diff --git a/matlab/particle/DsgeLikelihood.m b/matlab/particle/DsgeLikelihood.m
deleted file mode 100644
index ff6f3264106e7f93ef77b4d3172a6781507aa8d7..0000000000000000000000000000000000000000
--- a/matlab/particle/DsgeLikelihood.m
+++ /dev/null
@@ -1,265 +0,0 @@
-function [fval,cost_flag,ys,trend_coeff,info] = DsgeLikelihood(xparam1,gend,data,data_index,number_of_observations,no_more_missing_observations)
-% function [fval,cost_flag,ys,trend_coeff,info] = DsgeLikelihood(xparam1,gend,data,data_index,number_of_observations,no_more_missing_observations)
-% Evaluates the posterior kernel of a dsge model.
-%
-% INPUTS
-% xparam1 [double] vector of model parameters.
-% gend [integer] scalar specifying the number of observations.
-% data [double] matrix of data
-% data_index [cell] cell of column vectors
-% number_of_observations [integer]
-% no_more_missing_observations [integer]
-% OUTPUTS
-% fval : value of the posterior kernel at xparam1.
-% cost_flag : zero if the function returns a penalty, one otherwise.
-% ys : steady state of original endogenous variables
-% trend_coeff :
-% info : vector of informations about the penalty:
-% 41: one (many) parameter(s) do(es) not satisfied the lower bound
-% 42: one (many) parameter(s) do(es) not satisfied the upper bound
-%
-% SPECIAL REQUIREMENTS
-%
-
-% Copyright (C) 2004-2009 Dynare Team
-%
-% This file is part of Dynare.
-%
-% Dynare is free software: you can redistribute it and/or modify
-% it under the terms of the GNU General Public License as published by
-% the Free Software Foundation, either version 3 of the License, or
-% (at your option) any later version.
-%
-% Dynare is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-
- global bayestopt_ estim_params_ options_ trend_coeff_ M_ oo_
- fval = [];
- ys = [];
- trend_coeff = [];
- cost_flag = 1;
- nobs = size(options_.varobs,1);
- %------------------------------------------------------------------------------
- % 1. Get the structural parameters & define penalties
- %------------------------------------------------------------------------------
- if options_.mode_compute ~= 1 & any(xparam1 < bayestopt_.lb)
- k = find(xparam1 < bayestopt_.lb);
- fval = bayestopt_.penalty+sum((bayestopt_.lb(k)-xparam1(k)).^2);
- cost_flag = 0;
- info = 41;
- return;
- end
- if options_.mode_compute ~= 1 & any(xparam1 > bayestopt_.ub)
- k = find(xparam1 > bayestopt_.ub);
- fval = bayestopt_.penalty+sum((xparam1(k)-bayestopt_.ub(k)).^2);
- cost_flag = 0;
- info = 42;
- return;
- end
- Q = M_.Sigma_e;
- H = M_.H;
- for i=1:estim_params_.nvx
- k =estim_params_.var_exo(i,1);
- Q(k,k) = xparam1(i)*xparam1(i);
- end
- offset = estim_params_.nvx;
- if estim_params_.nvn
- for i=1:estim_params_.nvn
- k = estim_params_.var_endo(i,1);
- H(k,k) = xparam1(i+offset)*xparam1(i+offset);
- end
- offset = offset+estim_params_.nvn;
- end
- if estim_params_.ncx
- for i=1:estim_params_.ncx
- k1 =estim_params_.corrx(i,1);
- k2 =estim_params_.corrx(i,2);
- Q(k1,k2) = xparam1(i+offset)*sqrt(Q(k1,k1)*Q(k2,k2));
- Q(k2,k1) = Q(k1,k2);
- end
- [CholQ,testQ] = chol(Q);
- if testQ %% The variance-covariance matrix of the structural innovations is not definite positive.
- %% We have to compute the eigenvalues of this matrix in order to build the penalty.
- a = diag(eig(Q));
- k = find(a < 0);
- if k > 0
- fval = bayestopt_.penalty+sum(-a(k));
- cost_flag = 0;
- info = 43;
- return
- end
- end
- offset = offset+estim_params_.ncx;
- end
- if estim_params_.ncn
- for i=1:estim_params_.ncn
- k1 = options_.lgyidx2varobs(estim_params_.corrn(i,1));
- k2 = options_.lgyidx2varobs(estim_params_.corrn(i,2));
- H(k1,k2) = xparam1(i+offset)*sqrt(H(k1,k1)*H(k2,k2));
- H(k2,k1) = H(k1,k2);
- end
- [CholH,testH] = chol(H);
- if testH
- a = diag(eig(H));
- k = find(a < 0);
- if k > 0
- fval = bayestopt_.penalty+sum(-a(k));
- cost_flag = 0;
- info = 44;
- return
- end
- end
- offset = offset+estim_params_.ncn;
- end
- if estim_params_.np > 0
- M_.params(estim_params_.param_vals(:,1)) = xparam1(offset+1:end);
- end
- M_.Sigma_e = Q;
- M_.H = H;
- %------------------------------------------------------------------------------
- % 2. call model setup & reduction program
- %------------------------------------------------------------------------------
- options_.order = 2;%%% 'cause we use a non linear filter here...
- [T,R,SteadyState,info] = dynare_resolve(bayestopt_.restrict_var_list,...
- bayestopt_.restrict_columns,...
- bayestopt_.restrict_aux);
- if info(1) == 1 || info(1) == 2 || info(1) == 5
- fval = bayestopt_.penalty+1;
- cost_flag = 0;
- return
- elseif info(1) == 3 || info(1) == 4 || info(1)==6 ||info(1) == 19 || info(1) == 20 || info(1) == 21
- fval = bayestopt_.penalty+info(2);
- cost_flag = 0;
- return
- end
- bayestopt_.mf = bayestopt_.mf1;
- if options_.noconstant
- constant = zeros(nobs,1);
- else
- if options_.loglinear
- constant = log(SteadyState(bayestopt_.mfys));
- else
- constant = SteadyState(bayestopt_.mfys);
- end
- end
- if bayestopt_.with_trend
- trend_coeff = zeros(nobs,1);
- t = options_.trend_coeffs;
- for i=1:length(t)
- if ~isempty(t{i})
- trend_coeff(i) = evalin('base',t{i});
- end
- end
- trend = repmat(constant,1,gend)+trend_coeff*[1:gend];
- else
- trend = repmat(constant,1,gend);
- end
- start = options_.presample+1;
- np = size(T,1);
- mf = bayestopt_.mf;
- no_missing_data_flag = (number_of_observations==gend*nobs);
- %------------------------------------------------------------------------------
- % 3. Initial condition of the Kalman filter
- %------------------------------------------------------------------------------
- kalman_algo = options_.kalman_algo;
- if options_.lik_init == 1 % Kalman filter
- if kalman_algo ~= 2
- kalman_algo = 1;
- end
- Pstar = lyapunov_symm(T,R*Q*R',options_.qz_criterium,options_.lyapunov_complex_threshold);
- Pinf = [];
- elseif options_.lik_init == 2 % Old Diffuse Kalman filter
- if kalman_algo ~= 2
- kalman_algo = 1;
- end
- Pstar = options_.Harvey_scale_factor*eye(np);
- Pinf = [];
- elseif options_.lik_init == 3 % Diffuse Kalman filter
- if kalman_algo ~= 4
- kalman_algo = 3;
- end
- [QT,ST] = schur(T);
- e1 = abs(ordeig(ST)) > 2-options_.qz_criterium;
- [QT,ST] = ordschur(QT,ST,e1);
- k = find(abs(ordeig(ST)) > 2-options_.qz_criterium);
- nk = length(k);
- nk1 = nk+1;
- Pinf = zeros(np,np);
- Pinf(1:nk,1:nk) = eye(nk);
- Pstar = zeros(np,np);
- B = QT'*R*Q*R'*QT;
- for i=np:-1:nk+2
- if ST(i,i-1) == 0
- if i == np
- c = zeros(np-nk,1);
- else
- c = ST(nk1:i,:)*(Pstar(:,i+1:end)*ST(i,i+1:end)')+...
- ST(i,i)*ST(nk1:i,i+1:end)*Pstar(i+1:end,i);
- end
- q = eye(i-nk)-ST(nk1:i,nk1:i)*ST(i,i);
- Pstar(nk1:i,i) = q\(B(nk1:i,i)+c);
- Pstar(i,nk1:i-1) = Pstar(nk1:i-1,i)';
- else
- if i == np
- c = zeros(np-nk,1);
- c1 = zeros(np-nk,1);
- else
- c = ST(nk1:i,:)*(Pstar(:,i+1:end)*ST(i,i+1:end)')+...
- ST(i,i)*ST(nk1:i,i+1:end)*Pstar(i+1:end,i)+...
- ST(i,i-1)*ST(nk1:i,i+1:end)*Pstar(i+1:end,i-1);
- c1 = ST(nk1:i,:)*(Pstar(:,i+1:end)*ST(i-1,i+1:end)')+...
- ST(i-1,i-1)*ST(nk1:i,i+1:end)*Pstar(i+1:end,i-1)+...
- ST(i-1,i)*ST(nk1:i,i+1:end)*Pstar(i+1:end,i);
- end
- q = [eye(i-nk)-ST(nk1:i,nk1:i)*ST(i,i) -ST(nk1:i,nk1:i)*ST(i,i-1);...
- -ST(nk1:i,nk1:i)*ST(i-1,i) eye(i-nk)-ST(nk1:i,nk1:i)*ST(i-1,i-1)];
- z = q\[B(nk1:i,i)+c;B(nk1:i,i-1)+c1];
- Pstar(nk1:i,i) = z(1:(i-nk));
- Pstar(nk1:i,i-1) = z(i-nk+1:end);
- Pstar(i,nk1:i-1) = Pstar(nk1:i-1,i)';
- Pstar(i-1,nk1:i-2) = Pstar(nk1:i-2,i-1)';
- i = i - 1;
- end
- end
- if i == nk+2
- c = ST(nk+1,:)*(Pstar(:,nk+2:end)*ST(nk1,nk+2:end)')+ST(nk1,nk1)*ST(nk1,nk+2:end)*Pstar(nk+2:end,nk1);
- Pstar(nk1,nk1)=(B(nk1,nk1)+c)/(1-ST(nk1,nk1)*ST(nk1,nk1));
- end
- Z = QT(mf,:);
- R1 = QT'*R;
- [QQ,RR,EE] = qr(Z*ST(:,1:nk),0);
- k = find(abs(diag([RR; zeros(nk-size(Z,1),size(RR,2))])) < 1e-8);
- if length(k) > 0
- k1 = EE(:,k);
- dd =ones(nk,1);
- dd(k1) = zeros(length(k1),1);
- Pinf(1:nk,1:nk) = diag(dd);
- end
- end
- if kalman_algo == 2
- end
- kalman_tol = options_.kalman_tol;
- riccati_tol = options_.riccati_tol;
- mf = bayestopt_.mf1;
- Y = data-trend;
- %------------------------------------------------------------------------------
- % 4. Likelihood evaluation
- %------------------------------------------------------------------------------
- rfm.state.dr = oo_.dr;
- rfm.state.Q = Q;
- rfm.measurement.H = H;
- number_of_particles = 10;
-
- LIK = monte_carlo_gaussian_particle_filter(rfm,Y,[],number_of_particles);
-
-
- % ------------------------------------------------------------------------------
- % Adds prior if necessary
- % ------------------------------------------------------------------------------
- lnprior = priordens(xparam1,bayestopt_.pshape,bayestopt_.p6,bayestopt_.p7,bayestopt_.p3,bayestopt_.p4);
- fval = (LIK-lnprior);
\ No newline at end of file
diff --git a/matlab/particle/local_state_space_iteration_2.m b/matlab/particle/local_state_space_iteration_2.m
deleted file mode 100644
index 89faa12d0345fd3dcfc494f78afcfaca137d45c3..0000000000000000000000000000000000000000
--- a/matlab/particle/local_state_space_iteration_2.m
+++ /dev/null
@@ -1,47 +0,0 @@
-function y = local_state_space_iteration_2(yhat,epsilon,ghx,ghu,constant,half_ghxx,half_ghuu,ghxu)
-% Given an initial condition (y) and an innovation (epsilon), this
-% routines computes the next value of the endogenous variables if the
-% model is approximated by an order two taylor expansion around the
-% deterministic steady state.
-%
-% INPUTS
-% yhat [double] n*1 vector, initial condition, where n is the number of state variables.
-% epsilon [double] q*1 vector, structural innovations.
-% ys [double] m*1 vector, steady state (the variables are ordered as in ghx) where m
-% is the number of elements in the union of the states and observed
-% variables.
-% ghx [double] m*n matrix, is a subset of dr.ghx we only consider the lines corresponding
-% to the states and the observed variables.
-% ghu [double] m*q matrix, is a subset of dr.ghu
-% constant [double] m*1 vector (steady state + second order correction).
-% half_ghxx [double] m*n² matrix, subset of .5*dr.ghxx.
-% half_ghuu [double] m*q² matrix, subset of .5*dr.ghuu.
-% ghxu [double] m*nq matrix, subset of dr.ghxu.
-%
-% OUTPUTS
-% y [double] stochastic simulations results
-%
-% SPECIAL REQUIREMENTS
-% none
-
-% Copyright (C) 2009 Dynare Team
-%
-% This file is part of Dynare.
-%
-% Dynare is free software: you can redistribute it and/or modify
-% it under the terms of the GNU General Public License as published by
-% the Free Software Foundation, either version 3 of the License, or
-% (at your option) any later version.
-%
-% Dynare is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-
- y = constant + ghx*yhat + ghu*epsilon ...
- + A_times_B_kronecker_C(half_ghxx,yhat) ...
- + A_times_B_kronecker_C(half_ghuu,epsilon) ...
- + A_times_B_kronecker_C(ghxu,yhat,epsilon);
\ No newline at end of file
diff --git a/matlab/particle/monte_carlo_SIS_particle_filter.m b/matlab/particle/monte_carlo_SIS_particle_filter.m
deleted file mode 100644
index e45ab40f600849996f3f01b3fecc7d6ee6b6c4a4..0000000000000000000000000000000000000000
--- a/matlab/particle/monte_carlo_SIS_particle_filter.m
+++ /dev/null
@@ -1,196 +0,0 @@
-function [LIK,lik] = monte_carlo_SIS_particle_filter(reduced_form_model,Y,start,number_of_particles)
-% hparam,y,nbchocetat,nbchocmesure,smol_prec,nb_part,g,m,choix
-% Evaluates the likelihood of a nonlinear model with a particle filter without systematic resampling.
-%
-% INPUTS
-% reduced_form_model [structure] Matlab's structure describing the reduced form model.
-% reduced_form_model.measurement.H [double] (pp x pp) variance matrix of measurement errors.
-% reduced_form_model.state.Q [double] (qq x qq) variance matrix of state errors.
-% reduced_form_model.state.dr [structure] output of resol.m.
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% mf [integer] pp*1 vector of indices.
-% number_of_particles [integer] scalar.
-%
-% OUTPUTS
-% LIK [double] scalar, likelihood
-% lik [double] vector, density of observations in each period.
-%
-% REFERENCES
-%
-% NOTES
-% The vector "lik" is used to evaluate the jacobian of the likelihood.
-
-% Copyright (C) 2009 Dynare Team
-%
-% This file is part of Dynare.
-%
-% Dynare is free software: you can redistribute it and/or modify
-% it under the terms of the GNU General Public License as published by
-% the Free Software Foundation, either version 3 of the License, or
-% (at your option) any later version.
-%
-% Dynare is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-
-global M_ bayestopt_
-persistent init_flag
-persistent restrict_variables_idx observed_variables_idx state_variables_idx mf0 mf1
-persistent sample_size number_of_state_variables number_of_observed_variables number_of_structural_innovations
-
-% Set defaults.
-if (nargin<4) || (nargin==4 && isempty(number_of_particles))
- number_of_particles = 10 ;
-end
-if nargin==2 || isempty(start)
- start = 1;
-end
-
-dr = reduced_form_model.state.dr;% Decision rules and transition equations.
-Q = reduced_form_model.state.Q;% Covariance matrix of the structural innovations.
-H = reduced_form_model.measurement.H;% Covariance matrix of the measurement errors.
-
-% Set persistent variables.
-if isempty(init_flag)
- mf0 = bayestopt_.mf0;
- mf1 = bayestopt_.mf1;
- restrict_variables_idx = bayestopt_.restrict_var_list;
- observed_variables_idx = restrict_variables_idx(mf1);
- state_variables_idx = restrict_variables_idx(mf0);
- sample_size = size(Y,2);
- number_of_state_variables = length(mf0);
- number_of_observed_variables = length(mf1);
- number_of_structural_innovations = length(Q);
- init_flag = 1;
-end
-
-% Set local state space model (second order approximation).
-ghx = dr.ghx(restrict_variables_idx,:);
-ghu = dr.ghu(restrict_variables_idx,:);
-half_ghxx = .5*dr.ghxx(restrict_variables_idx,:);
-half_ghuu = .5*dr.ghuu(restrict_variables_idx,:);
-ghxu = dr.ghxu(restrict_variables_idx,:);
-steadystate = dr.ys(dr.order_var(restrict_variables_idx));
-constant = steadystate + .5*dr.ghs2(restrict_variables_idx);
-state_variables_steady_state = dr.ys(dr.order_var(state_variables_idx));
-
-StateVectorMean = state_variables_steady_state;
-StateVectorVariance = lyapunov_symm(ghx(mf0,:),ghu(mf0,:)*Q*ghu(mf0,:)',1e-12,1e-12);
-StateVectorVarianceSquareRoot = reduced_rank_cholesky(StateVectorVariance)';
-state_variance_rank = size(StateVectorVarianceSquareRoot,2);
-
-%state_idx = 1:state_variance_rank;
-%innovation_idx = 1+state_variance_rank:state_variance_rank+number_of_structural_innovations;
-
-Q_lower_triangular_cholesky = chol(Q)';
-
-% Set seed for randn().
-seed = [ 362436069 ; 521288629 ];
-randn('state',seed);
-
-const_lik = log(2*pi)*number_of_observed_variables;
-lik = NaN(sample_size,1);
-nb_obs_resamp = 0 ;
-w = ones(number_of_particles,1) ;
-for t=1:sample_size
- PredictedState = zeros(number_of_particles,number_of_state_variables);
- PredictionError = zeros(number_of_particles,number_of_observed_variables);
- %PredictedStateMean = zeros(number_of_state_variables,1);
- PredictedObservedMean = zeros(number_of_observed_variables,1);
- %PredictedStateVariance = zeros(number_of_state_variables,number_of_state_variables);
- PredictedObservedVariance = zeros(number_of_observed_variables,number_of_observed_variables);
- %PredictedStateAndObservedCovariance = zeros(number_of_state_variables,number_of_observed_variables);
- for i=1:number_of_particles
- if t==1
- StateVector = StateVectorMean + StateVectorVarianceSquareRoot*randn(state_variance_rank,1);
- else
- StateVector = StateUpdated(i,:)' ;
- end
- yhat = StateVector-state_variables_steady_state;
- epsilon = Q_lower_triangular_cholesky*randn(number_of_structural_innovations,1);
- tmp = local_state_space_iteration_2(yhat,epsilon,ghx,ghu,constant,half_ghxx,half_ghuu,ghxu);
- % stockage des particules et des erreurs de pr�visions
- PredictedState(i,:) = tmp(mf0)' ;
- PredictionError(i,:) = (Y(:,t) - tmp(mf1))' ;
- % calcul des moyennes et des matrices de variances covariances
- %PredictedStateMean_old = PredictedStateMean;
- PredictedObservedMean_old = PredictedObservedMean;
- %PredictedStateMean = PredictedStateMean + (tmp(mf0)-PredictedStateMean)/i;
- PredictedObservedMean = PredictedObservedMean + (tmp(mf1)-PredictedObservedMean)/i;
- %psm = PredictedStateMean*PredictedStateMean';
- pom = PredictedObservedMean*PredictedObservedMean';
- %pcm = PredictedStateMean*PredictedObservedMean';
- %PredictedStateVariance = PredictedStateVariance ...
- % + ( (tmp(mf0)*tmp(mf0)'-psm-PredictedStateVariance)+(i-1)*(PredictedStateMean_old*PredictedStateMean_old'-psm) )/i;
- PredictedObservedVariance = PredictedObservedVariance ...
- + ( (tmp(mf1)*tmp(mf1)'-pom-PredictedObservedVariance)+(i-1)*(PredictedObservedMean_old*PredictedObservedMean_old'-pom) )/i;
- %PredictedStateAndObservedCovariance = PredictedStateAndObservedCovariance ...
- % + ( (tmp(mf0)*tmp(mf1)'-pcm-PredictedStateAndObservedCovariance)+(i-1)*(PredictedStateMean_old*PredictedObservedMean_old'-pcm) )/i;
- end
- PredictedObservedVariance = PredictedObservedVariance + H;
- iPredictedObservedVariance = inv(PredictedObservedVariance);
- lnw = -0.5*(const_lik + log(det(PredictedObservedVariance)) + sum((PredictionError*iPredictedObservedVariance).*PredictionError,2)) ;
- %bidouille num�rique Schorfheide
- dfac = max(lnw);
- wtilde = w.*exp(lnw - dfac) ;
- % vraisemblance de l'observation
- lik(t) = log(mean(wtilde)) + dfac ;
- %clear (PredictionError) ;
- %clear (lnw) ;
- % calcul des poids
- w = wtilde/sum(wtilde) ;
- %clear (wtilde) ;
- %update
- Neff = 1/sum(w.*w) ;
- if Neff>number_of_particles %no resampling
- StateUpdated = PredictedState ;
- %clear (PredictedState) ;
- w = number_of_particles*w ;
- else %resampling
- nb_obs_resamp = nb_obs_resamp+1 ;
-
- %kill the smallest particles before resampling :! facultatif ?
- %to_kill = [w PredictedState] ;
- %to_kill = delif(to_kill,w<(1/number_of_particules)*1E-12);%%
- %[n,m] = size(to_kill) ;
- %w = to_kill(:,1) ;
- %PredictedState = to_kill(:,2:m) ;
- %clear (to_kill) ;
- %if number_of_particles neq n
- % 'Elimination de '; number_of_particles - n ; ' particules � l''observation ';t ;
- %end
- %fin de kill
- %remise � l'�chelle des poids sur les particules restantes
- %w = cumsum( w/sum(w) );
- %R��chantillonage syst�matique
- %rnduvec = ( (1:number_of_particles)-1+rand )/number_of_particles ;
- %selind = (number_of_particles - sum( w > rnduvec ) + 1)'; % probl�me de m�moire car w .> rnduvec' tr�s grande !
- %clear (rnduvec) ;
- %StateUpdated = PredictedState(selind,:) ;
- %clear (selind) ;
- % initialize
- selind = zeros(number_of_particles,1);
- % construct CDF
- c = cumsum(w);
- % draw a starting point
- rnduvec = ( (1:number_of_particles)-1+rand)/number_of_particles ;
- % start at the bottom of the CDF
- j=1;
- for i=1:number_of_particles
- % move along the CDF
- while (rnduvec(i)>c(j))
- j=j+1;
- end
- % assign index
- selind(i) = j;
- end
- StateUpdated = PredictedState(selind,:);
- w = ones(number_of_particles,1) ;
- end
-end
-LIK = -sum(lik(start:end));
\ No newline at end of file
diff --git a/matlab/particle/monte_carlo_gaussian_particle_filter.m b/matlab/particle/monte_carlo_gaussian_particle_filter.m
deleted file mode 100644
index 774d45a275f1e02117519d78f5e7acaa23c0931b..0000000000000000000000000000000000000000
--- a/matlab/particle/monte_carlo_gaussian_particle_filter.m
+++ /dev/null
@@ -1,133 +0,0 @@
-function [LIK,lik] = monte_carlo_gaussian_particle_filter(reduced_form_model,Y,start,number_of_particles)
-% hparam,y,nbchocetat,nbchocmesure,smol_prec,nb_part,g,m,choix
-% Evaluates the likelihood of a non linear model assuming that the particles are normally distributed.
-%
-% INPUTS
-% reduced_form_model [structure] Matlab's structure desvcribing the reduced form model.
-% reduced_form_model.measurement.H [double] (pp x pp) variance matrix of measurement errors.
-% reduced_form_model.state.Q [double] (qq x qq) variance matrix of state errors.
-% reduced_form_model.state.dr [structure] output of resol.m.
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% mf [integer] pp*1 vector of indices.
-% number_of_particles [integer] scalar.
-% grid_size [integer] scalar, size of the smoliak grid.
-%
-% OUTPUTS
-% LIK [double] scalar, likelihood
-% lik [double] vector, density of observations in each period.
-%
-% REFERENCES
-%
-% NOTES
-% The vector "lik" is used to evaluate the jacobian of the likelihood.
-
-% Copyright (C) 2009 Dynare Team
-%
-% This file is part of Dynare.
-%
-% Dynare is free software: you can redistribute it and/or modify
-% it under the terms of the GNU General Public License as published by
-% the Free Software Foundation, either version 3 of the License, or
-% (at your option) any later version.
-%
-% Dynare is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-
-global M_ bayestopt_ oo_
-persistent init_flag
-persistent restrict_variables_idx observed_variables_idx state_variables_idx mf0 mf1
-persistent sample_size number_of_state_variables number_of_observed_variables number_of_structural_innovations
-
-% Set defaults.
-if (nargin<4) || (nargin==4 && isempty(number_of_particles))
- number_of_particles = 1000 ;
-end
-if nargin==2 || isempty(start)
- start = 1;
-end
-
-dr = reduced_form_model.state.dr;% Decision rules and transition equations.
-Q = reduced_form_model.state.Q;% Covariance matrix of the structural innovations.
-H = reduced_form_model.measurement.H;% Covariance matrix of the measurement errors.
-
-% Set persistent variables.
-if isempty(init_flag)
- mf0 = bayestopt_.mf0;
- mf1 = bayestopt_.mf1;
- restrict_variables_idx = bayestopt_.restrict_var_list;
- observed_variables_idx = restrict_variables_idx(mf1);
- state_variables_idx = restrict_variables_idx(mf0);
- sample_size = size(Y,2);
- number_of_state_variables = length(mf0);
- number_of_observed_variables = length(mf1);
- number_of_structural_innovations = length(Q);
- init_flag = 1;
-end
-
-% Set local state space model (second order approximation).
-ghx = dr.ghx(restrict_variables_idx,:);
-ghu = dr.ghu(restrict_variables_idx,:);
-half_ghxx = .5*dr.ghxx(restrict_variables_idx,:);
-half_ghuu = .5*dr.ghuu(restrict_variables_idx,:);
-ghxu = dr.ghxu(restrict_variables_idx,:);
-steadystate = dr.ys(dr.order_var(restrict_variables_idx));
-constant = steadystate + .5*dr.ghs2(restrict_variables_idx);
-state_variables_steady_state = dr.ys(dr.order_var(state_variables_idx));
-
-StateVectorMean = state_variables_steady_state;
-StateVectorVariance = lyapunov_symm(ghx(mf0,:),ghu(mf0,:)*Q*ghu(mf0,:)',1e-12,1e-12);
-StateVectorVarianceSquareRoot = reduced_rank_cholesky(StateVectorVariance)';
-state_variance_rank = size(StateVectorVarianceSquareRoot,2);
-
-Q_lower_triangular_cholesky = chol(Q)';
-
-% Set seed for randn().
-seed = [ 362436069 ; 521288629 ];
-randn('state',seed);
-
-const_lik = log(2*pi)*number_of_observed_variables;
-lik = NaN(sample_size,1);
-
-for t=1:sample_size
- PredictedStateMean = zeros(number_of_state_variables,1);
- PredictedObservedMean = zeros(number_of_observed_variables,1);
- PredictedStateVariance = zeros(number_of_state_variables);
- PredictedObservedVariance = zeros(number_of_observed_variables);
- PredictedStateAndObservedCovariance = zeros(number_of_state_variables,number_of_observed_variables);
- for i=1:number_of_particles
- StateVector = StateVectorMean + StateVectorVarianceSquareRoot*randn(state_variance_rank,1);
- yhat = StateVector-state_variables_steady_state;
- epsilon = Q_lower_triangular_cholesky*randn(number_of_structural_innovations,1);
- tmp = local_state_space_iteration_2(yhat,epsilon,ghx,ghu,constant,half_ghxx,half_ghuu,ghxu);
- PredictedStateMean_old = PredictedStateMean;
- PredictedObservedMean_old = PredictedObservedMean;
- PredictedStateMean = PredictedStateMean + (tmp(mf0)-PredictedStateMean)/i;
- PredictedObservedMean = PredictedObservedMean + (tmp(mf1)-PredictedObservedMean)/i;
- psm = PredictedStateMean*PredictedStateMean';
- pom = PredictedObservedMean*PredictedObservedMean';
- pcm = PredictedStateMean*PredictedObservedMean';
- PredictedStateVariance = PredictedStateVariance ...
- + ( (tmp(mf0)*tmp(mf0)'-psm-PredictedStateVariance)+(i-1)*(PredictedStateMean_old*PredictedStateMean_old'-psm) )/i;
- PredictedObservedVariance = PredictedObservedVariance ...
- + ( (tmp(mf1)*tmp(mf1)'-pom-PredictedObservedVariance)+(i-1)*(PredictedObservedMean_old*PredictedObservedMean_old'-pom) )/i;
- PredictedStateAndObservedCovariance = PredictedStateAndObservedCovariance ...
- + ( (tmp(mf0)*tmp(mf1)'-pcm-PredictedStateAndObservedCovariance)+(i-1)*(PredictedStateMean_old*PredictedObservedMean_old'-pcm) )/i;
- end
- PredictedObservedVariance = PredictedObservedVariance + H;
- iPredictedObservedVariance = inv(PredictedObservedVariance);
- prediction_error = Y(:,t) - PredictedObservedMean;
- filter_gain = PredictedStateAndObservedCovariance*iPredictedObservedVariance;
- StateVectorMean = PredictedStateMean + filter_gain*prediction_error;
- StateVectorVariance = PredictedStateVariance - filter_gain*PredictedObservedVariance*filter_gain';
- StateVectorVarianceSquareRoot = reduced_rank_cholesky(StateVectorVariance)';
- state_variance_rank = size(StateVectorVarianceSquareRoot,2);
- lik(t) = -.5*(const_lik + log(det(PredictedObservedVariance)) + prediction_error'*iPredictedObservedVariance*prediction_error);
-end
-
-LIK = -sum(lik(start:end));
\ No newline at end of file
diff --git a/matlab/particle/reduced_rank_cholesky.m b/matlab/particle/reduced_rank_cholesky.m
deleted file mode 100644
index fac0d7e7213e9ed385a413fbe4c7042acf706ead..0000000000000000000000000000000000000000
--- a/matlab/particle/reduced_rank_cholesky.m
+++ /dev/null
@@ -1,50 +0,0 @@
-function T = reduced_rank_cholesky(X)
-% Computes the cholesky decomposition of a symetric semidefinite matrix or of a definite positive matrix.
-%
-% INPUTS:
-% X [double] n*n matrix to be factorized.
-%
-% OUTPUTS
-% T [double] q*n matrix such that T'*T = X, where q is the number of positive eigenvalues in X.
-%
-% NOTES:
-% If X is not positive definite, then X has to be a symetric semidefinite matrix.
-% The matrix T is upper triangular iff X is positive definite.
-
-% Copyright (C) 2009 Dynare Team
-%
-% This file is part of Dynare.
-%
-% Dynare is free software: you can redistribute it and/or modify
-% it under the terms of the GNU General Public License as published by
-% the Free Software Foundation, either version 3 of the License, or
-% (at your option) any later version.
-%
-% Dynare is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-
-
- [T,X_is_not_positive_definite] = chol(X);
-
- if X_is_not_positive_definite
- n = length(X);
- [U,D] = eig(.5*(X+X'));
- [tmp,max_elements_indices] = max(abs(U),[],1);
- negloc = (U(max_elements_indices+(0:n:(n-1)*n))<0);
- U(:,negloc) = -U(:,negloc);
- D = diag(D);
- tol = eps(max(D)) * length(D)*100;
- t = (abs(D) > tol);
- D = D(t);
- if ~(sum(D<0))
- T = diag(sqrt(D)) * U(:,t)';
- else
- disp('reduced_rank_cholesky:: Input matrix is not semidefinite positive!')
- T = NaN;
- end
- end
\ No newline at end of file
diff --git a/matlab/swz/c-code/Makefile b/matlab/swz/c-code/Makefile
deleted file mode 100644
index a0fb833f43bec806a481134fd5320e5fcfd71aac..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/Makefile
+++ /dev/null
@@ -1,226 +0,0 @@
-# -*- Makefile -*-
-# Generic makefile for IMSL, MKL, blas/lapack, and FORTRAN libraries
-# Generic makefile Tao's and Daniel's C routines
-# Generic makefile for various machines
-# All output is to OUT_DIR
-
-# MACHINE
-USE_MICHEL_LAPTOP=USE_MICHEL_LAPTOP
-
-
-# LIBRARIES
-USE_TAO = USE_TAO
-USE_MKL = USE_MKL
-#USE_IMSL = USE_IMSL
-USE_LAPACK = USE_LAPACK
-USE_FORTRAN = USE_FORTRAN
-USE_MATH = USE_MATH
-USE_GSL = USE_GLS
-#USE_GSL_CBLAS = USE_GSL_CBLAS
-
-
-WORK_DIR = .
-OUT_DIR = ../bin
-
-# MACHINE DEPENDENT DIRECTORIES
-
-# LAPTOP
-ifdef USE_LAPTOP
-WORK_DIR =/home/kalagman/Documents/InternshipJob/Dynare/
-OUT_DIR = /home/kalagman/Documents/InternshipJob/Dynare/work/
-
-CC = /usr/bin/gcc-4.3.2
-FC = gfortran
-CFLAGS = -g -static
-
-TAO_DIR = $(WORK_DIR)/utilities/TZCcode
-IMSL_BASE_DIR = /opt/vni/CTT6.0
-
-GSL_INCLUDE_DIR = /usr/include/gsl
-GSL_LIBS_DIR = /usr/lib
-
-MKL_BASE_DIR = /usr
-MKL_LIBS_DIR = $(MKL_BASE_DIR)/lib
-MKL_LIBS = -llapack -lblas
-
-NPSOL_DIR = /home/f1dfw14/data/npsol-5.0
-
-FORTRAN_LIBS = /usr/lib/gcc/i586-manbo-linux-gnu/4.3.2/libgfortran.a
-endif
-
-ifdef USE_MICHEL_LAPTOP
-
-#CC = gcc
-CC = /opt/intel/Compiler/11.0/074/bin/intel64/icc -no-multibyte-chars
-FC = gfortran
-CFLAGS = -g -static
-
-TAO_DIR = $(WORK_DIR)/utilities/TZCcode
-
-GSL_INCLUDE_DIR = /usr/include/gsl
-GSL_LIBS_DIR = /usr/lib
-
-INTEL_LIBS_DIR = /opt/intel/Compiler/11.0/074/lib/intel64
-INTEL_LIBS = -lguide
-MKL_BASE_DIR = /opt/intel/Compiler/11.0/074/mkl
-MKL_LIBS_DIR = $(MKL_BASE_DIR)/lib/em64t
-MKL_LIBS = -lmkl_lapack -lmkl_em64t
-endif
-
-
-#################################################################################
-VPATH =
-INCLUDE_DIR =
-LIBS_DIR =
-LIBS =
-OBJS =
-#################################################################################
-
-### TAO'S FILES #################################################################
-# TAO_DIR MUST be defined
-ifdef USE_TAO
- VPATH := $(VPATH) $(TAO_DIR)
- INCLUDE_DIR := $(INCLUDE_DIR) -I$(TAO_DIR)
-endif
-#################################################################################
-
-### GLS #########################################################################
-# GSL_LIBS_DIR and GSL_INCLUDE_DIR muste be defined
-ifdef USE_GSL
- INCLUDE_DIR := $(INCLUDE_DIR) -I$(GSL_INCLUDE_DIR)
- LIBS_DIR := $(LIBS_DIR) -L$(GSL_LIBS_DIR)
- LIBS := $(LIBS) -lgsl
-endif
-#################################################################################
-
-### GLS CBLAS ###################################################################
-# GSL_LIBS_DIR and GSL_INCLUDE_DIR muste be defined
-ifdef USE_GSL_CBLAS
- ifndef USE_GSL
- INCLUDE_DIR := $(INCLUDE_DIR) -I$(GSL_INCLUDE_DIR)
- LIBS_DIR := $(LIBS_DIR) -L$(GSL_LIBS_DIR)
- endif
- LIBS := $(LIBS) -lgslcblas
-endif
-#################################################################################
-
-### IMSL ########################################################################
-# IMSL_BASE_DIR must be defined
-ifdef USE_IMSL
- USE_PTHREAD = USE_PTHREAD
- IMSL_LIBS_DIR =$(IMSL_BASE_DIR)/lib/lib.linux_icc
- INCLUDE_DIR := $(INCLUDE_DIR) -I$(IMSL_BASE_DIR)/include
- LIBS_DIR := $(LIBS_DIR) -L$(IMSL_LIBS_DIR)
- LIBS := $(LIBS) $(IMSL_LIBS_DIR)/libimslcmath.a $(IMSL_LIBS_DIR)/libimslcstat.a
-endif
-#################################################################################
-
-### NPSOL #######################################################################
-ifdef USE_NPSOL
- NPSOL_LIBS = -lnpsol_f77 -llssol_f77
- LIBS_DIR := $(LIBS_DIR) -L$(NPSOL_DIR)
- LIBS := $(LIBS) $(NPSOL_LIBS)
-endif
-#################################################################################
-
-### MKL #########################################################################
-# MKL_BASE_DIR and MKL_LIBS must be defined
-ifdef USE_MKL
- USE_PTHREAD = USE_PTHREAD
- INCLUDE_DIR := $(INCLUDE_DIR) -I$(MKL_BASE_DIR)/include
- LIBS_DIR := $(LIBS_DIR) -Wl,-rpath=$(MKL_LIBS_DIR) -L$(MKL_LIBS_DIR) -L $(INTEL_LIBS_DIR)
- LIBS := $(LIBS) $(MKL_LIBS) $(INTEL_LIBS)
-endif
-#################################################################################
-
-### BLAS / LAPACK LIBRARIES #####################################################
-ifdef USE_LAPACK
- ifndef USE_MKL
- USE_FORTRAN = USE_FORTRAN
- ifdef LAPACK_LIBS_DIR
- LIBS_DIR := $(LIBS_DIR) -L$(LAPACK_LIBS_DIR)
- endif
- LIBS := $(LIBS) -llapack -lblas
- endif
-endif
-#################################################################################
-
-### FORTRAN #####################################################################
-# FORTRAN_LIBS should be defined
-ifdef USE_FORTRAN
- ifdef FORTRAN_LIBS_DIR
- LIBS_DIR := $(LIBS_DIR) -L$(FORTRAN_LIBS_DIR)
- endif
- LIBS := $(LIBS) $(FORTRAN_LIBS)
-endif
-#################################################################################
-
-### PTHREAD #####################################################################
-ifdef USE_PTHREAD
- LIBS := $(LIBS) -lpthread
-endif
-#################################################################################
-
-### MATH LIBRARY ################################################################
-ifdef USE_MATH
- LIBS := $(LIBS) -lm
-endif
-#################################################################################
-
-### DW FILES ####################################################################
-MATRIX_DIR = $(WORK_DIR)/utilities/DWCcode/matrix
-ERROR_DIR = $(WORK_DIR)/utilities/DWCcode/error
-ARRAY_DIR = $(WORK_DIR)/utilities/DWCcode/arrays
-ASCII_DIR = $(WORK_DIR)/utilities/DWCcode/ascii
-STAT_DIR = $(WORK_DIR)/utilities/DWCcode/stat
-SORT_DIR = $(WORK_DIR)/utilities/DWCcode/sort
-SWITCH_DIR = $(WORK_DIR)/sbvar/switching
-VAR_DIR = $(WORK_DIR)/sbvar/var
-#################################################################################
-
-# DW FILES
-INCLUDE_DIR := $(INCLUDE_DIR) -I$(MATRIX_DIR) -I$(ERROR_DIR) -I$(ARRAY_DIR) -I$(ASCII_DIR) -I$(STAT_DIR) -I$(SWITCH_DIR) -I$(VAR_DIR)
-VPATH := $(VPATH) $(MATRIX_DIR) $(ERROR_DIR) $(ARRAY_DIR) $(ASCII_DIR) $(STAT_DIR) $(SWITCH_DIR) $(VAR_DIR)
-OBJS := $(OBJS) bmatrix.o matrix.o dw_error.o dw_rand.o dw_matrix_rand.o dw_array.o dw_matrix_array.o dw_ascii.o dw_parse_cmd.o
-
-# TAO FILES
-OBJS := $(OBJS)
-
-# PROJECT FILE
-INCLUDE_DIR := $(INCLUDE_DIR)
-VPATH := $(VPATH)
-OBJS := $(OBJS) PrintDraws.o switch.o switchio.o VARbase.o VARio.o command_line_VAR.o
-
-#################################################################################
-# OUTPUT
-
-all: $(OUT_DIR)/sbvar_draws $(OUT_DIR)/sbvar_estimation $(OUT_DIR)/sbvar_init_file $(OUT_DIR)/sbvar_mhm_1 $(OUT_DIR)/sbvar_mhm_2 $(OUT_DIR)/sbvar_probabilities
-
-$(OUT_DIR)/sbvar_draws: $(OBJS)
- $(CC) $(CFLAGS) $^ $(LIBS_DIR) $(LIBS) -o $(OUT_DIR)/sbvar_draws
-
-$(OUT_DIR)/sbvar_estimation: $(OBJS)
- $(CC) $(CFLAGS) $^ $(LIBS_DIR) $(LIBS) -o $(OUT_DIR)/sbvar_estimation
-
-$(OUT_DIR)/sbvar_init_file: $(OBJS)
- $(CC) $(CFLAGS) $^ $(LIBS_DIR) $(LIBS) -o $(OUT_DIR)/sbvar_init_file
-
-$(OUT_DIR)/sbvar_mhm_1: $(OBJS)
- $(CC) $(CFLAGS) $^ $(LIBS_DIR) $(LIBS) -o $(OUT_DIR)/sbvar_mhm_1
-
-$(OUT_DIR)/sbvar_mhm_2: $(OBJS)
- $(CC) $(CFLAGS) $^ $(LIBS_DIR) $(LIBS) -o $(OUT_DIR)/sbvar_mhm_2
-
-$(OUT_DIR)/sbvar_probabilities: $(OBJS)
- $(CC) $(CFLAGS) $^ $(LIBS_DIR) $(LIBS) -o $(OUT_DIR)/sbvar_probabilities
-
-
-
-%.o : %.c
- $(CC) $(CFLAGS) $(INCLUDE_DIR) -c $< -o $@
-#
-#################################################################################
-clean:
- rm -f $(OUT_DIR)/*.o
-#
-#################################################################################
diff --git a/matlab/swz/c-code/sbvar/switching/MarkovStateVariable.dat b/matlab/swz/c-code/sbvar/switching/MarkovStateVariable.dat
deleted file mode 100644
index 3b0a143e13b68ee191621eb480e10909dc1d5e94..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/switching/MarkovStateVariable.dat
+++ /dev/null
@@ -1,117 +0,0 @@
-//== Flat Independent Markov States and Simple Restrictions ==//
-
-//-----------------------------------------------------------------------------//
-//-- Read by CreateMarkovStateVariable_File() only if the passed number of --//
-//-- observations is less than or equal to zero. Can be omitted if the --//
-//-- passed number of observations is positive. --//
-//-----------------------------------------------------------------------------//
-//== Number Observations ==//
-200
-
-//== Number Independent State Variables ==//
-2
-
-//-----------------------------------------------------------------------------//
-//-- state_variable[1] (1 <= i <= n_state_variables) --//
-//-----------------------------------------------------------------------------//
-//== Number of states for state_variable[1] ==//
-3
-
-//-----------------------------------------------------------------------------//
-//-- Each column contains the parameters for a Dirichlet prior on the --//
-//-- corresponding column of the transition matrix. Each element must be --//
-//-- positive. For each column, the relative size of the prior elements --//
-//-- determine the relative size of the elements of the transition matrix --//
-//-- and overall larger sizes implies a tighter prior. --//
-//-----------------------------------------------------------------------------//
-//== Transition matrix prior for state_variable[1]. (n_states x n_states) ==//
-10 1 1
- 1 10 1
- 1 1 10
-
-//-----------------------------------------------------------------------------//
-//-- An array of n_states integers with each entry between 1 and n_states, --//
-//-- inclusive. Determines the number of quasi-free Dirichlet dimensions --//
-//-- each column. Since the sum of the elements in a Dirichlet distribution --//
-//-- must equal to one, the actual number of free dimensions is one less. --//
-//-----------------------------------------------------------------------------//
-//== Free Dirichet dimensions for state_variable[1] ==//
-3 3 3
-
-//-----------------------------------------------------------------------------//
-//-- The jth restriction matrix is n_states x free[j]. Each row of the --//
-//-- restriction matrix has at most one non-zero entry and the sum of each --//
-//-- column of the restriction matrix must be one. If (x(1),...,x(free[j])) --//
-//-- is the Dirichlet random variable for column j, then the jth column of --//
-//-- the transition matrix Q is the jth restriction matrix times the --//
-//-- Dirichlet random random variable. --//
-//-----------------------------------------------------------------------------//
-//== Column restrictions for state_variable[1] ==//
-1 0 0
-0 1 0
-0 0 1
-
-1 0 0
-0 1 0
-0 0 1
-
-1 0 0
-0 1 0
-0 0 1
-
-
-//-----------------------------------------------------------------------------//
-//-- Allows for lagged values of the state variable to be encoded --//
-//-----------------------------------------------------------------------------//
-//== Number of lags encoded for state_variable[1] ==//
-2
-
-
-//-----------------------------------------------------------------------------//
-//-- state_variable[2] --//
-//-----------------------------------------------------------------------------//
-
-//== Number of states for state_variable[2] ==//
-2
-
-//-----------------------------------------------------------------------------//
-//-- Each column contains the parameters for a Dirichlet prior on the --//
-//-- corresponding column of the transition matrix. Each element must be --//
-//-- positive. For each column, the relative size of the prior elements --//
-//-- determine the relative size of the elements of the transition matrix --//
-//-- and overall larger sizes implies a tighter prior. --//
-//-----------------------------------------------------------------------------//
-//== Transition matrix prior for state_variable[2]. (n_states x n_states) ==//
- 5 1
- 1 5
-
-//-----------------------------------------------------------------------------//
-//-- An array of n_states integers with each entry between 1 and n_states, --//
-//-- inclusive. Determines the number of quasi-free Dirichlet dimensions --//
-//-- each column. Since the sum of the elements in a Dirichlet distribution --//
-//-- must equal to one, the actual number of free dimensions is one less. --//
-//-----------------------------------------------------------------------------//
-//== Free Dirichet dimensions for state_variable[2] ==//
-2 2
-
-//-----------------------------------------------------------------------------//
-//-- The jth restriction matrix is n_states x free[j]. Each row of the --//
-//-- restriction matrix has at most one non-zero entry and the sum of each --//
-//-- column of the restriction matrix must be one. If (x(1),...,x(free[j])) --//
-//-- is the Dirichlet random variable for column j, then the jth column of --//
-//-- the transition matrix Q is the jth restriction matrix times the --//
-//-- Dirichlet random random variable. --//
-//-----------------------------------------------------------------------------//
-//== Column restrictions for state_variable[2] ==//
-1 0
-0 1
-
-1 0
-0 1
-
-
-//-----------------------------------------------------------------------------//
-//-- Allows for lagged values of the state variable to be encoded --//
-//-----------------------------------------------------------------------------//
-//== Number of lags encoded for state_variable[2] ==//
-0
diff --git a/matlab/swz/c-code/sbvar/switching/switch.c b/matlab/swz/c-code/sbvar/switching/switch.c
deleted file mode 100644
index 457421b781f49344aeaeb70e22a979f6559bf80a..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/switching/switch.c
+++ /dev/null
@@ -1,3013 +0,0 @@
-
-#include "switch.h"
-#include "dw_array.h"
-#include "dw_matrix_array.h"
-#include "dw_error.h"
-#include "dw_rand.h"
-
-#include <math.h>
-#include <string.h>
-#include <stdlib.h>
-
-/*******************************************************************************/
-/**************************** TMarkovStateVariable *****************************/
-/*******************************************************************************/
-
-/********************** TMarkovStateVariable Destructors ***********************/
-/*
- Assumes:
- sv: valid pointer to TMarkovStateVariable structure or null pointer
-
- Results:
- Frees all memory allocated to sv.
-*/
-void FreeMarkovStateVariable(TMarkovStateVariable *sv)
-{
- int i;
- if (sv)
- {
- dw_FreeArray(sv->S);
-
- FreeMatrix(sv->Q);
-
- FreeVector(sv->B);
-
- //====== Non-standard memory managment ======
- if (sv->b)
- {
- for (i=dw_DimA(sv->b)-1; i >= 0; i--)
- if (sv->b[i]) pElementV(sv->b[i])=(PRECISION*)NULL;
- dw_FreeArray(sv->b);
- }
- //===========================================
-
- FreeMatrix(sv->Prior);
-
- FreeVector(sv->Prior_B);
-
- //====== Non-standard memory managment ======
- if (sv->Prior_b)
- {
- for (i=dw_DimA(sv->Prior_b)-1; i >= 0; i--)
- if (sv->Prior_b[i]) pElementV(sv->Prior_b[i])=(PRECISION*)NULL;
- dw_FreeArray(sv->Prior_b);
- }
- //===========================================
-
- dw_FreeArray(sv->FreeDim);
-
- dw_FreeArray(sv->NonZeroIndex);
-
- FreeMatrix(sv->MQ);
-
- if (sv->n_state_variables > 1)
- dw_FreeArray(sv->state_variable);
-
- dw_FreeArray(sv->Index);
-
- dw_FreeArray(sv->lag_index);
-
- if (sv->SA)
- {
- for (i=dw_DimA(sv->SA)-1; i >= 0; i--) sv->SA[i]=(int*)NULL;
- dw_FreeArray(sv->SA);
- }
-
- if (sv->QA)
- {
- for (i=dw_DimA(sv->QA)-1; i >= 0; i--) sv->QA[i]=(TMatrix)NULL;
- dw_FreeArray(sv->QA);
- }
-
- if (sv->ba)
- {
- for (i=dw_DimA(sv->ba)-1; i >= 0; i--) sv->ba[i]=(TVector)NULL;
- dw_FreeArray(sv->ba);
- }
-
- if (sv->Prior_ba)
- {
- for (i=dw_DimA(sv->Prior_ba)-1; i >= 0; i--) sv->Prior_ba[i]=(TVector)NULL;
- dw_FreeArray(sv->Prior_ba);
- }
-
- free(sv);
- }
-}
-/*******************************************************************************/
-
-/********************** TMarkovStateVariable Constructors **********************/
-/*
- Assumes
- nstates : positive integer
- nobs : positive integer
- Prior : nstates x nstates matrix
- FreeDim : integer array
- NonZeroIndex : nstates x nstates integer matrix
- MQ : nstates x nstates matrix
-
- Returns
- A valid pointer to a single TMarkovStateVariable structure.
-
- Notes
- This is the basic constructor for the TMarkovStateVariable structure. Upon
- error, this procedure terminates the program.
-*/
-TMarkovStateVariable* CreateMarkovStateVariable_Single(int nstates, int nobs, TMatrix Prior, int* FreeDim, int** NonZeroIndex, TMatrix MQ)
-{
- TMarkovStateVariable *sv;
- int i, j, k, q, total_free=0, terminal_errors;
-
- if (!CheckRestrictions(FreeDim,NonZeroIndex,MQ,nstates))
- {
- fprintf(stderr,"CreateMarkovStateVariable_Single(): Error in restrictions\n");
- exit(0);
- }
-
- if (!CheckPrior(Prior,nstates) || !CheckPriorOnFreeParameters(Prior,NonZeroIndex,nstates))
- {
- fprintf(stderr,"CreateMarkovStateVariable_Single(): Error in priors\n");
- exit(0);
- }
-
- //=== Compute total number of free transition matrix parameters
- for (k=dw_DimA(FreeDim)-1; k >= 0; k--) total_free+=FreeDim[k];
-
- if ((nstates <= 0) || (nobs <= 0))
- {
- fprintf(stderr,"CreateMarkovStateVariable(): improper argument values\n");
- exit(0);
- }
-
- if (!(sv=(TMarkovStateVariable*)malloc(sizeof(TMarkovStateVariable))))
- {
- fprintf(stderr,"CreateMarkovStateVariable(): out of memory\n");
- exit(0);
- }
-
- //=== Set flags ===
- sv->valid_transition_matrix=0;
-
- //=== Set to terminate on memory error ===
- terminal_errors=dw_SetTerminalErrors(MEM_ERR);
-
- //=== Sizes ===
- sv->nstates=nstates;
- sv->nobs=nobs;
-
- //== State vector ===
- dw_InitializeArray_int(sv->S=dw_CreateArray_int(nobs+1),0);
-
- //=== Number of lagged values of base state variable to encode ===
- sv->nlags_encoded=0;
- sv->nbasestates=nstates;
- sv->lag_index=CreateLagIndex(sv->nbasestates,sv->nlags_encoded,sv->nstates);
-
- //=== Transition matrix ===
- sv->Q=CreateMatrix(nstates,nstates);
-
- //=== Free transition matrix parameters ===
- sv->B=CreateVector(total_free);
-
- sv->b=dw_CreateArray_vector(dw_DimA(FreeDim));
- for (q=k=0; k < dw_DimA(FreeDim); k++)
- {
- sv->b[k]=CreateVector(FreeDim[k]);
- // seting up non-standard memory management
- free(pElementV(sv->b[k]));
- pElementV(sv->b[k])=pElementV(sv->B)+q;
- q+=FreeDim[k];
- }
-
- //=== Prior information ===
- sv->Prior=EquateMatrix((TMatrix)NULL,Prior);
-
- sv->Prior_B=CreateVector(total_free);
- InitializeVector(sv->Prior_B,1.0);
- for (j=nstates-1; j >= 0; j--)
- for (i=nstates-1; i >= 0; i--)
- if ((k=NonZeroIndex[i][j]) >= 0)
- ElementV(sv->Prior_B,k)+=ElementM(Prior,i,j)-1.0;
-
- sv->Prior_b=dw_CreateArray_vector(dw_DimA(FreeDim));
- for (q=k=0; k < dw_DimA(FreeDim); k++)
- {
- sv->Prior_b[k]=CreateVector(FreeDim[k]);
- // seting up non-standard memory management
- free(pElementV(sv->Prior_b[k]));
- pElementV(sv->Prior_b[k])=pElementV(sv->Prior_B)+q;
- q+=FreeDim[k];
- }
-
- //=== Restrictions ===
- sv->FreeDim=(int*)dw_CopyArray(NULL,FreeDim);
- sv->NonZeroIndex=(int**)dw_CopyArray(NULL,NonZeroIndex);
- sv->MQ=EquateMatrix((TMatrix)NULL,MQ);
-
- //=== Multiple state variables ===
- sv->parent=sv;
- sv->n_state_variables=1;
- sv->state_variable=(TMarkovStateVariable**)dw_CreateArray_array(1);
- sv->state_variable[0]=sv;
- sv->Index=(int**)dw_CreateArray_array(sv->nstates);
- sv->SA=(int**)dw_CreateArray_array(sv->n_state_variables);
- sv->QA=dw_CreateArray_matrix(sv->n_state_variables);
- sv->ba=dw_CreateArray_vector(dw_DimA(sv->b));
- for (k=dw_DimA(sv->ba)-1; k >= 0; k--) sv->ba[k]=sv->b[k];
- sv->Prior_ba=dw_CreateArray_vector(dw_DimA(sv->Prior_b));
- for (k=dw_DimA(sv->Prior_ba)-1; k >= 0; k--) sv->Prior_ba[k]=sv->Prior_b[k];
-
- //=== Initialize Index ===
- sv->Index[i=sv->nstates-1]=dw_CreateArray_int(sv->n_state_variables);
- for (k=sv->n_state_variables-1; k >= 0; k--)
- sv->Index[i][k]=sv->state_variable[k]->nstates-1;
- for (i--; i >= 0; i--)
- {
- sv->Index[i]=(int*)dw_CopyArray(NULL,sv->Index[i+1]);
- for (k=sv->n_state_variables-1; k >= 0; k--)
- if (--sv->Index[i][k] >= 0)
- break;
- else
- sv->Index[i][k]=sv->state_variable[k]->nstates-1;
- }
-
- //=== Initialize SA and QA ===
- for (k=sv->n_state_variables-1; k >= 0; k--)
- {
- sv->SA[k]=sv->state_variable[k]->S;
- sv->QA[k]=sv->state_variable[k]->Q;
- }
-
- //=== Control variables ===
- sv->UseErgodic=0;
-
- //=== Set Constants ===
- SetLogPriorConstant_SV(sv);
-
- //=== Set transition matrix to mean of prior ===
- SetTransitionMatrixToPriorMean_SV(sv);
-
- //=== Reset terminal errors ===
- dw_SetTerminalErrors(terminal_errors);
-
- return sv;
-}
-
-TMarkovStateVariable* CreateMarkovStateVariable_Multiple(int nobs, int n_state_variables, TMarkovStateVariable **state_variable)
-{
- int i, j, k, terminal_errors;
- TMarkovStateVariable *sv;
-
- if ((n_state_variables <= 1) || (nobs <= 0) || !state_variable || (dw_DimA(state_variable) != n_state_variables))
- {
- printf("CreateMarkovStateVariable_Multiple(): invalid arguments\n");
- exit(0);
- }
-
- if (!(sv=(TMarkovStateVariable*)malloc(sizeof(TMarkovStateVariable))))
- {
- printf("CreateMarkovStateVariable_Multiple(): out of memory\n");
- exit(0);
- }
-
- //=== Set to terminate on memory error ===
- terminal_errors=dw_SetTerminalErrors(MEM_ERR);
-
- //=== Flags ===
- sv->valid_transition_matrix=0;
-
- //=== Sizes ===
- for (sv->nstates=1, k=n_state_variables-1; k >= 0; k--) sv->nstates*=state_variable[k]->nstates;
- sv->nobs=nobs;
-
- //== State vector ===
- dw_InitializeArray_int(sv->S=dw_CreateArray_int(nobs+1),0);
-
- //=== Transition matrix ===
- sv->Q=CreateMatrix(sv->nstates,sv->nstates);
-
- //=== Free transition matrix parameters ===
- sv->B=(TVector)NULL;
- sv->b=(TVector*)NULL;
-
- //=== Number of lagged values of base state variable to encode ===
- sv->nlags_encoded=0;
- sv->nbasestates=sv->nstates;
- sv->lag_index=CreateLagIndex(sv->nbasestates,sv->nlags_encoded,sv->nstates);
-
- //=== Prior information ===
- sv->Prior=(TMatrix)NULL;
- sv->Prior_B=(TVector)NULL;
- sv->Prior_b=(TVector*)NULL;
-
- //=== Restrictions ===
- sv->FreeDim=(int*)NULL;
- sv->NonZeroIndex=(int**)NULL;
- sv->MQ=(TMatrix)NULL;
-
- //=== Multiple state variables ===
- sv->parent=sv;
- sv->n_state_variables=n_state_variables;
- sv->state_variable=state_variable;
- for (k=n_state_variables-1; k >= 0; k--) state_variable[k]->parent=sv;
-
- //=== Initialize Index ===
- sv->Index=(int**)dw_CreateArray_array(sv->nstates);
- sv->Index[i=sv->nstates-1]=dw_CreateArray_int(n_state_variables);
- for (k=n_state_variables-1; k >= 0; k--)
- sv->Index[i][k]=state_variable[k]->nstates-1;
- for (i--; i >= 0; i--)
- {
- sv->Index[i]=dw_CopyArray((int*)NULL,sv->Index[i+1]);
- for (k=n_state_variables-1; k >= 0; k--)
- if (--(sv->Index[i][k]) >= 0)
- break;
- else
- sv->Index[i][k]=state_variable[k]->nstates-1;
- }
-
- //=== Initialize SA and QA ===
- sv->SA=(int**)dw_CreateArray_array(n_state_variables);
- sv->QA=dw_CreateArray_matrix(n_state_variables);
- for (k=0; k < n_state_variables; k++)
- {
- sv->SA[k]=state_variable[k]->S;
- sv->QA[k]=state_variable[k]->Q;
- }
-
- //=== Initialize ba and Prior_ba ===
- for (i=k=0; k < n_state_variables; k++) i+=dw_DimA(state_variable[k]->ba);
- sv->ba=dw_CreateArray_vector(i);
- for (i=k=0; k < n_state_variables; k++)
- for (j=0; j < dw_DimA(state_variable[k]->ba); i++, j++)
- sv->ba[i]=state_variable[k]->ba[j];
-
- for (i=k=0; k < n_state_variables; k++) i+=dw_DimA(state_variable[k]->Prior_ba);
- sv->Prior_ba=dw_CreateArray_vector(i);
- for (i=k=0; k < n_state_variables; k++)
- for (j=0; j < dw_DimA(state_variable[k]->Prior_ba); i++, j++)
- sv->Prior_ba[i]=state_variable[k]->Prior_ba[j];
-
- //=== Control variables ===
- sv->UseErgodic=0;
-
- //=== Set Constants ===
- SetLogPriorConstant_SV(sv);
-
- //=== Set transition matrix to mean of prior ===
- SetTransitionMatrixToPriorMean_SV(sv);
-
- //=== Reset terminal errors ===
- dw_SetTerminalErrors(terminal_errors);
-
- return sv;
-}
-
-TMarkovStateVariable* CreateMarkovStateVariable_Mixture(int nstates, int nobs, TMatrix Prior)
-{
- int i, j;
- TMarkovStateVariable *sv;
- int* FreeDim;
- int** NonZeroIndex;
- TMatrix MQ;
- NonZeroIndex=dw_CreateRectangularArray_int(nstates,nstates);
- for (i=nstates-1; i >= 0; i--)
- for (j=nstates-1; j >= 0; j--)
- NonZeroIndex[i][j]=i;
- MQ=InitializeMatrix(CreateMatrix(nstates,nstates),1.0);
- FreeDim=dw_CreateArray_int(1);
- FreeDim[0]=nstates;
- sv=CreateMarkovStateVariable_Single(nstates,nobs,Prior,FreeDim,NonZeroIndex,MQ);
- dw_FreeArray(NonZeroIndex);
- FreeMatrix(MQ);
- dw_FreeArray(FreeDim);
- return sv;
-}
-
-TMarkovStateVariable* CreateMarkovStateVariable_NoRestrictions(int nstates, int nobs, TMatrix Prior)
-{
- int i, j;
- TMarkovStateVariable *sv;
- int* FreeDim;
- int** NonZeroIndex;
- TMatrix MQ;
- NonZeroIndex=dw_CreateRectangularArray_int(nstates,nstates);
- for (i=nstates-1; i >= 0; i--)
- for (j=nstates-1; j >= 0; j--)
- NonZeroIndex[i][j]=i+nstates*j;
- InitializeMatrix(MQ=CreateMatrix(nstates,nstates),1.0);
- FreeDim=dw_CreateArray_int(nstates);
- for (i=nstates-1; i >= 0; i--) FreeDim[i]=nstates;
- sv=CreateMarkovStateVariable_Single(nstates,nobs,Prior,FreeDim,NonZeroIndex,MQ);
- dw_FreeArray(NonZeroIndex);
- FreeMatrix(MQ);
- dw_FreeArray(FreeDim);
- return sv;
-}
-
-TMarkovStateVariable* CreateMarkovStateVariable_Exclusion(int nstates, int nobs, TMatrix Prior, TMatrix Exclusion)
-{
- int i, j, k, q;
- TMarkovStateVariable *sv;
- int* FreeDim;
- int** NonZeroIndex;
- TMatrix MQ;
- dw_InitializeArray_int(NonZeroIndex=dw_CreateRectangularArray_int(nstates,nstates),-1);
- MQ=InitializeMatrix(CreateMatrix(nstates,nstates),0.0);
- FreeDim=dw_CreateArray_int(nstates);
- for (k=j=0; j < nstates; j++)
- {
- for (q=i=0; i < nstates; i++)
- if (ElementM(Exclusion,i,j) > 0)
- {
- NonZeroIndex[i][j]=k++;
- ElementM(MQ,i,j)=1.0;
- q++;
- }
- FreeDim[j]=q;
- }
- sv=CreateMarkovStateVariable_Single(nstates,nobs,Prior,FreeDim,NonZeroIndex,MQ);
- dw_FreeArray(NonZeroIndex);
- FreeMatrix(MQ);
- dw_FreeArray(FreeDim);
- return sv;
-}
-
-TMarkovStateVariable* CreateMarkovStateVariable_SimpleRestrictions(int nstates, int nobs, TMatrix Prior, TMatrix* Restriction)
-{
- int i, j, k, q;
- TMarkovStateVariable *sv;
- int* FreeDim;
- int** NonZeroIndex;
- TMatrix MQ;
- dw_InitializeArray_int(NonZeroIndex=dw_CreateRectangularArray_int(nstates,nstates),-1);
- InitializeMatrix(MQ=CreateMatrix(nstates,nstates),0.0);
- FreeDim=dw_CreateArray_int(nstates);
- for (q=k=0; k < nstates; k++)
- {
- FreeDim[k]=ColM(Restriction[k]);
- for (i=0; i < nstates; i++)
- {
- for (j=0; j < ColM(Restriction[k]); j++)
- if (ElementM(Restriction[k],i,j) > 0)
- {
- NonZeroIndex[i][k]=q+j;
- ElementM(MQ,i,k)=ElementM(Restriction[k],i,j);
- break;
- }
- }
- q+=FreeDim[k];
- }
- sv=CreateMarkovStateVariable_Single(nstates,nobs,Prior,FreeDim,NonZeroIndex,MQ);
- dw_FreeArray(NonZeroIndex);
- FreeMatrix(MQ);
- dw_FreeArray(FreeDim);
- return sv;
-}
-
-TMarkovStateVariable* CreateMarkovStateVariable_ConstantState(int nobs)
-{
- TMarkovStateVariable *sv;
- int* FreeDim;
- int** NonZeroIndex;
- TMatrix MQ, Prior;
- dw_InitializeArray_int(NonZeroIndex=dw_CreateRectangularArray_int(1,1),0);
- InitializeMatrix(MQ=CreateMatrix(1,1),1.0);
- dw_InitializeArray_int(FreeDim=dw_CreateArray_int(1),1);
- InitializeMatrix(Prior=CreateMatrix(1,1),1.0);
- sv=CreateMarkovStateVariable_Single(1,nobs,Prior,FreeDim,NonZeroIndex,MQ);
- dw_FreeArray(NonZeroIndex);
- FreeMatrix(MQ);
- dw_FreeArray(FreeDim);
- FreeMatrix(Prior);
- return sv;
-}
-
-TMarkovStateVariable* DuplicateMarkovStateVariable(TMarkovStateVariable *sv)
-{
- TMarkovStateVariable **sv_array, *dup;
- int k;
- if (sv->n_state_variables > 1)
- {
- sv_array=dw_CreateArray_pointer(sv->n_state_variables,NULL);
- for (k=sv->n_state_variables-1; k >= 0; k--)
- sv_array[k]=DuplicateMarkovStateVariable(sv->state_variable[k]);
- dup=CreateMarkovStateVariable_Multiple(sv->nobs,sv->n_state_variables,sv_array);
- EquateMatrix(dup->Q,sv->Q);
- memcpy(dup->S,sv->S,(sv->nobs+1)*sizeof(int));
- dup->valid_transition_matrix=sv->valid_transition_matrix;
- }
- else
- {
- dup=CreateMarkovStateVariable_Single(sv->nstates,sv->nobs,sv->Prior,sv->FreeDim,sv->NonZeroIndex,sv->MQ);
- EquateMatrix(dup->Q,sv->Q);
- EquateVector(dup->B,sv->B);
- memcpy(dup->S,sv->S,(sv->nobs+1)*sizeof(int));
- dup->valid_transition_matrix=sv->valid_transition_matrix;
- }
- return dup;
-}
-
-/*
-
-*/
-TMarkovStateVariable* RestrictMarkovStateVariable(TMarkovStateVariable *sv, int nstates)
-{
- TMarkovStateVariable *rsv;
- int* free_translation;
- int** NonZeroIndex;
- int *FreeDim;
- TMatrix MQ, Prior;
- int i, j, k, m, n, q;
- PRECISION sum_in, sum_out, scale;
-
- if (nstates == 1) return CreateMarkovStateVariable_ConstantState(sv->nobs);
-
- if (nstates == sv->nstates) return DuplicateMarkovStateVariable(sv);
-
- free_translation=(int*)malloc(DimV(sv->B)*sizeof(int));
-
- // free_translation[i] = 1 if B[i] is accessed
- for (i=DimV(sv->B)-1; i >= 0; i--) free_translation[i]=0;
- for (i=nstates-1; i >= 0; i--)
- for (j=nstates-1; j >= 0; j--)
- if (sv->NonZeroIndex[i][j] >= 0)
- free_translation[sv->NonZeroIndex[i][j]]=1;
-
- // free_translation[i] will be index into new quasi-free Dirichlet vector B
- for (i=j=0; j < DimV(sv->B); j++)
- free_translation[j]=free_translation[j] ? i++ : -1;
-
- // Get number of new quasi-free variables
- for (k=m=n=0; k < dw_DimA(sv->FreeDim); k++)
- for (q=n, n+=sv->FreeDim[k]; q < n; q++)
- if (free_translation[q] != -1)
- {
- m++;
- break;
- }
- dw_InitializeArray_int(FreeDim=dw_CreateArray_int(m),0);
-
- // Compute size of new quasi-free variables
- for (k=m=n=0; k < dw_DimA(sv->FreeDim); k++)
- for (q=n, n+=sv->FreeDim[k]; q < n; q++)
- if (free_translation[q] != -1)
- {
- for (FreeDim[m]=1, q++; q < n; q++)
- if (free_translation[q] != -1) FreeDim[m]++;
- m++;
- break;
- }
-
- // Create new NonZeroIndex
- NonZeroIndex=dw_CreateRectangularArray_int(nstates,nstates);
- for (i=nstates-1; i >= 0; i--)
- for (j=nstates-1; j >= 0; j--)
- NonZeroIndex[i][j]=free_translation[sv->NonZeroIndex[i][j]];
-
- // Create new MQ
- InitializeMatrix(MQ=CreateMatrix(nstates,nstates),0.0);
- for (j=0; j < nstates; j++)
- for (q=DimV(sv->B)-1; q >= 0; q--)
- if (free_translation[q] != -1)
- {
- sum_in=sum_out=0.0;
- for (i=0; i < nstates; i++)
- if (sv->NonZeroIndex[i][j] == q) sum_in+=ElementM(sv->MQ,i,j);
- for ( ; i < sv->nstates; i++)
- if (sv->NonZeroIndex[i][j] == q) sum_out+=ElementM(sv->MQ,i,j);
- scale=(sum_in > 0) ? (sum_in + sum_out)/sum_in : 1.0;
- for (i=0; i < nstates; i++)
- if (sv->NonZeroIndex[i][j] == q) ElementM(MQ,i,j)=scale*ElementM(sv->MQ,i,j);
- }
-
- // Prior
- // The new prior is chosen so that Prior[i][j] = scale*sv->Prior[i][j] where
- // scale = 1 if sv->Prior[i][j] <= 1 and scale = (nstates-1)/(sv->nstates-1)
- // otherwise. This tends to keep the old and new prior mean roughly equal for
- // those elements with larger prior means and scales the prior mean equally
- // for those with smaller prior means. This ie exactly true if sv->Prior[i][j]
- // were equal to one for all j except one.
- Prior=CreateMatrix(nstates,nstates);
- for (i=nstates-1; i >= 0; i--)
- for (j=nstates-1; j >= 0; j--)
- ElementM(Prior,i,j)=(ElementM(sv->Prior,i,j) > 1) ? (nstates-1)*ElementM(sv->Prior,i,j)/(sv->nstates-1) : ElementM(sv->Prior,i,j);
-
- // Attempt to make new Markov state variable. MQ/NonZeroIndex may not be valid
- rsv=CreateMarkovStateVariable_Single(nstates,sv->nobs,Prior,FreeDim,NonZeroIndex,MQ);
-
- // Clean up
- FreeMatrix(Prior);
- FreeMatrix(MQ);
- dw_FreeArray(NonZeroIndex);
- dw_FreeArray(FreeDim);
- free(free_translation);
-
- return rsv;
-}
-
-/*
-
-*/
-TMatrix ConvertBaseTransitionMatrix(TMatrix Q, TMatrix bQ, int nlags_encoded)
-{
- int n, a, b, c, d, e, i, j, k, m;
- PRECISION p;
-
- if (nlags_encoded == 0)
- return EquateMatrix(Q,bQ);
-
- if (!bQ)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- n=RowM(bQ);
- if (n != ColM(bQ))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (a=n, i=nlags_encoded; i > 0; i--) a*=n;
- if (!Q)
- {
- if (!(Q=CreateMatrix(a,a)))
- return (TMatrix)NULL;
- }
- else
- if ((a != RowM(Q)) || (a != ColM(Q)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
-
- a/=n;
- b=a/n;
- InitializeMatrix(Q,0.0);
- for (j=0; j < n; j++)
- for (i=0; i < n; i++)
- for (p=ElementM(bQ,i,j), k=0; k < b; k++)
- for (c=b*j+k, d=i*a+c, e=n*c, m=0; m < n; m++)
- ElementM(Q,d,e+m)=p;
-
- return Q;
-}
-
-/*
-
-
-*/
-int** CreateLagIndex(int nbasestates, int nlags, int nstates)
-{
- int **lag_index;
- int j, k;
-
- lag_index=dw_CreateRectangularArray_int(nstates,nlags+1);
- for (j=nlags; j >= 0; j--) lag_index[0][j]=0;
- for (k=1; k < nstates; k++)
- {
- for (j=nlags; j >= 0; j--)
- if (lag_index[k-1][j] < nbasestates-1)
- {
- lag_index[k][j]=lag_index[k-1][j]+1;
- break;
- }
- else
- lag_index[k][j]=0;
- for (--j; j >= 0; j--) lag_index[k][j]=lag_index[k-1][j];
- }
-
- return lag_index;
-}
-
-/*
-
-*/
-TMarkovStateVariable* CreateMarkovStateVariable_Lags(int nlags, TMarkovStateVariable *base)
-{
- TMarkovStateVariable *sv;
- int** NonZeroIndex;
- TMatrix MQ;
- TMatrix Prior;
- int nstates, i, j, k, m, n, p, q;
- PRECISION scale;
-
- if (base->n_state_variables > 1)
- {
- fprintf(stderr,"CreateMarkovStateVariable_Lags(): multiple state variable for base.");
- exit(0);
- }
-
- if (nlags > 0)
- {
- nstates=base->nstates;
- for (i=nlags; i > 0; i--) nstates*=base->nstates;
- dw_InitializeArray_int(NonZeroIndex=dw_CreateRectangularArray_int(nstates,nstates),-1);
- InitializeMatrix(MQ=CreateMatrix(nstates,nstates),0.0);
- InitializeMatrix(Prior=CreateMatrix(nstates,nstates),1.0);
-
- for (m=base->nstates, n=1, i=nlags-1; i > 0; i--) n*=m;
- scale=pow(base->nstates,-nlags);
- for (p=i=0; i < base->nstates; i++)
- for (q=j=0; j < base->nstates; j++)
- for (k=0; k < n; p++, k++)
- for (m=0; m < base->nstates; q++, m++)
- {
- NonZeroIndex[p][q]=base->NonZeroIndex[i][j];
- ElementM(MQ,p,q)=ElementM(base->MQ,i,j);
- ElementM(Prior,p,q)=scale*(ElementM(base->Prior,i,j)-1.0)+1.0;
- }
-
- sv=CreateMarkovStateVariable_Single(nstates,base->nobs,Prior,base->FreeDim,NonZeroIndex,MQ);
-
- dw_FreeArray(sv->lag_index);
- sv->nlags_encoded=nlags;
- sv->nbasestates=base->nstates;
- sv->lag_index=CreateLagIndex(sv->nbasestates,sv->nlags_encoded,sv->nstates);
-
- dw_FreeArray(NonZeroIndex);
- FreeMatrix(MQ);
- FreeMatrix(Prior);
- }
- else
- sv=CreateMarkovStateVariable_Single(base->nstates,base->nobs,base->Prior,base->FreeDim,base->NonZeroIndex,base->MQ);
- return sv;
-}
-/*******************************************************************************/
-
-/**************** TMarkovStateVariable Data Extraction Routines ****************/
-/*
- Get the base transition matrix, which is the transition matrix with any
- encoded lags removed.
-*/
-TMatrix GetBaseTransitionMatrix_SV(TMatrix Q, TMarkovStateVariable *sv)
-{
- int i, j, k, n;
- TMatrix *A;
-
- if (!sv->valid_transition_matrix) return (TMatrix)NULL;
-
- if (sv->n_state_variables > 1)
- {
- A=dw_CreateArray_matrix(sv->n_state_variables);
- for (i=sv->n_state_variables-1; i >= 0; i--)
- A[i]=GetBaseTransitionMatrix_SV((TMatrix)NULL,sv->state_variable[i]);
- Q=MatrixTensor(Q,A);
- dw_FreeArray(A);
- return Q;
- }
- else
- if (sv->nlags_encoded > 0)
- {
- n=sv->nbasestates;
- for (k=1, i=sv->nlags_encoded-1; i > 0; i--) k=k*n;
- if (!Q)
- {
- if (!(Q=CreateMatrix(n,n)))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(Q) != n) || (ColM(Q) != n))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (i=n-1; i >= 0; i--)
- for (j=n-1; j >= 0; j--)
- ElementM(Q,i,j)=ElementM(sv->Q,(i*n+j)*k,j*n*k);
- return Q;
- }
- else
- return EquateMatrix(Q,sv->Q);
-}
-/*******************************************************************************/
-
-/***************** TMarkovStateVariable Normalization Routines *****************/
-void PropagateSwap_SV(TMarkovStateVariable *sv)
-{
- if (sv->parent != sv)
- {
- sv=sv->parent;
- sv->Q=MatrixTensor(sv->Q,sv->QA);
- PropagateSwap_SV(sv);
- }
-}
-
-void Swap_SV(TMarkovStateVariable *sv, int i, int j)
-{
- TMatrix Q, Y;
- TPermutation X;
- if (sv->n_state_variables > 1)
- {
- fprintf(stderr,"Swap(): Can only swap indices for terminal state variables.\n");
- exit(0);
- }
-
- if ((i < 0) || (j < 0) || (i >= sv->nbasestates) || (j >= sv->nbasestates))
- {
- fprintf(stderr,"Swap(): Indicies out of range.\n");
- exit(0);
- }
-
- X=TranspositionPermutation((TPermutation)NULL,i,j,sv->nbasestates);
- if (sv->nlags_encoded)
- {
- Q=GetBaseTransitionMatrix_SV((TMatrix)NULL,sv);
- Y=ProductMP((TMatrix)NULL,Q,X);
- TransposeProductPM(Q,X,Y);
- ConvertBaseTransitionMatrix(sv->Q,Q,sv->nlags_encoded);
- FreeMatrix(Q);
- }
- else
- {
- Y=ProductMP((TMatrix)NULL,sv->Q,X);
- TransposeProductPM(sv->Q,X,Y);
- }
- FreeMatrix(Y);
- FreePermutation(X);
- if (!Update_B_from_Q_SV(sv))
- {
- fprintf(stderr,"Swap(): Restrictions violated.\n");
- exit(0);
- }
- PropagateSwap_SV(sv);
-}
-
-/*******************************************************************************/
-
-/********************* TMarkovStateVariable Prior Routines *********************/
-void SetLogPriorConstant_SV(TMarkovStateVariable *sv)
-{
- PRECISION sum, x;
- int i, j;
- sv->LogPriorConstant=0.0;
- for (i=dw_DimA(sv->ba)-1; i >= 0; i--)
- {
- for (sum=0.0, j=DimV(sv->ba[i])-1; j >= 0; j--)
- {
- sum+=(x=ElementV(sv->Prior_ba[i],j));
- sv->LogPriorConstant-=dw_log_gamma(x);
- }
- sv->LogPriorConstant+=dw_log_gamma(sum);
- }
-}
-
-PRECISION LogPrior_SV(TMarkovStateVariable *sv)
-{
- PRECISION log_prior=sv->LogPriorConstant, y;
- int i, j;
- for (i=dw_DimA(sv->ba)-1; i >= 0; i--)
- for (j=DimV(sv->ba[i])-1; j >= 0; j--)
- if ((y=ElementV(sv->ba[i],j)) > 0.0)
- log_prior+=(ElementV(sv->Prior_ba[i],j)-1.0)*log(y);
- else
- if (ElementV(sv->Prior_ba[i],j) > 1.0)
- return MINUS_INFINITY;
- else
- if (ElementV(sv->Prior_ba[i],j) < 1.0)
- return PLUS_INFINITY;
- return log_prior;
-}
-/******************************************************************************/
-
-/********************** TMarkovStateVariables Simulation **********************/
-/*
- Assumes:
- sv is a pointer to a properly initialized TMarkovStateVariable and all
- state vectors have been computed.
-
- Results:
- Draws the transition matrix sv->P from the posterior distribution,
- conditional on sv->S and the parameters other than sv->P.
-*/
-void DrawTransitionMatrix_SV(TMarkovStateVariable *sv)
-{
- int i, j, k, t;
-
- if (sv->n_state_variables > 1)
- {
- for (k=sv->n_state_variables-1; k >= 0; k--)
- DrawTransitionMatrix_SV(sv->state_variable[k]);
- MatrixTensor(sv->Q,sv->QA);
-
- // Flags
- sv->valid_transition_matrix=1;
- }
- else
- {
- // Set Dirichlet parameters
- EquateVector(sv->B,sv->Prior_B);
- for (t=sv->nobs; t > 0; t--)
- if ((k=sv->NonZeroIndex[sv->S[t]][sv->S[t-1]]) >= 0)
- ElementV(sv->B,k)+=1.0;
-
- // Generate b[j]
- for (k=dw_DimA(sv->FreeDim)-1; k >= 0; k--)
- if (!DrawDirichletVector(sv->b[k],sv->b[k]))
- {
- fprintf(stderr,"Error drawing Dirichlet vector\n");
- exit(0);
- }
-
- // Compute Q
- for (j=sv->nstates-1; j >= 0; j--)
- for (i=sv->nstates-1; i >= 0; i--)
- ElementM(sv->Q,i,j)=((k=sv->NonZeroIndex[i][j]) >= 0) ? ElementM(sv->MQ,i,j)*ElementV(sv->B,k) : 0.0;
-
- // Flags
- sv->valid_transition_matrix=1;
- }
-}
-
-/*
- Assumes:
- sv is a pointer to a properly initialized TMarkovStateVariable.
-
- Results:
- Draws the transition matrix sv->P from the prior distribution.
-*/
-void DrawTransitionMatrixFromPrior_SV(TMarkovStateVariable *sv)
-{
- int i, j, k;
-
- if (sv->n_state_variables > 1)
- {
- for (k=sv->n_state_variables-1; k >= 0; k--)
- DrawTransitionMatrixFromPrior_SV(sv->state_variable[k]);
- MatrixTensor(sv->Q,sv->QA);
-
- // Flags
- sv->valid_transition_matrix=1;
- }
- else
- {
- // Set Dirichlet parameters
- EquateVector(sv->B,sv->Prior_B);
-
- // Generate b[j]
- for (j=dw_DimA(sv->FreeDim)-1; j >= 0; j--)
- if (!DrawDirichletVector(sv->b[j],sv->b[j]))
- {
- fprintf(stderr,"Error drawing Dirichlet vector\n");
- exit(0);
- }
-
- // Compute P
- for (j=sv->nstates-1; j >= 0; j--)
- for (i=sv->nstates-1; i >= 0; i--)
- ElementM(sv->Q,i,j)=((k=sv->NonZeroIndex[i][j]) >= 0) ? ElementM(sv->MQ,i,j)*ElementV(sv->B,k) : 0.0;
-
- // Flags
- sv->valid_transition_matrix=1;
- }
-}
-
-void SetTransitionMatrixToPriorMean_SV(TMarkovStateVariable *sv)
-{
- int i, j, k;
- PRECISION sum;
- if (sv->n_state_variables > 1)
- {
- for (k=sv->n_state_variables-1; k >= 0; k--)
- SetTransitionMatrixToPriorMean_SV(sv->state_variable[k]);
- MatrixTensor(sv->Q,sv->QA);
- sv->valid_transition_matrix=1;
- }
- else
- {
- for (j=dw_DimA(sv->Prior_b)-1; j >= 0; j--)
- {
- for (sum=ElementV(sv->Prior_b[j],0), i=DimV(sv->Prior_b[j])-1; i > 0; i--)
- sum+=ElementV(sv->Prior_b[j],i);
- for (i=DimV(sv->Prior_b[j])-1; i >= 0; i--)
- ElementV(sv->b[j],i)=ElementV(sv->Prior_b[j],i)/sum;
- }
- Update_Q_from_B_SV(sv);
- sv->valid_transition_matrix=1;
- }
-}
-
-/*
- Assumes:
- sv is a pointer to a properly initialized TMarkovStateVariable structure and
- the transition matrix has been.
-
- Results:
- Draws the vector of states S from the distribution defined by the transition
- matrix.
-
- Notes:
- If sv->Q was drawn from the prior distribution, then the vector of states
- can be considered as being drawing from the prior distribution.
-*/
-void DrawStatesFromTransitionMatrix_SV(TMarkovStateVariable *sv)
-{
- int i, j, t;
- PRECISION u, s;
-
- if (!sv->valid_transition_matrix)
- {
- printf("DrawStatesFromTransitionMatrix_SV(): Invalid transition matrix.\n");
- exit(0);
- }
-
- //=== Draw initial state from ergodic or uniform distribution ===
- if (sv->UseErgodic)
- {
- TVector v;
- if (!(v=Ergodic((TVector)NULL,sv->Q)))
- {
- printf("DrawStatesFromTransitionMatrix_SV(): Ergodic distribution does not exists.\n");
- exit(0);
- }
- if ((u=dw_uniform_rnd()) >= (s=ElementV(v,i=sv->nstates-1)))
- while (--i > 0)
- if (u < (s+=ElementV(v,i))) break;
- FreeVector(v);
- }
- else
- if ((i=(int)floor(dw_uniform_rnd()*sv->nstates)) >= sv->nstates) i=sv->nstates-1;
- sv->S[0]=j=i;
-
- //=== Draw subsequent states from transition matrix ===
- for (t=1; t <= sv->nobs; t++)
- {
- if ((u=dw_uniform_rnd()) >= (s=ElementM(sv->Q,i=sv->nstates-1,j)))
- while (--i > 0)
- if (u < (s+=ElementM(sv->Q,i,j))) break;
- sv->S[t]=j=i;
- }
-
- //====== Propagate states ======
- PropagateStates_SV(sv);
-}
-/******************************************************************************/
-
-/******************* TMarkovStateVariables Utility Routines *******************/
-/*
- Set sv->valid_transition_matrix to zero for all state variables in sv.
-*/
-void InvalidateTransitionMatrices_SV(TMarkovStateVariable *sv)
-{
- int k;
- if (sv->n_state_variables > 1)
- for (k=sv->n_state_variables-1; k >=0; k--)
- InvalidateTransitionMatrices_SV(sv->state_variable[k]);
- sv->valid_transition_matrix=0;
-}
-
-/*
- Set sv->valid_transition_matrix to one for all state variables in sv.
-*/
-void ValidateTransitionMatrices_SV(TMarkovStateVariable *sv)
-{
- int k;
- if (sv->n_state_variables > 1)
- for (k=sv->n_state_variables-1; k >=0; k--)
- ValidateTransitionMatrices_SV(sv->state_variable[k]);
- sv->valid_transition_matrix=1;
-}
-
-
-/*
- Distributes the vector of states throughout the tree of states variables
-*/
-void PropagateStates_SV(TMarkovStateVariable *sv)
-{
- int k, t;
- if (sv->n_state_variables > 1)
- {
- for (t=sv->nobs; t >= 0; t--)
- for (k=sv->n_state_variables-1; k >= 0; k--)
- sv->SA[k][t]=sv->Index[sv->S[t]][k];
- for (k=sv->n_state_variables-1; k >=0; k--)
- PropagateStates_SV(sv->state_variable[k]);
- }
-}
-
-/*
- If there are multiple state variables, computes the transition matrix as the
- tensor product of transition matrics. The single Markov state variables
- must have a valid transition matrix. Returns one upon success and zero upon
- failure. Failure occurs if a single Markov state variable does not have a
- valid transition matrix.
-*/
-int PropagateTransitionMatrices_SV(TMarkovStateVariable *sv)
-{
- int k;
- if (sv->n_state_variables > 1)
- {
- for (k=sv->n_state_variables-1; k >= 0; k--)
- if (!PropagateTransitionMatrices_SV(sv->state_variable[k]))
- return sv->valid_transition_matrix=0;
- sv->valid_transition_matrix=1;
- MatrixTensor(sv->Q,sv->QA);
- }
- return sv->valid_transition_matrix;
-}
-
-/*
- Assumes
- sv->Q has been updated and that sv->n_state_variables = 1.
-
- Returns
- One upon success and zero upon failure
-
- Results
- Updates sv->B (and hence sv->b and sv->ba) from sv->Q. Then sv->Q is
- updated from the computed sv->B.
-
- Notes
- If sv->n_state_variables != 1, then the routine returns zero.
-
- If any of the elements of sv->b[i] is negative or their sum differs from one
- by more than DimV(sv->b[i])*MACHINE_EPSILON, then the routine returns zero.
-
- If any element of the updated sv->Q differs from the original sv->Q by more
- than SQRT_MACHINE_EPSILON, then the routine returns zero.
-
- Because of the checking done, care should be taken in calling this routine
- in instances where efficiency is important.
-*/
-int Update_B_from_Q_SV(TMarkovStateVariable *sv)
-{
- int i, j, k;
- TVector scale;
- PRECISION x, sum;
- if (sv->n_state_variables > 1)
- return 0;
-
- // Compute B
- InitializeVector(scale=CreateVector(DimV(sv->B)),0.0);
- InitializeVector(sv->B,0.0);
- for (i=sv->nstates-1; i >= 0; i--)
- for (j=sv->nstates-1; j >= 0; j--)
- if ((k=sv->NonZeroIndex[i][j]) >= 0)
- {
- x=ElementM(sv->MQ,i,j);
- ElementV(sv->B,k)+=x*ElementM(sv->Q,i,j);
- ElementV(scale,k)+=x*x;
- }
- for (i=DimV(scale)-1; i >= 0; i--) ElementV(sv->B,i)/=ElementV(scale,i);
- FreeVector(scale);
-
- // Check computed B
- for (i=dw_DimA(sv->b)-1; i >= 0; i--)
- {
- for (sum=0.0, j=DimV(sv->b[i])-1; j >= 0; j--)
- if (ElementV(sv->b[i],j) < 0)
- return 0;
- else
- sum+=ElementV(sv->b[i],j);
- if (fabs(sum-1.0) > SQRT_MACHINE_EPSILON)
- return 0;
- }
-
- // Check computed Q
- for (i=sv->nstates-1; i >= 0; i--)
- for (j=sv->nstates-1; j >= 0; j--)
- {
- x=ElementM(sv->Q,i,j);
- if ((k=sv->NonZeroIndex[i][j]) >= 0)
- x-=ElementM(sv->MQ,i,j)*ElementV(sv->B,k);
- if (fabs(x) > SQRT_MACHINE_EPSILON)
- return 0;
- else
- ElementM(sv->Q,i,j)=(k >= 0) ? ElementM(sv->MQ,i,j)*ElementV(sv->B,k) : 0.0;
- }
-
- // Success
- return 1;
-}
-
-/*
- Assumes:
- sv->ba has been updated
-
- Results:
- Computes sv->Q
-
- Notes:
- Uses recursion to compute sv->Q
-*/
-void Update_Q_from_B_SV(TMarkovStateVariable *sv)
-{
- int i, j, k;
- if (sv->n_state_variables > 1)
- {
- for (k=sv->n_state_variables-1; k >= 0; k--) Update_Q_from_B_SV(sv->state_variable[k]);
- MatrixTensor(sv->Q,sv->QA);
- }
- else
- {
- for (j=sv->nstates-1; j >= 0; j--)
- for (i=sv->nstates-1; i >= 0; i--)
- ElementM(sv->Q,i,j)=((k=sv->NonZeroIndex[i][j]) >= 0) ? ElementM(sv->MQ,i,j)*ElementV(sv->B,k) : 0.0;
- }
-}
-
-/*
- Assumes:
- sv - valid pointer to TMarkovStateVariable structure.
-
- Returns:
- total number of states
-*/
-int TotalNumberStateVariables_SV(TMarkovStateVariable *sv)
-{
- int i, n;
- if (sv->n_state_variables == 1)
- return 1;
- else
- {
- for (n=0, i=sv->n_state_variables-1; i >= 0; i--)
- n+=TotalNumberStateVariables_SV(sv->state_variable[i]);
- return n;
- }
-}
-
-/******************************************************************************/
-/** Translation Arrays for Collections of Independent Markov State Variables **/
-/******************************************************************************/
-/*
- Counts the total number of states in the array of Markov state variables
-*
-static int NumberStates(TMarkovStateVariable** sv, int n)
-{
- int i, m=1;
- for (i=0; i < n; i++) m*=sv[i]->nstates;
- return m;
-}
-
-/*
- Assumes
- j: An integer with 0 <= j < dw_DimA(states)
- states: Rectangular array of integers
-*/
-int GetNumberStatesFromTranslationMatrix(int j, int **states)
-{
- int i, n=0;
- for (i=dw_DimA(states[j])-1; i >= 0; i--)
- if (states[j][i] > n) n=states[j][i];
- return n+1;
-}
-
-
-/*
- Attempts to find the Markov state variable sv in the chain of Markov variables
- given by top. If found, multiples the existing index by the number of states
- in sv and adds the appropriate index number.
-*/
-static int IncrementIndex(int idx, int i, TMarkovStateVariable *top, TMarkovStateVariable *sv)
-{
- int j, k;
- if (top == sv) return i + idx * sv->nstates;
- if (top->n_state_variables > 1)
- for (j=0; j < top->n_state_variables; j++)
- if ((k=IncrementIndex(idx,top->Index[i][j],top->state_variable[j],sv)) >= 0)
- return k;
- return -1;
-}
-
-/*
- Assumes:
- sv - Valid pointer to TMarkovStateVariable structure.
- list - Array of valid pointers of TMarkovStateVariable structures. Each
- structure in the array must be in the tree whose root is sv.
-
- Returns:
- Integer array of length sv->nstates.
-*/
-int* CreateStateIndex(TMarkovStateVariable* sv, TMarkovStateVariable** list, int n)
-{
- int i, j, k;
- int* index;
- if (!(index=dw_CreateArray_int(sv->nstates)))
- {
- fprintf(stdout,"CreateStateIndex(): Out of memory.\n");
- exit(0);
- }
- for (i=sv->nstates-1; i >= 0; i--)
- {
- for (k=j=0; j < n; j++)
- if ((k=IncrementIndex(k,i,sv,list[j])) == -1)
- {
- fprintf(stdout,"CreateStateIndex(): Unable to find required state variable.\n");
- exit(0);
- }
- index[i]=k;
- }
- return index;
-}
-
-/*
- Assumes:
- list :
-*/
-int **CreateTranslationMatrix(TMarkovStateVariable ***list, TMarkovStateVariable *sv)
-{
- int j, **states=(int**)dw_CreateArray_array(dw_DimA(list));
- for (j=dw_DimA(list)-1; j >= 0; j--)
- states[j]=CreateStateIndex(sv,list[j],list[j] ? dw_DimA(list[j]) : 0);
- return states;
-}
-
-/*
- Assumes
- states - An m x sv->n_state_variables array of integers. The integer
- states[j][k] will be non-zero of the kth state effects the jth
- group.
- sv - Valid pointer to TMarkovStateVariable structure. It must be the
- case that the number of columns in states is equal to
- sv->n_state_variables.
-
- Returns
- An m x nstates array of integers that is a translation from the values of
- the state variable sv to the state variable that is a product of the state
- variables with non-zero entries in states.
-*/
-int** CreateTranslationMatrix_Flat(int **states, TMarkovStateVariable *sv)
-{
- int **translation;
- int i, j, k;
- translation=dw_CreateRectangularArray_int(dw_DimA(states),sv->nstates);
-
- for (j=dw_DimA(states)-1; j >= 0; j--)
- for (i=sv->nstates-1; i >= 0; i--)
- for (translation[j][i]=k=0; k < sv->n_state_variables; k++)
- if (states[j][k])
- translation[j][i]=translation[j][i]*sv->state_variable[k]->nstates + sv->Index[i][k];
-
- return translation;
-}
-
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/******************************** ThetaRoutines ********************************/
-/*******************************************************************************/
-ThetaRoutines* CreateThetaRoutines_empty(void)
-{
- ThetaRoutines* pRoutines=(ThetaRoutines*)malloc(sizeof(ThetaRoutines));
-
- if (pRoutines)
- {
- pRoutines->pLogConditionalLikelihood=NULL;
- pRoutines->pExpectationSingleStep=NULL;
- pRoutines->pDestructor=NULL;
- pRoutines->pDrawParameters=NULL;
- pRoutines->pLogPrior=NULL;
- pRoutines->pNumberFreeParametersTheta=NULL;
- pRoutines->pConvertFreeParametersToTheta=NULL;
- pRoutines->pConvertThetaToFreeParameters=NULL;
- pRoutines->pStatesChanged=NULL;
- pRoutines->pThetaChanged=NULL;
- pRoutines->pTransitionMatrixChanged=NULL;
- pRoutines->pValidTheta=NULL;
- pRoutines->pInitializeForwardRecursion=NULL;
- pRoutines->pPermuteTheta=NULL;
- }
-
- return pRoutines;
-}
-/*******************************************************************************/
-/********************************* TStateModel *********************************/
-/*******************************************************************************/
-
-/*************************** TStateModel Destructors ***************************/
-/*
- Frees TStateModel
-*/
-void FreeStateModel(TStateModel *model)
-{
- if (model)
- {
- if (model->routines)
- {
- if (model->routines->pDestructor)
- model->routines->pDestructor(model->theta);
- free(model->routines);
- }
- FreeMarkovStateVariable(model->sv);
- dw_FreeArray(model->V);
- dw_FreeArray(model->Z);
- dw_FreeArray(model->states_count);
- free(model);
- }
-}
-/*******************************************************************************/
-
-/************************** TStateModel Constructors ***************************/
-/*
- Creates TStateModel structure. The structures sv, routines, and theta become the
- property of the the TStateModel structure. The structures sv and routines will
- be destroyed by the TStateModel destructor. If the pDestructor field of the
- routines structure has been set, then the structure theta will be destroyed by
- TStateModel destructor.
-*/
-TStateModel* CreateStateModel_new(TMarkovStateVariable *sv, ThetaRoutines *routines, void *theta)
-{
- int t;
- TStateModel *model;
-
- if (!(model=(TStateModel*)malloc(sizeof(TStateModel))))
- {
- fprintf(stderr,"CreateStateModel(): Out of memory\n");
- exit(0);
- }
-
- model->sv=sv;
- model->theta=theta;
- model->routines=routines;
-
- //=== Common work space ===
- model->Z=dw_CreateArray_vector(sv->nobs+1);
- model->V=dw_CreateArray_vector(sv->nobs+1);
- for (t=sv->nobs; t >= 0; t--)
- {
- model->Z[t]=CreateVector(sv->nstates);
- model->V[t]=CreateVector(sv->nstates);
- }
- InitializeVector(model->V[0],1.0/(PRECISION)(sv->nstates));
-
- model->n_degenerate_draws=0;
- model->states_count=dw_CreateArray_int(sv->nstates);
-
- //== Set control variables
- model->ValidForwardRecursion=0;
- model->UseLogFreeParametersQ=0;
-
- //=== Obsolete fields ===
- model->parameters=theta;
- model->p=(TParameters*)malloc(sizeof(TParameters));
- model->p->pLogConditionalLikelihood=model->routines->pLogConditionalLikelihood;
- model->p->pParameterDestructor=model->routines->pDestructor;
- model->p->pLogPrior=model->routines->pLogPrior;
- model->p->pNumberFreeParametersTheta=model->routines->pNumberFreeParametersTheta;
- model->p->pConvertFreeParametersToTheta=model->routines->pConvertFreeParametersToTheta;
- model->p->pConvertThetaToFreeParameters=model->routines->pConvertThetaToFreeParameters;
- model->p->pDrawParameters=model->routines->pDrawParameters;
- model->p->p=theta;
-
- //=== Set Transition matrix to prior mean ===
- SetTransitionMatrixToPriorMean(model);
-
- return model;
-}
-/*******************************************************************************/
-
-/************************** TStateModel Notifications **************************/
-void StatesChanged(TStateModel *model)
-{
- if (model->routines->pStatesChanged) model->routines->pStatesChanged(model);
-}
-
-void TransitionMatricesChanged(TStateModel *model)
-{
- model->ValidForwardRecursion=0;
-}
-
-void ThetaChanged(TStateModel *model)
-{
- model->ValidForwardRecursion=0;
- if (model->routines->pThetaChanged) model->routines->pThetaChanged(model);
-}
-/*******************************************************************************/
-
-/**************************** TStateModel Functions ****************************/
-/*
- Assumes:
- model is a pointer to a properly initialized TStateModel.
-
- Results:
- Computes the following:
-
- V[t][i] = P(s[t]=i | Y[t],Z[t],theta,Q) for 0 <= t <= T and 0 <= i < nstates
- Z[t][i] = P(s[t]=i | Y[t-1],Z[t-1],theta,Q) for 0 < t <= T and 0 <= i < nstates
- L[t] = Sum(ln(Sum(P(y[t] | z[t],theta,s[t])*P(s[t] | Y[t-1],Z[t-1],theta,Q),0 <= s[t] < nstates)),0 < t <= T)
-*/
-void ForwardRecursion(TStateModel *model)
-{
- int s, t;
- PRECISION scale, u;
- TMarkovStateVariable *sv=model->sv;
-
- //====== Initializes prior to forward recursion if necessary ======
- if (model->routines->pInitializeForwardRecursion)
- model->routines->pInitializeForwardRecursion(model);
-
- //====== Initialize L ======
- model->L=0;
-
- //====== Get ergodic distribution if necessary ======
- if (sv->UseErgodic)
- if (!Ergodic(model->V[0],sv->Q))
- {
- printf("ForwardRecursion(): Ergodic distribution does not exist.\n");
- exit(0);
- }
-
- //====== forward recursion ======
- for (t=1; t <= sv->nobs; t++)
- {
- //------ compute Z[t] ------
- ProductMV(model->Z[t],sv->Q,model->V[t-1]);
-
- //------ compute log conditional probabilities and scale ------
- scale=MINUS_INFINITY;
- for (s=sv->nstates-1; s >= 0; s--)
- {
- if (ElementV(model->Z[t],s) > 0.0)
- {
- u=LogConditionalLikelihood(s,t,model);
- scale=AddScaledLogs(1.0,scale,ElementV(model->Z[t],s),u);
- ElementV(model->V[t],s)=log(ElementV(model->Z[t],s)) + u;
- }
- else
- ElementV(model->V[t],s)=MINUS_INFINITY;
- }
-
- //------ update L ------
- model->L+=scale;
-
- //------ scale V[t] ------
- for (s=sv->nstates-1; s >= 0; s--)
- if (ElementV(model->V[t],s) != MINUS_INFINITY)
- ElementV(model->V[t],s)=exp(ElementV(model->V[t],s) - scale);
- else
- ElementV(model->V[t],s)=0.0;
- }
-
- model->ValidForwardRecursion=1;
-}
-
-/*
- Assumes:
- model is a pointer to a properly initialized TStateModel.
-
- Results:
- Draws the Markov state variables from the posterior distribution using
- backward recursion. The state variable values are stored in S.
-
- Notes:
- If model->ValidForwardRecursion is not set, calls ForwardRecusion().
-*/
-void DrawStates(TStateModel *model)
-{
- int i, j, t;
- PRECISION scale, u, s;
- TMarkovStateVariable *sv=model->sv;
- int *states_count=model->states_count;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- //====== Backward recursion ======
- if ((u=dw_uniform_rnd()) >= (s=ElementV(model->V[t=sv->nobs],i=sv->nstates-1)))
- while (--i > 0)
- if (u < (s+=ElementV(model->V[t],i))) break;
- states_count[sv->S[t]=i]++;
- for (t--; t >= 0; t--)
- {
- scale=1.0/ElementV(model->Z[t+1],j=i);
- i=sv->nstates-1;
- if ((u=dw_uniform_rnd()) >= (s=ElementV(model->V[t],i)*ElementM(sv->Q,j,i)*scale))
- while (--i > 0)
- if (u < (s+=ElementV(model->V[t],i)*ElementM(sv->Q,j,i)*scale)) break;
- states_count[sv->S[t]=i]++;
- }
-
-
- //====== Backward recursion ======
-/* for (iteration=10000; iteration > 0; iteration--) */
-/* { */
-/* for (i=sv->nstates-1; i >= 0; i--) states_count[i]=0; */
-
-/* if ((u=dw_uniform_rnd()) >= (s=ElementV(model->V[t=sv->nobs],i=sv->nstates-1))) */
-/* while (--i > 0) */
-/* if (u < (s+=ElementV(model->V[t],i))) break; */
-/* states_count[sv->S[t]=i]++; */
-/* for (t--; t >= 0; t--) */
-/* { */
-/* scale=1.0/ElementV(model->Z[t+1],j=i); */
-/* i=sv->nstates-1; */
-/* if ((u=dw_uniform_rnd()) >= (s=ElementV(model->V[t],i)*ElementM(sv->Q,j,i)*scale)) */
-/* while (--i > 0) */
-/* if (u < (s+=ElementV(model->V[t],i)*ElementM(sv->Q,j,i)*scale)) break; */
-/* states_count[sv->S[t]=i]++; */
-/* } */
-
-/* states_count[sv->S[0]]--; */
-/* for (i=sv->nstates-1; i >= 0; i--) */
-/* if (!states_count[i]) break; */
-/* if (i < 0) break; */
-/* model->n_degenerate_draws++; */
-/* } */
-
- //====== Propagate states ======
- PropagateStates_SV(model->sv);
-
- //====== State change notification ======
- StatesChanged(model);
-}
-
-/*
- Assumes:
- model is a pointer to a properly initialized TStateModel.
-
- Results:
- Draws the vector of states S from the distribution defined by the transition
- matrix.
-
- Notes:
- The data or the values of the parameters other than sv->P play no role in
- the distribution of the vector of states. If sv->P was drawn from the prior
- distribution, then the vector of states can be considered as being drawing
- from the prior distribution.
-*/
-void DrawStatesFromTransitionMatrix(TStateModel *model)
-{
- //====== Draw states ======
- DrawStatesFromTransitionMatrix_SV(model->sv);
-
- //====== State change notification ======
- StatesChanged(model);
-}
-
-/*
- Assumes:
- model: pointer to a properly initialized TStateModel structure
-
- Results:
- Draws the transition matrix from the posterior distribution, conditional on
- the states and theta.
-*/
-void DrawTransitionMatrix(TStateModel *model)
-{
- //== Draw transition matrix using recursive call ===
- DrawTransitionMatrix_SV(model->sv);
-
- //====== Transition Matrix Change change notification ======
- TransitionMatricesChanged(model);
-}
-
-/*
- Assumes:
- model: pointer to a properly initialized TStateModel structure
-
- Results:
- Draws the transition matrix sv->Q from the prior distribution.
-*/
-void DrawTransitionMatrixFromPrior(TStateModel *model)
-{
- //====== Draw transition matrix using recursive call ======
- DrawTransitionMatrixFromPrior_SV(model->sv);
-
- //====== Transition matrix change notification ======
- TransitionMatricesChanged(model);
-}
-
-void SetTransitionMatrixToPriorMean(TStateModel *model)
-{
- //====== Set transition matrix using recursive call ======
- SetTransitionMatrixToPriorMean_SV(model->sv);
-
- //====== Transition matrix change notification ======
- TransitionMatricesChanged(model);
-}
-
-void DrawTheta(TStateModel *model)
-{
- //====== Draw theta ======
- model->routines->pDrawParameters(model);
-
- //====== Theta change notification ======
- ThetaChanged(model);
-}
-
-void DrawAll(TStateModel *model)
-{
- DrawStates(model);
- DrawTransitionMatrix(model);
- DrawTheta(model);
-}
-
-/*******************************************************************************/
-/******************************* Normalization ********************************/
-/*******************************************************************************/
-int SetStateNormalizationMethod(int (*pGetNormalization)(int*, struct TStateModel_tag*),int (*pPermuteTheta)(int*, struct TStateModel_tag*),TStateModel *model)
-{
- if (pGetNormalization && pPermuteTheta)
- {
- model->NormalizeStates=1;
- model->routines->pGetNormalization=pGetNormalization;
- model->routines->pPermuteTheta=pPermuteTheta;
- }
- else
- {
- model->NormalizeStates=0;
- model->routines->pGetNormalization=NULL;
- model->routines->pPermuteTheta=NULL;
- }
- return 1;
-}
-
-/*
- Returns 1 if states successfully normalized and zero otherwise.
-*/
-int NormalizeStates(TStateModel *model)
-{
-/* int *p, rtrn=0; */
-
-/* if (!(model->NormalizeStates)) return 1; */
-
-/* if (p=(int*)malloc(model->sv->nstates)) */
-/* { */
-/* if (model->routines->pGetNormalization(p,model)) */
-/* if (Permute_SV(p,model->sv)) */
-/* if (model->routiens->pPermuteTheta(p,model)) */
-/* rtrn=1; */
-/* free(p); */
-/* } */
-
-/* return rtrn; */
- return 1;
-}
-
-
-/*******************************************************************************/
-/**************************** Compute Probabilities ****************************/
-/*******************************************************************************/
-
-/*
- Assumes:
- t : 1 <= t <= nobs
- model : pointer to valid TStateModel
-
- Returns:
- If valid transition matrix, returns the natural logrithm of
-
- P(y[t] | Y[t-1], Z[t], theta, Q).
-
- If the transition matrix is invalid, return minus infinity. Note that minus
- infinity is also a valid return value.
-
- Notes:
- If not ValidForwardRecursion, then calls ForwardRecursion(). The time
- parameter t is one based. Computation is based on the following:
-
- P(y[t] | Y[t-1], Z[t], theta, Q) =
- Sum(P(s[t]=s | Y[t-1], Z[t], theta, Q)
- * P(y[t] | Y[t-1], Z[t], theta, Q, s), 0 <= s < nstates)
-
- P(s[t]=s | Y[t-1], Z[t], theta, Q) = P(s[t]=s | Y[t-1], Z[t-1], theta, Q)
-*/
-PRECISION LogConditionalLikelihood_StatesIntegratedOut(int t, TStateModel *model)
-{
- int s;
- PRECISION x;
-
- //====== Check if transition matrix is valid ======
- if (!(model->sv->valid_transition_matrix)) return MINUS_INFINITY;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- x=LogConditionalLikelihood(0,t,model) + log(ProbabilityStateConditionalPrevious(0,t,model));
-
- for (s=model->sv->nstates-1; s > 0; s--)
- x=AddLogs(x,LogConditionalLikelihood(s,t,model) + log(ProbabilityStateConditionalPrevious(s,t,model)));
-
- return x;
-}
-
-/*
- Assumes:
- t : 1 <= t <= nobs
- model : pointer to valid TStateModel
-
- Returns:
- Returns
-
- E[y[t] | Y[t-1], Z[t], theta, Q]
-
- upon success and MINUS_INFINITY upon failure. Check
- model->ValidTransitionMatrix to determine if a failure has occured.
-
- Notes:
- If not ValidForwardRecursion, then calls ForwardRecursion(). The time
- parameter t is one based. Computation is based on the following:
-
- P(y[t] | Y[t-1], Z[t], theta, Q) =
- Sum(P(s[t]=s | Y[t-1], Z[t], theta, Q)
- * E(y[t] | Y[t-1], Z[t], theta, Q, s), 0 <= s < nstates)
-
- P(s[t]=s | Y[t-1], Z[t], theta, Q) = P(s[t]=s | Y[t-1], Z[t-1], theta, Q)
-*/
-TVector ExpectationSingleStep_StatesIntegratedOut(TVector y, int t, TStateModel *model)
-{
- int s;
- TVector y_tmp;
-
- //====== Check if transition matrix is valid ======
- if (!(model->sv->valid_transition_matrix)) (TVector)NULL;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- y=ExpectationSingleStep(y,0,t,model);
- ProductVS(y,y,ProbabilityStateConditionalPrevious(0,t,model));
-
- y_tmp=CreateVector(DimV(y));
- for (s=model->sv->nstates-1; s > 0; s--)
- {
- ExpectationSingleStep(y_tmp,s,t,model);
- ProductVS(y_tmp,y_tmp,ProbabilityStateConditionalPrevious(s,t,model));
- AddVV(y,y,y_tmp);
- }
-
- FreeVector (y_tmp);
-
- return y;
-}
-
-/*
- Assumes:
- s : 0 <= s < nstates
- t : 1 <= t <= nobs
- model : pointer to valid TStateModel
-
- Returns:
- Returns P(s[t] = s | Y[t], Z[t], theta, Q) if there is a valid transition
- matrix and -1 otherwise.
-
- Notes:
- If not ValidForwardRecursion, then calls ForwardRecursion(). The time
- parameter t is one based.
-*/
-PRECISION ProbabilityStateConditionalCurrent(int s, int t, TStateModel *model)
-{
- //====== Check if transition matrix is valid ======
- if (!(model->sv->valid_transition_matrix)) return -1.0;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- return ElementV(model->V[t],s);
-}
-
-/*
- Assumes:
- s : 0 <= s < nstates
- t : 1 <= t <= nobs
- model : pointer to valid TStateModel
-
- Returns:
-
- P(s[t] | Y[t-1], Z[t-1], theta, Q)
-
- Notes:
- If not ValidForwardRecursion, then calls ForwardRecursion(). The time
- parameter t is one based.
-*/
-PRECISION ProbabilityStateConditionalPrevious(int s, int t, TStateModel *model)
-{
- //====== Check if transition matrix is valid ======
- if (!(model->sv->valid_transition_matrix)) return -1.0;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- return ElementV(model->Z[t],s);
-}
-
-/*
- Assumes:
- S : vector of length at least nobs+1
- s : 0 <= s < nstates
- model : pointer to valid TStateModel
-
- Returns:
- Upon success, the vector P is returned and upon failure a null pointer is
- returned. If P is initially the null pointer, P is created.
-
- Results:
-
- P[t] = P(s[t] = s | Y[T], Z[T], theta, Q)
-
- for 0 <= t <= T.
-
- Notes:
- If not ValidForwardRecursion, then calls ForwardRecursion(). The time
- parameter t is one based. The computations use the following facts:
-
- P(s[t]=k | Y[T], Z[T], theta, Q)
- = Sum(P(s[t]=k, s[t+1]=i | Y[T], Z[T], theta, Q), 0 <= i < nstates)
-
- P(s[t]=k, s[t+1]=i | Y[T], Z[T], theta, Q)
- = P(s[t]=k | Y[T], Z[T], theta, Q, s[t+1]=i)
- * P(s[t+1]=i | Y[T], Z[T], theta, Q)
-
- P(s[t]=k | Y[t], Z[t], theta, Q, s[t+1]=i)
- = P(s[t]=k | Y[T], Z[T], theta, Q, s[t+1]=i)
-
- P(s[t]=k | Y[t], Z[t], theta, Q, s[t+1]=i) = Q[i][k]
- * P(s[t]=k | Y[t], Z[t], theta, Q) / P(s[t+1]=i | Y[t], Z[t], theta, Q)
-
- The third of these facts follows from
-
- P(s[t] | Y[t], Z[t], theta, Q, s[t+1])
- = P(s[t] | Y[T], Z[T], theta, Q, S(t+1,T))
-
- where S(t+1,T)={s[t+1],...,s[T]}. This is proven in the related paper.
-*/
-TVector ProbabilitiesState(TVector P, int s, TStateModel *model)
-{
- int nobs=model->sv->nobs, nstates=model->sv->nstates;
- int i, k, t;
- TVector p1, p2, p3;
-
- //====== Check if transition matrix is valid ======
- if (!(model->sv->valid_transition_matrix)) return (TVector)NULL;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- if (!P)
- P=CreateVector(nobs+1);
- else
- if (DimV(P) != nobs+1) return (TVector)NULL;
-
- p1=CreateVector(nstates);
- p2=CreateVector(nstates);
-
- // set p1 and the S[nobs]
- EquateVector(p1,model->V[nobs]);
- ElementV(P,nobs)=ElementV(p1,s);
-
- for (t=nobs-1; t >= 0; t--)
- {
- // s[t] = k and s[t+1] = i
- for (k=nstates-1; k >= 0; k--)
- {
- for (ElementV(p2,k)=0.0, i=nstates-1; i >= 0; i--)
- if (ElementV(model->Z[t+1],i) > 0.0)
- ElementV(p2,k)+=ElementV(p1,i)*ElementM(model->sv->Q,i,k)/ElementV(model->Z[t+1],i);
- ElementV(p2,k)*=ElementV(model->V[t],k);
- }
-
- // interchange p1 and p2
- p3=p1;
- p1=p2;
- p2=p3;
-
- ElementV(P,t)=ElementV(p1,s);
- }
-
- FreeVector(p1);
- FreeVector(p2);
-
- return P;
-}
-
-/*
- Assumes:
- S : integer array of length model->sv->nobs+1
- model : pointer to valid TStateModel
-
- Returns:
- If the transition matrix is valid, returns the natural logrithm of
- P(S[T] | Y[T], Z[T], theta, Q). If the transition matrix is invalid, return
- minus infinity. Note that minus infinity is also a valid return value.
-
- Notes:
- If not ValidForwardRecursion, then calls ForwardRecursion(). The time
- parameter t is one based. The computations use the following facts:
-
- P(S[T] | Y[T], Z[T], theta, Q)
- = Product(P(s[t] | Y[T], Z[T], theta, Q, S(t+1,T)),1 <= t <= T)
-
- P(s[t] | Y[t], Z[t], theta, Q, s[t+1])
- = P(s[t] | Y[T], Z[T], theta, Q, S(t+1,T))
-
- P(s[t] | Y[t], Z[t], theta, Q, s[t+1]) = Q[s(t+1)][s(t)]
- * P(s[t] | Y[t], Z[t], theta, Q) / P(s[t+1] | Y[t], Z[t], theta, Q)
-
- where S(t+1,T)={s[t+1],...,s[T]}. The second of these facts is proven in
- the related paper.
-*/
-PRECISION LogConditionalProbabilityStates(int *S, TStateModel *model)
-{
- PRECISION rtrn;
- TMarkovStateVariable *sv=model->sv;
- TMatrix Q=sv->Q;
- int t=sv->nobs;
-
- //====== Check if transition matrix is valid ======
- if (!(model->sv->valid_transition_matrix)) return MINUS_INFINITY;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- //====== Log probability ======
- rtrn=log(ElementV(model->V[t],S[t]));
- while (--t >= 0)
- if (ElementV(model->Z[t+1],S[t+1]) > 0.0)
- rtrn+=log(ElementM(Q,S[t+1],S[t])*ElementV(model->V[t],S[t])/ElementV(model->Z[t+1],S[t+1]));
- else
- return MINUS_INFINITY;
-
- //====== Probability ======
-/* rtrn=ElementV(model->V[t],S[t]); */
-/* while (--t >= 0) */
-/* rtrn*=ElementM(Q,S[t+1],S[t])*ElementV(model->V[t],S[t])/ElementV(model->Z[t+1],S[t+1]); */
-
- return rtrn;
-}
-
-/*
- Assumes
- model: pointer to valid TStateModel structure
-
- Returns
- The natural logrithm of
-
- P(S[T] | Theta, Q)
-*/
-PRECISION LogConditionalPrior_S(TStateModel *model)
-{
- int t, *S=model->sv->S;
- TMatrix Q=model->sv->Q;
- PRECISION p=-log(model->sv->nstates);
- for (t=model->sv->nobs; t > 0; t--)
- p+=log(ElementM(Q,S[t],S[t-1]));
- return p;
-}
-
-/*
- Assumes:
- model : pointer to valid TStateModel structure
-
- Returns:
- The natural logrithm of
-
- P(Y[T] | Z[T], Theta, Q, S[T])
-
-*/
-PRECISION LogLikelihood(TStateModel *model)
-{
- TMarkovStateVariable *sv=model->sv;
- int t, *S=sv->S;
- PRECISION loglikelihood=0.0;
- for (t=sv->nobs; t > 0; t--)
- loglikelihood+=LogConditionalLikelihood(S[t],t,model);
- return loglikelihood;
-}
-
-/*
- Assumes:
- model : pointer to valid TStateModel structure
-
- Returns:
- If the transition matrix is valid, returns the natural logrithm of
-
- P(Y[T] | Z[t], theta, Q).
-
- If the transition matrix is invalid, then minus infinity is returned. Note
- that minus infinity is also a valid return value.
-
- Notes:
- If not ValidForwardRecursion, then calls ForwardRecursion().
-*/
-PRECISION LogLikelihood_StatesIntegratedOut(TStateModel *model)
-{
- //====== Check if transition matrix is valid ======
- if (!(model->sv->valid_transition_matrix)) return MINUS_INFINITY;
-
- //====== Check if ForwardRecursion() has been called ======
- if (!model->ValidForwardRecursion) ForwardRecursion(model);
-
- return model->L;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-
-
-/*******************************************************************************/
-/************************** Free parameters routines ***************************/
-/*******************************************************************************/
-/*
- Returns the number of free parameters in sv->Q. Each column of Q is a linear
- combination of random vectors with Dirichlet distributions. A n-dimensional
- random vector with the Dirichlet distributions only has n-1 degrees of
- freedom.
-*/
-int NumberFreeParametersQ(TStateModel *model)
-{
- int i, n=0;
- TVector* ba=model->sv->ba;
- for (i=dw_DimA(ba)-1; i >= 0; i--) n+=DimV(ba[i]);
- return n - dw_DimA(ba);
-}
-
-/*
- Assumes
- model: valid pointer to a TStateModel structure.
- f: array of PRECISION of length at least NumberFreeParametersQ(sv).
-
- Results
- Copies the free parameters of Q into the array f.
-
- Notes
- If model->ValidTransitionMatrix is not set, then routine prints error
- message and exits.
-*/
-void ConvertQToFreeParameters(TStateModel *model, PRECISION *f)
-{
- int i, k;
- TVector* ba=model->sv->ba;
- if (!(model->sv->valid_transition_matrix))
- {
- fprintf(stderr,"ConvertQToFreeParameters(): Transition matrices not valid.\n");
- exit(0);
- }
- for (i=0; i < dw_DimA(ba); f+=k, i++)
- memcpy(f,pElementV(ba[i]),(k=DimV(ba[i])-1)*sizeof(PRECISION));
-}
-
-/*
- Assumes
- sv : valid pointer to a TMarkovStateVariable structure.
- f: array of PRECISION of length at least NumberFreeParametersQ(sv). The
- elements of f must be non-negative an 0 and 1 inclusive.
-
- Results
- Converts the array of free parameters into the matrix Q.
-
- Notes
- The routine TransitionMatricesChanged() is called. If any of the elements
- of f are negative or if one minus their sum is less than the number of
- states times machine epsilon, then model->sv->valid_transition_matrix is
- set to zero.
-*/
-void ConvertFreeParametersToQ(TStateModel *model, PRECISION *f)
-{
- int i, j, k;
- PRECISION scale;
- TVector* ba=model->sv->ba;
- for (i=0; i < dw_DimA(ba); f+=k, i++)
- {
- memcpy(pElementV(ba[i]),f,(k=DimV(ba[i])-1)*sizeof(PRECISION));
- for (scale=1.0, j=k-1; j >= 0; j--)
- if (f[j] < 0)
- {
- InvalidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
- return;
- }
- else
- scale-=f[j];
- if (scale < 0)
- if (scale < -DimV(ba[i])*MACHINE_EPSILON)
- {
- InvalidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
- return;
- }
- else
- ElementV(ba[i],k)=0.0;
- else
- ElementV(ba[i],k)=scale;
- }
- Update_Q_from_B_SV(model->sv);
- if (!(model->sv->valid_transition_matrix)) ValidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
-}
-
-/*
- Assumes:
- sv : valid pointer to a TMarkovStateVariable structure.
- f : array of PRECISION of length at least NumberFreeParametersQ(model).
-
- Results:
- Copies the free parameters of Q into the array f.
-
- Notes:
- The natural logrithms of free parameters of Q are stored in f.
-*/
-void ConvertQToLogFreeParameters(TStateModel *model, PRECISION *f)
-{
- int i, j, k;
- TVector* ba=model->sv->ba;
-
- if (!(model->sv->valid_transition_matrix))
- {
- fprintf(stderr,"ConvertQToFreeParameters(): Transition matrices not valid.\n");
- exit(0);
- }
-
- for (i=0; i < dw_DimA(ba); f+=k, i++)
- for (j=(k=DimV(ba[i])-1)-1; j >= 0; j--)
- f[j]=(ElementV(ba[i],j) > 0) ? log(ElementV(ba[i],j)) : MINUS_INFINITY;
-}
-
-/*
- Assumes:
- model : valid pointer to a TStateModel structure.
- f : array of PRECISION of length at least NumberFreeParametersQ(model). The
- elements of f must non-positive and the sum of the natural exponential
- of the elements must the less than or equal to 1.
-
- Results:
- Converts the array of free parameters into the matrix Q.
-*/
-void ConvertLogFreeParametersToQ(TStateModel *model, PRECISION *f)
-{
- int i, j, k;
- PRECISION scale;
- TVector* ba=model->sv->ba;
- for (i=0; i < dw_DimA(ba); f+=k, i++)
- {
- for (scale=1.0, j=(k=DimV(ba[i])-1)-1; j >= 0; j--)
- if (f[j] > 0)
- {
- InvalidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
- return;
- }
- else
- scale-=(ElementV(ba[i],j)=exp(f[j]));
- if (scale < 0)
- {
- InvalidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
- return;
- }
- ElementV(ba[i],k)=scale;
- }
- Update_Q_from_B_SV(model->sv);
- if (!(model->sv->valid_transition_matrix)) ValidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
-}
-
-void ConvertFreeParametersToTheta(TStateModel *model, PRECISION *f)
-{
- model->routines->pConvertFreeParametersToTheta(model,f);
- ThetaChanged(model);
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/****************************** Utility Routines *******************************/
-/*******************************************************************************/
-/*
- Checks that FreeDim, NonZeroIndex, and MQ satisfies the appropriate
- conditions. Returns 1 if the conditions are satisfied and 0 otherwise.
-*/
-int CheckRestrictions(int* FreeDim, int** NonZeroIndex, TMatrix MQ, int nstates)
-{
- int i, j, k, q, r, total_free;
- PRECISION sum, common_sum, total_sum;
-
- //====== Check for null pointer and sizes ======
- if (!FreeDim || !MQ || (RowM(MQ) != nstates) || (ColM(MQ) != nstates))
- return 0;
- if (!NonZeroIndex || (dw_DimA(NonZeroIndex) != nstates))
- return 0;
- else
- for (i=nstates-1; i >= 0; i--)
- if (dw_DimA(NonZeroIndex[i]) != nstates) return 0;
-
- // Checks FreeDim[i] > 0
- // Computes total_free = FreeDim[0] + ... + FreeDim[dw_DimA(FreeDim)-1]
- for (total_free=0, i=dw_DimA(FreeDim)-1; i >= 0; i--)
- if (FreeDim[i] <= 0)
- return 0;
- else
- total_free+=FreeDim[i];
-
- // Checks -1 <= NonZeroIndex[i][j] < total_free.
- // Checks NonZeroIndex[i][j] >= 0, ==> MQ[i][j] > 0.
- // Checks NonZeroIndex[i][j] = -1, ==> MQ[i][j] = 0.
- for (j=0; j < nstates; j++)
- for (i=0; i < nstates; i++)
- if ((NonZeroIndex[i][j] < -1) || (total_free <= NonZeroIndex[i][j]))
- return 0;
- else
- if (NonZeroIndex[i][j] >= 0)
- {
- if (ElementM(MQ,i,j) <= 0.0) return 0;
- }
- else
- {
- if (ElementM(MQ,i,j) != 0.0) return 0;
- }
-
- //====== Check that column sums are correct ======
- for (j=0; j < nstates; j++)
- {
- total_sum=0.0;
- for (q=r=k=0; k < total_free; k++)
- if (k == q)
- {
- common_sum=0.0;
- for (i=0; i < nstates; i++)
- if (NonZeroIndex[i][j] == k)
- common_sum+=ElementM(MQ,i,j);
- q+=FreeDim[r++];
- total_sum+=common_sum;
- }
- else
- {
- sum=0.0;
- for (i=0; i < nstates; i++)
- if (NonZeroIndex[i][j] == k)
- sum+=ElementM(MQ,i,j);
- if (fabs(sum - common_sum) > SQRT_MACHINE_EPSILON) return 0;
- }
- if (fabs(total_sum - 1.0) > SQRT_MACHINE_EPSILON) return 0;
- }
-
- return 1;
-}
-
-/*
- Checks that the Prior matrix is of the correct size and that all its elements
- are positive.
-*/
-int CheckPrior(TMatrix Prior, int nstates)
-{
- int i, j;
- if (!Prior || (RowM(Prior) != nstates) || (ColM(Prior) != nstates)) return 0;
- for (i=0; i < nstates; i++)
- for (j=0; j < nstates; j++)
- if (ElementM(Prior,i,j) <= 0) return 0;
- return 1;
-}
-
-/*
- Checks that both Prior and NonZeroIndex are of the correct size and that Prior
- elements are large enough.
-*/
-int CheckPriorOnFreeParameters(TMatrix Prior, int** NonZeroIndex, int nstates)
-{
- int i, j, q=0;
- PRECISION alpha;
-
- // non-null pointers and matrices of correct size
- if (!Prior || (RowM(Prior) != nstates) || (ColM(Prior) != nstates))
- return 0;
- if (!NonZeroIndex || (dw_DimA(NonZeroIndex) != nstates))
- return 0;
- else
- for (i=nstates-1; i >= 0; i--)
- if (dw_DimA(NonZeroIndex[i]) != nstates) return 0;
- for (j=0; j < nstates; j++)
- for (i=0; i < nstates; i++)
- if (q < NonZeroIndex[i][j]) q=NonZeroIndex[i][j];
- for ( ; q >= 0; q--)
- {
- alpha=1.0;
- for (j=0; j < nstates; j++)
- for (i=0; i < nstates; i++)
- if (NonZeroIndex[i][j] == q)
- alpha+=ElementM(Prior,i,j)-1.0;
- if (alpha <= 0) return 0;
- }
- return 1;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/****************************** Utility Routines *******************************/
-/*******************************************************************************/
-/*
- Assumes:
- v : An n vector or null pointer
- P : An n x n transition matrix. It must be the case that P(i,j) >= 0 for
- every i and j and P(0,j) + ... + P(n-1,j) = 1 for every j.
-
- Results:
- Computes the ergodic distribution of the transition matrix P if it exists.
- The ergodic distribution will exist if there is a unique vector v such that
- the elements of v are non-negative, sum to one and (P - I)v = 0.
-
- Notes:
- If w is the n dimensional row vector of ones, then w(P - I) = 0. This
- implies that there exists a non-zero v such that (P - I)v = 0. It is easy
- to show that if (P - I)v = 0 and v1 is the positive component of v and v2 is
- the negative component of v, then both (P - I)v1 = 0 and (P - I)v2 = 0. So
- there is always exists a v such that the elements of v are non-negative, sum
- to one, (P - I)v = 0. However, a unique such element might not exist.
-
- This routine does not check for uniqueness.
-
- This version uses the LU decomposition, which is fast and fairly stable.
-*/
-TVector Ergodic(TVector v, TMatrix P)
-{
- TVector rtrn;
- TMatrix IP;
- TPermutation S;
- PRECISION sum;
- int i, j, k;
-
- if (!P)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (RowM(P) != ColM(P))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!v)
- {
- if (!(rtrn=CreateVector(RowM(P))))
- return (TVector)NULL;
- }
- else
- if (RowM(P) != DimV(v))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- else
- rtrn=v;
-
- IP=EquateMatrix((TMatrix)NULL,P);
- for (i=RowM(P)-1; i >= 0; i--)
- ElementM(IP,i,i)-=1.0;
- S=CreatePermutation(RowM(P));
-
- if (LU(S,IP,IP))
- {
- for (k=0; k < RowM(P); k++)
- if (fabs(ElementM(IP,k,k)) < SQRT_MACHINE_EPSILON) break;
-
- if (k < RowM(P))
- {
- for (i=DimV(rtrn)-1; i > k; i--)
- ElementV(rtrn,i)=0.0;
- ElementV(rtrn,i--)=1.0;
- for ( ; i >= 0; i--)
- {
- for (sum=-ElementM(IP,i,k), j=k-1; j > i; j--) sum-=ElementM(IP,i,j)*ElementV(rtrn,j);
- ElementV(rtrn,i)=sum/ElementM(IP,i,i);
- }
-
- for (sum=1.0, i=k-1; i >= 0; i--)
- if (ElementV(rtrn,i) < 0.0)
- ElementV(rtrn,i)=0.0;
- else
- sum+=ElementV(rtrn,i);
-
- ProductSV(rtrn,1.0/sum,rtrn);
- FreePermutation(S);
- FreeMatrix(IP);
- return rtrn;
- }
- }
-
- FreePermutation(S);
- FreeMatrix(IP);
-
- if (!v) FreeVector(rtrn);
- return (TVector) NULL;
-}
-
-/*
- Assumes:
- v : An n vector or null pointer
- P : An n x n transition matrix. It must be the case that P(i,j) >= 0 for
- every i and j and P(0,j) + ... + P(n-1,j) = 1 for every j.
-
- Results:
- Computes the ergodic distribution of the transition matrix P if it exists.
- The ergodic distribution will exist if there is a unique vector v such that
- the elements of v are non-negative, sum to one and (P - I)v = 0.
-
- Notes:
- If w is the n dimensional row vector of ones, then w(P - I) = 0. This
- implies that there exists a non-zero v such that (P - I)v = 0. It is easy
- to show that if (P - I)v = 0 and v1 is the positive component of v and v2 is
- the negative component of v, then both (P - I)v1 = 0 and (P - I)v2 = 0. So
- there is always exists a v such that the elements of v are non-negative, sum
- to one, (P - I)v = 0. However, a unique such element might not exist.
-
- This version use the SVD and checks for uniqueness.
-*/
-TVector Ergodic_SVD(TVector v, TMatrix P)
-{
- TVector rtrn;
- TMatrix IP, U, V;
- PRECISION sum;
- int i, j, k;
-
- if (!P)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (RowM(P) != ColM(P))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!v)
- {
- if (!(rtrn=CreateVector(RowM(P))))
- return (TVector)NULL;
- }
- else
- if (RowM(P) != DimV(v))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- else
- rtrn=v;
-
- IP=EquateMatrix((TMatrix)NULL,P);
- for (i=RowM(P)-1; i >= 0; i--)
- ElementM(IP,i,i)-=1.0;
- U=CreateMatrix(RowM(P),RowM(P));
- V=CreateMatrix(RowM(P),RowM(P));
-
- if (SVD(U,rtrn,V,IP))
- {
- k=(ElementV(rtrn,0) < SQRT_MACHINE_EPSILON) ? 1 : 0;
- for (j=0, i=RowM(P)-1; i > 0; i--)
- if (ElementV(rtrn,i) < SQRT_MACHINE_EPSILON)
- {
- k++;
- if (ElementV(rtrn,i) < ElementV(rtrn,j)) j=i;
- }
-
- if (k == 1)
- {
- ColumnVector(rtrn,V,j);
- for (sum=ElementV(rtrn,0), i=DimV(rtrn)-1; i > 0; i--)
- sum+=ElementV(rtrn,i);
- if (sum > 0.0)
- {
- for (sum=0.0, i=DimV(rtrn)-1; i >= 0; i--)
- if (ElementV(rtrn,i) < 0.0)
- ElementV(rtrn,i)=0;
- else
- sum+=ElementV(rtrn,i);
- }
- else
- {
- for (sum=0.0, i=DimV(rtrn)-1; i >= 0; i--)
- if (ElementV(rtrn,i) > 0.0)
- ElementV(rtrn,i)=0;
- else
- sum+=ElementV(rtrn,i);
- }
-
- ProductSV(rtrn,1.0/sum,rtrn);
-
- FreeMatrix(V);
- FreeMatrix(U);
- FreeMatrix(IP);
- return rtrn;
- }
- }
-
- FreeMatrix(V);
- FreeMatrix(U);
- FreeMatrix(IP);
-
- if (!v) FreeVector(rtrn);
- return (TVector) NULL;
-}
-
-/*
- Assumes:
- v : An n vector or null pointer
- P : An n x n transition matrix. It must be the case that P(i,j) >= 0 for
- every i and j and P(0,j) + ... + P(n-1,j) = 1 for every j.
-
- Results:
- Computes the ergodic distribution of the transition matrix P if it exists.
- The ergodic distribution will exist if there is a unique vector v such that
- the elements of v are non-negative, sum to one and (P - I)v = 0.
-
- Notes:
- If w is the n dimensional row vector of ones, then w(P - I) = 0. This
- implies that there exists a non-zero v such that (P - I)v = 0. It is easy
- to show that if (P - I)v = 0 and v1 is the positive component of v and v2 is
- the negative component of v, then both (P - I)v1 = 0 and (P - I)v2 = 0. So
- there is always exists a v such that the elements of v are non-negative, sum
- to one, (P - I)v = 0. However, a unique such element might not exist.
-
- This version use the SVD and checks for uniqueness.
-*/
-TVector* ErgodicAll_SVD(TMatrix P)
-{
- TVector d, *rtrn;
- TMatrix IP, U, V;
- PRECISION sum;
- int i, j, k, p, n;
-
- if (!P)
- {
- dw_Error(NULL_ERR);
- return (TVector*)NULL;
- }
- if (RowM(P) != ColM(P))
- {
- dw_Error(SIZE_ERR);
- return (TVector*)NULL;
- }
-
- IP=EquateMatrix((TMatrix)NULL,P);
- for (i=RowM(P)-1; i >= 0; i--)
- ElementM(IP,i,i)-=1.0;
- U=CreateMatrix(RowM(P),RowM(P));
- V=CreateMatrix(RowM(P),RowM(P));
- d=CreateVector(RowM(P));
-
- if (SVD(U,d,V,IP))
- {
- for (k=0, i=RowM(P)-1; i >= 0; i--)
- if (ElementV(d,i) < SQRT_MACHINE_EPSILON)
- {
- for (p=n=0, j=RowM(P)-1; j >= 0; j--)
- if (ElementM(V,j,i) > SQRT_MACHINE_EPSILON)
- p=1;
- else
- if (ElementM(V,j,i) < -SQRT_MACHINE_EPSILON)
- n=1;
- k+=n+p;
- }
-
- if (k > 0)
- {
- rtrn=dw_CreateArray_vector(k);
- for (k=0, i=RowM(P)-1; i >= 0; i--)
- if (ElementV(d,i) < SQRT_MACHINE_EPSILON)
- {
- for (p=n=0, j=RowM(P)-1; j >= 0; j--)
- if (ElementM(V,j,i) > SQRT_MACHINE_EPSILON)
- p=1;
- else
- if (ElementM(V,j,i) < -SQRT_MACHINE_EPSILON)
- n=1;
-
- if (p > 0)
- {
- rtrn[k]=ColumnVector((TVector)NULL,V,i);
- for (sum=0.0, j=DimV(rtrn[k])-1; j >= 0; j--)
- if (ElementV(rtrn[k],j) < 0.0)
- ElementV(rtrn[k],j)=0.0;
- else
- sum+=ElementV(rtrn[k],j);
- if (sum < SQRT_MACHINE_EPSILON) { printf("Sum is not positive %le\n",sum); getchar(); }
- ProductSV(rtrn[k],1.0/sum,rtrn[k]);
- k++;
- }
-
- if (n > 0)
- {
- rtrn[k]=ColumnVector((TVector)NULL,V,i);
- for (sum=0.0, j=DimV(rtrn[k])-1; j >= 0; j--)
- if (ElementV(rtrn[k],j) > 0.0)
- ElementV(rtrn[k],j)=0.0;
- else
- sum+=ElementV(rtrn[k],j);
- if (sum > -SQRT_MACHINE_EPSILON) { printf("Sum is not negative %le\n",sum); getchar(); }
- ProductSV(rtrn[k],1.0/sum,rtrn[k]);
- k++;
- }
- }
-
- FreeVector(d);
- FreeMatrix(V);
- FreeMatrix(U);
- FreeMatrix(IP);
- return rtrn;
- }
- }
-
- FreeVector(d);
- FreeMatrix(V);
- FreeMatrix(U);
- FreeMatrix(IP);
-
- return (TVector*)NULL;
-}
-
-/*
- Assumes:
- Q : n-vector or null pointer
- A : n-vector with elements greater than -1
-
- Results:
- Fills the vector Q with a draw from the Dirichlet distribution with
- parameters given by A. The density of the Dirichlet distribution is
-
-
- Product(Gamma(A[i]), 0 <= i < n)
- ---------------------------------- * Product(Q[i]^A[i], 0 <= i < n)
- Gamma(Sum(A[i], 0 <= i < n))
-
- Returns:
- Upon success, returns Q. Upon failure, returns null. If Q is null, then it
- is created.
-
- Notes:
- The arguments A and Q do not have to be distinct.
-
- Sometimes the Dirichlet parameters are restricted to be greater than -1, as
- is done here. Other times the paramaters are restricted to be positive and
- the exponent in the formula for the density is A[i] - 1. Care must be taken
- to ensure the the correct form is used.
-*/
-TVector DrawDirichletVector(TVector Q, TVector A)
-{
- int i;
- PRECISION sum;
- TVector rtrn;
- if (!A)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (!Q)
- {
- if (!(rtrn=CreateVector(DimV(A))))
- return (TVector)NULL;
- }
- else
- if (DimV(Q) != DimV(A))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- else
- rtrn=Q;
-
- for (sum=0.0, i=DimV(A)-1; i >= 0; i--)
- sum+=ElementV(rtrn,i)=dw_gamma_rnd(ElementV(A,i));
-
- if (sum > 0)
- for (sum=1.0/sum, i=DimV(A)-1; i >= 0; i--)
- ElementV(rtrn,i)*=sum;
- else
- {
- if (!Q) FreeVector(rtrn);
- return (TVector)NULL;
- }
- return rtrn;
-}
-
-/*
- Assumes:
- Q : array of vectors
- A : arrat if vectorsr with elements greater than -1
-
- Results:
- Fills the vector Q[i] with a draw from the Dirichlet distribution with
- parameters given by A[i].
-
- Returns:
- Upon success, returns Q. Upon failure, returns null. If Q is null, then it
- is created.
-
- Notes:
- The arguments A and Q do not have to be distinct.
-
- Sometimes the Dirichlet parameters are restricted to be greater than -1, as
- is done here. Other times the paramaters are restricted to be positive and
- the exponent in the formula for the density is A[i] - 1. Care must be taken
- to ensure the the correct form is used.
-*/
-TVector* DrawIndependentDirichletVector(TVector *Q, TVector *A)
-{
- int i;
- TVector v, *rtrn;
- if (!A)
- {
- dw_Error(NULL_ERR);
- return (TVector*)NULL;
- }
- if (!Q)
- {
- if (!(rtrn=dw_CreateArray_vector(dw_DimA(A))))
- return (TVector*)NULL;
- }
- else
- if (dw_DimA(Q) != dw_DimA(A))
- {
- dw_Error(SIZE_ERR);
- return (TVector*)NULL;
- }
- else
- rtrn=Q;
-
- for (i=dw_DimA(Q) - 1; i >= 0; i--)
- if (v=DrawDirichletVector(rtrn[i],A[i]))
- rtrn[i]=v;
- else
- {
- if (!Q) dw_FreeArray(rtrn);
- return (TVector*)NULL;
- }
-
- return rtrn;
-}
-
-/*
- Assumes:
- Q : n dimensional vector with elements between 0 and 1.
- A : n dimensional vector with positive elements
-
- Returns:
- The log value of the Dirichlet density with parameters A evaluated at Q.
-
- Notes:
- The Dirichlet density is given by
-
- Gamma(Sum(A[i],0 <= i < n))
- --------------------------------- Product(Q[i]^(A[i] - 1), 0 <= i < n)
- Product(Gamma(A[i]), 0 <= i < n)
-*/
-PRECISION LogDirichlet_pdf(TVector Q, TVector A)
-{
- PRECISION sum=0.0, log_pdf=0.0, x, y;
- int i;
- if (!Q || !A)
- {
- dw_Error(NULL_ERR);
- return MINUS_INFINITY;
- }
- if (DimV(Q) != DimV(A))
- {
- dw_Error(SIZE_ERR);
- return MINUS_INFINITY;
- }
- for (i=DimV(Q)-1; i >= 0; i--)
- {
- sum+=(x=ElementV(A,i));
- log_pdf-=dw_log_gamma(x);
- if ((y=ElementV(Q,i)) > 0.0)
- log_pdf+=(x-1.0)*log(y);
- else
- if (x > 1.0)
- return PLUS_INFINITY;
- else
- if (x < 1.0)
- return MINUS_INFINITY;
- }
- return log_pdf + dw_log_gamma(sum);
-}
-
-/*
- Assumes:
- Q : m dimensional vector array. The elements of each vector in the array
- are between 0 and 1.
- A : m dimensional vector array. The elements of each vector in the array
- are positive
-
- Returns:
- The sum of the log values of the Dirichlet densities with parameters A[i]
- evaluated at Q[i].
-*/
-PRECISION LogIndependentDirichlet_pdf(TVector *Q, TVector *A)
-{
- int i;
- PRECISION log_pdf=0.0;
- for (i=dw_DimA(Q)-1; i >= 0; i--)
- log_pdf+=LogDirichlet_pdf(Q[i],A[i]);
- return log_pdf;
-}
-
-/*
- Returns ln(exp(a) + exp(b)) computed to avoid overflow. If
- a = ln(c) and b = ln(d), as is usually the case, then the
- routine returns ln(c + d).
-
-*/
-PRECISION AddLogs(PRECISION a, PRECISION b)
-{
- return (a > b) ? a + log(1.0 + exp(b-a)) : b + log(exp(a-b) + 1.0);
-}
-
-/*
- Returns ln(x*exp(a) + y*exp(b)) computed to avoid overflow. If a = ln(c) and
- b = ln(d), as is usually the case, then the routine returns ln(x*c + y*d).
- Assumes that x*exp(a) + y*exp(b) is positive, but no checking is done. This
- condition will always be satisfied if both x and y are positive.
-
-*/
-PRECISION AddScaledLogs(PRECISION x, PRECISION a, PRECISION y, PRECISION b)
-{
- return (a > b) ? a + log(x + y*exp(b-a)) : b + log(x*exp(a-b) + y);
-}
-
-/*
- Assumes:
- There are DimV(p) states, denoted by 0, ... , Dim(p)-1. The probability of
- state i occuring is given by p[i]. It must be the case that the sum of the
- p[i] is equal to one.
-
- Returns:
- A random draw of one of the states.
-*/
-int DrawDiscrete(TVector p)
-{
- int i=DimV(p)-1;
- PRECISION u=dw_uniform_rnd(), s=ElementV(p,i);
- while (i > 0)
- if (u < s)
- return i;
- else
- s+=ElementV(p,--i);
- return 0;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/****************************** Obsolete Routines ******************************/
-/*******************************************************************************
-/*
- Creates TStateModel
-*/
-TStateModel* CreateStateModel(TMarkovStateVariable *sv, TParameters *p)
-{
- ThetaRoutines *routines;
- TStateModel *model;
-
- routines=CreateThetaRoutines_empty();
- routines->pLogConditionalLikelihood=p->pLogConditionalLikelihood;
- routines->pDestructor=p->pParameterDestructor;
- routines->pLogPrior=p->pLogPrior;
- routines->pNumberFreeParametersTheta=p->pNumberFreeParametersTheta;
- routines->pConvertFreeParametersToTheta=p->pConvertFreeParametersToTheta;
- routines->pConvertThetaToFreeParameters=p->pConvertThetaToFreeParameters;
- routines->pDrawParameters=p->pDrawParameters;
-
- model=CreateStateModel_new(sv,routines,p->p);
- return model;
-}
-
-void FreeParameters(TParameters *p)
-{
- if (p)
- {
- if (p->pParameterDestructor) p->pParameterDestructor(p->p);
- free(p);
- }
-}
-
-/*
- Constructs a TParameters type using passed data. If pParameterDestructor is
- null, then the last argument will not be freed by FreeParameters(). If
- pParameterDestructor is not null, then the last argument will be freed by
- FreeParameters().
-*/
-TParameters* CreateParameters(PRECISION (*pLogConditionalLikelihood)(int,int,struct TStateModel_tag*),
- void (*pParameterDestructor)(void*),
- PRECISION (*pLogPrior)(struct TStateModel_tag*),
- int (*pNumberFreeParametersTheta)(struct TStateModel_tag*),
- void (*pConvertFreeParametersToTheta)(struct TStateModel_tag*, PRECISION*),
- void (*pConvertThetaToFreeParameters)(struct TStateModel_tag*, PRECISION*),
- void (*pDrawParameters)(struct TStateModel_tag*),
- void *parameters)
-{
- TParameters* p=(TParameters*)malloc(sizeof(TParameters));
- if (p)
- {
- p->pLogConditionalLikelihood=pLogConditionalLikelihood;
- p->pParameterDestructor=pParameterDestructor;
- p->pLogPrior=pLogPrior;
- p->pNumberFreeParametersTheta=pNumberFreeParametersTheta;
- p->pConvertFreeParametersToTheta=pConvertFreeParametersToTheta;
- p->pConvertThetaToFreeParameters=pConvertThetaToFreeParameters;
- p->pDrawParameters=pDrawParameters;
- p->p=parameters;
- }
- return p;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
diff --git a/matlab/swz/c-code/sbvar/switching/switch.h b/matlab/swz/c-code/sbvar/switching/switch.h
deleted file mode 100644
index 2ef8b35ef3a5657cd0239663c250ca7518ecc6d2..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/switching/switch.h
+++ /dev/null
@@ -1,605 +0,0 @@
-
-
-#ifndef __MARKOV_SWITCHING__
-#define __MARKOV_SWITCHING__
-
-#define __SWITCHING_VER_100__
-
-#include "matrix.h"
-
-//=== Declaring structures so pointers can be defined ===
-struct TStateModel_tag;
-struct TParameters_tag;
-
-/*******************************************************************************/
-/**************************** TMarkovStateVariable *****************************/
-/*******************************************************************************/
-
-typedef struct TMarkovStateVariable_tag
-{
- //=== Flags ===
- int valid_transition_matrix;
-
- //=== Sizes ===
- int nobs;
- int nstates;
-
- //=== State vector ===
- int* S;
-
- //=== Transition matrix
- TMatrix Q;
-
- //=== Quasi-free transition matrix parameters ===
- TVector *b; // The elements of b[k] are non-negative and their sum equals one up to DimV(b[k])*MACHINE_EPSILON.
- TVector B; // b stacked into single vector
-
- //=== Prior information ===
- TMatrix Prior; // Dirichlet prior on the columns of Q. Must be nstates x nstates with positive elements.
- TVector *Prior_b; // Dirichlet prior on the quasi-free parameters b
- TVector Prior_B; // Prior_b stacked into single vector
-
- //=== Lag information encoding ===
- int nlags_encoded; // Number of lags encoded in the restrictions
- int nbasestates; // Number of base states nbasestates^(nlags_encoded) = nstates
- int** lag_index; // nstates x (nlags_encoded + 1) lag_index[i][j] is the value of the jth lag when the overall state is k
-
- //=== Restrictions ===
- int* FreeDim; //
- int** NonZeroIndex; // nstates x nstates
- TMatrix MQ; // nstates x nstates
-
- //=== Parent Markov state variable ===
- struct TMarkovStateVariable_tag *parent; // either parent state variable or pointer to itself
-
- //=== Multiple state variables ===
- int n_state_variables;
- struct TMarkovStateVariable_tag **state_variable;
- TMatrix *QA;
- TVector *ba;
- TVector *Prior_ba;
- int** SA;
- int** Index;
-
- //=== Control variables ===
- int UseErgodic;
-
- //=== Workspace ===
- PRECISION LogPriorConstant;
-
-} TMarkovStateVariable;
-
-
-//=== Destructors ===
-void FreeMarkovStateVariable(TMarkovStateVariable *sv);
-
-//=== Constructors ===
-TMarkovStateVariable* CreateMarkovStateVariable_Single(int nstates, int nobs, TMatrix Prior, int* FreeDim, int** NonZeroIndex, TMatrix MQ);
-TMarkovStateVariable* CreateMarkovStateVariable_Multiple(int nobs, int n_state_variables, TMarkovStateVariable **state_variable);
-
-TMarkovStateVariable* CreateMarkovStateVariable_Mixture(int nstates, int nobs, TMatrix Prior);
-TMarkovStateVariable* CreateMarkovStateVariable_NoRestrictions(int nstates, int nobs, TMatrix Prior);
-TMarkovStateVariable* CreateMarkovStateVariable_Exclusion(int nstates, int nobs, TMatrix Prior, TMatrix Exclusion);
-TMarkovStateVariable* CreateMarkovStateVariable_SimpleRestrictions(int nstates, int nobs, TMatrix Prior, TMatrix* Restriction);
-TMarkovStateVariable* CreateMarkovStateVariable_ConstantState(int nobs);
-TMarkovStateVariable* DuplicateMarkovStateVariable(TMarkovStateVariable *sv);
-TMarkovStateVariable* RestrictMarkovStateVariable(TMarkovStateVariable *sv, int nstates);
-
-//=== Encoding lagged states into Markov state variable ===
-TMarkovStateVariable* CreateMarkovStateVariable_Lags(int nlags, TMarkovStateVariable *base);
-int** CreateLagIndex(int nbasestates, int nlags, int nstates);
-TMatrix ConvertBaseTransitionMatrix(TMatrix T, TMatrix bT, int nlags);
-
-//=== Data extractions routines ===
-TMatrix GetTransitionMatrix_SV(TMatrix Q, TMarkovStateVariable *sv);
-TMatrix GetBaseTransitionMatrix_SV(TMatrix Q, TMarkovStateVariable *sv);
-#define GetTransitionProbability_SV(sv,j,i) (ElementM((sv)->Q,N_E2I[i],N_E2I[j]))
-#define DecomposeIndexInd_SV(sv,i,j) ((sv)->state_variable[j]->N_I2E[(sv)->Index[N_E2I[i]][j]])
-#define DecomposeIndexLag_SV(sv,i,lag) ((sv)->baseN_I2E[(sv)->lag_index[N_E2I[i]][lag]])
-
-//=== Normalization ===
-void PropagateSwap_SV(TMarkovStateVariable *sv);
-void Swap_SV(TMarkovStateVariable *sv, int i, int j);
-
-//=== Prior routines ===
-void SetLogPriorConstant_SV(TMarkovStateVariable *sv);
-PRECISION LogPrior_SV(TMarkovStateVariable *sv);
-
-//=== Simulation ===
-void DrawTransitionMatrix_SV(TMarkovStateVariable *sv);
-void DrawTransitionMatrixFromPrior_SV(TMarkovStateVariable *sv);
-void SetTransitionMatrixToPriorMean_SV(TMarkovStateVariable *sv);
-void DrawStatesFromTransitionMatrix_SV(TMarkovStateVariable *sv);
-
-//=== Utility routines ===
-void InvalidateTransitionMatrices_SV(TMarkovStateVariable *sv);
-void ValidateTransitionMatrices_SV(TMarkovStateVariable *sv);
-void PropagateStates_SV(TMarkovStateVariable *sv);
-int PropagateTransitionMatrices_SV(TMarkovStateVariable *sv);
-void Update_Q_from_B_SV(TMarkovStateVariable *sv);
-int Update_B_from_Q_SV(TMarkovStateVariable *sv);
-int TotalNumberStateVariables_SV(TMarkovStateVariable *sv);
-
-int* CreateStateIndex(TMarkovStateVariable* sv, TMarkovStateVariable** list, int n);
-int** CreateTranslationMatrix(TMarkovStateVariable ***list, TMarkovStateVariable *sv);
-int** CreateTranslationMatrix_Flat(int **states, TMarkovStateVariable *sv);
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/******************************** ThetaRoutines ********************************/
-/*******************************************************************************/
-typedef struct
-{
- //=== Computes ln(P(y[t] | Y[t-1], Z[t], theta, s[t] = s)) ===
- PRECISION (*pLogConditionalLikelihood)(int s, int t, struct TStateModel_tag *model);
-
- //=== Computes E[y[t] | Y[t-1], Z[t], theta, Q, s[t]]
- TVector (*pExpectationSingleStep)(TVector y, int s, int t, struct TStateModel_tag *model);
-
- //=== Destructs parameters ===
- void (*pDestructor)(void *);
-
- //=== Draws parameters conditional states and transition probability ===
- void (*pDrawParameters)(struct TStateModel_tag *);
-
- //=== Computes Log of the prior on the model specific parameters ===
- PRECISION (*pLogPrior)(struct TStateModel_tag *);
-
- //=== Converts between free parameters and model specific parameters ===
- int (*pNumberFreeParametersTheta)(struct TStateModel_tag*);
- void (*pConvertFreeParametersToTheta)(struct TStateModel_tag*, PRECISION*);
- void (*pConvertThetaToFreeParameters)(struct TStateModel_tag*, PRECISION*);
-
- //=== Notification routines ===
- void (*pStatesChanged)(struct TStateModel_tag*);
- void (*pThetaChanged)(struct TStateModel_tag*);
- void (*pTransitionMatrixChanged)(struct TStateModel_tag*);
- int (*pValidTheta)(struct TStateModel_tag*);
-
- //=== Allows for initialization of data structures before forward recursion ===
- void (*pInitializeForwardRecursion)(struct TStateModel_tag*);
-
- //=== Permutes the elements of Theta.
- int (*pGetNormalization)(int*, struct TStateModel_tag*);
- int (*pPermuteTheta)(int*, struct TStateModel_tag*);
-
-} ThetaRoutines;
-
-//=== Constructors ===
-ThetaRoutines* CreateThetaRoutines_empty(void);
-
-/*******************************************************************************/
-/********************************* TStateModel *********************************/
-/*******************************************************************************/
-typedef struct TStateModel_tag
-{
- TMarkovStateVariable *sv;
- ThetaRoutines *routines;
- void *theta;
-
- //=== Control variables ===
- int ValidForwardRecursion;
- int UseLogFreeParametersQ;
- int NormalizeStates;
-
- //=== Common work space ===
- TVector* V; // V[t][i] = P(s[t] = i | Y[t], Z[t], theta, Q) 0 <= t <= T and 0 <= i < nstates
- TVector* Z; // Z[t][i] = P(s[t] = i | Y[t-1], Z[t-1], theta, Q) 0 < t <= T and 0 <= i < nstates
- PRECISION L; // L = Sum(ln(Sum(P(y[t] | Y[t-1], Z[t], theta, s[t]) * P(s[t] | Y[t-1], Z[t-1], theta, Q),0 <= s[t] < nstates)),0 < t <= T)
-
- //=== Simulation status fields
- int n_degenerate_draws; // counter for number of degenerate draws
- int *states_count; // integer array of length nstates to count the number of each of the states
-
- //=== Obsolete fields retained for backward compatibility ===
- void *parameters;
- struct TParameters_tag *p;
-
-} TStateModel;
-
-//=== Destructors ===
-void FreeStateModel(TStateModel *model);
-
-//=== Constructors ===
-TStateModel* CreateStateModel_new(TMarkovStateVariable *sv, ThetaRoutines *routines, void *theta);
-
-//=== Notification routines ===
-void StatesChanged(TStateModel *model);
-void TransitionMatricesChanged(TStateModel *model);
-void ThetaChanged(TStateModel *model);
-#define ValidTheta(model) (((model)->routines->pValidTheta) ? (model)->routines->pValidTheta(model) : 1)
-#define ValidTransitionMatrix(model) ((model)->sv->valid_transition_matrix)
-
-//=== Simulation routines ===
-void ForwardRecursion(TStateModel *model);
-void DrawStates(TStateModel *model);
-void DrawStatesFromTransitionMatrix(TStateModel *model);
-void DrawTransitionMatrix(TStateModel *model);
-void DrawTransitionMatrixFromPrior(TStateModel *model);
-void SetTransitionMatrixToPriorMean(TStateModel *model);
-void DrawTheta(TStateModel *model);
-void DrawAll(TStateModel *model);
-
-//=== Normalization ===
-int SetStateNormalizationMethod(int (*pGetNormalization)(int*, struct TStateModel_tag*),int (*pPermuteTheta)(int*, struct TStateModel_tag*),TStateModel *model);
-int NormalizeStates(TStateModel *model);
-
-//=== Probability routines ===
-// ln(P(y[t] | Y[t-1], Z[t], theta, Q, s[t]))
-#define LogConditionalLikelihood(s,t,model) ((model)->routines->pLogConditionalLikelihood(s,t,model))
-
-// ln(P(y[t] | Y[t-1], Z[t], theta, Q))
-PRECISION LogConditionalLikelihood_StatesIntegratedOut(int t, TStateModel *model);
-
-// E[y[t] | Y[t-1], Z[t], theta, Q, s[t]]
-#define ExpectationSingleStep(y,s,t,model) ((model)->routines->pExpectationSingleStep(y,s,t,model))
-
-// E[y[t] | Y[t-1], Z[t], theta, Q]
-TVector ExpectationSingleStep_StatesIntegratedOut(TVector y, int t, TStateModel *model);
-
-// ln(P(Q))
-#define LogPrior_Q(model) (LogPrior_SV((model)->sv))
-
-// ln(P(theta))
-#define LogPrior_Theta(model) ((model)->routines->pLogPrior(model))
-
-// ln(P(theta, Q))
-#define LogPrior(model) (LogPrior_Theta(model) + LogPrior_Q(model))
-
-// ln(P(S[T] | theta, Q))
-PRECISION LogConditionalPrior_S(TStateModel *model);
-
-// ln(P(Y[T] | Z[T], theta, Q, S[T]))
-PRECISION LogLikelihood(TStateModel *model);
-
-// ln(P(Y[T] | Z[T], theta, Q, S[T]) * P(S[T] | Theta, Q) * P(Theta, Q))
-#define LogPosterior(model) (LogLikelihood(model) + LogConditionalPrior_S(model) + LogPrior(model))
-
-// ln(P(Y[T] | Z[T], theta, Q))
-PRECISION LogLikelihood_StatesIntegratedOut(TStateModel *model);
-
-// ln(P(Y[T] | Z[T], theta, Q) * P(Theta, Q))
-#define LogPosterior_StatesIntegratedOut(model) (LogLikelihood_StatesIntegratedOut(model) + LogPrior(model))
-
-// ln(P(S[T] | Y[T], Z[T], theta, Q))
-PRECISION LogConditionalProbabilityStates(int *S, TStateModel *model);
-
-// P(s[t] | Y[t], Z[t], theta, Q)
-PRECISION ProbabilityStateConditionalCurrent(int s, int t, TStateModel *model);
-
-// P(s[t] | Y[t-1], Z[t-1], theta, Q)
-PRECISION ProbabilityStateConditionalPrevious(int s, int t, TStateModel *model);
-
-// P[t] = P(s[t] = s | Y[T], Z[T], theta, Q)
-TVector ProbabilitiesState(TVector P, int s, TStateModel *model);
-
-//=== Free parameters routines ===
-int NumberFreeParametersQ(TStateModel *model);
-void ConvertQToFreeParameters(TStateModel *model, PRECISION *f); // needs to be modified
-void ConvertFreeParametersToQ(TStateModel *model, PRECISION *f); // needs to be modified
-void ConvertQToLogFreeParameters(TStateModel *model, PRECISION *f); // needs to be modified
-void ConvertLogFreeParametersToQ(TStateModel *model, PRECISION *f); // needs to be modified
-#define NumberFreeParametersTheta(model) ((model)->routines->pNumberFreeParametersTheta(model))
-void ConvertFreeParametersToTheta(TStateModel *model, PRECISION *f);
-#define ConvertThetaToFreeParameters(model,f) ((model)->routines->pConvertThetaToFreeParameters(model,f))
-
-//=== Setup integrity routines ===
-int CheckRestrictions(int* FreeDim, int** NonZeroIndex, TMatrix MP, int nstates);
-int CheckPrior(TMatrix Prior, int nstates);
-int CheckPriorOnFreeParameters(TMatrix Prior, int** NonZeroIndex, int nstates);
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-//=== Utility routines ===
-TVector Ergodic(TVector v, TMatrix P);
-TVector Ergodic_SVD(TVector v, TMatrix P);
-TVector* ErgodicAll_SVD(TMatrix P);
-TVector DrawDirichletVector(TVector Q, TVector Alpha);
-TVector* DrawIndependentDirichletVector(TVector *Q, TVector *A);
-PRECISION LogDirichlet_pdf(TVector Q, TVector Alpha);
-PRECISION LogIndependentDirichlet_pdf(TVector *Q, TVector *Alpha);
-int DrawDiscrete(TVector p);
-PRECISION AddLogs(PRECISION a, PRECISION b);
-PRECISION AddScaledLogs(PRECISION x, PRECISION a, PRECISION y, PRECISION b);
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/****** Obsolete names and structures retained for backward compatibility ******/
-/*******************************************************************************/
-typedef struct TParameters_tag
-{
- //=== Computes ln(P(y[t] | Y[t-1], Z[t], theta, s[t] = s)) ===
- PRECISION (*pLogConditionalLikelihood)(int s, int t, struct TStateModel_tag *model);
-
- //=== Destructs parameters ===
- void (*pParameterDestructor)(void *parameters);
-
- //=== Draws parameters conditional states and transition probability ===
- void (*pDrawParameters)(struct TStateModel_tag *);
-
- //=== Computes Log of the prior on the model specific parameters ===
- PRECISION (*pLogPrior)(struct TStateModel_tag *);
-
- //=== Converts between free parameters and model specific parameters ===
- int (*pNumberFreeParametersTheta)(struct TStateModel_tag*);
- void (*pConvertFreeParametersToTheta)(struct TStateModel_tag*, PRECISION*);
- void (*pConvertThetaToFreeParameters)(struct TStateModel_tag*, PRECISION*);
-
- // Obsolete fields retained for backward compatibility
- void *p;
-
-} TParameters;
-
-//=== Constructors/Destructors ===
-void FreeParameters(TParameters *p);
-
-TParameters* CreateParameters(PRECISION (*)(int,int,struct TStateModel_tag*), // pLogConditionalLikelihood
- void (*)(void*), // Destructor for parameters
- PRECISION (*)(struct TStateModel_tag*), // pLogPrior
- int (*)(struct TStateModel_tag*), // pNumberFreeModelSpecificParameters
- void (*)(struct TStateModel_tag*, PRECISION*), // pConvertFreeParametersToModelSpecificParameters
- void (*)(struct TStateModel_tag*, PRECISION*), // pConvertModelSpecificParametersToFreeParameters
- void (*)(struct TStateModel_tag*), // pDrawParameters
- void *); // pointer to user defined parameters
-
-TStateModel* CreateStateModel(TMarkovStateVariable *sv, TParameters *p);
-
-//=== Obsolete names ===
-#define ProbabilityStateGivenCurrentData(s,t,model) ProbabilityStateConditionalCurrent(s,t,model)
-#define ProbabilityStateGivenPreviousData(s,t,model) ProbabilityStateConditionalPrevious(s,t,model)
-#define ProbabilityStateGivenAllData(P,s,model) ProbabilitiesState(P,s,model)
-//PRECISION ProbabilityStatesGivenData(TStateModel *model);
-#define LogLikelihoodGivenParameters(model) LogLikelihood_StatesIntegratedOut(model);
-//PRECISION LogMarginalPosterior(TStateModel *model);
-//void DrawAllParameters(TMarkovStateVariable *sv);
-//void DrawAllParametersAndNormalizeStates(TMarkovStateVariable *sv);
-//PRECISION ComputeMarginalLogLikelihood(TMarkovStateVariable *sv);
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-#endif
-
-/***************************** TMarkovStateVariable *****************************
- The TMarkovStateVariable type can represent either a single Markov state
- variable or a collection of independent Markov state variables.
-
- The transition matrix Q is generated for a single Markov state variable via
- the routines DrawTransitionMatrixFromPrior_SV() or DrawTransitionMatrix_SV().
- Calls to these functions by multiple independent Markov state variables result
- in recursive call to these functions.
-
- The vector of states S is generated only by a TStateModel type containing the
- TMarkovStateVariable type. The state is only generated at the top level and
- can be propagated downward with a call to PropagateStates_SV().
-
- The following set of fields are set for both types.
- ===============================================================================
- int UseErgodic
- Uses the ergodic distribution if non-zero and use the uniform distribution
- otherwise.
-
- int nstates
- Number of states. Always positive.
-
- int nobs
- Number of observations. Always positive.
-
- int* S
- S[t] is the state at time t, for 0 <= t <= nobs. S is created via a call
- to dw_CreateArray_int(). It is guaranteed that 0 <= S[t] < nstates.
-
- TMatrix Q
- Markov transition matrix.
-
- struct TMarkovStateVariable_tag *parent
- Parent of the Markov state variable. If the Markov state variable has no
- parent, then parent is a pointer to the structure itself.
-
- int n_state_variables
- Number of state variables. Will be equal to one for single Markov state
- variables and larger than one in the case of multiple independent Markov
- state variables
-
- struct TMarkovStateVariable_tag **state_variable
- An array of markov state variables of length n_state_variables. If
- n_state_variables is equal to one, then state_variable[0] is a pointer to
- the structure itself. Care must be taken to ensure that infinite loops do
- not result when transversing through state variables. When creating a
- mulitple Markov state variable via a call to the routine
- CreateMarkovStateVariable_Multiple(), the last argument which is a pointer
- to a pointer to a TMarkovStateVariable must have been created with
-
- dw_CreateArray_pointer(n_state_variables,(void (*)(void*))FreeMarkovStateVariable);
-
- Furthermore, the structure receives ownership of this argument and is
- responsible for its freeing.
-
- int** Index
- This is a nstates x n_state_variables rectangular array of integers. State
- s corresponds to state_variable[i] being equal to Index[s][i].
-
- int** SA
- An array of integer pointers of length n_state_variables. The pointers SA[i]
- and state_variable[i]->S point to the same address.
-
- TMatrix* QA
- An array of matrices of length n_state_variables. The matrix QA[i] is
- is the matrix state_variable[i]->Q.
-
- TVector* ba
- For single Markov state variables, ba[i] = b[i]. For multiple state
- variables ba[i] = state_variable[k]->ba[j] where
-
- i = j + dw_DimA(state_variable[0]->ba) + ... + dw_DimA(state_variable[k-1]->ba)
-
- TVector* Prior_ba
- For single Markov state variables, Prior_ba[i] = Prior_b[i]. For multiple
- state variables Prior_ba[i] = state_variable[k]->Prior_ba[j] where
-
- i = j + dw_DimA(state_variable[0]->Prior_ba) + ... + dw_DimA(state_variable[k-1]->Prior_ba)
-
- ===============================================================================
- The following fields are set only for single Markov state variables and are
- set to null for multiple independent Markov state variables.
-
- TVector B
- The vector B is the vector of quasi-free parameters.
-
- TVector *b
- Array of vectors of length DimA(FreeDim). The element b[k] is of length
- FreeDim[k]. Non-standard memory management is used so that
-
- &(b[k][i])=&B[FreeDim[0] + ... + FreeDim[k-1] + i])
-
- The elements of b[k] are non-negative and their sum equals one up to
- DimV(b[k])*MACHINE_EPSILON.
-
- TMatrix Prior
- Prior Dirichlet parameters for Q.
-
- TVector *Prior_b
- The Dirichlet prior parametrs for b. Array of vectors of length
- DimA(FreeDim). The element Prior_b[k] is of length FreeDim[k].
- Non-standard memory management is used so that
-
- &(Prior_b[k][i])=&B[FreeDim[0] + ... + FreeDim[k-1] + i])
-
- TVector Prior_B
- The Dirichlet prior parameters for B. This vector is created and
- initialized by CreateMarkovStateVariable(). The element B[k]-1 is the sum
- of Prior[i][j]-1 over all (i,j) such that NonZeroIndex[i][j] == k.
-
- int* FreeDim
- FreeDim[k] is the length of the kth free Dirichlet vector. The length of B
- must be equal to FreeDim[0] + ... + FreeDim[dw_DimA(FreeDim)-1].
-
- int** NonZeroIndex
- Defines the relationship between Q and B.
- --
- | MQ[i][j]*B[NonZeroIndex[i][j]] if NonZeroIndex[i][j] >= 0
- Q[i][j] = |
- | 0.0 if NonZeroIndex[i][j] == -1
- --
- TMatrix MQ
- Coefficients for the elements of Q in terms of the free parameters B.
-
-
- int nlags_encoded; // Number of lags encoded in the restrictions
- int nbasestates; // Number of base states nbasestates^(nlags_encoded) = nstates
- int** lag_index; // nstates x (nlags_encoded + 1) lag_index[i][j] is the value of the jth lag when the overall state is k
-
-
- ===============================================================================
-
-
- ===============================================================================
- Normalization:
- In general, a permutation of the states, together with the corresponding
- permutation of the rows and columns of the transition matrix and the model
- dependent parameters theta, does not change the value of the likelihood
- function and so presents a normalization problem. However, some permutations
- of the states are not permissible in that they may violate the restrictions
- placed on the transition matrix or restrictions on the model dependent
- parameters. Furthermore, even if a permutation did not cause a violation of
- any restrictions, a non-symmetric prior on the model dependent parameters
- could cause the value of the likelihood to change.
-
-********************************************************************************/
-
-/********************************************************************************
- Constrained optimization
- Because one of the tasks of this suite of programs is to find the maximum
- likelihood estimate, constrained optimization routines are often called.
- These routines almost always require a single or double precision array
- containing the parameters to be optimized over to be passed. To facilitate
- this, the TMarkovStateVariable type allows the memory being allocated for
- parameters to be passed, which allows the user to control exactly how the
- memory is laid out. Also, the TParameter type is defined which automates
- some of this process. The goal is to allow different aspects of this suite
- to access the common memory area for parameters in a manner appropriate to
- the task at hand while minimizing the amount of memory copying.
-
- Memory Management
- Different parts of this suite of routines need to have the parameters
- available in certain formats. However, copying parameters from one format to
- another should be avoided. Our approach is as follows. We define a
- structure TParameters which contains the following:
-
- int n_real_parameters;
- int n_integer_parameters;
- int n_miscellaneous_parameters;
- void* v;
- void* extra;
- The pointer v points to contiguous memory that contains all the
- parameters. The first n_real_parameters*sizeof(PRECISION) bytes contains
- floating point parameters. The next n_integer_parameters*sizeof(int)
- bytes contain integer parameters. The next n_miscellaneous_parameters
- bytes contain whatever parameters do not fit into the first two
- catagories.
-
- The idea is that many maximization routines work on a vector of floating
- point numbers. The integer parameters are included to record the values
- of Markov state variables, though they could certainly be used for other
- purposes. The general purpose memory is to provide flexibility.
-
- The pointer extra will point to some structure needed for the
- implementation of model in each state.
-
- Markov state variable parameter pointers
- The Markov state variables require transition matrix parameters and the
- values of the Markov state variables. For this two structures are defined.
-
- int n_state_variables;
- int T;
- TVectorArray BA;
- TMatrixArray QA;
- TIntVectorArray SA;
- All of pElementV(BA[i]), pElementM(QA[i]), and pElementIV(SA[i]) point to
- memory positions in the vector v. Non-standard memory management
- techniques are used and the following must be true.
-
- All of pElementV(BA[i]), pElementM(QA[i]), and pElementIV(SA[i]) were
- allocated with malloc(), can be freed with free(), and none of
- FreeVector(BA[i]), FreeMatrix(QA[i]), or FreeIntMatrix(SA[i]) attempt
- to free pElemementV(BA[i]), pElementM(QA[i]), or pElementIV(SA[i]) if
- these are null pointers.
-
- The default behavior is for the memory allocation of v is:
-
- Theta
- BA[0]
- .
- .
- BA[n_state_variables-1]
- QA[0]
- .
- .
- QA[n_state_variables-1]
- SA[0]
- .
- .
- SA[n_state_variables-1]
-
- The vector BA[i] stores the free parameters for the transition matrix
- of the ith Markov state variable. The matrix QA[i] stores the full
- transition matrix for the ith Markov state variable. The integer array
- SA[i] stores the values of the ith Markov state variable. The number of
- Markov state variables is n_state_variables and there are T+1 values
- stored for each Markov state variable. The total number of states, which
- is the product of the number of states for each state variables is
- nstates. If there are no restrictions on the ith transition matrix other
- than its elements being non-negative and the sum of its columns being
- one, then BA[i] can be equal to QA[i].
-
-
-*/
-
diff --git a/matlab/swz/c-code/sbvar/switching/switch_opt.c b/matlab/swz/c-code/sbvar/switching/switch_opt.c
deleted file mode 100644
index 5d2cd090774d79c97d9b4b37f129eee3d9e444d6..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/switching/switch_opt.c
+++ /dev/null
@@ -1,115 +0,0 @@
-
-#include "switch_opt.h"
-
-#include <stdlib.h>
-#include <string.h>
-#include <math.h>
-
-//====== Static Global Variables ======
-static TStateModel *Model=(TStateModel*)NULL;
-static PRECISION *buffer=(PRECISION*)NULL;
-static PRECISION *ModifiedFreeParameters=(PRECISION*)NULL;
-static PRECISION *FreeParameters_Q=(PRECISION*)NULL;
-static int NumberFreeParameters_Q=0;
-static PRECISION *FreeParameters_Theta=(PRECISION*)NULL;
-static int NumberFreeParameters_Theta=0;
-
-
-void SetupObjectiveFunction(TStateModel *model, PRECISION *Modified, PRECISION *FreeQ, PRECISION *FreeTheta)
-{
- if (buffer) free(buffer);
- Model=model;
- FreeParameters_Q=FreeQ;
- NumberFreeParameters_Q=NumberFreeParametersQ(model);
- FreeParameters_Theta=FreeTheta;
- NumberFreeParameters_Theta=model->routines->pNumberFreeParametersTheta(model);
- ModifiedFreeParameters=Modified;
-}
-
-void SetupObjectiveFunction_new(TStateModel *model, int FreeTheta_Idx, int FreeQ_Idx, int Modified_Idx)
-{
- if (buffer) free(buffer);
- Model=model;
- NumberFreeParameters_Q=NumberFreeParametersQ(model);
- NumberFreeParameters_Theta=model->routines->pNumberFreeParametersTheta(model);
- buffer=(PRECISION*)malloc((NumberFreeParameters_Q + NumberFreeParameters_Theta)*sizeof(PRECISION));
-
- FreeParameters_Q=buffer+FreeQ_Idx;
- FreeParameters_Theta=buffer+FreeTheta_Idx;
- ModifiedFreeParameters=buffer+Modified_Idx;
-}
-
-PRECISION PosteriorObjectiveFunction(PRECISION *x, int n)
-{
- if (x != ModifiedFreeParameters) memmove(ModifiedFreeParameters,x,n*sizeof(PRECISION));
- ConvertFreeParametersToQ(Model,FreeParameters_Q);
- ConvertFreeParametersToTheta(Model,FreeParameters_Theta);
- return -LogPosterior_StatesIntegratedOut(Model);
-
- //PRECISION lp_Q, lp_Theta, li;
- //FILE *f_out;
- //lp_Q=LogPrior_Q(Model);
- //lp_Theta=LogPrior_Theta(Model);
- //li=LogLikelihood_StatesIntegratedOut(Model);
- //if (isnan(lp_Q) || isnan(lp_Theta) || isnan(li))
- // {
- // f_out=fopen("tmp.tmp","wt");
- // Write_VAR_Specification(f_out,(char*)NULL,Model);
- // WriteTransitionMatrices(f_out,(char*)NULL,"Error: ",Model);
- // Write_VAR_Parameters(f_out,(char*)NULL,"Error: ",Model);
- // fprintf(f_out,"LogPrior_Theta(): %le\n",lp_Theta);
- // fprintf(f_out,"LogPrior_Q(): %le\n",lp_Q);
- // fprintf(f_out,"LogLikelihood_StatesIntegratedOut(): %le\n",li);
- // fprintf(f_out,"Posterior: %le\n\n",lp_Q+lp_Theta+li);
- // fclose(f_out);
- // exit(0);
- // }
- //return -(lp_Q+lp_Theta+li);
-}
-
-PRECISION PosteriorObjectiveFunction_csminwel(double *x, int n, double **args, int *dims)
-{
- return PosteriorObjectiveFunction(x,n);
-}
-
-void PosteriorObjectiveFunction_npsol(int *mode, int *n, double *x, double *f, double *g, int *nstate)
-{
- *f=PosteriorObjectiveFunction(x,*n);
-}
-
-PRECISION MLEObjectiveFunction(PRECISION *x, int n)
-{
- if (x != ModifiedFreeParameters) memmove(ModifiedFreeParameters,x,n*sizeof(PRECISION));
- ConvertFreeParametersToQ(Model,FreeParameters_Q);
- ConvertFreeParametersToTheta(Model,FreeParameters_Theta);
- return -LogLikelihood_StatesIntegratedOut(Model);
-}
-
-PRECISION MLEObjectiveFunction_csminwel(double *x, int n, double **args, int *dims)
-{
- return MLEObjectiveFunction(x,n);
-}
-
-void MLEObjectiveFunction_npsol(int *mode, int *n, double *x, double *f, double *g, int *nstate)
-{
- *f=MLEObjectiveFunction(x,*n);
-}
-
-
-PRECISION MLEObjectiveFunction_LogQ(PRECISION *x, int n)
-{
- if (x != ModifiedFreeParameters) memmove(ModifiedFreeParameters,x,n*sizeof(PRECISION));
- ConvertLogFreeParametersToQ(Model,FreeParameters_Q);
- ConvertFreeParametersToTheta(Model,FreeParameters_Theta);
- return -LogLikelihood_StatesIntegratedOut(Model);
-}
-
-PRECISION MLEObjectiveFunction_LogQ_csminwel(double *x, int n, double **args, int *dims)
-{
- return MLEObjectiveFunction_LogQ(x,n);
-}
-
-
-
-
-
diff --git a/matlab/swz/c-code/sbvar/switching/switch_opt.h b/matlab/swz/c-code/sbvar/switching/switch_opt.h
deleted file mode 100644
index 628af8cc6ff9be6af74ae7bdc2001008f38f1cd4..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/switching/switch_opt.h
+++ /dev/null
@@ -1,21 +0,0 @@
-
-
-#ifndef __MARKOV_SWITCHING_OPTIMIZATION__
-#define __MARKOV_SWITCHING_OPTIMIZATION__
-
-#include "switch.h"
-
-void SetupObjectiveFunction(TStateModel *model, PRECISION *MFPparms, PRECISION *FTMparms, PRECISION *FMSparms);
-
-PRECISION PosteriorObjectiveFunction(PRECISION *x, int n);
-PRECISION PosteriorObjectiveFunction_csminwel(double *x, int n, double **args, int *dims);
-void PosteriorObjectiveFunction_npsol(int *mode, int *n, double *x, double *f, double *g, int *nstate);
-
-PRECISION MLEObjectiveFunction(PRECISION *x, int n);
-PRECISION MLEObjectiveFunction_csminwel(double *x, int n, double **args, int *dims);
-void MLEObjectiveFunction_npsol(int *mode, int *n, double *x, double *f, double *g, int *nstate);
-
-PRECISION MLEObjectiveFunction_LogQ(PRECISION *x, int n);
-PRECISION MLEObjectiveFunction_LogQ_csminwel(double *x, int n, double **args, int *dims);
-
-#endif
diff --git a/matlab/swz/c-code/sbvar/switching/switchio.c b/matlab/swz/c-code/sbvar/switching/switchio.c
deleted file mode 100644
index d34932030c9e12472f286d0fd816c3192c08e84b..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/switching/switchio.c
+++ /dev/null
@@ -1,1167 +0,0 @@
-
-#include "switchio.h"
-#include "dw_array.h"
-#include "dw_matrix_array.h"
-#include "dw_error.h"
-#include "dw_ascii.h"
-
-#include <string.h>
-#include <stdlib.h>
-#include <math.h>
-
-static void ReadError(char *idformat, char *trailer, int error);
-static int SetFilePosition(FILE *f_in, char *format, char *str);
-static int ReadInteger(FILE *f_in, char *idformat, char *trailer, int *i);
-static int ReadMatrix(FILE *f_in, char *idformat, char *trailer, TMatrix X);
-static int ReadIntArray(FILE *f_in, char *idformat, char *trailer, void *X);
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-#define SWITCHIO_LINE_ID_NOT_FOUND 1
-#define SWITCHIO_ERROR_READING_DATA 2
-
-static void ReadError(char *idformat, char *trailer, int error)
-{
- char *idbuffer, *errmsg, *format;
- switch (error)
- {
- case SWITCHIO_LINE_ID_NOT_FOUND:
- format="Line identifier ""%s"" not found.";
- break;
- case SWITCHIO_ERROR_READING_DATA:
- format="Error reading data after line identifier ""%s"".";
- break;
- case 0:
- return;
- default:
- dw_Error(UNKNOWN_ERR);
- return;
- }
- if (trailer)
- sprintf(idbuffer=(char*)malloc(strlen(idformat)+strlen(trailer)-1),idformat,trailer);
- else
- idbuffer=idformat;
- sprintf(errmsg=(char*)malloc(strlen(format)+strlen(idbuffer)-1),format,idbuffer);
- dw_UserError(errmsg);
- free(errmsg);
- if (idbuffer != idformat) free(idbuffer);
-}
-
-/*
- Assumes
- format : "*%s*" or "*"
- str : "*"
-
- where * is any string that does not contain format specifiers.
-
- Results
- finds given string in file
-
-*/
-static int SetFilePosition(FILE *f_in, char *format, char *str)
-{
- char *buffer;
- int rtrn;
- if (str)
- sprintf(buffer=(char*)malloc(strlen(format)+strlen(str)-1),format,str);
- else
- buffer=format;
- rtrn=dw_SetFilePosition(f_in,buffer);
- if (buffer != format) free(buffer);
- return rtrn;
-}
-
-static int ReadInteger(FILE *f_in, char *format, char *str, int *i)
-{
- if (!SetFilePosition(f_in,format,str))
- return SWITCHIO_LINE_ID_NOT_FOUND;
- else
- if (fscanf(f_in," %d ",i) != 1)
- return SWITCHIO_ERROR_READING_DATA;
- else
- return 0;
-}
-
-static int ReadMatrix(FILE *f_in, char *format, char *str, TMatrix X)
-{
- if (!SetFilePosition(f_in,format,str))
- return SWITCHIO_LINE_ID_NOT_FOUND;
- else
- if (!dw_ReadMatrix(f_in,X))
- return SWITCHIO_ERROR_READING_DATA;
- else
- return 0;
-}
-
-static int ReadIntArray(FILE *f_in, char *format, char *str, void *X)
-{
- if (!SetFilePosition(f_in,format,str))
- return SWITCHIO_LINE_ID_NOT_FOUND;
- else
- if (!dw_ReadArray(f_in,X))
- return SWITCHIO_ERROR_READING_DATA;
- else
- return 0;
-}
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/***************** TMarkovStateVariable Input/Output Routines ******************/
-/*******************************************************************************/
-/*
- Assumes:
- f: valid file pointer
- idstring: pointer to null terminated string
-
- Returns:
- Valid pointer to a TMarkovStateVariable structure upon success and null
- pointer upon failure.
-
- Results:
- Reads Markov specification from file and creates TMarkovStateVariable
- structure.
-
- Notes:
- The null terminated string idstring is of the form "" or "[i][j]...[k]".
- Usually, this function will be called with idstring equal to "". The routine
- is called recursively with the more general form for idstring. For each path
- of Markov state variables of the form
-
- sv->state_variable[i]->state_variable[j]-> ... ->state_variable[k]
-
- which corresponds to a single Markov state variable, there must be an entries
- in the file of the form:
-*/
-TMarkovStateVariable* ReadMarkovSpecification_SV(FILE *f_in, char *idstring, int nobs)
-{
- char *idformat, *trailer=(char*)NULL, *idstring_new;
- int err, i, j, n_state_variables, nstates, nlags_encoded, nbasestates;
- TMatrix Prior, MQ;
- int *FreeDim, **NonZeroIndex;
- TMarkovStateVariable *sv=(TMarkovStateVariable*)NULL, **sv_array;
-
- // Get nobs if necessary
- if ((nobs > 0) || !(err=ReadInteger(f_in,idformat="//== Number observations ==//",trailer,&nobs)))
- {
- // Construct trailer
- if (idstring[0])
- sprintf(trailer=(char*)malloc(24+strlen(idstring)),"for state_variable%s ==//",idstring);
- else
- strcpy(trailer=(char*)malloc(5),"==//");
-
- // Read number of state variables
- if (!(err=ReadInteger(f_in,idformat="//== Number independent state variables %s",trailer,&n_state_variables)))
- {
- if (n_state_variables > 1)
- {
- sv_array=(TMarkovStateVariable**)dw_CreateArray_pointer(n_state_variables,(void (*)(void*))FreeMarkovStateVariable);
- for (j=10, i=1; n_state_variables/j > 0; j*=10, i++);
- strcpy(idstring_new=(char*)malloc((j=(int)strlen(idstring))+i+3),idstring);
- for (i=0; i < n_state_variables; i++)
- {
- sprintf(idstring_new+j,"[%d]",i+1);
- if (!(sv_array[i]=ReadMarkovSpecification_SV(f_in,idstring_new,nobs))) break;
- }
- free(idstring_new);
- if (i == n_state_variables)
- sv=CreateMarkovStateVariable_Multiple(nobs,n_state_variables,sv_array);
- else
- dw_FreeArray(sv_array);
- }
- else
- {
- // Read number states
- if (!(err=ReadInteger(f_in,idformat="//== Number states %s",trailer,&nstates)))
- {
- // Read number of lags to encode
- switch (err=ReadInteger(f_in,idformat="//== Number of lags encoded %s",trailer,&nlags_encoded))
- {
- case SWITCHIO_ERROR_READING_DATA:
- break;
- case SWITCHIO_LINE_ID_NOT_FOUND:
- nlags_encoded=0;
- case 0:
- if (nlags_encoded < 0)
- {
- err=SWITCHIO_ERROR_READING_DATA;
- break;
- }
-
- // Read number of base states
- if (nlags_encoded > 0)
- {
- if (err=ReadInteger(f_in,idformat="//== Number of base states %s",trailer,&nbasestates))
- break;
- for (j=nbasestates, i=nlags_encoded; i > 0; i--) j*=nbasestates;
- if (j != nstates)
- {
- err=SWITCHIO_ERROR_READING_DATA;
- break;
- }
- }
-
- // Read prior
- Prior=CreateMatrix(nstates,nstates);
- if (!(err=ReadMatrix(f_in,idformat="//== Prior %s",trailer,Prior)))
- {
- // Read free Dirichlet dimensions
- if (!(err=ReadInteger(f_in,idformat="//== Number free Dirichlet variables %s",trailer,&i)))
- {
- FreeDim=dw_CreateArray_int(i);
- if (!(err=ReadIntArray(f_in,idformat="//== Free Dirichlet dimensions %s",trailer,FreeDim)))
- {
- // Read free Dirichlet index
- NonZeroIndex=dw_CreateRectangularArray_int(nstates,nstates);
- if (!(err=ReadIntArray(f_in,idformat="//== Free Dirichlet index %s",trailer,NonZeroIndex)))
- {
- // Read free Dirichlet multipliers
- MQ=CreateMatrix(nstates,nstates);
- if (!(err=ReadMatrix(f_in,idformat="//== Free Dirichlet multipliers %s",trailer,MQ)))
- if (sv=CreateMarkovStateVariable_Single(nstates,nobs,Prior,FreeDim,NonZeroIndex,MQ))
- if (nlags_encoded > 0)
- {
- dw_FreeArray(sv->lag_index);
- sv->nlags_encoded=nlags_encoded;
- sv->nbasestates=nbasestates;
- sv->lag_index=CreateLagIndex(sv->nbasestates,sv->nlags_encoded,sv->nstates);
- }
- FreeMatrix(MQ);
- }
- dw_FreeArray(NonZeroIndex);
- }
- dw_FreeArray(FreeDim);
- }
- }
- FreeMatrix(Prior);
-
- break;
- }
- }
- }
- }
- }
- if (err) ReadError(idformat,trailer,err);
- if (trailer) free(trailer);
- return sv;
-}
-
-int WriteMarkovSpecification_SV(FILE *f_out, TMarkovStateVariable *sv, char *idstring)
-{
- int i, j;
- char *trailer, *idbuffer;
-
- if (idstring[0])
- {
- // 24 characters in "for state_variable ==//" plus null character
- trailer=(char*)malloc(24+strlen(idstring));
- sprintf(trailer,"for state_variable%s ==//",idstring);
-
- fprintf(f_out,"//****** Specification %s ******//\n\n",trailer);
- }
- else
- {
- trailer=(char*)malloc(5);
- strcpy(trailer,"==//");
-
- fprintf(f_out,"//== Number observations ==//\n%d\n\n",sv->nobs);
- fprintf(f_out,"//****** State Variable Specification ******//\n");
- }
-
- fprintf(f_out,"//== Number independent state variables %s\n%d\n",trailer,sv->n_state_variables);
-
- if (sv->n_state_variables > 1)
- {
- fprintf(f_out,"//******************************************//\n\n");
- for (j=10, i=1; sv->n_state_variables >= j; j*=10, i++);
- strcpy(idbuffer=(char*)malloc((j=(int)strlen(idstring))+i+3),idstring);
- for (i=0; i < sv->n_state_variables; i++)
- {
- sprintf(idbuffer+j,"[%d]",i+1);
- if (!WriteMarkovSpecification_SV(f_out,sv->state_variable[i],idbuffer))
- {
- free(idbuffer);
- return 0;
- }
- }
- free(idbuffer);
- }
- else
- {
- fprintf(f_out,"\n//== Number states %s\n%d\n\n",trailer,sv->nstates);
-
- if (sv->nlags_encoded > 0)
- {
- fprintf(f_out,"//== Number of lags encoded %s\n%d\n\n",trailer,sv->nlags_encoded);
- fprintf(f_out,"//== Number of base states %s\n%d\n\n",trailer,sv->nbasestates);
- }
-
- fprintf(f_out,"//== Prior %s\n",trailer);
- dw_PrintMatrix(f_out,sv->Prior,"%22.14le ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Number free Dirichlet variables %s\n%d\n\n",trailer,dw_DimA(sv->FreeDim));
-
- fprintf(f_out,"//== Free Dirichlet dimensions %s\n",trailer);
- dw_PrintArray(f_out,sv->FreeDim,"%d ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Free Dirichlet index %s\n",trailer);
- dw_PrintArray(f_out,sv->NonZeroIndex,"%d ");
-
- fprintf(f_out,"//== Free Dirichlet multipliers %s\n",trailer);
- dw_PrintMatrix(f_out,sv->MQ,"%22.14le ");
- fprintf(f_out,"//******************************************//\n\n");
- }
-
- free(trailer);
- return 1;
-}
-
-/*
- Assumes:
- f: valid file pointer
- sv: pointer to valid TMarkovStateVariable structure
- idstring: pointer to null terminated string
-
- Returns:
- One upon success and zero upon failure.
-
- Results:
- Reads transition matrices from file into sv. All transition matrices and the
- associated free parameters are set.
-
- Notes:
- The null terminated string idstring is of the form "" or "[i][j]...[k]".
- Usually, this function will be called with idstring equal to "". The routine
- is called recursively with the more general form for idstring. For each path
- of Markov state variables of the form
-
- sv->state_variable[i]->state_variable[j]-> ... ->state_variable[k]
-
- which corresponds to a single Markov state variable, there must be an entry
- in the file of the form:
-
- //== <header>Transition matrix[i][j]...[k] ==//
- x x ... x
- x x ... x
- . . .
- x x ... x
-
- If sv itself is a single Markov state variable, then the format can be
-
- //== <header>Transition matrix[1] ==//
- x x ... x
- x x ... x
- . . .
- x x ... x
-
- or
-
- //== <header>Transition matrix ==//
- x x ... x
- x x ... x
- . . .
- x x ... x
-
- Here the term <header> is replaced with the null terminated string header.
- Note that the spacing is important.
-*/
-int ReadTransitionMatrices_SV(FILE *f_in, TMarkovStateVariable* sv, char *header, char *idstring)
-{
- int i, j, err;
- char *format, *idbuffer;
- PRECISION sum;
-
- if (sv->n_state_variables > 1)
- {
- for (j=10, i=1; sv->n_state_variables >= j; j*=10, i++);
- strcpy(idbuffer=(char*)malloc((j=(int)strlen(idstring))+i+3),idstring);
- for (i=sv->n_state_variables-1; i >= 0; i--)
- {
- sprintf(idbuffer+j,"[%d]",i+1);
- if (!ReadTransitionMatrices_SV(f_in,sv->state_variable[i],header,idbuffer))
- {
- free(idbuffer);
- return sv->valid_transition_matrix=0;
- }
- }
- free(idbuffer);
- MatrixTensor(sv->Q,sv->QA);
- return sv->valid_transition_matrix=1;
- }
- else
- {
- // Read transition matrix
- if (!header) header="";
- format="//== %sTransition matrix%s ==//";
- sprintf(idbuffer=(char*)malloc(strlen(header) + strlen(format) + strlen(idstring) - 3),format,header,idstring);
- if (err=ReadMatrix(f_in,idbuffer,(char*)NULL,sv->Q))
- if (!idstring[0])
- {
- free(idbuffer);
- idstring="[1]";
- sprintf(idbuffer=(char*)malloc(strlen(header) + strlen(format) + strlen(idstring) - 3),format,header,idstring);
- err=ReadMatrix(f_in,idbuffer,(char*)NULL,sv->Q);
- }
- free(idbuffer);
- if (!err)
- {
- // Scale the columns of Q - loose requirement on sumation to one
- for (j=sv->nstates-1; j >= 0; j--)
- {
- for (sum=0.0, i=sv->nstates-1; i >= 0; i--)
- if (ElementM(sv->Q,i,j) < 0.0)
- {
- dw_UserError("Transition matrix can not have negative elements.");
- return sv->valid_transition_matrix=0;
- }
- else
- sum+=ElementM(sv->Q,i,j);
- if (fabs(sum-1.0) > 1.0e-4)
- {
- dw_UserError("Transition matrix columns must sum to one.");
- return sv->valid_transition_matrix=0;
- }
- for (sum=1.0/sum, i=sv->nstates-1; i >= 0; i--)
- ElementM(sv->Q,i,j)*=sum;
- }
-
- // Update
- if (!Update_B_from_Q_SV(sv))
- {
- dw_UserError("Transition matrices do not satisfy restrictions");
- return sv->valid_transition_matrix=0;
- }
-
- return sv->valid_transition_matrix=1;
- }
- return sv->valid_transition_matrix=0;
- }
-}
-
-/*
- Assumes:
- f: valid file pointer
- sv: pointer to valid TMarkovStateVariable structure
- idstring: pointer to null terminated string
-
- Returns:
- One upon success and zero upon failure.
-
- Results:
- Reads transition matrices from file into sv. All transition matrices and the
- associated free parameters are set.
-
- Notes:
- The null terminated string idstring is of the form "" or "[i][j]...[k]".
- Usually, this function will be called with idstring equal to "". The routine
- is called recursively with the more general form for idstring. For each path
- of Markov state variables of the form
-
- sv->state_variable[i]->state_variable[j]-> ... ->state_variable[k]
-
- which corresponds to a single Markov state variable, there must be an entry
- in the file of the form:
-
- //== <header>Transition matrix[i][j]...[k] ==//
- x x ... x
- x x ... x
- . . .
- x x ... x
-
- If sv itself is a single Markov state variable, then the format can be
-
- //== <header>Transition matrix[1] ==//
- x x ... x
- x x ... x
- . . .
- x x ... x
-
- or
-
- //== <header>Transition matrix ==//
- x x ... x
- x x ... x
- . . .
- x x ... x
-
- Here the term <header> is replaced with the null terminated string header.
- Note that the spacing is important.
-*/
-int ReadBaseTransitionMatrices_SV(FILE *f_in, TMarkovStateVariable* sv, char *header, char *idstring)
-{
- int i, j, err;
- char *format, *idbuffer;
- PRECISION sum;
- TMatrix Q;
-
- if (sv->n_state_variables > 1)
- {
- for (j=10, i=1; sv->n_state_variables >= j; j*=10, i++);
- strcpy(idbuffer=(char*)malloc((j=(int)strlen(idstring))+i+3),idstring);
- for (i=sv->n_state_variables-1; i >= 0; i--)
- {
- sprintf(idbuffer+j,"[%d]",i+1);
- if (!ReadBaseTransitionMatrices_SV(f_in,sv->state_variable[i],header,idbuffer))
- {
- free(idbuffer);
- return 0;
- }
- }
- free(idbuffer);
- MatrixTensor(sv->Q,sv->QA);
- return 1;
- }
- else
- {
- // Read transition matrix
- Q=CreateMatrix(sv->nbasestates,sv->nbasestates);
- if (!header) header="";
- format="//== %sBase transition matrix%s ==//";
- sprintf(idbuffer=(char*)malloc(strlen(header) + strlen(format) + strlen(idstring) - 3),format,header,idstring);
- if (err=ReadMatrix(f_in,idbuffer,(char*)NULL,Q))
- if (!idstring[0])
- {
- free(idbuffer);
- idstring="[1]";
- sprintf(idbuffer=(char*)malloc(strlen(header) + strlen(format) + strlen(idstring) - 3),format,header,idstring);
- err=ReadMatrix(f_in,idbuffer,(char*)NULL,Q);
- }
- free(idbuffer);
- if (!err)
- {
- // Scale the columns of Q - loose requirement on sumation to one
- for (j=sv->nbasestates-1; j >= 0; j--)
- {
- for (sum=0.0, i=sv->nbasestates-1; i >= 0; i--)
- if (ElementM(Q,i,j) < 0.0)
- {
- FreeMatrix(Q);
- dw_UserError("Transition matrix can not have negative elements.");
- return 0;
- }
- else
- sum+=ElementM(Q,i,j);
- if (fabs(sum-1.0) > 1.0e-4)
- {
- FreeMatrix(Q);
- dw_UserError("Transition matrix columns must sum to one.");
- return 0;
- }
- for (sum=1.0/sum, i=sv->nbasestates-1; i >= 0; i--)
- ElementM(Q,i,j)*=sum;
- }
-
- // Convert base transition matrix to full transition matrix.
- ConvertBaseTransitionMatrix(sv->Q,Q,sv->nlags_encoded);
-
- // Update
- if (!Update_B_from_Q_SV(sv))
- {
- dw_UserError("Transition matrices do not satisfy restrictions");
- return 0;
- }
-
- return 1;
- }
- return 0;
- }
-}
-
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- sv: pointer to valid TMarkovStateVariable structure
- header: pointer to null terminated string
- idstring: pointer to null terminated string
-
- Returns:
- One is always returned.
-
- Results:
- Writes transition matrices from sv to a file. See ReadTransitionMatrices()
- for the format.
-
- Notes:
- The null terminated string idstring is of the form "" or "[i][j]...[k]".
- Usually, this routine will be called with idstring equal to "". The routine
- is called recursively with the more general form for idstring.
-*/
-int WriteTransitionMatrices_SV(FILE *f_out, TMarkovStateVariable* sv, char *header, char *idstring)
-{
- int i, j;
- char *idbuffer;
-
- if (!header) header="";
- fprintf(f_out,"//== %sTransition matrix%s ==//\n",header,idstring);
- dw_PrintMatrix(f_out,sv->Q,"%22.14le ");
-
- if (sv->n_state_variables > 1)
- {
- for (j=10, i=1; sv->n_state_variables >= j; j*=10, i++);
- strcpy(idbuffer=(char*)malloc((j=(int)strlen(idstring))+i+3),idstring);
- for (i=0; i < sv->n_state_variables; i++)
- {
- sprintf(idbuffer+j,"[%d]",i+1);
- WriteTransitionMatrices_SV(f_out,sv->state_variable[i],header,idbuffer);
- }
- free(idbuffer);
- }
-
- return 1;
-}
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- sv: pointer to valid TMarkovStateVariable structure
- header: pointer to null terminated string
- idstring: pointer to null terminated string
-
- Returns:
- One is always returned.
-
- Results:
- Writes transition matrices from sv to a file. See ReadTransitionMatrices()
- for the format.
-
- Notes:
- The null terminated string idstring is of the form "" or "[i][j]...[k]".
- Usually, this routine will be called with idstring equal to "". The routine
- is called recursively with the more general form for idstring.
-*/
-int WriteBaseTransitionMatrices_SV(FILE *f_out, TMarkovStateVariable* sv, char *header, char *idstring)
-{
- int i, j;
- char *idbuffer;
- TMatrix Q;
-
- if (!header) header="";
- fprintf(f_out,"//== %sBase transition matrix%s ==//\n",header,idstring);
- if (Q=GetBaseTransitionMatrix_SV((TMatrix)NULL,sv))
- {
- dw_PrintMatrix(f_out,Q,"%22.14le ");
- fprintf(f_out,"\n");
- FreeMatrix(Q);
- }
- else
- fprintf(f_out,"Error geting base transition matrix\n");
-
- if (sv->n_state_variables > 1)
- {
- for (j=10, i=1; sv->n_state_variables >= j; j*=10, i++);
- strcpy(idbuffer=(char*)malloc((j=(int)strlen(idstring))+i+3),idstring);
- for (i=0; i < sv->n_state_variables; i++)
- {
- sprintf(idbuffer+j,"[%d]",i+1);
- WriteBaseTransitionMatrices_SV(f_out,sv->state_variable[i],header,idbuffer);
- }
- free(idbuffer);
- }
-
- return 1;
-}
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- sv: pointer to valid TMarkovStateVariable structure
- header: pointer to null terminated string
- idstring: pointer to null terminated string
-
- Returns:
- One is always returned.
-
- Results:
- Writes transition matrices from sv to a file. See ReadTransitionMatrices()
- for the format.
-
- Notes:
- The null terminated string idstring is of the form "" or "[i][j]...[k]".
- Usually, this routine will be called with idstring equal to "". The routine
- is called recursively with the more general form for idstring.
-*/
-void WriteBaseTransitionMatricesFlat_Headers_SV(FILE *f_out, TMarkovStateVariable* sv, char *idstring)
-{
- int i, j;
- char *idbuffer;
-
- if (sv->n_state_variables > 1)
- {
- for (j=10, i=1; sv->n_state_variables >= j; j*=10, i++);
- strcpy(idbuffer=(char*)malloc((j=(int)strlen(idstring))+i+3),idstring);
- for (i=0; i < sv->n_state_variables; i++)
- {
- sprintf(idbuffer+j,"[%d]",i+1);
- WriteBaseTransitionMatricesFlat_Headers_SV(f_out,sv->state_variable[i],idbuffer);
- }
- free(idbuffer);
- }
- else
- {
- for (j=0; j < sv->nbasestates; j++)
- for (i=0; i < sv->nbasestates; i++)
- fprintf(f_out,"Q%s(%d,%d) ",idstring,i+1,j+1);
- }
-}
-
-
-/*
- Returns 1 upon success and 0 upon failure.
-*/
-int WriteBaseTransitionMatricesFlat_SV(FILE *f_out, TMarkovStateVariable *sv, char *fmt)
-{
- int i, j;
- TMatrix Q;
-
- if (sv->n_state_variables > 1)
- {
- for (i=0; i < sv->n_state_variables; i++)
- if (!WriteBaseTransitionMatricesFlat_SV(f_out,sv->state_variable[i],fmt))
- return 0;
- }
- else
- {
- if (!fmt) fmt="%lf ";
- if (Q=GetBaseTransitionMatrix_SV((TMatrix)NULL,sv))
- {
- for (j=0; j < ColM(Q); j++)
- for (i=0; i < RowM(Q); i++)
- fprintf(f_out,fmt,ElementM(Q,i,j));
- FreeMatrix(Q);
- }
- else
- return 0;
- }
-
- return 1;
-}
-#undef SWITCHIO_LINE_ID_NOT_FOUND
-#undef SWITCHIO_ERROR_READING_DATA
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-/*
- Assumes:
- f: valid file pointer or null pointer
- filename: pointer to null terminated string or null
-
- Returns:
- Valid pointer to a TMarkovStateVariable structure upon success and null
- pointer upon failure.
-
- Results:
- Reads Markov specification from file and creates TMarkovStateVariable
- structure.
-
- Notes:
- One of f or filename should be non-null.
-*/
-TMarkovStateVariable* ReadMarkovSpecification(FILE *f, char *filename)
-{
- TMarkovStateVariable *sv;
- FILE *f_in=f ? f : fopen(filename,"rt");
- sv=(f_in) ? ReadMarkovSpecification_SV(f_in,"",-1) : (TMarkovStateVariable*)NULL;
- if (!f && f_in) fclose(f_in);
- return sv;
-}
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- filename: pointer to null terminated string or null
- model: pointer to valid TStateModel structure.
-
- Returns:
- one upon upon success and zero upon failure.
-
- Results:
- Writes Markov specification to file.
-
- Notes:
- One of f or filename should be non-null.
-*/
-int WriteMarkovSpecification(FILE *f, char *filename, TStateModel *model)
-{
- FILE *f_out=f ? f : fopen(filename,"at");
- int rtrn=(f_out) ? WriteMarkovSpecification_SV(f_out,model->sv,"") : 0;
- if (!f && f_out) fclose(f_out);
- return rtrn;
-}
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- filename: pointer to null terminated string or null
- model: pointer to valid TStateModel structure.
-
- Returns:
- One upon success and zero upon failure.
-
- Results:
- Attempts to read transition matrix into model.
-
- Notes:
- One of f or filename should be non-null. Calls TransitionMatricesChanged().
-*/
-int ReadTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model)
-{
- FILE *f_in=f ? f : fopen(filename,"rt");
- int rtrn=(f_in) ? ReadTransitionMatrices_SV(f_in,model->sv,header,"") : 0;
- TransitionMatricesChanged(model);
- if (!f && f_in) fclose(f_in);
- return rtrn;
-}
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- filename: pointer to null terminated string or null
- model: pointer to valid TStateModel structure.
-
- Returns:
- One upon success and zero upon failure.
-
- Results:
- Writes transition matrix.
-
- Notes:
- One of f or filename should be non-null.
-*/
-int WriteTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model)
-{
- FILE *f_out=f ? f : dw_CreateTextFile(filename);
- int rtrn=(f_out) ? WriteTransitionMatrices_SV(f_out,model->sv,header,"") : 0;
- if (!f && f_out) fclose(f_out);
- return rtrn;
-}
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- filename: pointer to null terminated string or null
- model: pointer to valid TStateModel structure.
-
- Returns:
- One upon success and zero upon failure.
-
- Results:
- Attempts to read transition matrix into model.
-
- Notes:
- One of f or filename should be non-null. Calls TransitionMatricesChanged().
-*/
-int ReadBaseTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model)
-{
- FILE *f_in=f ? f : fopen(filename,"rt");
- int rtrn=(f_in) ? ReadBaseTransitionMatrices_SV(f_in,model->sv,header,"") : 0;
- TransitionMatricesChanged(model);
- if (!f && f_in) fclose(f_in);
- return rtrn;
-}
-
-/*
- Assumes:
- f: valid file pointer or null pointer
- filename: pointer to null terminated string or null
- model: pointer to valid TStateModel structure.
-
- Returns:
- One upon success and zero upon failure.
-
- Results:
- Writes base transition matrices.
-
- Notes:
- One of f or filename should be non-null.
-*/
-int WriteBaseTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model)
-{
- FILE *f_out=f ? f : dw_CreateTextFile(filename);
- int rtrn=(f_out) ? WriteBaseTransitionMatrices_SV(f_out,model->sv,header,"") : 0;
- if (!f && f_out) fclose(f_out);
- return rtrn;
-}
-
-int WriteBaseTransitionMatricesFlat(FILE *f, TStateModel *model, char *fmt)
-{
- return f ? WriteBaseTransitionMatricesFlat_SV(f,model->sv,fmt) : 0;
-}
-
-
-int ReadStates(FILE *f, char *filename, char *header, TStateModel *model)
-{
- FILE *f_in=f ? f : dw_OpenTextFile(filename);
- char *format="//== %sStates ==//";
- int err, i;
-
- if (err=ReadIntArray(f_in,format,header,model->sv->S))
- ReadError(format,header,err);
- else
- {
- // Check states and propagate
- for (i=model->sv->nstates; i >= 0; i--)
- if ((model->sv->S[i] < 0) || (model->sv->S[i] >= model->sv->nstates))
- {
- for ( ; i >= 0; i--) model->sv->S[i]=0;
- dw_UserError("ReadStates(): Invalid state value.");
- err=1;
- break;
- }
- PropagateStates_SV(model->sv);
- }
-
- if (!f) fclose(f_in);
-
- return err ? 0 : 1;
-}
-
-int WriteStates(FILE *f, char *filename, char *header, TStateModel *model)
-{
- FILE *f_out=f ? f : dw_CreateTextFile(filename);
-
- fprintf(f_out,"//== %sStates ==//\n",header);
- dw_PrintArray(f_out,model->sv->S,"%d ");
- fprintf(f_out,"\n");
-
- if (!f) fclose(f_out);
- return 1;
-}
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-/*
-//== Flat Independent Markov States and Simple Restrictions ==//
-
-//-----------------------------------------------------------------------------//
-//-- Read by CreateMarkovStateVariable_File() only if the passed number of --//
-//-- observations is less than or equal to zero. Can be omitted if the --//
-//-- passed number of observations is positive. --//
-//-----------------------------------------------------------------------------//
-//== Number Observations ==//
-nobs
-
-//== Number Independent State Variables ==//
-n_state_variables
-
-//-----------------------------------------------------------------------------//
-//-- state_variable[i] --//
-//-----------------------------------------------------------------------------//
-
-//== Number of states for state_variable[i] ==//
-n_states
-
-//-----------------------------------------------------------------------------//
-//-- Each column contains the parameters for a Dirichlet prior on the --//
-//-- corresponding column of the transition matrix. Each element must be --//
-//-- positive. For each column, the relative size of the prior elements --//
-//-- determine the relative size of the elements of the transition matrix --//
-//-- and overall larger sizes implies a tighter prior. --//
-//-----------------------------------------------------------------------------//
-//== Transition matrix prior for state_variable[i]. (n_states x n_states) ==//
-prior
-
-//== Free Dirichet dimensions for state_variable[i] ==//
-free[0] ... free[n_states - 1]
-
-//-----------------------------------------------------------------------------//
-//-- The jth restriction matrix is n_states x free[j]. Each row of the --//
-//-- restriction matrix has exactly one non-zero entry and the sum of each --//
-//-- column of the restriction matrix must be one. If entry (i,k) of the --//
-//-- jth restriction matrix is non-zero, then entry (i,j) in the transition --//
-//-- matrix is controlled by the kth element of jth free Dirichlet random --//
-//-- variable --//
-//-----------------------------------------------------------------------------//
-//== Column restrictions for state_variable[i] ==//
-restriction[0]
- .
- .
- .
-restriction[n_states - 1]
-
-//-----------------------------------------------------------------------------//
-//-- Allows an optional initialization for the transition matrix, otherwise --//
-//-- the initial value is set to the mean of the prior --//
-//-----------------------------------------------------------------------------//
-//== Initial transition matrix for state_variable[i]. (n_states x n_states) ==//
-Q
-
-//-----------------------------------------------------------------------------//
-//-- Allows for lagged values of the state variable to be encoded. If this --//
-//-- identifier is missing, then the value of nlags_encoded is set to zero. --//
-//-----------------------------------------------------------------------------//
-//== Number of lags encoded for state_variable[i] ==//
-nlags_encoded
-
-*/
-TMarkovStateVariable* CreateMarkovStateVariable_File(FILE *f, char *filename, int nobs)
-{
- FILE *f_in;
- char *id, id_buffer[256];
- int nlags, n_state_variables, nstates, i, j;
- int* dims;
- TMatrix prior;
- TMatrix* restrictions;
- TMarkovStateVariable **sv, *rtrn=(TMarkovStateVariable*)NULL, *tmp;
-
- // Open file if necessary
- if (!f)
- f_in=dw_OpenTextFile(filename);
- else
- f_in=f;
-
- // Check for Flat Independent Markov States and Simple Restrictions
- if (dw_SetFilePosition(f_in,"//== Flat Independent Markov States and Simple Restrictions ==//"))
- {
- if (nobs <= 0)
- {
- id="//== Number Observations ==//";
- if (!dw_SetFilePosition(f_in,id))
- {
- fprintf(stderr,"Line identifier ""%s"" not found.\n",id);
- exit(0);
- }
- fscanf(f_in," %d ",&nobs);
- if (nobs <= 0)
- {
- fprintf(stderr,"Number Observations must be positive\n");
- exit(0);
- }
- }
-
- id="//== Number Independent State Variables ==//";
- if (!dw_SetFilePosition(f_in,id))
- {
- fprintf(stderr,"Line identifier ""%s"" not found.\n",id);
- exit(0);
- }
- fscanf(f_in," %d ",&n_state_variables);
- if (n_state_variables <= 0)
- {
- fprintf(stderr,"Number Independent State Variables must be positive\n");
- exit(0);
- }
-
- sv=(TMarkovStateVariable**)dw_CreateArray_pointer(n_state_variables,(void (*)(void*))FreeMarkovStateVariable);
- for (i=0; i < n_state_variables; i++)
- {
- sprintf(id_buffer,"//== Number of states for state_variable[%d] ==//",i+1);
- if (!dw_SetFilePosition(f_in,id_buffer))
- {
- fprintf(stderr,"Line identifier ""%s"" not found.\n",id_buffer);
- exit(0);
- }
- fscanf(f_in," %d ",&nstates);
- if (nstates <= 0)
- {
- fprintf(stderr,"Number of states for state_variable[%d] must be positive\n",i+1);
- exit(0);
- }
-
- sprintf(id_buffer,"//== Transition matrix prior for state_variable[%d]. (n_states x n_states) ==//",i+1);
- if (!dw_SetFilePosition(f_in,id_buffer))
- {
- fprintf(stderr,"Line identifier ""%s"" not found.\n",id_buffer);
- exit(0);
- }
- dw_ReadMatrix(f_in,prior=CreateMatrix(nstates,nstates));
-
- sprintf(id_buffer,"//== Free Dirichet dimensions for state_variable[%d] ==//",i+1);
- if (!dw_SetFilePosition(f_in,id_buffer))
- sv[i]=CreateMarkovStateVariable_NoRestrictions(nstates,nobs,prior);
- else
- {
- dw_ReadArray(f_in,dims=dw_CreateArray_int(nstates));
-
- sprintf(id_buffer,"//== Column restrictions for state_variable[%d] ==//",i+1);
- if (!dw_SetFilePosition(f_in,id_buffer))
- {
- fprintf(stderr,"Line identifier ""%s"" not found.\n",id_buffer);
- exit(0);
- }
- restrictions=dw_CreateArray_matrix(nstates);
- for (j=0; j < nstates; j++)
- if (dims[j] > 0)
- dw_ReadMatrix(f_in,restrictions[j]=CreateMatrix(nstates,dims[j]));
- else
- {
- fprintf(stderr,"Free Dirichet dimensions for column %d of state_variable[%d] must be positive\n",j+1,i+1);
- exit(0);
- }
-
- sv[i]=CreateMarkovStateVariable_SimpleRestrictions(nstates,nobs,prior,restrictions);
-
- dw_FreeArray(restrictions);
- dw_FreeArray(dims);
-
- sprintf(id_buffer,"//== Number of lags encoded for state_variable[%d] ==//",i+1);
- if (dw_SetFilePosition(f_in,id_buffer))
- {
- fscanf(f_in," %d ",&nlags);
- if (nlags > 0)
- {
- tmp=CreateMarkovStateVariable_Lags(nlags,sv[i]);
- FreeMarkovStateVariable(sv[i]);
- sv[i]=tmp;
- }
- }
- }
-
- FreeMatrix(prior);
- }
-
- if (n_state_variables > 1)
- rtrn=CreateMarkovStateVariable_Multiple(nobs,n_state_variables,sv);
- else
- rtrn=sv[0];
- }
-
- // Close file if necessary
- if (!f) fclose(f_in);
-
- return rtrn;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/************************* Test Input/Output Routines **************************/
-/*******************************************************************************
-int main(void)
-{
- char *filename="../switch/MarkovStateVariable.dat";
- char *outputfilename="../switch/tmp.dat";
- FILE *f_out;
-
- TMarkovStateVariable *sv;
-
- sv=CreateMarkovStateVariable_File((FILE*)NULL,filename,-1);
-
- f_out=dw_CreateTextFile(outputfilename);
- WriteMarkovSpecification_SV(f_out,sv,"");
- WriteTransitionMatrices_SV(f_out,sv,"Initial: ","");
-
- //DrawStatesFromTransitionMatrix_SV(sv);
- DrawTransitionMatrixFromPrior_SV(sv);
- WriteTransitionMatrices_SV(f_out,sv,"Draw: ","");
- fclose(f_out);
-
- FreeMarkovStateVariable(sv);
-
- return 0;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
diff --git a/matlab/swz/c-code/sbvar/switching/switchio.h b/matlab/swz/c-code/sbvar/switching/switchio.h
deleted file mode 100644
index b6c297671a09ecdc129972f3cbf90137abec238f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/switching/switchio.h
+++ /dev/null
@@ -1,36 +0,0 @@
-
-#include "switch.h"
-
-/*
- Base routines for reading/writing Markov state variables and transition
- matrices in native ascii format.
-*/
-TMarkovStateVariable* ReadMarkovSpecification_SV(FILE *f_in, char *idstring, int nobs);
-int WriteMarkovSpecification_SV(FILE *f_out, TMarkovStateVariable *sv, char *idstring);
-int ReadTransitionMatrices_SV(FILE *f_in, TMarkovStateVariable* sv, char *header, char *idstring);
-int WriteTransitionMatrices_SV(FILE *f_out, TMarkovStateVariable* sv, char *header, char *idstring);
-int ReadBaseTransitionMatrices_SV(FILE *f_out, TMarkovStateVariable *sv, char *header, char *idstring);
-int WriteBaseTransitionMatrices_SV(FILE *f_out, TMarkovStateVariable *sv, char *header, char *idstring);
-
-int WriteBaseTransitionMatricesFlat_SV(FILE *f_out, TMarkovStateVariable *sv, char *fmt);
-void WriteBaseTransitionMatricesFlat_Headers_SV(FILE *f_out, TMarkovStateVariable* sv, char *idstring);
-
-/*
- Routines for reading/writing Markov state variables and transition matrices
- from TStateModel. Calls base routines.
-*/
-TMarkovStateVariable* ReadMarkovSpecification(FILE *f, char *filename);
-int WriteMarkovSpecification(FILE *f, char *filename, TStateModel *model);
-int ReadTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model);
-int WriteTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model);
-int ReadStates(FILE *f, char *filename, char *header, TStateModel *model);
-int WriteStates(FILE *f, char *filename, char *header, TStateModel *model);
-int ReadBaseTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model);
-int WriteBaseTransitionMatrices(FILE *f, char *filename, char *header, TStateModel *model);
-
-int WriteBaseTransitionMatricesFlat(FILE *f, TStateModel *model, char *fmt);
-
-/*
- Read flat markov state variable specification from file.
-*/
-TMarkovStateVariable* CreateMarkovStateVariable_File(FILE *f, char *filename, int nobs);
diff --git a/matlab/swz/c-code/sbvar/var/PrintDraws.c b/matlab/swz/c-code/sbvar/var/PrintDraws.c
deleted file mode 100644
index b8a926be0a9203e0ac1fdc278429ceff0ed3a51a..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/PrintDraws.c
+++ /dev/null
@@ -1,147 +0,0 @@
-
-#include "matrix.h"
-#include "dw_rand.h"
-#include "dw_parse_cmd.h"
-#include "dw_ascii.h"
-#include "VARbase.h"
-#include "VARio.h"
-#include "switch.h"
-#include "switchio.h"
-#include "command_line_VAR.h"
-
-#include <stdlib.h>
-#include <string.h>
-#include <math.h>
-#include <time.h>
-
-int main(int nargs, char **args)
-{
- TStateModel *model;
- T_VAR_Parameters *p;
- FILE *f_out;
- char *filename;
- int count, begin_time, end_time, tuning, burn_in, iterations, check, period=1000, seed, output, thinning,
- nd1;
- TVARCommandLine *cmd=(TVARCommandLine*)NULL;
- char *include_help[]={"-di","-do","-fs","-fp","-ph","-MLE",(char*)NULL},
- *additional_help[]={
- "-ft <tag>",
- "Tag for input file. Input file name is est_final_<tag>.dat.",
- "-fto <tag>",
- "Tag for output file. Output file names are draws_<tag>.dat and headers_<tag>.dat. Default is -ft <tag>.",
- "-mh <integer>",
- "Tuning period for Metropolis-Hasting draws (default value = 30000)",
- "-b <integer>",
- "Burn-in period (default value = 0.1 * (number of iterations))",
- "-i <integer>",
- "Number of draw (default value = 1000), number saved is (-i)/(-t)",
- "-t <integer>",
- "Thinning factor. Only one in t draws are written to file.",
- "-nd1",
- "Normalize diagonal of A0 to one (flat output only)",
- "-gs <integer>",
- "Seed value for generator - 0 gets seed from clock (default value = 0)",
- (char*)NULL,
- (char*)NULL};
-
- //=== Help Screen ===
- if (dw_FindArgument_String(nargs,args,"h") != -1)
- {
- fprintf(stdout,"print_draws <options>\n");
- PrintHelpMessages(stdout,include_help,additional_help);
- return 0;
- }
-
- //=== Get seed, tuning peroid, burn-in period, number of iterations, and thinning factor
- seed=dw_ParseInteger_String(nargs,args,"gs",0);
- tuning=dw_ParseInteger_String(nargs,args,"mh",30000);
- iterations=dw_ParseInteger_String(nargs,args,"i",1000);
- burn_in=dw_ParseInteger_String(nargs,args,"b",iterations/10);
- thinning=dw_ParseInteger_String(nargs,args,"t",1);
- nd1=(dw_FindArgument_String(nargs,args,"nd1") >= 0) ? 1 : 0;
-
- //=== Initialize random number generator
- dw_initialize_generator(seed);
-
- //=== Setup model and initial parameters
- fprintf(stdout,"Reading data...\n");
- if (!(model=CreateTStateModelFromEstimateFinal(nargs,args,&cmd)))
- {
- fprintf(stderr,"Unable to read model or parameters\n");
- exit(1);
- }
- p=(T_VAR_Parameters*)(model->theta);
-
- //=== Open header file and print headers
- filename=CreateFilenameFromTag("%sheader_%s.dat",cmd->out_tag,cmd->out_directory);
- f_out=fopen(filename,"wt");
- free(filename);
- WriteBaseTransitionMatricesFlat_Headers_SV(f_out,model->sv,"");
- Write_VAR_ParametersFlat_Headers(f_out,model);
- fprintf(f_out,"\n");
- fclose(f_out);
-
- //=== Open output file
- filename=CreateFilenameFromTag("%sdraws_%s.dat",cmd->out_tag,cmd->out_directory);
- f_out=fopen(filename,"wt");
- free(filename);
-
- // Burn-in period with calibration of jumping parameters
- fprintf(stdout,"Calibrating jumping parameters - %d draws\n",tuning);
- begin_time=(int)time((time_t*)NULL);
- AdaptiveMetropolisScale(model,tuning,1000,1,(FILE*)NULL); // tuning iterations - 1000 iterations before updating - verbose
- end_time=(int)time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
-
- // Reset parametrers
- if (!ReadTransitionMatrices((FILE*)NULL,cmd->parameters_filename_actual,cmd->parameters_header_actual,model)
- || !Read_VAR_Parameters((FILE*)NULL,cmd->parameters_filename_actual,cmd->parameters_header_actual,model))
- fprintf(stdout,"Unable to reset parameters after tuning\n");
-
- // Burn-in period
- fprintf(stdout,"Burn-in period - %d draws\n",burn_in);
- for (check=period, count=1; count <= burn_in; count++)
- {
- DrawAll(model);
-
- if (count == check)
- {
- check+=period;
- fprintf(stdout,"%d iterations completed out of %d\n",count,burn_in);
- }
- }
- end_time=(int)time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
- ResetMetropolisInformation(p);
-
- // Simulation
- fprintf(stdout,"Simulating - %d draws\n",iterations);
- for (check=period, output=thinning, count=1; count <= iterations; count++)
- {
- DrawAll(model);
-
- if (count == output)
- {
- WriteBaseTransitionMatricesFlat(f_out,model,"%lf ");
- if (nd1)
- Write_VAR_ParametersFlat_A0_Diagonal_One(f_out,model,"%lf ");
- else
- Write_VAR_ParametersFlat(f_out,model,"%lf ");
- fprintf(f_out,"\n");
- output+=thinning;
- }
-
- if (count == check)
- {
- check+=period;
- fprintf(stdout,"%d(%d) iterations completed out of %d(%d)\n",count,thinning,iterations,thinning);
- }
- }
- end_time=(int)time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
-
- // clean up
- fclose(f_out);
- FreeStateModel(model);
- Free_VARCommandLine(cmd);
-}
diff --git a/matlab/swz/c-code/sbvar/var/VARbase.c b/matlab/swz/c-code/sbvar/var/VARbase.c
deleted file mode 100644
index 10cf3d521bfbd8ee6cf6850aa92db1909533a78b..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/VARbase.c
+++ /dev/null
@@ -1,3736 +0,0 @@
-
-#include "VARbase.h"
-#include "VARio.h"
-#include "switch.h"
-#include "switchio.h"
-#include "dw_error.h"
-#include "matrix.h"
-#include "bmatrix.h"
-#include "dw_array.h"
-#include "dw_matrix_array.h"
-#include "dw_rand.h"
-#include "dw_matrix_rand.h"
-#include "dw_ascii.h"
-
-#include <math.h>
-#include <time.h>
-#include <stdlib.h>
-#include <string.h>
-
-//=== Private counter for improper normal distribution ===
-static int _VAR_IMPROPER_DISTRIBUTION_COUNTER = 0;
-int Reset_VAR_Improper_Distribution_Counter(void)
-{
- int rtrn=_VAR_IMPROPER_DISTRIBUTION_COUNTER;
- _VAR_IMPROPER_DISTRIBUTION_COUNTER=0;
- return rtrn;
-}
-
-int Get_VAR_Improper_Distribution_Counter(void)
-{
- return _VAR_IMPROPER_DISTRIBUTION_COUNTER;
-}
-
-#define BPLUS_ERR 1
-#define PSI_ERR 2
-#define LAMBDA_ERR 3
-
-static int _SINGULAR_ERROR = 0;
-
-static int _VERBOSE_COUNT = 0;
-FILE *V_FILE = (FILE*)NULL;
-
-void Increment_Verbose(void)
-{
- _VERBOSE_COUNT++;
-}
-
-void SetVerboseFile(FILE *f)
-{
- V_FILE=f;
-}
-
-int Get_VAR_Sigular_Error(void)
-{
- return _SINGULAR_ERROR;
-}
-
-TVector DrawNormal_InverseVariance_SVD(TVector x, TVector b, TMatrix S);
-TVector SingularInverseVariance_RecoveryAttempt(TVector x, TVector b, TMatrix S, TMatrix InversePrior, TStateModel *model, int code);
-//=========================================================
-
-
-//=== Private Utility Functions ===
-static int NumberStates(TMarkovStateVariable** sv, int n);
-//static int* CreateStateIndex(TMarkovStateVariable* top, TMarkovStateVariable** sv, int n);
-
-extern FILE *fptr_debug;
-
-/*******************************************************************************/
-/************************** Constructors/Destructors ***************************/
-/*******************************************************************************/
-void FreeTheta_VAR(T_VAR_Parameters *p)
-{
- int j;
- if (p)
- {
- // Free parameters
- dw_FreeArray(p->A0);
- dw_FreeArray(p->Aplus);
- dw_FreeArray(p->Zeta);
-
- // Free state variable translation
- dw_FreeArray(p->n_var_states);
- dw_FreeArray(p->var_states);
- dw_FreeArray(p->n_coef_states);
- dw_FreeArray(p->coef_states);
- dw_FreeArray(p->A0_states);
- dw_FreeArray(p->A0_column_states);
-
- // Free free parameters
- dw_FreeArray(p->dim_b0);
- dw_FreeArray(p->b0);
- dw_FreeArray(p->dim_bplus);
- dw_FreeArray(p->bplus);
-
- // Free Sims-Zha specification parameters and workspace
- dw_FreeArray(p->lambda);
-
- //--- Non-standard memory management ---
- if (p->constant)
- for (j=dw_DimA(p->constant)-1; j >= 0; j--)
- if (p->constant[j])
- pElementV(p->constant[j])=(PRECISION*)NULL;
- dw_FreeArray(p->constant);
- //--------------------------------------
-
- dw_FreeArray(p->psi);
- dw_FreeArray(p->inverse_psi_prior);
-
- // Free Priors
- FreeVector(p->zeta_a_prior);
- FreeVector(p->zeta_b_prior);
- dw_FreeArray(p->A0_prior);
- dw_FreeArray(p->Aplus_prior);
-
- // Free identifiying restrictions
- dw_FreeArray(p->U);
- dw_FreeArray(p->V);
- dw_FreeArray(p->W);
- dw_FreeArray(p->IsIdentity_V);
-
- // Free normalization
- dw_FreeArray(p->flipped);
- dw_FreeArray(p->Target);
-
- // Free workspace
- FreeVector(p->inverse_zeta_b_prior);
- dw_FreeArray(p->inverse_b0_prior);
- dw_FreeArray(p->inverse_bplus_prior);
- FreeVector(p->log_abs_det_A0);
- dw_FreeArray(p->A0_dot_products);
- dw_FreeArray(p->Aplus_dot_products);
-
- // Free state dependent fields
- dw_FreeArray(p->YY);
- dw_FreeArray(p->XY);
- dw_FreeArray(p->XX);
- dw_FreeArray(p->yy);
- dw_FreeArray(p->xy);
- dw_FreeArray(p->xx);
- dw_FreeArray(p->S);
- dw_FreeArray(p->T);
-
- // A0 Metropolis Info
- dw_FreeArray(p->A0_Metropolis_Scale);
- dw_FreeArray(p->A0_Metropolis_Jumps);
-
- // Free Data
- dw_FreeArray(p->Y);
- dw_FreeArray(p->X);
-
- // Free pointer
- free(p);
- }
-}
-
-ThetaRoutines* CreateRoutines_VAR(void)
-{
- ThetaRoutines *rtns=CreateThetaRoutines_empty();
-
- rtns->pLogConditionalLikelihood=LogConditionalProbability_VAR;
- rtns->pExpectationSingleStep=ExpectationSingleStep_VAR;
- rtns->pDestructor=(void (*)(void*))FreeTheta_VAR;
- rtns->pLogPrior=LogPrior_VAR;
- rtns->pNumberFreeParametersTheta=NumberFreeParametersVAR;
- rtns->pConvertFreeParametersToTheta=FreeParametersToVAR;
- rtns->pConvertThetaToFreeParameters=VARToFreeParameters;
- rtns->pDrawParameters=DrawParameters_VAR;
- rtns->pStatesChanged=StatesChanged_VAR;
- rtns->pThetaChanged=ThetaChanged_VAR;
- rtns->pInitializeForwardRecursion=InitializeForwardRecursion_VAR;
-
- return rtns;
-}
-
-T_VAR_Parameters* CreateTheta_VAR(int flag, int nvars, int nlags, int nexg, int nstates, int nobs, // Specification and Sizes
- int **coef_states, int **var_states, // Translation Tables
- TMatrix *U, TMatrix *V, TMatrix *W, // Restrictions
- TMatrix Y, TMatrix X) // Data
-{
- T_VAR_Parameters *p;
- int i, j, k, t, npre;
- TMatrix S;
-
- if ((nvars <= 0) || (nlags < 0) || (nexg < 0))
- {
- fprintf(stderr,"CreateTheta_VAR(): Invalid arguments passed.\n");
- exit(0);
- }
-
- //=== Allocate memory for T_VAR_Parameters ===
- if (!(p=(T_VAR_Parameters*)malloc(sizeof(T_VAR_Parameters))))
- {
- fprintf(stderr,"Out of memory\n");
- exit(0);
- }
-
- //=== Model Specification ===
- if (flag & SPEC_SIMS_ZHA) flag|=SPEC_RANDOM_WALK;
- p->Specification=flag;
-
- //====== Flags ======
- p->valid_state_dependent_fields=0;
- p->valid_state_dependent_fields_previous=0;
- p->valid_log_abs_det_A0=0;
- p->valid_dot_products=0;
- p->valid_parameters=0;
-
- //=== Sizes ===//
- p->nobs=nobs;
- p->nstates=nstates;
- p->nvars=nvars;
- p->nlags=nlags;
- p->npre=npre=nvars*nlags+nexg;
-
- //====== Create n_coef_states, n_var_states ======
- p->n_coef_states=(int*)dw_CreateArray_int(nvars);
- p->n_var_states=(int*)dw_CreateArray_int(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- for (p->n_coef_states[j]=0, i=p->nstates-1; i >= 0; i--)
- if (coef_states[j][i] > p->n_coef_states[j])
- p->n_coef_states[j]=coef_states[j][i];
- p->n_coef_states[j]++;
-
- for (p->n_var_states[j]=0, i=nstates-1; i >= 0; i--)
- if (var_states[j][i] > p->n_var_states[j])
- p->n_var_states[j]=var_states[j][i];
- p->n_var_states[j]++;
- }
-
- //====== Create coef_states, var_states ======
- p->coef_states=(int**)dw_CopyArray((void*)NULL,coef_states);
- p->var_states=(int**)dw_CopyArray((void*)NULL,var_states);
-
- //====== Create A0, Aplus, Zeta ======
- p->A0=(TVector**)dw_CreateArray_array(nvars);
- p->Aplus=(TVector**)dw_CreateArray_array(nvars);
- p->Zeta=(PRECISION**)dw_CreateArray_array(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- p->A0[j]=dw_CreateArray_vector(p->n_coef_states[j]);
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- p->A0[j][k]=CreateVector(nvars);
-
- p->Aplus[j]=(TVector*)dw_CreateArray_vector(p->n_coef_states[j]);
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- p->Aplus[j][k]=CreateVector(npre);
-
- p->Zeta[j]=(PRECISION*)dw_CreateArray_scalar(p->n_var_states[j]);
- }
-
- //====== A0 Metropolis Info ======
- p->A0_Metropolis_Scale=dw_CreateArray_array(nvars);
- for (j=nvars-1; j >= 0; j--)
- p->A0_Metropolis_Scale[j]=dw_CreateArray_scalar(p->n_coef_states[j]);
- dw_InitializeArray_scalar(p->A0_Metropolis_Scale,1.0);
-
- p->A0_Metropolis_Jumps=dw_CreateArray_array(nvars);
- for (j=nvars-1; j >= 0; j--)
- p->A0_Metropolis_Jumps[j]=dw_CreateArray_int(p->n_coef_states[j]);
- dw_InitializeArray_int(p->A0_Metropolis_Jumps,0);
-
- //====== Create A0_states, A0_column_states, and log_det_abs_A0 ======
- p->A0_states=dw_CreateArray_int(nstates);
- for (p->n_A0_states=0, i=0; i < nstates; i++)
- {
- for (k=i-1; k >= 0; k--)
- {
- for (j=nvars-1; j >= 0; j--)
- if (coef_states[j][i] != coef_states[j][k]) break;
- if (j < 0) break;
- }
- p->A0_states[i]=(k < 0) ? p->n_A0_states++ : p->A0_states[k];
- }
-
- p->A0_column_states=dw_CreateRectangularArray_int(nvars,p->n_A0_states);
- for (i=0; i < p->n_A0_states; i++)
- for (k=0; k < nstates; k++)
- if (p->A0_states[k] == i)
- {
- for (j=nvars-1; j >= 0; j--)
- p->A0_column_states[j][i]=coef_states[j][k];
- break;
- }
-
- InitializeVector(p->log_abs_det_A0=CreateVector(p->n_A0_states),-1.0);
-
- //=== Set Restrictions ===
- p->U=dw_CopyArray(NULL,U);
- p->b0=(TVector**)dw_CreateArray_array(nvars);
- p->dim_b0=dw_CreateArray_int(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- p->b0[j]=(TVector*)dw_CreateArray_vector(p->n_coef_states[j]);
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- p->b0[j][k]=CreateVector(p->dim_b0[j]=ColM(U[j]));
- }
-
- //=== Normalization ===
- p->normalization_type=VAR_NORMALIZATION_NONE;
- p->Target=(TVector**)NULL;
- p->flipped=(int**)NULL;
- p->WZ_inconsistancies=0;
-
- //=== Specification ===
- if (flag & SPEC_RANDOM_WALK)
- {
- p->W=dw_CreateArray_matrix(nvars);
- InitializeMatrix(S=CreateMatrix(npre,nvars),0.0);
- for (j=nvars-1; j >= 0; j--) ElementM(S,j,j)=-1.0;
- for (j=nvars-1; j >= 0; j--) p->W[j]=EquateMatrix((TMatrix)NULL,S);
- FreeMatrix(S);
- }
- else
- p->W=dw_CopyArray((void*)NULL,W);
-
- if (flag & SPEC_SIMS_ZHA)
- {
- dw_InitializeArray_int(p->IsIdentity_V=dw_CreateArray_int(nvars),1);
- p->V=dw_CreateArray_matrix(nvars);
- for (j=p->nvars-1; j >= 0; j--) p->V[j]=IdentityMatrix((TMatrix)NULL,npre);
-
- // Setup psi and lambda parameters
- p->lambda=(TVector**)dw_CreateArray_array(nvars);
- p->psi=dw_CreateArray_vector(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- p->lambda[j]=dw_CreateArray_vector(p->n_coef_states[j]);
- for (k=dw_DimA(p->lambda[j])-1; k >= 0; k--)
- p->lambda[j][k]=CreateVector(nvars);
-
- p->psi[j]=CreateVector(npre - 1 + p->n_coef_states[j]);
- }
-
- //--- non-standard memory management ---
- p->constant=(TVector*)dw_CreateArray_vector(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- p->constant[j]=CreateVector(p->n_coef_states[j]);
- free(pElementV(p->constant[j]));
- pElementV(p->constant[j])=pElementV(p->psi[j]) + npre - 1;
- }
- //--------------------------------------
- }
- else
- {
- //====== Sims-Zha Specification ======
- p->lambda=(TVector**)NULL;
- p->psi=(TVector*)NULL;
- p->constant=(TVector*)NULL;
-
- //====== If the number of columns in V[j] == npre then we may assume that V[j] is the identity. ======
- dw_InitializeArray_int(p->IsIdentity_V=dw_CreateArray_int(nvars),0);
- p->V=dw_CreateArray_matrix(nvars);
- for (j=nvars-1; j >= 0; j--)
- if (V[j])
- if (ColM(V[j]) < npre)
- p->V[j]=EquateMatrix((TMatrix)NULL,V[j]);
- else
- {
- p->V[j]=IdentityMatrix((TMatrix)NULL,npre);
- p->IsIdentity_V[j]=1;
- }
- }
- p->bplus=(TVector**)dw_CreateArray_array(nvars);
- p->dim_bplus=dw_CreateArray_int(nvars);
- for (j=nvars-1; j >= 0; j--)
- if (V[j])
- {
- p->bplus[j]=(TVector*)dw_CreateArray_vector(p->n_coef_states[j]);
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- p->bplus[j][k]=CreateVector(p->dim_bplus[j]=ColM(V[j]));
- }
-
- //====== Data ======
- p->Y=dw_CreateArray_vector(nobs+1);
- p->X=dw_CreateArray_vector(nobs+1);
- for (t=nobs; t > 0; t--)
- {
- p->Y[t]=CreateVector(nvars);
- for (i=nvars-1; i >= 0; i--) ElementV(p->Y[t],i)=ElementM(Y,t-1,i);
-
- p->X[t]=CreateVector(p->npre);
- for (i=p->npre-1; i >= 0; i--) ElementV(p->X[t],i)=ElementM(X,t-1,i);
- }
-
- //====== Workspace ======
- p->minus_half_nvars_times_log2pi=-0.5*(double)nvars*log(2.0*3.141592653589793);
-
- // Dot products
- p->A0_dot_products=(PRECISION***)dw_CreateArray_array(nobs+1);
- for (t=0; t <= nobs; t++)
- {
- p->A0_dot_products[t]=(PRECISION**)dw_CreateArray_array(nvars);
- for (j=0; j < nvars; j++)
- p->A0_dot_products[t][j]=dw_CreateArray_scalar(p->n_coef_states[j]);
- }
-
- p->Aplus_dot_products=(PRECISION***)dw_CreateArray_array(nobs+1);
- for (t=0; t <= nobs; t++)
- {
- p->Aplus_dot_products[t]=(PRECISION**)dw_CreateArray_array(nvars);
- for (j=0; j < nvars; j++)
- p->Aplus_dot_products[t][j]=dw_CreateArray_scalar(p->n_coef_states[j]);
- }
-
- // State dependent data
- p->T=dw_CreateArray_int(nstates);
- p->YY=dw_CreateArray_matrix(nstates);
- p->XY=dw_CreateArray_matrix(nstates);
- p->XX=dw_CreateArray_matrix(nstates);
- for (k=nstates-1; k >= 0; k--)
- {
- p->YY[k]=CreateMatrix(nvars,nvars);
- p->XY[k]=CreateMatrix(p->npre,nvars);
- p->XX[k]=CreateMatrix(p->npre,p->npre);
- }
- p->yy=dw_CreateArray_matrix(nobs+1);
- p->xy=dw_CreateArray_matrix(nobs+1);
- p->xx=dw_CreateArray_matrix(nobs+1);
- p->S=dw_CreateArray_int(nobs+1);
- for (t=nobs; t > 0; t--)
- {
- p->yy[t]=OuterProduct((TMatrix)NULL,p->Y[t],p->Y[t]);
- p->xy[t]=OuterProduct((TMatrix)NULL,p->X[t],p->Y[t]);
- p->xx[t]=OuterProduct((TMatrix)NULL,p->X[t],p->X[t]);
- }
-
- //====== Set Priors to null ======
- p->A0_prior=(TMatrix*)NULL;
- p->Aplus_prior=(TMatrix*)NULL;
- p->zeta_a_prior=(TVector)NULL;
- p->zeta_b_prior=(TVector)NULL;
- p->lambda_prior=0.0;
-
- p->inverse_b0_prior=(TMatrix*)NULL;
- p->inverse_bplus_prior=(TMatrix*)NULL;
- p->inverse_zeta_b_prior=(TVector)NULL;
- p->inverse_lambda_prior=0.0;
- p->inverse_psi_prior=(TMatrix*)NULL;
-
- //====== Return ======
- return p;
-}
-
-void SetPriors_VAR(T_VAR_Parameters *theta, TMatrix* A0_prior, TMatrix* Aplus_prior, TVector zeta_a_prior, TVector zeta_b_prior)
-{
- int j;
- TMatrix S;
-
- //====== Priors ======
- theta->A0_prior=dw_CopyArray(NULL,A0_prior);
- theta->Aplus_prior=dw_CopyArray(NULL,Aplus_prior);
- theta->zeta_a_prior=EquateVector((TVector)NULL,zeta_a_prior);
- theta->zeta_b_prior=EquateVector((TVector)NULL,zeta_b_prior);
-
- //====== Prior workspace ======
- theta->inverse_zeta_b_prior=CreateVector(theta->nvars);
- for (j=theta->nvars-1; j >= 0; j--)
- ElementV(theta->inverse_zeta_b_prior,j)=1.0/ElementV(zeta_b_prior,j);
-
- theta->inverse_b0_prior=dw_CreateArray_matrix(theta->nvars);
- for (j=theta->nvars-1; j >= 0; j--)
- {
- S=Inverse_LU((TMatrix)NULL,A0_prior[j]);
- theta->inverse_b0_prior[j]=MatrixInnerProductSymmetric((TMatrix)NULL,theta->U[j],S);
- ProductMS(theta->inverse_b0_prior[j],theta->inverse_b0_prior[j],theta->n_A0_states/theta->n_coef_states[j]);
- FreeMatrix(S);
- }
-
- theta->inverse_bplus_prior=dw_CreateArray_matrix(theta->nvars);
- for (j=theta->nvars-1; j >= 0; j--)
- if (theta->V[j])
- {
- S=Inverse_LU((TMatrix)NULL,Aplus_prior[j]);
- theta->inverse_bplus_prior[j]=MatrixInnerProductSymmetric((TMatrix)NULL,theta->V[j],S);
- ProductMS(theta->inverse_bplus_prior[j],theta->inverse_bplus_prior[j],theta->n_A0_states/theta->n_coef_states[j]);
- FreeMatrix(S);
- }
-
- //====== Set prior constant ======
- SetLogPriorConstant_VAR(theta);
-}
-
-void SetPriors_VAR_SimsZha(T_VAR_Parameters *theta, TMatrix* A0_prior, TMatrix* Aplus_prior, TVector zeta_a_prior,
- TVector zeta_b_prior, PRECISION lambda_prior)
-{
- int j, k, n, m;
- TMatrix V, S, I, inverse_Aplus_prior;
-
- if (theta->Specification & SPEC_SIMS_ZHA)
- {
- theta->lambda_prior=lambda_prior;
- theta->inverse_lambda_prior=1.0/lambda_prior;
-
- theta->inverse_psi_prior=dw_CreateArray_matrix(theta->nvars);
- for (j=theta->nvars-1; j >= 0; j--)
- {
- inverse_Aplus_prior=Inverse_LU((TMatrix)NULL,Aplus_prior[j]);
- I=IdentityMatrix((TMatrix)NULL,theta->n_A0_states);
- S=KroneckerProduct((TMatrix)NULL,I,inverse_Aplus_prior);
- InitializeMatrix(V=CreateMatrix(theta->npre * theta->n_A0_states,theta->npre-1 + theta->n_coef_states[j]),0.0);
- for (k=theta->n_A0_states-1; k >= 0; k--)
- {
- for (n=theta->npre-2; n >= 0; n--)
- for (m=theta->npre-1; m >= 0; m--)
- ElementM(V,k*theta->npre + m,n)=ElementM(theta->V[j],m,n);
-
- n=theta->npre - 1 + theta->A0_column_states[j][k];
- for (m=theta->npre-1; m >= 0; m--)
- ElementM(V,k * theta->npre + m,n)=ElementM(theta->V[j],m,theta->npre - 1);
- }
- theta->inverse_psi_prior[j]=MatrixInnerProductSymmetric((TMatrix)NULL,V,S);
- FreeMatrix(V);
- FreeMatrix(S);
- FreeMatrix(I);
- FreeMatrix(inverse_Aplus_prior);
- }
-
- SetPriors_VAR(theta,A0_prior,Aplus_prior,zeta_a_prior,zeta_b_prior);
- }
- else
- {
- printf("Error SetPriors_VAR_SimsZha(): specification flag not set to SPEC_SIM_ZHA\n");
- exit(0);
- }
-}
-
-/*
- Assumes
- model: a properly initialized TStateModel structure.
-
- Returns
- A properly initialized TStateModel structure with the same number of first
- level state variables, but only one overall state.
-*/
-TStateModel* CreateConstantModel(TStateModel *model)
-{
- TMarkovStateVariable *sv, **sv_array;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta), *theta;
- ThetaRoutines *routines;
- TMatrix X, Y;
- int **translation_table, i, j, t;
-
- if (model->sv->n_state_variables == 1)
- sv=CreateMarkovStateVariable_ConstantState(model->sv->nobs);
- else
- {
- sv_array=dw_CreateArray_pointer(model->sv->n_state_variables,(void (*)(void*))FreeMarkovStateVariable);
- for (i=model->sv->n_state_variables-1; i >= 0; i--)
- sv_array[i]=CreateMarkovStateVariable_ConstantState(model->sv->nobs);
- sv=CreateMarkovStateVariable_Multiple(model->sv->nobs,model->sv->n_state_variables,sv_array);
- }
-
- routines=CreateRoutines_VAR();
-
- Y=CreateMatrix(p->nobs,p->nvars);
- X=CreateMatrix(p->nobs,p->npre);
- for (t=p->nobs; t > 0; t--)
- {
- for (i=p->nvars-1; i >= 0; i--) ElementM(Y,t-1,i)=ElementV(p->Y[t],i);
- for (i=p->npre-1; i >= 0; i--) ElementM(X,t-1,i)=ElementV(p->X[t],i);
- }
-
- dw_InitializeArray_int(translation_table=dw_CreateRectangularArray_int(p->nvars,1),0);
- theta=CreateTheta_VAR(p->Specification,p->nvars,p->nlags,p->npre - p->nlags*p->nvars,1,p->nobs,translation_table,translation_table,p->U,p->V,p->W,Y,X);
- if (p->Specification & SPEC_SIMS_ZHA)
- SetPriors_VAR_SimsZha(theta,p->A0_prior,p->Aplus_prior,p->zeta_a_prior,p->zeta_b_prior,p->lambda_prior);
- else
- SetPriors_VAR(theta,p->A0_prior,p->Aplus_prior,p->zeta_a_prior,p->zeta_b_prior);
-
- FreeMatrix(X);
- FreeMatrix(Y);
- dw_FreeArray(translation_table);
-
- // Initialize parameters
- for (j=0; j < p->nvars; j++)
- {
- theta->Zeta[j][0]=p->Zeta[j][0];
- EquateVector(theta->A0[j][0],p->A0[j][0]);
- EquateVector(theta->Aplus[j][0],p->Aplus[j][0]);
- }
- Update_b0_bplus_from_A0_Aplus(theta);
- if ((theta->Specification & SPEC_SIMS_ZHA) == SPEC_SIMS_ZHA)
- Update_lambda_psi_from_bplus(theta);
- theta->valid_parameters=1;
-
- //InitializeParameters_VAR(theta);
-
- return CreateStateModel_new(sv,routines,theta);
-}
-
-/*
- Assumes
- table: Properly initialized translation table.
- restricted table: Properly initialize translation table.
-*/
-int **ExpandTranslationTable(int **table, TMarkovStateVariable *sv, TMarkovStateVariable *rsv, int s)
-{
- int i, j, k, nstates;
- int **rtable, *idx, *master;
-
- // Compute size of new table.
- for (nstates=1, k=sv->n_state_variables-1; k >= 0; k--)
- nstates*=(k == s) ? rsv->state_variable[k]->nstates + 1 : rsv->state_variable[k]->nstates;
-
- // Create new table
- dw_InitializeArray_int(rtable=dw_CreateRectangularArray_int(dw_DimA(table),nstates),0);
-
- // Fill table
- idx=(int*)malloc(sv->nstates*sizeof(int));
- master=(int*)malloc(nstates*sizeof(int));
- for (k=i=0; k < sv->nstates; k++)
- {
- for (j=sv->n_state_variables-1; j >= 0; j--)
- if (sv->Index[k][j] > rsv->state_variable[j]->nstates)
- break;
- else
- if ((j != s) && (sv->Index[k][j] == rsv->state_variable[j]->nstates))
- break;
- if (j == -1) master[i++]=k;
- }
- for (j=dw_DimA(table)-1; j >= 0; j--)
- {
- for (k=sv->nstates-1; k >= 0; k--) idx[k]=0;
- for (k=nstates-1; k >= 0; k--)
- idx[table[j][master[k]]]=1;
- for (k=i=0; k < sv->nstates; k++) idx[k]=idx[k] ? i++ : -1;
- for (k=nstates-1; k >= 0; k--)
- rtable[j][k]=idx[table[j][master[k]]];
- }
- free(master);
- free(idx);
-
- // verbose
- //dw_PrintArray(stdout,rtable,(char*)NULL); fprintf(stdout,"\n"); dw_PrintArray(stdout,table,(char*)NULL); getchar();
- //dw_PrintArray(stdout,sv->Index,(char*)NULL); getchar();
-
- return rtable;
-}
-
-/*
- Assumes
- model:
- Properly intialized TStateModel structure. The Markov state variable
- structure must be flat with the same number state variables as
- restricted_model. Each state variable must have as least as many states
- as the corresponding state variable in restricted_model.
-
- restricted_model:
- Properly intialized TStateModel structure. The Markov state variable
- structure must be flat with the same number state variables as model. Each
- state variable must have no more states as the corresponding state
- variable in model.
-
- s:
- The state variable to expand. It must be the case that s is between 0 and
- model->n_state_variables - 1, inclusive, and that the number of states in
- the sth state variable of model is strictly larger than the number of
- states in the sth state variable of restricted_model.
-
- Returns
- Properly initialized TStateModel structure with in which the sth state
- variable has one more state.
-
- Notes
- A Markov state variable structure is flat if state_variable[i] is a single
- Markov state variable for 0 <= i < n_state_variables.
-*/
-TStateModel* ExpandModel_VAR(TStateModel *model, TStateModel *restricted_model, int s)
-{
- int i, j, k, m, q, t;
- TStateModel *expanded_model;
- T_VAR_Parameters *p=model->theta, *restricted_p=restricted_model->theta, *expanded_p;
- TMarkovStateVariable *sv=model->sv, *restricted_sv=restricted_model->sv, *expanded_sv, **sv_array;
- TMatrix X, Y;
- int **coef_table, **var_table;
-
- // Check sizes
- if ((p->nvars != restricted_p->nvars) || (p->nlags != restricted_p->nlags)
- || (p->npre != restricted_p->npre) || (p->nobs != restricted_p->nobs)
- || (sv->n_state_variables != restricted_sv->n_state_variables)
- || (s < 0) || (s > sv->n_state_variables))
- return (TStateModel*)NULL;
-
- for (k=sv->n_state_variables-1; k >= 0; k--)
- if (sv->state_variable[k]->nstates < restricted_sv->state_variable[k]->nstates) return (TStateModel*)NULL;
-
- if (sv->state_variable[s]->nstates == restricted_sv->state_variable[s]->nstates) return (TStateModel*)NULL;
-
- // Check VAR Restrictions
-
- // Check VAR Priors
-
- // Setup new Markov state variable
- sv_array=dw_CreateArray_pointer(sv->n_state_variables,(void (*)(void*))FreeMarkovStateVariable);
- for (k=model->sv->n_state_variables-1; k >= 0; k--)
- if (k != s)
- sv_array[k]=DuplicateMarkovStateVariable(restricted_sv->state_variable[k]);
- else
- sv_array[s]=RestrictMarkovStateVariable(sv->state_variable[k],restricted_sv->state_variable[k]->nstates+1);
-
- // Create multiple Markov state variable
- if (sv->n_state_variables == 1)
- {
- expanded_sv=sv_array[0];
- sv_array[0]=(TMarkovStateVariable*)NULL;
- dw_FreeArray(sv_array);
- }
- else
- expanded_sv=CreateMarkovStateVariable_Multiple(sv->nobs,sv->n_state_variables,sv_array);
-
- // Data
- Y=CreateMatrix(p->nobs,p->nvars);
- X=CreateMatrix(p->nobs,p->npre);
- for (t=p->nobs; t > 0; t--)
- {
- for (i=p->nvars-1; i >= 0; i--) ElementM(Y,t-1,i)=ElementV(p->Y[t],i);
- for (i=p->npre-1; i >= 0; i--) ElementM(X,t-1,i)=ElementV(p->X[t],i);
- }
-
- // Setup new translation tables
- coef_table=ExpandTranslationTable(p->coef_states,model->sv,restricted_model->sv,s);
- var_table=ExpandTranslationTable(p->var_states,model->sv,restricted_model->sv,s);
-
- // Setup new VAR
- expanded_p=CreateTheta_VAR(p->Specification,p->nvars,p->nlags,p->npre - p->nlags*p->nvars,expanded_sv->nstates,p->nobs,coef_table,var_table,p->U,p->V,p->W,Y,X);
- if (p->Specification & SPEC_SIMS_ZHA)
- SetPriors_VAR_SimsZha(expanded_p,p->A0_prior,p->Aplus_prior,p->zeta_a_prior,p->zeta_b_prior,p->lambda_prior);
- else
- SetPriors_VAR(expanded_p,p->A0_prior,p->Aplus_prior,p->zeta_a_prior,p->zeta_b_prior);
-
- // Create expanded model
- expanded_model=CreateStateModel_new(expanded_sv,CreateRoutines_VAR(),expanded_p);
-
- // Clean up
- FreeMatrix(X);
- FreeMatrix(Y);
- dw_FreeArray(coef_table);
- dw_FreeArray(var_table);
-
- // Set VAR parameters
- for (j=0; j < p->nvars; j++)
- {
- for (k=expanded_p->n_var_states[j]-1; k >= 0; k--)
- {
- for (i=expanded_p->nstates-1; i >= 0; i--)
- if (expanded_p->var_states[j][i] == k) break;
-
- for (q=m=0; q <= s; q++) m=m*expanded_sv->state_variable[q]->nstates + expanded_sv->Index[i][q];
- if (expanded_sv->Index[i][s] == expanded_sv->state_variable[s]->nstates - 1) m--;
- for ( ; q < expanded_sv->n_state_variables; q++) m=m*expanded_sv->state_variable[q]->nstates + expanded_sv->Index[i][q];
-
- expanded_p->Zeta[j][k]=restricted_p->Zeta[j][restricted_p->var_states[j][m]];
- }
-
- for (k=expanded_p->n_coef_states[j]-1; k >= 0; k--)
- {
- for (i=expanded_p->nstates-1; i >= 0; i--)
- if (expanded_p->coef_states[j][i] == k) break;
-
- for (q=m=0; q <= s; q++) m=m*expanded_sv->state_variable[q]->nstates + expanded_sv->Index[i][q];
- if (expanded_sv->Index[i][s] == expanded_sv->state_variable[s]->nstates - 1) m--;
- for ( ; q < expanded_sv->n_state_variables; q++) m=m*expanded_sv->state_variable[q]->nstates + expanded_sv->Index[i][q];
-
- EquateVector(expanded_p->A0[j][k],restricted_p->A0[j][restricted_p->coef_states[j][m]]);
- EquateVector(expanded_p->Aplus[j][k],restricted_p->Aplus[j][restricted_p->coef_states[j][m]]);
- }
- }
- Update_b0_bplus_from_A0_Aplus(expanded_p);
- if ((expanded_p->Specification & SPEC_SIMS_ZHA) == SPEC_SIMS_ZHA)
- Update_lambda_psi_from_bplus(expanded_p);
- expanded_p->valid_parameters=1;
-
- // Set transition matrices
- if (!restricted_model->sv->valid_transition_matrix)
- {
- FreeStateModel(expanded_model);
- return (TStateModel*)NULL;
- }
- for (k=expanded_sv->n_state_variables-1; k >= 0; k--)
- {
- if (k != s)
- {
- //EquateMatrix(expanded_sv->state_variable[k]->Q,restricted_sv->state_variable[k]->Q);
- //Update_B_from_Q_SV(expanded_sv->state_variable[k]);
-
- EquateMatrix(expanded_sv->state_variable[k]->Q,restricted_sv->state_variable[k]->Q);
- EquateVector(expanded_sv->state_variable[k]->B,restricted_sv->state_variable[k]->B);
- }
- else
- {
-/* j=restricted_sv->state_variable[k]->nstates; */
-/* for (i=0; i <= restricted_sv->state_variable[k]->nstates; i++) */
-/* for (j=0; j <= restricted_sv->state_variable[k]->nstates; j++) */
-/* ElementM(expanded_sv->state_variable[k]->Q,i,j)=0.5; */
-//=====================================================================================================================
-/* j=restricted_sv->state_variable[k]->nstates; */
-/* InsertSubMatrix(expanded_sv->state_variable[k]->Q,restricted_sv->state_variable[k]->Q,0,0,0,0,j,j); */
-/* for (i=j; i >= 0; i--) */
-/* { */
-/* ElementM(expanded_sv->state_variable[k]->Q,i,j)=0.0; */
-/* ElementM(expanded_sv->state_variable[k]->Q,j,i)=0.0; */
-/* } */
-/* ElementM(expanded_sv->state_variable[k]->Q,j,j)= 0.5*ElementM(expanded_sv->state_variable[k]->Q,j-1,j-1); */
-/* ElementM(expanded_sv->state_variable[k]->Q,j-1,j)=0.5*ElementM(expanded_sv->state_variable[k]->Q,j-1,j-1); */
-/* for (i=0; i < j-1; i++) */
-/* ElementM(expanded_sv->state_variable[k]->Q,i,j)= ElementM(expanded_sv->state_variable[k]->Q,i,j-1); */
-/* Update_B_from_Q_SV(expanded_sv->state_variable[k]); */
-//=====================================================================================================================
- // Draw states for restricted model
- DrawStates(restricted_model);
-
- // Copy states for kth state variable
- dw_CopyArray(expanded_sv->state_variable[k]->S,restricted_sv->state_variable[k]->S);
-
- //dw_PrintArray(stdout,expanded_sv->state_variable[k]->S,(char*)NULL); getchar();
-
- // Draw transition matrix for kth state variable
- DrawTransitionMatrix_SV(expanded_sv->state_variable[k]);
-//=====================================================================================================================
- // Then new state for the sth state variable is made to be reflecting
-/* j=restricted_sv->state_variable[k]->nstates; */
-/* InsertSubMatrix(expanded_sv->state_variable[k]->Q,restricted_sv->state_variable[k]->Q,0,0,0,0,j,j); */
-/* for (i=j; i >= 0; i--) */
-/* { */
-/* ElementM(expanded_sv->state_variable[k]->Q,i,j)=0.0; */
-/* ElementM(expanded_sv->state_variable[k]->Q,j,i)=0.0; */
-/* } */
-/* ElementM(expanded_sv->state_variable[k]->Q,j-1,j)=1.0; */
-/* Update_B_from_Q_SV(expanded_sv->state_variable[k]); */
- }
- }
- PropagateTransitionMatrices_SV(expanded_sv);
- // expanded_model->ValidTransitionMatrix=1;
- ValidateTransitionMatrices_SV(expanded_sv);
- // return
- return expanded_model;
-}
-
-
-
-
-/*
- The free transition matrix parameters are chosen to be equal.
-*/
-void FlatTransitionMatrix(TMarkovStateVariable *sv)
-{
- int i, j;
- PRECISION p;
- if (sv->n_state_variables == 1)
- {
- for (i=dw_DimA(sv->b)-1; i >= 0; i--)
- for (p=1.0/(PRECISION)DimV(sv->b[i]), j=DimV(sv->b[i])-1; j >= 0; j--)
- ElementV(sv->b[i],j)=p;
- Update_Q_from_B_SV(sv);
- }
- else
- {
- for (i=sv->n_state_variables-1; i >= 0; i--)
- FlatTransitionMatrix(sv->state_variable[i]);
- MatrixTensor(sv->Q,sv->QA);
- }
-}
-
-/*
-
-*/
-int NestTransitionMatrices_SV(TMarkovStateVariable *sv, TMarkovStateVariable *restricted_sv)
-{
- int i, j;
- PRECISION tmp;
- if (sv->n_state_variables < restricted_sv->n_state_variables) return 0;
- if (sv->n_state_variables == 1)
- if (sv->nstates < restricted_sv->nstates)
- return 0;
- else
- {
- for (i=0; i < restricted_sv->nstates-1; i++)
- {
- for (j=0; j < restricted_sv->nstates; j++)
- ElementM(sv->Q,i,j)=ElementM(restricted_sv->Q,i,j);
- for (tmp=ElementM(restricted_sv->Q,i,j-1); j < sv->nstates; j++)
- ElementM(sv->Q,i,j)=tmp;
- }
-
- for (j=0; j < restricted_sv->nstates; j++)
- {
- tmp=ElementM(restricted_sv->Q,restricted_sv->nstates-1,j)/(double)(sv->nstates - restricted_sv->nstates + 1);
- // tmp=0.0;
- for (i=restricted_sv->nstates-1; i < sv->nstates; i++)
- ElementM(sv->Q,i,j)=tmp;
- }
- for ( ; j < sv->nstates; j++)
- for (i=restricted_sv->nstates-1; i < sv->nstates; i++)
- ElementM(sv->Q,i,j)=tmp;
-
- return Update_B_from_Q_SV(sv);
- }
- else
- {
- for (i=sv->n_state_variables-1; i >= restricted_sv->n_state_variables; i--)
- FlatTransitionMatrix(sv->state_variable[i]);
- for ( ; i >= 0; i--)
- if (!NestTransitionMatrices_SV(sv->state_variable[i],restricted_sv->state_variable[i]))
- return 0;
- MatrixTensor(sv->Q,sv->QA);
- }
- return 1;
-}
-
-/*
- Sets the parameters of model so that it is equivalent to the parameters of
- restricted_model. Currently, the routine only checks that the sizes of the
- two models are the same. It should be the case that the restrictions are
- also identical.
-*
-int NestModel_VAR(TStateModel *model, TStateModel *restricted_model)
-{
- int j, k;
- T_VAR_Parameters *p=model->theta, *restricted_p=restricted_model->theta;
-
- // Set transition matrices
- if (!restricted_model->ValidTransitionMatrix || !NestTransitionMatrices_SV(model->sv,restricted_model->sv))
- return 0;
- else
- model->ValidTransitionMatrix=1;
-
- // Check VAR sizes
- if ((p->nvars != restricted_p->nvars) || (p->nlags != restricted_p->nlags)
- || (p->npre != restricted_p->npre) || (p->nobs != restricted_p->nobs))
- return 0;
-
- // Set VAR parameters
- for (j=0; j < p->nvars; j++)
- {
- if (p->n_var_states[j] < restricted_p->n_var_states[j]) return 0;
- for (k=0; k < restricted_p->n_var_states[j]; k++)
- p->Zeta[j][k]=restricted_p->Zeta[j][k];
- for ( ; k < p->n_var_states[j]; k++)
- p->Zeta[j][k]=restricted_p->Zeta[j][restricted_p->n_var_states[j]-1];
-
- if (p->n_coef_states[j] < restricted_p->n_coef_states[j]) return 0;
- for (k=0; k < restricted_p->n_coef_states[j]; k++)
- {
- EquateVector(p->A0[j][k],restricted_p->A0[j][k]);
- EquateVector(p->Aplus[j][k],restricted_p->Aplus[j][k]);
- }
- for ( ; k < p->n_coef_states[j]; k++)
- {
- EquateVector(p->A0[j][k],restricted_p->A0[j][restricted_p->n_coef_states[j]-1]);
- EquateVector(p->Aplus[j][k],restricted_p->Aplus[j][restricted_p->n_coef_states[j]-1]);
- }
- }
- Update_b0_bplus_from_A0_Aplus(model->theta);
- return 1;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/*************************** Workspace computations ****************************/
-/*******************************************************************************/
-void ComputeDotProducts_All(T_VAR_Parameters *p)
-{
- TVector *Y=p->Y, *X=p->X;
- int t, j, k;
-
- for (t=p->nobs; t > 0; t--)
- for (j=p->nvars-1; j >= 0; j--)
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- {
- p->A0_dot_products[t][j][k]=DotProduct(Y[t],p->A0[j][k]);
- p->Aplus_dot_products[t][j][k]=DotProduct(X[t],p->Aplus[j][k]);
- }
-
- p->valid_dot_products=1;
-
-}
-
-/*
- Assumes:
- p: A valid T_VAR_Parameters structure and p->A0 has been initialized.
-
- Results:
- Fill the vector p->log_abs_det_A0 with the natural logarithm of the the
- abso
-*/
-void ComputeLogAbsDetA0_All(T_VAR_Parameters *p)
-{
- TMatrix A0;
- int j, k=DimV(p->log_abs_det_A0)-1;
-
- A0=CreateMatrix(p->nvars,p->nvars);
-
- //=== Set initial A0 ===
- for (j=p->nvars-1; j >= 0; j--)
- memcpy(&ElementM(A0,0,j),pElementV(p->A0[j][p->A0_column_states[j][k]]),p->nvars*sizeof(PRECISION));
-
- ElementV(p->log_abs_det_A0,k)=LogAbsDeterminant_LU(A0);
-
- while (--k >= 0)
- {
- //=== Reset A0 ===
- for (j=p->nvars-1; j >= 0; j--)
- if (p->A0_column_states[j][k] != p->A0_column_states[j][k+1])
- memcpy(&ElementM(A0,0,j),pElementV(p->A0[j][p->A0_column_states[j][k]]),p->nvars*sizeof(PRECISION));
-
- ElementV(p->log_abs_det_A0,k)=LogAbsDeterminant_LU(A0);
- }
-
- FreeMatrix(A0);
-
- p->valid_log_abs_det_A0=1;
-}
-
-/*
- Computes the log of the absolute value of the determinant of A0(s) if
- A0_column_states[j][s] == k.
-*/
-void ComputeLogAbsDetA0(int j, int k, T_VAR_Parameters *p)
-{
- TMatrix A0;
- int i, s;
-
- A0=CreateMatrix(p->nvars,p->nvars);
-
- for (s=DimV(p->log_abs_det_A0)-1; s >= 0; s--)
- if (p->A0_column_states[j][s] == k)
- {
- for (i=p->nvars-1; i >= 0; i--)
- memcpy(&ElementM(A0,0,i),pElementV(p->A0[i][p->A0_column_states[i][s]]),p->nvars*sizeof(PRECISION));
-
- ElementV(p->log_abs_det_A0,s)=LogAbsDeterminant_LU(A0);
- }
-
- FreeMatrix(A0);
-}
-
-/*
- If p->A_state_variable is non-negative, then it controls A0 and Aplus. If
- p->A_state_variable is negative, then A0 and Aplus are constant across states.
-
- If Xi is not null and p->Xi_state_variable is non-negative, then it controls
- Xi. If Xi is not null and p->Xi_state_variable is negative, then Xi is
- constant across states. If Xi is null, then this parameter does not appear.
-
- -n*log(2*pi)/2 + log|A0[i]| + log|diag(Xi[j])|
- - (Y[t]'*A0[i] - X[t]'*Aplus[i])*diag(Xi[j])*diag(Xi[j])*(Y[t]'*A0[i] - X[t]'*Aplus[i])/2
-*/
-PRECISION LogConditionalProbability_VAR(int s, int t, TStateModel *model)
-{
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
- PRECISION x, y, sum=0.0, logdet=0.0;
- int j;
-
- if (!(p->valid_parameters)) return MINUS_INFINITY;
-
- //====== Computes log(abs(det(A0[i]))) and log(abs(det(Xi))) ======
- if (!p->valid_log_abs_det_A0) ComputeLogAbsDetA0_All(p);
-
- //====== Compute quadratic form ======
- if (p->valid_dot_products)
- for (j=p->nvars-1; j >= 0; j--)
- {
- y=p->Zeta[j][p->var_states[j][s]];
- x=p->A0_dot_products[t][j][p->coef_states[j][s]]
- - p->Aplus_dot_products[t][j][p->coef_states[j][s]];
- if (y <= 0)
- return MINUS_INFINITY;
- else
- logdet+=log(y);
- sum+=y*x*x;
- }
- else
- for (j=p->nvars-1; j >= 0; j--)
- {
- y=p->Zeta[j][p->var_states[j][s]];
- x=DotProduct(p->Y[t],p->A0[j][p->coef_states[j][s]])
- - DotProduct(p->X[t],p->Aplus[j][p->coef_states[j][s]]);
- if (y <= 0)
- return MINUS_INFINITY;
- else
- logdet+=log(y);
- sum+=y*x*x;
- }
-
- //====== Get log(det(A0)) ======
- logdet=0.5*logdet + ElementV(p->log_abs_det_A0,p->A0_states[s]);
-
- return p->minus_half_nvars_times_log2pi + logdet - 0.5*sum;
-}
-
-/*
- Since
-
- y(t)' * A0(s(t)) = x(t)' * Aplus(s(t)) + epsilon(t)' * Inverse(Xi(s(t)))
-
- The expectation is
-
- y(t)' = x(t)' * Aplus(s(t)) * Inverse(A0(s(t))
-*/
-TVector ExpectationSingleStep_VAR(TVector y, int s, int t, TStateModel *model)
-{
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
- TMatrix A0, Aplus;
-
- if ((t < 1) || (p->nobs < t))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
-
- A0=MakeA0((TMatrix)NULL,s,p);
- Aplus=MakeAplus((TMatrix)NULL,s,p);
-
- if (!y && !(y=CreateVector(p->nvars)))
- return (TVector)y;
-
- ProductVM(y,p->X[t],Aplus);
- ProductInverseVM(y,y,A0);
-
- FreeMatrix(Aplus);
- FreeMatrix(A0);
-
- return y;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/******************************** Notification *********************************/
-void StatesChanged_VAR(TStateModel *model)
-{
- ((T_VAR_Parameters*)(model->theta))->valid_state_dependent_fields=0;
-}
-
-void ThetaChanged_VAR(TStateModel *model)
-{
- ((T_VAR_Parameters*)(model->theta))->valid_log_abs_det_A0
- =((T_VAR_Parameters*)(model->theta))->valid_dot_products=0;
-}
-
-void InitializeForwardRecursion_VAR(TStateModel *model)
-{
- if (!((T_VAR_Parameters*)(model->theta))->valid_dot_products)
- ComputeDotProducts_All((T_VAR_Parameters*)(model->theta));
-}
-
-/*******************************************************************************/
-/********************************* Simulations *********************************/
-/*******************************************************************************/
-void DrawParameters_VAR(TStateModel *model)
-{
- // Draw unnormalized theta
- DrawZeta_DotProducts(model);
- DrawA0_Metropolis(model);
- DrawAplus(model);
-
- // Normalize
- Normalize_VAR((T_VAR_Parameters*)(model->theta));
-
- // Flags and notification that the VAR parameters have changed
- ((T_VAR_Parameters*)(model->theta))->valid_parameters=1;
- ThetaChanged(model);
-}
-
-/*
- Choose a random initial value for the VAR parameters. The function
- ThetaChanged() cannot be called.
-*/
-void InitializeParameters_VAR(T_VAR_Parameters *p)
-{
- int j, s;
- TMatrix X;
-
- // Initialize Zeta to one
- for (j=p->nvars-1; j >= 0; j--)
- for (s=p->n_var_states[j]-1; s >= 0; s--)
- p->Zeta[j][s]=1;
-
- // Draw b0 from prior - identical across states A0[j][s] = U[j]*b0[j][s].
- for (j=p->nvars-1; j >= 0; j--)
- {
- X=CholeskyUT((TMatrix)NULL,p->inverse_b0_prior[j]);
- Inverse_UT(X,X);
- dw_NormalVector(p->b0[j][0]);
- ProductMV(p->b0[j][0],X,p->b0[j][0]);
- ProductMV(p->A0[j][0],p->U[j],p->b0[j][0]);
- for (s=p->n_coef_states[j]-1; s > 0; s--)
- EquateVector(p->A0[j][s],p->A0[j][0]);
- FreeMatrix(X);
- }
-
- // Set Aplus[j][s] = W[j]*A0[j][s].
- for (j=p->nvars-1; j >= 0; j--)
- {
- if (!p->W[j])
- InitializeVector(p->Aplus[j][0],0.0);
- else
- ProductMV(p->Aplus[j][0],p->W[j],p->A0[j][0]);
- for (s=p->n_coef_states[j]-1; s > 0; s--)
- EquateVector(p->Aplus[j][s],p->Aplus[j][0]);
- }
-
- // Update b0, bplus, lambda, psi
- Update_b0_bplus_from_A0_Aplus(p);
- if ((p->Specification & SPEC_SIMS_ZHA) == SPEC_SIMS_ZHA) Update_lambda_psi_from_bplus(p);
-
- // Flags and notification that the VAR parameters have changed
- p->valid_parameters=1;
-}
-
-//-----------------------------------------------------------------------------//
-//--------------------------------- Draw Zeta ---------------------------------//
-//-----------------------------------------------------------------------------//
-void DrawZeta_Aplus(TStateModel *model)
-{
- int j, k, s, T;
- PRECISION v;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- if (!p->valid_state_dependent_fields) UpdateStateDependentFields(p,model->sv->S);
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- for (s=p->n_var_states[j]-1; s > 0; s--)
- {
- v=0.0;
- T=0;
- for (k=p->nstates-1; k >= 0; k--)
- {
- if (p->var_states[j][k] == s)
- {
- v+=InnerProductSymmetric(p->A0[j][p->coef_states[j][k]],p->YY[k])
- - 2.0 * InnerProductNonSymmetric(p->Aplus[j][p->coef_states[j][k]],p->A0[j][p->coef_states[j][k]],p->XY[k])
- + InnerProductSymmetric(p->Aplus[j][p->coef_states[j][k]],p->XX[k]);
- T+=p->T[k];
- }
- }
- p->Zeta[j][s]=dw_gamma_rnd(0.5*(PRECISION)T + ElementV(p->zeta_a_prior,j))/(0.5*v + ElementV(p->inverse_zeta_b_prior,j));
- }
-
- //=== State 0 is normalized to one
- p->Zeta[j][0]=1.0;
- }
-}
-
-void DrawZeta_DotProducts(TStateModel *model)
-{
- int j, s, t;
- PRECISION x;
- TVector v, T;
- int *S=model->sv->S;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
-
- if (!p->valid_dot_products) ComputeDotProducts_All(p);
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- v=InitializeVector(CreateVector(p->n_var_states[j]),0.0);
- T=InitializeVector(CreateVector(p->n_var_states[j]),0.0);
- for (t=p->nobs; t > 0; t--)
- {
- s=p->coef_states[j][S[t]];
- x=p->A0_dot_products[t][j][s] - p->Aplus_dot_products[t][j][s];
- s=p->var_states[j][S[t]];
- ElementV(v,s)+=x*x;
- ElementV(T,s)+=1.0;
- }
- for (s=p->n_var_states[j]-1; s > 0; s--)
- p->Zeta[j][s]=dw_gamma_rnd(0.5*ElementV(T,s) + ElementV(p->zeta_a_prior,j))/(0.5*ElementV(v,s) + ElementV(p->inverse_zeta_b_prior,j));
- FreeVector(v);
- FreeVector(T);
-
- //=== State 0 is normalized to one
- p->Zeta[j][0]=1.0;
- }
-}
-
-//-----------------------------------------------------------------------------//
-//-------------------------- Metropolis Draws of A0 ---------------------------//
-//-----------------------------------------------------------------------------//
-#define MID 0.35
-#define LOG_MID -1.0498221244987
-#define LOWER_BOUND 0.0052521875
-#define UPPER_BOUND 0.81061308309895
-void AdaptiveMetropolisScale(TStateModel *model, int iterations, int period, int verbose, FILE *f_posterior)
-{
- struct TAdaptive
- {
- int begin_jump_ratio;
- int iterations;
- int end_iteration_count;
- PRECISION best_scale;
- PRECISION low_scale;
- PRECISION low_jump_ratio;
- PRECISION high_scale;
- PRECISION high_jump_ratio;
- } ***Adaptive;
-
- PRECISION new_scale, new_jump_ratio;
- int j, k, begin_time, count, check=period;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- Adaptive=(struct TAdaptive***)dw_CreateArray_array(p->nvars);
- for (j=p->nvars-1; j >= 0; j--)
- {
- Adaptive[j]=(struct TAdaptive**)dw_CreateArray_pointer(p->n_coef_states[j],free);
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- {
- Adaptive[j][k]=((struct TAdaptive*)malloc(sizeof(struct TAdaptive)));
- Adaptive[j][k]->begin_jump_ratio=p->A0_Metropolis_Jumps[j][k];
- Adaptive[j][k]->iterations=period;
- Adaptive[j][k]->end_iteration_count=period;
- Adaptive[j][k]->low_scale=Adaptive[j][k]->low_jump_ratio=Adaptive[j][k]->high_scale=Adaptive[j][k]->high_jump_ratio=-1.0;
- Adaptive[j][k]->best_scale=p->A0_Metropolis_Scale[j][k];
- }
- }
-
- ResetMetropolisInformation(p);
-
- if (verbose)
- {
- printf("Beginning adaptive burn in -- %d iterations.\n",iterations);
- begin_time=(int)time((time_t*)NULL);
- }
-
- for (count=1; count <= iterations; count++)
- {
- DrawAll(model);
- if (count == check)
- {
- if (f_posterior) fprintf(f_posterior,"%le\n",LogPosterior_StatesIntegratedOut(model));
-
- if (verbose)
- printf("%d iterations completed out of %d - elapsed time: %d seconds\n",count,iterations,(int)time((time_t*)NULL) - begin_time);
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- if (Adaptive[j][k]->end_iteration_count == count)
- {
- // Compute new jump ratio and get scale
- new_jump_ratio=(PRECISION)(p->A0_Metropolis_Jumps[j][k] - Adaptive[j][k]->begin_jump_ratio)
- /(PRECISION)(Adaptive[j][k]->iterations);
-
- // Set new low or high bounds
- if (new_jump_ratio < MID)
- {
- Adaptive[j][k]->low_scale=p->A0_Metropolis_Scale[j][k];
- Adaptive[j][k]->low_jump_ratio=new_jump_ratio;
- }
- else
- {
- Adaptive[j][k]->high_scale=p->A0_Metropolis_Scale[j][k];
- Adaptive[j][k]->high_jump_ratio=new_jump_ratio;
- }
-
- // Compute new scale and best scale
- if (Adaptive[j][k]->low_jump_ratio < 0.0)
- {
- Adaptive[j][k]->best_scale=Adaptive[j][k]->high_scale;
- if (Adaptive[j][k]->low_scale < 0.0)
- new_scale=((new_jump_ratio > UPPER_BOUND) ? 5.0 : LOG_MID/log(new_jump_ratio))*Adaptive[j][k]->high_scale;
- else
- {
- new_scale=Adaptive[j][k]->low_scale;
- Adaptive[j][k]->low_scale=-1;
- }
- }
- else
- if (Adaptive[j][k]->high_jump_ratio < 0.0)
- {
- Adaptive[j][k]->best_scale=Adaptive[j][k]->low_scale;
- if (Adaptive[j][k]->high_scale < 0.0)
- new_scale=((new_jump_ratio < LOWER_BOUND) ? 0.2 : LOG_MID/log(new_jump_ratio))*Adaptive[j][k]->low_scale;
- else
- {
- new_scale=Adaptive[j][k]->high_scale;
- Adaptive[j][k]->high_scale=-1.0;
- }
- }
- else
- {
- new_scale=Adaptive[j][k]->best_scale=0.5*(Adaptive[j][k]->low_scale + Adaptive[j][k]->high_scale);
- //Adaptive[j][k]->iterations+=period;
- Adaptive[j][k]->iterations*=2;
- Adaptive[j][k]->low_jump_ratio=Adaptive[j][k]->high_jump_ratio=-1.0;
- }
-
- // Print data
- if (verbose)
- printf("col: %d state: %d (%d %lf %lf %lf)\n",j+1,k+1,p->A0_Metropolis_Jumps[j][k],
- new_jump_ratio,p->A0_Metropolis_Scale[j][k],new_scale);
-
- // Reset adaptive counts and A0_Metropolis_Scale
- Adaptive[j][k]->begin_jump_ratio=p->A0_Metropolis_Jumps[j][k];
- Adaptive[j][k]->end_iteration_count+=Adaptive[j][k]->iterations;
- p->A0_Metropolis_Scale[j][k]=new_scale;
- }
- else
- if (verbose)
- {
- new_jump_ratio=(PRECISION)(p->A0_Metropolis_Jumps[j][k] - Adaptive[j][k]->begin_jump_ratio)
- /(PRECISION)(Adaptive[j][k]->iterations - (Adaptive[j][k]->end_iteration_count - count));
-
- printf("col: %d state: %d (%d %lf %lf -)\n",j+1,k+1,p->A0_Metropolis_Jumps[j][k],
- new_jump_ratio,p->A0_Metropolis_Scale[j][k]);
- }
- }
-
- if (verbose) printf("\n");
-
- check+=period;
- }
- }
-
- for (j=p->nvars-1; j >= 0; j--)
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- p->A0_Metropolis_Scale[j][k]=Adaptive[j][k]->best_scale;
-
- ResetMetropolisInformation(p);
-
- dw_FreeArray(Adaptive);
-}
-#undef MID
-#undef UPPER
-#undef LOWER
-
-void SetupMetropolisInformation(PRECISION **Scale, T_VAR_Parameters *p)
-{
- dw_CopyArray(p->A0_Metropolis_Scale,Scale);
- ResetMetropolisInformation(p);
-}
-
-void ResetMetropolisInformation(T_VAR_Parameters *p)
-{
- p->Total_A0_Metropolis_Draws=0;
- dw_InitializeArray_int(p->A0_Metropolis_Jumps,0);
-}
-
-static void GetProposedJump_A0(TVector b, int j, int k, T_VAR_Parameters *p)
-{
- TMatrix YY, XX, XY, S, M0, M1;
- int s;
- PRECISION x;
- int terminal_errors;
-
- // Accumulate XX, XY, and YY
- InitializeMatrix(XX=CreateMatrix(p->npre,p->npre),0.0);
- InitializeMatrix(XY=CreateMatrix(p->npre,p->nvars),0.0);
- InitializeMatrix(YY=CreateMatrix(p->nvars,p->nvars),0.0);
- for (s=p->nstates-1; s >= 0; s--)
- if (p->coef_states[j][s] == k)
- {
- x=p->Zeta[j][p->var_states[j][s]];
- UpdateMS(XX,p->XX[s],x);
- UpdateMS(XY,p->XY[s],x);
- UpdateMS(YY,p->YY[s],x);
- }
-
- // S = inverse_b0_prior + U[j]'*(YY + W[j]'*XY + XY'*W[j] + W[j]'*XX*W[j])*U[j]
- if (p->W[j])
- {
- // M0 = W[j]'*(XX*W[j] + XY) + (XY'*W[j])
- M0=ProductMM((TMatrix)NULL,XX,p->W[j]);
- AddMM(M0,M0,XY);
- M1=TransposeProductMM((TMatrix)NULL,p->W[j],M0);
- AddMM(YY,YY,M1);
- TransposeProductMM(M1,XY,p->W[j]);
- AddMM(YY,YY,M1);
- FreeMatrix(M1);
- FreeMatrix(M0);
- }
- S=MatrixInnerProductSymmetric((TMatrix)NULL,p->U[j],YY);
- //dw_PrintMatrix(stdout,S,"%.17le "); fprintf(stdout,"\n");
- AddMM(S,S,p->inverse_b0_prior[j]);
-
- //dw_PrintMatrix(stdout,S,"%.17le "); fgetc(stdin);
-
- // Simulate draw
- terminal_errors=dw_SetTerminalErrors(NO_ERR);
- dw_NormalVector(b);
- if (!InverseProductUV(b,CholeskyUT(S,S),b))
- {
- fprintf(stdout,"Error in GetProposedJump_A0()\n");
- fprintf(stdout,"j = %d, k = %d\n,Prior =\n",j,k);
- dw_PrintMatrix(stdout,p->inverse_b0_prior[j],"%lg ");
- fprintf(stdout,"S =\n");
- dw_PrintMatrix(stdout,S,"%lg ");
- exit(1);
- }
- dw_SetTerminalErrors(terminal_errors);
-/* else */
-/* { */
-/* fprintf(stdout,"GetProposedJump_A0()\n"); */
-/* fprintf(stdout,"j = %d, k = %d\n,Prior =\n",j,k); */
-/* dw_PrintMatrix(stdout,p->inverse_b0_prior[j],"%lg "); */
-/* fprintf(stdout,"S =\n"); */
-/* dw_PrintMatrix(stdout,S,"%lg "); */
-/* getchar(); */
-/* } */
-
- // Scale factor
- ProductVS(b,b,p->A0_Metropolis_Scale[j][k]);
-
- // Free memory
- FreeMatrix(S);
- FreeMatrix(YY);
- FreeMatrix(XY);
- FreeMatrix(XX);
-}
-
-/*
- Assumes
- j column
- k state A0[j], 0 <= k < dw_DimA(A[j])
- p pointer to valid T_VAR_Parameters structure
-
- Returns
- The log of the density of a[j][k] conditional on all other parameters.
-
- Notes
- Uses the following information in model->parametes = p and model->data = d.
-
- p->XX[], p->XY[], p->YY, p->nobs_by_state[], p->log_det_abs_A0[]
-
- p->A0[j][k], p->b0[j][k], p->Aplus[j][k], p->Xi[j][]
-
- p->coef_states[j][], p->var_states[j][], p->A0_states[],
- p->inverse_b0_prior[j]
-*/
-PRECISION LogKernel_A0(int j, int k, TStateModel *model)
-{
- int s;
- PRECISION rtrn;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
-
- //====== Prior ======
- rtrn=-0.5*InnerProductSymmetric(p->b0[j][k],p->inverse_b0_prior[j]);
-
- for (s=p->nstates-1; s >= 0; s--)
- if (p->coef_states[j][s] == k)
- rtrn+=ElementV(p->log_abs_det_A0,p->A0_states[s]) * p->T[s]
- - 0.5 * p->Zeta[j][p->var_states[j][s]] * (InnerProductSymmetric(p->A0[j][k],p->YY[s])
- - 2.0*InnerProductNonSymmetric(p->Aplus[j][k],p->A0[j][k],p->XY[s])
- + InnerProductSymmetric(p->Aplus[j][k],p->XX[s]));
- return rtrn;
-}
-
-PRECISION LogKernel_A0_DotProduct(int j, int k, TStateModel *model)
-{
- int s, t;
- int* S=model->sv->S;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
- PRECISION x, rtrn;
-
- //====== Prior ======
- rtrn=-0.5*InnerProductSymmetric(p->b0[j][k],p->inverse_b0_prior[j]);
-
- for (t=model->sv->nobs; t > 0; t--)
- if (p->coef_states[j][s=S[t]] == k)
- {
- x=DotProduct(p->Y[t],p->A0[j][k]) - DotProduct(p->X[t],p->Aplus[j][k]);
- rtrn+=ElementV(p->log_abs_det_A0,p->A0_states[s]) - 0.5*p->Zeta[j][p->var_states[j][s]]*x*x;
- }
-
- return rtrn;
-}
-
-/*
- Assumes:
- p - pointer to a valid T_VAR_Parameter structure
- Jumps - null pointer or pointer to a 2-dimensional integer array with the
- first dimensional at lease p->nvars and the second dimension at
- least the dimension of p->A0[j].
-
- Results:
- New values for p->b0 and p->A0 are obtained using the Metropolis algorithm.
- If Jumps is not null, then Jump[j][k] is updated for all the Metropolis
- jumps that were accepted.
-
- Notes:
- Calls GetA0MetropolisJumpSize() to get the variance for the normal jumping
- kernel used in this algorithm. Calls LogConditionalDensity_A0() to compute
- the appropriate posterior density.
-*/
-void DrawA0_Metropolis(TStateModel *model)
-{
- int j, k;
- PRECISION old_log_kernel, log_difference;
- TVector old_b0, old_a0, old_aplus, old_log_abs_det_A0;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- if (!p->valid_state_dependent_fields) UpdateStateDependentFields(p,model->sv->S);
-
- old_a0=CreateVector(p->nvars);
- old_aplus=CreateVector(p->npre);
- old_log_abs_det_A0=CreateVector(DimV(p->log_abs_det_A0));
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- old_b0=CreateVector(DimV(p->b0[j][0]));
-
- for (k=dw_DimA(p->A0[j])-1; k >= 0; k--)
- {
- //=== Save old values ===
- EquateVector(old_b0,p->b0[j][k]);
- EquateVector(old_a0,p->A0[j][k]);
- EquateVector(old_aplus,p->Aplus[j][k]);
- EquateVector(old_log_abs_det_A0,p->log_abs_det_A0);
- old_log_kernel=LogKernel_A0(j,k,model);
- //old_log_kernel=LogKernel_A0_DotProduct(j,k,model);
-
- //=== Jump ===
- GetProposedJump_A0(p->b0[j][k],j,k,p);
- AddVV(p->b0[j][k],p->b0[j][k],old_b0);
- ProductMV(p->A0[j][k],p->U[j],p->b0[j][k]);
- Update_aplus_from_bplus_a0(j,k,p);
- ComputeLogAbsDetA0(j,k,p);
-
- //=== Accept Jump ===
- log_difference=LogKernel_A0(j,k,model) - old_log_kernel;
- //log_difference=LogKernel_A0_DotProduct(j,k,model) - old_log_kernel;
- if ((log_difference >= 0.0) || (dw_uniform_rnd() < exp(log_difference)))
- {
- p->A0_Metropolis_Jumps[j][k]++;
- p->valid_dot_products=0;
- }
- else
- {
- EquateVector(p->b0[j][k],old_b0);
- EquateVector(p->A0[j][k],old_a0);
- EquateVector(p->Aplus[j][k],old_aplus);
- EquateVector(p->log_abs_det_A0,old_log_abs_det_A0);
- }
- }
-
- FreeVector(old_b0);
- }
-
- FreeVector(old_log_abs_det_A0);
- FreeVector(old_aplus);
- FreeVector(old_a0);
-
- p->Total_A0_Metropolis_Draws++;
-}
-
-//-----------------------------------------------------------------------------//
-//-------------------------------- Draw Aplus ---------------------------------//
-//-----------------------------------------------------------------------------//
-/*
- The following matrices must be updated before calling this routine:
-
- p->A0 p->Xi p->XX p->XY
-
- The following matrices are used in this routine
-
- p->V p->W p->coef_states p->var_states p->inverse_bplus_prior
-
- The following matrices are modified in this routine
-
- p->bplus p->Aplus
-*/
-void DrawAplus(TStateModel *model)
-{
- int j, k, s;
- TMatrix S, XX, XY, M;
- TVector v;
- PRECISION x;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
-
- if (!p->valid_state_dependent_fields)
- UpdateStateDependentFields(p,model->sv->S);
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- Draw_psi(model);
- Draw_lambda(model);
- Update_bplus_from_lambda_psi(p);
- }
- else
- {
- XX=CreateMatrix(p->npre,p->npre);
- XY=CreateMatrix(p->npre,p->nvars);
- v=CreateVector(p->npre);
-
- for (j=p->nvars-1; j >= 0; j--)
- if (p->bplus[j])
- {
- S=CreateMatrix(p->dim_bplus[j],p->dim_bplus[j]);
-
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- {
- InitializeMatrix(XX,0.0);
- InitializeMatrix(XY,0.0);
- for (s=p->nstates-1; s >= 0; s--)
- if (p->coef_states[j][s] == k)
- {
- x=p->Zeta[j][p->var_states[j][s]];
- UpdateMS(XX,p->XX[s],x);
- UpdateMS(XY,p->XY[s],x);
- }
-
- //=== Compute inverse variance ===
- if (!p->IsIdentity_V[j])
- MatrixInnerProductSymmetric(S,p->V[j],XX);
- else
- EquateMatrix(S,XX);
- AddMM(S,S,p->inverse_bplus_prior[j]);
-
- //=== Compute b ===
- if (p->W[j])
- if (p->Specification & SPEC_RANDOM_WALK)
- if (MajorForm(XY) && MajorForm(XX))
- bSubtract(pElementM(XY),pElementM(XY),pElementM(XX),RowM(XX)*p->nvars);
- else
- {
- M=SubMatrix((TMatrix)NULL,XX,0,0,RowM(XX),p->nvars);
- SubtractMM(XY,XY,M);
- FreeMatrix(M);
- }
- else
- {
- M=ProductMM((TMatrix)NULL,XX,p->W[j]);
- AddMM(XY,XY,M);
- FreeMatrix(M);
- }
- if (!p->IsIdentity_V[j])
- {
- ProductMV(v,XY,p->A0[j][k]);
- TransposeProductMV(p->bplus[j][k],p->V[j],v);
- }
- else
- ProductMV(p->bplus[j][k],XY,p->A0[j][k]);
-
- //=== Draw bplus ===
- if (!DrawNormal_InverseVariance(p->bplus[j][k],p->bplus[j][k],S))
- SingularInverseVariance_RecoveryAttempt(p->bplus[j][k],p->bplus[j][k],S,p->inverse_bplus_prior[j],model,BPLUS_ERR);
- }
-
- FreeMatrix(S);
- }
-
- FreeMatrix(XX);
- FreeMatrix(XY);
- FreeVector(v);
- }
-
- Update_Aplus_from_bplus_A0(p);
- ThetaChanged(model);
-}
-
-//-----------------------------------------------------------------------------//
-//--------------------------------- Draw psi ----------------------------------//
-//-----------------------------------------------------------------------------//
-/*
- Assumes:
- S: (n*b + j) x (n*b + j) matrix with j > k. S must be column major.
- XX: (n*b + 1) x (n*b + 1) matrix. XX must be column major.
- lambda: n dimensional vector.
-
- Results:
- Adds
-
- PSI[k]'*diag(LAMBDA*lambda + e)*XX*diag(LAMBDA*lambda + e)*PSI[k]
-
- to S. The matrices LAMBDA and PSI[k] are given by
-
- - -
- | I(n) |
- | . | - -
- | . | | I(n*b) 0(n*b,j) |
- LAMBDA = | . | PSI[k] = | |
- | | | 0(1,n*b) e(j,k+1)'|
- | I(n) | - -
- | 0(1,n) |
- - -
-
- where I(r) is the r x r identity matrix, 0(r,s) is the r x s zero matrix,
- and e(r,s) is the sth column of I(r). e is the vector e(n*b+1,n*b+1).
-
- Notes:
- k is a zero based index.
-*/
-void update_psi_quadratic_form(TMatrix S, int n, int m, int k, TVector lambda, TMatrix XX)
-{
- int i, j, p, u=n*m-1, v;
- PRECISION *x, *s, *z=pElementV(lambda), w;
-
- s=pElementM(S)+(n*m+k)*RowM(S)+u;
- x=pElementM(XX)+n*m*RowM(XX)+u;
- s[k+1]=x[1];
- for (v=m-1; v >= 0; v--)
- for (i=n-1; i >= 0; s--, x--, i--)
- (*s)+=z[i]*(*x);
- for (p=n-1, j=u; j >= 0; p--, j--)
- {
- if (p < 0) p=n-1;
- w=z[p];
- s=pElementM(S)+j*RowM(S)+u;
- x=pElementM(XX)+j*RowM(XX)+u;
- s[k+1]=x[1]*w;
- for (v=m-1; v >= 0; v--)
- for (i=n-1; i >= 0; s--, x--, i--)
- (*s)+=z[i]*(*x)*w;
- }
-}
-
-/*
- Assmes:
- model: point to a valid TStateModel structure
-
- Results:
- A draw of psi conditional on A0,
-
- Notes:
- The matrices MUST be in column major format. Basic matrix routines from
- bmatrix.c are called in this routine.
-*/
-void Draw_psi(TStateModel *model)
-{
- int j, k, s, i, m;
- TVector b, v;
- TMatrix S, XX, XY;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
-
- // Update state dependent matrices if necessary
- if (!p->valid_state_dependent_fields)
- UpdateStateDependentFields(p,model->sv->S);
-
- // Allocate memory
- XX=CreateMatrix(p->npre,p->npre);
- XY=CreateMatrix(p->npre,p->nvars);
- v=CreateVector(p->npre);
-
- if (_VERBOSE_COUNT)
- fprintf(V_FILE,"//=== Draw_psi() (count = %d) =====================================//\n",_VERBOSE_COUNT);
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- InitializeVector(b=CreateVector(DimV(p->psi[j])),0.0);
- InitializeMatrix(S=CreateMatrix(DimV(p->psi[j]),DimV(p->psi[j])),0.0);
-
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- {
- // Accumulate XX and YY
- InitializeMatrix(XX,0.0);
- InitializeMatrix(XY,0.0);
- for (s=p->nstates-1; s >= 0; s--)
- if (p->coef_states[j][s] == k)
- {
- UpdateMS(XX,p->XX[s],p->Zeta[j][p->var_states[j][s]]);
- UpdateMS(XY,p->XY[s],p->Zeta[j][p->var_states[j][s]]);
- }
-
- // XY + XX*W[j]
- bSubtract(pElementM(XY),pElementM(XY),pElementM(XX),p->npre*p->nvars);
-
- // (XY + XX*W[j])*a0[j][k]
- ProductMV(v,XY,p->A0[j][k]);
-
- // b += PSI[k]'*diag(LAMBDA*lambda[j][k]+e)*(XY + XX*W[j])*a0[j][k]
- ElementV(b,p->npre-1+k)+=ElementV(v,i=p->npre-1);
- for (i--; i >= 0; )
- for (m=p->nvars-1; m >= 0; i--, m--)
- ElementV(b,i)+=ElementV(p->lambda[j][k],m)*ElementV(v,i);
-
- // S += PSI[k]'*diag(LAMBDA*lambda[j][k]+e)*XX*diag(LAMBDA*lambda[j][k]+e)*PSI[k]
- update_psi_quadratic_form(S,p->nvars,p->nlags,k,p->lambda[j][k],XX);
-
- if (_VERBOSE_COUNT)
- {
- fprintf(V_FILE,"//=== (j = %d k = %d) ===//\n",j,k);
- fprintf(V_FILE,"XX =\n");
- dw_PrintMatrix(V_FILE,XX,"%lg ");
-
- fprintf(V_FILE,"lambda[%d][%d] =\n",j,k);
- dw_PrintVector(V_FILE,p->lambda[j][k],"%lg ");
-
- fprintf(V_FILE,"S =\n");
- dw_PrintMatrix(V_FILE,S,"%lg ");
- }
- }
-
- // Add inverse prior
- AddMM(S,S,p->inverse_psi_prior[j]);
-
-/* TMatrix U,V; */
-/* TVector d; */
-/* int size=RowM(p->inverse_psi_prior[j]); */
-/* printf("inverse psi prior (%d)\n",j); */
-/* SVD(U=CreateMatrix(size,size),d=CreateVector(size),V=CreateMatrix(size,size),p->inverse_psi_prior[j]); */
-/* dw_PrintVector(stdout,d,"%lg "); */
-/* FreeMatrix(U); FreeMatrix(V); FreeVector(d); */
-/* getchar(); */
- if (_VERBOSE_COUNT)
- {
- fprintf(V_FILE,"inverse prior=\n");
- dw_PrintMatrix(V_FILE,p->inverse_psi_prior[j],"%lg ");
-
- fprintf(V_FILE,"S =\n");
- dw_PrintMatrix(V_FILE,S,"%lg ");
- fprintf(V_FILE,"//=====================================================================//\n");
- }
-
- // Draw psi[j]
- if (!DrawNormal_InverseVariance(p->psi[j],b,S))
- SingularInverseVariance_RecoveryAttempt(p->psi[j],b,S,p->inverse_psi_prior[j],model,PSI_ERR);
-
- FreeMatrix(S);
- FreeVector(b);
- }
-
- FreeVector(v);
- FreeMatrix(XY);
- FreeMatrix(XX);
-}
-
-//-----------------------------------------------------------------------------//
-//-------------------------------- Draw lambda --------------------------------//
-//-----------------------------------------------------------------------------//
-/*
- Assumes:
- S: n x n matrix.
- XX: (n*b + 1) x (n*b + 1) symmetric matrix. XX must be column major.
- psi: (n*b+j) dimensional vector with j > 0.
-
- Results:
- Set S to
-
- LAMBDA'*diag(PSI[k]*psi)*XX*diag(PSI[k]*psi)*LAMBDA
-
- to S. The matrices LAMBDA and PSI[k] are given by
-
- - -
- | I(n) |
- | . | - -
- | . | | I(n*b) 0(n*b,j) |
- LAMBDA = | . | PSI[k] = | |
- | | | 0(1,n*b) e(j,k)' |
- | I(n) | - -
- | 0(1,n) |
- - -
-
- where I(r) is the r x r identity matrix, 0(r,s) is the r x s zero matrix,
- and e(r,s) is the sth column of I(r).
-
- Notes:
- Even though PSI[k] depends on k, the term diag(PSI[k]*psi)*LAMBDA does not.
- For this reason, k is not passed.
-*/
-void lambda_quadratic_form(TMatrix S, int b, TVector psi, TMatrix XX)
-{
- int bj, j, i, r, n=RowM(S);
- PRECISION *x=pElementM(XX)+(b*n-1)*RowM(XX), *y, *z=pElementV(psi), w;
- InitializeMatrix(S,0.0);
- for (bj=b-1; bj >= 0; bj--)
- for (y=pElementM(S)+(n-1)*n, j=n-1; j >= 0; x-=RowM(XX), y-=n, j--)
- {
- w=z[bj*n+j];
- for (r=b*n-1; r >= 0; )
- for (i=n-1; i >= 0; r--, i--)
- y[i]+=z[r]*x[r]*w;
- }
-}
-
-/*
-
- Notes:
- The matrices MUST be in column major format. Basic matrix routines from
- bmatrix.c are called in this routine.
-*/
-void Draw_lambda(TStateModel *model)
-{
- int j, k, s, i, m;
- TVector b, v;
- TMatrix S, XX, XY;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
-
- // Update state dependent matrices if necessary
- if (!p->valid_state_dependent_fields)
- UpdateStateDependentFields(p,model->sv->S);
-
- // Allocate memory
- XX=CreateMatrix(p->npre,p->npre);
- XY=CreateMatrix(p->npre,p->nvars);
- v=CreateVector(p->npre);
- b=CreateVector(p->nvars);
- S=CreateMatrix(p->nvars,p->nvars);
-
- if (_VERBOSE_COUNT)
- fprintf(V_FILE,"//=== Draw_psi() (count = %d) =====================================//\n",_VERBOSE_COUNT);
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- for (k=p->n_coef_states[j]-1; k > 0; k--)
- {
- // Accumulate XX and XY
- InitializeMatrix(XX,0.0);
- InitializeMatrix(XY,0.0);
- for (s=p->nstates-1; s >= 0; s--)
- if (p->coef_states[j][s] == k)
- {
- UpdateMS(XX,p->XX[s],p->Zeta[j][p->var_states[j][s]]);
- UpdateMS(XY,p->XY[s],p->Zeta[j][p->var_states[j][s]]);
- }
-
- // Compute mean
- // XY + XX*W[j]
- bSubtract(pElementM(XY),pElementM(XY),pElementM(XX),p->npre*p->nvars);
-
- // (XY + XX*W[j])*a0[j][k]
- ProductMV(v,XY,p->A0[j][k]);
-
- // (XY + XX*W[j])*a0[j][k] - XX*diag(PSI[k]*psi[j])*e
- bLinearUpdateScalar(pElementV(v),pElementM(XX)+p->npre*(p->npre-1),-ElementV(p->constant[j],k),p->npre);
-
- // b = LAMBDA'*diag(PSI[j][k]*psi[j])*((XY + XX*W[j])*a0[j][k] - XX*diag(PSI[k]*psi[j])*lambda_hat)
- InitializeVector(b,0.0);
- for (i=p->npre-2; i >= 0; )
- for (m=p->nvars-1; m >= 0; i--, m--)
- ElementV(b,m)+=ElementV(p->psi[j],i)*ElementV(v,i);
-
- // Compute inverse variance matrix
- // S = LAMBDA'*diag(PSI[j][k]*psi[j])*XX*diag(PSI[j][k]*psi[j])*LAMBDA
- lambda_quadratic_form(S,p->nlags,p->psi[j],XX);
-
- for (i=p->nvars-1; i >= 0; i--) ElementM(S,i,i)+=p->inverse_lambda_prior;
-
- if (_VERBOSE_COUNT)
- {
- fprintf(V_FILE,"//=== (j = %d k = %d) ===//\n",j,k);
- fprintf(V_FILE,"XX =\n");
- dw_PrintMatrix(V_FILE,XX,"%lg ");
-
- fprintf(V_FILE,"psi[%d][%d] =\n",j,k);
- dw_PrintVector(V_FILE,p->psi[j],"%lg ");
-
- fprintf(V_FILE,"S =\n");
- dw_PrintMatrix(V_FILE,S,"%lg ");
-
- fprintf(V_FILE,"inverse prior = %lg\n",p->inverse_lambda_prior);
- }
-
- // Draw lambda[j][k]
- if (!DrawNormal_InverseVariance(p->lambda[j][k],b,S))
- {
- TMatrix InversePrior=IdentityMatrix((TMatrix)NULL,p->nvars);
- ProductMS(InversePrior,InversePrior,p->inverse_lambda_prior);
- SingularInverseVariance_RecoveryAttempt(p->lambda[j][k],b,S,InversePrior,model,LAMBDA_ERR);
- FreeMatrix(InversePrior);
- }
- }
-
- // State 0 normalized to one
- InitializeVector(p->lambda[j][k],1.0);
- }
-
- if (_VERBOSE_COUNT)
- fprintf(V_FILE,"//====================================================//\n");
-
- // Free memory
- FreeMatrix(S);
- FreeVector(b);
- FreeVector(v);
- FreeMatrix(XY);
- FreeMatrix(XX);
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/********************** Updating T_VAR_Parameter Fields ***********************/
-/******************************************************************************/
-void UpdateStateDependentFields(T_VAR_Parameters *p, int *S)
-{
- int i, s_prev, s_curr, t;
-
- dw_InitializeArray_int(p->T,0);
-
- if (!p->valid_state_dependent_fields_previous)
- {
- //=== Update Y'Y, X'Y, and X'X ===
- for (i=dw_DimA(p->YY)-1; i >= 0; i--)
- {
- InitializeMatrix(p->YY[i],0.0);
- InitializeMatrix(p->XY[i],0.0);
- InitializeMatrix(p->XX[i],0.0);
- }
- for (t=p->nobs; t > 0; t--)
- {
- s_curr=S[t];
- AddMM(p->YY[s_curr],p->YY[s_curr],p->yy[t]);
- AddMM(p->XY[s_curr],p->XY[s_curr],p->xy[t]);
- AddMM(p->XX[s_curr],p->XX[s_curr],p->xx[t]);
- p->T[s_curr]++;
- }
- //p->valid_state_dependent_fields_previous=1;
- }
- else
- {
- for (t=p->nobs; t > 0; t--)
- {
- if ((s_curr=S[t]) != (s_prev=p->S[t]))
- {
- SubtractMM(p->YY[s_prev],p->YY[s_prev],p->yy[t]);
- SubtractMM(p->XY[s_prev],p->XY[s_prev],p->xy[t]);
- SubtractMM(p->XX[s_prev],p->XX[s_prev],p->xx[t]);
- AddMM(p->YY[s_curr],p->YY[s_curr],p->yy[t]);
- AddMM(p->XY[s_curr],p->XY[s_curr],p->xy[t]);
- AddMM(p->XX[s_curr],p->XX[s_curr],p->xx[t]);
- }
- p->T[s_curr]++;
- }
- }
-
- //memcpy(p->S,S,(p->nobs+1)*sizeof(int));
-
- p->valid_state_dependent_fields=1;
-}
-
-/*
- Assumes:
- p: Pointer to valid T_VAR_Parameters structure with b0 updated.
-
- Results:
- Updates A0
-
- Notes:
- Uses the relation
-
- A0[j][k] = U[j]*b0[j][k]
-
-*/
-void Update_A0_from_B0(T_VAR_Parameters *p)
-{
- int j, k;
-
- for (j=p->nvars-1; j >= 0; j--)
- for (k=dw_DimA(p->A0[j])-1; k >= 0; k--)
- ProductMV(p->A0[j][k],p->U[j],p->b0[j][k]);
-}
-
-/*
- Sets
-
- Aplus[j][k] = V[j]*b0[j][k] - W[j]*A0[j][k]
-
- where 0 <= j < p->nvars and 0 <= k < p->n_coef_states[j].
-
- If (p->Specification & SPEC_RANDOMWALK) is set, uses the fact that
- W'[j] = [-I 0]. In this case a call to the base matrix function bAdd() is
- made.
-
- If p->IsIdentity_V[j] is set, uses the fact that V[j] = I.
-*/
-void Update_aplus_from_bplus_a0(int j, int k, T_VAR_Parameters *p)
-{
- TVector v;
-
- if (p->IsIdentity_V[j])
- if (p->W[j])
- if (p->Specification & SPEC_RANDOM_WALK)
- {
- bAdd(pElementV(p->Aplus[j][k]),pElementV(p->bplus[j][k]),pElementV(p->A0[j][k]),p->nvars);
- memcpy(pElementV(p->Aplus[j][k]) + p->nvars,pElementV(p->bplus[j][k]) + p->nvars,(p->npre - p->nvars)*sizeof(PRECISION));
- }
- else
- {
- ProductMV(p->Aplus[j][k],p->W[j],p->A0[j][k]);
- SubtractVV(p->Aplus[j][k],p->bplus[j][k],p->Aplus[j][k]);
- }
- else
- EquateVector(p->Aplus[j][k],p->bplus[j][k]);
- else
- if (p->V[j])
- {
- ProductMV(p->Aplus[j][k],p->V[j],p->bplus[j][k]);
- if (p->W[j])
- if (p->Specification & SPEC_RANDOM_WALK)
- bAdd(pElementV(p->Aplus[j][k]),pElementV(p->Aplus[j][k]),pElementV(p->A0[j][k]),p->nvars);
- else
- {
- v=ProductMV((TVector)NULL,p->W[j],p->A0[j][k]);
- SubtractVV(p->Aplus[j][k],p->Aplus[j][k],v);
- FreeVector(v);
- }
- }
- else
- if (p->W[j])
- if (p->Specification & SPEC_RANDOM_WALK)
- {
- InitializeVector(p->Aplus[j][k],0.0);
- memcpy(pElementV(p->Aplus[j][k]),pElementV(p->A0[j][k]),p->nvars*sizeof(PRECISION));
- }
- else
- {
- ProductMV(p->Aplus[j][k],p->W[j],p->A0[j][k]);
- MinusV(p->Aplus[j][k],p->Aplus[j][k]);
- }
- else
- InitializeVector(p->Aplus[j][k],0.0);
-}
-
-/*
- Assumes:
- p: Pointer to valid T_VAR_Parameters structure with A0 and bplus updated.
-
- Results:
- Updates Aplus
-
- Notes:
- Uses the relation
-
- Aplus[j][k] = V[j]*bplus[j][k] - W[j]*A0[j][k]
-
- If the Sims-Zha specification is used, special code is used to take advantage
- of the fact that V[j] is the identity and W[j] is diagonal with minus ones
- along the diagonal.
-
-*/
-void Update_Aplus_from_bplus_A0(T_VAR_Parameters *p)
-{
- int j, k;
- for (j=p->nvars-1; j >= 0; j--)
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- Update_aplus_from_bplus_a0(j,k,p);
-}
-
-/*
- Assumes:
- p: Pointer to valid TStateModel structure with psi and lambda updated.
-
- Results:
- Updates bplus and Aplus.
-
- Notes:
- Assumes Aplus[j][k] = V[j]*bplus[j][k] - W[j]*A0[j][k], V[j] is the identity,
- W[j] is a npre x nvar diagonal matrix with minus ones along the diagonal, and
-
- | lambda[j][k][i % nvars]*psi[j][i] for 0 <= i < nvars*nlags
- bplus[j][k][i] = |
- | psi[j][i] for nvar*nlags <= i
-
- This is the Sims-Zha specification.
-
-*/
-void Update_bplus_from_lambda_psi(T_VAR_Parameters *p)
-{
- int j, k, i, m;
- PRECISION *p_bplus, *p_lambda, *p_psi;
- if (!(p->Specification & SPEC_SIMS_ZHA))
- {
- fprintf(stderr,"Update_bplus_from_lambda_psi() called without Sims-Zha specification\n");
- exit(0);
- }
- for (j=p->nvars-1; j >= 0; j--)
- {
- p_psi=pElementV(p->psi[j]);
- for (k=dw_DimA(p->bplus[j])-1; k >= 0; k--)
- {
- p_bplus=pElementV(p->bplus[j][k]);
- p_lambda=pElementV(p->lambda[j][k]);
- p_bplus[i=p->nlags * p->nvars]=ElementV(p->constant[j],k);
- for (i--; i >= 0; )
- for (m=p->nvars-1; m >= 0; i--, m--)
- p_bplus[i]=p_lambda[m]*p_psi[i];
- }
- }
-}
-
-/*
- Assumes:
- p: Pointer to valid T_VAR_Parameters structure with A0 and Aplus udated.
-
- Results:
- Updates b0 and bplus
-
- Notes:
- Uses the relations
-
- A0[j][k] = U[j]*b0[j][k]
-
- Aplus[j][k] = V[j]*bplus[j][k] - W[j]*A0[j][k]
-
- U'[j]*U[j] = identity
-
- V'[j]*V[j] = identity
-*/
-void Update_b0_bplus_from_A0_Aplus(T_VAR_Parameters *p)
-{
- int i, j, k;
- TVector v;
- PRECISION *p_Aplus, *p_bplus, *p_A0;
-
- // A0
- for (j=p->nvars-1; j >= 0; j--)
- for (k=dw_DimA(p->A0[j])-1; k >= 0; k--)
- TransposeProductMV(p->b0[j][k],p->U[j],p->A0[j][k]);
-
- // Aplus
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- for (j=p->nvars-1; j >= 0; j--)
- for (k=dw_DimA(p->Aplus[j])-1; k >= 0; k--)
- {
- p_A0=pElementV(p->A0[j][k]);
- p_Aplus=pElementV(p->Aplus[j][k]);
- p_bplus=pElementV(p->bplus[j][k]);
- i=p->nvars;
- memcpy(p_bplus+i,p_Aplus+i,(p->npre - p->nvars)*sizeof(PRECISION));
- for (i--; i >= 0; i--) p_bplus[i]=p_Aplus[i]-p_A0[i];
- }
- }
- else
- {
- v=CreateVector(p->npre);
- for (j=p->nvars-1; j >= 0; j--)
- if (p->V[j])
- for (k=dw_DimA(p->A0[j])-1; k >= 0; k--)
- if (p->W[j])
- {
- ProductMV(v,p->W[j],p->A0[j][k]);
- AddVV(v,v,p->Aplus[j][k]);
- TransposeProductMV(p->bplus[j][k],p->V[j],v);
- }
- else
- TransposeProductMV(p->bplus[j][k],p->V[j],p->Aplus[j][k]);
- FreeVector(v);
- }
-}
-
-/*
- Assumes:
- model: pointer to valid TStateModel structure with A0 and bplus properly
- updated.
-
- Results:
- Updates lambda and psi.
-
- Notes:
- Assumes Aplus[j][k] = V[j]*bplus[j][k] - W[j]*A0[j][k], V[j] is the identity,
- W[j] is a npre x nvar matrix with minus ones along the diagonal and zeros
- elsewhere, and
-
- | lambda[j][k][i % nvars]*psi[j][i] for 0 <= i < nvars*nlags
- bplus[j][k][i] = |
- | psi[j][i] for nvar*nlags <= i
-
- The normalization lambda[j][0][i] = 1 is used.
-*/
-void Update_lambda_psi_from_bplus(T_VAR_Parameters *p)
-{
- int j, k, i, m, n, dim=p->nlags*p->nvars;
- PRECISION *p_bplus, *p_lambda, *p_psi;
- for (j=p->nvars-1; j >= 0; j--)
- {
- p_psi=pElementV(p->psi[j]);
- p_bplus=pElementV(p->bplus[j][0]);
- memcpy(p_psi,p_bplus,dim*sizeof(PRECISION));
- ElementV(p->constant[j],0)=p_bplus[dim];
- InitializeVector(p->lambda[j][0],1.0);
-
- for (k=dw_DimA(p->bplus[j])-1; k > 0; k--)
- {
- p_bplus=pElementV(p->bplus[j][k]);
- p_lambda=pElementV(p->lambda[j][k]);
- ElementV(p->constant[j],k)=p_bplus[dim];
- for (m=p->nvars-1; m >= 0; m--)
- {
- for (n=dim+m, i=n-p->nvars; i >= 0; i-=p->nvars)
- if (fabs(p_psi[i]) > fabs(p_psi[n])) n=i;
- p_lambda[m]=(p_psi[n] != 0) ? p_bplus[n]/p_psi[n] : 0;
- }
- }
- }
-}
-
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/** Impulse Response Routines **/
-/******************************************************************************/
-/*
- Consider the model
-
- y'(t) = [y'(t-1) ... y'(t-p) z'(t)]*B + epsilon'(t) * Inverse(A0*Xi)
-
-
- The impulse response of variable j to shock i
- at horizon h is the element in row i and colum j of
-
- Inverse(A0*Xi) * J * S^(h-1) * J'
-
- where
-
- B(1) I ... 0
- . . . .
- S = . . . .
- . . . .
- B(p-1) 0 ... I
- B(p) 0 ... 0
-
- J = [I 0 ... 0]
-
- B'= [B'(1) ... B'(p) C']
-*/
-TMatrix ComputeImpulseResponseReducedForm(TMatrix R, int h, TMatrix A0_Xi_inv, TMatrix B, int nlags)
-{
- TMatrix X=R, S, T, W;
- int n, t, i, j, m;
-
- dw_ClearError();
-
- if (!A0_Xi_inv || ((h > 1) && !B))
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- n=RowM(A0_Xi_inv);
- if (!X)
- {
- if (!(X=CreateMatrix(h,n*n))) return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != h) || (ColM(X) != n*n))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
-
- for (m=n*n-1, i=n-1; i >= 0; i--)
- for (j=n-1; j >= 0; m--, j--)
- ElementM(X,0,m)=ElementM(A0_Xi_inv,i,j);
-
- if (h > 1)
- {
- InitializeMatrix(S=CreateMatrix(n*nlags,n*nlags),0.0);
- for (i=n*(nlags - 1) - 1; i >= 0; i--) ElementM(S,i,i+n)=1.0;
- InsertSubMatrix(S,B,0,0,0,0,n*nlags,n);
-
-
- W=SubMatrix((TMatrix)NULL,S,0,0,n,n);
- ProductMM(W,A0_Xi_inv,W);
- for (m=n*n-1, i=n-1; i >= 0; i--)
- for (j=n-1; j >= 0; m--, j--)
- ElementM(X,1,m)=ElementM(W,i,j);
-
- if (h > 2)
- {
- T=EquateMatrix((TMatrix)NULL,S);
-
- for (t=2; t < h; t++)
- {
- ProductMM(T,T,S);
- SubMatrix(W,T,0,0,n,n);
- ProductMM(W,A0_Xi_inv,W);
- for (m=n*n-1, i=n-1; i >= 0; i--)
- for (j=n-1; j >= 0; m--, j--)
- ElementM(X,t,m)=ElementM(W,i,j);
- }
-
- FreeMatrix(T);
- }
-
- FreeMatrix(W);
- FreeMatrix(S);
- }
-
- if (dw_GetError() != NO_ERR)
- {
- if (X != R) FreeMatrix(X);
- return (TMatrix)NULL;
- }
-
- return X;
-}
-
-/*
- Consider the model
-
- y'(t)*A(0) = [y'(t-1) ... y'(t-p) z'(t)]*Aplus + epsilon'(t)*Inverse(Xi)
-
-
- The impulse response of variable j to shock i
- at horizon h is the element in row i and colum j of
-
- Inverse(A0*Xi) * J * S^(h-1) * J'
-
- where
-
- B(1) I ... 0
- . . . .
- S = . . . .
- . . . .
- B(p-1) 0 ... I
- B(p) 0 ... 0
-
- J = [I 0 ... 0]
-
- B = Aplus * Inverse(A0)
-
- B'= [B'(1) ... B'(p) C']
-
- Note that if Y'(t)=[y'(t) ... y'(t-p+1)], then
-
- Y'(t) = Y'(t-1)*S + J*z'(t)*C + J*epsilon'(t)*Inverse(A0*Xi)
-*/
-TMatrix ComputeImpulseResponseStructural(TMatrix R, int h, TMatrix A0, TMatrix Aplus, TVector Xi, int nlags)
-{
- TMatrix X, B;
- int n=RowM(A0), i, j;
- PRECISION xi_inv;
-
- X=Inverse_LU((TMatrix)NULL,A0);
-
- B=(h > 1) ? ProductMM((TMatrix)NULL,Aplus,X) : (TMatrix)NULL;
-
- for (i=n-1; i >= 0; i--)
- for (xi_inv=1.0/ElementV(Xi,i), j=n-1; j >= 0; j--)
- ElementM(X,i,j)*=xi_inv;
-
- R=ComputeImpulseResponseReducedForm(R,h,X,B,nlags);
-
- FreeMatrix(X);
- FreeMatrix(B);
-
- return R;
-}
-
-/*
- Consider the model
-
- y(t)' * A(0)(s(t)) = Sum[y(t-i)' * A(i)(s(t)),i=1,...,p] +
- + z(t)' * C + epsilon(t)' * Inverse(Xi(s(t)))
-
-
- Condition on state k occuring, the impulse response of variable j to shock i
- at horizon h is the element in row i and colum j of
-
- Inverse(Xi(k)) * Inverse(A(0)(k)) * J * S^(h-1) * J'
-
- where
-
- S = A(1)(k)*Inverse(A(0)(k)) I ... 0
- . . . .
- . . . .
- . . . .
- A(p-1)(k)*Inverse(A(0)(k)) 0 ... I
- A(p)(k)*Inverse(A(0)(k)) 0 ... 0
- and
-
- J = [I 0 ... 0].
-*/
-TMatrix ComputeImpulseResponse(TMatrix R, int h, int k, TStateModel *model)
-{
- TMatrix X, Aplus, B;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
- PRECISION xi_inv;
- int n=p->nvars, i, j;
-
- if ((k < 0) || (k >= p->nstates))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
-
- X=MakeA0((TMatrix)NULL,k,p);
- Inverse_LU(X,X);
-
- if (h > 1)
- {
- Aplus=MakeAplus((TMatrix)NULL,k,p);
- B=ProductMM((TMatrix)NULL,Aplus,X);
- }
- else
- Aplus=B=(TMatrix)NULL;
-
- for (i=n-1; i >= 0; i--)
- for (xi_inv=1.0/sqrt(p->Zeta[i][p->var_states[i][k]]), j=n-1; j >= 0; j--)
- ElementM(X,i,j)*=xi_inv;
-
- R=ComputeImpulseResponseReducedForm(R,h,X,B,p->nlags);
-
- FreeMatrix(B);
- FreeMatrix(Aplus);
- FreeMatrix(X);
-
- return R;
-}
-
-/*
- Computes the cummulative variance decomposition of the impulse responses (IR).
-*/
-TMatrix ComputeVarianceDecomposition(TMatrix X, TMatrix IR, int nvars)
-{
- TMatrix Y=X;
- int t, i, j;
- PRECISION sum, tmp;
-
- dw_ClearError();
-
- if (!IR)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- else
- if (ColM(IR) != nvars*nvars)
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- else
- if (!Y)
- {
- if (!(Y=CreateMatrix(RowM(IR),ColM(IR)))) return (TMatrix)NULL;
- }
- else
- if ((RowM(Y) != RowM(IR)) || (ColM(Y) != ColM(IR)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
-
- // Compute cummulative variation
- for (j=nvars*nvars-1; j >= 0; j--)
- {
- tmp=ElementM(IR,0,j);
- ElementM(Y,0,j)=tmp*tmp;
- }
- for (t=1; t < RowM(IR); t++)
- for (j=nvars*nvars-1; j >= 0; j--)
- {
- tmp=ElementM(IR,t,j);
- ElementM(Y,t,j)=tmp*tmp + ElementM(Y,t-1,j);
- }
-
- // Compute cummulative variance decomposition
- for (t=0; t < RowM(IR); t++)
- for (j=nvars-1; j >= 0; j--)
- {
- for (sum=0.0, i=nvars*(nvars-1)+j; i >= 0; i-=nvars) sum+=ElementM(Y,t,i);
- if (sum > 0)
- for (sum=1.0/sum, i=nvars*(nvars-1)+j; i >= 0; i-=nvars) ElementM(Y,t,i)*=sum;
- }
-
- return Y;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-
-/*******************************************************************************/
-/******************************** Optimization *********************************/
-/*******************************************************************************/
-/* PRECISION ComputeConstantSimsZha(TStateModel *model) */
-/* { */
-/* int j; */
-/* PRECISION constant=0.0; */
-/* T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p); */
-/* for (j=p->nvars-1; j >= 0; j--) */
-/* { */
-/* // b0 */
-/* constant+=0.5*p->n_coef_states[j]*DimV(p->b0[j][0])*log(p->n_A0_states/p->n_coef_states[j]); */
-
-/* // bplus or psi and constant */
-/* if (p->bplus[j]) */
-/* if (p->Specification & SPEC_SIMS_ZHA) */
-/* constant+=0.5*((p->npre-1)*log(p->n_A0_states) + p->n_coef_states[j]*log(p->n_A0_states/p->n_coef_states[j])); */
-/* else */
-/* constant+=0.5*p->n_coef_states[j]*DimV(p->bplus[j][0])*log(p->n_A0_states/p->n_coef_states[j]); */
-/* } */
-/* return constant; */
-/* } */
-
-#define LN_TWO_PI 1.837877066409345
-#define LN_TWO 0.6931471805599453
-void SetLogPriorConstant_VAR(T_VAR_Parameters *p)
-{
- int j;
-
- p->log_prior_constant=0.0;
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- // Gamma prior on Zeta
- if (p->n_var_states[j] > 1)
- p->log_prior_constant+=(p->n_var_states[j] - 1)*(ElementV(p->zeta_a_prior,j)*log(ElementV(p->zeta_b_prior,j))
- - dw_log_gamma(ElementV(p->zeta_a_prior,j)));
-
- // Normal prior on b0 (A0)
- p->log_prior_constant+=0.5*p->n_coef_states[j]*(-DimV(p->b0[j][0])*LN_TWO_PI + LogAbsDeterminant_LU(p->inverse_b0_prior[j]));
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- // Independent normal prior each element of delta with variance equal to delta_prior
- p->log_prior_constant-=0.5 * (dw_DimA(p->lambda[j])-1) * p->nvars * (LN_TWO_PI + log(p->lambda_prior));
-
- // Normal prior on psi and constant
- p->log_prior_constant+=0.5*(-(p->npre-1+p->n_coef_states[j])*LN_TWO_PI + LogAbsDeterminant_LU(p->inverse_psi_prior[j]));
- }
- else
- {
- // Normal prior on bplus (Aplus)
- if (p->bplus[j])
- p->log_prior_constant+=0.5*p->n_coef_states[j]*(-DimV(p->bplus[j][0])*LN_TWO_PI + LogAbsDeterminant_LU(p->inverse_bplus_prior[j]));
- }
- }
-
- // Scale for normalization
- switch (p->normalization_type)
- {
- case VAR_NORMALIZATION_NONE:
- break;
- case VAR_NORMALIZATION_WZ:
- p->log_prior_constant+=p->nvars*log(2);
- break;
- default:
- fprintf(stdout,"Unknown normalization type\n");
- exit(1);
- }
-}
-#undef LN_TWO_PI
-#undef LN_TWO
-
-PRECISION LogPrior_VAR(TStateModel *model)
-{
- int j, k;
- PRECISION x, y, log_prior=0.0;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- if (!(p->valid_parameters)) return MINUS_INFINITY;
-
- for (j=p->nvars-1; j >= 0; j--)
- {
- // Gamma prior on Zeta
- if (p->n_var_states[j] > 1)
- {
- x=ElementV(p->zeta_b_prior,j);
- y=2*(ElementV(p->zeta_a_prior,j)-1);
- for (k=p->n_var_states[j]-1; k > 0; k--)
- log_prior+=y*sqrt(p->Zeta[j][k]) - x*p->Zeta[j][k];
- }
-
- // Normal prior on b0 (A0)
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- log_prior-=0.5*InnerProductSymmetric(p->b0[j][k],p->inverse_b0_prior[j]);
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- // Independent normal prior each element of lambda with variance equal to lambda_prior
- if (dw_DimA(p->lambda[j]) > 1)
- {
- for (x=0.0, k=p->n_coef_states[j]-1; k > 0; k--)
- x+=DotProduct(p->lambda[j][k],p->lambda[j][k]);
- log_prior-=0.5 * x * p->inverse_lambda_prior;
- }
-
- // Normal prior on psi and constant
- log_prior-=0.5*InnerProductSymmetric(p->psi[j],p->inverse_psi_prior[j]);
- }
- else
- {
- // Normal prior on bplus (Aplus)
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- log_prior-=0.5*InnerProductSymmetric(p->bplus[j][k],p->inverse_bplus_prior[j]);
- }
- }
-
- return log_prior + p->log_prior_constant;
-}
-
-int NumberFreeParametersVAR(TStateModel *model)
-{
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
- int j, k, size=0;
-
- // b0
- for (j=0; j < p->nvars; j++)
- for (k=0; k < dw_DimA(p->b0[j]); k++)
- size+=DimV(p->b0[j][k]);
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- // lambda
- for (j=0; j < p->nvars; j++)
- for (k=1; k < dw_DimA(p->lambda[j]); k++)
- size+=DimV(p->lambda[j][k]);
-
- // psi
- for (j=0; j < p->nvars; j++)
- size+=DimV(p->psi[j]);
- }
- else
- {
- // bplus
- for (j=0; j < p->nvars; j++)
- if (p->bplus[j])
- for (k=0; k < dw_DimA(p->bplus[j]); k++)
- size+=DimV(p->bplus[j][k]);
- }
-
- // Zeta
- for (j=0; j < p->nvars; j++)
- size+=dw_DimA(p->Zeta[j])-1;
-
- return size;
-}
-
-void FreeParametersToVAR(TStateModel *model, PRECISION *f)
-{
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
- int k, j;
-
- // b0
- for (j=0; j < p->nvars; j++)
- for (k=0; k < dw_DimA(p->b0[j]); k++)
- {
- memcpy(pElementV(p->b0[j][k]),f,DimV(p->b0[j][k])*sizeof(PRECISION));
- f+=DimV(p->b0[j][k]);
- }
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- // lambda
- for (j=0; j < p->nvars; j++)
- {
- InitializeVector(p->lambda[j][0],1.0);
- for (k=1; k < dw_DimA(p->lambda[j]); k++)
- {
- memcpy(pElementV(p->lambda[j][k]),f,DimV(p->lambda[j][k])*sizeof(PRECISION));
- f+=DimV(p->lambda[j][k]);
- }
- }
-
- // psi
- for (j=0; j < p->nvars; j++)
- {
- memcpy(pElementV(p->psi[j]),f,DimV(p->psi[j])*sizeof(PRECISION));
- f+=DimV(p->psi[j]);
- }
- }
- else
- {
- // bplus
- for (j=0; j < p->nvars; j++)
- if (p->bplus[j])
- for (k=0; k < dw_DimA(p->bplus[j]); k++)
- {
- memcpy(pElementV(p->bplus[j][k]),f,DimV(p->bplus[j][k])*sizeof(PRECISION));
- f+=DimV(p->bplus[j][k]);
- }
- }
-
- // Zeta
- for (j=0; j < p->nvars; j++)
- {
- // Zeta non-negative
- for (k=dw_DimA(p->Zeta[j])-2; k >= 0; k--)
- if (f[k] < 0.0)
- {
- p->valid_parameters=0;
- return;
- }
-
- p->Zeta[j][0]=1.0;
- memcpy(p->Zeta[j]+1,f,(dw_DimA(p->Zeta[j])-1)*sizeof(PRECISION));
- f+=dw_DimA(p->Zeta[j])-1;
- }
-
- // Valid normalization
-
-
- // Update A0 and Aplus
- if (p->Specification & SPEC_SIMS_ZHA) Update_bplus_from_lambda_psi(p);
- Update_A0_from_B0(p);
- Update_Aplus_from_bplus_A0(p);
-
- // Set flags
- p->valid_parameters=1;
- ThetaChanged(model);
-}
-
-void VARToFreeParameters(TStateModel *model, PRECISION *f)
-{
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->p->p);
- int k, j;
-
- // b0
- for (j=0; j < p->nvars; j++)
- for (k=0; k < dw_DimA(p->b0[j]); k++)
- {
- memcpy(f,pElementV(p->b0[j][k]),DimV(p->b0[j][k])*sizeof(PRECISION));
- f+=DimV(p->b0[j][k]);
- }
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- // lambda
- for (j=0; j < p->nvars; j++)
- for (k=1; k < dw_DimA(p->lambda[j]); k++)
- {
- memcpy(f,pElementV(p->lambda[j][k]),DimV(p->lambda[j][k])*sizeof(PRECISION));
- f+=DimV(p->lambda[j][k]);
- }
-
- // psi
- for (j=0; j < p->nvars; j++)
- {
- memcpy(f,pElementV(p->psi[j]),DimV(p->psi[j])*sizeof(PRECISION));
- f+=DimV(p->psi[j]);
- }
- }
- else
- {
- //bplus
- for (j=0; j < p->nvars; j++)
- if (p->bplus[j])
- for (k=0; k < dw_DimA(p->bplus[j]); k++)
- {
- memcpy(f,pElementV(p->bplus[j][k]),DimV(p->bplus[j][k])*sizeof(PRECISION));
- f+=DimV(p->bplus[j][k]);
- }
- }
-
- // Zeta
- for (j=0; j < p->nvars; j++)
- {
- memcpy(f,p->Zeta[j]+1,(dw_DimA(p->Zeta[j])-1)*sizeof(PRECISION));
- f+=dw_DimA(p->Zeta[j])-1;
- }
-}
-
-/*
- Assumes:
- p: pointer to valid T_VAR_Parameters structure
-
- Returns:
- The starting position of the Zeta parameters in the array of free
- parameters.
-*/
-int ZetaIndex(T_VAR_Parameters *p)
-{
- int j, k, index=0;
-
- // b0
- for (j=0; j < p->nvars; j++)
- for (k=0; k < dw_DimA(p->b0[j]); k++)
- index+=DimV(p->b0[j][k]);
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- // lambda
- for (j=0; j < p->nvars; j++)
- for (k=1; k < dw_DimA(p->lambda[j]); k++)
- index+=DimV(p->lambda[j][k]);
-
- // psi
- for (j=0; j < p->nvars; j++)
- index+=DimV(p->psi[j]);
- }
- else
- {
- // bplus
- for (j=0; j < p->nvars; j++)
- if (p->bplus[j])
- for (k=0; k < dw_DimA(p->bplus[j]); k++)
- index+=DimV(p->bplus[j][k]);
- }
-
- return index;
-}
-
-/*
- Assumes:
- p: pointer to valid T_VAR_Parameters structure
-
- Returns:
- The the number of Zeta parameters in the array of free parameters.
-*/
-int ZetaLength(T_VAR_Parameters *p)
-{
- int j, length=0;
- for (j=0; j < p->nvars; j++) length+=dw_DimA(p->Zeta[j])-1;
- return length;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/******************************** Normalization ********************************/
-/*******************************************************************************/
-/*
- Assumes
- p : pointer to properly initialized T_VAR_Parameters structure.
-
- Returns
- 1 : parameters normalized according to p->normalization_type and
- p->normalized.
- 0 : parameters not normalized according to p->normalization_type and
- p->normalized.
-*/
-int IsNormalized_VAR(T_VAR_Parameters *p)
-{
- return (p->normalized == p->normalization_type) ? 1 : 0;
-}
-/*
- Assumes
- p : pointer to properly initialized T_VAR_Parameters structure.
-
- Returns
- 1 : successful normalization/at least one column changed
- 0 : successful normalization/no column changed
- -1 : unsuccessful normalization (should not be returned)
-
-*/
-int Normalize_VAR(T_VAR_Parameters *p)
-{
- switch(p->normalization_type)
- {
- case VAR_NORMALIZATION_WZ: return WZ_Normalize(p);
- case VAR_NORMALIZATION_NONE: return 0;
- default:
- fprintf(stdout,"Unknown normalization type\n");
- exit(1);
- }
-}
-
-
-/*
- Changes the sign of the jth column for state k. It must be the case that
- 0 <= j < nvars and 0 <= k < n_coef_states[j]
-*/
-void ChangeSign(int j, int k, T_VAR_Parameters *p)
-{
- // Change sign of A0[j][k]
- MinusV(p->A0[j][k],p->A0[j][k]);
-
- // Change sign of Aplus[j][k]
- MinusV(p->Aplus[j][k],p->Aplus[j][k]);
-
- // Change sign of b0[j][k]
- MinusV(p->b0[j][k],p->b0[j][k]);
-
- // Change sign of bplus[j][k]
- if (p->bplus[j]) MinusV(p->bplus[j][k],p->bplus[j][k]);
-
- if (p->Specification & SPEC_SIMS_ZHA)
- {
- // Change sign of constant
- ElementV(p->constant[j],k)=-ElementV(p->constant[j],k);
-
- // Change sign of lambda[j][p->A0_column_states[j][k]]
- MinusV(p->lambda[j][k],p->lambda[j][k]);
- }
-}
-
-void Setup_No_Normalization(T_VAR_Parameters *p)
-{
- p->normalization_type=p->normalized=VAR_NORMALIZATION_NONE;
-
- if (p->flipped) dw_FreeArray(p->flipped);
- if (p->Target) dw_FreeArray(p->Target);
-
- p->flipped=(int**)NULL;
- p->Target=(TVector**)NULL;
-
- SetLogPriorConstant_VAR(p);
-}
-
-/*
- Sets up the WZ normalization. The target parameters come from A0.
-*/
-void Setup_WZ_Normalization(T_VAR_Parameters *p, TVector **A0)
-{
- int j;
-
- p->normalization_type=VAR_NORMALIZATION_WZ;
-
- if (p->flipped) dw_FreeArray(p->flipped);
- if (p->Target) dw_FreeArray(p->Target);
-
- p->flipped=dw_CreateArray_array(p->nvars);
- for (j=p->nvars-1; j >= 0; j--)
- p->flipped[j]=dw_CreateArray_int(p->n_coef_states[j]);
-
- p->Target=dw_CopyArray((TVector**)NULL,A0);
-
- p->WZ_inconsistancies=0;
-
- SetLogPriorConstant_VAR(p);
-
- WZ_Normalize(p);
-}
-
-/*
- Assumes
- p : pointer to properly initialized T_VAR_Parameters structure.
-
- Returns
- 1 : successful normalization/at least one column changed
- 0 : successful normalization/no column changed
-
-*/
-int WZ_Normalize(T_VAR_Parameters *p)
-{
- int j, k, changed=0, inconsistent=0;
- TMatrix A0, M, Target;
-
- // zero flipped
- for (j=p->nvars-1; j >= 0; j--)
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- p->flipped[j][k]=0;
-
- // determine which columns to flip
- A0=CreateMatrix(p->nvars,p->nvars);
- Target=CreateMatrix(p->nvars,p->nvars);
- M=CreateMatrix(p->nvars,p->nvars);
- for (k=p->n_A0_states-1; k >= 0; k--)
- {
- for (j=p->nvars-1; j >= 0; j--)
- {
- memcpy(&ElementM(A0,0,j),pElementV(p->A0[j][p->A0_column_states[j][k]]),p->nvars*sizeof(PRECISION));
- memcpy(&ElementM(Target,0,j),pElementV(p->Target[j][p->A0_column_states[j][k]]),p->nvars*sizeof(PRECISION));
- }
- InverseProductMM(M,A0,Target);
- for (j=p->nvars-1; j >= 0; j--)
- if (ElementM(M,j,j) < 0.0)
- p->flipped[j][p->A0_column_states[j][k]]--;
- else
- p->flipped[j][p->A0_column_states[j][k]]++;
- }
- FreeMatrix(M);
- FreeMatrix(Target);
- FreeMatrix(A0);
-
- // flip columns and record inconsistencies
- for (j=p->nvars-1; j >= 0; j--)
- for (k=p->n_coef_states[j]-1; k >= 0; k--)
- if (p->flipped[j][k]*p->n_coef_states[j] == -p->n_A0_states)
- {
- changed=1;
- ChangeSign(j,k,p);
- }
- else
- if (p->flipped[j][k]*p->n_coef_states[j] != p->n_A0_states)
- {
- inconsistent=1;
- if ((p->flipped[j][k] < 0) || ((p->flipped[j][k] == 0) && (ElementV(p->A0[j][p->A0_column_states[j][k]],j) < 0.0)))
- {
- changed=1;
- ChangeSign(j,k,p);
- }
- }
-
- if (inconsistent) p->WZ_inconsistancies++;
-
- p->normalized=VAR_NORMALIZATION_WZ;
-
- return changed;
-}
-
-/* /\* */
-/* Assumes */
-/* A0: p->nvars x p->nvars matrix */
-/* k: 0 <= k < p->n_A0_states */
-/* p: valid pointer to T_VAR_Parameters stucture */
-
-/* Results */
-/* A0 is initialized to state k. */
-
-/* A0 = [A0[A0_column_state[0][k]], ..., A0[A0_column_state[nvars-1][k]]] */
-
-/* *\/ */
-/* void CreateA0_from_determinant_state(TMatrix A0, int k, T_VAR_Parameters *p) */
-/* { */
-/* int j; */
-/* for (j=p->nvars-1; j >= 0; j--) */
-/* CopyColumnVector(A0,p->A0[j][p->A0_column_states[j][k]],j); */
-/* } */
-
-/* /\* */
-/* Assumes */
-/* p: Valid pointer to T_VAR_Parameters structure. */
-/* Ref: p->nvars x p->nvars matrix */
-
-/* Results */
-/* A0, Aplus, b0, bplus are normalized so that the diagonal of Inverse(A0)*Ref */
-/* is positive. */
-
-/* Notes */
-/* The normalization described above is equivalent to requiring that the jth */
-/* column of A0 and the jth column of Ref lie on the same side of the hyperplane */
-/* spanned all the columns of A0 other than the jth. */
-/* *\/ */
-/* void Normalize_WZ(T_VAR_Parameters *p, TMatrix Ref) */
-/* { */
-/* int j, k; */
-/* TMatrix A=CreateMatrix(p->nvars,p->nvars); */
-
-/* for (k=p->n_A0_states-1; k >= 0; k--) */
-/* { */
-/* CreateA0_from_determinant_state(A,k,p); */
-
-/* if (!InverseProductMM(A,A,Ref)) */
-/* { */
-/* printf("\nNormalize_WZ(): A0 not invertible\n"); */
-/* exit(0); */
-/* } */
-
-/* for (j=p->nvars-1; j >= 0; j--) */
-/* if (ElementM(A,j,j) < 0) */
-/* ChangeSign(j,k,p); */
-/* } */
-
-/* FreeMatrix(A); */
-/* } */
-
-/* /\* */
-/* Assumes */
-/* p: Valid pointer to T_VAR_Parameters structure. */
-/* Ref: Array of length p->nvars of vectors */
-
-/* Results */
-/* A0, Aplus, b0, and bplus are normalized so that the diagonal of A0'*Ref is */
-/* positive. */
-
-/* Notes */
-/* If Ref has exactly one non-zero element in each column, this normalization */
-/* is equivalent to requiring that the corresponding elements of A0 are */
-/* positive. */
-/* *\/ */
-/* void Normalize_Traditional(T_VAR_Parameters *p, TVector *Ref) */
-/* { */
-/* int j, k; */
-
-/* for (j=p->nvars-1; j >= 0; j--) */
-/* for (k=p->n_coef_states[j]-1; k >= 0; k--) */
-/* if (DotProduct(p->A0[j][k],Ref[j]) < 0) */
-/* { */
-/* // Change sign of A0[j][k] */
-/* MinusV(p->A0[j][k],p->A0[j][k]); */
-
-/* // Change sign of Aplus[j][k] */
-/* MinusV(p->Aplus[j][k],p->Aplus[j][k]); */
-
-/* // Change sign of b0[j][k] */
-/* MinusV(p->b0[j][k],p->b0[j][k]); */
-
-/* // Change sign of bplus[j][k] */
-/* if (p->bplus[j]) MinusV(p->bplus[j][k],p->bplus[j][k]); */
-/* } */
-/* } */
-
-/* /\* */
-/* Assumes */
-/* p: Valid pointer to T_VAR_Parameters structure */
-
-/* Results */
-/* A0, Aplus, b0, and bplus are normalized so that the diagonal of A0 is */
-/* positive. */
-/* *\/ */
-/* void Normalize_Diagonal(T_VAR_Parameters *p) */
-/* { */
-/* int j, k; */
-
-/* for (j=p->nvars-1; j >= 0; j--) */
-/* for (k=p->n_coef_states[j]-1; k >= 0; k--) */
-/* if (ElementV(p->A0[j][k],j) < 0) */
-/* { */
-/* // Change sign of A0[j][k] */
-/* MinusV(p->A0[j][k],p->A0[j][k]); */
-
-/* // Change sign of Aplus[j][k] */
-/* MinusV(p->Aplus[j][k],p->Aplus[j][k]); */
-
-/* // Change sign of b0[j][k] */
-/* MinusV(p->b0[j][k],p->b0[j][k]); */
-
-/* // Change sign of bplus[j][k] */
-/* if (p->bplus[j]) MinusV(p->bplus[j][k],p->bplus[j][k]); */
-/* } */
-/* } */
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/********************************** Utilities **********************************/
-/*******************************************************************************/
-/*
- Assumes:
- X : A m x n matrix or null pointer.
- Y : A array of pointers to vectors of length n. For each i, Y[i] is an
- array of vectors of positive length. For each i and j, Y[i][j] is
- a vector of length m. Y must have be created via calls to the function
- CreateVectorMultidimensionArray() so that the macros DimA(Y) and
- DimA(Y[i]) are valid.
-
- Results:
- Creates X if X is null. Sets X[i][j] to Y[j][k][i] if k is less than
- DimA(Y[j]) and to Y[j][0][i] otherwise.
-
- Returns:
- Returns the matrix X.
-
- Notes:
- The routine does not check to ensure that every Y[i] is non-null (and hence
- of positive length) nor does it check that all the vectors Y[i][j] are of
- the same length.
-*/
-TMatrix ConstructMatrixFromColumns(TMatrix X, TVector **Y, int k)
-{
- int i, j, s;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(DimV(Y[0][0]),dw_DimA(Y))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != DimV(Y[0][0])) || (ColM(X) != dw_DimA(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (MajorForm(X))
- for (i=RowM(X)*sizeof(PRECISION), j=ColM(X)-1; j >= 0; j--)
- memcpy(&ElementM(X,0,j),pElementV(Y[j][(k < dw_DimA(Y[j])) ? k : 0]),i);
- else
- for (j=ColM(X)-1; j >= 0; j--)
- {
- s=(k < dw_DimA(Y[j])) ? k : 0;
- for (i=RowM(X)-1; i >= 0; i--) ElementM(X,i,j)=ElementV(Y[j][s],i);
- }
- return X;
-}
-
-/*
- Assumes:
- A0 : p->nvars x p->nvars matrix or null pointer
- k : 0 <= k < p->nstates
-*/
-TMatrix MakeA0(TMatrix A0, int s, T_VAR_Parameters *p)
-{
- int j;
- if (!A0)
- {
- if (!(A0=CreateMatrix(p->nvars,p->nvars)))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(A0) != p->nvars) || (ColM(A0) != p->nvars))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (j=0; j < p->nvars; j++)
- memcpy(&ElementM(A0,0,j),pElementV(p->A0[j][p->coef_states[j][s]]),p->nvars*sizeof(PRECISION));
- return A0;
-}
-
-/*
- Assumes:
- Aplus : p->npre x p->nvars matrix or null pointer
- k : 0 <= k < p->nstates
-*/
-TMatrix MakeAplus(TMatrix Aplus, int k, T_VAR_Parameters *p)
-{
- int j;
- if (!Aplus)
- {
- if (!(Aplus=CreateMatrix(p->npre,p->nvars)))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(Aplus) != p->npre) || (ColM(Aplus) != p->nvars))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (j=0; j < p->nvars; j++)
- memcpy(&ElementM(Aplus,0,j),pElementV(p->Aplus[j][p->coef_states[j][k]]),p->npre*sizeof(PRECISION));
- return Aplus;
-}
-
-TMatrix MakeZeta(TMatrix Zeta, int k, T_VAR_Parameters *p)
-{
- int j;
- if (!Zeta)
- {
- if (!(Zeta=CreateMatrix(p->nvars,p->nvars)))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(Zeta) != p->nvars) || (ColM(Zeta) != p->nvars))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- InitializeMatrix(Zeta,0.0);
- for (j=0; j < p->nvars; j++)
- ElementM(Zeta,j,j)=p->Zeta[j][p->var_states[j][k]];
- return Zeta;
-}
-
-/*
- Assumes
- X: n x n matrix or null pointer in column major format
- Y: m x n matrix in column major format
- S: m x m symmetric matrix in column major format
-
- Returns
- X = Y'*S*Y. If X is null, it is created.
-
- Notes:
- The matrix X must be distinct from either Y or S.
-*/
-TMatrix MatrixInnerProductSymmetric(TMatrix X, TMatrix Y, TMatrix S)
-{
- PRECISION *x, *y, *z, *s, w;
- int m, n, i, j, sj, k;
- if (!Y || !S)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(ColM(Y),ColM(Y)))) return (TMatrix)NULL;
- }
- else
- if ((RowM(S) != RowM(Y)) || (ColM(S) != RowM(Y)) || (RowM(X) != ColM(Y)) || (ColM(X) != ColM(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
-
- InitializeMatrix(X,0.0);
- m=RowM(Y); n=ColM(Y);
- for (i=n-1, x=pElementM(X)+i, y=pElementM(Y)+i*m; i >= 0; x--, y-=m, i--)
- {
- for (s=pElementM(S)+(sj=m-1)*m; sj >= 0; z--, s-=m, sj--)
- {
- for (w=0.0, k=m-1; k >= 0; k--)
- w+=y[k]*s[k];
- z=pElementM(Y)+(n-1)*m+sj;
- for (j=n*(n-1); j >= 0; z-=m, j-=n)
- x[j]+=w*(*z);
- }
- }
- return X;
-}
-
-/*
- Assumes
- x : m-vector
- S : m x m symmetric matrix in column major format
-
- Results
- returns x'*S*x
-*/
-PRECISION InnerProductSymmetric(TVector x, TMatrix S)
-{
- PRECISION *s, result=0.0, tmp;
- int i, j;
- if ((DimV(x) != RowM(S)) || (DimV(x) != ColM(S)))
- {
- dw_Error(SIZE_ERR);
- return 0.0;
- }
- for (s=pElementM(S), j=0; j < DimV(x); j++)
- {
- for (tmp=0.0, i=0; i < j; s++, i++) tmp+=ElementV(x,i)*(*s);
- result+=(2.0*tmp + ElementV(x,j)*(*s))*ElementV(x,j);
- s+=(DimV(x) - j);
- }
- return result;
-}
-
-/*
- Assumes
- x : m-vector
- y : n-vector
- S : m x n matrix in column major format
-
- Results
- returns x'*S*y
-*/
-PRECISION InnerProductNonSymmetric(TVector x, TVector y, TMatrix S)
-{
- PRECISION *s, result=0.0, tmp;
- int i, j;
- if ((DimV(x) != RowM(S)) || (DimV(y) != ColM(S)))
- {
- dw_Error(SIZE_ERR);
- return 0.0;
- }
- for (s=pElementM(S)+DimV(x)*DimV(y)-1, j=DimV(y)-1; j >= 0; j--)
- {
- for (tmp=0.0, i=DimV(x)-1; i >= 0; s--, i--) tmp+=ElementV(x,i)*(*s);
- result+=tmp*ElementV(y,j);
- }
- return result;
-}
-
-
-/*
- Assumes
- x : n-vector or null pointer
- b : n-vector
- S : n x n symmetric and positive definite matrix
-
- Results
- The vector x is drawn from a multivariate normal distribution with
-
- variance = Inverse(S)
- and
- mean = Inverse(S)*b
-
- If x is null, it is created. The matrix S is modified.
-
- Returns
- The vector x upon success and null upon failure.
-
- Notes
- Uses the Cholesky decomposition of S and the function
- DrawNormal_UpperTriangular().
-*/
-TVector DrawNormal_InverseVariance(TVector x, TVector b, TMatrix S)
-{
- int terminal_error=dw_SetTerminalErrors(0);
- TMatrix U=CholeskyUT((TMatrix)NULL,S);
- dw_SetTerminalErrors(terminal_error);
- if (U)
- {
- x=DrawNormal_InverseUpperTriangular(x,b,U);
- FreeMatrix(U);
- return x;
- }
- else
- return (TVector)NULL;
- //return DrawNormal_InverseVariance_SVD(x,b,S);
-}
-
-/*
- Assumes
- x : n-vector or null pointer
- b : n-vector
- S : n x n symmetric and positive definite matrix
-
- Results
- The vector x is drawn from a multivariate normal distribution with
-
- variance = Inverse(S)
- and
- mean = Inverse(S)*b
-
- If x is null, it is created. The matrix S is modified.
-
- Returns
- The vector x upon success and null upon failure.
-
- Notes
- Uses the Singular value decomposition of S to compute the square root of the
- inverse of S. If S = A'*A, and c is drawn from a standard normal
- distribution, then
-
- Inverse(A)*(c + Inverse(A')*b)
-
- is drawn from the required distribution.
-*/
-TVector DrawNormal_InverseVariance_SVD(TVector x, TVector b, TMatrix S)
-{
- PRECISION tol, scale;
- TMatrix U, V;
- TVector d, rtrn;
- int i, j, n=DimV(b);
-
- _VAR_IMPROPER_DISTRIBUTION_COUNTER++;
-
- SVD(U=CreateMatrix(n,n),d=CreateVector(n),V=CreateMatrix(n,n),S);
- for (tol=ElementV(d,0), i=n-1; i > 0; i--)
- if (tol < ElementV(d,i)) tol=ElementV(d,i);
- //tol*=n*MACHINE_EPSILON;
- tol*=SQRT_MACHINE_EPSILON;
- for (j=n-1; j >= 0; j--)
- {
- scale=(ElementV(d,j) < tol) ? 1.0/sqrt(tol) : 1.0/sqrt(ElementV(d,j));
- for (i=n-1; i >= 0; i--)
- ElementM(V,i,j)*=scale;
- }
- rtrn=ProductTransposeVM(x,b,V);
- for (i=n-1; i >= 0; i--) ElementV(rtrn,i)+=dw_gaussian_rnd();
- ProductMV(rtrn,V,rtrn);
- FreeMatrix(U);
- FreeMatrix(V);
- FreeVector(d);
- return rtrn;
-}
-
-/*
- Assumes
- x : n-vector or null pointer
- b : n-vector
- U : n x n upper triangular matrix with non-zero diagonal
-
- Results
- The vector x is drawn from a multivariate normal distribution with
-
- variance = Inverse(U'*U)
- and
- mean = Inverse(U'*U)*b
-
- If x is null, it is created.
-
- Returns
- The vector x upon success and null upon failure.
-
- Notes
- If c is drawn from a standard normal distribution, then
-
- Inverse(U)*(c + Inverse(U')*b)
-
- is drawn from the required distribution. If S=U'U, then x is drawn from the
- multivariate normal distribution with mean Inverse(S)*b and variance
- Inverse(S). The matrix U can be obtained from S by calling CholeskyUT(U,S).
-*/
-TVector DrawNormal_InverseUpperTriangular(TVector x, TVector b, TMatrix U)
-{
- int i;
- TVector rtrn=ProductInverseVU(x,b,U);
- if (rtrn)
- {
- for (i=DimV(rtrn)-1; i >= 0; i--) ElementV(rtrn,i)+=dw_gaussian_rnd();
- if (!InverseProductUV(rtrn,U,rtrn))
- {
- if (!x) FreeVector(rtrn);
- return (TVector)NULL;
- }
- }
- return rtrn;
-}
-
-
-/*
- Attempts recovery from a singular inverse variance matrix.
-*/
-TVector SingularInverseVariance_RecoveryAttempt(TVector x, TVector b, TMatrix S, TMatrix InversePrior, TStateModel *model, int code)
-{
- FILE *f_out;
- char *header;
- char filename[256];
-
- // print warning
- printf("Singular error\n");
-
- // Construct file name and open file
- if (!V_FILE)
- {
- sprintf(filename,"singular_error_%03d_test.dat",_VAR_IMPROPER_DISTRIBUTION_COUNTER);
- f_out=dw_CreateTextFile(filename);
- }
- else
- f_out=V_FILE;
-
- fprintf(f_out,"//+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++//\n");
-
- // Print error message, inverse variance matrix, and inverse prior
- switch (code)
- {
- case BPLUS_ERR:
- fprintf(f_out,"Error in DrawAplus(): Inverse of variance is singular\n");
- break;
- case PSI_ERR:
- fprintf(f_out,"Error in Draw_psi(): Inverse of variance is singular\n");
- break;
- case LAMBDA_ERR:
- fprintf(f_out,"Error in Draw_Lambda(): Inverse of variance is singular\n");
- break;
- default:
- fprintf(f_out,"Unknown routine code: Inverse of variance is singular\n");
- break;
- }
- fprintf(f_out,"Inverse variance =\n");
- dw_PrintMatrix(f_out,S,"%lg ");
- fprintf(f_out,"Inverse prior =\n");
- dw_PrintMatrix(f_out,InversePrior,"%lg ");
- fprintf(f_out,"\n");
-
- // Print generator state
- fprintf(f_out,"\\== Generator State ==\\\n");
- dw_print_generator_state(f_out);
- fprintf(f_out,"\n");
-
- // Attempt recovery
- x=DrawNormal_InverseVariance_SVD(x,b,S);
-
- // Print parameters
- header="Error draw: ";
- WriteStates(f_out,(char*)NULL,header,model);
- WriteTransitionMatrices(f_out,(char*)NULL,header,model);
- Write_VAR_Parameters(f_out,(char*)NULL,header,model);
-
- fprintf(f_out,"//+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++//\n");
-
- // Close file
- if (f_out != V_FILE) fclose(f_out);
-
- _SINGULAR_ERROR=1;
-
- return x;
-}
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
diff --git a/matlab/swz/c-code/sbvar/var/VARbase.h b/matlab/swz/c-code/sbvar/var/VARbase.h
deleted file mode 100644
index 7d066d20453b247f150553991c563901cf9f8f51..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/VARbase.h
+++ /dev/null
@@ -1,433 +0,0 @@
-
-#ifndef __VAR_BASE_MODEL__
-#define __VAR_BASE_MODEL__
-
-#include "switch.h"
-#include "matrix.h"
-#include "dw_matrix_array.h"
-
-#define standard_ordering 1 // for future implementation
-#define SPEC_RANDOM_WALK 0x00000001
-#define SPEC_SIMS_ZHA 0x00000002
-
-//=== Normalization types (must be mutually exclusive) ===//
-#define VAR_NORMALIZATION_NONE 0x00000000
-#define VAR_NORMALIZATION_WZ 0x00000001
-
-typedef struct
-{
- //====== Model specification ======
- int Specification;
- int *IsIdentity_V;
-
- //====== Free parameter specification (for future implementation) ======
- int FreeParameterType;
-
- //====== Sizes ======
- int nvars;
- int nlags;
- int npre;
- int nobs;
- int nstates;
-
- //====== State variable translation ======
- int* n_var_states; // nvars n_var_states[j] is the number of variance states for column j
- int** var_states; // nvars x n_states translation table for variance states
- int* n_coef_states; // nvars n_coef_states[j] is the number of coefficients states for column j
- int** coef_states; // nvars x n_states translation table for coefficient states
- int n_A0_states; // number of states for the matrix A0
- int* A0_states; // n_states translation table for the matrix A0
- int** A0_column_states; // nvars x n_A0_states translation table from determinant of A0 states to coefficient states
-
- //====== Parameters ======
- PRECISION** Zeta; // nvars x n_var_states[j]
- TVector** A0; // nvars x n_coef_states[j] x nvars
- TVector** Aplus; // nvars x n_coef_states[j] x npre
-
- //====== Free parameters ======
- int* dim_b0;
- TVector** b0;
- int* dim_bplus;
- TVector** bplus;
-
- //====== Priors ======
- TVector zeta_a_prior; //
- TVector zeta_b_prior; //
- TMatrix* A0_prior; // A0_prior[j] = constant parameter variance of the normal prior on the jth column of A0
- TMatrix* Aplus_prior; // Aplus_prior[j] = constant parameter variance of the normal prior on the jth column of Aplus
-
- //====== Identifying restrictions ======
- TMatrix *U;
- TMatrix *V;
- TMatrix *W;
-
- //====== Sims-Zha specification parameters and workspace ======
- TVector** lambda; // nvars x n_coef_states[j] array of nvars-dimensional vectors
- TVector* constant; // nvars x n_coef_states[j] -- constant[j][k] == psi[j][npre - 1 + k]
- TVector* psi; // nvars x (npre - 1 + n_coef_states[j])
- PRECISION lambda_prior; // prior variance of each element of lambda
- PRECISION inverse_lambda_prior;
- TMatrix* inverse_psi_prior;
-
- //====== Normalization ======
- int normalization_type; // type of normalization used
- int normalized; // type of normalization actually used to normalize current draw
- TVector** Target; // nvar x n_coef_states[j] array of nvars-dimensional vectors
- int** flipped; // nvar x n_coef_states[j] array of integers
- int WZ_inconsistancies;
-
- //====== Workspace ======
- PRECISION log_prior_constant; // Constant of integrate for the log prior
- PRECISION minus_half_nvars_times_log2pi; // Constant used in LogConditionalProbability functions
- TVector inverse_zeta_b_prior; // inverse_zeta_b_prior = 1.0/zeta_b_prior
- TMatrix* inverse_b0_prior; // inverse_b0_prior = U'[j]*Inverse(A0_prior[j])*U[j]
- TMatrix* inverse_bplus_prior; // inverse_bplus_prior = V'[j]*Inverse(Aplus_prior[j])*V[j]
-
- TVector log_abs_det_A0; // log(abs(det(A0[k])))
-
- PRECISION*** A0_dot_products; // A0_dot_products[t][j][k] = Y'[t] * A0[j][k]
- PRECISION*** Aplus_dot_products; // Aplus_dot_products[t][j][k] = X'[t] * Aplus[j][k]
-
- // A0 Metropolis Info
- PRECISION** A0_Metropolis_Scale;
- int Total_A0_Metropolis_Draws;
- int** A0_Metropolis_Jumps;
-
- // State dependent fields
- TMatrix* YY; // YY[k] = sum(Y[t]*Y'[t], 1 <= t <= nobs and S[t] == k)
- TMatrix* XY; // YX[k] = sum(X[t]*Y'[t], 1 <= t <= nobs and S[t] == k)
- TMatrix* XX; // XX[k] = sum(X[t]*X'[t], 1 <= t <= nobs and S[t] == k)
- int* T; // T[k] = number of t with 1 <= t <= nobs and S[t] == k
- int *S; // S[t] = state variable used to compute YY, XY, XX, and T
- TMatrix* yy; // yy[t] = Y[t]*Y'[t]
- TMatrix* xy; // xy[t] = X[t]*Y'[t]
- TMatrix* xx; // xx[t] = X[t]*X'[t]
-
- // Flags for validity of workspace fields
- int valid_log_abs_det_A0; // Invalid after A0 changes
- int valid_dot_products; // Invalid after A0 or Aplus changes
- int valid_state_dependent_fields; // Invalid after states change
- int valid_state_dependent_fields_previous; // Initially invalid.
- int valid_parameters; // Initially invalid. Valid after successful read or draw of parameters.
- // Parametes are invalid if Zeta is negative or if they do not satisfy
- // the normalization.
-
- //=== Data ===
- TVector* Y; // Y[t] nvar vector of time t data for 1 <= t <= T
- TVector* X; // X[t] npre vector of time t predetermined variables for 1 <= t <= T
-
-} T_VAR_Parameters;
-
-// Constructors-Destructors
-void FreeTheta_VAR(T_VAR_Parameters *p);
-ThetaRoutines* CreateRoutines_VAR(void);
-T_VAR_Parameters* CreateTheta_VAR(int flag, int nvars, int nlags, int nexg, int nstates, int nobs, // Specification and Sizes
- int **coef_states, int **var_states, // Translation Tables
- TMatrix *U, TMatrix *V, TMatrix *W, // Restrictions
- TMatrix Y, TMatrix X); // Data
-int** CreateTranslationMatrix_Flat(int **states, TMarkovStateVariable *sv);
-
-void SetPriors_VAR(T_VAR_Parameters *theta, TMatrix* A0_prior, TMatrix* Aplus_prior, TVector zeta_a_prior, TVector zeta_b_prior);
-void SetPriors_VAR_SimsZha(T_VAR_Parameters *theta, TMatrix* A0_prior, TMatrix* Aplus_prior, TVector zeta_a_prior,
- TVector zeta_b_prior, PRECISION lambda_prior);
-
-
-TStateModel* CreateConstantModel(TStateModel *model);
-TStateModel* ExpandModel_VAR(TStateModel *model, TStateModel *restricted_model, int s);
-
-
-void SetupSimsZhaSpecification(T_VAR_Parameters *p, PRECISION lambda_prior);
-
-PRECISION LogConditionalProbability_VAR(int i, int t, TStateModel *model);
-TVector ExpectationSingleStep_VAR(TVector y, int s, int t, TStateModel *model);
-
-
-void DrawParameters_VAR(TStateModel *model);
-void InitializeParameters_VAR(T_VAR_Parameters *p);
-
-// Priors
-void SetLogPriorConstant_VAR(T_VAR_Parameters *p);
-PRECISION LogPrior_VAR(TStateModel *model);
-
-// Normalization
-int IsNormalized_VAR(T_VAR_Parameters *p);
-int Normalize_VAR(T_VAR_Parameters *p);
-void Setup_No_Normalization(T_VAR_Parameters *p);
-void Setup_WZ_Normalization(T_VAR_Parameters *p, TVector **A0);
-int WZ_Normalize(T_VAR_Parameters *p);
-
-// Notification
-void StatesChanged_VAR(TStateModel *model);
-void ThetaChanged_VAR(TStateModel *model);
-void InitializeForwardRecursion_VAR(TStateModel *model);
-
-// Utility Routines
-int Reset_VAR_Improper_Distribution_Counter(void);
-int Get_VAR_Improper_Distribution_Counter(void);
-void Increment_Verbose(void);
-void SetVerboseFile(FILE *f);
-
-// Optimization
-int NumberFreeParametersVAR(TStateModel *model);
-void FreeParametersToVAR(TStateModel *model, PRECISION *f);
-void VARToFreeParameters(TStateModel *model, PRECISION *f);
-int ZetaIndex(T_VAR_Parameters *p);
-int ZetaLength(T_VAR_Parameters *p);
-
-//PRECISION ComputeConstantSimsZha(TStateModel *model);
-
-//
-void PsiDeltaToAplus(TStateModel *model);
-
-// Impulse Response
-TMatrix ComputeImpulseResponseReducedForm(TMatrix R, int h, TMatrix A0_Xi_inv, TMatrix B, int nlags);
-TMatrix ComputeImpulseResponseStructural(TMatrix R, int h, TMatrix A0, TMatrix Aplus, TVector Xi, int nlags);
-TMatrix ComputeImpulseResponse(TMatrix R, int h, int k, TStateModel *model);
-TMatrix ComputeVarianceDecomposition(TMatrix X, TMatrix IR, int nvars);
-
-// Simulation
-void DrawZeta_Aplus(TStateModel *model);
-void DrawZeta_DotProducts(TStateModel *model);
-void AdaptiveMetropolisScale(TStateModel *model, int iterations, int period, int verbose, FILE *f_posterior);
-void SetupMetropolisInformation(PRECISION **Scale, T_VAR_Parameters *p);
-void ResetMetropolisInformation(T_VAR_Parameters *p);
-PRECISION LogKernel_A0_DotProducts(int j, int k, TStateModel *model);
-PRECISION LogKernel_A0(int j, int k, TStateModel *model);
-void DrawA0_Metropolis(TStateModel *model);
-void DrawAplus(TStateModel *model);
-void Draw_psi(TStateModel *model);
-void Draw_lambda(TStateModel *model);
-
-/* Utilities */
-void ComputeDotProducts_All(T_VAR_Parameters *p);
-void ComputeLogAbsDetA0_All(T_VAR_Parameters *p);
-void ComputeLogAbsDetA0(int j, int k, T_VAR_Parameters *p);
-
-TMatrix MakeA0(TMatrix A0, int k, T_VAR_Parameters *p);
-TMatrix MakeAplus(TMatrix Aplus, int k, T_VAR_Parameters *p);
-TMatrix MakeZeta(TMatrix Zeta, int k, T_VAR_Parameters *p);
-TMatrix ConstructMatrixFromColumns(TMatrix X, TVector **, int k);
-
-void UpdateStateDependentFields(T_VAR_Parameters *p, int *S);
-void Update_aplus_from_bplus_a0(int j, int k, T_VAR_Parameters *p);
-void Update_A0_from_b0(T_VAR_Parameters *p);
-void Update_Aplus_from_bplus_A0(T_VAR_Parameters *p);
-void Update_bplus_from_lambda_psi(T_VAR_Parameters *p);
-void Update_b0_bplus_from_A0_Aplus(T_VAR_Parameters *p);
-void Update_lambda_psi_from_bplus(T_VAR_Parameters *p);
-
-int GetNumberStatesFromTranslationMatrix(int j, int **states);
-int **CreateTranslationMatrix(TMarkovStateVariable ***list, TMarkovStateVariable *sv);
-
-//PRECISION InnerProductSymmetric(TVector x, TMatrix S);
-//PRECISION InnerProductNonSymmetric(TVector x, TVector y, TMatrix S);
-
-void update_psi_quadratic_form(TMatrix S, int n, int m, int k, TVector lambda, TMatrix XX);
-TMatrix MatrixInnerProductSymmetric(TMatrix X, TMatrix Y, TMatrix S);
-PRECISION InnerProductSymmetric(TVector x, TMatrix S);
-PRECISION InnerProductNonSymmetric(TVector x, TVector y, TMatrix S);
-TVector DrawNormal_InverseVariance(TVector x, TVector b, TMatrix S);
-TVector DrawNormal_InverseVariance_SVD(TVector x, TVector b, TMatrix S);
-TVector DrawNormal_InverseUpperTriangular(TVector x, TVector b, TMatrix T);
-
-
-// Obsolete routines
-
-
-#endif // __VAR_BASE_MODEL__
-
-
-/********************************************************************************
-Notes:
-
-The model:
-
- y(t)' * A0(s(t)) = x(t)' * Aplus(s(t)) + epsilon(t)' * Inverse(Xi(s(t)))
-
- where
- y(t) is nvars x 1
- x(t) is npre x 1
- x(t)=[y(t-1),...,y(t-p),z(t)], where z(t) is exogenous
- epsilon(t) is nvars x 1
- A0(k) is nvars x nvars
- Aplus(k) is npre x nvars
- Xi(k) is an nvars x nvars diagonal matrix
- s(t) is an integer with 0 <= s(t) < nstates
-
- Furthermore
-
- A0(j,k) = U(j) * b0(j,k)
-
- Aplus(j,k) = V(j) * bplus(j,k) - W(j) * A0(j,k)
-
- and
-
- Zeta(j,k) = Xi(j,k)*Xi(j,k)
- where
-
- A0(j,k) is the jth column of A0(k)
- Aplus(j,k) is the jth column of A0(k)
- Xi(j,k) is the jth diagonal element of Xi(k)
- b0(j,k) is q(j) x 1
- bplus(j,k) is r(j) x 1
- U(j) is nvars x q(j) with orthonormal columns
- V(j) is npre x r(j) with orthonormal columns
- W(j) is npre x nvar
- e(j) is the jth column of an identity matrix
-
-Sims-Zha Specification:
- This specification imposes that r(j) == npre, V(j) is the identity matrix, and
- W(j) is equal to a npre x nvars diagonal matrix with minus ones along the
- diagonal. Further restrictions are imposed of the form.
-
- bplus(j,k) = f(psi(j),lambda(j,k))
-
- where
-
- psi(j) is npre x 1
- lambda(j,k) is nvars x 1
-
- and f is the function
-
- f(a,b) = diag(vec(a))
-
-Random Walk Specification:
- This specification imposes that W(j) is equal to a npre x nvars diagonal
- matrix with minus ones along the diagonal. Though it is not imposed, we
- usually want Aplus(j,k) to satisfy linear restrictions implicit in the
- matrix V(j). This means that W(j) must be in the span of V(j) and hence
- (I - V(j)*V'(j))*W(j) = 0.
-
-
-Normalization:
- We normalize by requiring Xi(0) to be the identity matrix and
- delta(j,0) to be a vector of ones.
-
-Prior:
- A0(j,k) - The prior on A0(j,k) is normal with mean zero and covariance matrix
- A0_Prior(j). This implies that the prior on b0(j,k) is normal with mean zero
- and covariance matrix Inverse(U'[j]*Inverse(A0_prior[j])*U[j]).
-
- Aplus(j,k) - The prior on Aplus(j,k) conditional on A0(j,k) is normal with mean
- -W(j) * A0(j,k) and covariance Aplus_Prior(j). This implies that the prior on
- bplus(j,k) is normal with mean zero and covariance matrix
- Inverse(V'[j]*Inverse(Aplus_prior[j])*V[j])
-
- Zeta(j,k) - The prior on Zeta(j,k) is Gamma(zeta_a_prior(j),zeta_b_prior(j)).
-
----------------------------------------------------------------------------------
-
-TVector** A0
- The length of A0 is nvars. The vector A0[j][k] is the jth column of A0 when
- the jth coefficient state variable is equal to k. Note that when the Markov
- state variable is equal to s, the jth coefficient state variable is equal to
- coef_states[j][s]. The number of distinct values for the jth coefficient state
- variable is equal to the dimension of A0[j]. This field is created with
- dw_CreateArray_array() and freed with dw_FreeArray().
-
-TVector** b0
- The length of b0 is nvars. The vector b0[j][k] consists of the free parameters
- in the jth column of A0 when the jth coefficient state variable is equal to k.
- The dimension of b0[j][k] does not vary across k. Note that when the Markov
- state variable is equal to s, the jth coefficient state variable is equal to
- coef_states[j][s]. The dimension of b0[j] is equal to the dimension of A0[j].
- This field is created with dw_CreateArray_array() and freed with
- dw_FreeArray().
-
-TVector** Aplus
- The length of Aplus is nvars. The vector Aplus[j][k] is the jth column of
- Aplus when the jth coefficient state variable is equal to k. Note that when
- the Markov state variable is equal to s, the jth coefficient state variable is
- equal to coef_states[j][s]. The dimension of Aplus[j] is equal to the
- dimension of A0[j]. This field is created with dw_CreateArray_array() and
- freed with dw_FreeArray().
-
-TVector** bplus
- The length of bplus is nvars. The vector bplus[j][k] consists of the free
- parameters in the jth column of Aplus when the jth coefficient state variable
- is equal to k. The dimension of bplus[j][k] does not vary across k. Note that
- when the Markov state variable is equal to s, the jth coefficient state
- variable is equal to coef_states[j][s]. The dimension of bplus[j] is equal to
- the dimension of A0[j]. This field is created with dw_CreateArray_array() and
- freed with dw_FreeArray().
-
-PRECISION** Zeta
- The length of Zeta is nvars. The value of Zeta[j][k] is the square of the
- value of the jth diagonal element of Xi when the jth variance state variable is
- equal to k. Note that the the Markov state variable is equal to s, the jth
- variance state variable is equal to var_states[j][s]. The number of distinct
- values for the jth variance state variable is equal to the dimension of
- Zeta[j]. This field is created with dw_CreateArray_array() and freed with
- dw_FreeArray().
-
-TVector** delta
- The length of delta is nvars. The vector bplus[j][k] is a non-linear function
- of delta[j][k] and psi[k]. The length of delta[j][k] is nvars. This field is
- non-null only when using the Sims-Zha specification.
-
-TVector* psi
- The length of psi is nvars. The vector bplus[j][k] is a non-linear function
- of psi[k] and delta[j][k]. The length of psi[k] is npre. This field is non-
- null only when using the Sims-Zha specification.
-
-
-=============================== State Translation ===============================
-
-int* n_var_states
- An integer array of dimension nvars. The value of n_var_states[j] is the
- number of variance states for column j.
-
-int** var_states
- An integer array of dimension nvars by nstates. The value of var_states[j][k]
- is the value of the variance state for column j when the overall Markov state
- variable is equal to k. It is used as an index into Xi[j]. It must be the
- case that
-
- 0 <= var_states[j][k] < n_var_states[j].
-
-int* n_coef_states
- An integer arrary of dimension nvars. The value of n_coef_states[j] is the
- number of coefficient states for column j.
-
-int** coef_states
- An integer array of dimension nvar by nstates. The value of coef_states[j][k]
- is the value of the coefficient state for column j when the overall Markov
- state variable is equal to k. It is used as an index into A0[j], b0[j],
- Aplus[j] or bplus[j]. It must be the case that
-
- 0 <= coef_states[j][k] < n_coef_states[j].
-
-int n_A0_states
- The number of distinct values for the matrix A0.
-
-int* A0_states
- An integer array of dimension nstates. The value of A0_states[k] is the value
- of the state variable controlling A0 when the value of the overall Markov state
- variable is k. It is used as an index into the vector log_abs_det_A0. It must
- be the case that
-
- 0 <= A0_states[k] < n_A0_states.
-
-int** A0_column_states
- An integer array of dimension nvars by n_A0_states. The value of
- A0_column_states[j][k] is the value of the coefficient state for column j when
- value of the state variable controlling the matrix A0 is k. It is used as an
- index into A0[j]. It must be the case that
-
- 0 <= A0_column_states[j][k] < n_coef_states[j].
-
-
-================================= Normalization =================================
-For 0 <= k < n_A0_states, the contemporaneous coefficient matrix A[k] is formed.
-For 0 <= j < nvars and 0 <= k < n_A0_states, the number
-
- e[j]*Inverse(A[k])*Target[j][A0_column_states[j][k]]
-
-is computed. If this number is negative, then the sign of
-
- A0[j][A0_column_states[j][k]]
-
-is flipped. If the sign of any element of A0[j][.] is flipped more than once,
-this event is recorded.
-
-********************************************************************************/
diff --git a/matlab/swz/c-code/sbvar/var/VARio.c b/matlab/swz/c-code/sbvar/var/VARio.c
deleted file mode 100644
index 27c97c4ecc1c0b498e9b423176d4097867c0d46e..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/VARio.c
+++ /dev/null
@@ -1,885 +0,0 @@
-
-#include "VARio.h"
-#include "switchio.h"
-#include "dw_error.h"
-#include "dw_ascii.h"
-
-#include <stdlib.h>
-#include <string.h>
-#include <math.h>
-
-static int strlen_int(int n)
-{
- int i, j;
- for (i=1, j=10; n >= j; i++, j*=10);
- return i;
-}
-
-static void ReadError_VARio(char *id)
-{
- char *errmsg, *fmt="Error after line identifier ""%s""";
- sprintf(errmsg=(char*)malloc(strlen(fmt) + strlen(id) - 1),fmt,id);
- dw_UserError(errmsg);
- free(errmsg);
-}
-
-static int ReadInteger_VARio(FILE *f_in, char *id)
-{
- int i;
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %d ",&i) != 1)) ReadError_VARio(id);
- return i;
-}
-
-static PRECISION ReadScalar_VARio(FILE *f_in, char *id)
-{
- double x;
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %lf ",&x) != 1)) ReadError_VARio(id);
- return (PRECISION)x;
-}
-
-static void ReadMatrix_VARio(FILE *f_in, char *id, TMatrix X)
-{
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,X)) ReadError_VARio(id);
-}
-
-static void ReadVector_VARio(FILE *f_in, char *id, TVector X)
-{
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadVector(f_in,X)) ReadError_VARio(id);
-}
-
-static void ReadArray_VARio(FILE *f_in, char *id, void *X)
-{
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,X)) ReadError_VARio(id);
-}
-
-static FILE* OpenFile_VARio(FILE *f, char *filename)
-{
- char *errmsg, *fmt="Unable to open %s";
- if (!f)
- if (!filename)
- dw_UserError("Filename pointer is null.");
- else
- if (!(f=fopen(filename,"rt")))
- {
- sprintf(errmsg=(char*)malloc(strlen(fmt) + strlen(filename) - 1),fmt,filename);
- dw_UserError(errmsg);
- free(errmsg);
- }
- return f;
-}
-
-/*
- Assumes:
- f: valid file pointer or null
- filename: pointer to null terminated string or null
-
- Returns:
- A pointer to a valid TStateModel upon success and null pointer upon failure.
- Upon failure, the routine prints an error message if USER_ERR is a verbose
- error and terminates if USER_ERR is a terminal error. The terminal errors
- and verbose errors can be set with dw_SetTerminalErrors() and
- dw_SetVerboseErrors().
-
- Results:
- Upon success, a valid TStateModel is created and initialized.
-
- Notes:
- One of f and filename must not be null.
-*/
-TStateModel* Read_VAR_Specification(FILE *f, char *filename)
-{
- TMarkovStateVariable *sv;
- T_VAR_Parameters *p;
- char *id, *fmt;
- int *IV;
- int j, spec, nvars, nlags, nexg, npre, nstates, nobs;
- PRECISION lambda_prior;
- TVector zeta_a_prior, zeta_b_prior;
- TMatrix *U, *V, *W, *A0_prior, *Aplus_prior, Y, X;
- int **coef_states, **var_states;
- PRECISION** A0_Metropolis_Scale=(PRECISION**)NULL;
-
- // Valid file
- FILE *f_in=OpenFile_VARio(f,filename);
- if (!f_in) return (TStateModel*)NULL;
-
- // Read Markov specifications
- sv=ReadMarkovSpecification(f_in,(char*)NULL);
-
- //=== Sizes ===//
- nvars=ReadInteger_VARio(f_in,"//== Number Variables ==//");
- nlags=ReadInteger_VARio(f_in,"//== Number Lags ==//");
- nexg=ReadInteger_VARio(f_in,"//== Exogenous Variables ==//");
- nstates=ReadInteger_VARio(f_in,"//== Number States ==//");
- nobs=ReadInteger_VARio(f_in,"//== Number Observations ==//");
- npre=nvars*nlags+nexg;
- if ((nobs != sv->nobs) || (nstates != sv->nstates))
- {
- dw_UserError("Read_VAR_Specification(): different values for nobs or nstates.");
- return (TStateModel*)NULL;
- }
-
- //=== Restrictions - U[j] ===//
- ReadArray_VARio(f_in,"//== Number of free parameters in each column of A0 ==//",IV=dw_CreateArray_int(nvars));
- U=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- {
- fmt="//== U[%d] ==//";
- sprintf(id=(char*)malloc(strlen(fmt) + strlen_int(j+1) - 1),fmt,j+1);
- ReadMatrix_VARio(f_in,id,U[j]=CreateMatrix(nvars,IV[j]));
- free(id);
- }
- dw_FreeArray(IV);
-
- //=== Restrictions - V[j] ===//
- ReadArray_VARio(f_in,"//== Number of free parameters in each column of Aplus ==//",IV=dw_CreateArray_int(nvars));
- V=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (IV[j] > 0)
- {
- fmt="//== V[%d] ==//";
- sprintf(id=(char*)malloc(strlen(fmt) + strlen_int(j+1) - 1),fmt,j+1);
- ReadMatrix_VARio(f_in,id,V[j]=CreateMatrix(npre,IV[j]));
- free(id);
- }
- dw_FreeArray(IV);
-
- //=== Restrictions - W[j] ===//
- ReadArray_VARio(f_in,"//== Non-zero W[j] ==//",IV=dw_CreateArray_int(nvars));
- W=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (IV[j])
- {
- fmt="//== W[%d] ==//";
- sprintf(id=(char*)malloc(strlen(fmt) + strlen_int(j+1) - 1),fmt,j+1);
- ReadMatrix_VARio(f_in,id,W[j]=CreateMatrix(npre,nvars));
- free(id);
- }
- dw_FreeArray(IV);
-
- //====== Priors ======
- ReadVector_VARio(f_in,"//== Gamma prior on zeta - a ==//",zeta_a_prior=CreateVector(nvars));
- ReadVector_VARio(f_in,"//== Gamma prior on zeta - b ==//",zeta_b_prior=CreateVector(nvars));
-
- A0_prior=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- {
- fmt="//== Variance of Gaussian prior on column %d of A0 ==//";
- sprintf(id=(char*)malloc(strlen(fmt) + strlen_int(j+1) - 1),fmt,j+1);
- ReadMatrix_VARio(f_in,id,A0_prior[j]=CreateMatrix(nvars,nvars));
- free(id);
- }
-
- Aplus_prior=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- {
- fmt="//== Variance of Gaussian prior on column %d of Aplus ==//";
- sprintf(id=(char*)malloc(strlen(fmt) + strlen_int(j+1) - 1),fmt,j+1);
- ReadMatrix_VARio(f_in,id,Aplus_prior[j]=CreateMatrix(npre,npre));
- free(id);
- }
-
- //=== Specification ===//
- spec=ReadInteger_VARio(f_in,"//== Specification (0=default 1=Sims-Zha 2=Random Walk) ==//");
- switch (spec)
- {
- case 0: spec=0; break;
- case 1: spec=SPEC_SIMS_ZHA | SPEC_RANDOM_WALK; break;
- case 2: spec=SPEC_RANDOM_WALK; break;
- default: ReadError_VARio("//== Specification (0=default 1=Sims-Zha 2=Random Walk) ==//"); exit(0);
- }
- if (spec & SPEC_SIMS_ZHA)
- lambda_prior=ReadScalar_VARio(f_in,"//== Variance of Gaussian prior on lambda ==//");
-
- //====== coefficient and variance state variables ======
- ReadArray_VARio(f_in,"//== Translation table for coefficient states ==//",coef_states=dw_CreateRectangularArray_int(nvars,nstates));
- ReadArray_VARio(f_in,"//== Translation table for variance states ==//",var_states=dw_CreateRectangularArray_int(nvars,nstates));
-
- //====== Metropolis jumping kernel info for A0 ======
- if (dw_SetFilePosition(f_in,"//== Metropolis kernel scales for A0 ==//"))
- {
- A0_Metropolis_Scale=dw_CreateArray_array(nvars);
- for (j=nvars-1; j >= 0; j--)
- A0_Metropolis_Scale[j]=dw_CreateArray_scalar(GetNumberStatesFromTranslationMatrix(j,coef_states));
- if (!dw_ReadArray(f_in,A0_Metropolis_Scale)) ReadError_VARio(id);
- }
-
- //=== Data ===
- ReadMatrix_VARio(f_in,"//== Data Y (nobs x nvars) ==//",Y=CreateMatrix(nobs,nvars));
- ReadMatrix_VARio(f_in,"//== Data X (nobs x npre) ==//",X=CreateMatrix(nobs,npre));
-
- //=== Create T_VAR_Parameters structure ===
- p=CreateTheta_VAR(spec,nvars,nlags,nexg,nstates,nobs,coef_states,var_states,U,V,W,Y,X);
- if (spec & SPEC_SIMS_ZHA)
- SetPriors_VAR_SimsZha(p,A0_prior,Aplus_prior,zeta_a_prior,zeta_b_prior,lambda_prior);
- else
- SetPriors_VAR(p,A0_prior,Aplus_prior,zeta_a_prior,zeta_b_prior);
-
- if (A0_Metropolis_Scale) SetupMetropolisInformation(A0_Metropolis_Scale,p);
-
- //=== Close output file ===
- if (!f) fclose(f_in);
-
- //=== Free memory ===
- dw_FreeArray(U);
- dw_FreeArray(V);
- dw_FreeArray(W);
- FreeVector(zeta_a_prior);
- FreeVector(zeta_b_prior);
- dw_FreeArray(A0_prior);
- dw_FreeArray(Aplus_prior);
- FreeMatrix(X);
- FreeMatrix(Y);
- dw_FreeArray(coef_states);
- dw_FreeArray(var_states);
- dw_FreeArray(A0_Metropolis_Scale);
-
- //=== return TStateModel structure ===
- return CreateStateModel_new(sv,CreateRoutines_VAR(),p);
-}
-
-/*
- Writes the specification
-*/
-void Write_VAR_Specification(FILE *f, char *filename, TStateModel *model)
-{
- int j, t;
- FILE *f_out=f ? f : dw_CreateTextFile(filename);
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- // Write Markov specifications
- WriteMarkovSpecification(f_out,(char*)NULL,model);
-
- //=== Sizes ===//
- fprintf(f_out,"//== Number Variables ==//\n%d\n\n",p->nvars);
- fprintf(f_out,"//== Number Lags ==//\n%d\n\n",p->nlags);
- fprintf(f_out,"//== Exogenous Variables ==//\n%d\n\n",p->npre - p->nvars * p->nlags);
- fprintf(f_out,"//== Number States ==//\n%d\n\n",p->nstates);
- fprintf(f_out,"//== Number Observations ==//\n%d\n\n",p->nobs);
-
- //=== Restrictions - U[j] ===//
- fprintf(f_out,"//== Number of free parameters in each column of A0 ==//\n");
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"%d ",ColM(p->U[j]));
- fprintf(f_out,"\n\n");
- for (j=0; j < p->nvars; j++)
- {
- fprintf(f_out,"//== U[%d] ==//\n",j+1);
- dw_PrintMatrix(f_out,p->U[j],"%22.14le ");
- fprintf(f_out,"\n");
- }
-
- //=== Restrictions - V[j] ===//
- fprintf(f_out,"//== Number of free parameters in each column of Aplus ==//\n");
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"%d ",p->V[j] ? ColM(p->V[j]) : 0);
- fprintf(f_out,"\n\n");
- for (j=0; j < p->nvars; j++)
- if (p->V[j])
- {
- fprintf(f_out,"//== V[%d] ==//\n",j+1);
- dw_PrintMatrix(f_out,p->V[j],"%22.14le ");
- fprintf(f_out,"\n");
- }
-
- //=== Restrictions - W[j] ===//
- fprintf(f_out,"//== Non-zero W[j] ==//\n");
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"%d ",p->W[j] ? 1 : 0);
- fprintf(f_out,"\n\n");
- for (j=0; j < p->nvars; j++)
- if (p->W[j])
- {
- fprintf(f_out,"//== W[%d] ==//\n",j+1);
- dw_PrintMatrix(f_out,p->W[j],"%22.14le ");
- fprintf(f_out,"\n");
- }
-
- //====== Priors ======
- fprintf(f_out,"//== Gamma prior on zeta - a ==//\n");
- dw_PrintVector(f_out,p->zeta_a_prior,"%22.14le ");
- fprintf(f_out,"\n");
- fprintf(f_out,"//== Gamma prior on zeta - b ==//\n");
- dw_PrintVector(f_out,p->zeta_b_prior,"%22.14le ");
- fprintf(f_out,"\n");
-
- for (j=0; j < p->nvars; j++)
- {
- fprintf(f_out,"//== Variance of Gaussian prior on column %d of A0 ==//\n",j+1);
- dw_PrintMatrix(f_out,p->A0_prior[j],"%22.14le ");
- fprintf(f_out,"\n");
- }
-
- for (j=0; j < p->nvars; j++)
- {
- fprintf(f_out,"//== Variance of Gaussian prior on column %d of Aplus ==//\n",j+1);
- dw_PrintMatrix(f_out,p->Aplus_prior[j],"%22.14le ");
- fprintf(f_out,"\n");
- }
-
- //=== Model specification ===//
- fprintf(f_out,"//== Specification (0=default 1=Sims-Zha 2=Random Walk) ==//\n");
- if (p->Specification & SPEC_SIMS_ZHA)
- fprintf(f_out,"1\n\n");
- else
- if (p->Specification & SPEC_RANDOM_WALK)
- fprintf(f_out,"2\n\n");
- else
- fprintf(f_out,"0\n\n");
- if ((p->Specification & SPEC_SIMS_ZHA) == SPEC_SIMS_ZHA)
- fprintf(f_out,"//== Variance of Gaussian prior on lambda ==//\n%22.14le\n\n",p->lambda_prior);
-
- //====== coefficient and variance state variables ======
- fprintf(f_out,"//== Translation table for coefficient states ==//\n");
- dw_PrintArray(f_out,p->coef_states,"%4d ");
-
- fprintf(f_out,"//== Translation table for variance states ==//\n");
- dw_PrintArray(f_out,p->var_states,"%4d ");
-
- //====== Metropolis jumping kernel info for A0 ======
- fprintf(f_out,"//== Metropolis kernel scales for A0 ==//\n");
- dw_PrintArray(f_out,p->A0_Metropolis_Scale,"%22.14le ");
-
- //=== Data ===
- fprintf(f_out,"//== Data Y (nobs x nvars) ==//\n");
- for (t=1; t <= p->nobs; t++)
- dw_PrintVector(f_out,p->Y[t],"%22.14le ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Data X (nobs x npre) ==//\n");
- for (t=1; t <= p->nobs; t++)
- dw_PrintVector(f_out,p->X[t],"%22.14le ");
- fprintf(f_out,"\n");
-
- //=== Close output file ===
- if (!f) fclose(f_out);
-}
-
-/*
- Assumes:
- f: valid file pointer or null
- filename: pointer to null terminated string or null
- model: pointer to valid TStateModel structure
-
- Returns:
- One upon success. Upon failure, the routine prints an error message if
- USER_ERR is a verbose error, terminates if USER_ERR is a terminal error and
- returns zero if USER_ERR is not a terminal error. The terminal errors and
- verbose errors can be set with dw_SetTerminalErrors() and
- dw_SetVerboseErrors().
-
- Results:
- Upon success, the following fields of p will be filled:
-
- A0, Aplus, Zeta, b0, bplus.
-
- If the Sims-Zha specification is used, the following fields will also be
- filled
-
- lambda, psi.
-
- The routine Thetahanged() will be called.
-
- Notes:
- One of f and filename must not be null.
-
- The file must contain line identifiers of the form
-
- //== A0[s] ==//
- //== Aplus[s] ==//
- //== Zeta[s] ==//
-
- for 1 <= s <= p->nstates.
-
- Zeta is checked for non-negativity. No checks are made to ensure that A0[s],
- Aplus[s], or Zeta[s] satisfy any restrictions.
-*/
-int Read_VAR_Parameters(FILE *f, char *filename, char *header, TStateModel *model)
-{
- FILE *f_in;
- char *idbuffer, *fmt;
- TMatrix *A0, *Aplus, *Zeta;
- int i, j, s;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- // Valid file
- f_in=OpenFile_VARio(f,filename);
- if (!f_in) return 0;
-
- if (!header) header="";
-
- // Allocate memory
- A0=dw_CreateArray_matrix(p->nstates);
- Aplus=dw_CreateArray_matrix(p->nstates);
- Zeta=dw_CreateArray_matrix(p->nstates);
-
- // Read File
- for (s=0; s < p->nstates; s++)
- {
- fmt="//== %sA0[%d] ==//";
- sprintf(idbuffer=(char*)malloc(strlen(fmt)+strlen(header)+strlen_int(s+1)-3),fmt,header,s+1);
- if (!dw_SetFilePosition(f_in,idbuffer) || !dw_ReadMatrix(f_in,A0[s]=CreateMatrix(p->nvars,p->nvars)))
- {
- ReadError_VARio(idbuffer);
- free(idbuffer);
- return 0;
- }
- free(idbuffer);
-
- fmt="//== %sAplus[%d] ==//";
- sprintf(idbuffer=(char*)malloc(strlen(fmt)+strlen(header)+strlen_int(s+1)-3),fmt,header,s+1);
- if (!dw_SetFilePosition(f_in,idbuffer) || !dw_ReadMatrix(f_in,Aplus[s]=CreateMatrix(p->npre,p->nvars)))
- {
- ReadError_VARio(idbuffer);
- free(idbuffer);
- return 0;
- }
- free(idbuffer);
-
- fmt="//== %sZeta[%d] ==//";
- sprintf(idbuffer=(char*)malloc(strlen(fmt)+strlen(header)+strlen_int(s+1)-3),fmt,header,s+1);
- if (!dw_SetFilePosition(f_in,idbuffer) || !dw_ReadMatrix(f_in,Zeta[s]=CreateMatrix(p->nvars,p->nvars)))
- {
- ReadError_VARio(idbuffer);
- free(idbuffer);
- return 0;
- }
- free(idbuffer);
- }
-
- // Set A0, Aplus, and Zeta
- for (j=0; j < p->nvars; j++)
- for (s=0; s < p->nstates; s++)
- {
- for (i=0; i < p->nvars; i++)
- ElementV(p->A0[j][p->coef_states[j][s]],i)=ElementM(A0[s],i,j);
-
- for (i=0; i < p->npre; i++)
- ElementV(p->Aplus[j][p->coef_states[j][s]],i)=ElementM(Aplus[s],i,j);
-
- p->Zeta[j][p->var_states[j][s]]=ElementM(Zeta[s],j,j);
- }
-
- // Free memory
- dw_FreeArray(A0);
- dw_FreeArray(Aplus);
- dw_FreeArray(Zeta);
-
- // Check Zeta non-negative
- for (j=p->nvars-1; j >= 0; j--)
- for (s=p->n_var_states[j]-1; s >= 0; s--)
- if (p->Zeta[j][s] < 0.0)
- {
- dw_UserError("Zeta has negative value.");
- p->valid_parameters=0;
- ThetaChanged(model);
- return 0;
- }
-
- // Update b0, bplus, lambda, psi
- Update_b0_bplus_from_A0_Aplus(p);
- if ((p->Specification & SPEC_SIMS_ZHA) == SPEC_SIMS_ZHA) Update_lambda_psi_from_bplus(p);
-
- // Flags and notification that the VAR parameters have changed
- p->valid_parameters=1;
- ThetaChanged(model);
-
- return 1;
-}
-
-/*
- Writes the VAR parameters to a file. The identifiers are
-
- //== A0[s] ==//
- //== Aplus[s] ==//
- //== Zeta[s] ==//
-
- for 1 <= s <= nstates
-*/
-int Write_VAR_Parameters(FILE *f, char *filename, char *header, TStateModel *model)
-{
- TMatrix X;
- int s;
- FILE *f_out;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- f_out=f ? f :dw_CreateTextFile(filename);
-
- if (!header) header="";
-
- for (s=0; s < p->nstates; s++)
- {
- X=MakeA0((TMatrix)NULL,s,p);
- fprintf(f_out,"//== %sA0[%d] ==//\n",header,s+1);
- dw_PrintMatrix(f_out,X,"%22.14le ");
- fprintf(f_out,"\n");
- FreeMatrix(X);
-
- X=MakeAplus((TMatrix)NULL,s,p);
- fprintf(f_out,"//== %sAplus[%d] ==//\n",header,s+1);
- dw_PrintMatrix(f_out,X,"%22.14le ");
- fprintf(f_out,"\n");
- FreeMatrix(X);
-
- X=MakeZeta((TMatrix)NULL,s,p);
- fprintf(f_out,"//== %sZeta[%d] ==//\n",header,s+1);
- dw_PrintMatrix(f_out,X,"%22.14le ");
- fprintf(f_out,"\n");
- FreeMatrix(X);
- }
-
- if (!f) fclose(f_out);
-
- return 1;
-}
-
-/*
- Writes the headers for Write_VAR_ParametersFlat(). This routine can
- be used to give the ordering for Write_VAR_ParametersFlat().
-*/
-int Write_VAR_ParametersFlat_Headers(FILE *f_out, TStateModel *model)
-{
- int i, j, s;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- if (!f_out) return 0;
-
- for (s=0; s < p->nstates; s++)
- {
- for (j=0; j < p->nvars; j++)
- for (i=0; i < p->nvars; i++)
- fprintf(f_out,"A0[%d](%d,%d) ",s+1,i+1,j+1);
-
- for (j=0; j < p->nvars; j++)
- for (i=0; i < p->npre; i++)
- fprintf(f_out,"Aplus[%d](%d,%d) ",s+1,i+1,j+1);
-
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"Zeta[%d](%d,%d) ",s+1,j+1,j+1);
- }
-
- return 1;
-}
-
-/*
- For each state the VAR parameters are printed as follows
- A0 (by columns)
- Aplus (by columns)
- Zeta (diagonal)
-*/
-int Write_VAR_ParametersFlat(FILE *f, TStateModel *model, char *fmt)
-{
- TMatrix A0, Aplus;
- int s, i, j;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- if (!f) return 0;
-
- if (!fmt) fmt="%lf ";
-
- A0=CreateMatrix(p->nvars,p->nvars);
- Aplus=CreateMatrix(p->npre,p->nvars);
-
- for (s=0; s < p->nstates; s++)
- {
- MakeA0(A0,s,p);
- for (j=0; j < p->nvars; j++)
- for (i=0; i < p->nvars; i++)
- fprintf(f,fmt,ElementM(A0,i,j));
-
-
- MakeAplus(Aplus,s,p);
- for (j=0; j < p->nvars; j++)
- for (i=0; i < p->npre; i++)
- fprintf(f,fmt,ElementM(Aplus,i,j));
-
- for (j=0; j < p->nvars; j++)
- fprintf(f,fmt,p->Zeta[j][p->var_states[j][s]]);
- }
-
- FreeMatrix(Aplus);
- FreeMatrix(A0);
-
- return 1;
-}
-
-/*
- For each state the VAR parameters are printed as follows
- A0 (by columns)
- Aplus (by columns)
- Zeta (diagonal)
- The system is normalized so that the diagonal of A0 is one.
-*/
-int Write_VAR_ParametersFlat_A0_Diagonal_One(FILE *f, TStateModel *model, char *fmt)
-{
- TMatrix A0, Aplus;
- TVector i_diagonal, s_diagonal;
- int s, i, j;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
- PRECISION x;
-
- if (!f) return 0;
-
- if (!fmt) fmt="%lf ";
-
- A0=CreateMatrix(p->nvars,p->nvars);
- Aplus=CreateMatrix(p->npre,p->nvars);
- s_diagonal=CreateVector(p->nvars);
- i_diagonal=CreateVector(p->nvars);
-
- for (s=0; s < p->nstates; s++)
- {
- MakeA0(A0,s,p);
- for (i=p->nvars-1; i >= 0; i--)
- {
- ElementV(i_diagonal,i)=1.0/(x=ElementM(A0,i,i));
- ElementV(s_diagonal,i)=x*x;
- }
-
- for (j=0; j < p->nvars; j++)
- for (i=0; i < p->nvars; i++)
- fprintf(f,fmt,ElementM(A0,i,j)*ElementV(i_diagonal,j));
-
- MakeAplus(Aplus,s,p);
- for (j=0; j < p->nvars; j++)
- for (i=0; i < p->npre; i++)
- fprintf(f,fmt,ElementM(Aplus,i,j)*ElementV(i_diagonal,j));
-
- for (j=0; j < p->nvars; j++)
- fprintf(f,fmt,p->Zeta[j][p->var_states[j][s]] * ElementV(s_diagonal,j));
- }
-
- FreeVector(i_diagonal);
- FreeVector(s_diagonal);
- FreeMatrix(Aplus);
- FreeMatrix(A0);
-
- return 1;
-}
-
-/*
- Attempts to read all parameters. The identifiers are
-
- //== <id>States ==//
- //== <id>Transition matrix[] ==//
- //== <id>A0[s] ==//
- //== <id>Aplus[s] ==//
- //== <id>Zeta[s] ==//
-
- for 1 <= s <= nstates
-*/
-void ReadAllParameters(FILE *f, char *filename, char *id, TStateModel *model)
-{
- char *buffer, *fmt="//== %sStates ==//";
- FILE *f_in=f ? f :dw_OpenTextFile(filename);
-
- if (!id) id="";
-
- sprintf(buffer=(char*)malloc(strlen(fmt) + strlen(id) - 1),fmt,id);
- ReadArray_VARio(f_in,buffer,model->sv->S);
- free(buffer);
-
- ReadTransitionMatrices(f_in,(char*)NULL,id,model);
- Read_VAR_Parameters(f_in,(char*)NULL,id,model);
-}
-
-/*
- Attempts to write all parameters using a format readable by the routine
- ReadAllParameters().
-*/
-void WriteAllParameters(FILE *f, char *filename, char *id, TStateModel *model)
-{
- FILE *f_in=f ? f : dw_CreateTextFile(filename);
-
- if (!id) id="";
-
- fprintf(f_in,"//== %sStates ==//\n",id);
- dw_PrintArray(f_in,model->sv->S,(char*)NULL);
- fprintf(f_in,"\n");
-
- WriteTransitionMatrices(f_in,(char*)NULL,id,model);
- Write_VAR_Parameters(f_in,(char*)NULL,id,model);
-}
-
-/*******************************************************************************/
-/******************************** Input/Output *********************************/
-/*******************************************************************************/
-void Write_ReducedFormVAR_Parameters(FILE *f, char *filename, T_VAR_Parameters *p)
-{
- TMatrix A0, Aplus, Zeta, C, Sigma;
- int k;
- FILE *f_out;
-
- f_out=f ? f :dw_CreateTextFile(filename);
-
- A0=CreateMatrix(p->nvars,p->nvars);
- Aplus=CreateMatrix(p->npre,p->nvars);
- Zeta=CreateMatrix(p->nvars,p->nvars);
- C=CreateMatrix(p->npre,p->nvars);
- Sigma=CreateMatrix(p->nvars,p->nvars);
-
- for (k=0; k < p->nstates; k++)
- {
- MakeA0(A0,k,p);
- MakeAplus(Aplus,k,p);
- MakeZeta(Zeta,k,p);
-
- //ProductInverseMM(C,Aplus,A0);
- //ProductMM(A0,A0,Xi);
- //ProductTransposeMM(Sigma,A0,A0);
- //Inverse_LU(Sigma,Sigma);
-
- fprintf(f_out,"//== Reduced Form[%d] ==//\n",k+1);
- dw_PrintMatrix(f_out,C,"%lf ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Variance[%d] ==//\n",k+1);
- dw_PrintMatrix(f_out,Sigma,"%lf ");
- fprintf(f_out,"\n");
- }
-
- FreeMatrix(A0);
- FreeMatrix(Aplus);
- FreeMatrix(Zeta);
- FreeMatrix(C);
- FreeMatrix(Sigma);
-
- if (!f) fclose(f_out);
-}
-
-/*
- Create Model from data file. Assumes that the state variables have a flat
- structure.
-*/
-void Write_VAR_Info(FILE *f, char *filename, T_VAR_Parameters *p)
-{
- FILE *f_out;
- int j;
-
- if (!f)
- f_out=dw_CreateTextFile(filename);
- else
- f_out=f;
-
- //=== Write sizes ===//
- fprintf(f_out,"//== Number Observations ==//\n%d\n\n",p->nobs);
- fprintf(f_out,"//== Number Variables ==//\n%d\n\n",p->nvars);
- fprintf(f_out,"//== Number Lags ==//\n%d\n\n",p->nlags);
- fprintf(f_out,"//== Exogenous Variables ==//\n%d\n\n",p->npre - p->nvars * p->nlags);
-
- //=== Restrictions - U[j] ===//
- fprintf(f_out,"//== Number of free parameters in jth column of A0 ==//\n");
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"%d ",ColM(p->U[j]));
- fprintf(f_out,"\n\n");
- fprintf(f_out,"//== U[j] 0 <= j < nvars ==//\n");
- for (j=0; j < p->nvars; j++)
- {
- dw_PrintMatrix(f_out,p->U[j],"%lf ");
- fprintf(f_out,"\n");
- }
-
- //=== Restrictions - V[j] ===//
- fprintf(f_out,"//== Number of free parameters in jth column of Aplus ==//\n");
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"%d ",p->V[j] ? ColM(p->V[j]) : 0);
- fprintf(f_out,"\n\n");
- fprintf(f_out,"//== V[j] 0 <= j < nvars ==//\n");
- for (j=0; j < p->nvars; j++)
- if (p->V[j])
- {
- dw_PrintMatrix(f_out,p->V[j],"%lf ");
- fprintf(f_out,"\n");
- }
-
- //=== Restrictions - W[j] ===//
- fprintf(f_out,"//== Non-zero W[j] ==//\n");
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"%d ",p->W[j] ? 1 : 0);
- fprintf(f_out,"\n\n");
- fprintf(f_out,"//== W[j] 0 <= j < nvars ==//\n");
- for (j=0; j < p->nvars; j++)
- if (p->W[j])
- {
- dw_PrintMatrix(f_out,p->W[j],"%lf ");
- fprintf(f_out,"\n");
- }
-
- //====== Priors ======
- fprintf(f_out,"//== Gamma prior on Xi ==//\n");
- for (j=0; j < p->nvars; j++)
- fprintf(f_out,"%lf %lf\n",ElementV(p->zeta_a_prior,j),ElementV(p->zeta_b_prior,j));
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Prior on jth column of A0 - Gaussian variance ==//\n");
- for (j=0; j < p->nvars; j++)
- {
- dw_PrintMatrix(f_out,p->A0_prior[j],"%lf ");
- fprintf(f_out,"\n");
- }
-
- fprintf(f_out,"//== Prior on jth column of Aplus - Gaussian variance ==//\n");
- for (j=0; j < p->nvars; j++)
- {
- dw_PrintMatrix(f_out,p->Aplus_prior[j],"%lf ");
- fprintf(f_out,"\n");
- }
-
-/* //====== coefficient/variance state variables ====== */
-/* CStates=dw_CreateRegularArrayList_int(2,p->nvars,sv->n_state_variables); */
-/* id="//== Controlling states variables for coefficients ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,CStates)) dw_Error(PARSE_ERR); */
-
-/* VStates=dw_CreateRegularArrayList_int(2,p->nvars,sv->n_state_variables); */
-/* id="//== Controlling states variables for variance ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,VStates)) dw_Error(PARSE_ERR); */
-
-/* //=== Read Data === */
-/* if (!dw_SetFilePosition(f_in,"//== Data Y (T x nvars) ==//") */
-/* || !dw_SetFilePosition(f_in,"//== Data X (T x npre) ==//")) */
-/* p->X=p->Y=(TVector*)NULL; */
-/* else */
-/* { */
-/* // Initialize Y */
-/* id="//== Data Y (T x nvars) ==//"; */
-/* if (!dw_SetFilePosition(f_in,id)) dw_Error(PARSE_ERR); */
-/* p->Y=dw_CreateArray_vector(p->nobs+1); */
-/* for (t=1; t <= p->nobs; t++) */
-/* if (!dw_ReadVector(f_in,p->Y[t]=CreateVector(p->nvars))) dw_Error(PARSE_ERR); */
-
-/* // Initialize X */
-/* id="//== Data X (T x npre) ==//"; */
-/* if (!dw_SetFilePosition(f_in,id)) dw_Error(PARSE_ERR); */
-/* p->X=dw_CreateArray_vector(p->nobs+1); */
-/* for (t=1; t <= p->nobs; t++) */
-/* if (!dw_ReadVector(f_in,p->X[t]=CreateVector(p->npre))) */
-/* dw_Error(PARSE_ERR); */
-/* } */
-
- //=== Close output file ===
- if (!f) fclose(f_out);
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*
- Create Model from data file. Assumes that the state variables have a flat
- structure.
-*/
-/**
-TStateModel* CreateStateModel_VAR_File(FILE *f, char *filename)
-{
- TMarkovStateVariable *sv;
- T_VAR_Parameters *p;
-
- //=== Create Markov State Variable ===
- sv=CreateMarkovStateVariable_File(f,filename,0);
-
- //=== Create VAR Parameters
- p=Create_VAR_Parameters_File(f,filename,sv);
-
- //=== Create TStateModel ===
- return CreateStateModel_new(sv,CreateRoutines_VAR(),p);
-}
-/**/
diff --git a/matlab/swz/c-code/sbvar/var/VARio.h b/matlab/swz/c-code/sbvar/var/VARio.h
deleted file mode 100644
index 6b90503ea5a613837bce2a5f7041e8f96b4e88b2..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/VARio.h
+++ /dev/null
@@ -1,26 +0,0 @@
-
-#ifndef __VAR_INPUT_OUTPUT__
-#define __VAR_INPUT_OUTPUT__
-
-#include "switch.h"
-#include "VARbase.h"
-
-void Write_VAR_Specification(FILE *f, char *filename, TStateModel *model);
-TStateModel* Read_VAR_Specification(FILE *f, char *filename);
-
-int Write_VAR_Parameters(FILE *f, char *filename, char *id, TStateModel *model);
-int Read_VAR_Parameters(FILE *f, char *filename, char *id, TStateModel *model);
-int Write_VAR_ParametersFlat(FILE *f, TStateModel *model, char *fmt);
-int Write_VAR_ParametersFlat_Headers(FILE *f_out, TStateModel *model);
-int Write_VAR_ParametersFlat_A0_Diagonal_One(FILE *f, TStateModel *model, char *fmt);
-
-void ReadAllParameters(FILE *f, char *filename, char *id, TStateModel *model);
-void WriteAllParameters(FILE *f, char *filename, char *id, TStateModel *model);
-
-//T_VAR_Parameters* Create_VAR_Parameters_File(FILE *f, char *filename, TMarkovStateVariable *sv);
-//TStateModel* CreateStateModel_VAR_File(FILE *f, char *filename);
-
-//void PrintParametersVAR(FILE *f_out, TStateModel *model);
-//void Write_VAR_Info(FILE *f, char *filename, T_VAR_Parameters *p);
-
-#endif
diff --git a/matlab/swz/c-code/sbvar/var/VARio_matlab.c b/matlab/swz/c-code/sbvar/var/VARio_matlab.c
deleted file mode 100644
index 766b78b56a69de804e2d44f02dc7fb4482cdd611..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/VARio_matlab.c
+++ /dev/null
@@ -1,510 +0,0 @@
-
-#include "VARio_matlab.h"
-#include "switchio.h"
-
-#include "dw_error.h"
-#include "dw_ascii.h"
-
-#include <stdlib.h>
-#include <string.h>
-
-static int ReadError_VARio_matlab(char *id)
-{
- char *errmsg, *fmt="Error after line identifier ""%s""";
- sprintf(errmsg=(char*)malloc(strlen(fmt) + strlen(id) - 1),fmt,id);
- dw_UserError(errmsg);
- free(errmsg);
- return 1;
-}
-
-TStateModel* Combine_matlab_standard(char *matlabfile, char *standardfile)
-{
- FILE *f_in;
- TStateModel *model;
- TMarkovStateVariable *sv, ***coef_sv, ***var_sv;
- T_VAR_Parameters *p;
- char *id;
- int *IV, **States;
- int nlags, nvars, nexg, npre, nstates, nobs, i, j, n, SimsZha=1, RandomWalk=1, flag;
- PRECISION scalar_zeta_a_prior, scalar_zeta_b_prior, lambda_prior;
- int **coef_states, **var_states;
- TMatrix *U, *V, *W, *A0_prior, *Aplus_prior, X, Y, S;
- TVector zeta_a_prior, zeta_b_prior;
-
- //=== Open matlab input file
- f_in=dw_OpenTextFile(matlabfile);
-
- //=== Read sizes ===//
- id="//== lags, nvar, nStates, T ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %d %d %d %d ",&nlags,&nvars,&nstates,&nobs) != 4)) ReadError_VARio_matlab(id);
-
- //=== A single constant term ===//
- nexg=1;
- npre=nvars * nlags + nexg;
-
- //=== Restrictions - U[j] ===//
- IV=dw_CreateArray_int(nvars);
- id="//== n0const: nvar-by-1 ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,IV)) ReadError_VARio_matlab(id);
- id="//== Uiconst: cell(nvar,1) and nvar-by-n0const(i) for the ith cell (equation) ==//";
- if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id);
- U=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (!dw_ReadMatrix(f_in,U[j]=CreateMatrix(nvars,IV[j]))) ReadError_VARio_matlab(id);
- dw_FreeArray(IV);
-
- //=== Restrictions - V[j] (V[j] should be an npre x npre identity matrix) ===//
- IV=dw_CreateArray_int(nvars);
- id="//== npconst: nvar-by-1 ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,IV)) ReadError_VARio_matlab(id);
- for (j=nvars-1; j >= 0; j--)
- if (IV[j] != npre) SimsZha=0;
- V=dw_CreateArray_matrix(nvars);
- if (SimsZha)
- {
- for (j=nvars-1; j >= 0; j--)
- V[j]=IdentityMatrix((TMatrix)NULL,npre);
- }
- else
- {
- id="//== Viconst: cell(nvar,1) and ncoef-by-n0const(i) for the ith cell (equation) ==//";
- if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id);
- for (j=0; j < nvars; j++)
- if (!dw_ReadMatrix(f_in,V[j]=CreateMatrix(npre,IV[j]))) ReadError_VARio_matlab(id);
- }
- dw_FreeArray(IV);
-
- //=== Restrictions - W[j] (Random walk specification) ===//
- InitializeMatrix(S=CreateMatrix(npre,nvars),0.0);
- for (j=nvars-1; j >= 0; j--) ElementM(S,j,j)=-1.0;
- W=dw_CreateArray_matrix(nvars);
- for (j=nvars-1; j >= 0; j--)
- W[j]=EquateMatrix((TMatrix)NULL,S);
- FreeMatrix(S);
-
- //====== Priors ======
- id="//== gxia: alpha parameter for gamma prior of xi ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %lf ",&scalar_zeta_a_prior) != 1)) ReadError_VARio_matlab(id);
- id="//== gxib: beta parameter for gamma prior of xi ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %lf ",&scalar_zeta_b_prior) != 1)) ReadError_VARio_matlab(id);
- zeta_a_prior=CreateVector(nvars);
- zeta_b_prior=CreateVector(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- ElementV(zeta_a_prior,j)=scalar_zeta_a_prior;
- ElementV(zeta_b_prior,j)=scalar_zeta_b_prior;
- }
-
- id="//== H0barconstcell: cell(nvar,1) and n-by-n for the ith cell (equation) ==//";
- if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id);
- A0_prior=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (!dw_ReadMatrix(f_in,A0_prior[j]=CreateMatrix(nvars,nvars))) ReadError_VARio_matlab(id);
-
- id="//== Hpbarconstcell: cell(nvar,1) and ncoef-by-ncoef for the ith cell (equation) ==//";
- if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id);
- Aplus_prior=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (!dw_ReadMatrix(f_in,Aplus_prior[j]=CreateMatrix(npre,npre))) ReadError_VARio_matlab(id);
-
- // Initialize Y
- id="//== Yleft -- Y: T-by-nvar ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,Y=CreateMatrix(nobs,nvars))) ReadError_VARio_matlab(id);
-
- // Initialize X
- id="//== Xright -- X: T-by-ncoef ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,X=CreateMatrix(nobs,npre))) ReadError_VARio_matlab(id);
-
- //=== Sims-Zha specification ===
- id="//== glamdasig: sigma parameter for normal prior of lamda ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %lf ",&lambda_prior) != 1)) ReadError_VARio_matlab(id);
- lambda_prior*=lambda_prior;
-
- //=== Close matlab input file ===
- fclose(f_in);
-
- //=== Open standard input file
- f_in=dw_OpenTextFile(standardfile);
-
- //=== Create Markov state variable ===//
- sv=CreateMarkovStateVariable_File(f_in,(char*)NULL,nobs);
-
- //====== coefficient/variance state variables ======
- id="//== Controlling states variables for coefficients ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,States=dw_CreateRectangularArray_int(nvars,sv->n_state_variables)))
- ReadError_VARio_matlab(id);
- coef_sv=(TMarkovStateVariable ***)dw_CreateArray_array(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- for (n=i=0; i < sv->n_state_variables; i++)
- if (States[j][i]) n++;
- if (n > 0)
- {
- coef_sv[j]=(TMarkovStateVariable **)dw_CreateArray_pointer(n,NULL);
- for (n=i=0; i < sv->n_state_variables; i++)
- if (States[j][i]) coef_sv[j][n++]=sv->state_variable[i];
- }
- }
- coef_states=CreateTranslationMatrix(coef_sv,sv);
- dw_FreeArray(States);
- dw_FreeArray(coef_sv);
-
- id="//== Controlling states variables for variance ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,States=dw_CreateRectangularArray_int(nvars,sv->n_state_variables)))
- ReadError_VARio_matlab(id);
- var_sv=(TMarkovStateVariable ***)dw_CreateArray_array(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- for (n=i=0; i < sv->n_state_variables; i++)
- if (States[j][i]) n++;
- if (n > 0)
- {
- var_sv[j]=(TMarkovStateVariable **)dw_CreateArray_pointer(n,NULL);
- for (n=i=0; i < sv->n_state_variables; i++)
- if (States[j][i]) var_sv[j][n++]=sv->state_variable[i];
- }
- }
- var_states=CreateTranslationMatrix(var_sv,sv);
- dw_FreeArray(States);
- dw_FreeArray(var_sv);
-
- //=== Close standard input file ===
- fclose(f_in);
-
- //=== Create T_VAR_Parameters structure ===
- flag=SimsZha ? SPEC_SIMS_ZHA : 0;
- flag|=RandomWalk ? SPEC_RANDOM_WALK : 0;
- p=CreateTheta_VAR(flag,nvars,nlags,nexg,sv->nstates,sv->nobs,coef_states,var_states,U,V,W,Y,X);
- if (flag & SPEC_SIMS_ZHA)
- SetPriors_VAR_SimsZha(p,A0_prior,Aplus_prior,zeta_a_prior,zeta_b_prior,lambda_prior);
- else
- SetPriors_VAR(p,A0_prior,Aplus_prior,zeta_a_prior,zeta_b_prior);
-
- //p=Create_VAR_Parameters(nvars,nlags,nexg,sv->nstates,sv->nobs,U,V,W,Zeta_a_prior,Zeta_b_prior,A0_prior,Aplus_prior,Y,X,coef_states,var_states);
- //SetupSimsZhaSpecification(p,delta_prior*delta_prior);
-
- //=== Create TStateModel ===
- model=CreateStateModel_new(sv,CreateRoutines_VAR(),p);
-
- //=== Print Model specifications to file ===
-
- //=== Free memory ===
- FreeMatrix(X);
- FreeMatrix(Y);
- dw_FreeArray(Aplus_prior);
- dw_FreeArray(A0_prior);
- FreeVector(zeta_b_prior);
- FreeVector(zeta_a_prior);
- dw_FreeArray(W);
- dw_FreeArray(V);
- dw_FreeArray(U);
-
- return model;
-}
-
-/*
- This reads the constant parameters from filename, which was created
- from Matlab and then sets all the parameters to the constant parameters.
-*/
-void ReadConstantParameters(char *filename, TStateModel *model)
-{
- char *id;
- int i, j, s;
- FILE *f_in;
- TMatrix A0, Aplus;
- T_VAR_Parameters *p=(T_VAR_Parameters*)(model->theta);
-
- if (!(f_in=fopen(filename,"rt")))
- {
- printf("Unable to read the input data file: %s\n", filename);
- exit(0);
- }
-
- // A0
- id="//== A0hat: nvar-by-nvar ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,A0=CreateMatrix(p->nvars,p->nvars))) ReadError_VARio_matlab(id);
- for (j=p->nvars-1; j >= 0; j--)
- for (s=p->n_coef_states[j]-1; s >= 0; s--)
- for (i=p->nvars-1; i >= 0; i--)
- ElementV(p->A0[j][s],i)=ElementM(A0,i,j);
- FreeMatrix(A0);
-
- // Aplus
- id="//== Aphat: ncoef(lags*nvar+1)-by-nvar ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,Aplus=CreateMatrix(p->npre,p->nvars))) ReadError_VARio_matlab(id);
- for (j=p->nvars-1; j >= 0; j--)
- for (s=p->n_coef_states[j]-1; s >= 0; s--)
- for (i=p->npre-1; i >= 0; i--)
- ElementV(p->Aplus[j][s],i)=ElementM(Aplus,i,j);
- FreeMatrix(Aplus);
-
- // Zeta
- for (j=p->nvars-1; j >= 0; j--)
- for (s=p->n_var_states[j]-1; s >= 0; s--)
- p->Zeta[j][s]=1.0;
-
- // b0, bplus, lambda, and psi
- Update_b0_bplus_from_A0_Aplus(p);
- if (p->Specification & SPEC_SIMS_ZHA) Update_lambda_psi_from_bplus(p);
-
- // Flags
- p->valid_parameters=1;
-
- // Transition matrix
- SetTransitionMatrixToPriorMean(model);
-
- ThetaChanged(model);
-}
-
-/*
- Create Model from Matlab data file
-*/
-TStateModel* CreateStateModel_VAR_matlab(char *filename)
-{
- T_VAR_Parameters *p;
- FILE *f_in;
- char *id;
- TMatrix PriorTransitionMatrix, S;
- int *IV, **IM;
- PRECISION scalar_Zeta_a_prior, scalar_Zeta_b_prior, lambda_prior;
- int i, j, nvars, nlags, nexg, npre, nobs, nstates;
- TMatrix *U, *V, *W;
- TVector Zeta_a_prior, Zeta_b_prior;
- TMatrix *A0_prior, *Aplus_prior;
- TMatrix Y, X;
- int **coef_states, **var_states;
- TMarkovStateVariable *sv;
-
- //=== Open file ===
- if (!(f_in=fopen(filename,"rt")))
- {
- printf("Unable to read the input data file: %s\n", filename);
- exit(0);
- }
-
- //=== Read sizes ===//
- id="//== lags, nvar, nStates, T ==//";
- if (!dw_SetFilePosition(f_in,id)
- || (fscanf(f_in," %d %d %d %d ",&nlags,&nvars,&nstates,&nobs) != 4)) ReadError_VARio_matlab(id);
-
- //=== A single constant term ===//
- nexg=1;
- npre=nvars * nlags + nexg;
-
- //=== Restrictions - U[j] ===//
- IV=dw_CreateArray_int(nvars);
- id="//== n0const: nvar-by-1 ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,IV)) ReadError_VARio_matlab(id);
- id="//== Uiconst: cell(nvar,1) and nvar-by-n0const(i) for the ith cell (equation) ==//";
- if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id);
- U=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (!dw_ReadMatrix(f_in,U[j]=CreateMatrix(nvars,IV[j]))) ReadError_VARio_matlab(id);
- dw_FreeArray(IV);
-
- //=== Restrictions - V[j] (V[j] should be an npre x npre identity matrix) ===//
- IV=dw_CreateArray_int(nvars);
- id="//== npconst: nvar-by-1 ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,IV)) ReadError_VARio_matlab(id);
- for (j=nvars-1; j >= 0; j--)
- if (IV[j] != npre)
- {
- fprintf(stderr,"V[%d] not %d x %d\n",j,npre,npre);
- exit(0);
- }
- V=dw_CreateArray_matrix(nvars);
- for (j=nvars-1; j >= 0; j--)
- V[j]=IdentityMatrix((TMatrix)NULL,npre);
- dw_FreeArray(IV);
-
- //=== Restrictions - W[j] (Random walk specification) ===//
- InitializeMatrix(S=CreateMatrix(npre,nvars),0.0);
- for (j=nvars-1; j >= 0; j--) ElementM(S,j,j)=-1.0;
- W=dw_CreateArray_matrix(nvars);
- for (j=nvars-1; j >= 0; j--)
- W[j]=EquateMatrix((TMatrix)NULL,S);
- FreeMatrix(S);
-
- //=== Create TMarkovStateVariable ===//
- PriorTransitionMatrix=CreateMatrix(nstates,nstates);
- id="//== Galpha: nStates-by-nStates ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,PriorTransitionMatrix)) ReadError_VARio_matlab(id);
- sv=CreateMarkovStateVariable_NoRestrictions(nstates,nobs,PriorTransitionMatrix);
- FreeMatrix(PriorTransitionMatrix);
-
- //====== regime/shock state variables ======
- coef_states=dw_CreateRectangularArray_int(nvars,nstates);
- var_states=dw_CreateRectangularArray_int(nvars,nstates);
- IM=dw_CreateRectangularArray_int(nvars,2);
- id="//== indxEqnTv_m: nvar-by-2 ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,IM)) ReadError_VARio_matlab(id);
- for (j=nvars-1; j >= 0; j--)
- switch (IM[j][1])
- {
- case 1:
- for (i=nstates-1; i >= 0; i--)
- coef_states[j][i]=var_states[j][i]=0;
- break;
- case 2:
- for (i=nstates-1; i >= 0; i--)
- {
- coef_states[j][i]=0;
- var_states[j][i]=i;
- }
- break;
- case 3:
- for (i=nstates-1; i >= 0; i--)
- {
- coef_states[j][i]=i;
- var_states[j][i]=0;
- }
- break;
- case 4:
- fprintf(stderr,"Case %d not implimented.\n",4);
- exit(0);
- default:
- fprintf(stderr,"Unknown type.\n");
- exit(0);
- }
- dw_FreeArray(IM);
-
- //====== Priors ======
- id="//== gxia: alpha parameter for gamma prior of xi ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %lf ",&scalar_Zeta_a_prior) != 1)) ReadError_VARio_matlab(id);
- id="//== gxib: beta parameter for gamma prior of xi ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %lf ",&scalar_Zeta_b_prior) != 1)) ReadError_VARio_matlab(id);
- Zeta_a_prior=CreateVector(nvars);
- Zeta_b_prior=CreateVector(nvars);
- for (j=nvars-1; j >= 0; j--)
- {
- ElementV(Zeta_a_prior,j)=scalar_Zeta_a_prior;
- ElementV(Zeta_b_prior,j)=scalar_Zeta_b_prior;
- }
-
- id="//== H0barconstcell: cell(nvar,1) and n-by-n for the ith cell (equation) ==//";
- if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id);
- A0_prior=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (!dw_ReadMatrix(f_in,A0_prior[j]=CreateMatrix(nvars,nvars))) ReadError_VARio_matlab(id);
-
- id="//== Hpbarconstcell: cell(nvar,1) and ncoef-by-ncoef for the ith cell (equation) ==//";
- if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id);
- Aplus_prior=dw_CreateArray_matrix(nvars);
- for (j=0; j < nvars; j++)
- if (!dw_ReadMatrix(f_in,Aplus_prior[j]=CreateMatrix(npre,npre))) ReadError_VARio_matlab(id);
-
-/* //=========================== Checks */
-/* TMatrix *H0, *Ui; */
-/* int *n0s; */
-/* TMatrix Sigma, XX, YY, ZZ; */
-/* int i, ii, jj; */
-/* PRECISION max; */
-
-/* id="//== n0s: nvar-by-1 ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,n0s=dw_CreateArray_int(nvars))) ReadError_VARio_matlab(id); */
-
-/* id="//== H0tldcell_inv: cell(nvar,1) and n0s(i)-by-n0s(i) for the ith cell ==//"; */
-/* if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id); */
-/* H0=dw_CreateArray_matrix(nvars); */
-/* for (j=0; j < nvars; j++) */
-/* if (!dw_ReadMatrix(f_in,H0[j]=CreateMatrix(n0s[j],n0s[j]))) ReadError_VARio_matlab(id); */
-
-/* id="//== Ui: cell(nvar,1) and nvar*nStates-by-n0s(i) for the ith cell ==//"; */
-/* if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id); */
-/* Ui=dw_CreateArray_matrix(nvars); */
-/* for (j=0; j < nvars; j++) */
-/* if (!dw_ReadMatrix(f_in,Ui[j]=CreateMatrix(nvars*nstates,n0s[j]))) ReadError_VARio_matlab(id); */
-
-/* Sigma=CreateMatrix(nvars*nstates,nvars*nstates); */
-/* XX=CreateMatrix(nvars,nvars); */
-/* for (j=0; j < nvars; j++) */
-/* { */
-/* InitializeMatrix(Sigma,0.0); */
-/* Inverse_LU(XX,A0_prior[j]); */
-/* for (i=0; i < nstates; i++) */
-/* for (ii=0; ii < nvars; ii++) */
-/* for (jj=0; jj < nvars; jj++) */
-/* ElementM(Sigma,i*nvars+ii,i*nvars+jj)=ElementM(XX,ii,jj); */
-/* YY=TransposeProductMM((TMatrix)NULL,Ui[j],Sigma); */
-/* ZZ=ProductMM((TMatrix)NULL,YY,Ui[j]); */
-
-/* fprintf(stdout,"Computed[%d]\n",j); dw_PrintMatrix(stdout,ZZ,"%le "); fprintf(stdout,"\n"); */
-/* fprintf(stdout,"File[%d]\n",j); dw_PrintMatrix(stdout,H0[j],"%le "); fprintf(stdout,"\n"); */
-/* max=0.0; */
-/* for (ii=0; ii < RowM(ZZ); ii++) */
-/* for (jj=0; jj < ColM(ZZ); jj++) */
-/* if (max < fabs(ElementM(H0[j],ii,jj) - ElementM(ZZ,ii,jj))) max=fabs(ElementM(H0[j],ii,jj) - ElementM(ZZ,ii,jj)); */
-/* fprintf(stdout,"H0: max[%d] = %le\n",j,max); */
-
-/* FreeMatrix(ZZ); */
-/* FreeMatrix(YY); */
-/* getc(stdin); */
-/* } */
-/* //exit(0); */
-
-/* id="//== nps: nvar-by-1 ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,n0s=dw_CreateArray_int(nvars))) ReadError_VARio_matlab(id); */
-
-/* id="//== Hptldcell_inv: cell(nvar,1) and nps(i)-by-nps(i) for the ith cell ==//"; */
-/* if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id); */
-/* H0=dw_CreateArray_matrix(nvars); */
-/* for (j=0; j < nvars; j++) */
-/* if (!dw_ReadMatrix(f_in,H0[j]=CreateMatrix(n0s[j],n0s[j]))) ReadError_VARio_matlab(id); */
-
-/* id="//== Vi: cell(nvar,1) and k*nStates-by-nps(i) for the ith cell ==//"; */
-/* if (!dw_SetFilePosition(f_in,id)) ReadError_VARio_matlab(id); */
-/* Ui=dw_CreateArray_matrix(nvars); */
-/* for (j=0; j < nvars; j++) */
-/* if (!dw_ReadMatrix(f_in,Ui[j]=CreateMatrix(npre*nstates,n0s[j]))) ReadError_VARio_matlab(id); */
-
-/* Sigma=CreateMatrix(npre*nstates,npre*nstates); */
-/* XX=CreateMatrix(npre,npre); */
-/* for (j=0; j < nvars; j++) */
-/* { */
-/* InitializeMatrix(Sigma,0.0); */
-/* Inverse_LU(XX,Aplus_prior[j]); */
-/* for (i=0; i < nstates; i++) */
-/* for (ii=0; ii < npre; ii++) */
-/* for (jj=0; jj < npre; jj++) */
-/* ElementM(Sigma,i*npre+ii,i*npre+jj)=ElementM(XX,ii,jj); */
-/* YY=TransposeProductMM((TMatrix)NULL,Ui[j],Sigma); */
-/* ZZ=ProductMM((TMatrix)NULL,YY,Ui[j]); */
-
-/* max=0.0; */
-/* for (ii=0; ii < RowM(ZZ); ii++) */
-/* for (jj=0; jj < ColM(ZZ); jj++) */
-/* if (max < fabs(ElementM(H0[j],ii,jj) - ElementM(ZZ,ii,jj))) max=fabs(ElementM(H0[j],ii,jj) - ElementM(ZZ,ii,jj)); */
-/* fprintf(stdout,"max[%d] = %le\n",j,max); */
-
-/* FreeMatrix(ZZ); */
-/* FreeMatrix(YY); */
-/* getc(stdin); */
-/* } */
-/* exit(0); */
-/* //=========================== Checks */
-
- // Initialize Y
- id="//== Yleft -- Y: T-by-nvar ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,Y=CreateMatrix(nobs,nvars))) ReadError_VARio_matlab(id);
-
- // Initialize X
- id="//== Xright -- X: T-by-ncoef ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,X=CreateMatrix(nobs,npre))) ReadError_VARio_matlab(id);
-
- //=== Create T_VAR_Parameters structure ===
- p=CreateTheta_VAR(SPEC_SIMS_ZHA | SPEC_RANDOM_WALK,nvars,nlags,nexg,nstates,nobs,coef_states,var_states,U,V,W,Y,X);
-
- //=== Sims-Zha specification ===
- id="//== glamdasig: sigma parameter for normal prior of lamda ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %lf ",&lambda_prior) != 1)) ReadError_VARio_matlab(id);
- SetPriors_VAR_SimsZha(p,A0_prior,Aplus_prior,Zeta_a_prior,Zeta_b_prior,lambda_prior*lambda_prior);
-
- //=== Close input file ===
- fclose(f_in);
-
- //=== Create TStateModel ===
- return CreateStateModel_new(sv,CreateRoutines_VAR(),p);
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
diff --git a/matlab/swz/c-code/sbvar/var/VARio_matlab.h b/matlab/swz/c-code/sbvar/var/VARio_matlab.h
deleted file mode 100644
index 8be828e702f2095a4d6687389aef2c409a4fcb3f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/VARio_matlab.h
+++ /dev/null
@@ -1,12 +0,0 @@
-
-#ifndef __VAR_INPUT_OUTPUT_MATLAB__
-#define __VAR_INPUT_OUTPUT_MATLAB__
-
-#include "switch.h"
-#include "VARbase.h"
-
-TStateModel* Combine_matlab_standard(char *inmatlab, char *instandard);
-void ReadConstantParameters(char *filename, TStateModel *model);
-TStateModel* CreateStateModel_VAR_matlab(char *filename);
-
-#endif
diff --git a/matlab/swz/c-code/sbvar/var/command_line_VAR.c b/matlab/swz/c-code/sbvar/var/command_line_VAR.c
deleted file mode 100644
index 8b1b0854dba7a5a54ee54789e379f00ffaf3e56f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/command_line_VAR.c
+++ /dev/null
@@ -1,550 +0,0 @@
-#include "command_line_VAR.h"
-#include "VARio.h"
-#include "switchio.h"
-#include "dw_error.h"
-#include "dw_parse_cmd.h"
-#include "dw_ascii.h"
-
-#include <stdlib.h>
-#include <string.h>
-#include <ctype.h>
-
-/*
- Allocates memory for filename. Assumes that fmt is of the form
-
- %s*%s*
-
- where the first %s will be filled with dir and the second will be
- filled with tag. If either dir or tag is a null pointer, then the
- the empty string will be used. The calling routine must free the
- returned pointer.
-*/
-char* CreateFilenameFromTag(char *fmt, char *tag, char *dir)
-{
- char *filename;
- if (!tag) tag="";
- if (!dir) dir="";
- sprintf(filename=(char*)malloc(strlen(dir) + strlen(fmt) + strlen(tag) - 3),fmt,dir,tag);
- return filename;
-}
-
-/*
- Create a full path name by appending a "/" if necessary. The
- returned pathname must be freed by he calling routine.
-*/
-char* CreatePath(char *path)
-{
-#define DIR_DELIMITER '\\'
- char *fullpath;
- int n;
- if (!path) path="";
- n=(int)strlen(path);
- if (path[0] && path[n-1] != DIR_DELIMITER)
- {
- memcpy(fullpath=(char*)malloc(n+2),path,n);
- fullpath[n]=DIR_DELIMITER;
- fullpath[n+1]='\0';
- }
- else
- fullpath=dw_DuplicateString(path);
- return fullpath;
-#undef DIR_DELIMITER
-}
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-static char *help_options[]={"-di","-do","-fs","-fp","-ph","-pho","-MLE","-ft","-fto",(char*)NULL};
-static char *help_messages[]=
-{
- "-di <directory>",
- "If this argument exists, then all input files are in specified directory.",
- "-do <directory>",
- "If this argument exists, then all output files are in specified directory.",
- "-fs <filename>",
- "If this argument exists, then the specification file name is <filename>.",
- "-fp <filename>",
- "If this argument exists, then the parameter file name is <filename>.",
- "-ph <header>",
- "If this argument exists, then the parameter header is <header>. The default value is \"Posterior mode: \", unless -MLE is in the command line, in which case it is \"MLE: \".",
- "-pho <header>",
- "If this argument exists, then the parameter header used for output is <header>. The default value is -ph <header>.",
- "-MLE",
- "If this augument exists, them \"MLE: \" is the default value for -ph.",
- "-ft <tag>",
- "The input file tag. Used to create input filenames if the -fs or -fp options are not present.",
- "-fto <tag>",
- "The output file tag. Used to create output filenames. The default value is -ft <tag>.",
- (char*)NULL,
- (char*)NULL
-};
-
-static int Match(char *option, char **list, int step)
-{
- int n=0, i=0;
- while (option[n] && !isspace(option[n])) n++;
- if (n > 0)
- while (list[i])
- if (memcmp(option,list[i],n))
- i+=step;
- else
- return i;
- return -1;
-}
-
-static void PrintMessage(FILE *f, char *msg)
-{
-#define LL 76
- int k;
- char line[LL];
- while (1)
- {
- while (*msg && isspace(*msg)) msg++;
- if (!(*msg)) return;
- strncpy(line,msg,LL);
- k=LL-1;
- if (!line[k])
- {
- fprintf(f," %s\n",line);
- return;
- }
- if (isspace(line[k]))
- {
- line[k]='\0';
- msg+=k+1;
- }
- else
- {
- for ( ; k > 0 && !isspace(line[k-1]); k--);
- if (k == 0) k=LL-1;
- line[k]='\0';
- msg+=k;
- }
- fprintf(f," %s\n",line);
- }
-#undef LL
-}
-
-void PrintHelpMessages(FILE *f, char **include, char **additional)
-{
-
- int i, j;
-
- if (!f) return;
-
- if (include)
- {
- i=0;
- while (include[i])
- if ((j=Match(include[i++],help_messages,2)) != -1)
- {
- fprintf(f," %s\n",help_messages[j]);
- PrintMessage(f,help_messages[j+1]);
- }
- }
- else
- {
- i=0;
- while (help_messages[i])
- {
- fprintf(f," %s\n",help_messages[i++]);
- PrintMessage(f,help_messages[i++]);
- }
- }
-
- if (additional)
- {
- i=0;
- while (additional[i])
- {
- fprintf(f," %s\n",additional[i++]);
- PrintMessage(f,additional[i++]);
- }
- }
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-TVARCommandLine* Create_VARCommandLine(void)
-{
- TVARCommandLine *cmd=(TVARCommandLine*)malloc(sizeof(TVARCommandLine));
- if (cmd)
- {
- cmd->out_directory=(char*)NULL;
- cmd->in_directory=(char*)NULL;
- cmd->in_tag=(char*)NULL;
- cmd->out_tag=(char*)NULL;
- cmd->out_header=(char*)NULL;
-
- cmd->specification_filename=(char*)NULL;
- cmd->parameters_filename=(char*)NULL;
- cmd->parameters_header=(char*)NULL;
-
- cmd->specification_filename_actual=(char*)NULL;
- cmd->parameters_filename_actual=(char*)NULL;
- cmd->parameters_header_actual=(char*)NULL;
- }
-
- return cmd;
-}
-
-void Free_VARCommandLine(TVARCommandLine *cmd)
-{
- if (cmd)
- {
- if (cmd->out_directory) free(cmd->out_directory);
- if (cmd->in_directory) free(cmd->in_directory);
- if (cmd->in_tag) free(cmd->in_tag);
- if (cmd->out_tag) free(cmd->out_tag);
- if (cmd->out_header) free(cmd->out_header);
- if (cmd->specification_filename) free(cmd->specification_filename);
- if (cmd->parameters_filename) free(cmd->parameters_filename);
- if (cmd->parameters_header) free(cmd->parameters_header);
- if (cmd->specification_filename_actual) free(cmd->specification_filename_actual);
- if (cmd->parameters_filename_actual) free(cmd->parameters_filename_actual);
- if (cmd->parameters_header_actual) free(cmd->parameters_header_actual);
- }
-}
-
-/*
- -di <directory>
- If this argument exists, then all input files are in specified directory.
-
- -do <directory>
- If this argument exists, then all output files are in specified directory.
-
- -fs <filename>
- If this argument exists, then the specification file name is <filename>.
- The argument -fs takes precedence over -ft.
-
- -fp <filename>
- If this argument exists, then the parameter file name is <filename>. The
- default value is the filename associated with the argument -fs or -ft.
-
- -ph <header>
- If this argument exists, then the header for the parameters is <header>.
- The default value is "MLE: " if -MLE is in the command line and
- "Posterior mode: " otherwise.
-
- -pho <header>
- If this argument exists, then the parameter header used for output is
- <header>. The default value is -ph <header>.
-
- -MLE
- If this augument exists, default value for the parameters header is "MLE: ".
- This assumes that the estimate file was produced via a maximum likelihood
- estimate.
-
- -ft <tag>
- The input file tag. Used to create input filenames if the -fs or
- -fp options are not present.
-
- -fto <tag>
- The output file tag. Used to create output filenames. The default
- value is -ft <tag>.
-*/
-TVARCommandLine* Base_VARCommandLine(int nargs, char **args, TVARCommandLine *cmd)
-{
- if (!cmd && !(cmd=Create_VARCommandLine())) return (TVARCommandLine*)NULL;
-
- // input directory
- cmd->in_directory=CreatePath(dw_ParseString_String(nargs,args,"di",""));
-
- // output directory
- cmd->out_directory=CreatePath(dw_ParseString_String(nargs,args,"do",""));
-
- // Specification file
- cmd->specification_filename=dw_DuplicateString(dw_ParseString_String(nargs,args,"fs",(char*)NULL));
-
- // Parameters file
- cmd->parameters_filename=dw_DuplicateString(dw_ParseString_String(nargs,args,"fp",(char*)NULL));
-
- // Parameter header
- cmd->parameters_header=dw_DuplicateString((dw_FindArgument_String(nargs,args,"MLE") == -1)
- ? dw_ParseString_String(nargs,args,"ph","Posterior mode: ")
- : dw_ParseString_String(nargs,args,"ph","MLE: "));
-
- // Output parameters header
- cmd->out_header=dw_DuplicateString(dw_ParseString_String(nargs,args,"ph",cmd->parameters_header));
-
- // Input file tag
- cmd->in_tag=dw_DuplicateString(dw_ParseString_String(nargs,args,"ft",(char*)NULL));
-
- // Output file tag
- cmd->out_tag=dw_DuplicateString(dw_ParseString_String(nargs,args,"fto",cmd->in_tag));
-
- return cmd;
-}
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-TStateModel* CreateTStateModelFromEstimateFinal(int nargs, char **args, TVARCommandLine **p_cmd)
-{
- TStateModel *model=(TStateModel*)NULL;
- char *filename;
- TVARCommandLine *cmd;
-
- if (!(*p_cmd) && !(*p_cmd=Base_VARCommandLine(nargs,args,*p_cmd))) return (TStateModel*)NULL;
- cmd=*p_cmd;
-
- if (cmd->specification_filename)
- {
- filename=CreateFilenameFromTag("%s%s",cmd->specification_filename,cmd->in_directory);
- if (!(model=Read_VAR_Specification((FILE*)NULL,filename)))
- {
- free(filename);
- return (TStateModel*)NULL;
- }
- }
- else
- if (cmd->in_tag)
- {
- filename=CreateFilenameFromTag("%sest_final_%s.dat",cmd->in_tag,cmd->in_directory);
- if (!(model=Read_VAR_Specification((FILE*)NULL,filename)))
- {
- free(filename);
- return (TStateModel*)NULL;
- }
- }
- else
- return (TStateModel*)NULL;
-
- if (cmd->specification_filename_actual) free(cmd->specification_filename_actual);
- cmd->specification_filename_actual=filename;
-
- filename=(cmd->parameters_filename)
- ? CreateFilenameFromTag("%s%s",cmd->parameters_filename,cmd->in_directory)
- : dw_DuplicateString(cmd->specification_filename_actual);
-
- if (!ReadTransitionMatrices((FILE*)NULL,filename,cmd->parameters_header,model)
- || !Read_VAR_Parameters((FILE*)NULL,filename,cmd->parameters_header,model))
- {
- free(filename);
- FreeStateModel(model);
- return (TStateModel*)NULL;
- }
-
- if (cmd->parameters_filename_actual) free(cmd->parameters_filename_actual);
- cmd->parameters_filename_actual=filename;
- if (cmd->parameters_header_actual) free(cmd->parameters_header_actual);
- cmd->parameters_header_actual=dw_DuplicateString(cmd->parameters_header);
-
- return model;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-/*
- Attempts to get the parameters from the last iteration in the intermediate
- file. Returns one and sets cmd->parameters_file_actual,
- cmd->parameters_header_actual and loads parameters upon success. Returns
- zero upon failure.
-*/
-int GetLastIteration(TStateModel *model, TVARCommandLine *cmd)
-{
- char *filename, *header, *fmt="Iteration %d: ";
- int rtrn=0, cont, terminal_errors, i, j, k=1;
- FILE *f_in;
-
- filename=CreateFilenameFromTag("%sest_intermediate_%s.dat",cmd->in_tag,cmd->in_directory);
- if (!(f_in=fopen(filename,"rt")))
- {
- free(filename);
- return 0;
- }
-
- terminal_errors=dw_SetTerminalErrors(dw_GetTerminalErrors() & (~USER_ERR));
-
- do
- {
- for (j=10, i=1; k >= j; j*=10, i++);
- sprintf(header=(char*)malloc(strlen(fmt) + i - 1),fmt,k);
- if (ReadTransitionMatrices(f_in,(char*)NULL,header,model)
- && Read_VAR_Parameters(f_in,(char*)NULL,header,model))
- {
- cont=1;
- free(header);
- k++;
- }
- else
- cont=0;
- }
- while (cont);
-
- if (k > 1)
- {
- k--;
- for (j=10, i=1; k >= j; j*=10, i++);
- sprintf(header=(char*)malloc(strlen(fmt) + i - 1),fmt,k);
- if (ReadTransitionMatrices(f_in,(char*)NULL,header,model) && Read_VAR_Parameters(f_in,(char*)NULL,header,model))
- {
- if (cmd->parameters_filename_actual) free(cmd->parameters_filename_actual);
- cmd->parameters_filename_actual=filename;
- if (cmd->parameters_header_actual) free(cmd->parameters_header_actual);
- cmd->parameters_header_actual=header;
- dw_SetTerminalErrors(terminal_errors);
- return 1;
- }
- }
- else
- {
- header="Initial: ";
- if (ReadTransitionMatrices(f_in,(char*)NULL,header,model) && Read_VAR_Parameters(f_in,(char*)NULL,header,model))
- {
- if (cmd->parameters_filename_actual) free(cmd->parameters_filename_actual);
- cmd->parameters_filename_actual=filename;
- if (cmd->parameters_header_actual) free(cmd->parameters_header_actual);
- cmd->parameters_header_actual=dw_DuplicateString(header);
- dw_SetTerminalErrors(terminal_errors);
- return 1;
- }
- }
-
- free(filename);
- dw_SetTerminalErrors(terminal_errors);
- return 0;
-}
-
-/*
- Attempt to set up model from command line.
-
- -ft <filename tag>
- If this argument exists, then the following is attempted:
-
- specification file name: est_final_<tag>.dat
- init/restart file name: est_final_<tag>.dat with header="Posterior mode: "
-
- specification file name: init_<tag>.dat
- init/restart file name: est_intermediate_<tag>.dat with header="Iteration %d: "
-
- (not yet implemented)
- specification file name: init_<tag>.dat
- init/restart file name: est_csminwel_<tag>.dat
-
- specification file name: init_<tag>.dat
- init/restart file name: init_<tag>.dat with header="Initial: "
-
- Returns valid pointer to a TStateModel upon success and null upon failure.
-*/
-TStateModel* CreateTStateModelForEstimate(int nargs, char **args, TVARCommandLine **p_cmd)
-{
- TStateModel *model;
- char *filename, *header;
- int terminal_errors;
- TVARCommandLine *cmd;
-
- terminal_errors=dw_SetTerminalErrors(dw_GetTerminalErrors() & (~USER_ERR));
-
- if (!(*p_cmd) && !(*p_cmd=Base_VARCommandLine(nargs,args,*p_cmd))) return (TStateModel*)NULL;
- cmd=*p_cmd;
-
- if (cmd->specification_filename)
- {
- filename=CreateFilenameFromTag("%s%s",cmd->specification_filename,cmd->in_directory);
- if (!(model=Read_VAR_Specification((FILE*)NULL,filename)))
- {
- free(filename);
- dw_SetTerminalErrors(terminal_errors);
- return (TStateModel*)NULL;
- }
- }
- else
- if (cmd->in_tag)
- {
- filename=CreateFilenameFromTag("%sest_final_%s.dat",cmd->in_tag,cmd->in_directory);
- if (!(model=Read_VAR_Specification((FILE*)NULL,filename)))
- {
- free(filename);
- filename=CreateFilenameFromTag("%sinit_%s.dat",cmd->in_tag,cmd->in_directory);
- if (!(model=Read_VAR_Specification((FILE*)NULL,filename)))
- {
- free(filename);
- dw_SetTerminalErrors(terminal_errors);
- return (TStateModel*)NULL;
- }
- }
- }
- else
- {
- dw_SetTerminalErrors(terminal_errors);
- return (TStateModel*)NULL;
- }
-
- if (cmd->specification_filename_actual) free(cmd->specification_filename_actual);
- cmd->specification_filename_actual=filename;
-
- if (cmd->parameters_filename)
- {
- header=cmd->parameters_header;
- filename=CreateFilenameFromTag("%s%s",cmd->parameters_filename,cmd->in_directory);
- if (!ReadTransitionMatrices((FILE*)NULL,filename,header,model)
- || !Read_VAR_Parameters((FILE*)NULL,filename,header,model))
- {
- free(filename);
- FreeStateModel(model);
- dw_SetTerminalErrors(terminal_errors);
- return (TStateModel*)NULL;
- }
- }
- else
- if (cmd->specification_filename)
- {
- header=cmd->parameters_header;
- filename=CreateFilenameFromTag("%s%s",cmd->specification_filename,cmd->in_directory);
- if (!ReadTransitionMatrices((FILE*)NULL,filename,header,model)
- || !Read_VAR_Parameters((FILE*)NULL,filename,header,model))
- {
- free(filename);
- FreeStateModel(model);
- dw_SetTerminalErrors(terminal_errors);
- return (TStateModel*)NULL;
- }
- }
- else
- if (cmd->in_tag)
- {
- header=cmd->parameters_header;
- filename=filename=CreateFilenameFromTag("%sest_final_%s.dat",cmd->in_tag,cmd->in_directory);
- if (!ReadTransitionMatrices((FILE*)NULL,filename,header,model)
- || !Read_VAR_Parameters((FILE*)NULL,filename,header,model))
- {
- free(filename);
- if (GetLastIteration(model,cmd))
- {
- dw_SetTerminalErrors(terminal_errors);
- return model;
- }
- else
- {
- header="Initial: ";
- filename=filename=CreateFilenameFromTag("%sinit_%s.dat",cmd->in_tag,cmd->in_directory);
- if (!ReadTransitionMatrices((FILE*)NULL,filename,header,model)
- || !Read_VAR_Parameters((FILE*)NULL,filename,header,model))
- {
- FreeStateModel(model);
- dw_SetTerminalErrors(terminal_errors);
- return (TStateModel*)NULL;
- }
- }
- }
- }
-
- if (cmd->parameters_filename_actual) free(cmd->parameters_filename_actual);
- cmd->parameters_filename_actual=filename;
- if (cmd->parameters_header_actual) free(cmd->parameters_header_actual);
- cmd->parameters_header_actual=dw_DuplicateString(header);
-
- dw_SetTerminalErrors(terminal_errors);
- return model;
-}
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
diff --git a/matlab/swz/c-code/sbvar/var/command_line_VAR.h b/matlab/swz/c-code/sbvar/var/command_line_VAR.h
deleted file mode 100644
index be626a7b634eb6cba788c0cb966323a2b5d7db7f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/command_line_VAR.h
+++ /dev/null
@@ -1,37 +0,0 @@
-#ifndef __command_line_VAR
-#define __command_line_VAR
-
-#include "switch.h"
-#include <stdio.h>
-
-char* CreateFilenameFromTag(char *fmt, char *tag, char *dir);
-char* CreatePath(char *path);
-void PrintHelpMessages(FILE *f, char **include, char **additional);
-
-typedef struct
-{
- char *in_directory; // -di
- char *in_tag; // -ft
- char *specification_filename; // -fs
- char *parameters_filename; // -fp
- char *parameters_header; // -ph
-
- char *specification_filename_actual;
- char *parameters_filename_actual;
- char *parameters_header_actual;
-
- char *out_directory; // -do
- char *out_tag; // -fto (default from -ft)
- char *out_header; // -pho (default from -ph)
-} TVARCommandLine;
-
-TVARCommandLine* Create_VARCommandLine(void);
-void Free_VARCommandLine(TVARCommandLine *cmd);
-TVARCommandLine* Base_VARCommandLine(int nargs, char **args, TVARCommandLine *cmd);
-
-void EstimateFinal_VARCommandLine_Help(FILE *f);
-TStateModel* CreateTStateModelFromEstimateFinal(int nargs, char **args, TVARCommandLine **p_cmd);
-
-TStateModel* CreateTStateModelForEstimate(int nargs, char **args, TVARCommandLine **p_cmd);
-
-#endif
diff --git a/matlab/swz/c-code/sbvar/var/create_init_file.c b/matlab/swz/c-code/sbvar/var/create_init_file.c
deleted file mode 100644
index b3b468e60478afa0e5830897c695bcb059e12aba..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/create_init_file.c
+++ /dev/null
@@ -1,43 +0,0 @@
-
-#include "switch.h"
-#include "switchio.h"
-#include "VARbase.h"
-#include "VARio.h"
-#include "VARio_matlab.h"
-#include "dw_error.h"
-#include "dw_ascii.h"
-
-#include <stdlib.h>
-#include <string.h>
-
-
-/*
- Creates a standard initialization file from the matlab and specification file.
-*/
-int main(int nargs, char **args)
-{
- TStateModel *model;
- FILE *f_out;
- char *filename, *fmt="init_%s.dat", *header="Initial: ";
-
- dw_SetTerminalErrors(ALL_ERRORS);
- dw_SetVerboseErrors(ALL_ERRORS);
-
- if (nargs != 4)
- {
- fprintf(stderr,"Syntax:\n create_init_file <matlab filename> <specs filename> <file tag>\n");
- exit(0);
- }
-
- model=Combine_matlab_standard(args[1],args[2]);
- ReadConstantParameters(args[1],model);
- sprintf(filename=(char*)malloc(strlen(fmt) + strlen(args[3]) - 1),fmt,args[3]);
- f_out=dw_CreateTextFile(filename);
- Write_VAR_Specification(f_out,(char*)NULL,model);
- WriteTransitionMatrices(f_out,(char*)NULL,header,model);
- Write_VAR_Parameters(f_out,(char*)NULL,header,model);
- fclose(f_out);
- FreeStateModel(model);
-
- return 0;
-}
diff --git a/matlab/swz/c-code/sbvar/var/estimate.c b/matlab/swz/c-code/sbvar/var/estimate.c
deleted file mode 100644
index b2b2fdb7579cae75b28733445872230caba03044..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/estimate.c
+++ /dev/null
@@ -1,718 +0,0 @@
-
-#include "switch.h"
-#include "switchio.h"
-#include "switch_opt.h"
-#include "VARbase.h"
-#include "VARio.h"
-#include "dw_error.h"
-#include "dw_ascii.h"
-#include "dw_parse_cmd.h"
-#include "dw_rand.h"
-#include "command_line_VAR.h"
-
-#include "optpackage.h"
-//#include "csminwel.h"
-//#include "dw_csminwel.h"
-
-#include <time.h>
-#include <string.h>
-#include <stdlib.h>
-#include <math.h>
-
-#define FIND_POSTERIOR_MODE 1
-#define FIND_LIKELIHOOD_MODE 2
-
-typedef struct
-{
- int type;
-
- TVARCommandLine *cmd;
-
- char *csminwel_output_filename;
- char *intermediate_output_filename;
-
- PRECISION criterion_start;
- PRECISION criterion_end;
- PRECISION criterion_increment;
-
- int max_iterations_start;
- PRECISION max_iterations_increment;
-
- int max_block_iterations;
-
-} TEstimateInfo;
-
-
-void FindMode_VAR_csminwel(TStateModel *model, TEstimateInfo *estimate)
-{
- int iteration, total_iteration, i, j, size_VAR, pos_VAR, size_Q, pos_Q;
- double objective, objective_last, likelihood, prior;
- int **block;
- FILE *f_out;
- char *header, *fmt="Iteration %d: ";
-
- // csminwel arguments
- int itct, fcount, retcodeh, nit;
- double *x, fh, crit;
- TMatrix H;
- TVector g;
-
- f_out=dw_CreateTextFile(estimate->intermediate_output_filename);
-
- //==== Allocate memory ===
- size_VAR=NumberFreeParametersTheta(model);
- size_Q=NumberFreeParametersQ(model);
- pos_VAR=0;
- pos_Q=size_VAR;
- x=(double*)malloc((size_VAR + size_Q)*sizeof(double));
-
- //=== Set starting value ===
- ConvertQToFreeParameters(model,x+pos_Q);
- ConvertThetaToFreeParameters(model,x+pos_VAR);
-
- //=== Set csminwel output file ===
- csminwel_SetPrintFile(estimate->csminwel_output_filename);
-
- //=== Print Initial Values ===
- fprintf(f_out,"\n//=== Initial Values ===//\n");
- fprintf(f_out,"Likelihood value: %22.14le\n",objective=likelihood=LogLikelihood_StatesIntegratedOut(model));
- fprintf(f_out,"Prior value: %22.14le\n",prior=LogPrior(model));
- fprintf(f_out,"Posterior value: %22.14le\n\n",likelihood+prior);
-
- header="Initial: ";
- WriteTransitionMatrices(f_out,(char*)NULL,header,model);
- Write_VAR_Parameters(f_out,(char*)NULL,header,model);
- fflush(f_out);
-
- //=== Create blocking structure ===
- block=dw_CreateRectangularArray_int(2,2);
- block[0][0]=size_VAR; block[0][1]=pos_VAR;
- block[1][0]=size_Q; block[1][1]=pos_Q;
-
- //=== Objective ===
- if (estimate->type == FIND_POSTERIOR_MODE)
- objective=likelihood+prior;
- else
- objective=likelihood;
-
- for (total_iteration=1, crit=estimate->criterion_start, nit=estimate->max_iterations_start;
- crit >= estimate->criterion_end;
- crit*=estimate->criterion_increment, nit*=(int)estimate->max_iterations_increment)
- {
- for (iteration=1; iteration <= estimate->max_block_iterations; total_iteration++, iteration++)
- {
- objective_last=objective;
-
- fprintf(f_out,"\n\n//=== Iteration %d ===//\n",total_iteration);
- fprintf(f_out,"Criterion/Max Iteration: %le %d\n",crit,nit);
- fprintf(f_out,"Previous likelihood value: %22.14le\n",likelihood);
- fprintf(f_out,"Previous prior value: %22.14le\n",prior);
- fprintf(f_out,"Previous posterior value: %22.14le\n\n",prior+likelihood);
- fflush(f_out);
-
- for (i=0; i < dw_DimA(block); i++)
- if (block[i][0] > 0)
- {
- g=CreateVector(block[i][0]);
- H=IdentityMatrix((TMatrix)NULL,block[i][0]);
- ProductMS(H,H,INI_H_CSMINWEL);
-
- SetupObjectiveFunction(model,x+block[i][1],x+pos_Q,x+pos_VAR);
-
- if (estimate->type == FIND_POSTERIOR_MODE)
- csminwel(PosteriorObjectiveFunction_csminwel,x+block[i][1],block[i][0],pElementM(H),pElementV(g),NULL,
- &fh,crit,&itct,nit,&fcount,&retcodeh,NULL,NULL);
- else
- csminwel(MLEObjectiveFunction_csminwel,x+block[i][1],block[i][0],pElementM(H),pElementV(g),NULL,
- &fh,crit,&itct,nit,&fcount,&retcodeh,NULL,NULL);
-
- ConvertFreeParametersToQ(model,x+pos_Q);
- ConvertFreeParametersToTheta(model,x+pos_VAR);
-
- FreeMatrix(H);
- FreeVector(g);
-
- fprintf(f_out,"Likelihood value after pass %d: %22.14le\n",i,likelihood=LogLikelihood_StatesIntegratedOut(model));
- fprintf(f_out,"Prior value after pass %d: %22.14le\n",i,prior=LogPrior(model));
- fprintf(f_out,"Posterior value after pass %d: %22.14le\n",i,likelihood+prior);
- fprintf(f_out,"Csminwel return code: %d\n\n",retcodeh);
- fflush(f_out);
- }
-
- for (j=10, i=1; total_iteration >= j; j*=10, i++);
- sprintf(header=(char*)malloc(strlen(fmt) + i - 1),fmt,total_iteration);
- WriteTransitionMatrices(f_out,(char*)NULL,header,model);
- Write_VAR_Parameters(f_out,(char*)NULL,header,model);
- free(header);
- fflush(f_out);
-
- if (estimate->type == FIND_POSTERIOR_MODE)
- objective=likelihood+prior;
- else
- objective=likelihood;
-
- if (fabs(objective - objective_last) <= crit) break;
- }
-
- objective_last=objective;
-
- fprintf(f_out,"\n\n//=== Iteration %d ===//\n",++total_iteration);
- fprintf(f_out,"Criterion/Max Iteration: %le %d\n",crit,nit);
- fprintf(f_out,"Previous likelihood value: %22.14le\n",likelihood);
- fprintf(f_out,"Previous prior value: %22.14le\n",prior);
- fprintf(f_out,"Previous posterior value: %22.14le\n\n",prior+likelihood);
- fflush(f_out);
-
- g=CreateVector(pos_Q+pos_VAR);
- H=IdentityMatrix((TMatrix)NULL,pos_Q+pos_VAR);
- ProductMS(H,H,INI_H_CSMINWEL);
-
- SetupObjectiveFunction(model,x,x+pos_Q,x+pos_VAR);
-
- if (estimate->type == FIND_POSTERIOR_MODE)
- csminwel(PosteriorObjectiveFunction_csminwel,x,pos_Q+pos_VAR,pElementM(H),pElementV(g),NULL,
- &fh,crit,&itct,nit,&fcount,&retcodeh,NULL,NULL);
- else
- csminwel(MLEObjectiveFunction_csminwel,x,pos_Q+pos_VAR,pElementM(H),pElementV(g),NULL,
- &fh,crit,&itct,nit,&fcount,&retcodeh,NULL,NULL);
-
- ConvertFreeParametersToQ(model,x+pos_Q);
- ConvertFreeParametersToTheta(model,x+pos_VAR);
-
- FreeMatrix(H);
- FreeVector(g);
-
- fprintf(f_out,"Likelihood value: %22.14le\n",likelihood=LogLikelihood_StatesIntegratedOut(model));
- fprintf(f_out,"Prior value: %22.14le\n",prior=LogPrior(model));
- fprintf(f_out,"Posterior value: %22.14le\n",likelihood+prior);
- fprintf(f_out,"Csminwel return code: %d\n\n",retcodeh);
- fflush(f_out);
-
- for (j=10, i=1; total_iteration >= j; j*=10, i++);
- sprintf(header=(char*)malloc(strlen(fmt) + i - 1),fmt,total_iteration);
- WriteTransitionMatrices(f_out,(char*)NULL,header,model);
- Write_VAR_Parameters(f_out,(char*)NULL,header,model);
- free(header);
- fflush(f_out);
-
- if (estimate->type == FIND_POSTERIOR_MODE)
- objective=likelihood+prior;
- else
- objective=likelihood;
- }
-
- //=== Free memory ===
- free(x);
- dw_FreeArray(block);
-
- //=== Close File ===
- fclose(f_out);
-}
-
-/*
- filename -
-*
-char** ReadInputFile(char *filename)
-{
- char **args=(char**)NULL;
- char ***X;
- int i, j, n;
- X=dw_ReadDelimitedFile((FILE*)NULL,filename,' ',REMOVE_EMPTY_FIELDS | STRIP_WHITESPACE);
- if (X)
- {
- for (n=i=0; i < dw_DimA(X); i++)
- if (X[i]) n+=dw_DimA(X[i]);
- if (n > 0)
- {
- args=dw_CreateArray_string(n);
- for (n=i=0; i < dw_DimA(X); i++)
- if (X[i])
- for (j=0; j < dw_DimA(X[i]); j++)
- {
- args[n]=X[i][j];
- X[i][j]=(char*)NULL;
- }
- }
- dw_FreeArray(X);
- }
- return args;
-}*/
-
-/*
- Attempts to load parameters from given file.
-*
-int LoadParameters(FILE *f, char *filename, TStateModel *model)
-{
- int i, terminal_errors, rtrn=0;
- char *header[5]={"","Initial: ","Current: ","Posterior mode: ","MLE: "};
- FILE *f_in=f ? f : dw_OpenTextFile(filename);
-
- terminal_errors=dw_SetTerminalErrors(ALL_ERRORS & (~USER_ERR));
-
- for (i=0; i < 5; i++)
- if (ReadTransitionMatrices(f_in,(char*)NULL,header[i],model) && Read_VAR_Parameters(f_in,(char*)NULL,header[i],model))
- {
- rtrn=1;
- break;
- }
-
- dw_SetTerminalErrors(terminal_errors);
-
- if (!f) fclose(f_in);
- return rtrn;
-}*/
-
-/*
- Attempts to get the parameters from the last iteration in the intermediate file.
-*
-int GetLastIteration(FILE *f_in, TStateModel *model, TEstimateInfo *estimate)
-{
- char *id, *header, *fmt="//=== Iteration %d ===//";
- int terminal_errors, i, j, k=0;
-
- while (1)
- {
- for (j=10, i=1; k+1 >= j; j*=10, i++);
- sprintf(id=(char*)malloc(strlen(fmt) + i - 1),fmt,k+1);
-
- if (!dw_SetFilePosition(f_in,id))
- {
- free(id);
- terminal_errors=dw_SetTerminalErrors(ALL_ERRORS & (~USER_ERR));
-
- fmt="Iteration %d: ";
- while (k > 0)
- {
- for (j=10, i=1; k >= j; j*=10, i++);
- sprintf(header=(char*)malloc(strlen(fmt) + i - 1),fmt,k);
- if (ReadTransitionMatrices(f_in,(char*)NULL,header,model) && Read_VAR_Parameters(f_in,(char*)NULL,header,model))
- {
- fprintf(stdout,"Using intermediate output - %s\n",header);
- estimate->initialization_header=header;
- dw_SetTerminalErrors(terminal_errors);
- return 1;
- }
- free(header);
- k--;
- }
-
- dw_SetTerminalErrors(terminal_errors);
- return 0;
- }
-
- free(id);
- k++;
- }
-}
-
-/*
- Attempt to set up model from command line. Command line options are the following
-
- -di <directory>
- If this argument exists, then all input files are in specified directory.
-
- -ft <filename tag>
- If this argument exists, then the following is attempted:
-
- specification file name: est_final_<tag>.dat
- init/restart file name: est_final_<tag>.dat with header="Posterior mode: "
-
- specification file name: init_<tag>.dat
- init/restart file name: est_intermediate_<tag>.dat with header="Iteration %d: "
-
- (not yet implemented)
- specification file name: init_<tag>.dat
- init/restart file name: est_csminwel_<tag>.dat
-
- specification file name: init_<tag>.dat
- init/restart file name: init_<tag>.dat with header="Initial: "
-
- Failure to load both the specification and restart/init files causes the routine to exit.
-
- -fs <filename>
- If this argument exists, then the specification file name is <filename>. The argument -ft
- takes precedence over -fs.
-
- -fr <filename>
- If this argument exists, then the init/restart file name is <filename>. Must be used in
- conjunction with the argument -fs. The default value is the filename associated with the
- argument -fs.
-
- -rh <header>
- If this argument exists, then the header for the init/restart file is <header>. Must be
- used in conjuction with the arguments -fr or -fs. The default value is "".
-
- If no command line options are given, then attemps to use a default input file
- with the name "default.ini". Returns one valid pointer to a TStateModel upon
- success and null upon failure.
-*
-TStateModel* GetModelFromCommandLine(int nargs, char **args, TEstimateInfo *estimate)
-{
- TStateModel *model;
- char *d1, *d2, *tag, *header, *filename, *fmt;
- FILE *f_in;
-
- d1=dw_ParseString_String(nargs,args,"di","");
- if (d1[0] && d1[strlen(d1)-1] != '/')
- {
- d2=(char*)malloc(strlen(d1)+2);
- strcat(strcpy(d2,d1),"/");
- d1=d2;
- }
- else
- d2=(char*)NULL;
-
- if (tag=dw_ParseString_String(nargs,args,"ft",(char*)NULL))
- {
- fmt="%sest_final_%s.dat";
- sprintf(filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- if (f_in=fopen(filename,"rt"))
- {
- model=Read_VAR_Specification(f_in,(char*)NULL);
- header=dw_ParseString_String(nargs,args,"rh","Posterior mode: ");
- ReadTransitionMatrices(f_in,(char*)NULL,header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,header,model);
- fclose(f_in);
- fprintf(stdout,"Using final output\n");
- estimate->specification_filename=filename;
- estimate->initialization_filename=filename;
- estimate->initialization_header=header;
- if (d2) free(d2);
- return model;
- }
- free(filename);
-
- fmt="%sinit_%s.dat";
- sprintf(filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- if (f_in=fopen(filename,"rt"))
- {
- model=Read_VAR_Specification(f_in,(char*)NULL);
- estimate->specification_filename=filename;
- fclose(f_in);
-
- fmt="%sest_intermediate_%s.dat";
- sprintf(filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- if (f_in=fopen(filename,"rt"))
- {
- if (GetLastIteration(f_in,model,estimate))
- {
- fclose(f_in);
- estimate->initialization_filename=filename;
- if (d2) free(d2);
- return model;
- }
- fclose(f_in);
- }
- free(filename);
-
- fmt="%sinit_%s.dat";
- sprintf(filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- if (f_in=fopen(filename,"rt"))
- {
- header=dw_ParseString_String(nargs,args,"rh","Initial: ");
- ReadTransitionMatrices(f_in,(char*)NULL,header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,header,model);
- fclose(f_in);
- fprintf(stdout,"Using initial data\n");
- estimate->initialization_filename=filename;
- estimate->initialization_header=header;
- if (d2) free(d2);
- return model;
- }
-
- FreeStateModel(model);
- }
- free(filename);
-
- //if (d2) free(d2);
- //fprintf(stderr,"GetModelFromCommandLine(): Unable to create model.\n");
- goto ERROR;
- }
-
- if (tag=dw_ParseString_String(nargs,args,"fs",(char*)NULL))
- {
- sprintf(filename=(char*)malloc(strlen(d1) + strlen(tag) + 1),"%s%s",d1,tag);
- model=Read_VAR_Specification((FILE*)NULL,filename);
- estimate->specification_filename=filename;
-
- if (!(tag=dw_ParseString_String(nargs,args,"fr",(char*)NULL)))
- tag=dw_ParseString_String(nargs,args,"fs",(char*)NULL);
- sprintf(filename=(char*)malloc(strlen(d1) + strlen(tag) + 1),"%s%s",d1,tag);
- header=dw_ParseString_String(nargs,args,"rh","");
- ReadTransitionMatrices((FILE*)NULL,filename,header,model);
- Read_VAR_Parameters((FILE*)NULL,filename,header,model);
- estimate->initialization_filename=filename;
- estimate->initialization_header=header;
-
- if (d2) free(d2);
- return model;
- }
-
- ERROR:
- if (d2) free(d2);
- //fprintf(stderr,"GetModelFromCommandLine(): No specification file defined.\n");
- return (TStateModel*)NULL;
-}
-
-/*
- Attempt to set up model from command line. Command line options are the following
-
- -do <directory>
- If this argument exists, then all output files are put in the specified directory.
-
- -fo <filename tag>
- If this argument exists, then the output files are
-
- est_csminwel_<tag>.dat
- est_intermediate_<tag>.dat
- est_final_<tag>.dat
-
- The default value is the filename tag associated with the argument -ft if it exists. Otherwise
- it is "default".
-
- //--- this is yet to be implemented
- -fa <filename>
- Aux output file. The default value is est_aux_<filename tag>.dat.
-
- -MLE
- Find the maximum likelihood estimate
-
- -PM (default)
- Find the posterior mode
-
- -cb <floating point number> (default = 1.0e-3)
- Beginning csminwel exit criterion
-
- -ce <floating point number> (default = 1.03-6)
- Ending csminwel exit criterion
-
- -ci <floating point number> (default = 0.1)
- csminwel exit criterion increment multiplier
-
- -ib <integer> (default = 50)
- Beginning csminwel maximum iteration value
-
- -ii <floating point number> (default = 2)
- csminwel maximum interation increment multiplier
-
- If no command line options are given, then attemps to use a default input file
- with the name "default.ini". Returns one valid pointer to a TStateModel upon
- success and null upon failure.
-*
-TEstimateInfo* GetEstimateInfoFromCommandLine(int nargs, char **args) //, TStateModel* model)
-{
- TEstimateInfo *estimate;
- char *d1, *d2, *tag, *fmt;
-
- estimate=(TEstimateInfo*)malloc(sizeof(TEstimateInfo));
-
- // Output directory
- d1=dw_ParseString_String(nargs,args,"di","");
- if (d1[0] && d1[strlen(d1)-1] != '/')
- {
- d2=(char*)malloc(strlen(d1)+2);
- strcat(strcpy(d2,d1),"/");
- d1=d2;
- }
- else
- d2=(char*)NULL;
-
- // Output filenames
- if (!(tag=dw_ParseString_String(nargs,args,"fo",(char*)NULL)))
- tag=dw_ParseString_String(nargs,args,"ft","default");
- fmt="%sest_csminwel_%s.dat";
- sprintf(estimate->csminwel_output_filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- fmt="%sest_intermediate_%s.dat";
- sprintf(estimate->intermediate_output_filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- fmt="%sest_final_%s.dat";
- sprintf(estimate->final_output_filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- fmt="%sest_aux_%s.dat";
- sprintf(estimate->aux_output_filename=(char*)malloc(strlen(d1) + strlen(fmt) + strlen(tag) - 3),fmt,d1,tag);
- if (d2) free(d2);
-
- // Posterior mode or MLE
- estimate->type=(dw_FindArgument_String(nargs,args,"MLE") >= 0) ? FIND_LIKELIHOOD_MODE : FIND_POSTERIOR_MODE;
-
- // Default values
- estimate->criterion_start=dw_ParseFloating_String(nargs,args,"cb",1.0e-3);
- estimate->criterion_end=dw_ParseFloating_String(nargs,args,"ce",1.0e-6);
- estimate->criterion_increment=dw_ParseFloating_String(nargs,args,"ci",0.1);
- estimate->max_iterations_start=dw_ParseInteger_String(nargs,args,"ib",50);
- estimate->max_iterations_increment=dw_ParseFloating_String(nargs,args,"ii",2.0);
-
- estimate->max_block_iterations=100;
-
- return estimate;
-}
-
-/*
- Creates TStateModel and reads parameters from command line. Other estimate info
- is also obtained from command line.
-*/
-static TStateModel* SetupFromCommandLine(int nargs, char **args, TEstimateInfo **p_info)
-{
- TEstimateInfo *info;
-
- if (!(*p_info)) *p_info=(TEstimateInfo*)malloc(sizeof(TEstimateInfo));
- info=*p_info;
-
- info->cmd=Base_VARCommandLine(nargs,args,(TVARCommandLine*)NULL);
-
- // Posterior mode or MLE
- info->type=(dw_FindArgument_String(nargs,args,"MLE") >= 0) ? FIND_LIKELIHOOD_MODE : FIND_POSTERIOR_MODE;
-
- // Default values
- info->criterion_start=dw_ParseFloating_String(nargs,args,"cb",1.0e-3);
- info->criterion_end=dw_ParseFloating_String(nargs,args,"ce",1.0e-6);
- info->criterion_increment=dw_ParseFloating_String(nargs,args,"ci",0.1);
- info->max_iterations_start=dw_ParseInteger_String(nargs,args,"ib",50);
- info->max_iterations_increment=dw_ParseFloating_String(nargs,args,"ii",2.0);
-
- info->max_block_iterations=100;
-
- // Output filenames
- info->csminwel_output_filename=CreateFilenameFromTag("%sest_csminwel_%s.dat",info->cmd->out_tag,info->cmd->out_directory);
- info->intermediate_output_filename=CreateFilenameFromTag("%sest_intermediate_%s.dat",info->cmd->out_tag,info->cmd->out_directory);
-
- return CreateTStateModelForEstimate(nargs,args,&(info->cmd));
-}
-
-int main(int nargs, char **args)
-{
- TStateModel *model;
- TEstimateInfo *estimate=(TEstimateInfo*)NULL;
- char *filename;
- FILE *f_out;
- time_t begin_time, end_time;
- int t, seed;
- TVector y;
- char *include_help[]={"-di","-do","-fs","-fp","-ph","-ft","-fto",(char*)NULL},
- *additional_help[]={
- "-MLE",
- "Finds the maximum likelihood estimate",
- "-PM",
- "Finds the posterior mode (default option)",
- "-cb <floating point number>",
- "Beginning csminwel exit criterion (default = 1.0e-3)",
- "-ce <floating point number>",
- "Ending csminwel exit criterion (default = 1.03-6)",
- "-ci <floating point number>",
- "csminwel exit criterion increment multiplier (default = 0.1)",
- "-ib <integer>",
- "Beginning csminwel maximum iteration value (default = 50)",
- "-ii <floating point number>",
- "csminwel maximum interation increment multiplier (default = 2)",
- "-nd1",
- "Normalize diagonal of A0 to one (flat output only)",
- "-gs <integer>",
- "Seed value for generator - 0 gets seed from clock (default value = 0)",
- (char*)NULL,
- (char*)NULL};
-
- //=== Help Screen ===
- if (dw_FindArgument_String(nargs,args,"h") != -1)
- {
- fprintf(stdout,"print_draws <options>\n");
- PrintHelpMessages(stdout,include_help,additional_help);
- return 0;
- }
-
- // Generator seed
- seed=dw_ParseInteger_String(nargs,args,"gs",0);
- dw_initialize_generator(seed);
-
- fprintf(stdout,"Reading initial data...\n");
- if (model=SetupFromCommandLine(nargs,args,&estimate))
- {
- // Estimation
- fprintf(stdout,"Beginning estimation...\n");
- begin_time=time((time_t*)NULL);
- FindMode_VAR_csminwel(model,estimate);
- end_time=time((time_t*)NULL);
-
- // Write final output
- filename=CreateFilenameFromTag("%sest_final_%s.dat",estimate->cmd->out_tag,estimate->cmd->out_directory);
- if (f_out=fopen(filename,"wt"))
- {
- Write_VAR_Specification(f_out,(char*)NULL,model);
- fprintf(f_out,"Specification file: %s\n",estimate->cmd->specification_filename_actual);
- fprintf(f_out,"Initialization file: %s\n",estimate->cmd->parameters_filename_actual);
- fprintf(f_out,"Initialization header: \"%s\"\n",estimate->cmd->parameters_header_actual);
-
- fprintf(f_out,"Number free parameters in transition matrix: %d\n",NumberFreeParametersQ(model));
- fprintf(f_out,"Number free parameters in theta: %d\n",NumberFreeParametersTheta(model));
-
- fprintf(f_out,"Time stamp: %s",ctime(&end_time));
- fprintf(f_out,"Elapsed time: %d seconds\n",(int)end_time-(int)begin_time);
-
- fprintf(f_out,"Likelihood Value: %g\n",LogLikelihood_StatesIntegratedOut(model));
- fprintf(f_out,"Prior Value: %g\n",LogPrior(model));
- fprintf(f_out,"Posterior Value: %g\n\n",LogPosterior_StatesIntegratedOut(model));
-
- WriteTransitionMatrices(f_out,(char*)NULL,estimate->cmd->out_header,model);
- Write_VAR_Parameters(f_out,(char*)NULL,estimate->cmd->out_header,model);
-
- fclose(f_out);
- }
- free(filename);
-
- // Write flat file
- filename=CreateFilenameFromTag("%sest_flat_header_%s.dat",estimate->cmd->out_tag,estimate->cmd->out_directory);
- if (f_out=fopen(filename,"wt"))
- {
- WriteBaseTransitionMatricesFlat_Headers_SV(f_out,model->sv,"");
- Write_VAR_ParametersFlat_Headers(f_out,model);
- fprintf(f_out,"\n");
- fclose(f_out);
- }
- free(filename);
- filename=CreateFilenameFromTag("%sest_flat_%s.dat",estimate->cmd->out_tag,estimate->cmd->out_directory);
- if (f_out=fopen(filename,"wt"))
- {
- WriteBaseTransitionMatricesFlat(f_out,model,"%lf ");
- if (dw_FindArgument_String(nargs,args,"nd1") >= 0)
- Write_VAR_ParametersFlat_A0_Diagonal_One(f_out,model,"%lf ");
- else
- Write_VAR_ParametersFlat(f_out,model,"%lf ");
- fprintf(f_out,"\n");
- fclose(f_out);
- }
- free(filename);
-
- // Write aux output
- filename=CreateFilenameFromTag("%sest_aux_%s.dat",estimate->cmd->out_tag,estimate->cmd->out_directory);
- if (f_out=fopen(filename,"wt"))
- {
- fprintf(f_out,"""ln(P(y[t]|Y[t-1],Z[t],theta,Q))"",""E[y[t]|Y[t-1],Z[t],theta,Q]""\n");
-
- y=CreateVector(((T_VAR_Parameters*)(model->theta))->nvars);
- for (t=1; t <= model->sv->nobs; t++)
- {
- fprintf(f_out,"%le,",LogConditionalLikelihood_StatesIntegratedOut(t,model));
- if (ExpectationSingleStep_StatesIntegratedOut(y,t,model))
- dw_PrintVector(f_out,y,"%le,");
- else
- fprintf(f_out,"\n");
- }
-
- FreeVector(y);
- fclose(f_out);
- }
- free(filename);
-
- // Free memory
- FreeStateModel(model);
- Free_VARCommandLine(estimate->cmd);
- }
- else
- {
- // unable to create model
- if (estimate)
- {
- if (estimate->cmd) Free_VARCommandLine(estimate->cmd);
- free(estimate);
- }
- }
-
- return 0;
-}
diff --git a/matlab/swz/c-code/sbvar/var/mhm_VAR.c b/matlab/swz/c-code/sbvar/var/mhm_VAR.c
deleted file mode 100644
index 5b281bdc6546ad69edec9dcb4d15920df2536c5f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/mhm_VAR.c
+++ /dev/null
@@ -1,641 +0,0 @@
-
-#include "mhm_VAR.h"
-#include "VARio.h"
-#include "switch.h"
-#include "switchio.h"
-#include "dw_ascii.h"
-#include "dw_rand.h"
-#include "dw_matrix_rand.h"
-#include "dw_error.h"
-
-#include <stdlib.h>
-#include <time.h>
-#include <string.h>
-
- // Compute psudo-inverse of mhm->variance
-static void PsudoInverse(TMatrix X, TMatrix Y)
-{
- int i, j, k;
- TMatrix U, V;
- TVector d;
- PRECISION epsilon, tmp;
- k=RowM(Y);
- SVD(U=CreateMatrix(k,k),d=CreateVector(k),V=CreateMatrix(k,k),Y);
- for (epsilon=ElementV(d,0),i=k-1; i > 0; i--)
- if (ElementV(d,0) > epsilon) epsilon=ElementV(d,0);
- epsilon*=SQRT_MACHINE_EPSILON;
- for (j=k-1; j >= 0; j--)
- {
- tmp=(ElementV(d,j) > epsilon) ? 1.0/ElementV(d,j) : 0.0;
- for (i=k-1; i >= 0; i--)
- ElementM(V,i,j)*=tmp;
- }
- ProductTransposeMM(X,V,U);
- FreeMatrix(U);
- FreeVector(d);
- FreeMatrix(V);
-}
-
-void ResetMHM(T_MHM *mhm)
-{
- mhm->N=0;
-
- mhm->sum=mhm->sum_square=0.0;
-
- mhm->max_log_posterior=mhm->max_log_likelihood=MINUS_INFINITY;
-}
-
-void FreeMHM(T_MHM *mhm)
-{
- if (mhm)
- {
- FreeVector(mhm->mean);
- FreeVector(mhm->posterior_mode_VAR);
- FreeMatrix(mhm->variance);
- FreeMatrix(mhm->inverse_variance);
-
- FreeVector(mhm->free_parameters_VAR);
-
- dw_FreeArray(mhm->states);
-
- dw_FreeArray(mhm->BaseAlpha);
- dw_FreeArray(mhm->Alpha);
-
- free(mhm);
- }
-}
-
-T_MHM* AddStateModel(TStateModel *model, T_MHM *mhm)
-{
- int i, nf_var=NumberFreeParametersTheta(model);
-
- if (!mhm) mhm=CreateMHM();
-
- // Allocate memory
- mhm->mean=CreateVector(nf_var);
- mhm->posterior_mode_VAR=CreateVector(nf_var);
- mhm->variance=CreateMatrix(nf_var,nf_var);
- mhm->inverse_variance=CreateMatrix(nf_var,nf_var);
-
- mhm->free_parameters_VAR=CreateVector(nf_var);
-
- mhm->states=dw_CreateArray_int(model->sv->nstates);
-
- mhm->BaseAlpha=dw_CreateArray_vector(dw_DimA(model->sv->ba));
- for (i=dw_DimA(model->sv->ba)-1; i >= 0; i--)
- mhm->BaseAlpha[i]=CreateVector(DimV(model->sv->ba[i]));
-
- // model information
- mhm->model=model;
- Setup_WZ_Normalization((T_VAR_Parameters*)mhm->model->theta,((T_VAR_Parameters*)mhm->model->theta)->A0);
- ConvertThetaToFreeParameters(model,pElementV(mhm->posterior_mode_VAR));
- mhm->log_likelihood_at_mode=LogLikelihood_StatesIntegratedOut(model);
- mhm->log_prior_at_mode=LogPrior(model);
- mhm->log_posterior_at_mode=mhm->log_likelihood_at_mode + mhm->log_prior_at_mode;
-
- // Center
- mhm->center=mhm->posterior_mode_VAR;
-
- return mhm;
-}
-
-T_MHM* AddDirichletScales(TVector alpha_scales, T_MHM *mhm)
-{
- if (!mhm) mhm=CreateMHM();
-
- mhm->alpha_scales=EquateVector((TVector)NULL,alpha_scales);
-
- return mhm;
-}
-
-T_MHM* CreateMHM(void)
-{
- int i, j;
- T_MHM* mhm;
-
- // Allocate structure
- mhm=(T_MHM*)malloc(sizeof(T_MHM));
-
- mhm->alpha_scales=(TVector)NULL;
-
- mhm->mean=(TVector)NULL;
- mhm->posterior_mode_VAR=(TVector)NULL;
- mhm->variance=(TMatrix)NULL;
- mhm->inverse_variance=(TMatrix)NULL;
- mhm->free_parameters_VAR=(TVector)NULL;
-
- mhm->BaseAlpha=(TVector*)NULL;
- mhm->Alpha=(TVector**)NULL;
-
- mhm->model=(TStateModel*)NULL;
-
- mhm->f_out=(FILE*)NULL;
- mhm->intermediate_output_filename=(char*)NULL;
- mhm->final_output_filename=(char*)NULL;
- mhm->intermediate_draws_output_filename=(char*)NULL;
- mhm->draws_output_filename=(char*)NULL;
- mhm->spec_filename=(char*)NULL;
- mhm->parameter_filename=(char*)NULL;
- mhm->parameter_header=(char*)NULL;
- mhm->mhm_filename=(char*)NULL;
-
- // Default values
- mhm->n_burn1=100000;
- mhm->n_burn2=0;
- mhm->n_mean_variance=200000;
- mhm->n_mhm=1000000;
- mhm->n_thin=1;
-
- ResetMHM(mhm);
-
- return mhm;
-}
-
-void BurnIn(T_MHM *mhm, int iterations, int period)
-{
- int count, begin_time, check=period;
- printf("Beginning burn in -- %d iterations.\n",iterations);
- begin_time=time((time_t*)NULL);
- for (count=1; count <= iterations; count++)
- {
- DrawAll(mhm->model);
-
- if (count == check)
- {
- check+=period;
- if (mhm->f_out)
- {
- fprintf(mhm->f_out,"%d iterations completed out of %d\n",count,iterations);
- PrintJumps(mhm->f_out,(T_VAR_Parameters*)(mhm->model->theta));
- fflush(mhm->f_out);
- }
-
- printf("Total Elapsed Time: %d seconds\n",(int)time((time_t*)NULL) - begin_time);
- fprintf(stdout,"%d iterations completed out of %d\n",count,iterations);
- PrintJumps(stdout,(T_VAR_Parameters*)(mhm->model->theta));
- }
- }
- ResetMetropolisInformation((T_VAR_Parameters*)(mhm->model->theta));
-}
-
-void BurnIn_AdaptiveMetropolisScale(T_MHM *mhm, int iterations, int period)
-{
- int verbose=1;
- AdaptiveMetropolisScale(mhm->model,iterations,period,verbose,mhm->f_out);
-}
-
-/*
- Computes mean and variance and base alpha
-*/
-void ComputeMeanVariance_MHM(T_MHM *mhm, int iterations, int period)
-{
- int i, j, begin_time, count, check=period;
- TVector *alpha;
- TMatrix S;
- PRECISION max, inc, tmp;
-
- dw_InitializeArray_vector(mhm->BaseAlpha,0.0);
- alpha=dw_CopyArray((void*)NULL,mhm->BaseAlpha);
-
- S=CreateMatrix(RowM(mhm->variance),ColM(mhm->variance));
- InitializeVector(mhm->mean,0.0);
- InitializeMatrix(mhm->variance,0.0);
-
- // loop and accumulate 1st and 2nd non-central moments
- fprintf(stdout,"Beginning mean and variance estimation -- %d iterations.\n",iterations);
- begin_time=time((time_t*)NULL);
- for (count=1; count <= iterations; count++)
- {
- DrawAll(mhm->model);
-
- ConvertThetaToFreeParameters(mhm->model,pElementV(mhm->free_parameters_VAR));
-
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- {
- AddVV(mhm->BaseAlpha[i],mhm->BaseAlpha[i],mhm->model->sv->ba[i]);
-
- for (j=DimV(alpha[i])-1; j >= 0; j--)
- ElementV(alpha[i],j)+=ElementV(mhm->model->sv->ba[i],j)*ElementV(mhm->model->sv->ba[i],j);
- }
-
- AddVV(mhm->mean,mhm->mean,mhm->free_parameters_VAR);
- OuterProduct(S,mhm->free_parameters_VAR,mhm->free_parameters_VAR);
- AddMM(mhm->variance,mhm->variance,S);
-
- if (count == check)
- {
- check+=period;
- fprintf(stdout,"Total Elapsed Time: %d seconds\n",(int)time((time_t*)NULL) - begin_time);
- fprintf(stdout,"%d iterations completed out of %d\n",count,iterations);
- PrintJumps(stdout,(T_VAR_Parameters*)(mhm->model->theta));
- }
- }
-
- // compute 1st and 2nd central moments for normal terms
- ProductVS(mhm->mean,mhm->mean,1.0/(PRECISION)iterations);
- ProductMS(mhm->variance,mhm->variance,1.0/(PRECISION)iterations);
- OuterProduct(S,mhm->mean,mhm->mean);
- SubtractMM(mhm->variance,mhm->variance,S);
-
- // Psudo variance
- SubtractVV(mhm->free_parameters_VAR,mhm->mean,mhm->posterior_mode_VAR);
- OuterProduct(S,mhm->free_parameters_VAR,mhm->free_parameters_VAR);
- AddMM(mhm->variance,mhm->variance,S);
-
- // Compute psudo-inverse of mhm->variance
- PsudoInverse(mhm->inverse_variance,mhm->variance);
-
- FreeMatrix(S);
-
- // compute base alpha's for Dirichlet distribution
- for (i=dw_DimA(mhm->BaseAlpha)-1; i >= 0; i--)
- ProductVS(mhm->BaseAlpha[i],mhm->BaseAlpha[i],1.0/(PRECISION)iterations);
- for (i=dw_DimA(mhm->BaseAlpha)-1; i >= 0; i--)
- for (j=DimV(mhm->BaseAlpha[i])-1; j >= 0; j--)
- ElementV(alpha[i],j)=ElementV(alpha[i],j)/(PRECISION)iterations - ElementV(mhm->BaseAlpha[i],j)*ElementV(mhm->BaseAlpha[i],j);
-
- for (i=dw_DimA(mhm->BaseAlpha)-1; i >= 0; i--)
- {
- for (max=0.0, j=DimV(mhm->BaseAlpha[i])-1; j >= 0; j--)
- if ((tmp=ElementV(mhm->BaseAlpha[i],j)*(1.0-ElementV(mhm->BaseAlpha[i],j))/ElementV(alpha[i],j)) > max) max=tmp;
- max-=1.0;
-
- for (inc=0.0, j=DimV(mhm->BaseAlpha[i])-1; j >= 0; j--)
- if ((tmp=1.1 - max*ElementV(mhm->BaseAlpha[i],j)) > inc) inc=tmp;
-
- for (j=DimV(mhm->BaseAlpha[i])-1; j >= 0; j--)
- ElementV(mhm->BaseAlpha[i],j)=max*ElementV(mhm->BaseAlpha[i],j)+inc;
- }
-
- // Create Alpha's
- mhm->Alpha=dw_CreateArray_array(DimV(mhm->alpha_scales));
- for (i=dw_DimA(mhm->Alpha)-1; i >= 0; i--)
- {
- mhm->Alpha[i]=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (j=dw_DimA(mhm->Alpha[i])-1; j >= 0; j--)
- mhm->Alpha[i][j]=ProductVS((TVector)NULL,mhm->BaseAlpha[j],ElementV(mhm->alpha_scales,i));
- }
-
- dw_FreeArray(alpha);
-}
-
-/* PRECISION UpdatePosteriorLikelihood(T_MHM *mhm) */
-/* { */
-/* PRECISION log_likelihood, log_posterior, difference; */
-
-/* log_likelihood=LogLikelihood_StatesIntegratedOut(mhm->model); */
-/* log_posterior=log_likelihood + LogPrior(mhm->model); */
-/* if (mhm->N > 1) */
-/* { */
-/* mhm->sum+=(difference=log_posterior - mhm->old_log_posterior); */
-/* mhm->sum_square+=difference*difference; */
-/* } */
-/* mhm->old_log_posterior=log_posterior; */
-/* if (log_likelihood > mhm->max_log_likelihood) mhm->max_log_likelihood=log_likelihood; */
-/* if (log_posterior > mhm->max_log_posterior) mhm->max_log_posterior=log_posterior; */
-
-/* return log_posterior; */
-/* } */
-
-/* void UpdateModifiedHarmonicMean(T_MHM *mhm, int n_singular) */
-/* { */
-/* int j, k; */
-/* PRECISION quadratic_form, log_posterior; */
-
-/* // Increment total number of observations */
-/* mhm->N++; */
-
-/* // Log posterior - log likelihood corrected for normalization (this is now done in VARbase.c) */
-/* log_posterior=UpdatePosteriorLikelihood(mhm); // + ((T_VAR_Parameters*)mhm->model->theta)->nvars*log(2); */
-
-/* // Compute quadratic form */
-/* ConvertThetaToFreeParameters(mhm->model,pElementV(mhm->free_parameters_VAR)); */
-/* SubtractVV(mhm->free_parameters_VAR,mhm->free_parameters_VAR,mhm->center); */
-/* quadratic_form=InnerProductSymmetric(mhm->free_parameters_VAR,mhm->inverse_variance); */
-
-/* // Print log posterior and quadratic form */
-/* fprintf(mhm->f_out,"%le %le",log_posterior,quadratic_form); */
-
-/* // Print Dirichlet PDF's */
-/* for (j=0; j < dw_DimA(mhm->Alpha); j++) */
-/* fprintf(mhm->f_out," %le",LogIndependentDirichlet_pdf(mhm->model->sv->ba,mhm->Alpha[j])); */
-
-/* // Print number of singular varinances */
-/* fprintf(mhm->f_out," %d\n",Get_VAR_Improper_Distribution_Counter()-n_singular); */
-
-/* // Print linefeed */
-/* //fprintf(mhm->f_out,"\n"); */
-
-/* // Tally states */
-/* for (j=mhm->model->sv->nstates-1; j >= 0; j--) mhm->states[j]=0; */
-/* for (j=mhm->model->sv->nobs; j > 1; j--) mhm->states[mhm->model->sv->S[j]]++; */
-/* for (j=mhm->model->sv->nstates-1; j >= 0; j--) fprintf(mhm->f_out_regime_counts,"%d ",mhm->states[j]); */
-/* fprintf(mhm->f_out_regime_counts,"\n"); */
-/* } */
-
-void UpdateModifiedHarmonicMean(T_MHM *mhm, int n_singular)
-{
- int j, k;
- PRECISION quadratic_form, log_likelihood, log_likelihood_states_integrated_out,
- log_prior_theta, log_prior_Q, log_posterior, difference;
-
- // Increment total number of observations
- mhm->N++;
-
- // Compute likelihoods and priors
- log_likelihood=LogLikelihood(mhm->model);
- log_likelihood_states_integrated_out=LogLikelihood_StatesIntegratedOut(mhm->model);
- log_prior_theta=LogPrior_Theta(mhm->model);
- log_prior_Q=LogPrior_Q(mhm->model);
- log_posterior=log_likelihood_states_integrated_out + log_prior_theta + log_prior_Q;
-
- // Average change
- if (mhm->N > 1)
- {
- mhm->sum+=(difference=log_posterior - mhm->old_log_posterior);
- mhm->sum_square+=difference*difference;
- }
- mhm->old_log_posterior=log_posterior;
-
- // Maximum likelihoods and priors
- if (log_likelihood_states_integrated_out > mhm->max_log_likelihood) mhm->max_log_likelihood=log_likelihood_states_integrated_out;
- if (log_posterior > mhm->max_log_posterior) mhm->max_log_posterior=log_posterior;
-
- // Compute quadratic form
- ConvertThetaToFreeParameters(mhm->model,pElementV(mhm->free_parameters_VAR));
- SubtractVV(mhm->free_parameters_VAR,mhm->free_parameters_VAR,mhm->center);
- quadratic_form=InnerProductSymmetric(mhm->free_parameters_VAR,mhm->inverse_variance);
-
- /*** Standard output ***/
- // Print log posterior and quadratic form
- fprintf(mhm->f_out,"%le %le",log_posterior,quadratic_form);
- // Print Dirichlet PDF's
- for (j=0; j < dw_DimA(mhm->Alpha); j++)
- fprintf(mhm->f_out," %le",LogIndependentDirichlet_pdf(mhm->model->sv->ba,mhm->Alpha[j]));
- // Print number of singular varinances
- fprintf(mhm->f_out," %d\n",Get_VAR_Improper_Distribution_Counter()-n_singular);
-
- /*** States not integrated out output ***/
- //if (mhm->f_states_not_integrated_out)
- // fprintf(mhm->f_states_not_integrated_out,"%le %le %le %le %le\n",quadratic_form,log_likelihood,log_prior_theta,log_prior_Q,log_posterior);
-
- // Tally states
- for (j=mhm->model->sv->nstates-1; j >= 0; j--) mhm->states[j]=0;
- for (j=mhm->model->sv->nobs; j > 1; j--) mhm->states[mhm->model->sv->S[j]]++;
- for (j=mhm->model->sv->nstates-1; j >= 0; j--) fprintf(mhm->f_out_regime_counts,"%d ",mhm->states[j]);
- fprintf(mhm->f_out_regime_counts,"\n");
-}
-
-void ComputeModifiedHarmonicMean(T_MHM *mhm, int period)
-{
- FILE *f_tmp;
- char *header;
-
- int count, check=period, begin_time, i, n_singular;
- printf("Beginning modified harmonic mean calculation -- %d iterations.\n",mhm->n_mhm);
- begin_time=time((time_t*)NULL);
- for (count=1; count <= mhm->n_mhm; count++)
- {
- n_singular=Get_VAR_Improper_Distribution_Counter();
- for (i=mhm->n_thin; i > 0; i--)
- {
- DrawAll(mhm->model);
- }
-
- UpdateModifiedHarmonicMean(mhm,n_singular);
- if (count == check)
- {
- check+=period;
- printf("Total Elapsed Time: %d seconds\n",(int)time((time_t*)NULL) - begin_time);
- printf("%d iterations completed out of %d\n",count,mhm->n_mhm);
- PrintJumps(stdout,(T_VAR_Parameters*)(mhm->model->theta));
- }
- }
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/******************************** Input/Output *********************************/
-/*******************************************************************************/
-static int ReadError_MHMio(char *id)
-{
- char *errmsg, *fmt="Error involving line identifier \"%s\"";
- sprintf(errmsg=(char*)malloc(strlen(fmt) + strlen(id) - 1),fmt,id);
- dw_UserError(errmsg);
- free(errmsg);
- return 0;
-}
-
-void PrintJumps(FILE *f, T_VAR_Parameters *p)
-{
- fprintf(f,"Jumping counts - Total: %d\n",p->Total_A0_Metropolis_Draws);
- dw_PrintArray(f,p->A0_Metropolis_Jumps,"%7d ");
-}
-
-void WriteMHM_Input(FILE *f_out, T_MHM *mhm)
-{
- fprintf(f_out,"//== scale values for Dirichlet distribution ==//\n%d\n",DimV(mhm->alpha_scales));
- dw_PrintVector(f_out,mhm->alpha_scales,"%22.14le ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== number draws for first burn-in ==//\n%d\n\n",mhm->n_burn1);
-
- fprintf(f_out,"//== number draws for second burn-in ==//\n%d\n\n",mhm->n_burn2);
-
- fprintf(f_out,"//== number draws to estimate mean and variance ==//\n%d\n\n",mhm->n_mean_variance);
-
- fprintf(f_out,"//== number draws for modified harmonic mean process ==//\n%d\n\n",mhm->n_mhm);
-
- fprintf(f_out,"//== thinning factor for modified harmonic mean process ==//\n%d\n\n",mhm->n_thin);
-}
-
-T_MHM* ReadMHM_Input(FILE *f, char *filename, T_MHM *mhm)
-{
- T_MHM *rtrn=mhm ? mhm : CreateMHM();
- FILE *f_in=f ? f : dw_OpenTextFile(filename);
- char *id;
- int m;
-
- id="//== scale values for Dirichlet distribution ==//";
- if (dw_SetFilePosition(f_in,id) && (fscanf(f_in," %d ",&m) == 1) && dw_ReadVector(f_in,rtrn->alpha_scales=CreateVector(m)))
- {
- id="//== number draws for first burn-in ==//";
- if (dw_SetFilePosition(f_in,id) && (fscanf(f_in," %d ",&(rtrn->n_burn1)) == 1))
- {
- id="//== number draws for second burn-in ==//";
- if (dw_SetFilePosition(f_in,id) && (fscanf(f_in," %d ",&(rtrn->n_burn2)) == 1))
- {
- id="//== number draws to estimate mean and variance ==//";
- if (dw_SetFilePosition(f_in,id) && (fscanf(f_in," %d ",&(rtrn->n_mean_variance)) == 1))
- {
- id="//== number draws for modified harmonic mean process ==//";
- if (dw_SetFilePosition(f_in,id) && (fscanf(f_in," %d ",&(rtrn->n_mhm)) == 1))
- {
- id="//== thinning factor for modified harmonic mean process ==//";
- if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %d ",&(rtrn->n_thin)) != 1))
- rtrn->n_thin=1;
- if (!f) fclose(f_in);
- return rtrn;
- }
- }
- }
- }
- }
- if (!mhm) FreeMHM(rtrn);
- if (!f) fclose(f_in);
- ReadError_MHMio(id);
- return (T_MHM*)NULL;
-}
-
-void WriteMeanVariance(FILE *f_out, T_MHM *mhm)
-{
- fprintf(f_out,"//== Base Dirichlet parameters ==//\n");
- dw_PrintArray(f_out,mhm->BaseAlpha,"%22.14le ");
-
- fprintf(f_out,"//== Variance ==//\n");
- dw_PrintMatrix(f_out,mhm->variance,"%22.14le ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Center ==//\n");
- dw_PrintVector(f_out,mhm->center,"%22.14le ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Mean ==//\n");
- dw_PrintVector(f_out,mhm->mean,"%22.14le ");
- fprintf(f_out,"\n");
-
- fprintf(f_out,"//== Posterior mode VAR parameters ==//\n");
- dw_PrintVector(f_out,mhm->posterior_mode_VAR,"%22.14le ");
- fprintf(f_out,"\n");
-}
-
-int ReadMeanVariance(FILE *f_in, T_MHM *mhm)
-{
- char *id;
- int i, j;
-
- id="//== Base Dirichlet parameters ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadArray(f_in,mhm->BaseAlpha))
- return ReadError_MHMio(id);
-
- // Create alpha
- mhm->Alpha=dw_CreateArray_array(DimV(mhm->alpha_scales));
- for (i=dw_DimA(mhm->Alpha)-1; i >= 0; i--)
- {
- mhm->Alpha[i]=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (j=dw_DimA(mhm->Alpha[i])-1; j >= 0; j--)
- mhm->Alpha[i][j]=ProductVS((TVector)NULL,mhm->BaseAlpha[j],ElementV(mhm->alpha_scales,i));
- }
-
- id="//== Variance ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,mhm->variance))
- return ReadError_MHMio(id);
- PsudoInverse(mhm->inverse_variance,mhm->variance);
-
- id="//== Center ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadVector(f_in,mhm->center))
- return ReadError_MHMio(id);
-
- id="//== Mean ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadVector(f_in,mhm->mean))
- return ReadError_MHMio(id);
-
- id="//== Posterior mode VAR parameters ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadVector(f_in,mhm->posterior_mode_VAR))
- return ReadError_MHMio(id);
-
- return 1;
-}
-
-
-/* T_MHM* Read_MHM(FILE *f, char *filename, TStateModel *model) */
-/* { */
-/* char *id; */
-
-/* id="//== p-values for gaussian truncation ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %d ",&n) != 1) || !dw_ReadVector(f_in,p_cuts=CreateVector(n))) dw_Error(PARSE_ERR); */
-
-/* id="//== zeta truncation values ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || !dw_ReadVector(f_in,zeta_cuts=CreateVector(2))) dw_Error(PARSE_ERR); */
-
-/* id="//== scale values for Dirichlet distribution ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || (fscanf(f_in," %d ",&m) != 1) || !dw_ReadVector(f_in,dirichlet_scales=CreateVector(m))) dw_Error(PARSE_ERR); */
-
-/* id="//== initial Metropolis scale values ==//"; */
-/* if (!dw_SetFilePosition(f_in,id) || !dw_ReadVector(f_in,metropolis_scales=CreateVector(((T_VAR_Parameters*)(model->theta))->nvars))) dw_Error(PARSE_ERR); */
-/* SetupMetropolisInformation(metropolis_scales,(T_VAR_Parameters*)(model->theta)); */
-/* } */
-
-/* void PrintMHM(FILE *f, char *filename, TStateModel *model, T_MHM *mhm) */
-/* { */
-/* int i, j; */
-/* FILE *f_out; */
-
-/* f_out=f ? f : dw_CreateTextFile(filename); */
-
-/* fprintf(f_out,"Log of marginal data density \n"); */
-/* for (i=0; i < RowM(mhm->log_sum); i++) */
-/* { */
-/* for (j=0; j < ColM(mhm->log_sum); j++) */
-/* fprintf(f_out,"%le ",log(mhm->N) - ElementM(mhm->log_sum,i,j)); */
-/* fprintf(f_out,"\n"); */
-/* } */
-/* fprintf(f_out,"\n"); */
-
-/* fprintf(f_out,"Total number of draws used to compute marginal data density\n%d\n\n",mhm->N); */
-
-/* fprintf(f_out,"For each p-value, percentage of non-zero terms in sum\n"); */
-/* for (i=0; i < mhm->n; i++) */
-/* if (mhm->N > 0) */
-/* fprintf(f_out,"%5.2lf ",(double)mhm->K[i]/(double)mhm->N); */
-/* else */
-/* fprintf(f_out,"0 "); */
-/* fprintf(f_out,"\n\n"); */
-
-/* fprintf(f_out,"Log values of sums of h( )/(Loglikelihood*Prior)\n"); */
-/* dw_PrintMatrix(f_out,mhm->log_sum,"%le "); */
-/* fprintf(f_out,"\n"); */
-
-/* fprintf(f_out,"Log value of the maximum of h( )/(Loglikelihood*Prior)\n"); */
-/* dw_PrintMatrix(f_out,mhm->log_max,"%le "); */
-/* fprintf(f_out,"\n"); */
-
-/* fprintf(f_out,"p-values for gaussian distribution\n"); */
-/* dw_PrintVector(f_out,mhm->p_values,"%5.3lf "); */
-/* fprintf(f_out,"\n"); */
-
-/* fprintf(f_out,"Cut points for the zeta\n"); */
-/* dw_PrintVector(f_out,mhm->zeta_cuts,"%lf "); */
-/* fprintf(f_out,"\n"); */
-
-/* fprintf(f_out,"Scaling factor for zeta truncation\n"); */
-/* dw_PrintVector(f_out,mhm->zeta_p_values,"%lf "); */
-/* fprintf(f_out,"\n"); */
-
-/* fprintf(f_out,"Log likelihood, posterior, and prior evauated at posterior peak\n"); */
-/* fprintf(f_out,"%lf %lf %lf\n\n",mhm->log_likelihood_at_mode,mhm->log_posterior_at_mode,mhm->log_prior_at_mode); */
-
-/* fprintf(f_out,"Maximum draw of log likelihood and posterior\n"); */
-/* fprintf(f_out,"%lf %lf\n\n",mhm->max_log_likelihood,mhm->max_log_posterior); */
-
-/* fprintf(f_out,"Mean and standard deviation of the log ratio of the posterior kernel of successive draws\n%le %lf\n\n", */
-/* mhm->sum/(double)mhm->N,sqrt((mhm->sum_square - mhm->sum*mhm->sum/(double)mhm->N)/(double)mhm->N)); */
-
-/* PrintJumps(f_out,(T_VAR_Parameters*)(model->theta)); */
-
-/* fprintf(f_out,"Total number of draws: %d\n",mhm->N); */
-/* fprintf(f_out,"Number of draws rejected because of zeta truncation: %d\n",mhm->zeta_truncations); */
-/* fprintf(f_out,"Number of draws rejected because of gaussian truncation.\n"); */
-/* dw_PrintArray(f_out,mhm->gaussian_truncations,"%d "); */
-
-/* if (!f) fclose(f_out); */
-/* } */
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-
diff --git a/matlab/swz/c-code/sbvar/var/mhm_VAR.h b/matlab/swz/c-code/sbvar/var/mhm_VAR.h
deleted file mode 100644
index ca8c52b6e4cc34da60e8b61cb35de441e88041c6..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/mhm_VAR.h
+++ /dev/null
@@ -1,88 +0,0 @@
-
-#ifndef __MODIFIED_HARMONIC_MEAN_
-#define __MODIFIED_HARMONIC_MEAN_
-
-#include "matrix.h"
-#include "switch.h"
-#include "VARbase.h"
-
-typedef struct
-{
- // Sample sizes to use in computations
- int n_burn1; // set to negative of actual value if first burn-in has been completed
- int n_burn2; // set to negative of actual value if second burn-in has been completed
- int n_mean_variance; // set to negative of actual value if mean and variance have been computed
- int n_mhm; // number of draws for computing the modified harmonic mean
- int n_thin; // thinning factor
-
- // Accumulation fields
- int N; // Total number observations
-
- PRECISION old_log_posterior;
- PRECISION sum;
- PRECISION sum_square;
- PRECISION max_log_posterior;
- PRECISION max_log_likelihood;
-
- // mhm info
- TVector mean; // Gaussian mean
- TMatrix variance; // Gaussian variance
- TMatrix inverse_variance; // Inverse of Gaussian variance
- TVector center; // Used to center gaussian. Must be equal to posterior_mode_VAR or mean.
-
- TVector alpha_scales; // scaling values for base dirichlet pdf parameters
- TVector* BaseAlpha; // base dirichlet pdf parameters
- TVector** Alpha; // base dirichlet pdf parameters times the scale factors
-
- // Model info
- TStateModel *model;
- TVector posterior_mode_VAR;
- PRECISION log_likelihood_at_mode;
- PRECISION log_posterior_at_mode;
- PRECISION log_prior_at_mode;
-
- // Workspace
- TVector free_parameters_VAR; // workspace for free parameters for VAR
-
- // Workspace for states
- int *states;
-
- // Files
- FILE *f_out;
- FILE *f_out_regime_counts;
- char *regime_counts_filename;
- char *intermediate_output_filename;
- char *final_output_filename;
- char *intermediate_draws_output_filename;
- char *draws_output_filename;
- char *spec_filename;
- char *parameter_filename;
- char *parameter_header;
- char *mhm_filename;
-
-} T_MHM;
-
-// Constructors
-void FreeMHM(T_MHM *mhm);
-T_MHM* CreateMHM(void);
-T_MHM* AddDirichletScales(TVector alpha_scales, T_MHM *mhm);
-T_MHM* AddStateModel(TStateModel *model, T_MHM *mhm);
-
-void ResetMHM(T_MHM *mhm);
-void BurnIn(T_MHM *mhm, int iterations, int period);
-void BurnIn_AdaptiveMetropolisScale(T_MHM *mhm, int iterations, int period);
-void ComputeMeanVariance_MHM(T_MHM *mhm, int iterations, int period);
-int IsValidZeta(PRECISION* zeta, int n, PRECISION* gamma_cuts);
-PRECISION UpdatePosteriorLikelihood(T_MHM *mhm);
-void UpdateModifiedHarmonicMean(T_MHM *mhm, int n_singular);
-void ComputeModifiedHarmonicMean(T_MHM *mhm, int period);
-
-void WriteMHM_Input(FILE *f_out, T_MHM *mhm);
-T_MHM* ReadMHM_Input(FILE *f_in, char *filename, T_MHM *mhm);
-void WriteMeanVariance(FILE *f_out, T_MHM *mhm);
-int ReadMeanVariance(FILE *f_in, T_MHM *mhm);
-
-void PrintJumps(FILE *f, T_VAR_Parameters *p);
-void PrintMHM(FILE *f, char *filename, TStateModel *model, T_MHM *mhm);
-
-#endif
diff --git a/matlab/swz/c-code/sbvar/var/mhm_VAR_main_1.c b/matlab/swz/c-code/sbvar/var/mhm_VAR_main_1.c
deleted file mode 100644
index 1c2ffe5a3dfdd8133e90c3909c1774b09b07f2d2..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/mhm_VAR_main_1.c
+++ /dev/null
@@ -1,530 +0,0 @@
-
-#include "mhm_VAR.h"
-#include "VARbase.h"
-#include "VARio.h"
-#include "switch.h"
-#include "switchio.h"
-#include "dw_rand.h"
-#include "dw_error.h"
-#include "dw_ascii.h"
-#include "dw_parse_cmd.h"
-
-#include <time.h>
-#include <string.h>
-#include <ctype.h>
-#include <stdlib.h>
-
-static void ReadError_MHMio(char *id)
-{
- char *errmsg, *fmt="Error after line identifier ""%s""";
- sprintf(errmsg=(char*)malloc(strlen(fmt) + strlen(id) - 1),fmt,id);
- dw_UserError(errmsg);
- free(errmsg);
-}
-
-/*
- Creates a copy of d and adds a trailing '/' if necessary. The returned
- pointer, if not null, must be freed by calling routine.
-*/
-static char* AddSlash(char *d)
-{
- char *d_out;
- int k=strlen(d);
- if (d[0] && d[k-1] != '/')
- {
- d_out=(char*)malloc(k+2);
- strcat(strcpy(d_out,d),"/");
- }
- else
- {
- d_out=(char*)malloc(k+2);
- strcpy(d_out,d);
- }
- return d_out;
-}
-
-T_MHM* RestartFromFinalFile(char *filename, T_MHM *mhm)
-{
- FILE *f_in;
- char *id;
- TStateModel *model;
- if (f_in=fopen(filename,"rt"))
- {
- id="//== Specification after mhm draws ==//";
- if (dw_SetFilePosition(f_in,id))
- {
- if (!mhm)
- {
- mhm=ReadMHM_Input(f_in,(char*)NULL,(T_MHM*)NULL);
- mhm->mhm_filename=filename;
- }
- mhm->spec_filename=mhm->parameter_filename=filename;
-
- model=Read_VAR_Specification(f_in,(char*)NULL);
- mhm->parameter_header="Posterior mode: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- mhm->parameter_header="Final draw: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
-
- mhm->n_burn1=-mhm->n_burn1;
- mhm->n_burn2=-mhm->n_burn2;
- mhm->n_mean_variance=-mhm->n_mean_variance;
- ReadMeanVariance(f_in,mhm);
- return mhm;
- }
- }
- return (T_MHM*)NULL;
-}
-
-/*
-
-*/
-T_MHM* RestartFromIntermediateFile(char *filename, T_MHM *mhm)
-{
- FILE *f_in;
- char *id;
- TStateModel *model;
- if (f_in=fopen(filename,"rt"))
- {
- if (!mhm)
- {
- mhm=ReadMHM_Input(f_in,(char*)NULL,(T_MHM*)NULL);
- mhm->mhm_filename=filename;
- }
- mhm->spec_filename=mhm->parameter_filename=filename;
- id="//== Specification after mhm draws ==//";
- if (dw_SetFilePosition(f_in,id))
- {
- model=Read_VAR_Specification(f_in,(char*)NULL);
- mhm->parameter_header="Posterior mode: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- mhm->parameter_header="Final draw: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
-
- mhm->n_burn1=-mhm->n_burn1;
- mhm->n_burn2=-mhm->n_burn2;
- mhm->n_mean_variance=-mhm->n_mean_variance;
- ReadMeanVariance(f_in,mhm);
- }
- else
- {
- id="//== Specification after mean-variance estimation ==//";
- if (dw_SetFilePosition(f_in,id))
- {
- model=Read_VAR_Specification(f_in,(char*)NULL);
- mhm->parameter_header="Posterior mode: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- mhm->parameter_header="Mean-variance: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
-
- mhm->n_burn1=-mhm->n_burn1;
- mhm->n_burn2=-mhm->n_burn2;
- mhm->n_mean_variance=-mhm->n_mean_variance;
- ReadMeanVariance(f_in,mhm);
- }
- else
- {
- id="//== Specification after second burn-in ==//";
- if (dw_SetFilePosition(f_in,id))
- {
- model=Read_VAR_Specification(f_in,(char*)NULL);
- mhm->parameter_header="Posterior mode: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- mhm->parameter_header="Second burn-in: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
-
- mhm->n_burn1=-mhm->n_burn1;
- mhm->n_burn2=-mhm->n_burn2;
- }
- else
- {
- id="//== Specification after first burn-in ==//";
- if (dw_SetFilePosition(f_in,id))
- {
- model=Read_VAR_Specification(f_in,(char*)NULL);
- mhm->parameter_header="Posterior mode: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- mhm->parameter_header="First burn-in: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
-
- mhm->n_burn1=-mhm->n_burn1;
- }
- else
- {
- model=Read_VAR_Specification(f_in,(char*)NULL);
- mhm->parameter_header="Posterior mode: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- }
- }
- }
- }
- fclose(f_in);
- return (mhm);
- }
- return (T_MHM*)NULL;
-}
-
-/*
- Attempt to set up model from command line. Command line options are the
- following
-
- -di <directory>
- If this argument exists, then all input files are in specified directory.
-
- -do <directory>
- If this argument exists, then all output files are in specified directory.
-
- -ft <filename tag>
- If this argument exists, then the following is attempted:
-
- 1) specification file name: mhm_final_<tag>.dat
- mhm arguments file name: mhm_final_<tag>.dat
-
- 2) specification file name: mhm_intermediate_<tag>.dat
- mhm arguments file name: mhm_intermediate_<tag>.dat
-
- 3) specification file name: est_final_<tag>.dat
- mhm arguments file name: -fi <filename>
-
- -fi <filename>
- If this argument exists, then additional mhm arguments are read from the
- input file with the given filename.
-
- -fs <filename>
- If this argument exists, then the specification file name is <filename>.
- The argument -ft takes precedence over -fs.
-
- -fp <filename>
- If this argument exists, then the posterior is read from <filename>. Must
- be used in conjunction with the argument -fs. The default value is the
- filename associated with the argument -fs.
-
- -ph <header>
- If this argument exists, then the header for the posterior file is
- <header>. Must be used in conjuction with the arguments -fp or -fs. The
- default value is "Posterior mode: ".
-
- -cm
- If this argument exists, then the mean of the posterior draws are used to
- center the quadratic form.
-
- If no command line options are given, then attemps to use a default input file
- with the name "default.ini". Returns one valid pointer to a TStateModel upon
- success and null upon failure.
-*/
-#define LOG_TWO_PI 1.837877066409345
-T_MHM* CreateMHM_CommandLine(int nargs, char **args)
-{
- TStateModel *model;
- T_MHM *mhm=(T_MHM*)NULL, *rtrn=(T_MHM*)NULL;
- char *d_in, *d_out, *tag, *filename, *spec_filename, *mhm_filename, *id, *fmt;
- FILE *f_in;
- TVector alpha_scales;
-
- d_in=AddSlash(dw_ParseString_String(nargs,args,"di",""));
- d_out=AddSlash(dw_ParseString_String(nargs,args,"do",""));
-
- if (filename=dw_ParseString_String(nargs,args,"fi",(char*)NULL))
- {
- fmt="%s%s";
- sprintf(mhm_filename=(char*)malloc(strlen(d_in) + strlen(fmt) + strlen(filename) - 3),fmt,d_in,filename);
- mhm=ReadMHM_Input((FILE*)NULL,mhm_filename,(T_MHM*)NULL);
- mhm->mhm_filename=mhm_filename;
- }
-
- if (tag=dw_ParseString_String(nargs,args,"ft",(char*)NULL))
- {
- fmt="%smhm_final_%s.dat";
- sprintf(spec_filename=(char*)malloc(strlen(d_in) + strlen(fmt) + strlen(tag) - 3),fmt,d_in,tag);
- if (rtrn=RestartFromFinalFile(spec_filename,mhm))
- mhm=rtrn;
- else
- {
- free(spec_filename);
- fmt="%smhm_intermediate_%s.dat";
- sprintf(spec_filename=(char*)malloc(strlen(d_in) + strlen(fmt) + strlen(tag) - 3),fmt,d_in,tag);
- if (rtrn=RestartFromIntermediateFile(spec_filename,mhm))
- mhm=rtrn;
- else
- {
- free(spec_filename);
- fmt="%sest_final_%s.dat";
- sprintf(spec_filename=(char*)malloc(strlen(d_in) + strlen(fmt) + strlen(tag) - 3),fmt,d_in,tag);
- if (!(f_in=fopen(spec_filename,"rt")))
- {
- fprintf(stderr,"CreateMHM_CommandLine: Unable to create model from %s tag.\n",tag);
- if (mhm) FreeMHM(mhm);
- }
- else
- if (mhm)
- {
- mhm->parameter_filename=mhm->spec_filename=spec_filename;
- model=Read_VAR_Specification(f_in,(char*)NULL);
- mhm->parameter_header="Posterior mode: ";
- ReadTransitionMatrices(f_in,(char*)NULL,mhm->parameter_header,model);
- Read_VAR_Parameters(f_in,(char*)NULL,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- fclose(f_in);
- }
- }
- }
- }
- else
- if (filename=dw_ParseString_String(nargs,args,"fs",(char*)NULL))
- {
- if (mhm)
- {
- fmt="%s%s";
- sprintf(mhm->spec_filename=(char*)malloc(strlen(d_in) + strlen(fmt) + strlen(filename) - 3),fmt,d_in,filename);
- model=Read_VAR_Specification((FILE*)NULL,mhm->spec_filename);
- if (!(filename=dw_ParseString_String(nargs,args,"fp",(char*)NULL)))
- filename=dw_ParseString_String(nargs,args,"fs",(char*)NULL);
- sprintf(mhm->parameter_filename=(char*)malloc(strlen(d_in) + strlen(fmt) + strlen(filename) - 3),fmt,d_in,filename);
- mhm->parameter_header=dw_ParseString_String(nargs,args,"ph","Posterior mode: ");
- ReadTransitionMatrices((FILE*)NULL,mhm->parameter_filename,mhm->parameter_header,model);
- Read_VAR_Parameters((FILE*)NULL,mhm->parameter_filename,mhm->parameter_header,model);
- AddStateModel(model,mhm);
- }
- }
- else
- {
- fprintf(stderr,"CreateMHM_CommandLine(): No specification file given.\n");
- if (mhm) FreeMHM(mhm);
- exit(0);
- }
-
- if (!mhm)
- {
- fprintf(stderr,"CreateMHM_CommandLine: No mhm input data file specified.\n");
- exit(0);
- }
-
- // Output filenames
- if (!(tag=dw_ParseString_String(nargs,args,"fo",(char*)NULL)))
- tag=dw_ParseString_String(nargs,args,"ft","default");
- fmt="%smhm_intermediate_%s.dat";
- sprintf(mhm->intermediate_output_filename=(char*)malloc(strlen(d_out) + strlen(fmt) + strlen(tag) - 3),fmt,d_out,tag);
- fmt="%smhm_final_%s.dat";
- sprintf(mhm->final_output_filename=(char*)malloc(strlen(d_out) + strlen(fmt) + strlen(tag) - 3),fmt,d_out,tag);
- fmt="%smhm_intermediate_draws_%s.dat";
- sprintf(mhm->intermediate_draws_output_filename=(char*)malloc(strlen(d_out) + strlen(fmt) + strlen(tag) - 3),fmt,d_out,tag);
- fmt="%smhm_draws_%s.dat";
- sprintf(mhm->draws_output_filename=(char*)malloc(strlen(d_out) + strlen(fmt) + strlen(tag) - 3),fmt,d_out,tag);
- fmt="%smhm_regime_counts_%s.dat";
- sprintf(mhm->regime_counts_filename=(char*)malloc(strlen(d_out) + strlen(fmt) + strlen(tag) - 3),fmt,d_out,tag);
- //fmt="%smhm_draws_states_not_integrated_%s.dat";
- //sprintf(mhm->states_not_integrated_out_filename=(char*)malloc(strlen(d_out) + strlen(fmt) + strlen(tag) - 3),fmt,d_out,tag);
-
- free(d_in);
- free(d_out);
- return mhm;
-}
-#undef LOG_TWO_PI
-
-int main(int nargs, char **args)
-{
- T_MHM *mhm;
- char *header, *buffer[256];
- int initial_time, begin_time, end_time;
- FILE *f_out_intermediate, *f_out_final, *f_out_intermediate_draws;
-
- if (mhm=CreateMHM_CommandLine(nargs,args))
- {
- //=== Random seed ===//
- dw_initialize_generator(0);
-
- //=== Test new normalization code ===//
- /**
- TVector** A0;
- PRECISION x1, x2, x3, x4;
- A0=dw_CopyArray((TVector**)NULL,((T_VAR_Parameters*)mhm->model->theta)->A0);
-
- dw_initialize_generator(-1);
-
- // burn-in
- initial_time=begin_time=time((time_t*)NULL);
- BurnIn_AdaptiveMetropolisScale(mhm,0,1000);
- end_time=time((time_t*)NULL);
-
- // test
- while (1)
- {
- Setup_WZ_Normalization((T_VAR_Parameters*)mhm->model->theta,A0);
- printf("Likelihood = %lg (WZ normalization)\n",LogLikelihood_StatesIntegratedOut(mhm->model));
- printf("Prior = %lg (WZ normalization)\n",x2=LogPrior(mhm->model));
- printf("Posterior = %lg (WZ normalization)\n",x4=LogPosterior_StatesIntegratedOut(mhm->model));
-
- Setup_No_Normalization((T_VAR_Parameters*)mhm->model->theta);
- printf("Likelihood = %lg (no normalization)\n",LogLikelihood_StatesIntegratedOut(mhm->model));
- printf("Prior = %lg (no normalization)\n",x1=LogPrior(mhm->model));
- printf("Posterior = %lg (no normalization)\n",x3=LogPosterior_StatesIntegratedOut(mhm->model));
-
- printf("Difference %lg %lg %lg\n\n",x2-x1,x4-x3,((T_VAR_Parameters*)mhm->model->theta)->nvars*log(2));
-
- //Setup_WZ_Normalization((T_VAR_Parameters*)mhm->model->theta,A0);
- DrawAll(mhm->model);
-
- getchar();
- }
- /**/
- //=== End test new normalization code ===//
-
- // Use WZ normalization
- Setup_WZ_Normalization((T_VAR_Parameters*)mhm->model->theta,((T_VAR_Parameters*)mhm->model->theta)->A0);
-
- // Posterior mode - Initial specification
- f_out_intermediate=dw_AppendTextFile(mhm->intermediate_output_filename);
- fprintf(f_out_intermediate,"//== Initial Specification ==//\n\n");
- Write_VAR_Specification(f_out_intermediate,(char*)NULL,mhm->model);
- ((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies=0;
- Reset_VAR_Improper_Distribution_Counter();
- header="Posterior mode: ";
- WriteTransitionMatrices(f_out_intermediate,(char*)NULL,header,mhm->model);
- Write_VAR_Parameters(f_out_intermediate,(char*)NULL,header,mhm->model);
- fclose(f_out_intermediate);
-
-/* f_out_final=dw_CreateTextFile(mhm->final_output_filename); */
-/* header="Posterior mode: "; */
-/* WriteTransitionMatrices(f_out_final,(char*)NULL,header,mhm->model); */
-/* Write_VAR_Parameters(f_out_final,(char*)NULL,header,mhm->model); */
-/* fclose(f_out_final); */
-
- f_out_intermediate_draws=dw_CreateTextFile(mhm->intermediate_draws_output_filename);
-
- // First burn-in
- if (mhm->n_burn1 > 0)
- {
- mhm->f_out=f_out_intermediate_draws;
- initial_time=begin_time=time((time_t*)NULL);
- BurnIn_AdaptiveMetropolisScale(mhm,mhm->n_burn1,1000);
- end_time=time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
- }
-
- // After first burn-in
- f_out_intermediate=dw_AppendTextFile(mhm->intermediate_output_filename);
- fprintf(f_out_intermediate,"//== Specification after first burn-in ==//\n");
- fprintf(f_out_intermediate,"Number inconsistent normalizations: %d\n",((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies);
- fprintf(f_out_intermediate,"Number singular inverse variances: %d\n\n",Get_VAR_Improper_Distribution_Counter());
- ((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies=0;
- header="First burn-in: ";
- WriteTransitionMatrices(f_out_intermediate,(char*)NULL,header,mhm->model);
- Write_VAR_Parameters(f_out_intermediate,(char*)NULL,header,mhm->model);
- fclose(f_out_intermediate);
-
- // Second burn-in
- if (mhm->n_burn2 > 0)
- {
- mhm->f_out=f_out_intermediate_draws;
- initial_time=begin_time=time((time_t*)NULL);
- BurnIn(mhm,mhm->n_burn2,1000);
- end_time=time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
-
- fprintf(stdout,"Number inconsistent normalizations: %d\n",((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies);
- fprintf(stdout,"Number singular inverse variances: %d\n\n",Get_VAR_Improper_Distribution_Counter());
- }
-
- fclose(f_out_intermediate_draws);
-
- // After second burn-in
- f_out_intermediate=dw_AppendTextFile(mhm->intermediate_output_filename);
- fprintf(f_out_intermediate,"//== Specification after second burn-in ==//\n");
- fprintf(f_out_intermediate,"Number inconsistent normalizations: %d\n",((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies);
- fprintf(f_out_intermediate,"Number singular inverse variances: %d\n\n",Get_VAR_Improper_Distribution_Counter());
- ((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies=0;
- header="Second burn-in: ";
- WriteTransitionMatrices(f_out_intermediate,(char*)NULL,header,mhm->model);
- Write_VAR_Parameters(f_out_intermediate,(char*)NULL,header,mhm->model);
- fclose(f_out_intermediate);
-
- // Mean-variance estimation
- if (mhm->n_mean_variance > 0)
- {
- begin_time=time((time_t*)NULL);
- ComputeMeanVariance_MHM(mhm,mhm->n_mean_variance,10000);
- end_time=time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
-
- fprintf(stdout,"Number inconsistent normalizations: %d\n",((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies);
- fprintf(stdout,"Number singular inverse variances: %d\n\n",Get_VAR_Improper_Distribution_Counter());
- }
-
- // Set center to mean if necessary
- if (dw_FindArgument_String(nargs,args,"cm") >= 0)
- {
- fprintf(stdout,"Using mean for center\n");
- mhm->center=mhm->mean;
- }
- else
- fprintf(stdout,"Using posterior mode for center\n");
-
-
- // After mean-variance estimation
- f_out_intermediate=dw_AppendTextFile(mhm->intermediate_output_filename);
- fprintf(f_out_intermediate,"//== Specification after mean-variance estimation ==//\n");
- fprintf(f_out_intermediate,"Number inconsistent normalizations: %d\n",((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies);
- fprintf(f_out_intermediate,"Number singular inverse variances: %d\n\n",Get_VAR_Improper_Distribution_Counter());
- ((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies=0;
- header="Mean-variance: ";
- WriteTransitionMatrices(f_out_intermediate,(char*)NULL,header,mhm->model);
- Write_VAR_Parameters(f_out_intermediate,(char*)NULL,header,mhm->model);
- WriteMeanVariance(f_out_intermediate,mhm);
- fclose(f_out_intermediate);
-
- // Open draw file and states file
- mhm->f_out=dw_CreateTextFile(mhm->draws_output_filename);
- WriteMHM_Input(mhm->f_out,mhm);
- WriteMeanVariance(mhm->f_out,mhm);
- //mhm->f_states_not_integrated_out=dw_CreateTextFile(mhm->states_not_integrated_out_filename);
- //WriteMHM_Input(mhm->f_states_not_integrated_out,mhm);
- //WriteMeanVariance(mhm->f_states_not_integrated_out,mhm);
- mhm->f_out_regime_counts=dw_CreateTextFile(mhm->regime_counts_filename);
-
- // Modified harmonic mean draws
- fprintf(mhm->f_out,"\n//== Draws ==//\n");
- //fprintf(mhm->f_states_not_integrated_out,"\n//== Draws ==//\n");
-
- begin_time=time((time_t*)NULL);
- ComputeModifiedHarmonicMean(mhm,10000);
- end_time=time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
- fprintf(stdout,"Number inconsistent normalizations: %d\n",((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies);
- fprintf(stdout,"Number singular inverse variances: %d\n\n",Get_VAR_Improper_Distribution_Counter());
-
- fclose(mhm->f_out);
-
- // After modified harmonic mean draws
- f_out_intermediate=dw_AppendTextFile(mhm->intermediate_output_filename);
- fprintf(f_out_intermediate,"//== Specification after mhm draws ==//\n");
- fprintf(f_out_intermediate,"Number inconsistent normalizations: %d\n",((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies);
- fprintf(f_out_intermediate,"Number singular inverse variances: %d\n\n",Get_VAR_Improper_Distribution_Counter());
- fprintf(f_out_intermediate,"//== RNG State ==//\n");
- dw_print_generator_state(f_out_intermediate);
- fprintf(f_out_intermediate,"\n");
- ((T_VAR_Parameters*)mhm->model->theta)->WZ_inconsistancies=0;
- header="Final draw: ";
- WriteTransitionMatrices(f_out_intermediate,(char*)NULL,header,mhm->model);
- Write_VAR_Parameters(f_out_intermediate,(char*)NULL,header,mhm->model);
- fclose(f_out_intermediate);
- }
-
- return 0;
-}
diff --git a/matlab/swz/c-code/sbvar/var/mhm_VAR_main_2.c b/matlab/swz/c-code/sbvar/var/mhm_VAR_main_2.c
deleted file mode 100644
index 9908132fd49369e747ce0f6e0a404a0961252b52..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/mhm_VAR_main_2.c
+++ /dev/null
@@ -1,2047 +0,0 @@
-
-
-#include "matrix.h"
-#include "dw_ascii.h"
-#include "dw_rand.h"
-#include "dw_matrix_rand.h"
-#include "dw_matrix_sort.h"
-
-#include "dw_parse_cmd.h"
-
-#include "switch.h"
-#include "switchio.h"
-#include "VARbase.h"
-#include "VARio.h"
-#include "mhm_VAR.h"
-
-#include "spherical.h"
-
-#include <stdlib.h>
-#include <math.h>
-#include <string.h>
-#include <time.h>
-
-/*
- Returns ln(exp(a) + exp(b)) computed to avoid overflow. If
- a = ln(c) and b = ln(d), as is usually the case, then the
- routine returns ln(c + d).
-
-*/
-static PRECISION AddLogs_static(PRECISION a, PRECISION b)
-{
- return (a > b) ? a + log(1.0 + exp(b-a)) : b + log(exp(a-b) + 1.0);
-}
-
-/*
- Let h(x) and f(x) be probability density functions and let c be an unknown
- constant. In applications, the following will usually be true.
- x - parameters
- y - data
- f(x) - posterior distribution = p(x|y)
- h(x) - proposal distribution
- c - marginal distribution = p(y)
- c*f(x) - likelihood*prior = p(y|x)*p(x)
-
- Assumes:
- posterior : M x 2 matrix with posterior[i][0] = ln(h(x(i))) and
- posterior[i][1] = ln(c*f(x(i))) where x(i) is sampled from f(x).
-
- Returns:
- Estimate of c.
-
- Notes:
- Uses the fact that c = 1/I(L) where I(L) is the integral over x of
-
- h(x)/(c*f(x)) * f(x)
-
- I(L) can be computed from the posterior draws.
-
-*/
-PRECISION ComputeMarginalDensity_Standard(TMatrix posterior)
-{
- PRECISION I=MINUS_INFINITY;
- int i;
-
- for (i=RowM(posterior)-1; i >= 0; i--)
- I=AddLogs_static(I,ElementM(posterior,i,0) - ElementM(posterior,i,1));
-
- I-=log((PRECISION)RowM(posterior));
-
- return -I;
-}
-
-
-/*
- Let h(x) and f(x) be probability density functions and let c be an unknown
- constant. In applications, the following will usually be true.
- x - parameters
- y - data
- f(x) - posterior distribution = p(x|y)
- h(x) - proposal distribution
- c - marginal distribution = p(y)
- c*f(x) - likelihood*prior = p(y|x)*p(x)
-
- Assumes:
- posterior : M x 2 matrix with posterior[i][0] = ln(h(x(i))) and
- posterior[i][1] = ln(c*f(x(i))) where x(i) is sampled from f(x).
- L : cutoff value in logs.
- q : estimate of the probability that x sampled from h(x) satisfies
- c*f(x) > exp(L).
-
- Returns:
- Estimate of c or MINUS_INFINITY if no proposal draws satisfied the
- restriction given by the cutoff value L.
-
- Notes:
- Uses the fact that c = q/I(L) where I(L) is the integral over x of
-
- 1{c*f(x)>exp(L)}*h(x)/(c*f(x)) * f(x)
-
- I(L) can be computed from the posterior draws.
-
-*/
-PRECISION ComputeMarginalDensity_WZ1_q(TMatrix posterior, PRECISION L, PRECISION q, int *in_posterior)
-{
- PRECISION I=MINUS_INFINITY;
- int i;
-
- for (*in_posterior=0, i=RowM(posterior)-1; i >= 0; i--)
- if (ElementM(posterior,i,1) >= L)
- {
- (*in_posterior)++;
- I=AddLogs_static(I,ElementM(posterior,i,0) - ElementM(posterior,i,1));
- }
-
- if ((*in_posterior) > 0) I-=log((PRECISION)RowM(posterior));
-
- return (q == 0.0) ? MINUS_INFINITY : log(q) - I;
-}
-
-/*
- Let h(x) and f(x) be probability density functions and let c be an unknown
- constant. In applications, the following will usually be true.
- x - parameters
- y - data
- f(x) - posterior distribution = p(x|y)
- h(x) - proposal distribution
- c - marginal distribution = p(y)
- c*f(x) - likelihood*prior = p(y|x)*p(x)
-
- Assumes:
- proposal : N x 2 matrix with proposal[i][0] = ln(h(x(i))) and
- proposal[i][1] = ln(c*f(x(i))) where x(i) is sampled from h(x).
- posterior : M x 2 matrix with posterior[i][0] = ln(h(x(i))) and
- posterior[i][1] = ln(c*f(x(i))) where x(i) is sampled from f(x).
- L : cutoff value.
-
- Returns:
- Estimate of c or MINUS_INFINITY if no proposal draws satisfied the
- restriction given by the cutoff value L.
-
- Notes:
- Uses the fact that c = P(L)/I(L) where p(L) is the probability that x
- sampled from h(x) satisfies c*f(x) > exp(L) and I(L) is the integral over x
- of
-
- 1{c*f(x)>exp(L)}*h(x)/(c*f(x)) * f(x)
-
- P(L) can be computed from the proposal draws and I(L) can be computed from
- the posterior draws.
-
-*/
-PRECISION ComputeMarginalDensity_WZ1(TMatrix proposal, TMatrix posterior, PRECISION L, int *in_proposal, int *in_posterior)
-{
- PRECISION I=MINUS_INFINITY;
- int i;
-
- for (*in_proposal=0, i=RowM(proposal)-1; i >= 0; i--)
- if (ElementM(proposal,i,1) >= L) (*in_proposal)++;
-
- for (*in_posterior=0, i=RowM(posterior)-1; i >= 0; i--)
- if (ElementM(posterior,i,1) >= L)
- {
- (*in_posterior)++;
- I=AddLogs_static(I,ElementM(posterior,i,0) - ElementM(posterior,i,1));
- }
-
- if ((*in_posterior) > 0) I-=log((PRECISION)RowM(posterior));
-
- return ((*in_proposal) == 0) ? MINUS_INFINITY : log((PRECISION)(*in_proposal)/(PRECISION)RowM(proposal)) - I;
-}
-
-/*
- ess - effective sample size
- This is the sum of h(x)/(c*f(x)) divided by the max of h(x)/(c*f(x)). See
- the header for ComputeMarginalDensity_WZ1() for the definitions of h(x) and c*f(x).
-*/
-PRECISION ComputeEffectiveSampleSize_WZ1(TMatrix posterior, PRECISION L)
-{
- PRECISION sum=MINUS_INFINITY, max=MINUS_INFINITY, tmp;
- int i;
-
- for (i=RowM(posterior)-1; i >= 0; i--)
- if (ElementM(posterior,i,1) >= L)
- {
- tmp=ElementM(posterior,i,0) - ElementM(posterior,i,1);
- sum=AddLogs_static(sum,tmp);
- if (tmp > max) max=tmp;
- }
-
- return exp(sum - max);
-}
-
-
-/*
- Let h(x) and f(x) be probability density functions and let c be an unknown
- constant. In applications, the following will usually be true.
- x - parameters
- y - data
- f(x) - posterior distribution = p(x|y)
- h(x) - proposal distribution
- c - marginal distribution = p(y)
- c*f(x) - likelihood*prior = p(y|x)*p(x)
-
- Assumes:
- proposal : N x 2 matrix with proposal[i][0] = ln(h(x(i))) and
- proposal[i][1] = ln(c*f(x(i))) where x(i) is sampled from h(x).
- posterior : M x 2 matrix with posterior[i][0] = ln(h(x(i))) and
- posterior[i][1] = ln(c*f(x(i))) where x(i) is sampled from f(x).
- L1 : cutoff value (likelihood(x)*prior(x) > L1)
- L2 : cutoff value for (proposal(x) < L2)
-
- Returns:
- Estimate of c or MINUS_INFINITY if no proposal draws satisfied the
- restriction given by the cutoff values of L1 and L2.
-
- Notes:
- Uses the fact that c = P(L1,L2)/I(L1,L2) where p(L1,L2) is the probability
- that x sampled from h(x) satisfies c*f(x) > exp(L1) and h(x) < exp(L2) and
- I(L1,L2) is the integral over x of
-
- 1{c*f(x)>exp(L1) and h(x)<exp(L2)}*h(x)/(c*f(x)) * f(x)
-
- P(L) can be computed from the proposal draws and I(L) can be computed from
- the posterior draws. The function 1{.} denotes the
-
-*/
-PRECISION ComputeMarginalDensity_WZ2(TMatrix proposal, TMatrix posterior, PRECISION L1, PRECISION L2, int *in_proposal, int *in_posterior)
-{
- PRECISION I=MINUS_INFINITY;
- int i;
-
- for (*in_proposal=0, i=RowM(proposal)-1; i >= 0; i--)
- if ((ElementM(proposal,i,1) >= L1) && (ElementM(proposal,i,0) <= L2))
- (*in_proposal)++;
-
- for (*in_posterior=0, i=RowM(posterior)-1; i >= 0; i--)
- if ((ElementM(posterior,i,1) >= L1) && (ElementM(posterior,i,0) <= L2))
- {
- (*in_posterior)++;
- I=AddLogs_static(I,ElementM(posterior,i,0) - ElementM(posterior,i,1));
- }
-
- if ((*in_posterior) > 0) I-=log((PRECISION)RowM(posterior));
-
- return ((*in_proposal) == 0) ? MINUS_INFINITY : log((PRECISION)(*in_proposal)/(PRECISION)RowM(proposal)) - I;
-}
-
-PRECISION ComputeMarginalDensity_WZ3(TMatrix proposal, TMatrix posterior, PRECISION L1, PRECISION L2, int *in)
-{
- PRECISION I=MINUS_INFINITY, tmp;
- int i;
-
- for (i=RowM(proposal)-1; i >= 0; i--)
- {
- tmp=ElementM(proposal,i,0) - ElementM(proposal,i,1);
- if ((L1 < tmp) && (tmp < L2)) (*in)++;
- }
-
- for (i=RowM(posterior)-1; i >= 0; i--)
- {
- tmp=ElementM(posterior,i,0) - ElementM(posterior,i,1);
- if ((L1 < tmp) && (tmp < L2))
- I=AddLogs_static(I,tmp);
- }
-
- if (I > MINUS_INFINITY) I-=log((PRECISION)RowM(posterior));
-
- return ((*in) == 0) ? MINUS_INFINITY : log((PRECISION)(*in)/(PRECISION)RowM(proposal)) - I;
-}
-
-/*******************************************************************************/
-/************************ Mueller's Method (alternate ) ************************/
-/*******************************************************************************/
-#define MAX_C 1E50
-#define TOL 1E-5
-PRECISION ComputeDifference(TMatrix proposal, TMatrix posterior, PRECISION c, int *in1, int *in2)
-{
- int i, n;
- PRECISION sum1=0.0, sum2=0.0, tmp;
- for (*in1=0, i=RowM(proposal)-1; i >= 0; i--)
- if (c < (tmp=ElementM(proposal,i,0)-ElementM(proposal,i,1)))
- {
- sum1+=1-exp(c-tmp);
- (*in1)++;
- }
- for (*in2=0, i=RowM(posterior)-1; i >= 0; i--)
- if (c > (tmp=ElementM(posterior,i,0)-ElementM(posterior,i,1)))
- {
- sum2+=1-exp(tmp-c);
- (*in2)++;
- }
- return sum1/(PRECISION)RowM(proposal) - sum2/(PRECISION)RowM(posterior);
-}
-PRECISION ComputeMarginalDensity_Mueller_Check(TMatrix proposal, TMatrix posterior,int *in1, int *in2)
-{
- PRECISION min_c, max_c, mid_c, diff;
- int i;
-
- if ((diff=ComputeDifference(proposal,posterior,mid_c=0.0,in1,in2)) < 0.0)
- {
-printf("%lf %le - %d %d\n",mid_c,diff,*in1,*in2); //**
- max_c=mid_c;
- for (min_c=-1.0; min_c > -MAX_C; max_c=min_c, min_c*=10)
- if ((diff=ComputeDifference(proposal,posterior,min_c,in1,in2)) > 0) break;
-else printf("%lf %lf %le - %d %d\n",min_c,max_c,diff,*in1,*in2); //**
- if (min_c <= -MAX_C) return min_c;
- }
- else
- {
-printf("%lf %le - %d %d\n",mid_c,diff,*in1,*in2); //**
- min_c=mid_c;
- for (max_c=1.0; max_c < MAX_C; min_c=max_c, max_c*=10)
- if ((diff=ComputeDifference(proposal,posterior,max_c,in1,in2)) < 0) break;
-else printf("%lf %lf %le - %d %d\n",min_c,max_c,diff,*in1,*in2); //**
- if (max_c >= MAX_C) return max_c;
- }
-printf("%lf %lf %le - %d %d\n",min_c,max_c,diff,*in1,*in2); //**
- diff=ComputeDifference(proposal,posterior,mid_c=(min_c + max_c)/2.0,in1,in2);
- for (i=0; i < 200; i++)
- {
- if (diff > 0)
- min_c=mid_c;
- else
- max_c=mid_c;
-printf("%lf %lf %le %d - %d %d\n",min_c,max_c,diff,i,*in1,*in2); //**
- if ((fabs(diff=ComputeDifference(proposal,posterior,mid_c=(min_c + max_c)/2.0,in1,in2)) < TOL) && (i > 20)) break;
- }
-printf("%lf %le - %d %d\n",mid_c,diff,*in1,*in2); //**
- return -mid_c;
-}
-#undef MAX_C
-#undef TOL
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/****************************** Mueller's Method *******************************/
-/*******************************************************************************/
-#define MAX_C 1E50
-//#define VERBOSE
-PRECISION ComputeLinear(TMatrix proposal, PRECISION log_c, int *intercept)
-{
- int i;
- PRECISION slope=0.0, tmp;
- for (*intercept=0, i=RowM(proposal)-1; i >= 0; i--)
- if (log_c < (tmp=ElementM(proposal,i,0) - ElementM(proposal,i,1)))
- {
- (*intercept)++;
- slope+=exp(log_c-tmp);
- }
- return slope;
-}
-PRECISION ComputeInverseLinear(TMatrix posterior, PRECISION log_c, int *intercept)
-{
- int i;
- PRECISION slope=0.0, tmp;
- for (*intercept=0, i=RowM(posterior)-1; i >= 0; i--)
- if (log_c > (tmp=ElementM(posterior,i,0)-ElementM(posterior,i,1)))
- {
- (*intercept)++;
- slope+=exp(tmp-log_c);
- }
- return slope;
-}
-PRECISION ComputeMarginalDensity_Mueller(TMatrix proposal, TMatrix posterior,int *in1, int *in2)
-{
- PRECISION log_c=0.0, slope1, slope2, N1=1.0/(PRECISION)RowM(proposal), N2=1.0/(PRECISION)RowM(posterior),
- intercept1, intercept2, max_log_c, min_log_c, diff, tmp;
- int min_in1, max_in1, min_in2, max_in2;
-
- slope1=ComputeLinear(proposal,log_c,in1);
- slope2=ComputeInverseLinear(posterior,log_c,in2);
- diff=N1*((PRECISION)(*in1) - slope1) - N2*((PRECISION)(*in2) - slope2);
-
- // Bracket the intersection
- if (diff < 0.0)
- {
- do
- if (log_c < -MAX_C)
- return log_c;
- else
- {
- max_in1=*in1;
- max_in2=*in2;
- max_log_c=log_c;
- log_c=10*(log_c-1);
- slope1=ComputeLinear(proposal,log_c,in1);
- slope2=ComputeInverseLinear(posterior,log_c,in2);
- diff=N1*((PRECISION)(*in1) - slope1) - N2*((PRECISION)(*in2) - slope2);
-#ifdef VERBOSE
-printf("%lf %lf %le - %d %d\n",log_c,max_log_c,diff,*in1,*in2);
-#endif
- }
- while (diff < 0.0);
- min_in1=*in1;
- min_in2=*in2;
- min_log_c=log_c;
- }
- else
- {
- do
- if (log_c > MAX_C)
- return log_c;
- else
- {
- min_in1=*in1;
- min_in2=*in2;
- min_log_c=log_c;
- log_c=10*(log_c+1);
- slope1=ComputeLinear(proposal,log_c,in1);
- slope2=ComputeInverseLinear(posterior,log_c,in2);
- diff=N1*((PRECISION)(*in1) - slope1) - N2*((PRECISION)(*in2) - slope2);
-#ifdef VERBOSE
-printf("%lf %lf %le - %d %d\n",min_log_c,log_c,diff,*in1,*in2);
-#endif
- }
- while (diff >= 0.0);
- max_in1=*in1;
- max_in2=*in2;
- max_log_c=log_c;
- }
-
- // At this point diff(min_log_c) >= 0 and diff(max_log_c) < 0.
- while ((min_in1 != max_in1) || (min_in2 != max_in2))
- {
- log_c=(min_log_c + max_log_c)/2.0;
- slope1=ComputeLinear(proposal,log_c,in1);
- slope2=ComputeInverseLinear(posterior,log_c,in2);
- diff=N1*((PRECISION)(*in1) - slope1) - N2*((PRECISION)(*in2) - slope2);
- if (diff > 0)
- {
- min_in1=*in1;
- min_in2=*in2;
- min_log_c=log_c;
- }
- else
- {
- max_in1=*in1;
- max_in2=*in2;
- max_log_c=log_c;
- }
-#ifdef VERBOSE
-printf("%lf %lf %le - %d %d\n",min_log_c,max_log_c,diff,*in1,*in2);
-#endif
- }
-
- slope1=N1*ComputeLinear(proposal,min_log_c,in1);
- intercept1=N1*(PRECISION)(*in1);
- slope2=N2*ComputeInverseLinear(posterior,min_log_c,in2);
- intercept2=N2*(PRECISION)(*in2);
-
- tmp=intercept1-intercept2;
- if (slope1 > 0)
- {
- tmp+=sqrt(tmp*tmp + 4*slope1*slope2);
- if (tmp >= 2.0*slope1)
- tmp=min_log_c + log(tmp) - log(2.0*slope1);
- else
- return -min_log_c;
- }
- else
- {
-#ifdef VERBOSE
-printf("Flat linear slope\n");
-#endif
- if (tmp > 0)
- if (slope2 > tmp)
- tmp=min_log_c + log(slope2) - log(tmp);
- else
- return -min_log_c;
- else
- return -max_log_c;
- }
- return (tmp > max_log_c) ? -max_log_c : -tmp;
-}
-
-void ComputeDiagnostics_Mueller(TMatrix proposal, TMatrix posterior, PRECISION log_c,
- PRECISION *log_slope1, PRECISION *ess1, PRECISION *log_slope2, PRECISION *ess2)
-{
- PRECISION slope, sum, max, tmp;
- int i;
-
- // proposal - piecewise linear
- sum=max=slope=0.0;
- for (i=RowM(proposal)-1; i >= 0; i--)
- if (log_c < (tmp=ElementM(proposal,i,0) - ElementM(proposal,i,1)))
- {
- tmp=exp(log_c-tmp);
- slope+=tmp;
- sum+=1.0-tmp;
- if (1.0-tmp > max) max=1.0-tmp;
- }
-
- *log_slope1=log(slope) - log_c - log(RowM(proposal));
- *ess1=(max > 0.0) ? sum/max : 0.0;
-
- // posterior - piecewise hyperbolic
- sum=max=slope=0.0;
- for (i=RowM(posterior)-1; i >= 0; i--)
- if (log_c > (tmp=ElementM(posterior,i,0)-ElementM(posterior,i,1)))
- {
- tmp=exp(tmp-log_c);
- slope-=tmp;
- sum+=1.0-tmp;
- if (1.0-tmp > max) max=1.0-tmp;
- }
-
- *log_slope2=log(slope) - log_c - log(RowM(posterior));
- *ess2=(max > 0.0) ? sum/max : 0.0;
-}
-#undef MAX_C
-#undef VERBOSE
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-TVector Sorted_Level_Cuts(TMatrix X, int n_cuts)
-{
- int step, start, i;
- PRECISION min, max, inc, tmp;
- TVector cuts=CreateVector(n_cuts), Y=ColumnVector((TVector)NULL,X,1);
-
- SortVectorAscending(Y,Y);
-
- step=RowM(X)/(n_cuts-1);
- start=(RowM(X) - (n_cuts-1)*step)/2;
-
- for (i=0; i < n_cuts; i++)
- ElementV(cuts,i)=ElementV(Y,start+i*step);
-
- FreeVector(Y);
- return cuts;
-}
-
-TVector Sorted_Center_Cuts(TMatrix X, int n_cuts)
-{
- int step, start, i;
- PRECISION min, max, inc, tmp;
- TVector cuts=CreateVector(n_cuts), Y=ColumnVector((TVector)NULL,X,1);
-
- step=RowM(X)/(n_cuts-1);
- start=(RowM(X) - (n_cuts-1)*step)/2;
-
- SortVectorAscending(Y,Y);
- for (i=0; i < n_cuts; i++)
- ElementV(cuts,i)=ElementV(Y,start+i*step);
-
- FreeVector(Y);
- return cuts;
-}
-
-
-TVector Linear_Level_Cuts(TMatrix X, int n_cuts)
-{
- int k;
- PRECISION min, max, inc, tmp;
- TVector cuts=CreateVector(n_cuts);
-
- max=min=ElementM(X,0,1);
- for (k=RowM(X)-1; k >= 0; k--)
- {
- tmp=ElementM(X,k,1);
- if (tmp < min)
- min=tmp;
- else
- if (tmp > max)
- max=tmp;
- }
- min-=0.1;
- max+=0.1;
-
- ElementV(cuts,0)=min;
- inc=(max - min)/(n_cuts-1);
-
- for (k=1; k < n_cuts; k++)
- ElementV(cuts,k)=ElementV(cuts,k-1)+inc;
-
- return cuts;
-}
-
-TVector Exponential_Level_Cuts(TMatrix X, int n_cuts)
-{
- int k;
- PRECISION min, max, inc, tmp;
- TVector cuts=CreateVector(n_cuts);
-
- max=min=ElementM(X,0,1);
- for (k=RowM(X)-1; k >= 0; k--)
- {
- tmp=ElementM(X,k,1);
- if (tmp < min)
- min=tmp;
- else
- if (tmp > max)
- max=tmp;
- }
-
- ElementV(cuts,0)=min;
- inc=max+log(1-exp(min-max))-log(n_cuts-1);
-
- for (k=1; k < n_cuts; k++)
- ElementV(cuts,k)=AddLogs_static(ElementV(cuts,k-1),inc);
-
- return cuts;
-}
-
-/*
- Assumes:
- center : center point for spherical distribution
- scale : linear transformation for spherical distribution
- model : valid point to TStateModel structure
- alpha : array of parameters of independent draws from the Dirichlet
- distribution
-
- Results:
- Draws theta from affine transformation of spherical distribution and Q from
- independent Dirichlet distribution. Computes the scaled log posterior
- (likelihood times prior), with the states integerated out. Returns the
- vector q. q[i] is the proportion of the draws that are greater than or
- equal to level_cuts[i].
-*/
-TVector Create_q(int ndraws, TVector center, TMatrix scale, TStateModel* model, TVector* alpha, TVector level_cuts)
-{
- TVector free_parameters, q;
- PRECISION density;
- int i, j, k, begin_time, end_time;
-
- // VAR specific
- PRECISION *zeta;
- int n_zeta;
-
- InitializeVector(q=CreateVector(DimV(level_cuts)),0.0);
- free_parameters=CreateVector(NumberFreeParametersTheta(model));
-
- // VAR specific
- zeta=pElementV(free_parameters) + ZetaIndex((T_VAR_Parameters*)(model->theta));
- n_zeta=ZetaLength((T_VAR_Parameters*)(model->theta));
-
- // timings
- begin_time=time((time_t*)NULL);
-
- for (i=ndraws-1; i >= 0; i--)
- {
- // draw uniform on sphere
- DrawSpherical(free_parameters);
-
- // scale and center to get draw for theta
- ProductMV(free_parameters,scale,free_parameters);
- AddVV(free_parameters,free_parameters,center);
-
- // draw Q from Dirichet
- DrawIndependentDirichletVector(model->sv->ba,alpha);
-
- // VAR specific - perform checks on theta parameters to ensure they are valid
- for (j=n_zeta-1; j >= 0; j--)
- if (zeta[j] <= 0)
- {
- // non-positive values of zeta - log posterior is minus infinity
- break;
- }
-
- if (j < 0)
- {
- // force free parameters into model
- ConvertFreeParametersToTheta(model,pElementV(free_parameters));
- Update_Q_from_B_SV(model->sv);
- if (!(model->sv->valid_transition_matrix)) ValidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
-
- // Normalize
- if (!IsNormalized_VAR(model->theta))
- {
- // parameters changed - log posterior is minus infinity
- break;
- }
- else
- {
- // compute log posterior
- density=LogPosterior_StatesIntegratedOut(model);
- for (k=DimV(level_cuts)-1; k >= 0; k--)
- if (density >= ElementV(level_cuts,k))
- ElementV(q,k)+=1.0;
- }
- }
- }
-
- for (k=DimV(level_cuts)-1; k >= 0; k--)
- ElementV(q,k)/=(PRECISION)ndraws;
-
- // timings
- end_time=time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
-
- FreeVector(free_parameters);
-
- return q;
-}
-
-/*
- Assumes:
- center : center point for spherical distribution
- scale : linear transformation for spherical distribution
- model : valid pointer to TStateModel structure
- alpha : array of parameters of independent draws from the Dirichlet
- distribution
-
- Results:
- Draws theta from affine transformation of spherical distribution and Q from
- independent Dirichlet distribution. Computes the log density, properly
- scaled, of the proposal distribution and stores this in the first column of
- proposal. Computes the scaled log posterior (likelihood time prior), with
- the states integerated out, and stores this in the second column of
- proposal.
-*/
-TMatrix CreateProposal(int ndraws, TVector center, TMatrix scale, TStateModel* model, TVector* alpha)
-{
- TMatrix proposal;
- TVector free_parameters;
- PRECISION r, Jacobian;
- int i, j, begin_time, end_time;
-
- // VAR specific
- PRECISION *zeta;
- int n_zeta;
-
- proposal=CreateMatrix(ndraws,2);
- free_parameters=CreateVector(NumberFreeParametersTheta(model));
- Jacobian=-LogAbsDeterminant_LU(scale);
-
- // VAR specific
- zeta=pElementV(free_parameters) + ZetaIndex((T_VAR_Parameters*)(model->theta));
- n_zeta=ZetaLength((T_VAR_Parameters*)(model->theta));
-
- // timings
- begin_time=time((time_t*)NULL);
-
- for (i=ndraws-1; i >= 0; i--)
- {
- // draw uniform on sphere
- r=DrawSpherical(free_parameters);
-
- // scale and center to get draw for theta
- ProductMV(free_parameters,scale,free_parameters);
- AddVV(free_parameters,free_parameters,center);
-
- // draw Q from Dirichet
- DrawIndependentDirichletVector(model->sv->ba,alpha);
-
- // compute log proposal density
- ElementM(proposal,i,0)=LogSphericalDensity(r) + Jacobian + LogIndependentDirichlet_pdf(model->sv->ba,alpha);
-
- // VAR specific - perform checks on theta parameters to ensure they are valid
- for (j=n_zeta-1; j >= 0; j--)
- if (zeta[j] <= 0)
- {
- ElementM(proposal,i,1)=MINUS_INFINITY;
- break;
- }
-
- if (j < 0)
- {
- // force free parameters into model
- ConvertFreeParametersToTheta(model,pElementV(free_parameters));
- Update_Q_from_B_SV(model->sv);
- if (!(model->sv->valid_transition_matrix)) ValidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
-
- // compute log posterior
- ElementM(proposal,i,1)=LogPosterior_StatesIntegratedOut(model);
- }
- }
-
- // timings
- end_time=time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
-
- FreeVector(free_parameters);
-
- return proposal;
-}
-
-/*
- Assumes:
- center : center point for spherical distribution
- scale : linear transformation for spherical distribution
- model : valid point to TStateModel structure
- alpha : array of parameters of independent draws from the Dirichlet
- distribution
-
- Results:
- Draws theta from affine transformation of spherical distribution and Q from
- independent Dirichlet distribution. Computes the log density, properly
- scaled, of the proposal distribution and stores this in the first column of
- proposal. Computes the scaled log posterior (likelihood time prior), with
- the states integerated out, and stores this in the second column of
- proposal.
-*/
-TMatrix CreateProposal_Radius(int ndraws, TVector center, TMatrix scale, TStateModel* model, TVector* alpha)
-{
- TMatrix proposal;
- TVector free_parameters;
- PRECISION r, Jacobian;
- int i, j, begin_time, end_time;
-
- // VAR specific
- PRECISION *zeta;
- int n_zeta;
-
- proposal=CreateMatrix(ndraws,2);
- free_parameters=CreateVector(NumberFreeParametersTheta(model));
- Jacobian=-LogAbsDeterminant_LU(scale);
-
- // VAR specific
- zeta=pElementV(free_parameters) + ZetaIndex((T_VAR_Parameters*)(model->theta));
- n_zeta=ZetaLength((T_VAR_Parameters*)(model->theta));
-
- // timings
- begin_time=time((time_t*)NULL);
-
- for (i=ndraws-1; i >= 0; i--)
- {
- // draw uniform on sphere
- r=DrawSpherical(free_parameters);
-
- // scale and center to get draw for theta
- ProductMV(free_parameters,scale,free_parameters);
- AddVV(free_parameters,free_parameters,center);
-
- // draw Q from Dirichet
- DrawIndependentDirichletVector(model->sv->ba,alpha);
-
- // save radius
- ElementM(proposal,i,0)=r;
-
- // VAR specific - perform checks on theta parameters to ensure they are valid
- for (j=n_zeta-1; j >= 0; j--)
- if (zeta[j] <= 0)
- {
- ElementM(proposal,i,1)=MINUS_INFINITY;
- continue;
- }
-
- // force free parameters into model
- ConvertFreeParametersToTheta(model,pElementV(free_parameters));
- Update_Q_from_B_SV(model->sv);
- if (!(model->sv->valid_transition_matrix)) ValidateTransitionMatrices_SV(model->sv);
- TransitionMatricesChanged(model);
-
- // compute log posterior
- ElementM(proposal,i,1)=LogPosterior_StatesIntegratedOut(model);
- }
-
- // timings
- end_time=time((time_t*)NULL);
- fprintf(stdout,"Elapsed Time: %d seconds\n",end_time - begin_time);
-
- FreeVector(free_parameters);
-
- return proposal;
-}
-
-/*
- Assumes:
- X is a m x k matrix with k > 2+idx_alpha
- Column 1 = log posterior density of (theta,Q) (not properly scaled).
- Column 2 = (theta - center)' * Inverse(scale * scale') * (theta - center).
- Column 2+i = log Dirichlet density of Q.
-
- Returns:
- m x 2 matrix. The first column is the log of the proposal density of the
- posterior draw and the second column is the log of the posterior density.
-
- Notes:
- The parameters are theta and Q. The proposal density is independent across
- these with a Dirichlet distribution on Q and a spherical density on theta.
- The scale for spherical distribution is (rescale_factor * base_scale).
-*/
-TMatrix CreatePosterior(TMatrix X, PRECISION rescale_factor, TMatrix base_scale, int idx_alpha, int dim)
-{
- int i;
- PRECISION factor=1.0/rescale_factor, Jacobian=-LogAbsDeterminant_LU(base_scale) - dim*log(rescale_factor);
- TMatrix Y=CreateMatrix(RowM(X),3);
-
- for (i=RowM(X)-1; i >= 0; i--)
- {
- ElementM(Y,i,0)=LogSphericalDensity(factor*sqrt(ElementM(X,i,1))) + Jacobian + ElementM(X,i,2+idx_alpha);
- ElementM(Y,i,1)=ElementM(X,i,0);
- ElementM(Y,i,2)=ElementM(X,i,5);
- }
-
- return Y;
-}
-
-void ComputeMarginal(int ndraws_proposal, TMatrix X, TStateModel *model, T_MHM *mhm, int idx_alpha, PRECISION rescale_factor,
- char *tag, char *proposal_tag)
-{
- TMatrix proposal, posterior, base_scale, scale;
- TVector *alpha=(TVector*)NULL, level_cuts;
- PRECISION diff, marginal_density, ess, slope1, ess1, slope2, ess2;
- int i, in1, in2;
- char filename[256];
- FILE *f_out;
-
- // compute base scale and scale for proposal
- base_scale=CholeskyUT((TMatrix)NULL,mhm->variance);
- Transpose(base_scale,base_scale);
- scale=ProductSM((TMatrix)NULL,rescale_factor,base_scale);
-
- // allocate alpha
- alpha=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- alpha[i]=CreateVector(DimV(mhm->BaseAlpha[i]));
-
- // Dirichlet index
- idx_alpha=1;
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- ProductVS(alpha[i],mhm->BaseAlpha[i],ElementV(mhm->alpha_scales,idx_alpha));
-
- // Create posterior matrix
- printf("Creating posterior (%d draws)\n",RowM(X));
- posterior=CreatePosterior(X,rescale_factor,base_scale,idx_alpha,NumberFreeParametersTheta(model));
-
- // Create proposal matrix
- printf("Creating proposal (%d draws)\n",ndraws_proposal);
- proposal=CreateProposal(ndraws_proposal,mhm->center,scale,model,alpha);
-
- // Create output file
- sprintf(filename,"%s_md_%s.dat",proposal_tag,tag);
- f_out=dw_AppendTextFile(filename);
-
- // Compute marginal density using standard technique
- marginal_density=ComputeMarginalDensity_Standard(posterior);
- fprintf(f_out,"Standard MHM method: %0.14lg\n",marginal_density);
-
- // Compute marginal density using WZ1
- level_cuts=Sorted_Level_Cuts(posterior,10);
- fprintf(f_out,"WZ method - no center cut\nmarginal density,level,number proposal draws,number posterior draws,effective sample size\n");
- for (i=0; i < DimV(level_cuts); i++)
- {
- marginal_density=ComputeMarginalDensity_WZ1(proposal,posterior,ElementV(level_cuts,i),&in1,&in2);
- ess=ComputeEffectiveSampleSize_WZ1(posterior,ElementV(level_cuts,i));
-
- fprintf(f_out,"%0.14lg,%lg,%d,%d,%lg\n",marginal_density,ElementV(level_cuts,i),in1,in2,ess);
- }
- FreeVector(level_cuts);
-
- // Compute marginal density Mueller
- fprintf(f_out,"\nMueller method\nmarginal density,difference,# proposal draws,proposal log slope,proposal ess,# posterior draws,posterior log slope,posterior ess\n");
- marginal_density=ComputeMarginalDensity_Mueller(proposal,posterior,&in1,&in2);
- ComputeDiagnostics_Mueller(proposal,posterior,-marginal_density,&slope1,&ess1,&slope2,&ess2);
- diff=ComputeDifference(proposal,posterior,-marginal_density,&in1,&in2);
- fprintf(f_out,"%0.14lg,%lg,%d,%lg,%lg,%d,%lg,%lg\n\n",marginal_density,diff,in1,slope1,ess1,in2,slope2,ess2);
-
- fclose(f_out);
-
- sprintf(filename,"%s_md_proposal_%s.dat",proposal_tag,tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,proposal,"%le,");
- fclose(f_out);
-
- sprintf(filename,"%s_md_posterior_%s.dat",proposal_tag,tag);
- f_out=dw_CreateTextFile(filename);
- //dw_PrintMatrix(f_out,posterior,"%le,");
- fclose(f_out);
-
- FreeMatrix(posterior);
- FreeMatrix(proposal);
-
- dw_FreeArray(alpha);
- FreeMatrix(base_scale);
- FreeMatrix(scale);
-}
-
-
-/*******************************************************************************/
-PRECISION SetupSphericalFromPosterior_Table(TMatrix X, int n)
-{
- TVector table, Y;
- PRECISION cut_point=0.01, p, inc;
- int n_table=100, i, j, B, N;
-
- Y=ColumnVector((TVector)NULL,X,1);
- SortVectorAscending(Y,Y);
-
- table=CreateVector(n_table+1);
-
- B=(int)floor(cut_point*(PRECISION)DimV(Y));
- N=DimV(Y) - B;
-
- ElementV(table,0)=0.0;
- inc=(PRECISION)N/(PRECISION)n_table;
- for (i=1; i <= n_table; i++)
- {
- j=(int)floor(inc*(PRECISION)i);
- p=(inc*(PRECISION)i - (PRECISION)j)/inc;
- j+=B;
- ElementV(table,i)=(j < DimV(Y) - 1) ? (1 - p)*sqrt(ElementV(Y,j)) + p*sqrt(ElementV(Y,j+1)) : sqrt(ElementV(Y,DimV(Y)-1));
- }
-
- FreeVector(Y);
-
- SetupSpherical_Table(n,pElementV(table),n_table);
-
- FreeVector(table);
-
- return 1.0;
-}
-
-void ComputeMarginal_Table(int ndraws_proposal, TMatrix X, TStateModel *model, T_MHM *mhm, char *tag)
-{
- int idx_alpha=1;
- char filename[256], *proposal_tag="table";
- FILE *f_out;
-
- SetupSphericalFromPosterior_Table(X,NumberFreeParametersTheta(model));
-
- // Create output file amd write headers
- sprintf(filename,"%s_md_%s.dat",proposal_tag,tag);
- f_out=dw_CreateTextFile(filename);
-
- fprintf(f_out,"tag: %s\n",tag);
- fprintf(f_out,"Table proposal\n");
-
- fprintf(f_out,"number draws posterior (kept): %d\n",RowM(X));
- fprintf(f_out,"thinning factor: %d\n",mhm->n_thin);
- fprintf(f_out,"total posterior draws: %d\n",RowM(X) * mhm->n_thin);
- fprintf(f_out,"number draws proposal: %d\n",ndraws_proposal);
-
- fclose(f_out);
-
- ComputeMarginal(ndraws_proposal,X,model,mhm,idx_alpha,1.0,tag,proposal_tag);
-}
-
-void PlotCumulative_Table(TMatrix X, int n, char *tag)
-{
- PRECISION cut_point=0.01, inc, max;
- int bins=1000, n_table=100, i, j;
- char filename[256];
- FILE *f_out;
- TVector cumulative;
-
- SetupSphericalFromPosterior_Table(X,n);
- max=sqrt(ElementM(X,RowM(X)-1,1));
- cumulative=SphericalCumulativeDensity(max,bins,20);
- sprintf(filename,"cumulative_table_%s.csv",tag);
- f_out=dw_CreateTextFile(filename);
- fprintf(f_out,"tag: %s\n",tag);
- fprintf(f_out,"number table entries: %d\n",n_table);
- fprintf(f_out,"number draws posterior: %d\n",RowM(X));
- fprintf(f_out,"cumulative densities\n");
- inc=max/(PRECISION)bins;
- for (i=j=0; i < bins; i++)
- {
- while ((j < RowM(X)) && (sqrt(ElementM(X,j,1)) <= (i+1)*inc)) j++;
- fprintf(f_out,"%lf,%lf,%lf\n",(PRECISION)(i+1)*inc,(PRECISION)j/(PRECISION)RowM(X),ElementV(cumulative,i));
- }
- fclose(f_out);
- FreeVector(cumulative);
-}
-/*******************************************************************************/
-
-/*******************************************************************************/
-PRECISION SetupSphericalFromPosterior_TruncatedPower(TMatrix X, int n)
-{
- TVector Y;
- PRECISION cut_point=0.01, min_point=0.1, max_point=0.9, a, b, k, truncate, rescale_factor;
- int i;
-
- Y=ColumnVector((TVector)NULL,X,1);
- SortVectorAscending(Y,Y);
-
- i=floor(min_point*(PRECISION)DimV(Y));
- a=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
- i=floor(max_point*(PRECISION)DimV(Y));
- b=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
-
- k=log(min_point/max_point)/log(a/b);
- rescale_factor=b/pow(max_point,1.0/k);
- i=floor(cut_point*(PRECISION)DimV(Y));
- truncate=((i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i)))/rescale_factor;
-
- FreeVector(Y);
-
- SetupSpherical_TruncatedPower(n,k,truncate);
-
- return rescale_factor;
-}
-void ComputeMarginal_TruncatedPowerProposal(int ndraws_proposal, TMatrix X, TStateModel *model, T_MHM *mhm, char *tag)
-{
- TMatrix proposal, posterior, base_scale, scale;
- TVector Y, *alpha=(TVector*)NULL, level_cuts;
- PRECISION rescale_factor, p, s=1.0/(PRECISION)RowM(X), cut_point=0.01, min_point=0.1, max_point=0.9, a, b, x, y, inc, k, truncate,
- diff, marginal_density, ess, slope1, ess1, slope2, ess2;
- int idx_alpha=1, i, j, in1, in2, bins=1000, ia, ib;
- char filename[256];
- FILE *f_out;
-
- Y=ColumnVector((TVector)NULL,X,1);
- SortVectorAscending(Y,Y);
-
- i=floor(min_point*(PRECISION)DimV(Y));
- a=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
- i=floor(max_point*(PRECISION)DimV(Y));
- b=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
-
- k=log(min_point/max_point)/log(a/b);
- rescale_factor=b/pow(max_point,1.0/k);
- i=floor(cut_point*(PRECISION)DimV(Y));
- truncate=((i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i)))/rescale_factor;
-
- FreeVector(Y);
- SetupSpherical_TruncatedPower(NumberFreeParametersTheta(model),k,truncate);
-
-/* // Plot cummulative densities */
-/* f_out=dw_CreateTextFile("tmp.csv"); */
-/* fprintf(f_out,"tag: %s\n",tag); */
-/* fprintf(f_out,"scale factor: %lf\n",rescale_factor); */
-/* fprintf(f_out,"power: %lf\n",k); */
-/* fprintf(f_out,"truncation: %lf\n",truncate); */
-/* fprintf(f_out,"number draws posterior: %d\n",RowM(Y)); */
-/* inc=1.0/(PRECISION)bins; */
-/* p=pow(truncate,k); */
-/* for (i=j=0; i < bins; i++) */
-/* { */
-/* while ((j < RowM(Y)) && (sqrt(ElementM(Y,j,1)) <= (i+1)*inc*rescale_factor)) j++; */
-/* x=((PRECISION)i+0.5)*inc; */
-/* y=(x < truncate) ? 0.0 : (pow(x,k) - p)/(1.0 - p); */
-/* fprintf(f_out,"%lf,%lf,%lf\n",x,(PRECISION)j/(PRECISION)RowM(Y),y); */
-/* } */
-/* fclose(f_out); */
-/* return; */
-
- // compute base scale and scale
- base_scale=CholeskyUT((TMatrix)NULL,mhm->variance);
- Transpose(base_scale,base_scale);
-
- // allocate alpha
- alpha=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- alpha[i]=CreateVector(DimV(mhm->BaseAlpha[i]));
-
- // Dirichlet index
- idx_alpha=1;
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- ProductVS(alpha[i],mhm->BaseAlpha[i],ElementV(mhm->alpha_scales,idx_alpha));
-
- // Create posterior matrix
- printf("Creating posterior (%d draws)\n",RowM(X));
- posterior=CreatePosterior(X,rescale_factor,base_scale,idx_alpha,NumberFreeParametersTheta(model));
-
- // Create proposal matrix
- printf("Creating proposal (%d draws)\n",ndraws_proposal);
- scale=ProductSM((TMatrix)NULL,rescale_factor,base_scale);
- proposal=CreateProposal(ndraws_proposal,mhm->center,scale,model,alpha);
-
- // Create output file
- sprintf(filename,"truncatedpower_md_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
-
- fprintf(f_out,"tag: %s\n",tag);
- fprintf(f_out,"Truncated power proposal\n");
- fprintf(f_out,"scale factor: %lf\n",rescale_factor);
- fprintf(f_out,"power: %lf\n",k);
- fprintf(f_out,"truncation: %lf\n",truncate);
-
- fprintf(f_out,"number draws posterior (kept): %d\n",RowM(X));
- fprintf(f_out,"thinning factor: %d\n",mhm->n_thin);
- fprintf(f_out,"total posterior draws: %d\n",RowM(X) * mhm->n_thin);
- fprintf(f_out,"number draws proposal: %d\n",ndraws_proposal);
-
- // Compute marginal density using standard technique
- marginal_density=ComputeMarginalDensity_Standard(posterior);
- fprintf(f_out,"Standard MHM method: %0.14lg\n",marginal_density);
-
- // Compute marginal density using WZ1
- level_cuts=Sorted_Level_Cuts(posterior,10);
- fprintf(f_out,"WZ method - no center cut\nmarginal density,level,number proposal draws,number posterior draws,effective sample size\n");
- for (i=0; i < DimV(level_cuts); i++)
- {
- marginal_density=ComputeMarginalDensity_WZ1(proposal,posterior,ElementV(level_cuts,i),&in1,&in2);
- ess=ComputeEffectiveSampleSize_WZ1(posterior,ElementV(level_cuts,i));
-
- fprintf(f_out,"%0.14lg,%lg,%d,%d,%lg\n",marginal_density,ElementV(level_cuts,i),in1,in2,ess);
- }
- FreeVector(level_cuts);
-
- // Compute marginal density Mueller
- fprintf(f_out,"\nMueller method\nmarginal density,difference,# proposal draws,proposal log slope,proposal ess,# posterior draws,posterior log slope,posterior ess\n");
- marginal_density=ComputeMarginalDensity_Mueller(proposal,posterior,&in1,&in2);
- ComputeDiagnostics_Mueller(proposal,posterior,-marginal_density,&slope1,&ess1,&slope2,&ess2);
- diff=ComputeDifference(proposal,posterior,-marginal_density,&in1,&in2);
- fprintf(f_out,"%0.14lg,%lg,%d,%lg,%lg,%d,%lg,%lg\n\n",marginal_density,diff,in1,slope1,ess1,in2,slope2,ess2);
-
- fclose(f_out);
-
- sprintf(filename,"truncatedpower_md_proposal_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,proposal,"%le,");
- fclose(f_out);
-
- sprintf(filename,"truncatedpower_md_posterior_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,posterior,"%le,");
- fclose(f_out);
-
- FreeMatrix(posterior);
- FreeMatrix(proposal);
-
- dw_FreeArray(alpha);
- FreeMatrix(base_scale);
- FreeMatrix(scale);
-}
-
-PRECISION SetupSphericalFromPosterior_Power(TMatrix X, int n)
-{
- int i;
- PRECISION a, b, k, rescale_factor, min_point=0.1, max_point=0.9;
- TVector Y=ColumnVector((TVector)NULL,X,1);
-
- SortVectorAscending(Y,Y);
-
- i=floor(min_point*(PRECISION)DimV(Y));
- a=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
- i=floor(max_point*(PRECISION)DimV(Y));
- b=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
-
- k=log(min_point/max_point)/log(a/b);
- rescale_factor=b/pow(max_point,1.0/k);
-
- FreeVector(Y);
-
- SetupSpherical_Power(n,k);
-
- return rescale_factor;
-}
-void ComputeMarginal_PowerProposal(int ndraws_proposal, TMatrix X, TStateModel *model, T_MHM *mhm, char *tag)
-{
- TMatrix proposal, posterior, base_scale, scale;
- TVector Y, *alpha=(TVector*)NULL, level_cuts;
- PRECISION rescale_factor, p, s=1.0/RowM(X), min_point=0.1, max_point=0.9, a, b, k,
- diff, marginal_density, ess, slope1, ess1, slope2, ess2, inc;
- int idx_alpha=1, i, j, in1, in2, bins=1000;
- char filename[256];
- FILE *f_out;
-
- Y=ColumnVector((TVector)NULL,X,1);
- SortVectorAscending(Y,Y);
-
- i=floor(min_point*(PRECISION)DimV(Y));
- a=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
- i=floor(max_point*(PRECISION)DimV(Y));
- b=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i));
-
- k=log(min_point/max_point)/log(a/b);
- rescale_factor=b/pow(max_point,1.0/k);
-
- FreeVector(Y);
-
- SetupSpherical_Power(NumberFreeParametersTheta(model),k);
-
-/* // Plot cummulative densities */
-/* f_out=dw_CreateTextFile("tmp.csv"); */
-/* fprintf(f_out,"tag: %s\n",tag); */
-/* fprintf(f_out,"scale factor: %lf\n",rescale_factor); */
-/* fprintf(f_out,"power: %lf\n",k); */
-/* fprintf(f_out,"number draws posterior: %d\n",RowM(Y)); */
-/* inc=1.0/(PRECISION)bins; */
-/* for (i=j=0; i < bins; i++) */
-/* { */
-/* while ((j < RowM(Y)) && (sqrt(ElementM(Y,j,1)) <= (i+1)*inc*rescale_factor)) j++; */
-/* fprintf(f_out,"%lf,%lf,%lf\n",((PRECISION)i+0.5)*inc,(PRECISION)j/(PRECISION)RowM(Y),pow(((PRECISION)i+0.5)*inc,k)); */
-/* } */
-/* fclose(f_out); */
-/* return; */
-
- // compute base scale and scale
- base_scale=CholeskyUT((TMatrix)NULL,mhm->variance);
- Transpose(base_scale,base_scale);
-
- // allocate alpha
- alpha=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- alpha[i]=CreateVector(DimV(mhm->BaseAlpha[i]));
-
- // Dirichlet index
- idx_alpha=1;
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- ProductVS(alpha[i],mhm->BaseAlpha[i],ElementV(mhm->alpha_scales,idx_alpha));
-
- // Create posterior matrix
- printf("Creating posterior (%d draws)\n",RowM(X));
- posterior=CreatePosterior(X,rescale_factor,base_scale,idx_alpha,NumberFreeParametersTheta(model));
-
- // Create proposal matrix
- printf("Creating proposal (%d draws)\n",ndraws_proposal);
- scale=ProductSM((TMatrix)NULL,rescale_factor,base_scale);
- proposal=CreateProposal(ndraws_proposal,mhm->center,scale,model,alpha);
-
- // Create output file
- sprintf(filename,"power_md_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
-
- fprintf(f_out,"tag: %s\n",tag);
- fprintf(f_out,"Power proposal\n");
- fprintf(f_out,"scale factor: %lf\n",rescale_factor);
- fprintf(f_out,"power: %lf\n",k);
-
- fprintf(f_out,"number draws posterior (kept): %d\n",RowM(X));
- fprintf(f_out,"thinning factor: %d\n",mhm->n_thin);
- fprintf(f_out,"total posterior draws: %d\n",RowM(X) * mhm->n_thin);
- fprintf(f_out,"number draws proposal: %d\n",ndraws_proposal);
-
- // Compute marginal density using standard technique
- marginal_density=ComputeMarginalDensity_Standard(posterior);
- fprintf(f_out,"Standard MHM method: %0.14lg\n",marginal_density);
-
- // Compute marginal density using WZ1
- level_cuts=Sorted_Level_Cuts(posterior,10);
- fprintf(f_out,"WZ method - no center cut\nmarginal density,level,number proposal draws,number posterior draws,effective sample size\n");
- for (i=0; i < DimV(level_cuts); i++)
- {
- marginal_density=ComputeMarginalDensity_WZ1(proposal,posterior,ElementV(level_cuts,i),&in1,&in2);
- ess=ComputeEffectiveSampleSize_WZ1(posterior,ElementV(level_cuts,i));
-
- fprintf(f_out,"%0.14lg,%lg,%d,%d,%lg\n",marginal_density,ElementV(level_cuts,i),in1,in2,ess);
- }
- FreeVector(level_cuts);
-
- // Compute marginal density Mueller
- fprintf(f_out,"\nMueller method\nmarginal density,difference,# proposal draws,proposal log slope,proposal ess,# posterior draws,posterior log slope,posterior ess\n");
- marginal_density=ComputeMarginalDensity_Mueller(proposal,posterior,&in1,&in2);
- ComputeDiagnostics_Mueller(proposal,posterior,-marginal_density,&slope1,&ess1,&slope2,&ess2);
- diff=ComputeDifference(proposal,posterior,-marginal_density,&in1,&in2);
- fprintf(f_out,"%0.14lg,%lg,%d,%lg,%lg,%d,%lg,%lg\n\n",marginal_density,diff,in1,slope1,ess1,in2,slope2,ess2);
-
- fclose(f_out);
-
- sprintf(filename,"power_md_proposal_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,proposal,"%le,");
- fclose(f_out);
-
- sprintf(filename,"power_md_posterior_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,posterior,"%le,");
- fclose(f_out);
-
- FreeMatrix(posterior);
- FreeMatrix(proposal);
-
- dw_FreeArray(alpha);
- FreeMatrix(base_scale);
- FreeMatrix(scale);
-}
-
-void ComputeMarginal_GaussianProposal(int ndraws_proposal, TMatrix X, TStateModel *model, T_MHM *mhm, char *tag, PRECISION variance)
-{
- TMatrix proposal, posterior, base_scale, scale;
- TVector *alpha=(TVector*)NULL, level_cuts;
- PRECISION rescale_factor, diff, marginal_density, ess, slope1, ess1, slope2, ess2;
- int idx_alpha=1, i, in1, in2;
- char filename[256];
- FILE *f_out;
-
- // set spherical type
- SetupSpherical_Gaussian(NumberFreeParametersTheta(model));
-
- // compute base scale
- base_scale=CholeskyUT((TMatrix)NULL,mhm->variance);
- Transpose(base_scale,base_scale);
-
- // allocate alpha
- alpha=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- alpha[i]=CreateVector(DimV(mhm->BaseAlpha[i]));
-
- // Dirichlet index
- idx_alpha=1;
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- ProductVS(alpha[i],mhm->BaseAlpha[i],ElementV(mhm->alpha_scales,idx_alpha));
-
- // rescale factor
- rescale_factor=sqrt(variance);
-
- // Create posterior matrix
- printf("Creating posterior (%d draws)\n",RowM(X));
- posterior=CreatePosterior(X,rescale_factor,base_scale,idx_alpha,NumberFreeParametersTheta(model));
-
- // Create proposal matrix
- printf("Creating proposal (%d draws)\n",ndraws_proposal);
- scale=ProductSM((TMatrix)NULL,rescale_factor,base_scale);
- proposal=CreateProposal(ndraws_proposal,mhm->center,scale,model,alpha);
-
- // Create output file
- sprintf(filename,"gaussian_md_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
-
- fprintf(f_out,"tag: %s\n",tag);
- fprintf(f_out,"Gaussian proposal\n");
- fprintf(f_out,"variance: %lf\n",variance);
-
- fprintf(f_out,"number draws posterior (kept): %d\n",RowM(X));
- fprintf(f_out,"thinning factor: %d\n",mhm->n_thin);
- fprintf(f_out,"total posterior draws: %d\n",RowM(X) * mhm->n_thin);
- fprintf(f_out,"number draws proposal: %d\n",ndraws_proposal);
-
- // Compute marginal density using standard technique
- marginal_density=ComputeMarginalDensity_Standard(posterior);
- fprintf(f_out,"Standard MHM method: %0.14lg\n",marginal_density);
-
- // Compute marginal density using WZ1
- level_cuts=Sorted_Level_Cuts(posterior,10);
- fprintf(f_out,"WZ method - no center cut\nmarginal density,level,number proposal draws,number posterior draws,effective sample size\n");
- for (i=0; i < DimV(level_cuts); i++)
- {
- marginal_density=ComputeMarginalDensity_WZ1(proposal,posterior,ElementV(level_cuts,i),&in1,&in2);
- ess=ComputeEffectiveSampleSize_WZ1(posterior,ElementV(level_cuts,i));
-
- fprintf(f_out,"%0.14lg,%lg,%d,%d,%lg\n",marginal_density,ElementV(level_cuts,i),in1,in2,ess);
- }
- FreeVector(level_cuts);
-
- // Compute marginal density Mueller
- fprintf(f_out,"\nMueller method\nmarginal density,difference,# proposal draws,proposal log slope,proposal ess,# posterior draws,posterior log slope,posterior ess\n");
- marginal_density=ComputeMarginalDensity_Mueller(proposal,posterior,&in1,&in2);
- ComputeDiagnostics_Mueller(proposal,posterior,-marginal_density,&slope1,&ess1,&slope2,&ess2);
- diff=ComputeDifference(proposal,posterior,-marginal_density,&in1,&in2);
- fprintf(f_out,"%0.14lg,%lg,%d,%lg,%lg,%d,%lg,%lg\n\n",marginal_density,diff,in1,slope1,ess1,in2,slope2,ess2);
-
- fclose(f_out);
-
- sprintf(filename,"gaussian_md_proposal_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,proposal,"%le,");
- fclose(f_out);
-
- sprintf(filename,"gaussian_md_posterior_%s.dat",tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,posterior,"%le,");
- fclose(f_out);
-
- FreeMatrix(posterior);
- FreeMatrix(proposal);
-
- dw_FreeArray(alpha);
- FreeMatrix(base_scale);
- FreeMatrix(scale);
-}
-
-void ComputeMarginal_TruncatedGaussianProposal(int ndraws_proposal, TMatrix X, TStateModel *model, T_MHM *mhm, char *tag, PRECISION p1, PRECISION p2)
-{
- TMatrix proposal, posterior, base_scale, scale;
- TVector Y, *alpha=(TVector*)NULL, level_cuts;
- PRECISION rescale_factor, diff, marginal_density, ess, slope1, ess1, slope2, ess2, min_point=0.05, max_point=0.95, r1, r2;
- int idx_alpha=1, i, in1, in2;
- char filename[256];
- FILE *f_out;
-
- // set spherical type
-
-/* Y=ColumnVector((TVector)NULL,X,1); */
-/* SortVectorAscending(Y,Y); */
-
-/* i=floor(min_point*(PRECISION)DimV(Y)); */
-/* r1=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i)); */
-/* i=floor(max_point*(PRECISION)DimV(Y)); */
-/* r2=(i > 0) ? 0.5*(sqrt(ElementV(Y,i-1)) + sqrt(ElementV(Y,i))) : sqrt(ElementV(Y,i)); */
-
-/* FreeVector(Y); */
-
- r1=sqrt(dw_chi_square_invcdf(p1,NumberFreeParametersTheta(model)));
- r2=sqrt(dw_chi_square_invcdf(1.0 - p2,NumberFreeParametersTheta(model)));
-
- // rescale factor
- rescale_factor=1;
-
- SetupSpherical_TruncatedGaussian(NumberFreeParametersTheta(model),r1,r2);
-
-/* // Plot cummulative densities */
-/* f_out=dw_CreateTextFile("tmp.csv"); */
-/* fprintf(f_out,"tag: %s\n",tag); */
-/* fprintf(f_out,"scale factor: %lf\n",rescale_factor); */
-/* fprintf(f_out,"power: %lf\n",k); */
-/* fprintf(f_out,"truncation: %lf\n",truncate); */
-/* fprintf(f_out,"number draws posterior: %d\n",RowM(Y)); */
-/* inc=1.0/(PRECISION)bins; */
-/* p=pow(truncate,k); */
-/* for (i=j=0; i < bins; i++) */
-/* { */
-/* while ((j < RowM(Y)) && (sqrt(ElementM(Y,j,1)) <= (i+1)*inc*rescale_factor)) j++; */
-/* x=((PRECISION)i+0.5)*inc; */
-/* y=(x < truncate) ? 0.0 : (pow(x,k) - p)/(1.0 - p); */
-/* fprintf(f_out,"%lf,%lf,%lf\n",x,(PRECISION)j/(PRECISION)RowM(Y),y); */
-/* } */
-/* fclose(f_out); */
-/* return; */
-
- // compute base scale
- base_scale=CholeskyUT((TMatrix)NULL,mhm->variance);
- Transpose(base_scale,base_scale);
-
- // allocate alpha
- alpha=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- alpha[i]=CreateVector(DimV(mhm->BaseAlpha[i]));
-
- // Dirichlet index
- idx_alpha=1;
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- ProductVS(alpha[i],mhm->BaseAlpha[i],ElementV(mhm->alpha_scales,idx_alpha));
-
- // Create posterior matrix
- printf("Creating posterior (%d draws)\n",RowM(X));
- posterior=CreatePosterior(X,rescale_factor,base_scale,idx_alpha,NumberFreeParametersTheta(model));
-
- // Create proposal matrix
- printf("Creating proposal (%d draws)\n",ndraws_proposal);
- scale=ProductSM((TMatrix)NULL,rescale_factor,base_scale);
- proposal=CreateProposal(ndraws_proposal,mhm->center,scale,model,alpha);
-
- // Create output file
- sprintf(filename,"truncatedgaussian_%.2lf_%.2lf_md_%s.dat",p1,p2,tag);
- f_out=dw_CreateTextFile(filename);
-
- fprintf(f_out,"tag: %s\n",tag);
- fprintf(f_out,"Truncated Gaussian proposal\n");
- fprintf(f_out,"center cut: %lf (radius: %lf)\n",p1,r1);
- fprintf(f_out,"tail cut: %lf (radius: %lf)\n",p2,r2);
-
- fprintf(f_out,"number draws posterior (kept): %d\n",RowM(X));
- fprintf(f_out,"thinning factor: %d\n",mhm->n_thin);
- fprintf(f_out,"total posterior draws: %d\n",RowM(X) * mhm->n_thin);
- fprintf(f_out,"number draws proposal: %d\n",ndraws_proposal);
-
- // Compute marginal density using standard technique
- marginal_density=ComputeMarginalDensity_Standard(posterior);
- fprintf(f_out,"Standard MHM method: %0.14lg\n",marginal_density);
-
- // Compute marginal density using WZ1
- level_cuts=Sorted_Level_Cuts(posterior,10);
- fprintf(f_out,"WZ method - no center cut\nmarginal density,level,number proposal draws,number posterior draws,effective sample size\n");
- for (i=0; i < DimV(level_cuts); i++)
- {
- marginal_density=ComputeMarginalDensity_WZ1(proposal,posterior,ElementV(level_cuts,i),&in1,&in2);
- ess=ComputeEffectiveSampleSize_WZ1(posterior,ElementV(level_cuts,i));
-
- fprintf(f_out,"%0.14lg,%lg,%d,%d,%lg\n",marginal_density,ElementV(level_cuts,i),in1,in2,ess);
- }
- FreeVector(level_cuts);
-
- // Compute marginal density Mueller
- fprintf(f_out,"\nMueller method\nmarginal density,difference,# proposal draws,proposal log slope,proposal ess,# posterior draws,posterior log slope,posterior ess\n");
- marginal_density=ComputeMarginalDensity_Mueller(proposal,posterior,&in1,&in2);
- ComputeDiagnostics_Mueller(proposal,posterior,-marginal_density,&slope1,&ess1,&slope2,&ess2);
- diff=ComputeDifference(proposal,posterior,-marginal_density,&in1,&in2);
- fprintf(f_out,"%0.14lg,%lg,%d,%lg,%lg,%d,%lg,%lg\n\n",marginal_density,diff,in1,slope1,ess1,in2,slope2,ess2);
-
- fclose(f_out);
-
- sprintf(filename,"truncatedgaussian_%.2lf_%.2lf_md_proposal_%s.dat",p1,p2,tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,proposal,"%le,");
- fclose(f_out);
-
- sprintf(filename,"truncatedgaussian_%.2lf_%.2lf_md_posterior_%s.dat",p1,p2,tag);
- f_out=dw_CreateTextFile(filename);
- dw_PrintMatrix(f_out,posterior,"%le,");
- fclose(f_out);
-
- FreeMatrix(posterior);
- FreeMatrix(proposal);
-
- dw_FreeArray(alpha);
- FreeMatrix(base_scale);
- FreeMatrix(scale);
-}
-
-
-/* PRECISION SetupSphericalFromPosterior(TMatrix X, int n, int type) */
-/* { */
-/* switch (type) */
-/* { */
-/* //case TYPE_GAUSSIAN: */
-/* case TYPE_POWER: */
-/* return SetupSphericalFromPosterior_Power(X,n); */
-/* case TYPE_TRUNCATED_POWER: */
-/* return SetupSphericalFromPosterior_TruncatedPower(X,n); */
-/* case TYPE_TABLE: */
-/* return SetupSphericalFromPosterior_Table(X,n); */
-/* default: */
-/* fprintf(stderr,"Unknown proposal type\n"); */
-/* exit(0); */
-/* } */
-/* } */
-
-/* FILE* CreateOutputFile(int type, char *tag, PRECISION rescale_factor) */
-/* { */
-/* FILE *f_out; */
-/* char filename[256]; */
-
-/* // Create output file */
-/* switch (type) */
-/* { */
-/* case TYPE_GAUSSIAN: */
-/* sprintf(filename,"gaussian_md_%s.dat",tag); */
-/* break; */
-/* case TYPE_POWER: */
-/* sprintf(filename,"power_md_%s.dat",tag); */
-/* break; */
-/* case TYPE_TRUNCATED_POWER: */
-/* sprintf(filename,"truncatedpower_md_%s.dat",tag); */
-/* break; */
-/* case TYPE_TABLE: */
-/* sprintf(filename,"table_md_%s.dat",tag); */
-/* break; */
-/* default: */
-/* fprintf(stderr,"Unknown proposal type\n"); */
-/* exit(0); */
-/* } */
-/* f_out=dw_CreateTextFile(filename); */
-
-/* // Write header information */
-/* fprintf(f_out,"tag: %s\n",tag); */
-/* fprintf(f_out,"%s\n",SphericalType()); */
-
-/* return f_out; */
-/* } */
-
-/*
- Computes marginal data density using the WZ technique. A small footprint technique is used to minimize
- memory and file usage.
-*/
-/* void ComputeMarginal_Small(int type, int ndraws_proposal, TMatrix X, TStateModel *model, T_MHM *mhm, char *tag, PRECISION variance) */
-/* { */
-/* TMatrix posterior, base_scale, scale; */
-/* TVector *alpha=(TVector*)NULL, level_cuts, q; */
-/* PRECISION rescale_factor, marginal_density, ess; */
-/* int idx_alpha=1, i, in2; */
-/* FILE *f_out; */
-
-/* // Setup spherical distribution */
-/* rescale_factor=SetupSphericalFromPosterior(X,NumberFreeParametersTheta(model),type); */
-
-/* // compute base scale and scale */
-/* base_scale=CholeskyUT((TMatrix)NULL,mhm->variance); */
-/* Transpose(base_scale,base_scale); */
-/* scale=ProductSM((TMatrix)NULL,rescale_factor,base_scale); */
-
-/* // allocate alpha */
-/* alpha=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha)); */
-/* for (i=dw_DimA(alpha)-1; i >= 0; i--) */
-/* alpha[i]=CreateVector(DimV(mhm->BaseAlpha[i])); */
-
-/* // Dirichlet index */
-/* idx_alpha=1; */
-/* for (i=dw_DimA(alpha)-1; i >= 0; i--) */
-/* ProductVS(alpha[i],mhm->BaseAlpha[i],ElementV(mhm->alpha_scales,idx_alpha)); */
-
-/* // Create posterior matrix */
-/* printf("Creating posterior (%d draws)\n",RowM(X)); */
-/* posterior=CreatePosterior(X,rescale_factor,base_scale,idx_alpha,NumberFreeParametersTheta(model)); */
-
-/* // Create output file and write header */
-/* f_out=CreateOutputFile(type,tag,rescale_factor); */
-/* fprintf(f_out,"number draws posterior: %d (trimming factor: %d)\n",RowM(X),mhm->n_thin); */
-/* fprintf(f_out,"number draws proposal: %d\n",ndraws_proposal); */
-
-/* // Compute marginal density using WZ1 */
-/* level_cuts=Sorted_Level_Cuts(posterior,10); */
-/* printf("Creating proposal (%d draws)\n",ndraws_proposal); */
-/* q=Create_q(ndraws_proposal,mhm->center,scale,model,alpha,level_cuts); */
-/* fprintf(f_out,"WZ method\nmarginal density,level,number proposal draws,number posterior draws,effective sample size\n"); */
-/* for (i=0; i < DimV(level_cuts); i++) */
-/* { */
-/* marginal_density=ComputeMarginalDensity_WZ1_q(posterior,ElementV(level_cuts,i),ElementV(q,i),&in2); */
-/* ess=ComputeEffectiveSampleSize_WZ1(posterior,ElementV(level_cuts,i)); */
-
-/* fprintf(f_out,"%0.14lg,%lg,%d,%d,%lg\n",marginal_density,ElementV(level_cuts,i),(int)floor(ElementV(q,i)*ndraws_proposal),in2,ess); */
-/* } */
-
-/* // Clean up */
-/* FreeVector(level_cuts); */
-/* FreeVector(q); */
-
-/* fclose(f_out); */
-
-/* FreeMatrix(posterior); */
-
-/* dw_FreeArray(alpha); */
-/* FreeMatrix(base_scale); */
-/* FreeMatrix(scale); */
-/* } */
-
-/*
- Creates a cumulative distribution of the radius from the posterior
- distribution. The square of the radius is the second column of X.
- The larger the bin size, the finer the plot. The first column is the
- radius and the second column is the cumulative distribution.
-*/
-void CreateCumulativeDistributionPosteriorRadius(TMatrix X, char *filename, int bins)
-{
- FILE *fout=fopen(filename,"wt");
- TVector r=CreateVector(RowM(X));
- TMatrix cumulative;
- PRECISION inc, max;
- int i, j;
-
- for (i=DimV(r)-1; i >= 0; i--) ElementV(r,i)=sqrt(ElementM(X,i,1));
- SortVectorAscending(r,r);
- max=ElementV(r,DimV(r)-1);
- inc=max/bins;
-
- cumulative=CreateMatrix(bins,2);
- for (i=j=0; i < bins; i++)
- {
- while ((j < DimV(r)) && (ElementV(r,j) <= (i+1)*inc)) j++;
- ElementM(cumulative,i,0)=(i+0.5)*inc;
- ElementM(cumulative,i,1)=(PRECISION)j/(PRECISION)DimV(r);
- }
-
- dw_PrintMatrix(fout,cumulative,"%lf,");
- fclose(fout);
- FreeMatrix(cumulative);
- FreeVector(r);
-}
-
-/*
- Creates a cumulative distribution of the radius from the posterior
- distribution. The square of the radius is the second column of X.
- The larger the bin size, the finer the plot. The first column is the
- radius and the second column is the cumulative distribution.
-*/
-void CreateCumulativeDistributionSphericalRadius(int ndraws, int dim, char *filename, int bins)
-{
- FILE *fout=fopen(filename,"wt");
- TMatrix cumulative;
- TVector x=CreateVector(dim);
- PRECISION inc, max=1, r, s=1.0/(PRECISION)ndraws;
- int i, j;
-
- inc=max/bins;
- cumulative=CreateMatrix(bins,2);
- for (i=0; i < bins; i++)
- {
- ElementM(cumulative,i,0)=(i+0.5)*inc;
- ElementM(cumulative,i,1)=0.0;
- }
-
- for (i=ndraws; i > 0; i--)
- {
- r=DrawSpherical(x);
- j=(int)floor(bins*r/max);
- if (j >= bins) j=bins-1;
- ElementM(cumulative,j,1)+=1.0;
- }
- ElementM(cumulative,0,1)*=s;
- for (i=1; i < bins; i++)
- ElementM(cumulative,i,1)=s*ElementM(cumulative,i,1) + ElementM(cumulative,i-1,1);
-
- dw_PrintMatrix(fout,cumulative,"%lf,");
- fclose(fout);
- FreeMatrix(cumulative);
- FreeVector(x);
-}
-
-/*
- Outputs
-*/
-void Plot_Posterior_vs_Posterior_Radius(TMatrix X, char* filename)
-{
- FILE *f_out=dw_CreateTextFile(filename);
- int bins=1000, inc=(RowM(X)-1)/(bins-1), start=(RowM(X) - inc*(bins-1))/2, stop, i, j;
- TMatrix Y;
-
- SortMatrixRowsAscending(X,X,1);
- Y=CreateMatrix(bins,4);
- for (i=0; i < bins; i++)
- {
- stop=start+inc;
- if (stop > RowM(X)) stop=RowM(X);
- ElementM(Y,i,0)=(ElementM(X,start,1) + ElementM(X,stop-1,1))/2;
- ElementM(Y,i,1)=ElementM(Y,i,2)=ElementM(Y,i,3)=ElementM(X,start,0);
- for (j=start+1; j < stop; j++)
- {
- ElementM(Y,i,2)+=ElementM(X,j,0);
- if (ElementM(X,j,0) < ElementM(Y,i,1))
- ElementM(Y,i,1)=ElementM(X,j,0);
- else
- if (ElementM(X,j,0) > ElementM(Y,i,3))
- ElementM(Y,i,3)=ElementM(X,j,0);
- }
- ElementM(Y,i,2)/=(PRECISION)(stop - start);
- start+=inc;
- }
-
- dw_PrintMatrix(f_out,Y,"%lf,");
- FreeMatrix(Y);
- fclose(f_out);
-}
-
-void Plot_Posterior_vs_Proposal_Radius(int ndraws, TStateModel *model, T_MHM *mhm, char* filename, PRECISION rescale_factor)
-{
- FILE *f_out=dw_CreateTextFile(filename);
- int bins=1000, inc=(ndraws-1)/(bins-1), start=(ndraws - inc*(bins-1))/2, idx_alpha=1, stop, i, j;
- TMatrix Y, X, base_scale, scale;
- TVector *alpha;
-
- // compute base scale and scale
- base_scale=CholeskyUT((TMatrix)NULL,mhm->variance);
- Transpose(base_scale,base_scale);
-
- // allocate scale and alpha
- alpha=dw_CreateArray_vector(dw_DimA(mhm->BaseAlpha));
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- alpha[i]=CreateVector(DimV(mhm->BaseAlpha[i]));
-
- // Dirichlet index
- idx_alpha=1;
- for (i=dw_DimA(alpha)-1; i >= 0; i--)
- ProductVS(alpha[i],mhm->BaseAlpha[i],ElementV(mhm->alpha_scales,idx_alpha));
-
- // Create proposal matrix
- printf("Creating proposal (%d draws)\n",ndraws);
- scale=ProductSM((TMatrix)NULL,rescale_factor,base_scale);
- X=CreateProposal_Radius(ndraws,mhm->center,scale,model,alpha);
- FreeMatrix(scale);
- FreeMatrix(base_scale);
- dw_FreeArray(alpha);
-
- SortMatrixRowsAscending(X,X,0);
- Y=CreateMatrix(bins,4);
- for (i=0; i < bins; i++)
- {
- stop=start+inc;
- if (stop > RowM(X)) stop=RowM(X);
- ElementM(Y,i,0)=rescale_factor*(ElementM(X,start,0) + ElementM(X,stop-1,0))/2;
- ElementM(Y,i,1)=ElementM(Y,i,2)=ElementM(Y,i,3)=ElementM(X,start,1);
- for (j=start+1; j < stop; j++)
- {
- ElementM(Y,i,2)+=ElementM(X,j,1);
- if (ElementM(X,j,1) < ElementM(Y,i,1))
- ElementM(Y,i,1)=ElementM(X,j,1);
- else
- if (ElementM(X,j,1) > ElementM(Y,i,3))
- ElementM(Y,i,3)=ElementM(X,j,1);
- }
- ElementM(Y,i,2)/=(PRECISION)(stop - start);
- start+=inc;
- }
- FreeMatrix(X);
-
- dw_PrintMatrix(f_out,Y,"%lf,");
- FreeMatrix(Y);
- fclose(f_out);
-}
-
-/*
- Overview:
- filename contains the following:
-
- (A) Information required to create and setup T_MHM structure.
- (B) Data - the columns are
-
- (1) - log posterior value for each draw
- (2) - fp_theta' * Inverse(variance) * fp_theta for each draw
- (3) - log Dirichlet value for each draw under several different values
- of the parameters for the Dirichlet parameter
-
- The parameters of the model are Q and theta. Q is the matrix of
- transition probabilities and theta contains the model specific
- parameters. fp_theta denotes the free parametes in theta.
-
- spec_filename contains information to create and setup the TStateModel
- structure and parameter values for the posterior mode.
-
- Output:
- for each draw in filename computes the following
-
- h(theta,Q)/posterior(theta,Q)
-
- where h(theta,Q) = f(theta)*g(Q) where f is a spherical distribution on
- x = sqrt(Inverse(variance))*fp_theta and g is Dirichlet distribution on Q.
- Recall that a spherical distribution is one in which the density of x depends
- only on the norm of x and sqrt(X) = Y only if Y'*Y = X.
-*/
-int main(int nargs, char **args)
-{
- char *id, *fmt, *tag, *mhm_filename, *spec_filename;
- FILE *f_in, *f_out=stdout;
- int n_fields, ndraws_proposal, ndraws_posterior, proposal_type;
- TMatrix X;
- TStateModel *model;
- T_MHM *mhm;
- PRECISION p1, p2;
-
- /*** Test Spherical distribution ***
- int n=120;
-
- PRECISION r1, r2;
- p1=0.0;
- p2=0.7;
- r1=sqrt(dw_chi_square_invcdf(p1,n));
- r2=sqrt(dw_chi_square_invcdf(1.0 - p2,n));
- printf("p1: %lf r1: %lf p1 (computed): %lf\n",p1,r1,dw_chi_square_cdf(r1*r1,n));
- printf("p2: %lf r2: %lf p2 (computed): %lf\n",p2,r2,1.0-dw_chi_square_cdf(r2*r2,n));
- SetupSpherical_TruncatedGaussian(n,r1,r2);
-
- TestSpherical((FILE*)NULL,"tmp.csv",10.0);
- return 0;
- /************************************/
-
- /*****************************************************************************/
- /* Read command line and input files */
- /*****************************************************************************/
- // help
- if (dw_FindArgument(nargs,args,'h') >= 0)
- {
- printf("\nSyntax: marginal_VAR -d <number posterior draws>"
- "\n -ft <file tag name>"
- "\n -t <proposal type>"
- "\n 1: gaussian"
- "\n 2: power"
- "\n 3: truncated power"
- "\n 4: table"
- "\n 5: truncated gaussian"
- "\n -u <upper tail truncation>"
- "\n -l <center region truncation>"
- "\n\n");
- exit(0);
- }
-
- // setup filenames
- if (!(tag=dw_ParseString_String(nargs,args,"ft",(char*)NULL)))
- {
- printf("Tag not specified. Usage: -ft <file tag name>\n\n");
- exit(0);
- }
-
- fmt="mhm_draws_%s.dat";
- sprintf(mhm_filename=(char*)malloc(strlen(tag)+strlen(fmt)-1),fmt,tag);
- fmt="est_final_%s.dat";
- sprintf(spec_filename=(char*)malloc(strlen(tag)+strlen(fmt)-1),fmt,tag);
-
- // get number of proposal draws - default 100000
- ndraws_proposal=dw_ParseInteger_String(nargs,args,"d",100000);
-
- // Read and create TStateModel strucure and setup normalization
- printf("Creating TStateModel\n");
- model=Read_VAR_Specification((FILE*)NULL,spec_filename);
- ReadTransitionMatrices((FILE*)NULL,spec_filename,"Posterior mode: ",model);
- Read_VAR_Parameters((FILE*)NULL,spec_filename,"Posterior mode: ",model);
- Setup_WZ_Normalization(model->theta,((T_VAR_Parameters*)(model->theta))->A0);
-
- // Read and create T_MHM structure
- printf("Creating T_MHM structure\n");
- f_in=dw_OpenTextFile(mhm_filename);
- mhm=ReadMHM_Input(f_in,(char*)NULL,(T_MHM*)NULL);
- AddStateModel(model,mhm);
- ReadMeanVariance(f_in,mhm);
-
- // Read draws
- printf("Reading draws\n");
- ndraws_posterior=mhm->n_mhm;
- n_fields=DimV(mhm->alpha_scales)+3;
- id="//== Draws ==//";
- if (!dw_SetFilePosition(f_in,id) || !dw_ReadMatrix(f_in,X=CreateMatrix(ndraws_posterior,n_fields)))
- {
- if (!dw_SetFilePosition(f_in,id))
- printf("Error in parsing header\n %s\n",id);
- else
- {
- char **line;
- int i;
- printf("Error in reading data matrix - checking data...\n");
- rewind(f_in);
- dw_SetFilePosition(f_in,id);
- for (i=0; i < ndraws_posterior; i++)
- {
- line=dw_ReadDelimitedLine(f_in,' ',REMOVE_EMPTY_FIELDS | STRIP_WHITESPACE);
- if (!line)
- {
- printf("Not enough lines - %d\n",i+1);
- exit(0);
- }
- if (dw_DimA(line) != n_fields)
- {
- printf("Error on line %d - incorrect number of fields\n ",i+1);
- dw_PrintDelimitedArray(stdout,line,' ');
- fgetc(stdin);
- }
- dw_FreeArray(line);
- }
- }
- exit(0);
- }
- fclose(f_in);
-
- // set proposal type - default power
- proposal_type=dw_ParseInteger_String(nargs,args,"t",2);
-
- /*****************************************************************************/
- /*****************************************************************************/
-
- // Initial generator from clock
- dw_initialize_generator(0);
-
- // Compute marginal using power functions
- switch (proposal_type)
- {
- case 1:
- ComputeMarginal_GaussianProposal(ndraws_proposal,X,model,mhm,tag,1.0);
- break;
- case 2:
- ComputeMarginal_PowerProposal(ndraws_proposal,X,model,mhm,tag);
- break;
- case 3:
- ComputeMarginal_TruncatedPowerProposal(ndraws_proposal,X,model,mhm,tag);
- break;
- case 4:
- ComputeMarginal_Table(ndraws_proposal,X,model,mhm,tag);
- break;
- case 5:
- p1=dw_ParseFloating_String(nargs,args,"l",0.0);
- p2=dw_ParseFloating_String(nargs,args,"u",0.0);
- ComputeMarginal_TruncatedGaussianProposal(ndraws_proposal,X,model,mhm,tag,p1,p2);
- default:
- printf("\nUnknown proposal density."
- "\n Usage: -t <proposal type>"
- "\n 1: gaussian"
- "\n 2: power"
- "\n 3: truncated power"
- "\n 4: table"
- "\n 5: truncated gaussian"
- "\n\n");
- break;
- }
-
- FreeMatrix(X);
- FreeStateModel(model);
- FreeMHM(mhm);
-}
-
diff --git a/matlab/swz/c-code/sbvar/var/probabilities.c b/matlab/swz/c-code/sbvar/var/probabilities.c
deleted file mode 100644
index db6fd49c7a2d8b4ed88d661069216c610229b44b..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/sbvar/var/probabilities.c
+++ /dev/null
@@ -1,136 +0,0 @@
-
-#include "switch.h"
-#include "switchio.h"
-#include "VARio.h"
-#include "dw_parse_cmd.h"
-#include "dw_ascii.h"
-
-#include <stdlib.h>
-
-/*
- Attempt to set up model from command line. Command line options are the
- following
-
- -ft <filename tag>
- If this argument exists, then the following is attempted:
- specification file name = est_final_<tag>.dat
- output file name = probabilites_<tag>.dat
- parameters file name = est_final_<tag>.dat
- header = "Posterior mode: "
-
- -fs <filename>
- If this argument exists, then the specification file name is <filename>.
- The argument -fs takes precedence over -ft.
-
- -fo <filename>
- If this argument exists, then the output file name is <filename>. The
- argument -fo takes precedence over -ft. The default value is
- parameters.dat.
-
- -fp <filename>
- If this argument exists, then the parameters file name is <filename>. The
- argument -fp takes precedence over -ft. The default value is the filename
- associated with the argument -fs.
-
- -ph <header>
- If this argument exists, then the header for the parameters file is
- <header>. The default value is "Posterior mode: ".
-
-*/
-
-
-int main(int nargs, char **args)
-{
- char *spec=(char*)NULL, *parm=(char*)NULL, *head=(char*)NULL, *out=(char*)NULL, *buffer, *fmt;
- TStateModel *model;
- TVector *probabilities;
- int s, t;
- FILE *f_out;
-
- // specification filename
- if (buffer=dw_ParseString_String(nargs,args,"fs",(char*)NULL))
- strcpy(spec=(char*)malloc(strlen(buffer)+1),buffer);
-
- // output filename
- if (buffer=dw_ParseString_String(nargs,args,"fo",(char*)NULL))
- strcpy(out=(char*)malloc(strlen(buffer)+1),buffer);
-
- // parameter filename
- if (buffer=dw_ParseString_String(nargs,args,"fp",(char*)NULL))
- strcpy(parm=(char*)malloc(strlen(buffer)+1),buffer);
-
- // header
- if (buffer=dw_ParseString_String(nargs,args,"ph",(char*)NULL))
- strcpy(head=(char*)malloc(strlen(buffer)+1),buffer);
-
- // file tag
- if (buffer=dw_ParseString_String(nargs,args,"ft",(char*)NULL))
- {
- fmt="est_final_%s.dat";
-
- // specification filename
- if (!spec)
- sprintf(spec=(char*)malloc(strlen(fmt) + strlen(buffer) - 1),fmt,buffer);
-
- // parameter filename
- if (!parm)
- sprintf(parm=(char*)malloc(strlen(fmt) + strlen(buffer) - 1),fmt,buffer);
-
- // output filename
- if (!out)
- {
- fmt="probabilities_%s.dat";
- sprintf(out=(char*)malloc(strlen(fmt) + strlen(buffer) - 1),fmt,buffer);
- }
- }
-
- if (!spec)
- {
- fprintf(stderr,"No specification filename given\n");
- fprintf(stderr,"Command line syntax:\n"
- " -ft : file tag\n"
- " -fs : specification filename\n"
- " -fo : output filename (probablities.dat)\n"
- " -fp : parameters filename (specification filename)\n"
- " -fh : parameter header (Posterior mode: )\n"
- );
- exit(1);
- }
-
- if (!parm)
- strcpy(parm=(char*)malloc(strlen(spec)+1),spec);
-
- if (!head)
- {
- buffer="Posterior mode: ";
- strcpy(head=(char*)malloc(strlen(buffer)+1),buffer);
- }
-
- if (!out)
- {
- buffer="probabilities.dat";
- strcpy(out=(char*)malloc(strlen(buffer)+1),buffer);
- }
-
- model=Read_VAR_Specification((FILE*)NULL,spec);
- ReadTransitionMatrices((FILE*)NULL,parm,head,model);
- Read_VAR_Parameters((FILE*)NULL,parm,head,model);
-
- probabilities=dw_CreateArray_vector(model->sv->nstates);
- for (s=model->sv->nstates-1; s >= 0; s--)
- probabilities[s]=ProbabilitiesState((TVector)NULL,s,model);
-
- f_out=dw_CreateTextFile(out);
- for (t=0; t <= model->sv->nobs; t++)
- {
- for (s=0; s < model->sv->nstates; s++)
- fprintf(f_out,"%lf ",ElementV(probabilities[s],t));
- fprintf(f_out,"\n");
- }
-
- free(spec);
- free(out);
- free(head);
- free(parm);
-
-}
diff --git a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_array.c b/matlab/swz/c-code/utilities/DWCcode/arrays/dw_array.c
deleted file mode 100644
index db0d67491e6f5938ef2ff924290b334d045eb9de..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_array.c
+++ /dev/null
@@ -1,609 +0,0 @@
-
-#include "dw_array.h"
-#include "dw_error.h"
-
-#include <stdlib.h>
-#include <string.h>
-#include <malloc.h>
-#include <stdarg.h>
-
-//================================== Macros ===================================//
-#define dw_ElementSizeA(a) (dw_SpecsA(a)->size)
-#define dw_GetOffsetA(a) (dw_SpecsA(a)->offset)
-#define dw_IsSameTypeA(a1,a2) (!memcmp(dw_SpecsA(a1),dw_SpecsA(a2),sizeof(TElementSpecification)))
-#define dw_IsPointerA(a) (dw_SpecsA(a)->flag & dw_ARRAY_POINTER)
-#define dw_UseMemcpyA(a) (dw_SpecsA(a)->flag & dw_ARRAY_USE_MEMCPY)
-#define dw_DeleteSpecsA(a) (dw_SpecsA(a)->flag & dw_ARRAY_DELETE_SPECS)
-#define dw_GetDestructorA(a) (dw_SpecsA(a)->destructor)
-#define dw_GetDefaultConstructorA(s) (dw_SpecsA(a)->default_constructor)
-#define dw_GetPointerCopyConstructorA(a) (dw_SpecsA(a)->pointer_copy_constructor)
-#define dw_GetStaticCopyConstructorA(a) (dw_SpecsA(a)->static_copy_constructor)
-#define dw_GetPrintRoutineA(a) (dw_SpecsA(a)->print_routine)
-#define dw_GetReadRoutineA(a) (dw_SpecsA(a)->read_routine)
-
-
-/*******************************************************************************/
-/********************** C-style multi-dimensional arrays ***********************/
-/*******************************************************************************/
-/*
- Frees a C-style multi-dimensional array. The pointer a must point to a valid
- array created via a call to dw_CreateArray() or be a null pointer.
-*/
-void dw_FreeArray(void* a)
-{
- int i, size, offset;
- void (*Destructor)(void*);
- if (a)
- {
- if (Destructor=dw_GetDestructorA(a))
- if (dw_IsPointerA(a))
- for (i=dw_DimA(a)-1; i >= 0; i--)
- Destructor(((void**)a)[i]);
- else
- for (i=(size=dw_ElementSizeA(a))*(dw_DimA(a)-1); i >= 0; i-=size)
- Destructor((void*)(((char*)a) + i));
- offset=dw_GetOffsetA(a);
- if (dw_DeleteSpecsA(a)) free(dw_SpecsA(a));
- free((void*)(((char*)a) - offset));
- }
-}
-
-/*
- Assumes:
- specs: Pointer to a valid TElementSpecification structure.
- dim: Positive integer
-
- Returns:
- A pointer to a valid array of lenth dim upon success and a null pointer upon
- failure.
-
- Notes:
- The return value should be type cast to the appropriate pointer type.
-*/
-void* dw_CreateArray(TElementSpecification *specs, int dim)
-{
- void *a=(void*)NULL;
- int i;
- if (dim <= 0)
- dw_Error(ARG_ERR);
- else
- if (!(a=malloc(dim*specs->size + specs->offset)))
- dw_Error(MEM_ERR);
- else
- {
- a=(void*)(((char*)a)+specs->offset);
- dw_DimA(a)=dim;
- dw_SpecsA(a)=specs;
- if (specs->default_constructor)
- for (i=(specs->size)*(dim-1); i >= 0; i-=specs->size)
- specs->default_constructor((void*)(((char*)a) + i));
- }
- return a;
-}
-
-/*
- Assumes:
- specs: Pointer to a valid TElementSpecification structure.
- depth: Positive integer
- dim: Array of positive integers of length at least depth
-
- Returns:
- A pointer to a valid multidimensiona array. The dimensions of the array are
- determined by depth and dim.
-
- Notes:
- The return value should be type cast to the appropriate pointer type.
-*/
-void* dw_CreateMultidimensionalArray(TElementSpecification *specs, int depth, int *dim)
-{
- int i;
- void *a;
- if (depth == 1) return dw_CreateArray(specs,dim[0]);
- if (a=dw_CreateArray_array(dim[0]))
- for (i=dim[0]-1; i >= 0; i--)
- if (!(((void**)a)[i]=dw_CreateMultidimensionalArray(specs,depth-1,dim+1)))
- {
- dw_FreeArray(a);
- return (void*)NULL;
- }
- return a;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/**************************** Default Constructors *****************************/
-/*******************************************************************************/
-void DefaultPointerConstructor(void *element)
-{
- *((void**)element)=(void*)NULL;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/******************************* Print Functions *******************************/
-/*******************************************************************************/
-int dw_PrintArray(FILE *f, void *a, char *format)
-{
- int i, size;
- int (*PrintRoutine)(FILE*, void*, char*);
- if (f && a)
- if (PrintRoutine=dw_GetPrintRoutineA(a))
- {
- if (dw_IsPointerA(a))
- for (i=0; i < dw_DimA(a); i++)
- { if (!PrintRoutine(f,((void**)a)[i],format)) return 0; }
- else
- for (size=dw_ElementSizeA(a), i=0; i < dw_DimA(a); i++)
- { if (!PrintRoutine(f,(void*)(((char*)a) + i*size),format)) return 0; }
- fprintf(f,"\n");
- return 1;
- }
- return 0;
-}
-
-static int dw_PrintInt(FILE* f, void* element, char *format)
-{
- return (fprintf(f,format ? format : "%d ",*((int*)element)) < 0) ? 0 : 1;
-}
-
-static int dw_PrintDouble(FILE* f, void* element, char *format)
-{
- return (fprintf(f,format ? format : "%lf ",*((double*)element)) < 0) ? 0 : 1;
-}
-
-static int dw_PrintFloat(FILE* f, void* element, char *format)
-{
- return (fprintf(f,format ? format : "%f ",*((float*)element)) < 0) ? 0 : 1;
-}
-
-static int dw_PrintChar(FILE* f, void* element, char *format)
-{
- return (fprintf(f,format ? format : "%c ",*((char*)element)) < 0) ? 0 : 1;
-}
-
-static int dw_PrintString(FILE* f, void* element, char *format)
-{
- return (fprintf(f,format ? format : "%s\t",(char*)element) < 0) ? 0 : 1;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/******************************* Read Functions ********************************/
-/*******************************************************************************/
-int dw_ReadArray(FILE *f, void *a)
-{
- int i, size;
- int (*ReadRoutine)(FILE*, void*);
- if (f && a)
- if (ReadRoutine=dw_GetReadRoutineA(a))
- {
- if (dw_IsPointerA(a))
- for (i=0; i < dw_DimA(a); i++)
- { if (!ReadRoutine(f,((void**)a)[i])) return 0; }
- else
- for (size=dw_ElementSizeA(a), i=0; i < dw_DimA(a); i++)
- { if (!ReadRoutine(f,(void*)(((char*)a) + i*size))) return 0; }
- return 1;
- }
- return 0;
-}
-
-static int dw_ReadInt(FILE* f, void* element)
-{
- return (fscanf(f," %d ",(int*)element) != 1) ? 0 : 1;
-}
-
-static int dw_ReadDouble(FILE* f, void* element)
-{
- return (fscanf(f," %lf ",(double*)element) != 1) ? 0 : 1;
-}
-
-static int dw_ReadFloat(FILE* f, void* element)
-{
-return (fscanf(f," %f ",(float*)element) != 1) ? 0 : 1;
-}
-
-static int dw_ReadChar(FILE* f, void* element)
-{
-return (fscanf(f," %c ",(char*)element) != 1) ? 0 : 1;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/****************************** Copy Constructors ******************************/
-/*******************************************************************************/
-/*
- Assumes
-*/
-static int FullCopyAttempt(void **d, void *s, void* (*copy)(void*, void*), void (*destructor)(void*))
-{
- if (s)
- if (*d)
- {
- if (!copy(*d,s))
- {
- if (destructor) destructor(*d);
- if (!(*d=copy((void*)NULL,s))) return 0;
- }
- }
- else
- {
- if (!(*d=copy((void*)NULL,s))) return 0;
- }
- else
- if (*d)
- {
- if (destructor) destructor(*d);
- *d=(void*)NULL;
- }
- return 1;
-}
-
-/*
- Assumes:
- d: A valid array or null pointer
- s: A valid array
-
- Returns:
- Upon success returns a copy of the array s. If d is null, then the array is
- created. Upon failure, a null pointer is returned.
-
- Notes:
- If d is
-*/
-void* dw_CopyArray(void* d, void* s)
-{
- int i, size;
- void* original_d=d;
-
- if (!s) return (void*)NULL;
-
- if (s == d) return d;
-
- if (!d)
- { if (!(d=dw_CreateArray(dw_SpecsA(s),dw_DimA(s)))) return (void*)NULL; }
- else
- { if ((dw_DimA(s) != dw_DimA(d)) || !dw_IsSameTypeA(d,s)) return (void*)NULL; }
-
- if (dw_UseMemcpyA(s))
- {
- memcpy(d,s,dw_DimA(s)*dw_ElementSizeA(s));
- }
- else if (dw_GetPointerCopyConstructorA(s))
- {
- for (i=dw_DimA(s)-1; i >= 0; i--)
- if (!FullCopyAttempt(((void**)d)+i,((void**)s)[i],dw_GetPointerCopyConstructorA(s),dw_GetDestructorA(d)))
- {
- if (!original_d) dw_FreeArray(d);
- return (void*)NULL;
- }
- }
- else if (dw_GetStaticCopyConstructorA(s))
- {
- for (i=(size=dw_ElementSizeA(s))*(dw_DimA(s)-1); i >= 0; i-=size)
- if (!dw_GetStaticCopyConstructorA(s)((void*)(((char*)d) + i),(void*)(((char*)s) + i)))
- {
- if (!original_d) dw_FreeArray(d);
- return (void*)NULL;
- }
- }
- else
- {
- if (!original_d) dw_FreeArray(d);
- return (void*)NULL;
- }
-
- return d;
-}
-
-/*
- Assumes
- Both d and s are valid pointers and both *d and *s are either null or a
- null terminated string. If *d is a null terminated string, then it must
- have been created via a call to malloc(), calloc() or realloc().
-
- Returns
- Returns one upon success and zero upon failure.
-
- Results
- If is *s is null, then *d is freed if it is non-null and is then set to
- null. If *s is null terminated string, then *d is reallocated if more
- memory is required and then *s is copied into *d.
-
- Notes
- It is critical that this function be called only if the destination string
- was dynamically created via a call to malloc(), calloc() or realloc(). If
- this is not the case, then servere memory problems can result.
-*/
-static int dw_CopyString(void *d, void *s)
-{
- char* dest;
- if (*((char**)s))
- if (dest=realloc(*((char**)d),strlen(*((char**)s))+1))
- strcpy(*((char**)d)=dest,*((char**)s));
- else
- return 0;
- else
- if (*((char**)d))
- {
- free(*((char**)d));
- *((char**)d)=(char*)NULL;
- }
- return 1;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/********* Multidimensional Arrays Create Via Variable Argument Lists **********/
-/*******************************************************************************/
-/*
- Assumes:
- specs: Pointer to a valid TElementSpecification structure.
- depth: Positive integer
-
- Returns:
- A pointer to a valid multidimensiona array. The dimensions of the array are
- determined by depth the variable list of arguments.
-
- Notes:
- The return value should be type cast to the appropriate pointer type. The
- variable list of arguments must be at least of length depth and consist of
- positive integers.
-*/
-void* dw_CreateMultidimensionalArrayList(TElementSpecification *specs, int depth, ...)
-{
- va_list ap;
- int i, *dim;
- void *a=(void*)NULL;
- if (dim=(int*)malloc(depth*sizeof(int)))
- {
- va_start(ap,depth);
- for (i=0; i < depth; i++) dim[i]=va_arg(ap,int);
- va_end(ap);
- a=dw_CreateMultidimensionalArray(specs,depth,dim);
- free(dim);
- }
- return a;
-}
-
-void* dw_CreateMultidimensionalArrayList_string(int depth, ...)
-{
- va_list ap;
- int i, *dim;
- void *a=(void*)NULL;
- if (dim=(int*)malloc(depth*sizeof(int)))
- {
- va_start(ap,depth);
- for (i=0; i < depth; i++) dim[i]=va_arg(ap,int);
- va_end(ap);
- a=dw_CreateMultidimensionalArray_string(depth,dim);
- free(dim);
- }
- return a;
-}
-
-void* dw_CreateMultidimensionalArrayList_int(int depth, ...)
-{
- va_list ap;
- int i, *dim;
- void *a=(void*)NULL;
- if (dim=(int*)malloc(depth*sizeof(int)))
- {
- va_start(ap,depth);
- for (i=0; i < depth; i++) dim[i]=va_arg(ap,int);
- va_end(ap);
- a=dw_CreateMultidimensionalArray_int(depth,dim);
- free(dim);
- }
- return a;
-}
-
-void* dw_CreateMultidimensionalArrayList_double(int depth, ...)
-{
- va_list ap;
- int i, *dim;
- void *a=(void*)NULL;
- if (dim=(int*)malloc(depth*sizeof(int)))
- {
- va_start(ap,depth);
- for (i=0; i < depth; i++) dim[i]=va_arg(ap,int);
- va_end(ap);
- a=dw_CreateMultidimensionalArray_double(depth,dim);
- free(dim);
- }
- return a;
-}
-
-void* dw_CreateMultidimensionalArrayList_float(int depth, ...)
-{
- va_list ap;
- int i, *dim;
- void *a=(void*)NULL;
- if (dim=(int*)malloc(depth*sizeof(int)))
- {
- va_start(ap,depth);
- for (i=0; i < depth; i++) dim[i]=va_arg(ap,int);
- va_end(ap);
- a=dw_CreateMultidimensionalArray_float(depth,dim);
- free(dim);
- }
- return a;
-}
-
-void* dw_CreateMultidimensionalArrayList_char(int depth, ...)
-{
- va_list ap;
- int i, *dim;
- void *a=(void*)NULL;
- if (dim=(int*)malloc(depth*sizeof(int)))
- {
- va_start(ap,depth);
- for (i=0; i < depth; i++) dim[i]=va_arg(ap,int);
- va_end(ap);
- a=dw_CreateMultidimensionalArray_char(depth,dim);
- free(dim);
- }
- return a;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/****************************** Initialize Arrays ******************************/
-/*******************************************************************************/
-int dw_InitializeArray(void *a, void *x)
-{
- int i, size;
- if (a)
- {
- if (dw_IsArrayA(a))
- {
- for (i=dw_DimA(a)-1; i >= 0; i--)
- if (!dw_InitializeArray(((void**)a)[i],x)) return 0;
- }
- else if (dw_UseMemcpyA(a))
- {
- for (size=dw_ElementSizeA(a), i=size*(dw_DimA(a)-1); i >= 0; i-=size)
- memcpy((void*)(((char*)a) + i),x,size);
- }
- else if (dw_GetPointerCopyConstructorA(a))
- {
- for (i=dw_DimA(a)-1; i >= 0; i--)
- if (!FullCopyAttempt(((void**)a)+i,x,dw_GetPointerCopyConstructorA(a),dw_GetDestructorA(a))) return 0;
- }
- else if (dw_GetStaticCopyConstructorA(a))
- {
- for (i=(size=dw_ElementSizeA(a))*(dw_DimA(a)-1); i >= 0; i-=size)
- if (!dw_GetStaticCopyConstructorA(a)((void*)(((char*)a)+i),x)) return 0;
- }
- else
- return 0;
- return 1;
- }
- return 0;
-}
-
-int dw_InitializeArray_int(void *a, int x) { return dw_InitializeArray(a,&x); }
-
-int dw_InitializeArray_double(void *a, double x) { return dw_InitializeArray(a,&x); }
-
-int dw_InitializeArray_float(void *a, float x) { return dw_InitializeArray(a,&x); }
-
-int dw_InitializeArray_char(void *a, char x) { return dw_InitializeArray(a,&x); }
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/**************************** TElementSpecification ****************************/
-/*******************************************************************************/
-TElementSpecification* CreateArraySpecification_pointer(void (*destructor)(void *))
-{
- TElementSpecification *specs;
- if (specs=(TElementSpecification*)malloc(sizeof(TElementSpecification)))
- {
- specs->flag=dw_ARRAY_POINTER | dw_ARRAY_DELETE_SPECS;
- specs->size=sizeof(void*);
- specs->offset=sizeof(void*)*((sizeof(int)+sizeof(TElementSpecification*)+sizeof(void*)-1)/sizeof(void*)),
- specs->destructor=destructor;
- specs->default_constructor=NULL;
- specs->pointer_copy_constructor=NULL;
- specs->static_copy_constructor=NULL;
- specs->print_routine=NULL;
- specs->read_routine=NULL;
- }
- return specs;
-}
-
-TElementSpecification dw_IntSpecs =
- {
- dw_ARRAY_USE_MEMCPY,
- sizeof(int),
- sizeof(int)*((sizeof(int)+sizeof(TElementSpecification*)+sizeof(int)-1)/sizeof(int)),
- NULL,
- NULL,
- NULL,
- NULL,
- dw_PrintInt,
- dw_ReadInt
- };
-
-TElementSpecification dw_DoubleSpecs =
- {
- dw_ARRAY_USE_MEMCPY,
- sizeof(double),
- sizeof(double)*((sizeof(int)+sizeof(TElementSpecification*)+sizeof(double)-1)/sizeof(double)),
- NULL,
- NULL,
- NULL,
- NULL,
- dw_PrintDouble,
- dw_ReadDouble
- };
-
-TElementSpecification dw_FloatSpecs =
- {
- dw_ARRAY_USE_MEMCPY,
- sizeof(float),
- sizeof(float)*((sizeof(int)+sizeof(TElementSpecification*)+sizeof(float)-1)/sizeof(float)),
- NULL,
- NULL,
- NULL,
- NULL,
- dw_PrintFloat,
- dw_ReadFloat
- };
-
-TElementSpecification dw_CharSpecs =
- {
- dw_ARRAY_USE_MEMCPY,
- sizeof(char),
- sizeof(char)*((sizeof(int)+sizeof(TElementSpecification*)+sizeof(char)-1)/sizeof(char)),
- NULL,
- NULL,
- NULL,
- NULL,
- dw_PrintChar,
- dw_ReadChar
- };
-
-TElementSpecification dw_StringSpecs =
- {
- dw_ARRAY_POINTER,
- sizeof(char*),
- sizeof(char*)*((sizeof(int)+sizeof(TElementSpecification*)+sizeof(char*)-1)/sizeof(char*)),
- free,
- DefaultPointerConstructor,
- NULL,
- dw_CopyString,
- dw_PrintString,
- NULL
- };
-
-TElementSpecification dw_ArraySpecs =
- {
- dw_ARRAY_POINTER | dw_ARRAY_ARRAY,
- sizeof(void*),
- sizeof(void*)*((sizeof(int)+sizeof(TElementSpecification*)+sizeof(void*)-1)/sizeof(void*)),
- dw_FreeArray,
- DefaultPointerConstructor,
- dw_CopyArray,
- NULL,
- dw_PrintArray,
- dw_ReadArray
- };
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
diff --git a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_array.h b/matlab/swz/c-code/utilities/DWCcode/arrays/dw_array.h
deleted file mode 100644
index 1ab7518b39a64fe98a16da105629e92b8f00121d..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_array.h
+++ /dev/null
@@ -1,205 +0,0 @@
-
-#ifndef __TARRAY__
-#define __TARRAY__
-
-/******************************** C-style arrays ********************************
-
-Attempts to implement a C++ class template for multidimensional arrays. The goal
-is to allow access through the bracket operator (a[i_1][i_2]...[i_n]) but provide
-mechanisms for creating, destroying, and determining the dimensions of the array.
-
-In this implementation, an array is a pointer to void. The exact behavior of the
-implementation is determined by structure TElementSpecification. This, together
-with the dimension of the array are stored before the first element of the array.
-The dimension of the array can be obtained with the macro dw_DimA().
-
-Additionally, mechanisms are provided for copying, initializing, printing, and
-writing arrays. If the array uses non-standard mechanisms for creating or
-destroying its elements, the functions dw_CopyArray() and dw_InitializeArray()
-should not be used.
-
-=================================================================================
-Specification of functions avaiable to arrays
-
-Destructor
- void Destructor(void*)
- The destructor is called to destroy each element of the array. It is assumed
- that each element of the array is in a valid state. If the flag bit
- dw_ARRAY_POINTER set, the calling syntax from an array is
-
- Destructor(((void**)a)[i])
-
- and the destructor should free the passed pointer if it is not null.
- Otherwise the calling syntax is
-
- Destructor((void*)(((char*)a) + i*size))
-
- and the destructor must not free the passed pointer.
-
----------------------------------------------------------------------------------
-
-Default Constructor
- void DefaultConstructor(void *)
- The default constructor is called to initialize each element of the array.
- The default constructor must not fail in the since that after a call to the
- default constructor, the element is in a valid state. The calling syntax is
-
- DefaultConstructor((void*)(((char*)a) + i*size))
-
- Note that calling syntax is the same for static and pointer arrays. This
- allows memory to be allocated to pointers.
-
----------------------------------------------------------------------------------
-
-Pointer Copy Constructor
- void* PointerCopyConstructor(void*, void*)
- The pointer copy constructor is called when coping or initializing elements.
- The calling syntax is
-
- CopyConstructor(((void**)d)[i],((void**)s)[i])
-
- The pointer copy constructor returns a pointer to the destination. If the
- destination was null, an attempt to create it can be made, and if successful
- a pointer to the newly allocated destination is returned. Upon failure, a
- null pointer is returned. In the event of failure, the pointer copy
- constructor should leave the contents of the destination in a valid state.
- It is assumed that source is in a valid state.
-
----------------------------------------------------------------------------------
-
-Static Copy Constructor
- int StaticCopyConstructor(void*, void*)
- The static copy constructor is called when coping or initializing elements.
- The calling syntax is
-
- CopyConstructor((void*)(((char*)d) + i*size),(void*)(((char*)s) + i*size)
-
- The static copy constrctor should return one upon success and zero upon
- failure. In the event of failure, the static copy constructor should leave
- the contents of the destination in a state such that a call to the destructor
- will behave as expected. The source is assume to be properly initialized.
-
----------------------------------------------------------------------------------
-Print Routine
- int Print(FILE*, void*, char*)
- The print routine prints an element to the file f using the formating
- information in the character string. If the flag bit dw_ARRAY_POINTER is
- set, the calling syntax is
-
- Print(f,((void**)a)[i],format)
-
- and otherwise is
-
- Print(f,(void*)(((char*)a) + i*size),format)
-
----------------------------------------------------------------------------------
-
-Read Routine
- int Read(FILE*, void*)
- The read routine reads an element from the file f. If the flag bit
- dw_ARRAY_POINTER is set, the calling syntax is
-
- Read(f,((void**)a)[i])
-
- and otherwise is
-
- Read(f,(void*)(((char*)a) + i*size))
-
-********************************************************************************/
-
-#include <stdio.h>
-
-//=========================== TElementSpecification ===========================//
-#define dw_ARRAY_USE_MEMCPY 0x00000001
-#define dw_ARRAY_POINTER 0x00000002
-#define dw_ARRAY_ARRAY 0x00000004
-#define dw_ARRAY_DELETE_SPECS 0x00000008
-
-typedef struct
-{
- int flag;
-
- int size;
- int offset;
-
- void (*destructor)(void*);
- void (*default_constructor)(void *);
- void* (*pointer_copy_constructor)(void*, void*);
- int (*static_copy_constructor)(void*, void*);
- int (*print_routine)(FILE*, void*, char*);
- int (*read_routine)(FILE*, void*);
-
-} TElementSpecification;
-
-TElementSpecification* CreateArraySpecification_pointer(void (*destructor)(void *));
-
-extern TElementSpecification dw_IntSpecs;
-extern TElementSpecification dw_DoubleSpecs;
-extern TElementSpecification dw_FloatSpecs;
-extern TElementSpecification dw_CharSpecs;
-extern TElementSpecification dw_StringSpecs;
-extern TElementSpecification dw_ArraySpecs;
-extern TElementSpecification dw_PointerSpecs;
-//=============================================================================//
-
-//=== Macros ===
-#define dw_DimA(a) (((int*)(a))[-1])
-#define dw_SpecsA(a) (*((TElementSpecification**)(((char*)(a))-(sizeof(TElementSpecification*)+sizeof(int)))))
-#define dw_IsArrayA(a) (dw_SpecsA(a)->flag & dw_ARRAY_ARRAY)
-
-//=== Destructor ===//
-void dw_FreeArray(void* a);
-
-//=== Constructors ===//
-void* dw_CreateArray(TElementSpecification *specs, int dim);
-void* dw_CreateMultidimensionalArray(TElementSpecification *specs, int depth, int *dim);
-void* dw_CreateMultidimensionalArrayList(TElementSpecification *specs, int depth, ...);
-
-//=== Routines ===//
-void* dw_CopyArray(void* d, void* s);
-int dw_PrintArray(FILE* f, void* a, char* format);
-int dw_ReadArray(FILE* f, void* a);
-
-// Array arrays
-#define dw_CreateArray_array(dim) dw_CreateArray(&dw_ArraySpecs,dim)
-
-// Pointer arrays
-#define dw_CreateArray_pointer(dim,destructor) dw_CreateArray(CreateArraySpecification_pointer(destructor),dim)
-void DefaultPointerConstructor(void*);
-
-// String arrays
-#define dw_CreateArray_string(dim) (char**)dw_CreateArray(&dw_StringSpecs,dim)
-#define dw_CreateMultidimensionalArray_string(depth,dim) dw_CreateMultidimensionalArray(&dw_StringSpecs,depth,dim)
-void* dw_CreateMultidimensionalArrayList_string(int depth, ...);
-#define dw_CreateRectangularArray_string(row,col) (char***)dw_CreateMultidimensionalArrayList_string(2,row,col)
-#define dw_InitializeArray_string(a,x) dw_InitializeArray(a,x)
-
-// Integer arrays
-#define dw_CreateArray_int(dim) (int*)dw_CreateArray(&dw_IntSpecs,dim)
-#define dw_CreateMultidimensionalArray_int(depth,dim) dw_CreateMultidimensionalArray(&dw_IntSpecs,depth,dim)
-void* dw_CreateMultidimensionalArrayList_int(int depth, ...);
-#define dw_CreateRectangularArray_int(row,col) (int**)dw_CreateMultidimensionalArrayList_int(2,row,col)
-int dw_InitializeArray_int(void *a, int x);
-
-// Double arrays
-#define dw_CreateArray_double(dim) (double*)dw_CreateArray(&dw_DoubleSpecs,dim)
-#define dw_CreateMultidimensionalArray_double(depth,dim) dw_CreateMultidimensionalArray(&dw_DoubleSpecs,depth,dim)
-void* dw_CreateMultidimensionalArrayList_double(int depth, ...);
-#define dw_CreateRectangularArray_double(row,col) (double**)dw_CreateMultidimensionalArrayList_double(2,row,col)
-int dw_InitializeArray_double(void *a, double x);
-
-// Float arrays
-#define dw_CreateArray_float(dim) (float*)dw_CreateArray(&dw_FloatSpecs,dim)
-#define dw_CreateMultidimensionalArray_float(depth,dim) dw_CreateMultidimensionalArray(&dw_FloatSpecs,depth,dim)
-void* dw_CreateMultidimensionalArrayList_float(int depth, ...);
-#define dw_CreateRectangularArray_float(row,col) (float**)dw_CreateMultidimensionalArrayList_float(2,row,col)
-int dw_InitializeArray_float(void *a, float x);
-
-// Character arrays
-#define dw_CreateArray_char(dim) (float*)dw_CreateArray(&dw_CharSpecs,dim)
-#define dw_CreateMultidimensionalArray_char(depth,dim) dw_CreateMultidimensionalArray(&dw_CharSpecs,depth,dim)
-void* dw_CreateMultidimensionalArrayList_char(int depth, ...);
-#define dw_CreateRectangularArray_char(row,col) (char**)dw_CreateMultidimensionalArrayList_char(2,row,col)
-int dw_InitializeArray_char(void *a, char x);
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_matrix_array.c b/matlab/swz/c-code/utilities/DWCcode/arrays/dw_matrix_array.c
deleted file mode 100644
index 04ec33291761c83943d869df18dea9c6202f33cd..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_matrix_array.c
+++ /dev/null
@@ -1,251 +0,0 @@
-
-#include "dw_matrix_array.h"
-#include "dw_error.h"
-#include "bmatrix.h"
-
-#include <stdlib.h>
-
-TElementSpecification dw_VectorSpecs =
- {
- dw_ARRAY_POINTER,
- sizeof(TVector),
- sizeof(int)+sizeof(TElementSpecification*),
- (void (*)(void*))FreeVector,
- DefaultPointerConstructor,
- (void* (*)(void*,void*))EquateVector,
- NULL,
- (int (*)(FILE*,void*,char*))dw_PrintVector,
- (int (*)(FILE*,void*))dw_ReadVector
- };
-
-TElementSpecification dw_MatrixSpecs =
- {
- dw_ARRAY_POINTER,
- sizeof(TMatrix),
- sizeof(int)+sizeof(TElementSpecification*),
- (void (*)(void*))FreeMatrix,
- DefaultPointerConstructor,
- (void* (*)(void*,void*))EquateMatrix,
- NULL,
- (int (*)(FILE*,void*,char*))dw_PrintMatrix,
- (int (*)(FILE*,void*))dw_ReadMatrix
- };
-
-/******************************************************************************/
-/******************************* Initializaton ********************************/
-/******************************************************************************/
-void* dw_InitializeArray_vector(void* x, PRECISION y)
-{
- int i;
- if (!x)
- dw_Error(NULL_ERR);
- else
- if (dw_IsArrayA(x))
- for (i=dw_DimA(x)-1; i >= 0; i--) dw_InitializeArray_vector(((void**)x)[i],y);
- else
- for (i=dw_DimA(x)-1; i >= 0; i--) InitializeVector(((void**)x)[i],y);
- return x;
-}
-
-void* dw_InitializeArray_matrix(void* X, PRECISION y)
-{
- int i;
- if (!X)
- dw_Error(NULL_ERR);
- else
- if (dw_IsArrayA(X))
- for (i=dw_DimA(X)-1; i >= 0; i--) dw_InitializeArray_matrix(((void**)X)[i],y);
- else
- for (i=dw_DimA(X)-1; i >= 0; i--) InitializeMatrix(((void**)X)[i],y);
- return X;
-}
-
-/******************************************************************************/
-/****************************** Tensor Calculus *******************************/
-/******************************************************************************/
-/*
- Assumes:
- X - r x s matrix or null pointer
- Y - k dimensional array of matrices
-
- Returns:
- The the tensor product
-
- Y[0] x Y[1] x ... x Y[k-1]
-
- If X is null, then space for the tensor product is allocated. If X is not
- null, then the dimensions must match.
-
- r=RowM(Y[0]) x ... x RowM(Y[k-1])
- c=ColM(Y[0]) x ... x ColM(Y[k-1])
-
- Notes:
- Calls bMatrixTensor().
-*/
-TMatrix MatrixTensor(TMatrix X, TMatrix* Y)
-{
- int i, r=1, c=1;
- PRECISION *Z, *U, *V, *W;
- TMatrix rtrn;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- for (i=dw_DimA(Y)-1; i >= 0; i--)
- if (!Y[i])
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- else
- {
- r*=RowM(Y[i]);
- c*=ColM(Y[i]);
- }
- if (!X)
- {
- if (!(rtrn=CreateMatrix(r,c)))
- return (TMatrix)NULL;
- }
- else
- if ((r != RowM(X)) || (c != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- else
- rtrn=X;
- if (dw_DimA(Y) > 2)
- {
- if (!(Z=(PRECISION*)malloc(r*c*sizeof(PRECISION))))
- {
- if (!X) FreeMatrix(rtrn);
- return (TMatrix)NULL;
- }
- if (dw_DimA(Y) % 2)
- {
- U=Z;
- V=pElementM(rtrn);
- }
- else
- {
- U=pElementM(rtrn);
- V=Z;
- }
- i=dw_DimA(Y)-2;
- bMatrixTensor(U,pElementM(Y[i]),pElementM(Y[i+1]),RowM(Y[i]),ColM(Y[i]),RowM(Y[i+1]),
- ColM(Y[i+1]),MajorForm(rtrn),MajorForm(Y[i]),MajorForm(Y[i+1]));
- r=RowM(Y[i])*RowM(Y[i+1]);
- c=ColM(Y[i])*ColM(Y[i+1]);
- while (--i >= 0)
- {
- bMatrixTensor(V,pElementM(Y[i]),U,RowM(Y[i]),ColM(Y[i]),r,c,MajorForm(rtrn),MajorForm(Y[i]),MajorForm(rtrn));
- r*=RowM(Y[i]);
- c*=ColM(Y[i]);
- W=U;
- U=V;
- V=W;
- }
- free(Z);
- }
- else
- if (dw_DimA(Y) > 1)
- bMatrixTensor(pElementM(rtrn),pElementM(Y[0]),pElementM(Y[1]),RowM(Y[0]),ColM(Y[0]),RowM(Y[1]),
- ColM(Y[1]),MajorForm(rtrn),MajorForm(Y[0]),MajorForm(Y[1]));
- else
- EquateMatrix(rtrn,Y[0]);
- return rtrn;
-}
-
-/*
- Assumes:
- X - d dimensional vector or null pointer
- Y - k dimensional array of vectors
-
- Returns:
- The the tensor product
-
- y[0] x y[1] x ... x y[k-1]
-
- If x is null, then space for the tensor product is allocated. If x is not
- null, then the dimensions must match.
-
- d=DimV(Y[0]) x ... x DimV(Y[k-1])
-
- Notes:
- Calls bVectorTensor().
-*/
-TVector VectorTensor(TVector x, TVector* y)
-{
- int i, d=1;
- PRECISION *z, *u, *v, *w;
- TVector rtrn;
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- for (i=dw_DimA(y)-1; i >= 0; i--)
- if (!y[i])
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- else
- d*=DimV(y[i]);
- if (!x)
- {
- if (!(rtrn=CreateVector(d)))
- return (TVector)NULL;
- }
- else
- if (d != DimV(x))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- else
- rtrn=x;
- if (dw_DimA(y) > 2)
- {
- if (!(z=(PRECISION*)malloc(d*sizeof(PRECISION))))
- {
- if (!x) FreeVector(rtrn);
- return (TVector)NULL;
- }
- if (dw_DimA(y) % 2)
- {
- u=z;
- v=pElementV(rtrn);
- }
- else
- {
- u=pElementV(rtrn);
- v=z;
- }
- i=dw_DimA(y)-2;
- bVectorTensor(u,pElementV(y[i]),pElementV(y[i+1]),DimV(y[i]),DimV(y[i+1]));
- d=DimV(y[i])*DimV(y[i+1]);
- while (--i >= 0)
- {
- bVectorTensor(v,pElementV(y[i]),u,DimV(y[i]),d);
- d*=DimV(y[i]);
- w=u;
- u=v;
- v=w;
- }
- free(z);
- }
- else
- if (dw_DimA(y) > 1)
- bVectorTensor(pElementV(rtrn),pElementV(y[0]),pElementV(y[1]),DimV(y[0]),DimV(y[1]));
- else
- EquateVector(rtrn,y[0]);
- return rtrn;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_matrix_array.h b/matlab/swz/c-code/utilities/DWCcode/arrays/dw_matrix_array.h
deleted file mode 100644
index a0e3667d3d8916f16fa7ce8b33827d175443bae4..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/arrays/dw_matrix_array.h
+++ /dev/null
@@ -1,34 +0,0 @@
-
-#ifndef __MATRIX_ARRAY__
-#define __MATRIX_ARRAY__
-
-#include "matrix.h"
-#include "dw_array.h"
-
-extern TElementSpecification dw_VectorSpecs;
-extern TElementSpecification dw_MatrixSpecs;
-
-#define dw_CreateArray_vector(dim) (TVector*)dw_CreateArray(&dw_VectorSpecs,dim)
-void* dw_InitializeArray_vector(void* x, PRECISION y);
-#define dw_CreateArray_matrix(dim) (TMatrix*)dw_CreateArray(&dw_MatrixSpecs,dim)
-void* dw_InitializeArray_matrix(void* X, PRECISION y);
-
-#if (PRECISION_SIZE == 8)
- #define dw_CreateArray_scalar(dim) (double*)dw_CreateArray(&dw_DoubleSpecs,dim)
- #define dw_CreateMultidimensionalArray_scalar(depth,dim) dw_CreateMultidimensionalArray(&dw_DoubleSpecs,depth,dim)
- #define dw_CreateMultidimensionalArrayList_scalar dw_CreateMultidimensionalArrayList_double
- #define dw_CreateRectangularArray_scalar(row,col) (double**)dw_CreateMultidimensionalArrayList_double(2,row,col)
- #define dw_InitializeArray_scalar(a,x) dw_InitializeArray_double(a,x)
-#else
- #define dw_CreateArray_scalar(dim) (float*)dw_CreateArray(&dw_FloatSpecs,dim)
- #define dw_CreateMultidimensionalArray_scalar(depth,dim) dw_CreateMultidimensionalArray(&dw_FloatSpecs,depth,dim)
- #define dw_CreateMultidimensionalArrayList_scalar dw_CreateMultidimensionalArrayList_float
- #define dw_CreateRectangularArray_scalar(row,col) (float**)dw_CreateMultidimensionalArrayList_float(2,row,col)
- #define dw_InitializeArray_scalar(a,x) dw_InitializeArray_float(a,x)
-#endif
-
-/* Tensor Calculus */
-TMatrix MatrixTensor(TMatrix X, TMatrix* Y);
-TVector VectorTensor(TVector x, TVector* y);
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_ascii.c b/matlab/swz/c-code/utilities/DWCcode/ascii/dw_ascii.c
deleted file mode 100644
index 3b4aec8f52d5e82d849b53cc66278f091f171d2b..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_ascii.c
+++ /dev/null
@@ -1,446 +0,0 @@
-
-#include "dw_ascii.h"
-#include "dw_array.h"
-
-#include <stdlib.h>
-#include <string.h>
-#include <ctype.h>
-#include <stdarg.h>
-
-/*
- Attempts to open filename for reading. Returns pointer to file upon success
- and prints error message and exits upon failure. The file must exist.
-*/
-FILE *dw_OpenTextFile(char *filename)
-{
- FILE *f=fopen(filename,"rt");
- if (!f)
- {
- printf("Unable to open %s\n",filename);
- exit(0);
- }
- return (f);
-}
-
-/*
- Attempts to create filename for writing. Returns pointer to file upon success
- and prints error message and exits upon failure. If the file exists, it is
- overwritten.
-*/
-FILE *dw_CreateTextFile(char *filename)
-{
- FILE *f=fopen(filename,"wt");
- if (!f)
- {
- printf("Unable to open %s\n",filename);
- exit(0);
- }
- return (f);
-}
-
-/*
- Attempts to create filename for writing. Returns pointer to file upon success
- and prints error message and exits upon failure. The file is created if it
- does not exist and is opened with the file pointer positioned at the end of
- file if it does exist.
-*/
-FILE *dw_AppendTextFile(char *filename)
-{
- FILE *f=fopen(filename,"at");
- if (!f)
- {
- printf("Unable to open %s\n",filename);
- exit(0);
- }
- return (f);
-}
-
-/*
- Assumes:
- f : valid file pointer
- buffer : pointer to character or null pointer
- n : pointer to integer containing the length of buffer
-
- Returns:
- Pointer to null terminated string containing the characters from the file up
- to and including the terminating new line character. A null pointer return
- indicates that there was a memory error or no characters to be read. Call
- dw_GetError() to determine if a error occured.
-
- Results:
- Reads line, beginning at current position from file f Returns a pointer to
- the buffer containing the file and resets *n if necessary. The if the
- passed buffer is null or is not large enough to contain the line, buffer is
- freed and a new buffer is allocated. Because of this, the passed buffer
- must either null or allocated with malloc(), realloc(), or calloc() and the
- calling routine is responsible for eventually freeing the memory if the
- return value is not null.
-
- Notes:
- If buffer is null, then value pointed to by the pointer n is not used.
-*/
-#define SIZE_INCREMENT 1024
-char* dw_ReadLine(FILE *f, char *buffer, int *n)
-{
- char *ptr, *nbuffer;
- int i, k=0;
- if (!buffer && !(buffer=(char*)malloc(*n=SIZE_INCREMENT)))
- {
- *n=0;
- return (char*)NULL;
- }
- ptr=buffer;
- while (fgets(ptr,*n-k,f))
- if (ptr[(i=(int)strlen(ptr))-1] == '\n')
- return buffer;
- else
- if (!(nbuffer=(char*)realloc(buffer,*n+=SIZE_INCREMENT)))
- {
- free(buffer);
- *n=0;
- return (char*)NULL;
- }
- else
- ptr=(buffer=nbuffer) + (k+=i);
- if (ptr != buffer)
- return buffer;
- else
- {
- free(buffer);
- *n=0;
- return (char*)NULL;
- }
-}
-#undef SIZE_INCREMENT
-
-
-char** dw_ParseDelimitedString(char *buffer, char delimiter, int flag)
-{
- struct StringList
- {
- struct StringList *next;
- char *string;
- int length;
- } *head, *ptr;
- int k=0, n, m;
- char **v;
- if (!buffer) return (char**)NULL;
- for (head=ptr=(struct StringList*)NULL; *buffer; buffer+=buffer[n] ? n+1 : n)
- {
- if (flag & STRIP_LEADING_WHITESPACE)
- while (*buffer && (*buffer != delimiter) && isspace(*buffer)) buffer++;
- for (n=0; buffer[n] && (buffer[n] != delimiter); n++);
- if (flag & STRIP_TRAILING_WHITESPACE)
- for (m=n-1; (m >= 0) && isspace(buffer[m]); m--);
- else
- m=n-1;
- if ((m >= 0) || !(flag & REMOVE_EMPTY_FIELDS))
- {
- ptr=(struct StringList*)malloc(sizeof(struct StringList));
- ptr->string=buffer;
- ptr->length=m+1;
- ptr->next=head;
- head=ptr;
- k++;
- }
- }
- v=dw_CreateArray_string(k);
- while (--k >= 0)
- {
- v[k]=(char*)malloc(head->length+1);
- if (head->length > 0) memcpy(v[k],head->string,head->length);
- v[k][head->length]='\0';
- ptr=head;
- head=head->next;
- free(ptr);
- }
- return v;
-}
-
-/*
- Assumes
- f: valid file pointer
- delimiter: field deliniter.
- flag: one of the values defined in dw_ascii.h
-
- Returns
- One-dimensional string array of the delimited fields of the current line of
- the file f or a null pointer.
-
- Notes
- The file is read starting from the current file position. If the file
- contains no fields or there is a memory error, then a null pointer is
- returned. The delimiter character defines the fields in each row and the
- new line character defines the rows.
-*/
-char** dw_ReadDelimitedLine(FILE *f, char delimiter, int flag)
-{
- int n=0;
- char **v=(char**)NULL, *buffer=dw_ReadLine(f,(char*)NULL,&n);
- if (buffer)
- {
- v=dw_ParseDelimitedString(buffer,delimiter,flag);
- free(buffer);
- }
- return v;
-}
-
-/*
- Assumes
- f: valid file pointer or null pointer.
- filename: pointer to null terminated string or null pointer.
- delimiter: field deliniter.
- flag: one of the values defined in dw_ascii.h
-
- Returns
- Two-dimensional string array of the deliminted fields of f or a null
- pointer.
-
- Notes
- One of f and filename should be non-null. If f is non-null, the file is
- read starting from the current file position. If f is null, an attempt is
- made to open the file. If successful, the file is read from the beginning.
- If the file does not exist or contains no fields, then a null pointer is
- returned. The delimiter character defines the fields in each row and the
- new line character defines the rows.
-
-*/
-char*** dw_ReadDelimitedFile(FILE *f, char* filename, char delimiter, int flag)
-{
- struct LineList
- {
- struct LineList *next;
- char **line;
- } *head=(struct LineList*)NULL, *ptr;
- int n=0;
- char **v, ***M=(char***)NULL, *buffer=(char*)NULL;
- FILE *f_in=f ? f : fopen(filename,"rt");
- if (f_in)
- {
- while (buffer=dw_ReadLine(f_in,buffer,&n))
- if (v=dw_ParseDelimitedString(buffer,delimiter,flag))
- {
- ptr=(struct LineList*)malloc(sizeof(struct LineList));
- ptr->line=v;
- ptr->next=head;
- head=ptr;
- n++;
- }
- if (!f) fclose(f_in);
- if (n > 0)
- {
- M=(char***)dw_CreateArray_array(n);
- while (--n >= 0)
- {
- M[n]=head->line;
- ptr=head;
- head=head->next;
- free(ptr);
- }
- }
- }
- return M;
-}
-
-int dw_PrintDelimitedArray(FILE *f, void* array, char delimiter)
-{
- char format[4];
- format[0]='%';
- format[1]='s';
- format[2]=delimiter;
- format[3]='\0';
- return dw_PrintArray(f,array,format);
-}
-
-
-/*
- Assumes:
- f : valid file pointer
- delimiter : field terminator
- terminal : line terminator
- flag : determine how characters are processed
- buffer : pointer to pointer to character or null pointer
- n : pointer to integer containing the length of buffer
-
- Returns:
- 0 : memory error occured
- 1 : field read, terminated by delimiter
- 2 : field read, terminated by terminal
- 3 : field read, terminated by EOF
-
- Results:
- If necessary, memory ia reallocated. The length of this reallocated memory
- is stored in n. It is the calling routines responsibility to free the
- memory pointed to by *buffer.
-
- Notes:
- flag values
- ALLOW_QUOTED_TEXT
- If set the delimiter and terminal characters do not stop processing when
- encountered between quotes. To produce a quote in quoted text, use two
- consectutive quotes. Outside quoted text, a quote always begins quoted
- text.
-
- PRINTABLE_ONLY_IN_QUOTES
-
- PRINTABLE_ONLY
-
- STRIP_LEADING_WHITESPACE
-
- STRIP_TRAILING_WHITESPACE
-
- STRIP_WHITESPACE
-
-
-*/
-//#define INCREMENT 1024
-//int dw_ReadDelimitedField(FILE *f, int delimiter, int terminal, int flag, char **buffer, int *n)
-//{
-/* int ch; // next character read */
-/* int k=0; // position to store next char, always less than *n */
-/* int quoted=0; */
-/* int leading=(flag & STRIP_LEADING_WHITESPACE) ? 1 : 0; */
-/* char *ptr; */
-
-/* ch=fgetc(f); */
-
-/* while (ch != EOF) */
-/* { */
-/* //=== reallocate memory if necessary */
-/* if (k+1 > *n) */
-/* if (!(ptr=(char*)realloc(buffer,*n+=INCREMENT))) */
-/* { */
-/* *n-=INCREMENT; */
-/* return 0; */
-/* } */
-/* else */
-/* buffer=ptr; */
-
-/* //=== process character */
-/* if (quoted) */
-/* { */
-/* if (ch == '"') */
-/* if ((ch=fgets(f)) != '"') */
-/* { */
-/* quoted=0; */
-/* continue; */
-/* } */
-/* if (!(flag & PRINTABLE_ONLY_IN_QUOTES) || isprint(ch)) */
-/* buffer[k++]=ch; */
-/* } */
-/* else */
-/* if ((ch == delimiter) || (ch == terminal)) */
-/* break; */
-/* else */
-/* if ((ch == '"') && (flag & ALLOW_QUOTED_TEXT)) */
-/* quoted=1; */
-/* else */
-/* if (!(flag & PRINTABLE_ONLY) || isprint(ch)) */
-/* { */
-/* if ((ch == "\r") && (terminal == '\n')) */
-/* { */
-/* if ((ch=fgetc(f)) == '\n') break; */
-/* if (!leading) buffer[k++]='\r'; */
-/* continue; */
-/* } */
-/* if (leading) */
-/* if (isspace(ch)) */
-/* { */
-/* ch=fgetc(f); */
-/* continue; */
-/* } */
-/* else */
-/* leading=0; */
-/* buffer[k++]=ch; */
-/* } */
-
-/* ch=fgets(f); */
-/* } */
-
-/* buffer[k]='\0'; */
-
-/* return (ch == EOF) ? 3 : (ch == terminal) ? 2 : 1; */
-//}
-//#undef INCREMENT
-
-/*
- Returns 1 if the null terminated string id is found at the beginning of a line
- in the file and 0 otherwise. The file pointer is set to the line immediately
- after the line containing id. The search starts at the current position of
- the file. If id is not found, then the file is rewound and the search is
- continued until the initial file position is passed.
-*/
-int dw_SetFilePosition(FILE *f, char *id)
-{
- char *buffer=(char*)NULL;
- int m, n, pos;
- if ((n=(int)strlen(id)) > 0)
- {
- pos=ftell(f);
- while (buffer=dw_ReadLine(f,buffer,&m))
- if (!memcmp(buffer,id,n))
- {
- free(buffer);
- return 1;
- }
- if (pos > 0)
- {
- rewind(f);
- while ((ftell(f) < pos) && (buffer=dw_ReadLine(f,buffer,&m)))
- if (!memcmp(buffer,id,n))
- {
- free(buffer);
- return 1;
- }
- if (buffer) free(buffer);
- }
- }
- return 0;
-}
-
-/*
- Returns 1 if the null terminated string id is found at the beginning of a line
- in the file and 0 otherwise. The file pointer is set to the line immediately
- after the line containing id. Compares a maximum of 1023 characters of id.
- The file is not rewound so that the search starts at the current position.
-*/
-int dw_SetFilePositionNoRewind(FILE *f, char *id)
-{
- char buffer[1024], ch;
- int n=(int)strlen(id);
- if (n > 1023) n=1023;
- while (fgets(buffer,1024,f))
- {
- if (buffer[strlen(buffer)-1] != '\n')
- do
- ch=fgetc(f);
- while ((ch != '\n') && (ch != EOF));
- if (!memcmp(buffer,id,n)) return 1;
- }
- return 0;
-}
-
-
-int dw_SetFilePositionBySection(FILE *f, int n, ...)
-{
- char *arg;
- int i;
- va_list ap;
- rewind(f);
- va_start(ap,n);
- for (i=0; i < n; i++)
- if (!(arg=va_arg(ap,char*)) || !dw_SetFilePositionNoRewind(f,arg))
- {
- va_end(ap);
- return 0;
- }
- va_end(ap);
- return 1;
-}
-
-char* dw_DuplicateString(char *buffer)
-{
- char *rtrn=(char*)NULL;
- if (buffer && (rtrn=(char*)malloc(strlen(buffer)+1))) strcpy(rtrn,buffer);
- return rtrn;
-}
diff --git a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_ascii.h b/matlab/swz/c-code/utilities/DWCcode/ascii/dw_ascii.h
deleted file mode 100644
index fcbd26edd72b85d2c1969d3e8b78428a9b689894..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_ascii.h
+++ /dev/null
@@ -1,34 +0,0 @@
-
-
-#ifndef __DW_ASCII_ROUTINES__
-#define __DW_ASCII_ROUTINES__
-
-#include <stdio.h>
-
-// Flag codes. See ParseDelimitedString() for explanation.
-#define REMOVE_EMPTY_FIELDS 0x00000001
-#define ALLOW_QUOTED_TEXT 0x00000002
-#define STRIP_LEADING_WHITESPACE 0x00000004
-#define STRIP_TRAILING_WHITESPACE 0x00000008
-#define STRIP_WHITESPACE 0x0000000c
-
-FILE *dw_OpenTextFile(char *filename);
-FILE *dw_CreateTextFile(char *filename);
-FILE *dw_AppendTextFile(char *filename);
-
-int dw_SetFilePosition(FILE *f, char *id);
-int dw_SetFilePositionNoRewind(FILE *f, char *id);
-int dw_SetFilePositionBySection(FILE *f, int n, ...);
-
-char* dw_ReadLine(FILE *f, char *buffer, int *n);
-char** dw_ParseDelimitedString(char *buffer, char delimiter, int flag);
-char** dw_ReadDelimitedLine(FILE *f, char delimiter, int flag);
-char*** dw_ReadDelimitedFile(FILE *f, char* filename, char delimiter, int flag);
-int dw_PrintDelimitedArray(FILE *f, void* array, char delimiter);
-
-//int dw_ReadDelimitedField(FILE *f, char **buffer, int *n);
-int dw_ReadDelimitedField(FILE *f, int delimiter, int terminal, int flag, char **buffer, int *n);
-
-char* dw_DuplicateString(char *buffer);
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_parse_cmd.c b/matlab/swz/c-code/utilities/DWCcode/ascii/dw_parse_cmd.c
deleted file mode 100644
index e556fdea46587a0b9f90895f40df7a564dd8b8c1..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_parse_cmd.c
+++ /dev/null
@@ -1,256 +0,0 @@
-
-#include "dw_parse_cmd.h"
-
-#include <stdlib.h>
-#include <string.h>
-#include <ctype.h>
-
-#define ARGUMENT_ID '-'
-
-/*
- A floating point number is of the form
-
- [white space][+/-]digits[.[digits]][E/e[+/-]digits]white space/null character
-
- or
-
- [white space][+/-].digits[E/e[+/-]digits]white space/null character
-
- where characters in square brackets are optional.
-
- Returns one if valid floating point number and zero otherwise.
-*/
-int dw_IsFloat(char *buffer)
-{
- int i=0;
-
- if (!buffer) return 0;
-
- /* Strip leading white space */
- while (isspace(buffer[i])) i++;
-
- /* Mantissa OK? */
- if ((buffer[i] == '+') || (buffer[i] == '-')) i++;
- if (isdigit(buffer[i]))
- {
- while (isdigit(buffer[++i]));
- if ((buffer[i] == '.'))
- while (isdigit(buffer[++i]));
- }
- else
- if ((buffer[i] == '.'))
- if (isdigit(buffer[++i]))
- while (isdigit(buffer[++i]));
- else
- return 0;
- else
- return 0;
-
- /* Is exponent OK? */
- if ((buffer[i] == 'e') || (buffer[i] == 'E'))
- {
- if ((buffer[++i] == '+') || (buffer[i] == '-')) i++;
- if (isdigit(buffer[i]))
- while (isdigit(buffer[++i]));
- else
- return 0;
- }
-
- /* Is end of string or trailing white space */
- if (buffer[i] && !isspace(buffer[i])) return 0;
-
- return 1;
-}
-
-/*
- Integers are of the form
-
- [white space][+/-]digits[.]white space/null character
-
- where characters in square brackets are optional.
-
- Returns one if valid integer and zero otherwise.
-*/
-int dw_IsInteger(char *buffer)
-{
- int i=0;
-
- if (!buffer) return 0;
-
- /* Strip leading white space */
- while (isspace(buffer[i])) i++;
-
- /* Leading sign */
- if ((buffer[i] == '+') || (buffer[i] == '-')) i++;
-
- /* At least one digits possibly followed by decimal point */
- if (isdigit(buffer[i]))
- {
- while (isdigit(buffer[++i]));
- if ((buffer[i] == '.')) i++;
- }
- else
- return 0;
-
- /* Is end of string or trailing white space */
- if (buffer[i] && !isspace(buffer[i])) return 0;
-
- return 1;
-}
-
-/*
- Searches args for a leading ARGUMENT_ID followed by the character opt. Returns
- the index if found and -1 otherwise.
-*/
-int dw_FindArgument(int nargs, char **args, char opt)
-{
- int i;
- for (i=nargs-1; i >= 0; i--)
- if ((args[i][0] == ARGUMENT_ID) && (args[i][1] == opt)) break;
- return i;
-}
-
-/*
- Searches for the last argument whose leading character is ARGUMENT_ID
- followed by the character opt. If such an argument is not found, then the
- integer def is returned. If such an argument is found then:
-
- Case 1: The string length of the found argument is greater than 2.
- If the characters following the second form a valid integer, then this
- integer is returned. Otherwise the integer def is returned.
-
- Case 2: The string length of the found argument is equal to 2.
- If there is an i+1 argument and its characters form a valid integer, then
- this integer is returned. Otherwise the integer def is returned.
-*/
-int dw_ParseInteger(int nargs, char **args, char opt, int def)
-{
- int i=dw_FindArgument(nargs,args,opt);
- if (i != -1)
- if (dw_IsInteger(args[i]+2))
- return atoi(args[i]+2);
- else
- if ((i+1 < nargs) && dw_IsInteger(args[i+1])) return atoi(args[i+1]);
- return def;
-}
-
-/*
- Searches for the last argument whose leading character is ARGUMENT_ID
- followed by the character opt. If such an argument is not found, then the
- double def is returned. If such an argument is found then:
-
- Case 1: The string length of the found argument is greater than 2.
- If the characters following the second form a valid floating point number,
- then this value is returned. Otherwise def is returned.
-
- Case 2: The string length of the found argument is equal to 2.
- If there is an i+1 argument and its characters form a valid floating point
- number, then this value is returned. Otherwise def is returned.
-*/
-double dw_ParseFloating(int nargs, char **args, char opt, double def)
-{
- int i=dw_FindArgument(nargs,args,opt);
- if (i != -1)
- if (dw_IsFloat(args[i]+2))
- return atof(args[i]+2);
- else
- if ((i+1 < nargs) && dw_IsFloat(args[i+1])) return atof(args[i+1]);
- return def;
-}
-
-
-/*
- Searches for the last argument whose leading character is ARGUMENT_ID
- followed by the character opt. If such an argument is not found, then the
- pointer def is returned. If such an argument is found then:
-
- Case 1: The string length of the found argument is greater than 2.
- A pointer to the found argument plus two is returned.
-
- Case 2: The string length of the found argument is equal to 2.
- If there is an i+1 argument then a pointer to this argument is returned.
- Otherwise the integer def is returned.
-*/
-char* dw_ParseString(int nargs, char **args, char opt, char *def)
-{
- int i=dw_FindArgument(nargs,args,opt);
- if (i != -1)
- if (args[i][2])
- return args[i]+2;
- else
- if (i+1 < nargs) return args[i+1];
- return def;
-}
-
-/*
- Searches args for a leading ARGUMENT_ID followed by the string opt. Returns
- the index if found and -1 otherwise.
-*/
-int dw_FindArgument_String(int nargs, char **args, char *opt)
-{
- int i;
- for (i=nargs-1; i >= 0; i--)
- if ((args[i][0] == ARGUMENT_ID) && !strcmp(args[i]+1,opt)) break;
- return i;
-}
-
-/*
- Searches for the last argument whose leading character is a ARGUMENT_ID
- followed by the string opt. If such an argument is not found, then the
- integer def is returned. If such an argument is found then:
-
- Case 1: The string length of the found argument is greater than 1+strlen(opt).
- If the characters following the second form a valid integer, then this
- integer is returned. Otherwise the integer def is returned.
-
- Case 2: The string length of the found argument is equal to 1+strlen(opt).
- If there is an i+1 argument and its characters form a valid integer, then
- this integer is returned. Otherwise the integer def is returned.
-*/
-int dw_ParseInteger_String(int nargs, char **args, char *opt, int def)
-{
- int i=dw_FindArgument_String(nargs,args,opt);
- if ((i != -1) && (i+1 < nargs) && dw_IsInteger(args[i+1])) return atoi(args[i+1]);
- return def;
-}
-
-/*
- Searches for the last argument whose leading character is ARGUMENT_ID
- followed by the string opt. If such an argument is not found, then the
- double def is returned. If such an argument is found then:
-
- Case 1: The string length of the found argument is greater than 1+strlen(opt).
- If the characters following the second form a valid floating point number,
- then this value is returned. Otherwise def is returned.
-
- Case 2: The string length of the found argument is equal to 1+strlen(opt).
- If there is an i+1 argument and its characters form a valid floating point
- number, then this value is returned. Otherwise def is returned.
-*/
-double dw_ParseFloating_String(int nargs, char **args, char *opt, double def)
-{
- int i=dw_FindArgument_String(nargs,args,opt);
- if ((i != -1) && (i+1 < nargs) && dw_IsFloat(args[i+1])) return atof(args[i+1]);
- return def;
-}
-
-
-/*
- Searches for the last argument whose leading character is ARGUMENT_ID
- followed by the string opt. If such an argument is not found, then the
- pointer def is returned. If such an argument is found then:
-
- Case 1: The string length of the found argument is greater than 1+strlen(opt).
- A pointer to the found argument plus two is returned.
-
- Case 2: The string length of the found argument is equal to 1+strlen(opt).
- If there is an i+1 argument, then a pointer to this argument is returned.
- Otherwise the string def is returned.
-*/
-char* dw_ParseString_String(int nargs, char **args, char *opt, char *def)
-{
- int i=dw_FindArgument_String(nargs,args,opt);
- if ((i != -1) && (i+1 < nargs)) return args[i+1];
- return def;
-}
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_parse_cmd.h b/matlab/swz/c-code/utilities/DWCcode/ascii/dw_parse_cmd.h
deleted file mode 100644
index 531e64737ef5f59ef2f62f9e13a7d5cf575dbdd8..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/ascii/dw_parse_cmd.h
+++ /dev/null
@@ -1,24 +0,0 @@
-
-#ifndef __PARSE_COMMAND_LINE__
-#define __PARSE_COMMAND_LINE__
-
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-
-int dw_FindArgument(int nargs, char **args, char opt);
-int dw_ParseInteger(int nargs, char **args, char opt, int def);
-double dw_ParseFloating(int nargs, char **args, char opt, double def);
-char* dw_ParseString(int nargs, char **args, char opt, char *def);
-
-int dw_FindArgument_String(int nargs, char **args, char *opt);
-int dw_ParseInteger_String(int nargs, char **args, char *opt, int def);
-double dw_ParseFloating_String(int nargs, char **args, char *opt, double def);
-char* dw_ParseString_String(int nargs, char **args, char *opt, char *def);
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/error/dw_error.c b/matlab/swz/c-code/utilities/DWCcode/error/dw_error.c
deleted file mode 100644
index d0a843c7fe508b3df67185338e18b0d948c4876c..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/error/dw_error.c
+++ /dev/null
@@ -1,206 +0,0 @@
-
-#include "dw_error.h"
-#include <stdlib.h>
-#include <string.h>
-
-#define ERROR_MESSAGE_BUFFER_LENGTH 256
-static int ERROR=NO_ERR;
-static char ERROR_MESSAGE[ERROR_MESSAGE_BUFFER_LENGTH]="";
-static int TerminalErrors=ALL_ERRORS;
-static int VerboseErrors=ALL_ERRORS;
-static FILE* f_err=(FILE*)NULL;
-
-/*
- Returns the value of the current error flag.
-*/
-int dw_GetError(void)
-{
- return ERROR;
-}
-
-/*
- Returns pointer to current error message. This buffer should not be modified
- or freed.
-*/
-char* dw_GetErrorMessage(void)
-{
- return ERROR_MESSAGE;
-}
-
-/*
- Clears the error flag and returns the value of the previous flag. This is the
- most efficient way to clear the error flag and message.
-*/
-int dw_ClearError(void)
-{
- int rtrn=ERROR;
- ERROR=NO_ERR;
- ERROR_MESSAGE[0]='\0';
- return rtrn;
-}
-
-
-/*
- Sets the error flag to err, the error message to msg and returns the value of
- the previous flag. If the null terminated string msg is longer than 255
- characters, only the first 255 characters are used. If msg is null, then a
- predefined error message is used.
-*/
-int dw_SetError(int err, char *msg)
-{
- int rtrn=ERROR;
- if (msg)
- switch (ERROR=err)
- {
- case MEM_ERR:
- case FILE_ERR:
- case PARSE_ERR:
- case FLOAT_ERR:
- case NULL_ERR:
- case ARG_ERR:
- case ITERATION_ERR:
- case NOT_IMPLEMENTED_ERR:
- case SIZE_ERR:
- case SING_ERR:
- case POSDEF_ERR:
- case BLAS_LAPACK_ERR:
- case USER_ERR:
- strncpy(ERROR_MESSAGE,msg,ERROR_MESSAGE_BUFFER_LENGTH-1);
- ERROR_MESSAGE[ERROR_MESSAGE_BUFFER_LENGTH-1]='\0';
- break;
- case NO_ERR:
- ERROR_MESSAGE[0]='\0';
- break;
- default:
- ERROR=UNKNOWN_ERR;
- strcpy(ERROR_MESSAGE,"Unknown error.");
- break;
- }
- else
- switch (ERROR=err)
- {
- case MEM_ERR:
- strcpy(ERROR_MESSAGE,"Out of memory.");
- break;
- case FILE_ERR:
- strcpy(ERROR_MESSAGE,"File operation error.");
- break;
- case PARSE_ERR:
- strcpy(ERROR_MESSAGE,"Error parsing data.");
- break;
- case FLOAT_ERR:
- strcpy(ERROR_MESSAGE,"Floating point error.");
- break;
- case NULL_ERR:
- strcpy(ERROR_MESSAGE,"Unexpected null pointer encountered.");
- break;
- case ARG_ERR:
- strcpy(ERROR_MESSAGE,"Argument error.");
- break;
- case ITERATION_ERR:
- strcpy(ERROR_MESSAGE,"Maximum iteration limit exceeded.");
- break;
- case NOT_IMPLEMENTED_ERR:
- strcpy(ERROR_MESSAGE,"Feature not yet implemented.");
- break;
- case SIZE_ERR:
- strcpy(ERROR_MESSAGE,"Matrices/vectors not conformable.");
- break;
- case SING_ERR:
- strcpy(ERROR_MESSAGE,"Singular matrix.");
- break;
- case POSDEF_ERR:
- strcpy(ERROR_MESSAGE,"Matrix not positive definite.");
- break;
- case BLAS_LAPACK_ERR:
- strcpy(ERROR_MESSAGE,"Blas/Lapack error.");
- break;
- case USER_ERR:
- strcpy(ERROR_MESSAGE,"Undocumented error.");
- break;
- case NO_ERR:
- ERROR_MESSAGE[0]='\0';
- break;
- default:
- ERROR=UNKNOWN_ERR;
- strcpy(ERROR_MESSAGE,"Unknown error.");
- break;
- }
- if (VerboseErrors & ERROR) fprintf(f_err ? f_err : stderr,"%s\n",ERROR_MESSAGE);
- if (TerminalErrors & ERROR) exit(ERROR);
- return rtrn;
-}
-
-/*
- Sets the error flag and to err, sets the error message to the predefined error
- message, and returns the value of the previous error flag.
-*/
-int dw_Error(int err)
-{
- return dw_SetError(err,(char*)NULL);
-}
-
-/*
- Sets the error flag and to USER_ERR, sets the error message to msg, and
- returns the value of the previous error flag.
-*/
-int dw_UserError(char *msg)
-{
- return dw_SetError(USER_ERR,msg);
-}
-
-/*
- Sets errors which terminate program. The integer err should be a combination
- of the error flags defined in dw_error.h.
-*/
-int dw_SetTerminalErrors(int err)
-{
- int rtrn=TerminalErrors;
- TerminalErrors=err & ALL_ERRORS;
- return rtrn;
-}
-
-/*
- Returns the current terminal errors.
-*/
-int dw_GetTerminalErrors(void)
-{
- return TerminalErrors;
-}
-
-/*
- Sets errors which causes program to print a error message to f_err. The
- integer err should be a combination of the error flags defined in dw_error.h.
-*/
-int dw_SetVerboseErrors(int err)
-{
- int rtrn=VerboseErrors;
- VerboseErrors=err & ALL_ERRORS;
- return rtrn;
-}
-
-/*
- Returns the current verbose errors.
-*/
-int dw_GetVerboseErrors(void)
-{
- return VerboseErrors;
-}
-
-/*
- Sets the file to which errors messages will be sent. The file pointer f
- must either be the null pointer or a valid printer to an open file. Passing a
- null pointer has the same effect as redirecting output to stderr. To suppress
- output of error messages, call dw_SetVerboseErrors(). Returns a pointer to
- current error message file. When redirecting the error message, if is
- critical that the error message file pointer point to an open file and that
- this file not be closed as long as it is the current error message file.
-*/
-FILE* dw_SetErrorMessageFile(FILE *f)
-{
- FILE *rtrn=f_err;
- f_err=f ? f : stderr;
- return rtrn;
-}
-
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/error/dw_error.h b/matlab/swz/c-code/utilities/DWCcode/error/dw_error.h
deleted file mode 100644
index f869efa832b3e06111eff0d046c37da518575cf6..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/error/dw_error.h
+++ /dev/null
@@ -1,42 +0,0 @@
-
-#ifndef __ERROR_HANDLING__
-#define __ERROR_HANDLING__
-
-#include <stdio.h>
-
-#define NO_ERR 0x00000000
-#define ALL_ERRORS 0x000F03FF
-
-//=== General Errors ===
-#define MEM_ERR 0x00000001
-#define FILE_ERR 0x00000002
-#define PARSE_ERR 0x00000004
-#define FLOAT_ERR 0x00000008
-#define NULL_ERR 0x00000010
-#define ARG_ERR 0x00000020
-#define ITERATION_ERR 0x00000040
-#define USER_ERR 0x00000080
-#define NOT_IMPLEMENTED_ERR 0x00000100
-#define UNKNOWN_ERR 0x00000200
-
-
-//=== Matrix Errors ===
-#define SIZE_ERR 0x00010000
-#define SING_ERR 0x00020000
-#define POSDEF_ERR 0x00040000
-#define BLAS_LAPACK_ERR 0x00080000
-
-//=== Error Routines ===
-int dw_GetError(void);
-char* dw_GetErrorMessage(void);
-int dw_ClearError(void);
-int dw_SetError(int err, char *msg);
-int dw_Error(int err);
-int dw_UserError(char *msg);
-int dw_SetVerboseErrors(int errors);
-int dw_GetVerboseErrors(void);
-int dw_SetTerminalErrors(int errors);
-int dw_GetTerminalErrors(void);
-FILE* dw_SetMessageFile(FILE *f);
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/blas_lapack.h b/matlab/swz/c-code/utilities/DWCcode/matrix/blas_lapack.h
deleted file mode 100644
index d3998606d3aebae5719ea03eb0758c35872d133b..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/blas_lapack.h
+++ /dev/null
@@ -1,90 +0,0 @@
-
-#ifndef __BLAS_LAPACK__
-#define __BLAS_LAPACK__
-
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-
-/* Linux defines */
-#define sscal sscal_
-#define saxpy saxpy_
-#define sgemm sgemm_
-#define sgetrf sgetrf_
-#define sgesdd sgesdd_
-#define sgesvd sgesvd_
-#define sgetrf sgetrf_
-#define sorgqr sorgqr_
-#define sgelqf sgelqf_
-#define sorglq sorglq_
-#define sgges sgges_
-#define stgsen stgsen_
-#define stgexc stgexc_
-
-#define dscal dscal_ // Blas scalar times vector
-#define daxpy daxpy_ // Blas vector plus scalar times vector
-#define dgemm dgemm_ // Blas matrix multiplication
-#define dgetrf dgetrf_
-#define dgesdd dgesdd_ // SVD decomposition (divide and conquer)
-#define dgesvd dgesvd_ // SVD decomposition (QR)
-#define dgetrf dgetrf_ // LU decomposition
-#define dgeqrf dgeqrf_ // QR decomposition
-#define dorgqr dorgqr_ // Forms orthogonal matrix from Housholder matrices created by dgeqrf
-#define dgelqf dgelqf_ // LQ decompostion
-#define dorglq dorglq_ // Forms orthogonal matrix from Housholder matrices created by dgeqrf
-#define dgges dgges_ // Generalized Schur decomposition
-#define dtgsen dtgsen_ // Reorders generalized Schur decomposition
-#define dtgexc dtgexc_ // Reorders generalized Schur decomposition
-
-#define dsyev dsyev_
-#define dgeev dgeev_
-#define dpotrf dpotrf_
-#define dpotri dpotri_
-/*******************************************************************************/
-
-
-/* cblas defines *
-#define cblas_daxpy daxpy
-/*******************************************************************************/
-
-
-/* Window defines */
-void sscal(int *n, float *alpha, float *x, int *incx);
-void saxpy(int *n, float *alpha, float *x, int *incx, float *y, int *incy);
-void sgemm(char *transa, char *transb, int *m, int *n, int *k, float *alpha, float *a, int *lda, float *b, int *ldb, float *beta, float *c, int *ldc);
-void sgetrf(int *M, int *N, float *A, int *LDA, int *IPIV, int *INFO);
-void sgesdd(char *jobz, int *m, int *n, float *a, int *lda, float *s, float *u, int *ldu, float *vt, int *ldvt, float *work, int *lwork, int *iwork, int *info);
-void sgesvd(char *jobu, char *jobvt, int *m, int *n, float *a, int *lda, float *s, float *u, int *ldu, float *vt, int *ldvt, float *work, int *lwork, int *info);
-void sgeqrf(int *M, int *N, float *A, int *LDA, float *TAU, float *WORK, int *LWORK, int *INFO);
-void sorgqr(int *M, int *N, int *K, float *A, int *LDA, float *TAU, float *WORK, int *LWORK, int *INFO);
-void sgelqf(int *M, int *N, float *A, int *LDA, float *TAU, float *WORK, int *LWORK, int *INFO);
-void sorglq(int *M, int *N, int *K, float *A, int *LDA, float *TAU, float *WORK, int *LWORK, int *INFO);
-void sgges(char *jobvsl, char *jobvsr, char *sort, void *selctg, int *n, float *a, int *lda, float *b, int *ldb, int *sdim, float *alphar, float *alphai, float *beta, float *vsl, int *ldvsl, float *vsr, int *ldvsr, float *work, int *lwork, void *bwork, int *info);
-void stgsen(int *ijob, void *wantq, void *wantz, void *select, int *n, float *a, int *lda, float *b, int *ldb, float *alphar, float *alphai, float *beta, float *q, int *ldq, float *z, int *ldz, int *m, float *pl, float *pr, float *dif, float *work, int *lwork, int *iwork, int *liwork, int *info);
-void stgexc(void *wantq, void *wantz, int *n, float *a, int *lda, float *b, int *ldb, float *q, int *ldq, float *z, int *ldz, int *ifst, int *ilst, float *work, int *lwork, int *info);
-
-void dscal(int*,double*,double*,int*);
-void daxpy(int*,double*,double*,int*,double*,int*);
-void dgemm(char*,char*,int*,int*,int*,double*,double*,int*,double*,int*,double*,double*,int*);
-void dgetrf(int*,int*,double*,int*,int*,int*);
-void dgesdd(char*,int*,int*,double*,int*,double*,double*,int*,double*,int*,double*,int*,int*,int*);
-void dgesvd(char*,char*,int*,int*,double*,int*,double*,double*,int*,double*,int*,double*,int*,int*);
-void dgeqrf(int*,int*,double*,int*,double*,double*,int*,int*);
-void dorgqr(int*,int*,int*,double*,int*,double*,double*,int*,int*);
-void dgelqf(int*,int*,double*,int*,double*,double*,int*,int*);
-void dorglq(int*,int*,int*,double*,int*,double*,double*,int*,int*);
-void dgges(char*,char*,char*,void*,int*,double*,int*,double*,int*,int*,double*,double*,double*,double*,int*,double*,int*,double*,int*,void*,int*);
-void dtgsen(int*,void*,void*,void*,int*,double*,int*,double*,int*,double*,double*,double*,double*,int*,double*,int*,int*,double*,double*,double*,double*,int*,int*,int*,int*);
-void dtgexc(void*,void*,int*,double*,int*,double*,int*,double*,int*,double*,int*,int*,int*,double*,int*,int*);
-void dsyev(char*,char*,int*,double*,int*,double*,double*,int*,int*);
-void dgeev(char*,char*,int*,double*,int*,double*,double*,double*,int*,double*,int*,double*,int*,int*);
-void dpotrf(char*,int*,double*,int*,int*);
-void dpotri(char*,int*,double*,int*,int*);
-/*******************************************************************************/
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix.c b/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix.c
deleted file mode 100644
index c16bc6e9e00a84c27b49bd9e964735cae2e12cbb..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix.c
+++ /dev/null
@@ -1 +0,0 @@
-#include "bmatrix_blas_lapack.c"
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix.h b/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix.h
deleted file mode 100644
index 0249c548e2524e18887cc30c0f3f2c46d5dbf355..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix.h
+++ /dev/null
@@ -1,67 +0,0 @@
-
-#ifndef __BMATRIX__
-#define __BMATRIX__
-
-#include "prcsn.h"
-
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-
-/* Unary Operators */
-int bNegative(PRECISION *x, PRECISION *y, int m);
-int bAbs(PRECISION *x, PRECISION *y, int m);
-int bTranspose(PRECISION *x, PRECISION *y, int m, int n, int t);
-int bTransposeInPlace(PRECISION *x, int m);
-
-/* Addition */
-int bAdd(PRECISION *x, PRECISION *y, PRECISION *z, int m);
-int bSubtract(PRECISION *x, PRECISION *y, PRECISION *z, int m);
-int bLinearUpdateScalar(PRECISION *x, PRECISION *y, PRECISION a, int m);
-int bLinearCombination(PRECISION *x, PRECISION a, PRECISION *y, PRECISION b, PRECISION *z, int m);
-int bMatrixAdd(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int xt, int yt, int zt);
-int bMatrixSubtract(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int xt, int yt, int zt);
-int bMatrixLinearCombination(PRECISION *x, PRECISION a, PRECISION *y, PRECISION b,PRECISION *z, int m, int n, int xt, int yt, int zt);
-
-/* Multiplication */
-int bMultiply(PRECISION *x, PRECISION *y, PRECISION s, int m);
-int bMatrixMultiply(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int p, int xt, int yt, int zt);
-
-/* LU Decomposition */
-int bLU(int *p, PRECISION *x, int m, int n, int xt);
-int bSolveTriangular(PRECISION *x, PRECISION *b, int m, int n,int u, int xt, int bt);
-int bSolveUnitTriangular(PRECISION *x, PRECISION *b, int m, int n, int u, int xt, int bt);
-
-/* QR Decompositions */
-int bQR(PRECISION *Q, PRECISION *R, PRECISION *X, int m, int n, int q, int qt, int rt, int xt);
-
-/* Singular Value Decomposition */
-int bSVD(PRECISION *U, PRECISION *d, PRECISION *V, PRECISION *A, int m, int n, int ut, int vt, int at);
-int bSVD_new(PRECISION *U, PRECISION *d, PRECISION *V, PRECISION *A, int m, int n, int ut, int vt, int at, int compact);
-
-/* Generalize Schur Decomposition */
-int bQZ_real(PRECISION *Q, PRECISION *Z, PRECISION *S, PRECISION *T, PRECISION *A, PRECISION *B, int n, int qt, int zt, int st, int tt, int at, int bt,
- PRECISION *alpha_r, PRECISION *alpha_i, PRECISION *beta);
-
-/* Cholesky Decompositions */
-int bCholesky(PRECISION *X, int m, int u, int t);
-
-/* Permutation Routines */
-int bPermutationMultiply(int *p, PRECISION *y, int m, int n, int q, int pt, int yt);
-int bPermutation(PRECISION *x, int *p, int m, int q, int t);
-
-/* Tensor Calculus */
-int bMatrixTensor(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int r, int s, int xt, int yt, int zt);
-int bVectorTensor(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n);
-
-//int bQRPivot_R(PRECISION *R, int *p, int m, int n);
-//int bQRPivot_QR(PRECISION *Q, PRECISION *R, int *p, int m, int n);
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
-
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix_blas_lapack.c b/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix_blas_lapack.c
deleted file mode 100644
index 8ed88ab53deb8bfd7840a031cbe2eb74f2d907c8..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix_blas_lapack.c
+++ /dev/null
@@ -1,2330 +0,0 @@
-
-#include "bmatrix.h"
-#include "dw_error.h"
-
-#include <math.h>
-#include <stdlib.h>
-#include <memory.h>
-#include <string.h>
-
-/********************/
-#include "blas_lapack.h"
-/********************/
-
-/********************
-#include "mkl.h"
-/********************/
-
-/******************************************************************************/
-/***************************** Uniary Operations ******************************/
-/******************************************************************************/
-/*
- Assumes:
- x : n-vector
- y : n-vector
- n : positive
-
- Results:
- x[i] = -y[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x and y do not have to be distinct
-*/
-int bNegative(PRECISION *x, PRECISION *y, int n)
-{
- while (--n >= 0) x[n]=-y[n];
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : n-vector
- y : n-vector
- n : positive
-
- Results:
- x[i] = fabs(y[i]) for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x and y do not have to be distinct
-*/
-int bAbs(PRECISION *x, PRECISION *y, int n)
-{
- while (--n >= 0) x[n]=fabs(y[n]);
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : array of length m*n
- y : array of length m*n
- m : positive
- n : positive
- t : 0 or 1
-
-
- Results:
- x y
- t (n x m) (m x n) results
- -----------------------------------------
- 0 row major row major x = y'
- 1 col major col major x = y'
-
- or
- x y
- t (m x n) (m x n) results
- -----------------------------------------
- 0 col major row major x = y
- 1 row major col major x = y
-
- or
- x y
- t row major row major results
- -----------------------------------------
- 0 n x m m x n x = y'
- 1 m x n n x m x = y'
- or
- x y
- t col major col major results
- -----------------------------------------
- 0 m x n n x m x = y'
- 1 n x m m x n x = y'
-
-*/
-int bTranspose(PRECISION *x, PRECISION *y, int m, int n, int t)
-{
- int i, j, k;
- if (t)
- for (i=k=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; j-=m)
- x[k--]=y[j];
- else
- for (i=k=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; j-=n)
- x[k--]=y[j];
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : array of length m*m
- m : positive
-
- Results:
- x = y'
-
- Notes:
- The major format (row or column) does not matter.
-*/
-int bTransposeInPlace(PRECISION *x, int m)
-{
- PRECISION tmp;
- int i, j;
- for (j=m*m-2; j > 0; j+=i-1)
- for (i=j-m+1; i >= 0; j--, i-=m)
- {
- tmp=x[i];
- x[i]=x[j];
- x[j]=tmp;
- }
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-/******************************************************************************/
-/***************************** Addition Routines ******************************/
-/******************************************************************************/
-/*
- Assumes:
- x : n-vector
- y : n-vector
- z : n-vector
- n : positive
-
- Results:
- x[i] = y[i] + z[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bAdd(PRECISION *x, PRECISION *y, PRECISION *z, int n)
-{
- while (--n >= 0) x[n]=y[n]+z[n];
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : n-vector
- y : n-vector
- z : n-vector
- n : positive
-
- Results
- x[i] = y[i] - z[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bSubtract(PRECISION *x, PRECISION *y, PRECISION *z, int n)
-{
- while (--n >= 0) x[n]=y[n]-z[n];
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : scalar array of dimension at least m
- y : scalar array of dimension at least m
- a : scalar
- m : positive
-
- Results:
- x = x + a*y
-
- Returns:
- NO_ERR
-
- Notes:
- x and y should be distinct.
-*/
-int bLinearUpdateScalar(PRECISION *x, PRECISION *y, PRECISION a, int m)
-{
- int inc=1;
-#if (PRECISION_SIZE == 4)
- saxpy(&m,&a,y,&inc,x,&inc);
-#else
- daxpy(&m,&a,y,&inc,x,&inc);
-#endif
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : m*n
- y : m*n
- z : m*n
- m : positive
- n : positive
- xt: 0 or 1
- yt: 0 or 1
- zt: 0 or 1
-
- Results:
- x = y + z
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bMatrixAdd(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int xt, int yt, int zt)
-{
- int i, j, k, s;
- if (xt == yt)
- if (yt == zt)
- for (k=m*n-1; k >= 0; k--) x[k]=y[k]+z[k];
- else
- for (s=zt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[k]+z[j];
- else
- if (yt == zt)
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]+z[j];
- else
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]+z[k];
- return NO_ERR;
-}
-
-int bMatrixSubtract(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int xt, int yt, int zt)
-{
- int i, j, k, s;
- if (xt == yt)
- if (yt == zt)
- for (k=m*n-1; k >= 0; k--) x[k]=y[k]-z[k];
- else
- for (s=zt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[k]-z[j];
- else
- if (yt == zt)
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]-z[j];
- else
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]-z[k];
- return NO_ERR;
-}
-
- /*
- Assumes:
- x : m vector
- y : m vector
- z : m vector
- m : positive
- n : positive
-
- Results:
- x = a*y + b*z
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bLinearCombination(PRECISION *x, PRECISION a, PRECISION *y, PRECISION b, PRECISION *z, int m)
-{
- while (--m >= 0) x[m]=a*y[m]+b*z[m];
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-/*
- Assumes:
- x : m x n matrix
- y : n-vector
- n : positive
-
- Results:
- x[i] = s * y[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x and y do not have to be distinct
-*/
-int bMultiply(PRECISION *x, PRECISION *y, PRECISION s, int n)
-{
- while (--n >= 0) x[n]=s*y[n];
- return NO_ERR;
-}
-
-
-/*
- Assumes:
- x : array of length mn
- y : array of length mp
- z : array of length pn
- m, n and p are positive
- xt, yt, and zt are 0 or 1
-
- Results:
- x y z
- xt yt zt (m x n) (m x p) (p x n) results
- -----------------------------------------------------------
- 0 0 0 row major row major row major x = y * z
- 1 0 0 col major row major row major x = y * z
- 0 1 0 row major col major row major x = y * z
- 1 1 0 col major col major row major x = y * z
- 0 0 1 row major row major col major x = y * z
- 1 0 1 col major row major col major x = y * z
- 0 1 1 row major col major col major x = y * z
- 1 1 1 col major col major col major x = y * z
-
- or
- x y z
- xt yt zt row major row major row major results
- ----------------------------------------------------------
- 0 0 0 m x n m x p p x n x = y * z
- 1 0 0 n x m m x p p x n x'= y * z
- 0 1 0 m x n p x m p x n x = y'* z
- 1 1 0 n x m p x m p x n x'= y'* z
- 0 0 1 m x n m x p n x p x = y * z'
- 1 0 1 n x m m x p n x p x'= y * z'
- 0 1 1 m x n p x m n x p x = y'* z'
- 1 1 1 n x m p x m n x p x'= y'* z'
-
- or
-
- x y z
- xt yt zt col major col major col major results
- -----------------------------------------------------------
- 0 0 0 n x m p x m n x p x'= y'* z'
- 1 0 0 m x n p x m n x p x = y'* z'
- 0 1 0 n x m m x p n x p x'= y * z'
- 1 1 0 m x n m x p n x p x = y * z'
- 0 0 1 n x m p x m p x n x'= y'* z
- 1 0 1 m x n p x m p x n x = y'* z
- 0 1 1 n x m m x p p x n x'= y * z
- 1 1 1 m x n m x p p x n x = y * z
-
- Returns:
- 0 upon success
-
- Notes:
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-
-*/
-
-int bMatrixMultiply(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int p, int xt, int yt, int zt)
-{
- char transy, transz;
- int dy, dz;
- PRECISION beta=0.0, alpha=1.0;
-#if PRECISION_SIZE == 4
- if (xt)
- {
- if (yt) {transy='N'; dy=m;} else {transy='T'; dy=p;}
- if (zt) {transz='N'; dz=p;} else {transz='T'; dz=n;}
- sgemm(&transy,&transz,&m,&n,&p,&alpha,y,&dy,z,&dz,&beta,x,&m);
- }
- else
- {
- if (yt) {transy='T'; dy=m;} else {transy='N'; dy=p;}
- if (zt) {transz='T'; dz=p;} else {transz='N'; dz=n;}
- sgemm(&transz,&transy,&n,&m,&p,&alpha,z,&dz,y,&dy,&beta,x,&n);
- }
-#else
- if (xt)
- {
- if (yt) {transy='N'; dy=m;} else {transy='T'; dy=p;}
- if (zt) {transz='N'; dz=p;} else {transz='T'; dz=n;}
- dgemm(&transy,&transz,&m,&n,&p,&alpha,y,&dy,z,&dz,&beta,x,&m);
- }
- else
- {
- if (yt) {transy='T'; dy=m;} else {transy='N'; dy=p;}
- if (zt) {transz='T'; dz=p;} else {transz='N'; dz=n;}
- dgemm(&transz,&transy,&n,&m,&p,&alpha,z,&dz,y,&dy,&beta,x,&n);
- }
-#endif
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/***************************** LU Decompositions ******************************/
-/******************************************************************************/
-/*
- Assumes
- p : integer array of length at least q=min(m,n)
- x : array of lenth mn
- m,n : positive
-
-
- Results:
-
- x L U P
- xt row major row major row major uses q results
- --------------------------------------------------------------
- 0 m x n m x q q x n m x m x = P * L * U
- 1 n x m n x q q x m m x m x = L * U * P'
-
- or
- x L U P
- xt col major col major col major uses q results
- --------------------------------------------------------------
- 0 n x m n x q q x m m x m x = L * U * P
- 1 m x n m x q q x n m x m x = P * L * U
-
- or
- x L U P
- xt (m x n) (m x q) (q x n) (m x m) results
- --------------------------------------------------------------
- 0 row major row major row major uses q x = P * L * U
- 1 col major col major col major uses q x = P * L * U
-
- Results
- Computes the LU decomposition of A with partial pivoting. The LU
- decomposition of a matrix A is
-
- A = P * L * U
-
- where P is a (m x m) permutation matrix, L is a (m x q) lower triangular
- matrix with ones on the diagonal, U is a (q x n) upper triangular matrix,
- and q=min(m,n). These matrices are stored as follows.
-
- U is stored in the upper part of x, including the diagonal.
-
- L is stored in the lower part of x. The diagonal of L is not stored.
-
- The matrix P is defined by
-
- P = P(0,p[0])*P(1,p[1])*...*P(q-1,p[q-1])
-
- where P(r,s) is the (m x m) matrix obtained by permuting the rth and sth
- rows of the (m x m) identity matrix. It is assumed that i <= p[i] < m.
-
- Returns
- NO_ERR - success
- SING_ERR - x was singular to machine precision. LU decomposition is
- still computed and returned.
-
- Notes
- Uses partial pivoting. Does not scale. An (n x m) matrix x is in row major
- format if x[i][j]=x[i*n+j] and is in column major format if x[i][j]=x[i+j*m].
- Only q elements of p are set.
-*/
-int bLU(int *p, PRECISION *x, int m, int n, int xt)
-{
-#if PRECISION_SIZE == 4
- #define getrf sgetrf
-#else
- #define getrf dgetrf
-#endif
-
- PRECISION *y;
- int i, info;
- if (xt)
- {
- getrf(&m,&n,x,&m,p,&info);
- }
- else
- {
- if (!( y=(PRECISION*)malloc(m*n*sizeof(PRECISION)))) return MEM_ERR;
- bTranspose(y,x,m,n,0);
-
- getrf(&m,&n,y,&m,p,&info);
-
- bTranspose(x,y,m,n,1);
- free(y);
- }
- for (i=(m < n) ? m-1 : n-1; i >= 0; i--) p[i]--;
- return (info < 0) ? SING_ERR : NO_ERR;
-
-#undef getrf
-}
-
-/*
- Assumes
- x : array of length m*m representing a triangular matrix.
- b : array of length m*n
-
- Results
- x b/y
- u xt bt (m x m) (m x n) solve
- --------------------------------------------------
- 0 0 0 L:row major row major L * y = b
- 1 0 0 U:row major row major U * y = b
- 1 1 0 U:col major row major U * y = b
- 0 1 0 L:col major row major L * y = b
- 0 0 1 L:row major col major L * y = b
- 1 0 1 U:row major col major U * y = b
- 1 1 1 U:col major col major U * y = b
- 0 1 1 L:col major col major L * y = b
-
- or
- x
- (m x m) b/y u^xt^0
- u xt bt row major row major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 L m x n L * y = b 0
- 1 0 0 U m x n U * y = b 1
- 1 1 0 L m x n L'* y = b 0
- 0 1 0 U m x n U'* y = b 1
- 0 0 1 L n x m L * y'= b' (y * L'= b) 0
- 1 0 1 U n x m U * y'= b' (y * U'= b) 1
- 1 1 1 L n x m L'* y'= b' (y * L = b) 0
- 0 1 1 U n x m U'* y'= b' (y * U = b) 1
-
- or
- x
- (m x m) b/y u^xt^1
- u xt bt col major col major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 U m x n U'* y'= b' (y * U = b) 1
- 1 0 0 L m x n L'* y'= b' (y * L = b) 0
- 1 1 0 U m x n U * y'= b' (y * U'= b) 1
- 0 1 0 L m x n L * y'= b' (y * L'= b) 0
- 0 0 1 U n x m U'* y = b 1
- 1 0 1 L n x m L'* y = b 0
- 1 1 1 U n x m U * y = b 1
- 0 1 1 L n x m L * y = b 0
-
- The solution y is stored in b.
-
- Returns
- 0 (NO_ERR) - success
- SING_ERR - x is singular
-
- Notes
- Because this routines tests using the xor operator, the values of u and xt
- must be either 0 or 1. The matrix x is assumed to be triangular. Care
- must be taken that the matrix is either upper or lower triangular in the
- correct format.
-
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-*/
-int bSolveTriangular(PRECISION *x, PRECISION *b, int m, int n, int u, int xt, int bt)
-{
- int i, j, k, bi, bj, xi, xj, mbi;
- PRECISION *pxx, *px, *pb;
- for (j=m+1, i=j*(m-1); i >= 0; i-=j) if (x[i] == 0.0) return SING_ERR;
- if (xt) { xi=1; xj=m; } else { xi=m; xj=1; }
- if (bt) { bi=1; bj=m; } else { bi=n; bj=1; }
- mbi=(m-1)*bi;
- if (u)
- for (x+=(m-1)*xj, j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x+(m-1)*xi, i=(m-1)*bi; i >= 0; pxx-=xi, i-=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=mbi-i; k > 0; px-=xj, k-=bi) (*pb)-=(*px)*pb[k];
- *pb/=(*px);
- }
- else
- {
- for (j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x, i=0; i <= mbi; pxx+=xi, i+=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=-i; k < 0; px+=xj, k+=bi) (*pb)-=(*px)*pb[k];
- *pb/=(*px);
- }
- }
- return NO_ERR;
-}
-
-/*
- Assumes
- x : array of length m*m representing a triangular matrix with unit diagonal
- b : array of length m*n
-
- Results
- x b/y
- u xt bt (m x m) (m x n) solve
- --------------------------------------------------
- 0 0 0 L:row major row major L * y = b
- 1 0 0 U:row major row major U * y = b
- 1 1 0 U:col major row major U * y = b
- 0 1 0 L:col major row major L * y = b
- 0 0 1 L:row major col major L * y = b
- 1 0 1 U:row major col major U * y = b
- 1 1 1 U:col major col major U * y = b
- 0 1 1 L:col major col major L * y = b
-
- or
- x
- (m x m) b/y u^xt^0
- u xt bt row major row major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 L m x n L * y = b 0
- 1 0 0 U m x n U * y = b 1
- 1 1 0 L m x n L'* y = b 0
- 0 1 0 U m x n U'* y = b 1
- 0 0 1 L n x m L * y'= b' (y * L'= b) 0
- 1 0 1 U n x m U * y'= b' (y * U'= b) 1
- 1 1 1 L n x m L'* y'= b' (y * L = b) 0
- 0 1 1 U n x m U'* y'= b' (y * U = b) 1
-
- or
- x
- (m x m) b/y u^xt^1
- u xt bt col major col major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 U m x n U'* y'= b' (y * U = b) 1
- 1 0 0 L m x n L'* y'= b' (y * L = b) 0
- 1 1 0 U m x n U * y'= b' (y * U'= b) 1
- 0 1 0 L m x n L * y'= b' (y * L'= b) 0
- 0 0 1 U n x m U'* y = b 1
- 1 0 1 L n x m L'* y = b 0
- 1 1 1 U n x m U * y = b 1
- 0 1 1 L n x m L * y = b 0
-
-
- The solution y is stored in b.
-
- Returns
- 0 (NO_ERR) - success
-
- Notes
- If f is zero for row major format and one for a column major format, then
- passing xt = 1^f (1 xor f) implies an upper triangular matrix is passed,
- and passing xt = 0^f implies a lower triangular matrix is passed.
-
- The matrix x is assumed to be triangular with unit diagonal. Care must be
- taken that the matrix is either upper or lower triangular in the correct
- format.
-
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-*/
-int bSolveUnitTriangular(PRECISION *x, PRECISION *b, int m, int n, int u, int xt, int bt)
-{
- int i, j, k, bi, bj, xi, xj, mbi;
- PRECISION *pxx, *px, *pb;
- if (xt) { xi=1; xj=m; } else { xi=m; xj=1; }
- if (bt) { bi=1; bj=m; } else { bi=n; bj=1; }
- mbi=(m-1)*bi;
- if (u)
- for (x+=(m-1)*xj, j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x+(m-1)*xi, i=(m-1)*bi; i >= 0; pxx-=xi, i-=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=mbi-i; k > 0; px-=xj, k-=bi) (*pb)-=(*px)*pb[k];
- }
- else
- {
- for (j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x, i=0; i <= mbi; pxx+=xi, i+=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=-i; k < 0; px+=xj, k+=bi) (*pb)-=(*px)*pb[k];
- }
- }
- return NO_ERR;
-}
-
-/*
- Assumes
- p : integer array of length q with 0 <= p[i] < m for all 0 <= i < q.
- y : array of length mn
-
- Results
- x/y
- pt yt row major product
- ---------------------------------------------
- 0 0 m x n x = P * y
- 1 0 m x n x = P'* y
- 0 1 n x m x'= P * y' (x = y * P')
- 1 1 n x m x'= P'* y' (x = y * P )
-
- or
-
- x/y
- pt yt col major product
- ---------------------------------------------
- 0 0 n x m x'= P * y' (x = y * P')
- 1 0 n x m x'= P'* y' (x = y * P )
- 0 1 m x n x = P * y
- 1 1 m x n x = P'* y
-
- or
- x/y
- pt yt (m x n) product
- -------------------------------
- 0 0 row major x = P * y
- 1 0 row major x = P'* y
- 0 1 col major x = P * y
- 1 1 col major x = P'* y
-
- The matrix P is defined by
-
- P = P(0,p[0])*P(1,p[1])*...*P(q-1,p[q])
-
- where P(r,s) is the (m x m) matrix obtained by permuting the rth and sth
- rows of the (m x m) identity matrix.
-
- Notes:
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-*/
-int bPermutationMultiply(int *p, PRECISION *y, int m, int n, int q, int pt, int yt)
-{
- int i, j, k, pk;
- PRECISION tmp;
- if (yt)
- if (pt)
- for (j=0; j < q; j++)
- {
- if (j != p[j])
- for (i=(n-1)*m; i >= 0; i-=m)
- {
- tmp=y[i+j];
- y[i+j]=y[i+p[j]];
- y[i+p[j]]=tmp;
- }
- }
- else
- for (j=q-1; j >= 0; j--)
- {
- if (j != p[j])
- for (i=(n-1)*m; i >= 0; i-=m)
- {
- tmp=y[i+j];
- y[i+j]=y[i+p[j]];
- y[i+p[j]]=tmp;
- }
- }
- else
- if (pt)
- for (i=0; i < q; i++)
- {
- if (i != p[i])
- {
- k=i*n;
- pk=p[i]*n;
- for (j=n-1; j >= 0; j--)
- {
- tmp=y[k+j];
- y[k+j]=y[pk+j];
- y[pk+j]=tmp;
- }
- }
- }
- else
- for (i=q-1; i >= 0; i--)
- {
- if (i != p[i])
- {
- k=i*n;
- pk=p[i]*n;
- for (j=n-1; j >= 0; j--)
- {
- tmp=y[k+j];
- y[k+j]=y[pk+j];
- y[pk+j]=tmp;
- }
- }
- }
- return NO_ERR;
-}
-
-/*
- Assumes
- p : integer array of length q with i <= p[i] < m for all 0 <= i < m.
- x : PRECISION array of length m*m
-
- Results
- If P(i,j) is the identity matrix with the ith and jth columns permuted,
- the the permutation matrix is defined from p is
-
- P = P(0,p[0])*P(1,p[1])*...*P(q-1,p[q-1])
-
- Then
- x
- xt row major
- ----------------
- 0 x = P
- 1 x = P'
-
- or
- x
- xt col major
- ----------------
- 0 x = P'
- 1 x = P
-
-
- if where P(r,s) is the (m x m) matrix obtained by permuting the rth and sth
- rows of the (m x m) identity matrix.
-
- Notes:
- Permuting the ith and jth columns of an identity matrix is equivalent to
- permuting the ith and jth rows. An (n x m) matrix x is in row major
- format if x[i][j]=x[i*n+j] and is in column major format if
- x[i][j]=x[i+j*m].
-*/
-int bPermutation(PRECISION *x, int *p, int m, int q, int xt)
-{
- int i, j, k;
- for (k=m*m-1; k >= 0; k--) x[k]=0.0;
- if (xt)
- for (j=m-1; j >= 0; j--)
- {
- if (j < q)
- {
- k=j-1;
- i=p[j];
- }
- else
- {
- k=q-1;
- i=j;
- }
- for ( ; k >= 0; k--) if (i == p[k]) i=k;
- x[i+j*m]=1.0;
- }
- else
- for (j=m-1; j >= 0; j--)
- {
- if (j < q)
- {
- k=j-1;
- i=p[j];
- }
- else
- {
- k=q-1;
- i=j;
- }
- for ( ; k >= 0; k--) if (i == p[k]) i=k;
- x[i*m+j]=1.0;
- }
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-/******************************************************************************/
-/************************ Singular Value Decomposition ************************/
-/******************************************************************************/
-/*
- Assumes
- U : array of length m*m (compact=0) or m*q (compact=1) or null
- d : array of length q=min(m,n)
- V : array of length n*n (compact=0) or n*q (compact=1) or null
- A : array of length m*n
- m : positive
- n : positive
- ut : 0 or 1
- vt : 0 or 1
- at : 0 or 1
- compact : 0 or 1
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
-
- Results
- Finds matrices U and V with orthonormal columns and a diagonal matrix
- D=diag(d) with non-negative diagonal such that A = U*D*V'. The matrix D is
- m x n if compact = 0 and is q x q if compact = 1. The elements of d are in
- descending order. The flags ut, vt, and at determine the format of U, V,
- and A. A value of 1 indicates column major format and a value of 0
- indicates row major format. If either U or V is null, then it is not
- computed.
-
- Notes
- If A=U, U and A must be of the same size and ut=at. If A=V, then V and A
- must be of the same size and vt=at. It cannot be the case that U=V unless
- both are null.
-*/
-int bSVD_new(PRECISION *U, PRECISION *d, PRECISION *V, PRECISION *A, int m, int n, int ut, int vt, int at, int compact)
-{
-#if (PRECISION_SIZE == 4)
- #define gesvd sgesvd
-#else
- #define gesvd dgesvd
-#endif
-
- char jobu, jobv;
- int qu, qv, k, info, err=NO_ERR;
- PRECISION *A_, *U_, *V_, *work, opt_size;
-
- if (!(A_=(PRECISION*)malloc(m*n*sizeof(PRECISION)))) return MEM_ERR;
- if (at)
- memcpy(A_,A,m*n*sizeof(PRECISION));
- else
- bTranspose(A_,A,m,n,at);
-
- if (!U)
- {
- jobu='N';
- qu=0;
- U_=(PRECISION*)NULL;
- }
- else
- {
- if (compact && (m > n))
- {
- jobu='S';
- qu=n;
- }
- else
- {
- jobu='A';
- qu=m;
- }
- if (ut)
- U_=U;
- else
- if (!(U_=(PRECISION*)malloc(m*qu*sizeof(PRECISION))))
- {
- free(A_);
- return MEM_ERR;
- }
- }
-
- if (!V)
- {
- qv=1;
- jobv='N';
- V_=(PRECISION*)NULL;
- }
- else
- {
- if (compact && (m < n))
- {
- jobv='S';
- qv=m;
- }
- else
- {
- jobv='A';
- qv=n;
- }
- if (!vt)
- V_=V;
- else
- if (!(V_=(PRECISION*)malloc(n*qv*sizeof(PRECISION))))
- {
- free(A_);
- if (U_ && (U_ != U)) free(U_);
- return MEM_ERR;
- }
- }
-
- // compute singular value decomposition
- k=-1;
- gesvd(&jobu,&jobv,&m,&n,A_,&m,d,U_,&m,V_,&qv,&opt_size,&k,&info);
- if (info)
- err=BLAS_LAPACK_ERR;
- else
- if (!(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION))))
- err=MEM_ERR;
- else
- {
- gesvd(&jobu,&jobv,&m,&n,A_,&m,d,U_,&m,V_,&qv,work,&k,&info);
- free(work);
- if (info)
- err=BLAS_LAPACK_ERR;
- else
- {
- if (U_ != U) bTranspose(U,U_,m,qu,1);
- if (V_ != V) bTranspose(V,V_,qv,n,1);
- err=NO_ERR;
- }
- }
-
- free(A_);
- if (U_ && (U_ != U)) free(U_);
- if (V_ && (V_ != V)) free(V_);
- return err;
-
-
-/* char jobu, jobv, jobt; */
-/* int k=-1, info, err, m_, n_, qu_, qv_, transpose; */
-/* PRECISION *A_, *U_, *V_, *work, opt_size; */
-
-/* A_=(PRECISION*)malloc(m*n*sizeof(PRECISION)); */
-
-/* jobu=jobv=compact ? 'S' : 'A'; */
-
-/* if (!U) */
-/* { */
-/* jobu='N'; */
-/* if (!V) */
-/* { */
-/* jobv='N'; */
-/* vt=transpose=1-at; */
-/* } */
-/* else */
-/* transpose=vt; */
-/* ut=1-vt; */
-/* } */
-/* else */
-/* if (!V) */
-/* { */
-/* jobv='N'; */
-/* vt=transpose=1-ut; */
-/* } */
-/* else */
-/* { */
-/* if (ut != vt) */
-/* transpose=vt; */
-/* else */
-/* transpose=1-at; */
-/* } */
-
-/* if (transpose) */
-/* { */
-/* jobt=jobu; */
-/* jobu=jobv; */
-/* jobv=jobt; */
-/* if (at) */
-/* bTranspose(A_,A,m,n,at); */
-/* else */
-/* memcpy(A_,A,m*n*sizeof(PRECISION)); */
-/* if (compact) */
-/* { */
-/* m_=n; */
-/* n_=m; */
-/* qu_=qv_=(m < n) ? m : n; */
-/* } */
-/* else */
-/* { */
-/* qu_=m_=n; */
-/* qv_=n_=m; */
-/* } */
-/* U_=vt ? V : (PRECISION*)malloc(m_*qu_*sizeof(PRECISION)); */
-/* V_=ut ? (PRECISION*)malloc(qv_*n_*sizeof(PRECISION)) : U; */
-/* } */
-/* else */
-/* { */
-/* if (at) */
-/* memcpy(A_,A,m*n*sizeof(PRECISION)); */
-/* else */
-/* bTranspose(A_,A,m,n,at); */
-/* if (compact) */
-/* { */
-/* m_=m; */
-/* n_=n; */
-/* qu_=qv_=(m < n) ? m : n; */
-/* } */
-/* else */
-/* { */
-/* qu_=m_=m; */
-/* qv_=n_=n; */
-/* } */
-/* U_=ut ? U : (PRECISION*)malloc(m_*qu_*sizeof(PRECISION)); */
-/* V_=vt ? (PRECISION*)malloc(qv_*n_*sizeof(PRECISION)) : V; */
-/* } */
-
-/* // compute singular value decomposition */
-/* gesvd(&jobu,&jobv,&m_,&n_,A_,&m_,d,U_,&m_,V_,&qv_,&opt_size,&k,&info); */
-/* if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* err=info ? BLAS_LAPACK_ERR : MEM_ERR; */
-/* else */
-/* { */
-/* gesvd(&jobu,&jobv,&m_,&n_,A_,&m_,d,U_,&m_,V_,&qv_,work,&k,&info); */
-/* free(work); */
-/* if (info) */
-/* err=BLAS_LAPACK_ERR; */
-/* else */
-/* { */
-/* if (transpose) */
-/* { */
-/* if (U != V_) */
-/* bTranspose(U,V_,qv_,n_,1); */
-/* else */
-/* if (V != U_) */
-/* bTranspose(V,U_,m_,qu_,1); */
-/* } */
-/* else */
-/* { */
-/* if (U != U_) */
-/* bTranspose(U,U_,m_,qu_,1); */
-/* else */
-/* if (V != V_) */
-/* bTranspose(V,V_,qv_,n_,1); */
-/* } */
-/* err=NO_ERR; */
-/* } */
-/* } */
-
-/* free(A_); */
-
-/* if (transpose) */
-/* { */
-/* if (U != V_) */
-/* free(V_); */
-/* else */
-/* if (V != U_) */
-/* free(U_); */
-/* } */
-/* else */
-/* { */
-/* if (U != U_) */
-/* free(U_); */
-/* else */
-/* if (V != V_) */
-/* free(V_); */
-/* } */
-
-/* return err; */
-
-/* #undef gesvd */
-}
-
-/*
- Assumes
- U : array of length m*m
- d : array of length q=min(m,n)
- V : array of length n*n
- A : array of length m*n
- m : positive
- n : positive
- ut : 0 or 1
- vt : 0 or 1
- at : 0 or 1
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- ITER_ERR : maximum number of iterations (MAX_ITER) exceeded - only if
- numerical recipe routines are used.
-
- Results
- A U V d
- ut vt at (m x n) (m x m) (n x n) diagonal solves
- ---------------------------------------------------------------------
- 0 0 0 row major row major row major m x n A = U * D * V'
- 1 0 0 row major col major row major m x n A = U * D * V'
- 1 1 0 row major col major col major m x n A = U * D * V'
- 0 1 0 row major row major col major m x n A = U * D * V'
- 0 0 1 col major row major row major m x n A = U * D * V'
- 1 0 1 col major col major row major m x n A = U * D * V'
- 1 1 1 col major col major col major m x n A = U * D * V'
- 0 1 1 col major row major col major m x n A = U * D * V'
-
- A U V d
- ut vt at row major row major row major diagonal solves
- ---------------------------------------------------------------------
- 0 0 0 m x n m x m n x n m x n A = U * D * V'
- 1 0 0 m x n m x m n x n m x n A = U'* D * V'
- 1 1 0 m x n m x m n x n m x n A = U'* D * V
- 0 1 0 m x n m x m n x n m x n A = U * D * V
- 0 0 1 n x m m x m n x n m x n A'= U * D * V'
- 1 0 1 n x m m x m n x n m x n A'= U'* D * V'
- 1 1 1 n x m m x m n x n m x n A'= U'* D * V
- 0 1 1 n x m m x m n x n m x n A'= U * D * V
-
- A U V d
- ut vt at col major col major col major diagonal solves
- ---------------------------------------------------------------------
- 0 0 0 n x m m x m n x n m x n A'= U'* D * V
- 1 0 0 n x m m x m n x n m x n A'= U * D * V
- 1 1 0 n x m m x m n x n m x n A'= U * D * V'
- 0 1 0 n x m m x m n x n m x n A'= U'* D * V'
- 0 0 1 m x n m x m n x n m x n A = U'* D * V
- 1 0 1 m x n m x m n x n m x n A = U * D * V
- 1 1 1 m x n m x m n x n m x n A = U * D * V'
- 0 1 1 m x n m x m n x n m x n A = U'* D * V'
-
-
- U and V are orthogonal matrices and the elemets of d are non-negative.
-
- Notes
- The lapack routine is avoids unnecessary transpositions when ut == at and
- vt = 1-at. When m=n, A can be equal to U or V. U and V must be distinct.
-
- The current code uses the
-*/
-int bSVD(PRECISION *U, PRECISION *d, PRECISION *V, PRECISION *A, int m, int n, int ut, int vt, int at)
-{
-#if (PRECISION_SIZE == 4)
-#define gesvd sgesvd
-#else
-#define gesvd dgesvd
-#endif
-
- char jobz='A';
- int k, *iwork, info;
- PRECISION *X, *work, opt_size;
- if (!(X=(PRECISION*)malloc(m*n*sizeof(PRECISION)))) return MEM_ERR;
- memcpy(X,A,m*n*sizeof(PRECISION));
- if (!(iwork=(int*)malloc(8*((m < n) ? m : n)*sizeof(int))))
- {
- free(X);
- return MEM_ERR;
- }
- k=-1;
- if (at)
- {
- memcpy(X,A,m*n*sizeof(PRECISION));
- k=-1;
- gesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,&info);
- if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION))))
- {
- free(iwork);
- free(X);
- return info ? BLAS_LAPACK_ERR : MEM_ERR;
- }
- gesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,&info);
- if (info)
- {
- free(work);
- free(iwork);
- free(X);
- return BLAS_LAPACK_ERR;
- }
- if (!ut)
- bTransposeInPlace(U,m);
- if (vt)
- bTransposeInPlace(V,n);
- }
- else
- {
- memcpy(X,A,m*n*sizeof(PRECISION));
- k=-1;
- gesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,&info);
- if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION))))
- {
- free(iwork);
- free(X);
- return info ? BLAS_LAPACK_ERR : MEM_ERR;
- }
- gesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,&info);
- if (info)
- {
- free(work);
- free(iwork);
- free(X);
- return BLAS_LAPACK_ERR;
- }
- if (!vt)
- bTransposeInPlace(V,n);
- if (ut)
- bTransposeInPlace(U,m);
- }
- free(work);
- free(iwork);
- free(X);
- return NO_ERR;
-
-#undef gesvd
-
- // The following code attempts to use the divide and conquer algorithm
-/* #if (PRECISION_SIZE == 4) */
-/* #define gesvd sgesdd */
-/* #else */
-/* #define gesdd dgesdd */
-/* #endif */
-/* int jobz='A', k, *iwork, info; */
-/* PRECISION *X, *work, opt_size; */
-/* if (!(X=(PRECISION*)malloc(m*n*sizeof(PRECISION)))) return MEM_ERR; */
-/* memcpy(X,A,m*n*sizeof(PRECISION)); */
-/* if (!(iwork=(int*)malloc(8*((m < n) ? m : n)*sizeof(int)))) */
-/* { */
-/* free(X); */
-/* return MEM_ERR; */
-/* } */
-/* k=-1; */
-/* if (at) */
-/* { */
-/* gesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,iwork,&info); */
-/* if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return info ? BLAS_LAPACK_ERR : MEM_ERR; */
-/* } */
-/* gesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,iwork,&info); */
-/* if (info) */
-/* { */
-/* free(work); */
-/* free(iwork); */
-/* free(X); */
-/* return BLAS_LAPACK_ERR; */
-/* } */
-/* if (!ut) */
-/* bTransposeInPlace(U,m); */
-/* if (vt) */
-/* bTransposeInPlace(V,n); */
-/* } */
-/* else */
-/* { */
-/* gesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,iwork,&info); */
-/* if (!(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return MEM_ERR; */
-/* } */
-/* gesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,iwork,&info); */
-/* if (info) */
-/* { */
-/* free(work); */
-/* free(iwork); */
-/* free(X); */
-/* return BLAS_LAPACK_ERR; */
-/* } */
-/* if (!vt) */
-/* bTransposeInPlace(V,n); */
-/* if (ut) */
-/* bTransposeInPlace(U,m); */
-/* } */
-/* free(work); */
-/* free(iwork); */
-/* free(X); */
-/* return NO_ERR; */
-
-/* #undef gesdd */
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/***************************** QR Decompositions ******************************/
-/******************************************************************************/
-/*
- Assumes
- Q : array of length m*q or null pointer
- R : array of length q*n
- X : array of length m*n
- n : positive
- m : positive
- q : m or min(m,n)
- qt : 0 or 1
- rt : 0 or 1
- xt : 0 or 1
-
- Returns
- NO_ERR : Success
- MEM_ERR : Out of memory
-
- Results
- Finds an orthogonal matrix Q and an upper triangular matrix R
- such that
-
- X = Q * R
-
- The matrix Q is computed only if it is not null.
-
- X Q R
- qt rt xt (m x n) (m x q) (q x n) solves
- ------------------------------------------------------
- 0 0 0 row major row major row major X = Q * R
- 1 0 0 row major col major row major X = Q * R
- 0 1 0 row major row major col major X = Q * R
- 1 1 0 row major col major col major X = Q * R
- 0 0 1 col major row major row major X = Q * R
- 1 0 1 col major col major row major X = Q * R
- 0 1 1 col major row major col major X = Q * R
- 1 1 1 col major col major col major X = Q * R
-
- or
- R/U Q
- qt rt row major row major solves
- ------------------------------------------
- 0 0 m x n m x m R = Q * U
- 1 0 m x n m x m R = Q'* U
- 0 1 n x m m x m R'= Q * U'
- 1 1 n x m m x m R'= Q'* U'
-
- or
- R/U Q
- qt rt col major col major solves
- ------------------------------------------
- 0 0 n x m m x m R'= Q'* U'
- 1 0 n x m m x m R'= Q * U'
- 0 1 m x n m x m R = Q'* U
- 1 1 m x n m x m R = Q * U
-
- Notes
- The matrices X and R do not have to be distinct. If X == R, then it must
- be the case that m == q and rt == xt. The QR decomposition is formed using
- Householder matrices without pivoting.
-*/
-int bQR(PRECISION *Q, PRECISION *R, PRECISION *X, int m, int n, int q, int qt, int rt, int xt)
-{
-#if (PRECISION_SIZE == 4)
- #define geqrf sgeqrf
- #define orgqr sorgqr
- #define gelqf sgelqf
- #define orglq sorglq
-#else
- #define geqrf dgeqrf
- #define orgqr dorgqr
- #define gelqf dgelqf
- #define orglq dorglq
-#endif
-
- int i, j, k, l, lwork, info, p=(m < n) ? m : n;
- PRECISION *tau, *work, *ptr, opt_size;
- if (!(tau=(PRECISION*)malloc(p*sizeof(PRECISION)))) return MEM_ERR;
- if (xt)
- {
- lwork=-1;
-
- geqrf(&m,&n,X,&m,tau,&opt_size,&lwork,&info);
-
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
-
- geqrf(&m,&n,X,&m,tau,work,&lwork,&info);
-
- free(work);
- if (info)
- {
- free(tau);
- return ARG_ERR;
- }
- if (Q)
- {
- if (qt)
- ptr=Q;
- else
- if (!(ptr=(PRECISION*)malloc(m*q*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
- memcpy(ptr,X,m*p*sizeof(PRECISION));
- lwork=-1;
-
- orgqr(&m,&q,&p,ptr,&m,tau,&opt_size,&lwork,&info);
-
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- if (!qt) free(ptr);
- free(tau);
- return MEM_ERR;
- }
-
- orgqr(&m,&q,&p,ptr,&m,tau,work,&lwork,&info);
-
- free(work);
- if (!qt)
- {
- bTranspose(Q,ptr,m,q,1);
- free(ptr);
- }
- free(tau);
- if (info) return ARG_ERR;
- }
- else
- free(tau);
- if (R != X)
- if (rt)
- for (k=q*n, j=n-1; j >= 0; j--)
- {
- for (i=q-1; i > j; i--) R[--k]=0.0;
- for (l=i+j*m; i >= 0; i--) R[--k]=X[l--];
- }
- else
- for (k=q*n, i=q-1; i >= 0; i--)
- {
- for (l=i+n*m, j=n-1; j >= i; j--) R[--k]=X[l-=m];
- for ( ; j >= 0; j--) R[--k]=0.0;
- }
- else
- {
- for (j=p-1; j >= 0; j--)
- for (k=m*(j+1), i=m-1; i > j; i--) X[--k]=0.0;
- }
- }
- else
- {
- lwork=-1;
-
- gelqf(&n,&m,X,&n,tau,&opt_size,&lwork,&info);
-
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
-
- gelqf(&n,&m,X,&n,tau,work,&lwork,&info);
-
- free(work);
- if (info)
- {
- free(tau);
- return ARG_ERR;
- }
- if (Q)
- {
- if (!qt)
- ptr=Q;
- else
- if (!(ptr=(PRECISION*)malloc(m*q*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
- if (q == n)
- memcpy(ptr,X,m*n*sizeof(PRECISION));
- else
- if (m < n)
- for (k=q*m, j=m-1; j >= 0; j--)
- for (l=p+j*n, i=p-1; i >= 0; i--)
- ptr[--k]=X[--l];
- else
- for (l=n*m, j=m-1; j >= 0; j--)
- for (k=p+j*q, i=p-1; i >= 0; i--)
- ptr[--k]=X[--l];
- lwork=-1;
-
- orglq(&q,&m,&p,ptr,&q,tau,&opt_size,&lwork,&info);
-
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- if (!qt) free(ptr);
- free(tau);
- return MEM_ERR;
- }
-
- orglq(&q,&m,&p,ptr,&q,tau,work,&lwork,&info);
-
- free(work);
- if (qt)
- {
- bTranspose(Q,ptr,q,m,1);
- free(ptr);
- }
- free(tau);
- if (info) return ARG_ERR;
- }
- else
- free(tau);
- if (R != X)
- if (rt)
- for (k=n*q, i=n-1; i >= 0; i--)
- {
- for (j=q-1; j > i; j--) R[--k]=0.0;
- for (l=i+j*n; j >= 0; l-=n, j--) R[--k]=X[l];
- }
- else
- for (k=n*q-1, j=q-1; j >= 0; j--)
- {
- for (i=n-1; i >= j; k--, i--) R[k]=X[k];
- for ( ; i >= 0; k--, i--) R[k]=0.0;
- }
- else
- {
- for (i=p-1; i >= 0; i--)
- for (k=i+m*n, j=m-1; j > i; j--) X[k-=n]=0.0;
- }
- }
- return NO_ERR;
-
-#undef geqrf
-#undef orgqr
-#undef gelqf
-#undef orglq
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/********************** Generalized Schur Decompositions **********************/
-/******************************************************************************/
-/*
- Assumes
- Q : array of length n*n or null
- Z : array of length n*n or null
- S : array of length n*n
- T : array of length n*n
- A : array of length n*n
- B : array of length n*n
- n : positive integer
- qt : 0 or 1
- zt : 0 or 1
- st : 0 or 1
- tt : 0 or 1
- at : 0 or 1
- bt : 0 or 1
- alpha_i : array of length n or null
- alpha_i : array of length n or null
- beta : array of length n or null
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- BLAS_LAPACK_ERR : blas or lapack error
-
- Results
- Finds orthogonal matrices Q and Z, an block upper triangular matrix S with
- 1 x 1 or 2 x 2 blocks along the diagonal, an upper triangular matrix T such
- that
-
- A = Q*S*Z' and B = Q*T*Z
-
- If either Q or Z is null, then it is not returned.
-
- Notes
- The flags qt, zt, st, tt, at, and bt control the format of the matrices Q,
- Z, S, T, A, and B. A value of 1 indicate column major format and a value of
- 0 indictes row major format.
-*/
-int bQZ_real(PRECISION *Q, PRECISION *Z, PRECISION *S, PRECISION *T, PRECISION *A, PRECISION *B, int n, int qt, int zt, int st, int tt, int at, int bt,
- PRECISION *alpha_r, PRECISION *alpha_i, PRECISION *beta)
-{
-#if (PRECISION_SIZE == 4)
- #define gges sgges
-#else
- #define gges dgges
-#endif
-
- char jobvsl, jobvsr, sort='N';
- int lwork, simd, info, rtrn;
- PRECISION *work, size, *palpha_r, *palpha_i, *pbeta;
-
- jobvsl=Q ? 'V' : 'N';
- jobvsr=Z ? 'V' : 'N';
- palpha_r=alpha_r ? alpha_r : (PRECISION*)malloc(n*sizeof(PRECISION));
- palpha_i=alpha_i ? alpha_i : (PRECISION*)malloc(n*sizeof(PRECISION));
- pbeta=beta ? beta : (PRECISION*)malloc(n*sizeof(PRECISION));
-
- if (palpha_r && palpha_i && pbeta)
- {
- if (S != A)
- if (at)
- memcpy(S,A,n*n*sizeof(PRECISION));
- else
- bTranspose(S,A,n,n,0);
- else
- if (!at) bTransposeInPlace(A,n);
-
- if (T != B)
- if (bt)
- memcpy(T,B,n*n*sizeof(PRECISION));
- else
- bTranspose(T,B,n,n,0);
- else
- if (!bt) bTransposeInPlace(B,n);
-
- lwork=-1;
- gges(&jobvsl,&jobvsr,&sort,(void*)NULL,&n,S,&n,T,&n,&simd,palpha_r,palpha_i,pbeta,Q,&n,Z,&n,&size,&lwork,(void*)NULL,&info);
- if (!info)
- if (!(work=malloc((lwork=(int)size)*sizeof(PRECISION))))
- rtrn=MEM_ERR;
- else
- {
- gges(&jobvsl,&jobvsr,&sort,(void*)NULL,&n,S,&n,T,&n,&simd,palpha_r,palpha_i,pbeta,Q,&n,Z,&n,work,&lwork,(void*)NULL,&info);
- if (!info)
- {
- if (Q && !qt) bTransposeInPlace(Q,n);
- if (Z && !zt) bTransposeInPlace(Z,n);
- if (!st) bTransposeInPlace(S,n);
- if (!tt) bTransposeInPlace(T,n);
- rtrn=NO_ERR;
- }
- else
- rtrn=BLAS_LAPACK_ERR;
- free(work);
- }
- else
- rtrn=BLAS_LAPACK_ERR;
- }
- else
- rtrn=MEM_ERR;
-
- if (!alpha_r && palpha_r) free(palpha_r);
- if (!alpha_i && palpha_i) free(palpha_i);
- if (!beta && pbeta) free(pbeta);
-
- return rtrn;
-
-#undef gges
-}
-
-/*
- Assumes
- select : array of length n
- QQ : array of length n*n or null
- ZZ : array of length n*n or null
- SS : array of length n*n
- TT : array of length n*n
- Q : array of length n*n or null
- Z : array of length n*n or null
- S : array of length n*n
- T : array of length n*n
- n : positive integer
- qqt : 0 or 1
- zzt : 0 or 1
- sst : 0 or 1
- ttt : 0 or 1
- qt : 0 or 1
- zt : 0 or 1
- st : 0 or 1
- tt : 0 or 1
- alpha_i : array of length n or null
- alpha_i : array of length n or null
- beta : array of length n or null
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- BLAS_LAPACK_ERR : blas or lapack error
-
- Results
- Finds orthogonal matrices QQ and ZZ, an block upper triangular matrix SS
- with 1 x 1 or 2 x 2 blocks along the diagonal, an upper triangular matrix TT
- such that
-
- Q*S*Z' = QQ*SS*ZZ' and Q*T*Z' = QQ*TT*ZZ'
-
- If either Q or QQ are null, then QQ is not computed and if either Z or ZZ is
- null, then ZZ is not computed. The matrices S and T are multiplied by
- orthogonal matrices in such a manner that their block triangular structure
- retained and the generalized eigenvalues corresponding to value of select
- equal to one are transformed to the upper part of SS and TT.
-
- Notes
- The flags qqt, zzt, sst, ttt, qt, zt, st, and tt control the format of the
- matrices QQ, ZZ, SS, TT, Q, Z, S, and T. A value of 1 indicate column major
- format and a value of 0 indictes row major format.
-*/
-int bReorderQZ_real(int *select, PRECISION *QQ, PRECISION *ZZ, PRECISION *SS, PRECISION *TT, PRECISION *Q, PRECISION *Z, PRECISION *S, PRECISION *T, int n,
- int qqt, int zzt, int sst, int ttt, int qt, int zt, int st, int tt, PRECISION *alpha_r, PRECISION *alpha_i, PRECISION *beta)
-{
-#if (PRECISION_SIZE == 4)
- #define tgsen stgsen
-#else
- #define tgsen dtgsen
-#endif
-
- int ijob=0, wantq, wantz, lwork, liwork=1, m=n, info, rtrn, iwork;
- PRECISION size, *palpha_r, *palpha_i, *pbeta, *work;
-
- wantq=(QQ && Q) ? 1 : 0;
- wantz=(ZZ && Z) ? 1 : 0;
-
- palpha_r=alpha_r ? alpha_r : (PRECISION*)malloc(n*sizeof(PRECISION));
- palpha_i=alpha_i ? alpha_i : (PRECISION*)malloc(n*sizeof(PRECISION));
- pbeta=beta ? beta : (PRECISION*)malloc(n*sizeof(PRECISION));
-
- if (palpha_r && palpha_i && pbeta)
- {
- if (SS != S)
- if (st)
- memcpy(SS,S,n*n*sizeof(PRECISION));
- else
- bTranspose(SS,S,n,n,0);
- else
- if (!st) bTransposeInPlace(S,n);
-
- if (TT != T)
- if (tt)
- memcpy(TT,T,n*n*sizeof(PRECISION));
- else
- bTranspose(TT,T,n,n,0);
- else
- if (!tt) bTransposeInPlace(T,n);
-
- if (wantq)
- if (QQ != Q)
- if (qt)
- memcpy(QQ,Q,n*n*sizeof(PRECISION));
- else
- bTranspose(QQ,Q,n,n,0);
- else
- if (!qt) bTransposeInPlace(Q,n);
-
- if (wantz)
- if (ZZ != Z)
- if (zt)
- memcpy(ZZ,Z,n*n*sizeof(PRECISION));
- else
- bTranspose(ZZ,Z,n,n,0);
- else
- if (!zt) bTransposeInPlace(Z,n);
-
- lwork=-1;
- tgsen(&ijob,&wantq,&wantz,select,&n,SS,&n,TT,&n,palpha_r,palpha_i,pbeta,QQ,&n,ZZ,&n,&m,
- (PRECISION*)NULL,(PRECISION*)NULL,(PRECISION*)NULL,&size,&lwork,&iwork,&liwork,&info);
- if (!info)
- if (!(work=malloc((lwork=(int)size)*sizeof(PRECISION))))
- rtrn=MEM_ERR;
- else
- {
- tgsen(&ijob,&wantq,&wantz,select,&n,SS,&n,TT,&n,palpha_r,palpha_i,pbeta,QQ,&n,ZZ,&n,&m,
- (PRECISION*)NULL,(PRECISION*)NULL,(PRECISION*)NULL,work,&lwork,&iwork,&liwork,&info);
- if (!info)
- {
- if (wantq && !qqt) bTransposeInPlace(QQ,n);
- if (wantz && !zzt) bTransposeInPlace(ZZ,n);
- if (!sst) bTransposeInPlace(SS,n);
- if (!ttt) bTransposeInPlace(TT,n);
- rtrn=NO_ERR;
- }
- else
- rtrn=BLAS_LAPACK_ERR;
- free(work);
- }
- else
- rtrn=BLAS_LAPACK_ERR;
- }
-
- if (!alpha_r && palpha_r) free(palpha_r);
- if (!alpha_i && palpha_i) free(palpha_i);
- if (!beta && pbeta) free(pbeta);
-
- return rtrn;
-
-#undef tgsen
-}
-
-/*
- Assumes
- QQ : array of length n*n or null
- ZZ : array of length n*n or null
- SS : array of length n*n
- TT : array of length n*n
- Q : array of length n*n or null
- Z : array of length n*n or null
- S : array of length n*n
- T : array of length n*n
- n : positive integer
- qqt : 0 or 1
- zzt : 0 or 1
- sst : 0 or 1
- ttt : 0 or 1
- qt : 0 or 1
- zt : 0 or 1
- st : 0 or 1
- tt : 0 or 1
- alpha_i : array of length n
- alpha_i : array of length n
- beta : array of length n
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- BLAS_LAPACK_ERR : blas or lapack error
-
- Results
- Finds orthogonal matrices QQ and ZZ, an block upper triangular matrix SS
- with 1 x 1 or 2 x 2 blocks along the diagonal, an upper triangular matrix TT
- such that
-
- Q*S*Z' = QQ*SS*ZZ' and Q*T*Z' = QQ*TT*ZZ'
-
- If either Q or QQ are null, then QQ is not computed and if either Z or ZZ is
- null, then ZZ is not computed. The matrices S and T are multiplied by
- orthogonal matrices in such a manner that their block triangular structure
- retained and the generalized eigenvalues are sorted in descending order. So
- upon exit,
-
- sqrt(alpha_r[i]^2 + alpha_i[i]^2)/beta[i]
- >= sqrt(alpha_r[i+1]^2 + alpha_i[i+1]^2)/beta[i+1]
-
- Notes
- The flags qqt, zzt, sst, ttt, qt, zt, st, and tt control the format of the
- matrices QQ, ZZ, SS, TT, Q, Z, S, and T. A value of 1 indicate column major
- format and a value of 0 indictes row major format.
-*/
-int bSortQZ_real(int *select, PRECISION *QQ, PRECISION *ZZ, PRECISION *SS, PRECISION *TT, PRECISION *Q, PRECISION *Z, PRECISION *S, PRECISION *T, int n,
- int qqt, int zzt, int sst, int ttt, int qt, int zt, int st, int tt, PRECISION *alpha_r, PRECISION *alpha_i, PRECISION *beta)
-{
-#if (PRECISION_SIZE == 4)
- #define tgexc stgexc
-#else
- #define tgexc dtgexc
-#endif
-
- int wantq, wantz, lwork, info, rtrn, *pairs, i, j, ii, jj;
- PRECISION size, *work, *gev, small, x1, x2;
-
- if (n == 1) return NO_ERR;
-
- wantq=(QQ && Q) ? 1 : 0;
- wantz=(ZZ && Z) ? 1 : 0;
-
- pairs=(int*)malloc(n*sizeof(int));
- gev=(PRECISION*)malloc(n*sizeof(PRECISION));
- small=SQRT_MACHINE_EPSILON;
-
- if (pairs && gev)
- {
- if (SS != S)
- if (st)
- memcpy(SS,S,n*n*sizeof(PRECISION));
- else
- bTranspose(SS,S,n,n,0);
- else
- if (!st) bTransposeInPlace(S,n);
-
- if (TT != T)
- if (tt)
- memcpy(TT,T,n*n*sizeof(PRECISION));
- else
- bTranspose(TT,T,n,n,0);
- else
- if (!tt) bTransposeInPlace(T,n);
-
- if (wantq)
- if (QQ != Q)
- if (qt)
- memcpy(QQ,Q,n*n*sizeof(PRECISION));
- else
- bTranspose(QQ,Q,n,n,0);
- else
- if (!qt) bTransposeInPlace(Q,n);
-
- if (wantz)
- if (ZZ != Z)
- if (zt)
- memcpy(ZZ,Z,n*n*sizeof(PRECISION));
- else
- bTranspose(ZZ,Z,n,n,0);
- else
- if (!zt) bTransposeInPlace(Z,n);
-
- lwork=-1;
- j=2; i=1;
- tgexc(&wantq,&wantz,&n,SS,&n,TT,&n,QQ,&n,ZZ,&n,&j,&i,&size,&lwork,&info);
- if (!info)
- if (!(work=malloc((lwork=(int)size)*sizeof(PRECISION))))
- rtrn=MEM_ERR;
- else
- {
- // Setup pairs and gev
- for (i=n-1; i >= 0; i--)
- {
- gev[i]=sqrt(alpha_r[i]*alpha_r[i] + alpha_i[i]*alpha_i[i]);
- gev[i]=(gev[i]*small > beta[i]) ? 1.0/small : gev[i]/beta[i];
- if ((i > 0) && (SS[n*(i-1)+i] != 0.0))
- {
- i--;
- gev[i]=gev[i+1];
- pairs[i]=1;
- pairs[i+1]=-1;
- }
- else
- pairs[i]=0;
- }
-
- rtrn=NO_ERR;
-
- // Order generalized eigenvalues
- j=pairs[0] ? 2 : 1;
- while (j < n)
- {
- i=j;
- while ((i > 0) && (gev[i-1] < gev[j])) i-=pairs[i-1] ? 2 : 1;
-
- if (i != j)
- {
- ii=i+1;
- jj=j+1;
- tgexc(&wantq,&wantz,&n,SS,&n,TT,&n,QQ,&n,ZZ,&n,&jj,&ii,work,&lwork,&info);
- if (!info)
- if (pairs[j])
- {
- memmove(pairs+i+2,pairs+i,(j-i)*sizeof(int));
- pairs[i]=1; pairs[i+1]=-1;
- x1=gev[j];
- memmove(gev+i+2,gev+i,(j-i)*sizeof(PRECISION));
- gev[i]=gev[i+1]=x1;
- x1=alpha_r[j]; x2=alpha_r[j+1];
- memmove(alpha_r+i+2,alpha_r+i,(j-i)*sizeof(PRECISION));
- alpha_r[i]=x1; alpha_r[i+1]=x2;
- x1=alpha_i[j]; x2=alpha_i[j+1];
- memmove(alpha_i+i+2,alpha_i+i,(j-i)*sizeof(PRECISION));
- alpha_i[i]=x1; alpha_i[i+1]=x2;
- x1=beta[j]; x2=beta[j+1];
- memmove(beta+i+2,beta+i,(j-i)*sizeof(PRECISION));
- beta[i]=x1; beta[i+1]=x2;
- j+=2;
- }
- else
- {
- memmove(pairs+i+1,pairs+i,(j-i)*sizeof(int));
- pairs[i]=0;
- x1=gev[j];
- memmove(gev+i+1,gev+i,(j-i)*sizeof(PRECISION));
- gev[i]=x1;
- x1=alpha_r[j];
- memmove(alpha_r+i+1,alpha_r+i,(j-i)*sizeof(PRECISION));
- alpha_r[i]=x1;
- x1=alpha_i[j];
- memmove(alpha_i+i+1,alpha_i+i,(j-i)*sizeof(PRECISION));
- alpha_i[i]=x1;
- x1=beta[j];
- memmove(beta+i+1,beta+i,(j-i)*sizeof(PRECISION));
- beta[i]=x1;
- j+=1;
- }
- else
- {
- rtrn=BLAS_LAPACK_ERR;
- break;
- }
- }
- else
- j+=pairs[j] ? 2 : 1;
-
- }
-
- free(work);
-
- if (rtrn == NO_ERR)
- {
- if (wantq && !qqt) bTransposeInPlace(QQ,n);
- if (wantz && !zzt) bTransposeInPlace(ZZ,n);
- if (!sst) bTransposeInPlace(SS,n);
- if (!ttt) bTransposeInPlace(TT,n);
- }
- }
- }
-
- if (pairs) free(pairs);
- if (gev) free(gev);
-
- return rtrn;
-
-#undef tgexc
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/************************** Cholesky Decompositions ***************************/
-/******************************************************************************/
-/*
- Assumes
- X : Scalar array of m*m representing an m x m symmetric matrix
-
- Returns
- 0 (NO_ERR) : success
- POS_DEF_ERR : X not positive definite
-
- Results
-
- u t X/T solves
- ----------------------------------
- 0 0 row major X = L'* L
- 1 0 row major X = U'* U
- 0 1 col major X = L'* L
- 1 1 col major X = U'* U
-
- or
- X/T
- u t row major solves
- ----------------------------------
- 0 0 - X = L'* L
- 1 0 - X = U'* U
- 0 1 - X = L * L'
- 1 1 - X = U * U'
-
- or
- X/T
- u t col major solves
- ----------------------------------
- 0 0 - X = L * L'
- 1 0 - X = U * U'
- 0 1 - X = L'* L
- 1 1 - X = U'* U
-
- u t T solves
- ---------------------------------- v
- 0 0 L:row major X = T'* T 0 v^t=0
- 1 0 U:row major X = T'* T 1 v^t=1
- 0 1 U:col major X = T'* T 1 v^t=0
- 1 1 L:col major X = T'* T 0 v^t=1
-
- or
- X
- u t row major solves
- ----------------------------------
- 0 0 L X = L'* L
- 1 0 U X = U'* U
- 0 1 L X = L * L'
- 1 1 U X = U * U'
-
- Upon successful exit T is upper triangular with positive diagonal and
- satisfies X = T' * T. T overwrites X.
-
- Notes
- Failure usually indicates X is not positive definite. Only half of X
- is accessed.
-*/
-int bCholesky(PRECISION *X, int m, int u, int t)
-{
- int i, j, k, b;
- PRECISION scale, *pX, *pXi, *pXj;
-
- if (u^t)
- if (t)
- for (i=m-1, pXi=X+i*m; i >= 0; pXi-=m, i--)
- {
- for (j=m-1, pX=X+i+j*m; j > i; pX-=m, j--) *pX=0.0;
-
- for (k=i+1; k < m; k++) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j--; j >= 0; j--)
- {
- pX-=m;
- pXj-=m;
- for (k=i+1; k < m; k++) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- else
- for (i=0, pXi=X; i < m; pXi++, i++)
- {
- for (j=0, pX=X+i*m; j < i; pX++, j++) *pX=0.0;
-
- for (k=(i-1)*m; k >= 0; k-=m) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j++; j < m; j++)
- {
- pXj++;
- pX++;
- for (k=(i-1)*m; k >= 0; k-=m) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- else
- if (t)
- for (i=0, pXi=X; i < m; pXi+=m, i++)
- {
- for (j=0, pX=X+i; j < i; pX+=m, j++) *pX=0.0;
-
- for (k=i-1; k >= 0; k--) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j++; j < m; j++)
- {
- pX+=m;
- pXj+=m;
- for (k=i-1; k >= 0; k--) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- else
- for (b=m*m, i=m-1, pXi=X+i; i >= 0; pXi--, i--)
- {
- for (j=m-1, pX=X+i*m+j; j > i; pX--, j--) *pX=0.0;
-
- for (k=(i+1)*m; k < b; k+=m) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j--; j >= 0; j--)
- {
- pXj--;
- pX--;
- for (k=(i+1)*m; k < b; k+=m) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- return NO_ERR;
-}
-
-/*
- Assumes
- x : array of length m*r*n*s
- y : array of length m*n
- z : array of length r*s
- m,n,r,s : positive
- xt,yt,zt : 0 or 1
-
- Returns
- NO_ERR : success
-
- Results
- x y z
- xt yt zt (mr x ns) (m x n) (r x s) computes
- ---------------------------------------------------------------------
- 0 0 0 row major row major row major x = y tensor z
- 1 0 0 col major row major row major x = y tensor z
- 1 1 0 col major col major row major x = y tensor z
- 0 1 0 row major col major row major x = y tensor z
- 0 0 1 row major row major col major x = y tensor z
- 1 0 1 col major row major col major x = y tensor z
- 1 1 1 col major col major col major x = y tensor z
- 0 1 1 row major col major col major x = y tensor z
-*/
-int bMatrixTensor(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int r, int s, int xt, int yt, int zt)
-{
- int iy, jy, iz, jz, k, l, stride;
- PRECISION t, *pz=z+r*s-1;
- if (xt)
- if (zt)
- {
- stride=m*r;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=(iy+1)*r-1 + ((jy+1)*s-1)*stride;
- z=pz;
- for (jz=s-1; jz >= 0; l-=stride, jz--)
- for (iz=r-1, k=l; iz >= 0; z--, k--, iz--)
- x[k]=t*(*z);
- }
- }
- else
- {
- stride=m*r;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=(iy+1)*r-1 + ((jy+1)*s-1)*stride;
- z=pz;
- for (iz=r-1; iz >= 0; l--, iz--)
- for (jz=s-1, k=l; jz >= 0; z--, k-=stride, jz--)
- x[k]=t*(*z);
- }
- }
- else
- if (zt)
- {
- stride=n*s;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=((iy+1)*r-1)*stride + (jy+1)*s-1;
- z=pz;
- for (jz=s-1; jz >= 0; l--, jz--)
- for (iz=r-1, k=l; iz >= 0; z--, k-=stride, iz--)
- x[k]=t*(*z);
-
- }
- }
- else
- {
- stride=n*s;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=((iy+1)*r-1)*stride + (jy+1)*s-1;
- z=pz;
- for (iz=r-1; iz >= 0; l-=stride, iz--)
- for (jz=s-1, k=l; jz >= 0; z--, k--, jz--)
- x[k]=t*(*z);
-
- }
- }
- return NO_ERR;
-}
-
-int bVectorTensor(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n)
-{
- int j, k;
- PRECISION s;
- for (x+=m*n-1, j=m-1; j >= 0; j--)
- for (s=y[j], k=n-1; k >= 0; x--, k--)
- *x=s*z[k];
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix_native.c b/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix_native.c
deleted file mode 100644
index 91c6f780bc082d5ee3bfb68c6b1d556a4070e330..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/bmatrix_native.c
+++ /dev/null
@@ -1,3697 +0,0 @@
-
-#include "bmatrix.h"
-#include "dw_error.h"
-
-#include <math.h>
-#include <stdlib.h>
-#include <memory.h>
-
-/********************/
-#include "blas_lapack.h"
-#define USE_BLAS_LAPACK
-/********************/
-
-/********************
-#include "mkl.h"
-#define USE_BLAS_LAPACK
-/********************/
-
-/********************
-#define USE_INLINE
-/********************/
-
-static PRECISION pythag(PRECISION a, PRECISION b);
-static int bSVD_NumericalRecipes(PRECISION *U, PRECISION *d, PRECISION *V, int m, int n);
-static int bQR_NumericalRecipes(PRECISION *Q, PRECISION *R, int m, int n);
-
-/******************************************************************************/
-/***************************** Uniary Operations ******************************/
-/******************************************************************************/
-/*
- Assumes:
- x : n-vector
- y : n-vector
- n : positive
-
- Results:
- x[i] = -y[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x and y do not have to be distinct
-*/
-int bNegative(PRECISION *x, PRECISION *y, int n)
-{
- while (--n >= 0) x[n]=-y[n];
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : n-vector
- y : n-vector
- n : positive
-
- Results:
- x[i] = fabs(y[i]) for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x and y do not have to be distinct
-*/
-int bAbs(PRECISION *x, PRECISION *y, int n)
-{
-#if defined USE_INLINE
- __asm {
- fninit
- mov edi,x
- mov esi,y
- mov eax,n
- dec eax
-a1: fld PRECISION_WORD ptr [esi+PRECISION_SIZE*eax]
- fabs
- fstp PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- dec eax
- jge a1
- }
- return NO_ERR;
-#else
- while (--n >= 0) x[n]=fabs(y[n]);
- return NO_ERR;
-#endif
-}
-
-/*
- Assumes:
- x : array of length m*n
- y : array of length m*n
- m : positive
- n : positive
- t : 0 or 1
-
-
- Results:
- x y
- t (n x m) (m x n) results
- -----------------------------------------
- 0 row major row major x = y'
- 1 col major col major x = y'
-
- or
- x y
- t (m x n) (m x n) results
- -----------------------------------------
- 0 col major row major x = y
- 1 row major col major x = y
-
- or
- x y
- t row major row major results
- -----------------------------------------
- 0 n x m m x n x = y'
- 1 m x n n x m x = y'
- or
- x y
- t col major col major results
- -----------------------------------------
- 0 m x n n x m x = y'
- 1 n x m m x n x = y'
-
-*/
-int bTranspose(PRECISION *x, PRECISION *y, int m, int n, int t)
-{
- int i, j, k;
- if (t)
- for (i=k=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; j-=m)
- x[k--]=y[j];
- else
- for (i=k=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; j-=n)
- x[k--]=y[j];
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : array of length m*m
- m : positive
-
- Results:
- x = y'
-
- Notes:
- The major format (row or column) does not matter.
-*/
-int bTransposeInPlace(PRECISION *x, int m)
-{
- PRECISION tmp;
- int i, j;
- for (j=m*m-2; j > 0; j+=i-1)
- for (i=j-m+1; i >= 0; j--, i-=m)
- {
- tmp=x[i];
- x[i]=x[j];
- x[j]=tmp;
- }
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-/******************************************************************************/
-/***************************** Addition Routines ******************************/
-/******************************************************************************/
-/*
- Assumes:
- x : n-vector
- y : n-vector
- z : n-vector
- n : positive
-
- Results:
- x[i] = y[i] + z[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bAdd(PRECISION *x, PRECISION *y, PRECISION *z, int n)
-{
-#if defined USE_INLINE
- int rtrn;
- __asm {
- fninit
- mov edi,x
- mov esi,y
- mov ebx,z
- mov eax,n
- jmp a2
-
-a1: fld PRECISION_WORD ptr [esi+PRECISION_SIZE*eax]
- fadd PRECISION_WORD ptr [ebx+PRECISION_SIZE*eax]
- fstp PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
-
-a2: dec eax
- jge a1
-
- /* check coprocessor for errors */
- fnstsw ax
- and ax,0x000D
- je a3
- mov rtrn,NO_ERR
- jmp a4
-a3: mov rtrn,FLOAT_ERR
-a4:
- }
- return rtrn;
-#else
- while (--n >= 0) x[n]=y[n]+z[n];
- return NO_ERR;
-#endif
-}
-
-/*
- Assumes:
- x : n-vector
- y : n-vector
- z : n-vector
- n : positive
-
- Results
- x[i] = y[i] - z[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bSubtract(PRECISION *x, PRECISION *y, PRECISION *z, int n)
-{
-#if defined USE_INLINE
- int rtrn;
- __asm {
- fninit
- mov edi,x
- mov esi,y
- mov ebx,z
- mov eax,n
- jmp a2
-
-a1: fld PRECISION_WORD ptr [esi+PRECISION_SIZE*eax]
- fsub PRECISION_WORD ptr [ebx+PRECISION_SIZE*eax]
- fstp PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
-
-a2: dec eax
- jge a1
-
- /* check coprocessor for errors */
- fnstsw ax
- and ax,0x000D
- je a3
- mov rtrn,NO_ERR
- jmp a4
-a3: mov rtrn,FLOAT_ERR
-a4:
- }
- return rtrn;
-#else
- while (--n >= 0) x[n]=y[n]-z[n];
- return NO_ERR;
-#endif
-}
-
-/*
- Assumes:
- x : scalar array of dimension at least m
- y : scalar array of dimension at least m
- a : scalar
- m : positive
-
- Results:
- x = x + a*y
-
- Returns:
- NO_ERR
-
- Notes:
- x and y should be distinct.
-*/
-int bLinearUpdateScalar(PRECISION *x, PRECISION *y, PRECISION a, int m)
-{
-#ifdef USE_BLAS_LAPACK
- int inc=1;
- #if (PRECISION_SIZE == 8)
- daxpy(&m,&a,y,&inc,x,&inc);
- #else
- saxpy(&m,&a,y,&inc,x,&inc);
- #endif
-#else
- while (--m >= 0) x[m]+=a*y[m];
-#endif
- return NO_ERR;
-}
-
-/*
- Assumes:
- x : m*n
- y : m*n
- z : m*n
- m : positive
- n : positive
- xt: 0 or 1
- yt: 0 or 1
- zt: 0 or 1
-
- Results:
- x = y + z
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bMatrixAdd(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int xt, int yt, int zt)
-{
- int i, j, k, s;
- if (xt == yt)
- if (yt == zt)
- for (k=m*n-1; k >= 0; k--) x[k]=y[k]+z[k];
- else
- for (s=zt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[k]+z[j];
- else
- if (yt == zt)
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]+z[j];
- else
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]+z[k];
- return NO_ERR;
-}
-
-int bMatrixSubtract(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int xt, int yt, int zt)
-{
- int i, j, k, s;
- if (xt == yt)
- if (yt == zt)
- for (k=m*n-1; k >= 0; k--) x[k]=y[k]-z[k];
- else
- for (s=zt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[k]-z[j];
- else
- if (yt == zt)
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]-z[j];
- else
- for (s=yt ? m : n, k=i=m*n-1; k >= 0; i--)
- for (j=i; j >= 0; k--, j-=s)
- x[k]=y[j]-z[k];
- return NO_ERR;
-}
-
- /*
- Assumes:
- x : m vector
- y : m vector
- z : m vector
- m : positive
- n : positive
-
- Results:
- x = a*y + b*z
-
- Returns:
- 0 upon success
-
- Notes:
- x, y and z do not have to be distinct
-*/
-int bLinearCombination(PRECISION *x, PRECISION a, PRECISION *y, PRECISION b, PRECISION *z, int m)
-{
- while (--m >= 0) x[m]=a*y[m]+b*z[m];
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-/*
- Assumes:
- x : m x n matrix
- y : n-vector
- n : positive
-
- Results:
- x[i] = s * y[i] for 0 <= i < n
-
- Returns:
- 0 upon success
-
- Notes:
- x and y do not have to be distinct
-*/
-int bMultiply(PRECISION *x, PRECISION *y, PRECISION s, int n)
-{
-#if defined USE_INLINE
- __asm {
- fninit
- mov edi,x
- mov esi,y
- mov eax,n
- dec eax
- fld s
- a1: fld PRECISION_WORD ptr [esi+PRECISION_SIZE*eax]
- fmul st,st(1)
- fstp PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- dec eax
- jge a1
- }
-#else
- while (--n >= 0) x[n]=s*y[n];
-#endif
- return NO_ERR;
-}
-
-
-/*
- Assumes:
- x : array of length mn
- y : array of length mp
- z : array of length pn
- m, n and p are positive
- xt, yt, and zt are 0 or 1
-
- Results:
- x y z
- xt yt zt (m x n) (m x p) (p x n) results
- -----------------------------------------------------------
- 0 0 0 row major row major row major x = y * z
- 1 0 0 col major row major row major x = y * z
- 0 1 0 row major col major row major x = y * z
- 1 1 0 col major col major row major x = y * z
- 0 0 1 row major row major col major x = y * z
- 1 0 1 col major row major col major x = y * z
- 0 1 1 row major col major col major x = y * z
- 1 1 1 col major col major col major x = y * z
-
- or
- x y z
- xt yt zt row major row major row major results
- ----------------------------------------------------------
- 0 0 0 m x n m x p p x n x = y * z
- 1 0 0 n x m m x p p x n x'= y * z
- 0 1 0 m x n p x m p x n x = y'* z
- 1 1 0 n x m p x m p x n x'= y'* z
- 0 0 1 m x n m x p n x p x = y * z'
- 1 0 1 n x m m x p n x p x'= y * z'
- 0 1 1 m x n p x m n x p x = y'* z'
- 1 1 1 n x m p x m n x p x'= y'* z'
-
- or
-
- x y z
- xt yt zt col major col major col major results
- -----------------------------------------------------------
- 0 0 0 n x m p x m n x p x'= y'* z'
- 1 0 0 m x n p x m n x p x = y'* z'
- 0 1 0 n x m m x p n x p x'= y * z'
- 1 1 0 m x n m x p n x p x = y * z'
- 0 0 1 n x m p x m p x n x'= y'* z
- 1 0 1 m x n p x m p x n x = y'* z
- 0 1 1 n x m m x p p x n x'= y * z
- 1 1 1 m x n m x p p x n x = y * z
-
- Returns:
- 0 upon success
-
- Notes:
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-
-*/
-
-int bMatrixMultiply(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int p, int xt, int yt, int zt)
-{
-#if defined USE_INLINE
- /*
- ebx = uj
- ecx = vi
- edx = x
- esi = pu
- edi = pv
- */
- int i, j, ui, vj, puj, pvi;
- __asm {
- fninit
- cmp yt,0
- je short dest1 // if (yt)
-
- mov ui,PRECISION_SIZE // ui=PRECISION_SIZE
-
- mov ebx,m
- shl ebx,PRECISION_SHIFT // uj=m*PRECISION_SIZE
-
- jmp short dest2 // else
-
-dest1: mov eax,p
- shl eax,PRECISION_SHIFT
- mov ui,eax // ui=p*PRECISION_SIZE
-
- mov ebx,PRECISION_SIZE // uj=PRECISION_SIZE
-
-dest2: cmp zt,0
- je short dest3 // if (zt)
-
- mov ecx,1 // vi=1
-
- mov eax,p
- shl eax,PRECISION_SHIFT
- mov vj,eax // vj=p*PRECISION_SIZE
-
- jmp short dest4 // else
-
-dest3: mov ecx,n // vi=n
-
- mov vj,PRECISION_SIZE // vj=PRECISION_SIZE
-
-dest4: mov eax,p
- dec eax
- imul eax,ecx
- mov pvi,eax // pvi=(p-1)*vi
-
- mov edx,m
- imul edx,n
- dec edx
- shl edx,PRECISION_SHIFT
- add edx,x // x+=(m*n-1)
-
- cmp xt,0
- je short dest5 // if (xt)
-
- mov eax,p
- dec eax
- imul eax,ebx
- add y,eax // y+=(p-1)*uj
-
- mov eax,n
- dec eax
- imul eax,vj // j=(n-1)*vj
-outer_1: mov j,eax
-
- mov edi,z
- add edi,eax // pv=z+j
-
- mov eax,m
- dec eax
- imul eax,ui // i=(m-1)*ui
-inner_1: mov i,eax
-
- mov esi,y
- add esi,eax // pu=y+i
-
- mov eax,pvi // k=pvi
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax] // st=(*pu)*pv[k];
-
- sub eax,ecx
- jl short dest2_1 // (k-=vi) >= 0
-
-dest1_1: sub esi,ebx // pu-=uj
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- fadd // st+=(*pu)*pv[k]
-
- sub eax,ecx
- jge short dest1_1 // (k-=vi) >= 0
-
-dest2_1: fstp PRECISION_WORD ptr [edx] // *x=st
-
- sub edx,PRECISION_SIZE // x--
-
- mov eax,i
- sub eax,ui
- jge short inner_1 // (i=i-ui) >= 0
-
- mov eax,j
- sub eax,vj
- jge short outer_1 // (j=j-vj) >= 0
-
- jmp short dest6 // else
-
-dest5: mov eax,p
- dec eax
- imul eax,ebx
- mov puj,eax // puj=(p-1)*uj;
-
- mov eax,m
- dec eax
- imul eax,ui // i=(m-1)*ui
-outer_0: mov i,eax
-
- mov esi,y
- add esi,eax // pu=y+i
-
- mov eax,n
- dec eax
- imul eax,vj // j=(n-1)*vj
-inner_0: mov j,eax
-
- mov edi,z
- add edi,eax // pv=z+j
-
- add esi,puj
- mov eax,pvi // pu+=puj
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax] // st=(*pu)*pv[k]
-
- sub eax,ecx
- jl short dest2_0 // (k-=vi) >= 0
-
-dest1_0: sub esi,ebx // pu-=uj
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- fadd // st+=(*pu)*pv[k]
-
- sub eax,ecx
- jge short dest1_0 // (k-=vi) >= 0
-
-dest2_0: fstp PRECISION_WORD ptr [edx] // *x=st
-
- sub edx,PRECISION_SIZE // x--
-
- mov eax,j
- sub eax,vj
- jge short inner_0 // (j-=vj) >= 0
-
- mov eax,i
- sub eax,ui
- jge short outer_0 // (i-=ui) >= 0
-dest6:
- }
- return NO_ERR;
-#elif defined USE_BLAS_LAPACK
- int transy, transz, dy, dz;
- PRECISION beta=0.0, alpha=1.0;
-#if PRECISION_SIZE == 4
- if (xt)
- {
- if (yt) {transy='N'; dy=m;} else {transy='T'; dy=p;}
- if (zt) {transz='N'; dz=p;} else {transz='T'; dz=n;}
- sgemm(&transy,&transz,&m,&n,&p,&alpha,y,&dy,z,&dz,&beta,x,&m);
- }
- else
- {
- if (yt) {transy='T'; dy=m;} else {transy='N'; dy=p;}
- if (zt) {transz='T'; dz=p;} else {transz='N'; dz=n;}
- sgemm(&transz,&transy,&n,&m,&p,&alpha,z,&dz,y,&dy,&beta,x,&n);
- }
-#else
- if (xt)
- {
- if (yt) {transy='N'; dy=m;} else {transy='T'; dy=p;}
- if (zt) {transz='N'; dz=p;} else {transz='T'; dz=n;}
- dgemm(&transy,&transz,&m,&n,&p,&alpha,y,&dy,z,&dz,&beta,x,&m);
- }
- else
- {
- if (yt) {transy='T'; dy=m;} else {transy='N'; dy=p;}
- if (zt) {transz='T'; dz=p;} else {transz='N'; dz=n;}
- dgemm(&transz,&transy,&n,&m,&p,&alpha,z,&dz,y,&dy,&beta,x,&n);
- }
-#endif
- return NO_ERR;
-#else
- int i, j, k, ui, uj, vi, vj, puj, pvi;
- PRECISION *pu, *pv;
- if (yt) { ui=1; uj=m; } else { ui=p; uj=1; }
- if (zt) { vi=1; vj=p; } else { vi=n; vj=1; }
- pvi=(p-1)*vi;
- x+=(m*n-1);
- if (xt)
- {
- y+=(p-1)*uj;
- for (j=(n-1)*vj; j >= 0; j-=vj)
- for (pv=z+j, i=(m-1)*ui; i >= 0; i-=ui)
- {
- k=pvi;
- pu=y+i;
- *x=(*pu)*pv[k];
- while ((k-=vi) >= 0) *x+=(*(pu-=uj))*pv[k];
- x--;
- }
- }
- else
- {
- puj=(p-1)*uj;
- for (i=(m-1)*ui; i >= 0; i-=ui)
- for (pu=y+i, j=(n-1)*vj; j >= 0; j-=vj)
- {
- k=pvi;
- pu+=puj;
- pv=z+j;
- *x=(*pu)*pv[k];
- while ((k-=vi) >= 0) *x+=(*(pu-=uj))*pv[k];
- x--;
- }
- }
- return NO_ERR;
-#endif
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/***************************** LU Decompositions ******************************/
-/******************************************************************************/
-/*
- Assumes
- p : integer array of length at least q=min(m,n)
- x : array of lenth mn
- m,n : positive
-
-
- Results:
-
- x L U P
- xt row major row major row major uses q results
- --------------------------------------------------------------
- 0 m x n m x q q x n m x m x = P * L * U
- 1 n x m n x q q x m m x m x = L * U * P'
-
- or
- x L U P
- xt col major col major col major uses q results
- --------------------------------------------------------------
- 0 n x m n x q q x m m x m x = L * U * P
- 1 m x n m x q q x n m x m x = P * L * U
-
- or
- x L U P
- xt (m x n) (m x q) (q x n) (m x m) results
- --------------------------------------------------------------
- 0 row major row major row major uses q x = P * L * U
- 1 col major col major col major uses q x = P * L * U
-
- Results
- Computes the LU decomposition of A with partial pivoting. The LU
- decomposition of a matrix A is
-
- A = P * L * U
-
- where P is a (m x m) permutation matrix, L is a (m x q) lower triangular
- matrix with ones on the diagonal, U is a (q x n) upper triangular matrix,
- and q=min(m,n). These matrices are stored as follows.
-
- U is stored in the upper part of x, including the diagonal.
-
- L is stored in the lower part of x. The diagonal of L is not stored.
-
- The matrix P is defined by
-
- P = P(0,p[0])*P(1,p[1])*...*P(q-1,p[q-1])
-
- where P(r,s) is the (m x m) matrix obtained by permuting the rth and sth
- rows of the (m x m) identity matrix. It is assumed that i <= p[i] < m.
-
- Returns
- NO_ERR - success
- SING_ERR - x was singular to machine precision. LU decomposition is
- still computed and returned.
-
- Notes
- Uses partial pivoting. Does not scale. An (n x m) matrix x is in row major
- format if x[i][j]=x[i*n+j] and is in column major format if x[i][j]=x[i+j*m].
- Only q elements of p are set.
-*/
-int bLU(int *p, PRECISION *x, int m, int n, int xt)
-{
-#if defined USE_BLAS_LAPACK
- PRECISION *y;
- int i, info;
- if (xt)
- {
-#if PRECISION_SIZE == 4
- sgetrf(&m,&n,x,&m,p,&info);
-#else
- dgetrf(&m,&n,x,&m,p,&info);
-#endif
- }
- else
- {
- if (!( y=(PRECISION*)malloc(m*n*sizeof(PRECISION)))) return MEM_ERR;
- bTranspose(y,x,m,n,0);
-
-#if PRECISION_SIZE == 4
- sgetrf(&m,&n,y,&m,p,&info);
-#else
- dgetrf(&m,&n,y,&m,p,&info);
-#endif
-
- bTranspose(x,y,m,n,1);
- free(y);
- }
- for (i=(m < n) ? m-1 : n-1; i >= 0; i--) p[i]--;
- return (info < 0) ? SING_ERR : NO_ERR;
-#else
- int a, b, c, d, i, j, k, q=(m < n) ? m : n, imax, rtrn=NO_ERR;
- PRECISION big, tmp;
- if (xt)
- {
- for (j=0; j < q; j++)
- {
- if (j == 0)
- {
- /* Find pivot */
- for (big=fabs(x[imax=0]), i=1; i < m; i++)
- if (fabs(x[i]) > big)
- {
- big=fabs(x[i]);
- imax=i;
- }
- }
- else
- {
- /* Perform stored row operations */
- for (i=1; i <= j; i++)
- {
- tmp=x[i+j*m];
- for (c=(i-1)+j*m, b=i+(i-1)*m; b >= 0; c--, b-=m) tmp-=x[b]*x[c];
- x[i+j*m]=tmp;
- }
-
- /* Perform stored row operations and find pivot */
- for (big=fabs(tmp), imax=j; i < m; i++)
- {
- tmp=x[i+j*m];
- for (c=(j-1)+j*m, b=i+(j-1)*m; b >= 0; c--, b-=m) tmp-=x[b]*x[c];
- x[i+j*m]=tmp;
- if (fabs(tmp) > big)
- {
- big=fabs(tmp);
- imax=i;
- }
- }
- }
-
- /* Interchange rows if necessary */
- if (j != imax)
- {
- p[j]=imax;
- for (a=imax+(n-1)*m, b=j+(n-1)*m; b >= 0; a-=m, b-=m)
- {
- tmp=x[a];
- x[a]=x[b];
- x[b]=tmp;
- }
- }
- else
- p[j]=j;
-
- /* Is pivot zero? */
- if (x[a=j+j*m] != 0.0)
- for (tmp=1.0/x[a], b=m-1+j*m; b > a; b--) x[b]*=tmp;
- else
- rtrn=SING_ERR;
- }
-
- /* Perform stored row operations */
- for ( ; j < n; j++)
- for (i=1; i < m; i++)
- {
- tmp=x[i+j*m];
- for (c=(i-1)+j*m, b=i+(i-1)*m; b >= 0; c--, b-=m) tmp-=x[b]*x[c];
- x[i+j*m]=tmp;
- }
-
- return rtrn;
- }
- else
- {
- for (j=0; j < q; j++)
- {
- if (j == 0)
- {
- /* Find pivot */
- for (big=fabs(x[imax=0]), a=n, i=1; i < m; a+=n, i++)
- if (fabs(x[a]) > big)
- {
- big=fabs(x[a]);
- imax=i;
- }
- }
- else
- {
- /* Perform stored row operations */
- for (d=n, a=j+n, i=1; i <= j; d+=n, a+=n, i++)
- {
- tmp=x[a];
- for (b=d, c=j, k=i; k > 0; b++, c+=n, k--) tmp-=x[b]*x[c];
- x[a]=tmp;
- }
-
- /* Perform stored row operations and find pivot */
- for (big=fabs(tmp), imax=j; i < m; d+=n, a+=n, i++)
- {
- tmp=x[a];
- for (b=d, c=j, k=j; k > 0; b++, c+=n, k--) tmp-=x[b]*x[c];
- x[a]=tmp;
- if (fabs(tmp) > big)
- {
- big=fabs(tmp);
- imax=i;
- }
- }
- }
-
- /* Interchange rows if necessary */
- if (j != imax)
- {
- p[j]=imax;
-
- for (k=n-1, a=imax*n+k, b=j*n+k; k >= 0; a--, b--, k--)
- {
- tmp=x[a];
- x[a]=x[b];
- x[b]=tmp;
- }
- }
- else
- p[j]=j;
-
- /* Is pivot zero? */
- if (x[a=j*n+j] != 0.0)
- for (tmp=1.0/x[a], a+=n, i=m*n; a < i; a+=n) x[a]*=tmp;
- else
- rtrn=SING_ERR;
- }
-
- /* Perform stored row operations */
- for ( ; j < n; j++)
- for (d=n, a=j+n, i=1; i < m; d+=n, a+=n, i++)
- {
- tmp=x[a];
- for (b=d, c=j, k=i; k > 0; b++, c+=n, k--) tmp-=x[b]*x[c];
- x[a]=tmp;
- }
-
- return rtrn;
- }
-#endif
-}
-
-/*
- Assumes
- x : array of length m*m representing a triangular matrix.
- b : array of length m*n
-
- Results
- x b/y
- u xt bt (m x m) (m x n) solve
- --------------------------------------------------
- 0 0 0 L:row major row major L * y = b
- 1 0 0 U:row major row major U * y = b
- 1 1 0 U:col major row major U * y = b
- 0 1 0 L:col major row major L * y = b
- 0 0 1 L:row major col major L * y = b
- 1 0 1 U:row major col major U * y = b
- 1 1 1 U:col major col major U * y = b
- 0 1 1 L:col major col major L * y = b
-
- or
- x
- (m x m) b/y u^xt^0
- u xt bt row major row major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 L m x n L * y = b 0
- 1 0 0 U m x n U * y = b 1
- 1 1 0 L m x n L'* y = b 0
- 0 1 0 U m x n U'* y = b 1
- 0 0 1 L n x m L * y'= b' (y * L'= b) 0
- 1 0 1 U n x m U * y'= b' (y * U'= b) 1
- 1 1 1 L n x m L'* y'= b' (y * L = b) 0
- 0 1 1 U n x m U'* y'= b' (y * U = b) 1
-
- or
- x
- (m x m) b/y u^xt^1
- u xt bt col major col major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 U m x n U'* y'= b' (y * U = b) 1
- 1 0 0 L m x n L'* y'= b' (y * L = b) 0
- 1 1 0 U m x n U * y'= b' (y * U'= b) 1
- 0 1 0 L m x n L * y'= b' (y * L'= b) 0
- 0 0 1 U n x m U'* y = b 1
- 1 0 1 L n x m L'* y = b 0
- 1 1 1 U n x m U * y = b 1
- 0 1 1 L n x m L * y = b 0
-
- The solution y is stored in b.
-
- Returns
- 0 (NO_ERR) - success
- SING_ERR - x is singular
-
- Notes
- Because this routines tests using the xor operator, the values of u and xt
- must be either 0 or 1. The matrix x is assumed to be triangular. Care
- must be taken that the matrix is either upper or lower triangular in the
- correct format.
-
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-*/
-int bSolveTriangular(PRECISION *x, PRECISION *b, int m, int n, int u, int xt, int bt)
-{
-#if defined USE_INLINE
- int i, j, bi, bj, xi, xj, mbi;
- PRECISION *pxx;
- for (j=m+1, i=m*m-1; i >= 0; i-=j) if (x[i] == 0.0) return SING_ERR;
- if (xt) { xi=1; xj=m; } else { xi=m; xj=1; }
- if (bt) { bi=1; bj=m; } else { bi=n; bj=1; }
- mbi=(m-1)*bi;
- if (u)
- for (x+=(m-1)*xj, j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x+(m-1)*xi, i=(m-1)*bi; i >= 0; pxx-=xi, i-=bi)
- __asm {
- fninit
- mov esi,pxx
- mov eax,i
- mov edi,eax
- shl edi,PRECISION_SHIFT
- add edi,b
-
- fld PRECISION_WORD ptr [edi] // st=*pb
-
- sub eax,mbi
- neg eax
- je short dest2_1 // (k=mbi-i) > 0
-
- mov ebx,xj
- shl ebx,PRECISION_SHIFT
- mov ecx,bi
-
-dest1_1: fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- fsub // st-=(*px)*pb[k]
-
- sub esi,ebx // px-=bi
-
- sub eax,ecx
- jg short dest1_1 // (k-=bi) > 0
-
-dest2_1: fld PRECISION_WORD ptr [esi]
- fdiv
- fstp PRECISION_WORD ptr [edi] // *pb=st/(*px)
- }
- else
- for (j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x, i=0; i <= mbi; pxx+=xi, i+=bi)
- __asm {
- fninit
- mov esi,pxx
- mov eax,i
- mov edi,eax
- shl edi,PRECISION_SHIFT
- add edi,b
-
- fld PRECISION_WORD ptr [edi] // st=*pb
-
- neg eax
- je short dest2_0 // (k=-i) < 0
-
- mov ebx,xj
- shl ebx,PRECISION_SHIFT
- mov ecx,bi
-
-dest1_0: fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- fsub // st-=(*px)*pb[k]
-
- add esi,ebx // px+=bi
-
- add eax,ecx
- jl short dest1_0 // (k+=bi) < 0
-
-dest2_0: fld PRECISION_WORD ptr [esi]
- fdiv
- fstp PRECISION_WORD ptr [edi] // *pb=st/(*px)
- }
- return NO_ERR;
-#else
- int i, j, k, bi, bj, xi, xj, mbi;
- PRECISION *pxx, *px, *pb;
- for (j=m+1, i=j*(m-1); i >= 0; i-=j) if (x[i] == 0.0) return SING_ERR;
- if (xt) { xi=1; xj=m; } else { xi=m; xj=1; }
- if (bt) { bi=1; bj=m; } else { bi=n; bj=1; }
- mbi=(m-1)*bi;
- if (u)
- for (x+=(m-1)*xj, j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x+(m-1)*xi, i=(m-1)*bi; i >= 0; pxx-=xi, i-=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=mbi-i; k > 0; px-=xj, k-=bi) (*pb)-=(*px)*pb[k];
- *pb/=(*px);
- }
- else
- {
- for (j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x, i=0; i <= mbi; pxx+=xi, i+=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=-i; k < 0; px+=xj, k+=bi) (*pb)-=(*px)*pb[k];
- *pb/=(*px);
- }
- }
- return NO_ERR;
-#endif
-}
-
-/*
- Assumes
- x : array of length m*m representing a triangular matrix with unit diagonal
- b : array of length m*n
-
- Results
- x b/y
- u xt bt (m x m) (m x n) solve
- --------------------------------------------------
- 0 0 0 L:row major row major L * y = b
- 1 0 0 U:row major row major U * y = b
- 1 1 0 U:col major row major U * y = b
- 0 1 0 L:col major row major L * y = b
- 0 0 1 L:row major col major L * y = b
- 1 0 1 U:row major col major U * y = b
- 1 1 1 U:col major col major U * y = b
- 0 1 1 L:col major col major L * y = b
-
- or
- x
- (m x m) b/y u^xt^0
- u xt bt row major row major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 L m x n L * y = b 0
- 1 0 0 U m x n U * y = b 1
- 1 1 0 L m x n L'* y = b 0
- 0 1 0 U m x n U'* y = b 1
- 0 0 1 L n x m L * y'= b' (y * L'= b) 0
- 1 0 1 U n x m U * y'= b' (y * U'= b) 1
- 1 1 1 L n x m L'* y'= b' (y * L = b) 0
- 0 1 1 U n x m U'* y'= b' (y * U = b) 1
-
- or
- x
- (m x m) b/y u^xt^1
- u xt bt col major col major solve (u^xt^major_form)
- ----------------------------------------------------------------------------
- 0 0 0 U m x n U'* y'= b' (y * U = b) 1
- 1 0 0 L m x n L'* y'= b' (y * L = b) 0
- 1 1 0 U m x n U * y'= b' (y * U'= b) 1
- 0 1 0 L m x n L * y'= b' (y * L'= b) 0
- 0 0 1 U n x m U'* y = b 1
- 1 0 1 L n x m L'* y = b 0
- 1 1 1 U n x m U * y = b 1
- 0 1 1 L n x m L * y = b 0
-
-
- The solution y is stored in b.
-
- Returns
- 0 (NO_ERR) - success
-
- Notes
- If f is zero for row major format and one for a column major format, then
- passing xt = 1^f (1 xor f) implies an upper triangular matrix is passed,
- and passing xt = 0^f implies a lower triangular matrix is passed.
-
- The matrix x is assumed to be triangular with unit diagonal. Care must be
- taken that the matrix is either upper or lower triangular in the correct
- format.
-
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-*/
-int bSolveUnitTriangular(PRECISION *x, PRECISION *b, int m, int n, int u, int xt, int bt)
-{
-#if defined USE_INLINE
- int i, j, bi, bj, xi, xj, mbi;
- PRECISION *pxx;
- if (xt) { xi=1; xj=m; } else { xi=m; xj=1; }
- if (bt) { bi=1; bj=m; } else { bi=n; bj=1; }
- mbi=(m-1)*bi;
- if (u)
- for (x+=(m-1)*xj, j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x+(m-1)*xi, i=(m-1)*bi; i >= 0; pxx-=xi, i-=bi)
- __asm { // eax ebx ecx edx esi edi st(0) st(1)
- mov eax,i // k=i k
- mov edi,eax // pb=i k pb
- sub eax,mbi // k=i-mbi k pb
- neg eax // k=mbi-i k pb
- je short a2 // jump if k > 0 k pb
-
- shl edi,PRECISION_SHIFT // pb=i*PRECISION_SIZE k pb
- add edi,b // pb=b+i*PRECISION_SIZE k pb
- mov esi,pxx // px=pxx k px pb
- mov ebx,xj // ebx=xj k xj px pb
- shl ebx,PRECISION_SHIFT // ebx=xj*PRECISION_SIZE k xj px pb
- mov ecx,bi // ecx=bi k xj bi px pb
-
- fld PRECISION_WORD ptr [edi] // st=pb[0] k xj bi px pb pb[0]
-
-a1: // assumes k xj bi px pb pb[0]
- fld PRECISION_WORD ptr [esi] // st=*px k xj bi px pb *px pb[0]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax] // st=pb[k]*(*px) k xj bi px pb pb[k]*(*px) pb[0]
- fsub // st=pb[0]-(*px)*pb[k] k xj bi px pb pb[0]
-
- sub esi,ebx // px-=xj k xj bi px pb pb[0]
-
- sub eax,ecx // k-=bi k xj bi px pb pb[0]
- jg short a1 // jump if k > 0 k xj bi px pb pb[0]
-
- fstp PRECISION_WORD ptr [edi] // pb[0]=st k xj bi px pb
-a2:
- }
- else
- for (j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x, i=0; i <= mbi; pxx+=xi, i+=bi)
- __asm {
- mov eax,i
- mov edi,eax
- neg eax
- je short dest2_0 // (k=-i) < 0
-
- mov esi,pxx
- shl edi,PRECISION_SHIFT
- add edi,b
- mov ebx,xj
- shl ebx,PRECISION_SHIFT
- mov ecx,bi
-
- fld PRECISION_WORD ptr [edi] // st=*pb
-
-dest1_0: fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- fsub // st-=(*px)*pb[k]
-
- add esi,ebx // px+=bi
-
- add eax,ecx
- jl short dest1_0 // (k+=bi) < 0
-
- fstp PRECISION_WORD ptr [edi] // *pb=st
-dest2_0:
- }
-#else
- int i, j, k, bi, bj, xi, xj, mbi;
- PRECISION *pxx, *px, *pb;
- if (xt) { xi=1; xj=m; } else { xi=m; xj=1; }
- if (bt) { bi=1; bj=m; } else { bi=n; bj=1; }
- mbi=(m-1)*bi;
- if (u)
- for (x+=(m-1)*xj, j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x+(m-1)*xi, i=(m-1)*bi; i >= 0; pxx-=xi, i-=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=mbi-i; k > 0; px-=xj, k-=bi) (*pb)-=(*px)*pb[k];
- }
- else
- {
- for (j=(n-1)*bj, b+=j; j >= 0; b-=bj, j-=bj)
- for (pxx=x, i=0; i <= mbi; pxx+=xi, i+=bi)
- {
- px=pxx;
- pb=b+i;
- for (k=-i; k < 0; px+=xj, k+=bi) (*pb)-=(*px)*pb[k];
- }
- }
-#endif
- return NO_ERR;
-}
-
-/*
- Assumes
- p : integer array of length q with 0 <= p[i] < m for all 0 <= i < q.
- y : array of length mn
-
- Results
- x/y
- pt yt row major product
- ---------------------------------------------
- 0 0 m x n x = P * y
- 1 0 m x n x = P'* y
- 0 1 n x m x'= P * y' (x = y * P')
- 1 1 n x m x'= P'* y' (x = y * P )
-
- or
-
- x/y
- pt yt col major product
- ---------------------------------------------
- 0 0 n x m x'= P * y' (x = y * P')
- 1 0 n x m x'= P'* y' (x = y * P )
- 0 1 m x n x = P * y
- 1 1 m x n x = P'* y
-
- or
- x/y
- pt yt (m x n) product
- -------------------------------
- 0 0 row major x = P * y
- 1 0 row major x = P'* y
- 0 1 col major x = P * y
- 1 1 col major x = P'* y
-
- The matrix P is defined by
-
- P = P(0,p[0])*P(1,p[1])*...*P(q-1,p[q])
-
- where P(r,s) is the (m x m) matrix obtained by permuting the rth and sth
- rows of the (m x m) identity matrix.
-
- Notes:
- An (n x m) matrix x is in row major format if x[i][j]=x[i*n+j] and is in
- column major format if x[i][j]=x[i+j*m].
-*/
-int bPermutationMultiply(int *p, PRECISION *y, int m, int n, int q, int pt, int yt)
-{
- int i, j, k, pk;
- PRECISION tmp;
- if (yt)
- if (pt)
- for (j=0; j < q; j++)
- {
- if (j != p[j])
- for (i=(n-1)*m; i >= 0; i-=m)
- {
- tmp=y[i+j];
- y[i+j]=y[i+p[j]];
- y[i+p[j]]=tmp;
- }
- }
- else
- for (j=q-1; j >= 0; j--)
- {
- if (j != p[j])
- for (i=(n-1)*m; i >= 0; i-=m)
- {
- tmp=y[i+j];
- y[i+j]=y[i+p[j]];
- y[i+p[j]]=tmp;
- }
- }
- else
- if (pt)
- for (i=0; i < q; i++)
- {
- if (i != p[i])
- {
- k=i*n;
- pk=p[i]*n;
- for (j=n-1; j >= 0; j--)
- {
- tmp=y[k+j];
- y[k+j]=y[pk+j];
- y[pk+j]=tmp;
- }
- }
- }
- else
- for (i=q-1; i >= 0; i--)
- {
- if (i != p[i])
- {
- k=i*n;
- pk=p[i]*n;
- for (j=n-1; j >= 0; j--)
- {
- tmp=y[k+j];
- y[k+j]=y[pk+j];
- y[pk+j]=tmp;
- }
- }
- }
- return NO_ERR;
-}
-
-/*
- Assumes
- p : integer array of length q with i <= p[i] < m for all 0 <= i < m.
- x : PRECISION array of length m*m
-
- Results
- If P(i,j) is the identity matrix with the ith and jth columns permuted,
- the the permutation matrix is defined from p is
-
- P = P(0,p[0])*P(1,p[1])*...*P(q-1,p[q-1])
-
- Then
- x
- xt row major
- ----------------
- 0 x = P
- 1 x = P'
-
- or
- x
- xt col major
- ----------------
- 0 x = P'
- 1 x = P
-
-
- if where P(r,s) is the (m x m) matrix obtained by permuting the rth and sth
- rows of the (m x m) identity matrix.
-
- Notes:
- Permuting the ith and jth columns of an identity matrix is equivalent to
- permuting the ith and jth rows. An (n x m) matrix x is in row major
- format if x[i][j]=x[i*n+j] and is in column major format if
- x[i][j]=x[i+j*m].
-*/
-int bPermutation(PRECISION *x, int *p, int m, int q, int xt)
-{
- int i, j, k;
- for (k=m*m-1; k >= 0; k--) x[k]=0.0;
- if (xt)
- for (j=m-1; j >= 0; j--)
- {
- if (j < q)
- {
- k=j-1;
- i=p[j];
- }
- else
- {
- k=q-1;
- i=j;
- }
- for ( ; k >= 0; k--) if (i == p[k]) i=k;
- x[i+j*m]=1.0;
- }
- else
- for (j=m-1; j >= 0; j--)
- {
- if (j < q)
- {
- k=j-1;
- i=p[j];
- }
- else
- {
- k=q-1;
- i=j;
- }
- for ( ; k >= 0; k--) if (i == p[k]) i=k;
- x[i*m+j]=1.0;
- }
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-
-/******************************************************************************/
-/************************ Singular Value Decomposition ************************/
-/******************************************************************************/
-/*
- results
- returns sqrt(a^2 + b^2)
-*/
-static PRECISION pythag(PRECISION a, PRECISION b)
-{
- PRECISION absa=fabs(a), absb=fabs(b), quotient;
-
- if (absa > absb)
- {
- quotient=absb/absa;
- return absa*sqrt(1.0+quotient*quotient);
- }
-
- if (absb == 0) return 0.0;
-
- quotient=absa/absb;
- return absb*sqrt(1.0+quotient*quotient);
-}
-
-/*
- Assumes
- U : m x n matrix in row major format
- d : n-vector
- V : n x n matrix in row major format
-
- Returns
- 0 (NO_ERR) : success
- MEM_ERR : out of memory
- ITER_ERR : maximum number of iterations (MAX_ITER) exceeded
-
- Results
- Finds U, V and d such that U = U * diag(d) * V'. U and V are orthogonal
- matrices and the elemets of d are non-negative. U is orthogonal in the
- sense that U'*U and U*U' are diagonal matrices with ones and zeros along
- the diagonal.
-
- Notes
- Based on Numerical Recipes in C routines.
-*/
-#define MAX_ITER 100
-static int bSVD_NumericalRecipes(PRECISION *U, PRECISION *d, PRECISION *V, int m, int n)
-{
- int flag, i, its, j, jj, k, l, nm;
- PRECISION anorm, c, f, g, h, s, scale, x, y, z, *rv1, tmp;
-
- rv1=(PRECISION*)malloc(n*sizeof(PRECISION));
- if (!rv1) return MEM_ERR;
- g=scale=anorm=0.0;
-
- for (i=0; i < n; i++)
- {
- l=i+1;
- rv1[i]=scale*g;
- g=s=scale=0.0;
-
- if (i < m)
- {
- for (k=i; k < m; k++) scale+=fabs(U[k*n+i]);
-
- if (scale)
- {
- for (k=i; k < m; k++)
- {
- U[k*n+i]/=scale;
- s+=U[k*n+i]*U[k*n+i];
- }
-
- f=U[i*n+i];
- g=(f >= 0) ? -sqrt(s) : sqrt(s);
- h=f*g-s;
- U[i*n+i]=f-g;
-
- for (j=l; j < n; j++)
- {
- for (s=0.0, k=i; k < m; k++) s+=U[k*n+i]*U[k*n+j];
- f=s/h;
- for (k=i; k < m; k++) U[k*n+j]+=f*U[k*n+i];
- }
-
- for (k=i; k < m; k++) U[k*n+i]*=scale;
- }
- }
-
- d[i]=scale *g;
- g=s=scale=0.0;
- if (i < m && i != n-1)
- {
- for (k=l; k < n; k++) scale+=fabs(U[i*n+k]);
-
- if (scale)
- {
- for (k=l; k < n; k++)
- {
- U[i*n+k]/=scale;
- s+=U[i*n+k]*U[i*n+k];
- }
-
- f=U[i*n+l];
- g=(f >= 0) ? -sqrt(s) : sqrt(s);
- h=f*g-s;
- U[i*n+l]=f-g;
-
- for (k=l; k < n; k++) rv1[k]=U[i*n+k]/h;
- for (j=l; j < m; j++)
- {
- for (s=0.0, k=l; k < n; k++) s+=U[j*n+k]*U[i*n+k];
- for (k=l; k < n; k++) U[j*n+k]+=s*rv1[k];
- }
-
- for (k=l; k < n; k++) U[i*n+k]*=scale;
- }
- }
-
- if (anorm < (tmp=fabs(d[i])+fabs(rv1[i]))) anorm=tmp;
- }
-
- for (i=n-1; i >= 0; i--)
- {
- if (i < n-1)
- {
- if (g)
- {
- for (j=l; j < n; j++) V[j*n+i]=(U[i*n+j]/U[i*n+l])/g;
- for (j=l; j < n; j++)
- {
- for (s=0.0, k=l; k < n; k++) s+=U[i*n+k]*V[k*n+j];
- for (k=l; k < n; k++) V[k*n+j]+=s*V[k*n+i];
- }
- }
-
- for (j=l; j < n; j++) V[i*n+j]=V[j*n+i]=0.0;
- }
-
- V[i*n+i]=1.0;
- g=rv1[i];
- l=i;
- }
-
- for (i=(m < n) ? m-1 : n-1; i >= 0; i--)
- {
- l=i+1;
- g=d[i];
-
- for (j=l; j < n; j++) U[i*n+j]=0.0;
-
- if (g)
- {
- g=1.0/g;
-
- for (j=l; j < n; j++)
- {
- for (s=0.0, k=l; k < m; k++) s+=U[k*n+i]*U[k*n+j];
- f=(s/U[i*n+i])*g;
- for (k=i; k < m; k++) U[k*n+j]+=f*U[k*n+i];
- }
-
- for (j=i; j < m; j++) U[j*n+i]*=g;
- }
- else
- for (j=i; j < m; j++) U[j*n+i]=0.0;
-
- ++U[i*n+i];
- }
-
- for (k=n-1; k >= 0; k--)
- {
- for (its=1; its <= 30; its++)
- {
- flag=1;
- for (l=k; l >= 0; l--)
- {
- nm=l-1;
-
- if ((PRECISION)(fabs(rv1[l])+anorm) == anorm)
- {
- flag=0;
- break;
- }
-
- if ((PRECISION)(fabs(d[nm])+anorm) == anorm) break;
- }
-
- if (flag)
- {
- c=0.0;
- s=1.0;
-
- for (i=l; i <= k; i++)
- {
- f=s*rv1[i];
- rv1[i]=c*rv1[i];
-
- if ((PRECISION)(fabs(f)+anorm) == anorm) break;
-
- g=d[i];
- h=pythag(f,g);
- d[i]=h;
- h=1.0/h;
- c=g*h;
- s=-f*h;
-
- for (j=0; j < m; j++)
- {
- y=U[j*n+nm];
- z=U[j*n+i];
- U[j*n+nm]=y*c+z*s;
- U[j*n+i]=z*c-y*s;
- }
- }
- }
-
- z=d[k];
-
- if (l == k)
- {
- if (z < 0.0)
- {
- d[k]=-z;
- for (j=0; j < n; j++) V[j*n+k]=-V[j*n+k];
- }
-
- break;
- }
-
- if (its >= MAX_ITER)
- {
- free(rv1);
- return ITERATION_ERR;
- }
-
- x=d[l];
- nm=k-1;
- y=d[nm];
- g=rv1[nm];
- h=rv1[k];
- f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
- g=pythag(f,1.0);
- f=((x-z)*(x+z)+h*((y/(f+((f >= 0.0) ? fabs(g) : -fabs(g))))-h))/x;
- c=s=1.0;
-
- for (j=l; j <= nm; j++)
- {
- i=j+1;
- g=rv1[i];
- y=d[i];
- h=s*g;
- g=c*g;
- z=pythag(f,h);
- rv1[j]=z;
- c=f/z;
- s=h/z;
- f=x*c+g*s;
- g=g*c-x*s;
- h=y*s;
- y*=c;
-
- for (jj=0; jj < n; jj++)
- {
- x=V[jj*n+j];
- z=V[jj*n+i];
- V[jj*n+j]=x*c+z*s;
- V[jj*n+i]=z*c-x*s;
- }
-
- z=pythag(f,h);
- d[j]=z;
-
- if (z)
- {
- z=1.0/z;
- c=f*z;
- s=h*z;
- }
-
- f=c*g+s*y;
- x=c*y-s*g;
-
- for (jj=0; jj < m; jj++)
- {
- y=U[jj*n+j];
- z=U[jj*n+i];
- U[jj*n+j]=y*c+z*s;
- U[jj*n+i]=z*c-y*s;
- }
- }
-
- rv1[l]=0.0;
- rv1[k]=f;
- d[k]=x;
- }
- }
-
- free(rv1);
-
- return 0;
-}
-#undef MAX_ITER
-
-/*
- Assumes
- U : array of length m*m (compact=0) or m*q (compact=1) or null
- d : array of length q=min(m,n)
- V : array of length n*n (compact=0) or n*q (compact=1) or null
- A : array of length m*n
- m : positive
- n : positive
- ut : 0 or 1
- vt : 0 or 1
- at : 0 or 1
- compact : 0 or 1
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- ITER_ERR : maximum number of iterations (MAX_ITER) exceeded - only if
- numerical recipe routines are used.
-
- Results
- Finds matrices U and V with orthonormal columns and a diagonal matrix
- D=diag(d) with non-negative diagonal such that A = U*D*V'. The matrix D is
- m x n if compact = 0 and is q x q if compact = 1. The flags ut, vt, and at
- determine the format of U, V, and A. A value of 1 indicates column major
- format and a value of 0 indicates row major format. If either U or V is
- null, then it is not computed.
-
- Notes
- If A=U, U and A must be of the same size and ut=at. If A=V, then V and A
- must be of the same size and vt=at. It cannot be the case that U=V unless
- both are null.
-*/
-int bSVD_new(PRECISION *U, PRECISION *d, PRECISION *V, PRECISION *A, int m, int n, int ut, int vt, int at, int compact)
-{
-#if defined USE_BLAS_LAPACK
-
-#if (PRECISION_SIZE == 4)
-#define gesdd sgesdd
-#define gesvd sgesvd
-#else
-#define gesdd dgesdd
-#define gesvd dgesvd
-#endif
-
- int jobu, jobv, jobt, k=-1, info, err, m_, n_, qu_, qv_, transpose;
- PRECISION *A_, *U_, *V_, *work, opt_size;
-
- A_=(PRECISION*)malloc(m*n*sizeof(PRECISION));
-
- jobu=jobv=compact ? 'S' : 'A';
-
- if (!U)
- {
- jobu='N';
- if (!V)
- {
- jobv='N';
- vt=transpose=1-at;
- }
- else
- transpose=vt;
- ut=1-vt;
- }
- else
- if (!V)
- {
- jobv='N';
- vt=transpose=1-ut;
- }
- else
- {
- if (ut != vt)
- transpose=vt;
- else
- transpose=1-at;
- }
-
- if (transpose)
- {
- jobt=jobu;
- jobu=jobv;
- jobv=jobt;
- if (at)
- bTranspose(A_,A,m,n,at);
- else
- memcpy(A_,A,m*n*sizeof(PRECISION));
- if (compact)
- {
- m_=n;
- n_=m;
- qu_=qv_=(m < n) ? m : n;
- }
- else
- {
- qu_=m_=n;
- qv_=n_=m;
- }
- U_=vt ? V : (PRECISION*)malloc(m_*qu_*sizeof(PRECISION));
- V_=ut ? (PRECISION*)malloc(qv_*n_*sizeof(PRECISION)) : U;
- }
- else
- {
- if (at)
- memcpy(A_,A,m*n*sizeof(PRECISION));
- else
- bTranspose(A_,A,m,n,at);
- if (compact)
- {
- m_=m;
- n_=n;
- qu_=qv_=(m < n) ? m : n;
- }
- else
- {
- qu_=m_=m;
- qv_=n_=n;
- }
- U_=ut ? U : (PRECISION*)malloc(m_*qu_*sizeof(PRECISION));
- V_=vt ? (PRECISION*)malloc(qv_*n_*sizeof(PRECISION)) : V;
- }
-
- // compute singular value decomposition
- gesvd(&jobu,&jobv,&m_,&n_,A_,&m_,d,U_,&m_,V_,&qv_,&opt_size,&k,&info);
- if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION))))
- err=info ? BLAS_LAPACK_ERR : MEM_ERR;
- else
- {
- gesvd(&jobu,&jobv,&m_,&n_,A_,&m_,d,U_,&m_,V_,&qv_,work,&k,&info);
- free(work);
- if (info)
- err=BLAS_LAPACK_ERR;
- else
- {
- if (transpose)
- {
- if (U != V_)
- bTranspose(U,V_,qv_,n_,1);
- else
- if (V != U_)
- bTranspose(V,U_,m_,qu_,1);
- }
- else
- {
- if (U != U_)
- bTranspose(U,U_,m_,qu_,1);
- else
- if (V != V_)
- bTranspose(V,V_,qv_,n_,1);
- }
- err=NO_ERR;
- }
- }
-
- free(A_);
-
- if (transpose)
- {
- if (U != V_)
- free(V_);
- else
- if (V != U_)
- free(U_);
- }
- else
- {
- if (U != U_)
- free(U_);
- else
- if (V != V_)
- free(V_);
- }
-
- return err;
-
-#else
-
- PRECISION *NU;
- int i, j, rtrn;
-
- if (m == n)
- {
- if (at)
- if (U != A)
- bTranspose(U,A,m,m,at);
- else
- bTransposeInPlace(U,m);
- else
- if (U != A)
- memcpy(U,A,m*m*sizeof(PRECISION));
-
- bSVD_NumericalRecipes(U,d,V,m,m);
- rtrn=NO_ERR;
- }
- else
- if (m < n)
- if (!(NU=(PRECISION*)malloc(m*n*sizeof(PRECISION))))
- rtrn=MEM_ERR;
- else
- {
- if (at)
- memcpy(NU,A,m*n*sizeof(PRECISION));
- else
- bTranspose(NU,A,n,m,1);
- bSVD_NumericalRecipes(NU,d,U,n,m);
- bQR_NumericalRecipes(V,NU,n,m);
- for (i=m-1; i >= 0; i--)
- if (NU[i*m+i] < 0)
- for (j=(n-1)*n+i; j >= 0; j-=n) V[j]=-V[j];
- rtrn=NO_ERR;
-/* if (!(nd=(PRECISION*)malloc(n*sizeof(PRECISION)))) */
-/* rtrn=MEM_ERR; */
-/* else */
-/* { */
-/* if (at) */
-/* bTranspose(NU,A,m,n,at); */
-/* else */
-/* memcpy(NU,A,m*n*sizeof(PRECISION)); */
-/* bSVD_NumericalRecipes(NU,nd,V,m,n); */
-/* for (i=m-1; i >= 0; i--) memcpy(U+i*m,NU+i*n,m*sizeof(PRECISION)); */
-/* memcpy(d,nd,m*sizeof(PRECISION)); */
-/* rtrn=NO_ERR; */
-/* free(nd); */
-/* } */
- free(NU);
- }
- else
- if (!(NU=(PRECISION*)malloc(m*n*sizeof(PRECISION))))
- rtrn=MEM_ERR;
- else
- {
- if (at)
- bTranspose(NU,A,m,n,at);
- else
- memcpy(NU,A,m*n*sizeof(PRECISION));
- bSVD_NumericalRecipes(NU,d,V,m,n);
- bQR_NumericalRecipes(U,NU,m,n);
- for (i=n-1; i >= 0; i--)
- if (NU[i*n+i] < 0)
- for (j=(m-1)*m+i; j >= 0; j-=m) U[j]=-U[j];
- rtrn=NO_ERR;
- free(NU);
- }
- if (vt) bTransposeInPlace(V,n);
- if (ut) bTransposeInPlace(U,m);
- return rtrn;
-
-#endif
-}
-
-/*
- Assumes
- U : array of length m*m
- d : array of length q=min(m,n)
- V : array of length n*n
- A : array of length m*n
- m : positive
- n : positive
- ut : 0 or 1
- vt : 0 or 1
- at : 0 or 1
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- ITER_ERR : maximum number of iterations (MAX_ITER) exceeded - only if
- numerical recipe routines are used.
-
- Results
- A U V d
- ut vt at (m x n) (m x m) (n x n) diagonal solves
- ---------------------------------------------------------------------
- 0 0 0 row major row major row major m x n A = U * D * V'
- 1 0 0 row major col major row major m x n A = U * D * V'
- 1 1 0 row major col major col major m x n A = U * D * V'
- 0 1 0 row major row major col major m x n A = U * D * V'
- 0 0 1 col major row major row major m x n A = U * D * V'
- 1 0 1 col major col major row major m x n A = U * D * V'
- 1 1 1 col major col major col major m x n A = U * D * V'
- 0 1 1 col major row major col major m x n A = U * D * V'
-
- A U V d
- ut vt at row major row major row major diagonal solves
- ---------------------------------------------------------------------
- 0 0 0 m x n m x m n x n m x n A = U * D * V'
- 1 0 0 m x n m x m n x n m x n A = U'* D * V'
- 1 1 0 m x n m x m n x n m x n A = U'* D * V
- 0 1 0 m x n m x m n x n m x n A = U * D * V
- 0 0 1 n x m m x m n x n m x n A'= U * D * V'
- 1 0 1 n x m m x m n x n m x n A'= U'* D * V'
- 1 1 1 n x m m x m n x n m x n A'= U'* D * V
- 0 1 1 n x m m x m n x n m x n A'= U * D * V
-
- A U V d
- ut vt at col major col major col major diagonal solves
- ---------------------------------------------------------------------
- 0 0 0 n x m m x m n x n m x n A'= U'* D * V
- 1 0 0 n x m m x m n x n m x n A'= U * D * V
- 1 1 0 n x m m x m n x n m x n A'= U * D * V'
- 0 1 0 n x m m x m n x n m x n A'= U'* D * V'
- 0 0 1 m x n m x m n x n m x n A = U'* D * V
- 1 0 1 m x n m x m n x n m x n A = U * D * V
- 1 1 1 m x n m x m n x n m x n A = U * D * V'
- 0 1 1 m x n m x m n x n m x n A = U'* D * V'
-
-
- U and V are orthogonal matrices and the elemets of d are non-negative.
-
- Notes
- The lapack routine is avoids unnecessary transpositions when ut == at and
- vt = 1-at. When m=n, A can be equal to U or V. U and V must be distinct.
-*/
-int bSVD(PRECISION *U, PRECISION *d, PRECISION *V, PRECISION *A, int m, int n, int ut, int vt, int at)
-{
-#if defined USE_BLAS_LAPACK
-#if (PRECISION_SIZE == 4)
-#define gesdd sgesdd
-#define gesvd sgesvd
-#else
-#define gesdd dgesdd
-#define gesvd dgesvd
-#endif
- int jobz='A', k, *iwork, info;
- PRECISION *X, *work, opt_size;
- if (!(X=(PRECISION*)malloc(m*n*sizeof(PRECISION)))) return MEM_ERR;
- memcpy(X,A,m*n*sizeof(PRECISION));
- if (!(iwork=(int*)malloc(8*((m < n) ? m : n)*sizeof(int))))
- {
- free(X);
- return MEM_ERR;
- }
- k=-1;
- if (at)
- {
-/* gesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,iwork,&info); */
-/* if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return info ? BLAS_LAPACK_ERR : MEM_ERR; */
-/* } */
-/* gesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,iwork,&info); */
-/* if (info) */
-/* { */
-/* free(work); */
- memcpy(X,A,m*n*sizeof(PRECISION));
- k=-1;
- gesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,&info);
- if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION))))
- {
- free(iwork);
- free(X);
- return info ? BLAS_LAPACK_ERR : MEM_ERR;
- }
- gesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,&info);
- if (info)
- {
- free(iwork);
- free(X);
- return BLAS_LAPACK_ERR;
- }
-/* } */
- if (!ut)
- bTransposeInPlace(U,m);
- if (vt)
- bTransposeInPlace(V,n);
- }
- else
- {
-/* gesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,iwork,&info); */
-/* if (!(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return MEM_ERR; */
-/* } */
-/* gesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,iwork,&info); */
-/* if (info) */
-/* { */
-/* free(work); */
- memcpy(X,A,m*n*sizeof(PRECISION));
- k=-1;
- gesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,&info);
- if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION))))
- {
- free(iwork);
- free(X);
- return info ? BLAS_LAPACK_ERR : MEM_ERR;
- }
- gesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,&info);
- if (info)
- {
- free(iwork);
- free(X);
- return BLAS_LAPACK_ERR;
- }
-/* } */
- if (!vt)
- bTransposeInPlace(V,n);
- if (ut)
- bTransposeInPlace(U,m);
- }
- free(work);
- free(iwork);
- free(X);
- return NO_ERR;
-#undef gesdd
-#undef gesvd
-#else
- // bSVD
- PRECISION *NU;
- int i, j, rtrn;
-
- if (m == n)
- {
- if (at)
- if (U != A)
- bTranspose(U,A,m,m,at);
- else
- bTransposeInPlace(U,m);
- else
- if (U != A)
- memcpy(U,A,m*m*sizeof(PRECISION));
-
- bSVD_NumericalRecipes(U,d,V,m,m);
- rtrn=NO_ERR;
- }
- else
- if (m < n)
- if (!(NU=(PRECISION*)malloc(m*n*sizeof(PRECISION))))
- rtrn=MEM_ERR;
- else
- {
- if (at)
- memcpy(NU,A,m*n*sizeof(PRECISION));
- else
- bTranspose(NU,A,n,m,1);
- bSVD_NumericalRecipes(NU,d,U,n,m);
- bQR_NumericalRecipes(V,NU,n,m);
- for (i=m-1; i >= 0; i--)
- if (NU[i*m+i] < 0)
- for (j=(n-1)*n+i; j >= 0; j-=n) V[j]=-V[j];
- rtrn=NO_ERR;
-/* if (!(nd=(PRECISION*)malloc(n*sizeof(PRECISION)))) */
-/* rtrn=MEM_ERR; */
-/* else */
-/* { */
-/* if (at) */
-/* bTranspose(NU,A,m,n,at); */
-/* else */
-/* memcpy(NU,A,m*n*sizeof(PRECISION)); */
-/* bSVD_NumericalRecipes(NU,nd,V,m,n); */
-/* for (i=m-1; i >= 0; i--) memcpy(U+i*m,NU+i*n,m*sizeof(PRECISION)); */
-/* memcpy(d,nd,m*sizeof(PRECISION)); */
-/* rtrn=NO_ERR; */
-/* free(nd); */
-/* } */
- free(NU);
- }
- else
- if (!(NU=(PRECISION*)malloc(m*n*sizeof(PRECISION))))
- rtrn=MEM_ERR;
- else
- {
- if (at)
- bTranspose(NU,A,m,n,at);
- else
- memcpy(NU,A,m*n*sizeof(PRECISION));
- bSVD_NumericalRecipes(NU,d,V,m,n);
- bQR_NumericalRecipes(U,NU,m,n);
- for (i=n-1; i >= 0; i--)
- if (NU[i*n+i] < 0)
- for (j=(m-1)*m+i; j >= 0; j-=m) U[j]=-U[j];
- rtrn=NO_ERR;
- free(NU);
- }
- if (vt) bTransposeInPlace(V,n);
- if (ut) bTransposeInPlace(U,m);
- return rtrn;
-#endif
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/***************************** QR Decompositions ******************************/
-/******************************************************************************/
-/*
- Assumes
- Q : m x m matrix in row major format or null pointer
- R : m x n matrix in row major format
-
- Returns
- 0 (NO_ERR) : Success
- MEM_ERR : Out of memory
-
- Results
- Finds an orthogonal matrix Q and an upper triangular matrix U
- such that
-
- R = Q * U
-
- The matrix U is returned in R and Q is computed only if it is
- not null.
-
- Notes
- The QR decomposition is formed using Householder matrices without
- pivoting. If Q is null, then the matrix Q will have the property
- that
-
- det(Q) = (-1)^s
-
- where s=min{m-1,n).
-*/
-static int bQR_NumericalRecipes(PRECISION *Q, PRECISION *R, int m, int n)
-{
- int i, j, k, s=(m <= n) ? m-1 : n;
- PRECISION tmp, scale, sigma, c, sum;
- PRECISION *diag, *norm;
-
- if (Q)
- {
- if (!(diag=(PRECISION*)malloc(2*s*sizeof(PRECISION)))) return MEM_ERR;
- norm=diag+s;
-
- for (k=0; k < s; k++)
- {
- for (scale=0.0, i=k; i < m; i++)
- if ((tmp=fabs(R[i*n+k])) > scale) scale=tmp;
-
- if (scale == 0.0)
- {
- diag[k]=norm[k]=0.0;
- continue;
- }
-
- for (scale=1.0/scale, sigma=0.0, i=k; i < m; i++)
- {
- R[i*n+k]*=scale;
- sigma+=R[i*n+k]*R[i*n+k];
- }
-
- sigma=sqrt(sigma);
-
- if (R[k*n+k] < 0.0) sigma=-sigma;
-
- diag[k]=R[k*n+k]+=sigma;
-
- norm[k]=c=1.0/(sigma*diag[k]);
-
- for (j=k+1; j < n; j++)
- {
- for (sum=0.0, i=k; i < m; i++) sum+=R[i*n+k]*R[i*n+j];
- sum*=c;
- for (i=k; i < m; i++) R[i*n+j]-=R[i*n+k]*sum;
- }
-
- R[k*n+k]=-sigma/scale;
- }
-
- for (i=m*m-1; i >= 0; i--) Q[i]=0.0;
- for (i=m*m-1; i >= 0; i-=m+1) Q[i]=1.0;
-
- for (k=s-1; k >= 0; k--)
- {
- c=norm[k];
- for (j=k; j < m; j++)
- {
- for (sum=diag[k]*Q[k*m+j], i=k+1; i < m; i++) sum+=R[i*n+k]*Q[i*m+j];
- for (Q[k*m+j]-=diag[k]*(sum*=c), i=k+1; i < m; i++) Q[i*m+j]-=R[i*n+k]*sum;
- }
- }
-
- for (k=s-1; k >= 0; k--)
- for (i=k+1; i < m; i++)
- R[i*n+k]=0;
-
- free(diag);
-
- return 0;
- }
- else
- {
- for (k=0; k < s; k++)
- {
- /* Find largest element below diagonal in kth column */
- for (scale=0.0, i=m-1; i > k; i--)
- if ((tmp=fabs(R[i*n+k])) > scale) scale=tmp;
-
- if (scale == 0.0)
- for (j=k; j < n; j++) R[k*n+j]=-R[k*n+j];
- else
- {
- if ((tmp=fabs(R[k*n+k])) > scale) scale=tmp;
-
- /* Compute normalized sum of squares */
- for (scale=1.0/scale, sigma=0.0, i=k; i < m; i++)
- {
- R[i*n+k]*=scale;
- sigma+=R[i*n+k]*R[i*n+k];
- }
-
- sigma=sqrt(sigma);
-
- /* choose sign of sigma to match the diagonal elements sign */
- if (R[k*n+k] < 0.0) sigma=-sigma;
-
- /* c = sigma*(diagonal + sigma) */
- R[k*n+k]+=sigma;
- c=1.0/(sigma*R[k*n+k]);
-
- for (j=k+1; j < n; j++)
- {
- for (sum=0.0, i=k; i < m; i++) sum+=R[i*n+k]*R[i*n+j];
- sum*=c;
- for (i=k; i < m; i++) R[i*n+j]-=R[i*n+k]*sum;
- }
-
- R[k*n+k]=-sigma/scale;
- for (i=k+1; i < m; i++) R[i*n+k]=0;
- }
- }
-
- return 0;
- }
-}
-
-
-/*
- Assumes
- Q : array of length m*q or null pointer
- R : array of length q*n
- X : array of length m*n
- n : positive
- m : positive
- q : m or min(m,n)
- qt : 0 or 1
- rt : 0 or 1
- xt : 0 or 1
-
- Returns
- NO_ERR : Success
- MEM_ERR : Out of memory
-
- Results
- Finds an orthogonal matrix Q and an upper triangular matrix R
- such that
-
- X = Q * R
-
- The matrix Q is computed only if it is not null.
-
- X Q R
- qt rt xt (m x n) (m x q) (q x n) solves
- ------------------------------------------------------
- 0 0 0 row major row major row major X = Q * R
- 1 0 0 row major col major row major X = Q * R
- 0 1 0 row major row major col major X = Q * R
- 1 1 0 row major col major col major X = Q * R
- 0 0 1 col major row major row major X = Q * R
- 1 0 1 col major col major row major X = Q * R
- 0 1 1 col major row major col major X = Q * R
- 1 1 1 col major col major col major X = Q * R
-
- or
- R/U Q
- qt rt row major row major solves
- ------------------------------------------
- 0 0 m x n m x m R = Q * U
- 1 0 m x n m x m R = Q'* U
- 0 1 n x m m x m R'= Q * U'
- 1 1 n x m m x m R'= Q'* U'
-
- or
- R/U Q
- qt rt col major col major solves
- ------------------------------------------
- 0 0 n x m m x m R'= Q'* U'
- 1 0 n x m m x m R'= Q * U'
- 0 1 m x n m x m R = Q'* U
- 1 1 m x n m x m R = Q * U
-
- Notes
- The matrices X and R do not have to be distinct. If X == R, then it must
- be the case that m == q and rt == xt. The QR decomposition is formed using
- Householder matrices without pivoting.
-
- -- Not implemented --
- If Q is not null, then the matrix Q will have the
- property that
-
- det(Q) = (-1)^s
-
- where s=min{m-1,n).
-*/
-int bQR(PRECISION *Q, PRECISION *R, PRECISION *X, int m, int n, int q, int qt, int rt, int xt)
-{
-#if defined USE_BLAS_LAPACK
- int i, j, k, l, lwork, info, p=(m < n) ? m : n;
- PRECISION *tau, *work, *ptr, opt_size;
- if (!(tau=(PRECISION*)malloc(p*sizeof(PRECISION)))) return MEM_ERR;
- if (xt)
- {
- lwork=-1;
-#if (PRECISION_SIZE == 4)
- sgeqrf(&m,&n,X,&m,tau,&opt_size,&lwork,&info);
-#else
- dgeqrf(&m,&n,X,&m,tau,&opt_size,&lwork,&info);
-#endif
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
-#if (PRECISION_SIZE == 4)
- sgeqrf(&m,&n,X,&m,tau,work,&lwork,&info);
-#else
- dgeqrf(&m,&n,X,&m,tau,work,&lwork,&info);
-#endif
- free(work);
- if (info)
- {
- free(tau);
- return ARG_ERR;
- }
- if (Q)
- {
- if (qt)
- ptr=Q;
- else
- if (!(ptr=(PRECISION*)malloc(m*q*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
- memcpy(ptr,X,m*p*sizeof(PRECISION));
- lwork=-1;
-#if (PRECISION_SIZE == 4)
- sorgqr(&m,&q,&p,ptr,&m,tau,&opt_size,&lwork,&info);
-#else
- dorgqr(&m,&q,&p,ptr,&m,tau,&opt_size,&lwork,&info);
-#endif
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- if (!qt) free(ptr);
- free(tau);
- return MEM_ERR;
- }
-#if (PRECISION_SIZE == 4)
- sorgqr(&m,&q,&p,ptr,&m,tau,work,&lwork,&info);
-#else
- dorgqr(&m,&q,&p,ptr,&m,tau,work,&lwork,&info);
-#endif
- free(work);
- if (!qt)
- {
- bTranspose(Q,ptr,m,q,1);
- free(ptr);
- }
- free(tau);
- if (info) return ARG_ERR;
- }
- else
- free(tau);
- if (R != X)
- if (rt)
- for (k=q*n, j=n-1; j >= 0; j--)
- {
- for (i=q-1; i > j; i--) R[--k]=0.0;
- for (l=i+j*m; i >= 0; i--) R[--k]=X[l--];
- }
- else
- for (k=q*n, i=q-1; i >= 0; i--)
- {
- for (l=i+n*m, j=n-1; j >= i; j--) R[--k]=X[l-=m];
- for ( ; j >= 0; j--) R[--k]=0.0;
- }
- else
- {
- for (j=p-1; j >= 0; j--)
- for (k=m*(j+1), i=m-1; i > j; i--) X[--k]=0.0;
- }
- }
- else
- {
- lwork=-1;
-#if (PRECISION_SIZE == 4)
- sgelqf(&n,&m,X,&n,tau,&opt_size,&lwork,&info);
-#else
- dgelqf(&n,&m,X,&n,tau,&opt_size,&lwork,&info);
-#endif
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
-#if (PRECISION_SIZE == 4)
- sgelqf(&n,&m,X,&n,tau,work,&lwork,&info);
-#else
- dgelqf(&n,&m,X,&n,tau,work,&lwork,&info);
-#endif
- free(work);
- if (info)
- {
- free(tau);
- return ARG_ERR;
- }
- if (Q)
- {
- if (!qt)
- ptr=Q;
- else
- if (!(ptr=(PRECISION*)malloc(m*q*sizeof(PRECISION))))
- {
- free(tau);
- return MEM_ERR;
- }
- if (q == n)
- memcpy(ptr,X,m*n*sizeof(PRECISION));
- else
- if (m < n)
- for (k=q*m, j=m-1; j >= 0; j--)
- for (l=p+j*n, i=p-1; i >= 0; i--)
- ptr[--k]=X[--l];
- else
- for (l=n*m, j=m-1; j >= 0; j--)
- for (k=p+j*q, i=p-1; i >= 0; i--)
- ptr[--k]=X[--l];
- lwork=-1;
-#if (PRECISION_SIZE == 4)
- sorglq(&q,&m,&p,ptr,&q,tau,&opt_size,&lwork,&info);
-#else
- dorglq(&q,&m,&p,ptr,&q,tau,&opt_size,&lwork,&info);
-#endif
- if (!(work=(PRECISION*)malloc((lwork=(int)opt_size)*sizeof(PRECISION))))
- {
- if (!qt) free(ptr);
- free(tau);
- return MEM_ERR;
- }
-#if (PRECISION_SIZE == 4)
- sorglq(&q,&m,&p,ptr,&q,tau,work,&lwork,&info);
-#else
- dorglq(&q,&m,&p,ptr,&q,tau,work,&lwork,&info);
-#endif
- free(work);
- if (qt)
- {
- bTranspose(Q,ptr,q,m,1);
- free(ptr);
- }
- free(tau);
- if (info) return ARG_ERR;
- }
- else
- free(tau);
- if (R != X)
- if (rt)
- for (k=n*q, i=n-1; i >= 0; i--)
- {
- for (j=q-1; j > i; j--) R[--k]=0.0;
- for (l=i+j*n; j >= 0; l-=n, j--) R[--k]=X[l];
- }
- else
- for (k=n*q-1, j=q-1; j >= 0; j--)
- {
- for (i=n-1; i >= j; k--, i--) R[k]=X[k];
- for ( ; i >= 0; k--, i--) R[k]=0.0;
- }
- else
- {
- for (i=p-1; i >= 0; i--)
- for (k=i+m*n, j=m-1; j > i; j--) X[k-=n]=0.0;
- }
- }
- return NO_ERR;
-#else
- // bQR
- PRECISION *NQ, *NR, *pQ;
- int i, j;
-
- if (Q && (q != m))
- {
- if (!(NQ=(PRECISION*)malloc(m*m*sizeof(PRECISION))))
- return MEM_ERR;
- }
- else
- NQ=Q;
-
- if (rt || (q != m))
- {
- if (!(NR=(PRECISION*)malloc(m*n*sizeof(PRECISION))))
- {
- if (NQ != Q) free(NQ);
- return MEM_ERR;
- }
- if (xt)
- bTranspose(NR,X,m,n,xt);
- else
- memcpy(NR,X,m*n*sizeof(PRECISION));
- }
- else
- {
- NR=R;
- if (xt)
- bTranspose(NR,X,m,n,xt);
- else
- if (X != NR)
- memcpy(NR,X,m*n*sizeof(PRECISION));
- }
-
- bQR_NumericalRecipes(NQ,NR,m,n);
-
- if (Q)
- if (q != m)
- {
- if (qt)
- for (pQ=Q+m*n-1, j=n-1; j >= 0; j--)
- for (i=m*(m-1)+j; i >= 0; pQ--, i-=m)
- *pQ=NQ[i];
- else
- for (i=m-1; i >= 0; i--) memcpy(Q+i*n,NQ+i*m,n*sizeof(PRECISION));
- free(NQ);
- }
- else
- if (qt)
- bTransposeInPlace(Q,m);
-
- if (rt)
- {
- bTranspose(R,NR,q,n,0);
- free(NR);
- }
- else
- if (q != m)
- {
- memcpy(R,NR,n*n*sizeof(PRECISION));
- free(NR);
- }
-
- return NO_ERR;
-#endif
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/******************************************************************************/
-/************************** Cholesky Decompositions ***************************/
-/******************************************************************************/
-/*
- Assumes
- X : Scalar array of m*m representing an m x m symmetric matrix
-
- Returns
- 0 (NO_ERR) : success
- POS_DEF_ERR : X not positive definite
-
- Results
-
- u t X/T solves
- ----------------------------------
- 0 0 row major X = L'* L
- 1 0 row major X = U'* U
- 0 1 col major X = L'* L
- 1 1 col major X = U'* U
-
- or
- X/T
- u t row major solves
- ----------------------------------
- 0 0 - X = L'* L
- 1 0 - X = U'* U
- 0 1 - X = L * L'
- 1 1 - X = U * U'
-
- or
- X/T
- u t col major solves
- ----------------------------------
- 0 0 - X = L * L'
- 1 0 - X = U * U'
- 0 1 - X = L'* L
- 1 1 - X = U'* U
-
- u t T solves
- ---------------------------------- v
- 0 0 L:row major X = T'* T 0 v^t=0
- 1 0 U:row major X = T'* T 1 v^t=1
- 0 1 U:col major X = T'* T 1 v^t=0
- 1 1 L:col major X = T'* T 0 v^t=1
-
- or
- X
- u t row major solves
- ----------------------------------
- 0 0 L X = L'* L
- 1 0 U X = U'* U
- 0 1 L X = L * L'
- 1 1 U X = U * U'
-
- Upon successful exit T is upper triangular with positive diagonal and
- satisfies X = T' * T. T overwrites X.
-
- Notes
- Failure usually indicates X is not positive definite. Only half of X
- is accessed.
-*/
-int bCholesky(PRECISION *X, int m, int u, int t)
-{
-#if defined USE_INLINE
- int i, b, rtrn=NO_ERR;
- __asm{ // eax ebx ecx edx esi edi st(0) st(1) st(2)
- fninit
- mov edx,m // ? ? ? m ? ?
-
- cmp u,0
- //je short c0 // ? ? ? m ? ?
- je c0
-
- cmp t,0
- //je short b0 // ? ? ? m ? ?
- je b0
- /********************************************************************************************************************************/
- // ? ? ? m ? ?
- mov eax,edx
- dec eax // i ? ? m ? ?
-
- mov edi,edx
- imul edi,eax
- shl edi,PRECISION_SHIFT
- add edi,X // i ? ? m ? X+i*m
-
-a1: // i ? ? m ? X+i*m
- mov i,eax
-
- mov ebx,edx
- dec ebx // i j ? m ? X+i*m
-
- mov esi,edx
- imul esi,ebx
- add esi,eax
- shl esi,PRECISION_SHIFT
- add esi,X // i j ? m X+i+j*m X+i*m
-
-a2: // i j ? m X+i+j*m X+i*m
- cmp ebx,eax
- jle short a3
-
- mov dword ptr[esi],0
-
-#if (PRECISION_SIZE == 8)
- mov dword ptr[esi+4],0
-#endif
-
- mov ecx,m // i j m m X+i+j*m X+i*m
- shl ecx,PRECISION_SHIFT // i j m*PRECISION_SIZE m X+i+j*m X+i*m
- sub esi,ecx // i j m*PRECISION_SIZE m X+i+j*m X+i*m
- dec ebx // i j ? m X+i+j*m X+i*m
- jmp short a2 // i j ? m X+i+j*m X+i*m
-
-a3:
- fld PRECISION_WORD ptr[esi] // i j ? m X+i+j*m X+i*m X[i+j*m]
-
-a4: // k j ? m X+i+j*m X+i*m X[i+j*m]
- inc eax // k j ? m X+i+j*m X+i*m X[i+j*m]
- cmp edx,eax
- jle short a5
-
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax] // k j ? m X+i+j*m X+i*m X[i*m+k] X[i+j*m]
- fld st(0) // k j ? m X+i+j*m X+i*m X[i*m+k] X[i*m+k] X[i+j*m]
- fmul // k j ? m X+i+j*m X+i*m X[i*m+k]^2 X[i+j*m]
- fsub // k j ? m X+i+j*m X+i*m X[i+j*m]
-
- jmp short a4 // k j ? m X+i+j*m X+i*m X[i+j*m]
-
-a5: // ? j ? m X+i+j*m X+i*m X[i+j*m]
- ftst
- fnstsw ax
- sahf
- //jbe short e1 // ? j ? m X+i+j*m X+i*m X[i+j*m]
- jbe e1
-
- fsqrt // ? j ? m X+i+j*m X+i*m X[i+j*m]
- fst PRECISION_WORD ptr[esi] // ? j ? m X+i+j*m X+i*m X[i+j*m]
-
- fld1 // ? j ? m X+i+j*m X+i*m 1
- fdivr // ? j ? m X+i+j*m X+i*m scale
-
- mov ecx,edi // ? j X+j*m m X+i+j*m X+i*m scale
-
-a6: // ? j X+j*m m X+i+j*m X+i*m scale
- dec ebx // ? j X+j*m m X+i+j*m X+i*m scale
- jl short a9 // ? j X+j*m m X+i+j*m X+i*m scale
-
- mov eax,m // m j X+j*m m X+i+j*m X+i*m scale
- shl eax,PRECISION_SHIFT // m*PRECISION_SIZE j X+j*m m X+i+j*m X+i*m scale
- sub ecx,eax // m*PRECISION_SIZE j X+j*m m X+i+j*m X+i*m scale
- sub esi,eax // ? j X+j*m m X+i+j*m X+i*m scale
-
- fld PRECISION_WORD ptr[esi] // ? j X+j*m m X+i+j*m X+i*m X[i+j*m] scale
-
- mov eax,i // k j X+j*m m X+i+j*m X+i*m X[i+j*m] scale
-
-a7: // k j X+j*m m X+i+j*m X+i*m X[i+j*m] scale
- inc eax
- cmp edx,eax
- jle short a8
-
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax] // k j X+j*m m X+i+j*m X+i*m X[i*m+k] X[i+j*m] scale
- fmul PRECISION_WORD ptr[ecx+PRECISION_SIZE*eax] // k j X+j*m m X+i+j*m X+i*m X[i*m+k]*X[j*m+k] X[i+j*m] scale
- fsub // k j X+j*m m X+i+j*m X+i*m X[i+j*m] scale
-
- jmp short a7 // k j X+j*m m X+i+j*m X+i*m X[i+j*m] scale
-
-a8:
- fmul st,st(1) // k j X+j*m m X+i+j*m X+i*m X[i+j*m] scale
- fstp PRECISION_WORD ptr[esi] // k j X+j*m m X+i+j*m X+i*m scale
- jmp short a6 // k j X+j*m m X+i+j*m X+i*m scale
-
-a9: ffree st(0) // ? ? ? m X+i+j*m X+i*m
-
- mov eax,edx
- shl eax,PRECISION_SHIFT
- sub edi,eax // ? ? ? m X+i+j*m X+i*m
-
- mov eax,i // i ? ? m X+i+j*m X+i*m
- dec eax // i ? ? m X+i+j*m X+i*m
- //jge short a1 // i ? ? m X+i+j*m X+i*m
- jge a1
-
- //jmp short e2 // ? ? ? ? ? ?
- jmp e2
-/********************************************************************************************************************************/
-b0: // ? ? ? m ? ?
- mov eax,0
-
- mov edi,X // i m X+i
-
-b1: // i m X+i
- mov i,eax
-
- mov ebx,0 // i j m X+i*m+j X+i
-
- mov esi,eax
- imul esi,edx
- shl esi,PRECISION_SHIFT
- add esi,X // i j m X+i*m+j X+i
-
-b2:
- cmp eax,ebx
- jle short b3
-
- mov dword ptr[esi],0
-
-#if (PRECISION_SIZE == 8)
- mov dword ptr[esi+4],0
-#endif
-
- add esi,PRECISION_SIZE
- inc ebx
- jmp short b2
-
-b3:
- fld PRECISION_WORD ptr[esi]
- dec eax
- imul eax,edx // k j m X+i+j*m X+i
-
- cmp eax,0
- jl short b5
-
-b4:
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax]
- fld st(0)
- fmul
- fsub
-
- sub eax,edx
- jge short b4
-
-b5:
- ftst
- fnstsw ax
- sahf
- //jbe short e1
- jbe e1
-
- fsqrt
- fst PRECISION_WORD ptr[esi]
-
- fld1
- fdivr
-
- mov ecx,edi // j X+j m X+i*m+j X+i
-
-b6: // j X+j m X+i*m+j X+i
- inc ebx
- cmp edx,ebx
- jle short b9
-
- add ecx,PRECISION_SIZE
- add esi,PRECISION_SIZE
-
- fld PRECISION_WORD ptr[esi]
-
- mov eax,i
- dec eax
- imul eax,edx // k j X+j*m m X+i+j*m X+i*m
-
- cmp eax,0
- jl short b8
-
-b7:
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax]
- fmul PRECISION_WORD ptr[ecx+PRECISION_SIZE*eax]
- fsub
-
- sub eax,edx
- jge short b7
-
-b8:
- fmul st,st(1)
- fstp PRECISION_WORD ptr[esi]
- jmp short b6
-
-
-b9: ffree st(0)
-
- add edi,PRECISION_SIZE
-
- mov eax,i
- inc eax
- cmp edx,eax
- //jg short b1
- jg b1
-
- //jmp short e2
- jmp e2
-/********************************************************************************************************************************/
-c0:
- mov eax,t
- cmp eax,0
- //je short d0
- je d0
-/********************************************************************************************************************************/
- mov eax,0 // i m X+i*m
-
- mov edi,X // m X+i*m
-
-c1: // i m X+i*m
- mov i,eax
-
- mov ebx,0 // i j m X+i+j*m X+i*m
-
- mov esi,eax
- shl esi,PRECISION_SHIFT
- add esi,X // i m X+i+j*m X+i*m
-
-c2:
- cmp eax,ebx
- jle short c3
-
- mov dword ptr[esi],0
-
-#if (PRECISION_SIZE == 8)
- mov dword ptr[esi+4],0
-#endif
-
- mov ecx,edx
- shl ecx,PRECISION_SHIFT
- add esi,ecx
- inc ebx
- jmp short c2
-
-c3:
- fld PRECISION_WORD ptr[esi]
-c4: // k j m X+i+j*m X+i*m
- dec eax
- jl short c5
-
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax]
- fld st(0)
- fmul
- fsub
-
- jmp short c4
-
-c5:
- ftst
- fnstsw ax
- sahf
- //jbe short e1
- jbe e1
-
- fsqrt
- fst PRECISION_WORD ptr[esi]
-
- fld1
- fdivr
-
- mov ecx,edi // j X+j m X+i+j*m X+i*m
-
-c6: // j X+j m X+i+j*m X+i*m
- inc ebx
- cmp edx,ebx
- jle short c9
-
- mov eax,edx
- shl eax,PRECISION_SHIFT
- add ecx,eax
- add esi,eax
-
- fld PRECISION_WORD ptr[esi]
-
- mov eax,i
-c7: // k j X+j m X+i+j*m X+i*m
- dec eax
- jl short c8
-
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax]
- fmul PRECISION_WORD ptr[ecx+PRECISION_SIZE*eax]
- fsub
-
- jmp short c7
-
-c8:
- fmul st,st(1)
- fstp PRECISION_WORD ptr[esi]
- jmp short c6
-
-c9: ffree st(0)
-
- mov eax,edx
- shl eax,PRECISION_SHIFT
- add edi,eax
-
- mov eax,i
- inc eax
- cmp edx,eax
- //jg short c1
- jg c1
-
- //jmp short e2
- jmp e2
-/********************************************************************************************************************************/
-d0: // ? ? ? m ? ?
- mov eax,edx
- imul eax,edx
- mov b,eax
-
- mov eax,edx
- dec eax // i ? ? m X+i*m+j X+i
-
- mov edi,eax
- shl edi,PRECISION_SHIFT
- add edi,X // ? ? ? m ? X+i
-
- mov esi,edx
- imul esi,edx
- shl esi,PRECISION_SHIFT
- add esi,X // ? j ? m X+i*m+j X+i
-
-d1: // i ? ? m X+i*m+j X+i
- mov i,eax
-
- mov ebx,edx // i j ? m X+i*m+j X+i
- dec ebx
-
- sub esi,PRECISION_SIZE
-
-d2: // i j ? m X+i*m+j X+i
- cmp ebx,eax
- jle short d3
-
- mov dword ptr[esi],0
-
-#if (PRECISION_SIZE == 8)
- mov dword ptr[esi+4],0
-#endif
-
- sub esi,PRECISION_SIZE // i j ? m X+i*m+j X+i
- dec ebx
- jmp short d2 // i j ? m X+i*m+j X+i
-
-d3:
- fld PRECISION_WORD ptr[esi] // i j ? m X+i*m+j X+i X[i+j*m]
-
- imul eax,edx
-
-d4: // k j ? m X+i*m+j X+i X[i+j*m]
- add eax,edx // k j ? m X+i*m+j X+i X[i+j*m]
- cmp b,eax
- jle short d5
-
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax] // k j ? m X+i*m+j X+i X[i*m+k] X[i+j*m]
- fld st(0) // k j ? m X+i*m+j X+i X[i*m+k] X[i*m+k] X[i+j*m]
- fmul // k j ? m X+i*m+j X+i X[i*m+k]^2 X[i+j*m]
- fsub // k j ? m X+i*m+j X+i X[i+j*m]
-
- jmp short d4 // k j ? m X+i*m+j X+i X[i+j*m]
-
-d5: // ? j ? m X+i*m+j X+i X[i+j*m]
- ftst
- fnstsw ax
- sahf
- jbe short e1 // ? j ? m X+i*m+j X+i X[i+j*m]
-
- fsqrt // ? j ? m X+i*m+j X+i X[i+j*m]
- fst PRECISION_WORD ptr[esi] // ? j ? m X+i*m+j X+i X[i+j*m]
-
- fld1 // ? j ? m X+i*m+j X+i 1
- fdivr // ? j ? m X+i*m+j X+i scale
-
- mov ecx,edi // ? j X+j m X+i*m+j X+i scale
-
-d6: // ? j X+j m X+i*m+j X+i scale
- dec ebx // ? j X+j m X+i*m+j X+i scale
- jl short d9 // ? j X+j m X+i*m+j X+i scale
-
- sub ecx,PRECISION_SIZE // ? j X+j m X+i*m+j X+i scale
- sub esi,PRECISION_SIZE // ? j X+j m X+i*m+j X+i scale
-
- fld PRECISION_WORD ptr[esi] // ? j X+j m X+i*m+j X+i X[i+j*m] scale
-
- mov eax,i // k j X+j m X+i*m+j X+i X[i+j*m] scale
- imul eax,edx
-
-d7: // k j X+j m X+i*m+j X+i X[i+j*m] scale
- add eax,edx
- cmp b,eax
- jle short d8
-
- fld PRECISION_WORD ptr[edi+PRECISION_SIZE*eax] // k j X+j m X+i*m+j X+i X[i*m+k] X[i+j*m] scale
- fmul PRECISION_WORD ptr[ecx+PRECISION_SIZE*eax] // k j X+j m X+i*m+j X+i X[i*m+k]*X[j*m+k] X[i+j*m] scale
- fsub // k j X+j m X+i*m+j X+i X[i+j*m] scale
-
- jmp short d7 // k j X+j m X+i*m+j X+i X[i+j*m] scale
-
-d8:
- fmul st,st(1) // k j X+j m X+i*m+j X+i X[i+j*m] scale
- fstp PRECISION_WORD ptr[esi] // k j X+j m X+i*m+j X+i scale
- jmp short d6 // k j X+j m X+i*m+j X+i scale
-
-d9: ffree st(0) // ? ? ? m X+i*m+j X+i
-
- sub edi,PRECISION_SIZE
-
- mov eax,i // i ? ? m X+i*m+j X+i
- dec eax // i ? ? m X+i*m+j X+i
- jge short d1 // i ? ? m X+i*m+j X+i
-
- jmp short e2
-/********************************************************************************************************************************/
-e1: mov rtrn,POSDEF_ERR
-e2:
- }
- return rtrn;
-#else
- int i, j, k, b;
- PRECISION scale, *pX, *pXi, *pXj;
-
- if (u^t)
- if (t)
- for (i=m-1, pXi=X+i*m; i >= 0; pXi-=m, i--)
- {
- for (j=m-1, pX=X+i+j*m; j > i; pX-=m, j--) *pX=0.0;
-
- for (k=i+1; k < m; k++) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j--; j >= 0; j--)
- {
- pX-=m;
- pXj-=m;
- for (k=i+1; k < m; k++) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- else
- for (i=0, pXi=X; i < m; pXi++, i++)
- {
- for (j=0, pX=X+i*m; j < i; pX++, j++) *pX=0.0;
-
- for (k=(i-1)*m; k >= 0; k-=m) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j++; j < m; j++)
- {
- pXj++;
- pX++;
- for (k=(i-1)*m; k >= 0; k-=m) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- else
- if (t)
- for (i=0, pXi=X; i < m; pXi+=m, i++)
- {
- for (j=0, pX=X+i; j < i; pX+=m, j++) *pX=0.0;
-
- for (k=i-1; k >= 0; k--) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j++; j < m; j++)
- {
- pX+=m;
- pXj+=m;
- for (k=i-1; k >= 0; k--) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- else
- for (b=m*m, i=m-1, pXi=X+i; i >= 0; pXi--, i--)
- {
- for (j=m-1, pX=X+i*m+j; j > i; pX--, j--) *pX=0.0;
-
- for (k=(i+1)*m; k < b; k+=m) *pX-=pXi[k]*pXi[k];
-
- if (*pX <= 0.0) return POSDEF_ERR;
- scale=1.0/(*pX=sqrt(*pX));
-
- pXj=pXi;
- for (j--; j >= 0; j--)
- {
- pXj--;
- pX--;
- for (k=(i+1)*m; k < b; k+=m) *pX-=pXi[k]*pXj[k];
- *pX*=scale;
- }
- }
- return NO_ERR;
-#endif
-
-}
-
-/*
- Assumes
- x : array of length m*r*n*s
- y : array of length m*n
- z : array of length r*s
- m,n,r,s : positive
- xt,yt,zt : 0 or 1
-
- Returns
- NO_ERR : success
-
- Results
- x y z
- xt yt zt (mr x ns) (m x n) (r x s) computes
- ---------------------------------------------------------------------
- 0 0 0 row major row major row major x = y tensor z
- 1 0 0 col major row major row major x = y tensor z
- 1 1 0 col major col major row major x = y tensor z
- 0 1 0 row major col major row major x = y tensor z
- 0 0 1 row major row major col major x = y tensor z
- 1 0 1 col major row major col major x = y tensor z
- 1 1 1 col major col major col major x = y tensor z
- 0 1 1 row major col major col major x = y tensor z
-*/
-int bMatrixTensor(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n, int r, int s, int xt, int yt, int zt)
-{
- int iy, jy, iz, jz, k, l, stride;
- PRECISION t, *pz=z+r*s-1;
- if (xt)
- if (zt)
- {
- stride=m*r;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=(iy+1)*r-1 + ((jy+1)*s-1)*stride;
- z=pz;
- for (jz=s-1; jz >= 0; l-=stride, jz--)
- for (iz=r-1, k=l; iz >= 0; z--, k--, iz--)
- x[k]=t*(*z);
- }
- }
- else
- {
- stride=m*r;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=(iy+1)*r-1 + ((jy+1)*s-1)*stride;
- z=pz;
- for (iz=r-1; iz >= 0; l--, iz--)
- for (jz=s-1, k=l; jz >= 0; z--, k-=stride, jz--)
- x[k]=t*(*z);
- }
- }
- else
- if (zt)
- {
- stride=n*s;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=((iy+1)*r-1)*stride + (jy+1)*s-1;
- z=pz;
- for (jz=s-1; jz >= 0; l--, jz--)
- for (iz=r-1, k=l; iz >= 0; z--, k-=stride, iz--)
- x[k]=t*(*z);
-
- }
- }
- else
- {
- stride=n*s;
- for (iy=m-1; iy >= 0; iy--)
- for (jy=n-1; jy >= 0; jy--)
- {
- t=y[yt ? iy+m*jy : n*iy+jy];
- l=((iy+1)*r-1)*stride + (jy+1)*s-1;
- z=pz;
- for (iz=r-1; iz >= 0; l-=stride, iz--)
- for (jz=s-1, k=l; jz >= 0; z--, k--, jz--)
- x[k]=t*(*z);
-
- }
- }
- return NO_ERR;
-}
-
-int bVectorTensor(PRECISION *x, PRECISION *y, PRECISION *z, int m, int n)
-{
- int j, k;
- PRECISION s;
- for (x+=m*n-1, j=m-1; j >= 0; j--)
- for (s=y[j], k=n-1; k >= 0; x--, k--)
- *x=s*z[k];
- return NO_ERR;
-}
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
-/*******************************************************************************
-
- Accumulation:
- u is an m x p matrix
- v is a p x n matrix
- 0 <= i < m
- 0 <= j < n
- ui=p uj=1 (u is in row major format)
- ui=1 uj=m (u is in column major format)
- vi=n vj=1 (v is in row major format)
- vi=1 vj=p (v is in column major format)
-
- Computes the following sum:
-
- u[i*ui + 0*uj]*v[0*vi + j*vj] + u[i*ui+1*uj]*v[1*vi+j*vj] + ...
-
- ... + u[i*ui + (p-1)*uj]*v[(p-1)*vi + j*vj]
-
-
- *** C code ***
-
- int k=(p-1)*vi;
- PRECISION *pu=u + i*ui + (p-1)*uj;
- PRECISION *pv=v + j*vj;
-
- PRECISION tmp=(*pu)*pv[k];
- while ((k-=vi) >= 0) tmp+=(*(pu-=uj))*pv[k];
- w(i,j)=tmp;
-
- *** assembly code ***
-
- __asm {
-
-
- // Upon entry:
- // eax=(p-1)*kv
- // ebx=ku*PRECISION_SIZE
- // ecx=kv
- // esi=u(i) + (p-1)*uj*PRECISION_SIZE
- // edi=v(j)
- //
- // Upon exit:
- // eax=0
- // ebx=ku*PRECISION_SIZE
- // ecx=kv
- // esi=u(i)
- // edi=v(j)
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax] // tmp=(*pu)*v(j)[k]
-
- sub eax,ecx // k-=kv
- jl short dest2 // k >= 0
-
-dest1 : sub esi,ebx // pu-=ku
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- fadd // tmp+=(*pu)*v(j)[k]
-
- sub eax,ecx // k-=kv
- jge short dest1_0 // k >= 0
-
-dest2 : fstp PRECISION_WORD ptr [edx] // w(i,j)=tmp
- }
-
- Notes:
- The register edx is unused. It is recommended that this register be used to store a pointer
- to the storage position for the accumlated value. Furthermore, the direction of outer loops
- should be such that edx-PRECISION_SIZE is the storage position for the next accumlated value.
-
- If vi is known to be one, then ecx is available.
-
- If uj is known to be one, then ebx is available and u+(i-1)*ui+(p-1)*uj = u+i*ui-1. If u is
- a matrix in row major format, then uj will be one.
-
-*******************************************************************************/
-
-
-/*******************************************************************************
- Back solving
- Given u(i), v(j), ku, kv, and p, computes
-
- v(j)[0]=(u(i)[(p-1)*ku]*v(j)[(p-1)*kv] + ... + u(i)[ku]*v(j)[kv])/u(i)[0]
-
- p is assumed to be positive and ku and kv are positive.
-
-
-
- *** C code ***
-
- int k=(p-1)*kv;
- PRECISION *pu=u(i)+(p-1)*ku;
-
- PRECISION tmp=(*pu)*v(j)[k];
- while (k != 0) tmp+=(*(pu-=ku))*v(j)[k-=kv];
-
- *** assembly code ***
-
- __asm {
-
-
- // Upon entry:
- // eax=(p-1)*kv
- // ebx=ku*PRECISION_SIZE
- // ecx=kv
- // esi=u(i) + (p-1)*uj*PRECISION_SIZE
- // edi=v(j)
- //
- // Upon exit:
- // eax=0
- // ebx=ku*PRECISION_SIZE
- // ecx=kv
- // esi=u(i)
- // edi=v(j)
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
-
- test eax,eax
- je short dest2
-
-dest1: sub eax,ecx // if kv=1, replace with: dec eax
- sub esi,ebx // if ku=1, replace with: sub esi,PRECISION_SIZE
-
- fld PRECISION_WORD ptr [esi]
- fmul PRECISION_WORD ptr [edi+PRECISION_SIZE*eax]
- fadd
-
- test eax,eax
- jne dest1
-
-dest2: fstp PRECISION_WORD ptr [edx] // pop accumulated value off stack and store
-
- sub edx,PRECISION_SIZE
-
- }
-
- Notes:
- The register edx is unused. It is recommended that this register be used to store a pointer
- to the storage position for the accumlated value. Furthermore, the direction of outer loops
- should be such that edx-PRECISION_SIZE is the storage position for the next accumlated value.
-
- If vi is known to be one, then ecx is available.
-
- If uj is known to be one, then ebx is available and u+(i-1)*ui+(p-1)*uj = u+i*ui-1. If u is
- a matrix in row major format, then uj will be one.
-
-*******************************************************************************/
-
-
-/* int jobz='A', k, *iwork, info; */
-/* PRECISION *X, *work, opt_size; */
-/* if (!(X=(PRECISION*)malloc(m*n*sizeof(PRECISION)))) return MEM_ERR; */
-/* memcpy(X,A,m*n*sizeof(PRECISION)); */
-/* if (!(iwork=(int*)malloc(8*((m < n) ? m : n)*sizeof(int)))) */
-/* { */
-/* free(X); */
-/* return MEM_ERR; */
-/* } */
-/* k=-1; */
-/* if (at) */
-/* { */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,iwork,&info); */
-/* #else */
-/* dgesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,iwork,&info); */
-/* #endif */
-/* if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return info ? BLAS_LAPACK_ERR : MEM_ERR; */
-/* } */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,iwork,&info); */
-/* #else */
-/* dgesdd(&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,iwork,&info); */
-/* #endif */
-/* if (info) */
-/* { */
-/* free(work); */
-/* memcpy(X,A,m*n*sizeof(PRECISION)); */
-/* k=-1; */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,&info); */
-/* #else */
-/* dgesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,&opt_size,&k,&info); */
-/* #endif */
-/* if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return info ? BLAS_LAPACK_ERR : MEM_ERR; */
-/* } */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,&info); */
-/* #else */
-/* dgesvd(&jobz,&jobz,&m,&n,X,&m,d,U,&m,V,&n,work,&k,&info); */
-/* #endif */
-/* if (info) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return BLAS_LAPACK_ERR; */
-/* } */
-/* } */
-/* if (!ut) */
-/* bTransposeInPlace(U,m); */
-/* if (vt) */
-/* bTransposeInPlace(V,n); */
-/* } */
-/* else */
-/* { */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,iwork,&info); */
-/* #else */
-/* dgesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,iwork,&info); */
-/* #endif */
-/* if (!(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return MEM_ERR; */
-/* } */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,iwork,&info); */
-/* #else */
-/* dgesdd(&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,iwork,&info); */
-/* #endif */
-/* if (info) */
-/* { */
-/* free(work); */
-/* memcpy(X,A,m*n*sizeof(PRECISION)); */
-/* k=-1; */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,&info); */
-/* #else */
-/* dgesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,&opt_size,&k,&info); */
-/* #endif */
-/* if (info || !(work=(PRECISION*)malloc((k=(int)opt_size)*sizeof(PRECISION)))) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return info ? BLAS_LAPACK_ERR : MEM_ERR; */
-/* } */
-/* #if (PRECISION_SIZE == 4) */
-/* sgesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,&info); */
-/* #else */
-/* dgesvd(&jobz,&jobz,&n,&m,X,&n,d,V,&n,U,&m,work,&k,&info); */
-/* #endif */
-/* if (info) */
-/* { */
-/* free(iwork); */
-/* free(X); */
-/* return BLAS_LAPACK_ERR; */
-/* } */
-/* } */
-/* if (!vt) */
-/* bTransposeInPlace(V,n); */
-/* if (ut) */
-/* bTransposeInPlace(U,m); */
-/* } */
-/* free(work); */
-/* free(iwork); */
-/* free(X); */
-/* return NO_ERR; */
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/m_err.h b/matlab/swz/c-code/utilities/DWCcode/matrix/m_err.h
deleted file mode 100644
index 299daf18de65fcce93190a2e4afffa90de2f97c6..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/m_err.h
+++ /dev/null
@@ -1,18 +0,0 @@
-
-/* Matrix error constants */
-
-#define NO_ERR 0x00000000
-
-#define MEM_ERR 0x00000001
-#define SIZE_ERR 0x00000002
-#define NULL_ERR 0x00000004
-#define SING_ERR 0x00000008
-#define ITER_ERR 0x00000010
-#define POSDEF_ERR 0x00000020
-#define FLOAT_ERR 0x00000040
-#define ARG_ERR 0x00000080
-#define NOT_IMPLEMENTED_ERR 0x00000100
-#define BLAS_LAPACK_ERR 0x00000200
-
-#define ALL_ERRORS 0x000001FF
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/matrix.c b/matlab/swz/c-code/utilities/DWCcode/matrix/matrix.c
deleted file mode 100644
index f3ff112ac48947e1bbeff6dee410cc470d551f61..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/matrix.c
+++ /dev/null
@@ -1,5031 +0,0 @@
-
-#include "matrix.h"
-#include "bmatrix.h"
-#include "dw_error.h"
-
-#include <stdlib.h>
-#include <memory.h>
-#include <math.h>
-
-/*******************************************************************************/
-/********************** Allocation/Deallocation Routines ***********************/
-/*******************************************************************************/
-/*
- TVector CreateVector(int m)
- Allocates memory for a m-dimensional vector. On success, returns a pointer
- to the vector. On failure, calls dw_Error() and returns null. The
- routine will fail if m <= 0 (SIZE_ERR) or is unable to allocate required
- memory (MEM_ERR).
-
- TMatrix CreateMatrix(int m, int n)
- Allocates memory for a (m x n) matrix. On success, returns a pointer to the
- matrix. On failure, calls dw_Error() and returns null. The routine will
- fail if m <= 0 or n <= 0 (SIZE_ERR) or is unable to allocate required memory
- (MEM_ERR).
-
- void FreeVector(TVector *x)
- Assumes
- x : valid vector or null pointer
- Results
- Deallocates memory for vector if x is not null.
- Notes
- The vector x MUST have been previously allocated with a call to
- CreateVector() or be null.
-
- void FreeMatrix(TMatrix *X)
- Assumes
- X : valid matrix or null pointer
- Results
- Deallocates memory for matrix if X is not null.
- Notes
- The matrix X MUST have been previously allocated with a call to
- CreateMatrix() or be null.
-*/
-#if (defined(STANDARD_ROW_MAJOR) || defined(STANDARD_COLUMN_MAJOR))
-/**/
-TVector CreateVector(int m)
-{
- TVector x;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (x=(TVector)malloc(sizeof(TVectorStructure) + (m-1)*sizeof(PRECISION)))
- DimV(x)=m;
- else
- dw_Error(MEM_ERR);
- return x;
-}
-/**/
-void FreeVector(TVector x)
-{
- if (x) free(x);
-}
-/**/
-TMatrix CreateMatrix(int m, int n)
-{
- TMatrix X;
- if ((m <= 0) || (n <= 0))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (X=(TMatrix)malloc(sizeof(TMatrixStructure) + (m*n-1)*sizeof(PRECISION)))
- {
- RowM(X)=m;
- ColM(X)=n;
- }
- else
- dw_Error(MEM_ERR);
- return X;
-}
-/**/
-void FreeMatrix(TMatrix X)
-{
- if (X) free(X);
-}
-/**/
-TPermutation CreatePermutation(int m)
-{
- TPermutation X;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- if (X=(TPermutation)malloc(sizeof(TPermutationStructure) + (m-1)*sizeof(int)))
- {
- X->dim=m;
- X->use=0;
- }
- else
- dw_Error(MEM_ERR);
- return X;
-}
-/**/
-void FreePermutation(TPermutation X)
-{
- if (X) free(X);
-}
-#endif
-/*-----------------------------------------------------------------------------*/
-#if (defined(STRUCTURED_ROW_MAJOR) || defined(STRUCTURED_COLUMN_MAJOR) || defined(STRUCTURED_MAJOR_FORM))
-/**/
-TVector CreateVector(int m)
-{
- TVector x;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (x=(TVector)malloc(sizeof(TVectorStructure)))
- if (x->x=(PRECISION*)malloc(m*sizeof(PRECISION)))
- DimV(x)=m;
- else
- {
- free(x);
- dw_Error(MEM_ERR);
- return (TVector)NULL;
- }
- else
- dw_Error(MEM_ERR);
- return x;
-}
-/**/
-void FreeVector(TVector x)
-{
- if (x)
- {
- if (x->x) free(x->x);
- free(x);
- }
-}
-/**/
-TMatrix CreateMatrix(int m, int n)
-{
- TMatrix X;
- if ((m <= 0) || (n <= 0))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (X=(TMatrix)malloc(sizeof(TMatrixStructure)))
- if (X->x=(PRECISION*)malloc(m*n*sizeof(PRECISION)))
- {
- RowM(X)=m;
- ColM(X)=n;
-#if defined STRUCTURED_MAJOR_FORM
- SetMajorForm(X,(rand() < RAND_MAX/2) ? 0 : 1);
-#endif
- }
- else
- {
- free(X);
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- else
- dw_Error(MEM_ERR);
- return X;
-}
-/**/
-void FreeMatrix(TMatrix X)
-{
- if (X)
- {
- if (X->x) free(X->x);
- free(X);
- }
-}
-/**/
-TPermutation CreatePermutation(int m)
-{
- TPermutation X;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- if (X=(TPermutation)malloc(sizeof(TPermutationStructure)))
- if (X->x=(int*)malloc(m*sizeof(int)))
- {
- X->dim=m;
- X->use=0;
- }
- else
- {
- free(X);
- dw_Error(MEM_ERR);
- return (TPermutation)NULL;
- }
- else
- dw_Error(MEM_ERR);
- return X;
-}
-/**/
-void FreePermutation(TPermutation X)
-{
- if (X)
- {
- if (X->x) free(X->x);
- free(X);
- }
-}
-#endif
-/*-----------------------------------------------------------------------------*/
-#if (defined(LEGACY_ROW_MAJOR))
-/**/
-TVector CreateVector(int m)
-{
- TVector x;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (x=(TVector)((int *)malloc(m*sizeof(PRECISION)+sizeof(int))+1))
- V_DIM(x)=m;
- else
- dw_Error(MEM_ERR);
- return x;
-}
-/**/
-void FreeVector(TVector x)
-{
- if (x) free((int *)x-1);
-}
-/**/
-TMatrix CreateMatrix(int m, int n)
-{
- TMatrix X;
- int i;
- if ((m <= 0) || (n <= 0))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (X=(TMatrix)((int *)malloc(m*(sizeof(PRECISION *)+n*sizeof(PRECISION))+2*sizeof(int))+2))
- {
- M_ROW(X)=m;
- M_COL(X)=n;
- X[0]=(PRECISION *)(X+m);
- for (i=1; i < m; i++) X[i]=X[i-1]+n;
- }
- else
- dw_Error(MEM_ERR);
- return X;
-}
-/**/
-void FreeMatrix(TMatrix X)
-{
- if (X) free((int *)X-2);
-}
-/**/
-TPermutation CreatePermutation(int m)
-{
- TPermutation X;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- if (X=(TPermutation)malloc((m+2)*sizeof(int)))
- {
- X[0]=m;
- X[1]=0;
- }
- else
- dw_Error(MEM_ERR);
- return (TPermutation)(X+2);
-}
-/**/
-void FreePermutation(TPermutation X)
-{
- if (!X)
- dw_Error(NULL_ERR);
- else
- free(X-2);
-}
-#endif
-/*-----------------------------------------------------------------------------*/
-#if (defined(TZ_COLUMN_MAJOR))
-/**/
-TVector CreateVector(int m)
-{
- TVector x;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (x=(TVector)malloc(sizeof(TSdvector)))
- if (!(pElementV(x)=(PRECISION*)malloc(m*sizeof(PRECISION))))
- {
- free(x);
- dw_Error(MEM_ERR);
- return (TVector)NULL;
- }
- else
- {
- DimV(x)=m;
- x->flag=V_DEF;
- }
- else
- dw_Error(MEM_ERR);
- return x;
-}
-/**/
-void FreeVector(TVector x)
-{
- if (x)
- {
- if (pElementV(x)) free(pElementV(x));
- free(x);
- }
-}
-/**/
-TMatrix CreateMatrix(int m, int n)
-{
- TMatrix X;
- if ((m <= 0) || (n <= 0))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (X=(TMatrix)malloc(sizeof(TSdmatrix)))
- if (!(pElementM(X)=(PRECISION*)malloc(m*n*sizeof(PRECISION))))
- {
- free(X);
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- else
- {
- RowM(X)=m;
- ColM(X)=n;
- X->flag=M_GE;
- }
- else
- dw_Error(MEM_ERR);
- return X;
-}
-/**/
-TPermutation CreatePermutation(int m)
-{
- TPermutation X;
- if (m <= 0)
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- if (X=(TPermutation)malloc(sizeof(TPermutationStructure) + (m-1)*sizeof(int)))
- {
- X->dim=m;
- X->use=0;
- }
- else
- dw_Error(MEM_ERR);
- return X;
-}
-/**/
-void FreePermutation(TPermutation X)
-{
- if (X) free(X);
-}
-/**/
-void FreeMatrix(TMatrix X)
-{
- if (X)
- {
- if (pElementM(X)) free(pElementM(X));
- free(X);
- }
-}
-#endif
-/*-----------------------------------------------------------------------------*/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/************************** Initialization Routines ****************************/
-/*******************************************************************************/
-/*
- Assumes
- x : m vector
-
- Results
- x(i) = c
-
- Returns
- x
-*/
-TVector InitializeVector(TVector x, PRECISION c)
-{
- int i;
- if (!x)
- dw_Error(NULL_ERR);
- else
- for (i=DimV(x); --i >= 0; ElementV(x,i)=c);
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix
-
- Results
- X(i,j) = c
-
- Returns
- X
-*/
-TMatrix InitializeMatrix(TMatrix X, PRECISION c)
-{
- int i;
- PRECISION *pX;
- if (!X)
- dw_Error(NULL_ERR);
- else
- for (pX=pElementM(X), i=RowM(X)*ColM(X)-1; i >= 0; i--) pX[i]=c;
- return X;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/**************************** Assignment Routines ******************************/
-/*******************************************************************************/
-/*
- Assumes
- x : m-vector or null pointer
- y : m-vector
-
- Results
- x = y. If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call dw_GetError() to
- determine the cause of failure.
-*/
-TVector EquateVector(TVector x, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(y))))
- return (TVector)NULL;
- }
- else
- if (x == y)
- return x;
- else
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- memcpy(pElementV(x),pElementV(y),DimV(y)*sizeof(PRECISION));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : m x n matrix
-
- Results
- X = Y. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix EquateMatrix(TMatrix X, TMatrix Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Y),ColM(Y))))
- return (TMatrix)NULL;
- }
- else
- if (X == Y)
- return X;
- else
- if ((RowM(Y) != RowM(X)) || (ColM(Y) != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- memcpy(pElementM(X),pElementM(Y),RowM(Y)*ColM(Y)*sizeof(PRECISION));
- SetMajorForm(X,MajorForm(Y));
- return X;
-}
-
-/*
- Assumes
- X : m x m matrix or null pointer
-
- Results
- X is set to the m x m identity matrix. If X is null pointer, X
- is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix IdentityMatrix(TMatrix X, int m)
-{
- int i;
- PRECISION *pX;
- if (!X)
- {
- if (!(X=CreateMatrix(m,m)))
- return (TMatrix)NULL;
- }
- else
- if ((m != RowM(X)) || (m != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (pX=pElementM(X), i=m*m-1; i >= 0; i--) pX[i]=0.0;
- for (i=m*m-1; i >= 0; i-=m+1) pX[i]=1.0;
- return X;
-}
-
-/*
- Assumes
- X : a null pointer or r x s matrix, where r = m and s >= m or r >= m and s = m.
- y : m-vector
-
- Results
- X = diag(y). If X is null pointer, a square matrix X is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix DiagonalMatrix(TMatrix X, TVector y)
-{
- int i, j, k;
- PRECISION *pX;
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(DimV(y),DimV(y))))
- return (TMatrix)NULL;
- }
- else
- if (DimV(y) != ((RowM(X) < ColM(X)) ? RowM(X) : ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (pX=pElementM(X), i=RowM(X)*ColM(X)-1; i >= 0; i--) pX[i]=0.0;
- for (k=(MajorForm(X) ? RowM(X) : ColM(X))+1, j=DimV(y)-1, pX=&ElementM(X,j,j); j >= 0; pX-=k, j--) *pX=ElementV(y,j);
- return X;
-}
-
-/*
- Assumes
- X : m x 1 matrix or null pointer
- y : m-vector
-
- Results
- X is equal to the column vector y. If X is null pointer, X is
- created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix ColumnMatrix(TMatrix X, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(DimV(y),1)))
- return (TMatrix)NULL;
- }
- else
- if ((DimV(y) != RowM(X)) || (1 != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- memcpy(pElementM(X),pElementV(y),DimV(y)*sizeof(PRECISION));
- return X;
-}
-
-/*
- Assumes
- X : 1 x m matrix or null pointer
- y : m-vector
-
- Results
- X is equal to the row vector y. If X is null pointer, X is
- created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix RowMatrix(TMatrix X, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(1,DimV(y))))
- return (TMatrix)NULL;
- }
- else
- if ((1 != RowM(X)) || (DimV(y) != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- memcpy(pElementM(X),pElementV(y),DimV(y)*sizeof(PRECISION));
- return X;
-}
-
-/*
- Assumes
- x : m vector or null pointer
- y : m vector
-
- Results
- x(i) = abs(y(i)). If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x and y do not have to be distinct vectors.
-*/
-TVector AbsV(TVector x, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(y))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- bAbs(pElementV(x),pElementV(y),DimV(y));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : m x n matrix
-
- Results
- X(i,j) = abs(Y(i,j)). If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct matrices
-*/
-TMatrix AbsM(TMatrix X, TMatrix Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Y),ColM(Y))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != RowM(Y)) || (ColM(X) != ColM(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bAbs(pElementM(X),pElementM(Y),RowM(Y)*ColM(Y));
- SetMajorForm(X,MajorForm(Y));
- return X;
-}
-
-/*
- Assumes
- x : m vector or null pointer
- y : m vector
-
- Results
- x = -x. If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x and y do not have to be distinct vectors.
-*/
-TVector MinusV(TVector x, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(y))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- bNegative(pElementV(x),pElementV(y),DimV(y));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : m x n matrix
-
- Results
- X = -Y. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct matrices.
-*/
-TMatrix MinusM(TMatrix X, TMatrix Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Y),ColM(Y))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != RowM(Y)) || (ColM(X) != ColM(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bNegative(pElementM(X),pElementM(Y),RowM(Y)*ColM(Y));
- SetMajorForm(X,MajorForm(Y));
- return X;
-}
-
-/*
- Assumes
- X : n x m matrix or null pointer
- Y : m x n matrix
-
- Results
- X = Y'. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- If Y is square, X and Y do not have to be distinct matrices
-*/
-TMatrix Transpose(TMatrix X, TMatrix Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (X == Y)
- {
- if (RowM(Y) != ColM(Y))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bTransposeInPlace(pElementM(Y),RowM(Y));
- }
- else
- {
- if (!X)
- {
- if (!(X=CreateMatrix(ColM(Y),RowM(Y))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != ColM(Y)) || (ColM(X) != RowM(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bTranspose(pElementM(X),pElementM(Y),RowM(Y),ColM(Y),MajorForm(Y));
- SetMajorForm(X,MajorForm(Y));
- }
- return X;
-}
-
-/*
- Assumes
- X : (rows x cols) matrix or null pointer
- Y : (r x c) matrix, where r >= brow+rows and c >= bcol+cols
-
- Results
- X(i,j) = Y(brow+i,bcol+j), for 0 <= i < rows and 0 <= j < cols. If
- X is null pointer, then the matrix X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix SubMatrix(TMatrix X, TMatrix Y, int brow, int bcol, int rows, int cols)
-{
- int j, s;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((brow+rows > RowM(Y)) || (bcol+cols > ColM(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(rows,cols)))
- return (TMatrix)NULL;
- }
- else
- if ((rows != RowM(X)) || (cols != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (Y != X)
- {
- if (MajorForm(Y))
- {
- if (rows == RowM(Y))
- memcpy(pElementM(X),&ElementM(Y,0,bcol),rows*cols*sizeof(PRECISION));
- else
- for (s=rows*sizeof(PRECISION), j=cols-1; j >= 0; j--)
- memcpy(&ElementM(X,0,j),&ElementM(Y,brow,bcol+j),s);
- }
- else
- {
- if (cols == ColM(Y))
- memcpy(pElementM(X),&ElementM(Y,brow,0),rows*cols*sizeof(PRECISION));
- else
- for (s=cols*sizeof(PRECISION), j=rows-1; j >= 0; j--)
- memcpy(&ElementM(X,j,0),&ElementM(Y,brow+j,bcol),s);
- }
- SetMajorForm(X,MajorForm(Y));
- }
- return X;
-}
-
-/*
- Assumes
- X : (rX x cX) matrix, where rX >= brow_X+rows and cX >= bcol_X+cols
- Y : (rY x cY) matrix, where rY >= brow_Y+rows and cY >= bcol_Y+cols
-
- Results
- X(brow_X+i,bcol_X+j) = Y(brow_Y+i,bcol_Y+j), for 0 <= i < rows and
- 0 <= j < cols.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix InsertSubMatrix(TMatrix X, TMatrix Y, int brow_X, int bcol_X, int brow_Y, int bcol_Y, int rows, int cols)
-
-{
- int i, j, s;
- if (!X || !Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((brow_Y+rows > RowM(Y)) || (bcol_Y+cols > ColM(Y))
- || (brow_X+rows > RowM(X)) || (bcol_X+cols > ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (Y != X)
- {
- if (MajorForm(Y) == MajorForm(X))
- if (MajorForm(Y))
- {
- if ((rows == RowM(Y)) && (rows == RowM(X)))
- memcpy(&ElementM(X,0,bcol_X),&ElementM(Y,0,bcol_Y),rows*cols*sizeof(PRECISION));
- else
- for (s=rows*sizeof(PRECISION), j=cols-1; j >= 0; j--)
- memcpy(&ElementM(X,brow_X,bcol_X+j),&ElementM(Y,brow_Y,bcol_Y+j),s);
- }
- else
- {
- if ((cols == ColM(Y)) && (cols == ColM(X)))
- memcpy(&ElementM(X,brow_X,0),&ElementM(Y,brow_Y,0),rows*cols*sizeof(PRECISION));
- else
- for (s=cols*sizeof(PRECISION), i=rows-1; i >= 0; i--)
- memcpy(&ElementM(X,brow_X+i,bcol_X),&ElementM(Y,brow_Y+i,bcol_Y),s);
- }
- else
- for (i=rows-1; i >= 0; i--)
- for (j=cols-1; j >= 0; j--)
- ElementM(X,brow_X+i,bcol_X+j)=ElementM(Y,brow_Y+i,bcol_Y+j);
- }
- return X;
-}
-
-/*
- Assumes
- x : d-dimensional vector or null pointer
- y : n-dimensional vector, where n >= b+d
-
- Results
- x(i) = y(b+i), for 0 <= i < d. If x is a null pointer, then the vector x is
- created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to determine
- the cause of failure.
-*/
-TVector SubVector(TVector x, TVector y, int b, int d)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (b+d > DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(d)))
- return (TVector)NULL;
- }
- else
- if (d != DimV(x))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (x != y)
- memcpy(pElementV(x),pElementV(y)+b,d*sizeof(PRECISION));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix
- y : m-vector
- col : 0 <= col < n
-
- Results
- X(i,col) = y(i), for 0 <= i < m.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TMatrix CopyColumnVector(TMatrix X, TVector y, int col)
-{
- int i, n;
- PRECISION *pX;
- if (!X || !y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((DimV(y) != RowM(X)) || (col < 0) || (ColM(X) <= col))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (MajorForm(X))
- memcpy(pElementM(X)+col*DimV(y),pElementV(y),DimV(y)*sizeof(PRECISION));
- else
- for (pX=pElementM(X)+(n=ColM(X))*(i=DimV(y)-1)+col; i >= 0; pX-=n, i--) *pX=ElementV(y,i);
- return X;
-}
-
-/*
- Assumes
- x : m-vector or null pointer
- Y : m x n matrix
- col : 0 <= col < n
-
- Results
- x(i) = Y(i,col), for 0 <= i < m. If x is null pointer, then the vector x
- is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TVector ColumnVector(TVector x, TMatrix Y, int col)
-{
- int i;
- PRECISION *pY;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if ((col < 0) || (ColM(Y) <= col))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(RowM(Y))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != RowM(Y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (MajorForm(Y))
- memcpy(pElementV(x),&ElementM(Y,0,col),DimV(x)*sizeof(PRECISION));
- else
- for (pY=&ElementM(Y,i=DimV(x)-1,col); i >= 0; pY-=ColM(Y), i--) ElementV(x,i)=*pY;
- return x;
-}
-
-/*
- Assumes
- x : n-vector or null pointer
- Y : m x n matrix
- row : 0 <= row < m
-
- Results
- x(j) = Y(row,j), for 0 <= j < n. If x is null pointer, then the vector x
- is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TVector RowVector(TVector x, TMatrix Y, int row)
-{
- int j, m;
- PRECISION *pY;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if ((row < 0) || (RowM(Y) <= row))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(ColM(Y))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != ColM(Y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (MajorForm(Y))
- for (pY=pElementM(Y)+row+(m=RowM(Y))*(j=DimV(x)-1); j >= 0; pY-=m, j--) ElementV(x,j)=*pY;
- else
- memcpy(pElementV(x),pElementM(Y)+row*DimV(x),DimV(x)*sizeof(PRECISION));
- return x;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/***************************** Addition Routines *******************************/
-/*******************************************************************************/
-/*
- Assumes
- x : m-vector or null pointer
- y : m-vector
- z : m-vector
-
- Results
- x = y + z. If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x, y, and z do not have to be distinct vectors
-*/
-TVector AddVV(TVector x, TVector y, TVector z)
-{
- if (!y || !z)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (DimV(y) != DimV(z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(y))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- bAdd(pElementV(x),pElementV(y),pElementV(z),DimV(y));
- return x;
-}
-
-/*
- Assumes
- x : m-vector or null pointer
- y : m-vector
- z : m-vector
-
- Results
- x = y - z. If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x, y, and z do not have to be distinct vectors
-*/
-TVector SubtractVV(TVector x, TVector y, TVector z)
-{
- if (!y || !z)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (DimV(y) != DimV(z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(y))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- bSubtract(pElementV(x),pElementV(y),pElementV(z),DimV(y));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : m x n matrix
- Z : m x n matrix
-
- Results
- X = Y + Z. If X is null pointer, x is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X, Y, and Z do not have to be distinct matrices
-*/
-TMatrix AddMM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((RowM(Y) != RowM(Z)) || (ColM(Y) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Z),ColM(Z))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != RowM(Z)) || (ColM(X) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bMatrixAdd(pElementM(X),pElementM(Y),pElementM(Z),RowM(Z),ColM(Z),MajorForm(X),MajorForm(Y),MajorForm(Z));
- return X;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : m x n matrix
- Z : m x n matrix
-
- Results
- X = Y - Z. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X, Y, and Z do not have to be distinct matrices
-*/
-TMatrix SubtractMM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((RowM(Y) != RowM(Z)) || (ColM(Y) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Z),ColM(Z))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != RowM(Z)) || (ColM(X) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bMatrixSubtract(pElementM(X),pElementM(Y),pElementM(Z),RowM(Z),ColM(Z),MajorForm(X),MajorForm(Y),MajorForm(Z));
- return X;
-}
-
-/*
- Assumes
- x : m vector
- y : m vector
- a : scalar
-
- Results
- x = x + ay
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x and y do not have to be distinct vectors
-*/
-TVector UpdateVS(TVector x, TVector y, PRECISION a)
-{
- if (!x || !y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (DimV(y) != DimV(x))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- bLinearUpdateScalar(pElementV(x),pElementV(y),a,DimV(y));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix
- Y : m x n matrix
- a : scalar
-
- Results
- X = X + aY
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct matrices
-*/
-TMatrix UpdateMS(TMatrix X, TMatrix Y, PRECISION a)
-{
- PRECISION *z;
- if (!X || !Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((RowM(Y) != RowM(X)) || (ColM(Y) != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((MajorForm(X) == MajorForm(Y)))
- bLinearUpdateScalar(pElementM(X),pElementM(Y),a,RowM(Y)*ColM(Y));
- else
- {
- if (!(z=(PRECISION*)malloc(RowM(Y)*ColM(Y)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- bTranspose(z,pElementM(Y),RowM(Y),ColM(Y),MajorForm(Y));
- bLinearUpdateScalar(pElementM(X),z,a,RowM(Y)*ColM(Y));
- free(z);
- }
- return X;
-}
-
-/*
- Assumes
- x : m vector or null pointer
- a : scalar
- y : m vector
- b : scalar
- z : m vector
-
- Results
- x = a*y + b*z. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x, y, and z do not have to be distinct vectors
-*/
-TVector LinearCombinationVV(TVector x, PRECISION a, TVector y, PRECISION b, TVector z)
-{
- if (!y || !z)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (DimV(y) != DimV(z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(z))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != DimV(z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- bLinearCombination(pElementV(x),a,pElementV(y),b,pElementV(z),DimV(z));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- a : scalar
- Y : m x n matrix
- b : scalar
- Z : m x n matrix
-
- Results
- X = a*Y + b*Z. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X, Y, and Z do not have to be distinct matrices
-*/
-TMatrix LinearCombinationMM(TMatrix X, PRECISION a, TMatrix Y, PRECISION b, TMatrix Z)
-{
- PRECISION *p;
- TMatrix W=X;
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((RowM(Y) != RowM(Z)) || (ColM(Y) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Z),ColM(Z))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != RowM(Z)) || (ColM(X) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (MajorForm(Y) == MajorForm(Z))
- {
- bLinearCombination(pElementM(X),a,pElementM(Y),b,pElementM(Z),RowM(X)*ColM(X));
- SetMajorForm(X,MajorForm(Y));
- }
- else
- if (X == Z)
- {
- if (!(p=(PRECISION*)malloc(RowM(Y)*ColM(Y)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- if (!W) FreeMatrix(X);
- return (TMatrix)NULL;
- }
- bTranspose(p,pElementM(Y),RowM(Y),ColM(Y),MajorForm(Y));
- bLinearCombination(pElementM(X),a,p,b,pElementM(Z),RowM(Z)*ColM(Z));
- free(p);
- }
- else
- if (X == Y)
- {
- if (!(p=(PRECISION*)malloc(RowM(Z)*ColM(Z)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- if (!W) FreeMatrix(X);
- return (TMatrix)NULL;
- }
- bTranspose(p,pElementM(Z),RowM(Z),ColM(Z),MajorForm(Z));
- bLinearCombination(pElementM(X),a,pElementM(Y),b,p,RowM(Z)*ColM(Z));
- free(p);
- }
- else
- {
- bTranspose(pElementM(X),pElementM(Z),RowM(Z),ColM(Z),MajorForm(Z));
- bLinearCombination(pElementM(X),a,pElementM(Y),b,pElementM(X),RowM(Z)*ColM(Z));
- SetMajorForm(X,MajorForm(Y));
- }
- return X;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/************************** Multiplication Routines ****************************/
-/*******************************************************************************/
-/*
- Assumes
- x : m-vector or null pointer
- y : m-vector
- s : scalar
-
- Results
- x = s*y. If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x and y do not have to be distinct
-*/
-TVector ProductSV(TVector x, PRECISION s, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(y))))
- return (TVector)NULL;
- }
- else
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- bMultiply(pElementV(x),pElementV(y),s,DimV(y));
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- y : m x n matix
- s : scalar
-
- Results
- X = s*Y. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct
-*/
-TMatrix ProductSM(TMatrix X, PRECISION s, TMatrix Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Y),ColM(Y))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != RowM(Y)) || (ColM(X) != ColM(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bMultiply(pElementM(X),pElementM(Y),s,RowM(Y)*ColM(Y));
- SetMajorForm(X,MajorForm(Y));
- return X;
-}
-
-/*
- Assumes
- x : n-vector or null pointer
- y : m-vector
- Z : m x n matrix
-
- Results
- x = y * Z. If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- If Z is square, x and y do not have to be distinct
-*/
-TVector ProductVM(TVector x, TVector y, TMatrix Z)
-{
- PRECISION *ptr;
- if (!y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (DimV(y) != RowM(Z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(ColM(Z))))
- return (TVector)NULL;
- }
- else
- {
- if (DimV(x) != ColM(Z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (x == y)
- {
- if (!(ptr=(PRECISION*)malloc(DimV(x)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TVector)NULL;
- }
- bMatrixMultiply(ptr,pElementV(y),pElementM(Z),1,DimV(x),DimV(y),0,0,MajorForm(Z));
- memcpy(pElementV(x),ptr,DimV(x)*sizeof(PRECISION));
- free(ptr);
- return x;
- }
- }
- bMatrixMultiply(pElementV(x),pElementV(y),pElementM(Z),1,DimV(x),DimV(y),0,0,MajorForm(Z));
- return x;
-}
-
-/*
- Assumes
- x : m-vector or null pointer
- Y : m x n matrix
- z : n-vector
-
- Results
- x = Y * z. If x is null pointer, x is created.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- If Y is square, x and z do not have to be distinct
-*/
-TVector ProductMV(TVector x, TMatrix Y, TVector z)
-{
- PRECISION *ptr;
- if (!Y || !z)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (ColM(Y) != DimV(z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(RowM(Y))))
- return (TVector)NULL;
- }
- else
- {
- if (DimV(x) != RowM(Y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (x == z)
- {
- if (!(ptr=(PRECISION*)malloc(DimV(x)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TVector)NULL;
- }
- bMatrixMultiply(ptr,pElementM(Y),pElementV(z),DimV(x),1,DimV(z),1,MajorForm(Y),1);
- memcpy(pElementV(x),ptr,DimV(x)*sizeof(PRECISION));
- free(ptr);
- return x;
- }
- }
- bMatrixMultiply(pElementV(x),pElementM(Y),pElementV(z),DimV(x),1,DimV(z),1,MajorForm(Y),1);
- return x;
-}
-
-
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : m x r matrix
- Z : r x n matrix
-
- Results
- X = Y * Z. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- If Z is square, X does not have to be distinct from Y
- If Y is square, X does not have to be distinct from Z
-*/
-TMatrix ProductMM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *ptr;
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (ColM(Y) != RowM(Z))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Y),ColM(Z))))
- return (TMatrix)NULL;
- }
- else
- {
- if ((RowM(X) != RowM(Y)) || (ColM(X) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((X == Y) || (X == Z))
- {
- if (!(ptr=(PRECISION*)malloc(RowM(X)*ColM(X)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- bMatrixMultiply(ptr,pElementM(Y),pElementM(Z),RowM(X),ColM(X),ColM(Y),MajorForm(X),MajorForm(Y),MajorForm(Z));
- memcpy(pElementM(X),ptr,RowM(X)*ColM(X)*sizeof(PRECISION));
- free(ptr);
- return X;
- }
- }
- bMatrixMultiply(pElementM(X),pElementM(Y),pElementM(Z),RowM(X),ColM(X),ColM(Y),MajorForm(X),MajorForm(Y),MajorForm(Z));
- return X;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/********************* Multiplication/Transpose Routines ***********************/
-/*******************************************************************************/
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : r x m matrix
- Z : r x n matrix
-
- Results
- X = Y'*Z. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- Y and Z do not have to be distinct matrices.
- If Y is square, X and Z do not have to be distinct matrices.
- If Z is square, X and Y do not have to be distinct matrices.
-*/
-TMatrix TransposeProductMM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *ptr;
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (RowM(Y) != RowM(Z))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(ColM(Y),ColM(Z))))
- return (TMatrix)NULL;
- }
- else
- {
- if ((RowM(X) != ColM(Y)) || (ColM(X) != ColM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((X == Y) || (X == Z))
- {
- if (!(ptr=(PRECISION*)malloc(RowM(X)*ColM(X)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- bMatrixMultiply(ptr,pElementM(Y),pElementM(Z),RowM(X),ColM(X),RowM(Y),MajorForm(X),1^MajorForm(Y),MajorForm(Z));
- memcpy(pElementM(X),ptr,RowM(X)*ColM(X)*sizeof(PRECISION));
- free(ptr);
- return X;
- }
- }
- bMatrixMultiply(pElementM(X),pElementM(Y),pElementM(Z),RowM(X),ColM(X),RowM(Y),MajorForm(X),1^MajorForm(Y),MajorForm(Z));
- return X;
-}
-
-/*
- Assumes
- X : m x n matrix or null pointer
- Y : m x p matrix
- Z : n x p matrix
-
- Results
- X = Y*Z'. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- Y and Z do not have to be distinct matrices.
- If Y is square, X and Z do not have to be distinct matrices.
- If Z is square, X and Y do not have to be distinct matrices.
-*/
-TMatrix ProductTransposeMM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *ptr;
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (ColM(Y) != ColM(Z))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Y),RowM(Z))))
- return (TMatrix)NULL;
- }
- else
- {
- if ((RowM(X) != RowM(Y)) || (ColM(X) != RowM(Z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((X == Y) || (X == Z))
- {
- if (!(ptr=(PRECISION*)malloc(RowM(X)*ColM(X)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- bMatrixMultiply(ptr,pElementM(Y),pElementM(Z),RowM(X),ColM(X),ColM(Y),MajorForm(X),MajorForm(Y),1^MajorForm(Z));
- memcpy(pElementM(X),ptr,RowM(X)*ColM(X)*sizeof(PRECISION));
- free(ptr);
- return X;
- }
- }
- bMatrixMultiply(pElementM(X),pElementM(Y),pElementM(Z),RowM(X),ColM(X),ColM(Y),MajorForm(X),MajorForm(Y),1^MajorForm(Z));
- return X;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-
-/*******************************************************************************/
-/********************** Multiplication/Inverse Routines ************************/
-/*******************************************************************************/
-/*
- Assumes
- x : m vector or null
- Y : m x m matrix
- z : m vector
-
- Results
- x = Inverse(Y) * z.
-
- Returns
- Returns x upon success, null otherwise.
-
- Notes
- The vectors x and z do not have to be distinct. Uses Gaussian elimination
- with partial pivoting and back substitution. A null return indicates
- that either Y or z was null, Y was singular, the matrices were not of the
- required size, or the routine was unable to allocate needed memory. Call
- GetError() to determine which of these occured.
-*/
-TVector InverseProductMV(TVector x, TMatrix Y, TVector z)
-{
- PRECISION *LU;
- int *p, err;
- TVector rtrn=(TVector)NULL;
- if (!Y || !z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Y) != ColM(Y)) || (ColM(Y) != DimV(z)))
- dw_Error(SIZE_ERR);
- else
- if (!(p=(int*)malloc(RowM(Y)*sizeof(int))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(LU=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(LU,pElementM(Y),RowM(Y)*RowM(Y)*sizeof(PRECISION));
- if (err=bLU(p,LU,RowM(Y),RowM(Y),MajorForm(Y)))
- dw_Error(err);
- else
- if (rtrn=((x == z) ? x : EquateVector(x,z)))
- {
- bPermutationMultiply(p,pElementV(rtrn),DimV(rtrn),1,RowM(Y),1,MajorForm(Y));
- bSolveUnitTriangular(LU,pElementV(rtrn),DimV(rtrn),1,0,MajorForm(Y),1);
- bSolveTriangular(LU,pElementV(rtrn),DimV(rtrn),1,1,MajorForm(Y),1);
- }
- free(LU);
- }
- free(p);
- }
- return rtrn;
-}
-
-/*
- Assumes
- x : m vector or null
- Y : m x m matrix upper triangular matrix
- z : m vector
-
- Results
- x = Inverse(Y) * z.
-
- Returns
- Returns x upon success, null otherwise.
-
- Notes
- The vectors x and z do not have to be distinct. Uses back substitution.
- A null return indicates that either Y or z was null, Y was singular, or
- the matrices were not of the required size. Call GetError() to
- determine which of these occured.
-*/
-TVector InverseProductUV(TVector x, TMatrix Y, TVector z)
-{
- TVector rtrn=(TVector)NULL;
- int err;
- if (!Y || !z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Y) != ColM(Y)) || (ColM(Y) != DimV(z)))
- dw_Error(SIZE_ERR);
- else
- if (rtrn=((x == z) ? x : EquateVector(x,z)))
- if (err=bSolveTriangular(pElementM(Y),pElementV(rtrn),DimV(rtrn),1,1,MajorForm(Y),1))
- {
- if (rtrn != x) FreeVector(rtrn);
- rtrn=(TVector)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-
-/*
- Assumes
- x : m vector or null
- Y : m x m matrix lower triangular matrix
- z : m vector
-
- Results
- x = Inverse(Y) * z.
-
- Returns
- Returns x upon success, null otherwise.
-
- Notes
- The vectors x and z do not have to be distinct. Uses back substitution.
- A null return indicates that either Y or z was null, Y was singular, or
- the matrices were not of the required size. Call GetError() to
- determine which of these occured.
-*/
-TVector InverseProductLV(TVector x, TMatrix Y, TVector z)
-{
- TVector rtrn=(TVector)NULL;
- int err;
- if (!Y || !z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Y) != ColM(Y)) || (ColM(Y) != DimV(z)))
- dw_Error(SIZE_ERR);
- else
- if (rtrn=((x == z) ? x : EquateVector(x,z)))
- if (err=bSolveTriangular(pElementM(Y),pElementV(rtrn),DimV(rtrn),1,0,MajorForm(Y),1))
- {
- if (rtrn != x) FreeVector(rtrn);
- rtrn=(TVector)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x n matrix or null
- Y : m x m matrix
- Z : m x n matrix
-
- Results
- X = Inverse(Y) * Z.
-
- Returns
- Returns X upon success, null otherwise.
-
- Notes
- Size permitting, X, Y and Z do not have to be distinct. Uses Gaussian
- elimination with partial pivoting and back substitution. A null return
- indicates that either Y or Z was null, Y was singular, the matrices were
- not of the required size, or the routine was unable to allocate needed
- memory. Call GetError() to determine which of these occured.
-*/
-TMatrix InverseProductMM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *LU;
- int *p, err, MajorFormLU, q;
- TMatrix rtrn=(TMatrix)NULL;
- if (!Y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Y) != ColM(Y)) || (ColM(Y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (!(p=(int*)malloc((q=(RowM(Y) < ColM(Y)) ? RowM(Y) : ColM(Y))*sizeof(int))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(LU=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(LU,pElementM(Y),RowM(Y)*RowM(Y)*sizeof(PRECISION));
- MajorFormLU=MajorForm(Y);
- if (err=bLU(p,LU,RowM(Y),RowM(Y),MajorForm(Y)))
- dw_Error(err);
- else
- if (rtrn=((X == Z) ? X : EquateMatrix(X,Z)))
- {
- bPermutationMultiply(p,pElementM(rtrn),RowM(rtrn),ColM(rtrn),q,1,MajorForm(rtrn));
- bSolveUnitTriangular(LU,pElementM(rtrn),RowM(rtrn),ColM(rtrn),0,MajorFormLU,MajorForm(rtrn));
- bSolveTriangular(LU,pElementM(rtrn),RowM(rtrn),ColM(rtrn),1,MajorFormLU,MajorForm(rtrn));
- }
- free(LU);
- }
- free(p);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x n matrix or null
- Y : m x m upper triangular matrix
- Z : m x n matrix
-
- Results
- X = Inverse(Y) * Z.
-
- Returns
- Returns X upon success, null otherwise.
-
- Notes
- Size permitting, X, Y and Z do not have to be distinct. Uses back
- substitution. A null return indicates that either Y or Z was null,
- Y was singular, or the matrices were not of the required size. Call
- GetError() to determine which of these occured.
-*/
-TMatrix InverseProductUM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *ptr;
- TMatrix rtrn=(TMatrix)NULL;
- int err, MajorFormY;
- if (!Y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Y) != ColM(Y)) || (ColM(Y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (X == Y)
- if (!(ptr=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(ptr,pElementM(Y),RowM(Y)*RowM(Y)*sizeof(PRECISION));
- MajorFormY=MajorForm(Y);
- if (rtrn=((X == Z) ? X : EquateMatrix(X,Z)))
- if (err=bSolveTriangular(ptr,pElementM(rtrn),RowM(rtrn),ColM(rtrn),1,MajorFormY,MajorForm(rtrn)))
- {
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- free(ptr);
- }
- else
- if (rtrn=((X == Z) ? X : EquateMatrix(X,Z)))
- if (err=bSolveTriangular(pElementM(Y),pElementM(rtrn),RowM(rtrn),ColM(rtrn),1,MajorForm(Y),MajorForm(rtrn)))
- {
- if (rtrn != X) FreeMatrix(rtrn);
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x n matrix or null
- Y : m x m lower triangular matrix
- Z : m x n matrix
-
- Results
- X = Inverse(Y) * Z.
-
- Returns
- Returns X upon success, null otherwise.
-
- Notes
- Size permitting, X, Y and Z do not have to be distinct. Uses back
- substitution. A null return indicates that either Y or Z was null,
- Y was singular, or the matrices were not of the required size. Call
- GetError() to determine which of these occured.
-*/
-TMatrix InverseProductLM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *ptr;
- TMatrix rtrn=(TMatrix)NULL;
- int err, MajorFormY;
- if (!Y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Y) != ColM(Y)) || (ColM(Y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (X == Y)
- if (!(ptr=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(ptr,pElementM(Y),RowM(Y)*RowM(Y)*sizeof(PRECISION));
- MajorFormY=MajorForm(Y);
- if (rtrn=((X == Z) ? X : EquateMatrix(X,Z)))
- if (err=bSolveTriangular(ptr,pElementM(rtrn),RowM(rtrn),ColM(rtrn),0,MajorFormY,MajorForm(rtrn)))
- {
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- free(ptr);
- }
- else
- if (rtrn=((X == Z) ? X : EquateMatrix(X,Z)))
- if (err=bSolveTriangular(pElementM(Y),pElementM(rtrn),RowM(rtrn),ColM(rtrn),0,MajorForm(Y),MajorForm(rtrn)))
- {
- if (rtrn != X) FreeMatrix(rtrn);
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-
-/*
- Assumes
- x : n vector or null pointer
- y : n vector
- Z : n x n invertible matrix
-
- Results
- x = y * Inverse(Z).
-
- Returns
- Returns x upon success, null otherwise.
-
- Notes
- The vectors x and y do not have to be distinct. Uses Gaussian elimination
- with partial pivoting and back substitution. A null return indicates
- that either y or Z was null, Z was singular, the matrices were not of the
- required size, or the routine was unable to allocate needed memory. Call
- GetError() to determine which of these occured.
-*/
-TVector ProductInverseVM(TVector x, TVector y, TMatrix Z)
-{
- PRECISION *LU;
- int *p, err;
- TVector rtrn=(TVector)NULL;
- if (!y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Z) != ColM(Z)) || (DimV(y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (!(p=(int*)malloc(RowM(Z)*sizeof(int))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(LU=(PRECISION*)malloc(RowM(Z)*RowM(Z)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(LU,pElementM(Z),RowM(Z)*RowM(Z)*sizeof(PRECISION));
- if (err=bLU(p,LU,RowM(Z),RowM(Z),MajorForm(Z)))
- dw_Error(err);
- else
- if (rtrn=((x == y) ? x : EquateVector(x,y)))
- {
- bSolveTriangular(LU,pElementV(rtrn),DimV(rtrn),1,0,1^MajorForm(Z),0);
- bSolveUnitTriangular(LU,pElementV(rtrn),DimV(rtrn),1,1,1^MajorForm(Z),0);
- bPermutationMultiply(p,pElementV(rtrn),DimV(rtrn),1,RowM(Z),0,0);
- }
- free(LU);
- }
- free(p);
- }
- return rtrn;
-}
-
-/*
- Assumes
- x : n vector or null pointer
- y : n vector
- Z : n x n upper triangular matrix
-
- Results
- x = y * Inverse(Z).
-
- Returns
- Returns x upon success, null otherwise.
-
- Notes
- The vectors x and y do not have to be distinct. Uses back substitution.
- A null return indicates that either y or Z was null, Z was singular, or
- the matrices were not of the required size. Call GetError() to
- determine which of these occured.
-*/
-TVector ProductInverseVU(TVector x, TVector y, TMatrix Z)
-{
- TVector rtrn=(TVector)NULL;
- int err;
- if (!y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Z) != ColM(Z)) || (DimV(y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (rtrn=((x == y) ? x : EquateVector(x,y)))
- if (err=bSolveTriangular(pElementM(Z),pElementV(rtrn),DimV(rtrn),1,0,1^MajorForm(Z),1))
- {
- if (rtrn != x) FreeVector(rtrn);
- rtrn=(TVector)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-
-/*
- Assumes
- x : n vector or null pointer
- y : n vector
- Z : n x n lower triangular matrix
-
- Results
- x = y * Inverse(Z).
-
- Returns
- Returns x upon success, null otherwise.
-
- Notes
- The vectors x and y do not have to be distinct. Uses back substitution.
- A null return indicates that either y or Z was null, Z was singular, or
- the matrices were not of the required size. Call GetError() to
- determine which of these occured.
-*/
-TVector ProductInverseVL(TVector x, TVector y, TMatrix Z)
-{
- TVector rtrn=(TVector)NULL;
- int err;
- if (!y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Z) != ColM(Z)) || (DimV(y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (rtrn=((x == y) ? x : EquateVector(x,y)))
- if (err=bSolveTriangular(pElementM(Z),pElementV(rtrn),DimV(rtrn),1,1,1^MajorForm(Z),1))
- {
- if (rtrn != x) FreeVector(rtrn);
- rtrn=(TVector)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x n matrix
- Y : m x n matrix
- Z : n x n matrix
-
- Results
- X = Y * Inverse(Z).
-
- Returns
- Returns X upon success, null otherwise.
-
- Notes
- Size permitting, X, Y and Z do not have to be distinct. Uses Gaussian
- elimination with partial pivoting and back substitution. A null return
- indicates that either Y or Z was null, Z was singular, the matrices were
- not of the required size, or the routine was unable to allocate needed
- memory. Call GetError() to determine which of these occured.
-*/
-TMatrix ProductInverseMM(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *LU;
- int *p, err, MajorFormLU;
- TMatrix rtrn=(TMatrix)NULL;
- if (!Y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Z) != ColM(Z)) || (ColM(Y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (!(p=(int*)malloc(RowM(Z)*sizeof(int))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(LU=(PRECISION*)malloc(RowM(Z)*RowM(Z)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(LU,pElementM(Z),RowM(Z)*RowM(Z)*sizeof(PRECISION));
- MajorFormLU=MajorForm(Z);
- if (err=bLU(p,LU,RowM(Z),RowM(Z),MajorForm(Z)))
- dw_Error(err);
- else
- if (rtrn=((X == Y) ? X : EquateMatrix(X,Y)))
- {
- bSolveTriangular(LU,pElementM(rtrn),ColM(rtrn),RowM(rtrn),0,1^MajorFormLU,1^MajorForm(rtrn));
- bSolveUnitTriangular(LU,pElementM(rtrn),ColM(rtrn),RowM(rtrn),1,1^MajorFormLU,1^MajorForm(rtrn));
- bPermutationMultiply(p,pElementM(rtrn),ColM(rtrn),RowM(rtrn),ColM(rtrn),0,1^MajorForm(rtrn));
- }
- free(LU);
- }
- free(p);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x n matrix
- Y : m x n matrix
- Z : n x n upper triangular matrix
-
- Results
- X = Y * Inverse(Z).
-
- Returns
- Returns X upon success, null otherwise.
-
- Notes
- Size permitting, X, Y and Z do not have to be distinct. Uses back
- substitution. A null return indicates that either Y or Z was null,
- Z was singular, or the matrices were not of the required size. Call
- Getdw_Error() to determine which of these occured.
-*/
-TMatrix ProductInverseMU(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *ptr;
- TMatrix rtrn=(TMatrix)NULL;
- int err;
- if (!Y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Z) != ColM(Z)) || (ColM(Y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (X == Z)
- if (!(ptr=(PRECISION*)malloc(RowM(Z)*RowM(Z)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(ptr,pElementM(Z),RowM(Z)*RowM(Z)*sizeof(PRECISION));
- if (rtrn=((X == Y) ? X : EquateMatrix(X,Y)))
- if (err=bSolveTriangular(ptr,pElementM(rtrn),ColM(rtrn),RowM(rtrn),0,1^MajorForm(Z),1^MajorForm(rtrn)))
- {
- if (rtrn != X) FreeMatrix(rtrn);
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- free(ptr);
- }
- else
- if (rtrn=((X == Y) ? X : EquateMatrix(X,Y)))
- if (err=bSolveTriangular(pElementM(Z),pElementM(rtrn),ColM(rtrn),RowM(rtrn),0,1^MajorForm(Z),1^MajorForm(rtrn)))
- {
- if (rtrn != X) FreeMatrix(rtrn);
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x n matrix
- Y : m x n matrix
- Z : n x n upper triangular matrix
-
- Results
- X = Y * Inverse(Z).
-
- Returns
- Returns X upon success, null otherwise.
-
- Notes
- Size permitting, X, Y and Z do not have to be distinct. Uses back
- substitution. A null return indicates that either Y or Z was null,
- Z was singular, or the matrices were not of the required size. Call
- GetError() to determine which of these occured.
-*/
-TMatrix ProductInverseML(TMatrix X, TMatrix Y, TMatrix Z)
-{
- PRECISION *ptr;
- TMatrix rtrn=(TMatrix)NULL;
- int err;
- if (!Y || !Z)
- dw_Error(NULL_ERR);
- else
- if ((RowM(Z) != ColM(Z)) || (ColM(Y) != RowM(Z)))
- dw_Error(SIZE_ERR);
- else
- if (X == Z)
- if (!(ptr=(PRECISION*)malloc(RowM(Z)*RowM(Z)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(ptr,pElementM(Z),RowM(Z)*RowM(Z)*sizeof(PRECISION));
- if (rtrn=((X == Y) ? X : EquateMatrix(X,Y)))
- if (err=bSolveTriangular(ptr,pElementM(rtrn),ColM(rtrn),RowM(rtrn),1,1^MajorForm(Z),1^MajorForm(rtrn)))
- {
- if (rtrn != X) FreeMatrix(rtrn);
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- free(ptr);
- }
- else
- if (rtrn=((X == Y) ? X : EquateMatrix(X,Y)))
- if (err=bSolveTriangular(pElementM(Z),pElementM(rtrn),ColM(rtrn),RowM(rtrn),1,1^MajorForm(Z),1^MajorForm(rtrn)))
- {
- if (rtrn != X) FreeMatrix(rtrn);
- rtrn=(TMatrix)NULL;
- dw_Error(err);
- }
- return rtrn;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/************************** Matrix Inverse Routines ****************************/
-/*******************************************************************************/
-/*
- Assumes
- X : m x m matrix or null pointer
- Y : m x m matrix
-
- Results
- X = inverse(Y)
-
- Returns
- Returns X upon success, null otherwise
-
- Notes
- The matrices X and Y do not have to be distinct. Uses Gaussian
- elimination with partial pivoting and back substitution to form the
- inverse. A null return indicates that either Y or Z was null, Y was
- singular, or unable to allocate required memory. Call GetError()
- to determine which of these occured.
-*/
-TMatrix Inverse_LU(TMatrix X, TMatrix Y)
-{
- PRECISION *LU;
- int *p;
- TMatrix rtrn=(TMatrix)NULL;
- if (!Y)
- dw_Error(NULL_ERR);
- else
- if (RowM(Y) != ColM(Y))
- dw_Error(SIZE_ERR);
- else
- if (!(p=(int*)malloc(RowM(Y)*sizeof(int))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(LU=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(LU,pElementM(Y),RowM(Y)*RowM(Y)*sizeof(PRECISION));
- if (bLU(p,LU,RowM(Y),RowM(Y),MajorForm(Y)))
- dw_Error(SING_ERR);
- else
- if (rtrn=IdentityMatrix(X,RowM(Y)))
- {
- bPermutationMultiply(p,pElementM(rtrn),RowM(rtrn),ColM(rtrn),RowM(Y),1,MajorForm(rtrn));
- bSolveUnitTriangular(LU,pElementM(rtrn),RowM(rtrn),ColM(rtrn),0,MajorForm(Y),MajorForm(rtrn));
- bSolveTriangular(LU,pElementM(rtrn),RowM(rtrn),ColM(rtrn),1,MajorForm(Y),MajorForm(rtrn));
- }
- free(LU);
- }
- free(p);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x m matrix or null pointer
- Y : m x m matrix
-
- Results
- X = inverse(Y)
-
- Returns
- Returns X upon success, null otherwise
-
- Notes
- The matrices X and Y do not have to be distinct. Uses singular value
- decomposition to form the inverse. A null return indicates that either
- Y or Z was null, Y was singular, or unable to allocate required memory.
- Call GetError() to determine which of these occured.
-*/
-TMatrix Inverse_SVD(TMatrix X, TMatrix Y)
-{
- int i, j, k, err;
- TMatrix rtrn=(TMatrix)NULL;
- PRECISION scale, tolerance, *U, *V, *d;
- if (!Y)
- dw_Error(NULL_ERR);
- else
- if (RowM(Y) != ColM(Y))
- dw_Error(SIZE_ERR);
- else
- if (!(U=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(V=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(d=(PRECISION*)malloc(RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- if (err=bSVD(U,d,V,pElementM(Y),RowM(Y),RowM(Y),MajorForm(Y),1^MajorForm(Y),MajorForm(Y)))
- dw_Error(err);
- else
- {
- for (tolerance=d[0], j=RowM(Y)-1; j > 0; j--)
- if (tolerance < d[j]) tolerance=d[j];
- tolerance*=MACHINE_EPSILON;
- for (k=RowM(Y)*RowM(Y), j=RowM(Y)-1; j >= 0; j--)
- {
- if (d[j] < tolerance)
- {
- dw_Error(SING_ERR);
- free(U);
- free(V);
- free(d);
- return (TMatrix)NULL;
- }
- scale=1.0/d[j];
- if (MajorForm(Y))
- for (i=--k; i >= 0; i-=RowM(Y)) V[i]*=scale;
- else
- for (i=RowM(Y)-1; i >= 0; i--) V[--k]*=scale;
- }
- if (X)
- if ((RowM(X) != RowM(Y)) || (ColM(X) != RowM(Y)))
- dw_Error(SIZE_ERR);
- else
- bMatrixMultiply(pElementM(rtrn=X),V,U,RowM(Y),RowM(Y),RowM(Y),MajorForm(X),1^MajorForm(Y),1^MajorForm(Y));
- else
- if (rtrn=CreateMatrix(RowM(Y),RowM(Y)))
- bMatrixMultiply(pElementM(rtrn),V,U,RowM(Y),RowM(Y),RowM(Y),MajorForm(rtrn),1^MajorForm(Y),1^MajorForm(Y));
- }
- free(d);
- }
- free(V);
- }
- free(U);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x m matrix or null pointer
- Y : m x m symmetric matrix
-
- Results
- X = inverse(Y)
-
- Returns
- Returns X upon success, null otherwise
-
- Notes
- The matrices X and Y do not have to be distinct. Uses Cholesky
- decomposition to form the inverse. Only the upper half of Y is used.
- A null return indicates that either Y or Z was null, Y was singular,
- or unable to allocate required memory. Call GetError() to
- determine which of these occured.
-*/
-TMatrix Inverse_Cholesky(TMatrix X, TMatrix Y)
-{
- TMatrix rtrn=(TMatrix)NULL;
- PRECISION *ptr;
- if (!Y)
- dw_Error(NULL_ERR);
- else
- if (RowM(Y) != ColM(Y))
- dw_Error(SIZE_ERR);
- else
- if (!(ptr=(PRECISION*)malloc(RowM(Y)*RowM(Y)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(ptr,pElementM(Y),RowM(Y)*RowM(Y)*sizeof(PRECISION));
- if (bCholesky(ptr,RowM(Y),1,MajorForm(Y)))
- dw_Error(SING_ERR);
- else
- {
- if (rtrn=IdentityMatrix(X,RowM(Y)))
- {
- bSolveTriangular(ptr,pElementM(rtrn),RowM(Y),RowM(Y),1,MajorForm(Y),MajorForm(rtrn));
- bMatrixMultiply(ptr,pElementM(rtrn),pElementM(rtrn),RowM(Y),RowM(Y),RowM(Y),MajorForm(rtrn),MajorForm(rtrn),1^MajorForm(rtrn));
- memcpy(pElementM(rtrn),ptr,RowM(Y)*RowM(Y)*sizeof(PRECISION));
- }
- }
- free(ptr);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x m matrix or null pointer
- T : m x m upper triangular matrix
-
- Results
- X = inverse(T)
-
- Returns
- Returns X upon success, null otherwise
-
- Notes
- The matrices X and T do not have to be distinct. Uses back substitution
- to form the inverse. A null return indicates that T was null or
- singular, or unable to allocate required memory. Call
- GetError() to determine which of these occured.
-*/
-TMatrix Inverse_UT(TMatrix X, TMatrix T)
-{
- PRECISION *ptr;
- int err;
- if (!T)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (RowM(T) != ColM(T))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (X=IdentityMatrix(X,RowM(T)))
- if (err=bSolveTriangular(pElementM(T),pElementM(X),RowM(T),RowM(T),1,MajorForm(T),MajorForm(X)))
- {
- dw_Error(err);
- FreeMatrix(X);
- return (TMatrix)NULL;
- }
- }
- else
- if (X == T)
- {
- if (!(ptr=(PRECISION*)malloc(RowM(T)*RowM(T)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- memcpy(ptr,pElementM(T),RowM(T)*RowM(T)*sizeof(PRECISION));
- if (X=IdentityMatrix(X,RowM(T)))
- if (err=bSolveTriangular(ptr,pElementM(X),RowM(T),RowM(T),1,MajorForm(T),MajorForm(X)))
- {
- dw_Error(err);
- free(ptr);
- return (TMatrix)NULL;
- }
- free(ptr);
- }
- else
- if (X=IdentityMatrix(X,RowM(T)))
- if (err=bSolveTriangular(pElementM(T),pElementM(X),RowM(T),RowM(T),1,MajorForm(T),MajorForm(X)))
- {
- dw_Error(err);
- return (TMatrix)NULL;
- }
- return X;
-}
-
-/*
- Assumes
- X : m x m matrix or null pointer
- T : m x m lower triangular matrix
-
- Results
- X = inverse(T)
-
- Returns
- Returns X upon success, null otherwise
-
- Notes
- The matrices X and T do not have to be distinct. Uses back substitution
- to form the inverse. A null return indicates that either T was null,
- Y was singular, or unable to allocate required memory. Call
- GetError() to determine which of these occured.
-*/
-TMatrix Inverse_LT(TMatrix X, TMatrix T)
-{
- PRECISION *ptr;
- int err;
- if (!T)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (RowM(T) != ColM(T))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (X=IdentityMatrix(X,RowM(T)))
- if (err=bSolveTriangular(pElementM(T),pElementM(X),RowM(T),RowM(T),0,MajorForm(T),MajorForm(X)))
- {
- dw_Error(err);
- FreeMatrix(X);
- return (TMatrix)NULL;
- }
- }
- else
- if (X == T)
- {
- if (!(ptr=(PRECISION*)malloc(RowM(T)*RowM(T)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- memcpy(ptr,pElementM(T),RowM(T)*RowM(T)*sizeof(PRECISION));
- if (X=IdentityMatrix(X,RowM(T)))
- if (err=bSolveTriangular(ptr,pElementM(X),RowM(T),RowM(T),0,MajorForm(T),MajorForm(X)))
- {
- dw_Error(err);
- free(ptr);
- return (TMatrix)NULL;
- }
- free(ptr);
- }
- else
- if (X=IdentityMatrix(X,RowM(T)))
- if (err=bSolveTriangular(pElementM(T),pElementM(X),RowM(T),RowM(T),0,MajorForm(T),MajorForm(X)))
- {
- dw_Error(err);
- return (TMatrix)NULL;
- }
- return X;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/*************************** Miscellaneous Routines ****************************/
-/*******************************************************************************/
-/*
- Assumes
- x : m-vector
-
- Results
- returns norm of x.
-*/
-PRECISION Norm(TVector x)
-{
- int i;
- PRECISION result;
- if (!x)
- {
- dw_Error(NULL_ERR);
- return 0.0;
- }
- dw_ClearError();
- for (result=ElementV(x,0)*ElementV(x,0), i=DimV(x)-1; i > 0; i--)
- result+=ElementV(x,i)*ElementV(x,i);
- return sqrt(result);
-}
-
-/*
- Assumes
- X : m x n matrix
-
- Results
- Returns the Euclidean norm of x.
-
- Notes
- The Euclidean norm is the square root of the sum of the squares of the
- elements of X
-*/
-PRECISION MatrixNormEuclidean(TMatrix X)
-{
- int i;
- PRECISION result, *p;
- if (!X)
- {
- dw_Error(NULL_ERR);
- return 0.0;
- }
- dw_ClearError();
- p=pElementM(X);
- for (result=p[0]*p[0], i=RowM(X)*ColM(X)-1; i > 0; i--)
- result+=p[i]*p[i];
- return sqrt(result);
-}
-
-/*
- Assumes
- X : m x n matrix
-
- Results
- Returns the Euclidean norm of x.
-
- Notes
- The matrix norm of X is the max of the norm of X*v over all vectors of unit
- length. It will be equal to the largest of the singular values of X.
-*/
-PRECISION MatrixNorm(TMatrix X)
-{
- PRECISION result, *d;
- if (!X)
- {
- dw_Error(NULL_ERR);
- return 0.0;
- }
- if (!(d=(PRECISION*)malloc(((RowM(X) < ColM(X)) ? RowM(X) : ColM(X))*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return 0.0;
- }
- dw_ClearError();
- if (bSVD_new((PRECISION*)NULL,d,(PRECISION*)NULL,pElementM(X),RowM(X),ColM(X),1,1,MajorForm(X),1) != NO_ERR)
- {
- dw_Error(BLAS_LAPACK_ERR);
- return 0.0;
- }
- result=d[0];
- free(d);
- return result;
-}
-
-/*
- Assumes
- x : m-vector
- y : m-vector
-
- Results
- returns dot product of x and y.
-
- Notes
- On error returns 0.0. Call GetError() to
- determine the type of error.
-*/
-PRECISION DotProduct(TVector x, TVector y)
-{
- PRECISION result;
- int i;
- if (!x || !y)
- {
- dw_Error(NULL_ERR);
- return 0.0;
- }
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return 0.0;
- }
- dw_ClearError();
- for (result=ElementV(x,0)*ElementV(y,0), i=DimV(x)-1; i > 0; i--) result+=ElementV(x,i)*ElementV(y,i);
- return result;
-}
-
-/*
- Assumes
- x : m-vector
- y : m-vector
- S : m x m matrix
-
- Results
- returns x'*S*y
-
- Notes
- In order for S to be a inner product, S must be positive definite
- and symmetric. A zero return could indicate a error condition.
- Call GetError() to determine if an error has occured.
-*/
-PRECISION InnerProduct(TVector x, TVector y, TMatrix S)
-{
- PRECISION result=0.0, tmp;
- int i, j;
- if (!x || !y || !S)
- {
- dw_Error(NULL_ERR);
- return 0.0;
- }
- if ((DimV(x) != RowM(S)) || (DimV(y) != ColM(S)))
- {
- dw_Error(SIZE_ERR);
- return 0.0;
- }
- dw_ClearError();
- for (i=DimV(x)-1; i >= 0; i--)
- {
- for (tmp=ElementM(S,i,0)*ElementV(y,0), j=DimV(y)-1; j > 0; j--) tmp+=ElementM(S,i,j)*ElementV(y,j);
- result+=ElementV(x,i)*tmp;
- }
- return result;
-}
-
-/*
- Assumes
- X : m x n matrix
- y : m-vector
- z : n-vector
-
- Results
- Returns X = y * z' upon success and a null pointer on failure.
-*/
-TMatrix OuterProduct(TMatrix X, TVector y, TVector z)
-{
- int i, j;
- if (!y || !z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- { if (!(X=CreateMatrix(DimV(y),DimV(z)))) return (TMatrix)NULL; }
- else
- if ((RowM(X) != DimV(y)) || (ColM(X) != DimV(z)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (i=DimV(y)-1; i >= 0; i--)
- for (j=DimV(z)-1; j >= 0; j--)
- ElementM(X,i,j)=ElementV(y,i)*ElementV(z,j);
- return X;
-}
-
-/*
- Assumes
- X : m x m matrix
-
- Results
- Returns the determinate of X upon success. Returns
- 0 upon failure. Call GetError() to determine
- failure.
-
- Notes
- Uses the LU decomposition to compute the determinate.
-*/
-PRECISION Determinant_LU(TMatrix X)
-{
- PRECISION rtrn=0.0, *LU;
- int i, sgn, *p;
- if (!X)
- dw_Error(NULL_ERR);
- else
- if (RowM(X) != ColM(X))
- dw_Error(SIZE_ERR);
- else
- if (!(p=(int*)malloc(RowM(X)*sizeof(int))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(LU=(PRECISION*)malloc(RowM(X)*RowM(X)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(LU,pElementM(X),RowM(X)*RowM(X)*sizeof(PRECISION));
- if (!bLU(p,LU,RowM(X),RowM(X),1))
- {
- for (sgn=1, i=RowM(X)-2; i >= 0; i--)
- if (p[i] != i) sgn=-sgn;
- for (rtrn=0.0, i=RowM(X)*RowM(X)-1; i >= 0; i-=RowM(X)+1)
- if (LU[i] < 0.0)
- {
- rtrn+=log(-LU[i]);
- sgn=-sgn;
- }
- else
- if (LU[i] > 0.0)
- rtrn+=log(LU[i]);
- else
- break;
- rtrn=(i >= 0) ? 0.0 : sgn*exp(rtrn);
- }
- dw_ClearError();
- free(LU);
- }
- free(p);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x m matrix
-
- Results
- Returns the determinate of X upon success. Returns
- 0 upon failure. Call GetError() to determine
- failure.
-
- Notes
- Uses the LU decomposition to compute the determinate.
-*/
-PRECISION LogAbsDeterminant_LU(TMatrix X)
-{
- PRECISION rtrn=0.0, *LU;
- int i, *p;
- if (!X)
- dw_Error(NULL_ERR);
- else
- if (RowM(X) != ColM(X))
- dw_Error(SIZE_ERR);
- else
- if (!(p=(int*)malloc(RowM(X)*sizeof(int))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(LU=(PRECISION*)malloc(RowM(X)*RowM(X)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(LU,pElementM(X),RowM(X)*RowM(X)*sizeof(PRECISION));
- if (!bLU(p,LU,RowM(X),RowM(X),1))
- {
- for (i=RowM(X)*RowM(X)-1; i >= 0; i-=RowM(X)+1)
- if (LU[i] < 0.0)
- rtrn+=log(-LU[i]);
- else
- if (LU[i] > 0.0)
- rtrn+=log(LU[i]);
- else
- {
- rtrn=MINUS_INFINITY;
- break;
- }
- dw_ClearError();
- }
- free(LU);
- }
- free(p);
- }
- return rtrn;
-}
-
-/*
- Assumes
- X : m x m matrix
-
- Results
- Returns the determinate of X upon success. Returns
- 0 upon failure. Call GetError() to determine
- failure.
-
- Notes
- Uses the QR decomposition to compute the determinate.
-*
-PRECISION Determinant_QR(TMatrix X)
-{
- PRECISION rtrn=0.0;
- if (!X)
- dw_Error(NULL_ERR);
- else
- if (RowM(X) != ColM(X))
- dw_Error(SIZE_ERR);
- else
- if (!(R=(PRECISION*)malloc(RowM(X)*RowM(X)*sizeof(PRECISION))))
- dw_Error(MEM_ERR);
- else
- {
- memcpy(R,pElementM(X),RowM(X)*RowM(X)*sizeof(PRECISION));
- if (err=bQR((PRECISION*)NULL,R,RowM(X),RowM(X),0,MajorForm(X)))
- dw_Error(err);
- else
- {
- MATRIX_ERROR=0;
- sgn=(RowM(X) % 2) ? 1 : -1;
- for (rtrn=0.0, i=RowM(X)*RowM(X)-1; i >= 0; i-=RowM(X)+1)
- if (R[i] < 0.0)
- {
- rtrn+=log(-R[i]);
- sgn=-sgn;
- }
- else
- if (R[i] > 0.0)
- rtrn+=log(R[i]);
- else
- {
- free(R);
- return 0.0;
- }
- rtrn=sgn*exp(rtrn);
- }
- free(R);
- }
- return rtrn;
-}
-/**/
-
-/*
- Assumes
- X : m x m matrix
-
- Results
- Returns the trace of X.
-*/
-PRECISION Trace(TMatrix X)
-{
- PRECISION trace=0.0;
- int i;
- if (!X)
- dw_Error(NULL_ERR);
- else
- if (RowM(X) != ColM(X))
- dw_Error(SIZE_ERR);
- else
- for (trace=ElementM(X,0,0), i=RowM(X)-1; i > 0; i--) trace+=ElementM(X,i,i);
- return trace;
-}
-
-/*
- Assumes
- X : m x n matrix
-
- Results
- Returns the rank of X. Return -1 upon error. Use GetMatrixERROR()
- to determine error type.
-
-
- Notes
- Uses the singular value decomposition to compute the rank.
-*/
-int Rank_SVD(TMatrix X)
-{
- PRECISION min;
- int rank=-1, i;
- TMatrix U, V;
- TVector d;
- if (!X)
- dw_Error(NULL_ERR);
- else
- if (!(U=CreateMatrix(RowM(X),ColM(X))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(V=CreateMatrix(ColM(X),ColM(X))))
- dw_Error(MEM_ERR);
- else
- {
- if (!(d=CreateVector(ColM(X))))
- dw_Error(MEM_ERR);
- else
- {
- if (i=SVD(U,d,V,X))
- dw_Error(i);
- else
- {
- for (min=ElementV(d,0), i=DimV(d)-1; i > 0; i--)
- if (ElementV(d,i) > min)
- min=ElementV(d,i);
- /*min*=((RowM(X) < ColM(X)) ? RowM(X) : ColM(X))*MACHINE_EPSILON;*/
- min*=SQRT_MACHINE_EPSILON;
- for (i=(rank=DimV(d))-1; i >= 0; i--)
- if (ElementV(d,i) < min) rank--;
- }
- FreeVector(d);
- }
- FreeMatrix(V);
- }
- FreeMatrix(U);
- }
- return rank;
-}
-
-/*
- Assumes
- x : n-vector or null pointer
- Y : n x (n-1) matrix
-
- Results
- The vector x is set to the cross product of the columns of Y.
-
- Notes
- The cross product of the columns of Y is the vector such that
-
- (1) Y'x = 0
- (2) det([Y x]) >= 0
- (3) norm(x) = volume of the parallelpiped spanned by the columns of Y
-
- Uses the LU decomposition to compute the cross product.
-*/
-
-TVector CrossProduct_LU(TVector x, TMatrix Y)
-{
- int i, j, sgn;
- PRECISION s;
- TMatrix X;
- TPermutation P;
- TVector z=(TVector)NULL;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (RowM(Y) != ColM(Y)+1)
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(z=x=CreateVector(RowM(Y))))
- return (TVector)NULL;
- }
- else
- if (RowM(Y) != DimV(x))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (X=CreateMatrix(RowM(Y),ColM(Y)))
- {
- if (P=CreatePermutation(RowM(Y)))
- {
- if (LU(P,X,Y))
- {
- ElementV(x,RowM(Y)-1)=1.0;
- for (i=RowM(Y)-2; i >= 0; i--)
- {
- ElementV(x,i)=0.0;
- for (j=RowM(Y)-1; j > i; j--)
- ElementV(x,i)-=ElementV(x,j)*ElementM(X,j,i);
- }
- ProductTransposeVP(x,x,P);
- for (sgn=1, i=RowM(X)-2; i >= 0; i--)
- if (ElementP(P,i) != i) sgn=-sgn;
- for (s=0.0, i=RowM(X)-2; i >= 0; i--)
- if (ElementM(X,i,i) < 0.0)
- {
- s+=log(-ElementM(X,i,i));
- sgn=-sgn;
- }
- else
- if (ElementM(X,i,i) > 0.0)
- s+=log(ElementM(X,i,i));
- else
- break;
- s=(i >= 0) ? 0.0 : sgn*exp(s);
- ProductSV(x,s,x);
- }
- else
- {
- FreePermutation(P);
- FreeMatrix(X);
- if (z) FreeVector(z);
- return (TVector)NULL;
- }
- FreePermutation(P);
- }
- FreeMatrix(X);
- }
- return x;
-}
-
-/*
- Assumes
- x : n-vector or null pointer
- Y : n x (n-1) matrix
-
- Results
- The vector x is set to the cross product of the columns of Y.
-
- Notes
- The cross product of the columns of Y is the vector such that
-
- (1) Y'x = 0
- (2) det([Y x]) >= 0
- (3) norm(x) = volume of the parallelpiped spanned by the columns of Y
-
- Uses the QR decomposition to compute the cross product.
-*/
-
-TVector CrossProduct_QR(TVector x, TMatrix Y)
-{
- int i, sgn;
- PRECISION s;
- TMatrix Q, R;
- TVector z=(TVector)NULL;;
-
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (RowM(Y) != ColM(Y)+1)
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(z=x=CreateVector(RowM(Y))))
- return (TVector)NULL;
- }
- else
- if (RowM(Y) != DimV(x))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (Q=CreateMatrix(RowM(Y),RowM(Y)))
- {
- if (R=CreateMatrix(RowM(Y),ColM(Y)))
- {
- if (QR(Q,R,Y))
- {
- sgn=(RowM(Y) % 2) ? 1 : -1;
- for (s=0.0, i=RowM(Y)-2; i >= 0; i--)
- if (ElementM(R,i,i) < 0)
- {
- s+=log(-ElementM(R,i,i));
- sgn=-sgn;
- }
- else
- if (ElementM(R,i,i) > 0)
- s+=log(ElementM(R,i,i));
- else
- break;
- s=(i >= 0) ? 0.0 : sgn*exp(s);
- for (i=RowM(Y)-1; i >= 0; i--)
- ElementV(x,i)=s*ElementM(Q,i,RowM(Y)-1);
- }
- else
- {
- FreeMatrix(R);
- FreeMatrix(Q);
- if (z) FreeVector(z);
- return (TVector)NULL;
- }
- FreeMatrix(R);
- }
- FreeMatrix(Q);
- }
- return x;
-}
-
-/*
- Assumes
- Y : m x n matrix
-
- Returns
- Upon success, the columns of the returned matrix form an orthonormal basis
- for the null space of Y. A null return either indicates the null space is
- {0} or an error condition. Call dw_GetError() to determine if a failure
- occured.
-
- Notes
- Use the singular value decomposition to compute the null space.
-
- If the largest singular value of Y is less than or equal to the square root
- of machine epsilon, then the matrix is assumed to be the zero matrix and
- the null space is all of n-dimensional Euclidean space. For this reason,
- care must be taken with the scale of Y.
-
- A singular value is assumed to be zero if it is smaller than the square root
- of the minimum of m and n times machine epsilon.
-*/
-TMatrix NullSpace(TMatrix Y)
-{
- PRECISION *d, small;
- TMatrix v, null;
- int q, i;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- q=(RowM(Y) < ColM(Y)) ? RowM(Y) : ColM(Y);
- d=(PRECISION*)malloc(q*sizeof(PRECISION));
- v=CreateMatrix(ColM(Y),ColM(Y));
- if (d && v)
- {
- if (bSVD_new((PRECISION*)NULL,d,pElementM(v),pElementM(Y),RowM(Y),ColM(Y),1,MajorForm(v),MajorForm(Y),0) != NO_ERR)
- {
- FreeMatrix(v);
- free(d);
- dw_Error(BLAS_LAPACK_ERR);
- return (TMatrix)NULL;
- }
- dw_ClearError();
- if (d[0] < SQRT_MACHINE_EPSILON)
- {
- free(d);
- return v;
- }
- small=d[0]*SQRT_MACHINE_EPSILON*sqrt(q);
- for (i=q-1; i > 0; i--)
- if (d[i] > small) break;
- null=(++i == ColM(Y)) ? (TMatrix)NULL : SubMatrix((TMatrix)NULL,v,0,i,ColM(Y),ColM(Y)-i);
- FreeMatrix(v);
- free(d);
- return null;
- }
- else
- {
- if (v) FreeMatrix(v);
- if (d) free(d);
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
-}
-
-/*
- Assumes
- X : n x m matrix or null pointer
- Y : m x n matrix
-
- Returns
- The generalized inverse upon success and null upon failure. If X is null,
- then it is created. The generalized inverse of Y is the unique matrix X
- such that
- (a) X*Y*X = X
- (b) Y*X*Y = Y
- (c) X*Y and Y*X are symmetric
-
- Notes
- Use the singular value decomposition to compute the null space.
-
- A singular value is assumed to be zero if it is smaller than the square root
- of the minimum of m and n times machine epsilon.
-*/
-TMatrix GeneralizedInverse(TMatrix X, TMatrix Y)
-{
- PRECISION *d, small, x;
- TMatrix u, v, w, y;
- int q, i, j;
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(ColM(Y),RowM(Y)))) return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != ColM(Y)) || (ColM(X) != RowM(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- q=(RowM(Y) < ColM(Y)) ? RowM(Y) : ColM(Y);
- d=(PRECISION*)malloc(q*sizeof(PRECISION));
- u=CreateMatrix(RowM(Y),q);
- v=CreateMatrix(ColM(Y),q);
- if (d && u && v)
- {
- if (bSVD_new(pElementM(u),d,pElementM(v),pElementM(Y),RowM(Y),ColM(Y),MajorForm(u),MajorForm(v),MajorForm(Y),1) != NO_ERR)
- {
- FreeMatrix(v);
- FreeMatrix(u);
- free(d);
- dw_Error(BLAS_LAPACK_ERR);
- return (TMatrix)NULL;
- }
-
- small=d[0]*SQRT_MACHINE_EPSILON*sqrt(q);
- for (i=q-1; i > 0; i--)
- if (d[i] > small) break;
- i++;
- w=CreateMatrix(RowM(Y),i);
- for (j=ColM(w)-1; j >= 0; j--)
- for (x=1.0/d[j], i=RowM(w)-1; i >= 0; i--)
- ElementM(w,i,j)=x*ElementM(u,i,j);
-
- y=(ColM(w) == q) ? v : SubMatrix((TMatrix)NULL,v,0,0,RowM(Y),ColM(w));
- ProductTransposeMM(X,y,w);
-
- if (y != v) FreeMatrix(y);
- FreeMatrix(w);
- FreeMatrix(u);
- FreeMatrix(v);
- free(d);
-
- return X;
- }
- else
- {
- if (v) FreeMatrix(v);
- if (u) FreeMatrix(u);
- if (d) free(d);
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
-}
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/***************************** Kronecker Routines ******************************/
-/*******************************************************************************/
-TVector Vec(TVector x, TMatrix Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(RowM(Y)*ColM(Y))))
- return (TVector)NULL;
- }
- else
- if (RowM(Y)*ColM(Y) != DimV(x))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (MajorForm(Y))
- memcpy(pElementV(x),pElementM(Y),RowM(Y)*ColM(Y)*sizeof(PRECISION));
- else
- bTranspose(pElementV(x),pElementM(Y),RowM(Y),ColM(Y),0);
- return x;
-}
-
-TMatrix KroneckerProduct(TMatrix X, TMatrix Y, TMatrix Z)
-{
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(Y)*RowM(Z),ColM(Y)*ColM(Z))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(Y)*RowM(Z) != RowM(X)) || (ColM(Y)*ColM(Z) != ColM(X)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (X == Y)
- bMultiply(pElementM(X),pElementM(X),*pElementM(Z),RowM(X)*ColM(X));
- else
- if (X == Z)
- bMultiply(pElementM(X),pElementM(X),*pElementM(Y),RowM(X)*ColM(X));
- else
- bMatrixTensor(pElementM(X),pElementM(Y),pElementM(Z),RowM(Y),ColM(Y),RowM(Z),ColM(Z),MajorForm(X),MajorForm(Y),MajorForm(Z));
-/* for (i=RowM(Y)-1, u=i*RowM(Z); i >= 0; u-=RowM(Z), i--) */
-/* for (j=ColM(Y)-1, v=j*ColM(Z); j >= 0; v-=ColM(Z), j--) */
-/* { */
-/* tmp=ElementM(Y,i,j); */
-/* for (r=RowM(Z)-1; r >= 0; r--) */
-/* for (s=ColM(Z)-1; s >= 0; s--) */
-/* ElementM(X,u+r,v+s)=tmp*ElementM(Z,r,s); */
-/* } */
- return X;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/****************************** Output Routines ********************************/
-/*******************************************************************************/
-/*
- Assumes
- x : m-vector
-
- Returns
- One upon success and zero otherwise.
-
- Results
- Prints x to f using format.
-
- Notes
- If format is the NULL pointer, uses default formating. The elements of x
- are output as double independently of the setting of PRECISION. Currently,
- the function does not check for failure.
-*/
-int dw_PrintVector(FILE *f, TVector x, char *format)
-{
- int i, m;
- if (!x) return 0;
- m=DimV(x);
- if (!format) format="%7.3lf\t";
- for (i=0; i < m; i++) fprintf(f,format,(double)(ElementV(x,i)));
- fprintf(f,"\n");
- return 1;
-}
-
-/*
- Assumes
- X : m x n matrix
-
- Returns
- One upon success and zero otherwise.
-
- Results
- Prints X to f using format.
-
- Notes
- If format is the NULL pointer, uses default formating. The elements of X
- are output as double independently of the setting of PRECISION.
-*/
-int dw_PrintMatrix(FILE *f, TMatrix X, char *format)
-{
- int i, j, m, n;
- if (!X) return 0;
- m=RowM(X); n=ColM(X);
- if (!format) format="%7.3lf\t";
- for (i=0; i < m; i++)
- {
- for (j=0; j < n; j++) fprintf(f,format,(double)(ElementM(X,i,j)));
- fprintf(f,"\n");
- }
- return 1;
-}
-
-/*
- Assumes
- x : m vector
- f : an pointer to an open file
-
- Results
- Reads in vector x from f. Return 1 on success, 0 otherwise.
-*/
-int dw_ReadVector(FILE *f, TVector x)
-{
- int i, m;
- PRECISION *px;
- if (!x) return 0;
- for (px=pElementV(x), i=0, m=DimV(x); i < m; i++)
-#if (PRECISION_SIZE == 8)
- if (fscanf(f," %lf ",px+i) != 1) return 0;
-#else
- if (fscanf(f," %f ",px+i) != 1) return 0;
-#endif
- return 1;
-}
-
-/*
- Assumes
- X : m x n matrix
- f : an pointer to an open file
-
- Results
- Reads in matrix X from f. Return 1 on success, 0 otherwise.
-*/
-int dw_ReadMatrix(FILE *f, TMatrix X)
-{
- int i, j, m, n;
- if (!X) return 0;
- m=RowM(X); n=ColM(X);
- for (i=0; i < m; i++)
- for (j=0; j < n; j++)
-#if (PRECISION_SIZE == 8)
- if (fscanf(f," %lf ",&ElementM(X,i,j)) != 1) return 0;
-#else
- if (fscanf(f," %f ",&Element(X,i,j))) != 1) return 0;
-#endif
- return 1;
-}
-
-/*
- Assumes
- f : pointer to open binary file
- x : m matrix
-
- Results
- Outputs x in binary format.
-
- Returns
- 1 upon success, 0 upon failure
-
- Notes
- Format
- int
- 0x1004 - vector float
- 0x2004 - matrix float
- 0x1008 - vector double
- 0x2008 - mattrix double
-
- int rows if matrix, dimension if vector
- int columns if matrix, absent if vector
- data m binary floating point numbers
-
-*/
-int OutVectorFloat(FILE *f, TVector x)
-{
- float y;
- int i, format_code=0x1000+sizeof(float);
- if (!x) return 0;
- if (fwrite(&format_code,sizeof(int),1,f) != 1) return 0;
- if (fwrite(&DimV(x),sizeof(int),1,f) != 1) return 0;
-#if (PRECISION_SIZE == 8)
- for (i=DimV(x)-1; i >= 0; i--)
- {
- y=(float)ElementV(x,i);
- if (fwrite(&y,sizeof(float),1,f) != 1) return 0;
- }
-#else
- if (fwrite(pElementV(x),DimV(x)*sizeof(float),1,f) != 1) return 0;
-#endif
- return 1;
-}
-
-/*
- Assumes
- f : pointer to open binary file
- x : m matrix
-
- Results
- Outputs x in binary format. Returns 1 on success and 0 otherwise.
-
- Notes
- Format
- int
- 0x1004 - vector float
- 0x2004 - matrix float
- 0x1008 - vector double
- 0x2008 - mattrix double
-
- int rows if matrix, dimension if vector
- int columns if matrix, absent if vector
- data m binary floating point numbers
-
-*/
-int OutVectorDouble(FILE *f, TVector x)
-{
- double y;
- int i, format_code=0x1000+sizeof(double);
- if (!x) return 0;
- if (fwrite(&format_code,sizeof(int),1,f) == 1) return 0;
- if (fwrite(&DimV(x),sizeof(int),1,f) != 1) return 0;
-#if (PRECISION_SIZE == 8)
- for (i=DimV(x)-1; i >= 0; i--)
- {
- y=(double)ElementV(x,i);
- if (fwrite(&y,sizeof(double),1,f) != 1) return 0;
- }
-#else
- if (fwrite(pElementV(x),DimV(x)*sizeof(double),1,f) != 1) return 0;
-#endif
- return 1;
-}
-
-
-/*
- Assumes
- f : pointer to open binary file
- X : m x n matrix
-
- Results
- Outputs X in binary format. Returns 1 on success and 0 otherwise.
-
- Notes
- Format
- int
- 0x1004 - vector float
- 0x2004 - matrix float
- 0x1008 - vector double
- 0x2008 - mattrix double
-
- int rows if matrix, dimension if vector
- int columns if matrix, absent if vector
- data m x n binary floating point numbers
-*/
-int OutMatrixFloat(FILE *f, TMatrix X)
-{
- float y;
- int i, j, format_code=0x2000+sizeof(float);
- if (!X) return 0;
- if (fwrite(&format_code,sizeof(int),1,f) != 1) return 0;
- if (fwrite(&RowM(X),sizeof(int),2,f) != 1) return 0;
- if (fwrite(&ColM(X),sizeof(int),1,f) != 1) return 0;
-#if (PRECISION_SIZE == 8)
- for (j=ColM(X)-1; j >= 0; j--)
- for (i=RowM(X)-1; i >= 0; i--)
- {
- y=(float)ElementM(X,i,j);
- if (fwrite(&y,sizeof(float),1,f) != 1) return 0;
- }
-#else
- if (fwrite(pElementM(X),RowM(X)*ColM(X)*sizeof(float),1,f) != 1) return 0;
-#endif
- return 1;
-}
-
-/*
- Assumes
- f : pointer to open binary file
- X : m x n matrix
-
- Results
- Outputs X in binary format. Returns 1 on success and 0 otherwise.
-
- Notes
- Format
- int
- 0x1004 - vector float
- 0x2004 - matrix float
- 0x1008 - vector double
- 0x2008 - mattrix double
-
- int rows if matrix, dimension if vector
- int columns if matrix, absent if vector
- data m x n binary floating point numbers
-*/
-int OutMatrixDouble(FILE *f, TMatrix X)
-{
- double y;
- int i, j, format_code=0x2000+sizeof(double);
- if (!X) return 0;
- if (fwrite(&format_code,sizeof(int),1,f) != 1) return 0;
- if (fwrite(&RowM(X),sizeof(int),2,f) != 1) return 0;
- if (fwrite(&ColM(X),sizeof(int),1,f) != 1) return 0;
-#if (PRECISION_SIZE == 8)
- if (fwrite(((int *)X)-2,sizeof(int),2,f) != 2) return 0;
- for (j=ColM(X)-1; j >= 0; j--)
- for (i=RowM(X)-1; i >= 0; i--)
- {
- y=ElementM(X,i,j);
- if (fwrite(&y,sizeof(double),1,f) != 1) return 0;
- }
-#else
- if (fwrite(pElementM(X),RowM(X)*ColM(X)*sizeof(double),1,f) != 1) return 0;
-#endif
- return 1;
-}
-
-
-/*
- Assumes
- f : pointer to open binary file
- x : m matrix or null pointer
-
- Results
- Reads x from binary format. Returns 1 on success and 0 otherwise.
-
- Notes
- Format
- int
- 0x1004 - vector float
- 0x2004 - matrix float
- 0x1008 - vector double
- 0x2008 - mattrix double
-
- int number rows if matrix, dimension if vector
- int number columns if matrix, absent if vector
- data m binary floating point numbers
-*/
-TVector InVector(FILE *f, TVector x)
-{
- int i, d[2], precision, del=0, position=ftell(f);
- void *y=(void*)NULL;
-
- if (fread(d,sizeof(int),2,f) != 2) goto EXIT_ERROR;
-
- switch(d[0])
- {
- case 0x1000+sizeof(float): precision=sizeof(float); break;
- case 0x1000+sizeof(double): precision=sizeof(double); break;
- default: goto EXIT_ERROR;
- }
-
- i=d[1];
-
- if (!x)
- {
- x=CreateVector(i);
- del=1;
- }
- else
- if (DimV(x) != i) goto EXIT_ERROR;
-
- if (precision != sizeof(PRECISION))
- {
- if (!(y=malloc(i*precision))) dw_Error(MEM_ERR);
- if (fread(y,i*precision,1,f) != 1) goto EXIT_ERROR;
- if (precision == sizeof(float))
- while (--i >= 0) ElementV(x,i)=((float*)y)[i];
- else
- while (--i >= 0) ElementV(x,i)=((double*)y)[i];
- free(y);
- }
- else
- if (fread(pElementV(x),i*sizeof(PRECISION),1,f) != 1) goto EXIT_ERROR;
-
- return x;
-
-EXIT_ERROR:
- fseek(f,position,SEEK_SET);
- if (del) FreeVector(x);
- if (y) free(y);
- return (TVector)NULL;
-}
-
-/*
- Assumes
- f : pointer to open binary file
- X : m x n matrix or null pointer
-
- Results
- Reads x from binary format. Returns 1 on success and 0 otherwise.
-
- Notes
- Format
- int
- 0x1004 - vector float
- 0x2004 - matrix float
- 0x1008 - vector double
- 0x2008 - mattrix double
-
- int number rows if matrix, dimension if vector
- int number columns if matrix, absent if vector
- data m x n binary floating point numbers
-*/
-TMatrix InMatrix(FILE *f, TMatrix X)
-{
- int i, d[3], precision, del=0, position=ftell(f);
- void *Y=(void*)NULL;
-
- if (fread(d,sizeof(int),3,f) != 3) goto EXIT_ERROR;
-
- switch(d[0])
- {
- case 0x2000+sizeof(float): precision=sizeof(float); break;
- case 0x2000+sizeof(double): precision=sizeof(double); break;
- default: goto EXIT_ERROR;
- }
-
- if (!X)
- {
- X=CreateMatrix(d[1],d[2]);
- del=1;
- }
- else
- if ((RowM(X) != d[1]) || (ColM(X) != d[2])) goto EXIT_ERROR;
-
- i=d[1]*d[2];
-
- if (precision != sizeof(PRECISION))
- {
- if (!(Y=malloc(i*precision))) dw_Error(MEM_ERR);
- if (fread(Y,i*precision,1,f) != 1) goto EXIT_ERROR;
- if (precision == sizeof(float))
- while (--i >= 0) pElementM(X)[i]=((float*)Y)[i];
- else
- while (--i >= 0) pElementM(X)[i]=((double*)Y)[i];
- free(Y);
- }
- else
- if (fread(pElementM(X),i*sizeof(PRECISION),1,f) != 1) goto EXIT_ERROR;
-
- return X;
-
-EXIT_ERROR:
- fseek(f,position,SEEK_SET);
- if (del) FreeMatrix(X);
- if (Y) free(Y);
- return (TMatrix)NULL;
-}
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*******************************************************************************/
-/*************************** Matrix Decompositions *****************************/
-/*******************************************************************************/
-/* /\* */
-/* Assumes */
-/* U : m x m matrix */
-/* d : min(m,n)-vector */
-/* V : n x n matrix */
-/* A : m x n matrix */
-
-/* Returns */
-/* 1 upon success, and 0 on failure. */
-
-/* Results */
-/* Finds U, V and d such that A = U * diag(d) * V'. U and V are orthogonal */
-/* matrices and the elemets of d are non-negative. Here, diag(d) denotes is */
-/* a m x n diagonal matrix with the elements of d along the diagonal. */
-/* *\/ */
-/* int SVD(TMatrix U, TVector d, TMatrix V, TMatrix A) */
-/* { */
-/* int err; */
-/* if (!U || !d || !V || !A) */
-/* { */
-/* dw_Error(NULL_ERR); */
-/* return 0; */
-/* } */
-/* if ((RowM(U) != RowM(A)) || (ColM(U) != RowM(A)) */
-/* || (RowM(V) != ColM(A)) || (ColM(V) != ColM(A)) */
-/* || (DimV(d) != ((RowM(A) < ColM(A)) ? RowM(A) : ColM(A)))) */
-/* { */
-/* dw_Error(SIZE_ERR); */
-/* return 0; */
-/* } */
-/* if (U == V) */
-/* { */
-/* dw_Error(ARG_ERR); */
-/* return 0; */
-/* } */
-/* if (err=bSVD(pElementM(U),pElementV(d),pElementM(V),pElementM(A),RowM(A),ColM(A),MajorForm(U),MajorForm(V),MajorForm(A))) */
-/* { */
-/* dw_Error(err); */
-/* return 0; */
-/* } */
-/* return 1; */
-/* } */
-
-/*
- Assumes
- U : m x qu matrix where qu is either m or min(m,n)
- d : min(m,n)-vector
- V : n x qv matrix where qv is either n or min(m,n)
- A : m x n matrix
-
- Returns
- 1 upon success, and 0 on failure.
-
- Results
- Finds U, V and d such that A = U * diag(d) * V'. The matrices U and V have
- orthonormal columns and the elemets of d are non-negative. Here, diag(d)
- denotes is the qu x qv diagonal matrix with the elements of d along the
- diagonal. The elements of d are non-negative and in descending order.
-*/
-int SVD(TMatrix U, TVector d, TMatrix V, TMatrix A)
-{
- int err, compact=1;
- if (!d || !A)
- {
- dw_Error(NULL_ERR);
- return 0;
- }
- if ((DimV(d) != ((RowM(A) < ColM(A)) ? RowM(A) : ColM(A))))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- if (U)
- {
- if (U == V)
- {
- dw_Error(ARG_ERR);
- return 0;
- }
- if (RowM(U) != RowM(A))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- if (ColM(U) != DimV(d))
- {
- compact=0;
- if (ColM(U) != RowM(U))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- }
- }
- if (V)
- {
- if (RowM(V) != ColM(A))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- if (ColM(V) != DimV(d))
- {
- compact=0;
- if (ColM(V) != RowM(V))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- }
- }
-
- if (err=bSVD_new(U ? pElementM(U) : (PRECISION*)NULL,pElementV(d),V ? pElementM(V) : (PRECISION*)NULL,
- pElementM(A),RowM(A),ColM(A),U ? MajorForm(U) : 1,V ? MajorForm(V) : 1,MajorForm(A),compact))
- {
- dw_Error(err);
- return 0;
- }
- return 1;
-}
-
-/*
- Assumes
- S : n x n matrix
- T : n x n matrix
- Q : n x n matrix or null pointer
- Z : n x n matrix or null pointer
- A : n x n matrix
- B : n x n matrix
- alpha_r : n vector or null pointer
- alpha_i : n vector or null pointer
- beta : n vector or null pointer
-
- Returns
- 1 upon success, and 0 on failure.
-
- Results
- Finds orthogonal matrices Q and Z, an block upper triangular matrix S with
- 1 x 1 or 2 x 2 blocks along the diagonal, and an upper triangular matrix T
- such that
-
- A = Q*S*Z' and B = Q*T*Z'
-
- the vectors alpha_r, alpha_i, and beta contain the generalized eigenvalues
- of A and B. alpha_r contains the real part of alpha and alpha_i contains
- the imginary part.
-
- If Q, Z, alpha_r, alpha_i, or beta is null, then it is not returned.
-
- Notes
- The generalized eigenvalue is (alpha_r + i*alpha_i)/beta, but because beta
- can be zero, alpha and beta are returned separately. The matrix A can be
- equal to the matrix B, but all other matrices should be distinct.
-*/
-int QZ_Real(TMatrix S, TMatrix T, TMatrix Q, TMatrix Z, TMatrix A, TMatrix B, TVector alpha_r, TVector alpha_i, TVector beta)
-{
- int n, err;
- if (!S || !T || !A || !B)
- {
- dw_Error(NULL_ERR);
- return 0;
- }
- n=RowM(A);
- if ((ColM(A) != n) || (RowM(S) != n) || (ColM(S) != n) || (RowM(T) != n) || (ColM(T) != n) || (RowM(B) != n) || (ColM(B) != n)
- || (Q && ((RowM(Q) != n) || (ColM(Q) != n))) || (Z && ((RowM(Z) != n) || (ColM(Z) != n))) || (alpha_r && (DimV(alpha_r) != n))
- || (alpha_i && (DimV(alpha_i) != n)) || (beta && (DimV(beta) != n)))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
-
- err=bQZ_real(Q ? pElementM(Q) : (PRECISION*)NULL,Z ? pElementM(Z) : (PRECISION*)NULL,pElementM(S),pElementM(T),pElementM(A),pElementM(B),n,
- Q ? MajorForm(Q) : 1,Z ? MajorForm(Z) : 1,MajorForm(S),MajorForm(T),MajorForm(A),MajorForm(B),
- alpha_r ? pElementV(alpha_r) : (PRECISION*)NULL,alpha_i ? pElementV(alpha_i) : (PRECISION*)NULL,beta ? pElementV(beta) : (PRECISION*)NULL);
-
- if (err == NO_ERR)
- return 1;
- else
- {
- dw_Error(err);
- return 0;
- }
-}
-
-/*
- Assumes
- select : array of length n
- QQ : n x n matrix or null
- ZZ : n x n matrix or null
- SS : n x n matrix
- TT : n x n matrix
- Q : n x n matrix or null. Q is orthogonal if it is not null.
- Z : n x n matrix or null. Z is orghogonal if it is not null.
- S : n x n matrix. S is block upper triangular with 1x1 or 2x2 blocks
- along the diagonal.
- T : n x n matrix. T is block upper triangular with positive diagonal.
- alpha_i : array of length n or null
- alpha_i : array of length n or null
- beta : array of length n or null
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- BLAS_LAPACK_ERR : blas or lapack error
-
- Results
- Finds orthogonal matrices QQ and ZZ, an block upper triangular matrix SS
- with 1 x 1 or 2 x 2 blocks along the diagonal, an upper triangular matrix TT
- such that
-
- Q*S*Z' = QQ*SS*ZZ' and Q*T*Z' = QQ*TT*ZZ'
-
- If either Q or QQ are null, then QQ is not computed and if either Z or ZZ is
- null, then ZZ is not computed. The generalized eigenvalues of S and T
- corresponding to the elements of select that are equal to one are
- transformed to the first block of SS and TT.
-
- Notes
- Q, Z, S, and T should be the results of a call to QZ_Real(), SortQZ_Real(),
- or ReorderQZ_Real().
-*/
-int ReorderQZ_Real(TMatrix SS, TMatrix TT, TMatrix QQ, TMatrix ZZ, TMatrix S, TMatrix T, TMatrix Q, TMatrix Z, int *select, TVector alpha_r, TVector alpha_i, TVector beta)
-{
- int n, err;
- if (!SS || !TT || !S || !T)
- {
- dw_Error(NULL_ERR);
- return 0;
- }
- n=RowM(S);
- if ((ColM(S) != n) || (RowM(SS) != n) || (ColM(SS) != n) || (RowM(TT) != n) || (ColM(TT) != n) || (RowM(T) != n) || (ColM(T) != n)
- || (QQ && ((RowM(QQ) != n) || (ColM(QQ) != n))) || (ZZ && ((RowM(ZZ) != n) || (ColM(ZZ) != n)))
- || (Q && ((RowM(Q) != n) || (ColM(Q) != n))) || (Z && ((RowM(Z) != n) || (ColM(Z) != n)))
- || (alpha_r && (DimV(alpha_r) != n)) || (alpha_i && (DimV(alpha_i) != n)) || (beta && (DimV(beta) != n)))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
-
- err=bReorderQZ_real(select,QQ ? pElementM(QQ) : (PRECISION*)NULL,ZZ ? pElementM(ZZ) : (PRECISION*)NULL,pElementM(SS),pElementM(TT),
- Q ? pElementM(Q) : (PRECISION*)NULL,Z ? pElementM(Z) : (PRECISION*)NULL,pElementM(S),pElementM(T),n,
- QQ ? MajorForm(QQ) : 1,ZZ ? MajorForm(ZZ) : 1,MajorForm(SS),MajorForm(TT),Q ? MajorForm(Q) : 1,Z ? MajorForm(Z) : 1,MajorForm(S),MajorForm(T),
- alpha_r ? pElementV(alpha_r) : (PRECISION*)NULL,alpha_i ? pElementV(alpha_i) : (PRECISION*)NULL,beta ? pElementV(beta) : (PRECISION*)NULL);
-
- if (err == NO_ERR)
- return 1;
- else
- {
- dw_Error(err);
- return 0;
- }
-}
-
-/*
- Assumes
- QQ : n x n matrix or null
- ZZ : n x n matrix or null
- SS : n x n matrix
- TT : n x n matrix
- Q : n x n matrix or null. Q is orthogonal if it is not null.
- Z : n x n matrix or null. Z is orghogonal if it is not null.
- S : n x n matrix. S is block upper triangular with 1x1 or 2x2 blocks
- along the diagonal.
- T : n x n matrix. T is block upper triangular with positive diagonal.
- alpha_r : array of length n
- alpha_i : array of length n
- beta : array of length n
-
- Returns
- NO_ERR : success
- MEM_ERR : out of memory
- BLAS_LAPACK_ERR : blas or lapack error
-
- Results
- Finds orthogonal matrices QQ and ZZ, an block upper triangular matrix SS
- with 1 x 1 or 2 x 2 blocks along the diagonal, an upper triangular matrix TT
- such that
-
- Q*S*Z' = QQ*SS*ZZ' and Q*T*Z' = QQ*TT*ZZ'
-
- If either Q or QQ are null, then QQ is not computed and if either Z or ZZ is
- null, then ZZ is not computed. The matrices S and T are multiplied by
- orthogonal matrices in such a manner that their block triangular structure
- retained and the generalized eigenvalues corresponding to value of select
- equal to one are transformed to the upper part of SS and TT.
-
- Notes
- Q, Z, S, T, alpha_r, alpha_i, and beta should be the results of a call to
- QZ_Real() or ReorderQZ_Real().
-*/
-/* int SortQZ_Real(TMatrix SS, TMatrix TT, TMatrix QQ, TMatrix ZZ, TMatrix S, TMatrix T, TMatrix Q, TMatrix Z, TVector alpha_r, TVector alpha_i, TVector beta) */
-/* { */
-/* int n, err; */
-/* if (!SS || !TT || !S || !T) */
-/* { */
-/* dw_Error(NULL_ERR); */
-/* return 0; */
-/* } */
-/* n=RowM(S); */
-/* if ((ColM(S) != n) || (RowM(SS) != n) || (ColM(SS) != n) || (RowM(TT) != n) || (ColM(TT) != n) || (RowM(T) != n) || (ColM(T) != n) */
-/* || (QQ && ((RowM(QQ) != n) || (ColM(QQ) != n))) || (ZZ && ((RowM(ZZ) != n) || (ColM(ZZ) != n))) */
-/* || (Q && ((RowM(Q) != n) || (ColM(Q) != n))) || (Z && ((RowM(Z) != n) || (ColM(Z) != n))) */
-/* || (alpha_r && (DimV(alpha_r) != n)) || (alpha_i && (DimV(alpha_i) != n)) || (beta && (DimV(beta) != n))) */
-/* { */
-/* dw_Error(SIZE_ERR); */
-/* return 0; */
-/* } */
-
-/* err=bSortQZ_real(select,QQ ? pElementM(QQ) : (PRECISION*)NULL,ZZ ? pElementM(ZZ) : (PRECISION*)NULL,pElementM(SS),pElementM(TT), */
-/* Q ? pElementM(Q) : (PRECISION*)NULL,Z ? pElementM(Z) : (PRECISION*)NULL,pElementM(S),pElementM(T),n, */
-/* QQ ? MajorForm(QQ) : 1,ZZ ? MajorForm(ZZ) : 1,MajorForm(SS),MajorForm(TT),Q ? MajorForm(Q) : 1,Z ? MajorForm(Z) : 1,MajorForm(S),MajorForm(T), */
-/* alpha_r ? pElementV(alpha_r) : (PRECISION*)NULL,alpha_i ? pElementV(alpha_i) : (PRECISION*)NULL,beta ? pElementV(beta) : (PRECISION*)NULL); */
-
-/* if (err == NO_ERR) */
-/* return 1; */
-/* else */
-/* { */
-/* dw_Error(err); */
-/* return 0; */
-/* } */
-/* } */
-
-
-/*
- Assumes
- U : m x m matrix or null pointer
- X : m x m symmetric positive definite matrix
-
- Results
- X = U' * U, where U is a upper triangular matrix with positive diagonal.
-
- Returns
- The matrix U is returned upon success and a null pointer is return upon
- failure. It the matrix U is null, it is created.
-
- Notes
- Failure usually indicates X is not positive definite. Only the upper
- half of X is used. The matrices U and X need not be distinct.
-*/
-TMatrix CholeskyUT(TMatrix U, TMatrix X)
-{
- int err;
- if (!X)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (RowM(X) != ColM(X))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!U)
- {
- if (!(U=EquateMatrix((TMatrix)NULL,X)))
- return (TMatrix)NULL;
- if (err=bCholesky(pElementM(U),RowM(X),1,MajorForm(U)))
- {
- FreeMatrix(U);
- dw_Error(err);
- return (TMatrix)NULL;
- }
- }
- else
- {
- if (U != X)
- {
- if ((RowM(X) != RowM(U)) || (RowM(X) != ColM(U)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- memcpy(pElementM(U),pElementM(X),RowM(X)*RowM(X)*sizeof(PRECISION));
- }
- if (err=bCholesky(pElementM(U),RowM(X),1,MajorForm(U)))
- {
- dw_Error(err);
- return (TMatrix)NULL;
- }
- }
- return U;
-}
-
-/*
- Assumes
- L : m x m matrix
- X : m x m symmetric positive definite matrix
-
- Results
- X = L' * L, where L is a lower triangular matrix with positive diagonal.
-
- Returns
- 1 success
- 0 failure, call GetError() to
-
- Notes
- Failure usually indicates X is not positive definite. Only the upper
- half of X is used. The matrices L and X need not be distinct.
-*/
-TMatrix CholeskyLT(TMatrix L, TMatrix X)
-{
- int err;
- if (!X)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (RowM(X) != ColM(X))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!L)
- {
- if (!(L=EquateMatrix((TMatrix)NULL,X)))
- return (TMatrix)NULL;
- if (err=bCholesky(pElementM(L),RowM(X),0,MajorForm(L)))
- {
- FreeMatrix(L);
- dw_Error(err);
- return (TMatrix)NULL;
- }
- }
- else
- {
- if (L != X)
- {
- if ((RowM(X) != RowM(L)) || (RowM(X) != ColM(L)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- memcpy(pElementM(L),pElementM(X),RowM(X)*RowM(X)*sizeof(PRECISION));
- }
- if (err=bCholesky(pElementM(L),RowM(X),0,MajorForm(L)))
- {
- dw_Error(err);
- return (TMatrix)NULL;
- }
- }
- return L;
-}
-
-/*
- Assumes
- Q : m x q matrix or null pointer
- R : q x n matrix
- X : m x n matrix
-
- Results
- Finds an orthogonal matrix Q and an upper triangular matrix R such that
-
- X = Q * R
-
- Not necessaraly true -- When using bmatrix.c, det(Q) = (-1)^s, where s=min(m-1,n).
-
- Returns
- 1 - Success
- 0 - Error, call GetError() to determine the type of error made.
-
- Notes
- The integer q must be equal to either m or the minimum of m and n. The
- matrices R and X do not have to be distinct. The QR decomposition is
- formed using Householder matrices without pivoting.
-*/
-int QR(TMatrix Q, TMatrix R, TMatrix X)
-{
- int err;
- PRECISION *ptr;
- if (!R || !X)
- {
- dw_Error(NULL_ERR);
- return 0;
- }
- if (R != X)
- if (ColM(R) != ColM(X))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- else
- if (RowM(R) == RowM(X))
- {
- EquateMatrix(R,X);
- ptr=pElementM(R);
- }
- else
- if ((RowM(R) == ColM(X)) && (ColM(X) < RowM(X)))
- if (!(ptr=(PRECISION*)malloc(RowM(X)*ColM(X)*sizeof(PRECISION))))
- {
- dw_Error(MEM_ERR);
- return 0;
- }
- else
- memcpy(ptr,pElementM(X),RowM(X)*ColM(X)*sizeof(PRECISION));
- else
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- else
- ptr=pElementM(R);
- if (!Q)
- err=bQR((PRECISION*)NULL,pElementM(R),ptr,RowM(X),ColM(X),RowM(R),0,MajorForm(R),MajorForm(X));
- else
- if (Q == R)
- {
- dw_Error(ARG_ERR);
- return 0;
- }
- else
- if ((RowM(Q) != RowM(X)) || (ColM(Q) != RowM(R)))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- else
- err=bQR(pElementM(Q),pElementM(R),ptr,RowM(X),ColM(X),RowM(R),MajorForm(Q),MajorForm(R),MajorForm(X));
- if (ptr != pElementM(R)) free(ptr);
- if (!err) return 1;
- dw_Error(err);
- return 0;
-}
-
-/*
- Assumes
- P : m x m permutation matrix
- X : m x n matrix
- A : m x n matrix invertible matrix
-
- Results
- Computes the LU decomposition of A with partial pivoting. The
- decomposition is
-
- A = P * L * U
-
- where P is a permutation matrix, L is lower triangular with ones along
- the diagonal, and U is upper triangular. These matrices are stored as
- follows.
-
- L is m x k, where k is the smaller of n and m, and is stored in the
- lower half of LU. The diagonal of L is not stored.
-
- U is k x n, where k is the smaller of n and m, and is stored in the
- upper half of X, including the diagonal.
-
- P is the integer representation of a permutation matrix. See the
- header file matrix.h for a description of its internal
- reqresentation.
-
-
- Returns
- 1 : success
- 0 : failure, call GetError() to determine the cause.
-
- Notes
- The matrices X and A do not have to be distinct. Uses partial pivoting.
-*/
-int LU(TPermutation P, TMatrix X, TMatrix A)
-{
- if (!P || !X || !A)
- {
- dw_Error(NULL_ERR);
- return 0;
- }
- if (DimP(P) != RowM(A))
- {
- dw_Error(SIZE_ERR);
- return 0;
- }
- if ((X != A) && !EquateMatrix(X,A)) return 0;
- bLU(pElementP(P),pElementM(X),RowM(X),ColM(X),MajorForm(X));
- UseP(P)=(RowM(X) < ColM(X)) ? RowM(X) : ColM(X);
- return 1;
-}
-
-/*
- Assumes
- x : n vector
- y : n vector
- LU : n x n matrix with non-zero diagonal
- p : integer array of length n with i <= p[i] < n for 0 <= i < n.
-
- Results
- Solves P * L * U * x = y, where P is a permutation matrix, L is lower
- triangular with ones along the diagonal, and U is upper triangular.
-
- Notes
- The vectors x and y do not have to be distinct. The integer array p
- must represent a permutation.
-
- The matrices P, L, and U are stored as follows.
-
- U is stored in the upper half of LU, including the diagonal.
-
- L is stored in the lower half of LU. The diagonal of L is not stored.
-
- The matrix P is defined by P*e(i)=e(p[i]), where e(j) is the jth column
- of the n x n identity matrix. See the notes in matrix.h for further
- details on permutation matrices.
-*/
-TVector LU_SolveColM(TVector x, TVector y, TMatrix LU, TPermutation P)
-{
- TVector z=x;
-
- if (!y || !LU || !P)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if ((DimV(y) != RowM(LU)) || (DimV(y) != ColM(LU)))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if (!x)
- {
- if (!(x=CreateVector(DimV(y)))) return (TVector)NULL;
- }
- else
- if (DimV(x) != DimV(y))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
-
- if (x != y) memcpy(x,y,DimV(y)*sizeof(int));
- if (!bPermutationMultiply(pElementP(P),pElementV(x),DimV(y),1,UseP(P),1,1) &&
- !bSolveUnitTriangular(pElementM(LU),pElementV(x),DimV(x),1,0,MajorForm(LU),1) &&
- !bSolveTriangular(pElementM(LU),pElementV(x),DimV(x),1,1,MajorForm(LU),1)) return x;
- if (!z) FreeVector(x);
- return (TVector)x;
-}
-
-/*
- Assumes
- x : n vector
- y : n vector
- LU : n x n matrix with non-zero diagonal
- permute : integer array of length n
-
- Results
- Solves x * P * L * U = y, where P is a permutation matrix, L is lower
- triangular with ones along the diagonal, and U is upper triangular.
-
- Notes
- The vectors x and y do not have to be distinct. The integer array permute
- must be of length at least n.
-
- The matrices P, L, and U are stored as follows.
-
- U is stored in the upper half of LU, including the diagonal.
-
- L is stored in the lower half of LU. The diagonal of L is not stored.
-
- The matrix P is defined by P*e(i)=e(p[i]), where e(j) is the jth column
- of the n x n identity matrix. See the notes in matrix.h for further
- details on permutation matrices.
-*/
-TVector LU_SolveRowM(TVector x, TVector y, TMatrix LU, TPermutation P)
-{
- int i, j;
- PRECISION *z, sum;
-
- if (!y || !LU || !P)
- { dw_Error(NULL_ERR); return (TVector)NULL; }
-
- if (!x)
- x=CreateVector(DimV(y));
- else
- if ((DimV(x) != DimV(y)) || (RowM(LU) != DimV(y)) || (ColM(LU) != DimV(y)) || (DimP(P) != DimV(y)))
- { dw_Error(SIZE_ERR); return (TVector)NULL; }
-
- if (!(z=(PRECISION*)malloc(sizeof(PRECISION)*DimV(y)))) { dw_Error(SIZE_ERR); return (TVector)NULL; }
-
- for (j=0; j < DimV(y); j++)
- {
- sum=ElementV(y,j);
- for (i=j-1; i >= 0; i--) sum-=z[i]*ElementM(LU,i,j);
- if (ElementM(LU,j,j) == 0.0) dw_Error(SING_ERR);
- z[j]=sum/ElementM(LU,j,j);
- }
-
- for (j=DimV(y)-2; j >= 0; j--)
- {
- sum=z[j];
- for (i=j+1; i < DimV(y); i++) sum-=z[i]*ElementM(LU,i,j);
- z[j]=sum;
- }
-
- for (i=UseP(P)-1; i >= 0; i--) ElementV(x,ElementP(P,i))=z[i];
- free(z);
- return x;
-}
-
-/*******************************************************************************/
-/**************************** Permutation Matrices *****************************/
-/*******************************************************************************/
-/*
- Assumes
- X : m-permutation or null pointer.
- i : 0 <= i < m
- j : 0 <= j < m
- m : positive integer
-
- Results
- X is initialized to be the permutation which is the transposition (i,j)
-*/
-TPermutation TranspositionPermutation(TPermutation X, int i, int j, int m)
-{
- if ((m <= 0) || (i < 0) || (i >= m) || (j < 0) || (j >= m))
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- if (!X)
- {
- if (!(X=CreatePermutation(m)))
- return (TPermutation)NULL;
- }
- else
- if (DimP(X) != m)
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- if (j > i)
- {
- UseP(X)=i+1;
- ElementP(X,i)=j;
- for (i--; i >= 0; i--) ElementP(X,i)=i;
- }
- else
- if (i > j)
- {
- UseP(X)=j+1;
- ElementP(X,j)=i;
- for (j--; j >= 0; j--) ElementP(X,j)=j;
- }
- else
- UseP(X)=0;
- return X;
-}
-
-/*
- Assumes
- X : m-permutation or null pointer.
- p : integer array of length m.
- m : postive integer
-
- Results
- X is initialized to be the permutation which is the mapping i -> p[i]
-*/
-TPermutation InitializePermutationFromIntArray(TPermutation X, int *p, int m)
-{
- int i;
- if (!p)
- {
- dw_Error(NULL_ERR);
- return (TPermutation)NULL;
- }
- if (!X)
- {
- if (!(X=CreatePermutation(m)))
- return (TPermutation)NULL;
- }
- else
- if (DimP(X) != m)
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- for (i=m-2; (i >= 0) && (p[i] <= i); i--);
- UseP(X)=i+1;
- if (i >= 0)
- {
- ElementP(X,i)=i;
- for (i--; i >= 0; i--)
- ElementP(X,i)=(p[i] > i) ? p[i] : i;
- }
- return X;
-}
-/*
- Assumes
- X : m-permutation or null pointer
- Y : m-permutation
-
- Results
- X = Y. If X is null pointer, X is created.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-*/
-TPermutation EquatePermutation(TPermutation X, TPermutation Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TPermutation)NULL;
- }
- if (!X)
- {
- if (!(X=CreatePermutation(DimP(Y))))
- return (TPermutation)NULL;
- }
- else
- if (DimP(X) != DimP(Y))
- {
- dw_Error(SIZE_ERR);
- return (TPermutation)NULL;
- }
- UseP(X)=UseP(Y);
- memcpy(pElementP(X),pElementP(Y),UseP(Y)*sizeof(int));
- return X;
-}
-
-TMatrix PermutationMatrix(TMatrix X, TPermutation Y)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(DimP(Y),DimP(Y))))
- {
- dw_Error(MEM_ERR);
- return (TMatrix)NULL;
- }
- }
- else
- if ((RowM(X) != DimP(Y)) || (ColM(X) != DimP(Y)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- bPermutation(pElementM(X),pElementP(Y),DimP(Y),UseP(Y),MajorForm(X));
- return X;
-}
-
-TMatrix ProductPM(TMatrix X, TPermutation Y, TMatrix Z)
-{
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (DimP(Y) != RowM(Z))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Z) && !(X=EquateMatrix(X,Z))) return (TMatrix)NULL;
- bPermutationMultiply(pElementP(Y),pElementM(X),RowM(X),ColM(X),UseP(Y),0,MajorForm(X));
- return X;
-}
-
-TMatrix ProductMP(TMatrix X, TMatrix Y, TPermutation Z)
-{
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (ColM(Y) != DimP(Z))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Y) && !(X=EquateMatrix(X,Y))) return (TMatrix)NULL;
- bPermutationMultiply(pElementP(Z),pElementM(X),ColM(X),RowM(X),UseP(Z),1,1^MajorForm(X));
- return X;
-}
-
-TVector ProductPV(TVector x, TPermutation Y, TVector z)
-{
- if (!Y || !z)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (DimP(Y) != DimV(z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if ((x != z) && !(x=EquateVector(x,z))) return (TVector)NULL;
- bPermutationMultiply(pElementP(Y),pElementV(x),DimV(x),1,UseP(Y),0,1);
- return x;
-}
-
-TVector ProductVP(TVector x, TVector y, TPermutation Z)
-{
- if (!y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if (DimV(y) != DimP(Z))
- {
- dw_Error(SIZE_ERR);
- return (TVector)NULL;
- }
- if ((x != y) && !(x=EquateVector(x,y))) return (TVector)NULL;
- bPermutationMultiply(pElementP(Z),pElementV(x),DimV(x),1,UseP(Z),1,1);
- return x;
-}
-
-TMatrix TransposeProductPM(TMatrix X, TPermutation Y, TMatrix Z)
-{
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (DimP(Y) != RowM(Z))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Z) && !(X=EquateMatrix(X,Z))) return (TMatrix)NULL;
- bPermutationMultiply(pElementP(Y),pElementM(X),RowM(X),ColM(X),UseP(Y),1,MajorForm(X));
- return X;
-}
-
-TMatrix ProductTransposeMP(TMatrix X, TMatrix Y, TPermutation Z)
-{
- if (!Y || !Z)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (ColM(Y) != DimP(Z))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Y) && !(X=EquateMatrix(X,Y))) return (TMatrix)NULL;
- bPermutationMultiply(pElementP(Z),pElementM(X),ColM(X),RowM(X),UseP(Z),0,1^MajorForm(X));
- return X;
-}
-
-
-void PrintPermutation(FILE *f, TPermutation X)
-{
- int i, j, k;
- for (i=0; i < DimP(X); i++)
- fprintf(f,"%3d ",i);
- fprintf(f,"\n");
- for (i=0; i < DimP(X); i++)
- {
- if (i < UseP(X))
- {
- k=ElementP(X,i);
- j=i-1;
- }
- else
- {
- k=i;
- j=UseP(X)-1;
- }
- for ( ; j >= 0; j--)
- if (k == ElementP(X,j)) k=j;
- fprintf(f,"%3d ",k);
- }
- fprintf(f,"\n");
-}
-/**/
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/matrix.h b/matlab/swz/c-code/utilities/DWCcode/matrix/matrix.h
deleted file mode 100644
index 6eab3089eddb7d2b1c2012b0d1b1d2b301716f4c..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/matrix.h
+++ /dev/null
@@ -1,594 +0,0 @@
-/********************************************************************************
- VECTORS AND MATRICES
- A TVector is an array of floating points together with the dimension of the
- vector. A TVector implementation can contain additional information. An
- instance of TVector must be created with calls to CreateVector() and freed with
- calls to FreeVector(). The following macros must be defined.
-
- DimV(x) - x : TVector
- Returns: int containing the dimension.
-
- ElementV(x,i) - x : TVector
- i : integer
- Returns: L-value PRECISION containing the ith element. The
- index i is zero-based.
-
- pElementV(x) - x : TVector
- Returns: pointer to 0th element of the array storing the vector.
-
- A TMatrix is an array of floating points together with the number of rows and
- columns in the matrix. If the storage type (row or column major) is variable,
- then it also must be stored. A TMatrix implementation can contain additional
- information. A instance of TMatrix must be created with CreateMatrix() and freed
- with FreeMatrix(). The following macros must be defined.
-
- RowM(x) - x : TMatrix
- Returns: int containing the number of rows.
-
- ColM(x) - x : TMatrix
- Returns: int containing the number of columns.
-
- ElementM(x,i,j) - x : TVector
- i : int
- j : int
- Returns: L-value PRECISION containing the element in the ith
- row and jth column. The indexes i and j are zero
- based.
-
- pElementM(x) - x : TMatrix
- Returns: pointer to 0th element of the array storing the
- matrix.
-
- MajorForm(x) - x : TMatrix
- Returns: 0 if data stored in row major format and 1 if data
- stored in column major format. The data is in row
- major format if
-
- ElementM(x,i,j) = pElementM(x)[i*ColM(x)+j]
-
- and is in column major format if
-
- ElementM(x,i,j) = pElementM(x)[i+j*RowM(x)]
-
- SetMajorForm(x,i) - Sets the MajorForm of the TMatrix x to the int i. The value
- of i must be either 0 or 1. If the implementation allows
- for only one type, then this can be defined to be blank.
- For this reason, it is important that the user be careful in
- using this macro since it may not have an effect in all
- implementations. It is always permissible to assign the
- value of an existing TMatrix, as in
-
- SetMajorForm(x,MajorForm(y));
-
- but in all other cases, it is important to check, via a call
- to MajorForm(), that the MajorForm has actually been set.
-
-
- The precision (float or double) is controlled by the define PRECISION
- contained in the file prcsn.h.
-
-
- PERMUTATION MATRICES
- For 0 <= i,j <= m-1, let (i,j) denote the transposition which interchanges i
- and j leaves the other elements fixed. Let P(i,j) denote the m x m matrix
- obtained from the m x m identitiy matrix by interchanging the ith and jth rows,
- which for the identity matrix is equivalent to interchanging the ith and jth
- columns. If p is a permutation of {0,...,m-1} and is equal to the product of
- transpositions
-
- (i1,j1)*(i2,j2)*...*(iq,jq)
-
- then the permutation matrix associated with the permutation p is
-
- P = P(i1,j1)*P(i2,j2)*...*P(iq,jq)
-
- Note that our convention is that
-
- (i1,j1)*(i2,j2)(k) = (i1,j1)((i2,j2)(k))
-
- Thus (1,2)(2,3) is the permutation that sends 1 to 2, 2 to 3, and 3 to 1. Note
- that multiplication on the left by a permutation matrix P associated with the
- permutation p permutes the rows by p. Multiplication on the right permutes the
- columns by the inverse of p.
-
- A TPermutation is an integer array together with the length of the array and
- the number of array elements actually used. A TPermutation implementation can
- contain additional information. A instance of TPermutation must be created
- with CreatePermutation() and freed with FreePermutation(). The following
- macros must be defined.
-
- DimP(x) - x : TPermutation
- Returns: int containing the dimension.
-
- UseP(x) - x : TPermutation
- Returns: L-value int containing the number of array elements
- used. This macro can also be used to set this number.
- It must be the case that 0 <= UseP(x) <= DimP(x).
-
- ElementP(x,i) - x : TPermutation
- i : int
- Returns: L-value int containing the ith element. The index i
- is zero-based. It must be case that
- i <= ElementP(x,i) <= DimP(x).
-
- pElementP(x) - x : TPermutation
- Returns: pointer to 0th element of the array storing the
- permutation.
-
-
- The representation as a product of transpositions used by TPermutation
-
- (0,ElementP(x,0))*...*(UseP(x)-1,ElementP(x,UseP(x)-1)
-
-*******************************************************************************/
-
-/*******************************************************************************
- Some thoughts on vector and matrix implementation:
-
- 1) Because vectors are one dimensional and matrices are two dimensional,
- they should have different implementations for reasons of efficiency.
-
- 2) Can one get efficiency from more general n-dimensional matrix
- representations?
-
- 3) Should the types be encoded as a pointer to a structure or as a pointer
- to a float or double with the dimension and other infomation hidden.
-
- 4) There must be an efficient Element() operator. If (1) is followed, there
- must be efficient ElementV() and ElementM() operators. These operators
- must be able to return L-values and so probably need to implemented as
- macros. This has the disadvantage that ElementM() will have side effects
- that must be avoided.
-
- 5) There must be an efficient Dim() operator. If (1) is followed, there
- should be efficient DimV(), RowM(), ColM() operators, probably
- implemented as macros.
-
- 6) Should there be a flag to represent special matrices. For instance,
- diagonal, upper triangular, lower triagular, and symmetric. If the
- decision is made to include such a flag, then a decision must be made
- on the storage of special matrices. In particular, should special
- matrices use a compressed storage, or should they use the general
- storage technique. If they use the general storage technique, should
- the full matrix be stored, or should the redundant elements be left
- undefined. This has implications for the ElementM() operator.
-
- 7) Should a decision be made to always encode matrices as column major, or
- should there be a flag to determine whether the matrix is encoded as
- column major or row major. This gives added flexibility, but adds an
- extra cost to all matrix functions. For complex functions which already
- check size, this cost is small, but for functions such as ElementM(),
- the cost may not be so small. One solution would to be to add the
- operators ElementM_R() and ElementM_C(), which would retrieve the orginal
- efficiency in ElementM(), but would put a burden on the user to ensure
- that the right operator was called.
-
- 8) Many routines will have the form Y = fnct(X, Z1, Z2, ...), where X and Y
- are pointers to the same type. The characteristics (usually size) of X
- depends on the Z's. For this reason, X is allowed to be a null pointer.
- This allows the routine to create and return a pointer with the proper
- characteristics. On the other hand, errors occur in the routine, then
- a null pointer is returned. There is a potential for memory leaks. The
- following syntax must be avoided: X = fnct(X, Z1, Z2, ... ). If X is null
- or no errors occur, then no harm will result, but if X is not null and an
- error occurs then a memory leak will exist. This type of construct must
- be avoided. Similarly, the following construct must be avoided:
-
- X = fnct2(fnct1(...), ...)
-
- If fnct1() returns a non-null pointer but fnct2 exists because of an
- error, then a memory leak will exist. The proper construct in this case
- is
- fnct1(X = fnct1(...), ...)
-
-********************************************************************************/
-
-#ifndef __MATRIX__
-#define __MATRIX__
-
-#include "prcsn.h"
-#include <stdio.h>
-
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-
-/******************************************************************************/
-/********************************* Data Types *********************************/
-/******************************************************************************/
-//#define STANDARD_COLUMN_MAJOR
-//#define STANDARD_ROW_MAJOR
-//#define STRUCTURED_COLUMN_MAJOR
-//#define STRUCTURED_ROW_MAJOR
-//#define STRUCTURED_MAJOR_FORM
-//#define LEGACY_ROW_MAJOR
-#define TZ_COLUMN_MAJOR
-//#define CHECK_MACRO_CALLS
-
-#define COLUMN_MAJOR 1
-#define ROW_MAJOR 0
-
-/*----------------------------------------------------------------------------*/
-#if defined CHECK_MACRO_CALLS
-typedef PRECISION *TVector;
-typedef PRECISION **TMatrix;
-typedef int *TPermutation;
-
-int DimV(TVector x);
-PRECISION ElementV(TVector x, int i);
-PRECISION* pElementV(TVector x);
-
-int RowM(TMatrix x);
-int ColM(TMatrix x);
-PRECISION ElementM(TMatrix x, int i, int j);
-PRECISION* pElementM(TMatrix x);
-
-int DimP(TPermutation x);
-int UseP(TPermutation x);
-int ElementP(TPermutation y, int i);
-int* pElementP(TPermutation y);
-#endif
-/*----------------------------------------------------------------------------*/
-#if (defined(STANDARD_COLUMN_MAJOR) || defined(STANDARD_ROW_MAJOR))
-// Data types
-typedef struct
-{
- int dim;
- PRECISION x[1];
-} TVectorStructure;
-typedef TVectorStructure *TVector;
-
-typedef struct
-{
- int row;
- int col;
- PRECISION x[1];
-} TMatrixStructure;
-typedef TMatrixStructure* TMatrix;
-
-typedef struct
-{
- int dim;
- int use;
- int x[1];
-} TPermutationStructure;
-typedef TPermutationStructure* TPermutation;
-
-// Element access macros
-#define DimV(y) ((y)->dim)
-#define pElementV(y) ((y)->x)
-#define ElementV(y,i) ((y)->x[(i)])
-
-#define RowM(y) ((y)->row)
-#define ColM(y) ((y)->col)
-#define pElementM(y) ((y)->x)
-#if defined STANDARD_COLUMN_MAJOR
-#define ElementM(y,i,j) ((y)->x[(i)+(j)*((y)->row)])
-#else
-#define ElementM(y,i,j) ((y)->x[(i)*((y)->col)+(j)])
-#endif
-
-#define UseP(y) ((y)->use)
-#define DimP(y) ((y)->dim)
-#define pElementP(y) ((y)->x)
-#define ElementP(y,i) ((y)->x[(i)])
-
-// Major form macros
-#define SetMajorForm(x,i)
-#if defined STANDARD_COLUMN_MAJOR
-#define MajorForm(x) COLUMN_MAJOR
-#else
-#define MajorForm(x) ROW_MAJOR
-#endif
-
-#endif
-/*----------------------------------------------------------------------------*/
-#if (defined(STRUCTURED_COLUMN_MAJOR) || defined(STRUCTURED_ROW_MAJOR) || defined(STRUCTURED_MAJOR_FORM))
-// Data types
-typedef struct
-{
- int dim;
- PRECISION *x;
-} TVectorStructure;
-typedef TVectorStructure *TVector;
-
-typedef struct
-{
- int row;
- int col;
-#if (defined(STRUCTURED_MAJOR_FORM))
- int major;
-#endif
- PRECISION *x;
-} TMatrixStructure;
-typedef TMatrixStructure* TMatrix;
-
-typedef struct
-{
- int dim;
- int use;
- int *x;
-} TPermutationStructure;
-typedef TPermutationStructure* TPermutation;
-
-// Element access macros
-#define DimV(y) ((y)->dim)
-#define pElementV(y) ((y)->x)
-#define ElementV(y,i) ((y)->x[(i)])
-
-#define RowM(y) ((y)->row)
-#define ColM(y) ((y)->col)
-#define pElementM(y) ((y)->x)
-#if defined STRUCTURED_COLUMN_MAJOR
-#define ElementM(y,i,j) ((y)->x[(i)+(j)*((y)->row)])
-#elif defined STRUCTURED_ROW_MAJOR
-#define ElementM(y,i,j) ((y)->x[(i)*((y)->col)+(j)])
-#elif defined STRUCTURED_MAJOR_FORM
-#define ElementM(y,i,j) ((y)->x[(y)->major ? (i)+(j)*((y)->row) : (i)*((y)->col)+(j)])
-#endif
-
-#define UseP(y) ((y)->use)
-#define DimP(y) ((y)->dim)
-#define pElementP(y) ((y)->x)
-#define ElementP(y,i) ((y)->x[(i)])
-
-// Major form macros
-#if defined STRUCTURED_COLUMN_MAJOR
-#define MajorForm(x) COLUMN_MAJOR
-#define SetMajorForm(x,i)
-#elif defined STRUCTURED_ROW_MAJOR
-#define MajorForm(x) ROW_MAJOR
-#define SetMajorForm(x,i)
-#elif defined STRUCTURED_MAJOR_FORM
-#define SetMajorForm(x,i) ((x)->major=(i))
-#define MajorForm(x) ((x)->major)
-#endif
-
-#endif
-/*----------------------------------------------------------------------------*/
-#if defined LEGACY_ROW_MAJOR
-// Data types
-typedef PRECISION *TVector;
-typedef PRECISION **TMatrix;
-typedef int* TPermutation;
-
-// Element access macros
-#define DimV(y) (((int*)(y))[-1])
-#define pElementV(y) (y)
-#define ElementV(y,i) ((y)[(i)])
-
-#define RowM(y) (((int*)(y))[-2])
-#define ColM(y) (((int*)(y))[-1])
-#define pElementM(y) ((y)[0])
-#define ElementM(y,i,j) ((y)[(i)][(j)])
-
-#define UseP(y) (((int*)(y))[-1])
-#define DimP(y) (((int*)(y))[-2])
-#define pElementP(y) (y)
-#define ElementP(y,i) ((y)[(i)])
-
-// Legacy element access
-#define V_DIM(x) (((int*)(x))[-1])
-#define M_ROW(x) (((int*)(x))[-2])
-#define M_COL(x) (((int*)(x))[-1])
-#define P_USE(x) (((int*)(x))[-1])
-#define P_DIM(x) (((int*)(x))[-2])
-
-// Major form macros
-#define SetMajorForm(x,i)
-#define MajorForm(x) 0
-
-#endif
-/*----------------------------------------------------------------------------*/
-#if defined TZ_COLUMN_MAJOR
-/* In prcsn.h, PRECISION must be defined to be double */
-//#define PRECISION double
-
-// Use Tao's implimentation
-#include "tzmatlab.h"
-// Use DW's implimentation - not all functionality supported
-//#include "tz2dw.h"
-
-
-// Data types
-typedef TSdvector* TVector;
-typedef TSdmatrix* TMatrix;
-
-typedef struct
-{
- int dim;
- int use;
- int x[1];
-} TPermutationStructure;
-typedef TPermutationStructure* TPermutation;
-
-// Element access macros
-#define DimV(y) ((y)->n)
-#define pElementV(y) ((y)->v)
-#define ElementV(y,i) ((y)->v[(i)])
-
-#define RowM(y) ((y)->nrows)
-#define ColM(y) ((y)->ncols)
-#define pElementM(y) ((y)->M)
-#define ElementM(y,i,j) ((y)->M[(i)+(j)*((y)->nrows)])
-
-#define UseP(y) ((y)->use)
-#define DimP(y) ((y)->dim)
-#define pElementP(y) ((y)->x)
-#define ElementP(y,i) ((y)->x[(i)])
-
-// Major form macros
-#define SetMajorForm(x,i)
-#define MajorForm(x) COLUMN_MAJOR
-
-#endif
-/*----------------------------------------------------------------------------*/
-/******************************************************************************/
-/******************************************************************************/
-
-/* Allocation/Deallocation Routines */
-TVector CreateVector(int m);
-TMatrix CreateMatrix(int m, int n);
-void FreeVector(TVector x);
-void FreeMatrix(TMatrix X);
-
-/* Initialization Routines */
-TVector InitializeVector(TVector x, PRECISION c);
-TMatrix InitializeMatrix(TMatrix X, PRECISION c);
-
-/* Assignment Routines */
-TVector EquateVector(TVector x, TVector y);
-TMatrix EquateMatrix(TMatrix X, TMatrix Y);
-TMatrix Transpose(TMatrix X, TMatrix Y);
-TMatrix IdentityMatrix(TMatrix X, int m);
-TMatrix DiagonalMatrix(TMatrix X, TVector y);
-TVector AbsV(TVector x, TVector y);
-TMatrix AbsM(TMatrix X, TMatrix Y);
-TVector MinusV(TVector x, TVector y);
-TMatrix MinusM(TMatrix X, TMatrix Y);
-TMatrix SubMatrix(TMatrix X, TMatrix Y, int brow, int bcol, int rows, int cols);
-TMatrix InsertSubMatrix(TMatrix X, TMatrix Y, int brow_X, int bcol_X, int brow_Y, int bcol_Y, int rows, int cols);
-TMatrix CopyColumnVector(TMatrix X, TVector y, int col);
-TVector SubVector(TVector x, TVector y, int b, int d);
-TVector ColumnVector(TVector x, TMatrix Y, int col);
-TVector RowVector(TVector x, TMatrix Y, int row);
-TMatrix ColumnMatrix(TMatrix X, TVector y);
-TMatrix RowMatrix(TMatrix X, TVector y);
-
-//=== Addition Routines ===
-TVector AddVV(TVector x, TVector y, TVector z);
-TMatrix AddMM(TMatrix X, TMatrix Y, TMatrix Z);
-TVector SubtractVV(TVector x, TVector y, TVector z);
-TMatrix SubtractMM(TMatrix X, TMatrix Y, TMatrix Z);
-
-//=== Multiplication Routines ===
-TVector ProductSV(TVector x, PRECISION s, TVector y);
-#define ProductVS(x,y,s) ProductSV(x,s,y)
-TMatrix ProductSM(TMatrix X, PRECISION s, TMatrix Y);
-#define ProductMS(X,Y,s) ProductSM(X,s,Y)
-TVector ProductVM(TVector x, TVector y, TMatrix Z);
-TVector ProductMV(TVector x, TMatrix Y, TVector z);
-TMatrix ProductMM(TMatrix X, TMatrix Y, TMatrix Z);
-TVector ProductInverseVM(TVector x, TVector y, TMatrix Z);
-TMatrix ProductInverseMM(TMatrix X, TMatrix Y, TMatrix Z);
-TVector ProductInverseVU(TVector x, TVector y, TMatrix Z);
-TMatrix ProductInverseMU(TMatrix X, TMatrix Y, TMatrix Z);
-TVector ProductInverseVL(TVector x, TVector y, TMatrix Z);
-TMatrix ProductInverseML(TMatrix X, TMatrix Y, TMatrix Z);
-TVector InverseProductMV(TVector x, TMatrix Y, TVector z);
-TMatrix InverseProductMM(TMatrix X, TMatrix Y, TMatrix Z);
-TVector InverseProductUV(TVector x, TMatrix Y, TVector z);
-TMatrix InverseProductUM(TMatrix X, TMatrix Y, TMatrix Z);
-TVector InverseProductLV(TVector x, TMatrix Y, TVector z);
-TMatrix InverseProductLM(TMatrix X, TMatrix Y, TMatrix Z);
-TMatrix TransposeProductMM(TMatrix X, TMatrix Y, TMatrix Z);
-#define TransposeProductMV(x,Y,z) ProductVM(x,z,Y)
-TMatrix ProductTransposeMM(TMatrix X, TMatrix Y, TMatrix Z);
-#define ProductTransposeVM(x,y,Z) ProductMV(x,Z,y)
-
-//=== Linear Combination with Updating ===
-TVector UpdateVS(TVector x, TVector y, PRECISION a);
-TMatrix UpdateMS(TMatrix X, TMatrix Y, PRECISION a);
-TVector LinearCombinationVV(TVector x, PRECISION a, TVector y, PRECISION b, TVector z);
-TMatrix LinearCombinationMM(TMatrix x, PRECISION a, TMatrix y, PRECISION b, TMatrix z);
-
-/* Matrix Inverse Routines */
-TMatrix Inverse_LU(TMatrix X, TMatrix Y);
-TMatrix Inverse_SVD(TMatrix X, TMatrix Y);
-TMatrix Inverse_Cholesky(TMatrix X, TMatrix Y);
-TMatrix Inverse_UT(TMatrix X, TMatrix Y);
-TMatrix Inverse_LT(TMatrix X, TMatrix Y);
-
-/* Matrix Decompositions */
-int SVD(TMatrix U, TVector d, TMatrix V, TMatrix A);
-int QR(TMatrix Q, TMatrix R, TMatrix X);
-int LU(TPermutation P, TMatrix X, TMatrix A);
-
-int QZ_Real(TMatrix S, TMatrix T, TMatrix Q, TMatrix Z, TMatrix A, TMatrix B, TVector alpha_r, TVector alpha_i, TVector beta);
-int ReorderQZ_Real(TMatrix SS, TMatrix TT, TMatrix QQ, TMatrix ZZ, TMatrix S, TMatrix T, TMatrix Q, TMatrix Z, int *select, TVector alpha_r, TVector alpha_i, TVector beta);
-
-TMatrix CholeskyUT(TMatrix T, TMatrix X);
-TMatrix CholeskyLT(TMatrix T, TMatrix X);
-
-TVector LU_SolveCol(TVector x, TVector y, TMatrix LU, TPermutation P);
-TVector LU_SolveRow(TVector x, TVector y, TMatrix LU, TPermutation P);
-
-/* Miscellaneous Routines */
-PRECISION Norm(TVector x);
-PRECISION MatrixNormEuclidean(TMatrix X);
-PRECISION MatrixNorm(TMatrix X);
-PRECISION DotProduct(TVector x, TVector y);
-PRECISION InnerProduct(TVector x, TVector y, TMatrix S);
-TMatrix OuterProduct(TMatrix X, TVector y, TVector z);
-PRECISION Trace(TMatrix X);
-PRECISION Determinant_LU(TMatrix X);
-PRECISION LogAbsDeterminant_LU(TMatrix X);
-PRECISION Determinant_QR(TMatrix X);
-int Rank_SVD(TMatrix X);
-TVector CrossProduct_LU(TVector x, TMatrix Y);
-TVector CrossProduct_QR(TVector x, TMatrix Y);
-TMatrix NullSpace(TMatrix Y);
-TMatrix GeneralizedInverse(TMatrix X, TMatrix Y);
-
-/* Kronecker Routines */
-TVector Vec(TVector x, TMatrix Y);
-TMatrix KroneckerProduct(TMatrix X, TMatrix Y, TMatrix Z);
-
-/* Input - Output Routines */
-int dw_PrintVector(FILE *f, TVector x, char *format);
-int dw_PrintMatrix(FILE *f, TMatrix X, char *format);
-int dw_ReadMatrix(FILE *f, TMatrix X);
-int dw_ReadVector(FILE *f, TVector x);
-int OutVectorFloat(FILE *f, TVector x);
-int OutMatrixFloat(FILE *f, TMatrix X);
-int OutVectorDouble(FILE *f, TVector x);
-int OutMatrixDouble(FILE *f, TMatrix X);
-TVector InVector(FILE *f, TVector x);
-TMatrix InMatrix(FILE *f, TMatrix X);
-
-/* Permutations */
-TPermutation CreatePermutation(int m);
-void FreePermutation(TPermutation X);
-TPermutation InitializePermutationFromIntArray(TPermutation X, int *p, int m);
-TPermutation TranspositionPermutation(TPermutation X, int i, int j, int m);
-TPermutation EquatePermutation(TPermutation X, TPermutation Y);
-TMatrix PermutationMatrix(TMatrix X, TPermutation Y);
-TMatrix ProductPM(TMatrix X, TPermutation Y, TMatrix Z);
-TMatrix ProductMP(TMatrix X, TMatrix Y, TPermutation Z);
-TVector ProductPV(TVector x, TPermutation Y, TVector z);
-TVector ProductVP(TVector x, TVector y, TPermutation Z);
-TMatrix TransposeProductPM(TMatrix X, TPermutation Y, TMatrix Z);
-#define TransposeProductPV(x,Y,z) ProductVP(x,z,Y)
-TMatrix ProductTransposeMP(TMatrix X, TMatrix Y, TPermutation Z);
-#define ProductTransposeVP(x,y,Z) ProductPV(x,Z,y)
-void PrintPermutation(FILE *f, TPermutation);
-
-/****** Old Style Syntax ******
-//====== Error Routines ======
-#define MatrixError(err) Error(err)
-#define ClearMatrixError() ClearError()
-#define GetMatrixError() GetError()
-#define SetMatrixErrorVerbose(err) SetVerboseErrors(err)
-#define SetMatrixErrorTerminate(err) SetTerminalErrors(err)
-
-//#define Inverse(X,Y) Inverse_LU(X,Y)
-//#define TransposeProduct(X,Y,Z) TransposeProductMM(X,Y,Z)
-//#define ProductTranspose(X,Y,Z) ProductTransposeMM(X,Y,Z)
-//#define InverseProduct(X,Y,Z) InverseProductMM(X,Y,Z)
-//#define ProductInverse(X,Y,Z) ProductInverseMM(X,Y,Z)
-//#define VectorProductInverse(x,y,Z) ProductInverseVM(x,y,Z)
-//#define ERROR(i) MatrixError(i)
-
-// int Cholesky_U(TMatrix T, TMatrix X) X = T'* T (T upper triangular)
-// int Cholesky_L(TMatrix T, TMatrix X) X = T * T' (T lower triangular)
-// int SingularValueDecomposition(TMatrix U, TVector d, TMatrix V, TMatrix A) A = U * Diagonal(d) * V'
-// int* QR_RPivot(TMatrix R, TMatrix X);
-// int* QR_QRPivot(TMatrix Q, TMatrix R, TMatrix X);
-/**/
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/prcsn.h b/matlab/swz/c-code/utilities/DWCcode/matrix/prcsn.h
deleted file mode 100644
index 3711e15f2ce52795ec8f8fda67a4e1591f874e94..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/prcsn.h
+++ /dev/null
@@ -1,35 +0,0 @@
-
-/*
- Defines the precision to be used
-*/
-
-#ifndef __PRECISION_H__
-#define __PRECISION_H__
-
-#include <float.h>
-
-/********** double precision **********/
-#define PRECISION double
-#define MACHINE_EPSILON 1.11E-16
-#define SQRT_MACHINE_EPSILON 1.06E-08
-#define PRECISION_SIZE 8
-#define PRECISION_SHIFT 3
-#define PRECISION_WORD qword
-#define MINUS_INFINITY -1.0E300
-#define PLUS_INFINITY 1.0E300
-//#define MINUS_INFINITY -DBL_MAX
-//#define PLUS_INFINITY DBL_MAX
-/**************************************/
-
-/********** single precision **********
-#define PRECISION float
-#define MACHINE_EPSILON 5.97E-08
-#define SQRT_MACHINE_EPSILON 2.45E-04
-#define PRECISION_SIZE 4
-#define PRECISION_SHIFT 2
-#define PRECISION_WORD dword
-#define MINUS_INFINITY -FLT_MAX
-#define PLUS_INFINITY FLT_MAX
-/**************************************/
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/matrix/tz2dw.h b/matlab/swz/c-code/utilities/DWCcode/matrix/tz2dw.h
deleted file mode 100644
index 09c77b5158d957abf9e2cb5a17d3bf98cc13b998..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/matrix/tz2dw.h
+++ /dev/null
@@ -1,43 +0,0 @@
-
-#ifndef __TZ2DW__
-#define __TZ2DW__
-
-#include "matrix.h"
-
-// flags and defines
-#define NEARINFINITY 1.0E+300
-#define M_UNDEF 0 //0 or NULL: No attribute will be given when memory is allocated but no values are initialized.
-#define M_GE 0x0001 //1: A general matrix.
-#define M_SU 0x0002 //2: A symmetric (must be square) matrix but only the upper triangular part is referenced.
-#define M_SL 0x0004 //4: A symmetric (must be square) matrix but only the lower triangular part is referenced.
-#define M_UT 0x0008 //8: A upper triangular (trapezoidal if nrows < ncols) matrix but only the upper triangular part is referenced.
-#define M_LT 0x0010 //16: A lower triangular (trapezoidal if nrows > ncols) matrix but only the lower triangular part is referenced.
-#define M_CN 0x0020 //32: A constant (CN) matrix (All elements are the same or no (N) change from one to another).
-#define V_UNDEF 0 //Zero or NULL: No values have been assigned to the double vector.
-#define V_DEF 1 //True: Values have been assigned to the double vector.
-#define square(x) ((x)*(x))
-
-// matrix and vector structures
-typedef struct
-{
- double *M;
- int nrows, ncols;
- int flag; //flag: Refers to M_GE, M_SU, M_SL, M_UT, and M_LT in tzmatlab.h.
-} TSdmatrix;
-typedef struct
-{
- double *v;
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
-} TSdvector;
-
-
-
-// memory management
-#define tzMalloc(elt_count,type) (type *)malloc((elt_count)*sizeof(type))
-#define tzDestroy(x) {if (x) { free((x)); (x) = NULL; }}
-
-// i/o
-#define tzFclose(x) {if (x) { fclose(x); (x)=(FILE *)NULL;}}
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/sort/dw_matrix_sort.c b/matlab/swz/c-code/utilities/DWCcode/sort/dw_matrix_sort.c
deleted file mode 100644
index 2a9e7e81fad5469ae4b839f7a9f6a34add69bee9..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/sort/dw_matrix_sort.c
+++ /dev/null
@@ -1,664 +0,0 @@
-
-#include "dw_matrix_sort.h"
-#include "dw_error.h"
-#include <stdlib.h>
-#include <string.h>
-
-static void b_qsort_array_ascending_real(PRECISION *x, int m);
-static void b_qsort_array_descending_real(PRECISION *x, int m);
-static void b_qsort_matrix_columns_ascending_real(PRECISION *x, int m, int n, int idx);
-static void b_qsort_matrix_columns_descending_real(PRECISION *x, int m, int n, int idx);
-static void b_qsort_matrix_rows_ascending_real(PRECISION *x, int m, int n, int br, int er, int idx);
-static void b_qsort_matrix_rows_descending_real(PRECISION *x, int m, int n, int br, int er, int idx);
-
-/*
- Assumes
- X : m x n matrix or null
- Y : m x n matrix
- j : column to sort
-
- Results
- The rows of X are sorted in ascending order on the ith column. The matrix
- X is created if null.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct matrices. Uses the quick sort algorithm,
-*/
-TMatrix SortMatrixRowsAscending(TMatrix X, TMatrix Y, int j)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Y) && !(X=EquateMatrix(X,Y)))
- return (TMatrix)NULL;
- if (MajorForm(X) == ROW_MAJOR)
- b_qsort_matrix_columns_ascending_real(pElementM(X),ColM(X),RowM(X),j);
- else
- b_qsort_matrix_rows_ascending_real(pElementM(X),RowM(X),ColM(X),0,RowM(X)-1,j*RowM(X));
- return X;
-}
-
-/*
- Assumes
- X : m x n matrix or null
- Y : m x n matrix
- j : column to sort
-
- Results
- The rows of X are sorted in descending order on the ith column. The matrix
- X is created if null.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct matrices. Uses the quick sort algorithm,
-*/
-TMatrix SortMatrixRowsDescending(TMatrix X, TMatrix Y, int j)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Y) && !(X=EquateMatrix(X,Y)))
- return (TMatrix)NULL;
- if (MajorForm(X) == ROW_MAJOR)
- b_qsort_matrix_columns_descending_real(pElementM(X),ColM(X),RowM(X),j);
- else
- b_qsort_matrix_rows_descending_real(pElementM(X),RowM(X),ColM(X),0,RowM(X)-1,j*RowM(X));
- return X;
-}
-
-/*
- Assumes
- X : m x n matrix or null
- Y : m x n matrix
- i : row to sort
-
- Results
- The columns of X are sorted in ascending order on the ith row. The matrix X
- is created if null.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct matrices. Uses the quick sort algorithm,
-*/
-TMatrix SortMatrixColumnsAscending(TMatrix X, TMatrix Y, int i)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Y) && !(X=EquateMatrix(X,Y)))
- return (TMatrix)NULL;
- if (MajorForm(X) == ROW_MAJOR)
- b_qsort_matrix_rows_ascending_real(pElementM(X),ColM(X),RowM(X),0,ColM(X)-1,i*RowM(X));
- else
- b_qsort_matrix_columns_ascending_real(pElementM(X),RowM(X),ColM(X),i);
- return X;
-}
-
-/*
- Assumes
- X : m x n matrix or null
- Y : m x n matrix
- i : row to sort
-
- Results
- The columns of X are sorted in descending order on the ith row. The matrix
- X is created if null.
-
- Returns
- Returns X upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- X and Y do not have to be distinct matrices. Uses the quick sort algorithm,
-*/
-TMatrix SortMatrixColumnsDescending(TMatrix X, TMatrix Y, int i)
-{
- if (!Y)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((X != Y) && !(X=EquateMatrix(X,Y)))
- return (TMatrix)NULL;
- if (MajorForm(X) == ROW_MAJOR)
- b_qsort_matrix_rows_descending_real(pElementM(X),ColM(X),RowM(X),0,ColM(X)-1,i*RowM(X));
- else
- b_qsort_matrix_columns_descending_real(pElementM(X),RowM(X),ColM(X),i);
- return X;
-}
-
-/*
- Assumes
- x : m vector or null
- y : m vector
-
- Results
- The vector x is sorted in ascending order. The vector x is created if
- null.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x and x do not have to be distinct vectors. Uses the quick sort algorithm,
-*/
-TVector SortVectorAscending(TVector x, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if ((x != x) && !(x=EquateVector(x,y)))
- return (TVector)NULL;
- b_qsort_array_ascending_real(pElementV(x),DimV(x));
- return x;
-}
-
-/*
- Assumes
- x : m vector or null
- y : m vector
-
- Results
- The vector x is sorted in descending order. The vector x is created if
- null.
-
- Returns
- Returns x upon success and null on failure. Call GetError() to
- determine the cause of failure.
-
- Notes
- x and x do not have to be distinct vectors. Uses the quick sort algorithm,
-*/
-TVector SortVectorDescending(TVector x, TVector y)
-{
- if (!y)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- if ((x != x) && !(x=EquateVector(x,y)))
- return (TVector)NULL;
- b_qsort_array_descending_real(pElementV(x),DimV(x));
- return x;
-}
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-/*
- Assumes:
- x - array of length m
-
- Results:
- x is sorted in ascending order
-
- Notes:
- Uses the quick sort mean algorithm. Switches to insertion sort when the
- size of the list is 10 or less.
-*/
-static void b_qsort_array_ascending_real(PRECISION *x, int m)
-{
- PRECISION y, c;
- int j, k;
- if (m > 10)
- {
- // quick sort
- m--;
-
- if (x[0] == x[m])
- c=x[0];
- else
- {
- if (x[0] > x[m])
- { y=x[m]; x[m]=x[0]; x[0]=y; }
- c=0.5*(x[0] + x[m]);
- }
-
- for (j=1; (j < m) && (x[j] <= c); j++);
- for (k=m-1; (k > 0) && (x[k] >= c); k--);
- while (j < k)
- {
- y=x[j]; x[j]=x[k]; x[k]=y;
- while (x[j] <= c) j++;
- while (x[k] >= c) k--;
- }
- if (k > 0)
- b_qsort_array_ascending_real(x,k+1);
- if (j < m)
- b_qsort_array_ascending_real(x+j,m-j+1);
- }
- else
- {
- // insertion sort
- for (j=1; j < m; j++)
- {
- y=x[j];
- for (k=j-1; k >= 0; k--)
- if (x[k] <= y)
- break;
- else
- x[k+1]=x[k];
- x[k+1]=y;
- }
- }
-}
-
-/*
- Assumes:
- x - array of length m
-
- Results:
- x is sorted in descending order
-
- Notes:
- Uses the quick sort mean algorithm. Switches to insertion sort when the
- size of the list is 10 or less.
-*/
-static void b_qsort_array_descending_real(PRECISION *x, int m)
-{
- PRECISION y, c;
- int j, k;
- if (m > 10)
- {
- // quick sort
- m--;
-
- if (x[0] == x[m])
- c=x[0];
- else
- {
- if (x[0] < x[m])
- { y=x[m]; x[m]=x[0]; x[0]=y; }
- c=0.5*(x[0] + x[m]);
- }
-
- for (j=1; (j < m) && (x[j] >= c); j++);
- for (k=m-1; (k > 0) && (x[k] <= c); k--);
- while (j < k)
- {
- y=x[j]; x[j]=x[k]; x[k]=y;
- while (x[j] >= c) j++;
- while (x[k] <= c) k--;
- }
- if (k > 0)
- b_qsort_array_descending_real(x,k+1);
- if (j < m)
- b_qsort_array_descending_real(x+j,m-j+1);
- }
- else
- {
- // insertion sort
- for (j=1; j < m; j++)
- {
- y=x[j];
- for (k=j-1; k >= 0; k--)
- if (x[k] >= y)
- break;
- else
- x[k+1]=x[k];
- x[k+1]=y;
- }
- }
-
-}
-
-/*
- Assumes:
- x - array of length m*n in colum major format.
- m - number of rows
- n - number of columns
-
- Results:
- The columns of x are sorted in ascending order on row idx.
-
- Notes:
- Uses the quick sort mean algorithm. Switches to insertion sort when the
- size of the list is 10 or less. If the matrix is in row major format, then
- m is the number of columns, n is the number of rows, and the rows of x are
- sorted in ascending order on column idx.
-*/
-static void b_qsort_matrix_columns_ascending_real(PRECISION *x, int m, int n, int idx)
-{
- PRECISION *y, c;
- int j, k, p, s;
- y=(PRECISION*)malloc(s=m*sizeof(PRECISION));
- if (n > 10)
- {
- // quick sort
- p=(n-1)*m;
- k=p+idx;
-
- if (x[idx] == x[k])
- c=x[idx];
- else
- {
- if (x[idx] > x[k])
- { memcpy(y,x+p,s); memcpy(x+p,x,s); memcpy(x,y,s); }
- c=0.5*(x[idx] + x[k]);
- }
-
- for (j=m+idx; (j < p) && (x[j] <= c); j+=m);
- for (k-=m; (k > idx) && (x[k] >= c); k-=m);
- while (j < k)
- {
- memcpy(y,x+j-idx,s); memcpy(x+j-idx,x+k-idx,s); memcpy(x+k-idx,y,s);
- while (x[j] <= c) j+=m;
- while (x[k] >= c) k-=m;
- }
- if (k > idx)
- b_qsort_matrix_columns_ascending_real(x,m,(k-idx)/m+1,idx);
- if (j < p)
- b_qsort_matrix_columns_ascending_real(x+j-idx,m,n-(j-idx)/m,idx);
- }
- else
- {
- // insertion sort
- p=n*m;
- for (j=m+idx; j < p; j+=m)
- if (x[j-m] > x[j])
- {
- memcpy(y,x+j-idx,s);
- memcpy(x+j-idx,x+j-m-idx,s);
- for (k=j-m-m; k >= 0; k-=m)
- if (x[k] <= y[idx])
- break;
- else
- memcpy(x+k+m-idx,x+k-idx,s);
- memcpy(x+k+m-idx,y,s);
- }
- }
- free(y);
-}
-
-/*
- Assumes:
- x - array of length m*n in colum major format.
- m - number of rows
- n - number of columns
-
- Results:
- The columns of x are sorted in ascending order on row idx.
-
- Notes:
- Uses the quick sort mean algorithm. Switches to insertion sort when the
- size of the list is 10 or less. If the matrix is in row major format, then
- m is the number of columns, n is the number of rows, and the rows of x are
- sorted in ascending order on column idx.
-*/
-static void b_qsort_matrix_columns_descending_real(PRECISION *x, int m, int n, int idx)
-{
- PRECISION *y, c;
- int j, k, p, s;
- y=(PRECISION*)malloc(s=m*sizeof(PRECISION));
- if (n > 10)
- {
- // quick sort
- p=(n-1)*m;
- k=p+idx;
-
- if (x[idx] == x[k])
- c=x[idx];
- else
- {
- if (x[idx] < x[k])
- { memcpy(y,x+p,s); memcpy(x+p,x,s); memcpy(x,y,s); }
- c=0.5*(x[idx] + x[k]);
- }
-
- for (j=m+idx; (j < p) && (x[j] >= c); j+=m);
- for (k-=m; (k > idx) && (x[k] <= c); k-=m);
- while (j < k)
- {
- memcpy(y,x+j-idx,s); memcpy(x+j-idx,x+k-idx,s); memcpy(x+k-idx,y,s);
- while (x[j] >= c) j+=m;
- while (x[k] <= c) k-=m;
- }
- if (k > idx)
- b_qsort_matrix_columns_descending_real(x,m,(k-idx)/m+1,idx);
- if (j < p)
- b_qsort_matrix_columns_descending_real(x+j-idx,m,n-(j-idx)/m,idx);
- }
- else
- {
- // insertion sort
- p=n*m;
- for (j=m+idx; j < p; j+=m)
- if (x[j-m] < x[j])
- {
- memcpy(y,x+j-idx,s);
- memcpy(x+j-idx,x+j-m-idx,s);
- for (k=j-m-m; k >= 0; k-=m)
- if (x[k] >= y[idx])
- break;
- else
- memcpy(x+k+m-idx,x+k-idx,s);
- memcpy(x+k+m-idx,y,s);
- }
- }
- free(y);
-}
-
-/*
- Assumes:
- x - array of length m*n in colum major format.
- m - number of rows
- n - number of columns
- br - first row in block to sort
- er - last row in block to sort to sort
- idx - idx/m is column to sort
-
- Results:
- The rows of x are sorted in ascending order on column idx/m.
-
- Notes:
- Uses the quick sort mean algorithm. Switches to insertion sort when the
- size of the list is 10 or less. If the matrix is in row major format, then
- m is the number of columns, n is the number of rows, and the columns of x
- are sorted in ascending order on row idx.
-*/
-static void b_qsort_matrix_rows_ascending_real(PRECISION *x, int m, int n, int br, int er, int idx)
-{
- PRECISION y, c;
- int i, j, k;
- if (er-br+1 > 10)
- {
- // quick sort
- if (x[idx+br] == x[idx+er])
- c=x[idx+br];
- else
- {
- if (x[idx+br] > x[idx+er])
- for (i=(n-1)*m; i >= 0; i-=m)
- { y=x[i+br]; x[i+br]=x[i+er]; x[i+er]=y; }
- c=0.5*(x[idx+br] + x[idx+er]);
- }
-
- for (j=br+1; (j < er) && (x[idx+j] <= c); j++);
- for (k=er-1; (k > br) && (x[idx+k] >= c); k--);
- while (j < k)
- {
- for (i=(n-1)*m; i >= 0; i-=m)
- { y=x[i+j]; x[i+j]=x[i+k]; x[i+k]=y; }
- while (x[idx+j] <= c) j++;
- while (x[idx+k] >= c) k--;
- }
- if (k > br)
- b_qsort_matrix_rows_ascending_real(x,m,n,br,k,idx);
- if (j < er)
- b_qsort_matrix_rows_ascending_real(x,m,n,j,er,idx);
- }
- else
- {
- // insertion sort
- int r;
- for (j=br+1; j <= er; j++)
- {
- for (k=j-1; k >= br; k--)
- if (x[idx+k] <= x[idx+j]) break;
- if (++k < j)
- for (i=(n-1)*m; i >= 0; i-=m)
- {
- y=x[i+j];
- for (r=j; r > k; r--) x[i+r]=x[i+r-1];
- x[i+k]=y;
- }
- }
- }
-}
-
-/*
- Assumes:
- x - array of length m*n in colum major format.
- m - number of rows
- n - number of columns
- br - first row in block to sort
- er - last row in block to sort to sort
- idx - idx/m is column to sort
-
- Results:
- The rows of x are sorted in ascending order on column idx/m.
-
- Notes:
- Uses the quick sort mean algorithm. Switches to insertion sort when the
- size of the list is 10 or less. If the matrix is in row major format, then
- m is the number of columns, n is the number of rows, and the columns of x
- are sorted in ascending order on row idx.
-*/
-static void b_qsort_matrix_rows_descending_real(PRECISION *x, int m, int n, int br, int er, int idx)
-{
- PRECISION y, c;
- int i, j, k;
- if (er-br+1 > 10)
- {
- // quick sort
- if (x[idx+br] == x[idx+er])
- c=x[idx+br];
- else
- {
- if (x[idx+br] < x[idx+er])
- for (i=(n-1)*m; i >= 0; i-=m)
- { y=x[i+br]; x[i+br]=x[i+er]; x[i+er]=y; }
- c=0.5*(x[idx+br] + x[idx+er]);
- }
-
- for (j=br+1; (j < er) && (x[idx+j] >= c); j++);
- for (k=er-1; (k > br) && (x[idx+k] <= c); k--);
- while (j < k)
- {
- for (i=(n-1)*m; i >= 0; i-=m)
- { y=x[i+j]; x[i+j]=x[i+k]; x[i+k]=y; }
- while (x[idx+j] >= c) j++;
- while (x[idx+k] <= c) k--;
- }
- if (k > br)
- b_qsort_matrix_rows_descending_real(x,m,n,br,k,idx);
- if (j < er)
- b_qsort_matrix_rows_descending_real(x,m,n,j,er,idx);
- }
- else
- {
- // insertion sort
- int r;
- for (j=br+1; j <= er; j++)
- {
- for (k=j-1; k >= br; k--)
- if (x[idx+k] >= x[idx+j]) break;
- if (++k < j)
- for (i=(n-1)*m; i >= 0; i-=m)
- {
- y=x[i+j];
- for (r=j; r > k; r--) x[i+r]=x[i+r-1];
- x[i+k]=y;
- }
- }
- }
-}
-
-/*
- Assumes:
- x - array of length m
-
- Results:
- x is sorted in ascending order
-
- Notes:
- Uses the quick sort median of three algorithm
-*/
-static void b_median_qsort_array_ascending(PRECISION *x, int m)
-{
- PRECISION y;
- int j, k;
- if (m > 10)
- {
- // Quick sort
- j=(m--)/2;
-
- y=x[j]; x[j]=x[1]; x[1]=y;
-
- if (x[1] > x[m])
- if (x[0] > x[m])
- if (x[0] > x[1])
- { y=x[0]; x[0]=x[m]; x[m]=y; }
- else
- { y=x[0]; x[0]=x[m]; x[m]=x[1]; x[1]=y; }
- else
- { y=x[1]; x[1]=x[m]; x[m]=y; }
- else
- if (x[0] > x[1])
- if (x[0] > x[m])
- { y=x[0]; x[0]=x[1]; x[1]=x[m]; x[m]=y; }
- else
- { y=x[0]; x[0]=x[1]; x[1]=y; };
-
-
- for (j=2; (j < m) && (x[j] <= x[1]); j++);
- for (k=m-1; (k > 1) && (x[k] >= x[1]); k--);
- while (j < k)
- {
- y=x[j]; x[j]=x[k]; x[k]=y;
- while (x[j] <= x[1]) j++;
- while (x[k] >= x[1]) k--;
- }
- if (k > 1)
- {
- y=x[k]; x[k]=x[1]; x[1]=y;
- b_median_qsort_array_ascending(x,k);
- }
- if (j < m)
- b_median_qsort_array_ascending(x+j,m-j+1);
- }
- else
- {
- // Insertion sort
- for (j=1; j < m; j++)
- {
- for (k=j-1; k >= 0; k--)
- if (x[j] >= x[k]) break;
- if (++k < j)
- {
- y=x[j];
- memmove(x+k+1,x+k,(j-k)*sizeof(PRECISION));
- x[k]=y;
- }
- }
- }
-}
diff --git a/matlab/swz/c-code/utilities/DWCcode/sort/dw_matrix_sort.h b/matlab/swz/c-code/utilities/DWCcode/sort/dw_matrix_sort.h
deleted file mode 100644
index 0beb5a8ac51ce869251619eaf43f9fea41f395b3..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/sort/dw_matrix_sort.h
+++ /dev/null
@@ -1,14 +0,0 @@
-
-#ifndef __SORT_MATRICES__
-#define __SORT_MATRICES__
-
-#include "matrix.h"
-
-TVector SortVectorAscending(TVector x, TVector y);
-TVector SortVectorDescending(TVector x, TVector y);
-TMatrix SortMatrixRowsAscending(TMatrix X, TMatrix Y, int j);
-TMatrix SortMatrixRowsDescending(TMatrix X, TMatrix Y, int j);
-TMatrix SortMatrixColumnsAscending(TMatrix X, TMatrix Y, int i);
-TMatrix SortMatrixColumnsDescending(TMatrix X, TMatrix Y, int i);
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/spherical/spherical.c b/matlab/swz/c-code/utilities/DWCcode/spherical/spherical.c
deleted file mode 100644
index 5ad4dfb25c25a8442913a0653bc5a4451172545d..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/spherical/spherical.c
+++ /dev/null
@@ -1,416 +0,0 @@
-
-#include "spherical.h"
-#include "dw_rand.h"
-#include "dw_matrix_rand.h"
-#include "dw_error.h"
-#include "dw_ascii.h"
-
-#include <math.h>
-#include <stdlib.h>
-#include <string.h>
-
-#define SPHERICAL_GAUSSIAN 1
-#define SPHERICAL_UNIFORM 2
-#define SPHERICAL_POWER 3
-#define SPHERICAL_TRUNCATED_POWER 4
-#define SPHERICAL_TABLE 5
-#define SPHERICAL_TRUNCATED_GAUSSIAN 6
-
-#define PI 3.141592653589793
-
-static int SPHERICAL_TYPE=0;
-static int SPHERICAL_DIM=0;
-static PRECISION SPHERICAL_CONSTANT=0.0;
-
-static PRECISION SPHERICAL_POWER_EXP=0.0;
-static PRECISION SPHERICAL_LOWER_TRUNCATE=0.0;
-static PRECISION SPHERICAL_UPPER_TRUNCATE=0.0;
-
-static PRECISION *SPHERICAL_TABLE_VALUES=(PRECISION*)NULL;
-static int SPHERICAL_TABLE_LENGTH=0;
-
-/*
- Returns ln(exp(a) + exp(b)) computed to avoid overflow. If
- a = ln(c) and b = ln(d), as is usually the case, then the
- routine returns ln(c + d).
-
-*/
-static PRECISION AddLogs_static(PRECISION a, PRECISION b)
-{
- return (a > b) ? a + log(1.0 + exp(b-a)) : b + log(exp(a-b) + 1.0);
-}
-
-char* SphericalType(void)
-{
- static char buffer[128];
- switch (SPHERICAL_TYPE)
- {
- case SPHERICAL_GAUSSIAN:
- return "Gaussian";
- case SPHERICAL_UNIFORM:
- return "Uniform";
- case SPHERICAL_POWER:
- sprintf(buffer,"Power(%lg)",SPHERICAL_POWER_EXP);
- return buffer;
- case SPHERICAL_TRUNCATED_POWER:
- sprintf(buffer,"TruncatedPower(%lg,%lg)",SPHERICAL_POWER_EXP,SPHERICAL_LOWER_TRUNCATE);
- return buffer;
- case SPHERICAL_TABLE:
- sprintf(buffer,"Table(%d)",SPHERICAL_TABLE_LENGTH);
- return buffer;
- case SPHERICAL_TRUNCATED_GAUSSIAN:
- sprintf(buffer,"TruncatedGaussian(%lg,%lg)",SPHERICAL_LOWER_TRUNCATE,SPHERICAL_UPPER_TRUNCATE);
- return buffer;
- default:
- return "Spherical type not set";
- }
-}
-
-void SetupSpherical_Gaussian(int n)
-{
- SPHERICAL_TYPE=SPHERICAL_GAUSSIAN;
- SPHERICAL_DIM=n;
- SPHERICAL_CONSTANT=-0.5*n*log(2.0*PI);
-}
-
-void SetupSpherical_TruncatedGaussian(int n, PRECISION r1, PRECISION r2)
-{
- SPHERICAL_TYPE=SPHERICAL_TRUNCATED_GAUSSIAN;
- SPHERICAL_DIM=n;
- SPHERICAL_CONSTANT=-0.5*n*log(2.0*PI) - log(dw_chi_square_cdf(r2*r2,n) - dw_chi_square_cdf(r1*r1,n));
- SPHERICAL_LOWER_TRUNCATE=r1;
- SPHERICAL_UPPER_TRUNCATE=r2;
-}
-
-void SetupSpherical_Uniform(int n)
-{
- SPHERICAL_TYPE=SPHERICAL_UNIFORM;
- SPHERICAL_DIM=n;
- SPHERICAL_CONSTANT=log(0.5*n) + dw_log_gamma(0.5*n) - 0.5*n*log(PI);
-}
-
-/*
- See the function PowerUnitBall() below for the description of the
- distribution.
-*/
-void SetupSpherical_Power(int n, PRECISION k)
-{
- SPHERICAL_TYPE=SPHERICAL_POWER;
- SPHERICAL_DIM=n;
- SPHERICAL_CONSTANT=log(0.5*k) + dw_log_gamma(0.5*n) - 0.5*n*log(PI);
- SPHERICAL_POWER_EXP=k;
-}
-
-void SetupSpherical_TruncatedPower(int n, PRECISION k, PRECISION a)
-{
- SPHERICAL_TYPE=SPHERICAL_TRUNCATED_POWER;
- SPHERICAL_DIM=n;
- SPHERICAL_CONSTANT=log(0.5*k/(1.0 - pow(a,k))) + dw_log_gamma(0.5*n) - 0.5*n*log(PI);
- SPHERICAL_POWER_EXP=k;
- SPHERICAL_LOWER_TRUNCATE=a;
-}
-
-void SetupSpherical_Table(int n, PRECISION *table, int m)
-{
- int i;
- SPHERICAL_TYPE=SPHERICAL_TABLE;
- SPHERICAL_DIM=n;
- SPHERICAL_CONSTANT=log(0.5) + dw_log_gamma(0.5*n) - 0.5*n*log(PI);
- if (SPHERICAL_TABLE_VALUES) free(SPHERICAL_TABLE_VALUES);
- SPHERICAL_TABLE_VALUES=(PRECISION*)malloc((m+1)*sizeof(PRECISION));
- SPHERICAL_TABLE_LENGTH=m;
- memcpy(SPHERICAL_TABLE_VALUES,table,(m+1)*sizeof(PRECISION));
-
- // Check
- if (SPHERICAL_TABLE_VALUES[0] != 0.0)
- {
- printf("First entry of inverse cumulative spherical table must be zero\n");
- exit(0);
- }
- for (i=1; i < SPHERICAL_TABLE_LENGTH; i++)
- if (SPHERICAL_TABLE_VALUES[i-1] >= SPHERICAL_TABLE_VALUES[i])
- {
- printf("Inverse cumulative spherical table must be strictly increasing\n");
- for (i=0; i <= m; i++) printf("%lf\n",table[i]);
- exit(0);
- }
-}
-
-PRECISION DrawSpherical(TVector x)
-{
- PRECISION r;
- switch (SPHERICAL_TYPE)
- {
- case SPHERICAL_GAUSSIAN:
- dw_NormalVector(x);
- return Norm(x);
- case SPHERICAL_UNIFORM:
- return UniformUnitBall(x);
- case SPHERICAL_POWER:
- return PowerUnitBall(x,SPHERICAL_POWER_EXP);
- case SPHERICAL_TRUNCATED_POWER:
- return TruncatedPowerUnitBall(x,SPHERICAL_POWER_EXP,SPHERICAL_LOWER_TRUNCATE);
- case SPHERICAL_TABLE:
- return SphericalTable(x,SPHERICAL_TABLE_VALUES,SPHERICAL_TABLE_LENGTH);
- case SPHERICAL_TRUNCATED_GAUSSIAN:
- do
- {
- dw_NormalVector(x);
- r=Norm(x);
- }
- while ((r < SPHERICAL_LOWER_TRUNCATE) || (SPHERICAL_UPPER_TRUNCATE < r));
- return r;
- default:
- fprintf(stderr,"Unknown spherical type\n");
- exit(0);
- }
-}
-
-PRECISION LogSphericalDensity(PRECISION r)
-{
- switch (SPHERICAL_TYPE)
- {
- case SPHERICAL_GAUSSIAN:
- return -0.5*r*r + SPHERICAL_CONSTANT;
- case SPHERICAL_UNIFORM:
- return (r > 1.0) ? MINUS_INFINITY : SPHERICAL_CONSTANT;
- case SPHERICAL_POWER:
- return (r > 1.0) ? MINUS_INFINITY : SPHERICAL_CONSTANT + (SPHERICAL_POWER_EXP - SPHERICAL_DIM)*log(r);
- case SPHERICAL_TRUNCATED_POWER:
- return ((r < SPHERICAL_LOWER_TRUNCATE) || (r > 1.0)) ? MINUS_INFINITY
- : SPHERICAL_CONSTANT + (SPHERICAL_POWER_EXP - SPHERICAL_DIM)*log(r);
- case SPHERICAL_TABLE:
- return SPHERICAL_CONSTANT - (SPHERICAL_DIM - 1)*log(r) + LogSphericalTableDensity(r,SPHERICAL_TABLE_VALUES,SPHERICAL_TABLE_LENGTH);
- case SPHERICAL_TRUNCATED_GAUSSIAN:
- return ((r < SPHERICAL_LOWER_TRUNCATE) || (r > SPHERICAL_UPPER_TRUNCATE)) ? MINUS_INFINITY : -0.5*r*r + SPHERICAL_CONSTANT;
- default:
- fprintf(stderr,"Unknown spherical type\n");
- exit(0);
- }
-}
-
-/*
- The ith entry of the returned vector is the cumulative density evaluated at
- (i + 1) * max / bins. The integer cum_bins controls the accuracy of the
- estimation. The larger the value, the more accuate the estimate.
-*/
-TVector SphericalCumulativeDensity(PRECISION max, int bins, int cum_bins)
-{
- TVector cumulative=CreateVector(bins);
- int i, j;
- PRECISION r, z, inc=max/(PRECISION)bins, cum_inc=inc/(PRECISION)cum_bins;
- for (i=0; i < bins; i++)
- {
- for (r=(PRECISION)i*inc + 0.5*cum_inc, z=MINUS_INFINITY, j=0; j < cum_bins; r+=cum_inc, j++)
- z=AddLogs_static(z,LogSphericalDensity(r) + (SPHERICAL_DIM - 1)*log(r));
- ElementV(cumulative,i)=exp(z - log(0.5) + 0.5*SPHERICAL_DIM*log(PI) - dw_log_gamma(0.5*SPHERICAL_DIM) + log(cum_inc));
- }
- for (i=1; i < bins; i++)
- ElementV(cumulative,i)+=ElementV(cumulative,i-1);
- return cumulative;
-}
-
-void TestSpherical(FILE *f, char *filename, PRECISION max)
-{
- TMatrix cumulative;
- TVector x;
- int i, j, bins=1000, cum_bins=20, ndraws=1000000;
- PRECISION r, z, inc=max/(PRECISION)bins, cum_inc=inc/(PRECISION)cum_bins, s=1.0/(PRECISION)ndraws;
- FILE *f_out;
-
- cumulative=CreateMatrix(bins,3);
- for (i=0; i < bins; i++)
- {
- ElementM(cumulative,i,0)=(PRECISION)(i+1)*inc;
- for (r=(PRECISION)i*inc + 0.5*cum_inc, z=MINUS_INFINITY, j=0; j < cum_bins; r+=cum_inc, j++)
- z=AddLogs_static(z,LogSphericalDensity(r) + (SPHERICAL_DIM - 1)*log(r));
- ElementM(cumulative,i,1)=exp(z - log(0.5) + 0.5*SPHERICAL_DIM*log(PI) - dw_log_gamma(0.5*SPHERICAL_DIM) + log(cum_inc));
- ElementM(cumulative,i,2)=0.0;
- }
-
- x=CreateVector(SPHERICAL_DIM);
- for (i=ndraws; i > 0; i--)
- {
- r=DrawSpherical(x);
- if ((j=(int)floor(r/inc)) < bins)
- ElementM(cumulative,j,2)+=s;
- }
- FreeVector(x);
-
- for (i=1; i < bins; i++)
- {
- ElementM(cumulative,i,1)+=ElementM(cumulative,i-1,1);
- ElementM(cumulative,i,2)+=ElementM(cumulative,i-1,2);
- }
-
- f_out=!f ? dw_CreateTextFile(filename) : f;
- dw_PrintMatrix(f_out,cumulative,"%lf,");
- if (!f) fclose(f_out);
- FreeMatrix(cumulative);
-}
-#undef PI
-
-#undef SPHERICAL_GAUSSIAN
-#undef SPHERICAL_UNIFORM
-#undef SPHERICAL_POWER
-#undef SPHERICAL_TURNCATED_POWER
-#undef SPHERICAL_TRUNCATED_GAUSSIAN
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*
- Assumes:
- x : m-vector
-
- Results:
- The vector x is filled with a vector drawn from the uniform distribution on
- the m dimensional solid unit sphere.
-
- Returns:
- Upon success, returns the norm of x, upon failure returns negative value.
-
- Notes:
- The vector is drawn by drawing a m-vector from the standard normal
- distribution and a real number u from the uniform distribution on [0,1], and
- normalizing the vector so its length equal to u^(1/m).
-*/
-PRECISION UniformUnitBall(TVector x)
-{
- PRECISION r, s;
- if (!x)
- {
- dw_Error(NULL_ERR);
- return -1.0;
- }
-
- do
- dw_NormalVector(x);
- while ((s=Norm(x)) == 0.0);
-
- ProductSV(x,(r=pow(dw_uniform_rnd(),1.0/DimV(x)))/s,x);
-
- return r;
-}
-
-/*
- Assumes:
- x : n-vector
-
- Results:
- The vector x is filled with a vector drawn from the distribution
-
- 0.5 * k * Gamma(n/2) * pi^(-n/2) * norm(x)^(k-n)
-
- Returns:
- norm(x) upon success and a negative value upon failure.
-
- Notes:
- If x is obtained by drawing y from the standard n-dimensional Gaussian
- distribtuion and r from the distribution on [0,1] with density
-
- k * r^(k-1)
-
- Since the cumulative density of r is
-
- r^k
-
- a draw of r can be obtained by drawing u from the uniform on [0,1] and
- defining r = u^(1/k). This assumes that k > 0.
-*/
-PRECISION PowerUnitBall(TVector x, PRECISION k)
-{
- PRECISION r, s;
- if (!x)
- {
- dw_Error(NULL_ERR);
- return -1.0;
- }
-
- do
- dw_NormalVector(x);
- while ((s=Norm(x)) == 0.0);
-
- ProductSV(x,(r=pow(dw_uniform_rnd(),1.0/k))/s,x);
-
- return r;
-}
-
-/*
- Assumes:
- x : n-vector
-
- Results:
- The vector x is filled with a vector drawn from the distribution
-
- 0.5 * k * Gamma(n/2) * pi^(-n/2) * norm(x)^(k-n) / (1 - a^k)
-
- Returns:
- norm(x) upon success and a negative value upon failure.
-
- Notes:
- If x is obtained by drawing y from the standard n-dimensional Gaussian
- distribtuion and r from the distribution on [a,1] with density
-
- k * r^(k-1) / (1 - a^k)
-
- Since the cumulative density of r is
-
- (r^k - a^k) / (1 - a^k)
-
- a draw of r can be obtained by drawing u from the uniform on [0,1] and
- defining r = (u(1-a^k) + a^k)^(1/k). This assumes that k > 0.
-*/
-PRECISION TruncatedPowerUnitBall(TVector x, PRECISION k, PRECISION a)
-{
- PRECISION r, s, t;
- if (!x)
- {
- dw_Error(NULL_ERR);
- return -1.0;
- }
-
- do
- dw_NormalVector(x);
- while ((s=Norm(x)) == 0.0);
-
- t=pow(a,k);
- ProductSV(x,(r=pow(dw_uniform_rnd()*(1.0 - t) + t,1.0/k))/s,x);
-
- return r;
-}
-
-
-PRECISION SphericalTable(TVector x, PRECISION *table, int m)
-{
- PRECISION r, s;
- int i, j;
- if (!x)
- {
- dw_Error(NULL_ERR);
- return -1.0;
- }
-
- do
- dw_NormalVector(x);
- while ((s=Norm(x)) == 0.0);
-
- j=(int)floor(dw_uniform_rnd()*(PRECISION)m);
- r=(j < m) ? table[j] + dw_uniform_rnd()*(table[j+1] - table[j]) : table[m];
- ProductSV(x,r/s,x);
-
- return r;
-}
-
-PRECISION LogSphericalTableDensity(PRECISION r, PRECISION *table, int m)
-{
- int min=0, max=m, mid;
- if (r > table[m]) return MINUS_INFINITY;
- while (max - min > 1)
- if (r > table[mid=(min + max)/2])
- min=mid;
- else
- max=mid;
- return -log((PRECISION)m*(table[max] - table[min]));
-}
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/spherical/spherical.h b/matlab/swz/c-code/utilities/DWCcode/spherical/spherical.h
deleted file mode 100644
index df4db59a1af31ae811501f0e86ddfdfafaec1748..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/spherical/spherical.h
+++ /dev/null
@@ -1,23 +0,0 @@
-
-#include "matrix.h"
-
-char* SphericalType(void);
-void SetupSpherical_Gaussian(int n);
-void SetupSpherical_Uniform(int n);
-void SetupSpherical_Power(int n, PRECISION k);
-void SetupSpherical_TruncatedPower(int n, PRECISION k, PRECISION a);
-void SetupSpherical_Table(int n, PRECISION *table, int m);
-void SetupSpherical_TruncatedGaussian(int n, PRECISION r1, PRECISION r2);
-
-PRECISION DrawSpherical(TVector x);
-PRECISION LogSphericalDensity(PRECISION r);
-TVector SphericalCumulativeDensity(PRECISION max, int bins, int cum_bins);
-
-void TestSpherical(FILE *f, char *filename, PRECISION max);
-
-PRECISION UniformUnitBall(TVector x);
-PRECISION PowerUnitBall(TVector x, PRECISION k);
-PRECISION TruncatedPowerUnitBall(TVector x, PRECISION k, PRECISION a);
-PRECISION SphericalTable(TVector x, PRECISION *table, int m);
-PRECISION LogSphericalTableDensity(PRECISION r, PRECISION *table, int m);
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/stat/dw_matrix_rand.c b/matlab/swz/c-code/utilities/DWCcode/stat/dw_matrix_rand.c
deleted file mode 100644
index a18be44347deda527a89fd9aec7337cb9a762190..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/stat/dw_matrix_rand.c
+++ /dev/null
@@ -1,283 +0,0 @@
-
-#include "dw_matrix_rand.h"
-#include "dw_rand.h"
-#include "dw_error.h"
-
-#include <math.h>
-
-
-/******************************************************************************/
-/************************ Random Matrices and Vectors *************************/
-/******************************************************************************/
-/*
- Assumes
- x : m-vector
-
- Results
- Fills x with deviates drawn from the uniform distribution on [0,1]
-*/
-TVector dw_UniformVector(TVector x)
-{
- int i;
- if (!x) { dw_Error(NULL_ERR); return (TVector)NULL; }
- for (i=DimV(x)-1; i >= 0; i--) ElementV(x,i)=dw_uniform_rnd();
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix
-
- Results
- Fills X with deviates drawn from the uniform distribution on [0,1]
-*/
-TMatrix dw_UniformMatrix(TMatrix X)
-{
- int i;
- PRECISION *pX;
- if (!X) { dw_Error(NULL_ERR); return (TMatrix)NULL; }
- for (pX=pElementM(X), i=RowM(X)*ColM(X)-1; i >= 0; i--) pX[i]=dw_uniform_rnd();
- return X;
-}
-
-/*
- Assumes
- x : m-vector
-
- Results
- Fills x with independent standard normal deviates
-*/
-TVector dw_NormalVector(TVector x)
-{
- int i;
- if (!x) { dw_Error(NULL_ERR); return (TVector)NULL; }
- for (i=DimV(x)-1; i >= 0; i--) ElementV(x,i)=dw_gaussian_rnd();
- return x;
-}
-
-/*
- Assumes
- X : m x n matrix
-
- Results
- Fills X with independent standard normal deviates
-*/
-TMatrix dw_NormalMatrix(TMatrix X)
-{
- int i;
- PRECISION *pX;
- if (!X) { dw_Error(NULL_ERR); return (TMatrix)NULL; }
- for (pX=pElementM(X), i=RowM(X)*ColM(X)-1; i >= 0; i--) pX[i]=dw_gaussian_rnd();
- return X;
-}
-
-
-/*
- Assumes
- x : m-vector
-
- Results
- Fills x with independent log normal deviates. The mean and standard
- deviation of the underlying normal distribution are passed.
-*/
-TVector dw_LogNormalVector(TVector x, PRECISION mean, PRECISION standard_deviation)
-{
- int i;
- if (!x) { dw_Error(NULL_ERR); return (TVector)NULL; }
- for (i=DimV(x)-1; i >= 0; i--) ElementV(x,i)=dw_lognormal_rnd(mean,standard_deviation);
- return x;
-}
-
-/*
- Computes a matrix of gamma deviates. If x, a, and b represent X(i,j),
- A(i,j), and B(i,j), then density of x is
-
- x^(a-1) exp(-x/b)
- ------------------
- gamma(a) b^a
-
-*/
-TMatrix dw_GammaMatrix(TMatrix X, TMatrix A, TMatrix B)
-{
- int i;
- PRECISION *pX, *pA, *pB;
- if (!A || !B)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if ((RowM(A) != RowM(B)) || (ColM(A) != ColM(B)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- if (!X)
- {
- if (!(X=CreateMatrix(RowM(A),ColM(A))))
- return (TMatrix)NULL;
- }
- else
- if ((RowM(X) != RowM(A)) || (ColM(X) != ColM(A)))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
- for (pX=pElementM(X), pA=pElementM(A), pB=pElementM(B), i=RowM(X)*ColM(X)-1; i >= 0; i--)
- pX[i]=pB[i]*dw_gamma_rnd(pA[i]);
- return X;
-}
-
-
-/*
- Assumes
- X : m x m matrix
- S : m x m non-singular matrix
-
- Results
- X is drawn from the Wishart distribution with parameters sigma, nu, and m,
- where sigma=Inverse(S'S). The pdf of X is proportional to
-
- |det(X)|^(0.5*(nu - m - 1))
- ---------------------------- * exp(-0.5*tr(Inverse(sigma*X))
- |det(sigma)|^(0.5*nu)
-
-
- = |det(X)|^(0.5*(nu - m - 1)) |det(S)|^(0.5*nu) exp(-0.5*tr(S'*X*S))
-*/
-TMatrix dw_Wishart(TMatrix X, TMatrix S, int nu)
-{
- int m=RowM(S);
- TMatrix Z;
-
- if ((m != ColM(S)) || (m != RowM(X)) || (m != ColM(X))) dw_Error(SIZE_ERR);
-
- Z=dw_NormalMatrix(CreateMatrix(m,nu));
- ProductMM(Z,S,Z);
- ProductTransposeMM(X,Z,Z);
- FreeMatrix(Z);
- return X;
-}
-
-/*
- Assumes
- x : n x n matrix
- T : n x n upper triangular matrix
-
- Results
- x is drawn from the multivariate student-t distribution with parameters.
- The pdf of x is given by
-*/
-TVector dw_StudentT(TVector x, TMatrix T, int nu)
-{
- PRECISION r=0.0, s;
- int i, n=DimV(x);
- if ((n != ColM(T)) || (n != RowM(T))) dw_Error(SIZE_ERR);
- dw_NormalVector(x);
- ProductMV(x,T,x);
- for (i=nu; i > 0; i--)
- {
- s=dw_gaussian_rnd();
- r+=s*s;
- }
- ProductSV(x,sqrt((PRECISION)nu/r),x);
- return x;
-}
-
-TMatrix dw_UniformOrthogonal(TMatrix Q)
-{
- TMatrix X;
- int i, j, err;
-
- if (!Q)
- {
- dw_Error(NULL_ERR);
- return (TMatrix)NULL;
- }
- if (RowM(Q) != ColM(Q))
- {
- dw_Error(SIZE_ERR);
- return (TMatrix)NULL;
- }
-
- /* Uncomment to use IMSL implementation */
- //imsls_d_random_orthogonal_matrix(RowM(Q),IMSLS_RETURN_USER,pElementM(Q),0);
- /**/
-
-
- /* Uncomment to use C code implementation */
- X=dw_NormalMatrix(CreateMatrix(RowM(Q),ColM(Q)));
- if (!(err=QR(Q,X,X)))
- for (i=RowM(X)-1; i >= 0; i--)
- if (ElementM(X,i,i) < 0)
- for (j=RowM(Q)-1; j >= 0; j--) ElementM(Q,j,i)=-ElementM(Q,j,i);
- FreeMatrix(X);
- if (err) return (TMatrix)NULL;
- /**/
-
- return Q;
-}
-
-/*
- Assumes:
- x : m-vector
-
- Results:
- The vector x is filled with a vector drawn from the uniform distribution on
- the m-1 dimensional unit sphere.
-
- Returns:
- The vector x.
-
- Notes:
- The vector is obtained by drawing a m-vector from the standard normal
- distribution and then normalizing its length to one.
-*/
-TVector dw_UniformUnitSphere(TVector x)
-{
- PRECISION r;
- if (!x)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- do
- dw_NormalVector(x);
- while ((r=Norm(x)) == 0.0);
- return ProductSV(x,1.0/r,x);
-}
-
-
-/*
- Assumes:
- x : m-vector
-
- Results:
- The vector x is filled with a vector drawn from the uniform distribution on
- the m dimensional solid unit sphere.
-
- Returns:
- Upon success, returns the norm of x, upon failure returns -1.0.
-
- Notes:
- The vector is drawn by drawing a m-vector from the standard normal
- distribution and a real number u from the uniform distribution on [0,1], and
- normalizing the vector so its length equal to u^(1/m).
-*/
-TVector dw_UniformUnitBall(TVector x)
-{
- PRECISION r, s;
- if (!x)
- {
- dw_Error(NULL_ERR);
- return (TVector)NULL;
- }
- do
- dw_NormalVector(x);
- while ((s=Norm(x)) == 0.0);
- ProductSV(x,(r=pow(dw_uniform_rnd(),1.0/DimV(x)))/s,x);
- return x;
-}
-
-/******************************************************************************/
-/******************************************************************************/
-
diff --git a/matlab/swz/c-code/utilities/DWCcode/stat/dw_matrix_rand.h b/matlab/swz/c-code/utilities/DWCcode/stat/dw_matrix_rand.h
deleted file mode 100644
index c70d30814a078b76a89361a146af2fed857d15ce..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/stat/dw_matrix_rand.h
+++ /dev/null
@@ -1,20 +0,0 @@
-
-#ifndef __RANDOM_MATRIX__
-#define __RANDOM_MATRIX__
-
-#include "matrix.h"
-
-/* Random Matrices and Vectors */
-TVector dw_UniformVector(TVector x);
-TMatrix dw_UniformMatrix(TMatrix X);
-TVector dw_NormalVector(TVector x);
-TMatrix dw_NormalMatrix(TMatrix X);
-TVector dw_LogNormalVector(TVector x, PRECISION mean, PRECISION standard_deviation);
-TMatrix dw_GammaMatrix(TMatrix X, TMatrix A, TMatrix B);
-TMatrix dw_Wishart(TMatrix X, TMatrix S, int nu);
-TVector dw_StudentT(TVector x, TMatrix T, int nu);
-TMatrix dw_UniformOrthogonal(TMatrix Q);
-TVector dw_UniformUnitSphere(TVector x);
-TVector dw_UniformUnitBall(TVector x);
-
-#endif
diff --git a/matlab/swz/c-code/utilities/DWCcode/stat/dw_rand.c b/matlab/swz/c-code/utilities/DWCcode/stat/dw_rand.c
deleted file mode 100644
index db1f7e5c27ffd0a48defcbf09bc6d39407d72854..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/stat/dw_rand.c
+++ /dev/null
@@ -1,643 +0,0 @@
-
-#include <math.h>
-#include <time.h>
-#include <stdlib.h>
-#include <memory.h>
-#include <limits.h>
-#include "prcsn.h"
-#include "dw_rand.h"
-#include "dw_error.h"
-
-//=== Static routines ===
-static void gser(PRECISION *gamser, PRECISION a, PRECISION x, PRECISION *gln);
-static void gcf(PRECISION *gammcf, PRECISION a, PRECISION x, PRECISION *gln);
-static PRECISION gammp(PRECISION a, PRECISION x);
-
-/*******************************************************************************/
-/*************************** Uniform Random Numbers ****************************/
-/*******************************************************************************/
-/*
- Flag controling which uniform random number to choose
-*/
-//#define USE_NR1_RNG
-#define USE_NR2_RNG
-//#define USE_IMSL_RNG
-
-#if defined (USE_IMSL_RNG)
-#include <imsls.h>
-#elif defined(USE_NR1_RNG)
-#define NTAB 32
-static int idum=-1;
-static int iy=0;
-static int iv[NTAB];
-#elif defined(USE_NR2_RNG)
-#define NTAB 32
-static int idum=-1;
-static int idum2=123456789;
-static int iy=0;
-static int iv[NTAB];
-#endif
-
-/*
- Initializes seed value for uniform random number generator. The seed value
- can be any integer. A value of 0 will initialize the seed from the system
- clock for the Numerical Recipies algorithms.
-*/
-void dw_initialize_generator(int init)
-{
-#ifdef USE_IMSL_RNG
- imsls_random_option(7);
- imsls_random_seed_set((init < 0) ? -init : init);
-#else
- if (init)
- idum=(init > 0) ? -init : init;
- else
- {
- idum=0;
- idum=(int)(-INT_MAX*dw_uniform_rnd());
- }
-#endif
-}
-
-/*
- Allocates memory and saves the state of the random number generator. The
- calling routine is responsible for freeing the returned memory.
-*/
-void* dw_get_generator_state(void)
-{
-#if defined(USE_IMSL_RNG)
- int *state=(int*)NULL;
- if (state=(int*)malloc(1566*sizeof(int)))
- {
- imsls_random_GFSR_table_get(&state,IMSLS_RETURN_USER,state,0);
- state[1565]=imsls_random_seed_get();
- }
- return state;
-#elif defined (USE_NR1_RNG)
- int *state=(int*)NULL;
- if (state=(int*)malloc((NTAB+2)*sizeof(int)))
- {
- memcpy(state,iv,NTAB*sizeof(int));
- state[NTAB]=iy;
- state[NTAB+1]=idum;
- }
- return state;
-#elif defined (USE_NR2_RNG)
- int *state=(int*)NULL;
- if (state=(int*)malloc((NTAB+3)*sizeof(int)))
- {
- memcpy(state,iv,NTAB*sizeof(int));
- state[NTAB]=iy;
- state[NTAB+1]=idum;
- state[NTAB+2]=idum2;
- }
- return state;
-#endif
-}
-
-/*
- Returns the size in bytes of the void pointer returned by
- dw_get_generator_state().
-*/
-int dw_get_generator_state_size(void)
-{
-#if defined(USE_IMSL_RNG)
- return 1566*sizeof(int);
-#elif defined (USE_NR1_RNG)
- return (NTAB+2)*sizeof(int);
-#elif defined (USE_NR2_RNG)
- return (NTAB+3)*sizeof(int);
-#endif
-}
-
-/*
- Sets the state of the random number generator. The void pointer must have
- been obtained via a call to dw_get_generator_state().
-*/
-void dw_set_generator_state(void *state)
-{
-#if defined(USE_IMSL_RNG)
- imsls_random_GFSR_table_set((int*)state);
- imsls_random_seed_set(((int*)state)[1565]);
-#elif defined (USE_NR1_RNG)
- memcpy(iv,state,NTAB*sizeof(int));
- iy=((int*)state)[NTAB];
- idum=((int*)state)[NTAB+1];
-#elif defined (USE_NR2_RNG)
- memcpy(iv,state,NTAB*sizeof(int));
- iy=((int*)state)[NTAB];
- idum=((int*)state)[NTAB+1];
- idum2=((int*)state)[NTAB+2];
-#endif
-}
-
-void dw_print_generator_state(FILE *f)
-{
- if (f)
- {
-#if defined(USE_IMSL_RNG)
- int i, *state;
- if (state=dw_get_generator_state())
- {
- for (i=0; i < 1566; i++) fprintf(f,"%d ",state[i]);
- fprintf(f,"\n");
- free(state);
- }
-#elif defined (USE_NR1_RNG)
- int i, *state;
- if (state=dw_get_generator_state())
- {
- for (i=0; i < NTAB+2; i++) fprintf(f,"%d ",state[i]);
- fprintf(f,"\n");
- free(state);
- }
-#elif defined (USE_NR2_RNG)
- int i, *state;
- if (state=dw_get_generator_state())
- {
- for (i=0; i < NTAB+3; i++) fprintf(f,"%d ",state[i]);
- fprintf(f,"\n");
- free(state);
- }
-#endif
- }
-}
-void dw_read_generator_state(FILE *f)
-{
- if (f)
- {
-#if defined(USE_IMSL_RNG)
- int i, *state;
- if (state=(int*)malloc(1566*sizeof(int)))
- {
- for (i=0; i < 1566; i++) fscanf(f," %d ",state+i);
- dw_set_generator_state(state);
- free(state);
- }
-#elif defined (USE_NR1_RNG)
- int i, *state;
- if (state=(int*)malloc((NTAB+2)*sizeof(int)))
- {
- for (i=0; i < NTAB+2; i++) fscanf(f," %d ",state+i);
- dw_set_generator_state(state);
- free(state);
- }
-#elif defined (USE_NR2_RNG)
- int i, *state;
- if (state=(int*)malloc((NTAB+3)*sizeof(int)))
- {
- for (i=0; i < NTAB+3; i++) fscanf(f," %d ",state+i);
- dw_set_generator_state(state);
- free(state);
- }
-#endif
- }
-}
-
-/*
- The following code is adapted from Numerical Recipes in C. This rnd1() from
- that text.
-*/
-#ifdef USE_NR1_RNG
-#define IA 16807
-#define IM 2147483647
-#define AM (1.0/IM)
-#define IQ 127773
-#define IR 2836
-#define NDIV (1+(IM-1)/NTAB)
-#define RNMX (1.0-MACHINE_EPSILON)
-PRECISION dw_uniform_rnd(void)
-{
- int j, k;
- PRECISION temp;
-
- if (idum <= 0)
- {
- if (idum == 0)
- {
- idum=abs((int)time((time_t *)NULL));
- if (idum == 0) idum=1;
- }
- else
- idum=-idum;
-
- for (j=NTAB+7; j >= 0; j--)
- {
- k=idum/IQ;
- idum=IA*(idum-k*IQ)-IR*k;
- if (idum < 0) idum+=IM;
- if (j < NTAB) iv[j]=idum;
- }
- iy=iv[0];
- }
- k=idum/IQ;
- idum=IA*(idum-k*IQ)-IR*k;
- if (idum < 0) idum+=IM;
- j=iy/NDIV;
- iy=iv[j];
- iv[j]=idum;
- return ((temp=(PRECISION)(AM*iy)) > RNMX) ? (PRECISION)RNMX : temp;
-}
-#undef IA
-#undef IM
-#undef AM
-#undef IQ
-#undef IR
-#undef NDIV
-#undef RNMX
-#endif
-
-/*
- The following code is adapted from Numerical Recipes in C. This rnd2() from
- that text.
-*/
-#ifdef USE_NR2_RNG
-#define IM1 2147483563
-#define IM2 2147483399
-#define AM (1.0/IM1)
-#define IMM1 (IM1-1)
-#define IA1 40014
-#define IA2 40692
-#define IQ1 53668
-#define IQ2 52774
-#define IR1 12211
-#define IR2 3791
-#define NDIV (1+IMM1/NTAB)
-#define RNMX (1.0-MACHINE_EPSILON)
-PRECISION dw_uniform_rnd(void)
-{
- int j, k;
- PRECISION temp;
-
- if (idum <= 0)
- {
- if (idum == 0)
- {
- idum=abs((int)time((time_t *)NULL));
- if (idum == 0) idum=1;
- }
- else
- idum=-idum;
-
- idum2=idum;
- for (j=NTAB+7; j>=0; j--)
- {
- k=idum/IQ1;
- idum=IA1*(idum-k*IQ1)-k*IR1;
- if (idum < 0) idum += IM1;
- if (j < NTAB) iv[j] = idum;
- }
- iy=iv[0];
- }
- k=idum/IQ1;
- idum=IA1*(idum-k*IQ1)-k*IR1;
- if (idum < 0) idum += IM1;
- k=idum2/IQ2;
- idum2=IA2*(idum2-k*IQ2)-k*IR2;
- if (idum2 < 0) idum2 += IM2;
- j=iy/NDIV;
- iy=iv[j]-idum2;
- iv[j] = idum;
- if (iy < 1) iy += IMM1;
- return ((temp=AM*iy) > RNMX) ? RNMX : temp;
-}
-#undef IM1
-#undef IM2
-#undef AM
-#undef IMM1
-#undef IA1
-#undef IA2
-#undef IQ1
-#undef IQ2
-#undef IR1
-#undef IR2
-#undef NDIV
-#undef RNMX
-#endif
-
-#ifdef USE_IMSL_RNG
-PRECISION dw_uniform_rnd(void)
-{
- PRECISION x;
-#if PRECISION_SIZE == 8
- imsls_d_random_uniform(1,IMSLS_RETURN_USER,&x,0);
-#else
- imsls_f_random_uniform(1,IMSLS_RETURN_USER,&x,0);
-#endif
- return x;
-}
-#endif
-
-#if defined (USE_IMSL_RNG)
-#undef USE_IMSL_RNG
-#elif defined (USE_NR1_RNG)
-#undef NTAB
-#undef USE_NR1_RNG
-#elif defined (USE_NR2_RNG)
-#undef NTAB
-#undef USE_NR2_RNG
-#endif
-
-/*******************************************************************************/
-/*******************************************************************************/
-/*******************************************************************************/
-
-/*
- Returns a standard gaussian deviate. The density function for the
- standard gaussian is
-
- 1
- ----------- exp(-0.5*x^2)
- sqrt(2*Pi)
-
-*/
-PRECISION dw_gaussian_rnd(void)
-{
- static int iset=0;
- static PRECISION gset;
- PRECISION fac,r,v1,v2;
-
- if (iset == 0)
- {
- do
- {
- v1=2.0*dw_uniform_rnd()-1.0;
- v2=2.0*dw_uniform_rnd()-1.0;
- r=v1*v1+v2*v2;
- }
- while (r >= 1.0);
- fac=sqrt(-2.0*log(r)/r);
- gset=v1*fac;
- iset=1;
- return v2*fac;
- }
- else
- {
- iset=0;
- return gset;
- }
-}
-
-#undef PI
-/*
- Returns a standard gamma deviate. The density function for a standard gamma
- distribution is
-
- x^(a-1)*exp(-x)
- gamma_density(x;a) = ----------------
- gamma(a)
-
- for a > 0. The function gamma(a) is the integral with from 0 to infinity of
- exp(-t)*t^(a-1).
-
- When a = 1.0, then gamma is exponential. (Devroye, page 405).
- When a < 1.0, Johnk's generator (Devroye, page 418).
- When a > 1.0, a rejection method or Best's algorithm (Devroye, page 410).
-
- A general gamma variate can be obtained as follows. Let z=b*x. Then,
- z is drawn from a general gamma distribution whose density is
-
- z^(a-1)*exp(-z/b)
- gamma_density(z;a,b) = ------------------
- gamma(a)*b^a
-
- Uses algorithm translated by Iskander Karibzhanov from the Matlab function
- gamrnd.m, which follows Johnk's generator in Devroye ("Non-Uniform Random
- Variate Generation", Springer-Verlag, 1986, page 418).
-
- Notes:
- Does not check if a > 0.
-*/
-PRECISION dw_gamma_rnd(PRECISION a)
-{
- PRECISION b, u, v, w, x, y, z;
-
- if (a == 1.0) return -log(dw_uniform_rnd());
-
- if (a < 1.0)
- {
- u=1.0/a;
- v=1.0/(1.0-a);
- do
- {
- x=pow(dw_uniform_rnd(),u);
- y=pow(dw_uniform_rnd(),v);
- }
- while (x+y > 1.0);
- return -log(dw_uniform_rnd())*x/(x+y);
- }
-
- b=a - 1.0;
- while(1)
- {
- u=dw_uniform_rnd();
- w=u*(1.0 - u);
- y=sqrt((3.0*a - 0.75)/w)*(u - 0.5);
- x=b + y;
- if (x > 0.0)
- {
- v=dw_uniform_rnd();
- z=64.0*w*w*w*v*v;
- if ((z <= 1.0 - 2.0*y*y/x) || (log(z) <= 2.0*(b*log(x/b) - y)))
- return x;
- }
- }
-}
-
-/*
- Returns a lognormal deviate. The mean and standard deviations of the
- underlying normal distributions are passed.
-*/
-PRECISION dw_lognormal_rnd(PRECISION mean, PRECISION standard_deviation)
-{
- return exp(standard_deviation * dw_gaussian_rnd() + mean);
-}
-
-
-/*
- Returns the integral from -infinity to x of 1/sqrt(2*PI)*exp(-y^2/2).
- Routine adapted from Numerical Recipes in C.
-*/
-double dw_normal_cdf(double x)
-{
- double z=fabs(0.7071067811865*x), t=2.0/(2.0+z);
-
- return (x > 0) ?
- 1.0-0.5*t*exp(-z*z-1.26551223+t*(1.00002368+t*(0.37409196+
- t*(0.09678418+t*(-0.18628806+t*(0.27886807+t*(-1.13520398+
- t*(1.48851587+t*(-0.82215223+t*0.17087277)))))))))
- :
- 0.5*t*exp(-z*z-1.26551223+t*(1.00002368+t*(0.37409196+
- t*(0.09678418+t*(-0.18628806+t*(0.27886807+t*(-1.13520398+
- t*(1.48851587+t*(-0.82215223+t*0.17087277)))))))));
-
-}
-
-PRECISION dw_chi_square_cdf(PRECISION x, int df)
-{
- return gammp(0.5*df,0.5*x);
-}
-
-#define MAXITER 1000
-PRECISION dw_chi_square_invcdf(PRECISION p, int df)
-{
- int i;
- PRECISION p_lo=p-SQRT_MACHINE_EPSILON, p_hi=p+SQRT_MACHINE_EPSILON, hi, lo=0.0, mid, cdf;
- if (p <= 0)
- {
- if (p < 0) dw_Error(ARG_ERR);
- return 0.0;
- }
- else
- if (p >= 1)
- {
- if (p > 1) dw_Error(ARG_ERR);
- return PLUS_INFINITY;
- }
- if ((cdf=dw_chi_square_cdf(hi=2*df,df)) < p_lo)
- {
- for (lo=hi, i=MAXITER; (i > 0) && ((cdf=dw_chi_square_cdf(hi*=2,df)) < p_lo); lo=hi, i--);
- if (i == 0)
- {
- dw_Error(ITERATION_ERR);
- return PLUS_INFINITY;
- }
- }
- if (cdf < p_hi) return hi;
- for (i=MAXITER; i > 0; i--)
- if ((cdf=dw_chi_square_cdf(mid=0.5*(lo+hi),df)) < p_lo)
- lo=mid;
- else
- if (cdf > p_hi)
- hi=mid;
- else
- return mid;
- return 0.5*(lo+hi);
-}
-#undef MAXITER
-
-/*
- Returns the natural logrithm of the gamma function applied to x. The gamma
- function of x is the integral from 0 to infinity of t^(x-1)*exp(-t)dt.
-
- Routine adapted from the gammln routine from Numerical Recipes in C.
-*/
-PRECISION dw_log_gamma(PRECISION x)
-{
- static PRECISION cof[6]={ 76.18009172947146, -86.50532032941677,
- 24.01409824083091, -1.231739572450155,
- 0.1208650973866179e-2, -0.5395239384953e-5};
- PRECISION y, z, ser;
- int j;
- z=x+5.5;
- z-=(x+0.5)*log(z);
- ser=1.000000000190015;
- for (y=x, j=0; j <= 5; j++) ser+=cof[j]/++y;
- return -z+log(2.5066282746310005*ser/x);
-}
-
-/******************************************************************************/
-/************************** Numerical Recipies in C ***************************/
-/******************************************************************************/
-#define ITMAX 1000
-#define EPS 3.0e-7
-static void gser(PRECISION *gamser, PRECISION a, PRECISION x, PRECISION *gln)
-{
- int n;
- PRECISION sum,del,ap;
-
- dw_ClearError();
- *gln=dw_log_gamma(a);
- if (x <= 0.0)
- {
- if (x < 0.0)
- dw_Error(ARG_ERR);
- else
- *gamser=0.0;
- }
- else
- {
- ap=a;
- del=sum=1.0/a;
- for (n=1; n <= ITMAX; n++)
- {
- ++ap;
- del *= x/ap;
- sum += del;
- if (fabs(del) < fabs(sum)*EPS)
- {
- *gamser=sum*exp(-x+a*log(x)-(*gln));
- return;
- }
- }
- dw_Error(ITERATION_ERR);
- }
-}
-#undef ITMAX
-#undef EPS
-/* (C) Copr. 1986-92 Numerical Recipes Software */
-
-#define ITMAX 100
-#define EPS 3.0e-7
-#define FPMIN 1.0e-30
-static void gcf(PRECISION *gammcf, PRECISION a, PRECISION x, PRECISION *gln)
-{
- int i;
- PRECISION an,b,c,d,del,h;
-
- *gln=dw_log_gamma(a);
- b=x+1.0-a;
- c=1.0/FPMIN;
- d=1.0/b;
- h=d;
- for (i=1; i <= ITMAX; i++)
- {
- an = -i*(i-a);
- b += 2.0;
- d=an*d+b;
- if (fabs(d) < FPMIN) d=FPMIN;
- c=b+an/c;
- if (fabs(c) < FPMIN) c=FPMIN;
- d=1.0/d;
- del=d*c;
- h *= del;
- if (fabs(del-1.0) < EPS) break;
- }
- if (i > ITMAX)
- dw_Error(ITERATION_ERR);
- else
- {
- *gammcf=exp(-x+a*log(x)-(*gln))*h;
- dw_ClearError();
- }
-}
-#undef ITMAX
-#undef EPS
-#undef FPMIN
-/* (C) Copr. 1986-92 Numerical Recipes Software */
-
-static PRECISION gammp(PRECISION a, PRECISION x)
-{
- PRECISION gamser,gammcf,gln;
-
- if (x < 0.0 || a <= 0.0)
- {
- dw_Error(ARG_ERR);
- return 0.0;
- }
- dw_ClearError();
- if (x < (a+1.0))
- {
- gser(&gamser,a,x,&gln);
- return gamser;
- }
- else
- {
- gcf(&gammcf,a,x,&gln);
- return 1.0-gammcf;
- }
-}
-/* (C) Copr. 1986-92 Numerical Recipes Software */
-/******************************************************************************/
-/******************************************************************************/
-/******************************************************************************/
diff --git a/matlab/swz/c-code/utilities/DWCcode/stat/dw_rand.h b/matlab/swz/c-code/utilities/DWCcode/stat/dw_rand.h
deleted file mode 100644
index d927d359875413e6abd54765abfc85e79e2cdb59..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/DWCcode/stat/dw_rand.h
+++ /dev/null
@@ -1,35 +0,0 @@
-
-#ifndef __DW_RANDOM__
-#define __DW_RANDOM__
-
-#ifdef __cplusplus
-extern "C"
-{
-#endif
-
-#include "prcsn.h"
-#include <stdio.h>
-
-void dw_initialize_generator(int init);
-
-void* dw_get_generator_state(void);
-int dw_get_generator_state_size(void);
-void dw_set_generator_state(void *state);
-void dw_print_generator_state(FILE *f);
-void dw_read_generator_state(FILE *f);
-
-PRECISION dw_uniform_rnd(void);
-PRECISION dw_gaussian_rnd(void);
-PRECISION dw_lognormal_rnd(PRECISION mean, PRECISION standard_deviation);
-PRECISION dw_gamma_rnd(PRECISION a);
-
-PRECISION dw_normal_cdf(PRECISION x);
-PRECISION dw_chi_square_cdf(PRECISION x, int df);
-PRECISION dw_chi_square_invcdf(PRECISION p, int df);
-PRECISION dw_log_gamma(PRECISION x);
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif
diff --git a/matlab/swz/c-code/utilities/TZCcode/congradmin.c b/matlab/swz/c-code/utilities/TZCcode/congradmin.c
deleted file mode 100644
index b09abf9801afb8fed4a674d970d0664ad7d0490d..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/congradmin.c
+++ /dev/null
@@ -1,580 +0,0 @@
-/*************************************************************
- * Conjugate Gradient Minimization Methods. See Numerical Recipes in C by Press, Flannery, Teukolsky, and Vetterling.
- * (I) frprmn(): Plolak-Ribiere method with the line minimization without using the derivative information.
- * (II) dlinmin(): Fletcher-Reeves method with the line minimization using the derivative information.
- *
- * Modified by Tao Zha, September 2003.
-*************************************************************/
-
-#include "congradmin.h"
-
-static void linmin(double p[], double xi[], int n, double *fret, double tol_brent, int itmax_brent, double (*func)(double [], int));
-static double brent(double ax, double bx, double cx, double (*f)(double), double tol_brent, double itmax_brent, double *xmin);
-//
-static void dlinmin(double p[], double xi[], int n, double *fret, double tol_dbrent, double itmax_dbrent, double *grdh_p, double (*func)(double [], int), void (*dfunc)(double [], double [], int, double (*func)(double [], int), double *, double));
-static double dbrent(double ax, double bx, double cx, double (*f)(double), double (*df)(double, double *), double *grdh_p, double tol_dbrent, double itmax_dbrent, double *xmin);
-static double df1dim(double x, double *grdh_p);
-//
-static void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, double *fc, double (*func)(double));
-static double f1dim(double x);
-//
-static double ftd_norm2(double *vnew_p, double *vold_p, int _n);
-static double ftd_innerproduct(double *x, double *y, int _n);
-
-
-#define ANGLE 0.001 //.0 implies 90.00 degress (acrcos(ANGLE)*180/pi).
- //.005 implies 89.71 degrees (acrcos(ANGLE)*180/pi).
- //.01 implies 89.43 degrees (acrcos(ANGLE)*180/pi).
- //.05 implies 87.13 degrees (acrcos(ANGLE)*180/pi).
- //.1 implies 84.26 degrees (acrcos(ANGLE)*180/pi).
-#define STRLEN 192
-static FILE *fptr_interesults = (FILE *)NULL; //Printing intermediate results to a file.
-static char filename_sp3vecs[STRLEN]; //Three vectors. 1st row: line search direction; 2nd row: numerical gradient; 3rd row: vectorized parameters.
-//static FILE *fptr_interesults_db = (FILE *)NULL; //Printing intermediate results to a file for debugging (db).
-#define PRINTON //Added by TZ, September 2003.
-#define EPS 1.0e-10 //Small number to rectify special case of converging to exactly zero function value.
-#ifdef PRINTON //Added by TZ, September 2003.
- #define FREEALL {tzDestroy(xi); tzDestroy(h); tzDestroy(g); tzDestroy(pold); tzDestroy(numgrad)}
-#else
- #define FREEALL {tzDestroy(xi); tzDestroy(h); tzDestroy(g);}
-#endif
-void frprmn(double p[], int n, int *iter, double *fret,
- double (*func)(double [], int), void (*dfunc)(double [], double [], int, double (*func)(double [], int), double *, double),
- double *ftol_p, int *itmax_p, double *tol_brent_p, int *itmax_brent_p, double *grdh_p) {
- //Outputs:
- // p[0, ..., n-1]: the location of the minimum if it converges, which replaces the starting value.
- // iter: pointer to the number of iterations that were performed.
- // fret: pointer to the minimum value of the function.
- //Inputs:
- // p[0, ..., n-1]: a starting point for the minimization.
- // n: the dimension of p.
- // ftol_p: pointer to the convergence tolerance on the objective function value. Default: 1.0e-4 if NULL.
- // itmax_p: pointer to the maximum number of iterations in the main minimization program frprmn(). Default: 2000 if NULL.
- // tol_brent_p: pointer to the convergence tolerance for the line minimization in brent(). Default: 2.0e-4 if NULL.
- // itmax_brent_p: pointer to the maximum number of iterations for the line minimization in brent(). Default: 100 if NULL.
- // grdh: pointer to the user's specified step size for a numerical gradient. If NULL, dfunc() (i.e., gradcd_gen()) will select grdh automatically.
- // func(): the objective function.
- // dfunc(): the gradient function computing the numerical gradient. In the form of gradcd_gen() in cstz.c.
- int j, its, itmax, itmax_brent;
- double gg, gam, fp, dgg, ftol, tol_brent;
- double *g=NULL, *h=NULL, *xi=NULL;
- #ifdef PRINTON //Added by TZ, September 2003.
- time_t begtime, currentime;
- double normforp, *pold = NULL, *numgrad = NULL;
- int cnt_wrong_dirs = -1; //Counts the number of times that a numerical direction in the line search has a wrong sign.
- #endif
-
- //=== Memory allocation.
- g=tzMalloc(n, double);
- h=tzMalloc(n, double);
- xi=tzMalloc(n, double);
- //
- numgrad = tzMalloc(n, double); //Added by TZ, September 2003.
- #ifdef PRINTON //Added by TZ, September 2003.
- pold = tzMalloc(n, double);
- #endif
-
- //=== Default values.
- if (!ftol_p) ftol = 1.0e-4; else ftol = *ftol_p;
- if (!itmax_p) itmax = 200; else itmax = *itmax_p;
- if (!tol_brent_p) tol_brent = 2.0e-4; else tol_brent = *tol_brent_p;
- if (!itmax_brent_p) itmax_brent = 100; else itmax_brent = *itmax_brent_p;
-
- fp=(*func)(p, n);
- (*dfunc)(xi, p, n, func, grdh_p, fp);
- for (j=n-1;j>=0;j--) {
- g[j] = -xi[j];
- xi[j]=h[j]=g[j];
- }
- memcpy(numgrad, xi, n*sizeof(double)); //Added by TZ, September 2003. Save the numerical gradient to be printed out at the right place.
- for (its=0;its<itmax;its++) {
- #ifdef PRINTON
- time(&begtime); //Added by TZ, September 2003.
- memcpy(pold, p, n*sizeof(double)); //Added by TZ, September 2003.
- #endif
- //====== Added by TZ, September 2003 ======
- if ( !(fptr_interesults = fopen(filename_sp3vecs,"w")) ) {
- printf("\n\nUnable to create the starting point data file %s in congradmin.c!\n", filename_sp3vecs);
- getchar();
- exit(EXIT_FAILURE);
- }
- // rewind(fptr_interesults); //Must put the pointer at the beginning of the file.
- //=== Prints out the line search direction.
- fprintf(fptr_interesults, "--------Line search direction---------\n");
- for (j=0; j<n; j++) fprintf(fptr_interesults, " %0.16e ", xi[j]);
- fprintf(fptr_interesults, "\n");
- // fflush( fptr_interesults );
- //=== Prints out the message about a wrong numerical direction in the line search for the miminziation.
- if ( ftd_innerproduct(xi, numgrad, n)/(ftd_norm2(xi, xi, n)*ftd_norm2(numgrad, numgrad, n)) > - ANGLE ) {
- #ifdef PRINTON
- printf("\n----------------\n"
- "Warning: wrong numerical direction in the line search for the miminziation (a total of %d times)!\n"
- "----------------\n", ++cnt_wrong_dirs);
- #endif
- }
-
-
- *iter=its;
- #if defined (CGI_OPTIMIZATION)
- linmin(p,xi,n,fret, tol_brent, itmax_brent, func);
- #elif defined (CGII_OPTIMIZATION)
- dlinmin(p, xi, n, fret, tol_brent, itmax_brent, grdh_p, func, dfunc);
- #else
- fn_DisplayError("The minimization routine frprmn() requires activating CGI_OPTIMIZATION or CGII_OPTIMIZATION in tzmatlab.h");
- #endif
- #ifdef PRINTON
- normforp = ftd_norm2(p, pold, n);
- //=== Prints out intermediate results.
- printf("\n========================================\n");
- printf("Intermediate results for the conjugate gradient algorithm.");
- printf("\n (1) Number of iterations so far (maximum number): %d (%d)\n (2) New value of objective function (old value, improvement): %0.9f (%0.9f, %0.9f)\n"
- " (3) Norm-2 of dx: %0.9f\n",
- its, itmax, *fret, fp, fp-(*fret), normforp);
- fflush(stdout); // Flush the buffer to get out this message without delay.
- #endif
- //====== The following statements print out intermediate results. Added by TZ, September 2003 ======
- //=== Prints out the gradient.
- fprintf(fptr_interesults, "--------Numerical graident---------\n");
- for (j=0; j<n; j++) fprintf(fptr_interesults, " %0.16e ", numgrad[j]);
- fprintf(fptr_interesults, "\n");
- //
- fprintf(fptr_interesults, "--------Restarting point---------\n");
- for (j=0; j<n; j++) fprintf(fptr_interesults, " %0.16e ", p[j]);
- fprintf(fptr_interesults, "\n\n");
-// fflush( fptr_interesults );
- tzFclose(fptr_interesults);
-
-
- if (2.0*fabs(*fret-fp) <= ftol*(fabs(*fret)+fabs(fp)+EPS)) {
- //This is a normal convergence.
- printf("\n----- Normal convergence by the criterion of the objective function evaluation -----------\n");
- FREEALL
- return;
- }
- fp=(*func)(p, n);
- (*dfunc)(xi, p, n, func, grdh_p, fp);
- memcpy(numgrad, xi, n*sizeof(double)); //Added by TZ, September 2003. Save the numerical gradient to be printed out at the right place.
-// if (filename_sp3vecs) {
-// //=== Prints out the gradient.
-// fprintf(fptr_interesults, "--------Numerical graident---------\n");
-// for (j=0; j<n; j++) fprintf(fptr_interesults, " %0.16e ", xi[j]);
-// fprintf(fptr_interesults, "\n\n");
-//// fflush( fptr_interesults );
-
-// tzFclose(fptr_interesults);
-// }
- dgg=gg=0.0;
- for (j=n-1;j>=0;j--) {
- gg += g[j]*g[j];
- dgg += (xi[j]+g[j])*xi[j];
- }
- if (gg == 0.0) {
- FREEALL
- return;
- }
- gam=dgg/gg;
- for (j=n-1;j>=0;j--) {
- g[j] = -xi[j];
- xi[j]=h[j]=g[j]+gam*h[j];
- }
-
- #ifdef PRINTON
- time(¤time);
- //=== Times the iterative progress.
- printf(" (4) Seconds to complete one iteration: %0.4f\n (5) Current time of day: %s\n", difftime(currentime, begtime), ctime(¤time));
- fflush(stdout); // Flush the buffer to get out this message without delay.
- #endif
- }
- fn_DisplayError("The maximum number of iterations in frprmn() is reached before convergence");
-}
-#undef PRINTON
-#undef EPS
-#undef FREEALL
-
-
-#if defined (CGI_OPTIMIZATION)
- static int ncom;
- static double *pcom=NULL, *xicom=NULL, (*nrfunc)(double [], int); //nrfunc(), pcom, ncom, and xicom will be used by f1dim().
- static void linmin(double p[], double xi[], int n, double *fret, double tol_brent, int itmax_brent, double (*func)(double [], int)) {
- //Outputs:
- // p[0, ..., n-1]: a returned and reset value.
- // xi[0, ..., n-1]: a value repaced by the actual vector displacement that p was moved.
- // fret: the value of func at the returned location p.
- //Inputs:
- // p[0, ..., n-1]: a given point.
- // xi[0, ..., n-1]: a given multidimensional direction.
- // n: the dimension of p and xi.
- // func(): the objective function.
- int j;
- double xx,xmin,fx,fb,fa,bx,ax;
-
- ncom=n;
- pcom = tzMalloc(n, double);
- xicom = tzMalloc(n, double);
- nrfunc=func;
- for (j=n-1;j>=0;j--) {
- pcom[j]=p[j];
- xicom[j]=xi[j];
- }
- ax=0.0;
- xx=1.0;
- mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,f1dim);
- *fret=brent(ax,xx,bx,f1dim, tol_brent, itmax_brent, &xmin);
- for (j=n-1;j>=0;j--) {
- xi[j] *= xmin;
- p[j] += xi[j];
- }
- tzDestroy(xicom);
- tzDestroy(pcom);
- }
-
-
- //=== Used by linmin() only;
- #define CGOLD 0.3819660
- #define ZEPS 1.0e-10
- #define SHFT(a,b,c,d) {(a)=(b);(b)=(c);(c)=(d);}
- #define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
- static double brent(double ax, double bx, double cx, double (*f)(double), double tol_brent, double itmax_brent, double *xmin) {
- int iter;
- double a,b,d,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm;
- double e=0.0;
-
- a=(ax < cx ? ax : cx);
- b=(ax > cx ? ax : cx);
- x=w=v=bx;
- fw=fv=fx=(*f)(x);
- for (iter=0;iter<itmax_brent;iter++) {
- xm=0.5*(a+b);
- tol2=2.0*(tol1=tol_brent*fabs(x)+ZEPS);
- if (fabs(x-xm) <= (tol2-0.5*(b-a))) {
- *xmin=x;
- return fx;
- }
- if (fabs(e) > tol1) {
- r=(x-w)*(fx-fv);
- q=(x-v)*(fx-fw);
- p=(x-v)*q-(x-w)*r;
- q=2.0*(q-r);
- if (q > 0.0) p = -p;
- q=fabs(q);
- etemp=e;
- e=d;
- if (fabs(p) >= fabs(0.5*q*etemp) || p <= q*(a-x) || p >= q*(b-x))
- d=CGOLD*(e=(x >= xm ? a-x : b-x));
- else {
- d=p/q;
- u=x+d;
- if (u-a < tol2 || b-u < tol2)
- d=SIGN(tol1,xm-x);
- }
- } else {
- d=CGOLD*(e=(x >= xm ? a-x : b-x));
- }
- u=(fabs(d) >= tol1 ? x+d : x+SIGN(tol1,d));
- fu=(*f)(u);
- if (fu <= fx) {
- if (u >= x) a=x; else b=x;
- SHFT(v,w,x,u)
- SHFT(fv,fw,fx,fu)
- } else {
- if (u < x) a=u; else b=u;
- if (fu <= fw || w == x) {
- v=w;
- w=u;
- fv=fw;
- fw=fu;
- } else if (fu <= fv || v == x || v == w) {
- v=u;
- fv=fu;
- }
- }
- }
- fn_DisplayError("The maximum number of iterations in brent() is reached before convergence");
- *xmin=x;
- return fx;
- }
- #undef CGOLD
- #undef ZEPS
- #undef SHFT
- #undef SIGN
-
-#else //Default to CGII_OPTIMIZATION
-
- static int ncom;
- static double *pcom=NULL, *xicom=NULL, (*nrfunc)(double [], int); //nrfunc(), pcom, ncom, and xicom will be used by f1dim() and df1dim().
- static void (*nrdfun)(double [], double [], int, double (*func)(double [], int), double *, double);
- static void dlinmin(double p[], double xi[], int n, double *fret, double tol_dbrent, double itmax_dbrent, double *grdh_p, double (*func)(double [], int), void (*dfunc)(double [], double [], int, double (*func)(double [], int), double *, double)) {
- //Outputs:
- // p[0, ..., n-1]: a returned and reset value.
- // xi[0, ..., n-1]: a value repaced by the actual vector displacement that p was moved.
- // fret: the value of func at the returned location p.
- //Inputs:
- // p[0, ..., n-1]: a given point.
- // xi[0, ..., n-1]: a given multidimensional direction.
- // n: the dimension of p and xi.
- // func(): the objective function.
- // dfunc(): the gradient function computing the numerical gradient. In the form of gradcd_gen() in cstz.c.
-
- int j;
- double xx,xmin,fx,fb,fa,bx,ax;
-
- ncom=n;
- pcom = tzMalloc(n, double);
- xicom = tzMalloc(n, double);
- nrfunc=func;
- nrdfun=dfunc;
- for (j=n-1;j>=0;j--) {
- pcom[j]=p[j];
- xicom[j]=xi[j];
- }
- ax=0.0;
- xx=1.0;
- mnbrak(&ax,&xx,&bx,&fa,&fx,&fb,f1dim);
- *fret=dbrent(ax,xx,bx,f1dim, df1dim, grdh_p, tol_dbrent, itmax_dbrent, &xmin);
- for (j=n-1;j>=0;j--) {
- xi[j] *= xmin;
- p[j] += xi[j];
- }
- tzDestroy(xicom);
- tzDestroy(pcom);
- }
-
-
- //=== Used by dlinmin() only;
- #define ZEPS 1.0e-10
- #define MOV3(a,b,c, d,e,f) {(a)=(d);(b)=(e);(c)=(f);}
- #define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
- static double dbrent(double ax, double bx, double cx, double (*f)(double), double (*df)(double, double *), double *grdh_p, double tol_dbrent, double itmax_dbrent, double *xmin) {
- int iter,ok1,ok2;
- double a,b,d,d1,d2,du,dv,dw,dx,e=0.0;
- double fu,fv,fw,fx,olde,tol1,tol2,u,u1,u2,v,w,x,xm;
-
- a=(ax < cx ? ax : cx);
- b=(ax > cx ? ax : cx);
- x=w=v=bx;
- fw=fv=fx=(*f)(x);
- dw=dv=dx=(*df)(x, grdh_p);
- for (iter=1;iter<=itmax_dbrent;iter++) {
- xm=0.5*(a+b);
- tol1=tol_dbrent*fabs(x)+ZEPS;
- tol2=2.0*tol1;
- if (fabs(x-xm) <= (tol2-0.5*(b-a))) {
- *xmin=x;
- return fx;
- }
- if (fabs(e) > tol1) {
- d1=2.0*(b-a);
- d2=d1;
- if (dw != dx) d1=(w-x)*dx/(dx-dw);
- if (dv != dx) d2=(v-x)*dx/(dx-dv);
- u1=x+d1;
- u2=x+d2;
- ok1 = (a-u1)*(u1-b) > 0.0 && dx*d1 <= 0.0;
- ok2 = (a-u2)*(u2-b) > 0.0 && dx*d2 <= 0.0;
- olde=e;
- e=d;
- if (ok1 || ok2) {
- if (ok1 && ok2)
- d=(fabs(d1) < fabs(d2) ? d1 : d2);
- else if (ok1)
- d=d1;
- else
- d=d2;
- if (fabs(d) <= fabs(0.5*olde)) {
- u=x+d;
- if (u-a < tol2 || b-u < tol2)
- d=SIGN(tol1,xm-x);
- } else {
- d=0.5*(e=(dx >= 0.0 ? a-x : b-x));
- }
- } else {
- d=0.5*(e=(dx >= 0.0 ? a-x : b-x));
- }
- } else {
- d=0.5*(e=(dx >= 0.0 ? a-x : b-x));
- }
- if (fabs(d) >= tol1) {
- u=x+d;
- fu=(*f)(u);
- } else {
- u=x+SIGN(tol1,d);
- fu=(*f)(u);
- if (fu > fx) {
- *xmin=x;
- return fx;
- }
- }
- du=(*df)(u, grdh_p);
- if (fu <= fx) {
- if (u >= x) a=x; else b=x;
- MOV3(v,fv,dv, w,fw,dw)
- MOV3(w,fw,dw, x,fx,dx)
- MOV3(x,fx,dx, u,fu,du)
- } else {
- if (u < x) a=u; else b=u;
- if (fu <= fw || w == x) {
- MOV3(v,fv,dv, w,fw,dw)
- MOV3(w,fw,dw, u,fu,du)
- } else if (fu < fv || v == x || v == w) {
- MOV3(v,fv,dv, u,fu,du)
- }
- }
- }
- fn_DisplayError("The maximum number of iterations in dbrent() is reached before convergence");
- return 0.0;
- }
- #undef ZEPS
- #undef MOV3
- #undef SIGN
-
- //=== Used by dlinmin() and dbrent() only;
- static double df1dim(double x, double *grdh_p) {
- int j;
- double df1=0.0;
- double *xt,*df;
-
- xt = tzMalloc(ncom, double);
- df = tzMalloc(ncom, double);
- for (j=ncom-1;j>=0;j--) xt[j]=pcom[j]+x*xicom[j];
- (*nrdfun)(df, xt, ncom, nrfunc, grdh_p, nrfunc(xt, ncom));
- //=================== WARNING ======================
- //We use 0.0 because the current gradient function gradcd_gen() in cstz.c do not use this function value. A more
- // sophisticated central gradient method would require this function value, and therefore we must pass
- // nrfunc(xt, ncom) instead of 0.0. TZ, September 2003.
- //=================== WARNING ======================
- for (j=ncom-1;j>=0;j--) df1 += df[j]*xicom[j];
- tzDestroy(df);
- tzDestroy(xt);
- return df1;
- }
-
-#endif
-
-
-
-static double f1dim(double x) {
- //Collapsing to one dimension line search, used by limin() or dlimin().
- int j;
- double f,*xt=NULL;
-
- xt = tzMalloc(ncom, double);
- for (j=ncom-1;j>=0;j--) xt[j]=pcom[j]+x*xicom[j];
- f=(*nrfunc)(xt, ncom);
- tzDestroy(xt);
- return f;
-}
-
-
-#define GOLD 1.618034
-#define GLIMIT 100.0
-#define TINY 1.0e-20
-#define SHFT(a,b,c,d) {(a)=(b);(b)=(c);(c)=(d);}
-#define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
-static void mnbrak(double *ax, double *bx, double *cx, double *fa, double *fb, double *fc, double (*func)(double)) {
- double ulim,u,r,q,fu,dum, tmpd;
-
- *fa=(*func)(*ax);
- *fb=(*func)(*bx);
- if (*fb > *fa) {
- SHFT(dum,*ax,*bx,dum)
- SHFT(dum,*fb,*fa,dum)
- }
- *cx=(*bx)+GOLD*(*bx-*ax);
- *fc=(*func)(*cx);
- while (*fb > *fc) {
- r=(*bx-*ax)*(*fb-*fc);
- q=(*bx-*cx)*(*fb-*fa);
- u=(*bx)-((*bx-*cx)*q-(*bx-*ax)*r)/
- (2.0*SIGN((tmpd=fabs(q-r))>TINY ? tmpd : TINY,q-r)); //Original: (2.0*SIGN(FMAX(fabs(q-r),TINY),q-r));
- ulim=(*bx)+GLIMIT*(*cx-*bx);
- if ((*bx-u)*(u-*cx) > 0.0) {
- fu=(*func)(u);
- if (fu < *fc) {
- *ax=(*bx);
- *bx=u;
- *fa=(*fb);
- *fb=fu;
- return;
- } else if (fu > *fb) {
- *cx=u;
- *fc=fu;
- return;
- }
- u=(*cx)+GOLD*(*cx-*bx);
- fu=(*func)(u);
- } else if ((*cx-u)*(u-ulim) > 0.0) {
- fu=(*func)(u);
- if (fu < *fc) {
- SHFT(*bx,*cx,u,*cx+GOLD*(*cx-*bx))
- SHFT(*fb,*fc,fu,(*func)(u))
- }
- } else if ((u-ulim)*(ulim-*cx) >= 0.0) {
- u=ulim;
- fu=(*func)(u);
- } else {
- u=(*cx)+GOLD*(*cx-*bx);
- fu=(*func)(u);
- }
- SHFT(*ax,*bx,*cx,u)
- SHFT(*fa,*fb,*fc,fu)
- }
-}
-#undef GOLD
-#undef GLIMIT
-#undef TINY
-#undef SHFT
-#undef SIGN
-
-
-
-
-
-//-------------------
-// My own functions.
-//-------------------
-//=== Computing Norm2 of dv.
-static double ftd_norm2(double *vnew_p, double *vold_p, int _n) {
- int _i;
- double dtheta=0.0, //Cumulative.
- tmpd;
-
- for (_i=_n-1; _i>=0; _i--) {
- tmpd = vnew_p[_i] - vold_p[_i];
- dtheta += square(tmpd);
- }
-
- return ( sqrt(dtheta) );
-}
-
-//=== Computing the inner product of x and y.
-static double ftd_innerproduct(double *x, double *y, int _n) {
- int _i;
- double a = 0.0; //Cumulative.
- for (_i=_n-1; _i>=0; _i--) a += x[_i] * y[_i]; //a += (*x++) * (*y++); Be aware that this alternative maybe too fancy.
- return (a);
-}
-
-
-
-
-//=== Extern function to be accessed by other C files.
-void congradmin_SetPrintFile(char *filename) {
- if (!filename) sprintf(filename_sp3vecs, "outdata5congradmin.prn"); //Default filename.
- else {
- strcpy(filename_sp3vecs, filename);
- //filename_sp3vecs[STRLEN-1] = '\0'; //The end of the string is set to NUL to prevent it from be a non-string.
- }
-}
-
-
-
-//void congradmin_SetPrintFile(FILE *fptr_sp) {
-// fptr_interesults = fptr_sp;
-//}
-
-//void congradmin_SetPrintFile_db(FILE *fptr_sp) {
-// fptr_interesults_db = fptr_sp;
-//}
-
-
-#undef STRLEN
diff --git a/matlab/swz/c-code/utilities/TZCcode/congradmin.h b/matlab/swz/c-code/utilities/TZCcode/congradmin.h
deleted file mode 100644
index cd412ee8328014eaa45ea30da581e32f46e0c6a9..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/congradmin.h
+++ /dev/null
@@ -1,33 +0,0 @@
-#ifndef __CONGRADMIN_H__
-#define __CONGRADMIN_H__
- #include "tzmatlab.h"
-
- #include <string.h>
-
-
-
-
- void frprmn(double p[], int n, int *iter, double *fret,
- double (*func)(double [], int), void (*dfunc)(double [], double [], int, double (*func)(double [], int), double *, double),
- double *ftol_p, int *itmax_p, double *tol_brent_p, int *itmax_brent_p, double *grdh_p);
- //Outputs:
- // p[0, ..., n-1]: the location of the minimum if it converges, which replaces the starting value.
- // iter: pointer to the number of iterations that were performed.
- // fret: pointer to the minimum value of the function.
- //Inputs:
- // p[0, ..., n-1]: a starting point for the minimization.
- // n: the dimension of p.
- // ftol_p: pointer to the convergence tolerance on the objective function value. Default: 1.0e-4 if NULL.
- // itmax_p: pointer to the maximum number of iterations in the main minimization program frprmn(). Default: 2000 if NULL.
- // tol_brent_p: pointer to the convergence tolerance for the line minimization in brent(). Default: 2.0e-4 if NULL.
- // itmax_brent_p: pointer to the maximum number of iterations for the line minimization in brent(). Default: 100 if NULL.
- // grdh: pointer to the user's specified step size for a numerical gradient. If NULL, dfunc() (i.e., gradcd_gen()) will select grdh automatically.
- // func(): the objective function.
- // dfunc(): the gradient function computing the numerical gradient. In the form of gradcd_gen() in cstz.c.
-
- void congradmin_SetPrintFile(char *filename);
- //If filename=NULL, no intermediate results will be printed out to a file.
-// void congradmin_SetPrintFile(FILE *fptr_sp);
- //If fptr_sp=NULL, no intermediate results will be printed out to a file.
-// void congradmin_SetPrintFile_db(FILE *fptr_sp);
-#endif
diff --git a/matlab/swz/c-code/utilities/TZCcode/csminwel.c b/matlab/swz/c-code/utilities/TZCcode/csminwel.c
deleted file mode 100644
index 6bae1803108d08100d1a814bdf11bc845cada849..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/csminwel.c
+++ /dev/null
@@ -1,848 +0,0 @@
-//======= Revisions by T. Zha.
-//======= Fixing bugs: convering all if-else loop. 02/24/05
-/*=========================================================
- * csminwel.c
- *
- * Unconstrained minimization. Uses a quasi-Newton method with BFGS update of
- * the estimated inverse hessian. It is robust against certain pathologies
- * common on likelihood functions. It attempts to be robust against "cliffs",
- * i.e. hyperplane discontinuities, though it is not really clear whether what
- * it does in such cases succeeds reliably.
- *
- * function [fhat,xhat,ghat,Hhat,itct,fcount,retcodehat] = csminwelmex(fcn,x0,H0,grad,crit,nit,varargin)
- * fcn: string naming the objective function to be minimized
- * x0: initial value of the parameter vector
- * H0: initial value for the inverse Hessian. Must be positive definite.
- * grad: Either a string naming a function that calculates the gradient, or the null matrix.
- * If it's null, the program calculates a numerical gradient. In this case fcn must
- * be written so that it can take a matrix argument and produce a row vector of values.
- * crit: Convergence criterion. Iteration will cease when it proves impossible to improve the
- * function value by more than crit.
- * nit: Maximum number of iterations.
- * varargin: A list of optional length of additional parameters that get handed off to fcn each
- * time it is called.
- * Note that if the program ends abnormally, it is possible to retrieve the current x,
- * f, and H from the files g1.mat and H.mat that are written at each iteration and at each
- * hessian update, respectively. (When the routine hits certain kinds of difficulty, it
- * write g2.mat and g3.mat as well. If all were written at about the same time, any of them
- * may be a decent starting point. One can also start from the one with best function value.)
- *
- * retcodes: 0, normal step (converged). 1, zero gradient (converged).
- * 4,2, back and forth adjustment of stepsize didn't finish.
- * 3, smallest stepsize still improves too slow. 5, largest step still improves too fast.
- * 6, no improvement found.
- *---------------------
- * Fixed 7/17/93 to use inverse-hessian instead of hessian itself in bfgs update.
- * Fixed 7/19/93 to flip eigenvalues of H to get better performance when it's not psd.
- *
- * Note: to set the level of display output, change preprocessor definitions at the beginning of this file.
- * to display all output, uncomment both VERBOSE_WARNINGS and VERBOSE_DETOUTPUT
- * to display only warnings without output, uncomment VERBOSE_WARNINGS
- * to display no ouput, comment both VERBOSE_DETOUTPUT and VERBOSE_WARNINGS
- *
- * MATLAB algorithm by Christopher Sims
- * C implementation by Iskander Karibzhanov
- * Modified by Dan Waggoner and Tao Zha
- *
- * Copyright(c) 1996 Christopher Sims
- * Copyright(c) 2003 Karibzhanov, Waggoner, and Zha
- *=======================================================
- * Revision history by T. Zha:
- *
- * 10/3/2002 - 1. corrected problem with memory corruption in C-MEX-file (csminwelmex.c)
- * (needed to switch fcnRhs[0] back to x[0] before destroying it.
- * If we don't do this, we will later clear previously destroyed array
- * (one of x[1], x[2] or x[3]) which causes memory fault.
- * The reason why fcnRhs[0] pointed to array other than x[0] is
- * because we use mxSetPr in feval and gfeval.
- * This was not a problem in C-file (csminwel.c).
- *
- * 10/11/2002 - 1. changed csminit function to avoid using fPeak without first initializing it
- * 2. added two switches in csminit function to assign retcode to 7 for lambda>=4
- * 3. added one more verbose level to display only warnings or all output *
- *
- * 07/13/2005 - Change #define GRADSTPS_CSMINWEL to double GRADSTPS_CSMINWEL in the .h file so the user can change the value.
- *
- * 03/10/2006 - Iskander's use of randmax=1/RAND_MAX is incorrect. Changed to randmax=1.0/RAND_MAX. Note rand() is in stdlib.h and time() is in time.h.
- * - Fatal BUG by Iskander to have eye(n) instead of eye(nn). Corrected by TZ.
- *
-========================================================*/
-
-//#include "csminwel.h"
-#include "optpackage.h"
-
-#define VERBOSE_WARNINGS //Display warnings.
-#define VERBOSE_DETOUTPUT //Display detailed output.
-#define STRLEN 192
-//#define INDXNUMGRAD_CSMINWEL 2 //Index for choosing the numerical gradient. 1, forward difference; 2, central difference.
-
-double GRADSTPS_CSMINWEL = 1.0e-04; //Default value. Will be overwritten by the data in the input file if it exists.
- //1.0e-04 (for monthly TBVAR)
- //Step size for numerical gradient only when the value of x is less than 1.0 in absolute value.
- //If abs(x)>1.0, the step size is GRADSTPS_CSMINWEL*x.
-static int RANDOMSEED_CSMINWEL = 0; //Default value: no fixed seed. Will be initialized somewhere else through csminwel_randomseedChanged().
-
-
-static double GLB_sclForHess;
-static int numgrad(double *g, double *x, int n,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims);
-static void csminit(double *fhat, double *xhat, int *fcount, int *retcode,
- double *x0, double f0, double *g, int badg, double *H0, int n,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims);
-static void bfgsi(double *H, double *dg, double *dx, int n, int nn);
-static int peakwall(double *g, int retcode, double *x, int n,
- int (*gfcn)(double *x, int n, double *g, double **args, int *dims),
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims);
-static double times(double *x, double *y, int n);
-static double *mtimes(double *x, double *y, int n, int nn);
-static double *mminus(double *x, double *y, int n);
-
-
-static FILE *fptr_interesults = (FILE *)NULL; //Printing intermediate results to a file.
-static char filename_sp2vecs[STRLEN]; //Two vectors. 1st row: numerical gradient; 2nd row: vectorized parameters.
-
-
-
-#define MAX_NUM_BADCASES 3
-#define EPS (1.0e-10) //Small number to rectify special case of converging to exactly zero function value.
-#define TERMINATEVALUE (1.0e+300) //If the value of the objective function at the intial value is greater than this, terminates the program.
-void csminwel(double (*fcn)(double *x, int n, double **args, int *dims),
- double *xh, int n, double *H, double *gh,
- int (*gfcn)(double *x, int n, double *g, double **args, int *dims),
- double *fh, double crit, int *itct, int nit,
- int *fcount, int *retcodeh, double **args, int *dims)
-{
- //If gfcn is passed as NULL, numerical gradient is automatically computed.
- //unsigned int randomseed = (unsigned int)time((time_t)RANDOMSEED_CSMINWEL); //793;
-
- unsigned int randomseed;
- static int first_time = TZ_TRUE; //Added by T.Zha; 03/10/2006.
-
- int done=0, badg[4], badgh, nogh=1, stuck=0;
- double *x[4], *g[4], f[4], *dg, *dx;
- int retcode[3], fc=0, ih, nn, i;
- int cnt_n_badcases = 0; //Must set to 0. Counts the number of bad cases before restarting with the initial diagonal (inverse of) Hessian. Added by TZ.
- TSdmatrix *H_dm = tzMalloc(1, TSdmatrix); //H_dm wil point to the same location as H.
- #ifdef VERBOSE_DETOUTPUT
- time_t begtime, currentime;
- #endif
-
- //=== Seed for random number generator in stdlib.h. Added by T.Zha; 03/10/2006.
- if (!RANDOMSEED_CSMINWEL)
- randomseed = (unsigned int)time((time_t *)NULL);
- //Note that (unsigned int)time(0) uses the time of day for random seed.
- //Added by T.Zha; 03/10/2006. time() is in time.h.
- else
- randomseed = (unsigned int)RANDOMSEED_CSMINWEL;
-
- if ( first_time )
- {
- first_time = TZ_FALSE;
- srand( randomseed );
- }
-
-
- GLB_sclForHess = H[0]; //The scale factor for the initial (inverse of) Hessian, which was supposed to be **diagonal**. Added by TZ.
-
- nn = n*n; /* n: dimension size of x or xh */
- *itct = -1; /* itct: number of actual iterations */
- *fcount = -1; /* fcount: number of evaluations of the function */
-
- for (i=0; i<4; i++)
- x[i] = tzMalloc(n, double); //x[i] = calloc(n, sizeof(double)); Commented out by TZ.
- memcpy(x[0],xh,n*sizeof(double));
-
- for (i=0; i<4; i++)
- g[i] = tzMalloc(n, double); //calloc(n, sizeof(double)); Commented out by TZ.
-
- f[0] = fcn(x[0],n,args,dims);
-
- if (f[0] > TERMINATEVALUE) {
- printf("Bad initial parameter. Minimization is terminated without any returned value!\n");
- return;
- }
-
- if (gfcn)
- /* if grad is a string, compute it */
- badg[0] = gfcn(x[0],n,g[0],args,dims);
- else
- /* if grad is not string, compute it */
- badg[0] = numgrad(g[0],x[0],n,fcn,args,dims);
- retcode[2] = 101;
- /* iterate until done is false */
- while (!done) {
- #ifdef VERBOSE_DETOUTPUT
- time(&begtime);
- #endif
-
- for (i=0; i<n; i++)
- g[1][i] = g[2][i] = g[3][i] = 0;
-
-// #ifdef VERBOSE_DETOUTPUT
-// printf("-----------------\n-----------------\n");
-// printf("f at the beginning of new iteration, %.10f\nx = ",f[0]);
-// for (i=0; i<n; i++) {
-// printf("%15.8g ",x[0][i]);
-// if (i%4==3) printf("\n");
-// }
-// if (i%4>0) printf("\n");
-// #endif
-
- (*itct)++;
- csminit(&f[1],x[1],&fc,&retcode[0],x[0],f[0],g[0],badg[0],H,n,fcn,args,dims);
- *fcount += fc;
- /* if retcode1=1 gradient is zero and you are at the peak */
- if (retcode[0]!=1) {
- badg[1] = peakwall(g[1],retcode[0],x[1],n,gfcn,fcn,args,dims);
- /* Bad gradient or back and forth on step length.
- Possibly at cliff edge. Try perturbing search direction. */
- if (badg[1]) {
- double *Hcliff = tzMalloc(nn, double); //calloc(nn,sizeof(double)); Commented out by TZ.
- double randmax=1.0/(double)RAND_MAX; //03/10/2006, changed from 1/ to 1.0/ to make randmax a legal double.
- /* if stuck, give it another try by perturbing Hessian */
- memcpy(Hcliff,H,nn*sizeof(double));
- for (i=0; i<nn; i+=n+1)
- Hcliff[i] *= 1+rand()*randmax; //DDDDebugging. Hcliff[i] *= 1+0.5;
-
- #ifdef VERBOSE_WARNINGS
- printf("======= Random search takes place now. =======\n");
- printf("Cliff. Perturbing search direction.\n");
- #endif
-
- csminit(&f[2],x[2],&fc,&retcode[1],x[0],f[0],g[0],badg[0],Hcliff,n,fcn,args,dims);
- *fcount += fc;
- if (f[2] < f[0]) {
- badg[2] = peakwall(g[2],retcode[1],x[2],n,gfcn,fcn,args,dims);
- if (badg[2]) {
- double *xx = tzMalloc(n, double), nx; //calloc(n,sizeof(double)), nx; Commented out by TZ.
-
- #ifdef VERBOSE_WARNINGS
- printf("Cliff again. Try traversing.\n");
- #endif
-
- for (i=0; i<n; i++)
- xx[i] = x[2][i]-x[1][i];
- nx = times(xx,xx,n);
- if (sqrt(nx) < 1e-13) {
- f[3] = f[0];
- memcpy(x[3],x[0],n*sizeof(double));
- badg[3] = 1;
- retcode[2] = 101;
- } else {
- double *gcliff = tzMalloc(n, double), //calloc(n,sizeof(double)), Commented out by TZ.
- *eye = tzMalloc(nn, double); //calloc(n,sizeof(double)); Bugs of Iskander. Changed from n to nn. 03/10/06.
- double dfnx = (f[2]-f[1])/nx;
- for (i=0; i<n; i++) {
- gcliff[i] = dfnx*xx[i];
- eye[i*(n+1)] = 1;
- }
- csminit(&f[3],x[3],&fc,&retcode[2],x[0],f[0],gcliff,0,eye,n,fcn,args,dims);
- *fcount += fc;
- badg[3] = peakwall(g[3],retcode[2],x[3],n,gfcn,fcn,args,dims);
- tzDestroy(eye);
- tzDestroy(gcliff);
- }
- tzDestroy(xx);
- } else {
- f[3] = f[0];
- memcpy(x[3],x[0],n*sizeof(double));
- badg[3] = 1;
- retcode[2] = 101;
- }
- } else {
- f[3] = f[0];
- memcpy(x[3],x[0],n*sizeof(double));
- badg[3] = 1;
- retcode[2] = 101;
- }
- tzDestroy(Hcliff);
- } else {
- /* normal iteration, no walls, or else we're finished here. */
- f[2] = f[0];
- f[3] = f[0];
- badg[2] = 1;
- badg[3] = 1;
- retcode[1] = 101;
- retcode[2] = 101;
- }
- }
- else //Bugs fixed by T. Zha -- 02/24/05.
- {
- f[1] = f[0];
- f[2] = f[0];
- f[3] = f[0];
- retcode[1] = retcode[0];
- retcode[2] = retcode[0];
- }
-// % normal iteration, no walls, or else we're finished here.
-// f2=f; f3=f; badg2=1; badg3=1; retcode2=101; retcode3=101;
-// f1=f; f2=f; f3=f; retcode2=retcode1; retcode3=retcode1;
-
- /* how to pick gh and xh */
- if (f[3]<f[0] && badg[3]==0) {
- /* if 3 (transversing) was needed, it improved and gradient is good, take that */
- ih = 3;
- *fh = f[3];
- memcpy(xh,x[3],n*sizeof(double));
- memcpy(gh,g[3],n*sizeof(double));
- badgh = badg[3];
- *retcodeh = retcode[2];
- }
- else if (f[2]<f[0] && badg[2]==0) {
- /* if 2 (perturbig) was needed, it improved and gradient is good, take that */
- ih = 2;
- *fh = f[2];
- memcpy(xh,x[2],n*sizeof(double));
- memcpy(gh,g[2],n*sizeof(double));
- badgh = badg[2];
- *retcodeh = retcode[1];
- }
- else if (f[1]<f[0] && badg[1]==0) {
- /* if first try went fine, take that */
- ih = 1;
- *fh = f[1];
- memcpy(xh,x[1],n*sizeof(double));
- memcpy(gh,g[1],n*sizeof(double));
- badgh = badg[1];
- *retcodeh = retcode[0];
- }
- else {
- /* if nothing worked, just take the min of your attempts and compute the gradient */
- if (f[1] <= f[2])
- if (f[1] <= f[3]) ih = 1;
- else ih = 3;
- else
- if (f[2] <= f[3]) ih = 2;
- else ih = 3;
- *fh = f[ih];
- memcpy(xh,x[ih],n*sizeof(double));
- *retcodeh = retcode[ih-1];
- if (nogh) {
- nogh = 0;
- if (gfcn)
- badgh = gfcn(xh,n,gh,args,dims);
- else
- badgh = numgrad(gh,xh,n,fcn,args,dims);
- }
- badgh = 1;
- }
- /* end of picking */
- stuck = fabs(*fh-f[0]) < crit; // Used if fh>0. TZ, 9/03.
- //stuck = (2.0*fabs(*fh-f[0]) <= crit*(fabs(*fh)+fabs(f[0])+EPS)); //Used if fh<0. Added by TZ, 9/03.
- /* if nothing REALLY worked, too bad, you're stuck */
- if (!badg[0] && !badgh && !stuck) {
- /* if you are not stuck, update H0 matrix */
- dg = mminus(gh,g[0],n);
- dx = mminus(xh,x[0],n);
- bfgsi(H,dg,dx,n,nn);
- tzDestroy(dx);
- tzDestroy(dg);
- }
-
- #ifdef VERBOSE_DETOUTPUT
- //=== Prints out intermediate results.
- printf("========================================\n");
- printf(" (1) New value of the obj. func. on iteration %d: %.9f\n (2) Old value: %.9f\n (3) Downhill improvement: %.9f\n",
- (int)*itct, *fh, f[0], f[0]-(*fh));
-
- time(¤time);
- //=== Times the iterative progress.
- printf(" (4) Seconds to complete one iteration: %0.4f\n (5) Current time of day: %s\n\n", difftime(currentime, begtime), ctime(¤time));
- fflush(stdout); // Flush the buffer to get out this message without delay.
- #endif
-
- //--------- Prints outputs to a file. ---------
- if ( !(fptr_interesults = fopen(filename_sp2vecs,"w")) ) {
- printf("\n\nUnable to create the starting point data file %s in csminwel.c!\n", filename_sp2vecs);
- getchar();
- exit(EXIT_FAILURE);
- }
- fprintf(fptr_interesults, "========= Only one block at a time if more-than-one blocks are used. ========== \n");
- fprintf(fptr_interesults, "--------Numerical gradient---------\n");
- for (i=0; i<n; i++) fprintf(fptr_interesults, " %0.16e ", gh[i]);
- fprintf(fptr_interesults, "\n");
- fprintf(fptr_interesults, "--------Restarting point---------\n");
- for (i=0; i<n; i++) fprintf(fptr_interesults, " %0.16e ", xh[i]);
- fprintf(fptr_interesults, "\n\n");
- fflush(fptr_interesults);
- tzFclose(fptr_interesults);
-
- if ((int)*itct > nit) {
- #ifdef VERBOSE_WARNINGS
- printf("\nWarning: termination as the maximum number of iterations is reached.\n");
- #endif
- done = 1;
- }
- else if (stuck) {
- #ifdef VERBOSE_DETOUTPUT
- printf("\nConvergence (improvement < crit %.4e) with return code %d.\n", crit, *retcodeh);
- #endif
-
- done = 1;
- }
-
-
- #ifdef VERBOSE_WARNINGS
- switch (*retcodeh) {
- case 1:
- printf("\nCoverged: Zero gradient.\n"); break;
- case 2:
- printf("\nWarning: Back adjustment of stepsize didn't finish.\n"); break;
- case 3:
- printf("\nWarning: Smallest stepsize still improving too slow.\n"); break;
- case 4:
- printf("\nWarning: Forth adjustment of stepsize didn't finish.\n"); break;
- case 6:
- printf("\nWarning: Smallest step still improving too slow, reversed gradient.\n"); break;
- case 5:
- printf("\nWarning: Largest stepsize still improving too fast.\n"); break;
- case 7:
- printf("\nWarning: Possible inaccuracy in Hessian matrix.\n"); break;
- }
- #endif
-
- //=== Restarts from the initial (inverse of) Hessian when stuck for a while in bad cases. Added by TZ.
- if (*retcodeh && *retcodeh != 1)
- if (++cnt_n_badcases >= MAX_NUM_BADCASES) {
- H_dm->M = H;
- H_dm->nrows = H_dm->ncols = n;
- InitializeDiagonalMatrix_lf(H_dm, GLB_sclForHess);
- //H_dm->flag = M_GE | M_SU | M_SL; //Hessian is symmetric.
- cnt_n_badcases = 0; //Reset after we restart wtih the initial Hessian.
- #ifdef VERBOSE_WARNINGS
- printf("Hessian is reset to the initial value because the maximum number of bad cases, %d, is reached!\n", MAX_NUM_BADCASES);
- #endif
- }
-
- f[0] = *fh;
- memcpy(x[0],xh,n*sizeof(double));
- memcpy(g[0],gh,n*sizeof(double));
- badg[0] = badgh;
- }
-
-
- //--------- Prints outputs to a file. ---------
- if ( !(fptr_interesults = fopen(filename_sp2vecs,"w")) ) {
- printf("\n\nUnable to create the starting point data file %s in csminwel.c!\n", filename_sp2vecs);
- getchar();
- exit(EXIT_FAILURE);
- }
- fprintf(fptr_interesults, "========= Only a block at a time if more-than-one blocks are used. ========== \n");
- fprintf(fptr_interesults, "--------Numerical gradient---------\n");
- for (i=0; i<n; i++) fprintf(fptr_interesults, " %0.16e ", g[0][i]);
- fprintf(fptr_interesults, "\n");
- fprintf(fptr_interesults, "--------Restarting point---------\n");
- for (i=0; i<n; i++) fprintf(fptr_interesults, " %0.16e ", x[0][i]);
- fprintf(fptr_interesults, "\n\n");
- fflush(fptr_interesults);
- tzFclose(fptr_interesults);
-
-
- //=== Frees memory.
- for (i=0; i<4; i++) {
- tzDestroy(g[i]);
- tzDestroy(x[i]);
- }
- tzDestroy(H_dm);
-}
-#undef MAX_NUM_BADCASES
-#undef EPS
-#undef TERMINATEVALUE
-
-
-#if INDXNUMGRAD_CSMINWEL == 1
- #define SCALE 1.0
- static int numgrad(double *g, double *x, int n,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- //Forward difference gradient method.
- double delta, deltai;
- double f0, g0, ff, tmp, *xp;
- int i;
- int badg;
- f0 = fcn(x,n,args,dims);
- badg = 0;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- delta=SCALE*GRADSTPS_CSMINWEL, deltai=1.0/delta; //e+5/SCALE;
-
- tmp = *xp;
- *xp += delta;
- delta = *xp - tmp; // This increases the precision slightly. Added by TZ.
- if ( (ff=fcn(x,n,args,dims)) < NEARINFINITY ) g0 = (ff-f0)*deltai; //Not over the boundary.
- else {
- //Switches to the other side of the boundary.
- *xp = tmp - delta;
- g0 = (f0-fcn(x,n,args,dims))*deltai;
- }
-
- *xp = tmp; //Puts back to the original place. TZ, 9/03.
- if (fabs(g0)<1.0e+15)
- *g = g0;
- else {
- #ifdef VERBOSE_WARNINGS
- printf("Bad gradient.\n");
- #endif
-
- *g = 0;
- badg = 1;
- }
- }
- return badg;
- }
- //#elif INDXNUMGRAD_CSMINWEL == 2
-#else
- //#define STPS 1.0e-04 // 6.0554544523933391e-6 step size = pow(DBL_EPSILON,1.0/3)
- static int numgrad(double *g, double *x, int n,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- //Central difference gradient method. Added by TZ.
- double dh;
- double f0, fp, fm, tmp, *xp;
- int i;
- int badg;
-
- badg = 0;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? GRADSTPS_CSMINWEL : GRADSTPS_CSMINWEL*(*xp);
-
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x,n,args,dims);
- *xp = tmp - dh;
- fm = fcn(x,n,args,dims);
-
- //=== Checking the boundary condition for the minimization problem.
- if (fp >= NEARINFINITY) {
- *xp = tmp; //Puts back to the original place. TZ, 9/03.
- f0 = fcn(x,n,args,dims);
- *g = (f0-fm)/dh;
- }
- else if (fm >= NEARINFINITY) {
- //Switches to the other side of the boundary.
- *xp = tmp; //Puts back to the original place. TZ, 9/03.
- f0 = fcn(x,n,args,dims);
- *g = (fp-f0)/dh;
- }
- else {
- *g = (fp-fm)/(2.0*dh);
- *xp = tmp; //Puts back to the original place. TZ, 9/03.
- }
-
- if (fabs(*g)>1.0e+15) {
- #ifdef VERBOSE_WARNINGS
- printf("Bad gradient.\n");
- #endif
- *g = 0.0;
- badg = 1;
- }
- }
- return badg;
- }
-#endif
-////#undef INDXNUMGRAD_CSMINWEL
-////#undef GRADSTPS_CSMINWEL
-
-
-
-
-#define ANGLE 0.01 //When output of this variable becomes negative, we have a wrong analytical graident.
- //.005 works for identified VARs and OLS.
- //.005 implies 89.71 degrees (acrcos(ANGLE)*180/pi).
- //.01 implies 89.43 degrees (acrcos(ANGLE)*180/pi).
- //.05 implies 87.13 degrees (acrcos(ANGLE)*180/pi).
- //.1 implies 84.26 degrees (acrcos(ANGLE)*180/pi).
-#define THETA .4 //(0<THETA<.5) THETA near .5 makes long line searches, possibly fewer iterations.
- //.1 works for OLS or other nonlinear functions.
- //.3 works for identified VARs.
-#define FCHANGE 1000
-#define MINLAMB 1e-9
-#define MINDFAC .01
-static void csminit(double *fhat, double *xhat, int *fcount, int *retcode,
- double *x0, double f0, double *g, int badg, double *H0, int n,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- double lambda=1, gnorm=0, dxnorm=0, factor=3, lambdaPeak=0;
- double f, dfhat, a, tmp, fPeak=f0, lambdaMax=DBL_MAX;
- double *dx, *dxtest;
- int done=0, shrink=1, shrinkSignal, growSignal;
- int i;
-
- memcpy(xhat, x0, n*sizeof(double)); //Iskander's original code does not have this line, which is a major bug. Corrected by TZ.
- *fhat = f0;
- *fcount = 0;
- *retcode = 0;
- gnorm = sqrt(times(g,g,n));
- if ((gnorm < 1.e-12) && !badg)
- *retcode = 1; /* gradient convergence */
- else {
- /* with badg 1, we don't try to match rate of improvement to directional
- derivative. We're satisfied just to get some improvement in f. */
- dx = tzMalloc(n, double); //dx = calloc(n, sizeof(double)); Commented out by TZ.
- //if (!dx) printf("Dynamic memory allocation error.\n"); Commnted out by TZ.
- for (i=0; i<n; i++)
- dx[i] = -times(&H0[i*n],g,n);
- dxnorm = sqrt(times(dx,dx,n));
- if (dxnorm > 1e12) {
- #ifdef VERBOSE_WARNINGS
- printf("Near-singular H problem.\n");
- #endif
-
- for (i=0; i<n; i++)
- dx[i] *= FCHANGE/dxnorm;
- }
- dfhat = times(dx,g,n);
- if (!badg) {
- /* If the gradient is good, test for alignment of dx with gradient and fix if necessary */
-
- if ((a=-dfhat/(gnorm*dxnorm))<ANGLE) {
- tmp = (ANGLE*dxnorm+dfhat/gnorm)/gnorm;
- for (i=0; i<n; i++)
- dx[i] -= tmp*g[i];
- dfhat = times(dx,g,n);
- dxnorm = sqrt(times(dx,dx,n));
-
- #ifdef VERBOSE_DETOUTPUT
- printf("Correct for low angle: %g\n",a);
- #endif
- }
- }
-
- #ifdef VERBOSE_DETOUTPUT
- printf("Predicted improvement: %18.9f, Norm of gradient: %18.9f\n", -dfhat*0.5, gnorm);
- #endif
-
- dxtest = tzMalloc(n, double); //calloc(n, sizeof(double)); Commented out by TZ.
- while (!done) {
- for (i=0; i<n; i++)
- dxtest[i] = x0[i]+dx[i]*lambda;
- f = fcn(dxtest,n,args,dims);
-
- #ifdef VERBOSE_DETOUTPUT
- printf("lambda = %10.5g; f = %20.7e\n",lambda,f);
- #endif
-
- if (f<*fhat) {
- *fhat = f;
- memcpy(xhat,dxtest,n*sizeof(double));
- }
- (*fcount)++;
- tmp = -THETA*dfhat*lambda;
-
- /* the optimal lambda should be such that f0-f > -THETA*dfhat*lambda (see Berndt et al.)
- If that's not the case and grad is good, OR
- if grad is bad and f is not going down, shrinkSignal = 1 */
- shrinkSignal = ( !badg && (f0-f <= (tmp>0?tmp:0)) ) ||
- ( badg && (f0-f < 0 ) );
-
- /* the optimal lambda should also be such that f0-f<-(1-THETA)*dfhat*lambda
- If that's not the case with lambda>0, AND grad is good, growthSignal = 1 */
- growSignal = !badg && ( (lambda > 0) && (f0-f >= -(1-THETA)*dfhat*lambda) );
-
- /* If shrinkSignal=1 AND ( lambda>lambdaPeak or lambda negative )
- (note when lambdaPeak=0 the second part only excludes lambda=0)
- try shrinking lambda */
- if ( shrinkSignal && ( (lambda>lambdaPeak) || (lambda<0) ) ) {
- /* if shrink=0 OR lambda/factor is already smaller than lambdaPeak, increase factor */
- if ( (lambda>0) && ((!shrink) || (lambda/factor <= lambdaPeak)) ) {
- shrink = 1;
- factor = pow(factor,.6);
- while (lambda/factor <= lambdaPeak)
- factor = pow(factor,.6);
- if (fabs(factor-1)<MINDFAC) {
- if (fabs(lambda) < 4)
- *retcode = 2;
- else
- *retcode = 7;
- done = 1;
- }
- }
- if ((lambda<lambdaMax) && (lambda>lambdaPeak))
- lambdaMax=lambda;
- /* shrink lambda */
- lambda /= factor;
- /* if lambda has already been shrunk as much as possible */
- if (fabs(lambda) < MINLAMB)
- /* if lambda is positive AND you have not made any improvement
- try going against gradient, which may be inaccurate */
- if ((lambda > 0) && (f0 <= *fhat))
- lambda = -lambda*pow(factor,6);
- else {
- /* if lambda is negative: let it be known and quit trying */
- if (lambda < 0)
- *retcode = 6;
- /* if you have not made any imporvement:
- let it be known and quit trying */
- else
- *retcode = 3;
- done = 1;
- }
- }
- /* If growSignal=1 and lambda positive OR ( lambda>lambdaPeak or lambda negative )
- (note when lambdaPeak=0 the second part only excludes lambda=0)
- try increase lambda */
- else
- if ( (growSignal && (lambda > 0) ) ||
- ( shrinkSignal && (lambda <= lambdaPeak) && (lambda > 0) ) ) {
- if (shrink) {
- shrink = 0;
- factor = pow(factor,.6);
- if (fabs(factor-1) < MINDFAC) {
- if (fabs(lambda) < 4)
- *retcode = 4;
- else
- *retcode = 7;
- done = 1;
- }
- }
- if ( (f<fPeak) && (lambda>0) ) {
- fPeak = f;
- lambdaPeak = lambda;
- if (lambdaMax <= lambdaPeak)
- lambdaMax = lambdaPeak*factor*factor;
- }
- /* increase lambda (up to 1e20) */
- lambda *= factor;
- /* if lambda has been increased up to the limit and
- you have not made any imporvement:
- let it be known and quit trying */
- if (fabs(lambda) > 1e20) {
- *retcode = 5;
- done = 1;
- }
- }
- /* If growthSignal=shrinkSignal=0 you found a good lambda, you are done */
- else {
- done = 1;
- *retcode = factor<1.2 ? 7 : 0;
- }
- }
- tzDestroy(dxtest);
- tzDestroy(dx);
- }
- #ifdef VERBOSE_DETOUTPUT
- printf("Norm of dx %10.5g\n", dxnorm);
- #endif
-}
-#undef ANGLE
-#undef THETA
-#undef FCHANGE
-#undef MINLAMB
-#undef MINDFAC
-
-
-static double times(double *x, double *y, int n) {
- double z = 0;
- int i;
- for (i=0; i<n; i++, x++, y++)
- z += (*x)*(*y);
- return z;
-}
-
-static int peakwall(double *g, int retcode, double *x, int n,
- int (*gfcn)(double *x, int n, double *g, double **args, int *dims),
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- /* if retcode=2 or 4 you have shrunk or increased lambda as much as you could:
- exhausted search possibilities the csminit step has failed */
- if (retcode==2 || retcode==4)
- return 1;
- else
- /* if you are not at the peak but the csminit has improved,
- compute the gradient again to update H0 */
- if (gfcn)
- return gfcn(x,n,g,args,dims);
- else
- return numgrad(g,x,n,fcn,args,dims);
-}
-
-static void bfgsi(double *H, double *dg, double *dx, int n, int nn) {
- double *Hdg, *dxdx, *dxHdg, *Hdgdx;
- double dgdx, m;
- int i;
- TSdmatrix *H_dm = NULL;
-
- Hdg = tzMalloc(n, double); //calloc(n, sizeof(double)); Commented out by TZ.
- //if (!Hdg) printf("Dynamic memory allocation error.\n"); Commented out by TZ.
-
- /* Hdg = H0*dg; */
- for (i=0; i<n; i++)
- Hdg[i] = times(&H[i*n],dg,n);
- /* dgdx = dg'*dx; */
- dgdx = 1/times(dg,dx,n);
- if (fabs(dgdx)<1e12) {
- dxdx = mtimes(dx,dx,n,nn);
- dxHdg = mtimes(dx,Hdg,n,nn);
- Hdgdx = mtimes(Hdg,dx,n,nn);
- m = 1+times(dg,Hdg,n)*dgdx;
- for (i=0; i<nn; i++, H++, dxdx++, dxHdg++, Hdgdx++)
- *H += (m*(*dxdx)-(*dxHdg)-(*Hdgdx))*dgdx;
- free(Hdgdx-nn);
- Hdgdx=NULL; //DDDDDebugging.
- free(dxHdg-nn);
- dxHdg = NULL;
- free(dxdx-nn);
- dxdx = NULL;
- }
- else {
- //=== Restarting the inverse of Hessian at its initial value. Added by TZ.
- H_dm = tzMalloc(1, TSdmatrix); //H_dm wil point to the same location as H.
- H_dm->M = H;
- H_dm->nrows = H_dm->ncols = n;
- InitializeDiagonalMatrix_lf(H_dm, GLB_sclForHess);
- //H_dm->flag = M_GE | M_SU | M_SL; //Hessian is symmetric.
- tzDestroy(H_dm);
-
- #ifdef VERBOSE_WARNINGS
- printf("BFGS update failed.\n");
- printf("|dg| = %f |dx| = %f\n",sqrt(times(dg,dg,n)),sqrt(times(dx,dx,n)));
- printf("dg\'*dx = %f\n",dgdx);
- printf("|H*dg| = %f\n",sqrt(times(Hdg,Hdg,n)));
- #endif
- }
- tzDestroy(Hdg);
-}
-
-static double *mtimes(double *x, double *y, int n, int nn) {
- double *x0;
- double *z;
- int i, j;
- z = tzMalloc(nn, double); //calloc(nn, sizeof(double)); Commented out by TZ.
- for (i=0, x0=x; i<n; i++, y++)
- for (j=0, x=x0; j<n; j++, x++, z++)
- *z = (*x)*(*y);
- return z-nn;
-}
-
-static double *mminus(double *x, double *y, int n) {
- double *z;
- int i;
- z = tzMalloc(n, double); //calloc(n, sizeof(double)); Commented out by TZ.
- for (i=0; i<n; i++, x++, y++, z++)
- *z = (*x)-(*y);
- return z-n;
-}
-
-
-//=== The following two extern functions to be accessed by other C files.
-void csminwel_SetPrintFile(char *filename) {
- if (!filename) sprintf(filename_sp2vecs, "outdata5csminwel.prn"); //Default filename.
- else if (STRLEN-1 < strlen(filename)) fn_DisplayError(".../csminwel.c: the allocated length STRLEN for filename_sp2vecs is too short. Must increase the string length");
- else strcpy(filename_sp2vecs, filename);
-}
-int csminwel_randomseedChanged(int seednumber)
-{
- int oldseednumber = RANDOMSEED_CSMINWEL;
- RANDOMSEED_CSMINWEL = seednumber;
- return (oldseednumber);
-}
-
-
-
-#undef STRLEN
-
-
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/csminwel.h b/matlab/swz/c-code/utilities/TZCcode/csminwel.h
deleted file mode 100644
index 84915ad36cb579fa5fcbefc53cebe15599867317..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/csminwel.h
+++ /dev/null
@@ -1,23 +0,0 @@
-#ifndef __CSMINWEL_H__
-#define __CSMINWEL_H__
-
-#include "tzmatlab.h"
-
-#include <string.h>
-#include <float.h>
-
-//--- This extern variable allows an input by the user from an input data file.
-extern double GRADSTPS_CSMINWEL;
-
-void csminwel(double (*fcn)(double *x, int n, double **args, int *dims),
- double *x, int n, double *H, double *gh,
- int (*grad)(double *x, int n, double *g, double **args, int *dims),
- double *fh, double crit, int *itct, int nit,
- int *fcount, int *retcodeh, double **args, int *dims);
-// Alternative but less clear way: ... (double (*fcn)(double *, int, double **, int *), ...
-
-void csminwel_SetPrintFile(char *filename);
-int csminwel_randomseedChanged(int seednumber);
-
-
-#endif
diff --git a/matlab/swz/c-code/utilities/TZCcode/cstz.c b/matlab/swz/c-code/utilities/TZCcode/cstz.c
deleted file mode 100644
index f82821d7f7d42ce17846bd1e399c606a1d7308de..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/cstz.c
+++ /dev/null
@@ -1,2791 +0,0 @@
-#include "cstz.h"
-
-#include <float.h>
-#include <string.h> //For memmove, etc.
-#include "mathlib.h"
-
-
-//????????
-//------- For computing inverse Hessian only. -------
-//static struct TStateModel_tag *SetModelGlobalForCovariance(struct TStateModel_tag *smodel_ps);
-//static double ObjFuncForSmodel(double *x0_p, int d_x0);
-//static double opt_logOverallPosteriorKernal(struct TStateModel_tag *smodel_ps, TSdvector *xchange_dv);
-
-static double logCondPostKernTimet(double *xchange_p, int t, struct TStateModel_tag *smodel_ps);
-static double neglogPostKern_hess(double *xchange_pd, struct TStateModel_tag *smodel_ps);
-static void hesscd_smodel(TSdmatrix *H_dm, TSdvector *x_dv, struct TStateModel_tag *smodel_ps, double (*fcn)(double *x, struct TStateModel_tag *), double grdh, double f0);
-
-TSdp2m5 *CreateP2m5(const double p, const double bound)
-{
- TSdp2m5 *x_dp2m5 = tzMalloc(1, TSdp2m5);
-
- if (p<=0.0 && p>=1.0) fn_DisplayError(".../cstz.c/CreateP2m5(): Input probability p must be between 0.0 and 1.0");
- if ((x_dp2m5->bound=bound)<=0.0) fn_DisplayError(".../cstz.c/CreateP2m5(): Real bound must be positive");
-
- x_dp2m5->cnt = 0;
- x_dp2m5->ndeg = 0;
- x_dp2m5->p = tzMalloc(5, double);
- x_dp2m5->q = tzMalloc(5, double);
- x_dp2m5->m = tzMalloc(5, int);
-
- //=== 5 markers.
- x_dp2m5->p[0] = 0.00;
- x_dp2m5->p[1] = 0.5*p;
- x_dp2m5->p[2] = p;
- x_dp2m5->p[3] = 0.5*(1.0+p);
- x_dp2m5->p[4] = 1.00;
- //=== Now 9 markers.
- // x_dp2m5->p[0] = 0.00;
- // x_dp2m5->p[1] = 0.25*p
- // x_dp2m5->p[2] = 0.5*p;
- // x_dp2m5->p[3] = 0.75*p;
- // x_dp2m5->p[4] = p;
- // x_dp2m5->p[5] = 0.25 + 0.75*p;
- // x_dp2m5->p[6] = 0.5*(1.0+p);
- // x_dp2m5->p[7] = 0.75 + 0.25*p;
- // x_dp2m5->p[8] = 1.00;
-
- return (x_dp2m5);
-}
-TSdp2m5 *DestroyP2m5(TSdp2m5 *x_dp2m5)
-{
- if (x_dp2m5) {
- free(x_dp2m5->m);
- free(x_dp2m5->q);
- free(x_dp2m5->p);
-
- free(x_dp2m5);
- return ((TSdp2m5 *)NULL);
- }
- else return (x_dp2m5);
-}
-TSdvectorp2m5 *CreateVectorP2m5(const int n, const double p, const double bound)
-{
- int _i;
- //
- TSdvectorp2m5 *x_dvp2m5 = tzMalloc(1, TSdvectorp2m5);
-
- x_dvp2m5->n = n;
- x_dvp2m5->v = tzMalloc(n, TSdp2m5 *);
- for (_i=n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = CreateP2m5(p, bound);
-
- return (x_dvp2m5);
-}
-TSdvectorp2m5 *DestroyVectorP2m5(TSdvectorp2m5 *x_dvp2m5)
-{
- int _i;
-
- if (x_dvp2m5) {
- for (_i=x_dvp2m5->n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = DestroyP2m5(x_dvp2m5->v[_i]);
- free(x_dvp2m5->v);
-
- free(x_dvp2m5);
- return ((TSdvectorp2m5 *)NULL);
- }
- else return (x_dvp2m5);
-}
-TSdmatrixp2m5 *CreateMatrixP2m5(const int nrows, const int ncols, const double p, const double bound)
-{
- int _i;
- //
- TSdmatrixp2m5 *X_dmp2m5 = tzMalloc(1, TSdmatrixp2m5);
-
- X_dmp2m5->nrows = nrows;
- X_dmp2m5->ncols = ncols;
- X_dmp2m5->M = tzMalloc(nrows*ncols, TSdp2m5 *);
- for (_i=nrows*ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = CreateP2m5(p, bound);
-
- return (X_dmp2m5);
-}
-TSdmatrixp2m5 *DestroyMatrixP2m5(TSdmatrixp2m5 *X_dmp2m5)
-{
- int _i;
-
- if (X_dmp2m5) {
- for (_i=X_dmp2m5->nrows*X_dmp2m5->ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = DestroyP2m5(X_dmp2m5->M[_i]);
- free(X_dmp2m5->M);
-
- free(X_dmp2m5);
- return ((TSdmatrixp2m5 *)NULL);
- }
- else return (X_dmp2m5);
-}
-TSdcellp2m5 *CreateCellP2m5(const TSivector *rows_iv, const TSivector *cols_iv, const double p, const double bound)
-{
- int _i;
- int ncells;
- //
- TSdcellp2m5 *X_dcp2m5 = tzMalloc(1, TSdcellp2m5);
-
-
- if (!rows_iv || !cols_iv || !rows_iv->flag || !cols_iv->flag) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Input row and column vectors must be (1) created and (2) assigned legal values");
- if ((ncells=rows_iv->n) != cols_iv->n) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Length of rows_iv must be the same as that of cols_iv");
-
-
- X_dcp2m5->ncells = ncells;
- X_dcp2m5->C = tzMalloc(ncells, TSdmatrixp2m5 *);
- for (_i=ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = CreateMatrixP2m5(rows_iv->v[_i], cols_iv->v[_i], p, bound);
-
- return (X_dcp2m5);
-}
-TSdcellp2m5 *DestroyCellP2m5(TSdcellp2m5 *X_dcp2m5)
-{
- int _i;
-
- if (X_dcp2m5) {
- for (_i=X_dcp2m5->ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = DestroyMatrixP2m5(X_dcp2m5->C[_i]);
- free(X_dcp2m5->C);
-
- free(X_dcp2m5);
- return ((TSdcellp2m5 *)NULL);
- }
- else return (X_dcp2m5);
-}
-TSdfourthp2m5 *CreateFourthP2m5(const int ndims, const TSivector *rows_iv, const TSivector *cols_iv, const double p, const double bound)
-{
- int _i;
- //
- TSdfourthp2m5 *X_d4p2m5 = tzMalloc(1, TSdfourthp2m5);
-
-
- if (!rows_iv || !cols_iv || !rows_iv->flag || !cols_iv->flag) fn_DisplayError(".../cstz.c/CreateFourthP2m5(): Input row and column vectors must be (1) created and (2) assigned legal values");
- if (rows_iv->n != cols_iv->n) fn_DisplayError(".../cstz.c/CreateFourthP2m5(): Length of rows_iv must be the same as that of cols_iv");
-
-
- X_d4p2m5->ndims = ndims;
- X_d4p2m5->F = tzMalloc(ndims, TSdcellp2m5 *);
- for (_i=ndims-1; _i>=0; _i--)
- X_d4p2m5->F[_i] = CreateCellP2m5(rows_iv, cols_iv, p, bound);
-
- return (X_d4p2m5);
-}
-TSdfourthp2m5 *DestroyFourthP2m5(TSdfourthp2m5 *X_d4p2m5)
-{
- int _i;
-
- if (X_d4p2m5) {
- for (_i=X_d4p2m5->ndims-1; _i>=0; _i--)
- X_d4p2m5->F[_i] = DestroyCellP2m5(X_d4p2m5->F[_i]);
- free(X_d4p2m5->F);
-
- free(X_d4p2m5);
- return ((TSdfourthp2m5 *)NULL);
- }
- else return (X_d4p2m5);
-}
-
-
-
-int P2m5Update(TSdp2m5 *x_dp2m5, const double newval)
-{
- //5-marker P2 algorithm.
- //quantiles q[0] to q[4] correspond to 5-marker probabilities {0.0, p/5, p, (1+p)/5, 1.0}.
- //Outputs:
- // x_dp2m5->q, the markers x_dp2m5->m, is updated and only x_dp2m5->q[2] is used.
- //Inputs:
- // newval: new random number.
- //
- // January 2003.
- int k, j;
- double a;
- double qm, dq;
- int i, dm, dn;
-
-
- if (!x_dp2m5) fn_DisplayError(".../cstz.c/P2m5Update(): x_dp2m5 must be created");
-
- //if (isgreater(newval, -P2REALBOUND) && isless(newval, P2REALBOUND)) {
- if (isfinite(newval) && newval > -x_dp2m5->bound && newval < x_dp2m5->bound) {
- if (++x_dp2m5->cnt > 5) {
- //Updating the quantiles and markers.
- for (i=0; x_dp2m5->q[i]<=newval && i<5; i++) ;
- if (i==0) { x_dp2m5->q[0]=newval; i++; }
- if (i==5) { x_dp2m5->q[4]=newval; i--; }
- for (; i<5; i++) x_dp2m5->m[i]++;
- for (i=1; i<4; i++) {
- dq = x_dp2m5->p[i]*x_dp2m5->m[4];
- if (x_dp2m5->m[i]+1<=dq && (dm=x_dp2m5->m[i+1]-x_dp2m5->m[i])>1) {
- dn = x_dp2m5->m[i]-x_dp2m5->m[i-1];
- dq = ((dn+1)*(qm=x_dp2m5->q[i+1]-x_dp2m5->q[i])/dm+
- (dm-1)*(x_dp2m5->q[i]-x_dp2m5->q[i-1])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] += dq;
- x_dp2m5->m[i]++;
- } else
- if (x_dp2m5->m[i]-1>=dq && (dm=x_dp2m5->m[i]-x_dp2m5->m[i-1])>1) {
- dn = x_dp2m5->m[i+1]-x_dp2m5->m[i];
- dq = ((dn+1)*(qm=x_dp2m5->q[i]-x_dp2m5->q[i-1])/dm+
- (dm-1)*(x_dp2m5->q[i+1]-x_dp2m5->q[i])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] -= dq;
- x_dp2m5->m[i]--;
- }
- }
- }
- else if (x_dp2m5->cnt < 5) {
- //Fills the initial values.
- x_dp2m5->q[x_dp2m5->cnt-1] = newval;
- x_dp2m5->m[x_dp2m5->cnt-1] = x_dp2m5->cnt-1;
- }
- else {
- //=== Last filling of initial values.
- x_dp2m5->q[4] = newval;
- x_dp2m5->m[4] = 4;
- //=== P2 algorithm begins with reshuffling quantiles and makers.
- for (j=1; j<5; j++) {
- a = x_dp2m5->q[j];
- for (k=j-1; k>=0 && x_dp2m5->q[k]>a; k--)
- x_dp2m5->q[k+1] = x_dp2m5->q[k];
- x_dp2m5->q[k+1]=a;
- }
- }
- }
- else ++x_dp2m5->ndeg; //Throwing away the draws to treat exceptions.
-
- return (x_dp2m5->cnt);
-}
-
-void P2m5VectorUpdate(TSdvectorp2m5 *x_dvp2m5, const TSdvector *newval_dv)
-{
- int _i, _n;
-
- if (!x_dvp2m5 || !newval_dv || !newval_dv->flag) fn_DisplayError(".../cstz.c/P2m5VectorUpdate(): (1) Vector struct x_dvp2m5 must be created and (2) input new value vector must be crated and given legal values");
- if ((_n=newval_dv->n) != x_dvp2m5->n)
- fn_DisplayError(".../cstz.c/P2m5VectorUpdate(): dimension of x_dvp2m5 must match that of newval_dv");
-
- for (_i=_n-1; _i>=0; _i--)
- P2m5Update(x_dvp2m5->v[_i], newval_dv->v[_i]);
-}
-
-void P2m5MatrixUpdate(TSdmatrixp2m5 *X_dmp2m5, const TSdmatrix *newval_dm)
-{
- int _i;
- int nrows, ncols;
-
- if (!X_dmp2m5 || !newval_dm || !newval_dm->flag) fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): (1) Matrix struct X_dmp2m5 must be created and (2) input new value matrix must be crated and given legal values");
- if ((nrows=newval_dm->nrows) != X_dmp2m5->nrows || (ncols=newval_dm->ncols) != X_dmp2m5->ncols)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of rows and colums in X_dmp2m5 must match those of newval_dm");
-
- for (_i=nrows*ncols-1; _i>=0; _i--)
- P2m5Update(X_dmp2m5->M[_i], newval_dm->M[_i]);
-}
-
-void P2m5CellUpdate(TSdcellp2m5 *X_dcp2m5, const TSdcell *newval_dc)
-{
- int _i;
- int ncells;
-
- if (!X_dcp2m5 || !newval_dc) fn_DisplayError(".../cstz.c/P2m5CellUpdate(): (1) Cell struct X_dcp2m5 must be created and (2) input new value cell must be crated and given legal values");
- if ((ncells=newval_dc->ncells) != X_dcp2m5->ncells)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of cells in X_dcp2m5 must match that of newval_dc");
-
- for (_i=ncells-1; _i>=0; _i--)
- P2m5MatrixUpdate(X_dcp2m5->C[_i], newval_dc->C[_i]);
-}
-
-void P2m5FourthUpdate(TSdfourthp2m5 *X_d4p2m5, const TSdfourth *newval_d4)
-{
- int _i;
- int ndims;
-
- if (!X_d4p2m5 || !newval_d4) fn_DisplayError(".../cstz.c/P2m5FourthUpdate(): (1) Fourth struct X_d4p2m5 must be created and (2) input new value fourth must be crated and given legal values");
- if ((ndims=newval_d4->ndims) != X_d4p2m5->ndims)
- fn_DisplayError(".../cstz.c/P2m5FourthUpdate(): Number of fourths in X_d4p2m5 must match that of newval_d4");
-
- for (_i=ndims-1; _i>=0; _i--)
- P2m5CellUpdate(X_d4p2m5->F[_i], newval_d4->F[_i]);
-}
-
-
-
-
-//---------------------------------------------------------------------
-//---------------------------------------------------------------------
-#if defined( CSMINWEL_OPTIMIZATION )
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_gradcd(double *g, double *x, int n, double grdh,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // grdh: step size. If ==0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // x: no change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
-
- double dh, fp, fm, tmp, *xp;
- int i;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = grdh?grdh:(fabs(*xp)<1?STPS:STPS*(*xp));
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x,n,args,dims);
- *xp = tmp - dh;
- fm = fcn(x,n,args,dims);
- *g = (fp-fm)/(2*dh);
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
- #undef STPS
-
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_hesscd(double *H, double *x, int n, double grdh,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- double dhi, dhj, f1, f2, f3, f4, tmpi, tmpj, *xpi, *xpj;
- int i, j;
- for (i=0, xpi=x; i<n; i++, xpi++) {
- dhi = grdh?grdh:(fabs(*xpi)<1?STPS:STPS*(*xpi));
- tmpi = *xpi;
- for (j=i, xpj=x+i; j<n; j++, xpj++)
- if (i==j) {
- /* f2 = f3 when i = j */
- f2 = fcn(x,n,args,dims);
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
-
- /* calculate f1 and f4 */
- *xpi = tmpi + 2*dhi;
- f1 = fcn(x,n,args,dims);
- *xpi = tmpi - 2*dhi;
- f4 = fcn(x,n,args,dims);
-
- /* diagonal element */
- H[i*(n+1)] = (f1-2*f2+f4)/(4*dhi*dhi);
-
- /* reset to intial value */
- *xpi = tmpi;
- } else {
- dhj = grdh?grdh:(fabs(*xpj)<1?STPS:STPS*(*xpj));
- tmpj = *xpj;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
- *xpj += dhj;
- dhj = *xpj - tmpj;
-
- /* calculate f1, f2, f3 and f4 */
- *xpj = tmpj + dhj;
- f1 = fcn(x,n,args,dims);
- *xpi = tmpi - dhi;
- f2 = fcn(x,n,args,dims);
- *xpi = tmpi + dhi;
- *xpj = tmpj - dhj;
- f3 = fcn(x,n,args,dims);
- *xpi = tmpi - dhi;
- f4 = fcn(x,n,args,dims);
-
- /* symmetric elements */
- H[i+j*n] = H[j+i*n] = (f1-f2-f3+f4)/(4*dhi*dhj);
-
- /* reset to intial values */
- *xpi = tmpi;
- *xpj = tmpj;
- }
- }
- }
- #undef STPS
-#elif defined( IMSL_OPTIMIZATION )
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_gradcd(double *g, double *x, int n, double grdh,
- double fcn(int n, double *x) // IMSL
- //void NAG_CALL fcn(Integer n,double x[],double *f,double g[],Nag_Comm *comm)
- ) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // grdh: step size. If ==0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // x: no change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
-
- double dh, fp, fm, tmp, *xp;
- int i;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = grdh?grdh:(fabs(*xp)<1?STPS:STPS*(*xp));
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(n,x); // IMSL
- //fcn(n,x,&fp,NULL,NULL); /* NAG */
- *xp = tmp - dh;
- fm = fcn(n,x); // IMSL
- //fcn(n,x,&fm,NULL,NULL);
- *g = (fp-fm)/(2*dh);
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
- #undef STPS
-
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_hesscd(double *H, double *x, int n, double grdh,
- double fcn(int n, double *x) // IMSL
- //void NAG_CALL fcn(Integer n,double x[],double *f,double g[],Nag_Comm *comm)
- ) {
- double dhi, dhj, f1, f2, f3, f4, tmpi, tmpj, *xpi, *xpj;
- int i, j;
- for (i=0, xpi=x; i<n; i++, xpi++) {
- dhi = grdh?grdh:(fabs(*xpi)<1?STPS:STPS*(*xpi));
- tmpi = *xpi;
- for (j=i, xpj=x+i; j<n; j++, xpj++)
- if (i==j) {
- /* f2 = f3 when i = j */
- f2 = fcn(n,x); // IMSL
- //fcn(n,x,&f2,NULL,NULL);
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
-
- /* calculate f1 and f4 */
- *xpi = tmpi + 2*dhi;
- f1 = fcn(n,x); // IMSL
- //fcn(n,x,&f1,NULL,NULL);
- *xpi = tmpi - 2*dhi;
- f4 = fcn(n,x); /* IMSL */
- //fcn(n,x,&f4,NULL,NULL);
-
- /* diagonal element */
- H[i*(n+1)] = (f1-2*f2+f4)/(4*dhi*dhi);
-
- /* reset to intial value */
- *xpi = tmpi;
- } else {
- dhj = grdh?grdh:(fabs(*xpj)<1?STPS:STPS*(*xpj));
- tmpj = *xpj;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
- *xpj += dhj;
- dhj = *xpj - tmpj;
-
- /* calculate f1, f2, f3 and f4 */
- *xpj = tmpj + dhj;
- f1 = fcn(n,x); // IMSL
- //fcn(n,x,&f1,NULL,NULL);
- *xpi = tmpi - dhi;
- f2 = fcn(n,x); // IMSL
- //fcn(n,x,&f2,NULL,NULL);
- *xpi = tmpi + dhi;
- *xpj = tmpj - dhj;
- f3 = fcn(n,x); // IMSL
- //fcn(n,x,&f3,NULL,NULL);
- *xpi = tmpi - dhi;
- f4 = fcn(n,x); // IMSL
- //fcn(n,x,&f4,NULL,NULL);
-
- /* symmetric elements */
- H[i+j*n] = H[j+i*n] = (f1-f2-f3+f4)/(4*dhi*dhj);
-
- /* reset to intial values */
- *xpi = tmpi;
- *xpj = tmpj;
- }
- }
- }
- #undef STPS
-#endif
-
-
-
-//-------------------------------
-//Modified from fn_gradcd() in cstz.c for the conjugate gradient method I or II
-//-------------------------------
-#define STPS 1.0e-04 // 6.0554544523933391e-6 step size = pow(DBL_EPSILON,1.0/3)
-#define GRADMANUAL 1.0e+01 //Arbitrarily (manually) set gradient.
-void gradcd_gen(double *g, double *x, int n, double (*fcn)(double *x, int n), double *grdh, double f0) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // n: the dimension of g or x.
- // fcn(): the function for which the gradient is evaluated
- // grdh: step size. If NULL, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dh, dhi, dh2i, fp, fm, tmp, *xp;
- int i;
-
- if (grdh) {
- //=== If f0 >= NEARINFINITY, we're in a bad region and so we assume it's flat in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 >= NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- dh2i = (dhi=1.0/(dh=*grdh))/2.0;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- tmp = *xp;
- *xp += dh;
- //The following statement is bad because dh does not get reset at the beginning of the loop and thus may get changed continually within the loop.
- // dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fp = fcn(n,x); // IMSL
- //fcn(n,x,&fp,NULL,NULL); /* NAG */
- *xp = tmp - dh;
- fm = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fm = fcn(n,x); // IMSL
- //fcn(n,x,&fm,NULL,NULL);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp < NEARINFINITY) && (fm < NEARINFINITY)) *g = (fp-fm)*dh2i;
- else if (fp < NEARINFINITY) *g = (fp-f0)*dhi;
- else if (fm < NEARINFINITY) *g = (f0-fm)*dhi;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
-
- }
- else {
- //=== If f0 >= NEARINFINITY, we're in a bad region and so we assume it's flat in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 >= NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fp = fcn(n,x); // IMSL
- //fcn(n,x,&fp,NULL,NULL); /* NAG */
- *xp = tmp - dh;
- fm = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fm = fcn(n,x); // IMSL
- //fcn(n,x,&fm,NULL,NULL);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp < 0.5*NEARINFINITY) && (fm < 0.5*NEARINFINITY)) *g = (fp-fm)/(2.0*dh);
- else if (fp < 0.5*NEARINFINITY) *g = (fp-f0)/dh;
- else if (fm < 0.5*NEARINFINITY) *g = (f0-fm)/dh;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
-}
-#undef STPS
-#undef GRADMANUAL
-
-
-//-------------------------------
-//Forward difference gradient: much faster than gradcd_gen() when the objective function is very expensive to evaluate.
-//-------------------------------
-#define STPS 1.0e-04 // 6.0554544523933391e-6 step size = pow(DBL_EPSILON,1.0/3)
-void gradfd_gen(double *g, double *x, int n, double (*fcn)(double *x, int n), double *grdh, double f0) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // n: the dimension of g or x.
- // fcn(): the function for which the gradient is evaluated
- // grdh: step size. If NULL, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dh, dhi, fp, tmp, *xp;
- int i;
- if (grdh) {
- dhi = 1.0/(dh=*grdh);
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- if ( (fp=fcn(x, n)) < NEARINFINITY ) *g = (fp-f0)*dhi; //For frprmn() CGI_OPTIMIZATION
- else {
- //Switches to the other side of the boundary.
- *xp = tmp - dh;
- *g = (f0-fcn(x,n))*dhi;
- }
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
-
- }
- else {
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- if ( (fp=fcn(x, n)) < NEARINFINITY ) *g = (fp-f0)/dh; //For frprmn() CGI_OPTIMIZATION
- else {
- //Switches to the other side of the boundary.
- *xp = tmp - dh;
- *g = (f0-fcn(x,n))/dh;
- }
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
-}
-#undef STPS
-
-
-
-//====================================================================================================
-//= Central difference gradient for logLH at time t, using DW's smodel.
-//====================================================================================================
-#define STPS 1.0e-04 // 6.0554544523933391e-6 step size = pow(DBL_EPSILON,1.0/3)
-#define GRADMANUAL 1.0e+01 //Arbitrarily (manually) set gradient.
-void gradcd_timet(TSdvector *g_dv, TSdvector *x_dv, int t, struct TStateModel_tag *smodel_ps, double (*fcn)(double *x, int t, struct TStateModel_tag *smodel_ps), double grdh, double f0)
-{
- //Outputs:
- // g_dv: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x_dv: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // fcn(): the log LH or posterior function for which the gradient is evaluated
- // grdh: step size. If 0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dh, dhi, dh2i, fp, fm, tmp, *xp;
- int i;
- //--- Accessible variables.
- int n;
- double *g, *x;
-
- if (!g_dv) fn_DisplayError(".../cstz.c/gradcd_timet(): the input g_dv must be allocated memory");
- if (!x_dv) fn_DisplayError(".../cstz.c/gradcd_timet(): the input x_dv must be allocated memory");
- if (!x_dv->flag) fn_DisplayError(".../cstz.c/gradcd_timet(): the input x_dv must be given legal values");
- if ((n=g_dv->n) != x_dv->n) fn_DisplayError(".../cstz.c/gradcd_timet(): dimensions of g_dv and x_dv must be the same");
-
- g = g_dv->v;
- x = x_dv->v;
-
- if (grdh>0.0)
- {
- //=== If f0 <= -0.5*NEARINFINITY, we're in a bad region and so we assume it's GRADMANUAL in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 < -0.5*NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- dh2i = (dhi=1.0/(dh=grdh))/2.0;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- tmp = *xp;
- *xp += dh;
- //The following statement is bad because dh does not get reset at the beginning of the loop and thus may get changed continually within the loop.
- // dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, t, smodel_ps);
- *xp = tmp - dh;
- fm = fcn(x, t, smodel_ps);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp > -0.5*NEARINFINITY) && (fm > -0.5*NEARINFINITY)) *g = (fp-fm)*dh2i;
- else if (fp > -0.5*NEARINFINITY) *g = (fp-f0)*dhi;
- else if (fm > -0.5*NEARINFINITY) *g = (f0-fm)*dhi;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
-
- }
- else {
- //=== If f0 <= -0.5*NEARINFINITY, we're in a bad region and so we assume it's GRADMANUAL in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 <= -0.5*NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, t, smodel_ps);
- *xp = tmp - dh;
- fm = fcn(x, t, smodel_ps);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp > -0.5*NEARINFINITY) && (fm > -0.5*NEARINFINITY)) *g = (fp-fm)/(2.0*dh);
- else if (fp > -0.5*NEARINFINITY) *g = (fp-f0)/dh;
- else if (fm > -0.5*NEARINFINITY) *g = (f0-fm)/dh;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
- g_dv->flag = V_DEF;
-}
-#undef STPS
-#undef GRADMANUAL
-//---
-#if defined (NEWVERSIONofDW_SWITCH)
-static double logCondPostKernTimet(double *xchange_pd, int t, struct TStateModel_tag *smodel_ps)
-{
- //Evaluating log conditional posterior kernel at time t -- p(y_t | Y_{t-1}, theta, q).
- int fss = smodel_ps->nobs - smodel_ps->fobs + 1;
- double *x1_pd, *x2_pd;
-
-
- x1_pd = xchange_pd;
- x2_pd = xchange_pd + NumberFreeParametersTheta(smodel_ps);
- //Note that NumberFreeParametersTheta() is DW's function, which points to TZ's function.
- //In the constant parameter model, this will point to an invalid place,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- //======= This is a must step to refresh the value at the new point. =======
- ConvertFreeParametersToTheta(smodel_ps, x1_pd); //Waggoner's function, which calls TZ's Convertphi2*().
- ConvertFreeParametersToQ(smodel_ps, x2_pd); //Waggoner's function, which automatically takes care of the constant-parameter situition
- ThetaChanged(smodel_ps); //DW's function, which will also call my function to set a flag for refreshing everything under these new parameters.
-
-
- if (1) //Posterior function.
- return ( LogConditionalLikelihood_StatesIntegratedOut(t, smodel_ps) + LogPrior(smodel_ps)/((double)fss) ); //DW's function.
- else //Likelihood (with no prior)
- return ( LogConditionalLikelihood_StatesIntegratedOut(t, smodel_ps) ); //DW's function.
-}
-#endif
-
-//------------------------
-// Computing the Hessian at the log posterior or log likelihood peak, using the outer-product Hessian.
-//------------------------
-#if defined (NEWVERSIONofDW_SWITCH)
-TSdmatrix *ComputeHessianFromOuterProduct(TSdmatrix *Hessian_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv)
-{
- //Output:
- // Hessian_dm: its inverse equals to Omega (covariance matrix) produced by ComputeCovarianceFromOuterProduct().
- //Inputs:
- // xhat_dv: Hessian at this point.
-
- int ti;
- double f0;
- int nData = smodel_ps->nobs;
- //===
- TSdvector *grad_dv;
-
-
- grad_dv = CreateVector_lf(xhat_dv->n);
- if (!Hessian_dm) Hessian_dm = CreateConstantMatrix_lf(xhat_dv->n, xhat_dv->n, 0.0);
-
- //=== Computing the outer-product Hessian.
- for (ti=smodel_ps->fobs; ti<=nData; ti++) //Base-1 set-up, thus <=nData, NOT <nData.
- {
- f0 = logCondPostKernTimet(xhat_dv->v, ti, smodel_ps);
- gradcd_timet(grad_dv, xhat_dv, ti, smodel_ps, logCondPostKernTimet, 0.0, f0);
- VectorTimesSelf(Hessian_dm, grad_dv, 1.0, 1.0, 'U');
- }
-
-
- SUtoGE(Hessian_dm); //Making upper symmetric matarix to a full matrix.
- Hessian_dm->flag = M_GE; //Reset this flag, so
- ScalarTimesMatrixSquare(Hessian_dm, 0.5, Hessian_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Hessian_dm->flag |= M_SU | M_SL;
-
-
- //===
- DestroyVector_lf(grad_dv);
-
- return (Hessian_dm);
-}
-//------------------------
-// Computing the covariance matrix for standard errors at the log posterior or likelihood peak, using the outer-product Hessian.
-//------------------------
-TSdmatrix *ComputeCovarianceFromOuterProduct(TSdmatrix *Omega_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv)
-{
- //Output:
- // Omega_dm: covariance matrix, which equals to the inverse of the Hessian produced by ComputeHessianFromOuterProduct().
- //Inputs:
- // xhat_dv: Hessian at this point.
-
- int ti;
- double f0;
- int nData = smodel_ps->nobs;
- //===
- TSdvector *grad_dv;
-
-
- grad_dv = CreateVector_lf(xhat_dv->n);
- if (!Omega_dm) Omega_dm = CreateConstantMatrix_lf(xhat_dv->n, xhat_dv->n, 0.0);
-
- //=== Computing the outer-product Hessian.
- for (ti=smodel_ps->fobs; ti<=nData; ti++) //Base-1 set-up, thus <=nData, NOT <nData.
- {
- f0 = logCondPostKernTimet(xhat_dv->v, ti, smodel_ps);
- gradcd_timet(grad_dv, xhat_dv, ti, smodel_ps, logCondPostKernTimet, 0.0, f0);
- VectorTimesSelf(Omega_dm, grad_dv, 1.0, 1.0, 'U');
- }
- SUtoGE(Omega_dm); //Making upper symmetric matarix to a full matrix.
- ScalarTimesMatrixSquare(Omega_dm, 0.5, Omega_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Omega_dm->flag |= M_SU | M_SL;
-
-
- //--- Converting or inverting the Hessian to covariance.
- if (invspd(Omega_dm, Omega_dm, 'U'))
- fn_DisplayError(".../cstz.c/ComputeCovarianceFromOuterProduct(): Hessian must be invertible");
-
-
- //-- Doubly safe to force it to be symmetric.
- SUtoGE(Omega_dm); //Making upper symmetric matarix to a full matrix.
- ScalarTimesMatrixSquare(Omega_dm, 0.5, Omega_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Omega_dm->flag |= M_SU | M_SL;
-
- //--- Checking if it's symmetric, positive definite.
-
-
- //===
- DestroyVector_lf(grad_dv);
-
- return (Omega_dm);
-}
-
-
-
-//------------------------
-// Computing the Hessian at the log posterior or log likelihood peak, using second derivatives.
-//------------------------
-TSdmatrix *ComputeHessianFrom2ndDerivative(TSdmatrix *Hessian_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv)
-{
- //Output:
- // Hessian_dm: its inverse equals to Omega (covariance matrix).
- // The flag is set to M_GE | M_SU | M_SL by hesscd_smodel().
- //Inputs:
- // xhat_dv: Hessian at this point.
-
- double f0;
- int nData = smodel_ps->nobs;
-
-
- if (!Hessian_dm) Hessian_dm = CreateConstantMatrix_lf(xhat_dv->n, xhat_dv->n, 0.0);
-
- //=== Computing the inner-product Hessian.
- f0 = neglogPostKern_hess(xhat_dv->v, smodel_ps);
- hesscd_smodel(Hessian_dm, xhat_dv, smodel_ps, neglogPostKern_hess, 0.0, f0);
-
- return (Hessian_dm);
-}
-//---
-#define STPS 1.0e-4 //6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
-static void hesscd_smodel(TSdmatrix *H_dm, TSdvector *x_dv, struct TStateModel_tag *smodel_ps, double (*fcn)(double *, struct TStateModel_tag *), double grdh, double f0)
-{
- //Outputs:
- // H_dm: the Hessian n-by-n (no need to be initialized).
- //Inputs:
- // x_dv: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // fcn(): the negative (-) log LH or posterior function for which the gradient is evaluated
- // grdh: step size. If 0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dhi, dhj, f1, f2, f3, f4, tmpi, tmpj, *xpi, *xpj;
- int i, j;
- //--- Accessible variables.
- int n;
- double *H, *x;
-
- if (!x_dv) fn_DisplayError(".../cstz.c/hesscd_smodel(): the input x_dv must be allocated memory");
- if (!x_dv->flag) fn_DisplayError(".../cstz.c/hesscd_smodel(): the input x_dv must be given legal values");
- if (!H_dm) fn_DisplayError(".../cstz.c/hesscd_smodel(): H_dm must be allocated memory");
- if ( ((n=x_dv->n) != H_dm->nrows) || (n != H_dm->ncols) ) fn_DisplayError(".../cstz.c/hesscd_smodel(): Check the dimension of x_dv and H_dm");
-
- H = H_dm->M;
- x = x_dv->v;
-
- for (i=0, xpi=x; i<n; i++, xpi++) {
- dhi = grdh?grdh:(fabs(*xpi)<1?STPS:STPS*(*xpi));
- tmpi = *xpi;
- for (j=i, xpj=x+i; j<n; j++, xpj++)
- if (i==j)
- {
- /* f2 = f3 when i = j */
- if ((f2 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f2 = f0;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
-
- /* calculate f1 and f4 */
- *xpi = tmpi + 2*dhi;
- if ((f1 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f1 = f0;
-
- *xpi = tmpi - 2*dhi;
- if ((f4 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f4 = f0;
-
- /* diagonal element */
- H[i*(n+1)] = (f1-2*f2+f4)/(4*dhi*dhi);
-
- /* reset to intial value */
- *xpi = tmpi;
- }
- else
- {
- dhj = grdh?grdh:(fabs(*xpj)<1?STPS:STPS*(*xpj));
- tmpj = *xpj;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
- *xpj += dhj;
- dhj = *xpj - tmpj;
-
- /* calculate f1, f2, f3 and f4 */
- *xpj = tmpj + dhj;
- if ((f1 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f1 = f0;
- *xpi = tmpi - dhi;
- if ((f2 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f2 = f0;
- *xpi = tmpi + dhi;
- *xpj = tmpj - dhj;
- if ((f3 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f3 = f0;
- *xpi = tmpi - dhi;
- if ((f4 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f4 = f0;
-
- /* symmetric elements */
- H[i+j*n] = H[j+i*n] = (f1-f2-f3+f4)/(4*dhi*dhj);
-
- /* reset to intial values */
- *xpi = tmpi;
- *xpj = tmpj;
- }
- }
-
- //--- To be safe.
- H_dm->flag = M_SU;
- SUtoGE(H_dm); //Making upper symmetric matarix to a full matrix.
- H_dm->flag = M_GE; //Reset this flag, so
-
- ScalarTimesMatrixSquare(H_dm, 0.5, H_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- H_dm->flag |= M_SU | M_SL;
-}
-#undef STPS
-//---
-static double neglogPostKern_hess(double *xchange_pd, struct TStateModel_tag *smodel_ps)
-{
- //Evaluating negative log posterior kernel p(y_T | theta, q).
- int fss = smodel_ps->nobs - smodel_ps->fobs + 1;
- double *x1_pd, *x2_pd;
-
-
- x1_pd = xchange_pd;
- x2_pd = xchange_pd + NumberFreeParametersTheta(smodel_ps);
- //Note that NumberFreeParametersTheta() is DW's function, which points to TZ's function.
- //In the constant parameter model, this will point to an invalid place,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- //======= This is a must step to refresh the value at the new point. =======
- ConvertFreeParametersToTheta(smodel_ps, x1_pd); //Waggoner's function, which calls TZ's Convertphi2*().
- ConvertFreeParametersToQ(smodel_ps, x2_pd); //Waggoner's function, which automatically takes care of the constant-parameter situition
- ThetaChanged(smodel_ps); //DW's function, which will also call my function to set a flag for refreshing everything under these new parameters.
-
-
- if (1) //Posterior function.
- return ( -LogLikelihood_StatesIntegratedOut(smodel_ps) - LogPrior(smodel_ps) ); //DW's function.
- else //Likelihood (with no prior)
- return ( -LogLikelihood_StatesIntegratedOut(smodel_ps) ); //DW's function.
-}
-#endif
-
-
-
-
-
-
-
-
-
-
-//????????????????
-/**
-//===
-static struct TStateModel_tag *SMODEL_PS = NULL; //Minimization to find the MLE or posterior peak.
-static struct TStateModel_tag *SetModelGlobalForCovariance(struct TStateModel_tag *smodel_ps)
-{
- //Returns the old pointer in order to preserve the previous value.
- struct TStateModel_tag *tmp_ps =SMODEL_PS;
- SMODEL_PS = smodel_ps;
- return (tmp_ps);
-}
-//--- Can be used for conjugate gradient minimization as well.
-static double ObjFuncForSmodel(double *x0_p, int d_x0)
-{
- TSdvector x0_sdv;
- x0_sdv.v = x0_p;
- x0_sdv.n = d_x0;
- x0_sdv.flag = V_DEF;
-
- return ( -opt_logOverallPosteriorKernal(SMODEL_PS, &x0_sdv) );
-}
-//---
-static double opt_logOverallPosteriorKernal(struct TStateModel_tag *smodel_ps, TSdvector *xchange_dv)
-{
- double *x1_pd, *x2_pd;
-
-
- x1_pd = xchange_dv->v;
- x2_pd = xchange_dv->v + NumberFreeParametersTheta(smodel_ps);
- //Note that NumberFreeParametersTheta() is DW's function, which points to TZ's function.
- //In the constant parameter model, this will point to invalid,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- //======= This is a must step to refresh the value at the new point. =======
- ConvertFreeParametersToTheta(smodel_ps, x1_pd); //Waggoner's function, which calls TZ's Convertphi2*().
- ConvertFreeParametersToQ(smodel_ps, x2_pd); //Waggoner's function, which automatically takes care of the constant-parameter situition
- ThetaChanged(smodel_ps); //DW's function, which will also call my function to set a flag for refreshing everything under these new parameters.
- if (1) //Posterior function.
- return ( LogPosterior_StatesIntegratedOut(smodel_ps) ); //DW's function.
- else //Likelihood (with no prior)
- return ( LogLikelihood_StatesIntegratedOut(smodel_ps) ); //DW's function.
-}
-/**/
-
-
-
-
-
-
-
-
-int next_permutation(int *first, int *last)
-{
- // Given the permulation, say, [3 2 1 0], the ouput is the next permulation [0 1 2 3], and so on.
- // Note that last is simply a pointer. Because it is not allocated to a memory, it cannot be accessed.
- // So last is used for (1) gauging the dimension size of the array first;
- // (2) being accssed but with --last (which points to a valid memory place), NOT last.
- //
- // first: n-by-1 vector of integers filled with 0, 1, 2, ..., n.
- // last: simply a pointer to the address after the last element of first. Note that no memory is allocated.
-
- int *i = last, *ii, *j, tmp;
- if (first == last || first == --i)
- return 0;
-
- for(; ; ) {
- ii = i;
- if (*--i < *ii) {
- j = last;
- while (!(*i < *--j));
- tmp = *i; *i = *j; *j = tmp;
- for (; ii != last && ii != --last; ++ii) {
- tmp = *ii; *ii = *last; *last = tmp;
- }
- return 1;
- }
- if (i == first) {
- for (; first != last && first != --last; ++first) {
- tmp = *first; *first = *last; *last = tmp;
- }
- return 0;
- }
- }
-}
-
-
-
-/**
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-void permute_matrix(double *a, int n, int *indx) {
- double *b;
- int nn=n*n;
- register int i;
- b = calloc(nn,sizeof(double));
- memcpy(b, a, nn*sizeof(double));
- for (i=0; i<nn; i++, a++)
- *a = b[indx[i%n]+indx[i/n]*n];
-}
-
-int main() {
- double a[9]={1,2,3,4,5,6,7,8,9};
- int indx[3]={1,2,0};
- permute_matrix(a,3,indx);
- return 0;
-}
-/**/
-
-
-int fn_cumsum_int(int *x_v, const int d_x_v) {
- //Outputs:
- // x_v: an int vector of cumulative sums over an input int vector.
- // return: the sum of an input int vector.
- //Inputs:
- // x_v: a vector of ints.
- // d_x_v: dimension of x_v.
- //
- // Compute cumulative sums of a vector of ints.
- int _i;
-
- if (x_v==NULL) fn_DisplayError(".../cstz/fn_cumsum_lf: x_v must be allocated with memory");
-
- for (_i=1; _i<d_x_v; _i++) {
- x_v[_i] = x_v[_i-1] + x_v[_i];
- }
-
- return (x_v[d_x_v-1]);
-}
-
-
-double fn_cumsum_lf(double *x_v, const int d_x_v) {
- //Outputs:
- // x_v: a double vector of cumulative sums over an input double vector.
- // return: the sum of an input double vector.
- //Inputs:
- // x_v: a vector of doubles.
- // d_x_v: dimension of x_v.
- //
- // Compute cumulative sums of a vector of doubles.
- int _i;
-
- if (!x_v) fn_DisplayError(".../cstz/fn_cumsum_lf: x_v must be allocated with memory");
-
- for (_i=1; _i<d_x_v; _i++) {
- x_v[_i] = x_v[_i-1] + x_v[_i];
- }
-
- return (x_v[d_x_v-1]);
-}
-
-
-double fn_mean(const double *a_v, const int _n) {
- int _i;
- double x=0.0;
-
- for (_i=0; _i<_n; _i++) x += a_v[_i];
- x /= (double)_n;
-
- return x;
-}
-
-//<<---------------
-static double *tz_BaseForComp; // This base variable is to be sorted and thus made global for this source file.
-void fn_SetBaseArrayForComp(TSdvector *x_dv)
-{
- if ( !x_dv->flag ) fn_DisplayError(".../cstz.c/ftd_SetBaseArrayForComp(): input vector used for comparison must be given legal values");
- else tz_BaseForComp = x_dv->v;
-}
-int fn_compare(const void *i1, const void *i2)
-{
- // Ascending order according to tz_BaseForComp.
- return ( (tz_BaseForComp[*((int*)i1)]<tz_BaseForComp[*((int*)i2)]) ? -1 : (tz_BaseForComp[*((int*)i1)]>tz_BaseForComp[*((int*)i2)]) ? 1 : 0 );
-}
-int fn_compare2(const void *i1, const void *i2)
-{
- // Descending order according to tz_BaseForComp.
- return ( (tz_BaseForComp[*((int*)i1)]<tz_BaseForComp[*((int*)i2)]) ? 1 : (tz_BaseForComp[*((int*)i1)]>tz_BaseForComp[*((int*)i2)]) ? -1 : 0);
-}
-//======= Quick sort. =======
-static int ftd_CompareDouble(const void *a, const void *b)
-{
- // Ascending order for the series that contains a and b.
- return (*(double *)a < *(double *)b ? -1 : *(double *)a > *(double *)b ? 1 : 0);
-}
-static int ftd_CompareDouble2(const void *a, const void *b)
-{
- // Dscending order for the series that contains a and b.
- return (*(double *)a < *(double *)b ? 1 : *(double *)a > *(double *)b ? -1 : 0);
-}
-//---
-void tz_sort(TSdvector *x_dv, char ad)
-{
- //x_dv will be replaced by the sorted value.
- //Sort x_dv according to the descending or ascending order indicated by ad.
- //ad == "A' or 'a': acending order.
- //ad == 'D' or 'd': descending order.
- if (!x_dv || !x_dv->flag) fn_DisplayError("cstz.c/tz_sort(): input vector x_dv must be (1) created and (2) assigned values");
-
- qsort( (void *)x_dv->v, (size_t)x_dv->n, sizeof(double), ((ad=='A') || (ad=='a')) ? ftd_CompareDouble : ftd_CompareDouble2);
-}
-void tz_sortindex_lf(TSivector *x_iv, TSdvector *base_dv, char ad)
-{
- //???????NOT fully tested yet.
- //x_iv will be replaced by the sorted integer vector.
- //base_dv will not be affected.
- //Sort x_iv according to the descending or ascending order of base_dv.
- //ad == "A' or 'a': acending order.
- //ad == 'D' or 'd': descending order.
- if (!x_iv || !base_dv || !x_iv->flag || !base_dv->flag) fn_DisplayError("cstz.c/tz_sortindex(): input vectors x_iv and base_dv must be (1) created and (2) assigned values");
- if (x_iv->n != base_dv->n) fn_DisplayError("cstz.c/tz_sortindex(): lengths of the two input vectors must be the same");
-
- fn_SetBaseArrayForComp(base_dv);
- qsort( (void *)x_iv->v, (size_t)x_iv->n, sizeof(int), ((ad=='A') || (ad=='a')) ? fn_compare : fn_compare2);
-}
-void tz_sortindex(TSivector *x_iv, TSvoidvector *base_voidv, char ad)
-{
- //???????NOT fully tested yet.
- //Allowing x_iv = base_voidv or sets base_voidv=NULL
- //Sort x_iv according to the descending or ascending order of base_voidv.
- //ad == "A' or 'a': acending order.
- //ad == 'D' or 'd': descending order.
- if (!x_iv || !base_voidv || !x_iv->flag || !base_voidv->flag) fn_DisplayError("cstz.c/tz_sort_int(): input vectors x_iv and base_voidv must be (1) created and (2) assigned values");
- if (x_iv->n != base_voidv->n) fn_DisplayError("cstz.c/tz_sort_int(): lengths of the two input vectors must be the same");
-
- fn_SetBaseArrayForComp((TSdvector *)base_voidv);
- qsort( (void *)x_iv->v, (size_t)x_iv->n, sizeof(int), ((ad=='A') || (ad=='a')) ? fn_compare : fn_compare2);
-}
-//---
-void tz_sort_matrix(TSdmatrix *X_dm, char ad, char rc)
-{
- //Fast method: rc = 'C' (sort each column).
- //Output: X_dm will be replaced by the sorted value.
- // Sort X_dm (1) by columns or rows indicated by rc and (2) according to the descending or ascending order indicated by ad.
- //Inputs:
- // ad == 'A' or 'a': acending order.
- // ad == 'D' or 'd': descending order.
- // rc == 'C' or 'c': sort each column.
- // rc == 'R' or 'r': sort each row.
- int nrows, ncols, _j, begloc;
- TSdvector x_sdv;
- double *X;
- //===
- TSdmatrix *Xtran_dm = NULL;
-
- if (!X_dm || !(X_dm->flag & M_GE)) fn_DisplayError("cstz.c/tz_sort_matrix(): input matrix X_dm must be (1) created and (2) assigned values and (3) regular (M_GE)");
- x_sdv.flag = V_DEF;
-
- if (rc=='C' || rc=='c')
- {
- X = X_dm->M;
- nrows = X_dm->nrows;
- ncols = X_dm->ncols;
- }
- else
- {
- Xtran_dm = tz_TransposeRegular((TSdmatrix *)NULL, X_dm);
- X = Xtran_dm->M;
- nrows = Xtran_dm->nrows;
- ncols = Xtran_dm->ncols;
- }
- x_sdv.n = nrows;
- for (begloc=nrows*(ncols-1), _j=ncols-1; _j>=0; begloc-=nrows, _j--)
- {
- x_sdv.v = X + begloc;
- tz_sort(&x_sdv, ad);
- }
-
- if (rc=='R' || rc=='r')
- {
- tz_TransposeRegular(X_dm, Xtran_dm);
- //===
- DestroyMatrix_lf(Xtran_dm);
- }
-}
-//---
-TSdvector *tz_prctile_matrix(TSdvector *z_dv, const double prc, TSdmatrix *Z_dm, const char rc)
-{
- //Fast method: rc = 'C' (sort each column).
- //Output: %prc percentile (i.e., containing 0% to %prc).
- // z_dv: an n-by-1 vector if rc=='C' or an m-by-1 vector if rc=='R'.
- // If z_dv==NULL, it will be created and has to be destroyed outside this function.
- //Inputs:
- // prc: percent (must be between 0.0 and 1.0 inclusive).
- // X_dm: an m-by-n general matrix.
- // rc == 'C' or 'c': sort each column.
- // rc == 'R' or 'r': sort each row.
- int nrows, ncols, _j, begloc;
- TSdvector x_sdv;
- double *X;
- //===
- TSdmatrix *X_dm = NULL;
- TSdmatrix *Xtran_dm = NULL;
-
- if (!Z_dm || !Z_dm->flag) fn_DisplayError("cstz.c/tz_prctile_matrix(): input matrix Z_dm must be (1) created and (2) assigned values");
- if (prc<0.0 || prc>1.0) fn_DisplayError("cstz.c/tz_prctile_matrix(): percentile mark prc must be between 0.0 and 1.0 inclusive");
- x_sdv.flag = V_DEF;
-
- nrows = Z_dm->nrows;
- ncols = Z_dm->ncols;
- if (!z_dv)
- {
- if (rc=='C' || rc=='c') z_dv = CreateVector_lf(ncols);
- else z_dv = CreateVector_lf(nrows);
- }
- else
- {
- if ((rc=='C' || rc=='c'))
- {
- if (ncols != z_dv->n) fn_DisplayError("cstz.c/tz_prctile_matrix(): z_dv->n must be the same as ncols of X_dm when sorting each column");
- }
- else
- {
- if (nrows != z_dv->n) fn_DisplayError("cstz.c/tz_prctile_matrix(): z_dv->n must be the same as nrows of X_dm when sorting each row");
- }
- }
- X_dm = CreateMatrix_lf(nrows, ncols);
- CopyMatrix0(X_dm, Z_dm);
-
- if (rc=='C' || rc=='c')
- {
- X = X_dm->M;
- nrows = X_dm->nrows;
- ncols = X_dm->ncols;
- }
- else
- {
- Xtran_dm = tz_TransposeRegular((TSdmatrix *)NULL, X_dm);
- X = Xtran_dm->M;
- nrows = Xtran_dm->nrows;
- ncols = Xtran_dm->ncols;
- }
- x_sdv.n = nrows;
- for (begloc=nrows*(ncols-1), _j=ncols-1; _j>=0; begloc-=nrows, _j--)
- {
- x_sdv.v = X + begloc;
- tz_sort(&x_sdv, 'A');
- z_dv->v[_j] = x_sdv.v[(int)floor(prc*(double)nrows)];
- }
- z_dv->flag = V_DEF;
- if (rc=='R' || rc=='r') DestroyMatrix_lf(Xtran_dm);
-
- //===
- DestroyMatrix_lf(X_dm);
-
- return (z_dv);
-}
-//---
-TSdvector *tz_mean_matrix(TSdvector *z_dv, TSdmatrix *Z_dm, const char rc)
-{
- //Fast method: rc = 'C' (mean for each column).
- //Output: %prc percentile (i.e., containing 0% to %prc).
- // z_dv: an n-by-1 vector if rc=='C' or an m-by-1 vector if rc=='R'.
- // If z_dv==NULL, it will be created and has to be destroyed outside this function.
- //Inputs:
- // X_dm: an m-by-n general matrix.
- // rc == 'C' or 'c': mean for each column.
- // rc == 'R' or 'r': mean for each row.
- int nrows, ncols, _j, begloc;
- TSdvector x_sdv;
- double *X;
- //===
- TSdmatrix *X_dm = NULL;
- TSdmatrix *Xtran_dm = NULL;
-
- if (!Z_dm || !Z_dm->flag) fn_DisplayError("cstz.c/tz_mean_matrix(): input matrix Z_dm must be (1) created and (2) assigned values");
- x_sdv.flag = V_DEF;
-
- nrows = Z_dm->nrows;
- ncols = Z_dm->ncols;
- if (!z_dv)
- {
- if (rc=='C' || rc=='c') z_dv = CreateVector_lf(ncols);
- else z_dv = CreateVector_lf(nrows);
- }
- else
- {
- if ((rc=='C' || rc=='c'))
- {
- if (ncols != z_dv->n) fn_DisplayError("cstz.c/tz_mean_matrix(): z_dv->n must be the same as ncols of X_dm when computing mean for each column");
- }
- else
- {
- if (nrows != z_dv->n) fn_DisplayError("cstz.c/tz_mean_matrix(): z_dv->n must be the same as nrows of X_dm when computing mean for each row");
- }
- }
- X_dm = CreateMatrix_lf(nrows, ncols);
- CopyMatrix0(X_dm, Z_dm);
-
- if (rc=='C' || rc=='c')
- {
- X = X_dm->M;
- nrows = X_dm->nrows;
- ncols = X_dm->ncols;
- }
- else
- {
- Xtran_dm = tz_TransposeRegular((TSdmatrix *)NULL, X_dm);
- X = Xtran_dm->M;
- nrows = Xtran_dm->nrows;
- ncols = Xtran_dm->ncols;
- }
- x_sdv.n = nrows;
- for (begloc=nrows*(ncols-1), _j=ncols-1; _j>=0; begloc-=nrows, _j--)
- {
- x_sdv.v = X + begloc;
- z_dv->v[_j] = fn_mean(x_sdv.v, x_sdv.n);
- }
- z_dv->flag = V_DEF;
- if (rc=='R' || rc=='r') DestroyMatrix_lf(Xtran_dm);
-
- //===
- DestroyMatrix_lf(X_dm);
-
- return (z_dv);
-}
-//--------------->>
-
-
-
-//<<---------------
-// WZ normalization on VARs.
-//--------------->>
-void fn_wznormalization(TSdvector *wznmlz_dv, TSdmatrix *A0draw_dm, TSdmatrix *A0peak_dm)
-{
- //Outputs:
- // wznmlz_dv (n-by-1): If negative, the sign of the equation must switch; if positive: no action needs be taken.
- // If NULL as an input, remains NULL.
- // A0draw_dm (n-by-n): replaced by wz-normalized draw.
- //Inputs:
- // wznmlz_dv (n-by-1): if NULL, no output for wznmlz_dv; otherwise, a memory allocated vector.
- // A0draw_dm (n-by-n): a draw of A0.
- // A0peak_dm (n-by-n): reference point to which normalized A0draw_dm is closest.
- int _j, _n,
- errflag = -2;
- double *v;
- TSdmatrix *X_dm = NULL;
- TSdvector *diagX_dv = NULL;
-
- if ( !A0peak_dm ) fn_DisplayError(".../cstz.c/fn_wznormalization(): input matrix for ML estimates must be created (memory allocated) and have legal values");
- //This is a minimum check to prevent crash without error messages. More robust checks are done in BdivA_rgens().
-
- _n = A0peak_dm->nrows;
- X_dm = CreateMatrix_lf(_n, _n);
-
- if ( errflag=BdivA_rgens(X_dm, A0peak_dm, '\\', A0draw_dm) ) {
- printf(".../cstz.c/fn_wznormalization(): errors when calling BdivA_rgens() with error flag %d", errflag);
- exit(EXIT_FAILURE);
- }
-
- if (wznmlz_dv) {
- diagdv(wznmlz_dv, X_dm);
- v = wznmlz_dv->v;
- }
- else {
- diagX_dv = CreateVector_lf(_n);
- diagdv(diagX_dv, X_dm);
- v = diagX_dv->v;
- }
-
-
- for (_j=_n-1; _j>=0; _j--)
- if (v[_j]<0) ScalarTimesColofMatrix((TSdvector *)NULL, -1.0, A0draw_dm, _j);
-
- //=== Destroys memory allocated for this function only.
- DestroyMatrix_lf(X_dm);
- DestroyVector_lf(diagX_dv);
-}
-
-
-
-
-//---------------<<
-// Handling under or over flows with log values.
-//--------------->>
-struct TSveclogsum_tag *CreateVeclogsum(int n)
-{
- struct TSveclogsum_tag *veclogsum_ps = tzMalloc(1, struct TSveclogsum_tag);
-
- //=== Memory allocation and initialization.
- veclogsum_ps->n = n; //Number of sums or the dimension of logofsum.
- veclogsum_ps->N_iv = CreateConstantVector_int(n, 0); //Cumulative. (N_1, ..., N_n).
- veclogsum_ps->logsum_dv = CreateConstantVector_lf(n, -MACHINEINFINITY); //Cumulative. (logofsum_1, ..., logofsum_n).
- veclogsum_ps->logmax_dv = CreateConstantVector_lf(n, -MACHINEINFINITY); //(logmax_1, ..., logmax_n).
-
- return (veclogsum_ps);
-}
-//---
-struct TSveclogsum_tag *DestroyVeclogsum(struct TSveclogsum_tag *veclogsum_ps)
-{
-
- if (veclogsum_ps) {
- DestroyVector_int(veclogsum_ps->N_iv);
- DestroyVector_lf(veclogsum_ps->logsum_dv);
- DestroyVector_lf(veclogsum_ps->logmax_dv);
-
- //===
- free(veclogsum_ps);
- return ((struct TSveclogsum_tag *)NULL);
- }
- else return (veclogsum_ps);
-}
-//===
-//------------------
-//Updating the sum (not divided by n) for the mean and the second moment.
-//------------------
-void UpdateSumFor1st2ndMoments(TSdvector *x1stsum_dv, TSdmatrix *X2ndsum_dm, const TSdvector *xdraw_dv)
-{
- static int ini_indicator = 0;
-
- if (!ini_indicator) {
- //Pass this loop once and no more.
- CopyVector0(x1stsum_dv, xdraw_dv);
- VectorTimesSelf(X2ndsum_dm, xdraw_dv, 1.0, 0.0, 'U');
- ini_indicator = 1;
- }
- else {
- VectorPlusVectorUpdate(x1stsum_dv, xdraw_dv);
- VectorTimesSelf(X2ndsum_dm, xdraw_dv, 1.0, 1.0, 'U');
- }
-}
-//---
-int tz_update_logofsum(double *Y_N_dp, double *y_Nmax_dp, double ynew, int N)
-{
- //Recursive algorithm to update Y_N (=log(sum of x_i)) for i=1, ..., N with the new value ynew = log(x_{N+1}).
- //Returns (1) the updated value Y_{N+1} = log(sum of x_i)) for i=1, ..., N+1;
- // (2) the updated value y_(N+1)max_dp;
- // (3) the integer N+1.
- //See TVBVAR Notes p.81a.
-
- if (*y_Nmax_dp>=ynew) *Y_N_dp = log( exp(*Y_N_dp - *y_Nmax_dp) + exp(ynew - *y_Nmax_dp) ) + *y_Nmax_dp;
- else {
- *y_Nmax_dp = ynew;
- *Y_N_dp = log( exp(*Y_N_dp - ynew) + 1.0 ) + ynew;
- }
-
- return (N+1);
-}
-int fn_update_logofsum(int N, double ynew, double *Y_N_dp, double *y_Nmax_dp)
-{
- //Recursive algorithm to update Y_N (=log(sum of x_i)) for i=1, ..., N with the new value ynew = log(x_{N+1}).
- //Returns (1) the updated value Y_{N+1} = log(sum of x_i)) for i=1, ..., N+1;
- // (2) the updated value y_(N+1)max_dp;
- // (3) the integer N+1.
- //See TVBVAR Notes p.81a.
- //If N=0, then ynew = -infty (no value yet) and thus no value is added to *Y_N_dp.
-
-// if (N>0)
-// {
- if (*y_Nmax_dp>=ynew) *Y_N_dp = log( exp(*Y_N_dp - *y_Nmax_dp) + exp(ynew - *y_Nmax_dp) ) + *y_Nmax_dp;
- else {
- *y_Nmax_dp = ynew;
- *Y_N_dp = log( exp(*Y_N_dp - ynew) + 1.0 ) + ynew;
- }
-// }
-
- return (N+1);
-}
-double fn_replace_logofsumsbt(double *yold, double _a, double ynew, double _b)
-{
- //Outputs:
- // *yold is replaced by log abs(a*xold + b*xnew).
- // 1.0 or -1.0: sign of a*xold + b*xnew.
- //
- //Given yold=log(xold) and ynew=log(xnew), it updates and returns yold = log abs(a*xold + b*xnew).
- //sbt: subtraction or subtract.
- //See TVBVAR Notes p.81a.
- double tmpd;
- //*yold = (*yold > ynew) ? (log( _a + _b*exp(ynew - *yold)) + *yold) : (log( _a*exp(*yold - ynew) + _b) + ynew);
-
- if (*yold > ynew) {
- if ((tmpd=_a + _b*exp(ynew - *yold) ) < 0.0) {
- // printf("WARNING! .../cstz.c/fn_replace_logofsumsbt(): Expression inside log is negative and the function returns the negative sign!\n");
- *yold += log(fabs(tmpd));
- return (-1.0);
- }
- else {
- *yold += log(tmpd);
- return (1.0);
- }
- }
- else {
- if ((tmpd=_a*exp(*yold - ynew) + _b) < 0.0 ) {
- // printf("WARNING! .../cstz.c/fn_replace_logofsumsbt(): Expression inside log is negative and the function returns the negative sign!\n");
- *yold = log(fabs(tmpd)) + ynew;
- return (-1.0);
- }
- else {
- *yold = log(tmpd) + ynew;
- return (1.0);
- }
- }
-}
-
-
-//<<---------------
-// Evaluating the inverse of the chi-square cumulative distribution function.
-//--------------->>
-double fn_chi2inv(double p, double df)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- //Returns x where p = int_{0}^{x} chi2pdf(t, df) dt
- if (df<=0.0) fn_DisplayError("cstz.c/fn_chi2inv(): degrees of freedom df must be greater than 0.0");
-
- if (p<=0.0) return (0.0);
- else if (p>=1.0) return (MACHINEINFINITY);
- else return (imsls_d_chi_squared_inverse_cdf(p, df));
-#elif defined( USE_GSL_LIBRARY )
- if (df<=0.0) fn_DisplayError("cstz.c/fn_chi2inv(): degrees of freedom df must be greater than 0.0");
-
- if (p<=0.0) return (0.0);
- else if (p>=1.0) return (MACHINEINFINITY);
- else
- return gsl_cdf_chisq_Pinv(p,df);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Evaluating the standard normal cumulative distribution function.
-//--------------->>
-double fn_normalcdf(double x)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsls_d_normal_cdf(x));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_cdf_ugaussian_P(x);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Evaluating the inverse of the standard normal cumulative distribution function.
-//--------------->>
-double fn_normalinv(double p)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsls_d_normal_inverse_cdf(p));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_cdf_ugaussian_Pinv(p);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Evaluating the inverse of the beta cumulative distribution function.
-//--------------->>
-double fn_betainv(double p, double _alpha, double _beta)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- //p = int_{0}^{\infty} betapdf(t, _alpha, _beta) dt where betapdf(t,_alpha,_beta) \propt t^{_alpha-1}*(1-t)^(_beta-1}.
- return (imsls_d_beta_inverse_cdf(p, _alpha, _beta));
-#elif defined( USE_GSL_LIBRARY)
- return gsl_cdf_beta_Pinv(p,_alpha,_beta);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Computes log gamma (x) where gamma(n+1) = n! and gamma(x) = int_0^{\infty} e^{-t} t^{x-1} dt.
-//--------------->>
-double fn_gammalog(double x)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsl_d_log_gamma(x));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_sf_lngamma(x);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Computes log beta(x, y) where beta(x, y) = gamma(x)*gamm(y)/gamma(x+y).
-//--------------->>
-double fn_betalog(double x, double y)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsl_d_log_beta(x, y));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_sf_lnbeta(x,y);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-
-//<<---------------
-// Computes log gamma (x) where gamma(n+1) = n! and gamma(x) = int_0^{\infty} e^{-t} t^{x-1} dt.
-//--------------->>
-double gammalog(double x)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsl_d_log_gamma(x));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_sf_lngamma(x);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//-----------------------------------------------------------------------------------
-//------------------------------ Normal distribution ------------------------------//
-//--- p(x) = (1.0/sqrt(2*pi)*sigma) exp( -(1.0/(2.0*sigma^2.0)) (x-mu)^2.0 )
-//--- for sigma>0.
-//-----------------------------------------------------------------------------------
-#define LOGSQRTOF2PI 9.189385332046727e-001
-double tz_lognormalpdf(double _x, double _m, double _s)
-{
- double xmm = _x-_m;
- if (_s <= 0.0) return (-NEARINFINITY);
- //fn_DisplayError("cstz.c/tz_lognormalpdf(): standard deviation must be positive");
-
- return ( -LOGSQRTOF2PI - log(_s) - (1.0/(2.0*square(_s))) * square(xmm) );
-}
-#undef LOGSQRTOF2PI
-
-//-----------------------------------------------------------------------------------
-//----------------------------- Beta density function -----------------------------//
-//--- p(x) = ( Gamma(a+b)/(Gamma(a)*Gamma(b)) ) x^(a-1) (1-x)^(b-1) for a>0 and b>0.
-//--- E(x) = a/(a+b); var(x) = a*b/( (a+b)^2*(a+b+1) );
-//--- The density is finite if a,b>=1.
-//--- Noninformative density: (1) a=b=1; (2) a=b=0.5; or (3) a=b=0.
-//-----------------------------------------------------------------------------------
-double tz_logbetapdf(double _x, double _a, double _b)
-{
- if ((_x < 0.0) || (_x > 1.0) || (_a <=0.0) || (_b <= 0.0)) return (-NEARINFINITY);
- if ((_x <= 0.0) && (_a != 1.0)) return (-NEARINFINITY);
- //Note that it should be +infinity for a < 1.0. We return -infinity anyway for the purpose of giving zero LH.
- if ((_x >= 1.0) && (_b != 1.0)) return (-NEARINFINITY);
- //Note that it should be +infinity for b < 1.0. We return -infinity anyway for the purpose of giving zero LH.
- //fn_DisplayError("cstz.c/tz_logbetapdf(): x must be (0,1) and a, b must be positive");
-
- if ((_x == 0.0 && _a == 1.0) || (_x == 1.0 && _b == 1.0)) return (-fn_betalog(_a, _b));
- else return ( -fn_betalog(_a, _b) + (_a-1.0)*log(_x) + (_b-1.0)*log(1.0-_x) );
-}
-//-----------------------------------------------------------------------------------
-//---------------------------- Gamma distribution ----------------------------------//
-//--- p(x) = ( b^a/Gamma(a) ) x^(a-1) exp(-bx) for a>0 and b>0.
-//--- where a is shape and b is inverse scale (rate) parameter.
-//--- E(x) = a/b; var(x) = a/b^2;
-//--- Noninformative distribution: a,b -> 0.
-//--- The density function is finite if a >= 1.
-//-----------------------------------------------------------------------------------
-double tz_loggammapdf(double _x, double _a, double _b)
-{
- if (_x < 0.0 || _a <= 0.0 || _b <= 0.0) return (-NEARINFINITY);
- if (_x <= 0.0 && _a != 1.0) return (-NEARINFINITY);
- //Note that it should be +infinity for a < 1.0. We return -infinity anyway for the purpose of giving zero LH.
- //fn_DisplayError("cstz.c/tz_loggammapdf(): x, a, and b must be positive");
-
- if (_x == 0.0 && _a == 1.0) return ( _a*log(_b) - fn_gammalog(_a) );
- else return ( _a*log(_b) - fn_gammalog(_a) + (_a-1.0)*log(_x) - _b*_x );
-}
-//-----------------------------------------------------------------------------------
-//------------------------ Inverse-Gamma distribution ------------------------------//
-//--- p(x) = ( b^a/Gamma(a) ) x^(-a-1) exp(-b/x) for a>0 and b>0.
-//--- where a is shape and b is scale parameter.
-//--- E(x) = b/(a-1) for a>1; var(x) = b^2/( (a-1)^2*(a-2) ) for a>2;
-//--- Noninformative distribution: a,b -> 0.
-//--- How to draw: (1) draw z from Gamma(a,b); (2) let x=1/z.
-//-----------------------------------------------------------------------------------
-double tz_loginversegammapdf(double _x, double _a, double _b)
-{
- //This denisity is always finite.
- //If a < 1.0, 1st moment does not exist,
- // a < 2.0, 2nd moment does not exist,
- // a < 3.0, 3rd moment does not exist,
- // a < 4.0, 4th moment does not exist.
-
- if (_x < 0.0 || _a <= 0.0 || _b <= 0.0) return (-NEARINFINITY);
- //fn_DisplayError("cstz.c/tz_loginversegammapdf(): x, a, and b must be positive");
-
- return ( _a*log(_b) - fn_gammalog(_a) - (_a+1.0)*log(_x) - _b /_x );
-}
-
-
-
-
-
-
-
-//<<---------------
-// P2 algorithm ???????
-//--------------->>
-void psqr(double *q, int *m, double x, const double *p, int n)
-{
- //Outputs:
- // q: n-by-1 vector of
- // m: n-by-1 vector of
- // x: a random draw.
- //------
- //Inputs:
- // p: n-by-1 vector of cumulative cut-off probabilties for the error bands.
- static double qm, dq;
- static int i, dm, dn;
-
- for (i=0; q[i]<=x && i<n; i++) ;
- if (i==0) { q[0]=x; i++; }
- if (i==n) { q[n-1]=x; i--; }
- for (; i<n; i++) m[i]++;
- for (i=1; i<n-1; i++) {
- dq = p[i]*m[n-1];
- if (m[i]+1<=dq && (dm=m[i+1]-m[i])>1) {
- dn = m[i]-m[i-1];
- dq = ((dn+1)*(qm=q[i+1]-q[i])/dm+
- (dm-1)*(q[i]-q[i-1])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- q[i] += dq;
- m[i]++;
- } else
- if (m[i]-1>=dq && (dm=m[i]-m[i-1])>1) {
- dn = m[i+1]-m[i];
- dq = ((dn+1)*(qm=q[i]-q[i-1])/dm+
- (dm-1)*(q[i+1]-q[i])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- q[i] -= dq;
- m[i]--;
- }
- }
-}
-void piksrt(double *arr, int n)
-{
- //Outputs:
- // arr: replaced by new values.
- //Inputs:
- // arr: n-by-1 vector ??????
- int i, j;
- double a;
-
- for (j=1; j<n; j++) {
- a = arr[j];
- for (i=j-1; i>=0 && arr[i]>a; i--)
- arr[i+1] = arr[i];
- arr[i+1]=a;
- }
-}
-
-
-
-//---------------------------- Some high-level VAR functions ---------------------
-void fn_lev2growthanual(TSdmatrix *levgro_dm, const TSdmatrix *levgrominus1_dm, const TSivector *indxlogper_iv)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs:
- // levgro_dm: nfores-by-nvar matrix of annual growth rates (percent) except interest rates and unemployment rate in level.
- //Inputs:
- // levgro_dm: nfores-by-nvar matrix of log levels and, say, interest rates already divided by 100.
- // levgrominus1_dm: qm-by-nvar matrix in the previous year (not necessarily a calendar year).
- // indxlogper_iv: nvar-by-1 array of 1, 2, or 4 for the list of endogenous variables. 1: decimal point with annual rate like the interest rate; 2: decimal point (NOT at annual rate) like the unemployment rate; 4: log level value.
- int ti, vj, qm, nvar, nfores, totrows;
- TSdmatrix *tf_levgroplus_dm = NULL;
-
- if ((qm=levgrominus1_dm->nrows) != 12 && qm != 4) fn_DisplayError("fn_lev2growthanual(): the second input must have 12 or 4 rows for monthly or quarterly data");
- if ((nvar=levgrominus1_dm->ncols) != indxlogper_iv->n || nvar != levgro_dm->ncols) fn_DisplayError("fn_lev2growthanual(): column dimensions and vector dimension of all inputs must be same");
-
- //=== Memory allocation for this function.
- tf_levgroplus_dm = CreateMatrix_lf(qm+(nfores=levgro_dm->nrows), nvar=levgrominus1_dm->ncols);
-
-
- CopySubmatrix0(tf_levgroplus_dm, (TSdmatrix *)levgrominus1_dm, 0, 0, qm, nvar);
- CopySubmatrix(tf_levgroplus_dm, qm, 0, levgro_dm, 0, 0, nfores, nvar);
- totrows = qm + nfores;
- for (vj=nvar-1; vj>=0; vj--) {
- switch (indxlogper_iv->v[vj]) {
- case 4:
- for (ti=nfores-1; ti>=0; ti--)
- levgro_dm->M[mos(ti, vj, nfores)] = 100.0*( exp(tf_levgroplus_dm->M[mos(ti+qm, vj, totrows)] - tf_levgroplus_dm->M[mos(ti, vj, totrows)]) - 1.0 );
- break;
- case 2:
- case 1:
- for (ti=nfores-1; ti>=0; ti--)
- levgro_dm->M[mos(ti, vj, nfores)] *= 100.0;
- break;
- default:
- fn_DisplayError("fn_lev2growthanual(): the input vector, indxlogper_iv, must have the integer values 4, 2, and 1");
- }
- }
-
-
-
- //=== Destroys memory allocated for this function.
- tf_levgroplus_dm = DestroyMatrix_lf(tf_levgroplus_dm);
-}
-
-
-
-//-------------------
-// Generating a counterfactual paths conditional on S_T and specified shocks_t(s_t) for _sm (a switching model).
-//-------------------
-void fn_ctfals_givenshocks_sm(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm,
- const TSivector *S_Tdraw_iv, const TSdcell *Bsdraw_dc, const TSdcell *A0sdrawinv_dc, const TSivector *noshocks_iv)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs: ctflasdrawtran = xprimeminus1*Bsdraw{s} + shocks'*A0sdrawinv{s}.
- // ctfalstran_dm: nvar-by-nfores where nfores (=eloc-bloc+1) is the forecast horizon. Conterfactual paths of nvar variables.
- // xprimeminus1_dv: updated 1-by-ncoef right-hand-side variables at the end of the forecast horizon, ready for the forecasts at the step nfores+1.
- // In the order of [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term].
- //Inputs:
- // xprimeminus1_dv: 1-by-ncoef vector of right-hand-side variables at the beginning of the forecast horizon.
- // bloc: beginning location for the forecast horizon.
- // eloc: end location for the forecast horizon.
- // strshockstran_dm: nvar-by-T. Matrix transpose of unit-variance (time-invariant) structural shocks.
- // S_Tdraw_iv: fss-by-1 or SampleSize-by-1 vector of (s_t|I_T,theta).
- // Bsdraw_dc: nStates cells. For each cell, ncoef-by-nvar reduced-form coefficient matrix.
- // A0sdrawinv_dc: nStates cells. For each cell, nvar-by-nvar inverse of contemporaneous coefficient matrix.
- // noshocks_iv: a (no greater than nvar) vector of base-0 integers indicating the corresponding equations whose shocks are set
- // to zero. Each element of this integer vector must be less than nvar.
- int ti, si, vi;
- int nfores = eloc - bloc + 1,
- nvar = ctfalstran_dm->nrows,
- ncoefminusnvar7const = Bsdraw_dc->C[0]->nrows - nvar - 1;
- TSdvector ctfals_sdv, strshocks_sdv;
- TSivector STnfores_siv; //nfores-by-1 vector of s_t's.
-
- if (nfores < 1) fn_DisplayError("cstz.c/fn_ctfals_givenshocks_sm(): Number of forecast steps must be greater than 0");
- if (eloc > strshockstran_dm->ncols-1) fn_DisplayError("cstz.c/fn_ctfals_givenshocks_sm(): End location in the forecast horizon must be no greater than the sample size");
- if (nvar != strshockstran_dm->nrows) fn_DisplayError("cstz.c/fn_ctfals_givenshocks_sm(): the number of rows of strshockstran_dm must be equal to nvar");
-
-
- //******* WARNING: The operation involves ctfals_sdv.v, strshocks_sdv.v, STnfores_siv.v *******
- //******* throughout this function is dangerous because of pointer movements. *******
- //******* But it gives us efficiency. *******
- ctfals_sdv.n = nvar;
- ctfals_sdv.v = ctfalstran_dm->M; //Points to the beginning of the 1st column of ctfalstran_dm.
- //+
- strshocks_sdv.n = nvar;
- strshocks_sdv.flag = V_DEF;
- strshocks_sdv.v = strshockstran_dm->M + strshockstran_dm->nrows*bloc; //Points to the beginning of the bloc_th column of strshockstran_dm.
- for (vi=noshocks_iv->n-1; vi>=0; vi--)
- strshocks_sdv.v[noshocks_iv->v[vi]] = 0.0; //Set shocks in those equations to be zero.
- //+
- STnfores_siv.n = nfores;
- STnfores_siv.flag = V_DEF;
- STnfores_siv.v = S_Tdraw_iv->v + bloc; //Points to the bloc_th position of S_Tdraw_iv.
-
-
- for (ti=0; ti<nfores; ti++) {
- //Must have a forward recursion.
- VectorTimesMatrix(&ctfals_sdv, xprimeminus1_dv, Bsdraw_dc->C[si=STnfores_siv.v[ti]], 1.0, 0.0, 'N');
- VectorTimesMatrix(&ctfals_sdv, &strshocks_sdv, A0sdrawinv_dc->C[si], 1.0, 1.0, 'N');
- //=== Updates the recursion. The order matters.
- memmove(xprimeminus1_dv->v+nvar, xprimeminus1_dv->v, ncoefminusnvar7const*sizeof(double));
- memcpy(xprimeminus1_dv->v, ctfals_sdv.v, nvar*sizeof(double));
- //+
- if (ti < nfores-1) //This is needed to prevent memory leak at the end when we have strshocks_sdv.v[noshocks_iv->v[vi]] = 0.0.
- {
- ctfals_sdv.v += nvar; //Points to the beginning of the next column of ctfalstran_dm.
- strshocks_sdv.v += nvar; //Points to the beginning of the next column of strshockstran_dm.
- for (vi=noshocks_iv->n-1; vi>=0; vi--)
- strshocks_sdv.v[noshocks_iv->v[vi]] = 0.0; //Set shocks in those equations to be zero.
- }
- }
-
- ctfalstran_dm->flag = M_GE;
-}
-
-
-//-------------------
-// Generating a random sequence of counterfactual (ctfal) paths for _sm (a switching model).
-//-------------------
-void fn_ctfals_sm(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm, const TSivector *Snfores_iv, const TSdcell *Bsdraw_dc, const TSdcell *A0sdrawinv_dc)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs: ctflasdrawtran = xprimeminus1*Bsdraw{s} + shocks'*A0sdrawinv{s}.
- // ctfalstran_dm: nvar-by-nfores where nfores (=eloc-bloc+1) is the forecast horizon. Conterfactual paths of nvar variables.
- // xprimeminus1_dv: updated 1-by-ncoef right-hand-side variables at the end of the forecast horizon, ready for the forecasts at the step nfores+1.
- // In the order of [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term].
- //Inputs:
- // xprimeminus1_dv: 1-by-ncoef vector of right-hand-side variables at the beginning of the forecast horizon.
- // bloc: beginning location for the forecast horizon.
- // eloc: end location for the forecast horizon.
- // strshockstran_dm: nvar-by-T. Matrix transpose of unit-variance (time-invariant) structural shocks.
- // Snfores_iv: nfores-by-1 vector of states where each element is less than nStates.
- // Bsdraw_dc: nStates cells. For each cell, ncoef-by-nvar reduced-form coefficient matrix.
- // A0sdrawinv_dc: nStates cells. For each cell, nvar-by-nvar inverse of contemporaneous coefficient matrix.
- int ti, si;
- int nfores = eloc - bloc + 1,
- nvar = ctfalstran_dm->nrows,
- ncoefminusnvar7const = Bsdraw_dc->C[0]->nrows - nvar - 1;
- TSdvector ctfals_sdv, strshocks_sdv;
-
- if (nfores < 1) fn_DisplayError("cstz.c/fn_ctfals_sm(): Number of forecast steps must be greater than 0");
- if (eloc > strshockstran_dm->ncols-1) fn_DisplayError("cstz.c/fn_ctfals_sm(): End location in the forecast horizon must be no greater than the sample size");
- if (nvar != strshockstran_dm->nrows) fn_DisplayError("cstz.c/fn_ctfals_sm(): the number of rows of strshockstran_dm must be equal to nvar");
-
-
- //******* WARNING: The operation involves ctfals_sdv.v and strshocks_sdv.v throughout this function *******
- //******* is dangerous because of pointer movements. But it gives us efficiency. *******
- ctfals_sdv.n = nvar;
- ctfals_sdv.v = ctfalstran_dm->M; //Points to the beginning of the 1st column of ctfalstran_dm.
- strshocks_sdv.n = nvar;
- strshocks_sdv.flag = V_DEF;
- strshocks_sdv.v = strshockstran_dm->M + strshockstran_dm->nrows*bloc; //Points to the beginning of the bloc_th column of strshockstran_dm.
-
-
- for (ti=0; ti<nfores; ti++) {
- //Must have a forward recursion.
- VectorTimesMatrix(&ctfals_sdv, xprimeminus1_dv, Bsdraw_dc->C[si=Snfores_iv->v[ti]], 1.0, 0.0, 'N');
- VectorTimesMatrix(&ctfals_sdv, &strshocks_sdv, A0sdrawinv_dc->C[si], 1.0, 1.0, 'N');
- //=== Updates the recursion. The order matters.
- memmove(xprimeminus1_dv->v+nvar, xprimeminus1_dv->v, ncoefminusnvar7const*sizeof(double));
- memcpy(xprimeminus1_dv->v, ctfals_sdv.v, nvar*sizeof(double));
- //+
- ctfals_sdv.v += nvar; //Points to the beginning of the next column of ctfalstran_dm.
- strshocks_sdv.v += nvar; //Points to the beginning of the next column of strshockstran_dm.
- }
-
- ctfalstran_dm->flag = M_GE;
-}
-
-//-------------------
-// Generating a random sequence of counterfactual (ctfal) paths with only monetary policy equation changing to a specified regime while holding other equations' regimes the same as historical ones.
-//-------------------
-void fn_ctfals_policyonly(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm, const TSivector *S_Tdraw_iv, const int statecon, const int selej, const TSdcell *A0sdraw_dc, const TSdcell *Apsdraw_dc)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs: ctflasdrawtran = xprimeminus1*Bsdraw{s} + shocks'*A0sdrawinv{s}.
- // ctfalstran_dm: nvar-by-nfores where nfores (=eloc-bloc+1) is the forecast horizon. Conterfactual paths of nvar variables.
- // xprimeminus1_dv: updated 1-by-ncoef right-hand-side variables at the end of the forecast horizon, ready for the forecasts at the step nfores+1.
- // In the order of [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term].
- //Inputs:
- // xprimeminus1_dv: 1-by-ncoef vector of right-hand-side variables at the beginning of the forecast horizon.
- // bloc: beginning location for the forecast horizon.
- // eloc: end location for the forecast horizon.
- // strshockstran_dm: nvar-by-T. Matrix transpose of unit-variance (time-invariant) structural shocks.
- // S_Tdraw_iv; fss-by-1 or SampleSize-by-1. Stores (s_t|I_T,theta).
- // statecon: the ith state conditioned for counterfactuals (base 0). Must be < nStates.
- // selej: location (base 0) of the selected structural equation (e.g., the monetary policy equation). Only for (1) long-run and short-run responses and (2) counterfactuals with only policy equation at specific state imposed.
- // A0sdraw_dc: nStates cells. For each cell, nvar-by-nvar contemporaneous coefficient matrix.
- // Apsdraw_dc: nStates cells. For each cell, ncoef-by-nvar lagged structural coefficient matrix.
- int ti, si;
- int errflag = -2, //Initialized to be unsuccessful. When 0, successful.
- nfores = eloc - bloc + 1,
- nvar = ctfalstran_dm->nrows,
- ncoef = Apsdraw_dc->C[0]->nrows,
- nStates = Apsdraw_dc->ncells,
- ncoefminusnvar7const = ncoef - nvar - 1;
- TSdvector ctfals_sdv, strshocks_sdv;
- TSivector sact_nfores_siv;
- //
- TSivector *tf_rnstates_iv = CreateConstantVector_int(nStates, nvar), //nStates-by-1: ncoef for each element for *p*_dc or nvar for each elment for *0*_dc.
- *tf_cnstates_iv = CreateConstantVector_int(nStates, nvar); //nStates-by-1: nvar for each element for both *p*_dc and *0*_dc.
- TSdcell *tf_A0sinv_dc = NULL;
- TSdcell *tf_Aps_dc = NULL,
- *tf_Bs_dc = NULL;
-
-
-
- if (nfores < 1) fn_DisplayError("cstz.c/fn_ctfals_policyonly(): Number of forecast steps must be greater than 0");
- if (eloc > strshockstran_dm->ncols-1) fn_DisplayError("cstz.c/fn_ctfals_policyonly(): End location in the forecast horizon must be no greater than the sample size");
- if (nvar != strshockstran_dm->nrows) fn_DisplayError("cstz.c/fn_ctfals_policyonly(): the number of rows of strshockstran_dm must be equal to nvar");
-
-
- //=== Memory allocation.
- tf_A0sinv_dc = CreateCell_lf(tf_rnstates_iv, tf_cnstates_iv); //Note rnstates_iv and cnstates_iv are already assigned right values.
- //+
- for (si=nStates-1; si>=0; si--) tf_rnstates_iv->v[si] = ncoef; //Note rnstates_iv is already assigned right values.
- tf_Aps_dc = CreateCell_lf(tf_rnstates_iv, tf_cnstates_iv);
- tf_Bs_dc = CreateCell_lf(tf_rnstates_iv, tf_cnstates_iv);
-
-
- //******* WARNING: The operation involves ctfals_sdv.v and strshocks_sdv.v throughout this function *******
- //******* is dangerous because of pointer movements. But it gives us efficiency. *******
- ctfals_sdv.n = nvar;
- ctfals_sdv.v = ctfalstran_dm->M; //Points to the beginning of the 1st column of ctfalstran_dm.
- strshocks_sdv.n = nvar;
- strshocks_sdv.flag = V_DEF;
- strshocks_sdv.v = strshockstran_dm->M + strshockstran_dm->nrows*bloc; //Points to the beginning of the bloc_th column of strshockstran_dm.
- //+
- sact_nfores_siv.n = nfores;
- sact_nfores_siv.flag = V_DEF;
- sact_nfores_siv.v = S_Tdraw_iv->v + bloc; //Points to the beginning of the bloc_th element of S_Tdraw_iv.
-
- //=== Sticks the policy equation at the statecon_th state to A0s and A0p.
- for (si=nStates-1; si>=0; si--) {
- CopyMatrix0(tf_A0sinv_dc->C[si], A0sdraw_dc->C[si]); //tf_A0sinv_dc is A0s for a moment.
- CopyMatrix0(tf_Aps_dc->C[si], Apsdraw_dc->C[si]);
- //=== Sticks the specified regime statecon in the counterfactual period.
- CopySubmatrix(tf_A0sinv_dc->C[si], 0, selej, A0sdraw_dc->C[statecon], 0, selej, nvar, 1);
- CopySubmatrix(tf_Aps_dc->C[si], 0, selej, Apsdraw_dc->C[statecon], 0, selej, ncoef, 1);
-
- if ( errflag=BdivA_rgens(tf_Bs_dc->C[si], tf_Aps_dc->C[si], '/', tf_A0sinv_dc->C[si]) ) {
- //tf_A0sinv_dc is at this moment tf_A0s_dc.
- printf(".../cstz.c/fn_ctfals_policyonly(): tf_Bs_dc->C[si] -- errors when calling BdivA_rgens() with error flag %d", errflag);
- exit(EXIT_FAILURE);
- }
- if ( errflag=invrgen(tf_A0sinv_dc->C[si], tf_A0sinv_dc->C[si]) ) {
- printf(".../cstz.c/fn_ctfals_policyonly(): tf_A0sinv_dc->C -- errors when calling invrgen() with error flag %d", errflag);
- exit(EXIT_FAILURE);
- }
- }
-
- for (ti=0; ti<nfores; ti++) {
- //Must have a forward recursion.
- VectorTimesMatrix(&ctfals_sdv, xprimeminus1_dv, tf_Bs_dc->C[si=sact_nfores_siv.v[ti]], 1.0, 0.0, 'N');
- VectorTimesMatrix(&ctfals_sdv, &strshocks_sdv, tf_A0sinv_dc->C[si], 1.0, 1.0, 'N');
- //=== Updates the recursion. The order matters.
- memmove(xprimeminus1_dv->v+nvar, xprimeminus1_dv->v, ncoefminusnvar7const*sizeof(double));
- memcpy(xprimeminus1_dv->v, ctfals_sdv.v, nvar*sizeof(double));
- //+
- ctfals_sdv.v += nvar; //Points to the beginning of the next column of ctfalstran_dm.
- strshocks_sdv.v += nvar; //Points to the beginning of the next column of strshockstran_dm.
- }
-
- ctfalstran_dm->flag = M_GE;
-
- //=== Destroys memory allocated for this function.
- tf_rnstates_iv = DestroyVector_int(tf_rnstates_iv);
- tf_cnstates_iv = DestroyVector_int(tf_cnstates_iv);
- tf_A0sinv_dc = DestroyCell_lf(tf_A0sinv_dc);
- tf_Aps_dc = DestroyCell_lf(tf_Aps_dc);
- tf_Bs_dc = DestroyCell_lf(tf_Bs_dc);
-}
-
-
-#if defined (INTELCMATHLIBRARY)
-void fn_impulse(TSdmatrix *imftran_dm, const TSdmatrix *Bh_dm, const TSdmatrix *swishtran_dm, const int nlags, const int imsteps)
-{
- //Outputs (memory allocated already):
- // imftran_dm: nvar^2-by-imsteps where imf_dm (imsteps-by-nvar^2) is in the same format as in RATS.
- // Rows: nvar responses to the 1st shock, ..., nvar responses to the last shock.
- // Columns: steps of impulse responses.
- //Inputs:
- // Bh_dm: ldbh-by-nvar reduced-form coefficient matrix (where ldbh is the leading dimension of Bh_dm and must be at least nvar*nlags) of the form:
- // Y(T*nvar) = X*Bh_dm + U, X: T*ldbh(ldbh may include all exogenous terms). Note that columns corresponding equations.
- // Columns of Bh_dm: nvar variables for the 1st lag, ..., nvariables for the last lag + (possible exogenous terms) + const = ldbh.
- // swishtran_dm: transponse of nvar-by-nvar inv(A0) in the structural model y(t)A0 = e(t).
- // nlags: lag length (number of lags);
- // imsteps: steps for impulse responses.
-
- int i, j,
- nvar, nvar2, ldbh, jmax;
- double *Bh, *imftran;
-
- if (!imftran_dm) fn_DisplayError(".../fn_impulse(): the output impulse matrix imftran_dm must be created (memory-allocated)");
- else if (!Bh_dm || !swishtran_dm) fn_DisplayError(".../fn_impulse(): the input matrices Bh_dm and swich_dm must be created (memory-allocated)");
- else if (!Bh_dm->flag || !swishtran_dm->flag) fn_DisplayError(".../fn_impulse(): the input matrices Bh_dm and swich_dm must be given legal values");
- else if (nlags < 1) fn_DisplayError(".../fn_impulse(): the lag length, nlags, must be equal to or greater than 1");
- else if (imsteps <1) fn_DisplayError(".../fn_impulse(): the number of steps for impulse responses, imsteps, must be must be equal to or greater than 1");
- else if ((nvar = swishtran_dm->nrows) != swishtran_dm->ncols ) fn_DisplayError(".../fn_impulse(): the input matrix, swishtran_dm, must be square");
- else if (nvar != Bh_dm->ncols) fn_DisplayError(".../fn_impulse(): the number of columns in Bh_dm must equal to the number of equations or endogenous variables");
- else if (square(nvar) != imftran_dm->nrows || imsteps != imftran_dm->ncols) fn_DisplayError(".../fn_impulse(): Dimension of impulse matrix input matrix imftran_dm is incompatible with other input matrices or with the number of steps");
-
- //if ( !(imftran_dm->flag & M_CN) && imftran_dm[0] !=0.0 ) InitializeConstantMatrix_lf(imftran_dm, 0.0);
- InitializeConstantMatrix_lf(imftran_dm, 0.0); //Cumulative. Always initialize it to zero.
-
-
- nvar2 = square(nvar);
- Bh = Bh_dm->M;
- imftran = imftran_dm->M;
-
-
- if ((ldbh=Bh_dm->nrows) < nvar*nlags) fn_DisplayError("Input matrix Bh_dm must have at least nvar*nlags rows");
- cblas_dcopy(nvar2, swishtran_dm->M, 1, imftran, 1);
- for (i=1; i<imsteps; i++) {
- jmax = i<nlags?i:nlags;
- for (j=0; j<jmax; j++) {
- cblas_dgemm(CblasColMajor, CblasTrans, CblasNoTrans, nvar, nvar, nvar,
- 1.0, &Bh[j*nvar], ldbh, &imftran[(i-j-1)*nvar2], nvar,
- 1.0, &imftran[i*nvar2], nvar);
- }
- }
-
-
- imftran_dm->flag = M_GE;
-}
-#else
-//No default routine yet. 7 Oct 2003
-#endif
-
-
-TSdmatrix *tz_impulse2levels(TSdmatrix *imflev_dm, TSdmatrix *imf_dm, TSivector *vlist2levels_iv)
-{
- //Converting imf_dm to the level impulse responses imflev_dm according to vlist2levels_iv.
- //If imflev_dm = imf_dm, then the value of imf_dm will be replaced by the new value.
- //
- //imf_dm; nsteps-by-nvar^2 where
- // rows: steps of impulse responses;
- // columns: nvar responses to the 1st shock, ..., nvar responses to the last shock.
- //vlist2levels_iv; must be in ascending order. A list of base-0 variables to be converted to levels. Example: [0 1 3]
- int _i, _j, _t;
- int largestvar; //last variable corresponding to the largest number.
- int _n, nsq, imsteps;
- TSdvector imf_sdv;
- TSdvector imflev_sdv;
-
- if (!imf_dm || !imf_dm->flag)
- fn_DisplayError(".../cstz.c/tz_impulse2levels(): the input matrix imf_dm must be (1) allocated memory and (2) given legal values");
-
- if (!imflev_dm) {
- imflev_dm = CreateMatrix_lf(imf_dm->nrows, imf_dm->ncols);
- imflev_dm->flag = M_GE; //Legal values will be given below.
- }
- else if (imflev_dm != imf_dm )
- if ( (imflev_dm->nrows != imf_dm->nrows) || (imflev_dm->ncols != imf_dm->ncols))
- fn_DisplayError(".../cstz.c/tz_impulse2levels(): dimensions of the input matrix imf_dm and the output matrix imflev_dm must match exactly");
- else imflev_dm->flag = M_GE; //Legal values will be given below.
-
- largestvar = vlist2levels_iv->v[vlist2levels_iv->n-1]+1;
- _n = (int)floor(sqrt(imf_dm->ncols)+0.5);
- nsq = imf_dm->ncols;
- if ( square(largestvar) > nsq)
- fn_DisplayError(".../cstz.c/tz_impulse2levels(): the last specified variable in vlist2levels_iv is out of the range of impulse responses");
-
-
- imflev_sdv.n = imf_sdv.n = imf_dm->nrows;
- imflev_sdv.flag = imf_sdv.flag = V_DEF; //Legal values will be given below.
- imsteps = imf_dm->nrows;
- for (_i=vlist2levels_iv->n-1; _i>=0; _i--)
- for (_j=vlist2levels_iv->v[_i]; _j<nsq; _j += _n) {
- imflev_sdv.v = imflev_dm->M + _j*imsteps;
- imf_sdv.v = imf_dm->M + _j*imsteps;
- imflev_sdv.v[0] = imf_sdv.v[0];
- for (_t=1; _t<imsteps; _t++)
- imflev_sdv.v[_t] = imflev_sdv.v[_t-1] + imf_sdv.v[_t];
- }
-
- return (imflev_dm);
-}
-
-
-void DynamicResponsesForStructuralEquation(TSdmatrix *Resps_dm, const int loclv, const int nlags, const TSdvector *a0p_dv)
-{
- //Outputs:
- // Resps_dm: k-by-nvar where k responses of the loclv_th variable to the _ith variable for _i=1:nvar.
- // The loclv_th column of Resps_dm is meaningless but as a debug check should be close to -1 for the kth responses as k->\infty.
- //Inputs:
- // loclv: loction of the left-hand variable either in difference (growth) or level.
- // nlags: number of lags.
- // a0p_dv: m-by-1 vector of [a0 a+] either in difference (growth) or level for the strctural equation considered where m>= (nlags+1)*nvar because m may
- // include the constant term. Note a0 is on the left hand side of the equation and a+ is on the right hand side of the equation.
- int vi, li;
- int nvar, K;
- double tmpdsum, c0, a0inv;
- TSdvector resps_sdv; //k-by-1.
- //----
- TSdvector *a1_dv = NULL; //nlags-by-1.
-
- if (!Resps_dm || !a0p_dv || !a0p_dv->flag) fn_DisplayError(".../cstz/DynamicResponsesForStructuralEquation(): (1) both input vector and output matrix must be allocated memory; (2) the input vector must have legal values");
- if (a0p_dv->n < (nlags+1)*(nvar=Resps_dm->ncols)) fn_DisplayError(".../cstz/DynamicResponsesForStructuralEquation(): the length of the input vector must be at least (nvar+1)*nlags");
- if (loclv >= nvar || loclv < 0) fn_DisplayError(".../cstz/DynamicResponsesForStructuralEquation(): the location for the left-hand-side variable must be between 0 and number of variables-1, inclusive");
- a1_dv = CreateVector_lf(nlags);
- a1_dv->flag = V_DEF; //which will be given legal values below.
-
- resps_sdv.n = K = Resps_dm->nrows;
- resps_sdv.flag = V_UNDEF;
-
- a0inv = 1.0/a0p_dv->v[loclv];
- for (li=nlags; li>=1; li--) //Note li=1; li<=nlags, NOT li=0; li<nlags.
- a1_dv->v[li-1] = a0p_dv->v[loclv+nvar*li]*a0inv;
- //Constructing the lagged coefficients for the loclv_th variable.
- for (vi=nvar-1; vi>=0; vi--) {
- //=== Constructing the constant term.
- tmpdsum = - a0p_dv->v[vi]; //Assigned to -a_0.
- for (li=nlags; li>=1; li--) //Note li=1; li<=nlags, NOT li=0; li<nlags.
- tmpdsum += a0p_dv->v[vi+nvar*li];
- c0 = tmpdsum*a0inv;
- //Done with t* array.
-
- //=== Getting dynamic responses to the vi_th variable.
- resps_sdv.v = Resps_dm->M + vi*K;
- DynamicResponsesAR(&resps_sdv, c0, a1_dv);
- }
- Resps_dm->flag = M_GE;
-
-
- //=== Destroys memory allocated for this function only.
- a1_dv = DestroyVector_lf(a1_dv);
-}
-
-
-
-void DynamicResponsesAR(TSdvector *resps_dv, const double c0, const TSdvector *a1_dv)
-{
- //Outputs:
- // resps_dv: k-by-1 where k responses r_{t+1} to r_{t+k} are computed from r_{t+1} = c0 + a1'*[r_t; ...; r_{t-nlags+1}].
- //Inputs:
- // c0: constant term.
- // a1_dv: nlags-by-1 vector of coefficients in the AR process.
- int ti;
- int k, nlags;
- double *rv;
- TSdvector *rlags_dv = NULL;
-
- if (!resps_dv || !a1_dv || !a1_dv->flag) fn_DisplayError(".../cstz/DynamicResponsesAR(): (1) both input and output vectors must be allocated memory; (2) the input vector must have legal values");
- rlags_dv = CreateConstantVector_lf(nlags=a1_dv->n, 0.0);
-
- rv = resps_dv->v;
- k = resps_dv->n;
-
- *(rlags_dv->v) = *rv = c0;
-
-
- for (ti=1; ti<k; ti++) {
- //Note ti=1, NOT ti=0.
- rv[ti] = c0 + VectorDotVector((TSdvector *)a1_dv, rlags_dv);
- //=== Updating rlags_dv.
- memmove(rlags_dv->v+1, rlags_dv->v, (nlags-1)*sizeof(double));
- *(rlags_dv->v) = rv[ti];
- }
- resps_dv->flag = V_DEF;
-
- //=== Destroys memory allocated for this function only.
- rlags_dv = DestroyVector_lf(rlags_dv);
-}
-
-
-
-
-
-//---------------------------- Some regular vector or matrix operations ---------------------
-double MinVector_lf(TSdvector *x_dv) {
- //Input: no change for x_dv in this function.
- int _i, n;
- double minvalue;
- double *v;
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/MinVector_lf(): Input vector x_dv must be (1) allocated memory and (2) assigned legal values");
- n = x_dv->n;
- v = x_dv->v;
-
- minvalue = v[0];
- for (_i=n-1; _i>0; _i--)
- if (v[_i]<minvalue) minvalue = v[_i];
-
- return( minvalue );
-}
-
-TSdvector *ConvertVector2exp(TSdvector *y_dv, TSdvector *x_dv)
-{
- //y=exp(x): output vector. If NULL, y will be created and memory-allocated.
- //x: input vector.
- TSdvector *z_dv=NULL;
- #if !defined (INTELCMATHLIBRARY)
- int _i;
- #endif
-
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/ConvertVector2exp(): input vector must be (1) created and (2) given legal values");
-
- #if defined (INTELCMATHLIBRARY)
-
- if (!y_dv)
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdExp(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- return (z_dv);
- }
- else if (x_dv!=y_dv)
- {
- vdExp(x_dv->n, x_dv->v, y_dv->v);
- y_dv->flag = V_DEF;
- return (y_dv);
- }
- else
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdExp(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- CopyVector0(x_dv, z_dv);
- DestroyVector_lf(z_dv);
- return (x_dv);
- }
-
- #else
-
- if (!y_dv) z_dv = CreateVector_lf(x_dv->n);
- else z_dv = y_dv;
- for (_i=x_dv->n-1; _i>=0; _i--) z_dv->v[_i] = exp(x_dv->v[_i]);
- z_dv->flag = V_DEF;
- return (z_dv);
-
- #endif
-}
-//---
-TSdvector *ConvertVector2log(TSdvector *y_dv, TSdvector *x_dv)
-{
- //y=log(x): output vector. If NULL, y will be created and memory-allocated.
- //x: input vector.
- TSdvector *z_dv=NULL;
- #if !defined (INTELCMATHLIBRARY)
- int _i;
- #endif
-
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/ConvertVector2exp(): input vector must be (1) created and (2) given legal values");
-
- #if defined (INTELCMATHLIBRARY)
-
- if (!y_dv)
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdLn(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- return (z_dv);
- }
- else if (x_dv!=y_dv)
- {
- vdLn(x_dv->n, x_dv->v, y_dv->v);
- y_dv->flag = V_DEF;
- return (y_dv);
- }
- else
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdLn(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- CopyVector0(x_dv, z_dv);
- DestroyVector_lf(z_dv);
- return (x_dv);
- }
-
- #else
-
- if (!y_dv) z_dv = CreateVector_lf(x_dv->n);
- else z_dv = y_dv;
- for (_i=x_dv->n-1; _i>=0; _i--) z_dv->v[_i] = log(x_dv->v[_i]);
- z_dv->flag = V_DEF;
- return (z_dv);
-
- #endif
-}
-
-double tz_normofvector(TSdvector *x_dv, double p)
-{
- double norm = 0.0;
- int ki, _n;
- double *v;
-
- if ( !x_dv || !x_dv->flag ) fn_DisplayError("/cstz.c/tz_normofvector(): Input x_dv must have (1) memory and (2) legal values");
- if (p<1.0) fn_DisplayError("/cstz.c/tz_normofvector(): The input p must be no less than 1.0");
- _n = x_dv->n;
- v = x_dv->v;
-
- if (p==2.0)
- {
- for (ki=_n-1; ki>=0; ki--) norm += v[ki]*v[ki];
- norm = sqrt(norm);
- }
- else
- {
- printf("\n/cstz.c/tz_normofvector(): HELLO I TRICK YOU and YOU MUST DO fabs(p-2.0)<MICHINEZERO!!!!!!\n"); //????
- if (p==1.0)
- for (ki=_n-1; ki>=0; ki--) norm += fabs(v[ki]);
- else
- {
- for (ki=_n-1; ki>=0; ki--) norm += pow(fabs(v[ki]), p);
- norm = pow(norm, 1.0/p);
- }
- }
-
- return (norm);
-}
-
-
-
-//---------------------------- Not used often ---------------------
-void fn_cumsum(double **aos_v, int *aods_v, double *v, int d_v) {
- // Compute a cumulative sum of a vector.
- //
- // v: an n-by-1 vector.
- // d_v: n -- size of the vector v to be used for a cumulative sum.
- // aos_v: address of the pointer to the n-by-1 vector s_v.
- // aods_v: address of the size of the dimension of s_v.
- //----------
- // *aos_v: An n-by-1 vector of cumulative sum s_v.
- // *aods_v: n -- size of the dimension for s_v.
-
- int ki;
-
- *aos_v = tzMalloc(d_v, double);
- (*aods_v) = d_v; // n for the n-by-1 vector s_v.
- *(*aos_v) = *v;
- if (d_v>1) {
- for (ki=1; ki<d_v; ki++) (*aos_v)[ki] = (*aos_v)[ki-1] + v[ki];
- }
-}
-
-
-
-/**
-void fn_ergodp(double **aop, int *aod, mxArray *cp) {
- // Compute the ergodic probabilities. See Hamilton p.681.
- //
- // cp: n-by-n Markovian transition matrix.
- // aop: address of the pointer to the n-by-1 vector p.
- // aod: address of the size of the dimension of p.
- //----------
- // *aop: n-by-1 vector of ergodic probabilities p. @@Must be freed outside this function.@@
- // *aod: n -- size of the dimension for p (automatically supplied within this function).
-
- mxArray *gpim=NULL, *gpid=NULL; // m: n-by-n eigvector matrix; d: n-by-n eigvalue diagonal.
- double *gpim_p, *gpid_p; // _p: a pointer to the corresponding mxArray whose name occurs before _p.
- //------- Note the following two lines will cause Matlab or C to crash because gpim has not been initialized so it points to garbage.
- // double *gpim_p = mxGetPr(gpim);
- // double *gpid_p = mxGetPr(gpid);
- int eigmaxindx, // Index of the column corresponding to the max eigenvalue.
- n, ki;
- double gpisum=0.0,
- eigmax, tmpd0;
-
- n=mxGetM(cp); // Get n for the n-by-n mxArray cp.
- (*aod)=n;
-
- *aop = tzMalloc(n, double);
-
- gpim = mlfEig(&gpid,cp,NULL,NULL);
- gpim_p = mxGetPr(gpim);
- gpid_p = mxGetPr(gpid);
-
- eigmax = *gpid_p;
- eigmaxindx = 0;
- if (n>1) {
- for (ki=1;ki<n;ki++) {
- if (gpid_p[n*ki+ki] > eigmax) {
- eigmax=gpid_p[n*ki+ki];
- eigmaxindx=ki;
- } // Note that n*ki+ki refers to a diagonal location in the n-by-n matrix.
- }
- }
- for (ki=0;ki<n;ki++) {
- gpisum += gpim_p[n*eigmaxindx+ki]; // Sum over the eigmaxindx_th column.
- }
- tmpd0 = 1.0/gpisum;
- for (ki=0;ki<n;ki++) {
- (*aop)[ki] = gpim_p[n*eigmaxindx+ki]*tmpd0; // Normalized eigmaxindx_th column as ergodic probabilities.
- }
-
- mxDestroyArray(gpim); // ????? free(gpim_p)
- mxDestroyArray(gpid);
-}
-/**/
-
-
-
-//---------- Must keep the following code forever. ---------------
-/**
-TSdp2m5 *CreateP2m5(const double p)
-{
- TSdp2m5 *x_dp2m5 = tzMalloc(1, TSdp2m5);
-
- if (p<=0.0 && p>=1.0) fn_DisplayError(".../cstz.c/CreateP2m5_lf(): input probability p must be between 0.0 and 1.0");
-
- x_dp2m5->cnt = 0;
- x_dp2m5->ndeg = 0;
- x_dp2m5->p = tzMalloc(5, double);
- x_dp2m5->q = tzMalloc(5, double);
- x_dp2m5->m = tzMalloc(5, int);
-
- x_dp2m5->p[0] = 0.00;
- x_dp2m5->p[1] = 0.5*p;
- x_dp2m5->p[2] = p;
- x_dp2m5->p[3] = 0.5*(1.0+p);
- x_dp2m5->p[4] = 1.00;
-
- return (x_dp2m5);
-}
-TSdp2m5 *DestroyP2m5(TSdp2m5 *x_dp2m5)
-{
- if (x_dp2m5) {
- free(x_dp2m5->m);
- free(x_dp2m5->q);
- free(x_dp2m5->p);
-
- free(x_dp2m5);
- return ((TSdp2m5 *)NULL);
- }
- else return (x_dp2m5);
-}
-TSdvectorp2m5 *CreateVectorP2m5(const int n, const double p)
-{
- int _i;
- //
- TSdvectorp2m5 *x_dvp2m5 = tzMalloc(1, TSdvectorp2m5);
-
- x_dvp2m5->n = n;
- x_dvp2m5->v = tzMalloc(n, TSdp2m5 *);
- for (_i=n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = CreateP2m5(p);
-
- return (x_dvp2m5);
-}
-TSdvectorp2m5 *DestroyVectorP2m5(TSdvectorp2m5 *x_dvp2m5)
-{
- int _i;
-
- if (x_dvp2m5) {
- for (_i=x_dvp2m5->n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = DestroyP2m5(x_dvp2m5->v[_i]);
- free(x_dvp2m5->v);
-
- free(x_dvp2m5);
- return ((TSdvectorp2m5 *)NULL);
- }
- return (x_dvp2m5);
-}
-TSdmatrixp2m5 *CreateMatrixP2m5(const int nrows, const int ncols, const double p)
-{
- int _i;
- //
- TSdmatrixp2m5 *X_dmp2m5 = tzMalloc(1, TSdmatrixp2m5);
-
- X_dmp2m5->nrows = nrows;
- X_dmp2m5->ncols = ncols;
- X_dmp2m5->M = tzMalloc(nrows*ncols, TSdp2m5 *);
- for (_i=nrows*ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = CreateP2m5(p);
-
- return (X_dmp2m5);
-}
-TSdmatrixp2m5 *DestroyMatrixP2m5(TSdmatrixp2m5 *X_dmp2m5)
-{
- int _i;
-
- if (X_dmp2m5) {
- for (_i=X_dmp2m5->nrows*X_dmp2m5->ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = DestroyP2m5(X_dmp2m5->M[_i]);
- free(X_dmp2m5->M);
-
- free(X_dmp2m5);
- return ((TSdmatrixp2m5 *)NULL);
- }
- else return (X_dmp2m5);
-}
-TSdcellp2m5 *CreateCellP2m5(const TSivector *rows_iv, const TSivector *cols_iv, const double p)
-{
- int _i;
- int ncells;
- //
- TSdcellp2m5 *X_dcp2m5 = tzMalloc(1, TSdcellp2m5);
-
-
- if (!rows_iv || !cols_iv || !rows_iv->flag || !cols_iv->flag) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Input row and column vectors must be (1) created and (2) assigned legal values");
- if ((ncells=rows_iv->n) != cols_iv->n) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Length of rows_iv must be the same as that of cols_iv");
-
-
- X_dcp2m5->ncells = ncells;
- X_dcp2m5->C = tzMalloc(ncells, TSdmatrixp2m5 *);
- for (_i=ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = CreateMatrixP2m5(rows_iv->v[_i], cols_iv->v[_i], p);
-
- return (X_dcp2m5);
-}
-TSdcellp2m5 *DestroyCellP2m5(TSdcellp2m5 *X_dcp2m5)
-{
- int _i;
-
- if (X_dcp2m5) {
- for (_i=X_dcp2m5->ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = DestroyMatrixP2m5(X_dcp2m5->C[_i]);
- free(X_dcp2m5->C);
-
- free(X_dcp2m5);
- return ((TSdcellp2m5 *)NULL);
- }
- else return (X_dcp2m5);
-}
-
-
-#define P2REALBOUND DBL_MAX
-int P2m5Update(TSdp2m5 *x_dp2m5, const double newval)
-{
- //5-marker P2 algorithm.
- //quantiles q[0] to q[4] correspond to 5-marker probabilities {0.0, p/5, p, (1+p)/5, 1.0}.
- //Outputs:
- // x_dp2m5->q, the markers x_dp2m5->m, is updated and only x_dp2m5->q[2] is used.
- //Inputs:
- // newval: new random number.
- //
- // January 2003.
- int k, j;
- double a;
- double qm, dq;
- int i, dm, dn;
-
-
- if (!x_dp2m5) fn_DisplayError(".../cstz.c/P2m5Update(): x_dp2m5 must be created");
-
- //if (isgreater(newval, -P2REALBOUND) && isless(newval, P2REALBOUND)) {
- if (isfinite(newval) && newval > -P2REALBOUND && newval < P2REALBOUND) {
- if (++x_dp2m5->cnt > 5) {
- //Updating the quantiles and markers.
- for (i=0; x_dp2m5->q[i]<=newval && i<5; i++) ;
- if (i==0) { x_dp2m5->q[0]=newval; i++; }
- if (i==5) { x_dp2m5->q[4]=newval; i--; }
- for (; i<5; i++) x_dp2m5->m[i]++;
- for (i=1; i<4; i++) {
- dq = x_dp2m5->p[i]*x_dp2m5->m[4];
- if (x_dp2m5->m[i]+1<=dq && (dm=x_dp2m5->m[i+1]-x_dp2m5->m[i])>1) {
- dn = x_dp2m5->m[i]-x_dp2m5->m[i-1];
- dq = ((dn+1)*(qm=x_dp2m5->q[i+1]-x_dp2m5->q[i])/dm+
- (dm-1)*(x_dp2m5->q[i]-x_dp2m5->q[i-1])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] += dq;
- x_dp2m5->m[i]++;
- } else
- if (x_dp2m5->m[i]-1>=dq && (dm=x_dp2m5->m[i]-x_dp2m5->m[i-1])>1) {
- dn = x_dp2m5->m[i+1]-x_dp2m5->m[i];
- dq = ((dn+1)*(qm=x_dp2m5->q[i]-x_dp2m5->q[i-1])/dm+
- (dm-1)*(x_dp2m5->q[i+1]-x_dp2m5->q[i])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] -= dq;
- x_dp2m5->m[i]--;
- }
- }
- }
- else if (x_dp2m5->cnt < 5) {
- //Fills the initial values.
- x_dp2m5->q[x_dp2m5->cnt-1] = newval;
- x_dp2m5->m[x_dp2m5->cnt-1] = x_dp2m5->cnt-1;
- }
- else {
- //=== Last filling of initial values.
- x_dp2m5->q[4] = newval;
- x_dp2m5->m[4] = 4;
- //=== P2 algorithm begins with reshuffling quantiles and makers.
- for (j=1; j<5; j++) {
- a = x_dp2m5->q[j];
- for (k=j-1; k>=0 && x_dp2m5->q[k]>a; k--)
- x_dp2m5->q[k+1] = x_dp2m5->q[k];
- x_dp2m5->q[k+1]=a;
- }
- }
- }
- else ++x_dp2m5->ndeg; //Throwing away the draws to treat exceptions.
-
- return (x_dp2m5->cnt);
-}
-#undef P2REALBOUND
-
-void P2m5MatrixUpdate(TSdmatrixp2m5 *X_dmp2m5, const TSdmatrix *newval_dm)
-{
- int _i;
- int nrows, ncols;
-
- if (!X_dmp2m5 || !newval_dm || !newval_dm->flag) fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): (1) Matrix struct X_dmp2m5 must be created and (2) input new value matrix must be crated and given legal values");
- if ((nrows=newval_dm->nrows) != X_dmp2m5->nrows || (ncols=newval_dm->ncols) != X_dmp2m5->ncols)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of rows and colums in X_dmp2m5 must match those of newval_dm");
-
- for (_i=nrows*ncols-1; _i>=0; _i--)
- P2m5Update(X_dmp2m5->M[_i], newval_dm->M[_i]);
-}
-
-void P2m5CellUpdate(TSdcellp2m5 *X_dcp2m5, const TSdcell *newval_dc)
-{
- int _i;
- int ncells;
-
- if (!X_dcp2m5 || !newval_dc) fn_DisplayError(".../cstz.c/P2m5CellUpdate(): (1) Cell struct X_dcp2m5 must be created and (2) input new value cell must be crated and given legal values");
- if ((ncells=newval_dc->ncells) != X_dcp2m5->ncells)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of cells in X_dcp2m5 must match that of newval_dc");
-
- for (_i=ncells-1-1; _i>=0; _i--)
- P2m5MatrixUpdate(X_dcp2m5->C[_i], newval_dc->C[_i]);
-}
-/**/
diff --git a/matlab/swz/c-code/utilities/TZCcode/cstz.h b/matlab/swz/c-code/utilities/TZCcode/cstz.h
deleted file mode 100644
index a2949c8afb8ffbd9b64f826807ce9378e250687f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/cstz.h
+++ /dev/null
@@ -1,199 +0,0 @@
-#ifndef __CSTZ_H__
-#define __CSTZ_H__
- #include "tzmatlab.h"
- #include "switch_opt.h" //DW's Markov-switching routines, only used by gradcd_timet() and ComputeCovarianceFromOuterProduct().
-
-
- typedef struct {
- double bound; //Real bounds to avoid extreme values that may make the P2 algorithm fail.
- double *p; //5-by-1 probabilities as {0.0, p/2, p, (1+p)/2, 1.0}.
- double *q; //5-by-1 quantiles. Only q[2] is used as an estimate of p[2]-quantile or p-quantile.
- int *m; //5-by-1 markers.
- int cnt;
- int ndeg; //Number of exceptions such as degenerate numbers like inf.
- } TSdp2m5;
- typedef struct {
- TSdp2m5 **v;
- int n;
- } TSdvectorp2m5;
- typedef struct {
- TSdp2m5 **M;
- int nrows;
- int ncols;
- } TSdmatrixp2m5;
- typedef struct {
- TSdmatrixp2m5 **C;
- int ncells;
- } TSdcellp2m5;
- typedef struct {
- TSdcellp2m5 **F;
- int ndims;
- } TSdfourthp2m5;
- TSdp2m5 *CreateP2m5(const double p, const double bound);
- TSdp2m5 *DestroyP2m5(TSdp2m5 *x_dp2m5);
- TSdvectorp2m5 *CreateVectorP2m5(const int n, const double p, const double bound);
- TSdvectorp2m5 *DestroyVectorP2m5(TSdvectorp2m5 *x_dvp2m5);
- TSdmatrixp2m5 *CreateMatrixP2m5(const int nrows, const int ncols, const double p, const double bound);
- TSdmatrixp2m5 *DestroyMatrixP2m5(TSdmatrixp2m5 *X_dmp2m5);
- TSdcellp2m5 *CreateCellP2m5(const TSivector *rows_iv, const TSivector *cols_iv, const double p, const double bound);
- TSdcellp2m5 *DestroyCellP2m5(TSdcellp2m5 *X_dcp2m5);
- TSdfourthp2m5 *CreateFourthP2m5(const int ndims, const TSivector *rows_iv, const TSivector *cols_iv, const double p, const double bound);
- TSdfourthp2m5 *DestroyFourthP2m5(TSdfourthp2m5 *X_d4p2m5);
- //
- int P2m5Update(TSdp2m5 *x_dp2m5, const double newval);
- void P2m5VectorUpdate(TSdvectorp2m5 *x_dvp2m5, const TSdvector *newval_dv);
- void P2m5MatrixUpdate(TSdmatrixp2m5 *X_dmp2m5, const TSdmatrix *newval_dm);
- void P2m5CellUpdate(TSdcellp2m5 *X_dcp2m5, const TSdcell *newval_dc);
- void P2m5FourthUpdate(TSdfourthp2m5 *X_d4p2m5, const TSdfourth *newval_d4);
-
-
- #if defined ( CSMINWEL_OPTIMIZATION )
- void fn_gradcd(double *g, double *x, int n, double grdh,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims);
-
- void fn_hesscd(double *H, double *x, int n, double grdh,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims);
- #elif defined ( IMSL_OPTIMIZATION )
- void fn_gradcd(double *g, double *x, int n, double grdh,
- double fcn(int n, double *x));
- void fn_hesscd(double *H, double *x, int n, double grdh,
- double fcn(int n, double *x));
- #endif
-
- //=== For the conjugate gradient method I or II
- void gradcd_gen(double *g, double *x, int n, double (*fcn)(double *x, int n), double *grdh, double f0);
- void gradfd_gen(double *g, double *x, int n, double (*fcn)(double *x, int n), double *grdh, double f0);
-
- //=== For computing inverse Hessian.
- void gradcd_timet(TSdvector *g_dv, TSdvector *x_dv, int t, struct TStateModel_tag *smodel_ps, double (*fcn)(double *x, int t, struct TStateModel_tag *smodel_ps), double grdh, double f0);
- TSdmatrix *ComputeHessianFromOuterProduct(TSdmatrix *Hessian_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv);
- TSdmatrix *ComputeCovarianceFromOuterProduct(TSdmatrix *Omega_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv);
-
-
-
-
- int next_permutation(int *first, int *last);
-
- //void fn_ergodp(double **aop, int *aod, mxArray *cp);
- void fn_cumsum(double **aos_v, int *aods_v, double *v, int d_v);
- int fn_cumsum_int(int *x_v, const int d_x_v);
- double fn_cumsum_lf(double *x_v, const int d_x_v);
- double fn_mean(const double *a_v, const int _n);
-
-
- //=== For sorting according to x_dv.
- void tz_sort(TSdvector *x_dv, char ad);
- void tz_sortindex_lf(TSivector *x_iv, TSdvector *base_dv, char ad);
- void tz_sortindex(TSivector *x_iv, TSvoidvector *base_voidv, char ad); //??????Not fully tested yet.
- //+
- void tz_sort_matrix(TSdmatrix *X_dm, char ad, char rc);
- TSdvector *tz_prctile_matrix(TSdvector *z_dv, const double prc, TSdmatrix *Z_dm, const char rc);
- TSdvector *tz_mean_matrix(TSdvector *z_dv, TSdmatrix *Z_dm, const char rc);
- //--- The following 3 functions should be hided (static) but are made visible to accomodate the old code that uses these functions.
- void fn_SetBaseArrayForComp(TSdvector *x_dv);
- int fn_compare(const void *i1, const void *i2);
- int fn_compare2(const void *i1, const void *i2);
-
-
- //=== Normalization for VARs.
- void fn_wznormalization(TSdvector *wznmlz_dv, TSdmatrix *A0draw_dm, TSdmatrix *A0peak_dm);
-
- //=== Handling under or over flows with log values.
- typedef struct TSveclogsum_tag {
- //For a recurisve algorithm to compute the log of sum (and therefore log of mean). See p.81a and p.105 in TVBAR Notes.
- int n; //Number of sums, which is the dimension for N_iv, Ysum_dv, and ymax_dv.
- TSivector *N_iv; //(N_1, ..., N_n).
- TSdvector *logsum_dv, //(logofsum_1, ..., logofsum_n).
- *logmax_dv; //(logmax_1, ..., logmax_n).
- } TSveclogsum;
- struct TSveclogsum_tag *CreateVeclogsum(int n);
- struct TSveclogsum_tag *DestroyVeclogsum(struct TSveclogsum_tag *);
- //
- void UpdateSumFor1st2ndMoments(TSdvector *x1stsum_dv, TSdmatrix *X2ndsum_dm, const TSdvector *xdraw_dv);
- int tz_update_logofsum(double *Y_N_dp, double *y_Nmax_dp, double ynew, int N);
- int fn_update_logofsum(int N, double ynew, double *Y_N_dp, double *y_Nmax_dp);
- double fn_replace_logofsumsbt(double *yold, double _a, double ynew, double _b);
-
-
-
- //---------------------------- Special functions and densities. ---------------------
- double fn_normalcdf(double x);
- double fn_normalinv(double p); //Inverse of normal cdf.
- double fn_chi2inv(double p, double df);
- //p = int_{0}^{\infty} chi2pdf(t, df) dt
- double fn_betainv(double p, double _alpha, double _beta);
- //p = int_{0}^{\infty} betapdf(t, _alpha, _beta) dt where betapdf(t,_alpha,_beta) \propt t^{_alpha-1}*(1-t)^(_beta-1}.
- double fn_gammalog(double x);
- //log gamma (x) where gamma(n+1) = n! and gamma(x) = int_0^{\infty} e^{-t} t^{x-1} dt.
- double fn_betalog(double x, double y);
- //log beta(x, y) where beta(x, y) = gamma(x)*gamm(y)/gamma(x+y).
- //+ Density functions
- double tz_lognormalpdf(double _x, double _m, double _s);
- double tz_logbetapdf(double _x, double _a, double _b);
- double tz_loggammapdf(double _x, double _a, double _b);
- double tz_loginversegammapdf(double _x, double _a, double _b);
-
-
- //---------------------------- Some high-level VAR functions ---------------------
- void fn_lev2growthanual(TSdmatrix *levgro_dm, const TSdmatrix *levgrominus1_dm, const TSivector *indxlogper_iv);
- void fn_ctfals_givenshocks_sm(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm,
- const TSivector *S_Tdraw_iv, const TSdcell *Bsdraw_dc, const TSdcell *A0sdrawinv_dc, const TSivector *noshocks_iv);
- void fn_ctfals_sm(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm, const TSivector *Snfores_iv, const TSdcell *Bsdraw_dc, const TSdcell *A0sdrawinv_dc);
- void fn_ctfals_policyonly(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm, const TSivector *S_Tdraw_iv, const int statecon, const int selej, const TSdcell *A0sdraw_dc, const TSdcell *Apsdraw_dc);
- void fn_impulse(TSdmatrix *imftran_dm, const TSdmatrix *Bh_dm, const TSdmatrix *swishtran_dm, const int nlags, const int imsteps);
- TSdmatrix *tz_impulse2levels(TSdmatrix *imflev_dm, TSdmatrix *imf_dm, TSivector *vlist2levels_iv);
- //
- void DynamicResponsesAR(TSdvector *resps_dv, const double c0, const TSdvector *a1_dv);
- void DynamicResponsesForStructuralEquation(TSdmatrix *Resps_dm, const int loclv, const int nlags, const TSdvector *a0p_dv);
-
-
-
- //---------------------------- Some regular vector or matrix operations ---------------------
- double MinVector_lf(TSdvector *x_dv);
- TSdvector *ConvertVector2exp(TSdvector *y_dv, TSdvector *x_dv); //y=exp(x): output; x: input.
- TSdvector *ConvertVector2log(TSdvector *y_dv, TSdvector *x_dv); //y=log(x): output; x: input.
- double tz_normofvector(TSdvector *x_dv, double p);
-
-
- //---------------------------- Old Interface ---------------------
- double gammalog(double x);
- //log gamma (x) where gamma(n+1) = n! and gamma(x) = int_0^{\infty} e^{-t} t^{x-1} dt.
-
-
-
-
- //----------- Must keep the following forever. -------------
- /**
- typedef struct {
- double *p; //5-by-1 probabilities as {0.0, p/2, p, (1+p)/2, 1.0}.
- double *q; //5-by-1 quantiles. Only q[2] is used as an estimate of p[2]-quantile or p-quantile.
- int *m; //5-by-1 markers.
- int cnt;
- int ndeg; //Number of exceptions such as degenerate numbers like inf.
- } TSdp2m5;
- typedef struct {
- TSdp2m5 **v;
- int n;
- } TSdvectorp2m5;
- typedef struct {
- TSdp2m5 **M;
- int nrows;
- int ncols;
- } TSdmatrixp2m5;
- typedef struct {
- TSdmatrixp2m5 **C;
- int ncells;
- } TSdcellp2m5;
-
- TSdp2m5 *CreateP2m5(const double p);
- TSdp2m5 *DestroyP2m5(TSdp2m5 *x_dp2m5);
- TSdvectorp2m5 *CreateVectorP2m5(const int n, const double p);
- TSdvectorp2m5 *DestroyVectorP2m5(TSdvectorp2m5 *x_dvp2m5);
- TSdmatrixp2m5 *CreateMatrixP2m5(const int nrows, const int ncols, const double p);
- TSdmatrixp2m5 *DestroyMatrixP2m5(TSdmatrixp2m5 *X_dmp2m5);
- TSdcellp2m5 *CreateCellP2m5(const TSivector *rows_iv, const TSivector *cols_iv, const double p);
- TSdcellp2m5 *DestroyCellP2m5(TSdcellp2m5 *X_dcp2m5);
- /**/
-#endif
diff --git a/matlab/swz/c-code/utilities/TZCcode/cstz_dw.c b/matlab/swz/c-code/utilities/TZCcode/cstz_dw.c
deleted file mode 100644
index 029daba5deae0a1f7e3469d6bf34349d40fae049..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/cstz_dw.c
+++ /dev/null
@@ -1,2791 +0,0 @@
-#include "cstz.h"
-
-#include <float.h>
-#include <string.h> //For memmove, etc.
-#include "mathlib.h"
-
-
-//????????
-//------- For computing inverse Hessian only. -------
-//static struct TStateModel_tag *SetModelGlobalForCovariance(struct TStateModel_tag *smodel_ps);
-//static double ObjFuncForSmodel(double *x0_p, int d_x0);
-//static double opt_logOverallPosteriorKernal(struct TStateModel_tag *smodel_ps, TSdvector *xchange_dv);
-
-static double logCondPostKernTimet(double *xchange_p, int t, struct TStateModel_tag *smodel_ps);
-static double neglogPostKern_hess(double *xchange_pd, struct TStateModel_tag *smodel_ps);
-static void hesscd_smodel(TSdmatrix *H_dm, TSdvector *x_dv, struct TStateModel_tag *smodel_ps, double (*fcn)(double *x, struct TStateModel_tag *), double grdh, double f0);
-
-TSdp2m5 *CreateP2m5(const double p, const double bound)
-{
- TSdp2m5 *x_dp2m5 = tzMalloc(1, TSdp2m5);
-
- if (p<=0.0 && p>=1.0) fn_DisplayError(".../cstz.c/CreateP2m5(): Input probability p must be between 0.0 and 1.0");
- if ((x_dp2m5->bound=bound)<=0.0) fn_DisplayError(".../cstz.c/CreateP2m5(): Real bound must be positive");
-
- x_dp2m5->cnt = 0;
- x_dp2m5->ndeg = 0;
- x_dp2m5->p = tzMalloc(5, double);
- x_dp2m5->q = tzMalloc(5, double);
- x_dp2m5->m = tzMalloc(5, int);
-
- //=== 5 markers.
- x_dp2m5->p[0] = 0.00;
- x_dp2m5->p[1] = 0.5*p;
- x_dp2m5->p[2] = p;
- x_dp2m5->p[3] = 0.5*(1.0+p);
- x_dp2m5->p[4] = 1.00;
- //=== Now 9 markers.
- // x_dp2m5->p[0] = 0.00;
- // x_dp2m5->p[1] = 0.25*p
- // x_dp2m5->p[2] = 0.5*p;
- // x_dp2m5->p[3] = 0.75*p;
- // x_dp2m5->p[4] = p;
- // x_dp2m5->p[5] = 0.25 + 0.75*p;
- // x_dp2m5->p[6] = 0.5*(1.0+p);
- // x_dp2m5->p[7] = 0.75 + 0.25*p;
- // x_dp2m5->p[8] = 1.00;
-
- return (x_dp2m5);
-}
-TSdp2m5 *DestroyP2m5(TSdp2m5 *x_dp2m5)
-{
- if (x_dp2m5) {
- free(x_dp2m5->m);
- free(x_dp2m5->q);
- free(x_dp2m5->p);
-
- free(x_dp2m5);
- return ((TSdp2m5 *)NULL);
- }
- else return (x_dp2m5);
-}
-TSdvectorp2m5 *CreateVectorP2m5(const int n, const double p, const double bound)
-{
- int _i;
- //
- TSdvectorp2m5 *x_dvp2m5 = tzMalloc(1, TSdvectorp2m5);
-
- x_dvp2m5->n = n;
- x_dvp2m5->v = tzMalloc(n, TSdp2m5 *);
- for (_i=n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = CreateP2m5(p, bound);
-
- return (x_dvp2m5);
-}
-TSdvectorp2m5 *DestroyVectorP2m5(TSdvectorp2m5 *x_dvp2m5)
-{
- int _i;
-
- if (x_dvp2m5) {
- for (_i=x_dvp2m5->n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = DestroyP2m5(x_dvp2m5->v[_i]);
- free(x_dvp2m5->v);
-
- free(x_dvp2m5);
- return ((TSdvectorp2m5 *)NULL);
- }
- else return (x_dvp2m5);
-}
-TSdmatrixp2m5 *CreateMatrixP2m5(const int nrows, const int ncols, const double p, const double bound)
-{
- int _i;
- //
- TSdmatrixp2m5 *X_dmp2m5 = tzMalloc(1, TSdmatrixp2m5);
-
- X_dmp2m5->nrows = nrows;
- X_dmp2m5->ncols = ncols;
- X_dmp2m5->M = tzMalloc(nrows*ncols, TSdp2m5 *);
- for (_i=nrows*ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = CreateP2m5(p, bound);
-
- return (X_dmp2m5);
-}
-TSdmatrixp2m5 *DestroyMatrixP2m5(TSdmatrixp2m5 *X_dmp2m5)
-{
- int _i;
-
- if (X_dmp2m5) {
- for (_i=X_dmp2m5->nrows*X_dmp2m5->ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = DestroyP2m5(X_dmp2m5->M[_i]);
- free(X_dmp2m5->M);
-
- free(X_dmp2m5);
- return ((TSdmatrixp2m5 *)NULL);
- }
- else return (X_dmp2m5);
-}
-TSdcellp2m5 *CreateCellP2m5(const TSivector *rows_iv, const TSivector *cols_iv, const double p, const double bound)
-{
- int _i;
- int ncells;
- //
- TSdcellp2m5 *X_dcp2m5 = tzMalloc(1, TSdcellp2m5);
-
-
- if (!rows_iv || !cols_iv || !rows_iv->flag || !cols_iv->flag) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Input row and column vectors must be (1) created and (2) assigned legal values");
- if ((ncells=rows_iv->n) != cols_iv->n) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Length of rows_iv must be the same as that of cols_iv");
-
-
- X_dcp2m5->ncells = ncells;
- X_dcp2m5->C = tzMalloc(ncells, TSdmatrixp2m5 *);
- for (_i=ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = CreateMatrixP2m5(rows_iv->v[_i], cols_iv->v[_i], p, bound);
-
- return (X_dcp2m5);
-}
-TSdcellp2m5 *DestroyCellP2m5(TSdcellp2m5 *X_dcp2m5)
-{
- int _i;
-
- if (X_dcp2m5) {
- for (_i=X_dcp2m5->ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = DestroyMatrixP2m5(X_dcp2m5->C[_i]);
- free(X_dcp2m5->C);
-
- free(X_dcp2m5);
- return ((TSdcellp2m5 *)NULL);
- }
- else return (X_dcp2m5);
-}
-TSdfourthp2m5 *CreateFourthP2m5(const int ndims, const TSivector *rows_iv, const TSivector *cols_iv, const double p, const double bound)
-{
- int _i;
- //
- TSdfourthp2m5 *X_d4p2m5 = tzMalloc(1, TSdfourthp2m5);
-
-
- if (!rows_iv || !cols_iv || !rows_iv->flag || !cols_iv->flag) fn_DisplayError(".../cstz.c/CreateFourthP2m5(): Input row and column vectors must be (1) created and (2) assigned legal values");
- if (rows_iv->n != cols_iv->n) fn_DisplayError(".../cstz.c/CreateFourthP2m5(): Length of rows_iv must be the same as that of cols_iv");
-
-
- X_d4p2m5->ndims = ndims;
- X_d4p2m5->F = tzMalloc(ndims, TSdcellp2m5 *);
- for (_i=ndims-1; _i>=0; _i--)
- X_d4p2m5->F[_i] = CreateCellP2m5(rows_iv, cols_iv, p, bound);
-
- return (X_d4p2m5);
-}
-TSdfourthp2m5 *DestroyFourthP2m5(TSdfourthp2m5 *X_d4p2m5)
-{
- int _i;
-
- if (X_d4p2m5) {
- for (_i=X_d4p2m5->ndims-1; _i>=0; _i--)
- X_d4p2m5->F[_i] = DestroyCellP2m5(X_d4p2m5->F[_i]);
- free(X_d4p2m5->F);
-
- free(X_d4p2m5);
- return ((TSdfourthp2m5 *)NULL);
- }
- else return (X_d4p2m5);
-}
-
-
-
-int P2m5Update(TSdp2m5 *x_dp2m5, const double newval)
-{
- //5-marker P2 algorithm.
- //quantiles q[0] to q[4] correspond to 5-marker probabilities {0.0, p/5, p, (1+p)/5, 1.0}.
- //Outputs:
- // x_dp2m5->q, the markers x_dp2m5->m, is updated and only x_dp2m5->q[2] is used.
- //Inputs:
- // newval: new random number.
- //
- // January 2003.
- int k, j;
- double a;
- double qm, dq;
- int i, dm, dn;
-
-
- if (!x_dp2m5) fn_DisplayError(".../cstz.c/P2m5Update(): x_dp2m5 must be created");
-
- //if (isgreater(newval, -P2REALBOUND) && isless(newval, P2REALBOUND)) {
- if (isfinite(newval) && newval > -x_dp2m5->bound && newval < x_dp2m5->bound) {
- if (++x_dp2m5->cnt > 5) {
- //Updating the quantiles and markers.
- for (i=0; x_dp2m5->q[i]<=newval && i<5; i++) ;
- if (i==0) { x_dp2m5->q[0]=newval; i++; }
- if (i==5) { x_dp2m5->q[4]=newval; i--; }
- for (; i<5; i++) x_dp2m5->m[i]++;
- for (i=1; i<4; i++) {
- dq = x_dp2m5->p[i]*x_dp2m5->m[4];
- if (x_dp2m5->m[i]+1<=dq && (dm=x_dp2m5->m[i+1]-x_dp2m5->m[i])>1) {
- dn = x_dp2m5->m[i]-x_dp2m5->m[i-1];
- dq = ((dn+1)*(qm=x_dp2m5->q[i+1]-x_dp2m5->q[i])/dm+
- (dm-1)*(x_dp2m5->q[i]-x_dp2m5->q[i-1])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] += dq;
- x_dp2m5->m[i]++;
- } else
- if (x_dp2m5->m[i]-1>=dq && (dm=x_dp2m5->m[i]-x_dp2m5->m[i-1])>1) {
- dn = x_dp2m5->m[i+1]-x_dp2m5->m[i];
- dq = ((dn+1)*(qm=x_dp2m5->q[i]-x_dp2m5->q[i-1])/dm+
- (dm-1)*(x_dp2m5->q[i+1]-x_dp2m5->q[i])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] -= dq;
- x_dp2m5->m[i]--;
- }
- }
- }
- else if (x_dp2m5->cnt < 5) {
- //Fills the initial values.
- x_dp2m5->q[x_dp2m5->cnt-1] = newval;
- x_dp2m5->m[x_dp2m5->cnt-1] = x_dp2m5->cnt-1;
- }
- else {
- //=== Last filling of initial values.
- x_dp2m5->q[4] = newval;
- x_dp2m5->m[4] = 4;
- //=== P2 algorithm begins with reshuffling quantiles and makers.
- for (j=1; j<5; j++) {
- a = x_dp2m5->q[j];
- for (k=j-1; k>=0 && x_dp2m5->q[k]>a; k--)
- x_dp2m5->q[k+1] = x_dp2m5->q[k];
- x_dp2m5->q[k+1]=a;
- }
- }
- }
- else ++x_dp2m5->ndeg; //Throwing away the draws to treat exceptions.
-
- return (x_dp2m5->cnt);
-}
-
-void P2m5VectorUpdate(TSdvectorp2m5 *x_dvp2m5, const TSdvector *newval_dv)
-{
- int _i, _n;
-
- if (!x_dvp2m5 || !newval_dv || !newval_dv->flag) fn_DisplayError(".../cstz.c/P2m5VectorUpdate(): (1) Vector struct x_dvp2m5 must be created and (2) input new value vector must be crated and given legal values");
- if ((_n=newval_dv->n) != x_dvp2m5->n)
- fn_DisplayError(".../cstz.c/P2m5VectorUpdate(): dimension of x_dvp2m5 must match that of newval_dv");
-
- for (_i=_n-1; _i>=0; _i--)
- P2m5Update(x_dvp2m5->v[_i], newval_dv->v[_i]);
-}
-
-void P2m5MatrixUpdate(TSdmatrixp2m5 *X_dmp2m5, const TSdmatrix *newval_dm)
-{
- int _i;
- int nrows, ncols;
-
- if (!X_dmp2m5 || !newval_dm || !newval_dm->flag) fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): (1) Matrix struct X_dmp2m5 must be created and (2) input new value matrix must be crated and given legal values");
- if ((nrows=newval_dm->nrows) != X_dmp2m5->nrows || (ncols=newval_dm->ncols) != X_dmp2m5->ncols)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of rows and colums in X_dmp2m5 must match those of newval_dm");
-
- for (_i=nrows*ncols-1; _i>=0; _i--)
- P2m5Update(X_dmp2m5->M[_i], newval_dm->M[_i]);
-}
-
-void P2m5CellUpdate(TSdcellp2m5 *X_dcp2m5, const TSdcell *newval_dc)
-{
- int _i;
- int ncells;
-
- if (!X_dcp2m5 || !newval_dc) fn_DisplayError(".../cstz.c/P2m5CellUpdate(): (1) Cell struct X_dcp2m5 must be created and (2) input new value cell must be crated and given legal values");
- if ((ncells=newval_dc->ncells) != X_dcp2m5->ncells)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of cells in X_dcp2m5 must match that of newval_dc");
-
- for (_i=ncells-1; _i>=0; _i--)
- P2m5MatrixUpdate(X_dcp2m5->C[_i], newval_dc->C[_i]);
-}
-
-void P2m5FourthUpdate(TSdfourthp2m5 *X_d4p2m5, const TSdfourth *newval_d4)
-{
- int _i;
- int ndims;
-
- if (!X_d4p2m5 || !newval_d4) fn_DisplayError(".../cstz.c/P2m5FourthUpdate(): (1) Fourth struct X_d4p2m5 must be created and (2) input new value fourth must be crated and given legal values");
- if ((ndims=newval_d4->ndims) != X_d4p2m5->ndims)
- fn_DisplayError(".../cstz.c/P2m5FourthUpdate(): Number of fourths in X_d4p2m5 must match that of newval_d4");
-
- for (_i=ndims-1; _i>=0; _i--)
- P2m5CellUpdate(X_d4p2m5->F[_i], newval_d4->F[_i]);
-}
-
-
-
-
-//---------------------------------------------------------------------
-//---------------------------------------------------------------------
-#if defined( CSMINWEL_OPTIMIZATION )
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_gradcd(double *g, double *x, int n, double grdh,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // grdh: step size. If ==0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // x: no change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
-
- double dh, fp, fm, tmp, *xp;
- int i;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = grdh?grdh:(fabs(*xp)<1?STPS:STPS*(*xp));
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x,n,args,dims);
- *xp = tmp - dh;
- fm = fcn(x,n,args,dims);
- *g = (fp-fm)/(2*dh);
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
- #undef STPS
-
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_hesscd(double *H, double *x, int n, double grdh,
- double (*fcn)(double *x, int n, double **args, int *dims),
- double **args, int *dims) {
- double dhi, dhj, f1, f2, f3, f4, tmpi, tmpj, *xpi, *xpj;
- int i, j;
- for (i=0, xpi=x; i<n; i++, xpi++) {
- dhi = grdh?grdh:(fabs(*xpi)<1?STPS:STPS*(*xpi));
- tmpi = *xpi;
- for (j=i, xpj=x+i; j<n; j++, xpj++)
- if (i==j) {
- /* f2 = f3 when i = j */
- f2 = fcn(x,n,args,dims);
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
-
- /* calculate f1 and f4 */
- *xpi = tmpi + 2*dhi;
- f1 = fcn(x,n,args,dims);
- *xpi = tmpi - 2*dhi;
- f4 = fcn(x,n,args,dims);
-
- /* diagonal element */
- H[i*(n+1)] = (f1-2*f2+f4)/(4*dhi*dhi);
-
- /* reset to intial value */
- *xpi = tmpi;
- } else {
- dhj = grdh?grdh:(fabs(*xpj)<1?STPS:STPS*(*xpj));
- tmpj = *xpj;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
- *xpj += dhj;
- dhj = *xpj - tmpj;
-
- /* calculate f1, f2, f3 and f4 */
- *xpj = tmpj + dhj;
- f1 = fcn(x,n,args,dims);
- *xpi = tmpi - dhi;
- f2 = fcn(x,n,args,dims);
- *xpi = tmpi + dhi;
- *xpj = tmpj - dhj;
- f3 = fcn(x,n,args,dims);
- *xpi = tmpi - dhi;
- f4 = fcn(x,n,args,dims);
-
- /* symmetric elements */
- H[i+j*n] = H[j+i*n] = (f1-f2-f3+f4)/(4*dhi*dhj);
-
- /* reset to intial values */
- *xpi = tmpi;
- *xpj = tmpj;
- }
- }
- }
- #undef STPS
-#elif defined( IMSL_OPTIMIZATION )
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_gradcd(double *g, double *x, int n, double grdh,
- double fcn(int n, double *x) // IMSL
- //void NAG_CALL fcn(Integer n,double x[],double *f,double g[],Nag_Comm *comm)
- ) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // grdh: step size. If ==0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // x: no change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
-
- double dh, fp, fm, tmp, *xp;
- int i;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = grdh?grdh:(fabs(*xp)<1?STPS:STPS*(*xp));
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(n,x); // IMSL
- //fcn(n,x,&fp,NULL,NULL); /* NAG */
- *xp = tmp - dh;
- fm = fcn(n,x); // IMSL
- //fcn(n,x,&fm,NULL,NULL);
- *g = (fp-fm)/(2*dh);
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
- #undef STPS
-
- #define STPS 6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
- void fn_hesscd(double *H, double *x, int n, double grdh,
- double fcn(int n, double *x) // IMSL
- //void NAG_CALL fcn(Integer n,double x[],double *f,double g[],Nag_Comm *comm)
- ) {
- double dhi, dhj, f1, f2, f3, f4, tmpi, tmpj, *xpi, *xpj;
- int i, j;
- for (i=0, xpi=x; i<n; i++, xpi++) {
- dhi = grdh?grdh:(fabs(*xpi)<1?STPS:STPS*(*xpi));
- tmpi = *xpi;
- for (j=i, xpj=x+i; j<n; j++, xpj++)
- if (i==j) {
- /* f2 = f3 when i = j */
- f2 = fcn(n,x); // IMSL
- //fcn(n,x,&f2,NULL,NULL);
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
-
- /* calculate f1 and f4 */
- *xpi = tmpi + 2*dhi;
- f1 = fcn(n,x); // IMSL
- //fcn(n,x,&f1,NULL,NULL);
- *xpi = tmpi - 2*dhi;
- f4 = fcn(n,x); /* IMSL */
- //fcn(n,x,&f4,NULL,NULL);
-
- /* diagonal element */
- H[i*(n+1)] = (f1-2*f2+f4)/(4*dhi*dhi);
-
- /* reset to intial value */
- *xpi = tmpi;
- } else {
- dhj = grdh?grdh:(fabs(*xpj)<1?STPS:STPS*(*xpj));
- tmpj = *xpj;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
- *xpj += dhj;
- dhj = *xpj - tmpj;
-
- /* calculate f1, f2, f3 and f4 */
- *xpj = tmpj + dhj;
- f1 = fcn(n,x); // IMSL
- //fcn(n,x,&f1,NULL,NULL);
- *xpi = tmpi - dhi;
- f2 = fcn(n,x); // IMSL
- //fcn(n,x,&f2,NULL,NULL);
- *xpi = tmpi + dhi;
- *xpj = tmpj - dhj;
- f3 = fcn(n,x); // IMSL
- //fcn(n,x,&f3,NULL,NULL);
- *xpi = tmpi - dhi;
- f4 = fcn(n,x); // IMSL
- //fcn(n,x,&f4,NULL,NULL);
-
- /* symmetric elements */
- H[i+j*n] = H[j+i*n] = (f1-f2-f3+f4)/(4*dhi*dhj);
-
- /* reset to intial values */
- *xpi = tmpi;
- *xpj = tmpj;
- }
- }
- }
- #undef STPS
-#endif
-
-
-
-//-------------------------------
-//Modified from fn_gradcd() in cstz.c for the conjugate gradient method I or II
-//-------------------------------
-#define STPS 1.0e-04 // 6.0554544523933391e-6 step size = pow(DBL_EPSILON,1.0/3)
-#define GRADMANUAL 1.0e+01 //Arbitrarily (manually) set gradient.
-void gradcd_gen(double *g, double *x, int n, double (*fcn)(double *x, int n), double *grdh, double f0) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // n: the dimension of g or x.
- // fcn(): the function for which the gradient is evaluated
- // grdh: step size. If NULL, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dh, dhi, dh2i, fp, fm, tmp, *xp;
- int i;
-
- if (grdh) {
- //=== If f0 >= NEARINFINITY, we're in a bad region and so we assume it's flat in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 >= NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- dh2i = (dhi=1.0/(dh=*grdh))/2.0;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- tmp = *xp;
- *xp += dh;
- //The following statement is bad because dh does not get reset at the beginning of the loop and thus may get changed continually within the loop.
- // dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fp = fcn(n,x); // IMSL
- //fcn(n,x,&fp,NULL,NULL); /* NAG */
- *xp = tmp - dh;
- fm = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fm = fcn(n,x); // IMSL
- //fcn(n,x,&fm,NULL,NULL);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp < NEARINFINITY) && (fm < NEARINFINITY)) *g = (fp-fm)*dh2i;
- else if (fp < NEARINFINITY) *g = (fp-f0)*dhi;
- else if (fm < NEARINFINITY) *g = (f0-fm)*dhi;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
-
- }
- else {
- //=== If f0 >= NEARINFINITY, we're in a bad region and so we assume it's flat in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 >= NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fp = fcn(n,x); // IMSL
- //fcn(n,x,&fp,NULL,NULL); /* NAG */
- *xp = tmp - dh;
- fm = fcn(x, n); //For frprmn() CGI_OPTIMIZATION
- //fm = fcn(n,x); // IMSL
- //fcn(n,x,&fm,NULL,NULL);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp < 0.5*NEARINFINITY) && (fm < 0.5*NEARINFINITY)) *g = (fp-fm)/(2.0*dh);
- else if (fp < 0.5*NEARINFINITY) *g = (fp-f0)/dh;
- else if (fm < 0.5*NEARINFINITY) *g = (f0-fm)/dh;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
-}
-#undef STPS
-#undef GRADMANUAL
-
-
-//-------------------------------
-//Forward difference gradient: much faster than gradcd_gen() when the objective function is very expensive to evaluate.
-//-------------------------------
-#define STPS 1.0e-04 // 6.0554544523933391e-6 step size = pow(DBL_EPSILON,1.0/3)
-void gradfd_gen(double *g, double *x, int n, double (*fcn)(double *x, int n), double *grdh, double f0) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // n: the dimension of g or x.
- // fcn(): the function for which the gradient is evaluated
- // grdh: step size. If NULL, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dh, dhi, fp, tmp, *xp;
- int i;
- if (grdh) {
- dhi = 1.0/(dh=*grdh);
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- if ( (fp=fcn(x, n)) < NEARINFINITY ) *g = (fp-f0)*dhi; //For frprmn() CGI_OPTIMIZATION
- else {
- //Switches to the other side of the boundary.
- *xp = tmp - dh;
- *g = (f0-fcn(x,n))*dhi;
- }
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
-
- }
- else {
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- if ( (fp=fcn(x, n)) < NEARINFINITY ) *g = (fp-f0)/dh; //For frprmn() CGI_OPTIMIZATION
- else {
- //Switches to the other side of the boundary.
- *xp = tmp - dh;
- *g = (f0-fcn(x,n))/dh;
- }
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
-}
-#undef STPS
-
-
-
-//====================================================================================================
-//= Central difference gradient for logLH at time t, using DW's smodel.
-//====================================================================================================
-#define STPS 1.0e-04 // 6.0554544523933391e-6 step size = pow(DBL_EPSILON,1.0/3)
-#define GRADMANUAL 1.0e+01 //Arbitrarily (manually) set gradient.
-void gradcd_timet(TSdvector *g_dv, TSdvector *x_dv, int t, struct TStateModel_tag *smodel_ps, double (*fcn)(double *x, int t, struct TStateModel_tag *smodel_ps), double grdh, double f0)
-{
- //Outputs:
- // g_dv: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x_dv: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // fcn(): the log LH or posterior function for which the gradient is evaluated
- // grdh: step size. If 0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dh, dhi, dh2i, fp, fm, tmp, *xp;
- int i;
- //--- Accessible variables.
- int n;
- double *g, *x;
-
- if (!g_dv) fn_DisplayError(".../cstz.c/gradcd_timet(): the input g_dv must be allocated memory");
- if (!x_dv) fn_DisplayError(".../cstz.c/gradcd_timet(): the input x_dv must be allocated memory");
- if (!x_dv->flag) fn_DisplayError(".../cstz.c/gradcd_timet(): the input x_dv must be given legal values");
- if ((n=g_dv->n) != x_dv->n) fn_DisplayError(".../cstz.c/gradcd_timet(): dimensions of g_dv and x_dv must be the same");
-
- g = g_dv->v;
- x = x_dv->v;
-
- if (grdh>0.0)
- {
- //=== If f0 <= -0.5*NEARINFINITY, we're in a bad region and so we assume it's GRADMANUAL in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 < -0.5*NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- dh2i = (dhi=1.0/(dh=grdh))/2.0;
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- tmp = *xp;
- *xp += dh;
- //The following statement is bad because dh does not get reset at the beginning of the loop and thus may get changed continually within the loop.
- // dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, t, smodel_ps);
- *xp = tmp - dh;
- fm = fcn(x, t, smodel_ps);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp > -0.5*NEARINFINITY) && (fm > -0.5*NEARINFINITY)) *g = (fp-fm)*dh2i;
- else if (fp > -0.5*NEARINFINITY) *g = (fp-f0)*dhi;
- else if (fm > -0.5*NEARINFINITY) *g = (f0-fm)*dhi;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
-
- }
- else {
- //=== If f0 <= -0.5*NEARINFINITY, we're in a bad region and so we assume it's GRADMANUAL in this bad region. This assumption may or may not work for a third-party optimimization routine.
- if (f0 <= -0.5*NEARINFINITY)
- {
- for (i=n-1; i>=0; i--)
- g[i] = GRADMANUAL;
- return;; //Early exit.
- }
-
- for (i=0, xp=x; i<n; i++, xp++, g++) {
- dh = fabs(*xp)<=1 ? STPS : STPS*(*xp);
- tmp = *xp;
- *xp += dh;
- dh = *xp - tmp; // This increases the precision slightly.
- fp = fcn(x, t, smodel_ps);
- *xp = tmp - dh;
- fm = fcn(x, t, smodel_ps);
-
- //=== Checking the boundary condition for the minimization problem.
- if ((fp > -0.5*NEARINFINITY) && (fm > -0.5*NEARINFINITY)) *g = (fp-fm)/(2.0*dh);
- else if (fp > -0.5*NEARINFINITY) *g = (fp-f0)/dh;
- else if (fm > -0.5*NEARINFINITY) *g = (f0-fm)/dh;
- else *g = GRADMANUAL;
-
- *xp = tmp; // Put the original value of x[i] back to x[i] so that the content x[i] is still unaltered.
- }
- }
- g_dv->flag = V_DEF;
-}
-#undef STPS
-#undef GRADMANUAL
-//---
-#if defined (__SWITCHING_VER_200__)
-static double logCondPostKernTimet(double *xchange_pd, int t, struct TStateModel_tag *smodel_ps)
-{
- //Evaluating log conditional posterior kernel at time t -- p(y_t | Y_{t-1}, theta, q).
- int fss = smodel_ps->nobs - smodel_ps->fobs + 1;
- double *x1_pd, *x2_pd;
-
-
- x1_pd = xchange_pd;
- x2_pd = xchange_pd + NumberFreeParametersTheta(smodel_ps);
- //Note that NumberFreeParametersTheta() is DW's function, which points to TZ's function.
- //In the constant parameter model, this will point to an invalid place,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- //======= This is a must step to refresh the value at the new point. =======
- ConvertFreeParametersToTheta(smodel_ps, x1_pd); //Waggoner's function, which calls TZ's Convertphi2*().
- ConvertFreeParametersToQ(smodel_ps, x2_pd); //Waggoner's function, which automatically takes care of the constant-parameter situition
- ThetaChanged(smodel_ps); //DW's function, which will also call my function to set a flag for refreshing everything under these new parameters.
-
-
- if (1) //Posterior function.
- return ( LogConditionalLikelihood_StatesIntegratedOut(t, smodel_ps) + LogPrior(smodel_ps)/((double)fss) ); //DW's function.
- else //Likelihood (with no prior)
- return ( LogConditionalLikelihood_StatesIntegratedOut(t, smodel_ps) ); //DW's function.
-}
-#endif
-
-//------------------------
-// Computing the Hessian at the log posterior or log likelihood peak, using the outer-product Hessian.
-//------------------------
-#if defined (__SWITCHING_VER_200__)
-TSdmatrix *ComputeHessianFromOuterProduct(TSdmatrix *Hessian_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv)
-{
- //Output:
- // Hessian_dm: its inverse equals to Omega (covariance matrix) produced by ComputeCovarianceFromOuterProduct().
- //Inputs:
- // xhat_dv: Hessian at this point.
-
- int ti;
- double f0;
- int nData = smodel_ps->nobs;
- //===
- TSdvector *grad_dv;
-
-
- grad_dv = CreateVector_lf(xhat_dv->n);
- if (!Hessian_dm) Hessian_dm = CreateConstantMatrix_lf(xhat_dv->n, xhat_dv->n, 0.0);
-
- //=== Computing the outer-product Hessian.
- for (ti=smodel_ps->fobs; ti<=nData; ti++) //Base-1 set-up, thus <=nData, NOT <nData.
- {
- f0 = logCondPostKernTimet(xhat_dv->v, ti, smodel_ps);
- gradcd_timet(grad_dv, xhat_dv, ti, smodel_ps, logCondPostKernTimet, 0.0, f0);
- VectorTimesSelf(Hessian_dm, grad_dv, 1.0, 1.0, 'U');
- }
-
-
- SUtoGE(Hessian_dm); //Making upper symmetric matarix to a full matrix.
- Hessian_dm->flag = M_GE; //Reset this flag, so
- ScalarTimesMatrixSquare(Hessian_dm, 0.5, Hessian_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Hessian_dm->flag |= M_SU | M_SL;
-
-
- //===
- DestroyVector_lf(grad_dv);
-
- return (Hessian_dm);
-}
-//------------------------
-// Computing the covariance matrix for standard errors at the log posterior or likelihood peak, using the outer-product Hessian.
-//------------------------
-TSdmatrix *ComputeCovarianceFromOuterProduct(TSdmatrix *Omega_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv)
-{
- //Output:
- // Omega_dm: covariance matrix, which equals to the inverse of the Hessian produced by ComputeHessianFromOuterProduct().
- //Inputs:
- // xhat_dv: Hessian at this point.
-
- int ti;
- double f0;
- int nData = smodel_ps->nobs;
- //===
- TSdvector *grad_dv;
-
-
- grad_dv = CreateVector_lf(xhat_dv->n);
- if (!Omega_dm) Omega_dm = CreateConstantMatrix_lf(xhat_dv->n, xhat_dv->n, 0.0);
-
- //=== Computing the outer-product Hessian.
- for (ti=smodel_ps->fobs; ti<=nData; ti++) //Base-1 set-up, thus <=nData, NOT <nData.
- {
- f0 = logCondPostKernTimet(xhat_dv->v, ti, smodel_ps);
- gradcd_timet(grad_dv, xhat_dv, ti, smodel_ps, logCondPostKernTimet, 0.0, f0);
- VectorTimesSelf(Omega_dm, grad_dv, 1.0, 1.0, 'U');
- }
- SUtoGE(Omega_dm); //Making upper symmetric matarix to a full matrix.
- ScalarTimesMatrixSquare(Omega_dm, 0.5, Omega_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Omega_dm->flag |= M_SU | M_SL;
-
-
- //--- Converting or inverting the Hessian to covariance.
- if (invspd(Omega_dm, Omega_dm, 'U'))
- fn_DisplayError(".../cstz.c/ComputeCovarianceFromOuterProduct(): Hessian must be invertible");
-
-
- //-- Doubly safe to force it to be symmetric.
- SUtoGE(Omega_dm); //Making upper symmetric matarix to a full matrix.
- ScalarTimesMatrixSquare(Omega_dm, 0.5, Omega_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Omega_dm->flag |= M_SU | M_SL;
-
- //--- Checking if it's symmetric, positive definite.
-
-
- //===
- DestroyVector_lf(grad_dv);
-
- return (Omega_dm);
-}
-
-
-
-//------------------------
-// Computing the Hessian at the log posterior or log likelihood peak, using second derivatives.
-//------------------------
-TSdmatrix *ComputeHessianFrom2ndDerivative(TSdmatrix *Hessian_dm, struct TStateModel_tag *smodel_ps, TSdvector *xhat_dv)
-{
- //Output:
- // Hessian_dm: its inverse equals to Omega (covariance matrix).
- // The flag is set to M_GE | M_SU | M_SL by hesscd_smodel().
- //Inputs:
- // xhat_dv: Hessian at this point.
-
- double f0;
- int nData = smodel_ps->nobs;
-
-
- if (!Hessian_dm) Hessian_dm = CreateConstantMatrix_lf(xhat_dv->n, xhat_dv->n, 0.0);
-
- //=== Computing the inner-product Hessian.
- f0 = neglogPostKern_hess(xhat_dv->v, smodel_ps);
- hesscd_smodel(Hessian_dm, xhat_dv, smodel_ps, neglogPostKern_hess, 0.0, f0);
-
- return (Hessian_dm);
-}
-//---
-#define STPS 1.0e-4 //6.0554544523933391e-6 /* step size = pow(DBL_EPSILON,1.0/3) */
-static void hesscd_smodel(TSdmatrix *H_dm, TSdvector *x_dv, struct TStateModel_tag *smodel_ps, double (*fcn)(double *, struct TStateModel_tag *), double grdh, double f0)
-{
- //Outputs:
- // H_dm: the Hessian n-by-n (no need to be initialized).
- //Inputs:
- // x_dv: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // fcn(): the negative (-) log LH or posterior function for which the gradient is evaluated
- // grdh: step size. If 0.0, then dh is set automatically; otherwise, grdh is taken as a step size, often set as 1.0e-004.
- // f0: the value of (*fcn)(x). NOT used in this function except dealing with the boundary (NEARINFINITY) for the
- // minimization problem, but to be compatible with a genral function call where, say, gradfw_gen() and cubic
- // interpolation of central difference method will use f0.
-
- double dhi, dhj, f1, f2, f3, f4, tmpi, tmpj, *xpi, *xpj;
- int i, j;
- //--- Accessible variables.
- int n;
- double *H, *x;
-
- if (!x_dv) fn_DisplayError(".../cstz.c/hesscd_smodel(): the input x_dv must be allocated memory");
- if (!x_dv->flag) fn_DisplayError(".../cstz.c/hesscd_smodel(): the input x_dv must be given legal values");
- if (!H_dm) fn_DisplayError(".../cstz.c/hesscd_smodel(): H_dm must be allocated memory");
- if ( ((n=x_dv->n) != H_dm->nrows) || (n != H_dm->ncols) ) fn_DisplayError(".../cstz.c/hesscd_smodel(): Check the dimension of x_dv and H_dm");
-
- H = H_dm->M;
- x = x_dv->v;
-
- for (i=0, xpi=x; i<n; i++, xpi++) {
- dhi = grdh?grdh:(fabs(*xpi)<1?STPS:STPS*(*xpi));
- tmpi = *xpi;
- for (j=i, xpj=x+i; j<n; j++, xpj++)
- if (i==j)
- {
- /* f2 = f3 when i = j */
- if ((f2 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f2 = f0;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
-
- /* calculate f1 and f4 */
- *xpi = tmpi + 2*dhi;
- if ((f1 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f1 = f0;
-
- *xpi = tmpi - 2*dhi;
- if ((f4 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f4 = f0;
-
- /* diagonal element */
- H[i*(n+1)] = (f1-2*f2+f4)/(4*dhi*dhi);
-
- /* reset to intial value */
- *xpi = tmpi;
- }
- else
- {
- dhj = grdh?grdh:(fabs(*xpj)<1?STPS:STPS*(*xpj));
- tmpj = *xpj;
-
- /* this increases precision slightly */
- *xpi += dhi;
- dhi = *xpi - tmpi;
- *xpj += dhj;
- dhj = *xpj - tmpj;
-
- /* calculate f1, f2, f3 and f4 */
- *xpj = tmpj + dhj;
- if ((f1 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f1 = f0;
- *xpi = tmpi - dhi;
- if ((f2 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f2 = f0;
- *xpi = tmpi + dhi;
- *xpj = tmpj - dhj;
- if ((f3 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f3 = f0;
- *xpi = tmpi - dhi;
- if ((f4 = fcn(x, smodel_ps)) > 0.5*NEARINFINITY) f4 = f0;
-
- /* symmetric elements */
- H[i+j*n] = H[j+i*n] = (f1-f2-f3+f4)/(4*dhi*dhj);
-
- /* reset to intial values */
- *xpi = tmpi;
- *xpj = tmpj;
- }
- }
-
- //--- To be safe.
- H_dm->flag = M_SU;
- SUtoGE(H_dm); //Making upper symmetric matarix to a full matrix.
- H_dm->flag = M_GE; //Reset this flag, so
-
- ScalarTimesMatrixSquare(H_dm, 0.5, H_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- H_dm->flag |= M_SU | M_SL;
-}
-#undef STPS
-//---
-static double neglogPostKern_hess(double *xchange_pd, struct TStateModel_tag *smodel_ps)
-{
- //Evaluating negative log posterior kernel p(y_T | theta, q).
- int fss = smodel_ps->nobs - smodel_ps->fobs + 1;
- double *x1_pd, *x2_pd;
-
-
- x1_pd = xchange_pd;
- x2_pd = xchange_pd + NumberFreeParametersTheta(smodel_ps);
- //Note that NumberFreeParametersTheta() is DW's function, which points to TZ's function.
- //In the constant parameter model, this will point to an invalid place,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- //======= This is a must step to refresh the value at the new point. =======
- ConvertFreeParametersToTheta(smodel_ps, x1_pd); //Waggoner's function, which calls TZ's Convertphi2*().
- ConvertFreeParametersToQ(smodel_ps, x2_pd); //Waggoner's function, which automatically takes care of the constant-parameter situition
- ThetaChanged(smodel_ps); //DW's function, which will also call my function to set a flag for refreshing everything under these new parameters.
-
-
- if (1) //Posterior function.
- return ( -LogLikelihood_StatesIntegratedOut(smodel_ps) - LogPrior(smodel_ps) ); //DW's function.
- else //Likelihood (with no prior)
- return ( -LogLikelihood_StatesIntegratedOut(smodel_ps) ); //DW's function.
-}
-#endif
-
-
-
-
-
-
-
-
-
-
-//????????????????
-/**
-//===
-static struct TStateModel_tag *SMODEL_PS = NULL; //Minimization to find the MLE or posterior peak.
-static struct TStateModel_tag *SetModelGlobalForCovariance(struct TStateModel_tag *smodel_ps)
-{
- //Returns the old pointer in order to preserve the previous value.
- struct TStateModel_tag *tmp_ps =SMODEL_PS;
- SMODEL_PS = smodel_ps;
- return (tmp_ps);
-}
-//--- Can be used for conjugate gradient minimization as well.
-static double ObjFuncForSmodel(double *x0_p, int d_x0)
-{
- TSdvector x0_sdv;
- x0_sdv.v = x0_p;
- x0_sdv.n = d_x0;
- x0_sdv.flag = V_DEF;
-
- return ( -opt_logOverallPosteriorKernal(SMODEL_PS, &x0_sdv) );
-}
-//---
-static double opt_logOverallPosteriorKernal(struct TStateModel_tag *smodel_ps, TSdvector *xchange_dv)
-{
- double *x1_pd, *x2_pd;
-
-
- x1_pd = xchange_dv->v;
- x2_pd = xchange_dv->v + NumberFreeParametersTheta(smodel_ps);
- //Note that NumberFreeParametersTheta() is DW's function, which points to TZ's function.
- //In the constant parameter model, this will point to invalid,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- //======= This is a must step to refresh the value at the new point. =======
- ConvertFreeParametersToTheta(smodel_ps, x1_pd); //Waggoner's function, which calls TZ's Convertphi2*().
- ConvertFreeParametersToQ(smodel_ps, x2_pd); //Waggoner's function, which automatically takes care of the constant-parameter situition
- ThetaChanged(smodel_ps); //DW's function, which will also call my function to set a flag for refreshing everything under these new parameters.
- if (1) //Posterior function.
- return ( LogPosterior_StatesIntegratedOut(smodel_ps) ); //DW's function.
- else //Likelihood (with no prior)
- return ( LogLikelihood_StatesIntegratedOut(smodel_ps) ); //DW's function.
-}
-/**/
-
-
-
-
-
-
-
-
-int next_permutation(int *first, int *last)
-{
- // Given the permulation, say, [3 2 1 0], the ouput is the next permulation [0 1 2 3], and so on.
- // Note that last is simply a pointer. Because it is not allocated to a memory, it cannot be accessed.
- // So last is used for (1) gauging the dimension size of the array first;
- // (2) being accssed but with --last (which points to a valid memory place), NOT last.
- //
- // first: n-by-1 vector of integers filled with 0, 1, 2, ..., n.
- // last: simply a pointer to the address after the last element of first. Note that no memory is allocated.
-
- int *i = last, *ii, *j, tmp;
- if (first == last || first == --i)
- return 0;
-
- for(; ; ) {
- ii = i;
- if (*--i < *ii) {
- j = last;
- while (!(*i < *--j));
- tmp = *i; *i = *j; *j = tmp;
- for (; ii != last && ii != --last; ++ii) {
- tmp = *ii; *ii = *last; *last = tmp;
- }
- return 1;
- }
- if (i == first) {
- for (; first != last && first != --last; ++first) {
- tmp = *first; *first = *last; *last = tmp;
- }
- return 0;
- }
- }
-}
-
-
-
-/**
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-void permute_matrix(double *a, int n, int *indx) {
- double *b;
- int nn=n*n;
- register int i;
- b = calloc(nn,sizeof(double));
- memcpy(b, a, nn*sizeof(double));
- for (i=0; i<nn; i++, a++)
- *a = b[indx[i%n]+indx[i/n]*n];
-}
-
-int main() {
- double a[9]={1,2,3,4,5,6,7,8,9};
- int indx[3]={1,2,0};
- permute_matrix(a,3,indx);
- return 0;
-}
-/**/
-
-
-int fn_cumsum_int(int *x_v, const int d_x_v) {
- //Outputs:
- // x_v: an int vector of cumulative sums over an input int vector.
- // return: the sum of an input int vector.
- //Inputs:
- // x_v: a vector of ints.
- // d_x_v: dimension of x_v.
- //
- // Compute cumulative sums of a vector of ints.
- int _i;
-
- if (x_v==NULL) fn_DisplayError(".../cstz/fn_cumsum_lf: x_v must be allocated with memory");
-
- for (_i=1; _i<d_x_v; _i++) {
- x_v[_i] = x_v[_i-1] + x_v[_i];
- }
-
- return (x_v[d_x_v-1]);
-}
-
-
-double fn_cumsum_lf(double *x_v, const int d_x_v) {
- //Outputs:
- // x_v: a double vector of cumulative sums over an input double vector.
- // return: the sum of an input double vector.
- //Inputs:
- // x_v: a vector of doubles.
- // d_x_v: dimension of x_v.
- //
- // Compute cumulative sums of a vector of doubles.
- int _i;
-
- if (!x_v) fn_DisplayError(".../cstz/fn_cumsum_lf: x_v must be allocated with memory");
-
- for (_i=1; _i<d_x_v; _i++) {
- x_v[_i] = x_v[_i-1] + x_v[_i];
- }
-
- return (x_v[d_x_v-1]);
-}
-
-
-double fn_mean(const double *a_v, const int _n) {
- int _i;
- double x=0.0;
-
- for (_i=0; _i<_n; _i++) x += a_v[_i];
- x /= (double)_n;
-
- return x;
-}
-
-//<<---------------
-static double *tz_BaseForComp; // This base variable is to be sorted and thus made global for this source file.
-void fn_SetBaseArrayForComp(TSdvector *x_dv)
-{
- if ( !x_dv->flag ) fn_DisplayError(".../cstz.c/ftd_SetBaseArrayForComp(): input vector used for comparison must be given legal values");
- else tz_BaseForComp = x_dv->v;
-}
-int fn_compare(const void *i1, const void *i2)
-{
- // Ascending order according to tz_BaseForComp.
- return ( (tz_BaseForComp[*((int*)i1)]<tz_BaseForComp[*((int*)i2)]) ? -1 : (tz_BaseForComp[*((int*)i1)]>tz_BaseForComp[*((int*)i2)]) ? 1 : 0 );
-}
-int fn_compare2(const void *i1, const void *i2)
-{
- // Descending order according to tz_BaseForComp.
- return ( (tz_BaseForComp[*((int*)i1)]<tz_BaseForComp[*((int*)i2)]) ? 1 : (tz_BaseForComp[*((int*)i1)]>tz_BaseForComp[*((int*)i2)]) ? -1 : 0);
-}
-//======= Quick sort. =======
-static int ftd_CompareDouble(const void *a, const void *b)
-{
- // Ascending order for the series that contains a and b.
- return (*(double *)a < *(double *)b ? -1 : *(double *)a > *(double *)b ? 1 : 0);
-}
-static int ftd_CompareDouble2(const void *a, const void *b)
-{
- // Dscending order for the series that contains a and b.
- return (*(double *)a < *(double *)b ? 1 : *(double *)a > *(double *)b ? -1 : 0);
-}
-//---
-void tz_sort(TSdvector *x_dv, char ad)
-{
- //x_dv will be replaced by the sorted value.
- //Sort x_dv according to the descending or ascending order indicated by ad.
- //ad == "A' or 'a': acending order.
- //ad == 'D' or 'd': descending order.
- if (!x_dv || !x_dv->flag) fn_DisplayError("cstz.c/tz_sort(): input vector x_dv must be (1) created and (2) assigned values");
-
- qsort( (void *)x_dv->v, (size_t)x_dv->n, sizeof(double), ((ad=='A') || (ad=='a')) ? ftd_CompareDouble : ftd_CompareDouble2);
-}
-void tz_sortindex_lf(TSivector *x_iv, TSdvector *base_dv, char ad)
-{
- //???????NOT fully tested yet.
- //x_iv will be replaced by the sorted integer vector.
- //base_dv will not be affected.
- //Sort x_iv according to the descending or ascending order of base_dv.
- //ad == "A' or 'a': acending order.
- //ad == 'D' or 'd': descending order.
- if (!x_iv || !base_dv || !x_iv->flag || !base_dv->flag) fn_DisplayError("cstz.c/tz_sortindex(): input vectors x_iv and base_dv must be (1) created and (2) assigned values");
- if (x_iv->n != base_dv->n) fn_DisplayError("cstz.c/tz_sortindex(): lengths of the two input vectors must be the same");
-
- fn_SetBaseArrayForComp(base_dv);
- qsort( (void *)x_iv->v, (size_t)x_iv->n, sizeof(int), ((ad=='A') || (ad=='a')) ? fn_compare : fn_compare2);
-}
-void tz_sortindex(TSivector *x_iv, TSvoidvector *base_voidv, char ad)
-{
- //???????NOT fully tested yet.
- //Allowing x_iv = base_voidv or sets base_voidv=NULL
- //Sort x_iv according to the descending or ascending order of base_voidv.
- //ad == "A' or 'a': acending order.
- //ad == 'D' or 'd': descending order.
- if (!x_iv || !base_voidv || !x_iv->flag || !base_voidv->flag) fn_DisplayError("cstz.c/tz_sort_int(): input vectors x_iv and base_voidv must be (1) created and (2) assigned values");
- if (x_iv->n != base_voidv->n) fn_DisplayError("cstz.c/tz_sort_int(): lengths of the two input vectors must be the same");
-
- fn_SetBaseArrayForComp((TSdvector *)base_voidv);
- qsort( (void *)x_iv->v, (size_t)x_iv->n, sizeof(int), ((ad=='A') || (ad=='a')) ? fn_compare : fn_compare2);
-}
-//---
-void tz_sort_matrix(TSdmatrix *X_dm, char ad, char rc)
-{
- //Fast method: rc = 'C' (sort each column).
- //Output: X_dm will be replaced by the sorted value.
- // Sort X_dm (1) by columns or rows indicated by rc and (2) according to the descending or ascending order indicated by ad.
- //Inputs:
- // ad == 'A' or 'a': acending order.
- // ad == 'D' or 'd': descending order.
- // rc == 'C' or 'c': sort each column.
- // rc == 'R' or 'r': sort each row.
- int nrows, ncols, _j, begloc;
- TSdvector x_sdv;
- double *X;
- //===
- TSdmatrix *Xtran_dm = NULL;
-
- if (!X_dm || !(X_dm->flag & M_GE)) fn_DisplayError("cstz.c/tz_sort_matrix(): input matrix X_dm must be (1) created and (2) assigned values and (3) regular (M_GE)");
- x_sdv.flag = V_DEF;
-
- if (rc=='C' || rc=='c')
- {
- X = X_dm->M;
- nrows = X_dm->nrows;
- ncols = X_dm->ncols;
- }
- else
- {
- Xtran_dm = tz_TransposeRegular((TSdmatrix *)NULL, X_dm);
- X = Xtran_dm->M;
- nrows = Xtran_dm->nrows;
- ncols = Xtran_dm->ncols;
- }
- x_sdv.n = nrows;
- for (begloc=nrows*(ncols-1), _j=ncols-1; _j>=0; begloc-=nrows, _j--)
- {
- x_sdv.v = X + begloc;
- tz_sort(&x_sdv, ad);
- }
-
- if (rc=='R' || rc=='r')
- {
- tz_TransposeRegular(X_dm, Xtran_dm);
- //===
- DestroyMatrix_lf(Xtran_dm);
- }
-}
-//---
-TSdvector *tz_prctile_matrix(TSdvector *z_dv, const double prc, TSdmatrix *Z_dm, const char rc)
-{
- //Fast method: rc = 'C' (sort each column).
- //Output: %prc percentile (i.e., containing 0% to %prc).
- // z_dv: an n-by-1 vector if rc=='C' or an m-by-1 vector if rc=='R'.
- // If z_dv==NULL, it will be created and has to be destroyed outside this function.
- //Inputs:
- // prc: percent (must be between 0.0 and 1.0 inclusive).
- // X_dm: an m-by-n general matrix.
- // rc == 'C' or 'c': sort each column.
- // rc == 'R' or 'r': sort each row.
- int nrows, ncols, _j, begloc;
- TSdvector x_sdv;
- double *X;
- //===
- TSdmatrix *X_dm = NULL;
- TSdmatrix *Xtran_dm = NULL;
-
- if (!Z_dm || !Z_dm->flag) fn_DisplayError("cstz.c/tz_prctile_matrix(): input matrix Z_dm must be (1) created and (2) assigned values");
- if (prc<0.0 || prc>1.0) fn_DisplayError("cstz.c/tz_prctile_matrix(): percentile mark prc must be between 0.0 and 1.0 inclusive");
- x_sdv.flag = V_DEF;
-
- nrows = Z_dm->nrows;
- ncols = Z_dm->ncols;
- if (!z_dv)
- {
- if (rc=='C' || rc=='c') z_dv = CreateVector_lf(ncols);
- else z_dv = CreateVector_lf(nrows);
- }
- else
- {
- if ((rc=='C' || rc=='c'))
- {
- if (ncols != z_dv->n) fn_DisplayError("cstz.c/tz_prctile_matrix(): z_dv->n must be the same as ncols of X_dm when sorting each column");
- }
- else
- {
- if (nrows != z_dv->n) fn_DisplayError("cstz.c/tz_prctile_matrix(): z_dv->n must be the same as nrows of X_dm when sorting each row");
- }
- }
- X_dm = CreateMatrix_lf(nrows, ncols);
- CopyMatrix0(X_dm, Z_dm);
-
- if (rc=='C' || rc=='c')
- {
- X = X_dm->M;
- nrows = X_dm->nrows;
- ncols = X_dm->ncols;
- }
- else
- {
- Xtran_dm = tz_TransposeRegular((TSdmatrix *)NULL, X_dm);
- X = Xtran_dm->M;
- nrows = Xtran_dm->nrows;
- ncols = Xtran_dm->ncols;
- }
- x_sdv.n = nrows;
- for (begloc=nrows*(ncols-1), _j=ncols-1; _j>=0; begloc-=nrows, _j--)
- {
- x_sdv.v = X + begloc;
- tz_sort(&x_sdv, 'A');
- z_dv->v[_j] = x_sdv.v[(int)floor(prc*(double)nrows)];
- }
- z_dv->flag = V_DEF;
- if (rc=='R' || rc=='r') DestroyMatrix_lf(Xtran_dm);
-
- //===
- DestroyMatrix_lf(X_dm);
-
- return (z_dv);
-}
-//---
-TSdvector *tz_mean_matrix(TSdvector *z_dv, TSdmatrix *Z_dm, const char rc)
-{
- //Fast method: rc = 'C' (mean for each column).
- //Output: %prc percentile (i.e., containing 0% to %prc).
- // z_dv: an n-by-1 vector if rc=='C' or an m-by-1 vector if rc=='R'.
- // If z_dv==NULL, it will be created and has to be destroyed outside this function.
- //Inputs:
- // X_dm: an m-by-n general matrix.
- // rc == 'C' or 'c': mean for each column.
- // rc == 'R' or 'r': mean for each row.
- int nrows, ncols, _j, begloc;
- TSdvector x_sdv;
- double *X;
- //===
- TSdmatrix *X_dm = NULL;
- TSdmatrix *Xtran_dm = NULL;
-
- if (!Z_dm || !Z_dm->flag) fn_DisplayError("cstz.c/tz_mean_matrix(): input matrix Z_dm must be (1) created and (2) assigned values");
- x_sdv.flag = V_DEF;
-
- nrows = Z_dm->nrows;
- ncols = Z_dm->ncols;
- if (!z_dv)
- {
- if (rc=='C' || rc=='c') z_dv = CreateVector_lf(ncols);
- else z_dv = CreateVector_lf(nrows);
- }
- else
- {
- if ((rc=='C' || rc=='c'))
- {
- if (ncols != z_dv->n) fn_DisplayError("cstz.c/tz_mean_matrix(): z_dv->n must be the same as ncols of X_dm when computing mean for each column");
- }
- else
- {
- if (nrows != z_dv->n) fn_DisplayError("cstz.c/tz_mean_matrix(): z_dv->n must be the same as nrows of X_dm when computing mean for each row");
- }
- }
- X_dm = CreateMatrix_lf(nrows, ncols);
- CopyMatrix0(X_dm, Z_dm);
-
- if (rc=='C' || rc=='c')
- {
- X = X_dm->M;
- nrows = X_dm->nrows;
- ncols = X_dm->ncols;
- }
- else
- {
- Xtran_dm = tz_TransposeRegular((TSdmatrix *)NULL, X_dm);
- X = Xtran_dm->M;
- nrows = Xtran_dm->nrows;
- ncols = Xtran_dm->ncols;
- }
- x_sdv.n = nrows;
- for (begloc=nrows*(ncols-1), _j=ncols-1; _j>=0; begloc-=nrows, _j--)
- {
- x_sdv.v = X + begloc;
- z_dv->v[_j] = fn_mean(x_sdv.v, x_sdv.n);
- }
- z_dv->flag = V_DEF;
- if (rc=='R' || rc=='r') DestroyMatrix_lf(Xtran_dm);
-
- //===
- DestroyMatrix_lf(X_dm);
-
- return (z_dv);
-}
-//--------------->>
-
-
-
-//<<---------------
-// WZ normalization on VARs.
-//--------------->>
-void fn_wznormalization(TSdvector *wznmlz_dv, TSdmatrix *A0draw_dm, TSdmatrix *A0peak_dm)
-{
- //Outputs:
- // wznmlz_dv (n-by-1): If negative, the sign of the equation must switch; if positive: no action needs be taken.
- // If NULL as an input, remains NULL.
- // A0draw_dm (n-by-n): replaced by wz-normalized draw.
- //Inputs:
- // wznmlz_dv (n-by-1): if NULL, no output for wznmlz_dv; otherwise, a memory allocated vector.
- // A0draw_dm (n-by-n): a draw of A0.
- // A0peak_dm (n-by-n): reference point to which normalized A0draw_dm is closest.
- int _j, _n,
- errflag = -2;
- double *v;
- TSdmatrix *X_dm = NULL;
- TSdvector *diagX_dv = NULL;
-
- if ( !A0peak_dm ) fn_DisplayError(".../cstz.c/fn_wznormalization(): input matrix for ML estimates must be created (memory allocated) and have legal values");
- //This is a minimum check to prevent crash without error messages. More robust checks are done in BdivA_rgens().
-
- _n = A0peak_dm->nrows;
- X_dm = CreateMatrix_lf(_n, _n);
-
- if ( errflag=BdivA_rgens(X_dm, A0peak_dm, '\\', A0draw_dm) ) {
- printf(".../cstz.c/fn_wznormalization(): errors when calling BdivA_rgens() with error flag %d", errflag);
- exit(EXIT_FAILURE);
- }
-
- if (wznmlz_dv) {
- diagdv(wznmlz_dv, X_dm);
- v = wznmlz_dv->v;
- }
- else {
- diagX_dv = CreateVector_lf(_n);
- diagdv(diagX_dv, X_dm);
- v = diagX_dv->v;
- }
-
-
- for (_j=_n-1; _j>=0; _j--)
- if (v[_j]<0) ScalarTimesColofMatrix((TSdvector *)NULL, -1.0, A0draw_dm, _j);
-
- //=== Destroys memory allocated for this function only.
- DestroyMatrix_lf(X_dm);
- DestroyVector_lf(diagX_dv);
-}
-
-
-
-
-//---------------<<
-// Handling under or over flows with log values.
-//--------------->>
-struct TSveclogsum_tag *CreateVeclogsum(int n)
-{
- struct TSveclogsum_tag *veclogsum_ps = tzMalloc(1, struct TSveclogsum_tag);
-
- //=== Memory allocation and initialization.
- veclogsum_ps->n = n; //Number of sums or the dimension of logofsum.
- veclogsum_ps->N_iv = CreateConstantVector_int(n, 0); //Cumulative. (N_1, ..., N_n).
- veclogsum_ps->logsum_dv = CreateConstantVector_lf(n, -MACHINEINFINITY); //Cumulative. (logofsum_1, ..., logofsum_n).
- veclogsum_ps->logmax_dv = CreateConstantVector_lf(n, -MACHINEINFINITY); //(logmax_1, ..., logmax_n).
-
- return (veclogsum_ps);
-}
-//---
-struct TSveclogsum_tag *DestroyVeclogsum(struct TSveclogsum_tag *veclogsum_ps)
-{
-
- if (veclogsum_ps) {
- DestroyVector_int(veclogsum_ps->N_iv);
- DestroyVector_lf(veclogsum_ps->logsum_dv);
- DestroyVector_lf(veclogsum_ps->logmax_dv);
-
- //===
- free(veclogsum_ps);
- return ((struct TSveclogsum_tag *)NULL);
- }
- else return (veclogsum_ps);
-}
-//===
-//------------------
-//Updating the sum (not divided by n) for the mean and the second moment.
-//------------------
-void UpdateSumFor1st2ndMoments(TSdvector *x1stsum_dv, TSdmatrix *X2ndsum_dm, const TSdvector *xdraw_dv)
-{
- static int ini_indicator = 0;
-
- if (!ini_indicator) {
- //Pass this loop once and no more.
- CopyVector0(x1stsum_dv, xdraw_dv);
- VectorTimesSelf(X2ndsum_dm, xdraw_dv, 1.0, 0.0, 'U');
- ini_indicator = 1;
- }
- else {
- VectorPlusVectorUpdate(x1stsum_dv, xdraw_dv);
- VectorTimesSelf(X2ndsum_dm, xdraw_dv, 1.0, 1.0, 'U');
- }
-}
-//---
-int tz_update_logofsum(double *Y_N_dp, double *y_Nmax_dp, double ynew, int N)
-{
- //Recursive algorithm to update Y_N (=log(sum of x_i)) for i=1, ..., N with the new value ynew = log(x_{N+1}).
- //Returns (1) the updated value Y_{N+1} = log(sum of x_i)) for i=1, ..., N+1;
- // (2) the updated value y_(N+1)max_dp;
- // (3) the integer N+1.
- //See TVBVAR Notes p.81a.
-
- if (*y_Nmax_dp>=ynew) *Y_N_dp = log( exp(*Y_N_dp - *y_Nmax_dp) + exp(ynew - *y_Nmax_dp) ) + *y_Nmax_dp;
- else {
- *y_Nmax_dp = ynew;
- *Y_N_dp = log( exp(*Y_N_dp - ynew) + 1.0 ) + ynew;
- }
-
- return (N+1);
-}
-int fn_update_logofsum(int N, double ynew, double *Y_N_dp, double *y_Nmax_dp)
-{
- //Recursive algorithm to update Y_N (=log(sum of x_i)) for i=1, ..., N with the new value ynew = log(x_{N+1}).
- //Returns (1) the updated value Y_{N+1} = log(sum of x_i)) for i=1, ..., N+1;
- // (2) the updated value y_(N+1)max_dp;
- // (3) the integer N+1.
- //See TVBVAR Notes p.81a.
- //If N=0, then ynew = -infty (no value yet) and thus no value is added to *Y_N_dp.
-
-// if (N>0)
-// {
- if (*y_Nmax_dp>=ynew) *Y_N_dp = log( exp(*Y_N_dp - *y_Nmax_dp) + exp(ynew - *y_Nmax_dp) ) + *y_Nmax_dp;
- else {
- *y_Nmax_dp = ynew;
- *Y_N_dp = log( exp(*Y_N_dp - ynew) + 1.0 ) + ynew;
- }
-// }
-
- return (N+1);
-}
-double fn_replace_logofsumsbt(double *yold, double _a, double ynew, double _b)
-{
- //Outputs:
- // *yold is replaced by log abs(a*xold + b*xnew).
- // 1.0 or -1.0: sign of a*xold + b*xnew.
- //
- //Given yold=log(xold) and ynew=log(xnew), it updates and returns yold = log abs(a*xold + b*xnew).
- //sbt: subtraction or subtract.
- //See TVBVAR Notes p.81a.
- double tmpd;
- //*yold = (*yold > ynew) ? (log( _a + _b*exp(ynew - *yold)) + *yold) : (log( _a*exp(*yold - ynew) + _b) + ynew);
-
- if (*yold > ynew) {
- if ((tmpd=_a + _b*exp(ynew - *yold) ) < 0.0) {
- // printf("WARNING! .../cstz.c/fn_replace_logofsumsbt(): Expression inside log is negative and the function returns the negative sign!\n");
- *yold += log(fabs(tmpd));
- return (-1.0);
- }
- else {
- *yold += log(tmpd);
- return (1.0);
- }
- }
- else {
- if ((tmpd=_a*exp(*yold - ynew) + _b) < 0.0 ) {
- // printf("WARNING! .../cstz.c/fn_replace_logofsumsbt(): Expression inside log is negative and the function returns the negative sign!\n");
- *yold = log(fabs(tmpd)) + ynew;
- return (-1.0);
- }
- else {
- *yold = log(tmpd) + ynew;
- return (1.0);
- }
- }
-}
-
-
-//<<---------------
-// Evaluating the inverse of the chi-square cumulative distribution function.
-//--------------->>
-double fn_chi2inv(double p, double df)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- //Returns x where p = int_{0}^{x} chi2pdf(t, df) dt
- if (df<=0.0) fn_DisplayError("cstz.c/fn_chi2inv(): degrees of freedom df must be greater than 0.0");
-
- if (p<=0.0) return (0.0);
- else if (p>=1.0) return (MACHINEINFINITY);
- else return (imsls_d_chi_squared_inverse_cdf(p, df));
-#elif defined( USE_GSL_LIBRARY )
- if (df<=0.0) fn_DisplayError("cstz.c/fn_chi2inv(): degrees of freedom df must be greater than 0.0");
-
- if (p<=0.0) return (0.0);
- else if (p>=1.0) return (MACHINEINFINITY);
- else
- return gsl_cdf_chisq_Pinv(p,df);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Evaluating the standard normal cumulative distribution function.
-//--------------->>
-double fn_normalcdf(double x)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsls_d_normal_cdf(x));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_cdf_ugaussian_P(x);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Evaluating the inverse of the standard normal cumulative distribution function.
-//--------------->>
-double fn_normalinv(double p)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsls_d_normal_inverse_cdf(p));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_cdf_ugaussian_Pinv(p);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Evaluating the inverse of the beta cumulative distribution function.
-//--------------->>
-double fn_betainv(double p, double _alpha, double _beta)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- //p = int_{0}^{\infty} betapdf(t, _alpha, _beta) dt where betapdf(t,_alpha,_beta) \propt t^{_alpha-1}*(1-t)^(_beta-1}.
- return (imsls_d_beta_inverse_cdf(p, _alpha, _beta));
-#elif defined( USE_GSL_LIBRARY)
- return gsl_cdf_beta_Pinv(p,_alpha,_beta);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Computes log gamma (x) where gamma(n+1) = n! and gamma(x) = int_0^{\infty} e^{-t} t^{x-1} dt.
-//--------------->>
-double fn_gammalog(double x)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsl_d_log_gamma(x));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_sf_lngamma(x);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//<<---------------
-// Computes log beta(x, y) where beta(x, y) = gamma(x)*gamm(y)/gamma(x+y).
-//--------------->>
-double fn_betalog(double x, double y)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsl_d_log_beta(x, y));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_sf_lnbeta(x,y);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-
-//<<---------------
-// Computes log gamma (x) where gamma(n+1) = n! and gamma(x) = int_0^{\infty} e^{-t} t^{x-1} dt.
-//--------------->>
-double gammalog(double x)
-{
-#if defined( IMSL_STATISTICSTOOLBOX )
- return (imsl_d_log_gamma(x));
-#elif defined( USE_GSL_LIBRARY )
- return gsl_sf_lngamma(x);
-#else
- ***No default routine yet;
-#endif
-}
-
-
-//-----------------------------------------------------------------------------------
-//------------------------------ Normal distribution ------------------------------//
-//--- p(x) = (1.0/sqrt(2*pi)*sigma) exp( -(1.0/(2.0*sigma^2.0)) (x-mu)^2.0 )
-//--- for sigma>0.
-//-----------------------------------------------------------------------------------
-#define LOGSQRTOF2PI 9.189385332046727e-001
-double tz_lognormalpdf(double _x, double _m, double _s)
-{
- double xmm = _x-_m;
- if (_s <= 0.0) return (-NEARINFINITY);
- //fn_DisplayError("cstz.c/tz_lognormalpdf(): standard deviation must be positive");
-
- return ( -LOGSQRTOF2PI - log(_s) - (1.0/(2.0*square(_s))) * square(xmm) );
-}
-#undef LOGSQRTOF2PI
-
-//-----------------------------------------------------------------------------------
-//----------------------------- Beta density function -----------------------------//
-//--- p(x) = ( Gamma(a+b)/(Gamma(a)*Gamma(b)) ) x^(a-1) (1-x)^(b-1) for a>0 and b>0.
-//--- E(x) = a/(a+b); var(x) = a*b/( (a+b)^2*(a+b+1) );
-//--- The density is finite if a,b>=1.
-//--- Noninformative density: (1) a=b=1; (2) a=b=0.5; or (3) a=b=0.
-//-----------------------------------------------------------------------------------
-double tz_logbetapdf(double _x, double _a, double _b)
-{
- if ((_x < 0.0) || (_x > 1.0) || (_a <=0.0) || (_b <= 0.0)) return (-NEARINFINITY);
- if ((_x <= 0.0) && (_a != 1.0)) return (-NEARINFINITY);
- //Note that it should be +infinity for a < 1.0. We return -infinity anyway for the purpose of giving zero LH.
- if ((_x >= 1.0) && (_b != 1.0)) return (-NEARINFINITY);
- //Note that it should be +infinity for b < 1.0. We return -infinity anyway for the purpose of giving zero LH.
- //fn_DisplayError("cstz.c/tz_logbetapdf(): x must be (0,1) and a, b must be positive");
-
- if ((_x == 0.0 && _a == 1.0) || (_x == 1.0 && _b == 1.0)) return (-fn_betalog(_a, _b));
- else return ( -fn_betalog(_a, _b) + (_a-1.0)*log(_x) + (_b-1.0)*log(1.0-_x) );
-}
-//-----------------------------------------------------------------------------------
-//---------------------------- Gamma distribution ----------------------------------//
-//--- p(x) = ( b^a/Gamma(a) ) x^(a-1) exp(-bx) for a>0 and b>0.
-//--- where a is shape and b is inverse scale (rate) parameter.
-//--- E(x) = a/b; var(x) = a/b^2;
-//--- Noninformative distribution: a,b -> 0.
-//--- The density function is finite if a >= 1.
-//-----------------------------------------------------------------------------------
-double tz_loggammapdf(double _x, double _a, double _b)
-{
- if (_x < 0.0 || _a <= 0.0 || _b <= 0.0) return (-NEARINFINITY);
- if (_x <= 0.0 && _a != 1.0) return (-NEARINFINITY);
- //Note that it should be +infinity for a < 1.0. We return -infinity anyway for the purpose of giving zero LH.
- //fn_DisplayError("cstz.c/tz_loggammapdf(): x, a, and b must be positive");
-
- if (_x == 0.0 && _a == 1.0) return ( _a*log(_b) - fn_gammalog(_a) );
- else return ( _a*log(_b) - fn_gammalog(_a) + (_a-1.0)*log(_x) - _b*_x );
-}
-//-----------------------------------------------------------------------------------
-//------------------------ Inverse-Gamma distribution ------------------------------//
-//--- p(x) = ( b^a/Gamma(a) ) x^(-a-1) exp(-b/x) for a>0 and b>0.
-//--- where a is shape and b is scale parameter.
-//--- E(x) = b/(a-1) for a>1; var(x) = b^2/( (a-1)^2*(a-2) ) for a>2;
-//--- Noninformative distribution: a,b -> 0.
-//--- How to draw: (1) draw z from Gamma(a,b); (2) let x=1/z.
-//-----------------------------------------------------------------------------------
-double tz_loginversegammapdf(double _x, double _a, double _b)
-{
- //This denisity is always finite.
- //If a < 1.0, 1st moment does not exist,
- // a < 2.0, 2nd moment does not exist,
- // a < 3.0, 3rd moment does not exist,
- // a < 4.0, 4th moment does not exist.
-
- if (_x < 0.0 || _a <= 0.0 || _b <= 0.0) return (-NEARINFINITY);
- //fn_DisplayError("cstz.c/tz_loginversegammapdf(): x, a, and b must be positive");
-
- return ( _a*log(_b) - fn_gammalog(_a) - (_a+1.0)*log(_x) - _b /_x );
-}
-
-
-
-
-
-
-
-//<<---------------
-// P2 algorithm ???????
-//--------------->>
-void psqr(double *q, int *m, double x, const double *p, int n)
-{
- //Outputs:
- // q: n-by-1 vector of
- // m: n-by-1 vector of
- // x: a random draw.
- //------
- //Inputs:
- // p: n-by-1 vector of cumulative cut-off probabilties for the error bands.
- static double qm, dq;
- static int i, dm, dn;
-
- for (i=0; q[i]<=x && i<n; i++) ;
- if (i==0) { q[0]=x; i++; }
- if (i==n) { q[n-1]=x; i--; }
- for (; i<n; i++) m[i]++;
- for (i=1; i<n-1; i++) {
- dq = p[i]*m[n-1];
- if (m[i]+1<=dq && (dm=m[i+1]-m[i])>1) {
- dn = m[i]-m[i-1];
- dq = ((dn+1)*(qm=q[i+1]-q[i])/dm+
- (dm-1)*(q[i]-q[i-1])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- q[i] += dq;
- m[i]++;
- } else
- if (m[i]-1>=dq && (dm=m[i]-m[i-1])>1) {
- dn = m[i+1]-m[i];
- dq = ((dn+1)*(qm=q[i]-q[i-1])/dm+
- (dm-1)*(q[i+1]-q[i])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- q[i] -= dq;
- m[i]--;
- }
- }
-}
-void piksrt(double *arr, int n)
-{
- //Outputs:
- // arr: replaced by new values.
- //Inputs:
- // arr: n-by-1 vector ??????
- int i, j;
- double a;
-
- for (j=1; j<n; j++) {
- a = arr[j];
- for (i=j-1; i>=0 && arr[i]>a; i--)
- arr[i+1] = arr[i];
- arr[i+1]=a;
- }
-}
-
-
-
-//---------------------------- Some high-level VAR functions ---------------------
-void fn_lev2growthanual(TSdmatrix *levgro_dm, const TSdmatrix *levgrominus1_dm, const TSivector *indxlogper_iv)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs:
- // levgro_dm: nfores-by-nvar matrix of annual growth rates (percent) except interest rates and unemployment rate in level.
- //Inputs:
- // levgro_dm: nfores-by-nvar matrix of log levels and, say, interest rates already divided by 100.
- // levgrominus1_dm: qm-by-nvar matrix in the previous year (not necessarily a calendar year).
- // indxlogper_iv: nvar-by-1 array of 1, 2, or 4 for the list of endogenous variables. 1: decimal point with annual rate like the interest rate; 2: decimal point (NOT at annual rate) like the unemployment rate; 4: log level value.
- int ti, vj, qm, nvar, nfores, totrows;
- TSdmatrix *tf_levgroplus_dm = NULL;
-
- if ((qm=levgrominus1_dm->nrows) != 12 && qm != 4) fn_DisplayError("fn_lev2growthanual(): the second input must have 12 or 4 rows for monthly or quarterly data");
- if ((nvar=levgrominus1_dm->ncols) != indxlogper_iv->n || nvar != levgro_dm->ncols) fn_DisplayError("fn_lev2growthanual(): column dimensions and vector dimension of all inputs must be same");
-
- //=== Memory allocation for this function.
- tf_levgroplus_dm = CreateMatrix_lf(qm+(nfores=levgro_dm->nrows), nvar=levgrominus1_dm->ncols);
-
-
- CopySubmatrix0(tf_levgroplus_dm, (TSdmatrix *)levgrominus1_dm, 0, 0, qm, nvar);
- CopySubmatrix(tf_levgroplus_dm, qm, 0, levgro_dm, 0, 0, nfores, nvar);
- totrows = qm + nfores;
- for (vj=nvar-1; vj>=0; vj--) {
- switch (indxlogper_iv->v[vj]) {
- case 4:
- for (ti=nfores-1; ti>=0; ti--)
- levgro_dm->M[mos(ti, vj, nfores)] = 100.0*( exp(tf_levgroplus_dm->M[mos(ti+qm, vj, totrows)] - tf_levgroplus_dm->M[mos(ti, vj, totrows)]) - 1.0 );
- break;
- case 2:
- case 1:
- for (ti=nfores-1; ti>=0; ti--)
- levgro_dm->M[mos(ti, vj, nfores)] *= 100.0;
- break;
- default:
- fn_DisplayError("fn_lev2growthanual(): the input vector, indxlogper_iv, must have the integer values 4, 2, and 1");
- }
- }
-
-
-
- //=== Destroys memory allocated for this function.
- tf_levgroplus_dm = DestroyMatrix_lf(tf_levgroplus_dm);
-}
-
-
-
-//-------------------
-// Generating a counterfactual paths conditional on S_T and specified shocks_t(s_t) for _sm (a switching model).
-//-------------------
-void fn_ctfals_givenshocks_sm(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm,
- const TSivector *S_Tdraw_iv, const TSdcell *Bsdraw_dc, const TSdcell *A0sdrawinv_dc, const TSivector *noshocks_iv)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs: ctflasdrawtran = xprimeminus1*Bsdraw{s} + shocks'*A0sdrawinv{s}.
- // ctfalstran_dm: nvar-by-nfores where nfores (=eloc-bloc+1) is the forecast horizon. Conterfactual paths of nvar variables.
- // xprimeminus1_dv: updated 1-by-ncoef right-hand-side variables at the end of the forecast horizon, ready for the forecasts at the step nfores+1.
- // In the order of [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term].
- //Inputs:
- // xprimeminus1_dv: 1-by-ncoef vector of right-hand-side variables at the beginning of the forecast horizon.
- // bloc: beginning location for the forecast horizon.
- // eloc: end location for the forecast horizon.
- // strshockstran_dm: nvar-by-T. Matrix transpose of unit-variance (time-invariant) structural shocks.
- // S_Tdraw_iv: fss-by-1 or SampleSize-by-1 vector of (s_t|I_T,theta).
- // Bsdraw_dc: nStates cells. For each cell, ncoef-by-nvar reduced-form coefficient matrix.
- // A0sdrawinv_dc: nStates cells. For each cell, nvar-by-nvar inverse of contemporaneous coefficient matrix.
- // noshocks_iv: a (no greater than nvar) vector of base-0 integers indicating the corresponding equations whose shocks are set
- // to zero. Each element of this integer vector must be less than nvar.
- int ti, si, vi;
- int nfores = eloc - bloc + 1,
- nvar = ctfalstran_dm->nrows,
- ncoefminusnvar7const = Bsdraw_dc->C[0]->nrows - nvar - 1;
- TSdvector ctfals_sdv, strshocks_sdv;
- TSivector STnfores_siv; //nfores-by-1 vector of s_t's.
-
- if (nfores < 1) fn_DisplayError("cstz.c/fn_ctfals_givenshocks_sm(): Number of forecast steps must be greater than 0");
- if (eloc > strshockstran_dm->ncols-1) fn_DisplayError("cstz.c/fn_ctfals_givenshocks_sm(): End location in the forecast horizon must be no greater than the sample size");
- if (nvar != strshockstran_dm->nrows) fn_DisplayError("cstz.c/fn_ctfals_givenshocks_sm(): the number of rows of strshockstran_dm must be equal to nvar");
-
-
- //******* WARNING: The operation involves ctfals_sdv.v, strshocks_sdv.v, STnfores_siv.v *******
- //******* throughout this function is dangerous because of pointer movements. *******
- //******* But it gives us efficiency. *******
- ctfals_sdv.n = nvar;
- ctfals_sdv.v = ctfalstran_dm->M; //Points to the beginning of the 1st column of ctfalstran_dm.
- //+
- strshocks_sdv.n = nvar;
- strshocks_sdv.flag = V_DEF;
- strshocks_sdv.v = strshockstran_dm->M + strshockstran_dm->nrows*bloc; //Points to the beginning of the bloc_th column of strshockstran_dm.
- for (vi=noshocks_iv->n-1; vi>=0; vi--)
- strshocks_sdv.v[noshocks_iv->v[vi]] = 0.0; //Set shocks in those equations to be zero.
- //+
- STnfores_siv.n = nfores;
- STnfores_siv.flag = V_DEF;
- STnfores_siv.v = S_Tdraw_iv->v + bloc; //Points to the bloc_th position of S_Tdraw_iv.
-
-
- for (ti=0; ti<nfores; ti++) {
- //Must have a forward recursion.
- VectorTimesMatrix(&ctfals_sdv, xprimeminus1_dv, Bsdraw_dc->C[si=STnfores_siv.v[ti]], 1.0, 0.0, 'N');
- VectorTimesMatrix(&ctfals_sdv, &strshocks_sdv, A0sdrawinv_dc->C[si], 1.0, 1.0, 'N');
- //=== Updates the recursion. The order matters.
- memmove(xprimeminus1_dv->v+nvar, xprimeminus1_dv->v, ncoefminusnvar7const*sizeof(double));
- memcpy(xprimeminus1_dv->v, ctfals_sdv.v, nvar*sizeof(double));
- //+
- if (ti < nfores-1) //This is needed to prevent memory leak at the end when we have strshocks_sdv.v[noshocks_iv->v[vi]] = 0.0.
- {
- ctfals_sdv.v += nvar; //Points to the beginning of the next column of ctfalstran_dm.
- strshocks_sdv.v += nvar; //Points to the beginning of the next column of strshockstran_dm.
- for (vi=noshocks_iv->n-1; vi>=0; vi--)
- strshocks_sdv.v[noshocks_iv->v[vi]] = 0.0; //Set shocks in those equations to be zero.
- }
- }
-
- ctfalstran_dm->flag = M_GE;
-}
-
-
-//-------------------
-// Generating a random sequence of counterfactual (ctfal) paths for _sm (a switching model).
-//-------------------
-void fn_ctfals_sm(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm, const TSivector *Snfores_iv, const TSdcell *Bsdraw_dc, const TSdcell *A0sdrawinv_dc)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs: ctflasdrawtran = xprimeminus1*Bsdraw{s} + shocks'*A0sdrawinv{s}.
- // ctfalstran_dm: nvar-by-nfores where nfores (=eloc-bloc+1) is the forecast horizon. Conterfactual paths of nvar variables.
- // xprimeminus1_dv: updated 1-by-ncoef right-hand-side variables at the end of the forecast horizon, ready for the forecasts at the step nfores+1.
- // In the order of [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term].
- //Inputs:
- // xprimeminus1_dv: 1-by-ncoef vector of right-hand-side variables at the beginning of the forecast horizon.
- // bloc: beginning location for the forecast horizon.
- // eloc: end location for the forecast horizon.
- // strshockstran_dm: nvar-by-T. Matrix transpose of unit-variance (time-invariant) structural shocks.
- // Snfores_iv: nfores-by-1 vector of states where each element is less than nStates.
- // Bsdraw_dc: nStates cells. For each cell, ncoef-by-nvar reduced-form coefficient matrix.
- // A0sdrawinv_dc: nStates cells. For each cell, nvar-by-nvar inverse of contemporaneous coefficient matrix.
- int ti, si;
- int nfores = eloc - bloc + 1,
- nvar = ctfalstran_dm->nrows,
- ncoefminusnvar7const = Bsdraw_dc->C[0]->nrows - nvar - 1;
- TSdvector ctfals_sdv, strshocks_sdv;
-
- if (nfores < 1) fn_DisplayError("cstz.c/fn_ctfals_sm(): Number of forecast steps must be greater than 0");
- if (eloc > strshockstran_dm->ncols-1) fn_DisplayError("cstz.c/fn_ctfals_sm(): End location in the forecast horizon must be no greater than the sample size");
- if (nvar != strshockstran_dm->nrows) fn_DisplayError("cstz.c/fn_ctfals_sm(): the number of rows of strshockstran_dm must be equal to nvar");
-
-
- //******* WARNING: The operation involves ctfals_sdv.v and strshocks_sdv.v throughout this function *******
- //******* is dangerous because of pointer movements. But it gives us efficiency. *******
- ctfals_sdv.n = nvar;
- ctfals_sdv.v = ctfalstran_dm->M; //Points to the beginning of the 1st column of ctfalstran_dm.
- strshocks_sdv.n = nvar;
- strshocks_sdv.flag = V_DEF;
- strshocks_sdv.v = strshockstran_dm->M + strshockstran_dm->nrows*bloc; //Points to the beginning of the bloc_th column of strshockstran_dm.
-
-
- for (ti=0; ti<nfores; ti++) {
- //Must have a forward recursion.
- VectorTimesMatrix(&ctfals_sdv, xprimeminus1_dv, Bsdraw_dc->C[si=Snfores_iv->v[ti]], 1.0, 0.0, 'N');
- VectorTimesMatrix(&ctfals_sdv, &strshocks_sdv, A0sdrawinv_dc->C[si], 1.0, 1.0, 'N');
- //=== Updates the recursion. The order matters.
- memmove(xprimeminus1_dv->v+nvar, xprimeminus1_dv->v, ncoefminusnvar7const*sizeof(double));
- memcpy(xprimeminus1_dv->v, ctfals_sdv.v, nvar*sizeof(double));
- //+
- ctfals_sdv.v += nvar; //Points to the beginning of the next column of ctfalstran_dm.
- strshocks_sdv.v += nvar; //Points to the beginning of the next column of strshockstran_dm.
- }
-
- ctfalstran_dm->flag = M_GE;
-}
-
-//-------------------
-// Generating a random sequence of counterfactual (ctfal) paths with only monetary policy equation changing to a specified regime while holding other equations' regimes the same as historical ones.
-//-------------------
-void fn_ctfals_policyonly(TSdmatrix *ctfalstran_dm, TSdvector *xprimeminus1_dv, const int bloc, const int eloc, const TSdmatrix *strshockstran_dm, const TSivector *S_Tdraw_iv, const int statecon, const int selej, const TSdcell *A0sdraw_dc, const TSdcell *Apsdraw_dc)
-{
- //******* It is the user's responsibility to check memory allocations and dimensions of inputs. *******
- //Outputs: ctflasdrawtran = xprimeminus1*Bsdraw{s} + shocks'*A0sdrawinv{s}.
- // ctfalstran_dm: nvar-by-nfores where nfores (=eloc-bloc+1) is the forecast horizon. Conterfactual paths of nvar variables.
- // xprimeminus1_dv: updated 1-by-ncoef right-hand-side variables at the end of the forecast horizon, ready for the forecasts at the step nfores+1.
- // In the order of [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term].
- //Inputs:
- // xprimeminus1_dv: 1-by-ncoef vector of right-hand-side variables at the beginning of the forecast horizon.
- // bloc: beginning location for the forecast horizon.
- // eloc: end location for the forecast horizon.
- // strshockstran_dm: nvar-by-T. Matrix transpose of unit-variance (time-invariant) structural shocks.
- // S_Tdraw_iv; fss-by-1 or SampleSize-by-1. Stores (s_t|I_T,theta).
- // statecon: the ith state conditioned for counterfactuals (base 0). Must be < nStates.
- // selej: location (base 0) of the selected structural equation (e.g., the monetary policy equation). Only for (1) long-run and short-run responses and (2) counterfactuals with only policy equation at specific state imposed.
- // A0sdraw_dc: nStates cells. For each cell, nvar-by-nvar contemporaneous coefficient matrix.
- // Apsdraw_dc: nStates cells. For each cell, ncoef-by-nvar lagged structural coefficient matrix.
- int ti, si;
- int errflag = -2, //Initialized to be unsuccessful. When 0, successful.
- nfores = eloc - bloc + 1,
- nvar = ctfalstran_dm->nrows,
- ncoef = Apsdraw_dc->C[0]->nrows,
- nStates = Apsdraw_dc->ncells,
- ncoefminusnvar7const = ncoef - nvar - 1;
- TSdvector ctfals_sdv, strshocks_sdv;
- TSivector sact_nfores_siv;
- //
- TSivector *tf_rnstates_iv = CreateConstantVector_int(nStates, nvar), //nStates-by-1: ncoef for each element for *p*_dc or nvar for each elment for *0*_dc.
- *tf_cnstates_iv = CreateConstantVector_int(nStates, nvar); //nStates-by-1: nvar for each element for both *p*_dc and *0*_dc.
- TSdcell *tf_A0sinv_dc = NULL;
- TSdcell *tf_Aps_dc = NULL,
- *tf_Bs_dc = NULL;
-
-
-
- if (nfores < 1) fn_DisplayError("cstz.c/fn_ctfals_policyonly(): Number of forecast steps must be greater than 0");
- if (eloc > strshockstran_dm->ncols-1) fn_DisplayError("cstz.c/fn_ctfals_policyonly(): End location in the forecast horizon must be no greater than the sample size");
- if (nvar != strshockstran_dm->nrows) fn_DisplayError("cstz.c/fn_ctfals_policyonly(): the number of rows of strshockstran_dm must be equal to nvar");
-
-
- //=== Memory allocation.
- tf_A0sinv_dc = CreateCell_lf(tf_rnstates_iv, tf_cnstates_iv); //Note rnstates_iv and cnstates_iv are already assigned right values.
- //+
- for (si=nStates-1; si>=0; si--) tf_rnstates_iv->v[si] = ncoef; //Note rnstates_iv is already assigned right values.
- tf_Aps_dc = CreateCell_lf(tf_rnstates_iv, tf_cnstates_iv);
- tf_Bs_dc = CreateCell_lf(tf_rnstates_iv, tf_cnstates_iv);
-
-
- //******* WARNING: The operation involves ctfals_sdv.v and strshocks_sdv.v throughout this function *******
- //******* is dangerous because of pointer movements. But it gives us efficiency. *******
- ctfals_sdv.n = nvar;
- ctfals_sdv.v = ctfalstran_dm->M; //Points to the beginning of the 1st column of ctfalstran_dm.
- strshocks_sdv.n = nvar;
- strshocks_sdv.flag = V_DEF;
- strshocks_sdv.v = strshockstran_dm->M + strshockstran_dm->nrows*bloc; //Points to the beginning of the bloc_th column of strshockstran_dm.
- //+
- sact_nfores_siv.n = nfores;
- sact_nfores_siv.flag = V_DEF;
- sact_nfores_siv.v = S_Tdraw_iv->v + bloc; //Points to the beginning of the bloc_th element of S_Tdraw_iv.
-
- //=== Sticks the policy equation at the statecon_th state to A0s and A0p.
- for (si=nStates-1; si>=0; si--) {
- CopyMatrix0(tf_A0sinv_dc->C[si], A0sdraw_dc->C[si]); //tf_A0sinv_dc is A0s for a moment.
- CopyMatrix0(tf_Aps_dc->C[si], Apsdraw_dc->C[si]);
- //=== Sticks the specified regime statecon in the counterfactual period.
- CopySubmatrix(tf_A0sinv_dc->C[si], 0, selej, A0sdraw_dc->C[statecon], 0, selej, nvar, 1);
- CopySubmatrix(tf_Aps_dc->C[si], 0, selej, Apsdraw_dc->C[statecon], 0, selej, ncoef, 1);
-
- if ( errflag=BdivA_rgens(tf_Bs_dc->C[si], tf_Aps_dc->C[si], '/', tf_A0sinv_dc->C[si]) ) {
- //tf_A0sinv_dc is at this moment tf_A0s_dc.
- printf(".../cstz.c/fn_ctfals_policyonly(): tf_Bs_dc->C[si] -- errors when calling BdivA_rgens() with error flag %d", errflag);
- exit(EXIT_FAILURE);
- }
- if ( errflag=invrgen(tf_A0sinv_dc->C[si], tf_A0sinv_dc->C[si]) ) {
- printf(".../cstz.c/fn_ctfals_policyonly(): tf_A0sinv_dc->C -- errors when calling invrgen() with error flag %d", errflag);
- exit(EXIT_FAILURE);
- }
- }
-
- for (ti=0; ti<nfores; ti++) {
- //Must have a forward recursion.
- VectorTimesMatrix(&ctfals_sdv, xprimeminus1_dv, tf_Bs_dc->C[si=sact_nfores_siv.v[ti]], 1.0, 0.0, 'N');
- VectorTimesMatrix(&ctfals_sdv, &strshocks_sdv, tf_A0sinv_dc->C[si], 1.0, 1.0, 'N');
- //=== Updates the recursion. The order matters.
- memmove(xprimeminus1_dv->v+nvar, xprimeminus1_dv->v, ncoefminusnvar7const*sizeof(double));
- memcpy(xprimeminus1_dv->v, ctfals_sdv.v, nvar*sizeof(double));
- //+
- ctfals_sdv.v += nvar; //Points to the beginning of the next column of ctfalstran_dm.
- strshocks_sdv.v += nvar; //Points to the beginning of the next column of strshockstran_dm.
- }
-
- ctfalstran_dm->flag = M_GE;
-
- //=== Destroys memory allocated for this function.
- tf_rnstates_iv = DestroyVector_int(tf_rnstates_iv);
- tf_cnstates_iv = DestroyVector_int(tf_cnstates_iv);
- tf_A0sinv_dc = DestroyCell_lf(tf_A0sinv_dc);
- tf_Aps_dc = DestroyCell_lf(tf_Aps_dc);
- tf_Bs_dc = DestroyCell_lf(tf_Bs_dc);
-}
-
-
-#if defined (INTELCMATHLIBRARY)
-void fn_impulse(TSdmatrix *imftran_dm, const TSdmatrix *Bh_dm, const TSdmatrix *swishtran_dm, const int nlags, const int imsteps)
-{
- //Outputs (memory allocated already):
- // imftran_dm: nvar^2-by-imsteps where imf_dm (imsteps-by-nvar^2) is in the same format as in RATS.
- // Rows: nvar responses to the 1st shock, ..., nvar responses to the last shock.
- // Columns: steps of impulse responses.
- //Inputs:
- // Bh_dm: ldbh-by-nvar reduced-form coefficient matrix (where ldbh is the leading dimension of Bh_dm and must be at least nvar*nlags) of the form:
- // Y(T*nvar) = X*Bh_dm + U, X: T*ldbh(ldbh may include all exogenous terms). Note that columns corresponding equations.
- // Columns of Bh_dm: nvar variables for the 1st lag, ..., nvariables for the last lag + (possible exogenous terms) + const = ldbh.
- // swishtran_dm: transponse of nvar-by-nvar inv(A0) in the structural model y(t)A0 = e(t).
- // nlags: lag length (number of lags);
- // imsteps: steps for impulse responses.
-
- int i, j,
- nvar, nvar2, ldbh, jmax;
- double *Bh, *imftran;
-
- if (!imftran_dm) fn_DisplayError(".../fn_impulse(): the output impulse matrix imftran_dm must be created (memory-allocated)");
- else if (!Bh_dm || !swishtran_dm) fn_DisplayError(".../fn_impulse(): the input matrices Bh_dm and swich_dm must be created (memory-allocated)");
- else if (!Bh_dm->flag || !swishtran_dm->flag) fn_DisplayError(".../fn_impulse(): the input matrices Bh_dm and swich_dm must be given legal values");
- else if (nlags < 1) fn_DisplayError(".../fn_impulse(): the lag length, nlags, must be equal to or greater than 1");
- else if (imsteps <1) fn_DisplayError(".../fn_impulse(): the number of steps for impulse responses, imsteps, must be must be equal to or greater than 1");
- else if ((nvar = swishtran_dm->nrows) != swishtran_dm->ncols ) fn_DisplayError(".../fn_impulse(): the input matrix, swishtran_dm, must be square");
- else if (nvar != Bh_dm->ncols) fn_DisplayError(".../fn_impulse(): the number of columns in Bh_dm must equal to the number of equations or endogenous variables");
- else if (square(nvar) != imftran_dm->nrows || imsteps != imftran_dm->ncols) fn_DisplayError(".../fn_impulse(): Dimension of impulse matrix input matrix imftran_dm is incompatible with other input matrices or with the number of steps");
-
- //if ( !(imftran_dm->flag & M_CN) && imftran_dm[0] !=0.0 ) InitializeConstantMatrix_lf(imftran_dm, 0.0);
- InitializeConstantMatrix_lf(imftran_dm, 0.0); //Cumulative. Always initialize it to zero.
-
-
- nvar2 = square(nvar);
- Bh = Bh_dm->M;
- imftran = imftran_dm->M;
-
-
- if ((ldbh=Bh_dm->nrows) < nvar*nlags) fn_DisplayError("Input matrix Bh_dm must have at least nvar*nlags rows");
- cblas_dcopy(nvar2, swishtran_dm->M, 1, imftran, 1);
- for (i=1; i<imsteps; i++) {
- jmax = i<nlags?i:nlags;
- for (j=0; j<jmax; j++) {
- cblas_dgemm(CblasColMajor, CblasTrans, CblasNoTrans, nvar, nvar, nvar,
- 1.0, &Bh[j*nvar], ldbh, &imftran[(i-j-1)*nvar2], nvar,
- 1.0, &imftran[i*nvar2], nvar);
- }
- }
-
-
- imftran_dm->flag = M_GE;
-}
-#else
-//No default routine yet. 7 Oct 2003
-#endif
-
-
-TSdmatrix *tz_impulse2levels(TSdmatrix *imflev_dm, TSdmatrix *imf_dm, TSivector *vlist2levels_iv)
-{
- //Converting imf_dm to the level impulse responses imflev_dm according to vlist2levels_iv.
- //If imflev_dm = imf_dm, then the value of imf_dm will be replaced by the new value.
- //
- //imf_dm; nsteps-by-nvar^2 where
- // rows: steps of impulse responses;
- // columns: nvar responses to the 1st shock, ..., nvar responses to the last shock.
- //vlist2levels_iv; must be in ascending order. A list of base-0 variables to be converted to levels. Example: [0 1 3]
- int _i, _j, _t;
- int largestvar; //last variable corresponding to the largest number.
- int _n, nsq, imsteps;
- TSdvector imf_sdv;
- TSdvector imflev_sdv;
-
- if (!imf_dm || !imf_dm->flag)
- fn_DisplayError(".../cstz.c/tz_impulse2levels(): the input matrix imf_dm must be (1) allocated memory and (2) given legal values");
-
- if (!imflev_dm) {
- imflev_dm = CreateMatrix_lf(imf_dm->nrows, imf_dm->ncols);
- imflev_dm->flag = M_GE; //Legal values will be given below.
- }
- else if (imflev_dm != imf_dm )
- if ( (imflev_dm->nrows != imf_dm->nrows) || (imflev_dm->ncols != imf_dm->ncols))
- fn_DisplayError(".../cstz.c/tz_impulse2levels(): dimensions of the input matrix imf_dm and the output matrix imflev_dm must match exactly");
- else imflev_dm->flag = M_GE; //Legal values will be given below.
-
- largestvar = vlist2levels_iv->v[vlist2levels_iv->n-1]+1;
- _n = (int)floor(sqrt(imf_dm->ncols)+0.5);
- nsq = imf_dm->ncols;
- if ( square(largestvar) > nsq)
- fn_DisplayError(".../cstz.c/tz_impulse2levels(): the last specified variable in vlist2levels_iv is out of the range of impulse responses");
-
-
- imflev_sdv.n = imf_sdv.n = imf_dm->nrows;
- imflev_sdv.flag = imf_sdv.flag = V_DEF; //Legal values will be given below.
- imsteps = imf_dm->nrows;
- for (_i=vlist2levels_iv->n-1; _i>=0; _i--)
- for (_j=vlist2levels_iv->v[_i]; _j<nsq; _j += _n) {
- imflev_sdv.v = imflev_dm->M + _j*imsteps;
- imf_sdv.v = imf_dm->M + _j*imsteps;
- imflev_sdv.v[0] = imf_sdv.v[0];
- for (_t=1; _t<imsteps; _t++)
- imflev_sdv.v[_t] = imflev_sdv.v[_t-1] + imf_sdv.v[_t];
- }
-
- return (imflev_dm);
-}
-
-
-void DynamicResponsesForStructuralEquation(TSdmatrix *Resps_dm, const int loclv, const int nlags, const TSdvector *a0p_dv)
-{
- //Outputs:
- // Resps_dm: k-by-nvar where k responses of the loclv_th variable to the _ith variable for _i=1:nvar.
- // The loclv_th column of Resps_dm is meaningless but as a debug check should be close to -1 for the kth responses as k->\infty.
- //Inputs:
- // loclv: loction of the left-hand variable either in difference (growth) or level.
- // nlags: number of lags.
- // a0p_dv: m-by-1 vector of [a0 a+] either in difference (growth) or level for the strctural equation considered where m>= (nlags+1)*nvar because m may
- // include the constant term. Note a0 is on the left hand side of the equation and a+ is on the right hand side of the equation.
- int vi, li;
- int nvar, K;
- double tmpdsum, c0, a0inv;
- TSdvector resps_sdv; //k-by-1.
- //----
- TSdvector *a1_dv = NULL; //nlags-by-1.
-
- if (!Resps_dm || !a0p_dv || !a0p_dv->flag) fn_DisplayError(".../cstz/DynamicResponsesForStructuralEquation(): (1) both input vector and output matrix must be allocated memory; (2) the input vector must have legal values");
- if (a0p_dv->n < (nlags+1)*(nvar=Resps_dm->ncols)) fn_DisplayError(".../cstz/DynamicResponsesForStructuralEquation(): the length of the input vector must be at least (nvar+1)*nlags");
- if (loclv >= nvar || loclv < 0) fn_DisplayError(".../cstz/DynamicResponsesForStructuralEquation(): the location for the left-hand-side variable must be between 0 and number of variables-1, inclusive");
- a1_dv = CreateVector_lf(nlags);
- a1_dv->flag = V_DEF; //which will be given legal values below.
-
- resps_sdv.n = K = Resps_dm->nrows;
- resps_sdv.flag = V_UNDEF;
-
- a0inv = 1.0/a0p_dv->v[loclv];
- for (li=nlags; li>=1; li--) //Note li=1; li<=nlags, NOT li=0; li<nlags.
- a1_dv->v[li-1] = a0p_dv->v[loclv+nvar*li]*a0inv;
- //Constructing the lagged coefficients for the loclv_th variable.
- for (vi=nvar-1; vi>=0; vi--) {
- //=== Constructing the constant term.
- tmpdsum = - a0p_dv->v[vi]; //Assigned to -a_0.
- for (li=nlags; li>=1; li--) //Note li=1; li<=nlags, NOT li=0; li<nlags.
- tmpdsum += a0p_dv->v[vi+nvar*li];
- c0 = tmpdsum*a0inv;
- //Done with t* array.
-
- //=== Getting dynamic responses to the vi_th variable.
- resps_sdv.v = Resps_dm->M + vi*K;
- DynamicResponsesAR(&resps_sdv, c0, a1_dv);
- }
- Resps_dm->flag = M_GE;
-
-
- //=== Destroys memory allocated for this function only.
- a1_dv = DestroyVector_lf(a1_dv);
-}
-
-
-
-void DynamicResponsesAR(TSdvector *resps_dv, const double c0, const TSdvector *a1_dv)
-{
- //Outputs:
- // resps_dv: k-by-1 where k responses r_{t+1} to r_{t+k} are computed from r_{t+1} = c0 + a1'*[r_t; ...; r_{t-nlags+1}].
- //Inputs:
- // c0: constant term.
- // a1_dv: nlags-by-1 vector of coefficients in the AR process.
- int ti;
- int k, nlags;
- double *rv;
- TSdvector *rlags_dv = NULL;
-
- if (!resps_dv || !a1_dv || !a1_dv->flag) fn_DisplayError(".../cstz/DynamicResponsesAR(): (1) both input and output vectors must be allocated memory; (2) the input vector must have legal values");
- rlags_dv = CreateConstantVector_lf(nlags=a1_dv->n, 0.0);
-
- rv = resps_dv->v;
- k = resps_dv->n;
-
- *(rlags_dv->v) = *rv = c0;
-
-
- for (ti=1; ti<k; ti++) {
- //Note ti=1, NOT ti=0.
- rv[ti] = c0 + VectorDotVector((TSdvector *)a1_dv, rlags_dv);
- //=== Updating rlags_dv.
- memmove(rlags_dv->v+1, rlags_dv->v, (nlags-1)*sizeof(double));
- *(rlags_dv->v) = rv[ti];
- }
- resps_dv->flag = V_DEF;
-
- //=== Destroys memory allocated for this function only.
- rlags_dv = DestroyVector_lf(rlags_dv);
-}
-
-
-
-
-
-//---------------------------- Some regular vector or matrix operations ---------------------
-double MinVector_lf(TSdvector *x_dv) {
- //Input: no change for x_dv in this function.
- int _i, n;
- double minvalue;
- double *v;
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/MinVector_lf(): Input vector x_dv must be (1) allocated memory and (2) assigned legal values");
- n = x_dv->n;
- v = x_dv->v;
-
- minvalue = v[0];
- for (_i=n-1; _i>0; _i--)
- if (v[_i]<minvalue) minvalue = v[_i];
-
- return( minvalue );
-}
-
-TSdvector *ConvertVector2exp(TSdvector *y_dv, TSdvector *x_dv)
-{
- //y=exp(x): output vector. If NULL, y will be created and memory-allocated.
- //x: input vector.
- TSdvector *z_dv=NULL;
- #if defined (INTELCMATHLIBRARY)
- int _i;
- #endif
-
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/ConvertVector2exp(): input vector must be (1) created and (2) given legal values");
-
- #if !defined (INTELCMATHLIBRARY)
-
- if (!y_dv)
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdExp(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- return (z_dv);
- }
- else if (x_dv!=y_dv)
- {
- vdExp(x_dv->n, x_dv->v, y_dv->v);
- y_dv->flag = V_DEF;
- return (y_dv);
- }
- else
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdExp(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- CopyVector0(x_dv, z_dv);
- DestroyVector_lf(z_dv);
- return (x_dv);
- }
-
- #else
-
- if (!y_dv) z_dv = CreateVector_lf(x_dv->n);
- else z_dv = y_dv;
- for (_i=x_dv->n-1; _i>=0; _i--) z_dv->v[_i] = exp(x_dv->v[_i]);
- z_dv->flag = V_DEF;
- return (z_dv);
-
- #endif
-}
-//---
-TSdvector *ConvertVector2log(TSdvector *y_dv, TSdvector *x_dv)
-{
- //y=log(x): output vector. If NULL, y will be created and memory-allocated.
- //x: input vector.
- TSdvector *z_dv=NULL;
- #if defined (INTELCMATHLIBRARY)
- int _i;
- #endif
-
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/ConvertVector2exp(): input vector must be (1) created and (2) given legal values");
-
- #if !defined (INTELCMATHLIBRARY)
-
- if (!y_dv)
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdLn(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- return (z_dv);
- }
- else if (x_dv!=y_dv)
- {
- vdLn(x_dv->n, x_dv->v, y_dv->v);
- y_dv->flag = V_DEF;
- return (y_dv);
- }
- else
- {
- z_dv = CreateVector_lf(x_dv->n);
- vdLn(x_dv->n, x_dv->v, z_dv->v);
- z_dv->flag = V_DEF;
- CopyVector0(x_dv, z_dv);
- DestroyVector_lf(z_dv);
- return (x_dv);
- }
-
- #else
-
- if (!y_dv) z_dv = CreateVector_lf(x_dv->n);
- else z_dv = y_dv;
- for (_i=x_dv->n-1; _i>=0; _i--) z_dv->v[_i] = log(x_dv->v[_i]);
- z_dv->flag = V_DEF;
- return (z_dv);
-
- #endif
-}
-
-double tz_normofvector(TSdvector *x_dv, double p)
-{
- double norm = 0.0;
- int ki, _n;
- double *v;
-
- if ( !x_dv || !x_dv->flag ) fn_DisplayError("/cstz.c/tz_normofvector(): Input x_dv must have (1) memory and (2) legal values");
- if (p<1.0) fn_DisplayError("/cstz.c/tz_normofvector(): The input p must be no less than 1.0");
- _n = x_dv->n;
- v = x_dv->v;
-
- if (p==2.0)
- {
- for (ki=_n-1; ki>=0; ki--) norm += v[ki]*v[ki];
- norm = sqrt(norm);
- }
- else
- {
- printf("\n/cstz.c/tz_normofvector(): HELLO I TRICK YOU and YOU MUST DO fabs(p-2.0)<MICHINEZERO!!!!!!\n"); //????
- if (p==1.0)
- for (ki=_n-1; ki>=0; ki--) norm += fabs(v[ki]);
- else
- {
- for (ki=_n-1; ki>=0; ki--) norm += pow(fabs(v[ki]), p);
- norm = pow(norm, 1.0/p);
- }
- }
-
- return (norm);
-}
-
-
-
-//---------------------------- Not used often ---------------------
-void fn_cumsum(double **aos_v, int *aods_v, double *v, int d_v) {
- // Compute a cumulative sum of a vector.
- //
- // v: an n-by-1 vector.
- // d_v: n -- size of the vector v to be used for a cumulative sum.
- // aos_v: address of the pointer to the n-by-1 vector s_v.
- // aods_v: address of the size of the dimension of s_v.
- //----------
- // *aos_v: An n-by-1 vector of cumulative sum s_v.
- // *aods_v: n -- size of the dimension for s_v.
-
- int ki;
-
- *aos_v = tzMalloc(d_v, double);
- (*aods_v) = d_v; // n for the n-by-1 vector s_v.
- *(*aos_v) = *v;
- if (d_v>1) {
- for (ki=1; ki<d_v; ki++) (*aos_v)[ki] = (*aos_v)[ki-1] + v[ki];
- }
-}
-
-
-
-/**
-void fn_ergodp(double **aop, int *aod, mxArray *cp) {
- // Compute the ergodic probabilities. See Hamilton p.681.
- //
- // cp: n-by-n Markovian transition matrix.
- // aop: address of the pointer to the n-by-1 vector p.
- // aod: address of the size of the dimension of p.
- //----------
- // *aop: n-by-1 vector of ergodic probabilities p. @@Must be freed outside this function.@@
- // *aod: n -- size of the dimension for p (automatically supplied within this function).
-
- mxArray *gpim=NULL, *gpid=NULL; // m: n-by-n eigvector matrix; d: n-by-n eigvalue diagonal.
- double *gpim_p, *gpid_p; // _p: a pointer to the corresponding mxArray whose name occurs before _p.
- //------- Note the following two lines will cause Matlab or C to crash because gpim has not been initialized so it points to garbage.
- // double *gpim_p = mxGetPr(gpim);
- // double *gpid_p = mxGetPr(gpid);
- int eigmaxindx, // Index of the column corresponding to the max eigenvalue.
- n, ki;
- double gpisum=0.0,
- eigmax, tmpd0;
-
- n=mxGetM(cp); // Get n for the n-by-n mxArray cp.
- (*aod)=n;
-
- *aop = tzMalloc(n, double);
-
- gpim = mlfEig(&gpid,cp,NULL,NULL);
- gpim_p = mxGetPr(gpim);
- gpid_p = mxGetPr(gpid);
-
- eigmax = *gpid_p;
- eigmaxindx = 0;
- if (n>1) {
- for (ki=1;ki<n;ki++) {
- if (gpid_p[n*ki+ki] > eigmax) {
- eigmax=gpid_p[n*ki+ki];
- eigmaxindx=ki;
- } // Note that n*ki+ki refers to a diagonal location in the n-by-n matrix.
- }
- }
- for (ki=0;ki<n;ki++) {
- gpisum += gpim_p[n*eigmaxindx+ki]; // Sum over the eigmaxindx_th column.
- }
- tmpd0 = 1.0/gpisum;
- for (ki=0;ki<n;ki++) {
- (*aop)[ki] = gpim_p[n*eigmaxindx+ki]*tmpd0; // Normalized eigmaxindx_th column as ergodic probabilities.
- }
-
- mxDestroyArray(gpim); // ????? free(gpim_p)
- mxDestroyArray(gpid);
-}
-/**/
-
-
-
-//---------- Must keep the following code forever. ---------------
-/**
-TSdp2m5 *CreateP2m5(const double p)
-{
- TSdp2m5 *x_dp2m5 = tzMalloc(1, TSdp2m5);
-
- if (p<=0.0 && p>=1.0) fn_DisplayError(".../cstz.c/CreateP2m5_lf(): input probability p must be between 0.0 and 1.0");
-
- x_dp2m5->cnt = 0;
- x_dp2m5->ndeg = 0;
- x_dp2m5->p = tzMalloc(5, double);
- x_dp2m5->q = tzMalloc(5, double);
- x_dp2m5->m = tzMalloc(5, int);
-
- x_dp2m5->p[0] = 0.00;
- x_dp2m5->p[1] = 0.5*p;
- x_dp2m5->p[2] = p;
- x_dp2m5->p[3] = 0.5*(1.0+p);
- x_dp2m5->p[4] = 1.00;
-
- return (x_dp2m5);
-}
-TSdp2m5 *DestroyP2m5(TSdp2m5 *x_dp2m5)
-{
- if (x_dp2m5) {
- free(x_dp2m5->m);
- free(x_dp2m5->q);
- free(x_dp2m5->p);
-
- free(x_dp2m5);
- return ((TSdp2m5 *)NULL);
- }
- else return (x_dp2m5);
-}
-TSdvectorp2m5 *CreateVectorP2m5(const int n, const double p)
-{
- int _i;
- //
- TSdvectorp2m5 *x_dvp2m5 = tzMalloc(1, TSdvectorp2m5);
-
- x_dvp2m5->n = n;
- x_dvp2m5->v = tzMalloc(n, TSdp2m5 *);
- for (_i=n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = CreateP2m5(p);
-
- return (x_dvp2m5);
-}
-TSdvectorp2m5 *DestroyVectorP2m5(TSdvectorp2m5 *x_dvp2m5)
-{
- int _i;
-
- if (x_dvp2m5) {
- for (_i=x_dvp2m5->n-1; _i>=0; _i--)
- x_dvp2m5->v[_i] = DestroyP2m5(x_dvp2m5->v[_i]);
- free(x_dvp2m5->v);
-
- free(x_dvp2m5);
- return ((TSdvectorp2m5 *)NULL);
- }
- return (x_dvp2m5);
-}
-TSdmatrixp2m5 *CreateMatrixP2m5(const int nrows, const int ncols, const double p)
-{
- int _i;
- //
- TSdmatrixp2m5 *X_dmp2m5 = tzMalloc(1, TSdmatrixp2m5);
-
- X_dmp2m5->nrows = nrows;
- X_dmp2m5->ncols = ncols;
- X_dmp2m5->M = tzMalloc(nrows*ncols, TSdp2m5 *);
- for (_i=nrows*ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = CreateP2m5(p);
-
- return (X_dmp2m5);
-}
-TSdmatrixp2m5 *DestroyMatrixP2m5(TSdmatrixp2m5 *X_dmp2m5)
-{
- int _i;
-
- if (X_dmp2m5) {
- for (_i=X_dmp2m5->nrows*X_dmp2m5->ncols-1; _i>=0; _i--)
- X_dmp2m5->M[_i] = DestroyP2m5(X_dmp2m5->M[_i]);
- free(X_dmp2m5->M);
-
- free(X_dmp2m5);
- return ((TSdmatrixp2m5 *)NULL);
- }
- else return (X_dmp2m5);
-}
-TSdcellp2m5 *CreateCellP2m5(const TSivector *rows_iv, const TSivector *cols_iv, const double p)
-{
- int _i;
- int ncells;
- //
- TSdcellp2m5 *X_dcp2m5 = tzMalloc(1, TSdcellp2m5);
-
-
- if (!rows_iv || !cols_iv || !rows_iv->flag || !cols_iv->flag) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Input row and column vectors must be (1) created and (2) assigned legal values");
- if ((ncells=rows_iv->n) != cols_iv->n) fn_DisplayError(".../cstz.c/CreateCellP2m5(): Length of rows_iv must be the same as that of cols_iv");
-
-
- X_dcp2m5->ncells = ncells;
- X_dcp2m5->C = tzMalloc(ncells, TSdmatrixp2m5 *);
- for (_i=ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = CreateMatrixP2m5(rows_iv->v[_i], cols_iv->v[_i], p);
-
- return (X_dcp2m5);
-}
-TSdcellp2m5 *DestroyCellP2m5(TSdcellp2m5 *X_dcp2m5)
-{
- int _i;
-
- if (X_dcp2m5) {
- for (_i=X_dcp2m5->ncells-1; _i>=0; _i--)
- X_dcp2m5->C[_i] = DestroyMatrixP2m5(X_dcp2m5->C[_i]);
- free(X_dcp2m5->C);
-
- free(X_dcp2m5);
- return ((TSdcellp2m5 *)NULL);
- }
- else return (X_dcp2m5);
-}
-
-
-#define P2REALBOUND DBL_MAX
-int P2m5Update(TSdp2m5 *x_dp2m5, const double newval)
-{
- //5-marker P2 algorithm.
- //quantiles q[0] to q[4] correspond to 5-marker probabilities {0.0, p/5, p, (1+p)/5, 1.0}.
- //Outputs:
- // x_dp2m5->q, the markers x_dp2m5->m, is updated and only x_dp2m5->q[2] is used.
- //Inputs:
- // newval: new random number.
- //
- // January 2003.
- int k, j;
- double a;
- double qm, dq;
- int i, dm, dn;
-
-
- if (!x_dp2m5) fn_DisplayError(".../cstz.c/P2m5Update(): x_dp2m5 must be created");
-
- //if (isgreater(newval, -P2REALBOUND) && isless(newval, P2REALBOUND)) {
- if (isfinite(newval) && newval > -P2REALBOUND && newval < P2REALBOUND) {
- if (++x_dp2m5->cnt > 5) {
- //Updating the quantiles and markers.
- for (i=0; x_dp2m5->q[i]<=newval && i<5; i++) ;
- if (i==0) { x_dp2m5->q[0]=newval; i++; }
- if (i==5) { x_dp2m5->q[4]=newval; i--; }
- for (; i<5; i++) x_dp2m5->m[i]++;
- for (i=1; i<4; i++) {
- dq = x_dp2m5->p[i]*x_dp2m5->m[4];
- if (x_dp2m5->m[i]+1<=dq && (dm=x_dp2m5->m[i+1]-x_dp2m5->m[i])>1) {
- dn = x_dp2m5->m[i]-x_dp2m5->m[i-1];
- dq = ((dn+1)*(qm=x_dp2m5->q[i+1]-x_dp2m5->q[i])/dm+
- (dm-1)*(x_dp2m5->q[i]-x_dp2m5->q[i-1])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] += dq;
- x_dp2m5->m[i]++;
- } else
- if (x_dp2m5->m[i]-1>=dq && (dm=x_dp2m5->m[i]-x_dp2m5->m[i-1])>1) {
- dn = x_dp2m5->m[i+1]-x_dp2m5->m[i];
- dq = ((dn+1)*(qm=x_dp2m5->q[i]-x_dp2m5->q[i-1])/dm+
- (dm-1)*(x_dp2m5->q[i+1]-x_dp2m5->q[i])/dn)/(dm+dn);
- if (qm<dq) dq = qm/dm;
- x_dp2m5->q[i] -= dq;
- x_dp2m5->m[i]--;
- }
- }
- }
- else if (x_dp2m5->cnt < 5) {
- //Fills the initial values.
- x_dp2m5->q[x_dp2m5->cnt-1] = newval;
- x_dp2m5->m[x_dp2m5->cnt-1] = x_dp2m5->cnt-1;
- }
- else {
- //=== Last filling of initial values.
- x_dp2m5->q[4] = newval;
- x_dp2m5->m[4] = 4;
- //=== P2 algorithm begins with reshuffling quantiles and makers.
- for (j=1; j<5; j++) {
- a = x_dp2m5->q[j];
- for (k=j-1; k>=0 && x_dp2m5->q[k]>a; k--)
- x_dp2m5->q[k+1] = x_dp2m5->q[k];
- x_dp2m5->q[k+1]=a;
- }
- }
- }
- else ++x_dp2m5->ndeg; //Throwing away the draws to treat exceptions.
-
- return (x_dp2m5->cnt);
-}
-#undef P2REALBOUND
-
-void P2m5MatrixUpdate(TSdmatrixp2m5 *X_dmp2m5, const TSdmatrix *newval_dm)
-{
- int _i;
- int nrows, ncols;
-
- if (!X_dmp2m5 || !newval_dm || !newval_dm->flag) fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): (1) Matrix struct X_dmp2m5 must be created and (2) input new value matrix must be crated and given legal values");
- if ((nrows=newval_dm->nrows) != X_dmp2m5->nrows || (ncols=newval_dm->ncols) != X_dmp2m5->ncols)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of rows and colums in X_dmp2m5 must match those of newval_dm");
-
- for (_i=nrows*ncols-1; _i>=0; _i--)
- P2m5Update(X_dmp2m5->M[_i], newval_dm->M[_i]);
-}
-
-void P2m5CellUpdate(TSdcellp2m5 *X_dcp2m5, const TSdcell *newval_dc)
-{
- int _i;
- int ncells;
-
- if (!X_dcp2m5 || !newval_dc) fn_DisplayError(".../cstz.c/P2m5CellUpdate(): (1) Cell struct X_dcp2m5 must be created and (2) input new value cell must be crated and given legal values");
- if ((ncells=newval_dc->ncells) != X_dcp2m5->ncells)
- fn_DisplayError(".../cstz.c/P2m5MatrixUpdate(): Number of cells in X_dcp2m5 must match that of newval_dc");
-
- for (_i=ncells-1-1; _i>=0; _i--)
- P2m5MatrixUpdate(X_dcp2m5->C[_i], newval_dc->C[_i]);
-}
-/**/
diff --git a/matlab/swz/c-code/utilities/TZCcode/fn_filesetup.c b/matlab/swz/c-code/utilities/TZCcode/fn_filesetup.c
deleted file mode 100644
index f75c865663be4beee65409b85ed646116a7fb90f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/fn_filesetup.c
+++ /dev/null
@@ -1,849 +0,0 @@
-/***********
- * Reads the input file name and output file names specified by the user from the command line with automatic default to
- * both input an output files.
-***********/
-
-#include "fn_filesetup.h"
-
-
-//-----------------
-// For command line.
-// Finds /ch in the command line. If found, returns the args location
-// indexed by int and zero otherwise.
-//-----------------
-int fn_ParseCommandLine(int n_arg, char **args, char ch) {
- int i;
- for (i=1; i<n_arg; i++)
- if ((args[i][0] == '/') && (args[i][1] == ch)) return i;
- return 0;
-}
-
-
-//-----------------
-// For command line.
-// Finds /ch in the command line. If found returns a pointer
-// to the string trailing /ch. If /ch is not found or there is
-// no trailing string or the trailing string is another argument,
-// then default_return is returned. No memory is allocated and
-// the calling routine should not free the returned pointer.
-//-----------------
-char *fn_ParseCommandLine_String(int n_arg, char **args, char ch, char *default_return) {
- int i=fn_ParseCommandLine(n_arg,args,ch);
- if (i > 0)
- if (strlen(args[i]) > 2) return args[i]+2;
- // In case the user forgot typing a space between /ch and string following it, still returns a pointer to the string folloing /ch.
- else if ((i+1 < n_arg) && (args[i+1][0] != '/')) return args[i+1];
- // Returns a pointer to the string that does NOT begin with / and there is a whitespace between /ch and the string.
- return default_return;
-}
-
-
-//-----------------
-// For command line.
-// Finds /ch in the command line. If found returns the integer
-// value of the string trailing /ch (e.g, the integer value is
-// sample size or normalization index. If /ch is not found or there
-// is no trailing string or the trailing string is another argument,
-// then the default_return value is returned.
-//-----------------
-int fn_ParseCommandLine_Integer(int n_arg, char **args, char ch, int default_return) {
- char *str=fn_ParseCommandLine_String(n_arg,args,ch,(char*)NULL);
- return str ? atoi(str) : default_return;
-}
-
-
-//-----------------
-// Finds proper location in the input data file.
-// Returns 1 if the NUL-terminated string id is found
-// in the file and 0 otherwise. The file pointer is set
-// to the line immediately after the line containing id.
-// If the string id has a length (including the new line
-// character \n) more than 1023, it will be cut off at 1023.
-//-----------------
-int fn_SetFilePosition(FILE *f, const char *id) {
- // As an output, the file pointer f will be reset to the beginning of the line next to the line headed by the string id.
- char buffer[1024];
- size_t n=strlen(id);
- int ch;
-
- if ( !f ) fn_DisplayError(".../fn_filesetup.c/fn_SetFilePosition(): the file, *f, must be created (opened)");
- if (n>1023) n=1023;
- rewind(f); // Reset a file poiniter to the beginning of the file. There may be more efficient ways but this is good enough as long as the file is not too long.
- while (fgets(buffer,1024,f)) { // Reads a line at a time in the file f (including \n and a NUL byte) until it matches id. fgets returns the pointer to the buffer and is often only used to check for EOF.
- if (buffer[strlen(buffer)-1] != '\n') // -1 because the first element of the buffer is indexed by buffer[0].
- // If the end of the buffer (excluding the NUL byte) encounters no new line, f points to the next character after
- // the end of the buffer on the SAME line (i.e., f does not point to the begining of the new line at this point).
- // The following do loop will take f to point to the beginning of the new line.
- do ch=fgetc(f); // Gets one character at a time until it reachs the end of the current '\n' or the end of the file EOF.
- while ( (ch != '\n') && (ch != EOF) );
- if (!memcmp(buffer,id,n)) return 1; // The match is found.
- }
- return 0; // No match is found.
-}
-
-
-//-----------------
-// Reads a string from the input data file with the NULL-terminated
-// character but without the new line character.
-// Returns 1 if the vector of characters is all read without
-// errors and 0 otherwise. The file pointer is then moved
-// to point to the next non-whitespace character after these
-// characters.
-//-----------------
-int ReadNullTerminatedString(FILE *fptr, TScvector *x_cv)
-{
- //x_cv will have a string without the new line character and with the NULL character.
- //It is the user's responsiblity to ensure the string x_cv has an enough length to use fgets().
- // If not, it stops after x_cv->n-1 characters have been stored in x_cv->v and a NULL byte is appended to make it a string.
- // If yet, reading stops after a newline character is read and stored in x_cv->v and a NULL byte is then appended.
- int _n;
- char *cv;
- if (!fptr || !x_cv) fn_DisplayError(".../fn_filesetup.c/ReadNullTerminatedString(): File or input string must be created (memory-allocated)");
- _n = x_cv->n;
- cv = x_cv->v;
- if ( !fgets(cv, _n, fptr) ) return 0;
- cv[strlen(cv)-1] = '\0'; //Removes the new line character and replaces it with the NULL character.
- //The string length (size_t type) strlen(cv) does NOT count the NULL byte at the end, but it counts the new line character.
- return 1;
-}
-
-
-//-----------------
-// Reads a vector of integers from the input data file.
-// Returns 1 if the vector of integers is all read without
-// errors and 0 otherwise. The file pointer is then moved
-// to point to the next non-whitespace character after these
-// integers.
-//-----------------
-int fn_ReadVector_int(FILE *fptr, int *x_v, const int d_x_v) {
- int ki;
- for (ki=0; ki<d_x_v; ki++)
- if ( fscanf(fptr, " %d ", &x_v[ki]) !=1 ) return 0;
- return 1;
-}
-int ReadVector_int(FILE *fptr, TSivector *x_iv) {
- int ki, _n,
- *v;
- if (!fptr || !x_iv) fn_DisplayError(".../fn_filesetup.c/ReadVector_int(): File or input matrix must be created (memory-allocated)");
- _n = x_iv->n;
- v = x_iv->v;
- for (ki=0; ki<_n; ki++)
- if ( fscanf(fptr, " %d ", &v[ki]) != 1 ) return 0;
- return 1;
-}
-
-
-//-----------------
-// Reads a vector of doubles from the input data file.
-// Returns 1 if the vector of doubles is all read without
-// errors and 0 otherwise. The file pointer is then moved
-// to point to the next non-whitespace character after these
-// doubles.
-//-----------------
-int fn_ReadVector_lf(FILE *fptr, double *x_v, const int d_x_v) {
- int ki;
- for (ki=0; ki<d_x_v; ki++)
- if ( fscanf(fptr, " %lf ", &x_v[ki]) !=1 ) return 0;
- return 1;
-}
-int ReadVector_lf(FILE *fptr, TSdvector *x_dv) {
- int ki, _n;
- double *v;
- if (!fptr || !x_dv) fn_DisplayError(".../fn_filesetup.c/ReadVector_lf(): File or input matrix must be created (memory-allocated)");
- _n = x_dv->n;
- v = x_dv->v;
- for (ki=0; ki<_n; ki++)
- if ( fscanf(fptr, " %lf ", &v[ki]) != 1 ) return 0;
-
- x_dv->flag = V_DEF;
- return 1;
-}
-
-
-//-----------------
-// Reads a column-major matrix of integers from the input data file.
-// Returns 1 if the matrix of integers is all read without
-// errors and 0 otherwise. The file pointer is then moved
-// to point to the next non-whitespace character after these
-// integers.
-//-----------------
-int fn_ReadMatrix_int(FILE *fptr, int *x_m, const int r_x_m, const int c_x_m) {
- int ki, kj;
-
- for (ki=0; ki<r_x_m; ki++)
- for (kj=0; kj<c_x_m; kj++)
- if ( fscanf(fptr, " %d ", &x_m[kj*r_x_m+ki]) !=1 ) return 0;
- return 1;
-}
-int ReadMatrix_int(FILE *fptr, TSimatrix *X_im)
-{
- int ki, kj;
- int nrows, ncols;
- if (!fptr || !X_im) fn_DisplayError(".../fn_filesetup.c/ReadMatrix_int(): File or input matrix must be created (memory-allocated)");
-
- nrows = X_im->nrows;
- ncols = X_im->ncols;
- for (ki=0; ki<nrows; ki++)
- for (kj=0; kj<ncols; kj++)
- if ( fscanf(fptr, " %d ", (X_im->M+mos(ki,kj,nrows))) !=1 ) return 0;
- return 1;
-}
-
-
-//-----------------
-// Reads a column-major matrix of doubles from the input data file.
-// Returns 1 if the matrix of doubles is all read without
-// errors and 0 otherwise. The file pointer is then moved
-// to point to the next non-whitespace character after these
-// doubles.
-//-----------------
-int fn_ReadMatrix_lf(FILE *fptr, double *x_m, const int r_x_m, const int c_x_m) {
- int ki, kj;
- for (ki=0; ki<r_x_m; ki++)
- for (kj=0; kj<c_x_m; kj++)
- if ( fscanf(fptr, " %lf ", &x_m[kj*r_x_m+ki]) !=1 ) return 0;
- return 1;
-}
-int ReadMatrix_lf(FILE *fptr, TSdmatrix *x_dm) {
- //Outputs:
- // x_dm (whose memory is already allocated): To be filled with the numbers from the file fptr.
- int ki, kj, nrows, ncols;
- double *M;
- if (!fptr || !x_dm) fn_DisplayError(".../fn_filesetup.c/ReadMatrix_lf(): File or input matrix must be created (memory-allocated)");
- nrows = x_dm->nrows;
- ncols = x_dm->ncols;
- M = x_dm->M;
- for (ki=0; ki<nrows; ki++)
- for (kj=0; kj<ncols; kj++)
- if ( fscanf(fptr, " %lf ", &M[mos(ki,kj,nrows)]) !=1 ) return 0;
-
- x_dm->flag = M_GE;
- return 1;
-}
-
-
-
-//-----------------
-// Reads a column-major cell of double vectors from the input data file.
-// Returns 1 if all data are read without errors and 0 otherwise.
-// The file pointer is then moved to point to the next non-whitespace character
-// after these doubles.
-//-----------------
-int ReadCellvec_lf(FILE *fptr, TSdcellvec *x_dcv) {
- //Outputs:
- // x_dcv (whose memory is already allocated): To be filled with the numbers from the file fptr.
- int ci, kj, _n, ncells;
- double *v;
- if (!fptr || !x_dcv) fn_DisplayError(".../fn_filesetup.c/ReadCellvec_lf(): File or input cell must be created (memory-allocated)");
- ncells = x_dcv->ncells;
- for (ci=0; ci<ncells; ci++) {
- _n = x_dcv->C[ci]->n;
- v = x_dcv->C[ci]->v;
- for (kj=0; kj<_n; kj++)
- if ( fscanf(fptr, " %lf ", &v[kj]) != 1 ) return 0;
- }
- return 1;
-}
-
-
-
-
-//-----------------
-// Reads a column-major cell of double matrices from the input data file.
-// Returns 1 if all data are read without errors and 0 otherwise.
-// The file pointer is then moved to point to the next non-whitespace character
-// after these doubles.
-//-----------------
-int ReadCell_lf(FILE *fptr, TSdcell *x_dc) {
- //Outputs:
- // x_dc (whose memory is already allocated): To be filled with the numbers from the file fptr.
- int ci, ki, kj, nrows, ncols, ncells;
- double *M;
- if (!fptr || !x_dc) fn_DisplayError(".../fn_filesetup.c/ReadCell_lf(): File or input cell must be created (memory-allocated)");
- ncells = x_dc->ncells;
- for (ci=0; ci<ncells; ci++) {
- nrows = x_dc->C[ci]->nrows;
- ncols = x_dc->C[ci]->ncols;
- M = x_dc->C[ci]->M;
- for (ki=0; ki<nrows; ki++)
- for (kj=0; kj<ncols; kj++)
- if ( fscanf(fptr, " %lf ", &M[mos(ki,kj,nrows)]) != 1 ) return 0;
- }
- return 1;
-}
-
-
-
-//-----------------
-// Write a column-major matrix of floats to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void fn_WriteMatrix_f(FILE *fptr_debug, const double *x_m, const int r_x_m, const int c_x_m) {
- int _i, _j;
-
- for (_i=0; _i<r_x_m; _i++) {
- for (_j=0; _j<c_x_m; _j++) {
- fprintf(fptr_debug, " %f ", x_m[_j*r_x_m + _i]);
- if (_j==c_x_m-1) fprintf(fptr_debug, "\n");
- }
- if (_i==r_x_m-1) fprintf(fptr_debug, "\n\n");
- }
-}
-void WriteMatrix_f(FILE *fptr_debug, const TSdmatrix *x_dm) {
- int _i, _j;
- if (!fptr_debug || !x_dm) fn_DisplayError(".../fn_filesetup.c/WriteMatrix_f(): File or input matrix cannot be NULL (must be created)");
- for (_i=0; _i<x_dm->nrows; _i++) {
- for (_j=0; _j<x_dm->ncols; _j++) {
- fprintf(fptr_debug, " %10.5f ", x_dm->M[_j*x_dm->nrows + _i]);
- if (_j==x_dm->ncols-1) fprintf(fptr_debug, "\n");
- }
- if (_i==x_dm->nrows-1) fprintf(fptr_debug, "\n\n");
- }
-}
-
-
-//-----------------
-// Write a column-major matrix of doubles to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void fn_WriteMatrix_lf(FILE *fptr_debug, const double *x_m, const int r_x_m, const int c_x_m) {
- int _i, _j;
- for (_i=0; _i<r_x_m; _i++) {
- for (_j=0; _j<c_x_m; _j++) {
- fprintf(fptr_debug, " %.16e ", x_m[_j*r_x_m + _i]);
- if (_j==c_x_m-1) fprintf(fptr_debug, "\n");
- }
- if (_i==r_x_m-1) fprintf(fptr_debug, "\n\n");
- }
-}
-void WriteMatrix_lf(FILE *fptr_debug, const TSdmatrix *x_dm) {
- int _i, _j;
- if (!fptr_debug || !x_dm) fn_DisplayError(".../fn_filesetup.c/WriteMatrix_lf(): File or input matrix cannot be NULL (must be created)");
- for (_i=0; _i<x_dm->nrows; _i++) {
- for (_j=0; _j<x_dm->ncols; _j++) {
- fprintf(fptr_debug, " %.16e ", x_dm->M[_j*x_dm->nrows + _i]);
- if (_j==x_dm->ncols-1) fprintf(fptr_debug, "\n");
- }
- if (_i==x_dm->nrows-1) fprintf(fptr_debug, "\n\n");
- }
-}
-void WriteMatrix(FILE *fptr_debug, const TSdmatrix *x_dm, const char *format) {
- int _i, _j, nrows, ncols;
- double *M;
- if (!fptr_debug || !x_dm) fn_DisplayError(".../fn_filesetup.c/WriteMatrix(): File or input matrix cannot be NULL (must be created)");
- nrows = x_dm->nrows;
- ncols = x_dm->ncols;
- M = x_dm->M;
- if (!format) format=" %10.5f "; //Default format.
- for (_i=0; _i<nrows; _i++)
- for (_j=0; _j<ncols; _j++) {
- fprintf(fptr_debug, format, M[_j*x_dm->nrows + _i]);
- if (_j==ncols-1) fprintf(fptr_debug, "\n");
- }
- //fprintf(fptr_debug, "\n");
-}
-//+
-void WriteMatrixTranspose(FILE *fptr_debug, const TSdmatrix *x_dm, const char *format)
-{
- int _i, _j, nrows, ncols;
- double *M;
- //===
- TSdmatrix *Xtran_dm = NULL;
-
- if (!fptr_debug || !x_dm) fn_DisplayError(".../fn_filesetup.c/WriteMatrixTranspose(): File or input matrix cannot be NULL (must be created)");
-
- Xtran_dm = tz_TransposeRegular((TSdmatrix *)NULL, x_dm);
-
- nrows = Xtran_dm->nrows;
- ncols = Xtran_dm->ncols;
- M = Xtran_dm->M;
- if (!format) format=" %10.5f "; //Default format.
- for (_i=0; _i<nrows; _i++)
- for (_j=0; _j<ncols; _j++) {
- fprintf(fptr_debug, format, M[_j*Xtran_dm->nrows + _i]);
- if (_j==ncols-1) fprintf(fptr_debug, "\n");
- }
- //fprintf(fptr_debug, "\n");
-
- //===
- DestroyMatrix_lf(Xtran_dm);
-}
-
-
-//-----------------
-// Write cells of column-major double matrices to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void WriteCell_lf(FILE *fptr_debug, const TSdcell *x_dc) {
- int _i, _n;
- if (!fptr_debug || !x_dc) fn_DisplayError(".../fn_filesetup.c/WriteCell_lf(): File or input cell cannot be NULL (must be created)");
- _n = x_dc->ncells;
- for (_i=0; _i<_n; _i++) {
- fprintf(fptr_debug, "Cell %d\n", _i);
- WriteMatrix_lf(fptr_debug, x_dc->C[_i]);
- }
-}
-void WriteCell_f(FILE *fptr_debug, const TSdcell *x_dc) {
- int _i, _n;
- if (!fptr_debug || !x_dc) fn_DisplayError(".../fn_filesetup.c/WriteCell_f(): File or input cell cannot be NULL (must be created)");
- _n = x_dc->ncells;
- for (_i=0; _i<_n; _i++) {
- fprintf(fptr_debug, "Cell %d\n", _i);
- WriteMatrix_f(fptr_debug, x_dc->C[_i]);
- }
-}
-void WriteCell(FILE *fptr_debug, const TSdcell *x_dc, const char *format) {
- int _i, _n;
- if (!fptr_debug || !x_dc) fn_DisplayError(".../fn_filesetup.c/WriteCell(): File or input cell cannot be NULL (must be created)");
- _n = x_dc->ncells;
- for (_i=0; _i<_n; _i++)
- {
- WriteMatrix(fptr_debug, x_dc->C[_i], format);
- fprintf(fptr_debug, "\n");
- }
-}
-//+
-void WriteCellTranspose(FILE *fptr_debug, const TSdcell *x_dc, const char *format)
-{
- int _i, _n;
- if (!fptr_debug || !x_dc) fn_DisplayError(".../fn_filesetup.c/WriteCell(): File or input cell cannot be NULL (must be created)");
- _n = x_dc->ncells;
- for (_i=0; _i<_n; _i++)
- {
- WriteMatrixTranspose(fptr_debug, x_dc->C[_i], format);
- fprintf(fptr_debug, "\n");
- }
-}
-
-
-//-----------------
-// Write cells of vectors to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void WriteCellvec_lf(FILE *fptr_debug, const TSdcellvec *x_dcv) {
- int _i;
- if (!fptr_debug || !x_dcv) fn_DisplayError(".../fn_filesetup.c/WriteCellvec_lf(): File or input cell cannot be NULL (must be created)");
- for (_i=0; _i<x_dcv->ncells; _i++) {
- fprintf(fptr_debug, "Cell %d\n", _i);
- WriteVector_lf(fptr_debug, x_dcv->C[_i]);
- }
-}
-void WriteCellvec_f(FILE *fptr_debug, const TSdcellvec *x_dcv) {
- int _i;
- if (!fptr_debug || !x_dcv) fn_DisplayError(".../fn_filesetup.c/WriteCellvec_lf(): File or input cell cannot be NULL (must be created)");
- for (_i=0; _i<x_dcv->ncells; _i++) {
- fprintf(fptr_debug, "Cell %d\n", _i);
- WriteVector_f(fptr_debug, x_dcv->C[_i]);
- }
-}
-void WriteCellvec(FILE *fptr_debug, const TSdcellvec *x_dcv, const char *format) {
- int _i, _n;
- if (!fptr_debug || !x_dcv) fn_DisplayError(".../fn_filesetup.c/WriteCellvec(): File or input cell cannot be NULL (must be created)");
- _n = x_dcv->ncells;
- for (_i=0; _i<_n; _i++) WriteVector(fptr_debug, x_dcv->C[_i], format);
-}
-void WriteCellvec_int(FILE *fptr_debug, const TSicellvec *x_icv)
-{
- int _i, _n;
- if (!fptr_debug || !x_icv) fn_DisplayError(".../fn_filesetup.c/WriteCellvec_int(): File or input cell cannot be NULL (must be created)");
- _n = x_icv->ncells;
- for (_i=0; _i<_n; _i++) WriteVector_int(fptr_debug, x_icv->C[_i]);
-}
-
-
-
-//-----------------
-// Write fourths of column-major double matrices to an output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void WriteFourth_f(FILE *fptr_debug, const TSdfourth *x_d4) {
- int _j, _i, _m, _n;
- if (!fptr_debug || !x_d4) fn_DisplayError(".../fn_filesetup.c/WriteFourth_f(): File or input fourth cannot be NULL (must be created)");
- _m = x_d4->ndims;
- for (_j=0; _j<_m; _j++) {
- _n = x_d4->F[_j]->ncells;
- fprintf(fptr_debug, "Fourth %d\n", _j);
- for (_i=0; _i<_n; _i++) {
- fprintf(fptr_debug, "Cell %d\n", _i);
- WriteMatrix_f(fptr_debug, x_d4->F[_j]->C[_i]);
- }
- }
-}
-void WriteFourth(FILE *fptr_debug, const TSdfourth *x_d4, const char *format) {
- int _j, _i, _m, _n;
- if (!fptr_debug || !x_d4) fn_DisplayError(".../fn_filesetup.c/WriteFourth_f(): File or input fourth cannot be NULL (must be created)");
- _m = x_d4->ndims;
- for (_j=0; _j<_m; _j++) {
- _n = x_d4->F[_j]->ncells;
- for (_i=0; _i<_n; _i++) {
- WriteMatrix(fptr_debug, x_d4->F[_j]->C[_i], format);
- }
- }
-}
-
-
-//-----------------
-// Write a column-major matrix of ints to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void fn_WriteMatrix_int(FILE *fptr_debug, const int *x_m, const int r_x_m, const int c_x_m) {
- int _i, _j;
- for (_i=0; _i<r_x_m; _i++) {
- for (_j=0; _j<c_x_m; _j++) {
- fprintf(fptr_debug, " %d ", x_m[_j*r_x_m + _i]);
- if (_j==c_x_m-1) fprintf(fptr_debug, "\n");
- }
- if (_i==r_x_m-1) fprintf(fptr_debug, "\n\n");
- }
-}
-void WriteMatrix_int(FILE *fptr_debug, const TSimatrix *x_im) {
- int _i, _j;
- if (!fptr_debug || !x_im) fn_DisplayError(".../fn_filesetup.c/WriteMatrix_int(): File or input matrix cannot be NULL (must be created)");
- for (_i=0; _i<x_im->nrows; _i++) {
- for (_j=0; _j<x_im->ncols; _j++) {
- fprintf(fptr_debug, " %d ", x_im->M[_j*x_im->nrows + _i]);
- if (_j==x_im->ncols-1) fprintf(fptr_debug, "\n");
- }
- if (_i==x_im->nrows-1) fprintf(fptr_debug, "\n\n");
- }
-}
-
-
-//-----------------
-// Write a vector of doubles to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void fn_WriteVector_lf(FILE *fptr_debug, const double *x_v, const int d_x_v) {
- int _i;
- for (_i=0; _i<d_x_v; _i++) {
- fprintf(fptr_debug, " %20.16f ", x_v[_i]);
- if (_i==d_x_v-1) fprintf(fptr_debug, "\n\n");
- }
-}
-void WriteVector_lf(FILE *fptr_debug, const TSdvector *x_dv) {
- int _i;
- for (_i=0; _i<x_dv->n; _i++) {
- fprintf(fptr_debug, " %20.16f ", x_dv->v[_i]);
- if (_i==x_dv->n-1) fprintf(fptr_debug, "\n\n");
- }
-}
-void WriteVector(FILE *fptr_debug, const TSdvector *x_dv, const char *format) {
- int _i, _n;
- double *v;
- if ( !fptr_debug || !x_dv ) fn_DisplayError(".../fn_filesetup.c/WriteVector(): File or input vector cannot be NULL (must be created)");
- _n = x_dv->n;
- v = x_dv->v;
- if (!format) format=" %10.5f "; //Default format.
- for (_i=0; _i<_n; _i++) fprintf(fptr_debug, format, v[_i]);
- fprintf(fptr_debug, "\n");
-}
-void WriteVector_column(FILE *fptr_debug, const TSdvector *x_dv, const char *format)
-{
- int _i, _n;
- double *v;
- if ( !fptr_debug || !x_dv ) fn_DisplayError(".../fn_filesetup.c/WriteVector_column(): File or input vector cannot be NULL (must be created)");
- _n = x_dv->n;
- v = x_dv->v;
- if (!format) format=" %10.5f "; //Default format.
- for (_i=0; _i<_n; _i++)
- {
- fprintf(fptr_debug, format, v[_i]);
- fprintf(fptr_debug, "\n");
- }
-}
-
-
-//-----------------
-// Write a vector of floats to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void fn_WriteVector_f(FILE *fptr_debug, const double *x_v, const int d_x_v) {
- int _i;
- for (_i=0; _i<d_x_v; _i++) fprintf(fptr_debug, " %f ", x_v[_i]);
- fprintf(fptr_debug, "\n");
-}
-void WriteVector_f(FILE *fptr_debug, const TSdvector *x_dv) {
- int _i;
- if (!fptr_debug || !x_dv) fn_DisplayError(".../fn_filesetup.c/WriteVector_f(): File or input vector cannot be NULL (must be created)");
- for (_i=0; _i<x_dv->n; _i++) fprintf(fptr_debug, " %10.5f ", x_dv->v[_i]);
- fprintf(fptr_debug, "\n");
-}
-
-
-
-//-----------------
-// Write a vector of integers to the output file.
-// The file pointer is then moved to point to the next
-// non-whitespace character after these doubles.
-//-----------------
-void WriteVector_int(FILE *fptr_debug, const TSivector *x_iv)
-{
- int _i;
- if (!fptr_debug || !x_iv) fn_DisplayError(".../fn_filesetup.c/WriteVector_int(): File or input vector cannot be NULL (must be created)");
- for (_i=0; _i<x_iv->n; _i++) {
- fprintf(fptr_debug, " %d ", x_iv->v[_i]);
- if (_i==x_iv->n-1) fprintf(fptr_debug, "\n\n");
- }
-}
-
-
-
-void PrintVector_int(const TSivector *x_iv)
-{
- int _i, _n;
-
- if (!x_iv) fn_DisplayError(".../fn_filesetup.c/PrintVector_int(): Input vector must be created (memory-allocated)");
- _n = x_iv->n;
- // printf("\nVector:\n");
- for (_i=0; _i<_n; _i++) {
- printf("v[%d]=%d\n", _i, x_iv->v[_i]);
- }
-}
-
-//-----------------
-// Print a vector of doubles to the screen.
-//-----------------
-void PrintVector(const TSdvector *x_dv, const char *format)
-{
- int _i, _n;
-
- if (!x_dv) fn_DisplayError(".../fn_filesetup.c/PrintVector(): Input vector must be created (memory-allocated)");
- _n = x_dv->n;
- // printf("\n\nVector:\n");
- for (_i=0; _i<_n; _i++) {
- printf(format, x_dv->v[_i]);
- }
-}
-//+
-void PrintVector_f(const TSdvector *x_dv)
-{
- int _i, _n;
-
- if (!x_dv) fn_DisplayError(".../fn_filesetup.c/PrintVector_f(): Input vector must be created (memory-allocated)");
- _n = x_dv->n;
- // printf("\n\nVector:\n");
- for (_i=0; _i<_n; _i++) {
- printf("v[%d]=%6.4f\n", _i, x_dv->v[_i]);
- }
-}
-
-void PrintVector_dz(const TSdzvector *x_dzv)
-{
- int _i;
-
- if (!x_dzv) fn_DisplayError(".../fn_filesetup.c/PrintVector_dz(): Input complex vector must be created (memory-allocated)");
-
- printf("\n\nComplex vector:\n");
- for (_i=0; _i<x_dzv->real->n; _i++) {
- printf("vreal[%d]=%6.4f; vimag[%d]=%6.4f\n", _i, x_dzv->real->v[_i], _i, x_dzv->imag->v[_i]);
- }
-}
-
-
-void PrintMatrix_int(const TSimatrix *X_im)
-{
- int _i, _j, nrows, ncols;
- int *M=X_im->M;
-
- if (!X_im) fn_DisplayError(".../fn_filesetup.c/PrintMatrix_int(): Input matrix must be created (memory-allocated)");
- else {
- nrows = X_im->nrows;
- ncols = X_im->ncols;
- M = X_im->M;
- }
-
- printf("\n\nMatrix:\n");
- for (_i=0; _i<nrows; _i++) {
- for (_j=0; _j<ncols; _j++) {
- printf(" %d ", M[_j*nrows + _i]);
- if (_j==ncols-1) printf("\n");
- }
- if (_i==nrows-1) printf("\n");
- }
-}
-
-void PrintMatrix_f(const TSdmatrix *x_dm)
-{
- int _i, _j, nrows, ncols;
- double *M=x_dm->M;
-
- if (!x_dm) fn_DisplayError(".../fn_filesetup.c/PrintMatrix_f(): Input matrix must be created (memory-allocated)");
- else {
- nrows = x_dm->nrows;
- ncols = x_dm->ncols;
- M = x_dm->M;
- }
-
- printf("\n\nMatrix:\n");
- for (_i=0; _i<nrows; _i++) {
- for (_j=0; _j<ncols; _j++) {
- printf(" %6.4f ", M[_j*nrows + _i]);
- if (_j==ncols-1) printf("\n");
- }
- if (_i==nrows-1) printf("\n");
- }
-}
-
-void PrintMatrix(const TSdmatrix *x_dm, const char *format)
-{
- int _i, _j, nrows, ncols;
- double *M=x_dm->M;
-
- if (!x_dm) fn_DisplayError(".../fn_filesetup.c/PrintMatrix_f(): Input matrix must be created (memory-allocated)");
- else {
- nrows = x_dm->nrows;
- ncols = x_dm->ncols;
- M = x_dm->M;
- }
-
- printf("\n\nMatrix:\n");
- if (!format) format=" %10.5f "; //Default format.
- for (_i=0; _i<nrows; _i++) {
- for (_j=0; _j<ncols; _j++) {
- printf(format, M[_j*nrows + _i]);
- if (_j==ncols-1) printf("\n");
- }
- if (_i==nrows-1) printf("\n");
- }
-}
-
-void PrintMatrix_dz(const TSdzmatrix *x_dzm) {
- int _i, _j, nrows, ncols;
- double *Mr=NULL,
- *Mi=NULL;
-
- if (!x_dzm) fn_DisplayError(".../fn_filesetup.c/PrintMatrix_dz(): Input complex matrix must be created (memory-allocated)");
- else {
- nrows = x_dzm->real->nrows;
- ncols = x_dzm->real->ncols;
- Mr = x_dzm->real->M,
- Mi = x_dzm->imag->M;
- }
-
- printf("\n\nReal part of the matrix:\n");
- for (_i=0; _i<nrows; _i++) {
- for (_j=0; _j<ncols; _j++) {
- printf(" %6.4f ", Mr[_j*nrows + _i]);
- if (_j==ncols-1) printf("\n");
- }
- if (_i==nrows-1) printf("\n");
- }
-
- printf("\n\nImaginary part of the matrix:\n");
- for (_i=0; _i<nrows; _i++) {
- for (_j=0; _j<ncols; _j++) {
- printf(" %6.4f ", Mi[_j*nrows + _i]);
- if (_j==ncols-1) printf("\n");
- }
- if (_i==nrows-1) printf("\n");
- }
-}
-
-void PrintCellvec_f(const TSdcellvec *x_dcv) {
- int _i, ci, _n;
- double *v;
-
- if (!x_dcv) fn_DisplayError(".../fn_filesetup.c/PrintCellvec_f(): Input cell must be created (memory-allocated)");
- for (ci=0; ci<x_dcv->ncells; ci++ ) {
- _n = x_dcv->C[ci]->n;
- v = x_dcv->C[ci]->v;
- printf("\nCellvec %d:\n", ci);
- for (_i=0; _i<_n; _i++) {
- printf("v[%d]=%6.4f\n", _i, v[_i]);
- }
- }
-}
-void PrintCell_f(const TSdcell *x_dc) {
- int _i, _j, ci, nrows, ncols;
- double *M;
-
- if (!x_dc) fn_DisplayError(".../fn_filesetup.c/PrintCell_f(): Input cell must be created (memory-allocated)");
- for (ci=0; ci<x_dc->ncells; ci++ ) {
- nrows = x_dc->C[ci]->nrows;
- ncols = x_dc->C[ci]->ncols;
- M = x_dc->C[ci]->M;
-
- printf("\nCell %d:\n", ci);
- for (_i=0; _i<nrows; _i++) {
- for (_j=0; _j<ncols; _j++) {
- printf(" %6.4f ", M[_j*nrows + _i]);
- if (_j==ncols-1) printf("\n");
- }
- if (_i==nrows-1) printf("\n");
- }
- }
-}
-
-
-void PrintCell(const TSdcell *x_dc, const char *format)
-{
- int _i, _j, ci, nrows, ncols;
- double *M;
-
- if (!x_dc) fn_DisplayError(".../fn_filesetup.c/PrintCell_f(): Input cell must be created (memory-allocated)");
- for (ci=0; ci<x_dc->ncells; ci++ ) {
- nrows = x_dc->C[ci]->nrows;
- ncols = x_dc->C[ci]->ncols;
- M = x_dc->C[ci]->M;
-
- printf("\nCell %d:\n", ci);
- if (!format) format=" %10.5f "; //Default format.
- for (_i=0; _i<nrows; _i++) {
- for (_j=0; _j<ncols; _j++) {
- printf(format, M[_j*nrows + _i]);
- if (_j==ncols-1) printf("\n");
- }
- if (_i==nrows-1) printf("\n");
- }
- }
-}
-
-
-void PrintFourthvec_f(TSdfourthvec *x_d4v) {
- int _j, _i, _k, _m, _n, _o;
- if (!x_d4v) fn_DisplayError(".../fn_filesetup.c/PrintFourthvec_f(): Input fourthvec cannot be NULL (must be created)");
- _m = x_d4v->ndims;
- for (_j=0; _j<_m; _j++) {
- _n = x_d4v->F[_j]->ncells;
- for (_i=0; _i<_n; _i++) {
- printf("\nFourthvec %d and Cell %d:\n", _j, _i);
- _o = x_d4v->F[_j]->C[_i]->n;
- for (_k=0; _k<_o; _k++) {
- printf("v[%d]=%6.4f\n", _k, x_d4v->F[_j]->C[_i]->v[_k]);
- }
- }
- }
-}
-
-
-
-
-//-------------------
-// Prints entire input data (fptr_in) to the output file (fptr_out)
-// for the user to know what has produced the output.
-// The maximum number of characters in each line of the input file
-// is 4095 (excluding the NUL byte), but the rest of the line will
-// continue to be printed in new lines in the output file.
-//-------------------
-#define BUFFERLEN 4096
-void ReprintInputData(FILE *fptr_in, FILE *fptr_out)
-{
- char *inpbuffer;
-
- inpbuffer = tzMalloc(BUFFERLEN, char); //@ Allocate memory to the string (including the NUL byte).
- rewind(fptr_in);
- while (fgets(inpbuffer,BUFFERLEN,fptr_in))
- fprintf(fptr_out, "%s", inpbuffer);
- fprintf(fptr_out, "\n\n\n\n\n//------------------------------- Output Data Begin Here -------------------------------\n");
- free(inpbuffer);
-}
-#undef BUFFERLEN
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/fn_filesetup.h b/matlab/swz/c-code/utilities/TZCcode/fn_filesetup.h
deleted file mode 100644
index 0859f390ed006347abaf765987c5383e020eda42..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/fn_filesetup.h
+++ /dev/null
@@ -1,69 +0,0 @@
-#ifndef __FN_FILESETUP_H__
-#define __FN_FILESETUP_H__
- #include <string.h>
- //#include <malloc.h> // For malloc, calloc, etc.
-
- #include "tzmatlab.h"
- #include "mathlib.h" //Used for tz_TransposeRegular().
-
- int fn_ParseCommandLine(int n_arg, char **args, char ch);
- char *fn_ParseCommandLine_String(int n_arg, char **args, char ch, char *default_return);
- int fn_ParseCommandLine_Integer(int n_arg, char **args, char ch, int default_return);
- int fn_SetFilePosition(FILE *f, const char *id);
-
- int fn_ReadVector_int(FILE *fptr, int *x_v, const int d_x_v);
- int fn_ReadVector_lf(FILE *fptr, double *x_v, const int d_x_v);
- int fn_ReadMatrix_int(FILE *fptr, int *x_m, const int r_x_m, const int c_x_m);
- int fn_ReadMatrix_lf(FILE *fptr, double *x_m, const int r_x_m, const int c_x_m);
-
- int ReadNullTerminatedString(FILE *fptr, TScvector *x_cv);
- int ReadVector_int(FILE *fptr, TSivector *x_iv);
- int ReadVector_lf(FILE *fptr, TSdvector *x_dv);
- int ReadMatrix_int(FILE *fptr, TSimatrix *X_im);
- int ReadMatrix_lf(FILE *fptr, TSdmatrix *x_dm);
- int ReadCell_lf(FILE *fptr, TSdcell *x_dc);
- int ReadCellvec_lf(FILE *fptr, TSdcellvec *x_dcv);
-
- void fn_WriteMatrix_f(FILE *fprt_debug, const double *x_m, const int r_x_m, const int c_x_m);
- void fn_WriteMatrix_lf(FILE *fprt_debug, const double *x_m, const int r_x_m, const int c_x_m);
- void fn_WriteMatrix_int(FILE *fprt_debug, const int *x_m, const int r_x_m, const int c_x_m);
- void fn_WriteVector_f(FILE *fprt_debug, const double *x_v, const int d_x_v);
-
- void WriteMatrix_f(FILE *fprt_debug, const TSdmatrix *x_dm);
- void WriteMatrix_lf(FILE *fprt_debug, const TSdmatrix *x_dm);
- void WriteMatrix(FILE *fprt_debug, const TSdmatrix *x_dm, const char *format);
- void WriteMatrixTranspose(FILE *fptr_debug, const TSdmatrix *x_dm, const char *format);
- void WriteCell_lf(FILE *fprt_debug, const TSdcell *x_dc);
- void WriteCell_f(FILE *fprt_debug, const TSdcell *x_dc);
- void WriteCell(FILE *fprt_debug, const TSdcell *x_dc, const char *format);
- void WriteCellTranspose(FILE *fptr_debug, const TSdcell *x_dc, const char *format);
- void WriteCellvec_lf(FILE *fprt_debug, const TSdcellvec *x_dcv);
- void WriteCellvec_f(FILE *fprt_debug, const TSdcellvec *x_dcv);
- void WriteCellvec(FILE *fptr_debug, const TSdcellvec *x_dcv, const char *format);
- void WriteFourth_f(FILE *fptr_debug, const TSdfourth *x_d4);
- void WriteFourth(FILE *fptr_debug, const TSdfourth *x_d4, const char *format);
- void WriteVector_f(FILE *fprt_debug, const TSdvector *x_dv);
- void WriteVector_lf(FILE *fprt_debug, const TSdvector *x_dv);
- void WriteVector(FILE *fprt_debug, const TSdvector *x_dv, const char *format);
- void WriteVector_column(FILE *fptr_debug, const TSdvector *x_dv, const char *format);
- void WriteCellvec_int(FILE *fptr_debug, const TSicellvec *x_icv);
- void WriteMatrix_int(FILE *fprt_debug, const TSimatrix *x_im);
- void WriteVector_int(FILE *fprt_debug, const TSivector *x_iv);
-
-
- void PrintVector_int(const TSivector *x_iv);
- void PrintVector(const TSdvector *x_dv, const char *format);
- void PrintVector_f(const TSdvector *x_dv);
- void PrintVector_dz(const TSdzvector *x_dzv);
- void PrintMatrix_int(const TSimatrix *X_im);
- void PrintMatrix_f(const TSdmatrix *x_dm);
- void PrintMatrix(const TSdmatrix *x_dm, const char *format);
- void PrintMatrix_dz(const TSdzmatrix *x_dzm);
- void PrintCellvec_f(const TSdcellvec *x_dcv);
- void PrintCell_f(const TSdcell *x_dc);
- void PrintCell(const TSdcell *x_dc, const char *format);
- void PrintFourthvec_f(TSdfourthvec *x_d4v);
-
-
- void ReprintInputData(FILE *fptr_in, FILE *fptr_out);
-#endif
diff --git a/matlab/swz/c-code/utilities/TZCcode/gensys.c b/matlab/swz/c-code/utilities/TZCcode/gensys.c
deleted file mode 100644
index 998b51c093af5f01a072e732ee2db7a5aa63aaf9..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/gensys.c
+++ /dev/null
@@ -1,1272 +0,0 @@
-/*******************************************************************
- * [G1,C,impact,fmat,fwt,ywt,gev,eu]=gensys(g0,g1,c,psi,pi,div)
- *
- * System given as
- * g0*y(t)=g1*y(t-1)+c+psi*z(t)+pi*eta(t),
- * with z an exogenous variable process and eta being endogenously determined
- * one-step-ahead expectational errors. Returned system is
- * y(t)=G1*y(t-1)+C+impact*z(t)+ywt*inv(I-fmat*inv(L))*fwt*z(t+1) .
- * If z(t) is i.i.d., the last term drops out.
- * If div or stake is omitted from argument list, a div>1 or stake>1 is calculated.
- * eu(1)=1 for existence, eu(2)=1 for uniqueness. eu(1)=-1 for
- * existence only with not-serially correlated z(t); eu=[-2,-2] for coincident zeros.
- *
- * g0, g1: n-by-n matrices.
- * c: n-by-1 constant terms.
- * z(t): m-by-1 vector of exogenous residuals where m < n.
- * psi: n-by-m matrix.
- * eta(t): h-by-1 vector of expectational (endogenous) errors.
- * pi: n-by-h matrix.
- * div: a real number dividing stable and unstable roots.. If < 1.0, a div>1.0 is calculated mechanically.
- *-------
- * G1 or Theta_dm: n-by-n matrices.
- * C: n-by-1 vector of constant terms.
- * impact: n-by-m matrix.
- * gev: n-by-2 z vector of stacked generalized eigenvalues where gev(;,2) ./ gev(:,1) = eig(g0, g1).
- * ywt: n-by-nunstab z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- * fmat: nunstab-by-nunstab z matrix where nunstab is the number of non-stable roots.
- * fwt: nunstab-by-m z matrix.
- *
- * 1996 MATLAB algorithm by Christopher Sims
- * 2002 Mex implementation by Iskander Karibzhanov
- * 2004 Modified to C function by Tao Zha (April), correcting a few bugs of Iskander.
- * 03/01/06 Another modification by Tao Zha, to be consistent with the CAS 3/10/04 correction.
- *
- * Note: Iskander is transforming g0 and g1 to complex matrices and uses zgges() as a qz decomposition.
- * This is really wasting efficiency. One should keep g0 and g1 as real matrices and use
- * dgges() as a qz decomposition. I don't have time to overhaul this at this point. 04/20/04, T. Zha.
- * Note: 02/22/06. I take the above note back. According to DW, it is easy to *order* the
- * the generalized eigenvalues by using the complex g0 and g1. In principle, one could
- * order the roots using the real qz decomposition on real matrices g0 and g1. But so far
- * Dan has found it a pain to do it. Perhaps we should read the MKL Lapack manual more
- * carefully at a later point.
-********************************************************************/
-#include "gensys.h"
-
-
-//----- NOTE: We can't replace MKL_Complex16 with a different name because the Intel Lapack uses MKL_Complex16.
-//----- The only way to do this is to overhaul the code and put a wrapper function on each Intel Lapack function.
-static int selctg(MKL_Complex16 *alpha, MKL_Complex16 *beta);
-static int qz(MKL_Complex16 *a, MKL_Complex16 *b, MKL_Complex16 *q, MKL_Complex16 *z, int n);
-static MKL_Complex16* CreateComplexMatrix5RealMatrix(TSdmatrix *X_dm);
-static MKL_Complex16* CreateComplexMatrix5RealVector(TSdvector *x_dv);
-static void ComplexMatrix2RealMatrix(TSdmatrix *Y_dm, MKL_Complex16 *Z);
-static void ComplexMatrix2RealVector(TSdvector *y_dv, MKL_Complex16 *Z);
-static TSdzmatrix *SubComplexMatrix2Zmatrix(TSdzmatrix *X_dzm, MKL_Complex16 *Z, const int nrowsforZ, const int _m, const int _n);
-static void copy_eigenvalues(TSdzmatrix *Gev_dzm, MKL_Complex16 *a, MKL_Complex16 *b);
-static int compute_svd(MKL_Complex16 *a, MKL_Complex16 **u, double **d, MKL_Complex16 **v, int m, int n);
-static int compute_norm(MKL_Complex16 *a, double **d, int m, int n);
-//--- 03/01/06 TZ. Commented out to be consistent with the CAS 3/10/04 correction.
-// static int compute_normx(MKL_Complex16 *a, MKL_Complex16 *b, MKL_Complex16 *zwt, MKL_Complex16 *ueta, double **normx, int nunstab, int psin, int n, int bigev);
-static void cblas_zdupe(int m, int n, MKL_Complex16 *a, int lda, MKL_Complex16 *b, int ldb);
-static void cblas_zdscali(int n, double *a, int lda, MKL_Complex16 *b, int ldb);
-static void cblas_zdscale(int n, double *a, int lda, MKL_Complex16 *b, int ldb);
-static void cblas_zdpsb(int m, int n, MKL_Complex16 *a, int lda, MKL_Complex16 *b, int ldb, MKL_Complex16 *c, int ldc);
-//
-static void InitializeConstantMLK_Complex16(MKL_Complex16 *x_clx, const int _n, const double c);
-static void InitializeConstantDouble(double *x_p, const int _n, const double c);
-static void ConverteZeroSquareMatrix2RealDiagonalMLK_Complex16(MKL_Complex16 *x_pc, const int _n, const double c);
-
-
-TSgensys *CreateTSgensys(TFlinratexp *func, const int _n, const int _m, const int _k, const double div)
-{
- //_n is the number of stacked variables (endogenous, Lagurangian multiplier, expected multiplier, etc.).
- //_m is the number of exogenous shocks.
- //_k is the number of expectational errors.
- //div is the dividing number to determine what constitutes an unstable root. If div<1.0, a div>1.0 is calculated mechanically.
- TSgensys *gensys_ps = tzMalloc(1, TSgensys);
-
- //=== Output arguments.
- gensys_ps->Theta_dm = CreateMatrix_lf(_n, _n); //n-by-n.
- gensys_ps->c_dv = CreateVector_lf(_n); //n-by-1.
- gensys_ps->Impact_dm = CreateMatrix_lf(_n, _m); //n-by-m.
- gensys_ps->Fmat_dzm = (TSdzmatrix *)NULL; //nunstab-by-nunstab z matrix. Initialized to NULL and will be dynamically allocated whenever gensys() is called.
- gensys_ps->Fwt_dzm = (TSdzmatrix *)NULL; //nunstab-by-m z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- gensys_ps->Ywt_dzm = (TSdzmatrix *)NULL; //n-by-nunstab z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- gensys_ps->Gev_dzm = CreateMatrix_dz(_n, 2); //n-by-2 z matrix of possible complex numbers.
- gensys_ps->eu_iv = CreateConstantVector_int(2, 0); //2-by-1.
-
- //=== Function itself.
- gensys_ps->gensys = func;
-
- //=== Input arguments.
- gensys_ps->G0_dm = CreateConstantMatrix_lf(_n, _n, 0.0); //n-by-n.
- gensys_ps->G0_dm->flag = M_GE;
- gensys_ps->G1_dm = CreateConstantMatrix_lf(_n, _n, 0.0); //n-by-n.
- gensys_ps->G1_dm->flag = M_GE;
- gensys_ps->c0_dv = CreateConstantVector_lf(_n, 0.0); //n-by-1.
- gensys_ps->Psi_dm = CreateConstantMatrix_lf(_n, _m, 0.0); //n-by-m.
- gensys_ps->Psi_dm->flag = M_GE;
- gensys_ps->Pi_dm = CreateConstantMatrix_lf(_n, _k, 0.0); //n-by-k where k is the number of expectational errors.
- gensys_ps->Pi_dm->flag = M_GE;
- gensys_ps->div = div;
-
- return (gensys_ps);
-}
-//-------
-TSgensys *DestroyTSgensys(TSgensys *gensys_ps)
-{
- if (gensys_ps) {
- //=== Output arguments.
- DestroyMatrix_lf(gensys_ps->Theta_dm); //n-by-n.
- DestroyVector_lf(gensys_ps->c_dv); //n-by-1.
- DestroyMatrix_lf(gensys_ps->Impact_dm); //n-by-m.
- DestroyMatrix_dz(gensys_ps->Fmat_dzm); //nunstab-by-nunstab z matrix. Initialized to NULL and will be dynamically allocated whenever gensys() is called.
- DestroyMatrix_dz(gensys_ps->Fwt_dzm); //nunstab-by-m z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- DestroyMatrix_dz(gensys_ps->Ywt_dzm); //n-by-nunstab z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- DestroyMatrix_dz(gensys_ps->Gev_dzm); //n-by-2 z matrix of possible complex numbers.
- DestroyVector_int(gensys_ps->eu_iv); //2-by-1.
-
- //=== Input arguments.
- DestroyMatrix_lf(gensys_ps->G0_dm); //n-by-n.
- DestroyMatrix_lf(gensys_ps->G1_dm); //n-by-n.
- DestroyVector_lf(gensys_ps->c0_dv); //n-by-1.
- DestroyMatrix_lf(gensys_ps->Psi_dm); //n-by-m.
- DestroyMatrix_lf(gensys_ps->Pi_dm); //n-by-k where k is the number of expectational errors.
-
- free(gensys_ps);
-
- return ((TSgensys *)NULL);
- }
- else return (gensys_ps);
-}
-
-
-//--------------------------- For the function gensys_sims() ------------------------------------
-static int fixdiv = 1, zxz = 0;
-static double stake = 1.01;
-static int nunstab = 0;
-static MKL_Complex16 one, minusone, zero;
-
-/* [G1,C,impact,fmat,fwt,ywt,gev,eu]=gensysmkl(g0,g1,c,psi,pi,stake) */
-//void mexFunction(int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[]) {
-int gensys_sims(TSgensys *gensys_ps, void *dummy_ps)
-{
- //Returns 1 if successful and 0 for fatal errors (such as qz or svd fails or all roots are explosive). Added DW and TZ, 03/08/06.
- int tmpi;
- int n, psin, pin, nsquare, md, md1, i, bigev, bigev1; //mds, bigevs, //03/01/06 TZ. Commented out to be consistent with the CAS 3/10/04 correction.
- int *eu;
- int exist = 0, existx = 0, unique = 0;
- //=== Memory will be allocated to the following.
- double *deta = NULL, *deta1 = NULL, *norm = NULL; //*normx = NULL, *dz = NULL, //03/01/06 TZ. Commented out to be consistent with the CAS 3/10/04 correction.
- MKL_Complex16 *a = NULL, *b = NULL, *q = NULL, *z = NULL, *pi = NULL, *psi = NULL;
- MKL_Complex16 *tmat = NULL, *g0 = NULL, *g1 = NULL, *dummy = NULL, *tmatq = NULL, *c = NULL, *impact = NULL, *ab = NULL;
- MKL_Complex16 *fmat = NULL, *fwt = NULL, *ywt = NULL;
- MKL_Complex16 *etawt = NULL, *ueta = NULL, *veta = NULL, *etawt1 = NULL, *ueta1 = NULL, *veta1 = NULL;
- // *uz = NULL, *vz = NULL, *zwt = NULL, //03/01/06 TZ. Commented out to be consistent with the CAS 3/10/04 correction.
- //--- Dimensions.
- n = gensys_ps->G0_dm->nrows;
- psin = gensys_ps->Psi_dm->ncols;
- pin = gensys_ps->Pi_dm->ncols;
- //--- Pointer.
- eu = gensys_ps->eu_iv->v;
-
- eu[0]=eu[1]=0; //Must be initialized because gensys_ps->eu_iv->v may have values in repeated loops.
-
- //=== [a b q z]=qz(g0,g1);
- a = CreateComplexMatrix5RealMatrix(gensys_ps->G0_dm);
- b = CreateComplexMatrix5RealMatrix(gensys_ps->G1_dm);
- q = tzMalloc(nsquare=square(n), MKL_Complex16);
- z = tzMalloc(nsquare, MKL_Complex16);
- InitializeConstantMLK_Complex16(q, nsquare, 0.0);
- InitializeConstantMLK_Complex16(z, nsquare, 0.0);
-
- fixdiv = (gensys_ps->div < 1.0);
- stake = fixdiv ? 1.01 : gensys_ps->div;
- nunstab = 0;
- zxz = 0;
-
- if (qz(a, b, q, z, n)) {
- printf("WARNING: QZ factorization failed.\n");
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
- eu[0] = 0;
- return 0;
- }
-
- nunstab /= 2;
-
- if (zxz) {
- printf("WARNING: Coincident zeros. Indeterminacy and/or nonexistence.\n");
- eu[0] = eu[1] = -2;
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
- return 1;
- }
- copy_eigenvalues(gensys_ps->Gev_dzm, a, b);
-
- one.real = 1.0;
- one.imag = 0.0;
-
- minusone.real = -1.0;
- minusone.imag = 0.0;
-
- zero.real = 0.0;
- zero.imag = 0.0;
-
- pi = CreateComplexMatrix5RealMatrix(gensys_ps->Pi_dm);
- //=============================================
- // Modified by DW and TZ to deal with the case where nunstab=0 (no explosive roots). 03/08/06.
- //=============================================
- if (nunstab) //This branch belongs to original CAS code.
- {
- etawt = tzMalloc(tmpi=nunstab*pin, MKL_Complex16);
- InitializeConstantMLK_Complex16(etawt, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, nunstab, pin, n,
- &one, q+n*(n-nunstab), n, pi, n, &zero, etawt, nunstab);
- if (compute_svd(etawt, &ueta, &deta, &veta, nunstab, pin)) {
- //Memory is now allocated to ueta, deta, and veta.
- printf("WARNING: SVD failed.\n");
- tzDestroy(pi);
- tzDestroy(ueta);
- tzDestroy(deta);
- tzDestroy(veta);
- tzDestroy(etawt);
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
- eu[0] = 0;
- return 0;
- }
- tzDestroy(etawt);
- md = nunstab<pin?nunstab:pin;
- bigev = md;
- for (i=0; i<md; i++)
- if (deta[i]<=REALSMALL) {
- bigev=i;
- break;
- }
- //------ 03/01/06 TZ: corrected code by CAS, 3/10/04.
- if ((eu[0]=(bigev >= nunstab))==0) //DW & TZ, 03/08/06
- {
- tzDestroy(pi);
- tzDestroy(ueta);
- tzDestroy(deta);
- tzDestroy(veta);
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
- return 1;
- }
- }
- else //DW & TZ. 03/08/06. This is where we deal with the case when nunstab=0.
- {
- eu[0] = 1; //Existence.
- }
-
-
- //---------------------------------
- // ueta = nunstab x bigev
- // deta = bigev x 1
- // veta = bigev x pin, ldveta = md
- // uz = nunstab x bigevs
- // dz = bigevs x 1
- // vz = bigevs x psin, ldvz = mds
- //---------------------------------
-
- //====== 03/01/06 TZ: the following note is added by CAS 3/10/04.
- //------ Code below allowed "existence" in cases where the initial lagged state was free to take on values
- //------ inconsistent with existence, so long as the state could w.p.1 remain consistent with a stable solution
- //------ if its initial lagged value was consistent with a stable solution. This is a mistake, though perhaps there
- //------ are situations where we would like to know that this "existence for restricted initial state" situation holds.
- // psi = CreateComplexMatrix5RealMatrix(gensys_ps->Psi_dm);
- // zwt = tzMalloc(tmpi=nunstab*psin, MKL_Complex16);
- // InitializeConstantMLK_Complex16(zwt, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- // cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, nunstab, psin, n,
- // &one, q+n*(n-nunstab), n, psi, n, &zero, zwt, nunstab);
- // if (compute_svd(zwt, &uz, &dz, &vz, nunstab, psin)) {
- // //Memory is now allocated to uz, dz, and vz.
- // printf("WARNING: SV decomposition failed.\n");
- // tzDestroy(ueta);
- // tzDestroy(deta);
- // tzDestroy(veta);
- // tzDestroy(uz);
- // tzDestroy(dz);
- // tzDestroy(vz);
- // tzDestroy(zwt);
- // tzDestroy(a);
- // tzDestroy(b);
- // tzDestroy(q);
- // tzDestroy(z);
- // return;
- // }
- // tzDestroy(vz);
- // mds = nunstab<psin?nunstab:psin;
- // bigevs = mds;
- // for (i=0; i<mds; i++)
- // if (dz[i]<=REALSMALL) {
- // bigevs=i;
- // break;
- // }
- // tzDestroy(dz);
- //
- // if (!bigevs) {
- // exist = 1;
- // existx = 1;
- // } else {
- // /* uz-ueta*ueta'*uz */
- // MKL_Complex16 *tmp = tzMalloc(tmpi=nunstab*nunstab, MKL_Complex16);
- // InitializeConstantMLK_Complex16(tmp, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- // cblas_zgemm(CblasColMajor, CblasNoTrans, CblasConjTrans, nunstab, nunstab,
- // bigev, &one, ueta, nunstab, ueta, nunstab, &zero, tmp, nunstab);
- // cblas_zhemm(CblasColMajor, CblasLeft, CblasUpper, nunstab,
- // bigevs, &minusone, tmp, nunstab, uz, nunstab, &one, uz, nunstab);
- // tzDestroy(tmp);
- // if (compute_norm(uz, &norm, nunstab, bigevs)) {
- // //Memory is now allocated to norm.
- // printf("WARNING: SVD failed.\n");
- // tzDestroy(norm);
- // tzDestroy(ueta);
- // tzDestroy(deta);
- // tzDestroy(veta);
- // tzDestroy(uz);
- // tzDestroy(zwt);
- // tzDestroy(a);
- // tzDestroy(b);
- // tzDestroy(q);
- // tzDestroy(z);
- // return;
- // }
- // exist = *norm < REALSMALL*n;
- // tzDestroy(norm);
- // if (compute_normx(a, b, zwt, ueta, &normx, nunstab, psin, n, bigev)) {
- // //If 0, memory is now allocated to normx; otherwise, normx is destroyed within the function compute_normx().
- // tzDestroy(ueta);
- // tzDestroy(deta);
- // tzDestroy(veta);
- // tzDestroy(uz);
- // tzDestroy(zwt);
- // tzDestroy(a);
- // tzDestroy(b);
- // tzDestroy(q);
- // tzDestroy(z);
- // return;
- // }
- // existx = *normx < REALSMALL*n;
- // tzDestroy(normx);
- // }
- //
- // tzDestroy(uz);
- // tzDestroy(zwt);
-
- //---------------------------------------------------------------------------
- // Note that existence and uniqueness are not just matters of comparing
- // numbers of roots and numbers of endogenous errors. These counts are
- // reported below because usually they point to the source of the problem.
- //---------------------------------------------------------------------------
- //=============================================
- // Modified by DW and TZ to deal with the case
- // where nunstab=n (all explosive roots). 03/08/06.
- //=============================================
- if (nunstab == n)
- {
- tzDestroy(pi);
- tzDestroy(ueta);
- tzDestroy(deta);
- tzDestroy(veta);
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
-
- printf("\n******** Fatal error: All roots are explosive while we have a solution. But this should NOT happen.***********\n");
- eu[0] = 0;
- return 0;
- }
-
- //======= Otherwise, returns to CAS's original code. 03/08/06. =======//
- etawt1 = tzMalloc(tmpi=(n-nunstab)*pin, MKL_Complex16);
- InitializeConstantMLK_Complex16(etawt1, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, n-nunstab, pin, n,
- &one, q, n, pi, n, &zero, etawt1, n-nunstab);
- tzDestroy(pi);
- if (compute_svd(etawt1, &ueta1, &deta1, &veta1, n-nunstab, pin)) {
- //Memory is now allocated to ueta1, deta1, and veta1.
- printf("WARNING: SVD failed for compute_svd().\n");
- tzDestroy(ueta1);
- tzDestroy(deta1);
- tzDestroy(veta1);
- tzDestroy(etawt1);
- tzDestroy(ueta);
- tzDestroy(deta);
- tzDestroy(veta);
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
- eu[0] = 0;
- return 0;
- }
- tzDestroy(etawt1);
- md1 = n-nunstab<pin?n-nunstab:pin;
- bigev1 = md1;
- for (i=0; i<md1; i++)
- if (deta1[i]<=REALSMALL) {
- bigev1=i;
- break;
- }
-
- //====== 03/01/06 TZ: the following is commented out by CAS 3/10/04.
- // if (existx || !nunstab) {
- // //=== Solution exists.
- // eu[0] = 1;
- // } else {
- // if (exist) {
- // printf("WARNING: Solution exists for unforecastable z only\n");
- // eu[0] = -1;
- // } /* else
- // mexPrintf("No solution. %d unstable roots. %d endog errors.\n",nunstab,bigev1); */
- // /* mexPrintf("Generalized eigenvalues\n");
- // mexCallMATLAB(0,NULL,1, &plhs[6], "disp"); */
- // }
-
-
- //-------------------------------
- // ueta1 = n-nunstab x bigev1
- // deta1 = bigev1 x 1
- // veta1 = bigev1 x pin, ldveta1 = md1
- //-------------------------------
- if (!bigev1)
- unique = 1;
- else {
- // veta1-veta1*veta*veta'
- // veta = bigev x pin, ldveta1 = md
- // veta1 = bigev1 x pin, ldveta1 = md1
- MKL_Complex16 *tmp = tzMalloc(pin*pin, MKL_Complex16);
- MKL_Complex16 *veta1_copy = tzMalloc(pin*bigev1, MKL_Complex16);
- InitializeConstantMLK_Complex16(tmp, pin*pin, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- InitializeConstantMLK_Complex16(veta1_copy, pin*bigev1, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- if (nunstab)
- {
- cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, pin, pin,
- bigev, &one, veta, md, veta, md, &zero, tmp, pin); //tmp=veta'*veta;
- cblas_zdupe(bigev1,pin,veta1,md1,veta1_copy,bigev1);
- cblas_zhemm(CblasColMajor, CblasRight, CblasUpper, bigev1, pin,
- &minusone, tmp, pin, veta1_copy, bigev1, &one, veta1_copy, bigev1);
- }
- else //Added by DW & TZ, 03/08/06.
- {
- cblas_zdupe(bigev1,pin,veta1,md1,veta1_copy,bigev1);
- }
- tzDestroy(tmp);
- if (compute_norm(veta1_copy, &norm, bigev1, pin)) {
- //Memory is now allocated to norm.
- printf("WARNING: SVD failed.\n");
- tzDestroy(norm);
- tzDestroy(ueta1);
- tzDestroy(deta1);
- tzDestroy(veta1);
- tzDestroy(ueta);
- tzDestroy(deta);
- tzDestroy(veta);
- tzDestroy(veta1_copy);
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
- eu[0] = 0;
- return 0;
- }
- tzDestroy(veta1_copy);
- unique = *norm < REALSMALL*n;
- tzDestroy(norm);
- }
- if (unique) {
- //=== Unique solution.
- eu[1] = 1;
- } else {
- eu[1] = 0;
- #if defined (PRINTWARNINGofSUNSPOT)
- if (nunstab)
- printf("WARNING: Indeterminacy. %d loose endog errors with eu being [%d, %d].\n",bigev1-bigev, eu[0], eu[1]);
- else
- printf("WARNING: Indeterminacy. %d loose endog errors with eu being [%d, %d].\n",pin, eu[0], eu[1]);
- //printf("WARNING: Indeterminacy. %d loose endog errors with eu being [%g, %g].\n",bigev1-bigev, gensys_ps->eu_dv->v[0], gensys_ps->eu_dv->v[1]);
- //printf("WARNING: Indeterminacy. %d loose endog errors.\n",bigev1-bigev);
- #endif
- }
-
- //---------------------------------------------------------//
- //------------------ Obtaining the outputs. ---------------//
- //---------------------------------------------------------//
- if (nunstab)
- {
- //=== All the following lines are used to compute only ONE object tmat, which is used subsequently. ===//
- cblas_zdscali(pin,deta,bigev,veta,md); /* veta' = deta\veta' */
- tzDestroy(deta);
- cblas_zdscale(pin,deta1,bigev1,veta1,md1); /* veta1' = deta1*veta1' */
- tzDestroy(deta1);
- etawt = tzMalloc(tmpi=nunstab*pin, MKL_Complex16); /* etawt = ueta*veta' */
- InitializeConstantMLK_Complex16(etawt, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, nunstab, pin, bigev,
- &one, ueta, nunstab, veta, md, &zero, etawt, nunstab);
- tzDestroy(ueta);
- tzDestroy(veta);
- etawt1 = tzMalloc(tmpi=(n-nunstab)*pin, MKL_Complex16); /* etawt1 = ueta1*veta1' */
- InitializeConstantMLK_Complex16(etawt1, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n-nunstab, pin, bigev1,
- &one, ueta1, n-nunstab, veta1, md1, &zero, etawt1, n-nunstab);
- tzDestroy(ueta1);
- tzDestroy(veta1);
- tmat = tzMalloc(tmpi=(n-nunstab)*nunstab, MKL_Complex16); /* tmat = etawt1*etawt' */
- InitializeConstantMLK_Complex16(tmat, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasConjTrans, n-nunstab, nunstab, pin,
- &one, etawt1, n-nunstab, etawt, nunstab, &zero, tmat, n-nunstab);
- tzDestroy(etawt1);
- tzDestroy(etawt);
-
- //=== Getting the solution Theta ===//
- g0 = tzMalloc(tmpi=n*n, MKL_Complex16);
- InitializeConstantMLK_Complex16(g0, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zdupe(n-nunstab, n, a, n, g0, n);
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n-nunstab, nunstab, nunstab,
- &minusone, tmat, n-nunstab, a+(n-nunstab)*(n+1), n, &one, g0+(n-nunstab)*n, n);
- cblas_zcopy(nunstab, &one, 0, g0+(n-nunstab)*(n+1), n+1);
-
- g1 = tzMalloc(tmpi=n*n, MKL_Complex16);
- InitializeConstantMLK_Complex16(g1, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zdupe(n-nunstab, n, b, n, g1, n);
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n-nunstab, nunstab, nunstab,
- &minusone, tmat, n-nunstab, b+(n-nunstab)*(n+1), n, &one, g1+(n-nunstab)*n, n);
- cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
- n, n, &one, g0, n, g1, n);
- dummy = tzMalloc(tmpi=n*n, MKL_Complex16);
- InitializeConstantMLK_Complex16(dummy, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n, n, n, &one, z, n, g1, n, &zero, dummy, n);
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasConjTrans, n, n, n, &one, dummy, n, z, n, &zero, g1, n);
- tzDestroy(dummy);
- ComplexMatrix2RealMatrix(gensys_ps->Theta_dm, g1); //Output.
- tzDestroy(g1);
-
- //=== Getting the constant term c ===//
- tmatq = tzMalloc(tmpi=n*n, MKL_Complex16);
- InitializeConstantMLK_Complex16(tmatq, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zcopy(n*n, q, 1, tmatq, 1);
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasConjTrans, n, n-nunstab, nunstab,
- &minusone, tmatq+(n-nunstab)*n, n, tmat, n-nunstab, &one, tmatq, n);
- tzDestroy(tmat);
-
- ab = tzMalloc(tmpi=nunstab*nunstab, MKL_Complex16);
- InitializeConstantMLK_Complex16(ab, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zdpsb(nunstab, nunstab, a+(n-nunstab)*(n+1), n, b+(n-nunstab)*(n+1), n, ab, nunstab);
- cblas_ztrsm(CblasColMajor, CblasRight, CblasUpper, CblasConjTrans, CblasNonUnit,
- n, nunstab, &one, ab, nunstab, tmatq+(n-nunstab)*n, n);
- tzDestroy(ab);
-
- c = CreateComplexMatrix5RealVector(gensys_ps->c0_dv);
- dummy = tzMalloc(gensys_ps->c0_dv->n, MKL_Complex16);
- //$$$$$$$ The following is Iskander's fatal code error. One cannot use c in the two different places; otherwise, it makes c be zero completely!
- // cblas_zgemv(CblasColMajor, CblasConjTrans, n, n, &one, tmatq, n, c, 1, &zero, c, 1);
- // cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, n, g0, n, c, 1);
- // cblas_zgemv(CblasColMajor, CblasNoTrans, n, n, &one, z, n, c, 1, &zero, c, 1);
- cblas_zgemv(CblasColMajor, CblasConjTrans, n, n, &one, tmatq, n, c, 1, &zero, dummy, 1);
- cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, n, g0, n, dummy, 1);
- cblas_zgemv(CblasColMajor, CblasNoTrans, n, n, &one, z, n, dummy, 1, &zero, c, 1);
- ComplexMatrix2RealVector(gensys_ps->c_dv, c); //Output.
- tzDestroy(c);
- tzDestroy(dummy);
-
- //=== Getting the term Impact ===//
- impact = tzMalloc(tmpi=n*psin, MKL_Complex16);
- InitializeConstantMLK_Complex16(impact, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- psi = CreateComplexMatrix5RealMatrix(gensys_ps->Psi_dm); //03/01/06 TZ. Added to be consistent with the CAS 3/10/04 correction.
- cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, n-nunstab, psin, n,
- &one, tmatq, n, psi, n, &zero, impact, n);
- tzDestroy(tmatq);
- cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
- n, psin, &one, g0, n, impact, n);
- dummy = tzMalloc(tmpi=n*psin, MKL_Complex16);
- InitializeConstantMLK_Complex16(dummy, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n, psin, n,
- &one, z, n, impact, n, &zero, dummy, n);
- tzDestroy(impact);
- ComplexMatrix2RealMatrix(gensys_ps->Impact_dm, dummy); //Output.
- tzDestroy(dummy);
-
- //=== Finishing up the other terms such as Fmat, Fwt, and Ywt. ===//
- fmat = a+(n-nunstab)*(n+1);
- cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
- nunstab, nunstab, &one, b+(n-nunstab)*(n+1), n, fmat, n);
- gensys_ps->Fmat_dzm = SubComplexMatrix2Zmatrix(gensys_ps->Fmat_dzm, fmat, n, nunstab, nunstab);
- tzDestroy(a);
-
- fwt = tzMalloc(tmpi=nunstab*psin, MKL_Complex16);
- InitializeConstantMLK_Complex16(fwt, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_ztrsm(CblasColMajor, CblasRight, CblasUpper, CblasConjTrans, CblasNonUnit,
- n, nunstab, &one, b+(n-nunstab)*(n+1), n, q+(n-nunstab)*n, n);
- tzDestroy(b);
- cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, nunstab, psin, n,
- &minusone, q+(n-nunstab)*n, n, psi, n, &zero, fwt, nunstab);
- tzDestroy(q);
- tzDestroy(psi);
- gensys_ps->Fwt_dzm = SubComplexMatrix2Zmatrix(gensys_ps->Fwt_dzm, fwt, nunstab, nunstab, psin);
- tzDestroy(fwt);
-
- ywt = tzMalloc(tmpi=n*nunstab, MKL_Complex16);
- InitializeConstantMLK_Complex16(ywt, tmpi, 0.0);
- cblas_zcopy(nunstab, &one, 0, ywt+n-nunstab, n+1);
- cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
- n, nunstab, &one, g0, n, ywt, n);
- tzDestroy(g0);
- dummy = tzMalloc(tmpi=n*nunstab, MKL_Complex16);
- InitializeConstantMLK_Complex16(dummy, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n, nunstab, n,
- &one, z, n, ywt, n, &zero, dummy, n);
- tzDestroy(z);
- tzDestroy(ywt);
- gensys_ps->Ywt_dzm = SubComplexMatrix2Zmatrix(gensys_ps->Ywt_dzm, dummy, n, n, nunstab);
- tzDestroy(dummy);
- }
- else //This part is added by DW and TZ, 03/08/06.
- {
- //======= Getting Theta = real(z*(G0\G1)*z') =======//
- cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
- n, n, &one, a, n, b, n); //Note that a is triangular and b = a\b (overwritten).
- dummy = tzMalloc(tmpi=n*n, MKL_Complex16);
- InitializeConstantMLK_Complex16(dummy, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- //--- Getting Theta = real(z*b*z');
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n, n, n, &one, z, n, b, n, &zero, dummy, n); //dummy=z*b;
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasConjTrans, n, n, n, &one, dummy, n, z, n, &zero, b, n); //dummy=dummy*z';
- ComplexMatrix2RealMatrix(gensys_ps->Theta_dm, b); //Output.
- tzDestroy(dummy);
-
- //======= Getting c = real(z*G0\q*c0) =======//
- c = CreateComplexMatrix5RealVector(gensys_ps->c0_dv);
- dummy = tzMalloc(gensys_ps->c0_dv->n, MKL_Complex16);
- cblas_zgemv(CblasColMajor, CblasConjTrans, n, n, &one, q, n, c, 1, &zero, dummy, 1); //dummy = q*c;
- cblas_ztrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, n, a, n, dummy, 1); //dummy=a\dummy where a is triangular.
- cblas_zgemv(CblasColMajor, CblasNoTrans, n, n, &one, z, n, dummy, 1, &zero, c, 1); //dummy=z*dummy;
- ComplexMatrix2RealVector(gensys_ps->c_dv, c); //Output.
- tzDestroy(dummy);
-
- //======= Getting Impact = real(z*G0\q*psi) =======//
- impact = tzMalloc(tmpi=n*psin, MKL_Complex16);
- InitializeConstantMLK_Complex16(impact, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- psi = CreateComplexMatrix5RealMatrix(gensys_ps->Psi_dm); //03/01/06 TZ. Added to be consistent with the CAS 3/10/04 correction.
- dummy = tzMalloc(tmpi=n*psin, MKL_Complex16);
- cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, n, psin, n,
- &one, q, n, psi, n, &zero, impact, n); //impact = q*psi;
- cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
- n, psin, &one, a, n, impact, n); //impact = a\impact;
- InitializeConstantMLK_Complex16(dummy, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
- cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, n, psin, n,
- &one, z, n, impact, n, &zero, dummy, n); //dummy = z*impact;
- ComplexMatrix2RealMatrix(gensys_ps->Impact_dm, dummy); //Output.
- tzDestroy(dummy);
-
-
- //=== Some of destructions may have been done, but it is better to be safe.
- tzDestroy(ueta1);
- tzDestroy(deta1);
- tzDestroy(veta1);
- tzDestroy(etawt);
- tzDestroy(etawt1);
- //+
- tzDestroy(a);
- tzDestroy(b);
- tzDestroy(q);
- tzDestroy(z);
- //+
- tzDestroy(c);
- tzDestroy(impact);
- tzDestroy(psi);
- }
-
- //=== Save this debugging format -- DDDDDebugging.
- // if (!nunstab)
- // {
- // fprintf(FPTR_DEBUG, "Aind=[\n");
- // WriteMatrix(FPTR_DEBUG, gensys_ps->G0_dm, " %.16e ");
- // fprintf(FPTR_DEBUG, "];\n");
- // fprintf(FPTR_DEBUG, "Bind=[\n");
- // WriteMatrix(FPTR_DEBUG, gensys_ps->G1_dm, " %.16e ");
- // fprintf(FPTR_DEBUG, "];\n");
- // fprintf(FPTR_DEBUG, "Consterm=[\n");
- // WriteVector(FPTR_DEBUG, gensys_ps->c0_dv, " %.16e ");
- // fprintf(FPTR_DEBUG, "]';\n");
- // fprintf(FPTR_DEBUG, "gUpsiloneind=[\n");
- // WriteMatrix(FPTR_DEBUG, gensys_ps->Psi_dm, " %.16e ");
- // fprintf(FPTR_DEBUG, "];\n");
- // fprintf(FPTR_DEBUG, "gUpsilonxind=[\n");
- // WriteMatrix(FPTR_DEBUG, gensys_ps->Pi_dm, " %.16e ");
- // fprintf(FPTR_DEBUG, "];\n");
- // fflush(FPTR_DEBUG);
- //
- // fprintf(FPTR_DEBUG, "\n********** Output ******************\n");
- // fprintf(FPTR_DEBUG, "Theta=[\n");
- // WriteMatrix(FPTR_DEBUG, gensys_ps->Theta_dm, " %.16e ");
- // fprintf(FPTR_DEBUG, "];\n");
- // fprintf(FPTR_DEBUG, "Impact=[\n");
- // WriteMatrix(FPTR_DEBUG, gensys_ps->Impact_dm, " %.16e ");
- // fprintf(FPTR_DEBUG, "];\n");
- // fprintf(FPTR_DEBUG, "Consterm=[\n");
- // WriteVector(FPTR_DEBUG, gensys_ps->c_dv, " %.16e ");
- // fprintf(FPTR_DEBUG, "]';\n");
- // fprintf(FPTR_DEBUG, "eu=[\n");
- // WriteVector_int(FPTR_DEBUG, gensys_ps->eu_iv);
- // fprintf(FPTR_DEBUG, "]';\n");
- // fflush(FPTR_DEBUG);
- // }
-
- return 1;
-}
-
-
-/******************************************************************************
- * function selctg orders the eigenvalues so that a selected cluster of *
- * eigenvalues appears in the leading diagonal blocks of the upper *
- * quasi-triangular matrix S and the upper triangular matrix T. *
- ******************************************************************************/
-
-static int selctg(MKL_Complex16 *alpha, MKL_Complex16 *beta)
-{
- double absA = sqrt(alpha->real*alpha->real+alpha->imag*alpha->imag),
- absB = fabs(beta->real);
- if (absA) {
- double divhat = absB/absA;
- //bug detected by Vasco Curdia and Daria Finocchiaro, 2/25/2004 CAS. A root of
- //exactly 1.01 and no root between 1 and 1.02, led to div being stuck at 1.01
- //and the 1.01 root being misclassified as stable. Changing < to <= below fixes this.
- if (fixdiv && 1+REALSMALL<divhat && divhat<=stake)
- stake = (1+divhat)/2;
- }
- if (absA<REALSMALL && absB<REALSMALL)
- zxz = 1;
- if (absB>stake*absA) {
- nunstab++;
- return(0);
- } else
- return(1);
-}
-
-/******************************************************************************
- * compute for a pair of N-by-N complex nonsymmetric matrices (A,B), *
- * the generalized eigenvalues, the generalized complex Schur form (S, T), *
- * and optionally left and/or right Schur vectors (VSL and VSR) *
- ******************************************************************************/
-
-static int qz(MKL_Complex16 *a, MKL_Complex16 *b, MKL_Complex16 *q, MKL_Complex16 *z, int n)
-{
-// unsigned char msg[101];
- int sdim, lwork = -1, info = 0;
- MKL_Complex16 *alpha = tzMalloc(n,MKL_Complex16),
- *beta = tzMalloc(n,MKL_Complex16),
- *work, work1;
- double *rwork = tzMalloc(8*n, double);
- int *bwork = tzMalloc(4*n, int);
-
- /* Query zgges on the value of lwork */
- zgges("V", "V", "S", &selctg, &n, a, &n, b, &n, &sdim, alpha, beta, q,
- &n, z, &n, &work1, &lwork, rwork, bwork, &info);
-
- if (info < 0) {
- printf("WARNING: Input %d to the Intel MKL function zgges() has an illegal value",-info);
- tzDestroy(bwork);
- tzDestroy(rwork);
- tzDestroy(alpha);
- tzDestroy(beta);
- return(info);
- }
-
- lwork = (int)(work1.real);
- work = tzMalloc(lwork, MKL_Complex16);
- zgges("V", "V", "S", &selctg, &n, a, &n, b, &n, &sdim, alpha, beta, q,
- &n, z, &n, work, &lwork, rwork, bwork, &info);
-
- tzDestroy(work);
- tzDestroy(bwork);
- tzDestroy(rwork);
- tzDestroy(alpha);
- tzDestroy(beta);
-
- if (info < 0) {
- printf("WARNING: Input %d to the Intel MKL function zgges() has an illegal value",-info);
- return(info);
- }
-
- if (info > 0)
- if (info < n)
- printf("WARNING: The QZ iteration failed. (A,B) are not in Schur form,\n"
- "but ALPHA(j) and BETA(j) should be correct for j=%d,...,N.",info+1);
- else {
- switch (info-n) {
- case 1:
- printf("WARNING: LAPACK problem: error return from ZGGBAL");
- break;
- case 2:
- printf("WARNING: LAPACK problem: error return from ZGEQRF");
- break;
- case 3:
- printf("WARNING: LAPACK problem: error return from ZUNMQR");
- break;
- case 4:
- printf("WARNING: LAPACK problem: error return from ZUNGQR");
- break;
- case 5:
- printf("WARNING: LAPACK problem: error return from ZGGHRD");
- break;
- case 6:
- printf("WARNING: LAPACK problem: error return from ZHGEQZ (other than failed iteration)");
- break;
- case 7:
- printf("WARNING: LAPACK problem: error return from ZGGBAK (computing VSL)");
- break;
- case 8:
- printf("WARNING: LAPACK problem: error return from ZGGBAK (computing VSR)");
- break;
- case 9:
- printf("WARNING: LAPACK problem: error return from ZLASCL (various places)");
- break;
- default:
- printf("WARNING: LAPACK problem: unknown error.");
- break;
- }
- }
- return(info);
-}
-
-/*
- * Convert MATLAB complex matrix to MKL complex storage.
- *
- * Z = mat2mkl(X,ldz,ndz)
- *
- * converts MATLAB's mxArray X to MKL_Complex16 Z(ldz,ndz).
- * The parameters ldz and ndz determine the storage allocated for Z,
- * while mxGetM(X) and mxGetN(X) determine the amount of data copied.
- */
-
-//MKL_Complex16* mat2mkl(const mxArray *X, int ldz, int ndz) {
-// MKL_Complex16 *Z, *zp;
-// int m, n, incz, cmplxflag;
-// register int i, j;
-// double *xr, *xi;
-
-// Z = mxCalloc(ldz*ndz, sizeof(MKL_Complex16));
-// xr = mxGetPr(X);
-// xi = mxGetPi(X);
-// m = mxGetM(X);
-// n = mxGetN(X);
-// zp = Z;
-// incz = ldz-m;
-// cmplxflag = (xi != NULL);
-// for (j = 0; j < n; j++) {
-// if (cmplxflag) {
-// for (i = 0; i < m; i++) {
-// zp->real = *xr++;
-// zp->imag = *xi++;
-// zp++;
-// }
-// } else {
-// for (i = 0; i < m; i++) {
-// zp->real = *xr++;
-// zp++;
-// }
-// }
-// zp += incz;
-// }
-// return(Z);
-//}
-
-
-/*
- * Convert MKL complex storage to MATLAB real and imaginary parts.
- *
- * X = mkl2mat(Z,ldz,m,n)
- *
- * copies MKL_Complex16 Z to X, producing a complex mxArray
- * with mxGetM(X) = m and mxGetN(X) = n.
- */
-
-//mxArray* mkl2mat(MKL_Complex16 *Z, int ldz, int m, int n) {
-// int i, j, incz;
-// double *xr, *xi;
-// MKL_Complex16 *zp;
-// mxArray *X;
-
-// X = mxCreateDoubleMatrix(m,n,mxCOMPLEX);
-// xr = mxGetPr(X);
-// xi = mxGetPi(X);
-// zp = Z;
-// incz = ldz-m;
-// for (j = 0; j < n; j++) {
-// for (i = 0; i < m; i++) {
-// *xr++ = zp->real;
-// *xi++ = zp->imag;
-// zp++;
-// }
-// zp += incz;
-// }
-// return(X);
-//}
-
-//plhs[3] = mkl2mat(fmat, n, nunstab, nunstab)
-
-/*
- * Convert MKL complex storage to MATLAB real matrix ignoring imaginary part.
- *
- * X = mkl2mat(Z,ldz,m,n)
- *
- * copies MKL_Complex16 Z to X, producing a real mxArray
- * with mxGetM(X) = m and mxGetN(X) = n.
- */
-
-//mxArray* mkl2mat_real(MKL_Complex16 *Z, int ldz, int m, int n) {
-// int i, j, incz;
-// double *xr;
-// MKL_Complex16 *zp;
-// mxArray *X;
-
-// X = mxCreateDoubleMatrix(m,n,mxREAL);
-// xr = mxGetPr(X);
-// zp = Z;
-// incz = ldz-m;
-// for (j = 0; j < n; j++) {
-// for (i = 0; i < m; i++) {
-// *xr++ = zp->real;
-// zp++;
-// }
-// zp += incz;
-// }
-// return(X);
-//}
-
-//void copy_eigenvalues(mxArray *gev, MKL_Complex16 *a, MKL_Complex16 *b, int n) {
-// double *gevr = mxGetPr(gev),
-// *gevi = mxGetPi(gev);
-// int i;
-
-// for (i=0; i<n; i++, gevr++, gevi++, a+=n+1) {
-// *gevr = a->real;
-// *gevi = a->imag;
-// }
-
-// for (i=0; i<n; i++, gevr++, gevi++, b+=n+1) {
-// *gevr = b->real;
-// *gevi = b->imag;
-// }
-//}
-
-static void copy_eigenvalues(TSdzmatrix *Gev_dzm, MKL_Complex16 *a, MKL_Complex16 *b)
-{
- int n = Gev_dzm->real->nrows;
- double *gevr = Gev_dzm->real->M,
- *gevi = Gev_dzm->imag->M;
- int i;
-
- for (i=0; i<n; i++, gevr++, gevi++, a+=n+1) {
- *gevr = a->real;
- *gevi = a->imag;
- }
-
- for (i=0; i<n; i++, gevr++, gevi++, b+=n+1) {
- *gevr = b->real;
- *gevi = b->imag;
- }
-}
-
-
-static int compute_svd(MKL_Complex16 *x, MKL_Complex16 **u, double **d, MKL_Complex16 **v, int m, int n)
-{
- //$$$Memory allocated to u, d, and v will be destroyed outside this function.$$$
- int tmpi;
- int md = m<n?m:n, lwork = -1, info = 0;
- MKL_Complex16 *a, *work, work1;
- double *rwork = tzMalloc(5*md>1?5*md:1, double);
-
- a = tzMalloc(m*n, MKL_Complex16);
- cblas_zcopy(m*n, x, 1, a, 1);
-
- *u = tzMalloc(tmpi=m*md,MKL_Complex16);
- InitializeConstantMLK_Complex16(*u, tmpi, 0.0);
- *v = tzMalloc(tmpi=md*n, MKL_Complex16);
- InitializeConstantMLK_Complex16(*v, tmpi, 0.0);
- *d = tzMalloc(md, double);
- InitializeConstantDouble(*d, md, 0.0);
-
- /* Query zgges on the value of lwork */
- zgesvd("S", "S", &m, &n, a, &m, *d, *u, &m, *v, &md, &work1, &lwork, rwork, &info);
-
- if (info < 0) {
- printf("WARNING: Input %d to zgesvd had an illegal value",-info);
- tzDestroy(rwork);
- return(info);
- }
-
- lwork = (int)(work1.real);
- work = tzMalloc(lwork, MKL_Complex16);
- zgesvd("S", "S", &m, &n, a, &m, *d, *u, &m, *v, &md, work, &lwork, rwork, &info);
-
- tzDestroy(work);
- tzDestroy(rwork);
- tzDestroy(a);
-
- if (info < 0)
- printf("WARNING: Input %d to zgesvd had an illegal value",-info);
-
- if (info > 0)
- printf("WARNING: ZBDSQR did not converge.\n%d superdiagonals of an intermediate "
- "bidiagonal form B did not converge to zero.",info);
- return(info);
-}
-
-static int compute_norm(MKL_Complex16 *a, double **d, int m, int n)
-{
- //Memory will be allocated to d, which will be destroyed outside this function.
- int md = m<n?m:n, lwork = -1, info = 0;
- MKL_Complex16 *work = NULL, work1;
- double *rwork = tzMalloc(5*md>1?5*md:1, double);
-
- *d = tzMalloc(md, double);
-
- /* Query zgges on the value of lwork */
- zgesvd("N", "N", &m, &n, a, &m, *d, NULL, &m, NULL, &md, &work1, &lwork, rwork, &info);
-
- if (info < 0) {
- printf("WARNING: Input %d to zgesvd had an illegal value",-info);
- tzDestroy(rwork);
- return(info);
- }
-
- lwork = (int)(work1.real);
- work = tzMalloc(lwork, MKL_Complex16);
- zgesvd("N", "N", &m, &n, a, &m, *d, NULL, &m, NULL, &md, work, &lwork, rwork, &info);
-
- tzDestroy(work);
- tzDestroy(rwork);
-
- if (info < 0)
- printf("WARNING: Input %d to zgesvd had an illegal value",-info);
-
- if (info > 0)
- printf("WARNING: ZBDSQR() in Intel MKL did not converge.\n%d superdiagonals of an intermediate "
- "bidiagonal form B did not converge to zero.",info);
-
- return(info);
-}
-
-
-//======= 03/01/06 TZ. Commented out to be consistent with the CAS 3/10/04 correction. =======//
-//static int compute_normx(MKL_Complex16 *a, MKL_Complex16 *b, MKL_Complex16 *zwt, MKL_Complex16 *ueta, double **normx, int nunstab, int psin, int n, int bigev)
-//{
-// //Memory is allocated to normx, which will be freed outside this function.
-// int tmpi;
-// int info = 0, i, bigevs;
-// //
-// MKL_Complex16 *M = NULL, *zwtx = NULL, *ux = NULL, *vx = NULL, *tmp = NULL;
-// double *dx = NULL;
-
-
-// a += (n+1)*(n-nunstab);
-// b += (n+1)*(n-nunstab);
-// cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
-// nunstab, psin, &one, b, n, zwt, nunstab);
-// M = tzMalloc(nunstab*nunstab, MKL_Complex16);
-// cblas_zdupe(nunstab, nunstab, a, n, M, nunstab);
-// cblas_ztrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit,
-// nunstab, nunstab, &one, b, n, M, nunstab);
-
-// zwtx = tzMalloc(nunstab*nunstab*psin, MKL_Complex16);
-// cblas_zcopy(nunstab*psin, zwt, 1, zwtx, 1);
-// for (i=1; i<nunstab; i++) {
-// cblas_ztrmm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit, nunstab, psin*i, &one, M, nunstab, zwtx, nunstab);
-// cblas_zcopy(nunstab*psin, zwt, 1, zwtx+nunstab*psin*i, 1);
-// }
-// tzDestroy(M);
-// cblas_ztrmm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans, CblasNonUnit, nunstab, nunstab*psin, &one, b, n, zwtx, nunstab);
-// info = compute_svd(zwtx, &ux, &dx, &vx, nunstab, nunstab*psin); //Memory is allocated to ux, dx, and vx.
-// tzDestroy(vx);
-// tzDestroy(zwtx);
-// if (info) {
-// printf("WARNING: SVD failed.\n");
-// tzDestroy(ux);
-// tzDestroy(dx);
-// return(info);
-// }
-// bigevs = nunstab;
-// for (i=0; i<nunstab; i++)
-// if (dx[i]<=REALSMALL) {
-// bigevs = i;
-// break;
-// }
-// tzDestroy(dx);
-// /* ux-ueta*ueta'*ux */
-// tmp = tzMalloc(tmpi=nunstab*nunstab, MKL_Complex16);
-// InitializeConstantMLK_Complex16(tmp, tmpi, 0.0); //Must be initialized to 0.0 in order to have legal values of this pointer.
-// cblas_zgemm(CblasColMajor, CblasNoTrans, CblasConjTrans, nunstab, nunstab,
-// bigev, &one, ueta, nunstab, ueta, nunstab, &zero, tmp, nunstab);
-// cblas_zhemm(CblasColMajor, CblasLeft, CblasUpper, nunstab,
-// bigevs, &minusone, tmp, nunstab, ux, nunstab, &one, ux, nunstab);
-// tzDestroy(tmp);
-// info = compute_norm(ux, normx, nunstab, bigevs); //Memory is allocated to normx.
-// if (info) {
-// printf("WARNING: SVD failed.\n");
-// tzDestroy(normx);
-// tzDestroy(ux);
-// return(info);
-// }
-// tzDestroy(ux);
-// return(info);
-//}
-
-static void cblas_zdupe(int m, int n, MKL_Complex16 *a, int lda, MKL_Complex16 *b, int ldb)
-{
- //Copying from a to b.
- int i;
- for (i=0; i<m; i++, a++, b++)
- cblas_zcopy(n, a, lda, b, ldb);
-}
-
-static void cblas_zdscali(int n, double *a, int lda, MKL_Complex16 *b, int ldb)
-{
- int i;
- for (i=0; i<lda; i++, a++, b++)
- cblas_zdscal(n, 1.0/(*a), b, ldb);
-}
-
-static void cblas_zdscale(int n, double *a, int lda, MKL_Complex16 *b, int ldb)
-{
- int i;
- for (i=0; i<lda; i++, a++, b++)
- cblas_zdscal(n, *a, b, ldb);
-}
-
-static void cblas_zdpsb(int m, int n, MKL_Complex16 *a, int lda, MKL_Complex16 *b, int ldb, MKL_Complex16 *c, int ldc)
-{
- int i;
- cblas_zdupe(m, n, a, lda, c, ldc);
- for (i=0; i<m; i++, b++, c++)
- cblas_zaxpy(n, &minusone, b, ldb, c, ldc);
-}
-
-
-static MKL_Complex16* CreateComplexMatrix5RealMatrix(TSdmatrix *X_dm)
-{
- int mn, k;
- double *M;
- //
- MKL_Complex16 *Z = NULL;
-
- if (!X_dm) fn_DisplayError("CreateComplexMatrix5RealMatrix(): Input matrix X_dm must be allocated memory");
- M = X_dm->M;
-
- Z = tzMalloc(mn=X_dm->nrows*X_dm->ncols, MKL_Complex16);
- for (k=mn-1; k>=0; k--) {
- Z[k].real = M[k];
- Z[k].imag = 0.0;
- }
- return(Z);
-}
-
-static MKL_Complex16* CreateComplexMatrix5RealVector(TSdvector *x_dv)
-{
- int n, k;
- double *v;
- //
- MKL_Complex16 *Z = NULL;
-
- if (!x_dv) fn_DisplayError("CreateComplexMatrix5RealVector(): Input vector x_dv must be allocated memory");
- v = x_dv->v;
-
- Z = tzMalloc(n=x_dv->n, MKL_Complex16);
- for (k=n-1; k>=0; k--) {
- Z[k].real = v[k];
- Z[k].imag = 0.0;
- }
- return(Z);
-}
-
-
-static void ComplexMatrix2RealMatrix(TSdmatrix *Y_dm, MKL_Complex16 *Z)
-{
- int _k;
- double *M;
-
- if (!Y_dm) fn_DisplayError("ComplexMatrix2RealMatrix(): Output matrix Y_dm must be allocated memory");
- M = Y_dm->M;
-
- for (_k=Y_dm->nrows*Y_dm->ncols-1; _k>=0; _k--) M[_k] = Z[_k].real;
- Y_dm->flag = M_GE;
-}
-
-
-static void ComplexMatrix2RealVector(TSdvector *y_dv, MKL_Complex16 *Z)
-{
- int _k;
- double *v;
-
- if (!y_dv) fn_DisplayError("ComplexMatrix2RealVector(): Output matrix y_dv must be allocated memory");
- v = y_dv->v;
-
- for (_k=y_dv->n-1; _k>=0; _k--) v[_k] = Z[_k].real;
- y_dv->flag = V_DEF;
-}
-
-
-static TSdzmatrix *SubComplexMatrix2Zmatrix(TSdzmatrix *X_dzm, MKL_Complex16 *Z, const int nrowsforZ, const int _m, const int _n)
-{
- //X_dzm is _m-by_n comlex types where nrowsforZ <= _m and Z is nrowsforZ-by-_n.
- int _i, _j, incz;
- double *Mreal, *Mimag;
- MKL_Complex16 *zp;
- //
- TSdzmatrix *Y_dzm = NULL;
-
- if (!X_dzm || X_dzm->real->nrows != _m || X_dzm->real->ncols != _n) {
- DestroyMatrix_dz(X_dzm); //Destroys Y_dzm if already allocated memory to accommodate a possbible change of its dimension.
- Y_dzm = CreateMatrix_dz(_m, _n);
- }
- else Y_dzm = X_dzm;
-
- Mreal = Y_dzm->real->M;
- Mimag = Y_dzm->imag->M;
- zp = Z;
- if ((incz=nrowsforZ-_m)<0) fn_DisplayError("SubComplexMatrix2ZMatrix(): Number of rows for the input complex matrix Z must be greater that of the output Z matrix Y_dzm");
-
- for (_j=0; _j<_n; _j++) {
- for (_i=0; _i<_m; _i++) {
- *Mreal++ = zp->real;
- *Mimag++ = zp->imag;
- zp++;
- }
- zp += incz;
- }
- return (Y_dzm);
-}
-
-
-static void InitializeConstantMLK_Complex16(MKL_Complex16 *x_clx, const int _n, const double c)
-{
- int _i;
-
- for (_i=_n-1; _i>=0; _i--)
- x_clx[_i].real = x_clx[_i].imag = c;
-}
-
-static void InitializeConstantDouble(double *x_p, const int _n, const double c)
-{
- int _i;
-
- for (_i=_n-1; _i>=0; _i--) x_p[_i] = c;
-}
-
-static void ConverteZeroSquareMatrix2RealDiagonalMLK_Complex16(MKL_Complex16 *x_pc, const int _n, const double c)
-{
- //Written by TZ, 03/08/06.
- //Output:
- // x_pc: _n-by-_n, with the diagonal
- //Inputs:
- // _n: dimension of x_pc so that x_pc is _n-by-_n.
- // x_pc: _n-by-_n, all initialized to zeros.
- int _i;
- int np1 = _n+1;
-
- for (_i=_n*_n-1; _i>=0; _i -= np1)
- x_pc[_i].real = x_pc[_i].imag = c;
-}
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/gensys.h b/matlab/swz/c-code/utilities/TZCcode/gensys.h
deleted file mode 100644
index 9b6d3516d0522f1af9280517a4687130055d32ad..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/gensys.h
+++ /dev/null
@@ -1,67 +0,0 @@
-/*******************************************************************
- * [G1,C,impact,fmat,fwt,ywt,gev,eu]=gensys(g0,g1,c,psi,pi,div)
- *
- * System given as
- * g0*y(t)=g1*y(t-1)+c+psi*z(t)+pi*eta(t),
- * with z an exogenous variable process and eta being endogenously determined
- * one-step-ahead expectational errors. Returned system is
- * y(t)=G1*y(t-1)+C+impact*z(t)+ywt*inv(I-fmat*inv(L))*fwt*z(t+1) .
- * If z(t) is i.i.d., the last term drops out.
- * If div or stake is omitted from argument list, a div>1 or stake>1 is calculated.
- * eu(1)=1 for existence, eu(2)=1 for uniqueness. eu(1)=-1 for
- * existence only with not-serially correlated z(t); eu=[-2,-2] for coincident zeros.
- *
- * g0, g1: n-by-n matrices.
- * c: n-by-1 constant terms.
- * z(t): m-by-1 vector of exogenous residuals where m < n.
- * psi: n-by-m matrix.
- * eta(t): h-by-1 vector of expectational (endogenous) errors.
- * pi: n-by-h matrix.
- * div: a real number dividing stable and unstable roots.. If < 1.0, a div>1.0 is calculated mechanically.
- *-------
- * G1 or Theta_dm: n-by-n matrices.
- * C: n-by-1 vector of constant terms.
- * impact: n-by-m matrix.
- * gev: n-by-2 z vector of stacked generalized eigenvalues where gev(;,2) ./ gev(:,1) = eig(g0, g1).
- * ywt: n-by-nunstab z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- * fmat: nunstab-by-nunstab z matrix where nunstab is the number of non-stable roots.
- * fwt: nunstab-by-m z matrix.
-********************************************************************/
-
-#ifndef __GENSYS_H__
- #define __GENSYS_H__
-
- #include "tzmatlab.h"
- //#include "fn_filesetup.h" //For DDDDebugging purpose.
-
- #define REALSMALL 1e-7
- //#define PRINTWARNINGofSUNSPOT
-
- typedef struct TSgensys_tag {
- //=== Output arguments.
- TSdmatrix *Theta_dm; //n-by-n.
- TSdvector *c_dv; //n-by-1.
- TSdmatrix *Impact_dm; //n-by-m.
- TSdzmatrix *Fmat_dzm; //nunstab-by-nunstab z matrix. Initialized to NULL and will be dynamically allocated whenever gensys() is called.
- TSdzmatrix *Fwt_dzm; //nunstab-by-m z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- TSdzmatrix *Ywt_dzm; //n-by-nunstab z matrix of possible complex numbers. Initialized to NULL and dynamically allocated.
- TSdzmatrix *Gev_dzm; //n-by-2 z matrix of possible complex numbers.
- TSivector *eu_iv; //2-by-1.
- //=== Function itself.
- int (*gensys)(struct TSgensys_tag *, void *);
- //=== Input arguments, which are all intialized to 0.0 and whose flags are set to M_GE.
- TSdmatrix *G0_dm; //n-by-n.
- TSdmatrix *G1_dm; //n-by-n.
- TSdvector *c0_dv; //n-by-1.
- TSdmatrix *Psi_dm; //n-by-m.
- TSdmatrix *Pi_dm; //n-by-k whtere k is the number of expectational errors.
- double div; //Real number dividing stable and unstable roots.. If < 1.0, a div>1.0 is calculated mechanically.
- } TSgensys;
- //
- typedef int TFlinratexp(struct TSgensys_tag *, void *); //For linear rational expectations models.
-
- struct TSgensys_tag *CreateTSgensys(TFlinratexp *func, const int _n, const int _m, const int _k, const double div);
- struct TSgensys_tag *DestroyTSgensys(struct TSgensys_tag *gensys_ps);
- int gensys_sims(struct TSgensys_tag *gensys_ps, void *dummy_ps);
-#endif
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/kalman.c b/matlab/swz/c-code/utilities/TZCcode/kalman.c
deleted file mode 100644
index b53d44e67f6162fcc07843849c030ab5e2c0751f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/kalman.c
+++ /dev/null
@@ -1,2751 +0,0 @@
-/*===============================================================================================================
- * Check $$$ for important notes.
- * Check <<>> for updating DW's new switch code or questions for DW.
- *
- * kalcvf_urw(): the Kalman filter forward prediction specialized for only a univariate random walk (urw) process.
- *
- * State space model is defined as follows:
- * z(t+1) = z(t)+eta(t) (state or transition equation)
- * y(t) = x(t)'*z(t)+eps(t) (observation or measurement equation)
- * where for this function, eta and eps must be uncorrelated; y(t) must be 1-by-1. Note that
- * x(t): k-by-1;
- * z(t): k-by-1;
- * eps(t): 1-by-1 and ~ N(0, sigma^2);
- * eta(t): ~ N(0, V) where V is a k-by-k covariance matrix.
- *
- *
- * Written by Tao Zha, May 2004.
- * Revised, May 2008;
-=================================================================================================================*/
-
-/**
-//=== For debugging purpose.
-if (1)
-{
- double t_loglht;
-
- t_loglht = -(0.5*ny)*LOG2PI - 0.5*logdeterminant(Dtdata_dm) - 0.5*VectorDotVector(wny_dv, etdata_dv);
- fprintf(FPTR_DEBUG, " %10.5f\n", t_loglht);
-
- fprintf(FPTR_DEBUG, "%%st=%d, inpt=%d, and sti=%d\n", st, inpt, sti);
-
- fprintf(FPTR_DEBUG, "\n wP0_dv:\n");
- WriteVector(FPTR_DEBUG, wP0_dv, " %10.5f ");
- fprintf(FPTR_DEBUG, "\n Vt_dc->C[sti_v=%d]:\n", sti_v);
- WriteMatrix(FPTR_DEBUG, Vt_dc->C[sti_v], " %10.5f ");
-
- fflush(FPTR_DEBUG);
-}
-/**/
-
-
-#include "kalman.h"
-
-
-static int Update_et_Dt_1stapp(int t_1, struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps);
-static int Updatekalfilms_1stapp(int inpt, struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps, struct TStateModel_tag *smodel_ps);
-
-
-TSkalcvfurw *CreateTSkalcvfurw(TFlearninguni *func, int T, int k, int tv) //, int storeZ, int storeV)
-{
- int _i;
- //===
- TSivector *rows_iv = NULL;
- TSivector *cols_iv = NULL;
- //---
- TSkalcvfurw *kalcvfurw_ps = tzMalloc(1, TSkalcvfurw);
-
-
- kalcvfurw_ps->indx_tvsigmasq = tv;
- kalcvfurw_ps->fss = T;
- kalcvfurw_ps->kx = k;
-
- //===
- kalcvfurw_ps->V_dm = CreateMatrix_lf(k, k);
- kalcvfurw_ps->ylhtran_dv = CreateVector_lf(T);
- kalcvfurw_ps->Xrhtran_dm = CreateMatrix_lf(k, T);
- kalcvfurw_ps->z10_dv = CreateVector_lf(k);
- kalcvfurw_ps->P10_dm = CreateMatrix_lf(k, k);
-
- kalcvfurw_ps->zupdate_dv = CreateVector_lf(k);
- kalcvfurw_ps->Zpredtran_dm = CreateMatrix_lf(k, T);
- kalcvfurw_ps->ylhtranpred_dv = CreateVector_lf(T);
- //
- rows_iv = CreateVector_int(T);
- cols_iv = CreateVector_int(T);
- for (_i=T-1; _i>=0; _i--) rows_iv->v[_i] = cols_iv->v[_i] = k;
- kalcvfurw_ps->Ppred_dc = CreateCell_lf(rows_iv, cols_iv);
- // if (!storeZ) kalcvfurw_ps->Zpredtran_dm = (TSdmatrix *)NULL;
- // else kalcvfurw_ps->Zpredtran_dm = CreateMatrix_lf(k, T);
- // if (!storeV) kalcvfurw_ps->Ppred_dc = (TSdcell *)NULL;
- // else {
- // rows_iv = CreateVector_int(T);
- // cols_iv = CreateVector_int(T);
- // for (_i=T; _i>=0; _i--) rows_iv->v[_i] = cols_iv->v[_i] = k;
- // kalcvfurw_ps->Ppred_dc = CreateCell_lf(rows_iv, cols_iv);
- // }
-
- DestroyVector_int(rows_iv);
- DestroyVector_int(cols_iv);
- return (kalcvfurw_ps);
-}
-
-TSkalcvfurw *DestroyTSkalcvfurw(TSkalcvfurw *kalcvfurw_ps)
-{
- if (kalcvfurw_ps) {
- DestroyMatrix_lf(kalcvfurw_ps->V_dm);
- DestroyVector_lf(kalcvfurw_ps->ylhtran_dv);
- DestroyMatrix_lf(kalcvfurw_ps->Xrhtran_dm);
- DestroyVector_lf(kalcvfurw_ps->z10_dv);
- DestroyMatrix_lf(kalcvfurw_ps->P10_dm);
-
- DestroyVector_lf(kalcvfurw_ps->zupdate_dv);
- DestroyMatrix_lf(kalcvfurw_ps->Zpredtran_dm);
- DestroyCell_lf(kalcvfurw_ps->Ppred_dc);
- DestroyVector_lf(kalcvfurw_ps->ylhtranpred_dv);
-
- free(kalcvfurw_ps);
- return ((TSkalcvfurw *)NULL);
- }
- else return (kalcvfurw_ps);
-}
-
-
-void kalcvf_urw(TSkalcvfurw *kalcvfurw_ps, void *dummy_ps)
-{
- //See the notes of SWZ regarding the government's updating of the parameters in their Phillips-curve equation.
- //NOTE: make sure that the value of kalcvfurw_ps->sigmasq and other input values are given.
- int ti;
- double workd, workdenominv;
- //---
- int fss, kx;
- double sigmasq_fix = kalcvfurw_ps->sigmasq;
-// double sigmasq;
- TSdmatrix *V_dm;
- TSdmatrix *Zpredtran_dm;
- TSdcell *Ppred_dc;
- TSdvector *ylhtran_dv;
- TSdmatrix *Xrhtran_dm;
- //===
- TSdvector *workkxby1_dv = NULL; //kx-by-1.
-// TSdvector *work1kxby1_dv = NULL; //kx-by-1.
- TSdmatrix *workkxbykx_dm = NULL; //kx-by-kx symmetric and positive positive.
-// //===
-// TSdvector *zbefore_dv = CreateVector_lf(kalcvfurw_ps->kx);
-// TSdmatrix *Vbefore_dm = CreateMatrix_lf(kalcvfurw_ps->kx, kalcvfurw_ps->kx);
-// TSdvector *zafter_dv = CreateVector_lf(kalcvfurw_ps->kx);
-// TSdmatrix *Vafter_dm = CreateMatrix_lf(kalcvfurw_ps->kx, kalcvfurw_ps->kx);
- //******* WARNING: Some dangerous pointer movement to gain efficiency *******
-// double *yt_p;
-// double *Vbefore_p;
-// double *Vafter_p;
- TSdvector xt_sdv;
- TSdvector zbefore_sdv;
- //TSdmatrix Vbefore_sdm;
- TSdvector zafter_sdv;
- //TSdmatrix Vafter_sdm;
-
-
- if (!kalcvfurw_ps) fn_DisplayError(".../kalcvf_urw(): the input argument kalcvfurw_ps must be created");
- if (!kalcvfurw_ps->V_dm || !kalcvfurw_ps->ylhtran_dv || !kalcvfurw_ps->Xrhtran_dm || !kalcvfurw_ps->z10_dv || !kalcvfurw_ps->P10_dm)
- fn_DisplayError(".../kalcvf_urw(): input arguments kalcvfurw_ps->V_dm, kalcvfurw_ps->ylhtran_dv, kalcvfurw_ps->Xrhtran_dm, kalcvfurw_ps->z10_dv, kalcvfurw_ps->P10_dm must be given legal values");
- if (!(kalcvfurw_ps->P10_dm->flag & (M_SU | M_SL))) fn_DisplayError(".../kalcvf_urw(): the input argument kalcvfurw_ps->P10_dm must be symmetric");
- fss = kalcvfurw_ps->fss;
- kx = kalcvfurw_ps->kx;
- V_dm = kalcvfurw_ps->V_dm;
- Zpredtran_dm = kalcvfurw_ps->Zpredtran_dm;
- Ppred_dc = kalcvfurw_ps->Ppred_dc;
- ylhtran_dv = kalcvfurw_ps->ylhtran_dv;
- Xrhtran_dm = kalcvfurw_ps->Xrhtran_dm;
- //---
- xt_sdv.n = kx;
- xt_sdv.flag = V_DEF;
- zbefore_sdv.n = kx;
- zbefore_sdv.flag = V_DEF;
- zafter_sdv.n = kx;
- zafter_sdv.flag = V_DEF;
-
- //=== Memory allocation.
- workkxby1_dv = CreateVector_lf(kx);
- workkxbykx_dm = CreateMatrix_lf(kx, kx);
-
-
- //------- The first period (ti=0). -------
- zbefore_sdv.v = kalcvfurw_ps->z10_dv->v;
- zafter_sdv.v = Zpredtran_dm->M;
- xt_sdv.v = Xrhtran_dm->M;
- //---
-
- workd = ylhtran_dv->v[0] - (kalcvfurw_ps->ylhtranpred_dv->v[0]=VectorDotVector(&xt_sdv, &zbefore_sdv)); //y_t - x_t'*z_{t-1}.
- SymmatrixTimesVector(workkxby1_dv, kalcvfurw_ps->P10_dm, &xt_sdv, 1.0, 0.0); //P_{t|t-1} x_t;
-
- if (!kalcvfurw_ps->indx_tvsigmasq)
- workdenominv = 1.0/(sigmasq_fix + VectorDotVector(&xt_sdv, workkxby1_dv)); //1/[sigma^2 + x_t' P_{t|t-1} x_t]
- else if (kalcvfurw_ps->indx_tvsigmasq == 1) //See pp.37 and 37a in SWZ Learning NOTES.
- workdenominv = 1.0/(sigmasq_fix*square(kalcvfurw_ps->z10_dv->v[0]) + VectorDotVector(&xt_sdv, workkxby1_dv)); //1/[sigma^2 + x_t' P_{t|t-1} x_t];
- else {
- printf(".../kalman.c/kalcvf_urw(): Have not got time to deal with kalcvfurw_ps->indx_tvsigmasq defined in kalman.h other than 0 or 1");
- exit(EXIT_FAILURE);
- }
-
-
- //--- Updating z_{t+1|t}.
- CopyVector0(&zafter_sdv, &zbefore_sdv);
- VectorPlusMinusVectorUpdate(&zafter_sdv, workkxby1_dv, workd*workdenominv); //z_{t+1|t} = z_{t|t-1} + P_{t|t-1} x_t [y_t - x_t'*z_{t-1}] / [sigma^2 + x_t' P_{t|t-1} x_t];
- //--- Updating P_{t+1|t}.
- CopyMatrix0(workkxbykx_dm, V_dm);
- VectorTimesSelf(workkxbykx_dm, workkxby1_dv, -workdenominv, 1.0, (V_dm->flag & M_SU) ? 'U' : 'L');
- // - P_{t|t-1}*x_t * xt'*P_{t|t-1} / [sigma^2 + x_t' P_{t|t-1} x_t] + V;
- MatrixPlusMatrix(Ppred_dc->C[0], kalcvfurw_ps->P10_dm, workkxbykx_dm);
- //P_{t|t-1} - P_{t|t-1}*x_t * xt'*P_{t|t-1} / [sigma^2 + x_t' P_{t|t-1} x_t] + V;
- Ppred_dc->C[0]->flag = M_GE | M_SU | M_SL; //This is necessary because if P10_dm is initialized as diagonal, it will have M_GE | M_SU | M_SL | M_UT | M_LT,
- // which is no longer true for workkxbykx_dm and therefore gives Ppred_dc->C[0] with M_GE only as a result of MatrixPlusMatrix().
- //Done with all work* arrays.
-
- //------- The rest of the periods (ti=1:T-1). -------
- for (ti=1; ti<fss; ti++) {
- //NOTE: ti=0 has been taken care of outside of this loop.
- zbefore_sdv.v = Zpredtran_dm->M + (ti-1)*kx;
- zafter_sdv.v = Zpredtran_dm->M + ti*kx;
- xt_sdv.v = Xrhtran_dm->M + ti*kx;
- //---
- workd = ylhtran_dv->v[ti] - (kalcvfurw_ps->ylhtranpred_dv->v[ti]=VectorDotVector(&xt_sdv, &zbefore_sdv)); //y_t - x_t'*z_{t-1}.
- SymmatrixTimesVector(workkxby1_dv, Ppred_dc->C[ti-1], &xt_sdv, 1.0, 0.0); //P_{t|t-1} x_t;
- if (!kalcvfurw_ps->indx_tvsigmasq)
- workdenominv = 1.0/(sigmasq_fix + VectorDotVector(&xt_sdv, workkxby1_dv)); //1/[sigma^2 + x_t' P_{t|t-1} x_t]
- else if (kalcvfurw_ps->indx_tvsigmasq == 1) //See pp.37 and 37a in SWZ Learning NOTES.
- workdenominv = 1.0/(sigmasq_fix*square(zbefore_sdv.v[0]) + VectorDotVector(&xt_sdv, workkxby1_dv)); //1/[sigma^2 + x_t' P_{t|t-1} x_t]
- else {
- printf(".../kalman.c/kalcvf_urw(): Have not got time to deal with kalcvfurw_ps->indx_tvsigmasq defined in kalman.h other than 0 or 1");
- exit(EXIT_FAILURE);
- }
- //--- Updating z_{t+1|t}.
- CopyVector0(&zafter_sdv, &zbefore_sdv);
- VectorPlusMinusVectorUpdate(&zafter_sdv, workkxby1_dv, workd*workdenominv); //z_{t+1|t} = z_{t|t-1} + P_{t|t-1} x_t [y_t - x_t'*z_{t-1}] / [sigma^2 + x_t' P_{t|t-1} x_t];
- //--- Updating P_{t+1|t}.
- CopyMatrix0(workkxbykx_dm, V_dm);
- VectorTimesSelf(workkxbykx_dm, workkxby1_dv, -workdenominv, 1.0, (V_dm->flag & M_SU) ? 'U' : 'L');
- // - P_{t|t-1}*x_t * xt'*P_{t|t-1} / [sigma^2 + x_t' P_{t|t-1} x_t] + V;
- MatrixPlusMatrix(Ppred_dc->C[ti], Ppred_dc->C[ti-1], workkxbykx_dm);
- //P_{t|t-1} - P_{t|t-1}*x_t * xt'*P_{t|t-1} / [sigma^2 + x_t' P_{t|t-1} x_t] + V;
- Ppred_dc->C[ti]->flag = M_GE | M_SU | M_SL; //This is necessary because if P10_dm is initialized as diagonal, it will have M_GE | M_SU | M_SL | M_UT | M_LT,
- // which is no longer true for workkxbykx_dm and therefore gives Ppred_dc->C[0] with M_GE only as a result of MatrixPlusMatrix().
- //Done with all work* arrays.
- }
- CopyVector0(kalcvfurw_ps->zupdate_dv, &zafter_sdv);
- Zpredtran_dm->flag = M_GE;
- kalcvfurw_ps->ylhtranpred_dv->flag = V_DEF;
-
-// DestroyVector_lf(zbefore_dv);
-// DestroyMatrix_lf(Vbefore_dm);
-// DestroyVector_lf(zafter_dv);
-// DestroyMatrix_lf(Vafter_dm);
-
- DestroyVector_lf(workkxby1_dv);
-// DestroyVector_lf(work1kxby1_dv);
- DestroyMatrix_lf(workkxbykx_dm);
-}
-
-
-
-//-----------------------------------------------------------------------------------------------------------------------
-//-- General constant (known-time-varying) Kalman filter for DSGE models.
-//-----------------------------------------------------------------------------------------------------------------------
-struct TSkalfiltv_tag *CreateTSkalfiltv(int ny, int nz, int T)
-{
- int _i;
- //===
- TSivector *rows_iv = CreateVector_int(T);
- TSivector *cols_iv = CreateVector_int(T);
- //~~~ Creating the structure and initializing the NULL pointers.
- struct TSkalfiltv_tag *kalfiltv_ps = tzMalloc(1, struct TSkalfiltv_tag);
-
-
- //--- Default value.
- kalfiltv_ps->indxIni = 0; //1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- //0: using the unconditional mean for any given regime at time 0.
- //--- Other assignments.
- kalfiltv_ps->ny = ny;
- kalfiltv_ps->nz = nz;
- kalfiltv_ps->T = T;
-
-
-
- //--------- Creates memory and assigns values. The order matters.
- kalfiltv_ps->yt_dm = CreateMatrix_lf(ny, T);
- kalfiltv_ps->at_dm = CreateMatrix_lf(ny, T);
- //
- for (_i=T-1; _i>=0; _i--)
- {
- rows_iv->v[_i] = ny;
- cols_iv->v[_i] = nz;
- }
- rows_iv->flag = cols_iv->flag = V_DEF;
- kalfiltv_ps->Ht_dc = CreateCell_lf(rows_iv, cols_iv);
- //
- for (_i=T-1; _i>=0; _i--)
- {
- rows_iv->v[_i] = ny;
- cols_iv->v[_i] = ny;
- }
- kalfiltv_ps->Rt_dc = CreateCell_lf(rows_iv, cols_iv);
- //
- for (_i=T-1; _i>=0; _i--)
- {
- rows_iv->v[_i] = nz;
- cols_iv->v[_i] = ny;
- }
- kalfiltv_ps->Gt_dc = CreateCell_lf(rows_iv, cols_iv);
- //
- kalfiltv_ps->bt_dm = CreateMatrix_lf(nz, T);
- //
- for (_i=T-1; _i>=0; _i--)
- {
- rows_iv->v[_i] = nz;
- cols_iv->v[_i] = nz;
- }
- kalfiltv_ps->Ft_dc = CreateCell_lf(rows_iv, cols_iv);
- kalfiltv_ps->Vt_dc = CreateCell_lf(rows_iv, cols_iv);
- //
- kalfiltv_ps->z0_dv = CreateVector_lf(nz);
- kalfiltv_ps->P0_dm = CreateMatrix_lf(nz, nz);
-
-
- //---
- kalfiltv_ps->zt_tm1_dm = CreateMatrix_lf(nz, T);
- for (_i=T-1; _i>=0; _i--)
- {
- rows_iv->v[_i] = nz;
- cols_iv->v[_i] = nz;
- }
- kalfiltv_ps->Pt_tm1_dc = CreateCell_lf(rows_iv, cols_iv);
-
-
- //===
- DestroyVector_int(rows_iv);
- DestroyVector_int(cols_iv);
-
- return (kalfiltv_ps);
-
-}
-//---
-struct TSkalfiltv_tag *DestroyTSkalfiltv(struct TSkalfiltv_tag *kalfiltv_ps)
-{
- if (kalfiltv_ps)
- {
- //=== The order matters!
- DestroyMatrix_lf(kalfiltv_ps->yt_dm);
- DestroyMatrix_lf(kalfiltv_ps->at_dm);
- DestroyCell_lf(kalfiltv_ps->Ht_dc);
- DestroyCell_lf(kalfiltv_ps->Rt_dc);
- DestroyCell_lf(kalfiltv_ps->Gt_dc);
- //---
- DestroyMatrix_lf(kalfiltv_ps->bt_dm);
- DestroyCell_lf(kalfiltv_ps->Ft_dc);
- DestroyCell_lf(kalfiltv_ps->Vt_dc);
- //---
- DestroyVector_lf(kalfiltv_ps->z0_dv);
- DestroyMatrix_lf(kalfiltv_ps->P0_dm);
- //---
- DestroyMatrix_lf(kalfiltv_ps->zt_tm1_dm);
- DestroyCell_lf(kalfiltv_ps->Pt_tm1_dc);
-
-
- //---
- tzDestroy(kalfiltv_ps); //Must be freed last!
-
- return ((struct TSkalfiltv_tag *)NULL);
- }
- else return (kalfiltv_ps);
-};
-
-
-//-----------------------------------------------------------------------------------------------------------------------
-//-- Inputs for filter for Markov-switching DSGE models at any time t.
-//-----------------------------------------------------------------------------------------------------------------------
-struct TSkalfilmsinputs_1stapp_tag *CreateTSkalfilmsinputs_1stapp(int ny, int nz, int nst, int T)
-{
- //~~~ Creating the structure and initializing the NULL pointers.
- struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps = tzMalloc(1, struct TSkalfilmsinputs_1stapp_tag);
-
- //===
- TSivector *rows_iv = NULL;
- TSivector *cols_iv = NULL;
-
- //=== Default value.
- kalfilmsinputs_1stapp_ps->indxIni = 0; //1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- //0: using the unconditional mean for any given regime at time 0.
- kalfilmsinputs_1stapp_ps->indxDiffuse = 1; //1: using the diffuse condition for z_{1|0} and P_{1|0} (default option), according to Koopman and Durbin, "Filtering and Smoothing of State Vector for Diffuse State-Space Models," J. of Time Series Analysis, Vol 24(1), pp.85-99.
- //0: using the unconditional moments.
- kalfilmsinputs_1stapp_ps->DiffuseScale = 100.0;
- kalfilmsinputs_1stapp_ps->ztm1_track = -1;
- kalfilmsinputs_1stapp_ps->dtm1_track = -1;
-
- //--- Other key assignments.
- kalfilmsinputs_1stapp_ps->ny = ny;
- kalfilmsinputs_1stapp_ps->nz = nz;
- kalfilmsinputs_1stapp_ps->nst = nst;
- kalfilmsinputs_1stapp_ps->T = T;
-
- //--------- Creates memory and assigns values. The order matters.
- kalfilmsinputs_1stapp_ps->yt_dm = CreateMatrix_lf(ny, T);
- kalfilmsinputs_1stapp_ps->at_dm = CreateMatrix_lf(ny, nst);
- //
- rows_iv = CreateConstantVector_int(nst, ny);
- cols_iv = CreateConstantVector_int(nst, nz);
- kalfilmsinputs_1stapp_ps->Ht_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nst, ny);
- cols_iv = CreateConstantVector_int(nst, ny);
- kalfilmsinputs_1stapp_ps->Rt_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nst, nz);
- cols_iv = CreateConstantVector_int(nst, ny);
- kalfilmsinputs_1stapp_ps->Gt_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- kalfilmsinputs_1stapp_ps->bt_dm = CreateMatrix_lf(nz, nst);
- //
- rows_iv = CreateConstantVector_int(nst, nz);
- cols_iv = CreateConstantVector_int(nst, nz);
- kalfilmsinputs_1stapp_ps->Ft_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nst, nz);
- cols_iv = CreateConstantVector_int(nst, nz);
- kalfilmsinputs_1stapp_ps->Vt_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- kalfilmsinputs_1stapp_ps->z0_dm = CreateMatrix_lf(nz, nst); //nz-by-nst.
- kalfilmsinputs_1stapp_ps->z0_0_dm = CreateMatrix_lf(nz, nst); //nz-by-nst.
- //
- rows_iv = CreateConstantVector_int(nst, nz);
- cols_iv = CreateConstantVector_int(nst, nz);
- kalfilmsinputs_1stapp_ps->P0_dc = CreateCell_lf(rows_iv, cols_iv); //nz-by-nz-by-nst.
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
-
- //--- For output arguments.
- rows_iv = CreateConstantVector_int(T+1, nz);
- cols_iv = CreateConstantVector_int(T+1, nst);
- kalfilmsinputs_1stapp_ps->zt_tm1_dc = CreateCell_lf(rows_iv, cols_iv); //nz-by-nst-by-(T+1).
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nst, nz);
- cols_iv = CreateConstantVector_int(nst, nz);
- kalfilmsinputs_1stapp_ps->Pt_tm1_d4 = CreateFourth_lf(T+1, rows_iv, cols_iv); //nz-by-nz-by-nst-by-(T+1).
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nst, nz);
- cols_iv = CreateConstantVector_int(nst, ny);
- kalfilmsinputs_1stapp_ps->PHtran_tdata_d4 = CreateFourth_lf(T, rows_iv, cols_iv); //nz-by-ny-by-nst-T, saved only for updating Kalman filter Updatekalfilms_1stapp().
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(T, ny);
- cols_iv = CreateConstantVector_int(T, nst);
- kalfilmsinputs_1stapp_ps->etdata_dc = CreateCell_lf(rows_iv, cols_iv); //ny-by-nst-by-T, used for updating Kalman filter Updatekalfilms_1stapp().
- rows_iv = CreateConstantVector_int(T, ny);
- cols_iv = CreateConstantVector_int(T, nst);
- //
- rows_iv = CreateConstantVector_int(nst, ny);
- cols_iv = CreateConstantVector_int(nst, ny);
- kalfilmsinputs_1stapp_ps->Dtdata_d4 = CreateFourth_lf(T, rows_iv, cols_iv); //ny-by-ny-nst-by-T, used for updating Kalman filter Updatekalfilms_1stapp().
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
-
- return (kalfilmsinputs_1stapp_ps);
-}
-//---
-struct TSkalfilmsinputs_1stapp_tag *DestroyTSkalfilmsinputs_1stapp(struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps)
-{
- if (kalfilmsinputs_1stapp_ps)
- {
- //=== The order matters!
- DestroyMatrix_lf(kalfilmsinputs_1stapp_ps->yt_dm);
- DestroyMatrix_lf(kalfilmsinputs_1stapp_ps->at_dm);
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->Ht_dc);
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->Rt_dc);
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->Gt_dc);
- //---
- DestroyMatrix_lf(kalfilmsinputs_1stapp_ps->bt_dm);
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->Ft_dc);
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->Vt_dc);
- //---
- DestroyMatrix_lf(kalfilmsinputs_1stapp_ps->z0_dm);
- DestroyMatrix_lf(kalfilmsinputs_1stapp_ps->z0_0_dm);
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->P0_dc);
- //---
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->zt_tm1_dc);
- DestroyFourth_lf(kalfilmsinputs_1stapp_ps->Pt_tm1_d4);
- DestroyFourth_lf(kalfilmsinputs_1stapp_ps->PHtran_tdata_d4);
- DestroyCell_lf(kalfilmsinputs_1stapp_ps->etdata_dc);
- DestroyFourth_lf(kalfilmsinputs_1stapp_ps->Dtdata_d4);
- //---
- tzDestroy(kalfilmsinputs_1stapp_ps); //Must be freed last!
-
- return ((struct TSkalfilmsinputs_1stapp_tag *)NULL);
- }
- else return (kalfilmsinputs_1stapp_ps);
-};
-
-
-//-----------------------------------------------------------------------------------------------------------------------
-//-- OLD Code: Inputs for filter for Markov-switching DSGE models at any time t.
-//-----------------------------------------------------------------------------------------------------------------------
-struct TSkalfilmsinputs_tag *CreateTSkalfilmsinputs(int ny, int nz, int nRc, int nRstc, int nRv, int indxIndRegimes, int T)
-{
- //~~~ Creating the structure and initializing the NULL pointers.
- struct TSkalfilmsinputs_tag *kalfilmsinputs_ps = tzMalloc(1, struct TSkalfilmsinputs_tag);
-
- //===
- TSivector *rows_iv = NULL;
- TSivector *cols_iv = NULL;
-
- //--- Default value.
- kalfilmsinputs_ps->indxIni = 0; //1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- //0: using the unconditional mean for any given regime at time 0.
- //--- Other assignments.
- kalfilmsinputs_ps->ny = ny;
- kalfilmsinputs_ps->nz = nz;
- kalfilmsinputs_ps->nRc = nRc;
- kalfilmsinputs_ps->nRstc = nRstc;
- kalfilmsinputs_ps->nRv = nRv;
- kalfilmsinputs_ps->indxIndRegimes = indxIndRegimes;
- kalfilmsinputs_ps->T = T;
-
-
- //--------- Creates memory and assigns values. The order matters.
- kalfilmsinputs_ps->yt_dm = CreateMatrix_lf(ny, T);
- kalfilmsinputs_ps->at_dm = CreateMatrix_lf(ny, nRc);
- //
- rows_iv = CreateConstantVector_int(nRc, ny);
- cols_iv = CreateConstantVector_int(nRc, nz);
- kalfilmsinputs_ps->Ht_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nRv, ny);
- cols_iv = CreateConstantVector_int(nRv, ny);
- kalfilmsinputs_ps->Rt_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nRv, nz);
- cols_iv = CreateConstantVector_int(nRv, ny);
- kalfilmsinputs_ps->Gt_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- kalfilmsinputs_ps->bt_dm = CreateMatrix_lf(nz, nRc);
- //
- rows_iv = CreateConstantVector_int(nRc, nz);
- cols_iv = CreateConstantVector_int(nRc, nz);
- kalfilmsinputs_ps->Ft_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nRv, nz);
- cols_iv = CreateConstantVector_int(nRv, nz);
- kalfilmsinputs_ps->Vt_dc = CreateCell_lf(rows_iv, cols_iv);
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- if (indxIndRegimes)
- {
- kalfilmsinputs_ps->z0_dm = CreateMatrix_lf(nz, nRc*nRv); //nz-by-nRc*nRv if indxIndRegimes == 1 or nz-by-nRv if indxIndRegimes == 0.
- //
- rows_iv = CreateConstantVector_int(nRc*nRv, nz);
- cols_iv = CreateConstantVector_int(nRc*nRv, nz);
- kalfilmsinputs_ps->P0_dc = CreateCell_lf(rows_iv, cols_iv); //nz-by-nz-by-nRc*nRv if indxIndRegimes == 1 or nz-by-nz-by-nRv if indxIndRegimes == 0.
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- }
- else
- {
- if (nRstc != nRv) fn_DisplayError("kalman.c/CreateTSkalfilmsinputs(): nRstc must equal to nRv when indxIndRegimes==0");
- kalfilmsinputs_ps->z0_dm = CreateMatrix_lf(nz, nRv); //nz-by-nRc*nRv if indxIndRegimes == 1 or nz-by-nRv if indxIndRegimes == 0.
- //
- rows_iv = CreateConstantVector_int(nRv, nz);
- cols_iv = CreateConstantVector_int(nRv, nz);
- kalfilmsinputs_ps->P0_dc = CreateCell_lf(rows_iv, cols_iv); //nz-by-nz-by-nRc*nRv if indxIndRegimes == 1 or nz-by-nz-by-nRv if indxIndRegimes == 0.
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- }
- //--- For output arguments.
- if (indxIndRegimes)
- {
- rows_iv = CreateConstantVector_int(T, nz);
- cols_iv = CreateConstantVector_int(T, nRc*nRv);
- kalfilmsinputs_ps->zt_tm1_dc = CreateCell_lf(rows_iv, cols_iv); //nz-by-nRc*nRv-by-T if indxIndRegimes==1, nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nRc*nRv, nz);
- cols_iv = CreateConstantVector_int(nRc*nRv, nz);
- kalfilmsinputs_ps->Pt_tm1_d4 = CreateFourth_lf(T, rows_iv, cols_iv); //nz-by-nz-by-nRc*nRv-T if indxIndRegimes==1, nz-by-nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- }
- else
- {
- if (nRstc != nRv) fn_DisplayError("kalman.c/CreateTSkalfilmsinputs(): nRstc must equal to nRv when indxIndRegimes==0");
- rows_iv = CreateConstantVector_int(T, nz);
- cols_iv = CreateConstantVector_int(T, nRv);
- kalfilmsinputs_ps->zt_tm1_dc = CreateCell_lf(rows_iv, cols_iv); //nz-by-nRc*nRv-by-T if indxIndRegimes==1, nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- //
- rows_iv = CreateConstantVector_int(nRv, nz);
- cols_iv = CreateConstantVector_int(nRv, nz);
- kalfilmsinputs_ps->Pt_tm1_d4 = CreateFourth_lf(T, rows_iv, cols_iv); //nz-by-nz-by-nRc*nRv-T if indxIndRegimes==1, nz-by-nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- rows_iv = DestroyVector_int(rows_iv);
- cols_iv = DestroyVector_int(cols_iv);
- }
-
-
- //===
- DestroyVector_int(rows_iv);
- DestroyVector_int(cols_iv);
-
- return (kalfilmsinputs_ps);
-
-}
-//---
-struct TSkalfilmsinputs_tag *DestroyTSkalfilmsinputs(struct TSkalfilmsinputs_tag *kalfilmsinputs_ps)
-{
- if (kalfilmsinputs_ps)
- {
- //=== The order matters!
- DestroyMatrix_lf(kalfilmsinputs_ps->yt_dm);
- DestroyMatrix_lf(kalfilmsinputs_ps->at_dm);
- DestroyCell_lf(kalfilmsinputs_ps->Ht_dc);
- DestroyCell_lf(kalfilmsinputs_ps->Rt_dc);
- DestroyCell_lf(kalfilmsinputs_ps->Gt_dc);
- //---
- DestroyMatrix_lf(kalfilmsinputs_ps->bt_dm);
- DestroyCell_lf(kalfilmsinputs_ps->Ft_dc);
- DestroyCell_lf(kalfilmsinputs_ps->Vt_dc);
- //---
- DestroyMatrix_lf(kalfilmsinputs_ps->z0_dm);
- DestroyCell_lf(kalfilmsinputs_ps->P0_dc);
- //---
- DestroyCell_lf(kalfilmsinputs_ps->zt_tm1_dc);
- DestroyFourth_lf(kalfilmsinputs_ps->Pt_tm1_d4);
- //---
- tzDestroy(kalfilmsinputs_ps); //Must be freed last!
-
- return ((struct TSkalfilmsinputs_tag *)NULL);
- }
- else return (kalfilmsinputs_ps);
-};
-
-
-#define LOG2PI (1.837877066409345e+000) //log(2*pi)
-//-----------------------------------------------------
-//-- Constant-parameters (known-time-varying) Kalman filter
-//-----------------------------------------------------
-double tz_kalfiltv(struct TSkalfiltv_tag *kalfiltv_ps)
-{
- //General constant (known-time-varying) Kalman filter for DSGE models (conditional on all the parameters).
- // It computes a sequence of one-step predictions and their covariance matrices, and the log likelihood.
- // The function uses a forward recursion algorithm. See also the Matlab function fn_kalfil_tv.m
- //
- // State space model is defined as follows:
- // y(t) = a(t) + H(t)*z(t) + eps(t) (observation or measurement equation)
- // z(t) = b(t) + F(t)*z(t) + eta(t) (state or transition equation)
- // where a(t), H(t), b(t), and F(t) depend on s_t that follows a Markov-chain process and are taken as given.
- //
- // Inputs are as follows:
- // Y_T is a n_y-by-T matrix containing data [y(1), ... , y(T)].
- // a is an n_y-by-T matrix of time-varying input vectors in the measurement equation.
- // H is an n_y-by-n_z-by-T 3-D of time-varying matrices in the measurement equation.
- // R is an n_y-by-n_y-by-T 3-D of time-varying covariance matrices for the error in the measurement equation.
- // G is an n_z-by-n_y-by-T 3-D of time-varying E(eta_t * eps_t').
- // ------
- // b is an n_z-by-T matrix of time-varying input vectors in the state equation with b(:,1) as an initial condition.
- // F is an n_z-by-n_z-by-T 3-D of time-varying transition matrices in the state equation with F(:,:,1) as an initial condition.
- // V is an n_z-by-n_z-by-T 3-D of time-varying covariance matrices for the error in the state equation with V(:,:,1) as an initial condition.
- // ------
- // indxIni: 1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- // 0: using the unconditional mean for any given regime at time 0.
- // z0 is an n_z-by-1 vector of initial condition when indxIni=1. (Do not enter if indxIni=0.)
- // P0 is an n_z-by-n_z matrix of initial condition when indxIni=1. (Do not enter if indxIni=0.)
- //
- // Outputs are as follows:
- // loglh is a value of the log likelihood function of the state-space model
- // under the assumption that errors are multivariate Gaussian.
- // zt_tm1 is an n_z-by-T matrices of one-step predicted state vectors with z0_0m1 as an initial condition (base-0 first element)
- // and with z_{T|T-1} as the last element. Thus, we can use it as a base-1 vector.
- // Pt_tm1 is an n_z-by-n_z-by-T 3-D of covariance matrices of zt_tm1 with P0_0m1 as though it were a initial condition
- // and with P_{T|T-1} as the last element. Thus, we can use it as though it were a base-1 cell.
- //
- // The initial state vector and its covariance matrix are computed under the bounded (stationary) condition:
- // z0_0m1 = (I-F(:,:,1))\b(:,1)
- // vec(P0_0m1) = (I-kron(F(:,:,1),F(:,:,1)))\vec(V(:,:,1))
- // Note that all eigenvalues of the matrix F(:,:,1) are inside the unit circle when the state-space model is bounded (stationary).
- //
- // March 2007, written by Tao Zha
- // See Hamilton's book ([13.2.13] -- [13.2.22]), Harvey (pp.100-106), and LiuWZ Model I NOTES pp.001-003.
-
- int T = kalfiltv_ps->T;
- int Tp1 = T + 1;
- int ny = kalfiltv_ps->ny;
- int nz = kalfiltv_ps->nz;
- int indx_badlh = 0; //1: bad likelihood with, say, -infinity of the LH value.
- int tdata, ti;
- //--- Work arguments.
- int nz2 = square(nz);
- TSdmatrix *Wnzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *Wnz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdmatrix *W2nz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdvector *wP0_dv = CreateVector_lf(nz2);
- //+
- TSdvector yt_sdv, at_sdv, zt_tm1_sdv, ztp1_t_sdv, btp1_sdv; //double loglh_tdata; //logdetDtdata.
- TSdvector *wny_dv = CreateVector_lf(ny);
- TSdmatrix *Wnzbyny_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *W2nzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *PHtran_tdata_dm = CreateMatrix_lf(nz,ny);
- TSdvector *etdata_dv = CreateVector_lf(ny);
- TSdmatrix *Dtdata_dm = CreateMatrix_lf(ny,ny);
- TSdmatrix *Kt_tdata0_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *Kt_tdata_dm = CreateMatrix_lf(nz,ny);
- //--- For eigenvalue decompositions
- int ki;
- int errflag;
- double eigmax, logdet_Dtdata;
- TSdzvector *evals_dzv = NULL;
- TSdvector *evals_abs_dv = NULL; //Absolute eigenvalues.
- //--- Input arguments.
- TSdmatrix *yt_dm = kalfiltv_ps->yt_dm; //ny-by-T.
- TSdmatrix *at_dm = kalfiltv_ps->at_dm; //ny-by-T.
- TSdcell *Ht_dc = kalfiltv_ps->Ht_dc; //ny-by-nz-by-T.
- TSdcell *Rt_dc = kalfiltv_ps->Rt_dc; //ny-by-ny-by-T. Covariance matrix for the measurement equation.
- TSdcell *Gt_dc = kalfiltv_ps->Gt_dc; //nz-by-ny-by-T. Cross-covariance.
- //
- TSdmatrix *bt_dm = kalfiltv_ps->bt_dm; //nz-by-T.
- TSdcell *Ft_dc = kalfiltv_ps->Ft_dc; //nz-by-nz-by-T.
- TSdcell *Vt_dc = kalfiltv_ps->Vt_dc; //nz-by-nz-by-T. Covariance matrix for the state equation.
- //
- TSdvector *z0_dv = kalfiltv_ps->z0_dv; //nz-by-1;
- TSdmatrix *P0_dm = kalfiltv_ps->P0_dm; //nz-by-nz.
- //--- Output arguments.
- double loglh; //log likelihood.
- TSdmatrix *zt_tm1_dm = kalfiltv_ps->zt_tm1_dm; //nz-by-T.
- TSdcell *Pt_tm1_dc = kalfiltv_ps->Pt_tm1_dc; //nz-by-nz-T.
-
-
-
- //=== Initializing.
- if (!kalfiltv_ps->indxIni)
- {
- InitializeDiagonalMatrix_lf(Wnzbynz_dm, 1.0); //To be used for I(nz) -
- InitializeDiagonalMatrix_lf(Wnz2bynz2_dm, 1.0); //To be used for I(nz2) -
-
- //=== Eigenanalysis to determine the roots to ensure boundedness.
- evals_dzv = CreateVector_dz(nz);
- evals_abs_dv = CreateVector_lf(nz);
- errflag = eigrgen(evals_dzv, (TSdzmatrix *)NULL, (TSdzmatrix *)NULL, Ft_dc->C[0]);
- if (errflag) fn_DisplayError("tz_kalfiltv() in kalman.c: eigen decomposition failed");
- for (ki=nz-1; ki>=0; ki--) evals_abs_dv->v[ki] = sqrt(square(evals_dzv->real->v[ki]) + square(evals_dzv->imag->v[ki]));
- evals_abs_dv->flag = V_DEF;
- eigmax = MaxVector(evals_abs_dv);
- if (eigmax < (1.0+1.0e-14))
- {
- //--- Getting z0_dv: zt_tm1(:,1) = (eye(n_z)-F(:,:,1))\b(:,1);
- MatrixMinusMatrix(Wnzbynz_dm, Wnzbynz_dm, Ft_dc->C[0]);
- CopySubmatrix2vector(z0_dv, 0, bt_dm, 0, 0, bt_dm->nrows);
- bdivA_rgens(z0_dv, z0_dv, '\\', Wnzbynz_dm);
- //Done with Wnzbynz_dm.
- //--- Getting P0_dm: Pt_tm1(:,:,1) = reshape((eye(n_z^2)-kron(F(:,:,1),F(:,:,1)))\V1(:),n_z,n_z);
- tz_kron(W2nz2bynz2_dm, Ft_dc->C[0], Ft_dc->C[0]);
- MatrixMinusMatrix(Wnz2bynz2_dm, Wnz2bynz2_dm, W2nz2bynz2_dm);
- CopySubmatrix2vector(wP0_dv, 0, Vt_dc->C[0], 0, 0, nz2);
- bdivA_rgens(wP0_dv, wP0_dv, '\\', Wnz2bynz2_dm);
- CopySubvector2matrix_unr(P0_dm, 0, 0, wP0_dv, 0, nz2);
- //Done with all w*_dv and W*_dm.
- }
- else
- {
- fprintf(stdout, "Fatal error: tz_kalfiltv() in kalman.c: the system is non-stationary solutions\n"
- " and the initial conditions must be supplied by, say, input arguments");
- fflush(stdout);
- exit( EXIT_FAILURE );
- }
- }
- CopySubvector2matrix(zt_tm1_dm, 0, 0, z0_dv, 0, z0_dv->n);
- CopyMatrix0(Pt_tm1_dc->C[0], P0_dm);
-
- //====== See p.002 in LiuWZ. ======
- at_sdv.n = yt_sdv.n = yt_dm->nrows;
- at_sdv.flag = yt_sdv.flag = V_DEF;
- zt_tm1_sdv.n = ztp1_t_sdv.n = zt_tm1_dm->nrows;
- zt_tm1_sdv.flag = ztp1_t_sdv.flag = V_DEF;
- btp1_sdv.n = bt_dm->nrows;
- btp1_sdv.flag = V_DEF;
- loglh = 0.0;
- for (tdata=0; tdata<T; tdata++ )
- {
- //Base-0 timing.
- ti = tdata + 1; //Next period.
-
- //--- Setup.
- MatrixTimesMatrix(PHtran_tdata_dm, Pt_tm1_dc->C[tdata], Ht_dc->C[tdata], 1.0, 0.0, 'N', 'T');
-
- //--- Data.
- //- etdata = Y_T(:,tdata) - a(:,tdata) - Htdata*ztdata;
- yt_sdv.v = yt_dm->M + tdata*yt_dm->nrows;
- at_sdv.v = at_dm->M + tdata*at_dm->nrows;
- zt_tm1_sdv.v = zt_tm1_dm->M + tdata*zt_tm1_dm->nrows;
- VectorMinusVector(etdata_dv, &yt_sdv, &at_sdv);
- MatrixTimesVector(etdata_dv, Ht_dc->C[tdata], &zt_tm1_sdv, -1.0, 1.0, 'N');
- //+ Dtdata = Htdata*PHtran_tdata + R(:,:,tdata);
- CopyMatrix0(Dtdata_dm, Rt_dc->C[tdata]);
- MatrixTimesMatrix(Dtdata_dm, Ht_dc->C[tdata], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- ScalarTimesMatrixSquare(Dtdata_dm, 0.5, Dtdata_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Dtdata_dm->flag = Dtdata_dm->flag | M_SU | M_SL;
-
- //--- Forming the log likelihood.
- if (!isfinite(logdet_Dtdata=logdetspd(Dtdata_dm))) return (kalfiltv_ps->loglh = -NEARINFINITY);
- bdivA_rgens(wny_dv, etdata_dv, '/', Dtdata_dm);
- loglh += -(0.5*ny)*LOG2PI - 0.5*logdet_Dtdata - 0.5*VectorDotVector(wny_dv, etdata_dv);
- //loglh += -(0.5*ny)*LOG2PI - 0.5*logdeterminant(Dtdata_dm) - 0.5*VectorDotVector(wny_dv, etdata_dv);
- //Done with all w*_dv.
-
-
- //--- Updating zt_tm1_dm and Pt_tm1_dc by ztp1_t_sdv and Pt_tm1_dc->C[ti].
- if (ti<T)
- {
- //Updating only up to tdata=T-2. The values at ti=T or tdata=T-1 will not be used in the likelihood function.
-
- //- Kt_tdata = (Ft*PHtran_tdata+G(:,:,tdata))/Dtdata;
- CopyMatrix0(Kt_tdata0_dm, Gt_dc->C[tdata]);
- MatrixTimesMatrix(Kt_tdata0_dm, Ft_dc->C[ti], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- BdivA_rrect(Kt_tdata_dm, Kt_tdata0_dm, '/', Dtdata_dm);
- //+ zt_tm1(:,t) = b(:,t) + Ft*zt_tm1(:,tdata) + Kt_tdata*etdata;
- ztp1_t_sdv.v = zt_tm1_dm->M + ti*zt_tm1_dm->nrows;
- MatrixTimesVector(&ztp1_t_sdv, Ft_dc->C[ti], &zt_tm1_sdv, 1.0, 0.0, 'N');
- MatrixTimesVector(&ztp1_t_sdv, Kt_tdata_dm, etdata_dv, 1.0, 1.0, 'N');
- btp1_sdv.v = bt_dm->M + ti*btp1_sdv.n;
- VectorPlusMinusVectorUpdate(&ztp1_t_sdv, &btp1_sdv, 1.0);
- //+ Pt_tm1(:,:,t) = Ft*Ptdata*Fttran - Kt_tdata*Dtdata*Kt_tdatatran + V(:,:,t);
- CopyMatrix0(Pt_tm1_dc->C[ti], Vt_dc->C[ti]);
- MatrixTimesMatrix(Wnzbyny_dm, Kt_tdata_dm, Dtdata_dm, 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(Wnzbynz_dm, Wnzbyny_dm, Kt_tdata_dm, 1.0, 0.0, 'N', 'T');
- MatrixPlusMinusMatrixUpdate(Pt_tm1_dc->C[ti], Wnzbynz_dm, -1.0);
- //Done with all W*_dm.
- MatrixTimesMatrix(Wnzbynz_dm, Ft_dc->C[ti], Pt_tm1_dc->C[tdata], 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(W2nzbynz_dm, Wnzbynz_dm, Ft_dc->C[ti], 1.0, 0.0, 'N', 'T');
- MatrixPlusMatrixUpdate(Pt_tm1_dc->C[ti], W2nzbynz_dm);
- //Done with all W*_dm.
- }
- }
- zt_tm1_dm->flag = M_GE;
-
- //===
- DestroyVector_dz(evals_dzv);
- DestroyVector_lf(evals_abs_dv);
- DestroyMatrix_lf(Wnzbynz_dm);
- DestroyMatrix_lf(Wnz2bynz2_dm);
- DestroyMatrix_lf(W2nz2bynz2_dm);
- DestroyVector_lf(wP0_dv);
- //
- DestroyVector_lf(wny_dv);
- DestroyMatrix_lf(Wnzbyny_dm);
- DestroyMatrix_lf(W2nzbynz_dm);
- DestroyMatrix_lf(PHtran_tdata_dm);
- DestroyVector_lf(etdata_dv);
- DestroyMatrix_lf(Dtdata_dm);
- DestroyMatrix_lf(Kt_tdata0_dm);
- DestroyMatrix_lf(Kt_tdata_dm);
-
- return (kalfiltv_ps->loglh = loglh);
-}
-/**
-double tz_kalfiltv(struct TSkalfiltv_tag *kalfiltv_ps)
-{
- //This function is used to test tz_logTimetCondLH_kalfiltv().
- int T = kalfiltv_ps->T;
- int tdata;
- double loglh;
-
- loglh = 0.0;
- for (tdata=0; tdata<T; tdata++) loglh += tz_logTimetCondLH_kalfiltv(0, tdata+1, kalfiltv_ps);
-
- return (loglh);
-}
-/**/
-//-----------------------------------------------------
-//-- Updating Kalman filter at time t for constant-parameters (or known-time-varying) Kalman filter.
-//-----------------------------------------------------
-double tz_logTimetCondLH_kalfiltv(int st, int inpt, struct TSkalfiltv_tag *kalfiltv_ps)
-{
- //st: base-0 grand regime at time t, which is just a dummy for this constant-parameter function in order to use
- // Waggoner's automatic functions.
- //inpt: base-1 in the sense that inpt>=1 to deal with the time series situation where S_T is (T+1)-by-1 and Y_T is T+nlags_max-by-1.
- // The 1st element for S_T is S_T[1] while S_T[0] is s_0 (initial condition).
- // The 1st element for Y_T, however, is Y_T[nlags_max+1-1].
- //See (42.3) on p.42 in the SWZII NOTES.
- //
- //log LH at time t for constant (known-time-varying) Kalman-filter DSGE models (conditional on all the parameters).
- // It computes a sequence of one-step predictions and their covariance matrices, and the log likelihood at time t.
- // The function uses a forward recursion algorithm. See also the Matlab function fn_kalfil_tv.m
- //
- // State space model is defined as follows:
- // y(t) = a(t) + H(t)*z(t) + eps(t) (observation or measurement equation)
- // z(t) = b(t) + F(t)*z(t) + eta(t) (state or transition equation)
- // where a(t), H(t), b(t), and F(t) depend on s_t that follows a Markov-chain process and are taken as given.
- //
- // Inputs are as follows:
- // Y_T is a n_y-by-T matrix containing data [y(1), ... , y(T)].
- // a is an n_y-by-T matrix of time-varying input vectors in the measurement equation.
- // H is an n_y-by-n_z-by-T 3-D of time-varying matrices in the measurement equation.
- // R is an n_y-by-n_y-by-T 3-D of time-varying covariance matrices for the error in the measurement equation.
- // G is an n_z-by-n_y-by-T 3-D of time-varying E(eta_t * eps_t').
- // ------
- // b is an n_z-by-T matrix of time-varying input vectors in the state equation with b(:,1) as an initial condition.
- // F is an n_z-by-n_z-by-T 3-D of time-varying transition matrices in the state equation with F(:,:,1) as an initial condition.
- // V is an n_z-by-n_z-by-T 3-D of time-varying covariance matrices for the error in the state equation with V(:,:,1) as an initial condition.
- // ------
- // indxIni: 1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- // 0: using the unconditional mean for any given regime at time 0.
- // z0 is an n_z-by-1 vector of initial condition when indxIni=1. (Value to be assigned if indxIni=0.)
- // P0 is an n_z-by-n_z matrix of initial condition when indxIni=1. (Value to be assigned if indxIni=0.)
- //
- // Outputs are as follows:
- // loglh is a value of the log likelihood function of the state-space model
- // under the assumption that errors are multivariate Gaussian.
- // zt_tm1 is an n_z-by-T matrices of one-step predicted state vectors with z0_0m1 as an initial condition (base-0 first element)
- // and with z_{T|T-1} as the last element. Thus, we can use it as a base-1 vector.
- // Pt_tm1 is an n_z-by-n_z-by-T 3-D of covariance matrices of zt_tm1 with P0_0m1 as though it were a initial condition
- // and with P_{T|T-1} as the last element. Thus, we can use it as though it were a base-1 cell.
- //
- // The initial state vector and its covariance matrix are computed under the bounded (stationary) condition:
- // z0_0m1 = (I-F(:,:,1))\b(:,1)
- // vec(P0_0m1) = (I-kron(F(:,:,1),F(:,:,1)))\vec(V(:,:,1))
- // Note that all eigenvalues of the matrix F(:,:,1) are inside the unit circle when the state-space model is bounded (stationary).
- //
- // April 2008, written by Tao Zha
- // See Hamilton's book ([13.2.13] -- [13.2.22]), Harvey (pp.100-106), and LiuWZ Model I NOTES pp.001-003.
-
- //--- Output arguments.
- double loglh_timet; //log likelihood at time t.
- TSdmatrix *zt_tm1_dm = kalfiltv_ps->zt_tm1_dm; //nz-by-T.
- TSdcell *Pt_tm1_dc = kalfiltv_ps->Pt_tm1_dc; //nz-by-nz-T.
- //--- Input arguments.
- int tdata, tp1;
- TSdvector *z0_dv = kalfiltv_ps->z0_dv; //nz-by-1;
- TSdmatrix *P0_dm = kalfiltv_ps->P0_dm; //nz-by-nz.
- int T = kalfiltv_ps->T;
- int ny = kalfiltv_ps->ny;
- int nz = kalfiltv_ps->nz;
- //--- Work arguments.
- int nz2 = square(nz);
- TSdmatrix *Wnzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *Wnz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdmatrix *W2nz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdvector *wP0_dv = CreateVector_lf(nz2);
- //+
- TSdvector yt_sdv, at_sdv, zt_tm1_sdv, ztp1_t_sdv, btp1_sdv;
- TSdvector *wny_dv = CreateVector_lf(ny);
- TSdmatrix *Wnzbyny_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *W2nzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *PHtran_tdata_dm = CreateMatrix_lf(nz,ny);
- TSdvector *etdata_dv = CreateVector_lf(ny);
- TSdmatrix *Dtdata_dm = CreateMatrix_lf(ny,ny);
- TSdmatrix *Kt_tdata0_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *Kt_tdata_dm = CreateMatrix_lf(nz,ny);
- //--- For eigenvalue decompositions
- int ki;
- int errflag;
- double eigmax, logdet_Dtdata;
- TSdzvector *evals_dzv = NULL;
- TSdvector *evals_abs_dv = NULL; //Absolute eigenvalues.
- //--- Input arguments.
- TSdmatrix *yt_dm = kalfiltv_ps->yt_dm; //ny-by-T.
- TSdmatrix *at_dm = kalfiltv_ps->at_dm; //ny-by-T.
- TSdcell *Ht_dc = kalfiltv_ps->Ht_dc; //ny-by-nz-by-T.
- TSdcell *Rt_dc = kalfiltv_ps->Rt_dc; //ny-by-ny-by-T. Covariance matrix for the measurement equation.
- TSdcell *Gt_dc = kalfiltv_ps->Gt_dc; //nz-by-ny-by-T. Cross-covariance.
- //
- TSdmatrix *bt_dm = kalfiltv_ps->bt_dm; //nz-by-T.
- TSdcell *Ft_dc = kalfiltv_ps->Ft_dc; //nz-by-nz-by-T.
- TSdcell *Vt_dc = kalfiltv_ps->Vt_dc; //nz-by-nz-by-T. Covariance matrix for the state equation.
- //
-
-
- tdata = (tp1=inpt) - 1; //Base-0 time.
-
- //======= Initial condition. =======
- if (tdata==0)
- {
- //=== Initializing.
- if (!kalfiltv_ps->indxIni)
- {
- InitializeDiagonalMatrix_lf(Wnzbynz_dm, 1.0); //To be used for I(nz) -
- InitializeDiagonalMatrix_lf(Wnz2bynz2_dm, 1.0); //To be used for I(nz2) -
-
- //=== Eigenanalysis to determine the roots to ensure boundedness.
- evals_dzv = CreateVector_dz(nz);
- evals_abs_dv = CreateVector_lf(nz);
- errflag = eigrgen(evals_dzv, (TSdzmatrix *)NULL, (TSdzmatrix *)NULL, Ft_dc->C[0]);
- if (errflag) fn_DisplayError("tz_logTimetCondLH_kalfiltv() in kalman.c: eigen decomposition failed");
- for (ki=nz-1; ki>=0; ki--) evals_abs_dv->v[ki] = sqrt(square(evals_dzv->real->v[ki]) + square(evals_dzv->imag->v[ki]));
- evals_abs_dv->flag = V_DEF;
- eigmax = MaxVector(evals_abs_dv);
- if (eigmax < (1.0+1.0e-14))
- {
- //--- Getting z0_dv: zt_tm1(:,1) = (eye(n_z)-F(:,:,1))\b(:,1);
- MatrixMinusMatrix(Wnzbynz_dm, Wnzbynz_dm, Ft_dc->C[0]);
- CopySubmatrix2vector(z0_dv, 0, bt_dm, 0, 0, bt_dm->nrows);
- bdivA_rgens(z0_dv, z0_dv, '\\', Wnzbynz_dm);
- //Done with Wnzbynz_dm.
- //--- Getting P0_dm: Pt_tm1(:,:,1) = reshape((eye(n_z^2)-kron(F(:,:,1),F(:,:,1)))\V1(:),n_z,n_z);
- tz_kron(W2nz2bynz2_dm, Ft_dc->C[0], Ft_dc->C[0]);
- MatrixMinusMatrix(Wnz2bynz2_dm, Wnz2bynz2_dm, W2nz2bynz2_dm);
- CopySubmatrix2vector(wP0_dv, 0, Vt_dc->C[0], 0, 0, nz2);
- bdivA_rgens(wP0_dv, wP0_dv, '\\', Wnz2bynz2_dm);
- CopySubvector2matrix_unr(P0_dm, 0, 0, wP0_dv, 0, nz2);
- //Done with all w*_dv and W*_dm.
- }
- else
- {
- fprintf(FPTR_DEBUG, "Fatal error: tz_logTimetCondLH_kalfiltv() in kalman.c: the system is non-stationary solutions\n"
- " and thus the initial conditions must be supplied by, say, input arguments");
- fflush(FPTR_DEBUG);
- exit( EXIT_FAILURE );
- }
- }
- CopySubvector2matrix(zt_tm1_dm, 0, 0, z0_dv, 0, z0_dv->n);
- CopyMatrix0(Pt_tm1_dc->C[tdata], P0_dm);
- }
-
-
- //======= Liklihood at time t (see p.002 in LiuWZ). =======
- at_sdv.n = yt_sdv.n = yt_dm->nrows;
- at_sdv.flag = yt_sdv.flag = V_DEF;
- zt_tm1_sdv.n = ztp1_t_sdv.n = zt_tm1_dm->nrows;
- zt_tm1_sdv.flag = ztp1_t_sdv.flag = V_DEF;
- btp1_sdv.n = bt_dm->nrows;
- btp1_sdv.flag = V_DEF;
-
- //--- Setup.
- MatrixTimesMatrix(PHtran_tdata_dm, Pt_tm1_dc->C[tdata], Ht_dc->C[tdata], 1.0, 0.0, 'N', 'T');
-
- //--- Data.
- //- etdata = Y_T(:,tdata) - a(:,tdata) - Htdata*ztdata;
- yt_sdv.v = yt_dm->M + tdata*yt_dm->nrows;
- at_sdv.v = at_dm->M + tdata*at_dm->nrows;
- zt_tm1_sdv.v = zt_tm1_dm->M + tdata*zt_tm1_dm->nrows;
- VectorMinusVector(etdata_dv, &yt_sdv, &at_sdv);
- MatrixTimesVector(etdata_dv, Ht_dc->C[tdata], &zt_tm1_sdv, -1.0, 1.0, 'N');
- //+ Dtdata = Htdata*PHtran_tdata + R(:,:,tdata);
- CopyMatrix0(Dtdata_dm, Rt_dc->C[tdata]);
- MatrixTimesMatrix(Dtdata_dm, Ht_dc->C[tdata], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- ScalarTimesMatrixSquare(Dtdata_dm, 0.5, Dtdata_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Dtdata_dm->flag = Dtdata_dm->flag | M_SU | M_SL;
-
- //--- Forming the log likelihood.
- if (!isfinite(logdet_Dtdata=logdetspd(Dtdata_dm))) return (loglh_timet = -NEARINFINITY);
- bdivA_rgens(wny_dv, etdata_dv, '/', Dtdata_dm);
- loglh_timet = -(0.5*ny)*LOG2PI - 0.5*logdet_Dtdata - 0.5*VectorDotVector(wny_dv, etdata_dv);
- //Done with all w*_dv.
-
-
- //======= Updating for the next period. =======
- //--- Updating zt_tm1_dm and Pt_tm1_dc by ztp1_t_sdv and Pt_tm1_dc->C[ti].
- if (tp1<T)
- {
- //Updating only up to tdata=T-2, because the values at tp1=T or tdata=T-1 will NOT be used in the likelihood function.
-
- //- Kt_tdata = (Ft*PHtran_tdata+G(:,:,tdata))/Dtdata;
- CopyMatrix0(Kt_tdata0_dm, Gt_dc->C[tdata]);
- MatrixTimesMatrix(Kt_tdata0_dm, Ft_dc->C[tp1], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- BdivA_rrect(Kt_tdata_dm, Kt_tdata0_dm, '/', Dtdata_dm);
- //+ zt_tm1(:,t) = b(:,t) + Ft*zt_tm1(:,tdata) + Kt_tdata*etdata;
- ztp1_t_sdv.v = zt_tm1_dm->M + tp1*zt_tm1_dm->nrows;
- MatrixTimesVector(&ztp1_t_sdv, Ft_dc->C[tp1], &zt_tm1_sdv, 1.0, 0.0, 'N');
- MatrixTimesVector(&ztp1_t_sdv, Kt_tdata_dm, etdata_dv, 1.0, 1.0, 'N');
- btp1_sdv.v = bt_dm->M + tp1*btp1_sdv.n;
- VectorPlusMinusVectorUpdate(&ztp1_t_sdv, &btp1_sdv, 1.0);
- //+ Pt_tm1(:,:,t) = Ft*Ptdata*Fttran - Kt_tdata*Dtdata*Kt_tdatatran + V(:,:,t);
- CopyMatrix0(Pt_tm1_dc->C[tp1], Vt_dc->C[tp1]);
- MatrixTimesMatrix(Wnzbyny_dm, Kt_tdata_dm, Dtdata_dm, 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(Wnzbynz_dm, Wnzbyny_dm, Kt_tdata_dm, 1.0, 0.0, 'N', 'T');
- MatrixPlusMinusMatrixUpdate(Pt_tm1_dc->C[tp1], Wnzbynz_dm, -1.0);
- //Done with all W*_dm.
- MatrixTimesMatrix(Wnzbynz_dm, Ft_dc->C[tp1], Pt_tm1_dc->C[tdata], 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(W2nzbynz_dm, Wnzbynz_dm, Ft_dc->C[tp1], 1.0, 0.0, 'N', 'T');
- MatrixPlusMatrixUpdate(Pt_tm1_dc->C[tp1], W2nzbynz_dm);
- //Done with all W*_dm.
- }
- zt_tm1_dm->flag = M_GE;
-
- //===
- DestroyVector_dz(evals_dzv);
- DestroyVector_lf(evals_abs_dv);
- DestroyMatrix_lf(Wnzbynz_dm);
- DestroyMatrix_lf(Wnz2bynz2_dm);
- DestroyMatrix_lf(W2nz2bynz2_dm);
- DestroyVector_lf(wP0_dv);
- //
- DestroyVector_lf(wny_dv);
- DestroyMatrix_lf(Wnzbyny_dm);
- DestroyMatrix_lf(W2nzbynz_dm);
- DestroyMatrix_lf(PHtran_tdata_dm);
- DestroyVector_lf(etdata_dv);
- DestroyMatrix_lf(Dtdata_dm);
- DestroyMatrix_lf(Kt_tdata0_dm);
- DestroyMatrix_lf(Kt_tdata_dm);
-
- return (loglh_timet);
-}
-
-
-
-
-//-----------------------------------------------------
-//- WARNING: bedore using this function, make sure to call the following functions
-// Only once in creating lwzmodel_ps: Refresh_kalfilms_*(lwzmodel_ps);
-// Everytime when parameters are changed: RefreshEverything(); RefreRunningGensys_allcases(lwzmodel_ps) in particular.
-//-----------------------------------------------------
-double logTimetCondLH_kalfilms_1stapp(int st, int inpt, struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps, struct TStateModel_tag *smodel_ps)
-{
- //st: base-0 grand regime -- deals with the cross-section values at time t.
- //inpt: base-1 in the sense that inpt>=1 to deal with the time series situation where S_T is (T+1)-by-1 and Y_T is T+nlags_max-by-1.
- // The 1st element for S_T is S_T[1] while S_T[0] is s_0 (initial condition).
- // The 1st element for Y_T, however, is Y_T[nlags_max+1-1].
- //See (42.3) on p.42 in the SWZII NOTES.
-
- //-- Output arguments
- double loglh_timet;
- //--- Input arguments
- TSdcell *etdata_dc = kalfilmsinputs_1stapp_ps->etdata_dc; //ny-by-nst-by-T, save for computing the likelihood.
- TSdfourth *Dtdata_d4 = kalfilmsinputs_1stapp_ps->Dtdata_d4; //ny-by-ny-nst-by-T, save for computing the likelihood and updating Kalman filter Updatekalfilms_1stapp().
- //--- Local variables
- int tbase0;
- double logdet_Dtdata;
- //--- Accessible variables
- int ny = kalfilmsinputs_1stapp_ps->ny;
- TSdvector etdata_sdv;
- //=== Work arguments.
- TSdvector *wny_dv = CreateVector_lf(ny);
-
-
-
- //--- Critical checking.
- if (inpt > kalfilmsinputs_1stapp_ps->T)
- fn_DisplayError(".../kalman.c/logTimetCondLH_kalfilms_1stapp(): The time exceeds the\n"
- " data sample size allocated the structure TSkalfilmsinputs_1stapp_tag");
-
- //--- The following is for safe guard. InitializeKalman_z10_P10() should be called in, say, RefreshEverything().
- if (kalfilmsinputs_1stapp_ps->ztm1_track < 0)
- if (!InitializeKalman_z10_P10(kalfilmsinputs_1stapp_ps, (TSdmatrix *)NULL, (TSdcell *)NULL))
- fn_DisplayError(".../kalman.c/logTimetCondLH_kalfilms_1stapp(): the system is non-stationary when calling"
- " InitializeKalman_z10_P10(). Please call this function in RefreshEverthing() and"
- " set the likehood to be -infty for early exit");
-
- tbase0=inpt-1;
-
- //------------------- The order matters. Updatekalfilms_1stapp() must be called before Update_et_Dt_1stapp(). -----------------
- //--- $$$ Critical updating where we MUSt have inpt-1. If inpt, Updatekalfilms_1stapp() will call this function again
- //--- $$$ because DW function ProbabilityStateConditionalCurrent() need to access this function at time inpt,
- //--- $$$ which has not computed before Updatekalfilms_1stapp(). Thus, we'll have an infinite loop.
- Updatekalfilms_1stapp(tbase0, kalfilmsinputs_1stapp_ps, smodel_ps);
-// //--- $$$ Critical updating.
-// Update_et_Dt_1stapp(tbase0, kalfilmsinputs_1stapp_ps);
-// //This function will give Dtdata_d4->F[tbase0], etdata_dc->C[tbase0], and PHtran_tdata_d4->F[tbase0].
-
-
-
- //======================================================
- //= Getting the logLH at time tbase0 or time inpt.
- //======================================================
- //--- Forming the log conditional likelihood at t.
- etdata_sdv.n = ny;
- etdata_sdv.v = etdata_dc->C[tbase0]->M + ny*st;
- etdata_sdv.flag = V_DEF;
- if (!isfinite(logdet_Dtdata=logdetspd(Dtdata_d4->F[tbase0]->C[st]))) return (loglh_timet = -NEARINFINITY);
- bdivA_rgens(wny_dv, &etdata_sdv, '/', Dtdata_d4->F[tbase0]->C[st]);
- loglh_timet = -(0.5*ny)*LOG2PI - 0.5*logdet_Dtdata - 0.5*VectorDotVector(wny_dv, &etdata_sdv);
- //Done with all w*_dv.
-
- //===
- DestroyVector_lf(wny_dv);
-
- return (loglh_timet);
-}
-//======================================================
-//= Computing z_{1|0} and P_{1|0} for each new parameter values.
-//======================================================
-int InitializeKalman_z10_P10(struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps, TSdmatrix *z10_dm, TSdcell *P10_dc)
-{
- //See p.001 and p.004 in LWZ Model II.
- //Outputs:
- // return 1: success in initializing; 0: initializing fails, so the likelihood must be set to -infty outside this function.
- // ztm1_track to track the time up to which Kalman filter have been updated.
- // z0_dm, zt_tm1_dc->C[0]
- // P0_dc, Pt_tm1_d4->F[0]
-
- //--- Output arguments
- TSdmatrix *z0_0_dm = kalfilmsinputs_1stapp_ps->z0_dm; //nz-by-nst.
- TSdmatrix *z0_dm = kalfilmsinputs_1stapp_ps->z0_dm; //nz-by-nst.
- TSdcell *P0_dc = kalfilmsinputs_1stapp_ps->P0_dc; //nz-by-nz-by-nst.
- //+ Used to get zt_tm1_dc->C[0] and Pt_tm1_d4->F[0] only.
- TSdcell *zt_tm1_dc = kalfilmsinputs_1stapp_ps->zt_tm1_dc; //nz-by-nst-by-(T+1).
- TSdfourth *Pt_tm1_d4 = kalfilmsinputs_1stapp_ps->Pt_tm1_d4; //nz-by-nz-by-nst-by-(T+1).
- //--- Input arguments
- TSdmatrix *yt_dm = kalfilmsinputs_1stapp_ps->yt_dm; //ny-by-T.
- TSdmatrix *at_dm = kalfilmsinputs_1stapp_ps->at_dm; //ny-by-nst.
- TSdcell *Ht_dc = kalfilmsinputs_1stapp_ps->Ht_dc; //ny-by-nz-by-nst.
- TSdcell *Rt_dc = kalfilmsinputs_1stapp_ps->Rt_dc; //ny-by-ny-by-nst. Covariance matrix for the measurement equation.
- //+
- TSdmatrix *bt_dm = kalfilmsinputs_1stapp_ps->bt_dm; //nz-by-nst.
- TSdcell *Ft_dc = kalfilmsinputs_1stapp_ps->Ft_dc; //nz-by-nz-by-nst.
- TSdcell *Vt_dc = kalfilmsinputs_1stapp_ps->Vt_dc; //nz-by-nz-by-nst. Covariance matrix for the state equation.
- //--- Local variables
- int sti;
- //--- Accessible variables
- int ny = kalfilmsinputs_1stapp_ps->ny;
- int nz = kalfilmsinputs_1stapp_ps->nz;
- int nst = kalfilmsinputs_1stapp_ps->nst;
- TSdvector z0_sdv, z0_0_sdv, bt_sdv;
- TSdvector yt_sdv, at_sdv;
- //--- For the initial conditions: eigenvalue decompositions
- int ki;
- int errflag;
- double eigmax;
- //===
- int nz2 = square(nz);
- TSdmatrix *Wnzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *Wnz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdmatrix *W2nz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdvector *wP0_dv = CreateVector_lf(nz2);
- //
- TSdzvector *evals_dzv = evals_dzv = CreateVector_dz(nz);
- TSdvector *evals_abs_dv = CreateVector_lf(nz); //Absolute eigenvalues.
-
-
- if (kalfilmsinputs_1stapp_ps->ztm1_track < 0)
- {
- z0_sdv.n = z0_0_sdv.n = bt_sdv.n = nz;
- z0_sdv.flag = z0_0_sdv.flag = bt_sdv.flag = V_DEF;
- at_sdv.n = yt_sdv.n = ny;
- at_sdv.flag = yt_sdv.flag = V_DEF;
-
-
- //======= Initial condition. =======
- if (!kalfilmsinputs_1stapp_ps->indxIni)
- {
- z0_0_dm->flag = z0_dm->flag = M_GE;
- for (sti=nst-1; sti>=0; sti--)
- {
- if (kalfilmsinputs_1stapp_ps->DiffuseScale) //Diffuse initial conditions are used.
- {
- //--- Diffuse condition for z0_dv.
- z0_sdv.v = z0_dm->M + z0_sdv.n*sti;
- z0_0_sdv.v = z0_0_dm->M + z0_0_sdv.n*sti;
- bt_sdv.v = bt_dm->M + bt_sdv.n*sti;
- InitializeConstantVector_lf(&z0_0_sdv, 0.0);
- MatrixTimesVector(&z0_sdv, Ft_dc->C[sti], &z0_0_sdv, 1.0, 0.0, 'N');
- VectorPlusVector(&z0_sdv, &z0_sdv, &bt_sdv);
- //--- Diffuse condition for P0_dm.
- InitializeDiagonalMatrix_lf(Wnzbynz_dm, kalfilmsinputs_1stapp_ps->DiffuseScale); //To be used for DiffuseScale*I(nz)
- CopyMatrix0(P0_dc->C[sti], Wnzbynz_dm);
- //Done with W*_dm.
- }
- else //Unconditional moments for initial conditions are used.
- {
- InitializeDiagonalMatrix_lf(Wnzbynz_dm, 1.0); //To be used for I(nz) -
- InitializeDiagonalMatrix_lf(Wnz2bynz2_dm, 1.0); //To be used for I(nz2) -
-
- //=== Eigenanalysis to determine the roots to ensure boundedness.
- errflag = eigrgen(evals_dzv, (TSdzmatrix *)NULL, (TSdzmatrix *)NULL, Ft_dc->C[sti]);
- if (errflag) fn_DisplayError("kalman.c/InitializeKalman_z10_P10(): eigen decomposition failed");
- for (ki=nz-1; ki>=0; ki--) evals_abs_dv->v[ki] = sqrt(square(evals_dzv->real->v[ki]) + square(evals_dzv->imag->v[ki]));
- evals_abs_dv->flag = V_DEF;
- eigmax = MaxVector(evals_abs_dv);
- if (eigmax < (1.0-SQRTEPSILON)) //(1.0+EPSILON))
- {
- //--- Getting z0_dv: zt_tm1(:,1) = (eye(n_z)-F(:,:,sti))\b(:,sti);
- z0_0_sdv.v = z0_0_dm->M + z0_0_sdv.n*sti;
- z0_sdv.v = z0_dm->M + z0_sdv.n*sti;
- MatrixMinusMatrix(Wnzbynz_dm, Wnzbynz_dm, Ft_dc->C[sti]);
- CopySubmatrix2vector(&z0_0_sdv, 0, bt_dm, 0, sti, bt_dm->nrows);
- bdivA_rgens(&z0_0_sdv, &z0_0_sdv, '\\', Wnzbynz_dm);
- //- Under the assumption s_0 = s_1 (this is a short-cut).
- MatrixTimesVector(&z0_sdv, Ft_dc->C[sti], &z0_0_sdv, 1.0, 0.0, 'N');
- VectorPlusVector(&z0_sdv, &z0_sdv, &bt_sdv);
- //Done with Wnzbynz_dm.
- //--- Getting P0_dm: Pt_tm1(:,:,1) = reshape((eye(n_z^2)-kron(F(:,:,sti),F(:,:,sti)))\V1(:),n_z,n_z);
- tz_kron(W2nz2bynz2_dm, Ft_dc->C[sti], Ft_dc->C[sti]);
- MatrixMinusMatrix(Wnz2bynz2_dm, Wnz2bynz2_dm, W2nz2bynz2_dm);
- CopySubmatrix2vector(wP0_dv, 0, Vt_dc->C[sti], 0, 0, nz2);
- bdivA_rgens(wP0_dv, wP0_dv, '\\', Wnz2bynz2_dm);
- CopySubvector2matrix_unr(P0_dc->C[sti], 0, 0, wP0_dv, 0, nz2);
- //Done with all w*_dv and W*_dm.
- }
- else
- {
- if (0) //0: no printing.
- {
- #if defined (USE_DEBUG_FILE)
- fprintf(FPTR_DEBUG, "\n-------WARNING: ----------\n");
- fprintf(FPTR_DEBUG, "\nIn grand regime sti=%d\n", sti);
- fprintf(FPTR_DEBUG, ".../kalman.c/InitializeKalman_z10_P10(): the system is non-stationary solutions\n"
- " and see p.003 in LWZ Model II");
- #else
- fprintf(stdout, "\n-----------------\n");
- fprintf(stdout, "\nIn grand regime sti=%d\n", sti);
- fprintf(stdout, ".../kalman.c/InitializeKalman_z10_P10(): the system is non-stationary solutions\n"
- " and see p.003 in LWZ Model II");
- #endif
- }
- //=== See p.000.3 in LWZ Model II.
- //=== Do NOT use the following option. It turns out that this will often generate explosive conditional liklihood
- //=== at the end of the sample, because Pt_tm1 shrinks to zero overtime due to the sigularity of
- //=== the initila condition P_{1|0}.
- //--- Letting z0_dv = 0.0
- // z0_sdv.v = z0_dm->M + z0_sdv.n*sti;
- // InitializeConstantVector_lf(&z0_sdv, 0.0);
- // //--- Letting P0_dm = V
- // CopyMatrix0(P0_dc->C[sti], Vt_dc->C[sti]);
-
- //===
- DestroyVector_dz(evals_dzv);
- DestroyVector_lf(evals_abs_dv);
- DestroyMatrix_lf(Wnzbynz_dm);
- DestroyMatrix_lf(Wnz2bynz2_dm);
- DestroyMatrix_lf(W2nz2bynz2_dm);
- DestroyVector_lf(wP0_dv);
-
- return (0); //Early exit with kalfilmsinputs_1stapp_ps->ztm1_track continues to be -1.
- }
- }
- }
- }
- else
- {
- if (!z10_dm) fn_DisplayError(".../kalman.c/InitializeKalman_z10_P10(): The initial condition z_{1|0}\n"
- " must be supplied as valid input arguments for when indxIni == 1");
- else
- CopyMatrix0(z0_dm, z10_dm);
-
- if (!P10_dc) fn_DisplayError(".../kalman.c/InitializeKalman_z10_P10(): The initial condition P_{1|0}\n"
- " must be supplied as valid input arguments for when indxIni == 1");
- else
- CopyCell0(P0_dc, P10_dc);
- }
- CopyMatrix0(zt_tm1_dc->C[0], z0_dm); //At time t-1 = 1.
- CopyCell0(Pt_tm1_d4->F[0], P0_dc); //At time t-1 = 1.
-
-
- kalfilmsinputs_1stapp_ps->ztm1_track = 0; //Must reset to 0, meaning initial setting is done and ready for computing LH at t = 1.
-
- Update_et_Dt_1stapp(0, kalfilmsinputs_1stapp_ps);
-
- //===
- DestroyVector_dz(evals_dzv);
- DestroyVector_lf(evals_abs_dv);
- DestroyMatrix_lf(Wnzbynz_dm);
- DestroyMatrix_lf(Wnz2bynz2_dm);
- DestroyMatrix_lf(W2nz2bynz2_dm);
- DestroyVector_lf(wP0_dv);
-
- return (1);
- }
- else
- {
- fn_DisplayError(".../kalman.c/InitializeKalman_z10_P10(): calling this function makes sense only if"
- " kalfilmsinputs_1stapp_ps->ztm1_track is -1. Please check this value.");
-
- //===
- DestroyVector_dz(evals_dzv);
- DestroyVector_lf(evals_abs_dv);
- DestroyMatrix_lf(Wnzbynz_dm);
- DestroyMatrix_lf(Wnz2bynz2_dm);
- DestroyMatrix_lf(W2nz2bynz2_dm);
- DestroyVector_lf(wP0_dv);
-
- return (0);
- }
-}
-//======================================================
-//= Integrating out the lagged regimes in order to
-//= updating zt_tm1 and Pt_tm1 for next perid tp1 through Kim-Nelson filter.
-//= tdata representing base-0 t timing, while inpt represents base-1 t timing.
-//
-//= Purpose: for each inpt, we integrate out grand regimes st
-//= only ONCE to prevent the dimension of updated zt_tm1 and Pt_tm1 through Kim-Nelson filter.
-//======================================================
-static int Updatekalfilms_1stapp(int t_1, struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps, struct TStateModel_tag *smodel_ps)
-{
- //Output:
- // tm1update
- // z_{t_1+1|t_1}
- // P_{t_1+1|t_1}
- //Input:
- // t-1: base-1 t timing. Thus t-1=inpt-1.
-
- //--- Local variables
- int stp1i, sti, t_2, t_2p1;
- double prob_previous_regimes;
- //-- Output arguments
- TSdcell *zt_tm1_dc = kalfilmsinputs_1stapp_ps->zt_tm1_dc; //nz-by-nst-by-(T+1).
- TSdfourth *Pt_tm1_d4 = kalfilmsinputs_1stapp_ps->Pt_tm1_d4; //nz-by-nz-by-nst-by-(T+1).
- //--- Input arguments
- TSdcell *Gt_dc = kalfilmsinputs_1stapp_ps->Gt_dc; //nz-by-ny-by-nst. Cross-covariance.
- //+
- TSdmatrix *bt_dm = kalfilmsinputs_1stapp_ps->bt_dm; //nz-by-nst.
- TSdcell *Ft_dc = kalfilmsinputs_1stapp_ps->Ft_dc; //nz-by-nz-by-nst.
- TSdcell *Vt_dc = kalfilmsinputs_1stapp_ps->Vt_dc; //nz-by-nz-by-nst. Covariance matrix for the state equation.
- //+
- TSdfourth *PHtran_tdata_d4 = kalfilmsinputs_1stapp_ps->PHtran_tdata_d4; //nz-by-ny-by-nst-T, saved only for updating Kalman filter Updatekalfilms_1stapp().
- TSdcell *etdata_dc = kalfilmsinputs_1stapp_ps->etdata_dc; //ny-by-nst-by-T, save for computing the likelihood.
- TSdfourth *Dtdata_d4 = kalfilmsinputs_1stapp_ps->Dtdata_d4; //ny-by-ny-nst-by-T, save for computing the likelihood and updating Kalman filter Updatekalfilms_1stapp().
- //--- Accessible variables
- int ny = kalfilmsinputs_1stapp_ps->ny;
- int nz = kalfilmsinputs_1stapp_ps->nz;
- int nst = kalfilmsinputs_1stapp_ps->nst;
- int T = kalfilmsinputs_1stapp_ps->T;
- TSdvector z0_sdv;
- TSdvector btp1_sdv;
- TSdvector etdata_sdv;
- //=== Work arguments.
- TSdmatrix *Wnzbynz_dm = CreateMatrix_lf(nz,nz);
- //+
- TSdmatrix *Wnzbyny_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *W2nzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *Kt_tdata0_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *Kt_tdata_dm = CreateMatrix_lf(nz,ny);
- //=== For updating zt_tm1_dm and Pt_tm1.
- TSdvector *ztp1_t_dv = CreateVector_lf(nz);
- TSdmatrix *Ptp1_t_dm = CreateMatrix_lf(nz, nz);
- TSdvector *ztp1_dv = CreateVector_lf(nz);
- TSdmatrix *Ptp1_dm = CreateMatrix_lf(nz, nz);
-
-
- //--- Critical checking.
- if (kalfilmsinputs_1stapp_ps->ztm1_track < 0)
- fn_DisplayError(".../kalman.c/Updatekalfilms_1stapp(): Make sure InitializeKalman_z10_P10() is called in the function RefreshEverthing()");
-
-
- z0_sdv.n = nz;
- z0_sdv.flag = V_DEF;
- btp1_sdv.n = nz;
- btp1_sdv.flag = V_DEF;
- //+
- etdata_sdv.n = ny;
- etdata_sdv.flag = V_DEF;
-
- for (t_2=kalfilmsinputs_1stapp_ps->ztm1_track; t_2<t_1; t_2++)
- {
- //If t_1 <= ztm1_track, no updating.
- //If t_1 > ztm1_track, updating z_{t|t-1} and P_{t|t-1} up to t-1 = t_1.
-
- zt_tm1_dc->C[t_2p1=t_2+1]->flag = M_GE;
- for (stp1i=nst-1; stp1i>=0; stp1i--)
- {
- InitializeConstantVector_lf(ztp1_dv, 0.0); //To be summed over sti.
- InitializeConstantMatrix_lf(Ptp1_dm, 0.0); //To be summed over sti.
-
- for (sti=nst-1; sti>=0; sti--)
- {
- //=== Updating for next period by integrating out sti..
- //--- Ktp1_t = (F_tp1*PHtran_t+G(:,:,t))/Dt;
- //--- Kt_tdata = (Ft*PHtran_tdata+G(:,:,tdata))/Dtdata where t=tp1 and tdata=t.
- CopyMatrix0(Kt_tdata0_dm, Gt_dc->C[sti]);
- MatrixTimesMatrix(Kt_tdata0_dm, Ft_dc->C[stp1i], PHtran_tdata_d4->F[t_2]->C[sti], 1.0, 1.0, 'N', 'N');
- BdivA_rrect(Kt_tdata_dm, Kt_tdata0_dm, '/', Dtdata_d4->F[t_2]->C[sti]);
- //+ zt_tm1(:,t) = b(:,t) + Ft*zt_tm1(:,tdata) + Kt_tdata*etdata where t=tp1 and tm1=t.
- etdata_sdv.v = etdata_dc->C[t_2]->M + ny*sti;
- z0_sdv.v = zt_tm1_dc->C[t_2]->M + nz*sti; //sti: regime at time t_2.
- MatrixTimesVector(ztp1_t_dv, Ft_dc->C[stp1i], &z0_sdv, 1.0, 0.0, 'N');
- MatrixTimesVector(ztp1_t_dv, Kt_tdata_dm, &etdata_sdv, 1.0, 1.0, 'N');
- btp1_sdv.v = bt_dm->M + stp1i*btp1_sdv.n;
- VectorPlusMinusVectorUpdate(ztp1_t_dv, &btp1_sdv, 1.0);
- //+ Pt_tm1(:,:,t) = Ft*Ptdata*Fttran - Kt_tdata*Dtdata*Kt_tdatatran + V(:,:,t);
- CopyMatrix0(Ptp1_t_dm, Vt_dc->C[stp1i]);
- MatrixTimesMatrix(Wnzbyny_dm, Kt_tdata_dm, Dtdata_d4->F[t_2]->C[sti], 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(Wnzbynz_dm, Wnzbyny_dm, Kt_tdata_dm, 1.0, 0.0, 'N', 'T');
- MatrixPlusMinusMatrixUpdate(Ptp1_t_dm, Wnzbynz_dm, -1.0);
- //Done with all W*_dm.
- MatrixTimesMatrix(Wnzbynz_dm, Ft_dc->C[stp1i], Pt_tm1_d4->F[t_2]->C[sti], 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(W2nzbynz_dm, Wnzbynz_dm, Ft_dc->C[stp1i], 1.0, 0.0, 'N', 'T');
- MatrixPlusMatrixUpdate(Ptp1_t_dm, W2nzbynz_dm);
- //Done with all W*_dm.
-
-
- //--- Integrating out the state at t_2 using
- //--- P(s_t_2|Y_{t_2}, theta) = ProbabilityStateConditionalCurrent(sti, t_2, smodel_ps);
- //--- One can also access to P(s_t_2|Y_{t_2}, theta) by using ElementV(smodel_ps->V[t_2],s_{t_2}i),
- //--- but this access will not call my function logTimetCondLH(), thus no updating for
- //--- P(s_t_2|Y_{t_2}, and thus leading to incorrect results.
- prob_previous_regimes = ProbabilityStateConditionalCurrent(sti, t_2, smodel_ps);
- ScalarTimesVectorUpdate(ztp1_dv, prob_previous_regimes, ztp1_t_dv);
- ScalarTimesMatrix(Ptp1_dm, prob_previous_regimes, Ptp1_t_dm, 1.0);
- Ptp1_dm->flag = M_GE | M_SU | M_SL;
- //Done with ztp1_t_dv and Ptp1_t_dm.
- }
- //--- Filling zt_tm1 and Pt_tm1 for next period.
- z0_sdv.v = zt_tm1_dc->C[t_2p1]->M + z0_sdv.n*stp1i; //stp1i: regime at time tp1.
- CopyVector0(&z0_sdv, ztp1_dv);
- CopyMatrix0(Pt_tm1_d4->F[t_2p1]->C[stp1i], Ptp1_dm); //stp1i: regime at time tp1.
- //Done with ztp1_dv, z0_sdv, Ptp1_dm.
- }
- //--- $$$ The following is important because it tells ProbabilityStateConditionalCurrent(), which calls
- //--- $$$ logTimetCondLH_kalfilms_1stapp(), which calls recursively this function again, that there is no
- //--- $$$ need to update Kalman filter for the period before kalfilmsinputs_1stapp_ps->ztm1_track.
- kalfilmsinputs_1stapp_ps->ztm1_track = t_2p1; //Means that z_{t_2p1+1|t_2p1} and P_{t_2p1+1|t_2p1} are done.
-
- //--- $$$ This function must be called after all the above computations are done.
- Update_et_Dt_1stapp(t_2p1, kalfilmsinputs_1stapp_ps);
- }
-
-
- //===
- DestroyMatrix_lf(Wnzbynz_dm);
- //
- DestroyMatrix_lf(Wnzbyny_dm);
- DestroyMatrix_lf(W2nzbynz_dm);
- DestroyMatrix_lf(Kt_tdata0_dm);
- DestroyMatrix_lf(Kt_tdata_dm);
- //
- DestroyVector_lf(ztp1_t_dv);
- DestroyMatrix_lf(Ptp1_t_dm);
- DestroyVector_lf(ztp1_dv);
- DestroyMatrix_lf(Ptp1_dm);
-
- return (kalfilmsinputs_1stapp_ps->ztm1_track);
-}
-//======================================================
-//= Computes etdata and Dtdata for all grand regimes st at tbase0=inpt-1 or dtm1_track
-//= to prevent recomputing this object for different st at given tbase0.
-//======================================================
-static int Update_et_Dt_1stapp(int t_1, struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps)
-{
- //Output:
- // dtm1_track is updated in this function.
- // PHtran_tdata_d4->F[t-1]
- // etdata_dc->C[t-1]
- // Dtdata_d4->F[t-1]
- //Input:
- // t_1=inpt-1: base-0 timing for et and Dt before the likelihood at time inpt is computed.
-
- //--- Local variables
- int sti, tbase0;
- //-- Output arguments
- TSdfourth *PHtran_tdata_d4 = kalfilmsinputs_1stapp_ps->PHtran_tdata_d4; //nz-by-ny-by-nst-T, saved only for updating Kalman filter Updatekalfilms_1stapp().
- TSdcell *etdata_dc = kalfilmsinputs_1stapp_ps->etdata_dc; //ny-by-nst-by-T, save for computing the likelihood.
- TSdcell *yt_tm1_dc = kalfilmsinputs_1stapp_ps->yt_tm1_dc; //ny-by-nst-by-T, one-step forecast y_{t|t-1} for t=0 to T-1 (base-0).
- TSdfourth *Dtdata_d4 = kalfilmsinputs_1stapp_ps->Dtdata_d4; //ny-by-ny-nst-by-T, save for computing the likelihood and updating Kalman filter Updatekalfilms_1stapp().
- //--- input arguments
- TSdcell *zt_tm1_dc = kalfilmsinputs_1stapp_ps->zt_tm1_dc; //nz-by-nst-by-T.
- TSdfourth *Pt_tm1_d4 = kalfilmsinputs_1stapp_ps->Pt_tm1_d4; //nz-by-nz-by-nst-by-T.
- //+
- TSdmatrix *yt_dm = kalfilmsinputs_1stapp_ps->yt_dm; //ny-by-T.
- TSdmatrix *at_dm = kalfilmsinputs_1stapp_ps->at_dm; //ny-by-nst.
- TSdcell *Ht_dc = kalfilmsinputs_1stapp_ps->Ht_dc; //ny-by-nz-by-nst.
- TSdcell *Rt_dc = kalfilmsinputs_1stapp_ps->Rt_dc; //ny-by-ny-by-nst. Covariance matrix for the measurement equation.
- //--- Accessible variables
- int ny = kalfilmsinputs_1stapp_ps->ny;
- int nz = kalfilmsinputs_1stapp_ps->nz;
- int nst = kalfilmsinputs_1stapp_ps->nst;
- TSdvector z0_sdv;
- TSdvector yt_sdv, at_sdv;
- TSdvector etdata_sdv, yt_tm1_sdv;
- //=== Work arguments.
- TSdmatrix *PHtran_tdata_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *Dtdata_dm = CreateMatrix_lf(ny,ny);
-
-
- z0_sdv.n = nz;
- z0_sdv.flag = V_DEF;
- at_sdv.n = yt_sdv.n = ny;
- at_sdv.flag = yt_sdv.flag = V_DEF;
- etdata_sdv.n = yt_tm1_sdv.n = ny;
- etdata_sdv.flag = yt_tm1_sdv.flag = V_DEF;
-
- for (tbase0=(kalfilmsinputs_1stapp_ps->dtm1_track+1); tbase0<=t_1; tbase0++)
- {
- //Note tbase0<=t_1, NOT tbase0<t_1.
- //If t_1 < (dtm1_track+1), no updating.
- //If t_1 >= (dtm1_track+1), updating etdata_dc->C[t-1] and Dtdata_d4->F[t-1] up to t-1=t_1.
-
- for (sti=nst-1; sti>=0; sti--)
- {
- //--- Setup.
- MatrixTimesMatrix(PHtran_tdata_dm, Pt_tm1_d4->F[tbase0]->C[sti], Ht_dc->C[sti], 1.0, 0.0, 'N', 'T');
- CopyMatrix0(kalfilmsinputs_1stapp_ps->PHtran_tdata_d4->F[tbase0]->C[sti], PHtran_tdata_dm);
-
-
- //--- Data.
- //- etdata = Y_T(:,tdata) - a(:,tdata) - Htdata*ztdata where tdata = tbase0 = inpt-1.
- yt_sdv.v = yt_dm->M + tbase0*yt_dm->nrows;
- at_sdv.v = at_dm->M + sti*at_dm->nrows; //grand regime at time tbase0.
- z0_sdv.v = zt_tm1_dc->C[tbase0]->M + z0_sdv.n*sti; //sti: regime at time tbase0.
- etdata_sdv.v = etdata_dc->C[tbase0]->M + etdata_sdv.n*sti;
- yt_tm1_sdv.v = etdata_dc->C[tbase0]->M + yt_tm1_sdv.n*sti;
- CopyVector0(&yt_tm1_sdv, &at_sdv);
- MatrixTimesVector(&yt_tm1_sdv, Ht_dc->C[sti], &z0_sdv, 1.0, 1.0, 'N'); //a + H*z_{t|t-1}.
- VectorMinusVector(&etdata_sdv, &yt_sdv, &yt_tm1_sdv); //y_t - a - H*z_{t|t-1}.
- //+ Dtdata = Htdata*PHtran_tdata + R(:,:,tbase0);
- CopyMatrix0(Dtdata_dm, Rt_dc->C[sti]);
- MatrixTimesMatrix(Dtdata_dm, Ht_dc->C[sti], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- //Done with z0_sdv.v.
- ScalarTimesMatrixSquare(Dtdata_dm, 0.5, Dtdata_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Dtdata_dm->flag = Dtdata_dm->flag | M_SU | M_SL;
- CopyMatrix0(Dtdata_d4->F[tbase0]->C[sti], Dtdata_dm); //Saved to be used for logTimetCondLH_kalfilms_1stapp().
- }
-
- //--- $$$ This tracker functions the same way as kalfilmsinputs_1stapp_ps->ztm1_track.
- kalfilmsinputs_1stapp_ps->dtm1_track = tbase0;
- }
-
- //===
- DestroyMatrix_lf(PHtran_tdata_dm);
- DestroyMatrix_lf(Dtdata_dm);
-
- return (kalfilmsinputs_1stapp_ps->dtm1_track);
-}
-
-
-
-
-
-
-//-----------------------------------------------------
-//------------ OLD Code --------------------------
-//- Updating or refreshing all Kalman filter at time t for Markov-switching DSGE model.
-//- WARNING: make sure to call the following functions
-// RunningGensys_const7varionly(lwzmodel_ps);
-// Refresh_kalfilms_*(lwzmodel_ps); //Creates or refreshes kalfilmsinputs_ps at new parameter values.
-//- before using tz_Refresh_z_T7P_T_in_kalfilms_1st_approx().
-//
-//- IMPORTANT NOTE: in the Markov-switching input file datainp_markov*.prn, it MUST be that
-//- the coefficient regime is the 1st state variable, and
-//- the volatility regime is the 2nd state variable.
-//-----------------------------------------------------
-#if defined (NEWVERSIONofDW_SWITCH)
-double tz_logTimetCondLH_kalfilms_1st_approx(int st, int inpt, struct TSkalfilmsinputs_tag *kalfilmsinputs_ps, struct TStateModel_tag *smodel_ps)
-{
- //st, st_c, and st_v: base-0: deals with the cross-section values at time t where
- // st is a grand regime, st_c is an encoded coefficient regime, and st_c is an encoded volatility regime.
- //inpt: base-1 in the sense that inpt>=1 to deal with the time series situation where S_T is (T+1)-by-1 and Y_T is T+nlags_max-by-1.
- // The 1st element for S_T is S_T[1] while S_T[0] is s_0 (initial condition).
- // The 1st element for Y_T, however, is Y_T[nlags_max+1-1].
- //See (42.3) on p.42 in the SWZII NOTES.
-
-
- //--- Local variables
- int comst_c; //composite (s_tc, s_{t-1}c)
- int st_c, stm1_c, st_v;
- int comsti_c; //composite (s_tc, s_{t-1}c)
- int sti, sti_c, stm1i_c, sti_v;
- int comstp1i_c; //composite (s_{t+1}c, s_tc)
- int stp1i, stp1i_c, stp1i_v;
- int tbase0, tp1;
- double logdet_Dtdata, loglh_timet;
- static int record_tbase1_or_inpt_or_tp1 = 0;
- static int passonce;
- double prob_previous_regimes;
- //=== Accessible variables
- int ny = kalfilmsinputs_ps->ny;
- int nz = kalfilmsinputs_ps->nz;
- int nRc = kalfilmsinputs_ps->nRc;
- int nRstc = kalfilmsinputs_ps->nRstc;
- int nRv = kalfilmsinputs_ps->nRv;
- int T = kalfilmsinputs_ps->T;
- int indxIndRegimes = kalfilmsinputs_ps->indxIndRegimes;
- int **Index = smodel_ps->sv->index; //Regime-switching states.
- //smodel_ps->sv->index is for our new code.
- // For old code (before 9 April 08 and before dsge_switch is created), use smodel_ps->sv->Index;
- TSdvector z0_sdv;
- //+ input arguments.
- TSdmatrix *yt_dm = kalfilmsinputs_ps->yt_dm; //ny-by-T.
- TSdmatrix *at_dm = kalfilmsinputs_ps->at_dm; //ny-by-nRc.
- TSdcell *Ht_dc = kalfilmsinputs_ps->Ht_dc; //ny-by-nz-by-nRc.
- TSdcell *Rt_dc = kalfilmsinputs_ps->Rt_dc; //ny-by-ny-by-nRv. Covariance matrix for the measurement equation.
- TSdcell *Gt_dc = kalfilmsinputs_ps->Gt_dc; //nz-by-ny-by-nRv. Cross-covariance.
- //
- TSdmatrix *bt_dm = kalfilmsinputs_ps->bt_dm; //nz-by-nRc.
- TSdcell *Ft_dc = kalfilmsinputs_ps->Ft_dc; //nz-by-nz-by-nRc.
- TSdcell *Vt_dc = kalfilmsinputs_ps->Vt_dc; //nz-by-nz-by-nRv. Covariance matrix for the state equation.
- //
- TSdmatrix *z0_dm = kalfilmsinputs_ps->z0_dm; //nz-by-nRc*nRv or nz-by-nRv, depending on indxIndRegimes.
- TSdcell *P0_dc = kalfilmsinputs_ps->P0_dc; //nz-by-nz-by-nRc*nRv or nz-by-nRv, depending on indxIndRegimes.
- //+ Output arguments.
- TSdcell *zt_tm1_dc = kalfilmsinputs_ps->zt_tm1_dc; //nz-by-nRc*nRv-by-T if indxIndRegimes==1, nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- TSdfourth *Pt_tm1_d4 = kalfilmsinputs_ps->Pt_tm1_d4; //nz-by-nz-by-nRc*nRv-T if indxIndRegimes==1, nz-by-nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- //=== Work arguments.
- int nz2 = square(nz);
- TSdmatrix *Wnzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *Wnz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdmatrix *W2nz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdvector *wP0_dv = CreateVector_lf(nz2);
- //+
- TSdvector yt_sdv, at_sdv, btp1_sdv; //zt_tm1_sdv, ztp1_t_sdv,
- TSdvector *wny_dv = CreateVector_lf(ny);
- TSdmatrix *Wnzbyny_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *W2nzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *PHtran_tdata_dm = CreateMatrix_lf(nz,ny);
- TSdvector *etdata_dv = CreateVector_lf(ny);
- TSdmatrix *Dtdata_dm = CreateMatrix_lf(ny,ny);
- TSdmatrix *Kt_tdata0_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *Kt_tdata_dm = CreateMatrix_lf(nz,ny);
- //--- For eigenvalue decompositions
- int ki;
- int errflag;
- double eigmax;
- TSdzvector *evals_dzv = evals_dzv = CreateVector_dz(nz);
- TSdvector *evals_abs_dv = CreateVector_lf(nz); //Absolute eigenvalues.
- //--- For updating zt_tm1_dm and Pt_tm1.
- TSdvector *ztp1_t_dv = CreateVector_lf(z0_dm->nrows);
- TSdmatrix *Ptp1_t_dm = CreateMatrix_lf(nz, nz);
- TSdvector *ztp1_dv = CreateVector_lf(z0_dm->nrows);
- TSdmatrix *Ptp1_dm = CreateMatrix_lf(nz, nz);
-
-
-
- if (smodel_ps->sv->nstates != z0_dm->ncols) fn_DisplayError("kalman.c/tz_logTimetLH_kalfilms_1st_approx():\n"
- " Make sure that the column dimension of z0_dm is the same as smodel_ps->sv->nstates");
- if (indxIndRegimes && (nRc>1) && (nRv>1))
- if (smodel_ps->sv->n_state_variables != 2) fn_DisplayError("kalman.c/tz_Refresh_z_T7P_T_in_kalfilms_1st_approx():\n"
- " Number of state variables must be coincide with indxIndRegimes");
-
- tbase0 = (tp1=inpt) - 1;
-
- z0_sdv.n = z0_dm->nrows;
- z0_sdv.flag = V_DEF;
- //
- at_sdv.n = yt_sdv.n = yt_dm->nrows;
- at_sdv.flag = yt_sdv.flag = V_DEF;
- btp1_sdv.n = bt_dm->nrows;
- btp1_sdv.flag = V_DEF;
-
-
- //======= Initial condition. =======
- if (tbase0==0)
- {
- for (sti=smodel_ps->sv->nstates-1; sti>=0; sti--)
- {
- if (indxIndRegimes)
- {
- if (nRc==1) //Volatility.
- {
- comsti_c = sti_c = 0;
- sti_v = sti;
- }
- else if ((nRv>1) && (nRc>nRstc)) //Trend inflation, both sc_t and sc_{t-1} enters coefficient regime.
- {
- comsti_c = Index[sti][0]; //composite (s_tc, s_{t-1}c)
- sti_v = Index[sti][1]; //volatility state s_tv
- sti_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][0]; //coefficient regime at t.
- stm1i_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][1]; //coefficient regime at t-1: tm1: t-1;
- }
- else if ((nRv==1) && (nRc>nRstc))
- {
- comsti_c = Index[sti][0]; //composite (s_tc, s_{t-1}c)
- sti_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][0]; //coefficient regime at t.
- stm1i_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][1]; //coefficient regime at t-1: tm1: t-1;
- sti_v = 0;
- }
- else if ((nRv==1) && (nRc==nRstc))
- {
- comsti_c = sti_c = sti;
- sti_v = 0;
- }
- else if ((nRv>1) && (nRc==nRstc)) //only sc_t enters coefficient regime.
- {
- comsti_c = sti_c = Index[sti][0];
- sti_v = Index[sti][1];
- }
- }
- else //Syncronized regimes.
- {
- if (nRc>nRstc)
- {
- comsti_c = Index[sti][0]; //composite (s_tc, s_{t-1}c)
- sti_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][0]; //coefficient regime at t.
- stm1i_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][1]; //coefficient regime at t-1: tm1: t-1;
- sti_v = sti_c;
- }
- else
- comsti_c = sti_c = sti_v = sti;
- }
-
-
- if (!kalfilmsinputs_ps->indxIni)
- {
- InitializeDiagonalMatrix_lf(Wnzbynz_dm, 1.0); //To be used for I(nz) -
- InitializeDiagonalMatrix_lf(Wnz2bynz2_dm, 1.0); //To be used for I(nz2) -
-
- //=== Eigenanalysis to determine the roots to ensure boundedness.
- errflag = eigrgen(evals_dzv, (TSdzmatrix *)NULL, (TSdzmatrix *)NULL, Ft_dc->C[comsti_c]);
- if (errflag) fn_DisplayError("kalman.c/tz_Refresh_z_T7P_T_in_kalfilms_1st_approx(): eigen decomposition failed");
- for (ki=nz-1; ki>=0; ki--) evals_abs_dv->v[ki] = sqrt(square(evals_dzv->real->v[ki]) + square(evals_dzv->imag->v[ki]));
- evals_abs_dv->flag = V_DEF;
- eigmax = MaxVector(evals_abs_dv);
- if (eigmax < (1.0+1.0e-14))
- {
- //--- Getting z0_dv: zt_tm1(:,1) = (eye(n_z)-F(:,:,1))\b(:,1);
- MatrixMinusMatrix(Wnzbynz_dm, Wnzbynz_dm, Ft_dc->C[comsti_c]);
- z0_sdv.v = z0_dm->M + z0_sdv.n*sti;
- CopySubmatrix2vector(&z0_sdv, 0, bt_dm, 0, comsti_c, bt_dm->nrows);
- bdivA_rgens(&z0_sdv, &z0_sdv, '\\', Wnzbynz_dm);
- //Done with Wnzbynz_dm.
- //--- Getting P0_dm: Pt_tm1(:,:,1) = reshape((eye(n_z^2)-kron(F(:,:,1),F(:,:,1)))\V1(:),n_z,n_z);
- tz_kron(W2nz2bynz2_dm, Ft_dc->C[comsti_c], Ft_dc->C[comsti_c]);
- MatrixMinusMatrix(Wnz2bynz2_dm, Wnz2bynz2_dm, W2nz2bynz2_dm);
- CopySubmatrix2vector(wP0_dv, 0, Vt_dc->C[sti_v], 0, 0, nz2);
-//=== ???????? For debugging purpose.
-//if ((inpt<2) && (st==0))
-//{
-// fprintf(FPTR_DEBUG, "%%st=%d, inpt=%d, and sti=%d\n", st, inpt, sti);
-
-// fprintf(FPTR_DEBUG, "wP0_dv:\n");
-// WriteVector(FPTR_DEBUG, wP0_dv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "Vt_dc->C[sti_v=%d]:\n", sti_v);
-// WriteMatrix(FPTR_DEBUG, Vt_dc->C[sti_v], " %10.5f ");
-
-// fflush(FPTR_DEBUG);
-
-//}
- bdivA_rgens(wP0_dv, wP0_dv, '\\', Wnz2bynz2_dm);
- CopySubvector2matrix_unr(P0_dc->C[sti], 0, 0, wP0_dv, 0, nz2);
- //Done with all w*_dv and W*_dm.
- }
- else
- {
- fprintf(stdout, "\n-----------------\n");
- fprintf(stdout, "\nIn regime comsti_c=%d and sti_v=%d and at time=%d\n", comsti_c, sti_v, 0);
- fn_DisplayError("kalman.c/tz_Refresh_z_T7P_T_in_kalfilms_1st_approx(): the system is non-stationary solutions\n"
- " and the initial conditions must be supplied by, say, input arguments");
- fflush(stdout);
- }
- }
- }
- z0_dm->flag = M_GE;
- CopyMatrix0(zt_tm1_dc->C[0], z0_dm); //At time t=0.
- CopyCell0(Pt_tm1_d4->F[0], P0_dc); //At time t=0.
- }
-
-
- //======================================================
- //= Getting the logLH at time tbase0 or time inpt.
- //======================================================
- if (indxIndRegimes )
- {
- if (nRc==1) //Volatility.
- {
- comst_c = st_c = 0;
- st_v = st;
- }
- else if ((nRv>1) && (nRc>nRstc)) //Trend inflation, both sc_t and sc_{t-1} enters coefficient regime.
- {
- if (smodel_ps->sv->n_state_variables != 2) fn_DisplayError("kalman.c/kalfilms_timet_1st_approx():\n"
- " Number of state variables must be coincide with indxIndRegimes");
-
- comst_c = Index[st][0]; //composite (s_tc, s_{t-1}c)
- st_v = Index[st][1]; //volatility state s_tv
- st_c = smodel_ps->sv->state_variable[0]->lag_index[comst_c][0]; //coefficient regime at t.
- stm1_c = smodel_ps->sv->state_variable[0]->lag_index[comst_c][1]; //coefficient regime at t-1: tm1: t-1;
- }
- else if ((nRv==1) && (nRc>nRstc))
- {
- comst_c = Index[st][0]; //composite (s_tc, s_{t-1}c)
- st_c = smodel_ps->sv->state_variable[0]->lag_index[comst_c][0]; //coefficient regime at t.
- stm1_c = smodel_ps->sv->state_variable[0]->lag_index[comst_c][1]; //coefficient regime at t-1: tm1: t-1;
- st_v = 0;
- }
- else if ((nRv==1) && (nRc==nRstc))
- {
- comst_c = st_c = st;
- st_v = 0;
- }
- else if ((nRv>1) && (nRc==nRstc)) //only sc_t enters coefficient regime.
- {
- if (smodel_ps->sv->n_state_variables != 2) fn_DisplayError("kalman.c/kalfilms_timet_1st_approx():\n"
- " Number of state variables must be coincide with indxIndRegimes");
-
- comst_c = st_c = Index[st][0];
- st_v = Index[st][1];
- }
- }
- else //Syncronized regimes
- {
- if (nRc>nRstc)
- {
- comst_c = Index[st][0]; //composite (s_tc, s_{t-1}c)
- st_c = smodel_ps->sv->state_variable[0]->lag_index[comst_c][0]; //coefficient regime at t.
- stm1_c = smodel_ps->sv->state_variable[0]->lag_index[comst_c][1]; //coefficient regime at t-1: tm1: t-1;
- st_v = st_c;
- }
- else
- comst_c = st_c = st_v = st;
- }
-
-
- z0_sdv.n = zt_tm1_dc->C[0]->nrows;
- z0_sdv.flag = V_DEF;
- //
- at_sdv.n = yt_sdv.n = yt_dm->nrows;
- at_sdv.flag = yt_sdv.flag = V_DEF;
-
- //====== Computing the conditional LH at time t. ======
- //--- Setup.
- MatrixTimesMatrix(PHtran_tdata_dm, Pt_tm1_d4->F[tbase0]->C[st], Ht_dc->C[comst_c], 1.0, 0.0, 'N', 'T');
-
- //--- Data.
- //- etdata = Y_T(:,tdata) - a(:,tdata) - Htdata*ztdata where tdata = tbase0 = inpt-1.
- yt_sdv.v = yt_dm->M + tbase0*yt_dm->nrows;
- at_sdv.v = at_dm->M + comst_c*at_dm->nrows; //comst_c: coefficient regime at time tbase0.
- z0_sdv.v = zt_tm1_dc->C[tbase0]->M + z0_sdv.n*st; //st: regime at time tbase0 for zt_tm1.
- VectorMinusVector(etdata_dv, &yt_sdv, &at_sdv);
- MatrixTimesVector(etdata_dv, Ht_dc->C[comst_c], &z0_sdv, -1.0, 1.0, 'N');
- //+ Dtdata = Htdata*PHtran_tdata + R(:,:,tbase0);
- CopyMatrix0(Dtdata_dm, Rt_dc->C[st_v]);
- MatrixTimesMatrix(Dtdata_dm, Ht_dc->C[comst_c], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- ScalarTimesMatrixSquare(Dtdata_dm, 0.5, Dtdata_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Dtdata_dm->flag = Dtdata_dm->flag | M_SU | M_SL;
-
-
- //--- Forming the log conditional likelihood at t.
- if (!isfinite(logdet_Dtdata=logdetspd(Dtdata_dm))) return (loglh_timet = -NEARINFINITY);
- bdivA_rgens(wny_dv, etdata_dv, '/', Dtdata_dm);
-//if ((inpt>82) && (inpt<86) )
-//{
-// //Must be declared at the top of this "if" block.
-// int kip1;
-// double tmp_Dtdata;
-// double tmp_expterm;
-
-// fprintf(FPTR_DEBUG, "%%------------------------\n");
-// fprintf(FPTR_DEBUG, "%%st=%d and inpt=%d\n", st, inpt);
-// fprintf(FPTR_DEBUG, "loglh_timet = %10.5f;\n", loglh_timet);
-
-
-// fprintf(FPTR_DEBUG, "wny_dv:\n");
-// WriteVector(FPTR_DEBUG, wny_dv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "etdata_dv:\n");
-// WriteVector(FPTR_DEBUG, etdata_dv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "Dtdata_dm:\n");
-// WriteMatrix(FPTR_DEBUG, Dtdata_dm, " %.16e ");
-
-// fflush(FPTR_DEBUG);
-//}
- loglh_timet = -(0.5*ny)*LOG2PI - 0.5*logdet_Dtdata - 0.5*VectorDotVector(wny_dv, etdata_dv);
- //Done with all w*_dv.
-
-
-
-
-//=== ???????? For debugging purpose.
-if (inpt==1)
-{
- double wk1, wk2;
-
- wk1 = logdet_Dtdata;
- wk2 = VectorDotVector(wny_dv, etdata_dv);
- fprintf(FPTR_DEBUG, "logdet_Dtdata = %10.5f\n", wk1);
- fprintf(FPTR_DEBUG, "VectorDotVector(wny_dv, etdata_dv) = %10.5f\n", wk2);
- fprintf(FPTR_DEBUG, "----- etdata_dv: \n");
- WriteVector(FPTR_DEBUG, etdata_dv, " %10.5f ");
- fprintf(FPTR_DEBUG, "----- yt_dv: \n");
- WriteVector(FPTR_DEBUG, &yt_sdv, " %10.5f ");
- fprintf(FPTR_DEBUG, "----- at_dv: \n");
- WriteVector(FPTR_DEBUG, &at_sdv, " %10.5f ");
- fprintf(FPTR_DEBUG, "----- z0_dv: \n");
- WriteVector(FPTR_DEBUG, &z0_sdv, " %10.5f ");
- fprintf(FPTR_DEBUG, "----- Ht_dc->C[comst_c=%d]:\n", comst_c);
- WriteMatrix(FPTR_DEBUG, Ht_dc->C[comst_c], " %10.5f ");
-
- fprintf(FPTR_DEBUG, "\n\n");
-
-}
-//
-fprintf(FPTR_DEBUG, " %10.5f\n", loglh_timet);
-fflush(FPTR_DEBUG);
-
-
-//=== ???????? For debugging purpose.
-//fprintf(FPTR_DEBUG, "------------------------\n");
-//fprintf(FPTR_DEBUG, "st=%d and inpt=%d\n", st, inpt);
-//fprintf(FPTR_DEBUG, "loglh_timet = %10.5f\n", loglh_timet);
-//fprintf(FPTR_DEBUG, "&yt_sdv:\n");
-//WriteVector(FPTR_DEBUG, &yt_sdv, " %10.5f ");
-////WriteVector(FPTR_DEBUG, etdata_dv, " %10.5f ");
-////fprintf(FPTR_DEBUG, "\n");
-////WriteMatrix(FPTR_DEBUG, Dtdata_dm, " %10.5f ");
-//fflush(FPTR_DEBUG);
-
-
-//=== ???????? For debugging purpose.
-//if ((inpt>82) && (inpt<86) )
-//if (inpt<2)
-//{
-// //Must be declared at the top of this "if" block.
-// int kip1;
-// double tmp_Dtdata;
-// double tmp_expterm;
-
-// fprintf(FPTR_DEBUG, "%%------------------------\n");
-// fprintf(FPTR_DEBUG, "%%st=%d and inpt=%d\n", st, inpt);
-// fprintf(FPTR_DEBUG, "loglh_timet = %10.5f;\n", loglh_timet);
-
-
-// tmp_Dtdata = logdeterminant(Dtdata_dm);
-// tmp_expterm = VectorDotVector(wny_dv, etdata_dv);
-// fprintf(FPTR_DEBUG, "logdeterminant(Dtdata_dm) = %10.5f;\n", tmp_Dtdata);
-// fprintf(FPTR_DEBUG, "VectorDotVector(wny_dv, etdata_dv) = %10.5f;\n", tmp_expterm);
-// fprintf(FPTR_DEBUG, "wny_dv:\n");
-// WriteVector(FPTR_DEBUG, wny_dv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "etdata_dv:\n");
-// WriteVector(FPTR_DEBUG, etdata_dv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "&yt_sdv:\n");
-// WriteVector(FPTR_DEBUG, &yt_sdv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "&at_sdv:\n");
-// WriteVector(FPTR_DEBUG, &at_sdv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "&z0_sdv:\n");
-// WriteVector(FPTR_DEBUG, &z0_sdv, " %10.5f ");
-// fprintf(FPTR_DEBUG, "Ht_dc->C[comst_c=%d]:\n",comst_c);
-// WriteMatrix(FPTR_DEBUG, Ht_dc->C[comst_c], " %10.5f ");
-// fprintf(FPTR_DEBUG, "Rt_dc->C[st_v=%d]:\n", st_v);
-// WriteMatrix(FPTR_DEBUG, Rt_dc->C[st_v], " %10.5f ");
-// fprintf(FPTR_DEBUG, "Pt_tm1_d4->F[tbase0]->C[st = %d]:\n",st);
-// WriteMatrix(FPTR_DEBUG, Pt_tm1_d4->F[tbase0]->C[st], " %10.5f ");
-// fprintf(FPTR_DEBUG, "Dtdata_dm:\n");
-// WriteMatrix(FPTR_DEBUG, Dtdata_dm, " %10.5f ");
-
-
-
-
-//// WriteMatrix(FPTR_DEBUG, Dtdata_dm, " %10.5f ");
-//// fprintf(FPTR_DEBUG, "zt_tm1_dc->C[tbase0]:\n");
-//// WriteMatrix(FPTR_DEBUG, zt_tm1_dc->C[tbase0], " %10.5f ");
-//// //WriteVector(FPTR_DEBUG, &z0_sdv, " %10.5f ");
-//// //fprintf(FPTR_DEBUG, "\n");
-//// fprintf(FPTR_DEBUG, "bt_dm = [\n");
-//// WriteMatrix(FPTR_DEBUG, bt_dm, " %10.5f ");
-//// fprintf(FPTR_DEBUG, "];\n");
-
-//// fprintf(FPTR_DEBUG, "et:\n");
-//// WriteVector(FPTR_DEBUG, etdata_dv, " %10.5f ");
-//// fprintf(FPTR_DEBUG, "yt_dv=[\n");
-//// WriteVector(FPTR_DEBUG, &yt_sdv, " %10.5f ");
-//// fprintf(FPTR_DEBUG, "]';\n");
-
-//// fprintf(FPTR_DEBUG, "at_dv=[\n");
-//// WriteVector(FPTR_DEBUG, &at_sdv, " %10.5f ");
-//// fprintf(FPTR_DEBUG, "]';\n");
-
-
-//// for (ki=0; ki<Ht_dc->ncells; ki++)
-//// {
-//// kip1 = ki+1;
-//// fprintf(FPTR_DEBUG, "Ht_dc(:,:,%d)=[\n", kip1);
-//// WriteMatrix(FPTR_DEBUG, Ht_dc->C[ki], " %10.5f ");
-//// fprintf(FPTR_DEBUG, "];\n");
-//// }
-//// for (ki=0; ki<Ft_dc->ncells; ki++)
-//// {
-//// kip1 = ki+1;
-//// fprintf(FPTR_DEBUG, "Ft_dc(:,:,%d)=[\n", kip1);
-//// WriteMatrix(FPTR_DEBUG, Ft_dc->C[ki], " %10.5f ");
-//// fprintf(FPTR_DEBUG, "];\n");
-//// }
-//// for (ki=0; ki<Vt_dc->ncells; ki++)
-//// {
-//// kip1 = ki+1;
-//// fprintf(FPTR_DEBUG, "Vt_dc(:,:,%d)=[\n", kip1);
-//// WriteMatrix(FPTR_DEBUG, Vt_dc->C[ki], " %10.5f ");
-//// fprintf(FPTR_DEBUG, "];\n");
-//// }
-// fflush(FPTR_DEBUG);
-//}
-
-
- //======================================================
- //= Updating zt_tm1 and Pt_tm1 for next perid tp1.
- //= tdata = tbase0 is base-0 timing.
- //======================================================
- if (inpt > record_tbase1_or_inpt_or_tp1) //This condition always satisfies at the 1st period (which is inpt=1).
- {
- passonce = 0;
- record_tbase1_or_inpt_or_tp1 = inpt;
- }
- if (!passonce)
- {
- for (stp1i=smodel_ps->sv->nstates-1; stp1i>=0; stp1i--)
- {
- if (indxIndRegimes)
- {
- if (nRc==1) //Volatility.
- {
- comstp1i_c = stp1i_c = 0;
- stp1i_v = stp1i;
- }
- else if ((nRv>1) && (nRc>nRstc)) //Trend inflation, both sc_t and sc_{t-1} enters coefficient regime.
- {
- comstp1i_c = Index[stp1i][0]; //composite (s_tc, s_{t-1}c)
- stp1i_v = Index[stp1i][1]; //volatility state s_tv
- stp1i_c = smodel_ps->sv->state_variable[0]->lag_index[comstp1i_c][0]; //coefficient regime at t.
- //sti_c = smodel_ps->sv->state_variable[0]->lag_index[comstp1i_c][1]; //coefficient regime at t-1: tm1: t-1;
- }
- else if ((nRv==1) && (nRc>nRstc))
- {
- comstp1i_c = Index[stp1i][0]; //composite (s_tc, s_{t-1}c)
- stp1i_c = smodel_ps->sv->state_variable[0]->lag_index[comstp1i_c][0]; //coefficient regime at t.
- //sti_c = smodel_ps->sv->state_variable[0]->lag_index[comstp1i_c][1]; //coefficient regime at t-1: tm1: t-1;
- stp1i_v = 0;
- }
- else if ((nRv==1) && (nRc==nRstc))
- {
- comstp1i_c = stp1i_c = stp1i;
- stp1i_v = 0;
- }
- else if ((nRv>1) && (nRc==nRstc)) //only sc_t enters coefficient regime.
- {
- comstp1i_c = stp1i_c = Index[stp1i][0];
- stp1i_v = Index[stp1i][1];
- }
- }
- else //Syncronized regimes.
- {
- if (nRc>nRstc)
- {
- comstp1i_c = Index[stp1i][0]; //composite (s_tc, s_{t-1}c)
- stp1i_c = smodel_ps->sv->state_variable[0]->lag_index[comstp1i_c][0]; //coefficient regime at t.
- //sti_c = smodel_ps->sv->state_variable[0]->lag_index[comstp1i_c][1]; //coefficient regime at t-1: tm1: t-1;
- stp1i_v = stp1i_c;
- }
- else
- comstp1i_c = stp1i_c = stp1i_v = stp1i;
- }
-
-
- InitializeConstantVector_lf(ztp1_dv, 0.0); //To be summed over sti.
- InitializeConstantMatrix_lf(Ptp1_dm, 0.0); //To be summed over sti.
-
- for (sti=smodel_ps->sv->nstates-1; sti>=0; sti--)
- {
- if (indxIndRegimes)
- {
- if (nRc==1) //Volatility.
- {
- comsti_c = sti_c = 0;
- sti_v = sti;
- }
- else if ((nRv>1) && (nRc>nRstc)) //Trend inflation, both sc_t and sc_{t-1} enters coefficient regime.
- {
- comsti_c = Index[sti][0]; //composite (s_tc, s_{t-1}c)
- sti_v = Index[sti][1]; //volatility state s_tv
- sti_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][0]; //coefficient regime at t.
- stm1i_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][1]; //coefficient regime at t-1: tm1: t-1;
- }
- else if ((nRv==1) && (nRc>nRstc))
- {
- comsti_c = Index[sti][0]; //composite (s_tc, s_{t-1}c)
- sti_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][0]; //coefficient regime at t.
- stm1i_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][1]; //coefficient regime at t-1: tm1: t-1;
- sti_v = 0;
- }
- else if ((nRv==1) && (nRc==nRstc))
- {
- comsti_c = sti_c = sti;
- sti_v = 0;
- }
- else if ((nRv>1) && (nRc==nRstc)) //only sc_t enters coefficient regime.
- {
- comsti_c = sti_c = Index[sti][0];
- sti_v = Index[sti][1];
- }
- }
- else //Syncronized regimes.
- {
- if (nRc>nRstc)
- {
- comsti_c = Index[sti][0]; //composite (s_tc, s_{t-1}c)
- sti_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][0]; //coefficient regime at t.
- stm1i_c = smodel_ps->sv->state_variable[0]->lag_index[comsti_c][1]; //coefficient regime at t-1: tm1: t-1;
- sti_v = sti_c;
- }
- else
- comsti_c = sti_c = sti_v = sti;
- }
-
-
- //--- Setup.
- MatrixTimesMatrix(PHtran_tdata_dm, Pt_tm1_d4->F[tbase0]->C[sti], Ht_dc->C[comsti_c], 1.0, 0.0, 'N', 'T');
-
- //--- Data.
- //- etdata = Y_T(:,tdata) - a(:,tdata) - Htdata*ztdata where tdata = tbase0 = inpt-1.
- yt_sdv.v = yt_dm->M + tbase0*yt_dm->nrows;
- at_sdv.v = at_dm->M + comsti_c*at_dm->nrows; //comsti_c: coefficient regime at time tbase0.
- z0_sdv.v = zt_tm1_dc->C[tbase0]->M + z0_sdv.n*sti; //sti: regime at time tbase0.
- VectorMinusVector(etdata_dv, &yt_sdv, &at_sdv);
- MatrixTimesVector(etdata_dv, Ht_dc->C[comsti_c], &z0_sdv, -1.0, 1.0, 'N');
- //+ Dtdata = Htdata*PHtran_tdata + R(:,:,tbase0);
- CopyMatrix0(Dtdata_dm, Rt_dc->C[sti_v]);
- MatrixTimesMatrix(Dtdata_dm, Ht_dc->C[comsti_c], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- //Done with z0_sdv.v.
- ScalarTimesMatrixSquare(Dtdata_dm, 0.5, Dtdata_dm, 'T', 0.5); //Making it symmetric against some rounding errors.
- //This making-symmetric is very IMPORTANT; otherwise, we will get the matrix being singular message
- // and eigenvalues being negative for the SPD matrix, etc. Then the likelihood becomes either
- // a bad number or a complex number.
- Dtdata_dm->flag = Dtdata_dm->flag | M_SU | M_SL;
-
-
- //=== Updating for next period by integrating out sti..
- if (tp1<T)
- {
- //Updating only up to tbase0=T-2. The values at tp1=T or tbase0=T-1 will not be used in the likelihood function.
-
- //--- Ktp1_t = (F_tp1*PHtran_t+G(:,:,t))/Dt;
- //--- Kt_tdata = (Ft*PHtran_tdata+G(:,:,tdata))/Dtdata where t=tp1 and tdata=t.
- CopyMatrix0(Kt_tdata0_dm, Gt_dc->C[sti_v]);
- MatrixTimesMatrix(Kt_tdata0_dm, Ft_dc->C[stp1i_c], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- BdivA_rrect(Kt_tdata_dm, Kt_tdata0_dm, '/', Dtdata_dm);
- //+ zt_tm1(:,t) = b(:,t) + Ft*zt_tm1(:,tdata) + Kt_tdata*etdata where t=tp1 and tm1=t.
- MatrixTimesVector(ztp1_t_dv, Ft_dc->C[stp1i_c], &z0_sdv, 1.0, 0.0, 'N');
- MatrixTimesVector(ztp1_t_dv, Kt_tdata_dm, etdata_dv, 1.0, 1.0, 'N');
- btp1_sdv.v = bt_dm->M + stp1i_c*btp1_sdv.n;
- VectorPlusMinusVectorUpdate(ztp1_t_dv, &btp1_sdv, 1.0);
- //+ Pt_tm1(:,:,t) = Ft*Ptdata*Fttran - Kt_tdata*Dtdata*Kt_tdatatran + V(:,:,t);
- CopyMatrix0(Ptp1_t_dm, Vt_dc->C[stp1i_v]);
- MatrixTimesMatrix(Wnzbyny_dm, Kt_tdata_dm, Dtdata_dm, 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(Wnzbynz_dm, Wnzbyny_dm, Kt_tdata_dm, 1.0, 0.0, 'N', 'T');
- MatrixPlusMinusMatrixUpdate(Ptp1_t_dm, Wnzbynz_dm, -1.0);
- //Done with all W*_dm.
- MatrixTimesMatrix(Wnzbynz_dm, Ft_dc->C[stp1i_c], Pt_tm1_d4->F[tbase0]->C[sti], 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(W2nzbynz_dm, Wnzbynz_dm, Ft_dc->C[stp1i_c], 1.0, 0.0, 'N', 'T');
- MatrixPlusMatrixUpdate(Ptp1_t_dm, W2nzbynz_dm);
- //Done with all W*_dm.
-
- //--- Integrating out the state at tbase0 using P(s_t|Y_{t-1}, theta) = ElementV(smodel_ps->Z[inpt],s_{inpt}_i).
- //--- Note tbase0 = inpt-1 because the data in DW code (ElementV) is base-1.
- //--- Note at this point, we cannot access to P(s_t|Y_t, theta) = ElementV(smodel_ps->V[inpt],s_{inpt}_i)
- //--- through DW's code. But we can modify my own code to do this later.
- prob_previous_regimes = ElementV(smodel_ps->Z[inpt],sti);
- ScalarTimesVectorUpdate(ztp1_dv, prob_previous_regimes, ztp1_t_dv);
- ScalarTimesMatrix(Ptp1_dm, prob_previous_regimes, Ptp1_t_dm, 1.0);
- Ptp1_dm->flag = M_GE | M_SU | M_SL;
- //Done with ztp1_t_dv and Ptp1_t_dm.
- }
- }
- //--- Filling zt_tm1 and Pt_tm1 for next period
- if (tp1<T)
- {
- z0_sdv.v = zt_tm1_dc->C[tp1]->M + z0_sdv.n*stp1i; //stp1i: regime at time tp1.
- CopyVector0(&z0_sdv, ztp1_dv);
- CopyMatrix0(Pt_tm1_d4->F[tp1]->C[stp1i], Ptp1_dm); //stp1i: regime at time tp1.
- //Done with ztp1_dv, z0_sdv, Ptp1_dm.
- }
- }
- if (tp1<T)
- zt_tm1_dc->C[tp1]->flag = M_GE;
- }
-
-
-//=== ???????? For debugging purpose.
-//if ((inpt>60) && (inpt<65) ) //if (inpt<5)
-//{
-// int kip1; //Must be declared at the top of this "if" block.
-
-// fprintf(FPTR_DEBUG, "zt_tm1t=[\n");
-// WriteMatrix(FPTR_DEBUG, zt_tm1_dc->C[tbase0], " %10.5f ");
-// fprintf(FPTR_DEBUG, "];\n");
-
-// for (ki=0; ki<Pt_tm1_d4->F[tbase0]->ncells; ki++)
-// {
-// kip1 = ki+1;
-// fprintf(FPTR_DEBUG, "Pt_tm1_d4t(:,:,%d)=[\n", kip1);
-// WriteMatrix(FPTR_DEBUG, Pt_tm1_d4->F[tbase0]->C[ki], " %10.5f ");
-// fprintf(FPTR_DEBUG, "];\n");
-// }
-
-// fflush(FPTR_DEBUG);
-//}
-
-
-//=== ???????? For debugging purpose.
-fprintf(FPTR_DEBUG, " loglh_timet = %10.5f\n", loglh_timet);
-fflush(FPTR_DEBUG);
-
-
- //===
- DestroyVector_dz(evals_dzv);
- DestroyVector_lf(evals_abs_dv);
- DestroyMatrix_lf(Wnzbynz_dm);
- DestroyMatrix_lf(Wnz2bynz2_dm);
- DestroyMatrix_lf(W2nz2bynz2_dm);
- DestroyVector_lf(wP0_dv);
- //
- DestroyVector_lf(wny_dv);
- DestroyMatrix_lf(Wnzbyny_dm);
- DestroyMatrix_lf(W2nzbynz_dm);
- DestroyMatrix_lf(PHtran_tdata_dm);
- DestroyVector_lf(etdata_dv);
- DestroyMatrix_lf(Dtdata_dm);
- DestroyMatrix_lf(Kt_tdata0_dm);
- DestroyMatrix_lf(Kt_tdata_dm);
- //
- DestroyVector_lf(ztp1_t_dv);
- DestroyMatrix_lf(Ptp1_t_dm);
- DestroyVector_lf(ztp1_dv);
- DestroyMatrix_lf(Ptp1_dm);
-
- return (loglh_timet);
-}
-#undef LOG2PI
-#endif
-
-
-/**
-//----------------------------------------------------------------
-//-- Tested OK, but has not use because tz_Refresh_z_T7P_T_in_kalfilms_1st_approx()
-//-- cannot access to ElementV(smodel_ps->V[tp1],sti) or ElementV(smodel_ps->V[tbase0],sti)
-//-- because no likelihood has been formed at all before this function is called.
-//----------------------------------------------------------------
-#define LOG2PI (1.837877066409345e+000) //log(2*pi)
-//-----------------------------------------------------
-//- Updating or refreshing all Kalman filter at time t for Markov-switching DSGE model.
-//- WARNING: make sure to call the following functions
-// RunningGensys_const7varionly(lwzmodel_ps);
-// Refresh_kalfilms_*(lwzmodel_ps); //Creates or refreshes kalfilmsinputs_ps at new parameter values.
-//- before using tz_Refresh_z_T7P_T_in_kalfilms_1st_approx().
-//-----------------------------------------------------
-void tz_Refresh_z_T7P_T_in_kalfilms_1st_approx(struct TSkalfilmsinputs_tag *kalfilmsinputs_ps, struct TStateModel_tag *smodel_ps)
-{
- double debug1;
- //--- Local variables
- int stp1i, stp1i_c, stp1i_v, sti, sti_c, sti_v, tbase0, tp1;
- //=== Accessible variables
- int ny = kalfilmsinputs_ps->ny;
- int nz = kalfilmsinputs_ps->nz;
- int nRc = kalfilmsinputs_ps->nRc;
- int nRv = kalfilmsinputs_ps->nRv;
- int T = kalfilmsinputs_ps->T;
- int indxIndRegimes = kalfilmsinputs_ps->indxIndRegimes;
- TSdvector z0_sdv;
- //+ input arguments.
- TSdmatrix *yt_dm = kalfilmsinputs_ps->yt_dm; //ny-by-T.
- TSdmatrix *at_dm = kalfilmsinputs_ps->at_dm; //ny-by-nRc.
- TSdcell *Ht_dc = kalfilmsinputs_ps->Ht_dc; //ny-by-nz-by-nRc.
- TSdcell *Rt_dc = kalfilmsinputs_ps->Rt_dc; //ny-by-ny-by-nRv. Covariance matrix for the measurement equation.
- TSdcell *Gt_dc = kalfilmsinputs_ps->Gt_dc; //nz-by-ny-by-nRv. Cross-covariance.
- //
- TSdmatrix *bt_dm = kalfilmsinputs_ps->bt_dm; //nz-by-nRc.
- TSdcell *Ft_dc = kalfilmsinputs_ps->Ft_dc; //nz-by-nz-by-nRc.
- TSdcell *Vt_dc = kalfilmsinputs_ps->Vt_dc; //nz-by-nz-by-nRv. Covariance matrix for the state equation.
- //
- TSdmatrix *z0_dm = kalfilmsinputs_ps->z0_dm; //nz-by-nRc*nRv or nz-by-nRv, depending on indxIndRegimes.
- TSdcell *P0_dc = kalfilmsinputs_ps->P0_dc; //nz-by-nz-by-nRc*nRv or nz-by-nRv, depending on indxIndRegimes.
- //+ Output arguments.
- TSdcell *zt_tm1_dc = kalfilmsinputs_ps->zt_tm1_dc; //nz-by-nRc*nRv-by-T if indxIndRegimes==1, nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- TSdfourth *Pt_tm1_d4 = kalfilmsinputs_ps->Pt_tm1_d4; //nz-by-nz-by-nRc*nRv-T if indxIndRegimes==1, nz-by-nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- //=== Work arguments.
- int nz2 = square(nz);
- TSdmatrix *Wnzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *Wnz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdmatrix *W2nz2bynz2_dm = CreateMatrix_lf(nz2,nz2);
- TSdvector *wP0_dv = CreateVector_lf(nz2);
- //+
- TSdvector yt_sdv, at_sdv, btp1_sdv; //zt_tm1_sdv, ztp1_t_sdv,
- TSdvector *wny_dv = CreateVector_lf(ny);
- TSdmatrix *Wnzbyny_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *W2nzbynz_dm = CreateMatrix_lf(nz,nz);
- TSdmatrix *PHtran_tdata_dm = CreateMatrix_lf(nz,ny);
- TSdvector *etdata_dv = CreateVector_lf(ny);
- TSdmatrix *Dtdata_dm = CreateMatrix_lf(ny,ny);
- TSdmatrix *Kt_tdata0_dm = CreateMatrix_lf(nz,ny);
- TSdmatrix *Kt_tdata_dm = CreateMatrix_lf(nz,ny);
- //--- For eigenvalue decompositions
- int ki;
- int errflag;
- double eigmax;
- TSdzvector *evals_dzv = evals_dzv = CreateVector_dz(nz);
- TSdvector *evals_abs_dv = CreateVector_lf(nz); //Absolute eigenvalues.
- //--- For updating zt_tm1_dm and Pt_tm1.
- TSdvector *ztp1_t_dv = CreateVector_lf(z0_dm->nrows);
- TSdmatrix *Ptp1_t_dm = CreateMatrix_lf(nz, nz);
- TSdvector *ztp1_dv = CreateVector_lf(z0_dm->nrows);
- TSdmatrix *Ptp1_dm = CreateMatrix_lf(nz, nz);
-
-
- if (smodel_ps->sv->nstates != z0_dm->ncols) fn_DisplayError("kalman.c/tz_Refresh_z_T7P_T_in_kalfilms_1st_approx():\n"
- " Make sure that the column dimension of z0_dm is the same as smodel_ps->sv->nstates");
- if (indxIndRegimes && (nRc>1) && (nRv>1))
- if (smodel_ps->sv->n_state_variables != 2) fn_DisplayError("kalman.c/tz_Refresh_z_T7P_T_in_kalfilms_1st_approx():\n"
- " Number of state variables must be coincide with indxIndRegimes");
-
-
- z0_sdv.n = z0_dm->nrows;
- z0_sdv.flag = V_DEF;
- //
- at_sdv.n = yt_sdv.n = yt_dm->nrows;
- at_sdv.flag = yt_sdv.flag = V_DEF;
- btp1_sdv.n = bt_dm->nrows;
- btp1_sdv.flag = V_DEF;
-
-
- //======= Initial condition. =======
- for (sti=smodel_ps->sv->nstates-1; sti>=0; sti--)
- {
- if (indxIndRegimes && (nRc==1))
- {
- sti_c = 0;
- sti_v = sti;
- }
- else if (indxIndRegimes && (nRv==1))
- {
- sti_c = sti;
- sti_v = 0;
- }
- else if (indxIndRegimes)
- {
- sti_c = smodel_ps->sv->Index[sti][0];
- sti_v = smodel_ps->sv->Index[sti][1];
- }
- else
- {
- sti_c = sti_v = sti;
- }
-
-
- if (!kalfilmsinputs_ps->indxIni)
- {
- InitializeDiagonalMatrix_lf(Wnzbynz_dm, 1.0); //To be used for I(nz) -
- InitializeDiagonalMatrix_lf(Wnz2bynz2_dm, 1.0); //To be used for I(nz2) -
-
- //=== Eigenanalysis to determine the roots to ensure boundedness.
- errflag = eigrgen(evals_dzv, (TSdzmatrix *)NULL, (TSdzmatrix *)NULL, Ft_dc->C[sti_c]);
- if (errflag) fn_DisplayError("kalman.c/tz_Refresh_z_T7P_T_in_kalfilms_1st_approx(): eigen decomposition failed");
- for (ki=nz-1; ki>=0; ki--) evals_abs_dv->v[ki] = sqrt(square(evals_dzv->real->v[ki]) + square(evals_dzv->imag->v[ki]));
- evals_abs_dv->flag = V_DEF;
- eigmax = MaxVector(evals_abs_dv);
- if (eigmax < (1.0+1.0e-14))
- {
- //--- Getting z0_dv: zt_tm1(:,1) = (eye(n_z)-F(:,:,1))\b(:,1);
- MatrixMinusMatrix(Wnzbynz_dm, Wnzbynz_dm, Ft_dc->C[sti_c]);
- z0_sdv.v = z0_dm->M + z0_sdv.n*sti;
- CopySubmatrix2vector(&z0_sdv, 0, bt_dm, 0, sti_c, bt_dm->nrows);
- bdivA_rgens(&z0_sdv, &z0_sdv, '\\', Wnzbynz_dm);
- //Done with Wnzbynz_dm.
- //--- Getting P0_dm: Pt_tm1(:,:,1) = reshape((eye(n_z^2)-kron(F(:,:,1),F(:,:,1)))\V1(:),n_z,n_z);
- tz_kron(W2nz2bynz2_dm, Ft_dc->C[sti_c], Ft_dc->C[sti_c]);
- MatrixMinusMatrix(Wnz2bynz2_dm, Wnz2bynz2_dm, W2nz2bynz2_dm);
- CopySubmatrix2vector(wP0_dv, 0, Vt_dc->C[sti_v], 0, 0, nz2);
- bdivA_rgens(wP0_dv, wP0_dv, '\\', Wnz2bynz2_dm);
- CopySubvector2matrix_unr(P0_dc->C[sti], 0, 0, wP0_dv, 0, nz2);
- //Done with all w*_dv and W*_dm.
- }
- else
- {
- fprintf(stdout, "\n-----------------\n");
- fprintf(stdout, "\nIn regime sti_c=%d and sti_v=%d and at time=%d\n", sti_c, sti_v, 0);
- fn_DisplayError("kalman.c/tz_Refresh_z_T7P_T_in_kalfilms_1st_approx(): the system is non-stationary solutions\n"
- " and the initial conditions must be supplied by, say, input arguments");
- fflush(stdout);
- }
- }
- }
- z0_dm->flag = M_GE;
- CopyMatrix0(zt_tm1_dc->C[0], z0_dm); //At time t=0.
- CopyCell0(Pt_tm1_d4->F[0], P0_dc); //At time t=0.
-
-
-// fprintf(FPTR_DEBUG, "\n zt_tm1_dc->C[0]:\n");
-// WriteMatrix(FPTR_DEBUG, zt_tm1_dc->C[0], " %.16e ");
-// fprintf(FPTR_DEBUG, "\n");
-// fprintf(FPTR_DEBUG, "\n Pt_tm1_d4->F[0]->C[0]:\n");
-// WriteMatrix(FPTR_DEBUG, Pt_tm1_d4->F[0]->C[0], " %.16e ");
-
-
- //============== Updating zt_tm1 and Pt_tm1. ==================
- for (tbase0=0; tbase0<T; tbase0++ )
- {
- //tdata = tbase0 is base-0 timing.
- tp1 = tbase0 + 1; //Next period.
-
- for (stp1i=smodel_ps->sv->nstates-1; stp1i>=0; stp1i--)
- {
- if (indxIndRegimes && (nRc==1))
- {
- stp1i_c = 0;
- stp1i_v = stp1i;
- }
- else if (indxIndRegimes && (nRv==1))
- {
- stp1i_c = stp1i;
- stp1i_v = 0;
- }
- else if (indxIndRegimes)
- {
- stp1i_c = smodel_ps->sv->Index[stp1i][0];
- stp1i_v = smodel_ps->sv->Index[stp1i][1];
- }
- else
- {
- stp1i_c = stp1i_v = stp1i;
- }
-
-
- InitializeConstantVector_lf(ztp1_dv, 0.0); //To be summed over sti.
- InitializeConstantMatrix_lf(Ptp1_dm, 0.0); //To be summed over sti.
- for (sti=smodel_ps->sv->nstates-1; sti>=0; sti--)
- {
- if (indxIndRegimes && (nRc==1))
- {
- sti_c = 0;
- sti_v = sti;
- }
- else if (indxIndRegimes && (nRv==1))
- {
- sti_c = sti;
- sti_v = 0;
- }
- else if (indxIndRegimes)
- {
- sti_c = smodel_ps->sv->Index[sti][0];
- sti_v = smodel_ps->sv->Index[sti][1];
- }
- else
- {
- sti_c = sti_v = sti;
- }
-
- //--- Setup.
- MatrixTimesMatrix(PHtran_tdata_dm, Pt_tm1_d4->F[tbase0]->C[sti], Ht_dc->C[sti_c], 1.0, 0.0, 'N', 'T');
-
- //--- Data.
- //- etdata = Y_T(:,tdata) - a(:,tdata) - Htdata*ztdata where tdata = tbase0 = inpt-1.
- yt_sdv.v = yt_dm->M + tbase0*yt_dm->nrows;
- at_sdv.v = at_dm->M + sti_c*at_dm->nrows; //sti_c: coefficient regime at time tbase0.
- z0_sdv.v = zt_tm1_dc->C[tbase0]->M + z0_sdv.n*sti; //sti: regime at time tbase0.
- VectorMinusVector(etdata_dv, &yt_sdv, &at_sdv);
- MatrixTimesVector(etdata_dv, Ht_dc->C[sti_c], &z0_sdv, -1.0, 1.0, 'N');
- //+ Dtdata = Htdata*PHtran_tdata + R(:,:,tbase0);
- CopyMatrix0(Dtdata_dm, Rt_dc->C[sti_v]);
- MatrixTimesMatrix(Dtdata_dm, Ht_dc->C[sti_c], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- //Done with z0_sdv.v.
-
-
- //=== Updating for next period by integrating out sti..
- if (tp1<T)
- {
- //Updating only up to tbase0=T-2. The values at tp1=T or tbase0=T-1 will not be used in the likelihood function.
-
- //--- Ktp1_t = (F_tp1*PHtran_t+G(:,:,t))/Dt;
- //--- Kt_tdata = (Ft*PHtran_tdata+G(:,:,tdata))/Dtdata where t=tp1 and tdata=t.
- CopyMatrix0(Kt_tdata0_dm, Gt_dc->C[sti_v]);
- MatrixTimesMatrix(Kt_tdata0_dm, Ft_dc->C[stp1i_c], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
- BdivA_rrect(Kt_tdata_dm, Kt_tdata0_dm, '/', Dtdata_dm);
- //+ zt_tm1(:,t) = b(:,t) + Ft*zt_tm1(:,tdata) + Kt_tdata*etdata where t=tp1 and tm1=t.
- MatrixTimesVector(ztp1_t_dv, Ft_dc->C[stp1i_c], &z0_sdv, 1.0, 0.0, 'N');
- MatrixTimesVector(ztp1_t_dv, Kt_tdata_dm, etdata_dv, 1.0, 1.0, 'N');
- btp1_sdv.v = bt_dm->M + stp1i_c*btp1_sdv.n;
- VectorPlusMinusVectorUpdate(ztp1_t_dv, &btp1_sdv, 1.0);
- //+ Pt_tm1(:,:,t) = Ft*Ptdata*Fttran - Kt_tdata*Dtdata*Kt_tdatatran + V(:,:,t);
- CopyMatrix0(Ptp1_t_dm, Vt_dc->C[stp1i]);
- MatrixTimesMatrix(Wnzbyny_dm, Kt_tdata_dm, Dtdata_dm, 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(Wnzbynz_dm, Wnzbyny_dm, Kt_tdata_dm, 1.0, 0.0, 'N', 'T');
- MatrixPlusMinusMatrixUpdate(Ptp1_t_dm, Wnzbynz_dm, -1.0);
- //Done with all W*_dm.
- MatrixTimesMatrix(Wnzbynz_dm, Ft_dc->C[stp1i_c], Pt_tm1_d4->F[tbase0]->C[sti], 1.0, 0.0, 'N', 'N');
- MatrixTimesMatrix(W2nzbynz_dm, Wnzbynz_dm, Ft_dc->C[stp1i_c], 1.0, 0.0, 'N', 'T');
- MatrixPlusMatrixUpdate(Ptp1_t_dm, W2nzbynz_dm);
- //Done with all W*_dm.
-
- //--- Integrating out the state at tbase0 using P(s_t|Y_t, theta) = ElementV(smodel_ps->V[t+1],s_{t+1}_i).
- //--- Note because the data in DW code (ElementV) is base-1, t+1 is actually tbase0.
- debug1 = ElementV(smodel_ps->V[tp1],sti); //?????? Debug.
- //ScalarTimesVectorUpdate(ztp1_dv, ElementV(smodel_ps->V[tp1],sti), ztp1_t_dv);
- //ScalarTimesMatrix(Ptp1_dm, ElementV(smodel_ps->V[tp1],sti), Ptp1_t_dm, 1.0);
- ScalarTimesVectorUpdate(ztp1_dv, 0.5, ztp1_t_dv);
- ScalarTimesMatrix(Ptp1_dm, 0.5, Ptp1_t_dm, 1.0);
- Ptp1_dm->flag = M_GE | M_SU | M_SL;
- //Done with ztp1_t_dv and Ptp1_t_dm.
- }
- }
- //--- Filling zt_tm1 and Pt_tm1 for next period
- if (tp1<T)
- {
- z0_sdv.v = zt_tm1_dc->C[tp1]->M + z0_sdv.n*stp1i; //stp1i: regime at time tp1.
- CopyVector0(&z0_sdv, ztp1_dv);
- CopyMatrix0(Pt_tm1_d4->F[tp1]->C[stp1i], Ptp1_dm); //stp1i: regime at time tp1.
- //Done with ztp1_dv, z0_sdv, Ptp1_dm.
- }
- }
- if (tp1<T)
- zt_tm1_dc->C[tp1]->flag = M_GE;
-
-// fprintf(FPTR_DEBUG, "\n &yt_sdv:\n");
-// WriteMatrix(FPTR_DEBUG, &yt_sdv, " %.16e ");
-// fprintf(FPTR_DEBUG, "\n zt_tm1_dc->C[tp1]:\n");
-// WriteMatrix(FPTR_DEBUG, zt_tm1_dc->C[tp1], " %.16e ");
-// fprintf(FPTR_DEBUG, "\n");
-// fprintf(FPTR_DEBUG, "\n Pt_tm1_d4->F[tp1]->C[0]:\n");
-// WriteMatrix(FPTR_DEBUG, Pt_tm1_d4->F[tp1]->C[0], " %.16e ");
-// fprintf(FPTR_DEBUG, "\n");
-// fflush(FPTR_DEBUG);
-
-
- }
-
- //===
- DestroyVector_dz(evals_dzv);
- DestroyVector_lf(evals_abs_dv);
- DestroyMatrix_lf(Wnzbynz_dm);
- DestroyMatrix_lf(Wnz2bynz2_dm);
- DestroyMatrix_lf(W2nz2bynz2_dm);
- DestroyVector_lf(wP0_dv);
- //
- DestroyVector_lf(wny_dv);
- DestroyMatrix_lf(Wnzbyny_dm);
- DestroyMatrix_lf(W2nzbynz_dm);
- DestroyMatrix_lf(PHtran_tdata_dm);
- DestroyVector_lf(etdata_dv);
- DestroyMatrix_lf(Dtdata_dm);
- DestroyMatrix_lf(Kt_tdata0_dm);
- DestroyMatrix_lf(Kt_tdata_dm);
- //
- DestroyVector_lf(ztp1_t_dv);
- DestroyMatrix_lf(Ptp1_t_dm);
- DestroyVector_lf(ztp1_dv);
- DestroyMatrix_lf(Ptp1_dm);
-}
-//-----------------------------------------------------
-//- Kalman filter at time t for Markov-switching DSGE model.
-//- WARNING: make sure to call the following functions
-// (1) RunningGensys_const7varionly(lwzmodel_ps);
-// (2) Refresh_kalfilms_*(lwzmodel_ps); //Creates or refreshes kalfilmsinputs_ps at new parameter values.
-// (3) tz_Refresh_z_T7P_T_in_kalfilms_1st_approx();
-//- before using kalfilms_timet_1st_approx().
-//-----------------------------------------------------
-double tz_kalfilms_timet_1st_approx(int st, int inpt, struct TSkalfilmsinputs_tag *kalfilmsinputs_ps, struct TStateModel_tag *smodel_ps)
-{
- //st, st_c, and st_v: base-0: deals with the cross-section values at time t where
- // st is a grand regime, st_c is an encoded coefficient regime, and st_c is an encoded volatility regime.
- //inpt: base-1 in the sense that inpt>=1 to deal with the time series situation where S_T is (T+1)-by-1 and Y_T is T+nlags_max-by-1.
- // The 1st element for S_T is S_T[1] while S_T[0] is s_0. The same for (T+1)-by-1 gbeta_dv and nlcoefs-by-(T+1) galpha_dm.
- // The 1st element for Y_T, however, is Y_T[nlags_max+1-1].
- //See (42.3) on p.42 in the SWZII NOTES.
-
-
- //--- Local variables
- int st_c, st_v, tbase0;
- double loglh_timet;
- //--- Accessible variables
- int ny = kalfilmsinputs_ps->ny;
- int nz = kalfilmsinputs_ps->nz;
- int nRc = kalfilmsinputs_ps->nRc;
- int nRv = kalfilmsinputs_ps->nRv;
- int indxIndRegimes = kalfilmsinputs_ps->indxIndRegimes;
- TSdvector z0_sdv;
- //+ input arguments.
- TSdmatrix *yt_dm = kalfilmsinputs_ps->yt_dm; //ny-by-T.
- TSdmatrix *at_dm = kalfilmsinputs_ps->at_dm; //ny-by-nRc.
- TSdcell *Ht_dc = kalfilmsinputs_ps->Ht_dc; //ny-by-nz-by-nRc.
- TSdcell *Rt_dc = kalfilmsinputs_ps->Rt_dc; //ny-by-ny-by-nRv. Covariance matrix for the measurement equation.
- //+ Output arguments.
- TSdcell *zt_tm1_dc = kalfilmsinputs_ps->zt_tm1_dc; //nz-by-nRc*nRv-by-T if indxIndRegimes==1, nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- TSdfourth *Pt_tm1_d4 = kalfilmsinputs_ps->Pt_tm1_d4; //nz-by-nz-by-nRc*nRv-T if indxIndRegimes==1, nz-by-nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- //=== Work arguments.
- TSdvector yt_sdv, at_sdv;
- TSdvector *wny_dv = CreateVector_lf(ny);
- TSdmatrix *PHtran_tdata_dm = CreateMatrix_lf(nz,ny);
- TSdvector *etdata_dv = CreateVector_lf(ny);
- TSdmatrix *Dtdata_dm = CreateMatrix_lf(ny,ny);
-
-
- if (smodel_ps->sv->nstates != zt_tm1_dc->C[0]->ncols) fn_DisplayError("kalman.c/kalfilms_timet_1st_approx():\n"
- " Make sure that the column dimension of zt_tm1_dc->C is the same as smodel_ps->sv->nstates");
-
- tbase0 = inpt - 1; //base-0 time t.
-
- if (indxIndRegimes && (nRc==1))
- {
- st_c = 0;
- st_v = st;
- }
- else if (indxIndRegimes && (nRv==1))
- {
- st_c = st;
- st_v = 0;
- }
- else if (indxIndRegimes)
- {
- if (smodel_ps->sv->n_state_variables != 2) fn_DisplayError("kalman.c/kalfilms_timet_1st_approx():\n"
- " Number of state variables must be coincide with indxIndRegimes");
- st_c = smodel_ps->sv->Index[st][0];
- st_v = smodel_ps->sv->Index[st][1];
- }
- else
- {
- st_c = st_v = st;
- }
-
-
- z0_sdv.n = zt_tm1_dc->C[0]->nrows;
- z0_sdv.flag = V_DEF;
- //
- at_sdv.n = yt_sdv.n = yt_dm->nrows;
- at_sdv.flag = yt_sdv.flag = V_DEF;
-
- //====== Computing the conditional LH at time t. ======
- //--- Setup.
- MatrixTimesMatrix(PHtran_tdata_dm, Pt_tm1_d4->F[tbase0]->C[st], Ht_dc->C[st_c], 1.0, 0.0, 'N', 'T');
-
- //--- Data.
- //- etdata = Y_T(:,tdata) - a(:,tdata) - Htdata*ztdata where tdata = tbase0 = inpt-1.
- yt_sdv.v = yt_dm->M + tbase0*yt_dm->nrows;
- at_sdv.v = at_dm->M + st_c*at_dm->nrows; //st_c: coefficient regime at time tbase0.
- z0_sdv.v = zt_tm1_dc->C[tbase0]->M + z0_sdv.n*st; //st: regime at time tbase0 for zt_tm1.
- VectorMinusVector(etdata_dv, &yt_sdv, &at_sdv);
- MatrixTimesVector(etdata_dv, Ht_dc->C[st_c], &z0_sdv, -1.0, 1.0, 'N');
- //+ Dtdata = Htdata*PHtran_tdata + R(:,:,tbase0);
- CopyMatrix0(Dtdata_dm, Rt_dc->C[st_v]);
- MatrixTimesMatrix(Dtdata_dm, Ht_dc->C[st_c], PHtran_tdata_dm, 1.0, 1.0, 'N', 'N');
-
- //--- Forming the log conditional likelihood at t.
- bdivA_rgens(wny_dv, etdata_dv, '/', Dtdata_dm);
- loglh_timet = -(0.5*ny)*LOG2PI - 0.5*logdeterminant(Dtdata_dm) - 0.5*VectorDotVector(wny_dv, etdata_dv);
- //Done with all w*_dv.
-
-
- //===
- DestroyVector_lf(wny_dv);
- DestroyMatrix_lf(PHtran_tdata_dm);
- DestroyVector_lf(etdata_dv);
- DestroyMatrix_lf(Dtdata_dm);
-
- return (loglh_timet);
-}
-#undef LOG2PI
-/**/
-
-
-
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/kalman.h b/matlab/swz/c-code/utilities/TZCcode/kalman.h
deleted file mode 100644
index 7dc57a642c863ba4159c4d8057787732c862d000..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/kalman.h
+++ /dev/null
@@ -1,300 +0,0 @@
-#ifndef __KALMAN_H__
- #define __KALMAN_H__
-
- #include "tzmatlab.h"
- #include "mathlib.h"
- #include "switch.h"
- #include "fn_filesetup.h" //Used to call WriteMatrix(FPTR_DEBUG,....).
-
-
- typedef struct TSkalcvfurw_tag {
- //urw: univariate random walk kalman filter. Desigend specially for the 2006 AER SWZ paper.
-
- //=== Input arguments.
- int indx_tvsigmasq; //0: constant siqmasq in Kalman updating (default);
- //1: Keyensian (project-specific) type of time-varying sigmasq in Kalman updating; See pp.37 and 37a in SWZ Learning NOTES;
- //2: project-specific type;
- //3: another project-specific type.
- double sigmasq; //Variance for the residual eps(t) of the measurement equation.
- int fss; //T: effective sample size (excluding lags).
- int kx; //dimension for x(t).
- TSdmatrix *V_dm; //kx-by-kx. Covariance (symmetric and positive definite) matrix for the residual eta(t) of the transition equation.
- TSdvector *ylhtran_dv; //1-by-T of y(t). The term lh means lelf hand side and tran means transpose.
- TSdmatrix *Xrhtran_dm; //kx-by-T of x(t). The term rh means right hand side and tran means transpose.
- TSdvector *z10_dv; //kx-by-1. Initial condition for prediction: z_{1|0}.
- TSdmatrix *P10_dm; //kx-by-kx symmetric matrix. Initial condition for the variance of the prediction: P_{1|0}.
-
- //=== Output arguments.
- TSdvector *zupdate_dv; //kx-by-1. z_{T+1|T}.
- TSdmatrix *Zpredtran_dm; //kx-by-T matrix of one-step predicted values of z(t). [z_{2|1}, ..., z_{t+1|t}, ..., z_{T+1|T}].
- //Set to NULL (no output) if storeZ = 0;
- TSdcell *Ppred_dc; //T cells and kx-by-kx symmetric and positive definite matrix for each cell. Mean square errors of predicted state variables.
- //{P_{2|1}, ..., P{t+1|t}, ..., P{T+1|T}. Set to NULL (no output if storeV = 0).
- TSdvector *ylhtranpred_dv; //1-by-T one-step prediction of y(t) or ylhtran_dv. Added 03/17/05.
-
- //=== Function itself.
- void (*learning_fnc)(struct TSkalcvfurw_tag *, void *);
- } TSkalcvfurw; //urw: univariate random walk.
- //
- typedef void TFlearninguni(struct TSkalcvfurw_tag *, void *); //For linear rational expectations models.
-
-
- //=== Better version is TSkalfilmsinputs_1stapp_tag. Kalman filter for constant or known-time-varying DSGE models.
- typedef struct TSkalfiltv_tag
- {
- //General (known-time-varying) Kalman filter for DSGE models.
- // It computes a sequence of one-step predictions and their covariance matrices, and the log likelihood.
- // The function uses a forward recursion algorithm. See also the Matlab function fn_kalfil_tv.m
- //
- // State space model is defined as follows:
- // y(t) = a(t) + H(t)*z(t) + eps(t) (observation or measurement equation)
- // z(t) = b(t) + F(t)*z(t) + eta(t) (state or transition equation)
- // where a(t), H(t), b(t), and F(t) depend on s_t that follows a Markov-chain process and are taken as given.
- //
- // Inputs are as follows:
- // Y_T is a n_y-by-T matrix containing data [y(1), ... , y(T)].
- // a is an n_y-by-T matrix of time-varying input vectors in the measurement equation.
- // H is an n_y-by-n_z-by-T 3-D of time-varying matrices in the measurement equation.
- // R is an n_y-by-n_y-by-T 3-D of time-varying covariance matrices for the error in the measurement equation.
- // G is an n_z-by-n_y-by-T 3-D of time-varying E(eta_t * eps_t').
- // ------
- // b is an n_z-by-T matrix of time-varying input vectors in the state equation with b(:,1) as an initial condition.
- // F is an n_z-by-n_z-by-T 3-D of time-varying transition matrices in the state equation with F(:,:,1) as an initial condition.
- // V is an n_z-by-n_z-by-T 3-D of time-varying covariance matrices for the error in the state equation with V(:,:,1) as an initial condition.
- // ------
- // indxIni: 1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- // 0: using the unconditional mean for any given regime at time 0.
- // z0 is an n_z-by-1 vector of initial condition when indxIni=1. (Not used if indxIni=0.)
- // P0 is an n_z-by-n_z matrix of initial condition when indxIni=1. (Not used if indxIni=0.)
- //
- // Outputs are as follows:
- // loglh is a value of the log likelihood function of the state-space model
- // under the assumption that errors are multivariate Gaussian.
- // zt_tm1 is an n_z-by-T matrices of one-step predicted state vectors with z0_0m1 as a initial condition
- // and with z_{t+1|t} as the last element. Thus, we can use it as a base-1 vector.
- // Pt_tm1 is an n_z-by-n_z-by-T 3-D of covariance matrices of zt_tm1 with P0_0m1 as a initial condition
- // and with P_{t+1|t} as the last element. Thus, we can use it as a base-1 cell.
- //
- // The initial state vector and its covariance matrix are computed under the bounded (stationary) condition:
- // z0_0m1 = (I-F(:,:,1))\b(:,1)
- // vec(P0_0m1) = (I-kron(F(:,:,1),F(:,:,1)))\vec(V(:,:,1))
- // Note that all eigenvalues of the matrix F(:,:,1) are inside the unit circle when the state-space model is bounded (stationary).
- //
- // March 2007, written by Tao Zha
- // See Hamilton's book ([13.2.13] -- [13.2.22]), Harvey (pp.100-106), and LiuWZ Model I NOTES pp.001-003.
-
- //=== Input arguments.
- int ny; //number of observables.
- int nz; //number of state variables.
- int T; //sample size.
- int indxIni; //1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- //0: using the unconditional mean for any given regime at time 0. (Default value)
- TSdmatrix *yt_dm; //ny-by-T.
- TSdmatrix *at_dm; //ny-by-T.
- TSdcell *Ht_dc; //ny-by-nz-by-T.
- TSdcell *Rt_dc; //ny-by-ny-by-T. Covariance matrix for the measurement equation.
- TSdcell *Gt_dc; //nz-by-ny-by-T. Cross-covariance.
- //
- TSdmatrix *bt_dm; //nz-by-T.
- TSdcell *Ft_dc; //nz-by-nz-by-T.
- TSdcell *Vt_dc; //nz-by-nz-by-T. Covariance matrix for the state equation.
- //
- TSdvector *z0_dv; //nz-by-1;
- TSdmatrix *P0_dm; //nz-by-nz.
-
- //=== Output arguments.
- double loglh; //log likelihood.
- TSdmatrix *zt_tm1_dm; //nz-by-T.
- TSdcell *Pt_tm1_dc; //nz-by-nz-T.
- } TSkalfiltv;
-
-
-
- //=== Inputs for filter for Markov-switching DSGE models at any time t.
- typedef struct TSkalfilmsinputs_1stapp_tag
- {
- //Inputs Markov-switching Kalman filter for DSGE models (conditional on all the regimes at time t).
- // It computes a sequence of one-step predictions and their covariance matrices, and the log likelihood.
- // The function uses a forward recursion algorithm. See also the Matlab function fn_kalfil_tv.m
- //
- // State space model is defined as follows:
- // y(t) = a(t) + H(t)*z(t) + eps(t) (observation or measurement equation)
- // z(t) = b(t) + F(t)*z(t) + eta(t) (state or transition equation)
- // where a(t), H(t), b(t), and F(t) depend on the grand regime s_t that follows a Markov-chain process
- // and is taken as given.
- //
- // Inputs at time t are as follows where nst is number of grand regimes (including lagged regime
- // and coefficients and shock variances):
- // Y_T is a n_y-by-T matrix containing data [y(1), ... , y(T)].
- // a is an n_y-by-nst matrix of Markov-switching input vectors in the measurement equation.
- // H is an n_y-by-n_z-by-nst 3-D of Markov-switching matrices in the measurement equation.
- // R is an n_y-by-n_y-by-nst 3-D of Markov-switching covariance matrices for the error in the measurement equation.
- // G is an n_z-by-n_y-by-nst 3-D of Markov-switching E(eta_t * eps_t').
- // ------
- // b is an n_z-by-nst matrix of Markov-switching input vectors in the state equation with b(:,st) as an initial condition.
- // (alternatively, with the ergodic weighted b(:,st) as an initial condition).
- // F is an n_z-by-n_z-by-nst 3-D of Markov-switching transition matrices in the state equation with F(:,:,st)
- // as an initial condition (alternatively, with the ergodic weighted F(:,:,st) as an initial condition).
- // V is an n_z-by-n_z-by-nRv 3-D of Markov-switching covariance matrices for the error in the state equation
- // with V(:,:,st) as an initial condition (alternatively, with the ergodic weighted V(:,:,st) as an initial condition).
- // ------
- // indxIni: 1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- // 0: using the unconditional mean for any given regime at time 0.
- // z0 is an n_z-by-nst matrix of initial condition (Not used if indxIni=0).
- // P0 is an n_z-by-n_z-by-nst 3-D of initial condition (Not used if indxIni=0).
- //
- // The initial state vector and its covariance matrix are computed under the bounded (stationary) condition:
- // z0_0m1 = (I-F(:,:,st))\b(:,st)
- // vec(P0_0m1) = (I-kron(F(:,:,st),F(:,:,st)))\vec(V(:,:,st))
- // Note that all eigenvalues of the matrix F(:,:,st) are inside the unit circle when the state-space model is bounded (stationary).
- //
- // November 2007, written by Tao Zha. Revised, April 2008.
- // See Hamilton's book ([13.2.13] -- [13.2.22]), Harvey (pp.100-106), and LiuWZ Model I NOTES pp.001-003.
-
- //=== Input arguments.
- int ny; //number of observables.
- int nz; //number of state variables.
- int nst; //number of grand composite regimes (current and past regimes, coefficient and volatility regimes).
- int T; //sample size.
- int indxIni; //1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0,
- //0: using the unconditional momnets for any given regime at time 0 (default when indxDiffuse = 0).
- int indxDiffuse; //1: using the diffuse condition for z_{1|0} and P_{1|0} (default option), according to Koopman and Durbin, "Filtering and Smoothing of State Vector for Diffuse State-Space Models," J. of Time Series Analysis, Vol 24(1), pp.85-99.
- //0: using the unconditional moments.
- double DiffuseScale; //A large (infinity) number when indxDiffuse = 1.
- int ztm1_track; //t-1 = -1: no initial conditions z_{1|0} and P_{1|0} has been computed yet, but will be using InitializeKalman_z10_P10(),
- //t-1 >= 0:T-1: z_{t|t-1} and P_{t|t-1} are updated up to t-1.
- int dtm1_track; //t-1 = -1: no etdata_dc->C[0] or Dtdata_d4->F[0] has been computed yet.
- //t-1 >= 0:T-1: etdata_dc->C[t-1] and Dtdata_d4->F[t-1] are updated up to t-1.
-
- TSdmatrix *yt_dm; //ny-by-T.
- TSdmatrix *at_dm; //ny-by-nst.
- TSdcell *Ht_dc; //ny-by-nz-by-nst.
- TSdcell *Rt_dc; //ny-by-ny-by-nst. Covariance matrix for the measurement equation.
- TSdcell *Gt_dc; //nz-by-ny-by-nst. Cross-covariance.
- //
- TSdmatrix *bt_dm; //nz-by-nst.
- TSdcell *Ft_dc; //nz-by-nz-by-nst.
- TSdcell *Vt_dc; //nz-by-nz-by-nst. Covariance matrix for the state equation.
- //
- TSdmatrix *z0_0_dm; //nz-by-nst. z_{0|0}.
- TSdmatrix *z0_dm; //nz-by-nst. z_{1|0}.
- TSdcell *P0_dc; //nz-by-nz-by-nst. P_{1|0}
-
-
- //=== Output arguments only used for 1st order approximation to zt and Pt depending on infinite past regimes.
- TSdcell *zt_tm1_dc; //nz-by-nst-by-(T+1), where z_{1|0} is an initial condition (1st element with t-1=0 or t=1 for base-1) and
- // the terminal condition z_{T+1|T} using Updatekalfilms_1stapp(T, ...) is not computed
- // when the likelihood logTimetCondLH_kalfilms_1stapp() is computed. Thus, z_{T+1|T}
- // has not legal value computed in most applications unless in out-of-sample forecasting problems.
- TSdfourth *Pt_tm1_d4; //nz-by-nz-by-nst-by-(T+1), where P_{1|0} is an initial condition (1st element with t-1=0) and
- // the terminal condition P_{T+1|T} using Updatekalfilms_1stapp(T, ...) is not computed
- // when the likelihood logTimetCondLH_kalfilms_1stapp() is computed. Thus, P_{T+1|T}
- // has not legal value computed in most applications unless in out-of-sample forecasting problems.
- //+ Will be save for updating likelihood and Kalman filter Updatekalfilms_1stapp(), so save time to recompute these objects again.
- TSdfourth *PHtran_tdata_d4; //nz-by-ny-by-nst-T, P_{t|t-1}*H_t'. Saved only for updating Kalman filter Updatekalfilms_1stapp().
- TSdcell *etdata_dc; //ny-by-nst-by-T (with base-0 T), forecast errors e_t in the likelihood.
- TSdcell *yt_tm1_dc; //ny-by-nst-by-T, one-step forecast y_{t|t-1} for t=0 to T-1 (base-0). Used to back out structural shocks.
- TSdfourth *Dtdata_d4; //ny-by-ny-nst-by-T, forecast covariance D_t in the likelihood. Saved for updating Kalman filter Updatekalfilms_1stapp().
- } TSkalfilmsinputs_1stapp;
-
-
- //=== OLD Code: Inputs for filter for Markov-switching DSGE models at any time t.
- typedef struct TSkalfilmsinputs_tag
- {
- //Inputs Markov-switching Kalman filter for DSGE models (conditional on all the regimes at time t).
- // It computes a sequence of one-step predictions and their covariance matrices, and the log likelihood.
- // The function uses a forward recursion algorithm. See also the Matlab function fn_kalfil_tv.m
- //
- // State space model is defined as follows:
- // y(t) = a(t) + H(t)*z(t) + eps(t) (observation or measurement equation)
- // z(t) = b(t) + F(t)*z(t) + eta(t) (state or transition equation)
- // where a(t), H(t), b(t), and F(t) depend on s_t that follows a Markov-chain process and are taken as given.
- //
- // Inputs at time t are as follows where nRc is number of regimes for coefficients
- // nRv is number of regimes for volatility (shock variances):
- // Y_T is a n_y-by-T matrix containing data [y(1), ... , y(T)].
- // a is an n_y-by-nRc matrix of Markov-switching input vectors in the measurement equation.
- // H is an n_y-by-n_z-by-nRc 3-D of Markov-switching matrices in the measurement equation.
- // R is an n_y-by-n_y-by-nRv 3-D of Markov-switching covariance matrices for the error in the measurement equation.
- // G is an n_z-by-n_y-by-nRv 3-D of Markov-switching E(eta_t * eps_t').
- // ------
- // b is an n_z-by-nRc matrix of Markov-switching input vectors in the state equation with b(:,1) as an initial condition.
- // F is an n_z-by-n_z-by-nRc 3-D of Markov-switching transition matrices in the state equation with F(:,:,1) as an initial condition.
- // V is an n_z-by-n_z-by-nRv 3-D of Markov-switching covariance matrices for the error in the state equation with V(:,:,1) as an initial condition.
- // ------
- // indxIndRegimes: 1: coefficient regime and volatility regime are independent; 0: these two regimes are synchronized completely.
- // indxIni: 1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- // 0: using the unconditional mean for any given regime at time 0.
- // z0 is an n_z-by-nRc*nRv matrix of initial condition when indxIni=1 and indxIndRegimes=1. (Not used if indxIni=0.)
- // z0 is an n_z-by-nRv matrix of initial condition when indxIni=1 and indxIndRegimes=0. (Not used if indxIni=0.)
- // P0 is an n_z-by-n_z-by-nRc*nRv 3-D of initial condition when indxIni=1 and indxIndRegimes=1. (Not used if indxIni=0.)
- // P0 is an n_z-by-n_z-by-nRv 3-D of initial condition when indxIni=1 and indxIndRegimes=0. (Not used if indxIni=0.)
- //
- // The initial state vector and its covariance matrix are computed under the bounded (stationary) condition:
- // z0_0m1 = (I-F(:,:,1))\b(:,1)
- // vec(P0_0m1) = (I-kron(F(:,:,1),F(:,:,1)))\vec(V(:,:,1))
- // Note that all eigenvalues of the matrix F(:,:,1) are inside the unit circle when the state-space model is bounded (stationary).
- //
- // November 2007, written by Tao Zha
- // See Hamilton's book ([13.2.13] -- [13.2.22]), Harvey (pp.100-106), and LiuWZ Model I NOTES pp.001-003.
-
- //=== Input arguments.
- int ny; //number of observables.
- int nz; //number of state variables.
- int nRc; //number of composite regimes (current and past regimes) for coefficients.
- int nRstc; //number of coefficient regimes at time t.
- int nRv; //number of regimes for volatility (shock variances).
- int indxIndRegimes; //1: coefficient regime and volatility regime are independent; 0: these two regimes are synchronized completely.
- int T; //sample size.
- int indxIni; //1: using the initial condition with zt_tm1(:,1)=z0 and Pt_tm1(:,:,1)=P0;
- //0: using the unconditional mean for any given regime at time 0. (Default value)
- TSdmatrix *yt_dm; //ny-by-T.
- TSdmatrix *at_dm; //ny-by-nRc.
- TSdcell *Ht_dc; //ny-by-nz-by-nRc.
- TSdcell *Rt_dc; //ny-by-ny-by-nRv. Covariance matrix for the measurement equation.
- TSdcell *Gt_dc; //nz-by-ny-by-nRv. Cross-covariance.
- //
- TSdmatrix *bt_dm; //nz-by-nRc.
- TSdcell *Ft_dc; //nz-by-nz-by-nRc.
- TSdcell *Vt_dc; //nz-by-nz-by-nRv. Covariance matrix for the state equation.
- //
- TSdmatrix *z0_dm; //nz-by-nRc*nRv if indxIndRegimes == 1 or nz-by-nRv if indxIndRegimes == 0.
- TSdcell *P0_dc; //nz-by-nz-by-nRc*nRv if indxIndRegimes == 1 or nz-by-nz-by-nRv if indxIndRegimes == 0.
-
-
- //=== Output arguments only used for 1st order approximation to zt and Pt depending on infinite past regimes.
- TSdcell *zt_tm1_dc; //nz-by-nRc*nRv-by-T if indxIndRegimes==1, nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- TSdfourth *Pt_tm1_d4; //nz-by-nz-by-nRc*nRv-T if indxIndRegimes==1, nz-by-nz-by-nRv-by-T if indxIndRegimes==0 where nRc=nRv.
- } TSkalfilmsinputs;
-
-
-
-
- //--- Functions for univariate random walk kalman filter.
- TSkalcvfurw *CreateTSkalcvfurw(TFlearninguni *func, int T, int k, int tv); //, int storeZ, int storeV);
- TSkalcvfurw *DestroyTSkalcvfurw(TSkalcvfurw *kalcvfurw_ps);
- void kalcvf_urw(TSkalcvfurw *kalcvfurw_ps, void *dummy_ps);
-
- //--- New Code: Functions for Markov-switching Kalman filter.
- struct TSkalfilmsinputs_1stapp_tag *CreateTSkalfilmsinputs_1stapp(int ny, int nz, int nst, int T);
- struct TSkalfilmsinputs_1stapp_tag *DestroyTSkalfilmsinputs_1stapp(struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps);
- int InitializeKalman_z10_P10(struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps, TSdmatrix *z10_dm, TSdcell *P10_dc);
- double logTimetCondLH_kalfilms_1stapp(int st, int inpt, struct TSkalfilmsinputs_1stapp_tag *kalfilmsinputs_1stapp_ps, struct TStateModel_tag *smodel_ps);
-
-
-
- //--- OLD Code: Functions for general constant Kalman filter.
- struct TSkalfiltv_tag *CreateTSkalfiltv(int ny, int nz, int T);
- struct TSkalfiltv_tag *DestroyTSkalfiltv(struct TSkalfiltv_tag *kalfiltv_ps);
- //Used to test tz_logTimetCondLH_kalfiltv(). (Done April 08). double tz_kalfiltv(struct TSkalfiltv_tag *kalfiltv_ps);
- double tz_logTimetCondLH_kalfiltv(int st, int inpt, struct TSkalfiltv_tag *kalfiltv_ps);
-
- //--- OLD Code: Functions for Markov-switching Kalman filter.
- struct TSkalfilmsinputs_tag *CreateTSkalfilmsinputs(int ny, int nz, int nRc, int nRstc, int nRv, int indxIndRegimes, int T);
- struct TSkalfilmsinputs_tag *DestroyTSkalfilmsinputs(struct TSkalfilmsinputs_tag *kalfilmsinputs_ps);
- double tz_logTimetCondLH_kalfilms_1st_approx(int st, int inpt, struct TSkalfilmsinputs_tag *kalfilmsinputs_ps, struct TStateModel_tag *smodel_ps);
- //IMPORTANT NOTE: in the Markov-switching input file datainp_markov*.prn, it MUST be that
- // the coefficient regime is the 1st state variable, and
- // the volatility regime is the 2nd state variable.
-#endif
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/lapack_compat.h b/matlab/swz/c-code/utilities/TZCcode/lapack_compat.h
deleted file mode 100644
index 97f035a3529ee8b3c67b76a73c0be7388234422b..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/lapack_compat.h
+++ /dev/null
@@ -1,24 +0,0 @@
-// Created: August 4,2009
-
-#ifndef __LAPACKCOMPAT__
-#define __LAPACKCOMPAT__
-
-#define USE_LAPACK
-
-#if defined(USE_LAPACK)
- #include "blas_lapack.h"
-#endif
-
-#define dgetrf dgetrf_
-#define dgesv dgesv_
-#define dpotrf dpotrf_
-#define dsyev dsyev_
-#define dgeev dgeev_
-#define dpotri dpotri_
-#define vdDiv vdDiv_
-#define vdInv vdInv_
-#define vdSqrt vdSqrt_
-#define vdLn vdLn_
-#define vdExp vdExp_
-#endif
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/mathlib.c b/matlab/swz/c-code/utilities/TZCcode/mathlib.c
deleted file mode 100644
index bd3fa2739424b712376858b94e549f36c777a956..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/mathlib.c
+++ /dev/null
@@ -1,5505 +0,0 @@
-#include "mathlib.h"
-#include "math.h"
-
-//=======================================================
-// LAPACK routines -- all based on Intel MKL (or IMSL C Math library)
-//=======================================================
-#if defined (INTELCMATHLIBRARY)
-int lurgen(TSdmatrix *lu_dm, TSivector *pivot_dv, TSdmatrix *x_dm) {
- // PLU = x_dm from the LU decomposition of the input matrix x_dm where P is a permutation matrix, L is lower triangular with unit
- // diagonal elements (lower trapezoidal if nrows>ncols) and U is upper triangular (upper trapezoidal if nrows<ncols).
- // L: (1) If nrows <= ncols, nrows-by-nrows .
- // (2) If nrows > ncols, nrows-by-ncols (lower trapezoidal).
- // U: (1) If nrows <= ncols, nrows-by-ncols (upper trapezoidal).
- // (2) If nrows > ncols, ncols-by-ncols.
- //
- //Outputs:
- // lu_dm: Stack L and U in this nrows-by-ncols matrix where the unit diagonal elements of L are not stored.
- // pivot_dv: Optional. An min(nrows, ncols) vector of index integers such that row i was interchanged with row pivot_dv->v[i].
- // When NULL, this output argument is not exported (but computed anyway by the MKL hard-coded function).
- //Inputs:
- // x_dm: nrows-by-ncols general real matrix.
-
- int nrows, ncols, mindim,
- errflag=2; //errflag=0 implies a successful execution. But we start with 2 so as to let dgetrf_ export a correct flag.
- int *pivot_p=NULL;
- double *LU;
-
- //=== Checking dimensions and memory allocation.
- if ( !lu_dm || !x_dm ) fn_DisplayError(".../mathlib.c/lurgen(): The input arguments lu_dm and x_dm must be cretaed (memory-allocated)");
- else if ( ( (nrows=x_dm->nrows) != lu_dm->nrows) || ( (ncols=x_dm->ncols) != lu_dm->ncols) )
- fn_DisplayError(".../mathlib.c/lurgen(): Make sure the dimensions of the input matricies lu_dm and x_dm are the same");
-
- if ( !(x_dm->flag & M_GE) )
- {
- if (x_dm->flag & M_SU) SUtoGE(x_dm);
- else if (x_dm->flag & M_SL) SLtoGE(x_dm);
- else fn_DisplayError(".../mathlib.c/lurgen(): Haven't got time to make M_UT, M_LT, and other to a general matrix M_GE");
- }
- //else if ( !(x_dm->flag & M_GE) ) fn_DisplayError(".../mathlib.c/lurgen(): The input arguments x_dm must be a general real matrix with the flag M_GE");
-
-
- mindim = _min(nrows, ncols);
- memcpy((LU=lu_dm->M), x_dm->M, nrows*ncols*sizeof(double));
- lu_dm->flag = M_UT; //To make the lower part of lu_dm available, one must create another matrix and explicitly make it a unit lower matrix.
-
- //=== Calling the MKL function.
- if (!pivot_dv) {
- pivot_p = tzMalloc(mindim, int);
- dgetrf_(&nrows, &ncols, LU, &nrows, pivot_p, &errflag);
- free(pivot_p); //Frees the memory belonging to this function.
- }
- else {
- if ( pivot_dv->n != mindim) fn_DisplayError("Make sure the dimension of the input vector pivot_dv is the minimum number of row number and column number of the input matrix x_dm");
- dgetrf_(&nrows, &ncols, LU, &nrows, pivot_dv->v, &errflag);
- }
-
-
- return( errflag ); //(1) If errflag = 0, success. (2) If errorflag = -i, the ith parameter has an illegal value.
- //(3) If errflag = i, u_{ii}=0.0. The factorization is completed, but U is exactly singular. Dividing
- // by 0.0 will occur if you use the factor U for solving a system of linear equations.
-}
-#else
-//No default routine yet.
-#endif
-
-
-#if defined (INTELCMATHLIBRARY)
-int eigrsym(TSdvector *eval_dv, TSdmatrix *eVec_dm, const TSdmatrix *S_dm)
-{
- // Outputs (dependent on Intel MKL):
- // eval_dv: _n-by-1 eigenvalues in ascending order;
- // eVec_dm: _n-by-_n eigenvalues -- if (eVec_m==NULL), no eigenvectors are computed; otherwise, S_dm = eVec_dm*diag(eval_dv)*inv(eVec_dm).
- // errflag: error flag.
- //------------
- // Inputs:
- // S_dm: _n-by_n real symmetric matrix.
- //
- // Eigenanalysis of real symmetric square matrix with all eigenvalues and, optionally, eigenvectors.
- // Experts' opinion: do NOT use Cuppen's divide-and-conquer algorithm; instead, use QR algorithm, which I guess this algorithm uses.
-
- int n1, _n, errflag=2, //errflat=0 implies successful decomposition. But we start with 2 so as to let dsyev_ export a correct flag.
- lwork;
- double *tmpd0_m = NULL,
- *work_p = NULL;
-
- if ( !S_dm || !(S_dm->flag & (M_SU | M_SL)) ) fn_DisplayError(".../mathlib.c/eigrsym(): input matrix (1) must be created (memory-alloacted) and (2) must be symmetric (either M_SU or M_SL)");
- if ( !eval_dv ) fn_DisplayError(".../mathlib.c/eigrsym(): input eigenvalue vector must be created (memory-allocated)");
- lwork = (n1=_n=S_dm->nrows)*BLOCKSIZE_FOR_INTEL_MKL;
-
-
- //=== Memory allocated for this function.
- tmpd0_m = tzMalloc(square(_n), double),
- work_p = tzMalloc(lwork, double);
-
-
- //---------------------------
- // Obtains eigenvalues and, optionally, eigenvectors.
- //---------------------------
- memcpy(tmpd0_m, S_dm->M, square(_n)*sizeof(double));
- dsyev_( (eVec_dm) ? "V" : "N", (S_dm->flag & M_SU) ? "U" : "L", &n1, tmpd0_m, &n1, eval_dv->v, work_p, &lwork, &errflag);
- if (work_p[0]>lwork) printf("Warning for /mathlib.c/eigrsym(): needs at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work_p[0], lwork);
- eval_dv->flag = V_DEF;
- if (eVec_dm) {
- memcpy(eVec_dm->M, tmpd0_m, square(_n)*sizeof(double));
- eVec_dm->flag = M_GE;
- }
-
-
- //---------------------------
- // Frees the allocated memory.
- //---------------------------
- tzDestroy(tmpd0_m);
- tzDestroy(work_p);
-
- //if (errflag<0) fn_DisplayError("/Subfolder: Calling eigrsym_decomp -- some element in input matrix has an illegal value");
- //else if (errflag>0) fn_DisplayError("/Subfolder: Calling eigrsym_decomp -- the factor U is exactly singular, so the solution cannot be computed");
- return (errflag);
-}
-#else
-//Not default routine yet.
-#endif
-
-
-
-#if defined (INTELCMATHLIBRARY)
-int eigrgen(TSdzvector *vals_dzv, TSdzmatrix *rights_dzm, TSdzmatrix *lefts_dzm, const TSdmatrix *x_dm)
-{
- //--- Eigenanalysis of real general (non-symmetric) square matrix with all eigenvalues and, optionally, eigenvectors. ---
- //
- //Outputs (dependent on Intel MKL):
- // vals_dzv->real->v: _n-by-1 real parts of eigenvalues;
- // vals_dzv->imag->v: _n-by-1 imaginary parts of eigenvalues -- must be *initialized to zero* in this function;
- // rights_dzm->real->M: if (rights_dzm==NULL), no right eigenvectors are computed; otherwise, _n-by-_n corresponding *real* parts of right eigenvectors column by column: A*v(j)=lambda(j)*v(j);
- // if (rights_dzm!=NULL), lefts_dzm->Mi must be *initialized to zero* in this function to get _n-by-_n *imaginary* parts of left eigenvectors corresponding to vals_dzv.
- // lefts_dzm->imag->M: if (lefts_dzm==NULL), no left eigenvectors are computed; otherwise, n-by-n corresponding *real* parts of left eigenvectors column by column: u(j)^H*A=lambda(j)*u(j)^H, where H means conjugate transpose;
- // if (lefts_dzm!=NULL), lefts_dzm->Mi must be *initialized to zero* in this function to get _n-by-_n *imaginary* parts of right eigenvectors corresponding to vals_dzv.
- // returned errflag: error flag. If errflag<0, some element in input matrix has an illegal value.
- // If errflag>0, the QR algorithm failed to compute all the eigenvalues and no eigenvectors have been computed.
- // if errflag=0, we have a successful decomposition.
- //------------
- // Inputs:
- // x_dm: _n-by_n real general (non-symmetric) matrix.
-
- int errflag=2, //errflag=0 implies successful decomposition. But we start with 2 so as to let dgeev_ export a correct flag.
- _n, lwork, n1, _i, _j;
- double *tmpd0_m=NULL,
- *work_p=NULL,
- *x_m=NULL,
- *evalr_v=NULL,
- *evali_v=NULL,
- *revecr_m=NULL, *reveci_m=NULL, //NULL means that by default we dont' compute eigenvectors.
- *levecr_m=NULL, *leveci_m=NULL;
-
- //---------------------------
- // Checking dimensions, etc.
- //---------------------------
- if ( !x_dm || !vals_dzv )
- fn_DisplayError(".../mathlib.c/eigrgen(): Input square matrix x_dm and eigen value vectors vals_dzv must be created (memory allocated) before the call to this function");
- else {
- _n = x_dm->nrows;
- lwork = _n*BLOCKSIZE_FOR_INTEL_MKL;
- n1 = _n;
- tmpd0_m = tzMalloc(square(_n), double), //@@Must be freed in this function.@@
- work_p = tzMalloc(lwork, double), //@@Must be freed in this function.@@
- InitializeConstantVector_lf(vals_dzv->imag, 0.0); //Imaginary part must be initialized to 0.0 to testing purposes later on.
- //
- x_m = x_dm->M;
- evalr_v = vals_dzv->real->v;
- evali_v = vals_dzv->imag->v;
- }
- if ( _n!=vals_dzv->real->n || _n!=x_dm->ncols ) fn_DisplayError(".../mathlib.c/eigrgen(): (1)input real matrix x_dm must be square; (2) the length of vals_dzv must match the dimension of x_dm");
- if (rights_dzm) {
- if ( _n!=rights_dzm->real->nrows || _n!=rights_dzm->real->ncols ) fn_DisplayError(".../mathlib.c/eigrgen(): rights_dzm must have the same dimension as the input square matrix");
- revecr_m = rights_dzm->real->M; // (rights_dzm) ? rights_dzm->real->M : NULL,
- rights_dzm->real->flag = M_GE;
- InitializeConstantMatrix_lf(rights_dzm->imag, 0.0);
- reveci_m = rights_dzm->imag->M;
- }
- if (lefts_dzm) {
- if ( _n!=lefts_dzm->real->nrows || _n!=lefts_dzm->real->ncols ) fn_DisplayError(".../mathlib.c/eigrgen(): lefts_dzm must have the same dimension as the input square matrix");
- levecr_m = lefts_dzm->real->M; // (lefts_dzm) ? lefts_dzm->real->M : NULL,
- lefts_dzm->real->flag = M_GE;
- InitializeConstantMatrix_lf(lefts_dzm->imag, 0.0);
- leveci_m = lefts_dzm->imag->M;
- }
-
-
-
- //---------------------------
- // Starts with x_m -- the matrix to be decomposed.
- //---------------------------
- memcpy(tmpd0_m, x_m, square(_n)*sizeof(double));
-
- //---------------------------
- // Obtains eigenvalues and, optionally, eigenvectors.
- //---------------------------
- dgeev_( (levecr_m) ? "V" : "N", (revecr_m) ? "V" : "N", &n1, tmpd0_m, &n1, evalr_v, evali_v,
- levecr_m, &n1, revecr_m, &n1, work_p, &lwork, &errflag);
- vals_dzv->real->flag = V_DEF;
-
- //---------------------------
- // Frees the allocated memory.
- //---------------------------
- if (work_p[0]>lwork) printf("Warning for /mathlib.c/eigrgen(): needs at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work_p[0], lwork);
- tzDestroy(work_p);
- tzDestroy(tmpd0_m);
-
- //---------------------------
- // Checks error conditions.
- // Exports final results.
- //---------------------------
- if (errflag) return( errflag );
- else {
- if (revecr_m) { //Tested against Matlab output. Works! 10/13/02.
- for (_j=0; _j<_n-1; _j++)
- if (evali_v[_j] && (evali_v[_j] == -evali_v[_j+1]))
- for (_i=0; _i<_n; _i++) {
- reveci_m[_i+(_j+1)*_n] = -(reveci_m[_i+_j*_n]=revecr_m[_i+(_j+1)*_n]);
- revecr_m[_i+(_j+1)*_n] = revecr_m[_i+_j*_n];
- }
- }
- if (levecr_m) { //!!WARNINGS!!: Hasn't tested against any other established program, but it seems working. 10/13/02.
- for (_j=0; _j<_n-1; _j++)
- if (evali_v[_j] && (evali_v[_j] == -evali_v[_j+1]))
- for (_i=0; _i<_n; _i++) {
- leveci_m[_i+(_j+1)*_n] = -(leveci_m[_i+_j*_n]=levecr_m[_i+(_j+1)*_n]);
- levecr_m[_i+(_j+1)*_n] = levecr_m[_i+_j*_n];
- }
- }
- return( errflag );
- }
-}
-#else
-//Not default routine yet.
-#endif
-
-#if defined (INTELCMATHLIBRARY)
-int chol(TSdmatrix *D_dm, TSdmatrix *S_dm, const char ul) {
- //?????????? Some of options are NOT tested yet.
- // Choleski decomposition of a symmetric, positive definite matrix S. Intel MKL Lapack dependent code.
- // The fastest way for chol() is to let D = S, but D will be replaced by the Choleski factor.
- //
- //Outputs:
- // D: _n-by_n -- if ul=='U' or 'u', D'*D = S where D is stored only in the upper triangular part;
- // if ul=='L' or 'l', D*D' = S where D is stored only in the lower triangular part.
- // If D_dm->M == S_dm->M, D_dm->M (and S_dm->M) will be replaced by the triangular Choleski factor after the call to this function.
- // errflag: error flag: 0: successful;
- // -6: not symmetric (see mklman.pdf for other error return codes on ?potrf().
- //--------
- //Inputs:
- // S: _n-by-_n symmetric, positive definite matrix (whose only triangular part is used by dpotrf_).
- // ul: if =='U' or 'u', D (NOT necessarily S unless D == S) is upper triangular; if =='L' or 'l', D (NOT necessarily S unless D == S) is lower triangular.
-
- int errflag=2, loc, nrows, _m, _i, _j; //errflat=0 implies successful decomposition. But we start with 2 so as to let dpotrf_ export a correct flag.
- double *D, *S;
-
-
- if ( !D_dm || !S_dm ) fn_DisplayError(".../mathlib.c/chol(): L and R input square matricies must be created (memory allocated)");
- else {
- nrows = S_dm->nrows;
- _m = nrows; //Used by Lapack.
- D = D_dm->M;
- S = S_dm->M;
- }
- if ( (nrows != D_dm->ncols) || (nrows != S_dm->nrows) || (nrows != S_dm->ncols) ) fn_DisplayError(".../mathlib.c/chol(): Make sure both R and L input matricies are square and have the same dimension");
-
-
- //=== Fills the triangular part that is used for Choleski decomposition.
- if ( D != S) {
- switch (ul) {
- case 'U': case 'u':
- if (S_dm->flag & M_SU) {
- for (_j=0; _j<nrows; _j++)
- for (_i=0; _i<=_j; _i++) {
- loc=mos(_i,_j,nrows);
- D[loc] = S[loc];
- }
- D_dm->flag = M_UT;
- }
- else if (S_dm->flag & M_SL) {
- for (_j=0; _j<nrows; _j++)
- for (_i=0; _i<=_j; _i++)
- D[mos(_i,_j,nrows)] = S[mos(_j,_i,nrows)];
- D_dm->flag = M_UT;
- }
- else
- {
- //fn_DisplayError(".../mathlib.c/chol(): R input square matrix must be symmetric (and positive definite)");
- printf("\n ------- .../mathlib.c/chol(): R input square matrix must be symmetric!-------\n");
- return (-6);
- }
- dpotrf_("U", &_m, D, &_m, &errflag);
- break;
- case 'L': case 'l':
- if (S_dm->flag & M_SL) {
- for (_j=0; _j<nrows; _j++) {
- //for (_i=0; _i<_j; _i++) D[_i+_j*nrows] = 0.0; //Initializes the other part of D to zero so as to make it visible and readable.
- for (_i=_j; _i<nrows; _i++) {
- loc=mos(_i,_j,nrows);
- D[loc] = S[loc];
- }
- }
- D_dm->flag = M_LT;
- }
- else if (S_dm->flag & M_SU) {
- //????????????? NOT teste yet for this option.
- for (_j=0; _j<nrows; _j++)
- for (_i=_j; _i<nrows; _i++)
- D[mos(_i,_j,nrows)] = S[mos(_j,_i,nrows)];
- D_dm->flag = M_LT;
- }
- else
- {
- //fn_DisplayError(".../mathlib.c/chol(): R input square matrix must be symmetric (and positive definite)");
- printf("\n ------- .../mathlib.c/chol(): R input square matrix must be symmetric!-------\n");
- return (-6);
- }
- //??????NOT tested yet.
- dpotrf_("L", &_m, D, &_m, &errflag);
- break;
- default:
- fn_DisplayError(".../mathlib.c/chol(): Input ul must be either 'U' or 'L'");
- }
- }
- else {
- if ( (ul=='U' || ul=='u') && (D_dm->flag & M_SU) ) {
- dpotrf_("U", &_m, D, &_m, &errflag);
- D_dm->flag = M_UT;
- }
- else if ( (ul=='L' || ul=='l') && (D_dm->flag & M_SL) ) {
- //Tested. It works!
- dpotrf_("L", &_m, D, &_m, &errflag);
- D_dm->flag = M_LT;
- }
- else {
- printf("\nFatal Error: The input ul is %c and the flag D_dm->flag is %d", ul, D_dm->flag);
- fn_DisplayError(".../mathlib.c/chol(): When D==S, upper or lower triangular output must be consistent with upper or lower symmetric input; otherwise, use the option with D != S");
- }
- }
- //=== Choleski decomposition.
- // dpotrf_(((ul=='u') || (ul=='U')) ? "U" : "L", &_m, D, &_m, &errflag);
- //---
- // if (errflag<0) fn_DisplayError("Some element has an illegal value");
- // else if (errflag>0) fn_DisplayError("The leadding minor of some order, hence the entire matrix, is not positive definite");
- return (errflag);
-}
-#else
-//No default routine yet.
-#endif
-
-
-#if defined (INTELCMATHLIBRARY)
-int invrtri(TSdmatrix *X_dm, TSdmatrix *A_dm, const char un)
-{
- //Inverse of a real triangular matrix A.
- //The fastest way is to let X=A and A (and X) will be replaced by inv(A).
- //
- //Outputs:
- // X: _n-by_n inverse of A;
- // errflag: error flag (=0 means successful).
- //--------
- //Inputs:
- // A: _n-by-_n real triangular matrix.
- // un: if un=='U' or 'u', A is unit triangular; otherwise (un=='N' or 'n', A is not a unit triangular matrix.
-
- int _n, errflag=2; //errflat=0 implies successful decomposition. But we start with 2 so as to let dgetri_ export a correct flag.
- double *X, *A;
-
-
- if ( !X_dm || !A_dm ) fn_DisplayError(".../mathlib.c/invrtri(): Both input matrices must be created (memory-allocated)");
- else if ( !(A_dm->flag & (M_UT | M_LT)) ) fn_DisplayError(".../mathlib.c/invrtri(): (1) R input matrix A must be given legal values; (2) A must be a real triangular matrix, i.e., M_UT or M_LT");
- else {
- X = X_dm->M;
- A = A_dm->M;
- _n=A_dm->nrows;
- }
- if ( (_n != A_dm->ncols) || (_n != X_dm->nrows) || (_n != X_dm->ncols) )
- fn_DisplayError(".../mathlib.c/invrtri(): both input and output matrices (1) must be square and (2) must have the same dimension");
-
-
- if (X==A) {
- dtrtri_((A_dm->flag & M_UT) ? "U" : "L", (un=='U' || un=='u') ? "U" : "N", &_n, X, &_n, &errflag);
- if (errflag) return (errflag);
- }
- else {
- memcpy(X, A, _n*_n*sizeof(double));
- dtrtri_((A_dm->flag & M_UT) ? "U" : "L", (un=='U' || un=='u') ? "U" : "N", &_n, X, &_n, &errflag);
- if (errflag) return (errflag);
- else X_dm->flag = A_dm->flag;
- }
-
- return errflag; //(1) If errflag = 0, success. (2) If errorflag = -i, the ith parameter has an illegal value.
- //(3) If errflag = i, the ith diagonal element of A is zero, A is singular, and the inversion
- // could not be completed.
-}
-#else
-//No default routine yet.
-#endif
-
-
-#if defined (INTELCMATHLIBRARY)
-int invspd(TSdmatrix *X_dm, TSdmatrix *A_dm, const char ul)
-{
- //Inverse of a symmetric positive matrix A.
- //Fastest way: let X=A. Then, A (and X) will be replaced by inv(A).
- //
- //Outputs:
- // X: _n-by_n inverse of A;
- // errflag: error flag (=0 means successful).
- //--------
- //Inputs:
- // A: _n-by-_n symmetric positive matrix.
- // ul: if ul=='U' or 'u', only upper part of A is used; otherwise (un=='L' or 'l', only lower part of A is used.
-
- int _n, errflag=2; //errflat=0 implies successful decomposition. But we start with 2 so as to let dgetri_ export a correct flag.
- double *X, *A;
-
-
- if ( !X_dm || !A_dm ) fn_DisplayError(".../mathlib.c/invspd(): Both input matrices must be created (memory-allocated)");
- else if ( !(A_dm->flag & (M_SU | M_SL)) ) fn_DisplayError(".../mathlib.c/invspd(): (1) R input matrix A must be given legal values; (2) A must be symmetric, positive-definite, i.e., M_SU or M_SL");
- else {
- X = X_dm->M;
- A = A_dm->M;
- _n=A_dm->nrows;
- }
-
-
- if (X==A) {
- if ( (_n != A_dm->ncols) )
- fn_DisplayError(".../mathlib.c/invspd(): input matrix (1) must be square and (2) must have the same dimension");
- //=== Choleski decomposition.
- dpotrf_(((ul=='U') || (ul=='u')) ? "U" : "L", &_n, X, &_n, &errflag);
- if (errflag) return (errflag);
- //=== Takes inverse.
- dpotri_(((ul=='U') || (ul=='u')) ? "U" : "L", &_n, X, &_n, &errflag);
- A_dm->flag = ((ul=='U') || (ul=='u')) ? M_SU : M_SL;
- return (errflag);
- //---
- // if (errflag<0) fn_DisplayError("Some element has an illegal value");
- // else if (errflag>0) fn_DisplayError("Not symmetric positive definite or matrix inversion cannot be computed");
- }
- else {
- if ( (_n != A_dm->ncols) || (_n != X_dm->nrows) || (_n != X_dm->ncols) )
- fn_DisplayError(".../mathlib.c/invspd(): both input and output matrices (1) must be square and (2) must have the same dimension");
- memcpy(X, A, _n*_n*sizeof(double));
- //=== Choleski decomposition.
- dpotrf_(((ul=='U') || (ul=='u')) ? "U" : "L", &_n, X, &_n, &errflag);
- if (errflag) return (errflag);
- //=== Takes inverse.
- dpotri_(((ul=='U') || (ul=='u')) ? "U" : "L", &_n, X, &_n, &errflag);
- X_dm->flag = ((ul=='U') || (ul=='u')) ? M_SU : M_SL;
- return (errflag);
- //---
- // if (errflag<0) fn_DisplayError("Some element has an illegal value");
- // else if (errflag>0) fn_DisplayError("Not symmetric positive definite or matrix inversion cannot be computed");
- }
-}
-#else
-//No default routine yet.
-#endif
-
-
-
-#if defined (INTELCMATHLIBRARY)
-int invrgen(TSdmatrix *X_dm, TSdmatrix *A_dm)
-{
- //Inverse of a general real matrix A.
- //If X=A, A (and X) will be replaced by inv(A).
- //
- //Outputs:
- // X: _n-by_n inverse of A;
- // errflag: error flag (=0 means successful).
- //--------
- //Inputs:
- // A: _n-by-_n real general matrix.
- int _n, errflag=2, //errflat=0 implies successful decomposition. But we start with 2 so as to let dgetri_ export a correct flag.
- lwork, *ipivot; //Used when calling LAPACK.
- double *X, *A,
- *work; //Used when calling LAPACK.
-
-
- if ( !X_dm || !A_dm ) fn_DisplayError(".../mathlib.c/invrgen(): Both input matrices must be created (memory-allocated)");
- else if ( !(A_dm->flag & M_GE) ) fn_DisplayError(".../mathlib.c/invrgen(): (1) R input matrix A must be given legal values; (2) A must be a general matrix, i.e., M_GE");
- else {
- X = X_dm->M;
- A = A_dm->M;
- ipivot = tzMalloc((_n=A_dm->nrows), int);
- work = tzMalloc((lwork=_n*BLOCKSIZE_FOR_INTEL_MKL), double);
- }
- if ( (_n != A_dm->ncols) || (_n != X_dm->nrows) || (_n != X_dm->ncols) )
- fn_DisplayError(".../mathlib.c/invrgen(): both input and output matrices (1) must be square and (2) have the same dimension");
-
-
- if (X==A) {
- dgetrf_(&_n, &_n, A, &_n, ipivot, &errflag);
- if (errflag) {
-// A_dm->flag = M_UNDEF;
- free(ipivot);
- free(work);
- return errflag;
- }
- dgetri_(&_n, A, &_n, ipivot, work, &lwork, &errflag);
- if (work[0]>lwork) printf("Warning for /mathlib.c/invrgen(); when calling MKL dgetri_(), we need at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work[0], lwork);
- if (errflag) {
- free(ipivot);
- free(work);
- return (errflag); //A_dm->flag = M_UNDEF;
- }
- }
- else {
- memcpy(X, A, _n*_n*sizeof(double));
- dgetrf_(&_n, &_n, X, &_n, ipivot, &errflag);
- if (errflag) {
-// X_dm->flag = M_UNDEF;
- free(ipivot);
- free(work);
- return errflag;
- }
- dgetri_(&_n, X, &_n, ipivot, work, &lwork, &errflag);
- if (work[0]>lwork) printf("Warning for /mathlib.c/invrgen(); when calling MKL dgetri_(), we need at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work[0], lwork);
- if (errflag) {
- free(ipivot);
- free(work);
- return (errflag); //X_dm->flag = M_UNDEF;
- }
- else X_dm->flag = A_dm->flag;
- }
- //=== Frees memory allocated in this function.
- free(ipivot);
- free(work);
-
- return errflag; //(1) If errflag = 0, success. (2) If errorflag = -i, the ith parameter has an illegal value.
- //(3) If errflag = i, U_{ii}=0.0. The LU factorization U is literally singular and the inversion
- // could not be completed.
-}
-#else
-//No default routine yet.
-#endif
-
-
-
-#if defined (INTELCMATHLIBRARY)
-int BdivA_rrect(TSdmatrix *X_dm, const TSdmatrix *B_dm, const char lr, const TSdmatrix *A_dm)
-{
- //This routine solves left division (\) problme AX=B (X=A\B). For XA=B (right division problem: X=B/A), we first transpose
- // it to A'*X'=B', then solve out X' = A'\B' as a left-division problem, and finally transpose X' back to X.
- //It handles cases with _m>=_n. For _n>_m, we have an infinite solution. To get one solution, take the _m-by-_m nonsigular
- // part of A_dm and get the solution for the _m-by-_r part of X with \ or the _r-by-_m part of X with /. The (_n-_m)-by-_r part
- // or _r-by-(_n-_m) part of X can simply be filled with 0.0.
- //
- //Outputs:
- // X = A\B or B/A where X is _n-by_r if \ (AX=B) or _r-by-_n if / (XA=B).
- // Returns info (if info==0, the execution is successful; if info == -i, the ith parameter has an illegal value.)
- //--------
- //Inputs:
- // A: _m-by-_n real rectangular (rrect) matrix if \ (AX=B) or
- // _n-by-_m real rectangular (rrect) matrix if / (XA=B).
- // B: _m-by-_r real rectangular (rrect) matrix if \ (AX=B) or
- // _r-by-_m real rectangular (rrect) matrix if / (XA=B).
- // lr: if lr='\\', left division \ is performed; if lr='/', right division / is performed.
-
- int _m, _n, _r, //mn_max, mn_min,
- lwork, _i, info = -2,
- *jpvt_p = NULL;
- double *A, *B, *X,
- *qra_p = NULL, //QR decomposion for A_dm.
- *qrb_p = NULL, //QR decomposion for B_dm.
- *tau_p = NULL,
- *work_p = NULL;
-
- if (!A_dm || !(A_dm->flag & M_GE) || !B_dm || !(B_dm->flag &M_GE)) fn_DisplayError(".../mathlib.c/BdivA_rrect(): both input matricies A_dm and B_dm must be (a) created (allocated memory) and (b) given legal values for all elements (in other words, the flag M_GE must exist)");
- if (!X_dm) fn_DisplayError(".../mathlib.c/BdivA_rrect(): output matrix X_dm must be created (allocated memory)");
- if (lr=='/') {
- if ( (_n=A_dm->nrows) != X_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rrect(): 1st dim of A_dm and 2nd dim of X_dm must exactly match for / (right division)");
- if ( (_m=A_dm->ncols) != B_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rrect(): 2nd dim of A_dm and 2nd dim of B_dm must exactly match for / (right division)");
- if ( (_r=B_dm->nrows) != X_dm->nrows ) fn_DisplayError(".../mathlib.c/BdivA_rrect(): 1st dim of B_dm and 1st dim of X_dm must exactly match for / (right division)");
- if ( _m < _n) fn_DisplayError(".../mathlib.c/BdivA_rrect(): A_dm->nrows must be <= A_dm->ncols for / (right division). Otherwise, take the nonsigular square part of A_dm and use BdivA_rrect()");
- }
- else if (lr=='\\') {
- if ( (_m=A_dm->nrows) != B_dm->nrows ) fn_DisplayError(".../mathlib.c/BdivA_rrect(): 1st dim of A_dm and 1st dim of B_dm must exactly match for \\ (left division)");
- if ( (_n=A_dm->ncols) != X_dm->nrows ) fn_DisplayError(".../mathlib.c/BdivA_rrect(): 2nd dim of A_dm and 1st dim of X_dm must exactly match for \\ (left division)");
- if ( (_r=B_dm->ncols) != X_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rrect(): 2nd dim of B_dm and 2nd dim of X_dm must exactly match for \\ (left division)");
- if ( _m < _n) fn_DisplayError(".../mathlib.c/BdivA_rrect(): A_dm->nrows must be >= A_dm->ncols for \\ (left division). Otherwise, take the nonsigular square part of A_dm and use BdivA_rrect()");
- }
- else fn_DisplayError(".../mathlib.c/BdivA_rrect(): input character lr must be / (right division) or \\\\ (left division)");
- A = A_dm->M;
- B = B_dm->M;
- X = X_dm->M;
-
-
-// lwork = ((mn_max = _m>_n ? _m : _n)>_r ? nm_max : _r)*BLOCKSIZE_FOR_INTEL_MKL;
-// mn_min = _m<_n ? _m : _n;
-
-
- //=== Memory allocation for this function only.
- qra_p = tzMalloc(_m*_n, double);
-// qrb_p = tzMalloc((mn_max = _m>_n?_m:_n)*_r, double); //DDDDebug: seems requiring _m>_n, but this may not be the case.
- qrb_p = tzMalloc(_m*_r, double); //Note that _m>=_n.
- jpvt_p = tzMalloc(_n, int);
- tau_p = tzMalloc(_n, double);
-// work_p = tzMalloc(lwork, double);
-
-
- //=== Making copies of input matrices A and B */
- if (lr=='/') //Right division. In this case, qra_p is _m-by-_n (transpose of A_dm), and qrb_p is max(_m,_n)-by-_r (transpose of B_dm).
- for (_i=0; _i<_m; _i++) {
- cblas_dcopy(_n, &A[_i*_n], 1, &qra_p[_i], _m);
- cblas_dcopy(_r, &B[_i*_r], 1, &qrb_p[_i], _m);
- }
- else {
- memcpy(qra_p, A, _m*_n*sizeof(double)); //qra_p is _m-by-_n.
- memcpy(qrb_p, B, _m*_r*sizeof(double)); //qrb_p is _m-by-_r.
-// for (_i=0; _i<_r; _i++) cblas_dcopy(_m, B+_i*_m, 1, qrb_p+_i*mn_max, 1); //qrb_p is max(_m,_n)-by-_r.
- }
-
-
- //=== Computes the QR factorization of a general m by n matrix with column pivoting using Level 3 BLAS.
- work_p = tzMalloc(lwork=_n*BLOCKSIZE_FOR_INTEL_MKL, double);
- dgeqp3_(&_m,&_n,qra_p,&_m,jpvt_p,tau_p,work_p,&lwork,&info);
- if (work_p[0]>lwork) printf("Warning for /mathlib.c/BdivA_rrect(); when calling MKL dgeqp3_(), we need at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work_p[0], lwork);
- tzDestroy(work_p);
- if (info) return (info); //If info==0, the execution is successful; if info == -i, the ith parameter has an illegal value.
-
- //=== Multiplies a real matrix by the orthogonal matrix Q of the QR factorization formed by dgeqp3_.
- work_p = tzMalloc(lwork=_r*BLOCKSIZE_FOR_INTEL_MKL, double);
- dormqr_("L","T",&_m,&_r,&_n,qra_p,&_m,tau_p,qrb_p,&_m,work_p,&lwork,&info);
- if (work_p[0]>lwork) printf("Warning for /mathlib.c/BdivA_rrect(); when calling MKL dormqr_(), we need at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work_p[0], lwork);
- //dormqr_("L","T",&_m,&_r,&mn_min,qra_p,&_m,tau_p,qrb_p,&mn_max,work_p,&lwork,&info);
- tzDestroy(work_p)
- if (info) return (info); //If info==0, the execution is successful; if info == -i, the ith parameter has an illegal value.
-
-
- //=== Solves a matrix equation R*x = C (one matrix operand is triangular). Note that the dim of X is n-by-r for \ or r-by-n for /
- cblas_dtrsm(CblasColMajor,CblasLeft,CblasUpper,CblasNoTrans,CblasNonUnit,_n,_r,1.0,qra_p,_m,qrb_p,_m);
- if (lr=='/') //Right division. In this case, qra_p is _m-by-_n (transpose of A_dm), and qrb_p is max(_m, _n)-by-_r (transpose of B_dm).
- for (_i=0; _i<_n; _i++) cblas_dcopy(_r, &qrb_p[_i], _m, &X[(jpvt_p[_i]-1)*_r], 1); //Copying the transpose of the _n-by-_r leading part of qrb_p.
-// cblas_dcopy(_r, &qrb_p[_i], mn_max, &X[(jpvt_p[_i]-1)*_r], 1); //Copying the transpose of the _n-by-_r leading part of qrb_p.
-
- else //qrb_p is max(_m, _n)-by-_r.
- for (_i=0; _i<_n; _i++) cblas_dcopy(_r, &qrb_p[_i], _m, &X[jpvt_p[_i]-1], _n);
-// cblas_dcopy(_r, &qrb_p[_i], mn_max, &X[jpvt_p[_i]-1], _n);
- X_dm->flag = M_GE;
-
- //=== Destroyes memory allocated for this function only.
- tzDestroy(qra_p);
- tzDestroy(qrb_p);
- tzDestroy(jpvt_p);
- tzDestroy(tau_p);
-// tzDestroy(work_p);
-
- return (0);
-}
-#else
-//No default routine yet. 7 Oct 2003
-#endif
-
-
-
-
-#if defined (INTELCMATHLIBRARY)
-int BdivA_rgens(TSdmatrix *X_dm, const TSdmatrix *B_dm, const char lr, const TSdmatrix *A_dm)
-{
- //Unlike BdivA_rrect(), this routine deals with only the general square matrix A_dm. It solves left division (\) problme
- // AX=B (X=A\B). For XA=B (right division problem: X=B/A), we first transpose it to A'*X'=B', then solve out X' = A'\B'
- // as a left-division problem, and finally transpose X' back to X.
- //
- //Outputs:
- // X = A\B or B/A where X is _m-by_r if \ (AX=B) or _r-by-_m if / (XA=B).
- // Returns info (if info==0, the execution is successful; if info == -i, the ith parameter has an illegal value.)
- //--------
- //Inputs:
- // A: _m-by-_m real general square (rgens) matrix.
- // B: _m-by-_r real general square (rgens) matrix if \ (AX=B) or
- // _r-by-_m real general square (rgens) matrix if / (XA=B).
- // lr: if lr='\\', left division \ is performed; if lr='/', right division / is performed.
-
- int _m, _r, m2,
- _i, info = -2,
- *ipiv_p = NULL;
- double *A, *B, *X,
- *Atran_p = NULL, //Transpose of A if right division / takes place.
- *Btran_p = NULL, //Transpose of B if right division / takes place.
- *W = NULL; //Duplicate copy of A when left division \ is used. This will be replaced by LU decomposition.
-// *tau_p = NULL,
-// *work_p = NULL;
-
- if (!A_dm || !(A_dm->flag & M_GE) || !B_dm || !(B_dm->flag & M_GE)) fn_DisplayError(".../mathlib.c/BdivA_rgens(): both input matricies A_dm and B_dm must be (a) created (allocated memory) and (b) given legal values for all elements (in other words, the flag M_GE must exist)");
- if (!X_dm) fn_DisplayError(".../mathlib.c/BdivA_rgens(): output matrix X_dm must be created (allocated memory)");
- if (lr=='/') {
- if ( (_m=A_dm->nrows) != X_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): 1st dim of A_dm and 2nd dim of X_dm must exactly match for / (right division)");
- if ( _m != A_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): input matrix A_dm must be square. For a nonsqaure matrix, use BdivA_rrect()");
- if ( _m != B_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): 2nd dim of A_dm and 2nd dim of B_dm must exactly match for / (right division)");
- if ( (_r=B_dm->nrows) != X_dm->nrows ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): 1st dim of B_dm and 1st dim of X_dm must exactly match for / (right division)");
-
- }
- else if (lr=='\\') {
- if ( (_m=A_dm->nrows) != B_dm->nrows ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): 1st dim of A_dm and 1st dim of B_dm must exactly match for \\ (left division)");
- if ( _m != A_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): input matrix A_dm must be square. For a nonsqaure matrix, use BdivA_rrect()");
- if ( _m != X_dm->nrows ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): 2nd dim of A_dm and 1st dim of X_dm must exactly match for \\ (left division)");
- if ( (_r=B_dm->ncols) != X_dm->ncols ) fn_DisplayError(".../mathlib.c/BdivA_rgens(): 2nd dim of B_dm and 2nd dim of X_dm must exactly match for \\ (left division)");
- }
- else fn_DisplayError(".../mathlib.c/BdivA_rgens(): input character lr must be / (right division) or \\\\ (left division)");
- A = A_dm->M;
- B = B_dm->M;
- X = X_dm->M;
-
-
-
- if (lr=='/') {
- //Right divistion /.
- //=== Memory allocation for this function only.
- ipiv_p = tzMalloc(_m, int);
- Atran_p = tzMalloc(square(_m), double);
- Btran_p = tzMalloc(_m*_r, double);
-
- for (_i=0; _i<_m; _i++) {
- cblas_dcopy(_m, A+_i*_m, 1, Atran_p+_i, _m); //Copying the transpose of A to Atran.
- cblas_dcopy(_r, B+_i*_r, 1, Btran_p+_i, _m); //Copying the transpose of B (_r-by-_m) to Btran (_m-by-_r);
- }
- dgesv_(&_m, &_r, Atran_p, &_m, ipiv_p, Btran_p, &_m, &info);
- for (_i=0; _i<_r; _i++) cblas_dcopy(_m, Btran_p+_i*_m, 1, X+_i, _r); //Copying the transpose of Btran(_m-by-_r) to X (_r-by-_m);
- X_dm->flag = M_GE;
-
- //=== Destroyes memory allocated for this function only.
- tzDestroy(ipiv_p);
- tzDestroy(Atran_p);
- tzDestroy(Btran_p);
-
- return (info);
- }
- else {
- //Left division \.
- //=== Memory allocation for this function only.
- ipiv_p = tzMalloc(_m, int);
- W = tzMalloc(m2=square(_m), double);
-
- memcpy(X, B, _m*_r*sizeof(double));
- memcpy(W, A, m2*sizeof(double));
- dgesv_(&_m, &_r, W, &_m, ipiv_p, X, &_m, &info);
- X_dm->flag = M_GE;
-
- //=== Destroyes memory allocated for this function only.
- tzDestroy(ipiv_p);
- tzDestroy(W);
-
- return (info); //If info==0, the execution is successful; if info == -i, the ith parameter has an illegal value;
- // if info==i, U(i,i) in LU decomposition is exactly zero. The factorization has been completed, but
- // the factor U is exactly singular, so the solution could not be computed.
- }
-}
-//---
-int bdivA_rgens(TSdvector *x_dv, const TSdvector *b_dv, const char lr, const TSdmatrix *A_dm)
-{
- //Use bdivA_rgens() where x_dv and b_dv are now both vectors and A_dm is a square matrix.
- //Unlike bdivA_rrect(), this routine deals with only the general square matrix A_dm. It solves left division (\) problme
- // Ax=b (x=A\b). For xA=b (right division problem: x=B/b), we first transpose it to A'*x'=b', then solve out x' = A'\b'
- // as a left-division problem, and finally transpose x' back to x.
- //
- //If x_dv->v = b_dv->v. Then, x_dv->v will be replaced by new values.
- //
- //Outputs: Solving Ax = b or xA = b.
- // x = A\b or b/A where x is _m-by-1 if \ (Ax=b) or 1-by-_m if / (xA=b).
- // Returns info (if info==0, the execution is successful; if info == -i, the ith parameter has an illegal value.)
- //--------
- //Inputs:
- // A: _m-by-_m real general square (rgens) matrix.
- // b: _m-by-1 vector if \ (Ax=b) or
- // 1-by-_m vector if / (xA=b).
- // lr: if lr='\\', left division \ is performed; if lr='/', right division / is performed.
-
- int _m, m2,
- _r = 1,
- _i, info = -2,
- *ipiv_p = NULL;
- double *A, *b, *x,
- *Atran_p = NULL, //Transpose of A if right division / takes place.
- *W = NULL; //Duplicate copy of A when left division \ is used. This will be replaced by LU decomposition.
-
- if (!A_dm || !(A_dm->flag & M_GE) || !b_dv || !b_dv->flag) fn_DisplayError("mathlib.c/bdivA_rgens(): Both A_dm and b_dv must be (a) created (allocated memory) and (b) given legal values for all elements (in other words, the flag M_GE must exist)");
- if (!x_dv) fn_DisplayError("mathlib.c/bdivA_rgens(): output vector x_dv must be created (allocated memory)");
- if ( b_dv->n != x_dv->n ) fn_DisplayError("mathlib.c/bdivA_rgens(): The dim of b_dv and the dim of x_dv must exactly match");
- if ( (_m=A_dm->nrows) != x_dv->n ) fn_DisplayError("mathlib.c/bdivA_rgens(): Number of rows of A_dm and the dim of x_dv must exactly match");
- if ( _m != A_dm->ncols ) fn_DisplayError("mathlib.c/bdivA_rgens(): Input matrix A_dm must be square");
-
- A = A_dm->M;
- b = b_dv->v;
- x = x_dv->v;
-
- if (lr=='/') {
- //Right divistion /.
- //=== Memory allocation for this function only.
- ipiv_p = tzMalloc(_m, int);
- Atran_p = tzMalloc(square(_m), double);
-
- for (_i=0; _i<_m; _i++)
- cblas_dcopy(_m, A+_i*_m, 1, Atran_p+_i, _m); //Copying the transpose of A to Atran.
- if (x_dv != b_dv ) memcpy(x, b, _m*sizeof(double));
- dgesv_(&_m, &_r, Atran_p, &_m, ipiv_p, x, &_m, &info);
- x_dv->flag = V_DEF;
-
- //=== Destroyes memory allocated for this function only.
- tzDestroy(ipiv_p);
- tzDestroy(Atran_p);
-
- return (info);
- }
- else {
- //Left division \.
- //=== Memory allocation for this function only.
- ipiv_p = tzMalloc(_m, int);
- W = tzMalloc(m2=square(_m), double);
-
- if (x_dv != b_dv ) memcpy(x, b, _m*sizeof(double));
- memcpy(W, A, m2*sizeof(double));
- dgesv_(&_m, &_r, W, &_m, ipiv_p, x, &_m, &info);
- x_dv->flag = V_DEF;
-
- //=== Destroyes memory allocated for this function only.
- tzDestroy(ipiv_p);
- tzDestroy(W);
-
- return (info); //If info==0, the execution is successful; if info == -i, the ith parameter has an illegal value;
- // if info==i, U(i,i) in LU decomposition is exactly zero. The factorization has been completed, but
- // the factor U is exactly singular, so the solution could not be computed.
- }
-}
-#else
-//No default routine yet. 7 Oct 2003
-#endif
-
-
-
-#if defined (INTELCMATHLIBRARY)
-void Aldivb_spd(TSdvector *x_dv, TSdmatrix *A_dm, TSdvector *b_dv, char an) {
- //??????? Some options (e.g., whe A_dm is M_SL) are NOT tested yet.
- //Output x = A\b where x_dv is an _n-by-1 vector.
- // Fastest way is to let x_dv->v = b_dv->v. Then, x_dv->v will be replaced by new values.
- //--------
- //Inputs:
- // A: _n-by-_n symmetric, positive definite matrix.
- // b: _n-by-1 vector.
- // an: 'N' or 'n': A_dm will NOT be altered and another matrix will be allocated and destroyed in this function.
- // Otherwise ('A' or 'a'): A_dm will be altered and A_dm = U if A_dm->flag = M_SU where U is an upper triagular Choleski such that U'*U = A;
- // or A_dm = L if A_dm->flag = M_SL (but != M_SU) where L is a lower triangular Choleski such that L*L' = A.
- //
- // Note I: Intel MLK cblas_dtrsv() does not test for singularity or near-singulariy of the system.
- // Such tests must be performed before calling this BLAS routine.
- // Note II: If x_dv->v = b_dv->v, x_dv->v will be replaced by new values.
- // Note III: If an != 'N' or 'n', A_dm will be replaced by U if A_dm->M_SU where U'*U = A or by L if A_dm->M_SL (but != M_SU) where L*L'=A.
-
- int errflag=2, nrows, nels; //errflat=0 implies successful decomposition. But we start with 2 so as to let dpotrf_ export a correct flag.
- double *A, *W=NULL, *x, *b;
-
- if ( !A_dm || !b_dv || !x_dv ) fn_DisplayError(".../mathlib.c/Aldivb_spd(): All input matrices or vectors must be created (memory allocated)");
- nrows = A_dm->nrows;
- nels = square(nrows);
- A = A_dm->M;
- x = x_dv->v;
- b= b_dv->v;
- if ( nrows != A_dm->ncols ) fn_DisplayError(".../mathlib.c/Aldivb_spd(): L input matrix must be square");
- if ( !A_dm->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/Aldivb_spd(): L input matrix and vector must be given legal values");
- if ( (an=='N') || (an=='n') ) {
- W = tzMalloc(nels, double);
- memcpy(W, A, nels*sizeof(double));
- }
- else if ( (an=='A') || (an=='a') ) W = A;
- else fn_DisplayError(".../mathlib.c/Aldivb_spd(): passing charecter an must be A, a, N, or n");
-
-
- if (A_dm->flag & M_SU) {
- dpotrf_("U", &nrows, W, &nrows, &errflag); //Choleski. U'*U = W where W will be replaced by upper triangular U.
- if (errflag) fn_DisplayError(".../mathlib.c/Aldivb_spd(): Error when calling Choleski dpotrf_(). Check if the L input matrix A_dm is positive definite or has legal values");
- if (x==b) {
- //=== Solving for A*x=b.
- cblas_dtrsv(CblasColMajor, CblasUpper, CblasTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- }
- else {
- memcpy(x, b, nrows*sizeof(double));
- cblas_dtrsv(CblasColMajor, CblasUpper, CblasTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- x_dv->flag = V_DEF;
- }
- if ( (an!='N') && (an!='n') ) A_dm->flag = M_UT;
- }
- else if (A_dm->flag & M_SL) { //?????????? Not tested yet.
- dpotrf_("L", &nrows, W, &nrows, &errflag); //Choleski. L*L' = W where W will be replaced by lower triangular L.
- if (errflag) fn_DisplayError(".../mathlib.c/Aldivb_spd(): Error when calling Choleski dpotrf_(). Check if the L input matrix A_dm is positive definite or has legal values");
- if (x==b) {
- //=== Solving for A*x=b.
- cblas_dtrsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- cblas_dtrsv(CblasColMajor, CblasLower, CblasTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- }
- else {
- memcpy(x, b, nrows*sizeof(double));
- cblas_dtrsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- cblas_dtrsv(CblasColMajor, CblasLower, CblasTrans, CblasNonUnit, nrows, W, nrows, x, 1);
- x_dv->flag = V_DEF;
- }
- if ( (an!='N') && (an!='n') ) A_dm->flag = M_LT;
- }
- else fn_DisplayError(".../mathlib.c/Aldivb_spd(): L input matrix A_dm must be symmetric");
- //dpotrf_((A_dm->flag & M_SU) ? "U" : "L", &nrows, A, &nrows, &errflag); //Choleski. If "U", U'*U = A where A will be replaced by upper triangular U.
- // if (errflag<0) fn_DisplayError("Some element has an illegal value");
- // else if (errflag>0) fn_DisplayError("The leadding minor of some order, hence the entire matrix, is not positive definite");
-
- if ( (an=='N') || (an=='n') ) free(W);
-}
-#else
-//No default routine yet.
-#endif
-
-
-
-#if defined (INTELCMATHLIBRARY)
-double detspd(TSdmatrix *S_dm)
-{
- //Determinant of symmetric positive definite (SPD) matrix must be positive.
- //We set the return value to be -1 if this matrix is NOT SPD.
- double valuedet;
- int _n, _i;
- int errflag;
- //===
- TSdmatrix *Work_dm = NULL;
-
- if (S_dm) {
- _n = S_dm->nrows;
- Work_dm = CreateMatrix_lf(_n, _n);
- }
- else fn_DisplayError(".../mathlib.c/detspd(): Input matrix must be (1) created, (2) symmetric, (3) positive definite");
-
- if (S_dm->flag & M_SU) errflag=chol(Work_dm, S_dm, 'U');
- else if (S_dm->flag & M_SL) errflag=chol(Work_dm, S_dm, 'L');
- else fn_DisplayError(".../mathlib.c/detpdf(): Input matrix S_dm must be either M_SU or M_SL");
-
- if (errflag) {
- //printf("\nFatal Error in .../mathlib.c/detspd() when calling chol() with error flag %d\n", errflag);
- //exit(EXIT_FAILURE);
- DestroyMatrix_lf(Work_dm);
- return (-1.0);
- }
- else
- {
- for (valuedet=1.0, _i=square(_n)-1; _i>=0; _i -= _n+1) valuedet *= Work_dm->M[_i];
- //log(fabs(M[_i]));
- if (!isfinite(valuedet)) fn_DisplayError(".../mathlib.c/detspd(): the determinant is overflow. Use logdetspd() instead");
- //Done with Work* arrays.
- DestroyMatrix_lf(Work_dm);
- return (square(valuedet)); //square() because Work_dm is a square root of S_dm.
- }
-}
-#else
-//No default routine yet.
-#endif
-//---
-#if defined (INTELCMATHLIBRARY)
-double logdetspd(TSdmatrix *S_dm)
-{
- //Determinant of symmetric positive definite (SPD) matrix must be positive.
- //We set the return value to be log(-1.0) (becomeing NaN) if this matrix is NOT SPD.
- double logvaluedet;
- int _n, _i;
- int errflag;
- //===
- TSdmatrix *Work_dm = NULL;
-
- if (S_dm) {
- _n = S_dm->nrows;
- Work_dm = CreateMatrix_lf(_n, _n);
- }
- else fn_DisplayError(".../mathlib.c/detspd(): Input matrix must be (1) created, (2) symmetric, (3) positive definite");
-
- if (S_dm->flag & M_SU) errflag=chol(Work_dm, S_dm, 'U');
- else if (S_dm->flag & M_SL) errflag=chol(Work_dm, S_dm, 'L');
- else fn_DisplayError(".../mathlib.c/logdetspd(): Input matrix S_dm must be either M_SU or M_SL");
-
- if (errflag) {
- //printf("\nFatal Error in .../mathlib.c/logdetspd() when calling chol() with error flag %d\n", errflag);
- //exit(EXIT_FAILURE);
- DestroyMatrix_lf(Work_dm);
- printf("----- errflag for chol() when calling logdetspd() in mathlib.c = %d -----", errflag);
- return (log(-1.0));
- }
- else
- {
- for (logvaluedet=0.0, _i=square(_n)-1; _i>=0; _i -= _n+1) logvaluedet += log(Work_dm->M[_i]);
- //Done with Work* arrays.
- DestroyMatrix_lf(Work_dm);
- return (2.0*logvaluedet); //2.0* because Work_dm is a square root of S_dm.
- }
-}
-#else
-//No default routine yet.
-#endif
-
-
-
-#if defined (INTELCMATHLIBRARY)
-double logdeterminant(TSdmatrix *A_dm) {
- //Outputs: log|A|.
- //------
- //Inputs:
- // A_dm: m-by-n real general matrix.
-
- double retval;
- int _m, _n,
- errflag = -2;
- TSdmatrix *U_dm;
-
- if (!A_dm) fn_DisplayError(".../logdeterminant(): Input matrix must be memory allocated (and make sure it has legal values with the flag M_GE)");
- //NOTE: all properties of A_dm will be double checked again by lurgen() below.
-
- //=== Allocates memory used only in this function.
- U_dm = CreateMatrix_lf(_m=A_dm->nrows, _n=A_dm->ncols);
-
- errflag = lurgen(U_dm, (TSivector *)NULL, A_dm); //Gets only the upper part of U_dm.
- if (errflag) fn_DisplayError(".../logdeterminant(): Error occurs when calling lurgen()");
- retval = tracelogfabs(U_dm); //tracelogfabs(U) = trace(log(diag(U))).
-
- //=== Frees memory allocated only for this function.
- DestroyMatrix_lf(U_dm);
-
- return ( retval );
-}
-#else
-//No default routine yet.
-#endif
-
-
-int eigrsym_decomp(double *eval_v, double *evec_m, const double *s_m, const int _n, const char ul) { //, const char revec_yn, const char levec_yn) {
- // Outputs (dependent on Intel MKL):
- // eval_v: _n-by-1 eigenvalues in ascending order;
- // evec_m: _n-by-_n eigenvalues -- if (evec_m==NULL), no eigenvectors are computed; otherwise, x_m = evec_m*diag(eval_v)*inv(evec_m).
- // errflag: error flag.
- //------------
- // Inputs:
- // s_m: _n-by_n real symmetric matrix.
- // ul: if =='u' or 'U', s_m is upper triangular; if =='l' or 'L', s_m is lower triangular.
- //
- // Eigenanalysis of real symmetric square matrix with all eigenvalues and, optionally, eigenvectors.
- // Experts' opinion: do NOT use Cuppen's divide-and-conquer algorithm; instead, use QR algorithm, which I guess this algorithm uses.
-
- int n1=_n, errflag=2, //errflat=0 implies successful decomposition. But we start with 2 so as to let dsyev_ export a correct flag.
- lwork=_n*BLOCKSIZE_FOR_INTEL_MKL;
- double *tmpd0_m=tzMalloc(square(_n), double),
- *work_p=tzMalloc(lwork, double);
-
-
- //---------------------------
- // Obtains eigenvalues and, optionally, eigenvectors.
- //---------------------------
- memcpy(tmpd0_m, s_m, square(_n)*sizeof(double));
- dsyev_( (evec_m) ? "V" : "N", ((ul=='u') || (ul=='U')) ? "U" : "L", &n1, tmpd0_m, &n1, eval_v, work_p, &lwork, &errflag);
- if (evec_m) memcpy(evec_m, tmpd0_m, square(_n)*sizeof(double));
-
-
- //---------------------------
- // Frees the allocated memory.
- //---------------------------
- if (work_p[0]>lwork) printf("Warning for /mathlib.c/eigrsym_decomp(): needs at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work_p[0], lwork);
- tzDestroy(tmpd0_m);
- tzDestroy(work_p);
-
- //if (errflag<0) fn_DisplayError("/Subfolder: Calling eigrsym_decomp -- some element in input matrix has an illegal value");
- //else if (errflag>0) fn_DisplayError("/Subfolder: Calling eigrsym_decomp -- the factor U is exactly singular, so the solution cannot be computed");
- return (errflag);
-}
-
-int eigrgen_decomp(double *evalr_v, double *evali_v, double *revecr_m, double *reveci_m, double *levecr_m, double *leveci_m, const double *x_m, const int _n) { //, const char revec_yn, const char levec_yn) {
- // Outputs (dependent on Intel MKL):
- // evalr_v: _n-by-1 real parts of eigenvalues;
- // evali_v: _n-by-1 imaginary parts of eigenvalues;
- // revecr_m: if (revecr_m==NULL), no right eigenvectors are computed; otherwise, _n-by-_n corresponding *real* parts of right eigenvectors column by column: A*v(j)=lambda(j)*v(j);
- // reveci_m: if (revecr_m!=NULL) -- must be initialized to zero, _n-by-_n *imaginary* parts of right eigenvectors corresponding to revecr_m;
- // levecr_m: if (levecr_m==NULL), no left eigenvectors are computed; otherwise, n-by-n corresponding *real* parts of left eigenvectors column by column: u(j)^H*A=lambda(j)*u(j)^H, where H means conjugate transpose;
- // leveci_m: if (levecr_m!=NULL) -- must be initialized to zero, _n-by-_n *imaginary* parts of left eigenvectors corresponding to revecr_m;
- // errflag: error flag.
- //------------
- // Inputs:
- // x_m: _n-by_n real general (non-symmetric) matrix.
- //
- // Eigenanalysis of real general (non-symmetric) square matrix with all eigenvalues and, optionally, eigenvectors.
-
- int n1=_n, errflag=2, //errflat=0 implies successful decomposition. But we start with 2 so as to let dgeev_ export a correct flag.
- lwork=_n*BLOCKSIZE_FOR_INTEL_MKL,
- _i, _j;
- double *tmpd0_m=tzMalloc(square(_n), double), //@@Must be freed in this function.@@
- *work_p=tzMalloc(lwork, double); //@@Must be freed in this function.@@
-
- //---------------------------
- // Starts with x_m -- the matrix to be decomposed.
- //---------------------------
- memcpy(tmpd0_m, x_m, square(_n)*sizeof(double));
-
- //---------------------------
- // Obtains eigenvalues and, optionally, eigenvectors.
- //---------------------------
- dgeev_( (levecr_m) ? "V" : "N", (revecr_m) ? "V" : "N", &n1, tmpd0_m, &n1, evalr_v, evali_v,
- levecr_m, &n1, revecr_m, &n1, work_p, &lwork, &errflag);
-
- //---------------------------
- // Frees the allocated memory.
- //---------------------------
- if (work_p[0]>lwork) printf("Warning for /mathlib.c/eigrgen_decomp(): needs at least %d workspace for good performance "
- "but lwork is allocated with only %d space!\n", (int)work_p[0], lwork);
- if (work_p) free(work_p);
- if (tmpd0_m) free(tmpd0_m);
-
- //---------------------------
- // Checks error conditions.
- // Exports final results.
- //---------------------------
- //if (errflag<0) fn_DisplayError("/Subfolder: Calling eigrgen_decomp -- some element in input matrix has an illegal value");
- //else if (errflag>0) fn_DisplayError("/Subfolder: Calling eigrgen_decomp -- the QR algorithm failed to compute all the eigenvalues and no eigenvectors have been computed");
- if (errflag) return (errflag);
- else {
- if (revecr_m) { // Tested against Matlab output. Works! 10/13/02.
- for (_j=0; _j<_n-1; _j++)
- if (evali_v[_j] && (evali_v[_j] == -evali_v[_j+1]))
- for (_i=0; _i<_n; _i++) {
- reveci_m[_i+(_j+1)*_n] = -(reveci_m[_i+_j*_n]=revecr_m[_i+(_j+1)*_n]);
- revecr_m[_i+(_j+1)*_n] = revecr_m[_i+_j*_n];
- }
- }
- if (levecr_m) { //Hasn't tested against any other established program, but it seems working. 10/13/02.
- for (_j=0; _j<_n-1; _j++)
- if (evali_v[_j] && (evali_v[_j] == -evali_v[_j+1]))
- for (_i=0; _i<_n; _i++) {
- leveci_m[_i+(_j+1)*_n] = -(leveci_m[_i+_j*_n]=levecr_m[_i+(_j+1)*_n]);
- levecr_m[_i+(_j+1)*_n] = levecr_m[_i+_j*_n];
- }
- }
- return (errflag);
- }
-}
-
-
-
-int chol_decomp(double *D, const double *s_m, const int _n, const char ul) {
- //Outputs:
- // D: _n-by_n -- if ul='u' or 'U', D'*D = s_m where D is stored only at the upper triangular part;
- // if ul='l' or 'L', D*D' = s_m where D is stored only at the lower triangular part.
- // errflag: error flag (=0 means successful).
- //--------
- //Inputs:
- // s_m: _n-by-_n symmetric, positive definite matrix (whose only triangular part is used by dpotrf_).
- // ul: if =='u' or 'U', D (as well as s_m) is upper triangular; if =='l' or 'L', D (as well as s_m) is lower triangular.
- //
- // Choleski decomposition of s_m.
- // For the MATLAB libriary, ul doest not apply and chol_decomp always takes the 'U' form.
- // And Matlab 6.5 (R13) has a different number of inputs for mlfChol().
- // See ...\extern\include\libmatlbm.h (included by matlab.h) for the definition of mlfChol().
- // So R12 version must be used if one chooses to use the MATLAB libriary.
-
- #ifdef INTELCMATHLIBRARY //Intel MKL Lapack dependent code.
- int errflag=2, _m=_n, _i, _j, tmpi0; //errflat=0 implies successful decomposition. But we start with 2 so as to let dpotrf_ export a correct flag.
-
- //=== Fills the triangular part that is used for Choleski decomposition.
-
- switch (ul) {
- case 'u': case 'U':
- for (_j=0; _j<_n; _j++) {
- for (_i=0; _i<=_j; _i++) {
- tmpi0 = _i+_j*_n;
- D[tmpi0] = s_m[tmpi0];
- }
- for (; _i<_n; _i++) D[_i+_j*_n] = 0.0; //Initializes the other part of D to zero so as to make it visible and readable.
- }
- break;
- case 'l': case 'L':
- for (_j=0; _j<_n; _j++) {
- for (_i=0; _i<_j; _i++) D[_i+_j*_n] = 0.0; //Initializes the other part of D to zero so as to make it visible and readable.
- for (; _i<_n; _i++) {
- tmpi0 = _i+_j*_n;
- D[tmpi0] = s_m[tmpi0];
- }
- }
- default:
- return (-1);
- }
- //=== Choleski decomposition.
- dpotrf_(((ul=='u') || (ul=='U')) ? "U" : "L", &_m, D, &_m, &errflag);
- //---
- // if (errflag<0) fn_DisplayError("Some element has an illegal value");
- // else if (errflag>0) fn_DisplayError("The leadding minor of some order, hence the entire matrix, is not positive definite");
- return (errflag);
- #endif
- #ifdef MATLABCMATHLIBRARY //Matlab dependent code.
- mxArray *ms_m=mlfDoubleMatrix(_n, _n, s_m, NULL), //@@Must be freed in this function.@@ mx version of s_m.
- *mxD=NULL, //@@Must be freed in this function.@@ mx version of D.
- *mxflag;
- int errflag;
-
- mxD = mlfChol(&mxflag, ms_m);
- errflag = (int)mxGetScalar(mxflag);
- //if (errflag) fn_DisplayError("Function mathlib.c\\chol_decomp(): matrix must be positive definite for choleski decomposition");
- memcpy(D, mxGetPr(mxD), square(_n)*sizeof(double));
-
- //=== Frees up allocated mxArray.
- mxDestroyArray(mxD);
- mxDestroyArray(ms_m);
- mxDestroyArray(mxflag);
-
- return errflag;
- #endif
-}
-
-int inv_spd(double *D, const double *s_m, const int _n, const char ul) {
- // Inverse of symmetric, positive-definite matrix s_m.
- //
- //Outputs:
- // D: _n-by_n inverse of s_m.
- // errflag: error flag (=0 means successful).
- //--------
- //Inputs:
- // s_m: _n-by-_n symmetric, positive definite matrix (whose only triangular part is used by dpotrf_).
- // ul: if =='u' or 'U', D (as well as s_m) is upper triangular; if =='l' or 'L', D (as well as s_m) is lower triangular.
-
- int errflag=2, _m=_n, _i, _j, tmpi0; //errflat=0 implies successful decomposition. But we start with 2 so as to let dpotrf_ export a correct flag.
-
- //=== Fills the triangular part that is used for Choleski decomposition.
- switch (ul) {
- case 'u': case 'U':
- for (_j=0; _j<_n; _j++) {
- for (_i=0; _i<=_j; _i++) {
- tmpi0 = _i+_j*_n;
- D[tmpi0] = s_m[tmpi0];
- }
- for (; _i<_n; _i++) D[_i+_j*_n] = 0.0; //Initializes the other part of D to zero so as to make it visible and readable.
- }
- break;
- case 'l': case 'L':
- for (_j=0; _j<_n; _j++) {
- for (_i=0; _i<_j; _i++) D[_i+_j*_n] = 0.0; //Initializes the other part of D to zero so as to make it visible and readable.
- for (; _i<_n; _i++) {
- tmpi0 = _i+_j*_n;
- D[tmpi0] = s_m[tmpi0];
- }
- }
- break;
- default:
- return (-1);
- }
- //=== Choleski decomposition.
- dpotrf_(((ul=='u') || (ul=='U')) ? "U" : "L", &_m, D, &_m, &errflag);
- if (errflag) return (errflag);
- //=== Takes inverse.
- dpotri_(((ul=='u') || (ul=='U')) ? "U" : "L", &_m, D, &_m, &errflag);
- return (errflag);
- //---
- // if (errflag<0) fn_DisplayError("Some element has an illegal value");
- // else if (errflag>0) fn_DisplayError("Not symmetric positive definite or matrix inversion cannot be computed");
-}
-
-
-
-
-//=======================================================
-// BLAS routines -- all based on Intel MKL (or IMSL C Math library).
-//=======================================================
-//void ScalingVectorUpdate(const double _alpha, TSdvector *x_dv) {
-// //Output: x = alpha*x;
-// //
-// call dscal (n, da, DX, incx)
-//}
-//Use the scaling vector MKL routine.
-
-double VectorDotVector(TSdvector *x1_dv, TSdvector *x2_dv) {
- //Output: Return sum(x1[i] * x2[i]) over i=1, ..., n.
- // Allows the case x1_dv = x2_dv.
- //Inputs:
- // x1_dv: _n-by-1 double vector.
- // x2_dv: _n-by-1 double vector.
- int _n, _i;
- double *x1, *x2,
- sum2 = 0.0; //Cumulative: must be set to 0.0.
-
- if ( !x1_dv || !x2_dv ) fn_DisplayError(".../mathlib.c/VectorDotVector(): All input vectors must be created (memory-allocated)");
-
- if ( (x1=x1_dv->v) == (x2=x2_dv->v) ) {
- if ( !x1_dv->flag ) fn_DisplayError(".../mathlib.c/VectorDotVector(): Input vectors must be given legal values");
- for (_i=x1_dv->n-1; _i>=0; _i--) sum2 += square(x1[_i]);
- }
- else {
- if ( (_n=x1_dv->n) != x2_dv->n ) fn_DisplayError(".../mathlib.c/VectorDotVector(): Dimensions of the two input vectors must be same");
- else if ( !x1_dv->flag || !x2_dv->flag ) fn_DisplayError(".../mathlib.c/VectorDotVector(): Both input vectors must be given legal values");
- for (_i=_n-1; _i>=0; _i--) sum2 += x1[_i]*x2[_i];
- }
-
- return ( sum2 );
- //return cblas_ddot(_n, x1_dv->v, 1, x2_dv->v, 1);
-}
-
-
-void ScalarTimesVectorUpdate(TSdvector *x2_dv, const double _alpha, TSdvector *x1_dv) {
- //Output: x2 = alpha * x1 + x2;
- //Inputs:
- // alpha: a double scalar;
- // x1: n-by-1 double vector.
- int _n;
-
- if ( !x1_dv || !x2_dv ) fn_DisplayError(".../mathlib.c/ScalarTimesVectorUpdate(): All input vectors must be created (memory-allocated)");
- else _n = x1_dv->n;
-
- if (_n != x2_dv->n) fn_DisplayError(".../mathlib.c/ScalarTimesVectorUpdate(): All input vectors must have the same length");
- else if ( !x1_dv->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesVectorUpdate(): R input vector must be given values");
- else {
- if ( x1_dv->v == x2_dv->v ) fn_DisplayError(".../mathlib.c/ScalarTimesVectorUpdate(): Two input vectors cannot be the same. Instead, use SclarTimesVector() for this option if you are sure this is what you want");
- cblas_daxpy(_n, _alpha, x1_dv->v, 1, x2_dv->v, 1);
- x2_dv->flag = V_DEF;
- }
-}
-
-void ScalarTimesVector(TSdvector *x_dv, const double _alpha, TSdvector *a_dv, const double _beta) {
- //Output: x_dv = alpha*a_dv + beta*x_dv where x_dv is n-by-1.
- // When beta=0.0 and x_dv->v = a_dv->v, x_dv->v will be replaced by new values.
- //Inputs:
- // a_dv: n-by-1.
- // _alpha: a double scalar.
- // _beta: a double scalar.
- int _i, _n;
- double *x, *a;
-
- if ( !x_dv || !a_dv ) fn_DisplayError(".../mathlib.c/ScalarTimesVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesVector(): R input vector must be given values");
- else {
- _n = x_dv->n;
- x = x_dv->v;
- a = a_dv->v;
- }
-
- if ( _n != a_dv->n ) fn_DisplayError(".../mathlib.c/ScalarTimesVector(): Two input vectors must have the same length");
- if (_beta == 0.0) {
- #if defined (INTELCMATHLIBRARY) // define: use Intek MKL LAPACK library; undef: use others.
- if ( x == a ) cblas_dscal(_n, _alpha, x, 1);
- else {
- memcpy(x_dv->v, a_dv->v, _n*sizeof(double));
- x_dv->flag = V_DEF;
- cblas_dscal(_n, _alpha, x, 1);
- }
- #else //SWITCHTOTZCMATH: use my own C math library (which is faster than MKL sometimes); undef: use others.
- for (_i=_n-1; _i>=0; _i--) x[_i] = _alpha*a[_i];
- x_dv->flag = V_DEF;
- #endif
- }
- else if (_beta == 1.0) {
- if ( x == a ) fn_DisplayError(".../mathlib.c/ScalarTimesVector(): Two input vectors must be different, i.e., pointing to different memory places");
- cblas_daxpy(_n, _alpha, a, 1, x, 1);
- x_dv->flag = V_DEF;
- }
- else {
- if ( x == a ) fn_DisplayError(".../mathlib.c/ScalarTimesVector(): Two input vectors must be different, i.e., pointing to different memory places");
- for (_i=_n-1; _i>=0; _i--) x[_i] = _alpha*a[_i] + _beta*x[_i];
- x_dv->flag = V_DEF;
- }
-}
-
-void VectorPlusMinusVectorUpdate(TSdvector *x_dv, const TSdvector *b_dv, double _alpha)
-{
- //Output: x_dv =_alpha * b_dv + x_dv where x_dv is _n-by-1.
- //Inputs:
- // b_dv: _n-by-1 double vector.
- // _alpha: double scalar.
- int _n;
-
-
- if ( !x_dv || !b_dv ) fn_DisplayError(".../mathlib.c/VectorPlusMinusVectorUpdate(): All input vectors must be created (memory-allocated)");
- else if ( !b_dv->flag || !x_dv->flag ) fn_DisplayError(".../mathlib.c/VectorPlusMinusVectorUpdate(): All input vectors must be given values");
- else {
- _n = x_dv->n;
- }
- if ( _n != b_dv->n ) fn_DisplayError(".../mathlib.c/VectorPlusMinusVectorUpdate(): Dimensions of all input vectors must be same");
-
- cblas_daxpy(_n, _alpha, b_dv->v, 1, x_dv->v, 1);
-}
-
-void VectorPlusMinusVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv, double _alpha)
-{
- //???????? Use tz_VectorPlusMinusVector() or VectorPlusVector() or VectorMinusVector().
- //????????? NOT finished yet.
- //????????Must add _beta for x_dv = alpha*a_dv + beta*b_dv. If x_dv=b_dv, update.
- //??????????? NOT fully tested yet.
- //Output: x_dv = a_dv + _alpha * b_dv where x_dv is _n-by-1.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- // _alpha: double scalar.
- int _n;
-
-
- if ( !x_dv || !a_dv || !b_dv ) fn_DisplayError(".../mathlib.c/VectorPlusMinusVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/VectorPlusMinusVector(): All input vectors must be given values");
- else {
- _n = x_dv->n;
- }
- if ( (_n != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError(".../mathlib.c/VectorPlusMinusVector(): Dimensions of all input vectors must be same");
-
- memcpy(x_dv->v, a_dv->v, _n*sizeof(double));
- cblas_daxpy(_n, _alpha, b_dv->v, 1, x_dv->v, 1);
-}
-
-void VectorTimesSelf(TSdmatrix *C_dm, const TSdvector *a_dv, const double _alpha, const double _beta, const char ul)
-{
- //Computes C = alpah*a*a' + beta*C where
- // Output:
- // the symmetric matrix C.
- // Inputs:
- // a is m-by-1,
- // C is m-by-m symmetric matrix,
- // alpha: a double scalar,
- // beta: a double scalar.
- // ul: if=='U' or 'u', only the upper triangular part of C is to be referenced; otherwise, only the lower triangular part of C is to be referenced;
- int _m, _n;
- int _i, _j;
- double *v, *M;
-
- if ( !C_dm || !a_dv ) fn_DisplayError(".../mathlib.c/VectorTimesSelf(): At least one of the pointer arguments is not created (memory-allocated)");
- else if (!a_dv->flag) fn_DisplayError(".../mathlib.c/VectorTimesSelf(): Input vector must have legal values");
- else {
- _m = C_dm->nrows;
- _n = C_dm->ncols;
- }
-
- if ( (_m != a_dv->n) || (_m !=_n) ) fn_DisplayError(".../mathlib.c/VectorTimesSelf(): (1) Size of the input matrix and dimensions of the two input vectors do not match. (2) Output matrix must be square");
- else {
- if ( _beta == 1.0 ) {
- #if defined (INTELCMATHLIBRARY) // define: use Intek MKL LAPACK library; undef: use others.
- //$$$$ cblas_dsyrk is much slower than the following line. cblas_dsyrk(CblasColMajor, ((ul=='u') || (ul=='U')) ? CblasUpper : CblasLower, CblasNoTrans, _m, 1, _alpha, a_dv->v, _m, _beta, C_dm->M, _m);
- cblas_dsyr(CblasColMajor, ((ul=='U') || (ul=='u')) ? CblasUpper : CblasLower, _m, _alpha, a_dv->v, 1, C_dm->M, _m);
- C_dm->flag = ((ul=='U') || (ul=='u')) ? M_SU : M_SL;
- #else //Corresponds to the default: SWITCHTOTZCMATH -- use my own C math library, which is faster than cblas_dsyrk().
- v = a_dv->v;
- M = C_dm->M;
- if ( (ul == 'U') || (ul == 'u') ) {
- C_dm->flag = M_SU;
- if ( _alpha==1.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] += v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] += _alpha * v[_i] * v[_j];
- }
- }
- }
- }
- else {
- C_dm->flag = M_SL;
- if ( _alpha==1.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] += v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] += _alpha * v[_i] * v[_j];
- }
- }
- }
- }
- #endif
- }
- else {
- //Corresponds to the default: SWITCHTOTZCMATH -- use my own C math library (which is faster than MKL sometimes).
- v = a_dv->v;
- M = C_dm->M;
- if ( (ul == 'U') || (ul == 'u') ) {
- C_dm->flag = M_SU;
- if ( _alpha==1.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] = v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- else {
- if ( _beta==0.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha * v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha* v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- }
- }
- else {
- C_dm->flag = M_SL;
- if ( _alpha==1.0 ) {
- if ( _beta==0.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- }
- else {
- if ( _beta==0.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha * v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha* v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- }
- }
- }
- }
-}
-
-#if defined (INTELCMATHLIBRARY)
-void VectorTimesVector(TSdmatrix *C_dm, const TSdvector *a_dv, const TSdvector *b_dv, const double _alpha, const double _beta) {
- //?????? NOT tested for _beta != 1.0.
- //Output is the matrix C and all other arguments are inputs.
- //If beta != 0, always converting C (if symmetric or trianuglar) to a general matrix before the operation.
- //The fastest way is to let _beta = 1.0.
- //Computes C = alpah*a*b' + beta*C where
- // a is m-by-1,
- // b is n-by-1,
- // C is m-by-n general matrix,
- // alpha: a double scalar,
- // beta: a double scalar.
- int _m, _n;
-
- if ( !C_dm || !a_dv || !b_dv ) fn_DisplayError(".../mathlib.c/VectorTimesVector(): At least one of the pointer arguments is not created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/VectorTimesVector(): Both input R vectors must be given values");
- else {
- _m = C_dm->nrows;
- _n = C_dm->ncols;
- }
- if (_beta != 0.0) {
- if ( !(C_dm->flag & M_GE) && (_m = _n) ) {
- if (C_dm->flag & M_SU) SUtoGE(C_dm);
- else if (C_dm->flag & M_SL) SLtoGE(C_dm);
- else fn_DisplayError(".../mathlib.c/VectorTimesVector(): (a) make sure C_dm has legal values; (b) for M_UT and M_LT, I have not got time to convert it to a general matrix");
- }
- }
-
-
-
- if ( (_m != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError(".../mathlib.c/VectorTimesVector(): Size of the input matrix and dimensions of the two input vectors do not match");
- else {
- if (_beta==1.0) {
- cblas_dger(CblasColMajor, _m, _n, _alpha, a_dv->v, 1, b_dv->v, 1, C_dm->M, _m);
- C_dm->flag = M_GE;
- }
- else {
- cblas_dgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, _m, _n, 1, _alpha, a_dv->v, _m, b_dv->v, 1, _beta, C_dm->M, _m);
- //???????????The above is probably too slow. Try the following two lines instead. 3/10/03.
- //????? Test to make sure this works for beta=0.
- //cblas_dscal(_m*_n, _beta, C_dm->M, 1);
- //cblas_dger(CblasColMajor, _m, _n, _alpha, a_dv->v, 1, b_dv->v, 1, C_dm->M, _m);
- C_dm->flag = M_GE;
- }
- }
-}
-#else
-//No default routine yet.
-#endif
-
-
-void MatrixPlusMinusMatrixUpdate(TSdmatrix *X_dm, TSdmatrix *A_dm, double _alpha)
-{
- //$$$$$ If A_dm or X_dm is only upper or lower symmetric, it will be always converted to a general (and symmetric) matrix. $$$$$$
- //Output: X =_alpha * A + X where X_dm is an m-by-n general (and possibly symmetric) matrix.
- //Inputs:
- // A_dm: m-by-n general or symmetric matrix.
- // _alpha: double scalar.
- int _m, _n, nels;
-
-
- if ( !X_dm || !A_dm ) fn_DisplayError(".../mathlib.c/MatrixPlusMinusMatrixUpdate(): All input matrices must be created (memory-allocated)");
- else if ( !X_dm->flag || !A_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixPlusMinusMatrixUpdate(): Both input matrices must be given values");
- else {
- _m = X_dm->nrows;
- _n = X_dm->ncols;
- nels = _m * _n;
- }
-
- if ( (_m != A_dm->nrows) || (_n != A_dm->ncols) ) fn_DisplayError(".../mathlib.c/MatrixPlusMinusMatrixUpdate(): Dimensions of all input matrices must be same");
-
- //=== Making both X_dm and A_dm general if not yet.
- if ( !(X_dm->flag & M_GE) ) {
- if (X_dm->flag & M_SU) SUtoGE(X_dm);
- else if (X_dm->flag & M_SL) SLtoGE(X_dm);
- else fn_DisplayError(".../mathlib.c/MatrixPlusMinusMatrixUpdate(): Haven't got time to deal with the M_UT and M_LT cases for X_dm");
- }
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixPlusMinusMatrixUpdate(): Haven't got time to deal with the M_UT and M_LT cases for A_dm");
- }
-
- cblas_daxpy(nels, _alpha, A_dm->M, 1, X_dm->M, 1); //This operation may be much cheaper than explicitly using SU or SL operations with two for loops and integer multiplications for matrix offsets.
-
- if ( X_dm->flag != A_dm->flag ) {
- //printf("WARNING for .../mathlib.c/MatrixPlusMinusMatrixUpdate(): the two input matrices do not have the same matrix type (or flag), so the output matrix is reset to M_GE");
- X_dm->flag = M_GE; //Reset to a general matrix only; otherwise, keep the original X_dm->flag.
- }
- //if ( X_dm->flag != A_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixPlusMinusMatrixUpdate(): both input matrices must have the same matrix type (or flag)");
-}
-
-void MatrixTimesVector(TSdvector *x_dv, TSdmatrix *A_dm, const TSdvector *b_dv, const double _alpha, const double _beta, const char tn)
-{
- //????? This is NOT checked yet: If x_dv = b_dv, x_dv or b_dv will be relaced by alpha*A*x + beta*x.
- //Output: x_dv = _alpha*A_dm'*b_dv + _beta*x_dv for tn=='T'; x_dv = _alpha*A_dm*b_dv + _beta*x_dv for tn=='N'
- // where x_dv->v is ncols-by-1 or nrows-by-1 and needs not be initialized outside this function if _beta is set to 0.0.
- //Inputs:
- // A_dm->M: nrows-by-ncols;
- // b_dv->v: nrows-by-1 or ncols-by-1;
- // _alpha: double scalar;
- // _beta: double scalar;
- // tn: if =='T' or 't', transpose of A_dm is used; otherwise, A_dm itself (no transpose) is used.
-
- if ( !x_dv || !A_dm || !b_dv) fn_DisplayError(".../mathlib.c/MatrixTimesVector(): At least one of the pointer arguments is not created (memory-allocated)");
- else if ( !A_dm->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/MatrixTimesVector(): R input matrix or vector must be given values");
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixTimesVector(): For M_UT and M_LT, use TrimatrixTimesVector() instead");
- }
-
-
- if ((tn=='T' || tn=='t') && (A_dm->nrows==b_dv->n) && (A_dm->ncols==x_dv->n)) {
- cblas_dgemv(CblasColMajor, CblasTrans, A_dm->nrows, A_dm->ncols, _alpha, A_dm->M, A_dm->nrows, b_dv->v, 1, _beta, x_dv->v, 1);
- x_dv->flag = V_DEF;
- }
- else if ( (A_dm->ncols==b_dv->n) && (A_dm->nrows==x_dv->n) ) {
- cblas_dgemv(CblasColMajor, CblasNoTrans, A_dm->nrows, A_dm->ncols, _alpha, A_dm->M, A_dm->nrows, b_dv->v, 1, _beta, x_dv->v, 1);
- x_dv->flag = V_DEF;
- }
-//--- The following if clause is wrong because, when tn=='N', A_dm->ncols == b_dv->n, NOT A_dm->nraws==b_dv_>n.
-// if ((A_dm->nrows==b_dv->n) && (A_dm->ncols==x_dv->n)) {
-// cblas_dgemv(CblasColMajor, (tn=='T' || tn=='t') ? CblasTrans : CblasNoTrans, A_dm->nrows, A_dm->ncols, _alpha, A_dm->M, A_dm->nrows, b_dv->v, 1, _beta, x_dv->v, 1);
-// x_dv->flag = V_DEF;
-// }
- else fn_DisplayError(".../mathlib.c/MatrixTimesVector(): Size of the input matrix and dimensions of the two input vectors do not match");
-}
-
-
-#if defined (INTELCMATHLIBRARY)
-void TrimatrixTimesVector(TSdvector *x_dv, TSdmatrix *A_dm, TSdvector *b_dv, const char tn, const char un)
-{
- //Output: x_dv = A_dm'*b_dv for tn=='T'; x_dv = A_dm*b_dv for tn=='N' where x_dv->v is _n-by-1.
- // If x_dv = b_dv (which gives the fastest return, so try to use this option when possible), x_dv will be relaced by A*b or A'*b.
- //Inputs:
- // A_dm->M: _n-by-_n triangular matrix.
- // b_dv->v: _n-by-1 vector.
- // tn: if =='T' or 't', transpose of A_dm is used; otherwise, A_dm itself (no transpose) is used.
- // un: if =='U' or 'u', A_dm is unit triangular; otherwise, A_dm is non-unit triangular (i.e., a regular triangular matrix).
-
- int _n;
-// double *x, *b;
-
- if ( !x_dv || !A_dm || !b_dv) fn_DisplayError(".../mathlib.c/TrimatrixTimesVector(): At least one of the pointer arguments is not created (memory-allocated)");
- else if ( !A_dm->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/TrimatrixTimesVector(): R input matrix or vector must be given values");
- else if ( ((_n = A_dm->nrows) != x_dv->n) ) fn_DisplayError(".../mathlib.c/TrimatrixTimesVector(): Size of input matrix and dimension of input vector must match");
- else if ( !(A_dm->flag & (M_UT | M_LT) ) ) fn_DisplayError(".../mathlib.c/TrimatrixTimesVector(): Make sure R matrix is triangular (i.e., M_UT or M_LT)");
-
-// if ( (x = x_dv->v) == (b = b_dv->v) ) //Commented out on 22 Oct 03.
- if ( x_dv == b_dv )
- cblas_dtrmv(CblasColMajor, (A_dm->flag & M_UT) ? CblasUpper : CblasLower, (tn=='T' || tn=='t') ? CblasTrans : CblasNoTrans, (un=='U' || un=='u') ? CblasUnit : CblasNonUnit, A_dm->nrows, A_dm->M, A_dm->nrows, x_dv->v, 1);
- else {
- if ( _n != b_dv->n ) fn_DisplayError(".../mathlib.c/TrimatrixTimesVector(): Two vectors must have the same length");
- memcpy(x_dv->v, b_dv->v, _n*sizeof(double));
- cblas_dtrmv(CblasColMajor, (A_dm->flag & M_UT) ? CblasUpper : CblasLower, (tn=='T' || tn=='t') ? CblasTrans : CblasNoTrans, (un=='U' || un=='u') ? CblasUnit : CblasNonUnit, A_dm->nrows, A_dm->M, A_dm->nrows, x_dv->v, 1);
- x_dv->flag = V_DEF;
- }
-}
-#else
-//No default routine yet.
-#endif
-
-
-#if defined (INTELCMATHLIBRARY)
-void SymmatrixTimesVector(TSdvector *x_dv, TSdmatrix *A_dm, TSdvector *b_dv, const double _alpha, const double _beta)
-{
- //????? This is NOT checked yet: If x_dv = b_dv, x_dv or b_dv will be relaced by alpha*A*x + beta*x.
- //Output:
- // x_dv = alpha*A_dm*b_dv + beta*x_dv where x_dv->v is _n-by-1.
- // When beta=0, there is no need to initialize the value of x_dv.
- //Inputs:
- // A_dm->M: _n-by-_n triangular matrix.
- // b_dv->v: _n-by-1 vector.
- // _alpha: double scalar;
- // _beta: double scalar;
-
- int _n;
-
- if ( !x_dv || !A_dm || !b_dv) fn_DisplayError(".../mathlib.c/SymmatrixTimesVector(): all input and output arguments must be created (memory-allocated)");
- else if ( !A_dm->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/SymmatrixTimesVector(): R input matrix or vector must be given values");
- else if ( ((_n = A_dm->nrows) != x_dv->n) || (_n != b_dv->n) ) fn_DisplayError(".../mathlib.c/SymmatrixTimesVector(): Size of input matrix and dimensions of input and output vectors must all match");
- else if ( !(A_dm->flag & (M_SU | M_SL) ) ) fn_DisplayError(".../mathlib.c/SymmatrixTimesVector(): Make sure R input matrix is symmetric (i.e., M_SU or M_SL)");
-
- cblas_dsymv(CblasColMajor, (A_dm->flag & M_SU) ? CblasUpper : CblasLower, _n, _alpha, A_dm->M, _n, b_dv->v, 1, _beta, x_dv->v, 1);
- x_dv->flag = V_DEF;
-}
-#else
-//No default routine yet.
-#endif
-
-
-
-void VectorTimesMatrix(TSdvector *x_dv, const TSdvector *b_dv, TSdmatrix *A_dm, const double _alpha, const double _beta, const char tn) {
- //Note this function is exactly the opposite of MatrixTimeVector (which is based on the MKL default).
- //
- //Output: x_dv->v = _alpha*b_dv*A_dm + _beta*x_dv for tn=='N'; x_dv = _alpha*b_dv*A_dm' + _beta*x_dv for tn=='T'
- // where x_dv->v is 1-by-ncols or 1-by-nrows and needs not be initialized outside this function if _beta is set to 0.0.
- //Inputs:
- // A_dm->M: nrows-by-ncols;
- // b_dv->v: 1-by-nrows or 1-by-ncols;
- // _alpha: double scalar;
- // _beta: double scalar;
- // tn: if =='T' or 't', transpose of A_dm is used; otherwise (=='N' or 'n'), A_dm itself (no transpose) is used.
-
- if ( !x_dv || !A_dm || !b_dv) fn_DisplayError(".../mathlib.c/VectorTimesMatrix(): At least one of the pointer arguments is not created (memory-allocated)");
- else if ( !A_dm->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/VectorTimesMatrix(): R input matrix or vector must be given values");
-
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/VectorTimesMatrix(): Haven't got time to deal with the M_UT and M_LT cases for A_dm");
- }
-
-
- if ( ((tn=='T') || (tn=='t')) && (A_dm->ncols==b_dv->n) && (A_dm->nrows==x_dv->n)) {
- cblas_dgemv(CblasColMajor, CblasNoTrans, A_dm->nrows, A_dm->ncols, _alpha, A_dm->M, A_dm->nrows, b_dv->v, 1, _beta, x_dv->v, 1);
- x_dv->flag = V_DEF;
- }
- else if ( (A_dm->nrows==b_dv->n) && (A_dm->ncols==x_dv->n) ) {
- cblas_dgemv(CblasColMajor, CblasTrans, A_dm->nrows, A_dm->ncols, _alpha, A_dm->M, A_dm->nrows, b_dv->v, 1, _beta, x_dv->v, 1);
- x_dv->flag = V_DEF;
- }
- else {
- fn_DisplayError(".../mathlib.c/VectorTimesMatrix(): Size of the matrix and dimensions of the two vectors do not match");
- }
-}
-
-void ScalarTimesMatrix(TSdmatrix *x_dm, const double _alpha, TSdmatrix *a_dm, const double _beta)
-{
- //$$$$$ If a_dm or x_dm (when _beta!=0) is only upper or lower symmetric, it will be always converted to a general (and symmetric) matrix. $$$$$$
- //Output: x_dm = alpha*a_dm + beta*x_dm where x_dm is m-by-n.
- // Fastest way is to let beta=0.0 and x_dm->M = a_dm->M. Then x_dm->M will be replaced by new values.
- // However, with beta=0.0, x_dm and a_dm can be different.
- //Inputs:
- // a_dm: m-by-n.
- // _alpha: a double scalar.
- // _beta: a double scalar.
- int _i, _m, _n, nels;
- double *X, *A;
-
- if ( !x_dm || !a_dm ) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): All input matrices must be created (memory-allocated)");
- else if ( _beta != 0 && !x_dm->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): Input and output matrix must be given legal values because beta != 0");
- else if ( !a_dm->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): R input matrix must be given legal values");
- else {
- _m = x_dm->nrows;
- _n = x_dm->ncols;
- nels = _m*_n;
- X = x_dm->M;
- A = a_dm->M;
- }
-
- if ( !(a_dm->flag & M_GE) ) {
- if (a_dm->flag & M_SU) SUtoGE(a_dm);
- else if (a_dm->flag & M_SL) SLtoGE(a_dm);
- else fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): Haven't got time to deal with the M_UT or M_LT cases for a_dm");
- }
- if ( _beta && !(x_dm->flag & M_GE) ) {
- if (x_dm->flag & M_SU) SUtoGE(x_dm);
- else if (x_dm->flag & M_SL) SLtoGE(x_dm);
- else fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): Haven't got time to deal with the M_UT or M_LT cases for x_dm");
- }
-
- if ( (_m != a_dm->nrows) || (_n != a_dm->ncols) ) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): Two input matrices must have the same dimension");
- if (_beta == 0.0) {
- #if defined( SWITCHTOINTELCMATH ) // define: use Intek MKL LAPACK library; undef: use others.
- if ( X == A ) cblas_dscal(nels, _alpha, X, 1);
- else {
- memcpy(X, A, nels*sizeof(double));
- x_dm->flag = a_dm->flag;
- cblas_dscal(nels, _alpha, X, 1);
- }
- #else //My own C math library (which is faster than MKL sometimes); undef: use others.
- for (_i=nels-1; _i>=0; _i--) X[_i] = _alpha*A[_i];
- x_dm->flag = a_dm->flag;
- #endif
- }
- else if (_beta == 1.0) {
- #if defined( SWITCHTOINTELCMATH ) // define: use Intek MKL LAPACK library; undef: use others.
- if ( X == A ) for (_i=nels-1; _i>=0; _i--) X[_i] += _alpha*A[_i]; //fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): to use cblas_daxpy(), the two input matrices must be different, i.e., pointing to different memory places");
- else cblas_daxpy(nels, _alpha, A, 1, X, 1);
- #else
- for (_i=nels-1; _i>=0; _i--) X[_i] += _alpha*A[_i];
- #endif
- if ( x_dm->flag != a_dm->flag ) x_dm->flag = M_GE;
- }
- else if (_alpha == _beta) {
- //if ( X == A ) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): Two input matrices must be different, i.e., pointing to different memory places");
- //=== Intel library is at least twice as slow as my own loop for a large matarix like 100-by-100 and can be 20 times slower for a small matrix like 15-by-15.
- //=== So I don't use Intel library for this.
- // #ifdef SWITCHTOINTELCMATH // define: use Intek MKL LAPACK library; undef: use others.
- // cblas_daxpy(nels, 1.0, A, 1, X, 1);
- // cblas_dscal(nels, _alpha, X, 1);
- // #endif
- // #ifdef SWITCHTOTZCMATH // define: use my own C math library (which is faster than MKL sometimes); undef: use others.
- // for (_i=nels-1; _i>=0; _i--) X[_i] = _alpha*(A[_i] + X[_i]);
- // #endif
- if (!(x_dm->flag & M_GE)) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): x_dm must be M_GE"
- " -- have not got time to convert other matrices to a general matrix");
- for (_i=nels-1; _i>=0; _i--) X[_i] = _alpha*(A[_i] + X[_i]);
- if ( x_dm->flag != a_dm->flag ) x_dm->flag = M_GE;
- }
- else {
- //if ( X == A ) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): Two input matrices must be different, i.e., pointing to different memory places");
- if (!(x_dm->flag & M_GE)) fn_DisplayError(".../mathlib.c/ScalarTimesMatrix(): x_dm must be M_GE"
- " -- have not got time to convert other matrices to a general matrix");
- for (_i=nels-1; _i>=0; _i--) X[_i] = _alpha*A[_i] + _beta*X[_i];
- if ( x_dm->flag != a_dm->flag ) x_dm->flag = M_GE;
- }
-}
-//---
-void ScalarTimesMatrixSquare(TSdmatrix *B_dm, const double _alpha, TSdmatrix *A_dm, const char tn, const double _beta)
-{
- //Outputs:
- // B = alpha*o(A) + beta*B, where o(A) = A' if tn=='T' or 't' or A if tn=='N' or 'n'.
- // If A=B, then A is replaced by alpha*o(A) + beta*A.
- //Inputs:
- // A_dm: n-by-n square matrix.
- // B_dm: n-by-n square matrix.
- // tn: 'T' (transpose of A) or 'N' (no transpose).
- // alpha, beta: double scalars.
-
- int _n = A_dm->nrows;
- TSdmatrix *Atran_dm = NULL;
-
- if (!A_dm || !B_dm) fn_DisplayError(".../mathlib.c/ScalarTimesMatrixSquare(): A_dm and B_dm must be created (memory-allocated)");
- if (A_dm->nrows != A_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesMatrixSquare(): A_dm must be square");
-
- if (A_dm->M == B_dm->M)
- {
- if ((tn == 'T') || (tn == 't'))
- {
- Atran_dm = CreateMatrix_lf(_n,_n);
- TransposeSquare(Atran_dm, A_dm);
- ScalarTimesMatrix(A_dm, _alpha, Atran_dm, _beta);
- }
- else
- {
- ScalarTimesMatrix(A_dm, _alpha, A_dm, _beta);
- }
- }
- else
- {
- if ((B_dm->nrows != B_dm->ncols) || (B_dm->nrows != A_dm->nrows)) fn_DisplayError(".../mathlib.c/ScalarTimesMatrixSquare(): B_dm must be square and B_dm=A_dm");
- if ((tn == 'T') || (tn == 't'))
- {
- Atran_dm = CreateMatrix_lf(_n,_n);
- TransposeSquare(Atran_dm, A_dm);
- ScalarTimesMatrix(B_dm, _alpha, Atran_dm, _beta);
- }
- else
- {
- ScalarTimesMatrix(B_dm, _alpha, A_dm, _beta);
- }
- }
-
- //===
- DestroyMatrix_lf(Atran_dm);
-}
-
-
-
-void MatrixTimesSelf(TSdmatrix *C_dm, const char ul, TSdmatrix *A_dm, const char tn, const double _alpha, const double _beta)
-{
- //If tn=='N' or 'n', C = alpha*A*A' + beta*C.
- //If tn=='T' or 't', C = alpha*A'*A + beta*C.
- //If ul=='U' or 'u', C_dm->flag = M_SU;
- //If ul=='L' or 'l', C_dm->flag = M_SL;
- // C must be different from A.
- // C is n-by-n;
- // A is n-by-k if tn=='N';
- // k-by-n if tn=='T';
- // alpha is a double scalar,
- // beta is a double scalar.
- int _n, _k, lda;
-
- if ( !C_dm || !A_dm ) fn_DisplayError(".../mathlib.c/MatrixTimesSelf): All input and output matrices must be created (memory-allocated)");
- else if ( !A_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixTimesSelf): Both R input matrices must be given values");
- //=== Making this matrix general if not yet.
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixTimesSelf): Haven't got time to deal with the M_UT or M_LT cases for A_dm");
- }
-
-
- if ((tn=='T') || (tn=='t')) {
- if (((_n=C_dm->nrows) != A_dm->ncols)) fn_DisplayError(".../mathlib.c/MatrixTimesSelf): Dimensions of A and C do not match where C = alpha*A'*A + beta*C");
- else if (_n != C_dm->ncols) fn_DisplayError(".../mathlib.c/MatrixTimesSelf): Output matrix C must be a square matrix");
- lda = _k = A_dm->nrows;
- }
- else {
- if ((_n=C_dm->nrows) != (lda=A_dm->nrows)) fn_DisplayError(".../mathlib.c/MatrixTimesSelf): Dimensions of A and C do not match where C = alpha*A*A' + beta*C");
- else if (_n != C_dm->ncols) fn_DisplayError(".../mathlib.c/MatrixTimesSelf): Output matrix C must be a square matrix");
- _k = A_dm->ncols;
- }
-
- cblas_dsyrk(CblasColMajor, ((ul=='U') || (ul=='u')) ? CblasUpper : CblasLower, ((tn=='T') || (tn=='t')) ? CblasTrans : CblasNoTrans, _n, _k, _alpha, A_dm->M, lda, _beta, C_dm->M, _n);
- C_dm->flag = ((ul=='U') || (ul=='u')) ? M_SU : M_SL;
-}
-
-
-void MatrixTimesMatrix(TSdmatrix *C_dm, TSdmatrix *A_dm, TSdmatrix *B_dm, const double _alpha, const double _beta, const char tn1, const char tn2) {
- //Output is C and all other arguments are inputs.
- //Computes C = alpah*op(A)*op(B) + beta*C where op() is either transpose or not, depending on 't' or 'n',
- // op(A) is m-by-k,
- // op(B) is k-by-n,
- // C is m-by-n,
- // C must be different from A and from B.
- // A and B can be the same, however.
- // alpha is a double scalar,
- // beta is a double scalar.
- // tn1: if == 'T' or 't', the transpose of A is used; otherwise (== 'N' or 'n'), A itself (no transpose) is used.
- // tn2: if == 'T' or 't', the transpose of B is used; otherwise (== 'N' or 'n'), B itself (no transpose) is used.
- int m1, n1, m2, n2, m3, n3;
-
- if ( !C_dm || !A_dm || !B_dm ) fn_DisplayError(".../mathlib.c/MatrixTimesMatrix(): All input and output matrices must be created (memory-allocated)");
- else if ( !A_dm->flag || !B_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixTimesMatrix(): Both R input matrices must be given values");
- else {
- m1 = A_dm->nrows;
- n1 = A_dm->ncols;
- m2 = B_dm->nrows;
- n2 = B_dm->ncols;
- m3 = C_dm->nrows;
- n3 = C_dm->ncols;
- }
- if ( (_beta != 0.0) && !(C_dm->flag) ) fn_DisplayError(".../mathlib.c/MatrixTimesMatrix(): L input matrix C_dm must be given values when beta !=0.0 (i.e., when C_dm is to be particially updated)");
-
-
- //=== Making these matrices general if not yet. For complete symmetric matrix multiplications, do use this function.
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixTimesMatrix(): Haven't got time to deal with the M_UT or M_LT cases for A_dm");
- }
- if ( !(B_dm->flag & M_GE) ) {
- if (B_dm->flag & M_SU) SUtoGE(B_dm);
- else if (B_dm->flag & M_SL) SLtoGE(B_dm);
- else fn_DisplayError(".../mathlib.c/MatrixTimesMatrix(): Haven't got time to deal with the M_UT or M_LT cases for B_dm");
- }
-
-
-
- if ( ((tn1=='N') || (tn1=='n')) && ((tn2=='N') || (tn2=='n')) && (n1 == m2) && (m3 == m1) && (n3 == n2) ) {
- cblas_dgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, m3, n3, n1, _alpha, A_dm->M, m1, B_dm->M, m2, _beta, C_dm->M, m3);
- C_dm->flag = M_GE;
- }
- else if ( ((tn1=='T') || (tn1=='t')) && ((tn2=='N') || (tn2=='n')) && (m1 == m2) && (m3 == n1) && (n3 == n2) ) {
- cblas_dgemm(CblasColMajor, CblasTrans, CblasNoTrans, m3, n3, m1, _alpha, A_dm->M, m1, B_dm->M, m2, _beta, C_dm->M, m3);
- C_dm->flag = M_GE;
- }
- else if ( ((tn1=='T') || (tn1=='t')) && ((tn2=='T') || (tn2=='t')) && (m1 == n2) && (m3 == n1) && (n3 == m2) ) {
- cblas_dgemm(CblasColMajor, CblasTrans, CblasTrans, m3, n3, m1, _alpha, A_dm->M, m1, B_dm->M, m2, _beta, C_dm->M, m3);
- C_dm->flag = M_GE;
- }
- else if ( ((tn1=='N') || (tn1=='n')) && ((tn2=='T') || (tn2=='t')) && (n1 == n2) && (m3 == m1) && (n3 == m2) ) {
- cblas_dgemm(CblasColMajor, CblasNoTrans, CblasTrans, m3, n3, n1, _alpha, A_dm->M, m1, B_dm->M, m2, _beta, C_dm->M, m3);
- C_dm->flag = M_GE;
- }
- else fn_DisplayError(".../mathlib.c/MatrixTimesMatrix(): (1) Dimensions of both R input matrices must match. (2) Dimension of L input matrix must compatible with the multiplication of the two R input matrices");
-}
-
-void SolveTriSysVector(TSdvector *x_dv, const TSdmatrix *T_dm, TSdvector *b_dv, const char tn, const char un)
-{
- //Output: computes x_dv = inv(T_dm)*b_dv by solving a triangular system of equation T_dm * x_dv = b_dv.
- // x_dv(_n-by-1) = inv(T_dm)*b_v if tn=='N'; = inv(T_dm')*b_v if tn=='T'.
- // Fastest way is to let x_dv->v = b_dv->v. Then, x_dv->v will be replaced by new values.
- //-------
- //Inputs:
- // T_dm: _n-by-_n upper or lower triangular matrix;
- // b_dv: _n-by-1 vector.
- // tn: if =='T' or 't', T_dm->M' (transpose), instead of T_m, will be used; otherwise (i.e., =='n' or 'N'), T_dm->M itself (no transpose) will be used.
- // un: if =='U' or 'u', T_dm is a unit upper triangular (i.e., the diagonal being 1);
- // otherwise (i.e., if =='N' or 'n'), T_dm is a non-unit upper triangular.
- //
- // Note I: Intel MLK cblas_dtrsv() does not test for singularity or near-singulariy of the system.
- // Such tests must be performed before calling this BLAS routine.
- // Note II: if x_dv->v = b_dv->v, x_dv->v will be replaced by new values.
- int _n, _i;
- double *x, *b;
-
- if ( !T_dm || !b_dv || !x_dv ) fn_DisplayError(".../mathlib.c/SolveTriSysVector(): All input pointers must be created (memory-allocated)");
- else if ( !( T_dm->flag & (M_UT | M_LT) ) || !b_dv->flag ) fn_DisplayError(".../mathlib.c/SolveTriSysVector(): (1) R input matrix must be triangular. (2) R input vector must be given legal values");
- else {
- _n = T_dm->nrows;
- x = x_dv->v;
- b = b_dv->v;
- }
-
- for (_i=square(_n)-1; _i>=0; _i -= _n+1)
- if (fabs(T_dm->M[_i])<=MACHINEZERO)
- fn_DisplayError(".../mathlib.c/SolveTriSysVector(): The input triangular matrix is singular");
-
-
- if ( (_n != T_dm->ncols) || (_n != b_dv->n) || (_n != x_dv->n) ) fn_DisplayError(".../mathlib.c/SolveTriSysVector(): (1) R input matrix must be square. (2) Input vectors and the square matrix must have the same dimension");
- else if ( x == b) {
- cblas_dtrsv(CblasColMajor, ( T_dm->flag & M_UT ) ? CblasUpper : CblasLower,
- ((tn=='T') || (tn=='t')) ? CblasTrans : CblasNoTrans,
- ((un=='U') || (tn=='u')) ? CblasUnit : CblasNonUnit,
- _n, T_dm->M, _n, x, 1);
- }
- else {
- memcpy(x, b, _n*sizeof(double));
- cblas_dtrsv(CblasColMajor, ( T_dm->flag & M_UT ) ? CblasUpper : CblasLower,
- ((tn=='T') || (tn=='t')) ? CblasTrans : CblasNoTrans,
- ((un=='U') || (tn=='u')) ? CblasUnit : CblasNonUnit,
- _n, T_dm->M, _n, x, 1);
- x_dv->flag = V_DEF;
- }
-}
-
-
-
-
-
-
-void SymmetricMatrixTimesVector(double *x_v, const double a, const double *A_m, const double *a_v, const double b, const int _n, const char ul) {
- //Output: x_v = a*A_m*a_v + b*X_m where x_v (_n-by-1) must be allocated (but needs not be initialized).
- //Inputs: X_m??????????????????????
- // A_m: _n-by-_n symmetric matrix;
- // a_v: _n-by-1;
- // a, b: scalars;
- // ul: if =='u' or 'U', upper triangular elements in A_m are filled; if =='l' or 'L', lower triangular elements in A_m are filled.
-
- cblas_dsymv(CblasColMajor, ((ul=='u') || (ul=='U')) ? CblasUpper : CblasLower, _n, a, A_m, _n, a_v, 1, b, x_v, 1);
-}
-
-
-void SolveTriangularSystemVector(double *x_v, const double *A_m, const double *b_v, const int _n, const char ul, const char tn, const char un) {
- //Outputs:
- // x_v(_n-by-1) = inv(A_m)*b_v. If x_v=b_v, b_v will be overwritten by x_v.
- //-------
- //Inputs:
- // A_m: _n-by-_n upper or lower triangular matrix;
- // b_v: _n-by-1 vector.
- // ul: if =='u' or 'U', A_m is upper triangular; if =='l' or 'L', A_m is lower triangular.
- // tn: if =='t' or 'T', A_m' (transpose), instead of A_m, will be used; if =='n', A_m itself (no transpose) will be used.
- // un: if =='u' or 'U', A_m is a unit upper triangular (i.e., the diagonal being 1);
- // if =='n' or 'N', A_m is a non-unit upper triangular.
- //
- // Computes x_v = inv(A_m)*b_v by solving a triangular system of equation A_m * x_v = b_v.
- // Note I: Intel MLK cblas_dtrsv() does not test for singularity or near-singulariy of the system.
- // Such tests must be performed before calling this BLAS routine.
- // Note II: if x_v=b_v, b_v will be overwritten by x_v.
-
- if (x_v != b_v) memcpy(x_v, b_v, _n*sizeof(double));
- cblas_dtrsv(CblasColMajor, ((ul=='u') || (ul=='U')) ? CblasUpper : CblasLower,
- ((tn=='t') || (tn=='T')) ? CblasTrans : CblasNoTrans,
- ((un=='u') || (tn=='U')) ? CblasNonUnit : CblasNonUnit,
- _n, A_m, _n, x_v, 1);
-}
-
-
-
-
-
-//=======================================================
-// MKL Vector Mathematical Library with default using my own routines.
-//=======================================================
-void VectorDotDivByVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv) {
- //????????? NOT tested yet. 06/13/03.
- //Output: x_dv = a_dv ./ b_dv (division element by elment) where x_dv, a_dv, and b_dv are all _n-by-1.
- // The fastest way is to use MKL VML with x != a and x != b.
- // If x_dv = a_dv, x_dv will be replaced by x_dv ./ b_dv.
- // If x_dv = b_dv, x_dv will be replaced by a_dv ./ x_dv.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- int _i, _n;
- double *x, *a, *b;
-
-
- if ( !x_dv || !a_dv || !b_dv) fn_DisplayError(".../mathlib.c/VectorDotDivideVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/VectorDotDivideVector(): R input vectors must be given legal values");
- else if ( ((_n=x_dv->n) != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError(".../mathlib.c/VectorDotDivideVector(): Dimensions of all input vectors must be same");
- else {
- x = x_dv->v;
- a = a_dv->v;
- b = b_dv->v;
- }
-
-
- #if !defined (INTELCMATHLIBRARY)
- if ( (x != a) && (x != b) ) {
- vdDiv (_n, a, b, x);
- x_dv->flag = V_DEF;
- }
- else
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i]/b[_i];
- #else //Default to my own routine.
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i]/b[_i];
- x_dv->flag = V_DEF;
- #endif
-}
-
-void ElementwiseVectorDivideVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv)
-{
- //The fastest way is to use MKL VML with x != a and x != b.
- //Output: x_dv = a_dv ./ b_dv (division element by elment) where x_dv, a_dv, and b_dv are all _n-by-1.
- // If x_dv = a_dv, x_dv will be replaced by x_dv ./ b_dv.
- // If x_dv = b_dv, x_dv will be replaced by a_dv ./ x_dv.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- int _i, _n;
- double *x, *a, *b;
-
- if ( !x_dv || !a_dv || !b_dv) fn_DisplayError("mathlib.c/ElementwiseVectorDivideVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError("mathlib.c/ElementwiseVectorDivideVector(): R input vectors must be given legal values");
- else if ( ((_n=x_dv->n) != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError("mathlib.c/ElementwiseVectorDivideVector(): Dimensions of all input vectors must be same");
- else {
- x = x_dv->v;
- a = a_dv->v;
- b = b_dv->v;
- }
-
-
- #if !defined (INTELCMATHLIBRARY)
- if ( (x != a) && (x != b) ) {
- vdDiv (_n, a, b, x);
- x_dv->flag = V_DEF;
- }
- else
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i]/b[_i];
- #else //Default to my own routine.
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i]/b[_i];
- x_dv->flag = V_DEF;
- #endif
-}
-
-void ElementwiseInverseofVector(TSdvector *y_dv, TSdvector *x_dv) {
- //The fastest way is to use MKL VML with y_dv != x_dv;
- //Outputs:
- // If y_dv!=x_dv, y_dv = 1 ./ x_dv;
- // If y_dv=x_dv, x_dv = 1 ./ x_dv.
-
- int _i;
- #if defined( INTELCMATHLIBRARY )
- int _n;
- double *y;
- #endif
- double *x;
-
- if ( !x_dv || !x_dv->flag ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofVector(): (1) Input vector must be memory-allocated; (2) Legal values must be given");
-
- #if !defined( INTELCMATHLIBRARY )
- if ( y_dv == x_dv ) {
- x = x_dv->v;
- for (_i=x_dv->n-1; _i>=0; _i--) x[_i] = 1.0/x[_i];
- }
- else {
- if ( !y_dv ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofVector(): Output vector must be memory-allocated (but no need for legal values)");
- if ( x_dv->n != y_dv->n) fn_DisplayError(".../mathlib.c/ElementwiseInverseofVector(): Lengths of both input and output vectors must be same");
- vdInv (x_dv->n, x_dv->v, y_dv->v);
- y_dv->flag = V_DEF;
- }
- #else
- if ( y_dv == x_dv ) {
- x = x_dv->v;
- for (_i=x_dv->n-1; _i>=0; _i--) x[_i] = 1.0/x[_i];
- }
- else {
- if ( !y_dv ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofVector(): Output vector must be memory-allocated (but no need for legal values)");
- if ( (_n=x_dv->n) != y_dv->n) fn_DisplayError(".../mathlib.c/ElementwiseInverseofVector(): Lengths of both input and output vectors must be same");
- x = x_dv->v;
- y = y_dv->v;
- for (_i=_n-1; _i>=0; _i--) y[_i] = 1.0/x[_i];
- y_dv->flag = V_DEF;
- }
- #endif
-}
-
-void ElementwiseSqrtofVector(TSdvector *y_dv, TSdvector *x_dv)
-{
- //The fastest way is to use MKL VML with y_dv != x_dv;
- //Outputs:
- // If y_dv!=x_dv, y_dv = sqrt(x_dv);
- // If y_dv=x_dv, x_dv = sqrt(x_dv);
-
- int _i;
- #if defined( INTELCMATHLIBRARY )
- int _n;
- double *y;
- #endif
- double *x;
-
- if ( !x_dv || !x_dv->flag ) fn_DisplayError("mathlib.c/ElementwiseSqrtofVector(): (1) Input vector must be memory-allocated; (2) Legal values must be given");
-
- #if !defined( INTELCMATHLIBRARY )
- if ( y_dv == x_dv ) {
- x = x_dv->v;
- for (_i=x_dv->n-1; _i>=0; _i--) x[_i] = sqrt(x[_i]);
- }
- else {
- if ( !y_dv ) fn_DisplayError("mathlib.c/ElementwiseSqrtofVector(): Output vector must be memory-allocated (but no need for legal values)");
- if ( x_dv->n != y_dv->n) fn_DisplayError("mathlib.c/ElementwiseSqrtofVector(): Lengths of both input and output vectors must be same");
- vdSqrt(x_dv->n, x_dv->v, y_dv->v);
- y_dv->flag = V_DEF;
- }
- #else
- if ( y_dv == x_dv ) {
- x = x_dv->v;
- for (_i=x_dv->n-1; _i>=0; _i--) x[_i] = sqrt(x[_i]);
- }
- else {
- if ( !y_dv ) fn_DisplayError("mathlib.c/ElementwiseSqrtofVector(): Output vector must be memory-allocated (but no need for legal values)");
- if ( (_n=x_dv->n) != y_dv->n) fn_DisplayError("mathlib.c/ElementwiseSqrtofVector(): Lengths of both input and output vectors must be same");
- x = x_dv->v;
- y = y_dv->v;
- for (_i=_n-1; _i>=0; _i--) y[_i] = sqrt(x[_i]);
- y_dv->flag = V_DEF;
- }
- #endif
-}
-
-void ElementwiseLogofVector(TSdvector *y_dv, TSdvector *x_dv)
-{
- //The fastest way is to use MKL VML with y_dv != x_dv;
- //Outputs:
- // If y_dv!=x_dv, y_dv = log(x_dv);
- // If y_dv=x_dv, x_dv = log(x_dv);
-
- int _i;
- #if defined( INTELCMATHLIBRARY )
- int _n;
- double *y;
- #endif
- double *x;
-
- if ( !x_dv || !x_dv->flag ) fn_DisplayError("mathlib.c/ElementwiseLogofVector(): (1) Input vector must be memory-allocated; (2) Legal values must be given");
-
- #if !defined( INTELCMATHLIBRARY )
- if ( y_dv == x_dv ) {
- x = x_dv->v;
- for (_i=x_dv->n-1; _i>=0; _i--) x[_i] = log(x[_i]);
- }
- else {
- if ( !y_dv ) fn_DisplayError("mathlib.c/ElementwiseLogofVector(): Output vector must be memory-allocated (but no need for legal values)");
- if ( x_dv->n != y_dv->n) fn_DisplayError("mathlib.c/ElementwiseLogofVector(): Lengths of both input and output vectors must be same");
- vdLn(x_dv->n, x_dv->v, y_dv->v);
- y_dv->flag = V_DEF;
- }
- #else
- if ( y_dv == x_dv ) {
- x = x_dv->v;
- for (_i=x_dv->n-1; _i>=0; _i--) x[_i] = log(x[_i]);
- }
- else {
- if ( !y_dv ) fn_DisplayError("mathlib.c/ElementwiseLogofVector(): Output vector must be memory-allocated (but no need for legal values)");
- if ( (_n=x_dv->n) != y_dv->n) fn_DisplayError("mathlib.c/ElementwiseLogofVector(): Lengths of both input and output vectors must be same");
- x = x_dv->v;
- y = y_dv->v;
- for (_i=_n-1; _i>=0; _i--) y[_i] = log(x[_i]);
- y_dv->flag = V_DEF;
- }
- #endif
-}
-
-
-void ElementwiseInverseofMatrix(TSdmatrix *Y_dm, TSdmatrix *X_dm)
-{
- //The fastest way is to use MKL VML with Y_dm != X_dm;
- //Outputs:
- // If Y_dm!=X_dm, Y_dm = 1 ./ X_dm;
- // If Y_dm=X_dm, X_dm = 1 ./ X_dm.
-
- int _i,
- nrows, ncols;
- double *X;
- #if defined( INTELCMATHLIBRARY )
- double *Y;
- #endif
-
-
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofMatrix(): (1) Input matrix must be memory-allocated; (2) Legal values must be given");
-
- #if !defined( INTELCMATHLIBRARY )
- if ( Y_dm == X_dm ) {
- X = X_dm->M;
- for (_i=X_dm->nrows*X_dm->ncols-1; _i>=0; _i--) X[_i] = 1.0/X[_i];
- }
- else {
- if ( !Y_dm ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofMatrix(): Output matrix must be memory-allocated (but no need for legal values)");
- if ( ((nrows=X_dm->nrows) != Y_dm->nrows) || ((ncols=X_dm->ncols) != Y_dm->ncols) ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofMatrix(): Dimensions of both input and output matrices must be same");
- vdInv (nrows*ncols, X_dm->M, Y_dm->M);
- Y_dm->flag = M_GE;
- }
- #else //Default to my own routine.
- if ( Y_dm == X_dm ) {
- X = X_dm->M;
- for (_i=X_dm->nrows*X_dm->ncols-1; _i>=0; _i--) X[_i] = 1.0/X[_i];
- }
- else {
- if ( !Y_dm ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofMatrix(): Output matrix must be memory-allocated (but no need for legal values)");
- if ( ((nrows=X_dm->nrows) != Y_dm->nrows) || ((ncols=X_dm->ncols) != Y_dm->ncols) ) fn_DisplayError(".../mathlib.c/ElementwiseInverseofMatrix(): Dimensions of both input and output matrices must be same");
- X = X_dm->M;
- Y = Y_dm->M;
- for (_i=nrows*ncols-1; _i>=0; _i--) Y[_i] = 1.0/X[_i];
- Y_dm->flag = M_GE;
- }
- #endif
-}
-
-
-
-//=======================================================
-// Matrix routines (my own).
-//=======================================================
-void tz_VectorPlusMinusVector(TSdvector *x_dv, const TSdvector *a_dv, const double _alpha, const TSdvector *b_dv, const double _beta)
-{
- //Output: x_dv = alpha*a_dv + beta*b_dv where x_dv is _n-by-1.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // _alpha: double constant.
- // b_dv: _n-by-1 double vector.
- // _beta: double constant.
- int _i, _n;
- double *x, *a, *b;
-
-
- if ( !x_dv || !a_dv || !b_dv) fn_DisplayError("mathlib.c/tz_VectorPlusMinusVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError("mathlib.c/tz_VectorPlusMinusVector(): R input vectors must be given values");
- else {
- _n = x_dv->n;
- x = x_dv->v;
- a = a_dv->v;
- b = b_dv->v;
- }
- if ( (_n != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError("mathlib.c/tz_VectorPlusMinusVector(): Dimensions of all input vectors must be same");
- else {
- for (_i=_n-1; _i>=0; _i--) x[_i] = _alpha*a[_i] + _beta*b[_i];
- x_dv->flag = V_DEF;
- }
-}
-void VectorPlusVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv) {
- //Output: x_dv = a_dv + b_dv where x_dv is _n-by-1.
- // If x_dv = a_dv, a_dv will be replaced by x_dv.
- // If x_dv = b_dv, b_dv will be replaced by x_dv,
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- int _i, _n;
- double *x, *a, *b;
-
-
- if ( !x_dv || !a_dv || !b_dv) fn_DisplayError(".../mathlib.c/VectorPlusVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/VectorPlusVector(): R input vectors must be given values");
- else {
- _n = x_dv->n;
- x = x_dv->v;
- a = a_dv->v;
- b = b_dv->v;
- }
- if ( (_n != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError(".../mathlib.c/VectorPlusVector(): Dimensions of all input vectors must be same");
- else {
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i] + b[_i];
- x_dv->flag = V_DEF;
- }
-}
-void VectorMinusVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv)
-{
- //Output: x_dv = a_dv - b_dv where x_dv is _n-by-1.
- // If x_dv = a_dv, x_dv will be replaced by x_dv - b_dv.
- // If x_dv = b_dv, x_dv will be replaced by a_dv - x_dv.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- int _i, _n;
- double *x, *a, *b;
-
-
- if ( !x_dv || !a_dv || !b_dv) fn_DisplayError(".../mathlib.c/VectorMinusVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/VectorMinusVector(): R input vectors must be given values");
- else {
- x = x_dv->v;
- a = a_dv->v;
- b = b_dv->v;
- }
- if ( ((_n = x_dv->n) != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError(".../mathlib.c/VectorMinusVector(): Dimensions of all input vectors must be same");
- else {
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i] - b[_i];
- x_dv->flag = V_DEF;
- }
-}
-
-
-void VectorPlusVectorUpdate(TSdvector *x_dv, const TSdvector *b_dv) {
- //Output: x_dv = b_dv + x_dv where x_dv is _n-by-1.
- //Inputs:
- // b_dv: _n-by-1 double vector.
- int _n, _i;
- double *x, *b;
-
-
- if ( !x_dv || !b_dv ) fn_DisplayError(".../mathlib.c/VectorPlusVectorUpdate(): All input vectors must be created (memory-allocated)");
- if ( !b_dv->flag || !x_dv->flag ) fn_DisplayError(".../mathlib.c/VectorPlusVectorUpdate(): All input vectors must be given values");
- if ( (_n=x_dv->n) != b_dv->n ) fn_DisplayError(".../mathlib.c/VectorPlusVectorUpdate(): Dimensions of all input vectors must be same");
-
- x = x_dv->v;
- b = b_dv->v;
- for (_i=_n-1; _i>=0; _i--) x[_i] += b[_i];
-}
-
-
-void VectorDotTimesVector(TSdvector *x_dv, const TSdvector *a_dv, TSdvector *b_dv, const double _alpha, const double _beta) {
- //Output:
- // x_dv is _n-by-1.
- // x_dv = _alpha * a_dv .* b_dv + _beta * x_dv if x_dv != b_dv.
- // x_dv = _alpha * a_dv .* x_dv + _beta * x_dv if x_dv = b_dv.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- // _alpha: double scalar.
- // _beta: a double scalar.
- int _i, _n;
- double *x, *a, *b;
-
-
- if ( !x_dv || !a_dv || !b_dv) fn_DisplayError(".../mathlib.c/VectorDotTimesVector(): All input vectors must be created (memory-allocated)");
- else if ( !a_dv->flag || !b_dv->flag ) fn_DisplayError(".../mathlib.c/VectorDotTimesVector(): Both R input vectors must be given values");
- else {
- _n = x_dv->n;
- x = x_dv->v;
- a = a_dv->v;
- b = b_dv->v;
- }
- if ( (_n != a_dv->n) || (_n != b_dv->n) ) fn_DisplayError(".../mathlib.c/VectorDotTimesVector(): Dimensions of all input vectors must be same");
-
-
- if ( _alpha==1.0 ) {
- if ( _beta==0.0 ) {
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i] * b[_i];
- if (!x_dv->flag) x_dv->flag = V_DEF;
- }
- else if ( _beta==1.0 ) {
- for (_i=_n-1; _i>=0; _i--) x[_i] += a[_i] * b[_i];
- if (!x_dv->flag) x_dv->flag = V_DEF;
- }
- else {
- for (_i=_n-1; _i>=0; _i--) x[_i] = a[_i] * b[_i] + _beta * x[_i];
- if (!x_dv->flag) x_dv->flag = V_DEF;
- }
- }
- else {
- if ( _beta==0.0 ) {
- for (_i=_n-1; _i>=0; _i--) x[_i] = _alpha * a[_i] * b[_i];
- if (!x_dv->flag) x_dv->flag = V_DEF;
- }
- else if ( _beta==1.0 ) {
- for (_i=_n-1; _i>=0; _i--) x[_i] += _alpha * a[_i] * b[_i];
- if (!x_dv->flag) x_dv->flag = V_DEF;
- }
- else {
- for (_i=_n-1; _i>=0; _i--) x[_i] = _alpha * a[_i] * b[_i] + _beta * x[_i];
- if (!x_dv->flag) x_dv->flag = V_DEF;
- }
- }
-}
-
-void SwapColsofMatrix(TSdmatrix *X_dm, int j1, int j2)
-{
- //??????? NOT tested yet.
- //Ouputs:
- // The j1_th column of X_dm is swapped with the j2_th column of X_dm.
- //Inputs:
- // X_dm: Memory allocated and legal values given already.
- // j1: The j1_th column of X_dm.
- // j2: The j2_th column of X_dm.
-
- int nrows;
- double *M1, *M2;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): (1) Input matrix X must be created (memory-allocated); (2) Legal values must be given");
- if (j1 >= X_dm->ncols) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): The j1_th column specified for the input matrix X exceeds its column dimension");
- if (j2 >= X_dm->ncols) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): The j2_th column specified for the input matrix X exceeds its column dimension");
- if (j1 == j2) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): The two columns for swapping must be different");
-
- #if defined( INTELCMATHLIBRARY )
- M1 = X_dm->M + j1*(nrows=X_dm->nrows); //Points to the beginning of the j1_th column.
- M2 = X_dm->M + j2*nrows; //Points to the beginning of the j2_th column.
- cblas_dswap(nrows, M1, 1, M2, 1);
- #else
- fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): Haven't got time to write my own for-loop routine to swap two columns");
- #endif
-}
-void SwapColsofMatrices(TSdmatrix *X1_dm, int j1, TSdmatrix *X2_dm, int j2)
-{
- //Ouputs:
- // The j1_th column of X1_dm is swapped with the j2_th column of X2_dm.
- //Inputs:
- // X1_dm: Memory allocated and legal values given already.
- // X2_dm: Memory allocated and legal values given already.
- // j1: The j1_th column of X1_dm.
- // j2: The j2_th column of X2_dm.
-
- int nrows;
- double *M1, *M2;
-
- if ( !X1_dm || !X1_dm->flag ) fn_DisplayError(".../mathlib.c/SwapColsofMatrices(): (1) Input matrix X1 must be created (memory-allocated); (2) Legal values must be given");
- if ( !X2_dm || !X2_dm->flag ) fn_DisplayError(".../mathlib.c/SwapColsofMatrices(): (1) Input matrix X2 must be created (memory-allocated); (2) Legal values must be given");
- if ( X1_dm == X2_dm ) fn_DisplayError(".../mathlib.c/SwapColsofMatrices(): The two input matrices must be different");
- if (j1 >= X1_dm->ncols) fn_DisplayError(".../mathlib.c/SwapColsofMatrices(): The jth column specified for the input matrix X1 exceeds its column dimension");
- if (j2 >= X2_dm->ncols) fn_DisplayError(".../mathlib.c/SwapColsofMatrices(): The jth column specified for the input matrix X1 exceeds its column dimension");
- if ( (nrows=X1_dm->nrows) != X2_dm->nrows ) fn_DisplayError(".../mathlib.c/SwapColsofMatrices(): The number of rows for both input matrices must be the same");
-
-
- #if defined (INTELCMATHLIBRARY)
- M1 = X1_dm->M + j1*nrows; //Points to the beginning of the j1_th column.
- M2 = X2_dm->M + j2*nrows; //Points to the beginning of the j2_th column.
- cblas_dswap(nrows, M1, 1, M2, 1);
- #else
- fn_DisplayError(".../mathlib.c/SwapColsofMatrices(): Haven't got time to write my own for-loop routine to swap two columns");
- #endif
-}
-void SwapPositionsofMatrix(TSdmatrix *X_dm, int j1, int j2) {
- //Ouputs:
- // Column operation: first, the j1_th column of X_dm is swapped with the j2_th column of X_dm.
- // Row operation: second, the j1_th row of X_dm is swapped with the j2_th row of X_dm.
- //Inputs:
- // X_dm: Memory allocated and legal values given already.
- // j1: The j1_th column and row of X_dm.
- // j2: The j2_th column and row of X_dm.
-
- int nrows, ncols;
- double *M1, *M2;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): (1) Input matrix X must be created (memory-allocated); (2) Legal values must be given");
- if (j1 >= (ncols=X_dm->ncols) || j1 >= (nrows=X_dm->nrows) ) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): The j1_th column or row specified for the input matrix X exceeds its column or row dimension");
- if (j2 >= X_dm->ncols || j2 >= X_dm->ncols ) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): The j2_th column or row specified for the input matrix X exceeds its column or row dimension");
- if (j1 == j2) fn_DisplayError(".../mathlib.c/SwapColsofMatrix(): The two columns for swapping must be different");
-
- #if defined( INTELCMATHLIBRARY )
- M1 = X_dm->M + j1*nrows; //Points to the beginning of the j1_th column.
- M2 = X_dm->M + j2*nrows; //Points to the beginning of the j2_th column.
- cblas_dswap(nrows, M1, 1, M2, 1); //Swaps columns.
- //
- M1 = X_dm->M + j1; //Points to the beginning of the j1_th row.
- M2 = X_dm->M + j2; //Points to the beginning of the j2_th row.
- cblas_dswap(ncols, M1, nrows, M2, nrows); //Swaps corresponding rows.
- #else
- fn_DisplayError(".../mathlib.c/SwapPositionsofMatrix(): Haven't got time to write my own for-loop routine to swap two columns and then two corresponding rows");
- #endif
-}
-
-void SwapMatricesofCell(TSdcell *A_dc, int c1, int c2)
-{
- //Ouputs:
- // A_dc->C[c1] and A_dc->C[c2] are swapped.
- //Inputs:
- // A_dc: Memory allocated and legal values given already.
- // c1, c2: Positions of cells.
-
- int _n;
- TSdmatrix *tpnter2dm = NULL;
-
- if ( !A_dc ) fn_DisplayError(".../mathlib.c/SwapMatricesofCell(): Input cell A_dc must be created (memory-allocated)");
- _n = A_dc->ncells;
- if ( (c1>=_n) || (c1<0) || (c2>=_n) || (c2<0) ) fn_DisplayError(".../mathlib.c/SwapMatricesofCell(): c1 and c2 must be between 0 and A_dc->ncells inclusive");
-
- tpnter2dm = A_dc->C[c1];
- A_dc->C[c1] = A_dc->C[c2];
- A_dc->C[c2] = tpnter2dm;
-}
-
-void SwapVectorsofCellvec(TSdcellvec *x_dcv, int c1, int c2)
-{
- //Ouputs:
- // x_dcv->C[c1] and x_dcv->C[2] are swapped.
- //Inputs:
- // x_dcv: Memory allocated and legal values given already.
- // c1, c2: Positions of cells.
-
- int _n;
- TSdvector *tpnter2dv = NULL;
-
- if ( !x_dcv ) fn_DisplayError(".../mathlib.c/SwapVectorsofCellvec(): Input cell vector x_dcv must be created (memory-allocated)");
- _n = x_dcv->ncells;
- if ( (c1>=_n) || (c1<0) || (c2>=_n) || (c2<0) ) fn_DisplayError(".../mathlib.c/SwapVectorsofCellvec(): c1 and c2 must be between 0 and x_dcv->ncells inclusive");
-
- tpnter2dv = x_dcv->C[c1];
- x_dcv->C[c1] = x_dcv->C[c2];
- x_dcv->C[c2] = tpnter2dv;
-}
-//--
-void SwapVectorsofCellvec_int(TSicellvec *x_icv, int c1, int c2)
-{
- //Ouputs:
- // x_icv->C[c1] and x_icv->C[2] are swapped.
- //Inputs:
- // x_icv: Memory allocated and legal values given already.
- // c1, c2: Positions of cells.
-
- int _n;
- TSivector *tpnter2iv = NULL;
-
- if ( !x_icv ) fn_DisplayError(".../mathlib.c/SwapVectorsofCellvec_int(): Input cell vector x_icv must be created (memory-allocated)");
- _n = x_icv->ncells;
- if ( (c1>=_n) || (c1<0) || (c2>=_n) || (c2<0) ) fn_DisplayError(".../mathlib.c/SwapVectorsofCellvec_int(): c1 and c2 must be between 0 and x_icv->ncells inclusive");
-
- tpnter2iv = x_icv->C[c1];
- x_icv->C[c1] = x_icv->C[c2];
- x_icv->C[c2] = tpnter2iv;
-}
-
-
-//=== The following is NOT efficient.
-//#if defined( INTELCMATHLIBRARY )
-//void SwapMatricesofCell(TSdcell *X_dc, int c1, int c2)
-//{
-// //??????? NOT tested yet.
-// //Ouputs:
-// // The c1_th matrix of X_dc is swapped with the c2_th matrix of X_dc.
-// //Inputs:
-// // X_dc: Memory allocated and legal values given already.
-// // c1: The c1_th matrix of X_dc.
-// // c2: The c2_th matrix of X_dc.
-
-// int dim;
-
-
-// if ( !X_dc ) fn_DisplayError(".../mathlib.c/SwapMatricesofCell(): input cell X_dc must be created (memory-allocated)");
-// if ( c1 >= X_dc->ncells || c2 >= X_dc->ncells ) fn_DisplayError(".../mathlib.c/SwapMatricesofCell(): the c1_th or c2_th cell exceeds the cell dimension");
-// if ( c1 == c2 ) fn_DisplayError(".../mathlib.c/MatricesofCell(): the two matrices for swapping must be different");
-// if ( !X_dc->C[c1]->flag || !X_dc->C[c2]->flag ) fn_DisplayError(".../mathlib.c/MatricesofCell(): both matrices for swapping must have legal values");
-// if ( (dim=X_dc->C[c1]->nrows*X_dc->C[c1]->ncols) != (X_dc->C[c2]->nrows*X_dc->C[c2]->ncols) )
-// fn_DisplayError(".../mathlib.c/MatricesofCell(): the two matrices for swapping must have the same dimension");
-
-
-// cblas_dswap(dim, X_dc->C[c1]->M, 1, X_dc->C[c2]->M, 1);
-//}
-//#else
-////.../mathlib.c/SwapColsofMatrix(): Haven't got time to write my own for-loop routine to swap two columns. 19 Oct. 03
-//#endif
-
-
-//=== Do NOT know what the following is. 20 Oct. 03.
-//void SwapPositionsofCell(TSdcell *X_dc, const int c1, const int c2)
-//{
-// //???? Not tested yet.
-// int dim;
-
-
-// if ( !X_dc ) fn_DisplayError(".../mathlib.c/SwapMatricesofCell(): input cell A_dc must be created (memory-allocated)");
-// if ( c1 >= X_dc->ncells || c2 >= X_dc->ncells ) fn_DisplayError(".../mathlib.c/SwapMatricesofCell(): the c1_th or c2_th cell exceeds the cell dimension");
-// if ( c1 == c2 ) fn_DisplayError(".../mathlib.c/MatricesofCell(): the two matrices for swapping must be different");
-// if ( !X_dc->C[c1]->flag || !X_dc->C[c2]->flag ) fn_DisplayError(".../mathlib.c/MatricesofCell(): both matrices for swapping must have legal values");
-// if ( (dim=X_dc->C[c1]->nrows*X_dc->C[c1]->ncols) != (X_dc->C[c2]->nrows*X_dc->C[c2]->ncols) )
-// fn_DisplayError(".../mathlib.c/MatricesofCell(): the two matrices for swapping must have the same dimension");
-
-
-// cblas_dswap(dim, X_dc->C[c1]->M, 1, X_dc->C[c2]->M, 1);
-//}
-
-
-void PermuteColsofMatrix(TSdmatrix *A_dm, const TSivector *indx_iv)
-{
- //Ouputs:
- // A_dm (m-by-n) is replaced by permuted columns only, according to indx_iv.
- //Inputs:
- // A_dm (m-by-n): Memory allocated and legal values given already.
- // indx_iv (n-by-1): index for columns and rows of A_dm to exchanged simultaneously. Example: indx_-v->v = {2 0 1} (base 0) for the 3-by-3 matrix
- // means that original column 2 is column 0, original column 0 is column 1, etc.
-
- double *B_pd = NULL,
- *A;
- int _j, _n, _m, mn,
- *indx;
-
- if ( !A_dm || !A_dm->flag ) fn_DisplayError(".../mathlib.c/PermuteColsofMatrix(): input matrix A_dm must (1) be created (memory allocated) and (2) have legal values");
- if ( !indx_iv->flag || (_n=A_dm->ncols) != indx_iv->n ) fn_DisplayError(".../mathlib.c/PermuteColsofMatrix(): (1) sorted index vector, indx_iv, must have legal values; (2) its length must match the number of columns of the input matrix A_dm");
-
-
- //=== Memory allocated for this function.
- B_pd = tzMalloc(mn=_n*(_m=A_dm->nrows), double);
-
- indx = indx_iv->v;
- memcpy(B_pd, A = A_dm->M, mn*sizeof(double));
- for (_j=_n-1; _j>=0; _j--)
- memcpy(A+_j*_m, B_pd+indx[_j]*_m, _m*sizeof(double));
-
- //=== Destroys memory allocated for this function.
- tzDestroy(B_pd);
-}
-
-void PermuteRowsofMatrix(TSdmatrix *A_dm, const TSivector *indx_iv)
-{
- //Ouputs:
- // A_dm (n-by-m) is replaced by permuted rows only, according to indx_iv.
- //Inputs:
- // A_dm (n-by-m): Memory allocated and legal values given already.
- // indx_iv (n-by-1): index for columns and rows of A_dm to exchanged simultaneously. Example: indx_-v->v = {2 0 1} (base 0) for the 3-by-3 matrix
- // means that original column 2 is column 0, original column 0 is column 1, etc.
-
- double *B_pd = NULL,
- *A;
- int _i, _n, _m, mn,
- *indx;
- #if !defined( INTELCMATHLIBRARY )
- int _j;
- #endif
-
- if ( !A_dm || !A_dm->flag ) fn_DisplayError(".../mathlib.c/PermuteRowsMatrix(): input matrix A_dm must (1) be created (memory allocated) and (2) have legal values");
- if ( !indx_iv->flag || (_n=A_dm->nrows) != indx_iv->n ) fn_DisplayError(".../mathlib.c/PermuteRowsMatrix(): (1) indx_iv must have legal values; (2) number of rows in A_dm must match the length of indx_iv");
-
-
- //=== Memory allocated for this function.
- B_pd = tzMalloc(mn=_n*(_m=A_dm->ncols), double);
-
- indx = indx_iv->v;
- memcpy(B_pd, A = A_dm->M, mn*sizeof(double));
- #if defined( INTELCMATHLIBRARY )
- for (_i=_n-1; _i>=0; _i--)
- cblas_dcopy(_m, B_pd+indx[_i], _n, A+_i, _n);
- #else //Default to my own routine.
- _m = A_dm->ncols;
- for (_j=_m-1; _j>=0; _j--)
- for (_i=_n-1; _i>=0; _i--)
- A[mos(_i, _j, _n)] = B_pd[mos(indx[_i], _j, _n)];
- #endif
-
- //=== Destroys memory allocated for this function.
- tzDestroy(B_pd);
-}
-
-void PermuteMatrix(TSdmatrix *A_dm, const TSivector *indx_iv)
-{
- //Ouputs:
- // A_dm (n-by-n) is replaced by permuted columns and rows simultaneously. The permutation is dicated by indx_iv.
- //Inputs:
- // A_dm (n-by-n): Memory allocated and legal values given already.
- // indx_iv (n-by-1): index for columns and rows of A_dm to exchanged simultaneously. Example: indx_-v->v = {2 0 1} (base 0) for the 3-by-3 matrix
- // means that original column 2 and row 2 are column 0 and row 0, original column 0 and row 0 are column 1 and row 1, etc.
-
- double *B_pd = NULL,
- *A;
- int _i, _j, _n, n2,
- *indx;
-
- if ( !A_dm || !A_dm->flag ) fn_DisplayError(".../mathlib.c/PermuteMatrix(): input matrix A_dm must (1) be created (memory allocated) and (2) have legal values");
- if ( !indx_iv->flag || (_n=A_dm->nrows) != A_dm->ncols || _n != indx_iv->n ) fn_DisplayError(".../mathlib.c/PermuteMatrix(): (1) indx_iv must have legal values; (2) input matrix A_dm must be square; (3) it dimension must coincide with the length of indx_iv");
-
-
- //=== Memory allocated for this function.
- B_pd = tzMalloc(n2=_n*_n, double);
-
- indx = indx_iv->v;
- memcpy(B_pd, A = A_dm->M, n2*sizeof(double));
- for (_j=_n-1; _j>=0; _j--)
- for (_i=_n-1; _i>=0; _i--)
- A[mos(_i, _j, _n)] = B_pd[mos(indx[_i], indx[_j], _n)];
-
-
- //=== Destroys memory allocated for this function.
- tzDestroy(B_pd);
-}
-//=== The following works but may be less efficient and definitely hard to understand.
-// void PermuteMatrix(TSdmatrix *A_dm, const TSivector *indx_iv)
-// {
-// //Ouputs:
-// // A_dm is replaced by permuted columns and rows simultaneously. The permutation is dicated by indx_iv.
-// //Inputs:
-// // A_dm: Memory allocated and legal values given already.
-// // indx_iv: index for columns and rows of A_dm to exchanged simultaneously. Example: indx_-v->v = {2 0 1} (base 0) for the 3-by-3 matrix
-// // means that original column 2 and row 2 are column 0 and row 0, original column 0 and row 0 are column 1 and row 1, etc.
-//
-// double *B_pd = NULL,
-// *A;
-// int _i, _n, n2,
-// *indx;
-//
-// if ( !A_dm || !A_dm->flag ) fn_DisplayError(".../mathlib.c/PermuteMatrix(): input matrix A_dm must (1) be created (memory allocated) and (2) have legal values");
-// if ( (_n=A_dm->nrows) != A_dm->ncols || _n != indx_iv->n ) fn_DisplayError(".../mathlib.c/PermuteMatrix(): (1) input matrix A_dm must be square; (2) it dimension must coincide with the length of indx_iv");
-//
-//
-// //=== Memory allocated for this function.
-// B_pd = tzMalloc(n2=_n*_n, double);
-//
-// indx = indx_iv->v;
-// memcpy(B_pd, A = A_dm->M, n2*sizeof(double));
-// for (_i=0; _i<n2; _i++) A[_i] = B_pd[indx[_i%_n]+indx[_i/_n]*_n];
-//
-// //=== Destroys memory allocated for this function.
-// tzDestroy(B_pd);
-// }
-
-
-void PermuteMatricesofCell(TSdcell *A_dc, const TSivector *indx_iv)
-{
- //Ouputs:
- // A_dc is replaced by permuted matrices. The permutation is dicated by indx_iv.
- //Inputs:
- // A_dc: Memory allocated and legal values given already.
- // indx_iv: index for matrices of A_dc to exchanged simultaneously. Example: indx_-v->v = {2 0 1} (base 0) for the 3-by-1 cell
- // means that original matrix 2 is matrix 0, original matrix 0 is matrix 1, etc.
-
- int _i, _n,
- *indx_p;
- TSdmatrix **tA_p2dm = NULL;
-
- if ( !A_dc || !indx_iv || !indx_iv->flag ) fn_DisplayError(".../mathlib.c/PermuteMatricesofCell(): (1) input cell A_dc must be created (memory-allocated); (2) index vector indx_iv must be created and have legal values");
- if ( (_n=A_dc->ncells) != indx_iv->n ) fn_DisplayError(".../mathlib.c/PermuteMatricesofCell(): number of cells must match the length of indx_iv");
- indx_p = indx_iv->v;
-
-
- //=== Memory allocated for this function.
- tA_p2dm = tzMalloc(_n, TSdmatrix *);
-
- for (_i=_n-1; _i>=0; _i--) tA_p2dm[_i] = A_dc->C[indx_p[_i]];
- //=== This one is less efficient than the following: for (_i=_n-1; _i>=0; _i--) A_dc->C[_i] = tA_p2dm[_i];
- memcpy(A_dc->C, tA_p2dm, _n*sizeof(TSdmatrix *));
-
- //=== Destroys memory allocated for this function.
- tzDestroy(tA_p2dm);
-}
-
-
-void ScalarTimesColofMatrix(TSdvector *y_dv, double _alpha, TSdmatrix *X_dm, int _j)
-{
- //????????? Default option, in the #else, has NOT been tested yet!
- //Ouputs:
- // If y_dv!=NULL, y_dv is the jth column of X_dm is multiplied by _alpha.
- // If !y_dv, the jth column of X_dm is replaced by the new value, which will be multiplied by _alpha.
- //Inputs:
- // _alpha: Scalar.
- // X_dm: Memory allocated and legal values given already.
- // _j: The jth column of X_dm.
-
- #if !defined( INTELCMATHLIBRARY )
- int _i;
- #endif
- int nrows;
- double *M, *v;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix(): (1) Input matrix must be created (memory-allocated); (2) Legal values must be given");
- if (_j >= X_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix(): The jth column specified for the input matrix exceeds the column dimension");
-
- #if defined( INTELCMATHLIBRARY )
- M = X_dm->M + _j*(nrows=X_dm->nrows); //Points to the beginning of the jth column.
- if (!y_dv) cblas_dscal(nrows, _alpha, M, 1);
- else {
- memcpy(v=y_dv->v, M, nrows*sizeof(double));
- cblas_dscal(nrows, _alpha, v, 1);
- y_dv->flag = V_DEF;
- }
- #else
- Need to be tested for the following.
- //
- // M = X_dm->M + (_j+1)*(nrows=X_dm->nrows) - 1; //Points to the end of the jth column.
- // if (!y_dv)
- // for (_i=nrows-1; _i>=0; _i--, M--) *M = _alpha * (*M);
- // else {
- // v = y_dv->v;
- // for (_i=nrows-1; _i>=0; _i--, M--) v[_i] = _alpha * (*M);
- // y_dv->flag = V_DEF;
- // }
- #endif
-}
-void ScalarTimesColofMatrix2ColofMatrix(TSdmatrix *Y_dm, int jy, double _alpha, TSdmatrix *X_dm, int jx)
-{
- //Ouputs:
- // If Y_dm!=NULL, the jy_th column of Y_dm is the jx_th column of X_dm multiplied by _alpha.
- // If !Y_dm, the jx_th column of X_dm is replaced by the new value, which will be multiplied by _alpha.
- //Inputs:
- // _alpha: Scalar.
- // X_dm: Memory allocated and legal values given already.
- // jy: The jy_th column of Y_dm.
- // yx: The jx_th column of X_dm.
-
- #if !defined( INTELCMATHLIBRARY )
- int _i;
- #endif
- int nrows_x;
- double *Mx, *My;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): (1) Input matrix must be created (memory-allocated); (2) Legal values must be given");
- if (jx >= X_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The jth column specified for the input matrix exceeds the column dimension");
-
- #if defined( INTELCMATHLIBRARY )
- Mx = X_dm->M + jx*(nrows_x=X_dm->nrows); //Points to the beginning of the jth column.
- if (!Y_dm) cblas_dscal(nrows_x, _alpha, Mx, 1);
- else {
- if (jy >= Y_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The jth column specified for the output matrix exceeds the column dimension");
- if ( nrows_x != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The number of rows for both input and output matrices must be the same");
-
- My = Y_dm->M + jy*nrows_x; //Points to the beginning of the jth column.
- memcpy(My, Mx, nrows_x*sizeof(double));
- cblas_dscal(nrows_x, _alpha, My, 1);
- }
- #else
- Mx = X_dm->M + (jx+1)*(nrows_x=X_dm->nrows) - 1; //Points to the end of the jth column.
- if (!Y_dm)
- for (_i=nrows_x-1; _i>=0; _i--, Mx--) *Mx = _alpha * (*Mx);
- else {
- if (jy >= Y_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The jth column specified for the output matrix exceeds the column dimension");
- if ( nrows_x != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The number of rows for both input and output matrices must be the same");
-
- My = Y_dm->M + (jy+1)*nrows_x - 1; //Points to the end of the jth column.
- for (_i=nrows_x-1; _i>=0; _i--, Mx--, My--) *My = _alpha * (*Mx);
- }
- #endif
-}
-
-
-void ScalarTimesColofMatrixPlusVector2ColofMatrix(TSdmatrix *Y_dm, int jy, double _alpha, TSdmatrix *X_dm, int jx, double _beta, TSdvector *x_dv) {
- //Ouputs:
- // If Y_dm!=NULL, Y(:,jy) = alpha*X(:,jx) + beta*x.
- // If !Y_dm, X(:,jx) = alpha*X(:,jx) + beta*x.
- //Inputs:
- // _alpha: Scalar.
- // _beta: Scalar.
- // X_dm: Memory allocated and legal values given already.
- // jy: The jy_th column of Y_dm.
- // yx: The jx_th column of X_dm.
-
- int _i, nrows_x;
- double *Mx, *My, *v;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrixPlusVector2ColofMatrix(): (1) Input matrix must be created (memory-allocated); (2) Legal values must be given");
- if (jx >= X_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrixPlusVector2ColofMatrix(): The jth column specified for the input matrix exceeds the column dimension");
- if ( !x_dv || !x_dv->flag ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrixPlusVector2ColofMatrix(): (1) input vectr must be created (memory-allocated); (2) legal values must be given");
-
- if (_beta == 0.0) {
- #if defined( INTELCMATHLIBRARY )
- Mx = X_dm->M + jx*(nrows_x=X_dm->nrows); //Points to the beginning of the jth column.
- if (!Y_dm) cblas_dscal(nrows_x, _alpha, Mx, 1);
- else {
- if (jy >= Y_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The jth column specified for the output matrix exceeds the column dimension");
- if ( nrows_x != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The number of rows for both input and output matrices must be the same");
-
- My = Y_dm->M + jy*nrows_x; //Points to the beginning of the jth column.
- memcpy(My, Mx, nrows_x*sizeof(double));
- cblas_dscal(nrows_x, _alpha, My, 1);
- }
- #else
- Mx = X_dm->M + (jx+1)*(nrows_x=X_dm->nrows) - 1; //Points to the end of the jth column.
- if (!Y_dm)
- for (_i=nrows_x-1; _i>=0; _i--, Mx--) *Mx = _alpha * (*Mx);
- else {
- if (jy >= Y_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The jth column specified for the output matrix exceeds the column dimension");
- if ( nrows_x != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrix2ColofMatrix(): The number of rows for both input and output matrices must be the same");
-
- My = Y_dm->M + (jy+1)*nrows_x - 1; //Points to the end of the jth column.
- for (_i=nrows_x-1; _i>=0; _i--, Mx--, My--) *My = _alpha * (*Mx);
- }
- #endif
- }
- else {
- Mx = X_dm->M + (jx+1)*(nrows_x=X_dm->nrows) - 1; //Points to the end of the jth column.
- if ( nrows_x != x_dv->n ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrixPlusVector2ColofMatrix(): The length of the input vector must match the number of rows in the input matrix");
-
- if (!Y_dm) {
- if ( _alpha == 1.0 && _beta == 1.0 )
- for (_i=nrows_x-1, v=x_dv->v+_i; _i>=0; _i--, Mx--, v--) *Mx = *Mx + *v;
- else if ( _alpha == 1.0 )
- for (_i=nrows_x-1, v=x_dv->v+_i; _i>=0; _i--, Mx--, v--) *Mx = _alpha * (*Mx) + *v;
- else
- for (_i=nrows_x-1, v=x_dv->v+_i; _i>=0; _i--, Mx--, v--) *Mx = _alpha * (*Mx) + _beta * (*v);
- }
- else {
- if (jy >= Y_dm->ncols) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrixPlusVector2ColofMatrix(): The jth column specified for the output matrix exceeds the column dimension");
- if ( nrows_x != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ScalarTimesColofMatrixPlusVector2ColofMatrix(): The number of rows for both input and output matrices must be the same");
-
- My = Y_dm->M + (jy+1)*nrows_x - 1; //Points to the end of the jth column.
- if ( _alpha == 1.0 && _beta == 1.0 )
- for (_i=nrows_x-1, v=x_dv->v+_i; _i>=0; _i--, Mx--, My--, v--) *My = *Mx + *v;
- else if ( _alpha == 1.0 )
- for (_i=nrows_x-1, v=x_dv->v+_i; _i>=0; _i--, Mx--, My--, v--) *My = _alpha * (*Mx) + *v;
- else
- for (_i=nrows_x-1, v=x_dv->v+_i; _i>=0; _i--, Mx--, My--, v--) *My = _alpha * (*Mx) + _beta * (*v);
- }
- }
-}
-
-
-void MatrixDotDivideVector_row(TSdmatrix *Y_dm, TSdmatrix *X_dm, TSdvector *x_dv, double _alpha, double _beta)
-{
- //Outputs:
- // If (Y_dm != X_dm), Y_dm(ix, :) = _alpha * X_dm(ix, :) ./ x_dv + _beta * X_dm(ix, :), for all ix.
- // If (Y_dm = X_dm), X_dm(ix, :) = _alpha * X_dm(ix, :) ./ x_dv + _beta * X_dm(ix, :), for all ix.
- //Inputs:
- // _alpha: double scalar.
- // _beta: double scalar.
-
- int _i, cnt, ncols_x, nrows_x, nrows_xm1, ix;
- double *X, *x, *Y, xinv;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixDotDivideVector(): (1) Input matrix must be created (memory-allocated); (2) Legal values must be given");
- if ( !x_dv || !x_dv->flag ) fn_DisplayError(".../mathlib.c/MatrixDotDivideVector(): (1) Input vector must be created (memory-allocated); (2) Legal values must be given");
- if ( (ncols_x=X_dm->ncols) != x_dv->n ) fn_DisplayError(".../mathlib.c/MatrixDotDivideVector(): Number of columns in the input matrix must match the length of the input vector");
- X = X_dm->M;
- x = x_dv->v;
- nrows_xm1 = (nrows_x=X_dm->nrows)-1;
-
-
- if ( _beta==0.0 ) {
- if ( Y_dm == X_dm ) {
- for (ix=nrows_x*ncols_x-1, cnt=ncols_x-1; ix>=nrows_xm1; ix -= nrows_x, cnt--) {
- //Last row of X_dm
- xinv = _alpha/x[cnt];
- for (_i=ix-nrows_x+1; _i<=ix; _i++) X[_i] *= xinv; //Must _i<=ix, not _i<ix. For each column at time.
- }
- }
- else {
- Y = Y_dm->M;
- if ( ncols_x != Y_dm->ncols || nrows_x != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/MatrixDotDivideVector(): Dimension of output matrix Y_dm must be the same as that of input matrix X_dm");
- for (ix=nrows_x*ncols_x-1, cnt=ncols_x-1; ix>=nrows_xm1; ix -= nrows_x, cnt--) {
- //Last row of X_dm
- xinv = _alpha/x[cnt];
- for (_i=ix-nrows_x+1, cnt=0; _i<=ix; _i++, cnt++) Y[_i] = X[_i] * xinv; //Must _i<=ix, not _i<ix. For each column at time.
- }
- Y_dm->flag = M_GE;
- }
- }
- else {
- if ( Y_dm == X_dm ) {
- for (ix=nrows_x*ncols_x-1, cnt=ncols_x-1; ix>=nrows_xm1; ix -= nrows_x, cnt--) {
- //Last row of X_dm
- xinv = _alpha/x[cnt] + _beta;
- for (_i=ix-nrows_x+1; _i<=ix; _i++) X[_i] *= xinv; //Must _i<=ix, not _i<ix. For each column at time.
- }
- }
- else {
- Y = Y_dm->M;
- if ( ncols_x != Y_dm->ncols || nrows_x != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/MatrixDotDivideVector(): Dimension of output matrix Y_dm must be the same as that of input matrix X_dm");
- for (ix=nrows_x*ncols_x-1, cnt=ncols_x-1; ix>=nrows_xm1; ix -= nrows_x, cnt--) {
- //Last row of X_dm
- xinv = _alpha/x[cnt] + _beta;
- for (_i=ix-nrows_x+1, cnt=0; _i<=ix; _i++, cnt++) Y[_i] = X[_i] * xinv; //Must _i<=ix, not _i<ix. For each column at time.
- }
- Y_dm->flag = M_GE;
- }
- }
-}
-
-
-void RowofMatrixDotDivideVector(TSdvector *y_dv, TSdmatrix *X_dm, int ix, TSdvector *x_dv, double _alpha, double _beta)
-{
- //??????? NOT tested yet, 01/02/04.
- //Outputs:
- // If (y_dv), y_dv = _alpha * X_dm(ix, :) ./ x_dv + _beta * X_dm(ix, :).
- // If (!y_dv), X_dm(ix, :) = _alpha * X_dm(ix, :) ./ x_dv + _beta * X_dm(ix, :).
- //Inputs:
- // _alpha: double scalar.
- // _beta: double scalar.
-
- int _i, cnt, ncols_x, nrows_x;
- double *X, *x, *y;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): (1) Input matrix must be created (memory-allocated); (2) Legal values must be given");
- if ( !x_dv || !x_dv->flag ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): (1) Input vector must be created (memory-allocated); (2) Legal values must be given");
- if ( (ncols_x=X_dm->ncols) != x_dv->n ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): Number of columns in the input matrix must match the length of the input vector");
- if ( ix >= (nrows_x=X_dm->nrows) ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): The specified ix_th row of the input matrix exceeds its row dimension");
- X = X_dm->M;
- x = x_dv->v;
-
-
- if ( _alpha==1.0 ) {
- if ( _beta==0.0 ) {
- if ( !y_dv )
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) X[_i] /= x[cnt];
- else {
- y = y_dv->v;
- if ( ncols_x != y_dv->n ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): Number of columns in the input matrix must match the length of the output vector");
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) y[cnt] = X[_i] / x[cnt];
- y_dv->flag = V_DEF;
- }
- }
-// else if ( _beta==1.0 ) {
-// if ( !y_dv )
-// for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) X[_i] *= ( 1.0 / x[cnt] + 1.0);
-// else {
-// y = y_dv->v;
-// if ( ncols_x != y_dv->n ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): Number of columns in the input matrix must match the length of the output vector");
-// for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) y[cnt] = X[_i] * ( 1.0 / x[cnt] + 1.0 );
-// y_dv->flag = V_DEF;
-// }
-// }
- else {
- if ( !y_dv )
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) X[_i] *= 1.0 / x[cnt] + _beta;
- else {
- y = y_dv->v;
- if ( ncols_x != y_dv->n ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): Number of columns in the input matrix must match the length of the output vector");
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) y[cnt] = X[_i] * ( 1.0 / x[cnt] + _beta );
- y_dv->flag = V_DEF;
- }
- }
- }
- else {
- if ( _beta==0.0 ) {
- if ( !y_dv )
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) X[_i] *= _alpha / x[cnt];
- else {
- y = y_dv->v;
- if ( ncols_x != y_dv->n ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): Number of columns in the input matrix must match the length of the output vector");
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) y[cnt] = (_alpha * X[_i]) / x[cnt];
- y_dv->flag = V_DEF;
- }
- }
-// else if ( _beta==1.0 ) {
-// if ( !y_dv )
-// for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) X[_i] *= _alpha / x[cnt] + 1.0;
-// else {
-// y = y_dv->v;
-// if ( ncols_x != y_dv->n ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): Number of columns in the input matrix must match the length of the output vector");
-// for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) y[cnt] = X[_i] * (_alpha / x[cnt] + 1.0);
-// y_dv->flag = V_DEF;
-// }
-// }
- else {
- if ( !y_dv )
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) X[_i] *= _alpha / x[cnt] + _beta;
- else {
- y = y_dv->v;
- if ( ncols_x != y_dv->n ) fn_DisplayError(".../mathlib.c/RowofMatrixDotDivideVector(): Number of columns in the input matrix must match the length of the output vector");
- for (_i=ix + (ncols_x-1)*nrows_x, cnt=ncols_x-1; _i>=ix; _i -= nrows_x, cnt--) y[cnt] = X[_i] * (_alpha / x[cnt] + _beta);
- y_dv->flag = V_DEF;
- }
- }
- }
-}
-
-void ColofMatrixDotTimesVector(TSdvector *y_dv, TSdmatrix *X_dm, int jx, TSdvector *x_dv, double _alpha, double _beta) {
- //Outputs:
- // If (y_dv), y_dv = _alpha * X_dm(:,jx) .* x_dv + _beta * X_dm(:,jx).
- // If (!y_dv), X_dm(:,jx) = _alpha * X_dm(:,jx) .* x_dv + _beta * X_dm(:,jx).
- //Inputs:
- // _alpha: double scalar.
- // _beta: double scalar.
-
- int _i, nrows_x;
- double *X, *x, *y;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): (1) Input matrix must be created (memory-allocated); (2) Legal values must be given");
- if ( !x_dv || !x_dv->flag ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): (1) Input vector must be created (memory-allocated); (2) Legal values must be given");
- if ( (nrows_x=X_dm->nrows) != x_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the input vector");
- if ( jx >= X_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jx_th column of the input matrix exceeds its column dimension");
-
-
- X = X_dm->M + (jx+1)*nrows_x - 1; //Points to the end of the jx_th column.
- x = x_dv->v + nrows_x - 1; //Points to the end of the vector.
- if ( _alpha==1.0 ) {
- if ( _beta==0.0 ) {
- if ( !y_dv )
- for (_i=nrows_x-1; _i>=0; _i--, X--, x--) *X = (*X) * (*x);
- else {
- if ( nrows_x != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows_x-1, y=y_dv->v+_i; _i>=0; _i--, X--, x--, y--) *y = (*X) * (*x);
- y_dv->flag = V_DEF;
- }
- }
- else if ( _beta==1.0 ) {
- if ( !y_dv )
- for (_i=nrows_x-1; _i>=0; _i--, X--, x--) *X = (*X) * (*x) + (*X);
- else {
- if ( nrows_x != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows_x-1, y=y_dv->v+_i; _i>=0; _i--, X--, x--, y--) *y = (*X) * (*x) + (*X);
- y_dv->flag = V_DEF;
- }
- }
- else {
- if ( !y_dv )
- for (_i=nrows_x-1; _i>=0; _i--, X--, x--) *X = (*X) * (*x) + _beta * (*X);
- else {
- if ( nrows_x != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows_x-1, y=y_dv->v+_i; _i>=0; _i--, X--, x--, y--) *y = (*X) * (*x) + _beta * (*X);
- y_dv->flag = V_DEF;
- }
- }
- }
- else {
- if ( _beta==0.0 ) {
- if ( !y_dv )
- for (_i=nrows_x-1; _i>=0; _i--, X--, x--) *X = _alpha * (*X) * (*x);
- else {
- if ( nrows_x != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows_x-1, y=y_dv->v+_i; _i>=0; _i--, X--, x--, y--) *y = _alpha * (*X) * (*x);
- y_dv->flag = V_DEF;
- }
- }
- else if ( _beta==1.0 ) {
- if ( !y_dv )
- for (_i=nrows_x-1; _i>=0; _i--, X--, x--) *X = _alpha * (*X) * (*x) + (*X);
- else {
- if ( nrows_x != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows_x-1, y=y_dv->v+_i; _i>=0; _i--, X--, x--, y--) *y = _alpha * (*X) * (*x) + (*X);
- y_dv->flag = V_DEF;
- }
- }
- else {
- if ( !y_dv )
- for (_i=nrows_x-1; _i>=0; _i--, X--, x--) *X = _alpha * (*X) * (*x) + _beta * (*X);
- else {
- if ( nrows_x != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows_x-1, y=y_dv->v+_i; _i>=0; _i--, X--, x--, y--) *y = _alpha * (*X) * (*x) + _beta * (*X);
- y_dv->flag = V_DEF;
- }
- }
- }
-}
-void ColofMatrixDotTimesColofMatrix(TSdvector *y_dv, TSdmatrix *X1_dm, int jx1, TSdmatrix *X2_dm, int jx2, double _alpha, double _beta) {
- //????????? NOT tested yet.
- //Outputs:
- // If y_dv!=NULL, y_dv = _alpha * X1_dm(:,jx1) .* X2_dm(:,jx2) + _beta * X1_dm(:,jx1).
- // If !y_dv, X1_dm(:,jx1) = _alpha * X1_dm(:,jx1) .* X2_dm(:,jx2) + _beta * X1_dm(:,jx2).
- //Inputs:
- // _alpha: double scalar.
- // _beta: double scalar.
-
- int _i, nrows1;
- double *X1, *X2, *y;
-
- if ( !X1_dm || !X1_dm->flag ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesColofMatrix(): (1) Input matrix X1 must be created (memory-allocated); (2) Legal values must be given");
- if ( !X2_dm || !X2_dm->flag ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesColofMatrix(): (1) Input matrix X2 must be created (memory-allocated); (2) Legal values must be given");
- if ( (nrows1=X1_dm->nrows) != X2_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesColofMatrix(): Numbers of rows in both input matrices must be the same");
- if ( jx1 >= X1_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jx1_th column of input matrix X1 exceeds its column dimension");
- if ( jx2 >= X2_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jx2_th column of input matrix X2 exceeds its column dimension");
-
- X1 = X1_dm->M + (jx1+1)*nrows1 - 1; //Points to the end of the jx1_th column.
- X2 = X2_dm->M + (jx2+1)*nrows1 - 1; //Points to the end of the jx2_th column.
- if ( _alpha==1.0 ) {
- if ( _beta==0.0 ) {
- if ( !y_dv )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = (*X1) * (*X2);
- else {
- if ( nrows1 != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows1-1, y=y_dv->v+_i; _i>=0; _i--, X1--, X2--, y--) *y = (*X1) * (*X2);
- y_dv->flag = V_DEF;
- }
- }
- else if ( _beta==1.0 ) {
- if ( !y_dv )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = (*X1) * (*X2) + (*X1);
- else {
- if ( nrows1 != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows1-1, y=y_dv->v+_i; _i>=0; _i--, X1--, X2--, y--) *y = (*X1) * (*X2) + (*X1);
- y_dv->flag = V_DEF;
- }
- }
- else {
- if ( !y_dv )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = (*X1) * (*X2) + _beta * (*X1);
- else {
- if ( nrows1 != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows1-1, y=y_dv->v+_i; _i>=0; _i--, X1--, X2--, y--) *y = (*X1) * (*X2) + _beta * (*X1);
- y_dv->flag = V_DEF;
- }
- }
- }
- else {
- if ( _beta==0.0 ) {
- if ( !y_dv )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = _alpha * (*X1) * (*X2);
- else {
- if ( nrows1 != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows1-1, y=y_dv->v+_i; _i>=0; _i--, X1--, X2--, y--) *y = _alpha * (*X1) * (*X2);
- y_dv->flag = V_DEF;
- }
- }
- else if ( _beta==1.0 ) {
- if ( !y_dv )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = _alpha * (*X1) * (*X2) + (*X1);
- else {
- if ( nrows1 != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows1-1, y=y_dv->v+_i; _i>=0; _i--, X1--, X2--, y--) *y = _alpha * (*X1) * (*X2) + (*X1);
- y_dv->flag = V_DEF;
- }
- }
- else {
- if ( !y_dv )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = _alpha * (*X1) * (*X2) + _beta * (*X1);
- else {
- if ( nrows1 != y_dv->n ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in the input matrix must match the length of the output vector");
- for (_i=nrows1-1, y=y_dv->v+_i; _i>=0; _i--, X1--, X2--, y--) *y = _alpha * (*X1) * (*X2) + _beta * (*X1);
- y_dv->flag = V_DEF;
- }
- }
- }
-}
-void ColofMatrixDotTimesColofMatrix2ColofMatrix(TSdmatrix *Y_dm, int jy, TSdmatrix *X1_dm, int jx1, TSdmatrix *X2_dm, int jx2, double _alpha, double _beta) {
- //Outputs:
- // If Y_dm!=NULL, Y_dm(:,jy) = _alpha * X1_dm(:,jx1) .* X2_dm(:,jx2) + _beta * X1_dm(:,jx1).
- // If !Y_dm, X1_dm(:,jx1) = _alpha * X1_dm(:,jx1) .* X2_dm(:,jx2) + _beta * X1_dm(:,jx2).
- //Inputs:
- // _alpha: double scalar.
- // _beta: double scalar.
-
- int _i, nrows1;
- double *X1, *X2, *Y;
-
- if ( !X1_dm || !X1_dm->flag ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesColofMatrix(): (1) Input matrix X1 must be created (memory-allocated); (2) Legal values must be given");
- if ( !X2_dm || !X2_dm->flag ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesColofMatrix(): (1) Input matrix X2 must be created (memory-allocated); (2) Legal values must be given");
- if ( (nrows1=X1_dm->nrows) != X2_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesColofMatrix(): Numbers of rows in both input matrices must be the same");
- if ( jx1 >= X1_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jx1_th column of input matrix X1 exceeds its column dimension");
- if ( jx2 >= X2_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jx2_th column of input matrix X2 exceeds its column dimension");
-
- X1 = X1_dm->M + (jx1+1)*nrows1 - 1; //Points to the end of the jx1_th column.
- X2 = X2_dm->M + (jx2+1)*nrows1 - 1; //Points to the end of the jx2_th column.
- if ( _alpha==1.0 ) {
- if ( _beta==0.0 ) {
- if ( !Y_dm )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = (*X1) * (*X2);
- else {
- if ( nrows1 != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in input matrices must match that of the output matrix");
- if ( jy >= Y_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jy_th column of output matrix Y exceeds its column dimension");
- Y = Y_dm->M + (jy+1)*nrows1 - 1; //Points to the end of the jy_th column.
-
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--, Y--) *Y = (*X1) * (*X2);
- }
- }
- else if ( _beta==1.0 ) {
- if ( !Y_dm )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = (*X1) * (*X2) + (*X1);
- else {
- if ( nrows1 != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in input matrices must match that of the output matrix");
- if ( jy >= Y_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jy_th column of output matrix Y exceeds its column dimension");
- Y = Y_dm->M + (jy+1)*nrows1 - 1; //Points to the end of the jy_th column.
-
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--, Y--) *Y = (*X1) * (*X2) + (*X1);
- }
- }
- else {
- if ( !Y_dm )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = (*X1) * (*X2) + _beta * (*X1);
- else {
- if ( nrows1 != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in input matrices must match that of the output matrix");
- if ( jy >= Y_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jy_th column of output matrix Y exceeds its column dimension");
- Y = Y_dm->M + (jy+1)*nrows1 - 1; //Points to the end of the jy_th column.
-
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--, Y--) *Y = (*X1) * (*X2) + _beta * (*X1);
- }
- }
- }
- else {
- if ( _beta==0.0 ) {
- if ( !Y_dm )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = _alpha * (*X1) * (*X2);
- else {
- if ( nrows1 != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in input matrices must match that of the output matrix");
- if ( jy >= Y_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jy_th column of output matrix Y exceeds its column dimension");
- Y = Y_dm->M + (jy+1)*nrows1 - 1; //Points to the end of the jy_th column.
-
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--, Y--) *Y = _alpha * (*X1) * (*X2);
- }
- }
- else if ( _beta==1.0 ) {
- if ( !Y_dm )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = _alpha * (*X1) * (*X2) + (*X1);
- else {
- if ( nrows1 != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in input matrices must match that of the output matrix");
- if ( jy >= Y_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jy_th column of output matrix Y exceeds its column dimension");
- Y = Y_dm->M + (jy+1)*nrows1 - 1; //Points to the end of the jy_th column.
-
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--, Y--) *Y = _alpha * (*X1) * (*X2) + (*X1);
- }
- }
- else {
- if ( !Y_dm )
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--) *X1 = _alpha * (*X1) * (*X2) + _beta * (*X1);
- else {
- if ( nrows1 != Y_dm->nrows ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): Number of rows in input matrices must match that of the output matrix");
- if ( jy >= Y_dm->ncols ) fn_DisplayError(".../mathlib.c/ColofMatrixDotTimesVector(): The specified jy_th column of output matrix Y exceeds its column dimension");
- Y = Y_dm->M + (jy+1)*nrows1 - 1; //Points to the end of the jy_th column.
-
- for (_i=nrows1-1; _i>=0; _i--, X1--, X2--, Y--) *Y = _alpha * (*X1) * (*X2) + _beta * (*X1);
- }
- }
- }
-}
-
-
-void MatrixPlusMatrixUpdate(TSdmatrix *X_dm, TSdmatrix *A_dm) {
- //Output: X = A + X where X_dm is an m-by-n general (and possibly symmetric) matrix.
- // If X = A, then X will be replaced by 2*A;
- //Inputs:
- // A_dm: m-by-n general or symmetric matrix.
- int _i, _m, _n, nels;
- double *X, *A;
-
-
- if ( !X_dm || !A_dm ) fn_DisplayError(".../mathlib.c/MatrixPlusMatrixUpdate(): All input matrices must be created (memory-allocated)");
- else if ( !X_dm->flag || !A_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixPlusMatrixUpdate(): Both input matrices must be given values");
- else {
- _m = X_dm->nrows;
- _n = X_dm->ncols;
- nels = _m * _n;
- X = X_dm->M;
- A = A_dm->M;
- }
-
- if ( (_m != A_dm->nrows) || (_n != A_dm->ncols) ) fn_DisplayError(".../mathlib.c/MatrixPlusMatrixUpdate(): Dimensions of all input matrices must be same");
-
- //=== Making both X_dm and A_dm general if not yet.
- if ( !(X_dm->flag & M_GE) ) {
- if (X_dm->flag & M_SU) SUtoGE(X_dm);
- else if (X_dm->flag & M_SL) SLtoGE(X_dm);
- else fn_DisplayError(".../mathlib.c/MatrixPlusMatrixUpdate(): Haven't got time to deal with the M_UT and M_LT cases for X_dm");
- }
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixPlusMatrixUpdate(): Haven't got time to deal with the M_UT and M_LT cases for A_dm");
- }
- for (_i=nels-1; _i>=0; _i--) X[_i] += A[_i]; //This operation may be much cheaper than explicitly using SU or SL operations with two for loops and integer multiplications for matrix offsets.
-
- if ( X_dm->flag != A_dm->flag ) X_dm->flag = M_GE; //Reset to a general matrix only; otherwise, keep the original X_dm->flag.
-}
-
-void MatrixPlusMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm) {
- //Output: X = A + B where X_dm is an m-by-n general matrix.
- // If X=A, A will be replaced by X; if X=B, B will be replaced by X.
- //Inputs:
- // A_dm: m-by-n general matrix.
- // B_dm: m-by-n general matrix.
- int _i, _m, _n, nels;
- double *X, *A, *B;
-
-
- if ( !X_dm || !A_dm || !B_dm ) fn_DisplayError(".../mathlib.c/MatrixPlusMatrix(): All input matrices must be created (memory-allocated)");
- else if ( !A_dm->flag || !B_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixPlusMatrix(): Two R input matrices must be given values");
- else {
- _m = X_dm->nrows;
- _n = X_dm->ncols;
- nels = _m * _n;
- X = X_dm->M;
- A = A_dm->M;
- B = B_dm->M;
- }
-
-
- if ( (_m != A_dm->nrows) || (_m != B_dm->nrows) || (_n != A_dm->ncols) || (_n != B_dm->ncols) )
- fn_DisplayError(".../mathlib.c/MatrixPlusMatrix(): Dimensions of all input matrices must be same");
- else {
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixPlusMatrix(): Haven't got time to deal with the M_UT and M_LT cases for A_dm");
- }
- if ( !(B_dm->flag & M_GE) ) {
- if (B_dm->flag & M_SU) SUtoGE(B_dm);
- else if (B_dm->flag & M_SL) SLtoGE(B_dm);
- else fn_DisplayError(".../mathlib.c/MatrixPlusMatrix(): Haven't got time to deal with the M_UT and M_LT cases for B_dm");
- }
-
- for (_i=nels-1; _i>=0; _i--) X[_i] = A[_i] + B[_i];
- if (A_dm->flag == B_dm->flag) X_dm->flag = A_dm->flag;
- else X_dm->flag = M_GE;
- }
-}
-
-void MatrixMinusMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm) {
- //Output: X = A - B where X_dm is an m-by-n general matrix.
- // If X=A, A will be replaced by X; if X=B, B will be replaced by X.
- //Inputs:
- // A_dm: m-by-n general matrix.
- // B_dm: m-by-n general matrix.
- int _i, _m, _n, nels;
- double *X, *A, *B;
-
-
- if ( !X_dm || !A_dm || !B_dm ) fn_DisplayError(".../mathlib.c/MatrixMinusMatrix(): All input matrices must be created (memory-allocated)");
- else if ( !A_dm->flag || !B_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixMinusMatrix(): Two R input matrices must be given values");
- else {
- _m = X_dm->nrows;
- _n = X_dm->ncols;
- nels = _m * _n;
- X = X_dm->M;
- A = A_dm->M;
- B = B_dm->M;
- }
-
-
- if ( (_m != A_dm->nrows) || (_m != B_dm->nrows) || (_n != A_dm->ncols) || (_n != B_dm->ncols) )
- fn_DisplayError(".../mathlib.c/MatrixMinusMatrix(): Dimensions of all input matrices must be same");
- else {
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixMinusMatrix(): Haven't got time to deal with the M_UT and M_LT cases for A_dm");
- }
- if ( !(B_dm->flag & M_GE) ) {
- if (B_dm->flag & M_SU) SUtoGE(B_dm);
- else if (B_dm->flag & M_SL) SLtoGE(B_dm);
- else fn_DisplayError(".../mathlib.c/MatrixMinusMatrix(): Haven't got time to deal with the M_UT and M_LT cases for B_dm");
- }
-
- for (_i=nels-1; _i>=0; _i--) X[_i] = A[_i] - B[_i];
- if (A_dm->flag == B_dm->flag) X_dm->flag = A_dm->flag;
- else X_dm->flag = M_GE;
- }
-}
-
-void Matrix2PlusMinusMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm, TSdmatrix *C_dm, const double _alpha, const double _beta, const double _gamma) {
- //????? Not yet exhaust all possibilities of alpha, beta, and gamma to get most efficiency. Add more as required. 10 February 2003.
- //Output: X = alpha*A + beta*B + gamma*C where X_dm is an m-by-n general matrix.
- //Inputs:
- // A_dm: m-by-n general matrix.
- // B_dm: m-by-n general matrix.
- // C_dm: m-by-n general matrix.
- // _alpha: a double scalar for A_dm.
- // _beta: a double scalar for B_dm.
- // _gamma: a double scalar for C_dm.
- int _i, _m, _n, nels;
- double *X, *A, *B, *C;
-
-
- if ( !X_dm || !A_dm || !B_dm || !C_dm ) fn_DisplayError(".../mathlib.c/Matrix2PlusMinusMatrix(): All input matrices must be created (memory-allocated)");
- else if ( !A_dm->flag || !B_dm->flag || !C_dm->flag ) fn_DisplayError(".../mathlib.c/Matrix2PlusMinusMatrix(): Some of R input matrices are not given values");
- else {
- _m = X_dm->nrows;
- _n = X_dm->ncols;
- nels = _m * _n;
- X = X_dm->M;
- A = A_dm->M;
- B = B_dm->M;
- C = C_dm->M;
- }
-
-
- if ( (_m != A_dm->nrows) || (_m != B_dm->nrows) || (_m != C_dm->nrows) || (_n != A_dm->ncols) || (_n != B_dm->ncols) || (_n != C_dm->ncols) )
- fn_DisplayError(".../mathlib.c/Matrix2PlusMinusMatrix(): Dimensions of all L and R input matrices must be same");
- else {
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/Matrix2PlusMinusMatrix(): Haven't got time to deal with the M_UT and M_LT cases for A_dm");
- }
- if ( !(B_dm->flag & M_GE) ) {
- if (B_dm->flag & M_SU) SUtoGE(B_dm);
- else if (B_dm->flag & M_SL) SLtoGE(B_dm);
- else fn_DisplayError(".../mathlib.c/Matrix2PlusMinusMatrix(): Haven't got time to deal with the M_UT and M_LT cases for B_dm");
- }
- if ( !(C_dm->flag & M_GE) ) {
- if (C_dm->flag & M_SU) SUtoGE(C_dm);
- else if (C_dm->flag & M_SL) SLtoGE(C_dm);
- else fn_DisplayError(".../mathlib.c/Matrix2PlusMinusMatrix(): Haven't got time to deal with the M_UT and M_LT cases for C_dm");
- }
-
-
- if ( (_alpha==1.0) && (_beta==1.0) && (_gamma==1.0) ) {
- for (_i=nels-1; _i>=0; _i--) X[_i] = A[_i] + B[_i] + C[_i];
- if ( (A_dm->flag == B_dm->flag) && (A_dm->flag == C_dm->flag) ) X_dm->flag = A_dm->flag;
- else X_dm->flag = M_GE;
- }
- else if ( (_alpha==1.0) && (_beta==1.0) && (_gamma==-1.0) ) {
- for (_i=nels-1; _i>=0; _i--) X[_i] = A[_i] + B[_i] - C[_i];
- if ( (A_dm->flag == B_dm->flag) && (A_dm->flag == C_dm->flag) ) X_dm->flag = A_dm->flag;
- else X_dm->flag = M_GE;
- }
- else if ( (_alpha==1.0) && (_gamma==1.0) ) {
- for (_i=nels-1; _i>=0; _i--) X[_i] = A[_i] + _beta*B[_i] + C[_i];
- if ( (A_dm->flag == B_dm->flag) && (A_dm->flag == C_dm->flag) ) X_dm->flag = A_dm->flag;
- else X_dm->flag = M_GE;
- }
- else {
- //Default for all cases (thus, may be most inefficient at this point.).
- for (_i=nels-1; _i>=0; _i--) X[_i] = _alpha*A[_i] + _beta*B[_i] + _gamma*C[_i];
- if ( (A_dm->flag == B_dm->flag) && (A_dm->flag == C_dm->flag) ) X_dm->flag = A_dm->flag;
- else X_dm->flag = M_GE;
- }
- }
-}
-
-void MatrixPlusConstantDiagUpdate(TSdmatrix *X_dm, const double _alpha) {
- //Output: X = X + diag([_alpha, ..., _alpha]) where X is an n-by-n square real matrix.
- int _i, nrows;
- double *M;
-
- if (!X_dm) fn_DisplayError(".../mathlib.c/MatrixPlusConstantDiagUpdate(): Input matrix must be created (memory-allocated)");
- else if (!X_dm->flag) fn_DisplayError(".../mathlib.c/MatrixPlusConstantDiagUpdate(): R input matrix must be given values");
-
- M = X_dm->M;
- nrows = X_dm->nrows;
- for (_i=square(nrows)-1; _i>=0; _i -= nrows+1) M[_i] += _alpha;
-}
-
-
-void MatrixDotTimesMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm, const double _alpha, const double _beta)
-{
- //$$$$$ If A_dm or B_dm or X_dm (when _beta!=0) is only upper or lower symmetric, it will be always converted to a general (and symmetric) matrix. $$$$$$
- //Output:
- // X_dm is m-by-n.
- // X_dm = _alpha * A_dm .* B_dm + _beta * X_dm if X_dm != B_dm.
- // X_dm = _alpha * A_dm .* X_dm + _beta * X_dm if X_dm = B_dm.
- //Inputs:
- // A_dm: m-by-n double vector.
- // B_dm: m-by-n double vector.
- // _alpha: double scalar.
- // _beta: a double scalar.
- int _i, nrows, ncols;
- double *X, *A, *B;
-
-
- if ( !X_dm || !A_dm || !B_dm) fn_DisplayError(".../mathlib.c/MatrixDotTimesMatrix(): All input matrices must be created (memory-allocated)");
- else if ( !A_dm->flag || !B_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixDotTimesMatrix(): Both R input matrices must be given legal values");
- else if ( _beta && !X_dm->flag ) fn_DisplayError(".../mathlib.c/MatrixDotTimesMatrix(): L output matrix, X_dm, must be given legal values");
- else {
- nrows = X_dm->nrows;
- ncols = X_dm->ncols;
- X = X_dm->M;
- A = A_dm->M;
- B = B_dm->M;
- }
- if ( (nrows != A_dm->nrows) || (nrows != B_dm->nrows) || (ncols != A_dm->ncols) || (ncols != B_dm->ncols) )
- fn_DisplayError(".../mathlib.c/MatrixDotTimesMatrix(): Dimensions of all input matrices must be same");
- if ( !(A_dm->flag & M_GE) ) {
- if (A_dm->flag & M_SU) SUtoGE(A_dm);
- else if (A_dm->flag & M_SL) SLtoGE(A_dm);
- else fn_DisplayError(".../mathlib.c/MatrixDotTimesMatrix(): Haven't got time to deal with the M_UT or M_LT cases for A_dm");
- }
- if ( !(B_dm->flag & M_GE) ) {
- if (B_dm->flag & M_SU) SUtoGE(B_dm);
- else if (B_dm->flag & M_SL) SLtoGE(B_dm);
- else fn_DisplayError(".../mathlib.c/MatrixDotTimesMatrix(): Haven't got time to deal with the M_UT or M_LT cases for B_dm");
- }
- if ( _beta && !(X_dm->flag & M_GE) ) {
- if (X_dm->flag & M_SU) SUtoGE(X_dm);
- else if (X_dm->flag & M_SL) SLtoGE(X_dm);
- else fn_DisplayError(".../mathlib.c/MatrixDotTimesMatrix(): Haven't got time to deal with the M_UT or M_LT cases for X_dm");
- }
-
-
-
- if ( _alpha==1.0 ) {
- if ( _beta==0.0 ) {
- for (_i=nrows*ncols-1; _i>=0; _i--) X[_i] = A[_i] * B[_i];
- if (B_dm->flag != A_dm->flag) X_dm->flag = M_GE;
- else X_dm->flag = A_dm->flag;
- }
- else if ( _beta==1.0 ) {
- for (_i=nrows*ncols-1; _i>=0; _i--) X[_i] += A[_i] * B[_i];
- if (X_dm->flag != A_dm->flag || X_dm->flag != B_dm->flag) X_dm->flag = M_GE;
- }
- else {
- for (_i=nrows*ncols-1; _i>=0; _i--) X[_i] = A[_i] * B[_i] + _beta * X[_i];
- if (X_dm->flag != A_dm->flag || X_dm->flag != B_dm->flag) X_dm->flag = M_GE;
- }
- }
- else {
- if ( _beta==0.0 ) {
- for (_i=nrows*ncols-1; _i>=0; _i--) X[_i] = _alpha * A[_i] * B[_i];
- if (B_dm->flag != A_dm->flag) X_dm->flag = M_GE;
- else X_dm->flag = A_dm->flag;
- }
- else if ( _beta==1.0 ) {
- for (_i=nrows*ncols-1; _i>=0; _i--) X[_i] += _alpha * A[_i] * B[_i];
- if (X_dm->flag != A_dm->flag || X_dm->flag != B_dm->flag) X_dm->flag = M_GE;
- }
- else {
- for (_i=nrows*ncols-1; _i>=0; _i--) X[_i] = _alpha * A[_i] * B[_i] + _beta * X[_i];
- if (X_dm->flag != A_dm->flag || X_dm->flag != B_dm->flag) X_dm->flag = M_GE;
- }
- }
-}
-
-
-
-void CopyVector0(TSdvector *x1_dv, const TSdvector *x2_dv) {
- //Ouputs:
- // x1_dv, whose elements are copied from from x2_dv.
- //Inputs:
- // Copying elements from x2_dv->v to x1_dv.
- int _n;
-
- if ( !x1_dv || !x2_dv || (x1_dv->n != x2_dv->n) )
- fn_DisplayError(".../mathlib.c/CopyVector0(): (1) all input pointers must be created (memory-allocated) and (2) dimensions of x1_dv and x2_dv must be compatible");
- else if ( !x2_dv->flag ) {
- // printf("x2_dv->flag is %d, and length is %d, and the vector is: \n", x2_dv->flag, x2_dv->n);
- // PrintVector(x2_dv, " %g ");
- fn_DisplayError(".../mathlib.c/CopyVector0(): R input vector must be given values");
- }
- else _n = x2_dv->n;
-
- if ( _n != x1_dv->n ) fn_DisplayError(".../mathlib.c/CopyVector0(): Both L and R input vectors must have the same length");
- memcpy(x1_dv->v, x2_dv->v, _n*sizeof(double));
- x1_dv->flag = V_DEF;
-}
-
-
-void CopyMatrix0(TSdmatrix *x1_dm, TSdmatrix *x2_dm) {
- //Deals with double matrices.
- //Copies the entire matrix x2_dm to x1_dm.
- int nrows1, ncols1, nrows2, ncols2;
-
- if ( !x1_dm || !x2_dm ) fn_DisplayError(".../mathlib.c/CopyMatrix0(): All input matrices must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopyMatrix0(): R input matrix must be given values");
- else {
- nrows1=x1_dm->nrows;
- ncols1=x1_dm->ncols;
- nrows2=x2_dm->nrows;
- ncols2=x2_dm->ncols;
- }
-
-
- if (nrows2 == nrows1 && ncols2 == ncols1) {
- //$$$$$$$$$$ 5/15/2003. At some point, the following if command should be got rid of completely. For now, we keep this for maintaining the backward compatibility.
- if ( !(x2_dm->flag & M_GE) ) {
- if (x2_dm->flag & M_SU) SUtoGE(x2_dm);
- else if (x2_dm->flag & M_SL) SLtoGE(x2_dm);
-// else fn_DisplayError(".../mathlib.c/CopyMatrix0(): Haven't got time to deal with the M_UT and M_LT cases for x2_dm");
- }
- //Both matrices have the same size.
- memcpy(x1_dm->M, x2_dm->M, nrows1 * ncols1 * sizeof(double));
- x1_dm->flag = x2_dm->flag;
-
-// #ifdef SWITCHTOTZCMATH // define: use my own C math library ; undef: use others.
-// memcpy(x1_dm->M, x2_dm->M, nrows1 * ncols1 * sizeof(double));
-// #endif
-// #ifdef SWITCHTOINTELCMATH // define: use Intek MKL LAPACK library; undef: use others.
-// cblas_dcopy(nrows1*ncols1, x2_dm->M, 1, x1_dm->M, 1);
-// #endif
-// x1_dm->flag = x2_dm->flag;
- }
- else fn_DisplayError(".../mathlib.c/CopyMatrix0(): Copying matrix (x2_m) and copied matrix (x1_dm) must have the same size");
-
-//?????????? The following is good, but should be used in CopySubmatrix0(), which might have already taken this into account.
-// else if (nrows2 <= nrows1 && ncols2 <= ncols1) {
-// if ( !(x2_dm->flag & M_GE) ) fn_DisplayError(".../mathlib.c/CopyMatrix0(): Haven't got time to deal with the M_UT and M_LT cases for x2_dm");
-// //Size of x2_dm is smaller than that of x1_dm.
-// for (_i=0; _i<ncols2; _i++) {
-// loc1 = _i*nrows1; //Points to the top of the column in x1_dm.
-// loc2 = _i*nrows2; //Points to the top of the column in x2_dm.
-// memcpy((x1_dm->M+loc1), (x2_dm->M+loc2), x2_dm->nrows*sizeof(double));
-// }
-// x1_dm->flag = M_GE;
-// }
-// else fn_DisplayError(".../mathlib.c/CopyMatrix0(): number of rows (columns) of the copying matrix (x2) must be no greater than that of the copied matrix (x1)");
-}
-
-void CopyCellvec0(TSdcellvec *x1_dcv, TSdcellvec *x2_dcv)
-{
- //Deals with double vectors.
- //Copies the entire cellvector x2_dcv to x1_dcv.
- int _i, ncells;
- if (!x1_dcv || !x2_dcv) fn_DisplayError(".../mathlib.c/CopyCellvec0(): Both input cellvectors must be created (memory-allocated)");
- else if ( (ncells=x2_dcv->ncells) != x1_dcv->ncells ) fn_DisplayError(".../mathlib.c/CopyCellvec0(): Both input cellvectors must have exactly the same size");
- for (_i=ncells-1; _i>=0; _i--) CopyVector0(x1_dcv->C[_i], x2_dcv->C[_i]);
-}
-
-void CopyCell0(TSdcell *x1_dc, TSdcell *x2_dc)
-{
- //Deals with double matrices.
- //Copies the entire cell x2_dc to x1_dc.
- int _i, ncells;
- if (!x1_dc || !x2_dc) fn_DisplayError(".../mathlib.c/CopyCell0(): Both input cells must be created (memory-allocated)");
- else if ( (ncells=x2_dc->ncells) != x1_dc->ncells ) fn_DisplayError(".../mathlib.c/CopyCell0(): Both input cells must have exactly the same size");
- for (_i=ncells-1; _i>=0; _i--) CopyMatrix0(x1_dc->C[_i], x2_dc->C[_i]);
-}
-
-
-void CopySubmatrix0(TSdmatrix *x1_dm, TSdmatrix *x2_dm, const int br, const int bc, const int nrs, const int ncs)
-{
- //Copies the nrs-by-ncs submatrix of x2_dm to the most left corner of x1_dm (i.e., at 0).
- //Note: br means the beginning of the row (*must* be 0 based) for this submatrix of x2_dm, inclusive;
- // bc means the beginning of the column (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- int _j, loc1, loc2,
- nrows1, ncols1, nrows2, ncols2;
-
- if ( !x1_dm || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubmatrix0(): All input matrices must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubmatrix0(): R input matrix must be given values");
- else {
- nrows1=x1_dm->nrows;
- ncols1=x1_dm->ncols;
- nrows2=x2_dm->nrows;
- ncols2=x2_dm->ncols;
- }
-
- if ( !(x2_dm->flag & M_GE) ) {
- if (x2_dm->flag & M_SU) SUtoGE(x2_dm);
- else if (x2_dm->flag & M_SL) SLtoGE(x2_dm);
- else fn_DisplayError(".../mathlib.c/CopySubmatrix0(): Haven't got time to deal with the M_UT and M_LT cases for x2_dm");
- }
-
- //=== Performs the operation.
- if ( (bc+ncs)<=ncols2 && (br+nrs)<=nrows2 && ncs<=ncols1 && nrs<=nrows1 ) {
- for (_j=ncs-1; _j>=0; _j--) {
- loc1 = _j*nrows1; //Points to the top of the column in x1_dm.
- loc2 = mos(br, bc+_j, nrows2); //Points to the top of the column in the submatrix of x2_dm.
- #ifdef SWITCHTOTZCMATH // define: use my own C math library ; undef: use others.
- memcpy(x1_dm->M+loc1, x2_dm->M+loc2, nrs*sizeof(double));
- #endif
- #ifdef SWITCHTOINTELCMATH // define: use Intek MKL LAPACK library; undef: use others.
- cblas_dcopy(nrs, x2_dm->M+loc2, 1, x1_dm->M+loc1, 1);
- #endif
- }
- x1_dm->flag = M_GE;
- }
- else fn_DisplayError(".../mathlib.c/CopySubmatrix0(): the submatrix of x2_dm must be within the ranges of both x1_dm and x2_dm");
-}
-
-void CopySubmatrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs) {
- //Copies the nrs-by-ncs submatrix of x2_dm to x1_dm at the specified location (br1, bc1).
- //Note: br1 means the beginning of the row (*must* be 0 based) for x1_dm, inclusive.
- // bc1 means the beginning of the column (*must* be 0 based) for x1_dm, inclusive.
- // br2 means the beginning of the row (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- // bc2 means the beginning of the column (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- int _j, loc1, loc2,
- nrows1, ncols1, nrows2, ncols2;
-
- if ( !x1_dm || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubmatrix(): All input matrices must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubmatrix(): R input matrix must be given values");
- else {
- nrows1=x1_dm->nrows;
- ncols1=x1_dm->ncols;
- nrows2=x2_dm->nrows;
- ncols2=x2_dm->ncols;
- }
-
- if ( (bc2+ncs)<=ncols2 && (br2+nrs)<=nrows2 && (bc1+ncs)<=ncols1 && (br1+nrs)<=nrows1 ) {
- for (_j=ncs-1; _j>=0; _j--) {
- loc1 = mos(br1, bc1+_j, nrows1); //Points to the top of the column in the submatrix of x1_dm.
- loc2 = mos(br2, bc2+_j, nrows2); //Points to the top of the column in the submatrix of x2_dm.
- memcpy((x1_dm->M+loc1), (x2_dm->M+loc2), nrs*sizeof(double));
- }
- x1_dm->flag = M_GE;
- }
- else fn_DisplayError(".../mathlib.c/CopySubmatrix(): the submatrix of x2_dm must be within the ranges of both x1_dm and x2_dm");
-}
-
-#if defined( INTELCMATHLIBRARY )
-void CopySubrowmatrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs)
-{
- //??????? NOT tested yet.
- //Copies the nrs-by-ncs submatrix of x2_dm to x1_dm at the specified location (br1, bc1).
- //Note: br1 means the beginning of the row (*must* be 0 based) for x1_dm, inclusive.
- // bc1 means the beginning of the column (*must* be 0 based) for x1_dm, inclusive.
- // br2 means the beginning of the row (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- // bc2 means the beginning of the column (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- int _i, loc1, loc2,
- nrows1, ncols1, nrows2, ncols2;
-
- if ( !x1_dm || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubrowmatrix(): All input matrices must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubrowmatrix(): R input matrix must be given values");
- else {
- nrows1=x1_dm->nrows;
- ncols1=x1_dm->ncols;
- nrows2=x2_dm->nrows;
- ncols2=x2_dm->ncols;
- }
-
- if ( (bc2+ncs)<=ncols2 && (br2+nrs)<=nrows2 && (bc1+ncs)<=ncols1 && (br1+nrs)<=nrows1 ) {
- for (_i=nrs-1; _i>=0; _i--) {
- loc1 = mos(br1+_i, bc1, nrows1); //Points to the beginning of the row in the submatrix of x1_dm.
- loc2 = mos(br2+_i, bc2, nrows2); //Points to the beginning of the row in the submatrix of x2_dm.
- cblas_dcopy(ncs, x2_dm->M+loc2, nrows2, x1_dm->M+loc1, nrows1);
- }
- }
- else fn_DisplayError(".../mathlib.c/CopySubrowmatrix(): the submatrix of x2_dm must be within the range of itself as well as x1_dm");
-}
-#else
- Havent got time to code up the default using Linux BLAS.
-#endif
-
-
-#if defined( INTELCMATHLIBRARY )
-void CopySubmatrix2rowmatrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs)
-{
- //Column by column operation on x2_dm: coping the transpose of the nrs-by-ncs submatrix of x2_dm to x1_dm at the specified location (br1, bc1).
- //Note: br1 means the beginning of the row (*must* be 0 based) for x1_dm, inclusive.
- // bc1 means the beginning of the column (*must* be 0 based) for x1_dm, inclusive.
- // br2 means the beginning of the row (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- // bc2 means the beginning of the column (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- int _j, loc1, loc2,
- nrows1, ncols1, nrows2, ncols2;
-
- if ( !x1_dm || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubmatrix2rowmatrix(): All input matrices must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubmatrix2rowmatrix(): R input matrix must be given values");
- else {
- nrows1=x1_dm->nrows;
- ncols1=x1_dm->ncols;
- nrows2=x2_dm->nrows;
- ncols2=x2_dm->ncols;
- }
-
- if ( (bc2+ncs)<=ncols2 && (br2+nrs)<=nrows2 && (bc1+nrs)<=ncols1 && (br1+ncs)<=nrows1 ) {
- for (_j=ncs-1; _j>=0; _j--) {
- loc1 = mos(br1+_j, bc1, nrows1); //Points to the beginning of the row in the submatrix of x1_dm.
- loc2 = mos(br2, bc2+_j, nrows2); //Points to the top of the column in the submatrix of x2_dm.
- cblas_dcopy(nrs, x2_dm->M+loc2, 1, x1_dm->M+loc1, nrows1);
- }
- }
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2rowmatrix(): the submatrix of x2_dm must be within the range of x2_dm and its transpose must be within the range of x1_dm");
-}
-#else
- Havent got time to code up the default using Linux BLAS.
-#endif
-
-
-#if defined( INTELCMATHLIBRARY )
-void CopySubrowmatrix2matrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs)
-{
- //??????? NOT tested yet.
- //Row by row operation on x2_dm: coping the transpose of the nrs-by-ncs submatrix of x2_dm to x1_dm at the specified location (br1, bc1).
- //Note: br1 means the beginning of the row (*must* be 0 based) for x1_dm, inclusive.
- // bc1 means the beginning of the column (*must* be 0 based) for x1_dm, inclusive.
- // br2 means the beginning of the row (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- // bc2 means the beginning of the column (*must* be 0 based) for this submatrix of x2_dm, inclusive.
- int _i, loc1, loc2,
- nrows1, ncols1, nrows2, ncols2;
-
- if ( !x1_dm || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubrowmatrix2matrix(): All input matrices must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubrowmatrix2matrix(): R input matrix must be given values");
- else {
- nrows1=x1_dm->nrows;
- ncols1=x1_dm->ncols;
- nrows2=x2_dm->nrows;
- ncols2=x2_dm->ncols;
- }
-
- if ( (bc2+ncs)<=ncols2 && (br2+nrs)<=nrows2 && (bc1+nrs)<=ncols1 && (br1+ncs)<=nrows1 ) {
- for (_i=nrs-1; _i>=0; _i--) {
- loc1 = mos(br1, bc1+_i, nrows1); //Points to the top of the column in the submatrix of x1_dm.
- loc2 = mos(br2+_i, bc2, nrows2); //Points to the beginning of the row in the submatrix of x2_dm.
- cblas_dcopy(ncs, x2_dm->M+loc2, nrows2, x1_dm->M+loc1, 1);
- }
- }
- else fn_DisplayError(".../mathlib.c/CopySubrowmatrix2matrix(): the submatrix of x2_dm must be within the range of itself as well as x1_dm");
-}
-#else
- Havent got time to code up the default using Linux BLAS.
-#endif
-
-
-void CopySubvector(TSdvector *x1_dv, const int ptrloc1, const TSdvector *x2_dv, const int ptrloc2, const int nels) {
- //Ouputs:
- // x1_dv, whose elements from x1_dv->v+ptrloc1 to x1_dv->v+ptrloc1+nels-1 are copied from from x2_dv->v.
- //Inputs:
- // Copying elements from x2_dv->v+ptrloc2 to x2_dv->v+ptrloc2+nels-1 (to x1_dv->v).
- // nels: number of elements to be copied.
- // ptrloc1: pointer location for x1_dv->v where the copy begins, inclusive.
- // ptrloc2: pointer location for x2_dv->v where the copy begins, inclusive.
-
- if ( !x1_dv || !x2_dv ) fn_DisplayError(".../mathlib.c/CopySubvector(): All input vectors must be created (memory-allocated)");
- else if (!x2_dv->flag) fn_DisplayError(".../mathlib.c/CopySubvector(): R input vector must be given values");
-
- if ( (ptrloc2+nels)<=x2_dv->n && (ptrloc1+nels)<=x1_dv->n) {
- memcpy(x1_dv->v+ptrloc1, x2_dv->v+ptrloc2, nels*sizeof(double));
- x1_dv->flag = V_DEF;
- }
- else fn_DisplayError(".../mathlib.c/CopySubvector(): Copying (copied) elements are outside the dimension of the copying vector x2_dv (the copied vector x1_dv)");
-}
-//---
-void CopySubvector_int(TSivector *x1_iv, const int ptrloc1, const TSivector *x2_iv, const int ptrloc2, const int nels)
-{
- //Ouputs:
- // x1_iv, whose elements from x1_iv->v+ptrloc1 to x1_iv->v+ptrloc1+nels-1 are copied from from x2_iv->v.
- //Inputs:
- // Copying elements from x2_iv->v+ptrloc2 to x2_iv->v+ptrloc2+nels-1 (to x1_iv->v).
- // nels: number of elements to be copied.
- // ptrloc1: pointer location for x1_iv->v where the copy begins, inclusive.
- // ptrloc2: pointer location for x2_iv->v where the copy begins, inclusive.
-
- if ( !x1_iv || !x2_iv ) fn_DisplayError(".../mathlib.c/CopySubvector_int(): All input vectors must be created (memory-allocated)");
- else if (!x2_iv->flag) fn_DisplayError(".../mathlib.c/CopySubvector_int(): R input vector must be given values");
-
- if ( (ptrloc2+nels)<=x2_iv->n && (ptrloc1+nels)<=x1_iv->n) {
- memcpy(x1_iv->v+ptrloc1, x2_iv->v+ptrloc2, nels*sizeof(int));
- x1_iv->flag = V_DEF;
- }
- else fn_DisplayError(".../mathlib.c/CopySubvector_int(): Copying (copied) elements are outside the dimension of the copying vector x2_iv (the copied vector x1_iv)");
-}
-
-void CopySubmatrix2vector(TSdvector *x1_dv, const int ptrloc1, TSdmatrix *x2_dm, const int br, const int bc, const int nels)
-{
- //Ouputs:
- // x1_dv whose elements from x1_dv->v+ptrloc1 to x1_dv->v+ptrloc1+nels-1 are copied from x2_dm->M[br,bc] onward (inclusive)
- // where copied elements can run column by column all the way to the end of x2_dm->M[end,end]. Thus, this function
- // can be used as the Matlab reshape command.
- //Inputs: Copying elements from x2_dm->M+ptrloc2 to x2_dm->M+ptrloc2+nels-1 (to x1_dv->v).
- // ptrloc1: pointer location for x1_dv->v where the copy begins, inclusive.
- // br: beginning of the row (*must* be 0 based) for x2_dm, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x2_dm, inclusive.
- // nels: number of elements to be copied.
- int ptrloc2; //pointer location for x2_dm->M where the copy begins.
-
- if ( !x1_dv || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubmatrix2vector(): All input pointers must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubmatrix2vector(): R input matrix must be given values");
- else ptrloc2 = mos(br,bc,x2_dm->nrows); // ptrloc2: pointer location for x2_dm->M where the copy begins.
-
- if ( !(x2_dm->flag & M_GE) ) {
- if (x2_dm->flag & M_SU) SUtoGE(x2_dm);
- else if (x2_dm->flag & M_SL) SLtoGE(x2_dm);
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2vector(): Haven't got time to deal with the M_UT and M_LT cases for x2_dm");
- }
-
-
-
- if ( (ptrloc2+nels)<=(x2_dm->nrows*x2_dm->ncols) && (ptrloc1+nels)<=x1_dv->n) {
- memcpy(x1_dv->v+ptrloc1, x2_dm->M+ptrloc2, nels*sizeof(double));
- x1_dv->flag = V_DEF;
- }
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2vector(): Copying (copied) elements are outside the dimension of the copying matrix x2_dm (the copied vector x1_dv)");
-}
-
-void CopySubmatrix2vector_sub(TSdvector *x1_dv, const int ptrloc1, TSdmatrix *x2_dm, const int br, const int bc, const int nrs, const int ncs) {
- //Ouputs: Unlike CopySubmatrix2vector, _sub means a submatrix, NOT just one column, of the copying matrix x2_dm.
- // The copying submatrix must start at (br, bc) ane end at (br+nrs-1, bc+ncs-1).
- // Copying is done column by column.
- // x1_dv, whose elements from x1_dv->v+ptrloc1 to x1_dv->v+ptrloc1+nrs*ncs-1 are copied from the submatrix of of x2_dm->m.
- //Inputs: The copying submatrix of x2_dm->M.
- // ptrloc1: inclusive pointer location for x1_dv->v where the copy begins.
- // br: beginning of the row (*must* be 0 based) for x2_dm, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x2_dm, inclusive.
- // nrs: number of rows to be copied.
- // ncs: number of colums to be copied.
- int nrows, ncols, _j, loc1;
- double *v, *M;
-
- if ( !x1_dv || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_sub(): All input pointers must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_sub(): R input matrix must be given values");
- else {
- v = x1_dv->v;
- M = x2_dm->M;
- nrows = x2_dm->nrows;
- ncols = x2_dm->ncols;
- }
-
- if ( !(x2_dm->flag & M_GE) ) {
- if (x2_dm->flag & M_SU) SUtoGE(x2_dm);
- else if (x2_dm->flag & M_SL) SLtoGE(x2_dm);
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_sub(): Haven't got time to deal with the M_UT and M_LT cases for x2_dm");
- }
-
- if ( (bc+ncs)<=ncols && (br+nrs)<=nrows && (ptrloc1+ncs*nrs)<=x1_dv->n ) {
- loc1 = ptrloc1;
- for (_j=0; _j<ncs; _j++) {
- memcpy(v+loc1, M+mos(br, bc+_j, nrows), nrs*sizeof(double)); //mos(br, bc+_j, nrows): Points to the top of the column in the submatrix of x2_dm.
- loc1 += nrs; //Must be after memcpy().
- }
- x1_dv->flag = V_DEF;
- }
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_sub(): the submatrix of x2_dm must be within the ranges of both x1_dv and x2_dm");
-}
-
-void CopySubmatrix2vector_int(TSivector *x1_iv, const int ptrloc1, TSimatrix *x2_im, const int br, const int bc, const int nels) {
- //Ouputs:
- // x1_iv, whose elements from x1_iv->v+ptrloc1 to x1_iv->v+ptrloc1+nels-1 are copied from a column of x2_im->m.
- //Inputs: Copying elements from x2_im->M+ptrloc2 to x2_im->M+ptrloc2+nels-1 (to x1_iv->v).
- // ptrloc1: pointer location for x1_iv->v where the copy begins, inclusive.
- // br: beginning of the row (*must* be 0 based) for x2_im, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x2_im, inclusive.
- // nels: number of elements to be copied.
- int ptrloc2; //pointer location for x2_im->M where the copy begins.
-
- if ( !x1_iv || !x2_im ) fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_int(): All input pointers must be created (memory-allocated)");
- else ptrloc2 = mos(br,bc,x2_im->nrows); // ptrloc2: pointer location for x2_im->M where the copy begins.
-
-
-
- if ( (ptrloc2+nels)<=(x2_im->nrows*x2_im->ncols) && (ptrloc1+nels)<=x1_iv->n) {
- memcpy(x1_iv->v+ptrloc1, x2_im->M+ptrloc2, nels*sizeof(int));
- x1_iv->flag = V_DEF;
- }
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_int(): Copying (copied) elements are outside the dimension of the copying matrix x2_im (the copied vector x1_iv)");
-}
-
-void CopySubmatrix2vector_row(TSdvector *x1_dv, const int ptrloc1, TSdmatrix *x2_dm, const int br, const int bc, const int nels) {
- //This is much less efficient because we copy a row of x2_dm where x2_dm is a column-major matrix. But sometimes,
- // transposing x2_dm and then using CopySubmatrix2vector() proves more costly if the transpose has to be done in each iteration.
- //If SWITCHINTELCMATH is activated, it may achieve efficiency.
- //
- //Ouputs: copying a row of x2_dm to a vector.
- // x1_dv, whose elements from x1_dv->v+ptrloc1 to x1_dv->v+ptrloc1+nels-1 are copied from a row of x2_dm->m.
- //Inputs: Copying elements from x2_dm->M(br, bc) to x2_dm->M(br, bc+nels-1) (to x1_dv->v).
- // ptrloc1: inclusive pointer location for x1_dv->v where the copy begins.
- // br: beginning of the row (*must* be 0 based) for x2_dm, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x2_dm, inclusive.
- // nels: number of elements to be copied.
- int nrows;
- #if !defined(SWITCHTOINTELCMATH) // define: use my own C math library ; undef: use others.
- int _i;
- #endif
- double *v, *M;
-
- if ( !x1_dv || !x2_dm ) fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_row(): All input pointers must be created (memory-allocated)");
- else if ( !x2_dm->flag ) fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_row(): R input matrix must be given values");
- else {
- v = x1_dv->v;
- M = x2_dm->M;
- nrows = x2_dm->nrows;
- }
-
- if ( !(x2_dm->flag & M_GE) ) {
- if (x2_dm->flag & M_SU) SUtoGE(x2_dm);
- else if (x2_dm->flag & M_SL) SLtoGE(x2_dm);
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_row(): Haven't got time to deal with the M_UT and M_LT cases for x2_dm");
- }
-
-
- if ( (bc+nels)<=x2_dm->ncols && (ptrloc1+nels)<=x1_dv->n) {
- #if defined (INTELCMATHLIBRARY) // define: use Intek MKL LAPACK library; undef: use others.
- cblas_dcopy(nels, M+mos(br, bc, nrows), nrows, v+ptrloc1, 1); //mos(): inclusive pointer location for x2_dm where the copy begins.
- #else //Default to SWITCHTOTZCMATH // define: use my own C math library ; undef: use others.
- //for (_i=0; _i<nels; _i++) v[ptrloc1+_i] = M[mos(br, bc+_i, nrows)];
- for (_i=nels-1; _i>=0; _i--) v[ptrloc1+_i] = M[mos(br, bc+_i, nrows)]; //Changed above to this. 9/2/03.
- #endif
- x1_dv->flag = V_DEF;
- }
- else fn_DisplayError(".../mathlib.c/CopySubmatrix2vector_row(): Copying (copied) elements are outside the dimension of the copying matrix x2_dm (the copied vector x1_dv)");
-}
-
-void CopySubvector2matrix(TSdmatrix *x1_dm, const int br, const int bc, const TSdvector *x2_dv, const int ptrloc2, const int nels) {
- //Ouputs: only the ``bc''th column of the matrix is copied. If this is too restrictive, see CopySubvector2matrix_unr().
- // Copied elements (x1_dm->M+ptrloc1 to x1_dv->M+ptrloc1+nels-1) from x2_dv->v.
- // Always sets x1_dm->flag = M_GE after the call to this function.
- //Inputs:
- // Copying elements from x2_dv->v+ptrloc2 to x2_dv->v+ptrloc2+nels-1 (to x1_dm->M).
- // nels: number of elements to be copied.
- // br: beginning of the row (*must* be 0 based) for x2_dm, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x2_dm, inclusive.
- // ptrloc2: pointer location for x2_dv->v where the copy begins, inclusive.
- int ptrloc1, nrows, ncols;
-
- if ( !x1_dm || !x2_dv ) fn_DisplayError(".../mathlib.c/CopySubvector2matrix(): All input pointers must be created (memory-allocated)");
- else if (!x2_dv->flag) fn_DisplayError(".../mathlib.c/CopySubvector2matrix(): R input vector must be given values");
- else {
- nrows = x1_dm->nrows;
- ncols = x1_dm->ncols;
- ptrloc1 = mos(br, bc, x1_dm->nrows); //ptrloc1: pointer location for x1_dm->M where the copy begins.
- }
-
-
- if ( (ptrloc2+nels)<=x2_dv->n && (br+nels)<=nrows ) {
- memcpy(x1_dm->M+ptrloc1, x2_dv->v+ptrloc2, nels*sizeof(double));
- x1_dm->flag = M_GE; //Always reset to a general matrix because it will almost surely break, say, the original symmetry of the matrix x1_dm if x1_dm->flag exists in the first place.
- //-------if (!x1_dm->flag) x1_dm->flag = M_GE; //Set to a general matrix if this matrix is not set yet.
- }
- else fn_DisplayError(".../mathlib.c/CopySubvector2matrix(): Copying (copied) elements are outside the (row) dimension of the copying vector x2_dv (the copied matrix x1_dm)");
-}
-
-
-#if defined( INTELCMATHLIBRARY )
-void CopySubvector2rowmatrix(TSdmatrix *x1_dm, const int br, const int bc, const TSdvector *x2_dv, const int ptrloc2, const int nels)
-{
- //Ouputs:
- // Only the ``br''th row of the matrix x1_dm (starting from the ``bc''th column) is copied from x2_dv->v.
- // Always sets x1_dm->flag = M_GE after the call to this function.
- //Inputs:
- // Copying elements from x2_dv->v+ptrloc2 to x2_dv->v+ptrloc2+nels-1 (to x1_dm).
- // nels: number of elements to be copied.
- // br: beginning of the row (*must* be 0 based) for x2_dm, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x2_dm, inclusive.
- // ptrloc2: pointer location for x2_dv->v where the copy begins, inclusive.
- int ptrloc1, nrows, ncols;
-
- if ( !x1_dm || !x2_dv ) fn_DisplayError(".../mathlib.c/CopySubvector2rowmatrix(): All input pointers must be created (memory-allocated)");
- else if (!x2_dv->flag) fn_DisplayError(".../mathlib.c/CopySubvector2rowmatrix(): R input vector must be given values");
- else {
- nrows = x1_dm->nrows;
- ncols = x1_dm->ncols;
- ptrloc1 = mos(br, bc, x1_dm->nrows); //ptrloc1: pointer location for x1_dm->M where the copy begins.
- }
-
-
- if ( (ptrloc2+nels)<=x2_dv->n && (bc+nels)<=ncols ) {
- cblas_dcopy(nels, x2_dv->v+ptrloc2, 1, x1_dm->M+ptrloc1, nrows);
- x1_dm->flag = M_GE; //Always reset to a general matrix because it will almost surely break, say, the original symmetry of the matrix x1_dm if x1_dm->flag exists in the first place.
- //-------if (!x1_dm->flag) x1_dm->flag = M_GE; //Set to a general matrix if this matrix is not set yet.
- }
- else fn_DisplayError(".../mathlib.c/CopySubvector2rowmatrix(): Copying (copied) elements are outside the (row) dimension of the copying vector x2_dv (the copied matrix x1_dm)");
-}
-#else
- Havent got time to code up the default using Linux BLAS.
-#endif
-
-
-void CopySubvector2matrix_sub(TSdmatrix *x1_dm, const int br, const int bc, const int nrs, const int ncs, TSdvector *x2_dv, const int ptrloc2) {
- //Ouputs: Unlike CopySubvector2matrix, _sub means a submatrix, NOT just one column, of the copied matrix x1_dm.
- // The copyed submatrix must start at (br, bc) ane end at (br+nrs-1, bc+ncs-1).
- // x1_dm: The copyed submatrix of x2_dm->M.
-
- //Inputs:
- // x2_dv: whose elements from x2_dv->v+ptrloc2 to x2_dv->v+ptrloc2+nrs*ncs-1 are copied to the submatrix of of x1_dm->m.
- // ptrloc2: inclusive pointer location for x2_dv->v where the copy begins.
- // br: beginning of the row (*must* be 0 based) for x1_dm, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x1_dm, inclusive.
- // nrs: number of rows to be copied.
- // ncs: number of colums to be copied.
- int nrows, ncols, _j, loc2;
- double *v, *M;
-
- if ( !x1_dm || !x2_dv ) fn_DisplayError(".../mathlib.c/CopySubvector2matrix_sub(): All input pointers must be created (memory-allocated)");
- else if ( !x2_dv->flag ) fn_DisplayError(".../mathlib.c/CopySubvector2matrix_sub(): R input vector must be given values");
- else {
- v = x2_dv->v;
- M = x1_dm->M;
- nrows = x1_dm->nrows;
- ncols = x1_dm->ncols;
- }
-
- if ( (bc+ncs)<=ncols && (br+nrs)<=nrows && (ncs*nrs)<=(x2_dv->n-ptrloc2) ) {
- loc2 = ptrloc2;
- for (_j=0; _j<ncs; _j++) {
- memcpy(M+mos(br, bc+_j, nrows), v+loc2, nrs*sizeof(double)); //mos(br, bc+_j, nrows): Points to the top of the column in the submatrix of x2_dm.
- loc2 += nrs; //Must be after memcpy().
- }
- x1_dm->flag = M_GE;
- }
- else fn_DisplayError(".../mathlib.c/CopySubvector2matrix_sub(): the submatrix of x1_dm must be within the ranges of both x1_dm and x2_dv");
-}
-
-void CopySubvector2matrix_unr(TSdmatrix *x1_dm, const int br, const int bc, const TSdvector *x2_dv, const int ptrloc2, const int nels) {
- //Ouputs: _unr means that there is no such a restriction that only the ``bc''th column to be copied in the matrix. Copied
- // elements can affect several columns of the matrix other than the ``bc'' column, but one must be aware
- // that the bc+1 column may start before the specified br. Thus, this function can be used as the Matlab reshape function.
- // Copied elements (x1_dm->M+ptrloc1 to x1_dv->M+ptrloc1+nels-1) from x2_dv->v.
- // Always sets x1_dm->flag = M_GE after the call to this function.
- //Inputs:
- // Copying elements from x2_dv->v+ptrloc2 to x2_dv->v+ptrloc2+nels-1 (to x1_dm->M).
- // nels: number of elements to be copied.
- // br: beginning of the row (*must* be 0 based) for x2_dm, inclusive.
- // bc: beginning of the column (*must* be 0 based) for x2_dm, inclusive.
- // ptrloc2: pointer location for x2_dv->v where the copy begins, inclusive.
- int ptrloc1, nrows, ncols;
-
- if ( !x1_dm || !x2_dv ) fn_DisplayError(".../mathlib.c/CopySubvector2matrix_unr(): All input pointers must be created (memory-allocated)");
- else if (!x2_dv->flag) fn_DisplayError(".../mathlib.c/CopySubvector2matrix_unr(): R input vector must be given values");
- else {
- nrows = x1_dm->nrows;
- ncols = x1_dm->ncols;
- ptrloc1 = mos(br, bc, x1_dm->nrows); //ptrloc1: pointer location for x1_dm->M where the copy begins.
- }
-
-
- if ( (ptrloc2+nels)<=x2_dv->n && (ptrloc1+nels)<=(nrows*ncols) ) {
- memcpy(x1_dm->M+ptrloc1, x2_dv->v+ptrloc2, nels*sizeof(double));
- x1_dm->flag = M_GE; //Always reset to a general matrix because it will almost surely break, say, the original symmetry of the matrix x1_dm if x1_dm->flag exists in the first place.
- //-------if (!x1_dm->flag) x1_dm->flag = M_GE; //Set to a general matrix if this matrix is not set yet.
- }
- else fn_DisplayError(".../mathlib.c/CopySubvector2matrix_unr(): Copying (copied) elements are outside the dimension of the copying vector x2_dv (the copied matrix x1_dm)");
-}
-
-void TransposeSquare(TSdmatrix *B_dm, TSdmatrix *A_dm) {
- //???????? Some options are NOT test yet. 5/27/03. ???????????
- // Transposes the n-by-n matrix A_dm to the n-by-n matrix B_dm.
- // If A_dm = B_dm, B_dm will be replaced by transposed values.
- //
- //Outputs:
- // B_dm: n-by-n matrix (memory already allocated outside this function).
- //Inputs:
- // A_dm: n-by-n matrix to be transposed.
- int _i, _j, _n, Aflag;
- double *A, *B, tmpd;
-
- //=== Checking dimensions and memory allocation.
- if ( !B_dm || !A_dm ) fn_DisplayError(".../mathlib.c/TransposeSquare(): Input matrices must be created (memory-allocated)");
- if ( ((_n=A_dm->nrows) != B_dm->ncols) || (_n != B_dm->nrows) || (_n != A_dm->ncols) )
- fn_DisplayError(".../mathlib.c/TransposeSquare(): Both input matrices must be square");
- //This is too tough by killing the program. if ( ((Aflag=A_dm->flag) & M_SU) && (Aflag & M_SL) ) fn_DisplayError(".../mathlib.c/TransposeSquare(): Matrix is already both SU and SL, so there is no need to transpose. Check a possible bug in your program");
- //The above checking is very important even though it takes about 4 clock cycles, because
- // (1) one may make a mistake to mis-use this matrix over and over again;
- // (2) if there is no mistake, then no need to transpose this matrix.
- if ( ((Aflag=A_dm->flag) & M_SU) && (Aflag & M_SL) )
- {
- #if defined (USE_DEBUG_FILE)
- fprintf(FPTR_DEBUG, "\nWARNING: .../mathlib.c/TransposeSquare(): the matrix is already both SU and SL, so there is no need to transpose.\n");
- fflush(FPTR_DEBUG);
- #else
- fprintf(stdout, "\nWARNING: .../mathlib.c/TransposeSquare(): the matrix is already both SU and SL, so there is no need to transpose.\n");
- fflush(stdout);
- #endif
-
- if ( (A=A_dm->M) != (B=B_dm->M) )
- {
- CopyMatrix0(B_dm, A_dm);
- return;
- }
- else return;
- }
-
-
-
- //=== Transposing the square matrix A_dm.
- if ( (A=A_dm->M) != (B=B_dm->M) ) {
- if (Aflag & M_GE) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++) {
- //Off-diagonal elements.
- B[_i*_n+_j] = A[_j*_n+_i];
- B[_j*_n+_i] = A[_i*_n+_j];
- }
- for (_i=square(_n)-1; _i>=0; _i -= _n+1) B[_i] = A[_i]; //Diagonal elements.
- switch (Aflag) {
- case (M_GE | M_UT):
- B_dm->flag = M_GE | M_LT;
- break;
- case (M_GE | M_LT):
- B_dm->flag = M_GE | M_UT;
- break;
- default:
- B_dm->flag = M_GE;
- }
- }
- else if (Aflag & M_SU) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- B[mos(_i, _j, _n)] = A[mos(_j, _i, _n)]; //Off-diagonal elements.
- for (_i=square(_n)-1; _i>=0; _i -= _n+1)
- B[_i] = A[_i]; //Diagonal elements.
- B_dm->flag = M_SL;
- }
- else if (Aflag & M_SL) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- B[mos(_j, _i, _n)] = A[mos(_i, _j, _n)]; //Off-diagonal elements.
- for (_i=square(_n)-1; _i>=0; _i -= _n+1)
- B[_i] = A[_i]; //Diagonal elements.
- B_dm->flag = M_SU;
- }
- else if (Aflag & M_UT) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- B[mos(_i, _j, _n)] = A[mos(_j, _i, _n)]; //Off-diagonal elements.
- for (_i=square(_n)-1; _i>=0; _i -= _n+1)
- B[_i] = A[_i]; //Diagonal elements.
- B_dm->flag = M_LT;
- }
- else if (Aflag & M_LT) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- B[mos(_j, _i, _n)] = A[mos(_i, _j, _n)]; //Off-diagonal elements.
- for (_i=square(_n)-1; _i>=0; _i -= _n+1)
- B[_i] = A[_i]; //Diagonal elements.
- B_dm->flag = M_UT;
- }
- }
- else {
- // ????? NOT tested yet. 5/27/03. ????????????
- if ( (Aflag & M_GE) && (Aflag & M_UT) ) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++) {
- //Off-diagonal elements.
- A[mos(_i, _j, _n)] = A[mos(_j, _i, _n)];
- A[mos(_j, _i, _n)] = 0.0;
- }
- A_dm->flag = M_GE | M_LT;
- }
- else if ( (Aflag & M_GE) && (Aflag & M_LT) ) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++) {
- //Off-diagonal elements.
- A[mos(_j, _i, _n)] = A[mos(_i, _j, _n)];
- A[mos(_i, _j, _n)] = 0.0;
- }
- A_dm->flag = M_GE | M_UT;
- }
- else if (Aflag & M_GE) {
- //Tested. Fine. 10 Oct. 03.
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- swap(A[mos(_i,_j,_n)], A[mos(_j,_i,_n)], tmpd); //Off-diagonal elements.
- A_dm->flag = M_GE;
- }
- else if (Aflag & M_SU) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- A[mos(_i, _j, _n)] = A[mos(_j, _i, _n)]; //Off-diagonal elements.
- A_dm->flag = M_GE | M_SU | M_SL;
- }
- else if (Aflag & M_SL) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- A[mos(_j, _i, _n)] = A[mos(_i, _j, _n)]; //Off-diagonal elements.
- A_dm->flag = M_GE | M_SU | M_SL;
- }
- else if (Aflag & M_UT) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- A[mos(_i, _j, _n)] = A[mos(_j, _i, _n)]; //Off-diagonal elements.
- A_dm->flag = M_LT;
- }
- else if (Aflag & M_LT) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++)
- A[mos(_j, _i, _n)] = A[mos(_i, _j, _n)]; //Off-diagonal elements.
- A_dm->flag = M_UT;
- }
- else fn_DisplayError(".../mathlib.c/TransposeSquare(): Input matrix is not M_GE, M_SU, M_SL, M_UT, or M_LT. Check the matrix to see why transpose is still required");
- }
-
-
- /** OLD code, which has some errors, I belive. 5/28/03.
- //=== Transposing the square matrix A_dm.
- if ( (A=A_dm->M) != (B=B_dm->M) ) {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++) {
- //Off-diagonal elements.
- B[_i*_n+_j] = A[_j*_n+_i];
- B[_j*_n+_i] = A[_i*_n+_j];
- }
- for (_i=square(_n)-1; _i>=0; _i -= _n+1)
- B[_i] = A[_i]; //Diagonal elements.
-
- switch (A_dm->flag) {
- case (M_GE | M_UT):
- B_dm->flag = M_GE | M_LT;
- break;
- case (M_GE | M_LT):
- B_dm->flag = M_GE | M_UT;
- break;
- case M_GE:
- B_dm->flag = M_GE;
- break;
- default:
- fn_DisplayError(".../mathlib.c/TransposeSquare(): (1) If the R input matrix is symmetric, no transpose is needed. (2) If triangular, it may be unnecessary so that no code is written for a triangular case");
- }
- }
- else {
- // ????? NOT tested yet. 2/27/03. ????????????
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++) {
- //Off-diagonal elements.
- tmpd = A[_j*_n+_i];
- A[_j*_n+_i] = A[_i*_n+_j];
- A[_i*_n+_j] = tmpd;
- }
-
- switch (A_dm->flag) {
- case (M_GE | M_UT):
- B_dm->flag = M_GE | M_LT;
- break;
- case (M_GE | M_LT):
- B_dm->flag = M_GE | M_UT;
- break;
- case M_GE:
- B_dm->flag = M_GE;
- break;
- default:
- fn_DisplayError(".../mathlib.c/TransposeSquare(): (1) If the R input matrix is symmetric, no transpose is needed. (2) If triangular, it may be unnecessary so that no code is written for a triangular case");
- }
- }
- /**/
-}
-
-void TransposeRegular(TSdmatrix *B_dm, const TSdmatrix *A_dm) {
- // Transposes the m-by-n matrix A_dm to the n-by-m matrix B_dm.
- //
- //Outputs:
- // B_dm: n-by-m general matrix (memory already allocated outside this function).
- //Inputs:
- // A_dm: m-by-n general matrix to be transposed.
- int _i, _j, _m, _n;
- double *A, *B;
-
-
- //=== Checking dimensions and memory allocation.
- if ( !B_dm || !A_dm ) fn_DisplayError(".../mathlib.c/TransposeRegular(): Input matrices must be created (memory-allocated)");
- else if ( !(A_dm->flag & M_GE) ) fn_DisplayError(".../mathlib.c/TransposeRegular(): (1) Input matrix A_dm must be given values. (2) A_dm must be a general (M_GE) matrix");
- else {
- _m = A_dm->nrows;
- _n = A_dm->ncols;
- A = A_dm->M;
- B = B_dm->M;
- }
- if ( (_m != B_dm->ncols) || (_n != B_dm->nrows) ) fn_DisplayError(".../mathlib.c/TransposeRegular(): Dimension of B_dm must be compatible with those of tranposed A_dm");
-
-
- //=== Transposing the regular matrix A_dm
- if (_m<_n) {
- for (_j=0; _j<_m; _j++)
- for (_i=_j+1; _i<_m; _i++) {
- //Off-diagonal elements in the square part.
- B[mos(_j, _i, _n)] = A[mos(_i, _j, _m)];
- B[mos(_i, _j, _n)] = A[mos(_j, _i, _m)];
- }
-
- for (_i=_m-1; _i>=0; _i--)
- B[mos(_i,_i,_n)] = A[mos(_i, _i, _m)]; //Diagonal elements.
-
- for (_j=_m; _j<_n; _j++)
- for (_i=0; _i<_m; _i++)
- B[_i*_n+_j] = A[_j*_m+_i]; //Off-diagonal elements in the trapozoidal part.
-
- B_dm->flag = M_GE;
- }
- else {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++) {
- //Off-diagonal elements in the square part.
- B[_i*_n+_j] = A[_j*_m+_i];
- B[_j*_n+_i] = A[_i*_m+_j];
- }
-
- for (_i=0; _i<_n; _i++)
- B[mos(_i,_i,_n)] = A[mos(_i,_i,_m)]; //Diagonal elements.
-
- for (_i=_n; _i<_m; _i++)
- for (_j=0; _j<_n; _j++)
- B[_i*_n+_j] = A[_j*_m+_i]; //Off-diagonal elements in the trapozoidal part.
-
- B_dm->flag = M_GE;
- }
-}
-//---
-TSdmatrix *tz_TransposeRegular(TSdmatrix *B_dm, const TSdmatrix *A_dm)
-{
- // Transposes the m-by-n matrix A_dm to the n-by-m matrix B_dm.
- //
- //Outputs:
- // If B_dm==NULL, B_dm (n-by-m general matrix) is created (memory allocated) and returned (thus, the memory must be destroyed outside this function).
- // If B_dm!=NULL, B_dm (n-by-m general matrix)'s memory has already been allocated outside this function and the same B_dm will be returned.
- //Inputs:
- // A_dm: m-by-n general matrix to be transposed.
- int _i, _j, _m, _n;
- double *A, *B;
-
-
- //=== Checking dimensions and memory allocation.
- if (!A_dm) fn_DisplayError(".../mathlib.c/TransposeRegular(): Input matrix A_dm must be created (memory-allocated)");
- if ( !(A_dm->flag & M_GE) ) fn_DisplayError(".../mathlib.c/TransposeRegular(): (1) Input matrix A_dm must be given values. (2) A_dm must be a general (M_GE) matrix");
- _m = A_dm->nrows;
- _n = A_dm->ncols;
- A = A_dm->M;
- //
- if (!B_dm) B_dm = CreateMatrix_lf(_n, _m);
- else
- if ( (_m != B_dm->ncols) || (_n != B_dm->nrows) ) fn_DisplayError(".../mathlib.c/TransposeRegular(): Dimension of B_dm must be compatible with those of tranposed A_dm");
- B = B_dm->M;
-
- //=== Transposing the regular matrix A_dm
- if (_m<_n) {
- for (_j=0; _j<_m; _j++)
- for (_i=_j+1; _i<_m; _i++) {
- //Off-diagonal elements in the square part.
- B[mos(_j, _i, _n)] = A[mos(_i, _j, _m)];
- B[mos(_i, _j, _n)] = A[mos(_j, _i, _m)];
- }
-
- for (_i=_m-1; _i>=0; _i--)
- B[mos(_i,_i,_n)] = A[mos(_i, _i, _m)]; //Diagonal elements.
-
- for (_j=_m; _j<_n; _j++)
- for (_i=0; _i<_m; _i++)
- B[_i*_n+_j] = A[_j*_m+_i]; //Off-diagonal elements in the trapozoidal part.
-
- B_dm->flag = M_GE;
- }
- else {
- for (_j=0; _j<_n; _j++)
- for (_i=_j+1; _i<_n; _i++) {
- //Off-diagonal elements in the square part.
- B[_i*_n+_j] = A[_j*_m+_i];
- B[_j*_n+_i] = A[_i*_m+_j];
- }
-
- for (_i=0; _i<_n; _i++)
- B[mos(_i,_i,_n)] = A[mos(_i,_i,_m)]; //Diagonal elements.
-
- for (_i=_n; _i<_m; _i++)
- for (_j=0; _j<_n; _j++)
- B[_i*_n+_j] = A[_j*_m+_i]; //Off-diagonal elements in the trapozoidal part.
-
- B_dm->flag = M_GE;
- }
-
- return (B_dm);
-}
-
-
-void SUtoGE(TSdmatrix *x_dm) {
- //Output: x_dm (nrows<=ncols) becomes a general matrix in addition to being upper symmetric.
- //Input: x_dm (nrows<=ncols) is upper symmetric.
- // We do not check if x_dm is upper symmetric because we assume the calling function checks this before this function is called.
- int nrows, ncols, _i, _j;
- if (!x_dm) fn_DisplayError(".../mathlib.c/SUtoGE(): Input upper symmetric matrix must be created (memory-allocated)");
- else if ( !(x_dm->flag & M_SU) ) fn_DisplayError(".../mathlib.c/SUtoGE(): Input matrix must be (1) upper symmetric and (2) given legal values");
- else if ( (nrows=x_dm->nrows) != (ncols=x_dm->ncols) ) fn_DisplayError(".../mathlib.c/SUtoGE(): Upper symmetric matrix must be square.");
- else {
- for (_j=0; _j<nrows; _j++)
- for (_i=_j+1; _i<nrows; _i++)
- x_dm->M[mos(_i, _j, nrows)] = x_dm->M[mos(_j, _i, nrows)]; //Off-diagonal elements in the square part.
- x_dm->flag = M_GE | M_SL | M_SU;
- }
-}
-
-void SLtoGE(TSdmatrix *x_dm) {
- //Output: x_dm becomes a general square matrix in addition to being lower symmetric.
- //Input: x_dm is lower symmetric.
- // We do not check if x_dm is upper symmetric because we assume the calling function checks this before this function is called.
- int nrows, ncols, _i, _j;
- if (!x_dm) fn_DisplayError(".../mathlib.c/SLtoGE(): Input lower symmetric matrix must be created (memory-allocated)");
- else if ( !(x_dm->flag & M_SL) ) fn_DisplayError(".../mathlib.c/SLtoGE(): Input matrix must be (1) lower symmetric and (2) given legal values");
- else if ( (nrows=x_dm->nrows) != (ncols=x_dm->ncols) ) fn_DisplayError(".../mathlib.c/SLtoGE(): The lower symmetric matrix must be sqaure");
- else {
- for (_j=0; _j<nrows; _j++)
- for (_i=_j+1; _i<nrows; _i++)
- x_dm->M[mos(_j, _i, nrows)] = x_dm->M[mos(_i, _j, nrows)]; //Off-diagonal elements in the square part.
- x_dm->flag = M_GE | M_SU | M_SL;
- }
-}
-
-double SumVector(TSdvector *x_dv) {
- int _i;
- double sum = 0.0, //Cumulative.
- *v;
- //double *ptrcnt, *endptr;
-
- //=== This option may not speed up.
- // if ( !x_dv ) fn_DisplayError(".../mathlib.c/SumVector(): Input vector must be created (memory-allocated)");
- // else endptr = (ptrcnt = x_dv->v) + x_dv->n;
- // for ( ; ptrcnt<endptr; ptrcnt++ ) sum += *ptrcnt;
-
- if ( !x_dv || !x_dv->flag ) fn_DisplayError(".../mathlib.c/SumVector(): input vector must be (a) created (memory-allocated) and (b) assigned legal values");
- for (_i=x_dv->n-1, v=x_dv->v; _i>=0; _i--) sum += v[_i];
-
- return( sum );
-}
-
-//double SumVector(TSdvector *x_dv) {
-// int _i, _n;
-// double sum;
-// double *v;
-
-// if ( !x_dv ) fn_DisplayError(".../mathlib.c/SumVector(): Input vector must be created (memory-allocated)");
-// else {
-// v = x_dv->v;
-// _n = x_dv->n;
-// }
-
-// sum = v[0];
-// for ( _i=1; _i<_n; _i++ ) sum += v[_i];
-// return( sum );
-//}
-
-
-double MinVector(TSdvector *x_dv)
-{
- //Input: no change for x_dv in this function.
- int _i, n;
- double minvalue;
- double *v;
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/MinVector_lf(): Input vector x_dv must be (1) allocated memory and (2) assigned legal values");
- n = x_dv->n;
- v = x_dv->v;
-
- minvalue = v[0];
- for (_i=n-1; _i>0; _i--)
- if (v[_i]<minvalue) minvalue = v[_i];
-
- return( minvalue );
-}
-
-double MaxVector(TSdvector *x_dv)
-{
- //Input: no change for x_dv in this function.
- int _i, n;
- double maxvalue;
- double *v;
-
- if (!x_dv || !x_dv->flag) fn_DisplayError(".../cstz.c/MaxVector_lf(): Input vector x_dv must be (1) allocated memory and (2) assigned legal values");
- n = x_dv->n;
- v = x_dv->v;
-
- maxvalue = v[0];
- for (_i=n-1; _i>0; _i--)
- if (v[_i]>maxvalue) maxvalue = v[_i];
-
- return( maxvalue );
-}
-
-int MaxVector_int(TSivector *x_iv)
-{
- //Input: no change for x_iv in this function.
- int _i;
- int maxvalue;
- int *v;
-
- if (!x_iv || !x_iv->flag) fn_DisplayError(".../cstz.c/MaxVector_int(): Input vector x_iv must be (1) allocated memory and (2) assigned legal values");
- v = x_iv->v;
-
- maxvalue = v[0];
- for (_i=x_iv->n-1; _i>0; _i--)
- if (v[_i]>maxvalue) maxvalue = v[_i];
-
- return( maxvalue );
-}
-
-
-void SumMatrix(TSdvector *x_dv, const TSdmatrix *X_dm, const char rc)
-{
- //Outputs:
- // x_dv: if rc=='R' or 'r', x_dv = sum of X_dm across rows; else or if rc=='C' or 'c', x_dv = sum of X_dm across columns.
- int _i, _n, _k, nrows, ncols, last;
- double sum;
- double *v, *M;
-
-
- if ( !x_dv || !X_dm || !X_dm->flag ) fn_DisplayError(".../mathlib.c/SumMatrix(): (a) output vector must be created (memory-allocated) and (b) input matrix must be created and assigned legal values");
-
-
- if (rc=='R' || rc=='r') {
- if ((_n=x_dv->n) != X_dm->ncols) fn_DisplayError(".../mathlib.c/SumMatrix(): length of the output vector must match the number of columns of the input matrix when summing it across rows");
- v = x_dv->v;
- M = X_dm->M;
- for (_i=_n-1; _i>=0; _i--) {
- sum = 0.0;
- last = (_i+1)*(nrows=X_dm->nrows);
- for (_k=_i*nrows; _k<last; _k++) sum +=M[_k];
- v[_i] = sum;
- }
- }
- else {
- if ((_n=x_dv->n) != X_dm->nrows) fn_DisplayError(".../mathlib.c/SumMatrix(): length of the output vector must match the number of rows of the input matrix when summing it across columns");
- v = x_dv->v;
- M = X_dm->M;
- for (_i=_n-1; _i>=0; _i--) {
- sum = 0.0;
- last = _i + ((ncols=X_dm->ncols)-1)*_n;
- for (_k=_i; _k<=last; _k += _n) sum +=M[_k]; //Must _k<=, NOT, _k<.
- v[_i] = sum;
- }
- }
-
- x_dv->flag = V_DEF;
-}
-
-
-void diagdv(TSdvector *x_dv, TSdmatrix *x_dm)
-{
- //Extract the diagonal elements of x_dm to a vector.
- //
- //Outputs:
- // x_dv: nrows-by-1 vector.
- //Inputs:
- // x_dm: nrows-by-ncols matrix.
- int _i, _n;
- double *v, *M;
-
-
- //=== Checking dimensions and memory allocation.
- if ( !x_dv || !x_dm ) fn_DisplayError(".../mathlib.c/diagdv(): Both the input vector and output matrix must be created (memory-allocated)");
- else {
- if (x_dm->nrows < x_dm->ncols) _n = x_dm->nrows;
- else _n = x_dm->ncols;
- v = x_dv->v;
- M = x_dm->M;
- }
- if ( _n != x_dv->n ) fn_DisplayError(".../mathlib.c/diagdv(): Dimensions of input vector and matrix must match");
-
-
- for (_i=0; _i<_n; _i++) v[_i] = M[mos(_i,_i,_n)];
- x_dv->flag = V_DEF;
-}
-//---
-TSdmatrix *tz_DiagMatrix(TSdmatrix *X_dm, TSdvector *x_dv)
-{
- //Converts a vector to a diagonal matrix with the diagonal elements being the input vector.
- //
- //Outputs:
- // X_dm: _n-by-_n diagonal matrix.
- // If X_dm = NULL, then Xout_dm is allocated memory and exported (therefore, its memory will be freed outside this function0.
- //Inputs:
- // x_dv: _n-by-1 vector.
- int _i, _n;
- double *v, *M;
- TSdmatrix *Xout_dm;
-
-
- //=== Checking dimensions and memory allocation.
- if ( !x_dv || !x_dv->flag) fn_DisplayError(".../mathlib.c/tz_DiagMatrix(): the input vector must be (1) created (memory-allocated) and (2) given legal values");
- _n = x_dv->n;
-
- if (X_dm)
- {
- if ((_n != X_dm->nrows) || (_n != X_dm->ncols)) fn_DisplayError(".../mathlib.c/tz_DiagMatrix(): (1) the input matrix must be square; (2) dimensions of input vector and matrix must match");
- if (isdiagonalmatrix(X_dm)) Xout_dm = X_dm;
- else fn_DisplayError(".../mathlib.c/tz_DiagMatrix(): the input matrix must be diagonal (M_UT | M_LT)");
- }
- else Xout_dm = CreateConstantMatrix_lf(_n, _n, 0.0);
-
- M = Xout_dm->M;
- v = x_dv->v;
-
- for (_i=0; _i<_n; _i++) M[mos(_i,_i,_n)] = v[_i];
- if ( !X_dm ) Xout_dm->flag = (M_GE | M_UT | M_LT); //Diagonal (i.e., both lower and upper triangular).
-
- return (Xout_dm);
-}
-
-
-double tracefabs(TSdmatrix *x_dm)
-{
- //Sum of absolute values of the diagonal elements of x_dm.
- //
- //Outputs:
- // y: double value.
- //Inputs:
- // x_dm: nrows-by-ncols matrix.
- int _i, _n;
- double traceval=0.0, //Cumulative.
- *M;
-
-
- //=== Checking dimensions and memory allocation.
- if (!x_dm) fn_DisplayError(".../mathlib.c/tracefabs(): The input matrix must be created (memory-allocated)");
- else {
- if (x_dm->nrows < x_dm->ncols) _n = x_dm->nrows;
- else _n = x_dm->ncols;
- M = x_dm->M;
- }
-
-
- for (_i=0; _i<_n; _i++) traceval += fabs(M[mos(_i,_i,_n)]);
- return( traceval );
-}
-double tracelogfabs(TSdmatrix *x_dm)
-{
- //Sum of logs of absolute values of the diagonal elements of the square x_dm or sum(log(diag(abs(x_dm)))).
- //
- //Outputs:
- // y: double value.
- //Inputs:
- // x_dm: nrows-by-ncols matrix.
- int _i, _n;
- double traceval=0.0, //Cumulative.
- *M;
-
- //=== Checking dimensions and memory allocation.
- if (!x_dm || !x_dm->flag) fn_DisplayError(".../mathlib.c/tracelogfabs(): The input matrix must be (1) created (memory-allocated) and (2) gvein legal values");
- else M = x_dm->M;
- if ((_n = x_dm->nrows) != x_dm->ncols) fn_DisplayError(".../mathlib.c/tracelogfabs(): The input matrix must be square");
- for (_i=square(_n)-1; _i>=0; _i -= _n+1) traceval += log(fabs(M[_i]));
-
-// if (!x_dm) fn_DisplayError(".../mathlib.c/tracelogfabs(): The input matrix must be created (memory-allocated)");
-// else if ( !x_dm->flag ) fn_DisplayError(".../mathlib.c/tracelogfabs(): The input matrix must be given legal values");
-// else {
-// if (x_dm->nrows < x_dm->ncols) _n = x_dm->nrows;
-// else _n = x_dm->ncols;
-// M = x_dm->M;
-// }
-// for (_i=0; _i<_n; _i++) traceval += log(fabs(M[mos(_i,_i,_n)]));
-
- return( traceval );
-}
-double tracelog(TSdmatrix *x_dm)
-{
- //Sum of logs of the diagonal elements of the square x_dm or sum(log(diag(x_dm))).
- //
- //Outputs:
- // y: double value.
- //Inputs:
- // x_dm: nrows-by-ncols matrix.
- int _i, _n;
- double traceval=0.0, //Cumulative.
- *M;
-
- //=== Checking dimensions and memory allocation.
- if (!x_dm || !x_dm->flag) fn_DisplayError(".../mathlib.c/tracelogfabs(): The input matrix must be (1) created (memory-allocated) and (2) gvein legal values");
- else M = x_dm->M;
- if ((_n = x_dm->nrows) != x_dm->ncols) fn_DisplayError(".../mathlib.c/tracelogfabs(): The input matrix must be square");
- for (_i=square(_n)-1; _i>=0; _i -= _n+1) traceval += log(M[_i]);
-
- return( traceval );
-}
-//---
-double sumoflogvector(TSdvector *x_dv)
-{
- //Output: sum(log(x_dv)).
- int _i;
- double sumlog = 0.0;
- double *v;
-
- if ( !x_dv || !x_dv->flag ) fn_DisplayError("mathlib.c/sumoflogvector(): Input vector x_dv must be (1) created and (2) given legal values");
- v = x_dv->v;
- for (_i=x_dv->n-1; _i>=0; _i--) sumlog += log(v[_i]);
-
- return( sumlog );
-}
-
-
-TSdmatrix *tz_kron(TSdmatrix *C_dm, TSdmatrix *A_dm, TSdmatrix *B_dm)
-{
- //C = kron(A, B), compatible with Matlab notation.
- //Inputs:
- // A_dm and B_dm: two real general matrices.
- //Outputs:
- // If C_dm == NULL, C_dm is created (memory allocated) and returned (thus, the memory must be destroyed outside this function).
- // If C_dm != NULL, C_dm's memory has already been allocated outside this function and the same C_dm will be returned.
- int _i, _j, ma, na, mb, nb, ki, kj;
- TSdmatrix *Wmb_nb_dm = NULL;
-
- //=== Checking dimensions and memory allocation.
- if (!A_dm || !B_dm) fn_DisplayError("mathlib.c/tz_kron(): Input matrices A_dm and B_dm must be created (memory-allocated)");
- if ( !(A_dm->flag & M_GE) || !(B_dm->flag & M_GE)) fn_DisplayError("mathlib.c/tz_kron(): "
- " (1) Input matrices A_dm and B_dm must be given values."
- " (2) A_dm and B_dm must be general (M_GE) matrices");
- ma = A_dm->nrows;
- na = A_dm->ncols;
- mb = B_dm->nrows;
- nb = B_dm->ncols;
- Wmb_nb_dm = CreateMatrix_lf(mb,nb);
- //
- if (!C_dm) C_dm = CreateZeroMatrix_lf(ma*mb, na*nb);
- else
- if ( (C_dm->nrows != (ma*mb)) || (C_dm->ncols != (na*nb)) )
- fn_DisplayError("mathlib.c/tz_kron(): Dimension of C_dm must be compatible with those of A_dm and B_dm");
-
- for (_i=ma-1; _i>=0; _i--)
- for (_j=na-1; _j>=0; _j--)
- {
- ki = _i*mb;
- kj = _j*nb;
- ScalarTimesMatrix(Wmb_nb_dm, A_dm->M[mos(_i,_j,ma)], B_dm, 0.0);
- CopySubmatrix(C_dm, ki, kj, Wmb_nb_dm, 0, 0, mb, nb);
- }
-
- //===
- DestroyMatrix_lf(Wmb_nb_dm);
-
-
- return (C_dm);
-}
-
-
-
-
-
-
-
-//=======================================================
-// Self-written routines.
-//=======================================================
-void ergodicp(TSdvector *p_dv, TSdmatrix *P_dm) {
- // Computes the ergodic probabilities. See Hamilton p.681.
- //
- //Outputs:
- // p_dv: n-by-1 vector filled by ergodic probabilities p.
- //------------
- //Inputs:
- // P_dm: n-by-n Markovian transition matrix. Elements in each column sum up to 1.0.
-
- int eigmaxindx, // Index of the column corresponding to the max eigenvalue.
- _i, _j, _n, errflag;
- double gpisum=0.0,
- eigmax, tmpd0;
- double *p_v=NULL,
- *absval_v=NULL,
- *evalr_v=NULL,
- *evali_v=NULL,
- *revecr_m=NULL,
- *reveci_m=NULL,
- *levecr_m=NULL,
- *leveci_m=NULL;
- TSdvector *absvals_dv=NULL;
- TSdzvector *vals_dzv=NULL;
- TSdzmatrix *rights_dzm=NULL, *lefts_dzm=NULL;
-
-
- if ( !p_dv || !P_dm || (p_dv->n != P_dm->nrows) || (P_dm->nrows != P_dm->ncols) ) fn_DisplayError(".../mathlib.c/ergodicp(): One of the two pointer arguments is not created (memory-allocated) or sizes of two pointer arguments do not match or input matrix P_dm is not square");
- else if ( !P_dm->flag || !(P_dm->flag & M_GE) ) fn_DisplayError(".../mathlib.c/ergodicp(): (1) R square input matrix (P_dm) must be given values. (2) P_dm must be a general (M_GE) matrix");
- else {
- _n = p_dv->n;
- absvals_dv = CreateVector_lf(_n);
- vals_dzv = CreateVector_dz(_n);
- rights_dzm = CreateMatrix_dz(_n, _n);
- InitializeConstantMatrix_lf(rights_dzm->imag, 0.0); //Imaginary part must be initialized to zero.
- }
-
-
- //=== Obtains eigen values and vectors.
- //errflag = eigrgen_decomp(evalr_v, evali_v, revecr_m, reveci_m, levecr_m, leveci_m, cp_m, _n);
- errflag = eigrgen(vals_dzv, rights_dzm, lefts_dzm, P_dm);
- if (errflag<0) fn_DisplayError("/mathlib.c/eigrgen(): some element in input matrix P_dm has an illegal value");
- else if (errflag>0) fn_DisplayError("/mathlib.c/eigrgen(): the QR algorithm failed to compute all the eigenvalues and no eigenvectors have been computed");
-
- //=== Utilizes old notations because I have no time to polish this function.
- p_v = p_dv->v;
- absval_v = absvals_dv->v;
- evalr_v = vals_dzv->real->v;
- evali_v = vals_dzv->imag->v;
- revecr_m = rights_dzm->real->M;
- reveci_m = rights_dzm->imag->M; //Imaginary part must be initialized to zero.
-
-
- for (_j=0; _j<_n; _j++) {
- if (!(evali_v[_j])) { //No imaginary part (in other words, real solutions).
- eigmax = evalr_v[_j];
- eigmaxindx = _j;
- break;
- }
- else {
- eigmax = sqrt(square(evalr_v[_j])+square(evali_v[_j]));
- eigmaxindx = _j;
- break;
- }
- }
- //+
- for (_j++; _j<_n; _j++) {
- if (!(evali_v[_j]) && (evalr_v[_j] > eigmax)) {
- eigmax = evalr_v[_j];
- eigmaxindx = _j;
- }
- else if (evali_v[_j]) {
- tmpd0 = sqrt(square(evalr_v[_j])+square(evali_v[_j]));
- if (tmpd0 > eigmax) {
- eigmax = tmpd0;
- eigmaxindx = _j;
- }
- }
- }
-
- if (!(evali_v[eigmaxindx])) {
- for (_i=0;_i<_n;_i++) {
- absval_v[_i] = fabs(revecr_m[_i+_n*eigmaxindx]);
- gpisum += absval_v[_i]; // Sum over the eigmaxindx_th column.
- }
- tmpd0 = 1.0/gpisum;
- for (_i=0;_i<_n;_i++) p_v[_i] = absval_v[_i]*tmpd0; // Normalized eigmaxindx_th column as ergodic probabilities.
- }
- else {
- for (_i=0;_i<_n;_i++) {
- absval_v[_i] = sqrt(square(revecr_m[_i+_n*eigmaxindx])+square(reveci_m[_i+_n*eigmaxindx]));
- gpisum += absval_v[_i]; // Sum over the eigmaxindx_th column.
- }
- tmpd0 = 1.0/gpisum;
- for (_i=0;_i<_n;_i++) p_v[_i] = absval_v[_i]*tmpd0; // Normalized eigmaxindx_th column as ergodic probabilities.
- }
-
-
- p_dv->flag = V_DEF;
- //=== Frees up allocated memory belonging to this function.
- DestroyVector_lf(absvals_dv);
- DestroyVector_dz(vals_dzv);
- DestroyMatrix_dz(rights_dzm);
-}
-
-
-
-double *alloc_ergodp2(const double *cp_m, const int _n) {
- // Output:
- // p_v: n-by-1 vector of ergodic probabilities p.
- //------------
- // cp_m: n-by-n Markovian transition matrix.
- // _n: the order of cp_m.
- //
- // Compute the ergodic probabilities. See Hamilton p.681.
-
- int eigmaxindx, // Index of the column corresponding to the max eigenvalue.
- _i, _j, errflag;
- double gpisum=0.0,
- eigmax, tmpd0;
- double *p_v=NULL, //@@Will be freed outside this function.@@ D: n-by-1. Erogodic probabilties.
- *absval_v=NULL,
- *evalr_v=NULL,
- *evali_v=NULL,
- *revecr_m=NULL,
- *reveci_m=NULL,
- *levecr_m=NULL,
- *leveci_m=NULL;
-
- //=== Allocates memory.
- p_v = tzMalloc(_n, double);
- absval_v = tzMalloc(_n, double);
- evalr_v = tzMalloc(_n, double);
- evali_v = tzCalloc(_n, double); //Imaginary part must be initialized to zero.
- revecr_m = tzMalloc(square(_n), double);
- reveci_m = tzCalloc(square(_n), double); //Imaginary part must be initialized to zero.
-
- //=== Obtains eigen values and vectors.
- errflag = eigrgen_decomp(evalr_v, evali_v, revecr_m, reveci_m, levecr_m, leveci_m, cp_m, _n);
- if (errflag<0) fn_DisplayError("/mathlib.c/eigrgen_decomp(): some element in input matrix has an illegal value");
- else if (errflag>0) fn_DisplayError("/mathlib.c/eigrgen_decomp(): the QR algorithm failed to compute all the eigenvalues and no eigenvectors have been computed");
-
- for (_j=0; _j<_n; _j++) {
- if (!(evali_v[_j])) { //No imaginary part (in other words, real solutions).
- eigmax = evalr_v[_j];
- eigmaxindx = _j;
- break;
- }
- else {
- eigmax = sqrt(square(evalr_v[_j])+square(evali_v[_j]));
- eigmaxindx = _j;
- break;
- }
- }
- //+
- for (_j++; _j<_n; _j++) {
- if (!(evali_v[_j]) && (evalr_v[_j] > eigmax)) {
- eigmax = evalr_v[_j];
- eigmaxindx = _j;
- break;
- }
- else if (evali_v[_j]) {
- tmpd0 = sqrt(square(evalr_v[_j])+square(evali_v[_j]));
- if (tmpd0 > eigmax) {
- eigmax = tmpd0;
- eigmaxindx = _j;
- break;
- }
- }
- }
-
- if (!(evali_v[eigmaxindx])) {
- for (_i=0;_i<_n;_i++) {
- absval_v[_i] = fabs(revecr_m[_i+_n*eigmaxindx]);
- gpisum += absval_v[_i]; // Sum over the eigmaxindx_th column.
- }
- tmpd0 = 1.0/gpisum;
- for (_i=0;_i<_n;_i++) p_v[_i] = absval_v[_i]*tmpd0; // Normalized eigmaxindx_th column as ergodic probabilities.
- }
- else {
- for (_i=0;_i<_n;_i++) {
- absval_v[_i] = sqrt(square(revecr_m[_i+_n*eigmaxindx])+square(reveci_m[_i+_n*eigmaxindx]));
- gpisum += absval_v[_i]; // Sum over the eigmaxindx_th column.
- }
- tmpd0 = 1.0/gpisum;
- for (_i=0;_i<_n;_i++) p_v[_i] = absval_v[_i]*tmpd0; // Normalized eigmaxindx_th column as ergodic probabilities.
- }
-
-
- //=== Frees up allocated memory.
- if (absval_v) free(absval_v);
- if (evalr_v) free(evalr_v);
- if (evali_v) free(evali_v);
- if (revecr_m) free(revecr_m);
- if (reveci_m) free(reveci_m);
- if (levecr_m) free(levecr_m);
- if (leveci_m) free(leveci_m);
-
- return (p_v);
-}
-
-
-
-
-/**
-void eig_rgen_all(double *eval_v, double *evec_m, const double *x_m, const int _n) {
- // Outputs (dependent on MATLAB C math library): NEED to be fixed about eval_v or mxval_d, which may be *complex*. 10/13/02
- // eval_v: n-by-1 eigenvalues;
- // evec_m: n-by-n corresponding eigenvectors column by column.
- //------------
- // Inputs:
- // x_m: _n-by_n real general (non-symmetric) matrix.
- //
- // Eigenanalysis of real general (non-symmetric) square matrix with all eigenvalues and eigenvectors.
-
- #ifdef MATLABCMATHLIBRARY //Matlab dependent code.
- mxArray *mxval_d=NULL, *mxvec_m=NULL, // @@Must be freed in this function.@@ m: n-by-n eigvector matrix; d: n-by-n eigvalue diagonal.
- *mx_m=NULL; // @@Must be freed in this function.@@
- double *mxval_d_p; // _p: pointer to the corresponding mxArray whose name occurs before _p.
- int ki;
-
-
- mx_m = mlfDoubleMatrix(_n, _n, x_m, NULL);
- mxvec_m = mlfEig(&mxval_d, mx_m, NULL, NULL);
-
- memcpy(evec_m, mxGetPr(mxvec_m), square(_n)*sizeof(double));
- //+
- mxval_d_p = mxGetPr(mxval_d);
- for (ki=0; ki<_n; ki++) eval_v[ki] = mxval_d_p[_n*ki+ki]; // Note that n*ki+ki refers to a diagonal location in the n-by-n matrix.
-
- //=== Frees up allocated mxArray.
- mxDestroyArray(mxval_d);
- mxDestroyArray(mxvec_m);
- mxDestroyArray(mx_m);
- #endif
-}
-
-
-double *fn_ergodp2(const double *cp_m, const int _n) {
- // Output:
- // p_v: n-by-1 vector of ergodic probabilities p.
- //------------
- // cp_m: n-by-n Markovian transition matrix.
- // _n: the order of cp_m.
- //
- // Compute the ergodic probabilities. See Hamilton p.681.
-
- int eigmaxindx, // Index of the column corresponding to the max eigenvalue.
- ki;
- double gpisum=0.0,
- eigmax, tmpd0,
- *p_v, // @@Will be freed outside this function.@@ D: n-by-1. Erogodic probabilties.
- *eval_v, *evec_m; // @@Must be freed in this function.@@ D: n-by-1 and n-by-n. Eigenvalues and eigenvectors.
-
- //=== Allocates memory.
- p_v = tzMalloc(_n, double);
- eval_v = tzMalloc(_n, double);
- evec_m = tzMalloc(square(_n), double);
-
-
- eig_rgen_all(eval_v, evec_m, cp_m, _n);
- eigmax = *eval_v;
- eigmaxindx = 0;
- if (_n>1) {
- for (ki=1;ki<_n;ki++) {
- if (eval_v[ki] > eigmax) {
- eigmax=eval_v[ki];
- eigmaxindx=ki;
- } // Note that n*ki+ki refers to a diagonal location in the n-by-n matrix.
- }
- }
- for (ki=0;ki<_n;ki++) gpisum += evec_m[_n*eigmaxindx+ki]; // Sum over the eigmaxindx_th column.
- tmpd0 = 1.0/gpisum;
- for (ki=0;ki<_n;ki++) p_v[ki] = evec_m[_n*eigmaxindx+ki]*tmpd0; // Normalized eigmaxindx_th column as ergodic probabilities.
-
- //=== Frees up allocated memory.
- free(eval_v);
- free(evec_m);
-
-
- return p_v;
-}
-/**/
-
-
-/** //Iskander's code.
-int eiggen(double *a, int n, double *dr, double *di, double *vr, double *vi) {
- unsigned char msg[101];
- int lwork = -1, info = 0;
- double *work, work1;
- char *jobvr = vr?"V":"N";
- register int i, j;
-
- // Query dsyev_ on the value of lwork
- dgeev_("N",jobvr,&n,a,&n,dr,di,NULL,&n,vr,&n,&work1,&lwork,&info);
-
- if (info < 0) {
- sprintf(msg, "Input %d to dgeev_ had an illegal value",-info);
- mexWarnMsgTxt(msg);
- return(info);
- }
-
- lwork = (int)(work1);
- work = mxCalloc(lwork,sizeof(double));
- dgeev_("N",jobvr,&n,a,&n,dr,di,NULL,&n,vr,&n,work,&lwork,&info);
- mxFree(work);
-
- if (info < 0) {
- sprintf(msg, "Input %d to dgeev_ had an illegal value",-info);
- mexWarnMsgTxt(msg);
- return(info);
- }
-
- for (i=0; i<n-1; i++)
- if (di[i] && (di[i]==-di[i+1]))
- for (j=0; j<n; j++) {
- vi[(i+1)*n+j] = -(vi[i*n+j]=vr[(i+1)*n+j]);
- vr[(i+1)*n+j] = vr[i*n+j];
- }
-
- if (info > 0) {
- sprintf(msg,"The QR algorithm failed to compute all the eigenvalues,\n"
- "and no eigenvectors have been computed, but elements D(%d:N) contain\n"
- "those eigenvalues which have converged.",info+1);
- mexWarnMsgTxt(msg);
- return(info);
- }
-
- return(info);
-}
-/**/
-
-
-/** SAVE (Dan's code). Transpose the square matrix.
-for (_i=0: _i<_n; _i++)
- for (_j=i+1; _j<_n; _j++) {
- tmp=A[_i+_j*_n];
- A[i+j*n]=A[j+i*n];
- A[j+i*n] = tmp;
- }
-/**/
-
-/** SAVE (Dan's code). Transpose the regular matrix.
-memcpy(tmp, A, ....);
-for (_i=0: _i<_n; _i++)
- for (_j=i+1; _j<m; _j++) {
- A[i+j*..] = tmp[j+i*..];
- }
-/**/
-
-
-
-
-/**
-void VectorTimesSelf(TSdmatrix *C_dm, const TSdvector *a_dv, const double _alpha, const double _beta, const char ul) {
- //No Lapack -- my own function.
- //Output is C and all other arguments are inputs.
- //Computes C = alpah*a*a' + beta*C where
- // a is m-by-1,
- // C is m-by-m symmetric matrix,
- // alpha: a double scalar,
- // beta: a double scalar,
- // ul: if == 'u' or 'U', elements in C are stored only in the upper part; otherwise, C is stored only in the lower part.
- int _i, _j, _m, _n;
- double *v, *M;
-
- if ( !C_dm || !a_dv ) fn_DisplayError(".../mathlib.c/VectorTimesSelf(): At least one of the pointer arguments is not created (memory-allocated)");
- else {
- v = a_dv->v;
- M = C_dm->M;
- _m = C_dm->nrows;
- _n = C_dm->ncols;
- }
-
- if ( (_m != a_dv->n) || (_m != _n) ) fn_DisplayError(".../mathlib.c/VectorTimesSelf(): (1) Input matrix must square and (2) its size must match the dimension of the input vector");
- else {
- if ( (ul == 'u') || (ul == 'U') ) {
- if ( _alpha==1.0 ) {
- if ( _beta==1.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] += v[_i] * v[_j];
- }
- }
- }
- else if ( _beta==0.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] = v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] = v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- }
- else {
- if ( _beta==1.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] += _alpha * v[_i] * v[_j];
- }
- }
- }
- else if ( _beta==0.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha * v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=0; _i<=_j; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha* v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- }
- }
- else {
- if ( _alpha==1.0 ) {
- if ( _beta==1.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] += v[_i] * v[_j];
- }
- }
- }
- else if ( _beta==0.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- }
- else {
- if ( _beta==1.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] += _alpha * v[_i] * v[_j];
- }
- }
- }
- else if ( _beta==0.0 ) {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha * v[_i] * v[_j];
- }
- }
- }
- else {
- for ( _j=0; _j<_m; _j++ ) {
- for ( _i=_j; _i<_m; _i++ ) {
- M[mos(_i, _j, _m)] = _alpha* v[_i] * v[_j] + _beta*M[mos(_i, _j, _m)];
- }
- }
- }
- }
- }
- }
-}
-/**/
-
-
-
-
-
-/**
-void swap_lf(double *a, double *b) {
- double tmpd0;
-
- tmpd0 = *a;
- *a = *b;
- *b = tmpd0;
-}
-/**/
-
-/** Creates zeros of the matrix of a given size.
-TSdmatrix *CreateZeros_lf(int nrows, int ncols) {
- int _i;
- TSdmatrix *x_im=CreateMatrix_lf(nrows, ncols);
- for (_i=nrows*ncols-1; _i>=0; _i--)
- x_im->M[_i] = 0.0;
- return(x_im);
-}
-TSdmatrix *CreateIdentity_lf(int nrows, int ncols) {
- int _i;
- TSdmatrix *x_im=CreateMatrix_lf(nrows, ncols);
- for (_i=nrows*ncols-1; _i>=0; _i--)
- x_im->M[_i] = 0.0;
- if (nrows<=ncols)
- for (_i=square(nrows)-1; _i>=0; _i -= nrows+1)
- x_im->M[_i] = 1.0;
- else
- for (_i=(ncols-1)*(nrows+1); _i>=0; _i -= nrows+1)
- x_im->M[_i] = 1.0;
- return(x_im);
-}
-/**/
-
-
-
-/**
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-void permute_matrix(double *a, int n, int *indx) {
- double *b;
- int nn=n*n;
- register int i;
- b = calloc(nn,sizeof(double));
- memcpy(b, a, nn*sizeof(double));
- for (i=0; i<nn; i++, a++)
- *a = b[indx[i%n]+indx[i/n]*n];
-}
-
-int main() {
- double a[9]={1,2,3,4,5,6,7,8,9};
- int indx[3]={1,2,0};
- permute_matrix(a,3,indx);
- return 0;
-}
-/**/
diff --git a/matlab/swz/c-code/utilities/TZCcode/mathlib.h b/matlab/swz/c-code/utilities/TZCcode/mathlib.h
deleted file mode 100644
index 4db819580b18d7fe7dce0d5fe5b0af34776f54c5..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/mathlib.h
+++ /dev/null
@@ -1,395 +0,0 @@
-#ifndef __MATHLIB_H__
-#define __MATHLIB_H__
- #include "tzmatlab.h"
- #include "fn_filesetup.h" //Used to call WriteMatrix(FPTR_DEBUG,....).
-
- //------------------------------------------------------
- // LAPACK routines -- all based on Intel MKL (or IMSL C Math library).
- //------------------------------------------------------
- int lurgen(TSdmatrix *lu_dm, TSivector *pivot_dv, TSdmatrix *x_dm);
- int eigrsym(TSdvector *eval_dv, TSdmatrix *eVec_dm, const TSdmatrix *S_dm);
- int invrtri(TSdmatrix *X_dm, TSdmatrix *A_dm, const char un);
- //The fastest way is to let X=A and A (and X) will be replaced by inv(A).
- int invspd(TSdmatrix *X_dm, TSdmatrix *A_dm, const char ul);
- //Inverse of a symmetric positive matrix A.
- //Fastest way: let X=A. Then, A (and X) will be replaced by inv(A).
- int invrgen(TSdmatrix *X_dm, TSdmatrix *A_dm);
- //Inverse of a general real matrix A.
- //If X=A, A (and X) will be replaced by inv(A).
- int eigrgen(TSdzvector *vals_dzv, TSdzmatrix *rights_dzm, TSdzmatrix *lefts_dzm, const TSdmatrix *x_dm);
- int chol(TSdmatrix *D_dm, TSdmatrix *S_dm, const char ul);
- // The fastest way for chol() is to let D = S, but D will be replaced by the Choleski factor.
- int BdivA_rrect(TSdmatrix *X_dm, const TSdmatrix *B_dm, const char lr, const TSdmatrix *A_dm);
- int BdivA_rgens(TSdmatrix *X_dm, const TSdmatrix *B_dm, const char lr, const TSdmatrix *A_dm);
- int bdivA_rgens(TSdvector *x_dv, const TSdvector *b_dv, const char lr, const TSdmatrix *A_dm);
- //If x_dv->v = b_dv->v. Then, x_dv->v will be replaced by new values.
- // x = A\b or b/A if lr='\\' or lr='/' where A is a real general square matrix.
- void Aldivb_spd(TSdvector *x_dv, TSdmatrix *A_dm, TSdvector *b_dv, char an);
- // Fastest way is to let x_dv->v = b_dv->v. Then, x_dv->v will be replaced by new values.
- double detspd(TSdmatrix *S_dm);
- //Determinant of symmetric positive definite (SPD) matrix must be positive.
- //We set the return value to be -1 if this matrix is NOT SPD.
- double logdetspd(TSdmatrix *S_dm);
- //Determinant of symmetric positive definite (SPD) matrix must be positive.
- //We set the return value to be log(-1.0) (becomeing NaN) if this matrix is NOT SPD.
- double logdeterminant(TSdmatrix *A_dm);
- //
- //void eig_rgen_all(double *eval_v, double *evec_m, const double *x_m, const int _n);
- int chol_decomp(double *D, const double *x_m, const int _n, const char ul);
- int eigrgen_decomp(double *evalr_v, double *evali_v, double *revecr_m, double *reveci_m, double *levecr_m, double *leveci_m, const double *x_m, const int _n);
- int eigrsym_decomp(double *eval_v, double *evec_m, const double *s_m, const int _n, const char ul);
- int inv_spd(double *D, const double *s_m, const int _n, const char ul);
-
-
-
- //------------------------------------------------------
- // BLAS routines -- all based on Intel MKL (or IMSL C Math library).
- //------------------------------------------------------
- double VectorDotVector(TSdvector *x1_dv, TSdvector *x2_dv);
- //Output: Return sum(x1[i] * x2[i]) over i=1, ..., n.
- // Allows the case x1_dv = x2_dv.
- void ScalarTimesVectorUpdate(TSdvector *x2_dv, const double _alpha, TSdvector *x1_dv);
- //Output: x2 = alpha * x1 + x2;
- //Inputs:
- // alpha: a double scalar;
- // x1: n-by-1 double vector.
- void ScalarTimesVector(TSdvector *x_dv, const double _alpha, TSdvector *a_dv, const double _beta);
- //Output: x_dv = alpha*a_dv + beta*x_dv where x_dv is n-by-1.
- // When beta=0.0 and x_dv->v = a_dv->v, x_dv->v will be replaced by new values.
- //Inputs:
- // a_dv: n-by-1.
- // _alpha: a double scalar.
- // _beta: a double scalar.
- void VectorPlusMinusVectorUpdate(TSdvector *x_dv, const TSdvector *b_dv, double _alpha);
- //Output: x_dv = _alpha * b_dv + x_dv where x_dv is _n-by-1.
- //Inputs:
- // b_dv: _n-by-1 double vector.
- // _alpha: double scalar.
- void VectorPlusMinusVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv, double _alpha);
- //???????? Use tz_VectorPlusMinusVector() or VectorPlusVector() or VectorMinusVector().
- //???????? NOT finished yet.
- //????????Must add _beta for x_dv = alpha*a_dv + beta*b_dv.
- //??????????? NOT fully tested yet.
- //Output: x_dv = a_dv + _alpha * b_dv where x_dv is _n-by-1.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- // _alpha: double scalar.
- void VectorTimesSelf(TSdmatrix *C_dm, const TSdvector *a_dv, const double _alpha, const double _beta, const char ul);
- //Using MKL with a default to my own C code.
- //Output is the matrix C and all other arguments are inputs.
- //Computes C = alpah*a*a' + beta*C where
- // a is m-by-1,
- // C is m-by-m symmetric matrix,
- // alpha: a double scalar,
- // beta: a double scalar.
- // ul: if=='u' or 'U', only the upper triangular part of C is to be referenced; otherwise, only the lower triangular part of C is to be referenced;
- void VectorTimesVector(TSdmatrix *C_dm, const TSdvector *a_dv, const TSdvector *b_dv, const double _alpha, const double _beta);
- //?????? NOT tested for _beta != 1.0.
- //Output is the matrix C and all other arguments are inputs.
- //If beta != 0, always converting C (if symmetric or trianuglar) to a general matrix before the operation.
- //The fastest way is to let _beta = 1.0.
- //Computes C = alpah*a*b' + beta*C where
- // a is m-by-1,
- // b is n-by-1,
- // C is m-by-n general matrix,
- // alpha: a double scalar,
- // beta: a double scalar.
- void MatrixPlusMinusMatrixUpdate(TSdmatrix *X_dm, TSdmatrix *A_dm, double _alpha);
- //$$$$$ If A_dm or X_dm is only upper or lower symmetric, it will be always converted to a general (and symmetric) matrix. $$$$$$
- //Output: X =_alpha * A + X where X_dm is an m-by-n general (and possibly symmetric) matrix.
- //Inputs:
- // A_dm: m-by-n general or symmetric matrix.
- // _alpha: double scalar.
- void MatrixTimesVector(TSdvector *x_dv, TSdmatrix *A_dm, const TSdvector *b_dv, const double _alpha, const double _beta, const char tn);
- //????? This is NOT checked yet: If x_dv = b_dv, x_dv or b_dv will be relaced by alpha*A*x + beta*x.
- //Output: x_dv->v = _alpha*A_dm'*b_dv + _beta*x_dv for tn=='T'; x_dv = _alpha*A_dm*b_dv + _beta*x_dv for tn=='N'
- // where x_dv->v is ncols-by-1 or nrows-by-1 and needs not be initialized if _beta is set to 0.0.
- //Inputs:
- // A_dm->M: nrows-by-ncols;
- // b_dv->v: nrows-by-1 or ncols-by-1;
- // _alpha: double scalar;
- // _beta: double scalar;
- // tn: if =='t' or 'T', transpose of A_dm is used; otherwise, A_dm itself (no transpose) is used.
- void TrimatrixTimesVector(TSdvector *x_dv, TSdmatrix *A_dm, TSdvector *b_dv, const char tn, const char un);
- //Output: x_dv = A_dm'*b_dv for tn=='T'; x_dv = A_dm*b_dv for tn=='N' where x_dv->v is _n-by-1.
- // If x_dv = b_dv (which gives the fastest return, so try to use this option), x_dv will be relaced by A*b or A'*b.
- //Inputs:
- // A_dm->M: _n-by-_n triangular matrix.
- // b_dv->v: _n-by-1 vector.
- // tn: if =='T' or 't', transpose of A_dm is used; otherwise, A_dm itself (no transpose) is used.
- // un: if =='U' or 'u', A_dm is unit triangular; otherwise, A_dm is non-unit triangular (i.e., a regular triangular matrix).
- void SymmatrixTimesVector(TSdvector *x_dv, TSdmatrix *A_dm, TSdvector *b_dv, const double _alpha, const double _beta);
- //????? This is NOT checked yet: If x_dv = b_dv, x_dv or b_dv will be relaced by alpha*A*x + beta*x.
- //Output:
- // x_dv = alpha*A_dm*b_dv + beta*x_dv where x_dv->v is _n-by-1.
- // When beta=0, there is no need to initialize the value of x_dv.
- //Inputs:
- // A_dm->M: _n-by-_n triangular matrix.
- // b_dv->v: _n-by-1 vector.
- // _alpha: double scalar;
- // _beta: double scalar;
- void VectorTimesMatrix(TSdvector *x_dv, const TSdvector *b_dv, TSdmatrix *A_dm, const double _alpha, const double _beta, const char tn);
- //Output: x_dv->v = _alpha*b_dv*A_dm + _beta*x_dv for tn=='N'; x_dv = _alpha*b_dv*A_dm' + _beta*x_dv for tn=='T'
- // where x_dv->v is 1-by-ncols or 1-by-nrows and needs not be initialized if _beta is set to 0.0.
- //Inputs:
- // A_dm->M: nrows-by-ncols;
- // b_dv->v: 1-by-nrows or 1-by-ncols;
- // _alpha: double scalar;
- // _beta: double scalar;
- // tn: if =='T' or 't', transpose of A_dm is used; otherwise (=='N' or 'n'), A_dm itself (no transpose) is used.
- void ScalarTimesMatrix(TSdmatrix *x_dm, const double _alpha, TSdmatrix *a_dm, const double _beta);
- //$$$$$ If a_dm or x_dm (when _beta!=0) is only upper or lower symmetric, it will be always converted to a general (and symmetric) matrix. $$$$$$
- //Output: x_dm = alpha*a_dm + beta*x_dm where x_dm is m-by-n.
- // Fastest way is to let beta=0.0 and x_dm->M = a_dm->M. Then x_dm->M will be replaced by new values.
- // However, with beta=0.0, x_dm and a_dm can be different.
- //Inputs:
- // a_dm: m-by-n.
- // _alpha: a double scalar.
- // _beta: a double scalar.
- void ScalarTimesMatrixSquare(TSdmatrix *B_dm, const double _alpha, TSdmatrix *A_dm, const char tn, const double _beta);
- //Outputs:
- // B = alpha*o(A) + beta*B, where o(A) = A' if tn=='T' or 't' or A if tn=='N' or 'n'.
- // If A=B, then A is replaced by alpha*o(A) + beta*A.
- //Inputs:
- // A_dm: n-by-n square matrix.
- // B_dm: n-by-n square matrix.
- // tn: 'T' (transpose of A) or 'N' (no transpose).
- // alpha, beta: double scalars.
- void MatrixTimesSelf(TSdmatrix *C_dm, const char ul, TSdmatrix *A_dm, const char tn, const double _alpha, const double _beta);
- //If tn=='N' or 'n', C = alpha*A*A' + beta*C.
- //If tn=='T' or 't', C = alpha*A'*A + beta*C.
- //If ul=='U' or 'u', C_dm->flag = M_SU;
- //If ul=='L' or 'l', C_dm->flag = M_SL;
- // C must be different from A.
- // C is n-by-n;
- // A is n-by-k if tn=='N';
- // k-by-n if tn=='T';
- // alpha is a double scalar,
- // beta is a double scalar.
- void MatrixTimesMatrix(TSdmatrix *C_dm, TSdmatrix *A_dm, TSdmatrix *B_dm, const double _alpha, const double _beta, const char tn1, const char tn2);
- //Output is C and all other arguments are inputs.
- //Computes C = alpah*op(A)*op(B) + beta*C where op() is either transpose or not, depending on 't' or 'n',
- // op(A) is m-by-k,
- // op(B) is k-by-n,
- // C is m-by-n,
- // C must be different from A and from B.
- // A and B can be the same, however.
- // alpha is a double scalar,
- // beta is a double scalar.
- // tn1: if == 'T' or 't', the transpose of A is used; otherwise (== 'N' or 'n"), A itself (no transpose) is used.
- // tn2: if == 'T' or 't', the transpose of B is used; otherwise (== 'N' or 'n"), B itself (no transpose) is used.
- void SolveTriSysVector(TSdvector *x_dv, const TSdmatrix *T_dm, TSdvector *b_dv, const char tn, const char un);
- //Output --- computes x_dv = inv(T_dm)*b_dv by solving a triangular system of equation T_dm * x_dv = b_dv.
- // x_dv(_n-by-1) = inv(T_dm)*b_v if tn=='N'; = inv(T_dm')*b_v if tn=='T'.
- // Fastest way is to let x_dv->v = b_dv->v. Then, x_dv->v will be replaced by new values.
-
-
-
-
-// #define ScalarTimesVector(x_v, a, b_v, _n) cblas_daxpy(_n, a, b_v, 1, x_v, 1)
-// //Output: x_v = a * b_v + x_v where double *x_v (_n-by-1) must be initialized.
-// //Inputs: a -- double scalar; b_v -- pointer (_n-by-1) to double.
-// #define VectorDotVector(a_v, b_v, _n) cblas_ddot(_n, a_v, 1, b_v, 1)
-// //Output: x=a_v'*b_v: double scalar.
-// //Inputs: a_v, b_v: pointer (_n-by-1) to double.
-
- void SymmetricMatrixTimesVector(double *x_v, const double a, const double *A_m, const double *a_v, const double b, const int _n, const char ul);
- //Output: x_v = a*A_m*a_v + b*X_m where x_v (_n-by-1) must be allocated (but needs not be initialized).
- //Inputs:
- // A_m: _n-by-_n symmetric matrix;
- // a_v: _n-by-1;
- // a, b: scalars;
- // ul: if =='u' or 'U', upper triangular elements in A_m are filled; if =='l' or 'L', lower triangular elements in A_m are filled.
- void SolveTriangularSystemVector(double *x_v, const double *A_m, const double *b_v, const int _n, const char ul, const char tn, const char un);
- //Outputs:
- // x_v(_n-by-1) = inv(A_m)*b_v. If x_v=b_v, b_v will be overwritten by x_v.
- //-------
- //Inputs:
- // A_m: _n-by-_n upper or lower triangular matrix;
- // b_v: _n-by-1 vector.
- // ul: if =='u' or 'U', A_m is upper triangular; if =='l' or 'L', A_m is lower triangular.
- // tn: if =='t' or 'T', A_m' (transpose), instead of A_m, will be used; if =='n', A_m itself (no transpose) will be used.
- // un: if =='u' or 'U', A_m is a unit upper triangular (i.e., the diagonal being 1);
- // if =='n' or 'N', A_m is a non-unit upper triangular.
- //
- // Computes x_v = inv(A_m)*b_v by solving a triangular system of equation A_m * x_v = b_v.
- // Note I: Intel MLK cblas_dtrsv() does not test for singularity or near-singulariy of the system.
- // Such tests must be performed before calling this BLAS routine.
- // Note II: if x_v=b_v, b_v will be overwritten by x_v.
-
-
-
-
-
-
- //------------------------------------------------------
- // MKL Vector Mathematical Library with default using my own routines.
- //------------------------------------------------------
- void VectorDotDivByVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv);
- //????????? NOT tested yet. 06/13/03.
- //--- The faster way is to use MKL VML with x_dv != a_dv and x_dv != b_dv; x = a./b;
- void ElementwiseVectorDivideVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv);
- //--- The faster way is to use MKL VML with y_dv != x_dv;
- void ElementwiseInverseofVector(TSdvector *y_dv, TSdvector *x_dv);
- void ElementwiseSqrtofVector(TSdvector *y_dv, TSdvector *x_dv);
- void ElementwiseLogtofVector(TSdvector *y_dv, TSdvector *x_dv);
- //--- The faster way is to use MKL VML with Y_dm != X_dm;
- void ElementwiseInverseofMatrix(TSdmatrix *Y_dm, TSdmatrix *X_dm);
-
-
-
- //------------------------------------------------------
- // Matrix routines (my own).
- //------------------------------------------------------
- void tz_VectorPlusMinusVector(TSdvector *x_dv, const TSdvector *a_dv, const double _alpha, const TSdvector *b_dv, const double _beta);
- //Output: x_dv = alpha*a_dv + beta*b_dv where x_dv is _n-by-1.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // _alpha: double constant.
- // b_dv: _n-by-1 double vector.
- // _beta: double constant.
- void VectorPlusVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv);
- //Output: x_dv = a_dv + b_dv where x_dv is _n-by-1.
- // If x_dv = a_dv, a_dv will be replaced by x_dv.
- // If x_dv = b_dv, b_dv will be replaced by x_dv,
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- void VectorMinusVector(TSdvector *x_dv, const TSdvector *a_dv, const TSdvector *b_dv);
- //Output: x_dv = a_dv - b_dv where x_dv is _n-by-1.
- // If x_dv = a_dv, x_dv will be replaced by x_dv - b_dv.
- // If x_dv = b_dv, x_dv will be replaced by a_dv - x_dv.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- void VectorPlusVectorUpdate(TSdvector *x_dv, const TSdvector *b_dv);
- //Output: x_dv = b_dv + x_dv where x_dv is _n-by-1.
- //Inputs:
- // b_dv: _n-by-1 double vector.
- void VectorDotTimesVector(TSdvector *x_dv, const TSdvector *a_dv, TSdvector *b_dv, const double _alpha, const double _beta);
- //Output:
- // x_dv is _n-by-1.
- // x_dv = _alpha * a_dv .* b_dv + _beta * x_dv if x_dv != b_dv.
- // x_dv = _alpha * a_dv .* x_dv + _beta * x_dv if x_dv = b_dv.
- //Inputs:
- // a_dv: _n-by-1 double vector.
- // b_dv: _n-by-1 double vector.
- // _alpha: double scalar.
- // _beta: a double scalar.
- void SwapColsofMatrix(TSdmatrix *X_dm, int j1, int j2);
- //??????? NOT tested yet.
- void SwapColsofMatrices(TSdmatrix *X1_dm, int j1, TSdmatrix *X2_dm, int j2);
- void SwapPositionsofMatrix(TSdmatrix *X_dm, int j1, int j2);
- void SwapMatricesofCell(TSdcell *A_dc, int c1, int c2);
- void SwapVectorsofCellvec(TSdcellvec *x_dcv, int c1, int c2);
- void SwapVectorsofCellvec_int(TSicellvec *x_icv, int c1, int c2);
- void PermuteColsofMatrix(TSdmatrix *A_dm, const TSivector *indx_iv);
- void PermuteRowsofMatrix(TSdmatrix *A_dm, const TSivector *indx_iv);
- void PermuteMatrix(TSdmatrix *A_dm, const TSivector *indx_iv);
- void PermuteMatricesofCell(TSdcell *A_dc, const TSivector *indx_iv);
- void ScalarTimesColofMatrix(TSdvector *y_dv, double _alpha, TSdmatrix *x_dm, int _j);
- //????????? Default option, in the #else, has NOT been tested yet!
- void ScalarTimesColofMatrix2ColofMatrix(TSdmatrix *y_dm, int jy, double _alpha, TSdmatrix *x_dm, int jx);
- void ScalarTimesColofMatrixPlusVector2ColofMatrix(TSdmatrix *Y_dm, int jy, double _alpha, TSdmatrix *X_dm, int jx, double _beta, TSdvector *x_dv);
-// void ColofMatrixDotTimesVector(TSdvector *y_dv, TSdmatrix *X_dm, int jx, TSdvector *x_dv, double _alpha, double _beta);
- void MatrixDotDivideVector_row(TSdmatrix *Y_dm, TSdmatrix *X_dm, TSdvector *x_dv, double _alpha, double _beta);
- void RowofMatrixDotDivideVector(TSdvector *y_dv, TSdmatrix *X_dm, int ix, TSdvector *x_dv, double _alpha, double _beta);
- //??????? NOT tested yet, 01/02/04.
- void ColofMatrixDotTimesVector(TSdvector *y_dv, TSdmatrix *X_dm, int jx, TSdvector *x_dv, double _alpha, double _beta);
- void ColofMatrixDotTimesColofMatrix(TSdvector *y_dv, TSdmatrix *X1_dm, int jx1, TSdmatrix *X2_dm, int jx2, double _alpha, double _beta);
- void ColofMatrixDotTimesColofMatrix2ColofMatrix(TSdmatrix *Y_dm, int jy, TSdmatrix *X1_dm, int jx1, TSdmatrix *X2_dm, int jx2, double _alpha, double _beta);
- void MatrixPlusMatrixUpdate(TSdmatrix *X_dm, TSdmatrix *A_dm);
- //Output: X = X + A where X_dm is an m-by-n general matrix.
- //Inputs:
- // A_dm: m-by-n general matrix.
- void MatrixPlusMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm);
- //Output: X = A + B where X_dm is an m-by-n general matrix.
- // If X=A, A will be replaced by X; if X=B, B will be replaced by X.
- //Inputs:
- // A_dm: m-by-n general matrix.
- // B_dm: m-by-n general matrix.
- void MatrixMinusMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm);
- //Output: X = A - B where X_dm is an m-by-n general matrix.
- // If X=A, A will be replaced by X; if X=B, B will be replaced by X.
- //Inputs:
- // A_dm: m-by-n general matrix.
- // B_dm: m-by-n general matrix.
- void Matrix2PlusMinusMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm, TSdmatrix *C_dm, const double _alpha, const double _beta, const double _gamma);
- //????? Not yet exhaust all possibilities of alpha, beta, and gamma to get most efficiency. Add more as required. 10 February 2003.
- //Output: X = alpha*A + beta*B + gamma*C where X_dm is an m-by-n general matrix.
- //Inputs:
- // A_dm: m-by-n general matrix.
- // B_dm: m-by-n general matrix.
- // C_dm: m-by-n general matrix.
- // _alpha: a double scalar for A_dm.
- // _beta: a double scalar for B_dm.
- // _gamma: a double scalar for C_dm.
- void MatrixPlusConstantDiagUpdate(TSdmatrix *X_dm, const double _alpha);
- //Output: X = X + diag([_alpha, ..., _alpha]) where X is an n-by-n square real matrix.
- void MatrixDotTimesMatrix(TSdmatrix *X_dm, TSdmatrix *A_dm, TSdmatrix *B_dm, const double _alpha, const double _beta);
- //$$$$$ If A_dm or B_dm or X_dm (when _beta!=0) is only upper or lower symmetric, it will be always converted to a general (and symmetric) matrix. $$$$$$
- //Output:
- // X_dm is m-by-n.
- // X_dm = _alpha * A_dm .* B_dm + _beta * X_dm if X_dm != B_dm.
- // X_dm = _alpha * A_dm .* X_dm + _beta * X_dm if X_dm = B_dm.
- void CopyVector0(TSdvector *x1_dv, const TSdvector *x2_dv);
- void CopyMatrix0(TSdmatrix *x1_dm, TSdmatrix *x2_dm);
- void CopyCellvec0(TSdcellvec *x1_dcv, TSdcellvec *x2_dcv);
- void CopyCell0(TSdcell *x1_dc, TSdcell *x2_dc);
- void CopySubmatrix0(TSdmatrix *x1_dm, TSdmatrix *x2_dm, const int br, const int bc, const int nrs, const int ncs);
- void CopySubmatrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs);
- void CopySubrowmatrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs);
- //??????? NOT tested yet.
- void CopySubmatrix2rowmatrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs);
- void CopySubrowmatrix2matrix(TSdmatrix *x1_dm, const int br1, const int bc1, TSdmatrix *x2_dm, const int br2, const int bc2, const int nrs, const int ncs);
- //??????? NOT tested yet.
- void CopySubvector(TSdvector *x1_dv, const int ptrloc1, const TSdvector *x2_dv, const int ptrloc2, const int nels);
- void CopySubvector_int(TSivector *x1_iv, const int ptrloc1, const TSivector *x2_iv, const int ptrloc2, const int nels);
- void CopySubmatrix2vector(TSdvector *x1_dv, const int ptrloc1, TSdmatrix *x2_dm, const int br, const int bc, const int nels);
- void CopySubmatrix2vector_sub(TSdvector *x1_dv, const int ptrloc1, TSdmatrix *x2_dm, const int br, const int bc, const int nrs, const int ncs);
- void CopySubmatrix2vector_int(TSivector *x1_iv, const int ptrloc1, TSimatrix *x2_im, const int br, const int bc, const int nels);
- void CopySubmatrix2vector_row(TSdvector *x1_dv, const int ptrloc1, TSdmatrix *x2_dm, const int br, const int bc, const int nels);
- void CopySubvector2matrix(TSdmatrix *x1_dm, const int br, const int bc, const TSdvector *x2_dv, const int ptrloc2, const int nels);
- void CopySubvector2rowmatrix(TSdmatrix *x1_dm, const int br, const int bc, const TSdvector *x2_dv, const int ptrloc2, const int nels);
- void CopySubvector2matrix_sub(TSdmatrix *x1_dm, const int br, const int bc, const int nrs, const int ncs, TSdvector *x2_dv, const int ptrloc2);
- void CopySubvector2matrix_unr(TSdmatrix *x1_dm, const int br, const int bc, const TSdvector *x2_dv, const int ptrloc2, const int nels);
- void TransposeSquare(TSdmatrix *B_dm, TSdmatrix *A_dm);
- //???????? Some options are NOT test yet. 2/27/03. ???????????
- void TransposeRegular(TSdmatrix *B_dm, const TSdmatrix *A_dm);
- TSdmatrix *tz_TransposeRegular(TSdmatrix *B_dm, const TSdmatrix *A_dm);
- void SUtoGE(TSdmatrix *x_dm);
- //Output: x_dm (nrows<=ncols) becomes a general matrix in addition to being upper symmetric.
- //Input: x_dm (nrows<=ncols) is upper symmetric.
- void SLtoGE(TSdmatrix *x_dm);
- //Output: x_dm (nrows>=ncols) becomes a general matrix in addition to being lower symmetric.
- //Input: x_dm (nrows>=ncols) is lower symmetric.
- double SumVector(TSdvector *x_dv);
- double MaxVector(TSdvector *x_dv);
- double MinVector(TSdvector *x_dv);
- int MaxVector_int(TSivector *x_iv);
- void SumMatrix(TSdvector *x_dv, const TSdmatrix *X_dm, const char rc);
- //+
- void diagdv(TSdvector *x_dv, TSdmatrix *x_dm);
- TSdmatrix *tz_DiagMatrix(TSdmatrix *X_dm, TSdvector *x_dv);
- double tracefabs(TSdmatrix *x_dm);
- double tracelogfabs(TSdmatrix *x_dm);
- double tracelog(TSdmatrix *x_dm);
- double sumoflogvector(TSdvector *x_dv);
- //
- TSdmatrix *tz_kron(TSdmatrix *C_dm, TSdmatrix *A_dm, TSdmatrix *B_dm);
- //C = kron(A, B), compatible with Matlab notation.
- //Inputs:
- // A_dm and B_dm: two real general matrices.
- //Outputs:
- // If C_dm == NULL, C_dm is created (memory allocated) and returned (thus, the memory must be destroyed outside this function).
- // If C_dm != NULL, C_dm's memory has already been allocated outside this function and the same C_dm will be returned.
-
-
-
-
- //=== Self-written routines.
- void ergodicp(TSdvector *p_dv, TSdmatrix *P_dm);
- //double *fn_ergodp2(const double *cp_m, const int _n);
- double *alloc_ergodp2(const double *cp_m, const int _n);
-#endif
diff --git a/matlab/swz/c-code/utilities/TZCcode/optpackage.c b/matlab/swz/c-code/utilities/TZCcode/optpackage.c
deleted file mode 100644
index d8e6aa729f8afdde78e78fff2625cdbb2537f09f..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/optpackage.c
+++ /dev/null
@@ -1,1108 +0,0 @@
-/*=========================================================
- * Optimization package for different third-party routines, including csminwel.
- *
-=========================================================*/
-#include "optpackage.h"
-
-#define STRLEN 256
-static char filename_sp_vec_minproj[STRLEN];
-
-static struct TSetc_csminwel_tag *CreateTSetc_csminwel(FILE *fptr_input1, const int n, const int q, const int k); //Used by CreateTSminpack() only.
-static struct TSetc_csminwel_tag *DestroyTSetc_csminwel(struct TSetc_csminwel_tag *etc_csminwel_ps); //Used by DestroyTSminpack() only.
-//------- For csminwel only. -------
-static TSminpack *SetMincsminwelGlobal(TSminpack *minpack_csminwel_ps);
-static double minobj_csminwelwrap(double *x, int n, double **dummy1, int *dummy2);
-static int mingrad_csminwelwrap(double *x, int n, double *g, double **dummy1, int *dummy2);
-//------- For IMSL linearly constrainted optimization only. -------
-static double GLB_FVALMIN = NEARINFINITY; //Must be initialized to ba a very big number.
-static int GLB_DISPLAY = 1; //Print out intermediate results on screen.
-static TSdvector *XIMSL_DV = NULL; //To save the minimized value in case the IMSL quits with a higher value.
-static struct TStateModel_tag *SetModelGlobalForIMSLconlin(struct TStateModel_tag *smodel_ps);
-static void ObjFuncForModel_imslconlin(int d_x0, double *x0_p, double *fret_p);
-static void imslconlin_SetPrintFile(char *filename);
-static double opt_logOverallPosteriorKernal(struct TStateModel_tag *smodel_ps, TSdvector *xchange_dv);
-static void gradcd_imslconlin(int n, double *x, double *g);
-static double ObjFuncForModel_congrad(double *x0_p, int d_x0);
-
-
-
-////TSminpack *CreateTSminpack(TFminpackage *minfinder_func, TFminobj *minobj_func, TFmingrad *mingrad_func, TFSetPrintFile *printinterresults_func, const int n, const int package) //, const int indxAnag)
-////TSminpack *CreateTSminpack(TFminfinder *minfinder_func, TFminobj *minobj_func, TFmingrad *mingrad_func, char *filename_printout, const int n, const int package) //, const int indxAnag)
-TSminpack *CreateTSminpack(TFminobj *minobj_func, void **etc_project_pps, TFmindestroy_etcproject *etcproject_func, TFmingrad *mingrad_func, char *filename_printout, const int n, const int package)
-{
- TSminpack *minpack_ps = tzMalloc(1, TSminpack);
-
- //$$$$WARNING: Note the vector xtemp_dv->v or gtemp_dv-v itself is not allocated memory, but only the POINTER.
- //$$$$ Within the minimization routine like csminwel(), the temporary array x enters as the argument in
- //$$$$ the objective function to compare with other values. If we use minpack_ps->x_dv->v = x
- //$$$$ in a wrapper function like minobj_csminwelwrap() where x is a temporay array in csminwel(),
- //$$$$ this tempoary array (e.g., x[0] in csminwel()) within the csminwel minimization routine
- //$$$$ will be freed after the csminwel minimization is done. Consequently, minpack_ps->x_dv-v, which
- //$$$$ which was re-pointed to this tempoary array, will freed as well. Thus, no minimization results
- //$$$$ would be stored and trying to access to minpack_ps->x_dv would cause memory leak.
- //$$$$ We don't need, however, to create another temporary pointer within the objective function itself,
- //$$$$ but we must use minpack_ps->xtemp_dv for a *wrapper* function instead and at the end of
- //$$$$ minimization, minpack_ps->x_dv will have the value of minpack_ps->xtemp_dv, which is automatically
- //$$$$ taken care of by csminwel with the lines such as
- //$$$$ memcpy(xh,x[3],n*sizeof(double));
- //$$$$ where xh and minpack_ps->x_dv->v point to the same memory space.
-
-
- minpack_ps->xtemp_dv = tzMalloc(1, TSdvector);
- minpack_ps->gtemp_dv = tzMalloc(1, TSdvector);
- minpack_ps->xtemp_dv->flag = minpack_ps->gtemp_dv->flag = V_DEF; //Set the flag first but will be assigned legal values in minobj_csminwelwrap().
- minpack_ps->xtemp_dv->n = minpack_ps->gtemp_dv->n = n;
-
-
- minpack_ps->x_dv = CreateVector_lf(n);
- minpack_ps->g_dv = CreateVector_lf(n);
- minpack_ps->x0_dv = CreateVector_lf(n);
- //
- minpack_ps->etc_project_ps = (void *)*etc_project_pps;
- minpack_ps->DestroyTSetc_project = etcproject_func;
- if (etcproject_func) *etc_project_pps = NULL; //If destroy function makes this structure responsible to free memory of the passing pointer, reset this passing pointer to NULL to avoid double destroying actions and cause memory problem.
- //
- minpack_ps->etc_package_ps = NULL;
- minpack_ps->minobj = minobj_func;
- minpack_ps->mingrad = mingrad_func;
- minpack_ps->filename_printout = filename_printout;
-// minpack_ps->SetPrintFile = printinterresults_func;
-
- if ( (minpack_ps->package=package) & MIN_CSMINWEL ) {
- minpack_ps->etc_package_ps = (void *)CreateTSetc_csminwel(((struct TSetc_minproj_tag *)minpack_ps->etc_project_ps)->args_blockcsminwel_ps->fptr_input1, n, 0, 0);
-// if (minpack_ps->mingrad) fn_DisplayError(".../optpackage.c/CreateTSminpack(): Have not got time to deal with analytical gradient situation");
-// if (minpack_ps->indxAnag=indxAnag) fn_DisplayError(".../optpackage.c/CreateTSminpack(): Have not got time to deal with analytical gradient situation");
- }
- else fn_DisplayError(".../optpackage.c/CreateTSminpack(): Have not got time to specify other minimization packages than csminwel");
-
- return (minpack_ps);
-}
-//---
-TSminpack *DestroyTSminpack(TSminpack *minpack_ps)
-{
- if (minpack_ps) {
- //$$$$WARNING: Note the following vectors themselves are NOT allocated memory, but only the POINTERs. Used within the minimization problem.
- //$$$$ See minobj_csminwelwrap() as an example.
- free(minpack_ps->xtemp_dv);
- free(minpack_ps->gtemp_dv);
-
-
- DestroyVector_lf(minpack_ps->x_dv);
- DestroyVector_lf(minpack_ps->g_dv);
- DestroyVector_lf(minpack_ps->x0_dv);
- if (minpack_ps->DestroyTSetc_project) minpack_ps->DestroyTSetc_project(minpack_ps->etc_project_ps); //If destroy function is active, destroy it here; ohterwise, it will be destroyed somewhere else.
- if ( minpack_ps->package & MIN_CSMINWEL ) DestroyTSetc_csminwel((TSetc_csminwel *)minpack_ps->etc_package_ps);
-
- //===
- free(minpack_ps);
- return ((TSminpack *)NULL);
- }
- else return (minpack_ps);
-}
-
-
-
-//-----------------------------------------------------------------------
-// Unconstrained BFGS csminwel package.
-//-----------------------------------------------------------------------
-static TSetc_csminwel *CreateTSetc_csminwel(FILE *fptr_input1, const int n, const int q, const int k)
-{
- //If fptr_input1==NULL or no no values supplied when fptr_input1 != NULL, default values are taken.
-
- int _i;
- //===
- TSetc_csminwel *etc_csminwel_ps = tzMalloc(1, TSetc_csminwel);
-
- etc_csminwel_ps->_k = k;
- if (!k) {
- etc_csminwel_ps->args = (double **)NULL;
- etc_csminwel_ps->dims = (int *)NULL;
- }
- else {
- etc_csminwel_ps->dims = tzMalloc(k, int);
- etc_csminwel_ps->args = tzMalloc(k, double *);
- for (_i=k-1; _i>=0; _i--) *(etc_csminwel_ps->args + _i) = tzMalloc(q, double);
- }
-
- //=== Default values of input arguments.
- etc_csminwel_ps->Hx_dm = CreateMatrix_lf(n, n); //n-by-n inverse Hessian.
- //+
- etc_csminwel_ps->badg = 1; //1: numerical gradient will be used.
- etc_csminwel_ps->indxnumgrad_csminwel = INDXNUMGRAD_CSMINWEL; //Method of the numerical gradient.
-
- //=== Reads doubles.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== crit ==//") || fscanf(fptr_input1, " %lf ", &etc_csminwel_ps->crit) != 1 )
- etc_csminwel_ps->crit = CRIT_CSMINWEL; //Defaut for overall convergence criterion for the function value.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== ini_h_csminwel ==//") || fscanf(fptr_input1, " %lf ", &etc_csminwel_ps->ini_h_csminwel) != 1 )
- etc_csminwel_ps->ini_h_csminwel = INI_H_CSMINWEL; //Defaut
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== gradstps_csminwel ==//") || fscanf(fptr_input1, " %lf ", &etc_csminwel_ps->gradstps_csminwel) != 1 )
- etc_csminwel_ps->gradstps_csminwel = GRADSTPS_CSMINWEL; //Default for step size of the numerical gradient.
-
- //=== Reads integers.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== itmax ==//") || fscanf(fptr_input1, " %d ", &etc_csminwel_ps->itmax) != 1 )
- etc_csminwel_ps->itmax = ITMAX_CSMINWEL; //Default for maximum number of iterations.
-
-
- return (etc_csminwel_ps);
-}
-//#undef CRIT_CSMINWEL
-//#undef ITMAX_CSMINWEL
-//---
-static TSetc_csminwel *DestroyTSetc_csminwel(TSetc_csminwel *etc_csminwel_ps)
-{
- int _i;
-
- if (etc_csminwel_ps) {
- for (_i=etc_csminwel_ps->_k-1; _i>=0; _i--) tzDestroy(etc_csminwel_ps->args[_i]);
- tzDestroy(etc_csminwel_ps->args);
- tzDestroy(etc_csminwel_ps->dims);
- //---
- DestroyMatrix_lf(etc_csminwel_ps->Hx_dm);
-
- //===
- free(etc_csminwel_ps);
- return ((TSetc_csminwel *)NULL);
- }
- else return (etc_csminwel_ps);
-}
-
-
-
-/*********************************************
- * WARNING: All the following data structures are declared global because
- * (1) the minimization package takes only global variables;
- * (2) these global structures make the existing functions reusable;
- * (3) modifying the exisiting functions to keep global variables at minimum is NOT really worth the time.
-*********************************************/
-//---------------------------------
-// Begin: This wrapper function makes it conformable to the call of the csminwel package.
-//---------------------------------
-static struct TSminpack_tag *MINPACK_CSMINWEL_PS = NULL; //Minimization to find the MLE or posterior peak.
-static TSminpack *SetMincsminwelGlobal(TSminpack *minpack_csminwel_ps)
-{
- //Returns the old pointer in order to preserve the previous value.
- TSminpack *tmp_ps = MINPACK_CSMINWEL_PS;
- MINPACK_CSMINWEL_PS = minpack_csminwel_ps;
- return (tmp_ps);
-}
-static double minobj_csminwelwrap(double *x, int n, double **dummy1, int *dummy2)
-{
- if (!MINPACK_CSMINWEL_PS || !MINPACK_CSMINWEL_PS->minobj) fn_DisplayError(".../optpackage.c/minobj_csminwelwrap(): (1) MINPACK_CSMINWEL_PS must be created and (2) there exists an objective function assigned to MINPACK_CSMINWEL_PS->minobj");
- // if (MINPACK_CSMINWEL_PS->x_dv->n != n) fn_DisplayError(".../optpackage.c/minobj_csminwelwrap(): Length of passing vector must match minpack_ps->x_dv");
- MINPACK_CSMINWEL_PS->xtemp_dv->v = x;
- return (MINPACK_CSMINWEL_PS->minobj(MINPACK_CSMINWEL_PS)); //This function is specified in the main program.
-}
-//---
-static int mingrad_csminwelwrap(double *x, int n, double *g, double **dummy1, int *dummy2)
-{
- if (!MINPACK_CSMINWEL_PS || !MINPACK_CSMINWEL_PS->mingrad) fn_DisplayError(".../optpackage.c/mingrad_csminwelwrap(): (1) MINPACK_CSMINWEL_PS must be created and (2) there exists an objective function assigned to MINPACK_CSMINWEL_PS->minobj");
- // if (MINPACK_CSMINWEL_PS->x_dv->n != n) fn_DisplayError(".../optpackage.c/mingrad_csminwelwrap(): Length of passing vector must match minpack_ps->x_dv");
- MINPACK_CSMINWEL_PS->xtemp_dv->v = x;
- MINPACK_CSMINWEL_PS->gtemp_dv->v = g;
- //>>>>>>>> Inside the following function, make sure to set MINPACK_CSMINWEL_PS->etc_csminwel_ps->badg = 0; //1: numerical gradient will be used.
- MINPACK_CSMINWEL_PS->mingrad(MINPACK_CSMINWEL_PS);
- //<<<<<<<<
-
- return (0);
-}
-//---------------------------------
-// End: This wrapper function makes it conformable to the call of the csminwel package.
-//---------------------------------
-
-
-//---------------------------------------------------------------//
-//--- New ways to set up the minimization problems. 03/10/06. ---//
-//---------------------------------------------------------------//
-//------- Step 1. -------
-//===
-//=== Using blockwise csminwel minimization package.
-struct TSargs_blockcsminwel_tag *CreateTSargs_blockcsminwel(FILE *fptr_input1)
-{
- //If fptr_input1==NULL or no no values supplied when fptr_input1 != NULL, default values are taken.
-
- int nvec;
- struct TSargs_blockcsminwel_tag *args_blockcsminwel_ps = tzMalloc(1, struct TSargs_blockcsminwel_tag);
-
-
- //=== Reads doubles.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== criterion_start ==//") || fscanf(fptr_input1, " %lf ", &args_blockcsminwel_ps->criterion_start) != 1 )
- args_blockcsminwel_ps->criterion_start = 1.0e-3; //Default.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== criterion_end ==//") || fscanf(fptr_input1, " %lf ", &args_blockcsminwel_ps->criterion_end) != 1 )
- args_blockcsminwel_ps->criterion_end = 1.0e-6; //Default.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== criterion_increment ==//") || fscanf(fptr_input1, " %lf ", &args_blockcsminwel_ps->criterion_increment) != 1 )
- args_blockcsminwel_ps->criterion_increment = 0.1; //Default.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== max_iterations_increment ==//") || fscanf(fptr_input1, " %lf ", &args_blockcsminwel_ps->max_iterations_increment) != 1 )
- args_blockcsminwel_ps->max_iterations_increment = 1.5; //Default.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== ini_h_scale ==//") || fscanf(fptr_input1, " %lf ", &args_blockcsminwel_ps->ini_h_scale) != 1 )
- args_blockcsminwel_ps->ini_h_scale = 5.0e-4; //Default.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== gradstps_csminwel_const ==//") || fscanf(fptr_input1, " %lf ", &args_blockcsminwel_ps->gradstps_csminwel_const) != 1 )
- args_blockcsminwel_ps->gradstps_csminwel_const = 1.0e-4; //Default.
-
- //=== Reads integers.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== max_iterations_start ==//") || fscanf(fptr_input1, " %d ", &args_blockcsminwel_ps->max_iterations_start) != 1 )
- args_blockcsminwel_ps->max_iterations_start = 50; //Default.
- if ( !fptr_input1 || !fn_SetFilePosition(fptr_input1, "//== max_block_iterations ==//") || fscanf(fptr_input1, " %d ", &args_blockcsminwel_ps->max_block_iterations) != 1 )
- args_blockcsminwel_ps->max_block_iterations = 70; //Default.
-
- //=== Reads vectors.
- if (fptr_input1 && fn_SetFilePosition(fptr_input1, "//== gradstps_csminwel_dv ==//"))
- {
- if ( fscanf(fptr_input1, " %d ", &nvec) != 1)
- fn_DisplayError(".../fwz_comfuns.c/CreateTSinput(): check the first integer in the first row below the line //== gradstps_csminwel_dv ==// in the input data file");
- args_blockcsminwel_ps->gradstps_csminwel_dv = CreateVector_lf(nvec);
- if ( !ReadVector_lf(fptr_input1, args_blockcsminwel_ps->gradstps_csminwel_dv) )
- fn_DisplayError(".../fwz_comfuns.c/CreateTSinput(): check the data matrix or vector after the first row below the line //== gradstps_csminwel_dv ==// in the input data file");
- args_blockcsminwel_ps->gradstps_csminwel_dv->flag = V_DEF;
- }
- else //Default (hard-coded). fn_DisplayError(".../fwz_comfuns.c/CreateTSinput(): the line with //== gradstps_csminwel_dv ==// in the input data file does not exist");
- {
- args_blockcsminwel_ps->gradstps_csminwel_dv = CreateVector_lf(3);
- args_blockcsminwel_ps->gradstps_csminwel_dv->v[0] = 1.0e-02;
- args_blockcsminwel_ps->gradstps_csminwel_dv->v[1] = 1.0e-03;
- args_blockcsminwel_ps->gradstps_csminwel_dv->v[2] = 1.0e-03;
- args_blockcsminwel_ps->gradstps_csminwel_dv->flag = V_DEF;
- }
-
-
- args_blockcsminwel_ps->fptr_input1 = fptr_input1;
-
- return (args_blockcsminwel_ps);
-}
-//---
-struct TSargs_blockcsminwel_tag *DestroyTSargs_blockcsminwel(struct TSargs_blockcsminwel_tag *args_blockcsminwel)
-{
- if (args_blockcsminwel)
- {
- //===
- free(args_blockcsminwel);
- return ((struct TSargs_blockcsminwel_tag *)NULL);
- }
- else
- return (args_blockcsminwel);
-}
-//===
-//=== Sets up a project-specific structure.
-struct TSetc_minproj_tag *CreateTSetc_minproj(struct TStateModel_tag **smodel_pps, TFDestroyTStateModel *DestroyTStateModel_func,
- struct TSargs_blockcsminwel_tag **args_blockcsminwel_pps, struct TSargs_blockcsminwel_tag *(*DestroyTSargs_blockcsminwel)(struct TSargs_blockcsminwel_tag *))
-{
- struct TSetc_minproj_tag *etc_minproj_ps = tzMalloc(1, struct TSetc_minproj_tag);
-
- //=== Initialization.
- etc_minproj_ps->smodel_ps = *smodel_pps;
- etc_minproj_ps->DestroyTStateModel = DestroyTStateModel_func;
- if (DestroyTStateModel_func) *smodel_pps = (struct TStateModel_tag *)NULL;
- //If destroy function makes this structure responsible to free memory of the passing pointer, reset this passing pointer to NULL to avoid double destroying actions and cause memory problem.
- // In this case, the original pointer *smodel_pps or smodel_ps is no longer valid, while etc_minproj_ps->smodel_ps.
- // Note that we pass **smodel_pps only when we want to use DestroyTStateModel_func and let this structure take over smodel_ps.
- // In many other cases, we do not need to pass **smodel_pps, but only *smodel_ps will do.
- //+
- etc_minproj_ps->args_blockcsminwel_ps = *args_blockcsminwel_pps;
- etc_minproj_ps->DestroyTSargs_blockcsminwel = DestroyTSargs_blockcsminwel;
- if (DestroyTSargs_blockcsminwel) *args_blockcsminwel_pps = (struct TSargs_blockcsminwel_tag *)NULL;
- //If destroy function makes this structure responsible to free memory of the passing pointer, reset this passing pointer to NULL to avoid double destroying actions and cause memory problem.
-
- return (etc_minproj_ps);
-}
-//---
-struct TSetc_minproj_tag *DestroyTSetc_minproj(struct TSetc_minproj_tag *etc_minproj_ps)
-{
- if (etc_minproj_ps)
- {
- if (etc_minproj_ps->DestroyTStateModel) etc_minproj_ps->DestroyTStateModel(etc_minproj_ps->smodel_ps);
- //If destroy function is active, destroy it here; ohterwise, it will be destroyed somewhere else.
- if (etc_minproj_ps->DestroyTSargs_blockcsminwel) etc_minproj_ps->DestroyTSargs_blockcsminwel(etc_minproj_ps->args_blockcsminwel_ps);
- //If destroy function is active, destroy it here; ohterwise, it will be destroyed somewhere else.
-
- //===
- free(etc_minproj_ps);
- return ((struct TSetc_minproj_tag *)NULL);
- }
- else return (etc_minproj_ps);
-}
-//------- Step 2. -------
-//$$$$$$ 28/Oct/2007: I commented them out because it'd better left to be the user's function because of
-//$$$$$$ (1) constant-parameter case without using DW's functions;
-//$$$$$$ (2) allowing us to generate parameters randomly, which depends on the specific model.
-//$$$$$$ See lwz_est.c in D:\ZhaData\WorkDisk\LiuWZ\Project2_empirical\EstimationOct07
-//$$$$$$ or ExamplesForC.prn in D:\ZhaData\CommonFiles\C_Examples_DebugTips.
-/**
-void InitializeForMinproblem(struct TSminpack_tag *minpack_ps, char *filename_sp, TSdvector *gphi_dv, int indxStartValuesForMin)
-{
- //Outputs:
- // minpack_ps->x_dv and minpack_ps->xtemp_dv:
- // The 1st gphi_dv->n elements of x_dv are model parameters (excluding those in the transition matrices).
- // The 2nd-part or rest of the elements of x_dv are the free parameters in the transition matrices.
- //Inputs:
- // gphi_dv: model free parameters (excluding those in the transition matrices);
- // indxStartValuesForMin (corresponding to the command option /c in runprog.bat):
- // 0: continuing from the last estimated results contained in filename_sp.
- // 1: starts from the fixed values for gphi_dv, manually keyed in datainpu_setup.prn.
- // 2: randomly or arbitarily selects the initial starting values for the MLE or posterior estimate.
- FILE *fptr_sp = NULL;
- int _n, _i;
- int nqs;
- TSdvector xphi_sdv, xqs_sdv;
- TSdvector *x_dv = minpack_ps->x_dv;
- TSdvector *x0_dv = minpack_ps->x0_dv;
- //---
- struct TStateModel_tag *smodel_ps = (struct TStateModel_tag *)((struct TSetc_minproj_tag *)minpack_ps->etc_project_ps)->smodel_ps;
- int nfreempars = smodel_ps->routines->pNumberFreeParametersTheta(smodel_ps);
-
- if ( nfreempars != gphi_dv->n )
- fn_DisplayError("optpackage.c/InitializeForMinproblem(): Input vector gphi_dv must be free model parameters only");
- if ( nqs=NumberFreeParametersQ(smodel_ps) != x_dv->n - nfreempars )
- fn_DisplayError("optpackage.c/InitializeForMinproblem(): Minimization vector must have length equal to # of free model parameters plus # of free transition matrix parameters");
-
- xphi_sdv.flag = V_DEF;
- xphi_sdv.n = nfreempars;
- xphi_sdv.v = x_dv->v;
-
- xqs_sdv.flag = V_DEF;
- xqs_sdv.n = nqs;
- xqs_sdv.v = x_dv->v + xphi_sdv.n;
-
- if (indxStartValuesForMin == 1)
- {
- CopyVector0(&xphi_sdv, gphi_dv);
- ConvertQToFreeParameters(smodel_ps, xqs_sdv.v); //Waggnoer's own function for the transition matrix.
- x_dv->flag = V_DEF;
- }
- else if (!indxStartValuesForMin)
- {
- fptr_sp = tzFopen(filename_sp,"r");
- rewind(fptr_sp); //Must put the pointer at the beginning of the file.
-
- for (_n=x_dv->n, _i=0; _i<_n; _i++)
- if (fscanf(fptr_sp, " %lf ", x_dv->v+_i) != 1)
- {
- printf("Error: optpackage.c/InitializeForMinproblem() -- cannot read the number from the file %s. Check the data file", filename_sp);
- exit(EXIT_FAILURE);
- }
- x_dv->flag = V_DEF;
-
- tzFclose(fptr_sp);
- }
- else fn_DisplayError("optpackage.c/InitializeForMinproblem(): the case indxStartValuesForMin = 2 has not been programmed yet");
-
-
- //--- Initial or starting values of the parameters.
- CopyVector0(x0_dv, x_dv);
- SetupObjectiveFunction(smodel_ps, xphi_sdv.v, xqs_sdv.v, xphi_sdv.v); //Must before using PosteriorObjectiveFunction();
- minpack_ps->fret0 = minpack_ps->fret = PosteriorObjectiveFunction(xphi_sdv.v, xphi_sdv.n);
-// minpack_ps->fret0 = minpack_ps->fret = -logOverallPosteriorKernal(smodel_ps, x0_dv);
- if (minpack_ps->fret0 >= NEARINFINITY)
- {
- printf("\nFatal Error:\n");
- printf(" optpackage.c/InitializeForMinproblem(): Bad initialization. All parameters must be in the reasonable range.\n");
-// printf(" optpackage.c/InitializeForMinproblem(): Bad initialization. All parameters must be in the reasonable range.\n"
-// " Most likely, the parameters get stuck in the following line in swz2_confuns.c:\n"
-// " if ((tmpd1mPhi=1.0-fn_normalcdf(xid * (log(mt-boundthetamt_1) - logdbar))) <= 0.0) logvalue = -NEARINFINITY;\n");
-// exit(EXIT_FAILURE);
- }
-}
-/**/
-//------- Step 3. -------
-void minfinder_blockcsminwel(struct TSminpack_tag *minpack_ps, int indx_findMLE)
-{
- //Better version (November 2007)
- //Inputs:
- // indx_findMLE: 1: find MLE without a prior, 0: find posterior (with a prior).
-
- //--- Block-csminwel arguments.
- struct TSargs_blockcsminwel_tag *args_blockcsminwel_ps = ((struct TSetc_minproj_tag *)minpack_ps->etc_project_ps)->args_blockcsminwel_ps;
- //--- DW's Markov-switching structure.
- struct TStateModel_tag *smodel_ps = ((struct TSetc_minproj_tag *)minpack_ps->etc_project_ps)->smodel_ps;
- //--- TSminpack arguments.
- TSdvector *x_dv = minpack_ps->x_dv;
- TSdvector *g_dv = minpack_ps->g_dv;
- char *filename_printout = minpack_ps->filename_printout; //Printing out the intermediate results of x_dv and g_dv.
- double fret = minpack_ps->fret; //Returned value of the objective function.
- struct TSetc_csminwel_tag *etc_csminwel_ps = (TSetc_csminwel *)minpack_ps->etc_package_ps;
- //--- Blockwise arguments.
- int n1, n2;
- int _n = x_dv->n;
- double *x1_pd, *x2_pd, *g1_pd, *g2_pd;
- double fret_last, logvalue;
- TSdvector *gradstps_csminwel_dv = args_blockcsminwel_ps->gradstps_csminwel_dv;
- //--- Blockwise csminwel intput arguments.
- double criterion_start = args_blockcsminwel_ps->criterion_start;
- double criterion_end = args_blockcsminwel_ps->criterion_end;
- double criterion_increment = args_blockcsminwel_ps->criterion_increment;
- int max_iterations_start = args_blockcsminwel_ps->max_iterations_start;
- double max_iterations_increment = args_blockcsminwel_ps->max_iterations_increment;
- int max_block_iterations = args_blockcsminwel_ps->max_block_iterations;
- double ini_h_csminwel = args_blockcsminwel_ps->ini_h_scale;
- //+ Other csminwel arguments
- int iteration, total_iteration;
- int niters, fcount, retcodeh, max_niters;
- double crit;
- //=== Blockwise and overall memory creations.
- TSdmatrix *H1_dm = NULL;
- TSdmatrix *H2_dm = NULL;
- TSdmatrix *H_dm = NULL;
- //
- FILE *fptr_interesults = (FILE *)NULL; //Printing intermediate results to a file.
-
-
-
- if (!x_dv || !x_dv->flag) fn_DisplayError("swz2_comfuns.c/ minfinder_blockcsminwel(): free parameters x_dv must be initialized");
-
- n1 = NumberFreeParametersTheta(smodel_ps); //Number of free model parameters.
- n2 = NumberFreeParametersQ(smodel_ps); //Number of free transition matrix elements.
- if (_n != (n1 + n2)) fn_DisplayError("optpackage.c/minfinder_blockcsminwel(): total number of free parameters"
- " must be equal to number of free model parameters + number of free q's");
- H1_dm = CreateMatrix_lf(n1, n1);
- H2_dm = CreateMatrix_lf(n2, n2);
- H_dm = CreateMatrix_lf(_n, _n);
- //
- x1_pd = x_dv->v;
- x2_pd = x_dv->v+n1;
- g1_pd = g_dv->v;
- g2_pd = g_dv->v+n1;
-
- //---- Refreshing the parameters outside this function. TZ October 2007.
- SetupObjectiveFunction(smodel_ps, x1_pd, x2_pd, x_dv->v);
- logvalue = -( minpack_ps->fret0 = minpack_ps->fret = PosteriorObjectiveFunction(x_dv->v, x_dv->n) ); //Refreshing. logPosterirPdf. DW function.
- fprintf(FPTR_OPT, "\n=========== Beginning Blockwise and Overall csminwel Minimizations =======================\nLog Peak Value: %.16e\n", logvalue);
- fflush(FPTR_OPT);
-
-
- //======= Minimizing using csminwel =======
- //--- Set up a printout file to record x_dv and g_dv.
- csminwel_SetPrintFile(filename_printout); //Set the print-out file outputsp_mle_tag.prn.
- for (total_iteration=1, crit=criterion_start, max_niters=max_iterations_start;
- crit >= criterion_end;
- crit*=criterion_increment, max_niters=(int)(max_niters*max_iterations_increment))
- {
- for (iteration=1; iteration <= max_block_iterations; total_iteration++, iteration++)
- {
- fret_last = fret;
- //=== Minimizing the objective function w.r.t. the 1st block of parameters (model parameters).
- printf("\nMinimizing user's specific model parameters at iteration %d\n",iteration);
- InitializeDiagonalMatrix_lf(H1_dm, ini_h_csminwel);
- H1_dm->flag = M_GE | M_SU | M_SL; //Hessian is symmetric.
- //+
- SetupObjectiveFunction(smodel_ps, x1_pd, x2_pd, x_dv->v);
- GRADSTPS_CSMINWEL = gradstps_csminwel_dv->v[0];
- if (indx_findMLE)
- csminwel(MLEObjectiveFunction_csminwel, x1_pd, n1, H1_dm->M, g1_pd, NULL,
- &fret, crit, &niters, max_niters, &fcount, &retcodeh,
- (double **)NULL, (int *)NULL);
- else
- csminwel(PosteriorObjectiveFunction_csminwel, x1_pd, n1, H1_dm->M, g1_pd, NULL,
- &fret, crit, &niters, max_niters, &fcount, &retcodeh,
- (double **)NULL, (int *)NULL);
-
- ConvertFreeParametersToQ(smodel_ps,x2_pd);
- ConvertFreeParametersToTheta(smodel_ps,x1_pd);
-
- //+
- logvalue = -fret;
- fprintf(FPTR_OPT, "\n=========== Block iteration %d for block 1 at total iteration %d =======================\nLog Peak Value: %.16e\n", iteration, total_iteration, logvalue);
- fflush(FPTR_OPT);
-
-
-
- //=== Minimizing the objective function w.r.t. the 2nd block of parameters (transition matrix).
- printf("\nMinimizing transitiona matrix Q at iteration %d\n",iteration);
- InitializeDiagonalMatrix_lf(H2_dm, ini_h_csminwel);
- H2_dm->flag = M_GE | M_SU | M_SL; //Hessian is symmetric.
- //+
- SetupObjectiveFunction(smodel_ps, x2_pd, x2_pd, x_dv->v);
- GRADSTPS_CSMINWEL = gradstps_csminwel_dv->v[1];
- if (indx_findMLE)
- csminwel(MLEObjectiveFunction_csminwel, x2_pd, n2, H2_dm->M, g2_pd, NULL,
- &fret, crit, &niters, max_niters, &fcount, &retcodeh,
- (double **)NULL, (int *)NULL);
- else
- csminwel(PosteriorObjectiveFunction_csminwel, x2_pd, n2, H2_dm->M, g2_pd, NULL,
- &fret, crit, &niters, max_niters, &fcount, &retcodeh,
- (double **)NULL, (int *)NULL);
-
- ConvertFreeParametersToQ(smodel_ps,x2_pd);
- ConvertFreeParametersToTheta(smodel_ps,x1_pd);
-
- //+
- logvalue = -fret;
- fprintf(FPTR_OPT, "\n=========== Block iteration %d for block 2 at total iteration %d =======================\nLog Peak Value: %.16e\n", iteration, total_iteration, logvalue);
- fprintf(FPTR_OPT, "--------Numerical gradient---------\n");
- WriteVector(FPTR_OPT, g_dv, " %0.16e ");
- fprintf(FPTR_OPT, "--------Restarting point---------\n");
- WriteVector(FPTR_OPT, x_dv, " %0.16e ");
- fflush(FPTR_OPT);
-
-
- if (fabs(fret - fret_last) <= crit) break;
- }
-
- //=== Minimizing the overall likelihood or posterior kernel.
- logvalue = -fret;
- fprintf(FPTR_OPT,"\n\n=========== Total iteration %d ===========\n",++total_iteration);
- fprintf(FPTR_OPT,"Criterion/Max_Numer_Iterations: %le %d\n",crit,max_niters);
- fprintf(FPTR_OPT,"Log peak value before overall minimization: %.16e\n", logvalue);
- fflush(FPTR_OPT);
- //---
- InitializeDiagonalMatrix_lf(H_dm, ini_h_csminwel);
- H_dm->flag = M_GE | M_SU | M_SL; //Hessian is symmetric.
- //+
- SetupObjectiveFunction(smodel_ps, x_dv->v, x2_pd, x_dv->v);
- GRADSTPS_CSMINWEL = gradstps_csminwel_dv->v[2];
- if (indx_findMLE)
- csminwel(MLEObjectiveFunction_csminwel, x_dv->v, _n, H_dm->M, g_dv->v, NULL,
- &fret, crit, &niters, max_niters, &fcount, &retcodeh,
- (double **)NULL, (int *)NULL);
- else
- csminwel(PosteriorObjectiveFunction_csminwel, x_dv->v, _n, H_dm->M, g_dv->v, NULL,
- &fret, crit, &niters, max_niters, &fcount, &retcodeh,
- (double **)NULL, (int *)NULL);
-
-
- //---
- logvalue = -fret;
- fprintf(FPTR_OPT,"Log peak value after overall minimization: %.16e\n", logvalue);
- fprintf(FPTR_OPT, "--------Numerical gradient---------\n");
- WriteVector(FPTR_OPT, g_dv, " %0.16e ");
- fprintf(FPTR_OPT, "--------Restarting point---------\n");
- WriteVector(FPTR_OPT, x_dv, " %0.16e ");
- fflush(FPTR_OPT);
-
- //--- Write to the intermediate results file.
- if ( !(fptr_interesults = fopen(filename_printout,"w")) ) {
- printf("\n\nUnable to open the starting point data file %s in minfinder_blockcsminwel() in optpackage.c!\n", filename_printout);
- getchar();
- exit(EXIT_FAILURE);
- }
- fprintf(fptr_interesults, "========= All blocks are reported here. ========== \n");
- fprintf(fptr_interesults, "--------Numerical gradient---------\n");
- WriteVector(fptr_interesults, g_dv, " %0.16e ");
- fprintf(fptr_interesults, "--------Restarting point---------\n");
- WriteVector(fptr_interesults, x_dv, " %0.16e ");
- fflush(fptr_interesults);
- tzFclose(fptr_interesults);
-
-
- ConvertFreeParametersToQ(smodel_ps,x2_pd);
- ConvertFreeParametersToTheta(smodel_ps,x1_pd);
- }
-
- etc_csminwel_ps->niter = niters; //Number of iterations taken by csminwel.
- etc_csminwel_ps->fcount = fcount; //Number of function evaluations used by csminwel.
- etc_csminwel_ps->retcode = retcodeh; //Return code for the terminating condition.
- // 0, normal step (converged). 1, zero gradient (converged).
- // 4,2, back and forth adjustment of stepsize didn't finish.
- // 3, smallest stepsize still improves too slow. 5, largest step still improves too fast.
- // 6, no improvement found.
-
- DestroyMatrix_lf(H1_dm);
- DestroyMatrix_lf(H2_dm);
- DestroyMatrix_lf(H_dm);
-}
-
-
-//-----------------------------------------------------
-// Minimization csminwel for the constant parameter model only. 5/24/04.
-//-----------------------------------------------------
-//------- Step 2. -------
-//--- 28/Oct/07: This function has NOT been used even for the constant-parameter model.
-//--- For examples, see lwz_est.c in D:\ZhaData\WorkDisk\LiuWZ\Project2_empirical\EstimationOct07
-//--- or ExamplesForC.prn under D:\ZhaData\CommonFiles\C_Examples_DebugTips.
-/**
-void InitializeForMinproblem_const(struct TSminpack_tag *minpack_ps, char *filename_sp, TSdvector *gphi_dv, int indxStartValuesForMin)
-{
- //Outputs:
- // minpack_ps->x_dv and minpack_ps->xtemp_dv:
- // The 1st gphi_dv->n elements of x_dv are model parameters (excluding those in the transition matrices).
- // The 2nd-part or rest of the elements of x_dv are the free parameters in the transition matrices.
- //Inputs:
- // gphi_dv: model free parameters (excluding those in the transition matrices);
- // indxStartValuesForMin (corresponding to the command option /c in runprog.bat):
- // 0: continuing from the last estimated results contained in filename_sp.
- // 1: starts from the fixed values for gphi_dv, manually keyed in datainpu_setup.prn.
- // 2: randomly or arbitarily selects the initial starting values for the MLE or posterior estimate.
- FILE *fptr_sp = NULL;
- int _n, _i;
- TSdvector xphi_sdv;
- TSdvector *x_dv = minpack_ps->x_dv;
- TSdvector *x0_dv = minpack_ps->x0_dv;
- //---
- struct TStateModel_tag *smodel_ps = (struct TStateModel_tag *)((struct TSetc_minproj_tag *)minpack_ps->etc_project_ps)->smodel_ps;
- int nfreempars = smodel_ps->routines->pNumberFreeParametersTheta(smodel_ps);
-
- if ( nfreempars != gphi_dv->n )
- fn_DisplayError("optpackage.c/InitializeForMinproblem_const(): Input vector gphi_dv must be free model parameters only");
-
- xphi_sdv.flag = V_DEF;
- xphi_sdv.n = nfreempars;
- xphi_sdv.v = x_dv->v;
-
- if (indxStartValuesForMin == 1)
- {
- CopyVector0(&xphi_sdv, gphi_dv);
- x_dv->flag = V_DEF;
- }
- else if (!indxStartValuesForMin)
- {
- fptr_sp = tzFopen(filename_sp,"r");
- rewind(fptr_sp); //Must put the pointer at the beginning of the file.
-
- for (_n=x_dv->n, _i=0; _i<_n; _i++)
- if (fscanf(fptr_sp, " %lf ", x_dv->v+_i) != 1)
- {
- printf("Error: optpackage.c/InitializeForMinproblem_const() -- cannot read the number from the file %s. Check the data file", filename_sp);
- exit(EXIT_FAILURE);
- }
- x_dv->flag = V_DEF;
-
- tzFclose(fptr_sp);
- }
- else fn_DisplayError("optpackage.c/InitializeForMinproblem_const(): the case indxStartValuesForMin = 2 has not been programmed yet");
-
-
- //--- Initial or starting values of the parameters.
- CopyVector0(x0_dv, x_dv);
- //The following line does not work because minpack_ps->xtemp_ps will be used in minneglogpost_const(), which has not be initialized.
- //Use instead minpack_ps->fret0 = minpack_ps->fret = logOverallPosteriorKernal_const(smodel_ps, minpack_ps->x0_dv);
- //minpack_ps->fret0 = minpack_ps->fret = minpack_ps->minobj(minpack_ps); This will not work because
-}
-/**/
-
-//------- Step 3. -------
-void minfinder(TSminpack *minpack_ps)
-{
- TSdvector *x_dv = minpack_ps->x_dv;
- //--- For MIN_CSMINWEL only.
- TSdmatrix *Hx_dm;
- TSetc_csminwel *etc_csminwel_ps;
-
- if (minpack_ps->package & MIN_CSMINWEL) {
- if (!x_dv->flag) fn_DisplayError("optpackage.c/ minfinder(): Parameter x_dv must be initialized");
- else {
- //=== BFGS (csminwel) method.
- etc_csminwel_ps = (TSetc_csminwel *)minpack_ps->etc_package_ps;
- Hx_dm = etc_csminwel_ps->Hx_dm;
- //Alternative: Hx_dm = ((TSetc_csminwel *)minpack_ps->etc_package_ps)->Hx_dm;
- if (!Hx_dm->flag) {
- InitializeDiagonalMatrix_lf(Hx_dm, INI_H_CSMINWEL);
- Hx_dm->flag = M_GE | M_SU | M_SL; //Hessian is symmetric.
- }
- //if (minpack_ps->filename_printout) csminwel_SetPrintFile(minpack_ps->filename_printout);
- csminwel_SetPrintFile(minpack_ps->filename_printout);
- SetMincsminwelGlobal(minpack_ps);
- GRADSTPS_CSMINWEL = etc_csminwel_ps->gradstps_csminwel;
- csminwel(minobj_csminwelwrap, x_dv->v, x_dv->n, Hx_dm->M, minpack_ps->g_dv->v, minpack_ps->mingrad ? mingrad_csminwelwrap : NULL,
- &minpack_ps->fret, etc_csminwel_ps->crit, &etc_csminwel_ps->niter, etc_csminwel_ps->itmax,
- &etc_csminwel_ps->fcount, &etc_csminwel_ps->retcode, (double **)NULL, (int *)NULL);
- }
- }
- else fn_DisplayError("optpackage.c/minfinder(): (1) minpack_ps must be created and (2) I have not got time to specify other minimization packages such as ISML");
-}
-
-
-
-//-----------------------------------------------------------------------
-// Linearly-constrained IMSL minimization package.
-//-----------------------------------------------------------------------
-struct TSpackage_imslconlin_tag *CreateTSpackagae_imslconlin(const int npars_tot, const int neqs, const int ncons)
-{
- //npars_tot: total number of variables (e.g., all the model variables plus free parameters in transition matrix).
- //ncons: total number of constraints (excluding simple bounds) which include the linear equality constraints.
- //neqs: number of linear equality constrains. Thus, ncons >= neqs.
- //lh_coefs_dv: ncons*npars_tot-by-1 left-hand-side constraint cofficients with the first neqs rows dealing with equality constraints.
- //rh_constraints_dv: ncons-by-1 right-hand-side the values for all the constraints.
- //lowbounds_dv: npars_tot-by-1 simple lower bounds.
- //upperbounds_dv: npars_tot-by-1 simple upper bounds.
- //===
- struct TSpackage_imslconlin_tag *package_imslconlin_ps = tzMalloc(1, struct TSpackage_imslconlin_tag);
-
- if (neqs > ncons || npars_tot<=0)
- fn_DisplayError("CreateTSpackage_imslconlin(): make sure (1) # of equality constraints no greater than total # of constraints"
- "\t and (2) number of free parameters must be greater than 0");
- package_imslconlin_ps->npars_tot = npars_tot;
- package_imslconlin_ps->neqs = neqs;
- package_imslconlin_ps->ncons = ncons;
-
-
- if (ncons<=0)
- {
- package_imslconlin_ps->lh_coefs_dv = NULL;
- package_imslconlin_ps->rh_constraints_dv = NULL;
- }
- else
- {
- package_imslconlin_ps->lh_coefs_dv = CreateConstantVector_lf(ncons*npars_tot, 0.0);
- package_imslconlin_ps->rh_constraints_dv = CreateVector_lf(ncons);
- }
- package_imslconlin_ps->lowbounds_dv = CreateConstantVector_lf(npars_tot, -BIGREALNUMBER);
- package_imslconlin_ps->upperbounds_dv = CreateConstantVector_lf(npars_tot, BIGREALNUMBER);
- //-
- package_imslconlin_ps->xsaved_dv = CreateVector_lf(package_imslconlin_ps->npars_tot);
- XIMSL_DV = CreateVector_lf(package_imslconlin_ps->npars_tot); //Used in ObjFuncForModel_imslconlin() to save the minimized value in case the IMSL quits with a higher value.
-
- package_imslconlin_ps->crit = CRIT_IMSLCONLIN;
- package_imslconlin_ps->itmax = ITMAX_IMSLCONLIN;
-
-
- return (package_imslconlin_ps);
-}
-//---
-struct TSpackage_imslconlin_tag *DestroyTSpackagae_imslconlin(struct TSpackage_imslconlin_tag *package_imslconlin_ps)
-{
- if (package_imslconlin_ps)
- {
- DestroyVector_lf(package_imslconlin_ps->lh_coefs_dv);
- DestroyVector_lf(package_imslconlin_ps->rh_constraints_dv);
- DestroyVector_lf(package_imslconlin_ps->lowbounds_dv);
- DestroyVector_lf(package_imslconlin_ps->upperbounds_dv);
- //
- DestroyVector_lf(package_imslconlin_ps->xsaved_dv);
- DestroyVector_lf(XIMSL_DV);
-
- //===
- free(package_imslconlin_ps);
- return ((struct TSpackage_imslconlin_tag *)NULL);
- }
- else return (package_imslconlin_ps);
-}
-//-----------------------------------------------------------------------
-// Using Linearly-constrained IMSL minimization package.
-//-----------------------------------------------------------------------
-void minfinder_noblockimslconlin(struct TSpackage_imslconlin_tag *package_imslconlin_ps, struct TSminpack_tag *minpack_ps, char *filename_printout, int ntheta)
-{
- //ntheta: number of free model parameters (NOT including free transition matrix Q parameters).
- //filename_printout: the file that stores the intermediate results.
-
- //--- Model or project specific structure.
- struct TStateModel_tag *smodel_ps = ((struct TSetc_minproj_tag *)minpack_ps->etc_project_ps)->smodel_ps;
- //---
- TSdvector *x_dv = minpack_ps->x_dv;
- TSdvector *g_dv = minpack_ps->g_dv;
- double *x1_pd, *x2_pd;
- //===
- TSdvector *xguess_dv = CreateVector_lf(x_dv->n);
-
- x1_pd = x_dv->v;
- x2_pd = x_dv->v + ntheta; //In the constant parameter model, this will point to invalid,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- CopyVector0(xguess_dv, x_dv);
-
-
- //======= IMSL linearly-constrained optimization, which makes sure that the boundary condition is met.
- imslconlin_SetPrintFile(filename_printout); //Set the print-out file outputsp_min_tag.prn.
- printf("\n\n======= Starting the IMSL constrained optimization======= \n\n");
- fflush(stdout);
- //====== The following linearly-constrained minimization works well for this kind of model but has a bugger of returning a higher value of the objective function.
- CopyVector0(XIMSL_DV, x_dv); //This is absolutely necessary because once imsl_d_min_con_gen_lin() is called, x_dv will be
- // changed before ObjFuncForModel_imslconlin() is evaluated. It is possible that x_dv is changed
- // so much that bad objective is returned and thus XIMSL_DV would be bad from the start, thus
- // giving 1.eE+3000 from beginning to end.
- GLB_FVALMIN = -LogPosterior_StatesIntegratedOut(smodel_ps);
- CopyVector0(package_imslconlin_ps->xsaved_dv, XIMSL_DV);
- //+
- SetModelGlobalForIMSLconlin(smodel_ps);
- if (imsl_d_min_con_gen_lin(ObjFuncForModel_imslconlin, x_dv->n, package_imslconlin_ps->ncons, package_imslconlin_ps->neqs,
- package_imslconlin_ps->lh_coefs_dv->v,
- package_imslconlin_ps->rh_constraints_dv->v,
- package_imslconlin_ps->lowbounds_dv->v, package_imslconlin_ps->upperbounds_dv->v,
- IMSL_XGUESS, xguess_dv->v, IMSL_GRADIENT, gradcd_imslconlin,
- IMSL_MAX_FCN, package_imslconlin_ps->itmax, IMSL_OBJ, &minpack_ps->fret,
- IMSL_TOLERANCE, package_imslconlin_ps->crit, IMSL_RETURN_USER, x_dv->v, 0))
- {
- printf("\nFinished: IMSL linearly-constrained optimization is successfully finished with the value of obj. fun.: %.16e\n", minpack_ps->fret);
- }
- else printf("\nWarning: IMSL linearly-constrained optimization fails, so the results from csminwel and congramin are used.\n");
- printf("\n===Ending the IMSL constrained optimization===\n");
-
- //=== Printing out messages indicating that IMSL has bugs.
- if (minpack_ps->fret > GLB_FVALMIN)
- {
- //IMSL linearly-constrained optimization returns a higher obj. func. (a bug).
- printf("\n----------IMSL linearly-constrained minimization finished but with a higher objective function value!----------\n");
- printf("The improperly-returned value is %.10f while the lowest value of the objective function is %.16e.\n\n", minpack_ps->fret, GLB_FVALMIN);
- fflush(stdout);
- fprintf(FPTR_DEBUG, "\n----------IMSL linearly-constrained minimization finished but with a higher objective function value!----------\n");
- fprintf(FPTR_DEBUG, "The improperly-returned value is %.16e while the lowest value of the objective function is %.16e.\n\n", minpack_ps->fret, GLB_FVALMIN);
- fflush(FPTR_DEBUG);
- }
-
- ConvertFreeParametersToQ(smodel_ps,x2_pd);
- //DW's function, which takes care of the degenerate case where x2_pd points to an
- // invalid place as in the constant parameter case.
- ConvertFreeParametersToTheta(smodel_ps,x1_pd); //DW's function, which calls TZ's function. So essentially it's TZ's function.
-
- //Saved the last best results in case the IMSL quits with a bug.
- CopyVector0(package_imslconlin_ps->xsaved_dv, XIMSL_DV);
-
-
- //===
- DestroyVector_lf(xguess_dv);
-}
-//===
-static struct TStateModel_tag *SMODEL_PS = NULL; //Minimization to find the MLE or posterior peak.
-static struct TStateModel_tag *SetModelGlobalForIMSLconlin(struct TStateModel_tag *smodel_ps)
-{
- //Returns the old pointer in order to preserve the previous value.
- struct TStateModel_tag *tmp_ps = SMODEL_PS;
- SMODEL_PS = smodel_ps;
- return (tmp_ps);
-}
-static void ObjFuncForModel_imslconlin(int d_x0, double *x0_p, double *fret_p)
-{
- TSdvector x0_sdv;
- //
- FILE *fptr_startingpoint_vec = NULL;
- static int ncnt_fevals = -1;
-
- // printf("\n----- Entering the objective function. ------");
- // fflush(stdout);
- x0_sdv.v = x0_p;
- x0_sdv.n = d_x0;
- x0_sdv.flag = V_DEF;
-
- *fret_p = -opt_logOverallPosteriorKernal(SMODEL_PS, &x0_sdv);
- if ( GLB_DISPLAY) {
- printf("\nValue of objective function at the %dth evaluation: %.16e\n", ++ncnt_fevals, *fret_p);
- fflush(stdout);
- }
- if (*fret_p < GLB_FVALMIN) {
- //=== Resets GLB_FVALMIN at *fret_p and then prints the intermediate point to a file.
- fptr_startingpoint_vec = tzFopen(filename_sp_vec_minproj,"w");
- fprintf(fptr_startingpoint_vec, "================= Output from IMSC linear constrained optimization ====================\n");
- fprintf(fptr_startingpoint_vec, "IMSL: Value of objective miminization function at the %dth iteration: %.15f\n", ncnt_fevals, GLB_FVALMIN=*fret_p);
- fprintf(fptr_startingpoint_vec, "--------Restarting point---------\n");
- WriteVector(fptr_startingpoint_vec, &x0_sdv, " %0.16e ");
- CopyVector0(XIMSL_DV, &x0_sdv); //Saved in case the IMSL quits with a bug.
- //=== Must print this results because imsl_d_min_con_gen_lin() has a bug and quits with a higher value. The printed-out results in the debug file may be used for imsl_d_min_con_nonlin() to continue.
- fprintf(FPTR_DEBUG, "\nIMSL: Value of objective miminization function at the %dth iteration: %.15f\n", ncnt_fevals, GLB_FVALMIN=*fret_p);
- fprintf(FPTR_DEBUG, "--------Restarting point---------\n");
- WriteVector(FPTR_DEBUG, &x0_sdv, " %0.16e ");
- fflush(FPTR_DEBUG);
- }
-
- // printf("\n----- Leaving the objective function. ------\n");
- // fflush(stdout);
-
- tzFclose(fptr_startingpoint_vec);
-}
-//------------------------
-// Overall posterior kernal for calling Waggoner's regime-switching procedure.
-//------------------------
-static double opt_logOverallPosteriorKernal(struct TStateModel_tag *smodel_ps, TSdvector *xchange_dv)
-{
- double *x1_pd, *x2_pd;
-
- x1_pd = xchange_dv->v;
- x2_pd = xchange_dv->v + NumberFreeParametersTheta(smodel_ps);
- //Note that NumberFreeParametersTheta() is DW's function, which points to TZ's function.
- //In the constant parameter model, this will point to invalid,
- // but will be taken care of automatically by DW's function ConvertFreeParametersToQ().
-
- //======= This is a must step to refresh the value at the new point. =======
- ConvertFreeParametersToTheta(smodel_ps, x1_pd); //Waggoner's function, which calls TZ's Convertphi2*().
- ConvertFreeParametersToQ(smodel_ps, x2_pd); //Waggoner's function, which automatically takes care of the constant-parameter situition
- ThetaChanged(smodel_ps); //DW's function, which will also call my function to set a flag for refreshing everything under these new parameters.
- if (1) //Posterior function.
- return ( LogPosterior_StatesIntegratedOut(smodel_ps) ); //DW's function.
- else //Likelihood (with no prior)
- return ( LogLikelihood_StatesIntegratedOut(smodel_ps) ); //DW's function.
-}
-//---
-static void imslconlin_SetPrintFile(char *filename) {
- if (!filename) sprintf(filename_sp_vec_minproj, "outdata5imslconlin.prn"); //Default filename.
- else if (STRLEN-1 < strlen(filename)) fn_DisplayError(".../optpackage.c: the allocated length STRLEN for filename_sp_vec_minproj is too short. Must increase the string length");
- else strcpy(filename_sp_vec_minproj, filename);
-}
-//---
-static void gradcd_imslconlin(int n, double *x, double *g)
-{
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x: the vector point at which the gradient is evaluated. No change in the end although will be added or
- // substracted by dh during the function (but in the end the original value will be put back).
- // n: the dimension of g or x.
- //int _i;
- FILE *fptr_startingpoint_vec = NULL;
-
- // printf("\n=== Entering the gradient function. ===\n");
- // fflush(stdout);
- GLB_DISPLAY = 0; //This guarantees that the objective function printouts will not show when the gradient is computed.
- gradcd_gen(g, x, n, ObjFuncForModel_congrad, (double *)NULL, ObjFuncForModel_congrad(x, n));
-
- //=== Prints the intermediate gradient to a file.
- // fptr_startingpoint_vec = tzFopen(filename_sp_vec_minproj,"r");
- // fprintf(fptr_startingpoint_vec, "--------Numerical gradient---------\n");
- // for (_i=0; _i<n; _i++) fprintf(fptr_startingpoint_vec, " %0.16e ", g[_i]);
- // tzFclose(fptr_startingpoint_vec);
-
- GLB_DISPLAY = 1;
- // printf("\n=== Leaving the gradient function. ===\n");
- // fflush(stdout);
-}
-//--- For conjugate gradient minimization as well.
-static double ObjFuncForModel_congrad(double *x0_p, int d_x0)
-{
- TSdvector x0_sdv;
- x0_sdv.v = x0_p;
- x0_sdv.n = d_x0;
- x0_sdv.flag = V_DEF;
-
- return ( -opt_logOverallPosteriorKernal(SMODEL_PS, &x0_sdv) );
-}
-
-
-
-
-
-
-
-//-----------------------------------------------------------------------
-// Conjugate gradient method I minimization package.
-//-----------------------------------------------------------------------
-struct TSpackage_congrad1_tag *CreateTSpackage_congrad1(void)
-{
- //===
- struct TSpackage_congrad1_tag *package_congrad1_ps = tzMalloc(1, struct TSpackage_congrad1_tag);
-
- package_congrad1_ps->crit = CRIT_CONGRAD1;
- package_congrad1_ps->itmax = ITMAX_CONGRAD1;
-
- return (package_congrad1_ps);
-}
-//---
-struct TSpackage_congrad1_tag *DestroyTSpackage_congrad1(struct TSpackage_congrad1_tag *package_congrad1_ps)
-{
- if (package_congrad1_ps)
- {
- //===
- free(package_congrad1_ps);
- return ((struct TSpackage_congrad1_tag *)NULL);
- }
- else return (package_congrad1_ps);
-}
-
-
-/**
-static void imslconlin_gradcd(int n, double *x, double *g) {
- //Outputs:
- // g: the gradient n-by-1 g (no need to be initialized).
- //Inputs:
- // x: the vector point at which the gradient is evaluated. No change in the end although will be added or substracted by dh during the function (but in the end the original value will be put back).
- // n: the dimension of g or x.
- int _i;
-
- // printf("\n=== Entering the gradient function. ===\n");
- // fflush(stdout);
- GLB_DISPLAY = 0; //This guarantees so that the objective function printouts will not show when the gradient is computed.
- gradcd_gen(g, x, n, congrad_ObjFuncForTVBVAR, (double *)NULL, congrad_ObjFuncForTVBVAR(x, n));
- //=== Prints the intermediate gradient to a file.
- fptr_startingpoint_grad = tzFopen(filename_spgrad,"w");
- fprintf(fptr_startingpoint_grad, "--------Numerical gradient---------\n");
- for (_i=0; _i<n; _i++) fprintf(fptr_startingpoint_grad, " %0.16e ", g[_i]);
- tzFclose(fptr_startingpoint_grad);
- GLB_DISPLAY = 1;
- // printf("\n=== Leaving the gradient function. ===\n");
- // fflush(stdout);
-}
-/**/
-
-
-
-/**
- //=== Conjugate gradient method, which works too slowly but is reliable. Thus, it is used to finish it up.
- congradmin_SetPrintFile(filename_spvec);
- frprmn(x0_dv->v, x0_dv->n, &niter, &fret, congrad_ObjFuncForTVBVAR, gradcd_gen, &ftol, &itmax, (double *)NULL, (int *)NULL, (double *)NULL);
-
-
-void frprmn(double p[], int n, int *iter, double *fret,
- double (*func)(double [], int), void (*dfunc)(double [], double [], int, double (*func)(double [], int), double *, double),
- double *ftol_p, int *itmax_p, double *tol_brent_p, int *itmax_brent_p, double *grdh_p) {
- //Outputs:
- // p[0, ..., n-1]: the location of the minimum if it converges, which replaces the starting value.
- // iter: pointer to the number of iterations that were performed.
- // fret: pointer to the minimum value of the function.
- //Inputs:
- // p[0, ..., n-1]: a starting point for the minimization.
- // n: the dimension of p.
- // ftol_p: pointer to the convergence tolerance on the objective function value. Default: 1.0e-4 if NULL.
- // itmax_p: pointer to the maximum number of iterations in the main minimization program frprmn(). Default: 2000 if NULL.
- // tol_brent_p: pointer to the convergence tolerance for the line minimization in brent(). Default: 2.0e-4 if NULL.
- // itmax_brent_p: pointer to the maximum number of iterations for the line minimization in brent(). Default: 100 if NULL.
- // grdh: pointer to the user's specified step size for a numerical gradient. If NULL, dfunc() (i.e., gradcd_gen()) will select grdh automatically.
- // func(): the objective function.
- // dfunc(): the gradient function computing the numerical gradient. In the form of gradcd_gen() in cstz.c.
-
-
-//------- For csminwel only. -------
-typedef struct TSetc_congrad1_tag {
- //=== Optional input arguments, often NOT used, so we set to NULL at this point.
- double **args; //k-by-q.
- int *dims; //k-by-1;
- int _k;
-
- //=== Mandatory input arguments.
- TSdmatrix *Hx_dm; //n-by-n inverse Hessian. Output as well, when csminwel is done.
- double crit; //Overall convergence criterion for the function value.
- int itmax; //Maximum number of iterations.
-// double grdh; //Step size for the numerical gradient if no analytical gradient is available.
-
- //=== Some reported input arguments.
- double ini_h_csminwel;
- int indxnumgrad_csminwel;
- double gradstps_csminwel;
-
-
- //=== Output arguments.
- int badg; //If (badg==0), analytical gradient is used; otherwise, numerical gradient will be produced.
- int niter; //Number of iterations taken by csminwel.
- int fcount; //Number of function evaluations used by csminwel.
- int retcode; //Return code for the terminating condition.
- // 0, normal step (converged). 1, zero gradient (converged).
- // 4,2, back and forth adjustment of stepsize didn't finish.
- // 3, smallest stepsize still improves too slow. 5, largest step still improves too fast.
- // 6, no improvement found.
-} TSetc_csminwel;
-
-
-/**/
-
-
-
-/**
-//------- For IMSL multivariate linearly-constrained minimizaiton package only. -------
-typedef struct TSetc_imslconlin_tag {
- //=== Non-trivial constraint arguments, whose arrays will point to the constraints specified in the specific project minpack->etc_project_ps.
- int nvars; //Total number of free parameters for the optimaization.
- int neqs; //Number of linear equality constrains. Must be no greater than ncons.
- int ncons; //Total number of linear equality and non-equality constrains (excluding simple bounds).
- double *lh_coefs_pd; //ncons*nvars-by-1. Left-hand coefficients in the linear constrains (excluding simple bounds).
- //lh_coefs_pd stacks the neqs rows first, followed by the inequality constraints.
- //Set to NULL if ncons=0;
- double *rh_constraints_pd; //ncons-by-1. Right-hand constrains in the equality and non-equality constrains (excluding simple bounds).
- //Set to NULL if ncons=0;
-
- //=== Trivial or simple bounds.
- double *lowbounds_pd; //nvars-by-1. Simple lower bounds. If a component is unbounded, choose a very negative large value (e.g., -BIGREALNUMBER).
- double *upperbounds_pd; //nvars-by-1. Simple upper bounds. If a component is unbounded, choose a very positive large value (e.g., BIGREALNUMBER).
-
- //=== Other inputs.
- int itmax; //Maximum number of iterations.
- double crit; //Overall convergence criterion on the first-order conditions.
-} TSetc_imslconlin;
-
-
-//-----------------------------------------------------------------------
-// Linearly-constrained IMSL minimization package.
-//-----------------------------------------------------------------------
-static struct TSetc_imslconlin_tag *CreateTSetc_imslconlin(struct TSminpack_tag *minpack_psconst int nvars, const int neqs, const int ncons)
-{
- //===
- struct TSetc_imslconlin *etc_imslconlin_ps = tzMalloc(1, struct TSetc_imslconlin_tag);
-
- if (neqs.ncons) fn_DisplayErrors("optpackage.c/CreateTSetc_imslconlin: make sure # of equality constraints no greater than total # of constraints");
-
-
- return (etc_imslconlin_ps);
-}
-
-/**/
diff --git a/matlab/swz/c-code/utilities/TZCcode/optpackage.h b/matlab/swz/c-code/utilities/TZCcode/optpackage.h
deleted file mode 100644
index 8603a0318e03a68256f667581ff7f2c4fe251f85..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/optpackage.h
+++ /dev/null
@@ -1,496 +0,0 @@
-/************ 3 steps to find minimization solution. *****************
- * See details at the bottom of this file.
- * or lwz_est.c in D:\ZhaData\WorkDisk\LiuWZ\Project2_empirical\EstimationOct07
- * or ExamplesForC.prn in D:\ZhaData\CommonFiles\C_Examples_DebugTips
- *
- *
- * 1. minpack_csminwel_ps = CreateTSminpack();
- * 2. InitializeForMinproblem(minpack_csminwel_ps, ..., indxRanIniForMin);
- * //This is a local, project-specific function that initializes minpack_csminwel_ps->x_dv (note, NOT xtemp_dv)
- * // according to indxStartValuesForMin.
- * 3. minfinder(minpack_csminwel_ps);
-/*********************************************************************/
-
-
-#ifndef __OPTPACKAGE_H__
-#define __OPTPACKAGE_H__
-
-#include "tzmatlab.h"
-#include "csminwel.h"
-#include "congradmin.h"
-#include "fn_filesetup.h" //fn_SetFilePosition(), etc.
-#include "mathlib.h" //CopyVector0(), etc.
-#include "switch_opt.h" //DW's optimization routines for Markov-switching models.
-#include "cstz.h" //Used for gradcd_gen() only in the IMSL linear constrainted problem.
-
-//-------------- Attributes for selecting optimization packages. --------------
-#define MIN_DEFAULT 0 //0 or NULL: default or no minimization package.
-#define MIN_CSMINWEL 0x0001 //1: csminwel unconstrained minimization package.
-#define MIN_IMSL 0x0002 //2: IMSL unconstrained minimization package.
-#define MIN_IMSL_LNCONS 0x0004 //4: IMSL linearly constrained minimization package.
-#define MIN_IMSL_NLNCONS 0x0008 //8: IMSL nonlinearly constrained minimization package.
-#define MIN_CONGRADI 0x0010 //16: unconstrained conjugate gradient minimization method 1. Polak-Ribiere conjugate gradient method without using derivative information in performing the line minimization.
-#define MIN_CONGRADII 0x0020 //2*16=32: unconstrained conjugate gradient minimization method 2. NOT available yet! Pletcher-Reeves conjugate gradient method using derivative information in performing the line minimization.
-//#define MIN_CONGRADII 0x0040 //4*16=2^6: unconstrained conjugate gradient minimization method 2.
-//#define MIN_CONGRADII 0x0080 //8*16=2^7: unconstrained conjugate gradient minimization method 2.
-//#define MIN_CONGRADII 0x0100 //16^2=2^8: unconstrained conjugate gradient minimization method 2.
-
-
-//-------------- Minimization package: unconstrained BFGS csminwel. --------------
-//--- The following three macros will be void if the input data file specifies the values of these macros.
-//--- The following three are used for the constant-parameter model only.
-#define CRIT_CSMINWEL 1.0e-09 //1.5e-08 (for monthly TVBVAR) //Overall convergence criterion for the function value.
-#define ITMAX_CSMINWEL 100000 //Maximum number of iterations.
-#define INI_H_CSMINWEL 1.0e-005 //Initial value for the diagonal of inverse Hessian in the quasi-Newton search.
- //1.0e-05 (sometimes used for SargentWZ USinflation project I)
- //5.0e-04 (for monthly TVBAR)
-//--- The following macros are used in csminwel.c. Have not got time to make them void by input values.
-#define INDXNUMGRAD_CSMINWEL 2 //Index for choosing the numerical gradient. 1, forward difference; 2, central difference.
- //central difference method is twice as slower as forward difference.
-
-
-//-------------- Minimization package: linearly-nconstrained IMSL. --------------
-#define CRIT_IMSLCONLIN 1.0e-09 //Overall convergence criterion on the first-order conditions.
-#define ITMAX_IMSLCONLIN 100000 //Maximum number of iterations.
-
-//-------------- Minimization package: conjugate gradient method I. --------------
-#define CRIT_CONGRAD1 1.0e-09 //Overall convergence criterion on the first-order conditions.
-#define ITMAX_CONGRAD1 100000 //Maximum number of iterations.
-
-
-//struct TSminpack_tag;
-
-// extern struct TSminpack_tag *MINPACK_PS;
-
-
-//typedef void TFminfinder(struct TSminpack_tag *, const int ipackage); //If ipackage = MIN_CWMINWEL, uses csminwel; etc.
-//int n, double *x_ptr, double g_ptr); //, void *mingrad_etc_ptr);
-//typedef void TFmingrad_imsl(struct TSminpack_tag *); //NOT used yet.
-//typedef void TFmingrad(void); //int n, double *x_ptr, double g_ptr); //, void *mingrad_etc_ptr);
-
-//======================================================
-// Old way of using cwminwel. No longer used in my new code. 11/01/05.
-//======================================================
-//------- For unconstrained BFGS csminwel only. -------
-typedef struct TSetc_csminwel_tag {
- //=== Optional input arguments (originally set up by Iskander), often or no longer NOT used, so we set to NULL at this point.
- double **args; //k-by-q.
- int *dims; //k-by-1;
- int _k;
-
- //=== Mandatory input arguments.
- TSdmatrix *Hx_dm; //n-by-n inverse Hessian. Output as well, when csminwel is done.
- double crit; //Overall convergence criterion for the function value.
- int itmax; //Maximum number of iterations.
-
- //=== Some reported input arguments.
- double ini_h_csminwel;
- int indxnumgrad_csminwel;
- double gradstps_csminwel; //Step size for the numerical gradient if no analytical gradient is available.
-
-
- //=== Output arguments.
- int badg; //If (badg==0), analytical gradient is used; otherwise, numerical gradient will be produced.
- int niter; //Number of iterations taken by csminwel.
- int fcount; //Number of function evaluations used by csminwel.
- int retcode; //Return code for the terminating condition.
- // 0, normal step (converged). 1, zero gradient (converged).
- // 4,2, back and forth adjustment of stepsize didn't finish.
- // 3, smallest stepsize still improves too slow. 5, largest step still improves too fast.
- // 6, no improvement found.
-} TSetc_csminwel;
-
-
-//=============================================================
-// New ways of making optimization packages.
-//=============================================================
-typedef struct TSminpack_tag {
- //=== Input arguments.
- int package; //Minimization package or routine.
- TSdvector *x_dv; //n-by-1 of estimated parameters.
- TSdvector *g_dv; //n-by-1 of gradient. When no analytical gradient is provided, it returns the numerical one.
- //$$$$ The x_dv and g_dv are only used minfinder(). In the wrapper function like minobj_csminwelwrap(), we must
- //$$$$ use xtemp_dv and gtemp_dv to be repointed to the temporary array created in csminwel() itself. See below.
-
- TSdvector *xtemp_dv; //$$$$Used within the minimization problem.
- TSdvector *gtemp_dv; //$$$$Used within the minimization problem.
- //$$$$WARNING: Note the vector xtemp_dv->v or gtemp_dv-v itself is not allocated memory, but only the POINTER.
- //$$$$ Within the minimization routine like csminwel(), the temporary array x enters as the argument in
- //$$$$ the objective function to compare with other values. If we use minpack_ps->x_dv->v = x
- //$$$$ in a wrapper function like minobj_csminwelwrap() where x is a temporay array in csminwel(),
- //$$$$ this tempoary array (e.g., x[0] in csminwel()) within the csminwel minimization routine
- //$$$$ will be freed after the csminwel minimization is done. Consequently, minpack_ps->x_dv-v, which
- //$$$$ which was re-pointed to this tempoary array, will freed as well. Thus, no minimization results
- //$$$$ would be stored and trying to access to minpack_ps->x_dv would cause memory leak.
- //$$$$ We don't need, however, to create another temporary pointer within the objective function itself,
- //$$$$ but we must use minpack_ps->xtemp_dv for a *wrapper* function instead and at the end of
- //$$$$ minimization, minpack_ps->x_dv will have the value of minpack_ps->xtemp_dv, which is automatically
- //$$$$ taken care of by csminwel with the lines such as
- //$$$$ memcpy(xh,x[3],n*sizeof(double));
- //$$$$ where xh and minpack_ps->x_dv->v point to the same memory space.
-
- TSdvector *x0_dv; //n-by-1 of initial or starting values of the estimated parameters.
-
-
- //--- Created here. Contains csminwel arguments iter, retcodeh, etc. or those that are essential to minimization package.
- void *etc_package_ps;
-
- //--- Created outside of this structure. Including, say, csminwel input arguments such as convergence criteria
- //--- or block-wise csminwel input arguments.
- void *etc_project_ps;
- void *(*DestroyTSetc_project)(void *);
- //--- Optional.
- char *filename_printout;
-
- //--- Minimization function for objective function.
- //--- May *NOT* be needed for swithcing model because DW's switch_opt.c takes care of things.
- double (*minobj)(struct TSminpack_tag *); ////From the input argument of CreateTSminpack().
- /*** This function is used only for the constant-parameter case, NOT for DW's Markov-swtiching case. ***/
- //--- Optional: Minimization function for analytical gradient. Often NOT available.
- void (*mingrad)(struct TSminpack_tag *); //From the input argument of CreateTSminpack().
-
- //=== Output arguments.
- double fret; //Returned value of the objective function.
- double fret0; //Returned value of the objective function at the initial or starting values x0.
-
-} TSminpack;
-
-typedef double TFminobj(struct TSminpack_tag *); //int n, double *x_ptr); //, void *minobj_etc_ptr);
-typedef void TFmingrad(struct TSminpack_tag *);
-typedef void *TFmindestroy_etcproject(void *);
-typedef void TFSetPrintFile(char *);
-
-//======= Function prototypes. =======//
-TSminpack *CreateTSminpack(TFminobj *minobj_func, void **etc_project_pps, TFmindestroy_etcproject *etcproject_func, TFmingrad *mingrad_func, char *filename_printout, const int n, const int package);
-TSminpack *DestroyTSminpack(TSminpack *);
-
-
-//=== Used for the constant-parameter model.
-//--- 28/Oct/07: The function InitializeForMinproblem_const() has not been used even for the constant-parameter model.
-//--- For examples, see lwz_est.c in D:\ZhaData\WorkDisk\LiuWZ\Project2_empirical\EstimationOct07
-//--- or ExamplesForC.prn under D:\ZhaData\CommonFiles\C_Examples_DebugTips.
-//NOT used: void InitializeForMinproblem_const(struct TSminpack_tag *minpack_ps, char *filename_sp, TSdvector *gphi_dv, int indxStartValuesForMin);
-//---
-void minfinder(TSminpack *minpack_ps);
-
-
-//------------------------------------------------------------------------------//
-//---------- New ways of making optimization packages. 03/10/06. -------//
-//------------------------------------------------------------------------------//
-//================ For the csminwel minimization problem. ================//
-//=== Step 1.
-typedef struct TSargs_blockcsminwel_tag
-{
- //Arguments for blockwise minimization.
-
- //=== Within the block: sequence of convergence criteria.
- double criterion_start; //Default: 1.0e-3;
- double criterion_end; //Default: 1.0e-6;
- double criterion_increment; //Default: 0.1;
- int max_iterations_start; //Default: 50; Max # of iterations for csminwel. The starting value is small because criterion_start
- // is coarse at the start. As the convergence criterion is getting tighter, the max # of
- // iteration increases as it is multiplied by max_iterations_increment.
- double max_iterations_increment; //Default: 2.0; Used to multiply the max # of iterations in csminwel as the convergence
- // criterion tightens.
- double ini_h_scale; //Default: 5.0e-4; 1.0e-05 (sometimes used for SargentWZ USinflation project I)
- // 5.0e-04 (for monthly TVBAR)
- //=== Outside the blocks.
- int max_block_iterations; //Default: 100;
-
- //------------------------------------------------------------
- //Step size for numerical gradient only when the value of x is less than 1.0 in absolute value.
- //If abs(x)>1.0, the step size is GRADSTPS_CSMINWEL*x.
- //
- //For the time-varying-parameter model, GRADSTPS_CSMINWEL takes the values of gradstps_csminwel_dv:
- // 1st element: gradient step for the model parameters (tends to be large; the default value is 1.0e-02).
- // 2nd element: gradient step for the transition probability matrix (tends to be smaller; the default value is 1.0e-03)
- // 3rd element: gradient step for all the parameters (tends to be smaller; the default value is 1.0e-03 or 1.0e-04).
- //For the constant-parameter model:
- // GRADSTPS_CSMINWEL takes the value of gradstps_csminwel_const. The default value is 1.0e-04 (for monthly TBVAR)
- //------------------------------------------------------------
- TSdvector *gradstps_csminwel_dv; //3-by-1. For the time-varying-parameter model only.
- double gradstps_csminwel_const; //For the constant-parameter model.
-
- //--- pointer to the input data file that contains all the data on convergence, max iterations, etc.
- FILE *fptr_input1;
-} TSargs_blockcsminwel;
-struct TSargs_blockcsminwel_tag *CreateTSargs_blockcsminwel(FILE *fptr_input1);
- //If fptr_input1==NULL or no no values supplied when fptr_input1 != NULL, default values are taken.
-struct TSargs_blockcsminwel_tag *DestroyTSargs_blockcsminwel(struct TSargs_blockcsminwel_tag *args_blockcsminwel_ps);
-//+
-typedef struct TStateModel_tag *TFDestroyTStateModel(struct TStateModel_tag *);
-typedef struct TSetc_minproj_tag
-{
- //For optimization of the posterior or likelihood function.
- struct TStateModel_tag *smodel_ps;
- struct TStateModel_tag *(*DestroyTStateModel)(struct TStateModel_tag *);
- //
- struct TSargs_blockcsminwel_tag *args_blockcsminwel_ps;
- struct TSargs_blockcsminwel_tag *(*DestroyTSargs_blockcsminwel)(struct TSargs_blockcsminwel_tag *);
-} TSetc_minproj;
-//
-struct TSetc_minproj_tag *CreateTSetc_minproj(struct TStateModel_tag **smodel_pps, TFDestroyTStateModel *DestroyTStateModel_func,
- struct TSargs_blockcsminwel_tag **args_blockcsminwel_pps, struct TSargs_blockcsminwel_tag *(*DestroyTSargs_blockcsminwel)(struct TSargs_blockcsminwel_tag *));
-struct TSetc_minproj_tag *DestroyTSetc_minproj(struct TSetc_minproj_tag *);
-//And creates the following user's function.
-//static double minneglogpost(struct TSminpack_tag *minpack_ps); //For the constant-parameter only.
-//=== Step 2. Belongs to the user's responsibility because this function must be able to deal with
-// (1) constant-parameter case without using DW's functions;
-// (2) allowing us to generate parameters randomly, which depends on the specific model.
-// See lwz_est.c in D:\ZhaData\WorkDisk\LiuWZ\Project2_empirical\EstimationOct07
-// or ExamplesForC.prn in D:\ZhaData\CommonFiles\C_Examples_DebugTips.
-//---
-//void InitializeForMinproblem(struct TSminpack_tag *minpack_ps, char *filename_sp, TSdvector *gphi_dv, int indxStartValuesForMin);
-//=== Step 3.
-void minfinder_blockcsminwel(struct TSminpack_tag *minpack_ps, int indx_findMLE); //Blockwise minimization.
- //indx_findMLE: 1: find MLE without a prior, 0: find posterior (with a prior).
-
-
-
-
-//================ For IMSL multivariate linearly-constrained minimizaiton package only. ================//
-typedef struct TSpackage_imslconlin_tag
-{
- //=== Non-simple constraints.
- int npars_tot; //Total number of free parameters for the optimaization.
- //For example, model free parameters + free transition matrix parameters in the regime-switching case.
- int neqs; //Number of equality constraints, excluding simple bound constraints. Must be no greater than ncons.
- //IMSL dictates that equality constraints come always BEFORE inequality constrains.
- int ncons; //Total number of constrains, including equality and inequality constraints, but excluding simple bounds.
- TSdvector *lh_coefs_dv; //ncons*npars_tot-by-1. ALWAYS initialized to be 0.0.
- //Left-hand coefficients in the linear constrains (excluding simple bounds).
- //IMSL rule: lh_coefs_dv stacks the neqs rows of equality constraints first, followed by the inequality constraints.
- //Set to NULL if ncons=0;
- TSdvector *rh_constraints_dv; //ncons-by-1. Set to NULL if ncons=0.
- //Right-hand constraints in the equality and non-equality constrains (excluding simple bounds).
-
-
- //=== Simple bounds.
- TSdvector *lowbounds_dv; //npars_tot-by-1. ALWAYS initialized to -BIGREALNUMBER for thes simple lower bounds.
- //If a component is unbounded, choose a very negative large value (e.g., -BIGREALNUMBER).
- TSdvector *upperbounds_dv; //npars_tot-by-1. ALWAYS initialized to +BIGREALNUMBER for thes simple lower bounds.
- //If a component is unbounded, choose a very positive large value (e.g., BIGREALNUMBER).
-
- //=== Other output.
- TSdvector *xsaved_dv; //npars_tot-by-1. Saved the parameters that give the minimal value of the objective function.
-
- //=== Other inputs.
- double crit; //Overall convergence criterion on the first-order conditions.
- int itmax; //Maximum number of iterations.
-} TSpackage_imslconlin;
-//+
-struct TSpackage_imslconlin_tag *CreateTSpackagae_imslconlin(const int npars_tot, const int neqs, const int ncons);
-struct TSpackage_imslconlin_tag *DestroyTSpackagae_imslconlin(struct TSpackage_imslconlin_tag *package_imslconlin_ps);
-void minfinder_noblockimslconlin(struct TSpackage_imslconlin_tag *package_imslconlin_ps, struct TSminpack_tag *minpack_ps, char *filename_printout, int ntheta);
-
-
-
-
-
-//================ For conjugate gradient method I only. ================//
-typedef struct TSpackage_congrad1_tag
-{
- //=== Input arguments.
- double crit; //Overall convergence criterion on the function value.
- int itmax; //Maximum number of iterations.
-
- //=== Output arguments.
- int niters; //Number of iterations.
-} TSpackage_congrad1;
-//+
-struct TSpackage_congrad1_tag *CreateTSpackage_congrad1(void);
-struct TSpackage_congrad1_tag *DestroyTSpackage_congrad1(struct TSpackage_congrad1_tag *package_congrad1_ps);
-
-
-
-
-/**
-//------- For unconstrained BFGS csminwel only. -------
-typedef struct TSminpack_csminwel_tag {
- //=== Optional input arguments, often NOT used, so we set to NULL at this point.
- double **args; //k-by-q.
- int *dims; //k-by-1;
- int _k;
-
- //=== Mandatory input arguments.
- TSdmatrix *Hx_dm; //n-by-n inverse Hessian. Output as well, when csminwel is done.
- double crit; //Overall convergence criterion for the function value.
- int itmax; //Maximum number of iterations.
-// double grdh; //Step size for the numerical gradient if no analytical gradient is available.
-
- //=== Initial input arguments.
- double ini_h_csminwel;
- int indxnumgrad_csminwel;
- double gradstps_csminwel;
-
-
- //=== Output arguments.
- int badg; //If (badg==0), analytical gradient is used; otherwise, numerical gradient will be produced.
- int niter; //Number of iterations taken by csminwel.
- int fcount; //Number of function evaluations used by csminwel.
- int retcode; //Return code for the terminating condition.
- // 0, normal step (converged). 1, zero gradient (converged).
- // 4,2, back and forth adjustment of stepsize didn't finish.
- // 3, smallest stepsize still improves too slow. 5, largest step still improves too fast.
- // 6, no improvement found.
-} TSminpack_csminwel;
-/**/
-
-
-
-#endif
-
-
-/*************** 3 steps to find minimization solution. *****************
-//---------------------------------
-//-- For concrete examples, see
-//-- lwz_est.c in D:\ZhaData\WorkDisk\LiuWZ\Project2_empirical\EstimationOct07
-//-- ExamplesForC.prn in D:\ZhaData\CommonFiles\C_Examples_DebugTips
-//---------------------------------
-
-//------ For the csminwel minimization problem. -------
-//--- Step 1. Creats a number of csminwel structures for both Markov-switching and constant-parameter models.
-static double minobj(struct TSminpack_tag *minpack_ps); //This function is for the constant-parameter model only.
-//--- Step 2.
-static void InitializeForMinproblem(struct TSminpack_tag *minpack_ps, char *filename_sp);
-//--- Step 3.
-//For the constant-parameter model, run minfinder(minpack_ps); //Constant-parameter case.
-//For the regime-switching model, run minfinder_blockcsminwel(minpack_ps); //Time-varying case.
- *
- *
- *
-
-
-//=== main.c
-
-int indxInitializeTransitionMatrix;
-//--- My model structure.
-struct TSlwzmodel_tag *lwzmodel_ps = NULL;
-//--- Waggoner's Markov switching package.
-struct TMarkovStateVariable_tag *sv_ps = NULL;
-ThetaRoutines *sroutines_ps = NULL;
-struct TStateModel_tag *smodel_ps = NULL;
-//--- General (csminwel) minimization for constant-parameter.
-struct TSetc_minproj_tag *etc_minproj_ps = NULL;
-struct TSminpack_tag *minpack_ps = NULL;
-//--- Blockwise (csminwel) minimization for regime-switching model.
-struct TSargs_blockcsminwel_tag *args_blockcsminwel_ps = NULL;
-
-
-//-----------------
-// Reads from the command line the user-specified input file and the most-often-used integer arguments such as sample size.
-//-----------------
-cl_modeltag = fn_ParseCommandLine_String(n_arg,args_cl,'t',(char *)NULL); // Tag for different models.
-if (!cl_modeltag) fn_DisplayError(".../main(): No model tag is specified yet");
-//--- Type of the model: (0) const, (1) varionly, (2) trendinf, (3) policyonly, and (4) firmspolicy.
-if (!strncmp("const", cl_modeltag, 5)) indx_tvmodel = 0;
-else if (!strncmp("varionly", cl_modeltag, 5)) indx_tvmodel = 1;
-else if (!strncmp("trendinf", cl_modeltag, 5)) indx_tvmodel = 2;
-else if (!strncmp("policyonly", cl_modeltag, 5)) indx_tvmodel = 3;
-else if (!strncmp("firmspolicy", cl_modeltag, 5)) indx_tvmodel = 4;
-else fn_DisplayError("main(): the model tag is NOT properly selected");
-indxStartValuesForMin = fn_ParseCommandLine_Integer(n_arg,args_cl,'c',1);
-sprintf(filename_sp_vec_minproj, "outdatasp_min_%s.prn", cl_modeltag);
-//+
-sprintf(filenamebuffer, "dataraw.prn");
-cl_filename_rawdata = fn_ParseCommandLine_String(n_arg,args_cl,'r',filenamebuffer); //Raw data input file.
-fptr_rawdata = tzFopen(cl_filename_rawdata,"r");
-//+
-sprintf(filenamebuffer, "datainp_common.prn");
-cl_filename_input1 = fn_ParseCommandLine_String(n_arg,args_cl,'i',filenamebuffer); //Common setup input data file.
-fptr_input1 = tzFopen(cl_filename_input1,"r");
-//+
-sprintf(filenamebuffer, "datainp_%s.prn", cl_modeltag);
-cl_filename_input2 = fn_ParseCommandLine_String(n_arg,args_cl,'s',filenamebuffer); //Model-specific setupt input data file.
-fptr_input2 = tzFopen(cl_filename_input2,"r");
-//+
-sprintf(filenamebuffer, "datainp_markov_%s.prn", cl_modeltag);
-cl_filename_markov = fn_ParseCommandLine_String(n_arg,args_cl,'m',filenamebuffer); //Markov-switching setup input data file.
-fptr_markov = tzFopen(cl_filename_markov,"r");
-//--- Output data files.
-sprintf(filenamebuffer, "outdata_debug_%s.prn", cl_modeltag);
-FPTR_DEBUG = tzFopen(filenamebuffer,"w"); //Debug output file.
-//+
-sprintf(filenamebuffer, "outdataout_%s.prn", cl_modeltag);
-fptr_output = tzFopen(filenamebuffer,"w"); //Final output file.
-//+
-sprintf(filenamebuffer, "outdatainp_matlab_%s.prn", cl_modeltag);
-fptr_matlab = tzFopen(filenamebuffer, "w");
-//+
-sprintf(filenamebuffer, "outdatainp_matlab1_%s.prn", cl_modeltag);
-fptr_matlab1 = tzFopen(filenamebuffer, "w");
-//+
-sprintf(filenamebuffer, "outdatainp_matlab2_%s.prn", cl_modeltag);
-fptr_matlab2 = tzFopen(filenamebuffer, "w");
-//+
-sprintf(filenamebuffer, "outdatainp_matlab3_%s.prn", cl_modeltag);
-fptr_matlab3 = tzFopen(filenamebuffer, "w");
-
-
-//----------------------------------------------
-//--- Memory allocation and structure creation.
-//--- The order matters!
-//----------------------------------------------
-//--- Model structure. ---
-lwzmodel_ps = CreateTSlwzmodel(fptr_rawdata, fptr_input1, fptr_input2, fptr_markov, indx_tvmodel, indxStartValuesForMin);
-sprintf(lwzmodel_ps->tag_modeltype_cv->v, cl_modeltag);
-lwzmodel_ps->tag_modeltype_cv->flag = V_DEF;
-
-
-//====== Waggoner's Markov switching variables. ======
-sv_ps = CreateMarkovStateVariable_File(fptr_markov, (char *)NULL, lwzmodel_ps->fss);
- //In this case, fptr_markov points to datainp_markov_const.prn, which can be found in D:\ZhaData\CommonFiles\C_Examples_DebugTips\DW_MarkovInputFiles.
-sroutines_ps = CreateThetaRoutines_empty();
-sroutines_ps->pLogConditionalLikelihood = logTimetCondLH; //User's: logTimetCondLH
-sroutines_ps->pLogPrior = logpriordensity_usingDW; //User's: pLogPrior
-sroutines_ps->pNumberFreeParametersTheta = NumberOfFreeModelSpecificParameters; //User's: NumberOfFreeModelSpecificParameters,
-sroutines_ps->pConvertFreeParametersToTheta = ConvertFreeParameters2ModelSpecificParameters; //User's: ConvertFreeParameters2ModelSpecificParameters,
-sroutines_ps->pConvertThetaToFreeParameters = ConvertModelSpecificParameters2FreeParameters; //User's: ConvertModelSpecificParameters2FreeParameters,
-sroutines_ps->pThetaChanged = tz_thetaChanged; //User's: Notification routine (need to refresh everything given new parameters?)
-sroutines_ps->pTransitionMatrixChanged = tz_TransitionMatrixChanged; //User's: Notification routine (need to refresh everything given new parameters?)
-smodel_ps = CreateStateModel_new(sv_ps, sroutines_ps, (void *)lwzmodel_ps);
-//--- Optional.
-if (!indx_tvmodel && fn_SetFilePosition(fptr_markov, "//== indxInitializeTransitionMatrix ==//"))
- if ((fscanf(fptr_markov, " %d ", &indxInitializeTransitionMatrix) == 1) && indxInitializeTransitionMatrix)
- ReadTransitionMatrices(fptr_markov, (char*)NULL, "Initial: ", smodel_ps); //Waggoner's function.
-
-
-//--- Minimization problem: Step 1. ---
-args_blockcsminwel_ps = CreateTSargs_blockcsminwel(fptr_input1);
- //Blockwise (csminwel) minimization arguments, reading convergence criteria or using default values if fptr_input1 is set to NULL.
- //fptr_input1 contains parameters for both constant-parameter and Markov-switching models.
-etc_minproj_ps = CreateTSetc_minproj(&smodel_ps, (TFDestroyTStateModel *)NULL, &args_blockcsminwel_ps, DestroyTSargs_blockcsminwel);
- //Taking convergence criteria and my model structure smodel_ps into minpack_ps.
-minpack_ps = CreateTSminpack((TFminobj *)minobj, (void **)&etc_minproj_ps, (TFmindestroy_etcproject *)NULL, (TFmingrad *)NULL,
- filename_sp_vec_minproj,
- lwzmodel_ps->xphi_dv->n+NumberFreeParametersQ(smodel_ps),
- MIN_CSMINWEL);
- //minobj is for the constant-parameter model only in which case, NumberFreeParametersQ(smodel_ps) will be 0.
-
-
-//-----------------
-// Main matter.
-//-----------------
-time(&lwzmodel_ps->prog_begtime); //Beginning time of the whole program.
-InitializeGlobleSeed(lwzmodel_ps->randomseed = 0); //2764 If seednumber==0, a value is computed using the system clock.
-csminwel_randomseedChanged(lwzmodel_ps->randomseed); //Using the same (or different) seednumber to reset csminwel seednumber for random perturbation.
-//=== Finding the peak value of the logLH or logPosterior
-if (lwzmodel_ps->indxEstFinder)
-{
- //Minimization problem: Steps 2 and 3.
-
- InitializeForMinproblem(minpack_ps, filename_sp_vec_minproj); //Initialization for minimization.
- //======= 1st round of minimization. =======
- //--------------------------
- //-- csminwel minimization where
- //-- minpack_ps->x_dv contains the minimizing vector of parameters.
- //-- minpack_ps->fret contains the minimized value.
- //--------------------------
-
- if (!lwzmodel_ps->indx_tvmodel) minfinder(minpack_ps); //Constant-parameter case.
- else minfinder_blockcsminwel(minpack_ps); //Time-varying case.
-}
-else InitializeForMinproblem(minpack_ps, filename_sp_vec_minproj);
-time(&lwzmodel_ps->prog_endtime); //Ending time of the whole program.
-/*************************************************************************/
-
diff --git a/matlab/swz/c-code/utilities/TZCcode/tzmatlab.c b/matlab/swz/c-code/utilities/TZCcode/tzmatlab.c
deleted file mode 100644
index b6c59d424338fc495ad62d3206289156a2a849f0..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/tzmatlab.c
+++ /dev/null
@@ -1,831 +0,0 @@
-/** Example:
- #if defined (USE_DEBUG_FILE)
- fprintf(FPTR_DEBUG, "\nWARNING: .../mathlib.c/TransposeSquare(): the matrix is already both SU and SL, so there is no need to transpose.\n");
- fflush(FPTR_DEBUG);
- #else
- fprintf(stdout, "\nWARNING: .../mathlib.c/TransposeSquare(): the matrix is already both SU and SL, so there is no need to transpose.\n");
- fflush(stdout);
- #endif
-/**/
-
-
-#include "tzmatlab.h"
-
-
-FILE *FPTR_DEBUG = (FILE *)NULL; //Debug output file, to be opened by main.c.
-FILE *FPTR_OPT = (FILE *)NULL; //Optimization output file, to be opened by main.c.
-
-//-----------------
-// Some high-level functions.
-//-----------------
-int fn_locofyearqm(int q_m, int yrstart, int qmstart, int yrend, int qmend)
-{
- //Returns the (base 0) location of a specified year and month (quarter) for the time series.
- //All the other inputs take the usual (base-1) numbers, I guess 01/17/05. For example, yrstart = 1960 means the year 1960.
- int tmpi, loc;
-
- if ( q_m != 12 )
- if ( q_m != 4 ) fn_DisplayError(".../tzmatlab.c/fn_locofyearqm(): This function only works for monthly or quarterly data");
-
- if ( (tmpi=yrend - yrstart) < 0 )
- fn_DisplayError(".../cstz.c/fn_locofyearqm(): the end year must be greater than or equal to the start year");
- else if ( (loc = (tmpi==0) ? qmend-qmstart : tmpi*q_m+qmend-qmstart) < 0 )
- fn_DisplayError(".../tzmatlab.c/fn_locofyearqm(): the end month or quarter must be greater than or equal to the start month or quarter for the given year");
-
- return (loc);
-}
-
-
-
-//-----------------
-// Function to display errors.
-//-----------------
-void fn_DisplayError(char *msg_s)
-{
- #if defined (USE_DEBUG_FILE)
- fprintf(FPTR_DEBUG, "\nFatal Error:\n"
- " %s!\n", msg_s);
- fflush(FPTR_DEBUG);
- #else
- fprintf(stdout, "\nFatal Error:\n"
- "\t %s!\n", msg_s);
- fflush(stdout);
- #endif
-
- #ifdef WIN_MATLABAPI
- mexErrMsgTxt(".");
- #else
- //getchar();
- exit( EXIT_FAILURE ); // This exits the entire C program.
- #endif
-}
-
-
-//-----------------
-// Error-checking memory allocators
-//-----------------
-void *m_alloc(size_t size) {
- void *new_mem;
- if ( (new_mem = malloc(size)) == NULL ) fn_DisplayError("Out of Memory!");
- return(new_mem);
-}
-//+
-void *c_alloc(size_t elt_count, size_t elt_size) {
- void *new_mem;
- if ( (new_mem = calloc(elt_count, elt_size)) == NULL ) fn_DisplayError("Out of Memory!");
- return(new_mem);
-}
-
-
-//-----------------
-// Creat and destroy vectors, matrices, and cells.
-//-----------------
-/**
-TSvoidvector *CreateVector_void(int _n)
-{
- TSvoidvector *x_voidv = tzMalloc(1, TSvoidvector);
- x_voidv->flag = V_UNDEF;
- x_voidv->n = _n;
- x_voidv->v = tzMalloc(_n, void);
- return(x_voidv);
-}
-TSvoidvector *DestroyVector_void(TSvoidvector *x_voidv)
-{
- if (x_voidv) {
- free(x_voidv->v);
- free(x_voidv);
- return ((TSvoidvector *)NULL);
- }
- else return (x_voidv);
-}
-/**/
-
-
-TScvector *CreateVector_c(int _n)
-{
- TScvector *x_cv = tzMalloc(1, TScvector);
- x_cv->flag = V_UNDEF;
- x_cv->n = _n;
- if (_n<1) fn_DisplayError(".../tzmatlab.c/CreateVector_c(): dimension input _n must be a positive integer");
- x_cv->v = tzMalloc(_n, char);
- return( x_cv );
-}
-TScvector *DestroyVector_c(TScvector *x_cv)
-{
- if (x_cv) {
- free(x_cv->v);
- free(x_cv);
- return ((TScvector *)NULL);
- }
- else return (x_cv);
-}
-
-TSivector *CreateVector_int(int _n)
-{
- TSivector *x_iv=tzMalloc(1, TSivector);
- x_iv->flag = V_UNDEF;
- x_iv->n = _n;
- if (_n<1) fn_DisplayError(".../tzmatlab.c/CreateVector_int(): dimension input _n must be a positive integer");
- x_iv->v = tzMalloc(_n, int);
- return(x_iv);
-}
-TSivector *DestroyVector_int(TSivector *x_iv)
-{
- if (x_iv) {
- free(x_iv->v);
- free(x_iv);
- return ((TSivector *)NULL);
- }
- else return (x_iv);
-}
-
-TSimatrix *CreateMatrix_int(int nrows, int ncols)
-{
- TSimatrix *x_im=tzMalloc(1, TSimatrix);
- x_im->nrows = nrows;
- x_im->ncols = ncols;
- if (nrows<1 || ncols<1) fn_DisplayError(".../tzmatlab.c/CreateMatrix_int(): dimension inputs nrows and ncols must both be positive integers");
- x_im->M = tzMalloc(nrows*ncols, int);
- return (x_im);
-}
-TSimatrix *DestroyMatrix_int(TSimatrix *x_im)
-{
- if (x_im) {
- free(x_im->M);
- free(x_im);
- return ((TSimatrix *)NULL);
- }
- else return (x_im);
-}
-
-TSicellvec *CreateCellvec_int(TSivector *n_iv)
-{
- int _i,
- ncells;
- TSicellvec *x_icv = tzMalloc(1, TSicellvec);
-
- if (!n_iv || !n_iv->flag) fn_DisplayError(".../CreateCellvec_int( ): Dimension vector n_iv must (1) created and (2) assigned legal values");
- x_icv->ncells = ncells = n_iv->n;
- x_icv->C = tzMalloc(ncells, TSivector *);
- for (_i=ncells-1; _i>-0; _i--) *(x_icv->C + _i) = CreateVector_int(n_iv->v[_i]);
- return(x_icv);
-}
-TSicellvec *DestroyCellvec_int(TSicellvec *x_icv)
-{
- int _i;
- if (x_icv) {
- for (_i=0; _i<x_icv->ncells; _i++) DestroyVector_int(x_icv->C[_i]);
- free(x_icv->C);
- free(x_icv);
- return ((TSicellvec *)NULL);
- }
- else return (x_icv);
-}
-
-TSicell *CreateCell_int(TSivector *row_iv, TSivector *col_iv)
-{
- int _i,
- ncells;
- TSicell *x_ic=NULL;
- if (!row_iv || !col_iv || !row_iv->flag || !col_iv->flag) fn_DisplayError(".../CreateCell_int( ): Dimension vectors row_iv and col_iv must (1) created and (2) assigned legal values");
- if ((ncells = row_iv->n) != col_iv->n) fn_DisplayError(".../CreateCell_int( ): the lengths of row_iv and col_iv (i.e., numbers of cells) must be the same");
- x_ic = tzMalloc(1, TSicell);
- x_ic->ncells = ncells;
- x_ic->C = tzMalloc(ncells, TSimatrix *);
- for (_i=ncells-1; _i>=0; _i--) {
- *(x_ic->C + _i) = CreateMatrix_int(row_iv->v[_i], col_iv->v[_i]);
- }
- return(x_ic);
-}
-TSicell *DestroyCell_int(TSicell *x_ic)
-{
- int _i;
- if (x_ic) {
- for (_i=x_ic->ncells-1; _i>=0; _i--) x_ic->C[_i] = DestroyMatrix_int(x_ic->C[_i]);
- tzDestroy(x_ic->C);
- free(x_ic);
- return ((TSicell *)NULL);
- }
- else return (x_ic);
-}
-
-
-
-
-TSdvector *CreateVector_lf(int _n)
-{
- TSdvector *x_dv=tzMalloc(1, TSdvector);
- x_dv->flag = V_UNDEF;
- x_dv->n = _n;
- if (_n<1) fn_DisplayError(".../tzmatlab.c/CreateVector_lf(): dimension input _n must be a positive integers");
- x_dv->v = tzMalloc(_n, double);
- return(x_dv);
-}
-TSdvector *DestroyVector_lf(TSdvector *x_dv)
-{
- if (x_dv) {
- free(x_dv->v);
- free(x_dv);
- return ((TSdvector *)NULL);
- }
- else return (x_dv);
-}
-
-TSdmatrix *CreateMatrix_lf(int nrows, int ncols)
-{
- TSdmatrix *x_dm=tzMalloc(1, TSdmatrix);
- x_dm->flag = M_UNDEF;
- x_dm->nrows = nrows;
- x_dm->ncols = ncols;
- if (nrows<1 || ncols<1) fn_DisplayError(".../tzmatlab.c/CreateMatrix_lf(): dimension inputs nrows and ncols must both be positive integers");
- x_dm->M = tzMalloc(nrows*ncols, double);
- return(x_dm);
-}
-TSdmatrix *DestroyMatrix_lf(TSdmatrix *x_dm)
-{
- if (x_dm) {
- free(x_dm->M);
- free(x_dm);
- return ((TSdmatrix *)NULL);
- }
- else return (x_dm);
-}
-
-TSdcell *CreateCell_lf(TSivector *row_iv, TSivector *col_iv)
-{
- int _i,
- ncells;
- TSdcell *x_dc=NULL;
- //-------------- The following line must be enacted when we produce new code in the future. ---------------------
- //-------------- In old code I forgot to set the flags for row_iv and col_iv but change them in all places are too time-consuming at this point. ---------------------
- //if (!row_iv || !col_iv || !row_iv->flag || !col_iv->flag) fn_DisplayError(".../CreateCell_lf( ): Dimension vectors row_iv and col_iv must (1) created and (2) assigned legal values");
- if ((ncells = row_iv->n) != col_iv->n) fn_DisplayError(".../CreateCell_lf( ): the lengths of row_iv and col_iv (i.e., numbers of cells) must be the same");
- x_dc = tzMalloc(1, TSdcell);
- x_dc->ncells = ncells;
- x_dc->C = tzMalloc(ncells, TSdmatrix *);
- for (_i=ncells-1; _i>=0; _i--) {
- *(x_dc->C + _i) = CreateMatrix_lf(row_iv->v[_i], col_iv->v[_i]);
- }
- return(x_dc);
-}
-TSdcell *DestroyCell_lf(TSdcell *x_dc)
-{
- int _i;
- if (x_dc) {
- for (_i=x_dc->ncells-1; _i>=0; _i--) x_dc->C[_i] = DestroyMatrix_lf(x_dc->C[_i]);
- tzDestroy(x_dc->C);
- free(x_dc);
- return ((TSdcell *)NULL);
- }
- else return (x_dc);
-}
-
-TSdcellvec *CreateCellvec_lf(TSivector *n_iv) {
- TSdcellvec *x_dcv = tzMalloc(1, TSdcellvec);
- int _i,
- ncells;
- //-------------- The following line must be enacted when we produce new code in the future. ---------------------
- //-------------- In old code I forgot to set the flag for n_iv but change it in all places are too time-consuming at this point. ---------------------
- //if (!n_iv || !n_iv->flag) fn_DisplayError(".../CreateCellvec_lf( ): Dimension vector n_iv must (1) created and (2) assigned legal values");
- x_dcv->ncells = ncells = n_iv->n;
- x_dcv->C = tzMalloc(ncells, TSdvector *);
- for (_i=0; _i<ncells; _i++) *(x_dcv->C + _i) = CreateVector_lf(n_iv->v[_i]);
- return(x_dcv);
-}
-TSdcellvec *DestroyCellvec_lf(TSdcellvec *x_dcv) {
- int _i;
- if (x_dcv) {
- for (_i=x_dcv->ncells-1; _i>=0; _i--) DestroyVector_lf(x_dcv->C[_i]);
- free(x_dcv->C);
- free(x_dcv);
- return ((TSdcellvec *)NULL);
- }
- else return (x_dcv);
-}
-
-TSdfourth *CreateFourth_lf(int ndims, TSivector *row_iv, TSivector *col_iv) {
- int _i;
- TSdfourth *x_d4 = NULL;
- //if (row_iv->n != col_iv->n) fn_DisplayError(".../CreateFourth_lf( ): the lengths of row_iv and col_iv (i.e., sizes of dimensions) must be the same");
-
- x_d4 = tzMalloc(1, TSdfourth);
- x_d4->ndims = ndims;
- x_d4->F = tzMalloc(ndims, TSdcell *);
- for (_i=ndims-1; _i>=0; _i--) {
- *(x_d4->F + _i) = CreateCell_lf(row_iv, col_iv);
- }
- return(x_d4);
-}
-TSdfourth *DestroyFourth_lf(TSdfourth *x_d4) {
- int _i;
- if (x_d4) {
- for (_i=x_d4->ndims-1; _i>=0; _i--) DestroyCell_lf(x_d4->F[_i]);
- free(x_d4->F);
- free(x_d4);
- return ((TSdfourth *)NULL);
- }
- else return (x_d4);
-}
-
-TSdfourthvec *CreateFourthvec_lf(int ndims, TSivector *n_iv)
-{
- int _i;
- TSdfourthvec *x_d4v = NULL;
- //if (n_iv->n != col_iv->n) fn_DisplayError(".../CreateFourth_lf( ): the lengths of n_iv and col_iv (i.e., sizes of dimensions) must be the same");
-
- x_d4v = tzMalloc(1, TSdfourthvec);
- x_d4v->ndims = ndims;
- x_d4v->F = tzMalloc(ndims, TSdcellvec *);
- for (_i=ndims-1; _i>=0; _i--) {
- *(x_d4v->F + _i) = CreateCellvec_lf(n_iv);
- }
- return(x_d4v);
-}
-TSdfourthvec *DestroyFourthvec_lf(TSdfourthvec *x_d4v)
-{
- int _i;
- if (x_d4v) {
- for (_i=x_d4v->ndims-1; _i>=0; _i--) DestroyCellvec_lf(x_d4v->F[_i]);
- free(x_d4v->F);
- free(x_d4v);
- return ((TSdfourthvec *)NULL);
- }
- else return (x_d4v);
-}
-
-TSdzvector *CreateVector_dz(int _n)
-{
- TSdzvector *x_dzv=tzMalloc(1, TSdzvector);
- x_dzv->real = CreateVector_lf(_n);
- x_dzv->imag = CreateVector_lf(_n);
- return( x_dzv );
-}
-TSdzvector *DestroyVector_dz(TSdzvector *x_dzv)
-{
- if (x_dzv) {
- DestroyVector_lf(x_dzv->real);
- DestroyVector_lf(x_dzv->imag);
- free(x_dzv);
- return ((TSdzvector *)NULL);
- }
- else return (x_dzv);
-}
-
-TSdzmatrix *CreateMatrix_dz(int nrows, int ncols) {
- TSdzmatrix *x_dzm=tzMalloc(1, TSdzmatrix);
- x_dzm->real = CreateMatrix_lf(nrows, ncols);
- x_dzm->imag = CreateMatrix_lf(nrows, ncols);
- return( x_dzm );
-}
-TSdzmatrix *DestroyMatrix_dz(TSdzmatrix *x_dzm)
-{
- if (x_dzm) {
- DestroyMatrix_lf(x_dzm->real);
- DestroyMatrix_lf(x_dzm->imag);
- free(x_dzm);
- return ((TSdzmatrix *)NULL);
- }
- else return (x_dzm);
-}
-
-
-
-//-----------------
-// Creates special vectors, matrices, and cells but uses the same destroy utilities as above.
-//-----------------
-//=== Creates two special matrices: zeros and identity. Use DestroyMatrix_lf to free the memory allocated to these functions.
-TSdmatrix *CreateZeroMatrix_lf(const int nrows, const int ncols) {
- int _i;
- TSdmatrix *x_dm=CreateMatrix_lf(nrows, ncols);
- //x_dm->flag = M_GE | M_SU | M_SL | M_UT | M_LT;
- x_dm->flag = M_GE;
- for (_i=nrows*ncols-1; _i>=0; _i--)
- x_dm->M[_i] = 0.0;
- return(x_dm);
-}
-TSdmatrix *CreateIdentityMatrix_lf(const int nrows, const int ncols) {
- int _i;
- TSdmatrix *x_dm=CreateZeroMatrix_lf(nrows, ncols);
- if (nrows==ncols) {
- //x_dm->flag = M_GE | M_SU | M_SL | M_UT | M_LT;
- //x_dm->flag = M_GE;
- for (_i=square(nrows)-1; _i>=0; _i -= nrows+1) x_dm->M[_i] = 1.0;
- x_dm->flag = M_GE | M_SU | M_SL | M_UT | M_LT;
- }
- else if (nrows<ncols) {
- //x_dm->flag = M_GE | M_SU | M_UT;
- //x_dm->flag = M_GE;
- for (_i=square(nrows)-1; _i>=0; _i -= nrows+1) x_dm->M[_i] = 1.0;
- x_dm->flag = M_GE | M_UT | M_LT;
- }
- else {
- //x_dm->flag = M_GE | M_SL | M_LT;
- //x_dm->flag = M_GE;
- for (_i=(ncols-1)*(nrows+1); _i>=0; _i -= nrows+1) x_dm->M[_i] = 1.0;
- x_dm->flag = M_GE | M_UT | M_LT;
- }
- return(x_dm);
-}
-
-//=== Other speicial matrices.
-TSivector *CreateConstantVector_int(const int _n, const int _k) {
- //Inputs:
- // _k: Integer constant;
- // _n: Dimension of the vector.
- int _i;
- TSivector *x_iv=CreateVector_int(_n);
- for (_i=_n-1; _i>=0; _i--)
- x_iv->v[_i] = _k;
- x_iv->flag = V_DEF;
- return(x_iv);
-}
-
-TSimatrix *CreateConstantMatrix_int(const int nrows, const int ncols, const int _n)
-{
- int _i;
- TSimatrix *x_im=CreateMatrix_int(nrows, ncols);
-
- for (_i=nrows*ncols-1; _i>=0; _i--) x_im->M[_i] = _n;
- if ( nrows==ncols ) x_im->flag = M_GE | M_SU | M_SL | M_CN;
- else x_im->flag = M_GE | M_CN;
- return(x_im);
-}
-
-TSicellvec *CreateConstantCellvec_int(TSivector *n_iv, const int _n)
-{
- int _i,
- ncells;
- TSicellvec *x_icv = tzMalloc(1, TSicellvec);
-
- if (!n_iv || !n_iv->flag) fn_DisplayError(".../CreateCellvec_int( ): Dimension vector n_iv must (1) created and (2) assigned legal values");
- x_icv->ncells = ncells = n_iv->n;
- x_icv->C = tzMalloc(ncells, TSivector *);
- for (_i=ncells-1; _i>=0; _i--) *(x_icv->C + _i) = CreateConstantVector_int(n_iv->v[_i], _n);
- return(x_icv);
-}
-
-TSicell *CreateConstantCell_int(TSivector *row_iv, TSivector *col_iv, const int _n)
-{
- int _i,
- ncells;
- TSicell *x_ic=NULL;
- if (!row_iv || !col_iv || !row_iv->flag || !col_iv->flag) fn_DisplayError(".../CreateConstantCell_int( ): Dimension vectors row_iv and col_iv must (1) created and (2) assigned legal values");
- if ((ncells = row_iv->n) != col_iv->n) fn_DisplayError(".../CreateCell_int( ): the lengths of row_iv and col_iv (i.e., numbers of cells) must be the same");
-
- x_ic = tzMalloc(1, TSicell);
- x_ic->ncells = ncells;
- x_ic->C = tzMalloc(ncells, TSimatrix *);
- for (_i=ncells-1; _i>=0; _i--) *(x_ic->C + _i) = CreateConstantMatrix_int(row_iv->v[_i], col_iv->v[_i], _n);
- return(x_ic);
-}
-
-
-TSdvector *CreateConstantVector_lf(const int _n, const double _alpha) {
- int _i;
- TSdvector *x_dv=CreateVector_lf(_n);
- for (_i=_n-1; _i>=0; _i--) x_dv->v[_i] = _alpha;
- x_dv->flag = V_DEF;
- return(x_dv);
-}
-
-TSdmatrix *CreateConstantMatrix_lf(const int nrows, const int ncols, const double _alpha) {
- //Inputs:
- // _alpha: Double constant;
- // nrows and ncols: Dimensions of the matrix.
- int _i;
- TSdmatrix *x_dm=CreateMatrix_lf(nrows, ncols);
-
- for (_i=nrows*ncols-1; _i>=0; _i--) x_dm->M[_i] = _alpha;
- if ( nrows==ncols ) x_dm->flag = M_GE | M_SU | M_SL | M_CN;
- else x_dm->flag = M_GE | M_CN;
- return(x_dm);
-}
-
-TSdcellvec *CreateConstantCellvec_lf(TSivector *n_iv, const double _alpha) {
- //Inputs:
- // _alpha: Double constant;
- // _n: Length (dimension) of the vector.
- int _i,
- ncells;
- TSdcellvec *x_dcv = tzMalloc(1, TSdcellvec);
- //-------------- The following line must be enacted when we produce new code in the future. ---------------------
- //-------------- In old code I forgot to set the flag for n_iv but change it in all places are too time-consuming at this point. ---------------------
- //if (!n_iv || !n_iv->flag) fn_DisplayError(".../CreateConstantCellvec_lf( ): Dimension vector n_iv must (1) created and (2) assigned legal values");
- x_dcv->ncells = ncells = n_iv->n;
- x_dcv->C = tzMalloc(ncells, TSdvector *);
- for (_i=ncells-1; _i>=0; _i--) *(x_dcv->C + _i) = CreateConstantVector_lf(n_iv->v[_i], _alpha);
- return(x_dcv);
-}
-
-TSdcell *CreateConstantCell_lf(TSivector *row_iv, TSivector *col_iv, const double _alpha) {
- //Inputs:
- // _alpha: Double constant;
- // nrows: Number of rows;
- // ncols: Number of columns.
- int _i,
- ncells;
- TSdcell *x_dc=NULL;
- //-------------- The following line must be enacted when we produce new code in the future. ---------------------
- //-------------- In old code I forgot to set the flags for row_iv and col_iv but change them in all places are too time-consuming at this point. ---------------------
- //if (!row_iv || !col_iv || !row_iv->flag || !col_iv->flag) fn_DisplayError(".../CreateConstantCell_lf( ): Dimension vectors row_iv and col_iv must (1) created and (2) assigned legal values");
- if ((ncells = row_iv->n) != col_iv->n) fn_DisplayError(".../CreateCell_lf( ): the lengths of row_iv and col_iv (i.e., numbers of cells) must be the same");
-
- x_dc = tzMalloc(1, TSdcell);
- x_dc->ncells = ncells;
- x_dc->C = tzMalloc(ncells, TSdmatrix *);
- for (_i=ncells-1; _i>=0; _i--) *(x_dc->C + _i) = CreateConstantMatrix_lf(row_iv->v[_i], col_iv->v[_i], _alpha);
- return(x_dc);
-}
-
-
-TSdvector *CreateDatesVector_lf(int nq_m, int yrstart, int qmstart, int yrend, int qmend)
-{
- //If nq_m==4, quarterly data; nq_m==12, monthly data.
- //All the other inputs take the usual (base-1) numbers, I guess 01/17/05. For example, yrstart = 1960 means the year 1960.
- int _t;
- int samplesize = 1+fn_locofyearqm(nq_m, yrstart, qmstart, yrend, qmend); //1+ because fn_locofyearqm() returns a 0-based integer.
- //
- TSdvector *dates_dv = tzMalloc(1, TSdvector);
- dates_dv->n = samplesize;
- dates_dv->v = tzMalloc(samplesize, double);
-
- if (nq_m==4 || nq_m==12) {
- for (_t=samplesize-1; _t>=0; _t--) dates_dv->v[_t] = (double)yrstart + (double)(qmstart+_t-1)/(double)nq_m;
- dates_dv->flag = V_DEF;
- }
- else fn_DisplayError(".../tzmatlab.c/CreateDatesVector_lf(): Dates have to be either monthly or quarterly");
-
-
- return (dates_dv);
-}
-
-
-
-//-----------------
-// Initializes already-created special vectors, matrices, and cells.
-//-----------------
-void InitializeConstantVector_lf(TSdvector *x_dv, const double _alpha)
-{
- //Ouputs:
- // x_dv: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_dv: Memory allocated already.
- // _alpha: Double constant;
- int _i, _n;
-
- if (!x_dv) fn_DisplayError(".../tzmatlab.c/InitializeConstantVector_lf(): Input vector must be created (memory-allocated)");
- else {
- _n=x_dv->n;
- }
- for (_i=_n-1; _i>=0; _i--) x_dv->v[_i] = _alpha;
- x_dv->flag = V_DEF;
-}
-
-void InitializeConstantVector_int(TSivector *x_iv, const int _k)
-{
- //Ouputs:
- // x_iv: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_iv: Memory allocated already.
- // _alpha: Integer constant;
- int _i, _n;
-
- if (!x_iv) fn_DisplayError(".../tzmatlab.c/InitializeConstantVector_int(): Input vector must be created (memory-allocated)");
- else {
- _n=x_iv->n;
- }
- for (_i=_n-1; _i>=0; _i--) x_iv->v[_i] = _k;
- x_iv->flag = V_DEF;
-}
-
-void InitializeConstantMatrix_lf(TSdmatrix *x_dm, const double _alpha)
-{
- //Ouputs:
- // x_dm: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_dm: Memory allocated already.
- // _alpha: Double constant;
- //See Kenneth Reek, pp.202-212.
-
-// int _i;
-// for (_i=x_dm->nrows*x_dm->ncols-1; _i>=0; _i--)
-// x_dm->M[_i] = _alpha;
-// int nrows, ncols;
- double *ptrcnt, *lastptr;
-
- if ( !x_dm) fn_DisplayError(".../tzmathlab.c/InitializeConstantMatrix_int(): Input matrix must be created (memory-allocated)");
- else {
-// nrows = x_dm->nrows;
-// ncols = x_dm->ncols;
- lastptr = (ptrcnt = x_dm->M) + x_dm->nrows * x_dm->ncols;
- }
-
-// if (nrows==ncols) x_dm->flag = M_GE | M_SU | M_SL;
-// else if (nrows<ncols) x_dm->flag = M_GE | M_SU;
-// else x_dm->flag = M_GE | M_SL;
- x_dm->flag = M_GE | M_CN;
- for ( ; ptrcnt<lastptr; ptrcnt++ ) *ptrcnt = _alpha;
-}
-
-void InitializeDiagonalMatrix_lf(TSdmatrix *x_dm, const double _alpha) {
- int _i, n2, nrows, ncols;
- double *M;
-
- if ( !x_dm ) fn_DisplayError(".../tzmathlab.c/InitializeIdentiyMatrix_lf(): (1) Input matrix must be created (memory-allocated)");
- else {
- nrows = x_dm->nrows;
- ncols = x_dm->ncols;
- M = x_dm->M;
- }
-
- if (nrows==ncols) {
- for (_i=(n2=square(nrows))-1; _i>=0; _i--) M[_i] = 0.0;
- for (_i=n2-1; _i>=0; _i -= nrows+1) M[_i] = _alpha;
- x_dm->flag = M_GE | M_SU | M_SL | M_UT | M_LT;
- }
- else if (nrows<ncols) {
- for (_i=nrows*ncols-1; _i>=0; _i--) M[_i] = 0.0;
- for (_i=square(nrows)-1; _i>=0; _i -= nrows+1) M[_i] = _alpha;
- x_dm->flag = M_GE | M_UT | M_LT;
- }
- else {
- for (_i=nrows*ncols-1; _i>=0; _i--) M[_i] = 0.0;
- for (_i=(ncols-1)*(nrows+1); _i>=0; _i -= nrows+1) M[_i] = _alpha;
- x_dm->flag = M_GE | M_UT | M_LT;
- }
-}
-
-void InitializeConstantMatrix_int(TSimatrix *x_im, const int _alpha) {
- //Ouputs:
- // x_im: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_im: Memory allocated already.
- // _alpha: Integer constant;
- //
- //See Kenneth Reek, pp.202-212.
-
-
-// int _i;
-// for (_i=x_im->nrows*x_im->ncols-1; _i>=0; _i--)
-// x_im->M[_i] = _alpha;
-
- int *ptrcnt, *lastptr;
-
- if ( !x_im) fn_DisplayError(".../tzmathlab.c/InitializeConstantMatrix_int(): Input matrix must be created (memory-allocated)");
- else lastptr = (ptrcnt = x_im->M) + x_im->nrows * x_im->ncols;
-
- for ( ; ptrcnt<lastptr; ptrcnt++ ) *ptrcnt = _alpha;
-}
-
-void InitializeConstantCellvec_lf(TSdcellvec *x_dcv, const double _alpha) {
- //Ouputs:
- // x_dcv: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_dcv: Memory allocated already.
- // _alpha: Double constant;
- int _i, _k, _n;
- double *v;
-
- if ( !x_dcv ) fn_DisplayError(".../tzmatlab.c/InitializeConstantCellvec_lf(): Input cell vector must be created (memory-allocated)");
-
-
- for (_i=x_dcv->ncells-1; _i>=0; _i--) {
- v = x_dcv->C[_i]->v;
- _n = x_dcv->C[_i]->n;
- for (_k=_n-1; _k>=0; _k--) v[_k] = _alpha;
- x_dcv->C[_i]->flag = V_DEF;
- }
-}
-
-void InitializeConstantCell_lf(TSdcell *x_dc, const double _alpha)
-{
- //Ouputs:
- // x_dc: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_dc: Memory allocated already.
- // _alpha: Double constant;
- int _i, _k, nrows, ncols;
- double *M;
-
- if ( !x_dc ) fn_DisplayError(".../tzmatlab.c/InitializeConstantCell_lf(): Input cell must be created (memory-allocated)");
-
-
- for (_i=x_dc->ncells-1; _i>=0; _i--) {
- M = x_dc->C[_i]->M;
- nrows = x_dc->C[_i]->nrows;
- ncols = x_dc->C[_i]->ncols;
-// if (nrows==ncols) x_dc->C[_i]->flag = M_GE | M_SU | M_SL;
-// else if (nrows<ncols) x_dc->C[_i]->flag = M_GE | M_SU;
-// else x_dc->C[_i]->flag = M_GE | M_SL;
- for (_k=nrows*ncols-1; _k>=0; _k--) M[_k] = _alpha;
- x_dc->C[_i]->flag = M_GE | M_CN;
- }
-}
-
-
-
-void InitializeConstantFourthvec_lf(TSdfourthvec *x_d4v, const double _alpha) {
- //Ouputs:
- // x_d4v: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_d4v: Memory allocated already.
- // _alpha: Double constant;
- int _j, _i, _k;
- double *v;
-
- if ( !x_d4v ) fn_DisplayError(".../tzmatlab.c/InitializeConstantFourthvec_lf(): Input fourth must be created (memory-allocated)");
-
- for (_j=x_d4v->ndims-1; _j>=0; _j--) {
- for (_i=x_d4v->F[_j]->ncells-1; _i>=0; _i--) {
- v = x_d4v->F[_j]->C[_i]->v;
- for (_k=x_d4v->F[_j]->C[_i]->n-1; _k>=0; _k--) v[_k] = _alpha;
- x_d4v->F[_j]->C[_i]->flag = V_DEF;
- }
- }
-}
-void InitializeConstantFourth_lf(TSdfourth *x_d4, const double _alpha) {
- //Ouputs:
- // x_d4: Initialized to a constant value _alpha for all elements.
- //Inputs:
- // x_d4: Memory allocated already.
- // _alpha: Double constant;
- int _j, _i, _k, nrows, ncols;
- double *M;
-
- if ( !x_d4 ) fn_DisplayError(".../tzmatlab.c/InitializeConstantFourth_lf(): Input fourth must be created (memory-allocated)");
-
- for (_j=x_d4->ndims-1; _j>=0; _j--) {
- for (_i=x_d4->F[_j]->ncells-1; _i>=0; _i--) {
- M = x_d4->F[_j]->C[_i]->M;
- nrows = x_d4->F[_j]->C[_i]->nrows;
- ncols = x_d4->F[_j]->C[_i]->ncols;
- for (_k=nrows*ncols-1; _k>=0; _k--) M[_k] = _alpha;
- x_d4->F[_j]->C[_i]->flag = M_GE | M_CN;
- }
- }
-}
-
-
-void NegateColofMatrix_lf(TSdvector *y_dv, TSdmatrix *X_dm, int jx) {
- //Ouputs:
- // If y_dv!=NULL, y_dv is the negative of the jx_th column of X_dm (i.e., multiplied by -1.0).
- // If !y_dv, the jx_th column of X_dm is replaced by its negated value (i.e., multiplied by -1.0).
- //Inputs:
- // X_dm: Memory allocated and legal values given already.
- // jx: The jx_th column of X_dm.
-
- int _i, nrows_x;
- double *M, *v;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../tzmathlab.c/NegateColumnofMatrix_lf(): (1) input matrix must be created (memory-allocated); (2) legal values must be given");
- if (jx >= X_dm->ncols) fn_DisplayError(".../tzmathlab.c/NegateColumnofMatrix_lf(): The jx_th column specified exceeds the column dimension of the input matrix");
-
- M = X_dm->M + (jx+1)*(nrows_x=X_dm->nrows) - 1; //Points to the end of the jx_th column.
- if ( !y_dv )
- for (_i=nrows_x-1; _i>=0; _i--, M--) *M = -(*M);
- else {
- for (_i=nrows_x-1, v=y_dv->v+_i; _i>=0; _i--, M--, v--) *v = -(*M);
- y_dv->flag = V_DEF;
- }
-}
-
-
-void InitializeConstantColofMatrix_lf(TSdmatrix *X_dm, int jx, double _alpha) {
- //Ouputs:
- // The jx_th column of X_dm is replaced by its original value multiplied by _alpha.
- //Inputs:
- // X_dm: Memory allocated and legal values given already.
- // jx: The jx_th column of X_dm.
- // _alpha: A double constant.
-
- int _i, nrows_x;
- double *M;
-
- if ( !X_dm || !X_dm->flag ) fn_DisplayError(".../tzmathlab.c/NegateColumnofMatrix_lf(): (1) input matrix must be created (memory-allocated); (2) legal values must be given");
- if (jx >= X_dm->ncols) fn_DisplayError(".../tzmathlab.c/NegateColumnofMatrix_lf(): The jx_th column specified exceeds the column dimension of the input matrix");
-
- M = X_dm->M + (jx+1)*(nrows_x=X_dm->nrows) - 1; //Points to the end of the jx_th column.
- for (_i=nrows_x-1; _i>=0; _i--, M--) *M = _alpha;
-}
-
-
-
-
-//-----------------
-// Open files.
-//-----------------
-FILE *tzFopen(char *filename, char *mode) {
- FILE *fptr_dummy;
-
- if (filename)
- {
- if ( !(fptr_dummy = fopen(filename,mode)) ) {
- printf("\n\n...tzmatlab.c/tzFopen(): Fatal Error -- unable to write, read, or append the file %s!\n", filename);
- //getchar();
- exit(EXIT_FAILURE);
- }
- }
- else fn_DisplayError(".../tzmatlab.c/tzFopen(): the input filename must exit");
-
- return (fptr_dummy);
-}
diff --git a/matlab/swz/c-code/utilities/TZCcode/tzmatlab.h b/matlab/swz/c-code/utilities/TZCcode/tzmatlab.h
deleted file mode 100644
index 7c405ec188f5cc76f3499859ccf0d7decde8bd5c..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/tzmatlab.h
+++ /dev/null
@@ -1,7 +0,0 @@
-
-// Use this for tao's orginal code
-//#include "tzmatlab_tao.h"
-
-
-// Use this for dan's version of the code
-#include "tzmatlab_dw.h"
diff --git a/matlab/swz/c-code/utilities/TZCcode/tzmatlab_dw.h b/matlab/swz/c-code/utilities/TZCcode/tzmatlab_dw.h
deleted file mode 100644
index 0d2449ae007127c9da3503d1bf202a61c322ffea..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/tzmatlab_dw.h
+++ /dev/null
@@ -1,363 +0,0 @@
-/*********
- * _cv: Pointer to TScvector (character vector).
- * _iv: Pointer to TSivector (integer vector).
- * _im: Pointer to TSimatrix (integer matrix).
- * _dv: Pointer to TSdvector (double vector).
- * _dm: Pointer to TSdmatrix (double matrix).
- * _dc: Pointer to TSdcell (double cell -- pointer to pointer to a matrix).
- * _dcv: Pointer to TSdcellvec (double cell -- pointer to pointer to a vector).
- * _d4: Pointer to TSdfourth (double fourth dimension -- pointer to pointer to pointer to a matrix).
- * _dzv: Pointer to TSdzvector (double complex vector).
- * _dzm: Pointer to TSdzmatrix (double complex matrix).
- *
- * _s: structure variable.
- * _ps: pointer to a structure.
- * _sv: an array of structures.
- *
- * _sdv: structure (NOT pointer to structure) that contains TSdvector.
- * _sdm: structure (NOT pointer to structure) that contains TSdmatrix.
- *
- * ???????? OLD NOTATIONS ??????????
- * _v: C row or column vector pointer.
- * _vint: C row or column vector pointer to integer.
- * _m: C matrix pointer.
- * _mint: C matrix pointer to integer.
- * _m3: C 3-D matrix pointer.
- * _ppm: C pointer to pointer to a matrix.
- * d_???_ppm: the number of pointers that are pointed to by _ppm.
- * rv_???_ppm: a vector (with dimension d_???_ppm) pointer of numbers of rows, each of the numbers coresponding to a pointed matrix.
- * cv_???_ppm: a vector (with dimension d_???_ppm) pointer of numbers of columns, each of the numbers coresponding to a pointed matrix.
- * d_???_v: dimension size.
- * r_???_m: numbers of rows.
- * c_???_m: number of columns.
- * r_???_m3: number of rows.
- * c_???_m3: number of columns.
- * t_???_m3: number of a third dimension.
-*********/
-
-
-#ifndef __TZMATLAB__
-#define __TZMATLAB__
- #define _ISOC99_SOURCE //Using C99 features for gcc or icc on Linux. Must be placed as the first line above all #include lines.
-
- #include <stdio.h>
- #include <stdlib.h> // For rand(), size_t, exit, malloc, free, qsort, EXIT_FAILURE.
- #include <memory.h> //For memcpy, etc. Alternative: string.h
- #include <math.h> //For isfinite.
- #include <float.h> //For DBL_MIN, etc.
- #include <time.h> //For time(), etc.
-
-
- #define USE_DEBUG_FILE //When defined, one must use tzFopen to give the file name in the main .c file.
- extern FILE *FPTR_DEBUG; //For debugging. Applied to all functions and all .c files that call tzmatlab.h.
- //Initiated to NULL in tzmatlab.c.
- //Must use tzFopen to give the file name in the main .c file.
- extern FILE *FPTR_OPT; //For recording the optimization intermediate results.
- //Applied to minfinder_blockcsminwel() in optpackage.c.
- //Initiated to NULL in tzmatlab.c.
- //Must use tzFopen to give the file name in the main .c file.
-
-/*******************************************************************************/
-/* Added by DW 9/1/08 */
-/*******************************************************************************/
-//#define USE_IMSL_MATH_LIBRARY
-//#define USE_IMSL_STAT_LIBRARY
-#define USE_GSL_LIBRARY
-#define USE_MKL_LIBRARY
-/*******************************************************************************/
-
-// #define NEWVERSIONofDW_SWITCH //If defined, using DW's new switch program (implemented in 2008),
- // which may be incompatible with previous programs, such as ...\SargentWZ2\EstProbModel\EstimationJuly07USED
- //If undef, using the old, working switch program for, say, ...\SargentWZ2\EstProbModel\EstimationJuly07USED.
- //Files that are affected are: cstz.c, kalman.c, optpackage.c,
-
-
- #define SWITCHTOIMSLCMATH // define: use IMSL special functions like gammlog; undef: use my own default code if it exists.
-
- //-------Only one of the following for math library.--------
- #define INTELCMATHLIBRARY // define: use Intel MKL LAPACK library; undef: use others.
- //#define IMSLCMATHLIBRARY // define: use IMSL C Math library; undef: use others.
- //#define MATLABCMATHLIBRARY // define: use Matlab C math library; undef: use others.
-
- //-------Only one of the following for math library.--------
- #define SWITCHTOINTELCMATH // define: use Intel MKL LAPACK library; undef: use others.
- //#define SWITCHTOTZCMATH // define: use my own C math library; undef: use others.
-
- //-------Only one of the following for optimization routines except that CG?_ and CSMINWEL_ can be chosen together.--------
- //#define IMSL_OPTIMIZATION // IMSL optimization routines.
- #define CSMINWEL_OPTIMIZATION //Sims's optimization routine.
- #define CGI_OPTIMIZATION //Polak-Ribiere conjugate gradient method without using derivative information in performing the line minimization.
- //NOT available yet! #define CGII_OPTIMIZATION //NOT available yet! Pletcher-Reeves conjugate gradient method using derivative information in performing the line minimization.
-
- //-------Only one of the following for random number generating routines.--------
- #define IMSL_RANDOMNUMBERGENERATOR // IMSL random number generator.
- //#define CASE2_RANDOMNUMBERGENERATOR //Imported from the C recipe book -- case 2 and my own (Iskander) code for generating a gamma distribution.
-
- //-------Only one of the following statistical packages.--------
- #define IMSL_STATISTICSTOOLBOX // IMSL statistical package.
-
-/*******************************************************************************/
-/* Added by DW 9/1/08 */
-/*******************************************************************************/
-#if defined(USE_MKL_LIBRARY)
- #include "mkl.h"
-#else
- #if defined (USE_GSL_LIBRARY)
- #include "gsl_cblas.h"
- #endif
- #include "blas_lapack.h"
- #undef SWITCHTOINTELCMATH
- #undef INTELCMATHLIBRARY
-#endif
-
-#if defined(USE_GSL_LIBRARY)
- #include "gsl_sf_gamma.h"
- #include "gsl_cdf.h"
-#endif
-
-#if defined(USE_IMSL_MATH_LIBRARY)
- #include <imsl.h> //IMSL math package.
- #include <imsls.h> //IMSL statistical package.
-#else
- #undef IMSL_OPTIMIZATION
- #undef SWITCHTOIMSLCMATH
- #undef IMSL_OPTIMIZATION
- #undef IMSL_RANDOMNUMBERGENERATOR
-#endif
-
-#if defined(USE_IMSL_STAT_LIBRARY)
- #include <imsls.h> //IMSL statistical package.
-#else
- #undef IMSL_STATISTICSTOOLBOX
-#endif
-/*******************************************************************************/
-
- //-------If define: use matlab API interface; otherwise (undef), use C console.
- #undef WIN_MATLABAPI // define: use matlab API interface; undef: use C dos console.
-
-
- //---------------
- #ifdef MATLABCMATHLIBRARY
- #include "matlab.h" // For all mlf???? functions.
- #include "matrix.h" // For mxGetM, mxCreatDoubleMatrix, etc.
- #endif
- #ifdef WIN_MATLABAPI // define: use matlab API interface; undef: use C dos console.
- #include "mex.h" // For all mex??? calls. Matlab API (application program interface or external interface).
- #define printf mexPrintf
- #define malloc mxMalloc
- #define calloc mxCalloc
- #define free mxFree
- #endif
-
-
- //-------------- Attributes for the real double matrix type TSdmatrix. --------------
- //-------------- Whenever a matrix is initialized, the default is M_GE, but nothing else. --------------
- #define M_UNDEF 0 //0 or NULL: No attribute will be given when memory is allocated but no values are initialized.
- #define M_GE 0x0001 //1: A general matrix.
- #define M_SU 0x0002 //2: A symmetric (must be square) matrix but only the upper triangular part is referenced.
- #define M_SL 0x0004 //4: A symmetric (must be square) matrix but only the lower triangular part is referenced.
- #define M_UT 0x0008 //8: A upper triangular (trapezoidal if nrows < ncols) matrix but only the upper triangular part is referenced.
- #define M_LT 0x0010 //16: A lower triangular (trapezoidal if nrows > ncols) matrix but only the lower triangular part is referenced.
- #define M_CN 0x0020 //32: A constant (CN) matrix (All elements are the same or no (N) change from one to another).
-// #define M_UTU 0x0040 //2^6: An unit upper triangular matrix.
-// #define M_LTU 0x0080 //2^7: An unit lower triangular matrix.
- //-------------- Attributes for the real double vector type TSdvector or the character vector type TScvector. --------------
- #define V_UNDEF 0 //Zero or NULL: No values have been assigned to the double vector.
- #define V_DEF 1 //True: Values have been assigned to the double vector.
-
-
- //-------------- Other macro definitions. --------------
- #define BLOCKSIZE_FOR_INTEL_MKL 128 //A machine-dependent value (typically, 16 to 64) required for optimum performance of the blocked algorithm in Intel MKL.
- #define NEARINFINITY 1.0E+300
- #define BIGREALNUMBER 1.0E+30
- #define MACHINEZERO DBL_MIN
- #define EPSILON DBL_EPSILON //1.0E-015. In Standard C, DBL_EPSILON = 2.2204460492503131
- #define SQRTEPSILON 1.490116119384766E-008 //1.0E-15. In Standard C, DBL_EPSILON = 2.2204460492503131E-016
- #define SQRTMACHINEZERO 1.490116119384766E-008
- //This is really not correct, because this number is sqrt(epsion), where DBL_MIN is around 1.0e-300.
- #define MACHINEINFINITY DBL_MAX
- #define MACHINE_EXP_INFINITY DBL_MAX_EXP
- #define EXP_NEARINFINITY 1000
- //===
- #define TZ_TRUE 1
- #define TZ_FALSE 0
-
-
-
- //---------------
- #define tzMalloc(elt_count, type) (type *)m_alloc((elt_count)*sizeof(type))
- #define tzCalloc(elt_count, type) (type *)c_alloc((elt_count), sizeof(type))
- #define tzDestroy(x) {if ((x)) { \
- free((x)); \
- (x) = NULL; \
- }}
- #define tzFclose(x) {if ((x)) { \
- fclose((x)); \
- (x) = (FILE *)NULL; \
- }}
- #define mos(i, j, nrows) ((j)*(nrows)+(i)) //i: ith row; j: jth column; nrows: number of rows for the matrix.
- //Offset(os) for a matrix(m) in column major order and with base 0. See Reek pp.241-242.
- #define square(x) ((x) * (x)) //Must be careful to avoid using, say, square(tmpd=2) or square(++x).
- #define _max(a, b) ((a)>(b) ? (a) : (b)) // Macro max or __max is already defined in stdlib.h in MS visual C++, but mex.h may overwrite the max macro so we use _max.
- #define _min(a, b) ((a)>(b) ? (b) : (a))
- #define swap(a, b, stemp) {(stemp)=(a); (a)=(b); (b)=(stemp);}
- //
- #ifndef isfinite
- #define isfinite(x) _finite(x) //_finite is for Microsoft C++ compiler only (in float.h, which strangely is not ANSI compible),
- // All these Microsoft functions are not yet C99 compatible.
- #endif
- //--- The following does not work.
- // #ifndef FP_NAN
- // #define FP_NAN _FPCLASS_SNAN //_FPCLASS_SNAN is for Microsoft C++ compiler only (in float.h, which strangely is not ANSI compible),
- // // All these Microsoft functions are not yet C99 compatible.
- // #endif
- #define isdiagonalmatrix(x) (((x)->flag & (M_UT | M_LT)) == (M_UT | M_LT)) //x is the tz type of matrix.
- //
- #define DestroyDatesVector_lf(x) DestroyVector_lf(x)
-
-
- //---------------
- typedef struct TScvector_tag
- {
- char *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TScvector;
- typedef struct TSvoidvector_tag
- {
- void *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TSvoidvector;
- typedef struct {
- int *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TSivector;
- typedef struct {
- int *M; //M: matrix.
- int nrows, ncols;
- int flag; //flag: Refers to M_GE, M_SU, M_SL, M_UT, and M_LT in tzmatlab.h.
- } TSimatrix;
- typedef struct {
- TSivector **C; //ncells-by-1 cells (C) and a ponter to vector in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSicellvec;
- typedef struct {
- TSimatrix **C; //ncells-by-1 cells (C) and a ponter to vector in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSicell;
- //=== Real types.
- typedef struct {
- double *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TSdvector;
- typedef struct {
- double *M; //M: matrix.
- int nrows, ncols;
- int flag; //flag: Refers to M_GE, M_SU, M_SL, M_UT, and M_LT in tzmatlab.h.
- } TSdmatrix;
- typedef struct {
- TSdmatrix **C; //ncells-by-1 cells (C) and a pointer to matrix in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSdcell;
- typedef struct {
- TSdvector **C; //ncells-by-1 cells (C) and a ponter to vector in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSdcellvec;
- typedef struct {
- TSdcell **F; //ndims-by-1 fourths (F) and a pointer to cell in each fourth.
- int ndims; //Number of pointers (fourth dimensions) to pointer.
- } TSdfourth;
- typedef struct {
- TSdcellvec **F; //ndims-by-1 fourths (F) and a pointer to cellvec in each fourth.
- int ndims; //Number of pointers (fourth dimensions) to pointer.
- } TSdfourthvec;
- //=== Complex types.
- typedef struct {
- TSdvector *real; //Real part.
- TSdvector *imag; //Imaginary part.
- } TSdzvector;
- typedef struct {
- TSdmatrix *real; //Real part.
- TSdmatrix *imag; //Imaginary part.
- } TSdzmatrix;
-
-
-
- //----------------- Some high-level functions. -----------------
- int fn_locofyearqm(int q_m, int yrstart, int qmstart, int yrend, int qmend);
-
-
-
-
- //---------------
- void fn_DisplayError(char *msg_s);
- void *m_alloc(size_t size);
- void *c_alloc(size_t elt_count, size_t elt_size);
-
- /**
- TSvoidvector *CreateVector_void(int _n);
- TSvoidvector *DestroyVector_void(TSvoidvector *x_voidv);
- /**/
-
- TScvector *CreateVector_c(int _n);
- TScvector *DestroyVector_c(TScvector *x_s);
- TSivector *CreateVector_int(int _n);
- TSivector *DestroyVector_int(TSivector *x_iv);
- TSimatrix *CreateMatrix_int(int nrows, int ncols);
- TSimatrix *DestroyMatrix_int(TSimatrix *x_im);
- TSicellvec *CreateCellvec_int(TSivector *n_iv);
- TSicellvec *DestroyCellvec_int(TSicellvec *x_icv);
- TSicell *CreateCell_int(TSivector *row_iv, TSivector *col_iv);
- TSicell *DestroyCell_int(TSicell *x_ic);
-
- TSdvector *CreateVector_lf(int _n);
- TSdvector *DestroyVector_lf(TSdvector *x_iv);
- TSdmatrix *CreateMatrix_lf(int nrows, int ncols);
- TSdmatrix *DestroyMatrix_lf(TSdmatrix *x_im);
- TSdcell *CreateCell_lf(TSivector *row_iv, TSivector *col_iv);
- TSdcell *DestroyCell_lf(TSdcell *x_dc);
- TSdcellvec *CreateCellvec_lf(TSivector *n_iv);
- TSdcellvec *DestroyCellvec_lf(TSdcellvec *x_dcv);
- TSdfourth *CreateFourth_lf(int ndims, TSivector *row_iv, TSivector *col_iv);
- TSdfourth *DestroyFourth_lf(TSdfourth *x_d4);
- TSdfourthvec *CreateFourthvec_lf(int ndims, TSivector *n_iv);
- TSdfourthvec *DestroyFourthvec_lf(TSdfourthvec *x_d4v);
-
- TSdzvector *CreateVector_dz(int _n);
- TSdzvector *DestroyVector_dz(TSdzvector *x_dzv);
- TSdzmatrix *CreateMatrix_dz(int nrows, int ncols);
- TSdzmatrix *DestroyMatrix_dz(TSdzmatrix *x_dzm);
-
- //+
- TSdmatrix *CreateZeroMatrix_lf(const int nrows, const int ncols);
- TSdmatrix *CreateIdentityMatrix_lf(const int nrows, const int ncols);
- //TSdvector *CreateZerosVector_lf(int _n);
- TSivector *CreateConstantVector_int( const int _n, const int _k);
- TSimatrix *CreateConstantMatrix_int(const int nrows, const int ncols, const int _n);
- TSicellvec *CreateConstantCellvec_int(TSivector *n_iv, const int _n);
- TSicell *CreateConstantCell_int(TSivector *row_iv, TSivector *col_iv, const int _n);
- TSdvector *CreateConstantVector_lf(const int _n, const double _alpha);
- TSdmatrix *CreateConstantMatrix_lf(const int nrows, const int ncols, const double _alpha);
- TSdcellvec *CreateConstantCellvec_lf(TSivector *n_iv, const double _alpha);
- TSdcell *CreateConstantCell_lf(TSivector *row_iv, TSivector *col_iv, const double _alpha);
- TSdvector *CreateDatesVector_lf(int nq_m, int yrstart, int qmstart, int yrend, int qmend);
- //+
- void InitializeConstantVector_lf(TSdvector *x_dv, const double _alpha);
- void InitializeConstantVector_int(TSivector *x_iv, const int _k);
- void InitializeConstantMatrix_lf(TSdmatrix *x_dm, const double _alpha);
- void InitializeDiagonalMatrix_lf(TSdmatrix *x_dm, const double _alpha);
- void InitializeConstantMatrix_int(TSimatrix *x_dm, const int _alpha);
- void InitializeConstantCellvec_lf(TSdcellvec *x_dcv, const double _alpha);
- void InitializeConstantCell_lf(TSdcell *x_dc, const double _alpha);
- void InitializeConstantFourthvec_lf(TSdfourthvec *x_d4v, const double _alpha);
- void InitializeConstantFourth_lf(TSdfourth *x_d4, const double _alpha);
-
-
- void NegateColofMatrix_lf(TSdvector *y_dv, TSdmatrix *x_dm, int _j);
- void InitializeConstantColofMatrix_lf(TSdmatrix *X_dm, int jx, double _alpha);
-
- FILE *tzFopen(char *filename, char *mode);
-#endif
diff --git a/matlab/swz/c-code/utilities/TZCcode/tzmatlab_tao.h b/matlab/swz/c-code/utilities/TZCcode/tzmatlab_tao.h
deleted file mode 100644
index e8da1ac75ec89f031c686cafa8fdd03968c0ebaf..0000000000000000000000000000000000000000
--- a/matlab/swz/c-code/utilities/TZCcode/tzmatlab_tao.h
+++ /dev/null
@@ -1,359 +0,0 @@
-/*********
- * _cv: Pointer to TScvector (character vector).
- * _iv: Pointer to TSivector (integer vector).
- * _im: Pointer to TSimatrix (integer matrix).
- * _dv: Pointer to TSdvector (double vector).
- * _dm: Pointer to TSdmatrix (double matrix).
- * _dc: Pointer to TSdcell (double cell -- pointer to pointer to a matrix).
- * _dcv: Pointer to TSdcellvec (double cell -- pointer to pointer to a vector).
- * _d4: Pointer to TSdfourth (double fourth dimension -- pointer to pointer to pointer to a matrix).
- * _dzv: Pointer to TSdzvector (double complex vector).
- * _dzm: Pointer to TSdzmatrix (double complex matrix).
- *
- * _s: structure variable.
- * _ps: pointer to a structure.
- * _sv: an array of structures.
- *
- * _sdv: structure (NOT pointer to structure) that contains TSdvector.
- * _sdm: structure (NOT pointer to structure) that contains TSdmatrix.
- *
- * ???????? OLD NOTATIONS ??????????
- * _v: C row or column vector pointer.
- * _vint: C row or column vector pointer to integer.
- * _m: C matrix pointer.
- * _mint: C matrix pointer to integer.
- * _m3: C 3-D matrix pointer.
- * _ppm: C pointer to pointer to a matrix.
- * d_???_ppm: the number of pointers that are pointed to by _ppm.
- * rv_???_ppm: a vector (with dimension d_???_ppm) pointer of numbers of rows, each of the numbers coresponding to a pointed matrix.
- * cv_???_ppm: a vector (with dimension d_???_ppm) pointer of numbers of columns, each of the numbers coresponding to a pointed matrix.
- * d_???_v: dimension size.
- * r_???_m: numbers of rows.
- * c_???_m: number of columns.
- * r_???_m3: number of rows.
- * c_???_m3: number of columns.
- * t_???_m3: number of a third dimension.
-*********/
-
-
-#ifndef __TZMATLAB__
-#define __TZMATLAB__
- #define _ISOC99_SOURCE //Using C99 features for gcc or icc on Linux. Must be placed as the first line above all #include lines.
-
- #include <stdio.h>
- #include <stdlib.h> // For rand(), size_t, exit, malloc, free, qsort, EXIT_FAILURE.
- #include <memory.h> //For memcpy, etc. Alternative: string.h
- #include <math.h> //For isfinite.
- #include <float.h> //For DBL_MIN, etc.
- #include <time.h> //For time(), etc.
-
-
- #define USE_DEBUG_FILE //When defined, one must use tzFopen to give the file name in the main .c file.
- extern FILE *FPTR_DEBUG; //For debugging. Applied to all functions and all .c files that call tzmatlab.h.
- //Initiated to NULL in tzmatlab.c.
- //Must use tzFopen to give the file name in the main .c file.
- extern FILE *FPTR_OPT; //For recording the optimization intermediate results.
- //Applied to minfinder_blockcsminwel() in optpackage.c.
- //Initiated to NULL in tzmatlab.c.
- //Must use tzFopen to give the file name in the main .c file.
-
-/*******************************************************************************/
-/* Added by DW 9/1/08 */
-/*******************************************************************************/
-//#define USE_IMSL_MATH_LIBRARY
-//#define USE_IMSL_STAT_LIBRARY
-#define USE_GSL_LIBRARY
-#define USE_MKL_LIBRARY
-/*******************************************************************************/
-
- #define NEWVERSIONofDW_SWITCH //If defined, using DW's new switch program (implemented in 2008),
- // which may be incompatible with previous programs, such as ...\SargentWZ2\EstProbModel\EstimationJuly07USED
- //If undef, using the old, working switch program for, say, ...\SargentWZ2\EstProbModel\EstimationJuly07USED.
- //Files that are affected are: cstz.c, kalman.c, optpackage.c,
-
-
- #define SWITCHTOIMSLCMATH // define: use IMSL special functions like gammlog; undef: use my own default code if it exists.
-
- //-------Only one of the following for math library.--------
- #define INTELCMATHLIBRARY // define: use Intel MKL LAPACK library; undef: use others.
- //#define IMSLCMATHLIBRARY // define: use IMSL C Math library; undef: use others.
- //#define MATLABCMATHLIBRARY // define: use Matlab C math library; undef: use others.
-
- //-------Only one of the following for math library.--------
- #define SWITCHTOINTELCMATH // define: use Intel MKL LAPACK library; undef: use others.
- //#define SWITCHTOTZCMATH // define: use my own C math library; undef: use others.
-
- //-------Only one of the following for optimization routines except that CG?_ and CSMINWEL_ can be chosen together.--------
- //#define IMSL_OPTIMIZATION // IMSL optimization routines.
- #define CSMINWEL_OPTIMIZATION //Sims's optimization routine.
- #define CGI_OPTIMIZATION //Polak-Ribiere conjugate gradient method without using derivative information in performing the line minimization.
- //NOT available yet! #define CGII_OPTIMIZATION //NOT available yet! Pletcher-Reeves conjugate gradient method using derivative information in performing the line minimization.
-
- //-------Only one of the following for random number generating routines.--------
- #define IMSL_RANDOMNUMBERGENERATOR // IMSL random number generator.
- //#define CASE2_RANDOMNUMBERGENERATOR //Imported from the C recipe book -- case 2 and my own (Iskander) code for generating a gamma distribution.
-
- //-------Only one of the following statistical packages.--------
- #define IMSL_STATISTICSTOOLBOX // IMSL statistical package.
-
-/*******************************************************************************/
-/* Added by DW 9/1/08 */
-/*******************************************************************************/
-#if defined(USE_MKL_LIBRARY)
- #include "mkl.h"
-#else
- #include "blas_lapack.h"
- #undef SWITCHTOINTELCMATH
-#endif
-
-#if defined(USE_GSL_LIBRARY)
- #include "gsl_sf_gamma.h"
- #include "gsl_cdf.h"
-#endif
-
-#if defined(USE_IMSL_MATH_LIBRARY)
- #include <imsl.h> //IMSL math package.
- #include <imsls.h> //IMSL statistical package.
-#else
- #undef IMSL_OPTIMIZATION
- #undef SWITCHTOIMSLCMATH
- #undef IMSL_OPTIMIZATION
- #undef IMSL_RANDOMNUMBERGENERATOR
-#endif
-
-#if defined(USE_IMSL_STAT_LIBRARY)
- #include <imsls.h> //IMSL statistical package.
-#else
- #undef IMSL_STATISTICSTOOLBOX
-#endif
-/*******************************************************************************/
-
- //-------If define: use matlab API interface; otherwise (undef), use C console.
- #undef WIN_MATLABAPI // define: use matlab API interface; undef: use C dos console.
-
-
- //---------------
- #ifdef MATLABCMATHLIBRARY
- #include "matlab.h" // For all mlf???? functions.
- #include "matrix.h" // For mxGetM, mxCreatDoubleMatrix, etc.
- #endif
- #ifdef WIN_MATLABAPI // define: use matlab API interface; undef: use C dos console.
- #include "mex.h" // For all mex??? calls. Matlab API (application program interface or external interface).
- #define printf mexPrintf
- #define malloc mxMalloc
- #define calloc mxCalloc
- #define free mxFree
- #endif
-
-
- //-------------- Attributes for the real double matrix type TSdmatrix. --------------
- //-------------- Whenever a matrix is initialized, the default is M_GE, but nothing else. --------------
- #define M_UNDEF 0 //0 or NULL: No attribute will be given when memory is allocated but no values are initialized.
- #define M_GE 0x0001 //1: A general matrix.
- #define M_SU 0x0002 //2: A symmetric (must be square) matrix but only the upper triangular part is referenced.
- #define M_SL 0x0004 //4: A symmetric (must be square) matrix but only the lower triangular part is referenced.
- #define M_UT 0x0008 //8: A upper triangular (trapezoidal if nrows < ncols) matrix but only the upper triangular part is referenced.
- #define M_LT 0x0010 //16: A lower triangular (trapezoidal if nrows > ncols) matrix but only the lower triangular part is referenced.
- #define M_CN 0x0020 //32: A constant (CN) matrix (All elements are the same or no (N) change from one to another).
-// #define M_UTU 0x0040 //2^6: An unit upper triangular matrix.
-// #define M_LTU 0x0080 //2^7: An unit lower triangular matrix.
- //-------------- Attributes for the real double vector type TSdvector or the character vector type TScvector. --------------
- #define V_UNDEF 0 //Zero or NULL: No values have been assigned to the double vector.
- #define V_DEF 1 //True: Values have been assigned to the double vector.
-
-
- //-------------- Other macro definitions. --------------
- #define BLOCKSIZE_FOR_INTEL_MKL 128 //A machine-dependent value (typically, 16 to 64) required for optimum performance of the blocked algorithm in Intel MKL.
- #define NEARINFINITY 1.0E+300
- #define BIGREALNUMBER 1.0E+30
- #define MACHINEZERO DBL_MIN
- #define EPSILON DBL_EPSILON //1.0E-015. In Standard C, DBL_EPSILON = 2.2204460492503131
- #define SQRTEPSILON 1.490116119384766E-008 //1.0E-15. In Standard C, DBL_EPSILON = 2.2204460492503131E-016
- #define SQRTMACHINEZERO 1.490116119384766E-008
- //This is really not correct, because this number is sqrt(epsion), where DBL_MIN is around 1.0e-300.
- #define MACHINEINFINITY DBL_MAX
- #define MACHINE_EXP_INFINITY DBL_MAX_EXP
- #define EXP_NEARINFINITY 1000
- //===
- #define TZ_TRUE 1
- #define TZ_FALSE 0
-
-
-
- //---------------
- #define tzMalloc(elt_count, type) (type *)m_alloc((elt_count)*sizeof(type))
- #define tzCalloc(elt_count, type) (type *)c_alloc((elt_count), sizeof(type))
- #define tzDestroy(x) {if ((x)) { \
- free((x)); \
- (x) = NULL; \
- }}
- #define tzFclose(x) {if ((x)) { \
- fclose((x)); \
- (x) = (FILE *)NULL; \
- }}
- #define mos(i, j, nrows) ((j)*(nrows)+(i)) //i: ith row; j: jth column; nrows: number of rows for the matrix.
- //Offset(os) for a matrix(m) in column major order and with base 0. See Reek pp.241-242.
- #define square(x) ((x) * (x)) //Must be careful to avoid using, say, square(tmpd=2) or square(++x).
- #define _max(a, b) ((a)>(b) ? (a) : (b)) // Macro max or __max is already defined in stdlib.h in MS visual C++, but mex.h may overwrite the max macro so we use _max.
- #define _min(a, b) ((a)>(b) ? (b) : (a))
- #define swap(a, b, stemp) {(stemp)=(a); (a)=(b); (b)=(stemp);}
- //
- #ifndef isfinite
- #define isfinite(x) _finite(x) //_finite is for Microsoft C++ compiler only (in float.h, which strangely is not ANSI compible),
- // All these Microsoft functions are not yet C99 compatible.
- #endif
- //--- The following does not work.
- // #ifndef FP_NAN
- // #define FP_NAN _FPCLASS_SNAN //_FPCLASS_SNAN is for Microsoft C++ compiler only (in float.h, which strangely is not ANSI compible),
- // // All these Microsoft functions are not yet C99 compatible.
- // #endif
- #define isdiagonalmatrix(x) (((x)->flag & (M_UT | M_LT)) == (M_UT | M_LT)) //x is the tz type of matrix.
- //
- #define DestroyDatesVector_lf(x) DestroyVector_lf(x)
-
-
- //---------------
- typedef struct TScvector_tag
- {
- char *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TScvector;
- typedef struct TSvoidvector_tag
- {
- void *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TSvoidvector;
- typedef struct {
- int *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TSivector;
- typedef struct {
- int *M; //M: matrix.
- int nrows, ncols;
- int flag; //flag: Refers to M_GE, M_SU, M_SL, M_UT, and M_LT in tzmatlab.h.
- } TSimatrix;
- typedef struct {
- TSivector **C; //ncells-by-1 cells (C) and a ponter to vector in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSicellvec;
- typedef struct {
- TSimatrix **C; //ncells-by-1 cells (C) and a ponter to vector in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSicell;
- //=== Real types.
- typedef struct {
- double *v; //v: vector.
- int n;
- int flag; //flag: no legal values are assigned if 0 and legal values are assigned if 1.
- } TSdvector;
- typedef struct {
- double *M; //M: matrix.
- int nrows, ncols;
- int flag; //flag: Refers to M_GE, M_SU, M_SL, M_UT, and M_LT in tzmatlab.h.
- } TSdmatrix;
- typedef struct {
- TSdmatrix **C; //ncells-by-1 cells (C) and a pointer to matrix in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSdcell;
- typedef struct {
- TSdvector **C; //ncells-by-1 cells (C) and a ponter to vector in each cell.
- int ncells; //Number of pointers (cells) to pointer.
- } TSdcellvec;
- typedef struct {
- TSdcell **F; //ndims-by-1 fourths (F) and a pointer to cell in each fourth.
- int ndims; //Number of pointers (fourth dimensions) to pointer.
- } TSdfourth;
- typedef struct {
- TSdcellvec **F; //ndims-by-1 fourths (F) and a pointer to cellvec in each fourth.
- int ndims; //Number of pointers (fourth dimensions) to pointer.
- } TSdfourthvec;
- //=== Complex types.
- typedef struct {
- TSdvector *real; //Real part.
- TSdvector *imag; //Imaginary part.
- } TSdzvector;
- typedef struct {
- TSdmatrix *real; //Real part.
- TSdmatrix *imag; //Imaginary part.
- } TSdzmatrix;
-
-
-
- //----------------- Some high-level functions. -----------------
- int fn_locofyearqm(int q_m, int yrstart, int qmstart, int yrend, int qmend);
-
-
-
-
- //---------------
- void fn_DisplayError(char *msg_s);
- void *m_alloc(size_t size);
- void *c_alloc(size_t elt_count, size_t elt_size);
-
- /**
- TSvoidvector *CreateVector_void(int _n);
- TSvoidvector *DestroyVector_void(TSvoidvector *x_voidv);
- /**/
-
- TScvector *CreateVector_c(int _n);
- TScvector *DestroyVector_c(TScvector *x_s);
- TSivector *CreateVector_int(int _n);
- TSivector *DestroyVector_int(TSivector *x_iv);
- TSimatrix *CreateMatrix_int(int nrows, int ncols);
- TSimatrix *DestroyMatrix_int(TSimatrix *x_im);
- TSicellvec *CreateCellvec_int(TSivector *n_iv);
- TSicellvec *DestroyCellvec_int(TSicellvec *x_icv);
- TSicell *CreateCell_int(TSivector *row_iv, TSivector *col_iv);
- TSicell *DestroyCell_int(TSicell *x_ic);
-
- TSdvector *CreateVector_lf(int _n);
- TSdvector *DestroyVector_lf(TSdvector *x_iv);
- TSdmatrix *CreateMatrix_lf(int nrows, int ncols);
- TSdmatrix *DestroyMatrix_lf(TSdmatrix *x_im);
- TSdcell *CreateCell_lf(TSivector *row_iv, TSivector *col_iv);
- TSdcell *DestroyCell_lf(TSdcell *x_dc);
- TSdcellvec *CreateCellvec_lf(TSivector *n_iv);
- TSdcellvec *DestroyCellvec_lf(TSdcellvec *x_dcv);
- TSdfourth *CreateFourth_lf(int ndims, TSivector *row_iv, TSivector *col_iv);
- TSdfourth *DestroyFourth_lf(TSdfourth *x_d4);
- TSdfourthvec *CreateFourthvec_lf(int ndims, TSivector *n_iv);
- TSdfourthvec *DestroyFourthvec_lf(TSdfourthvec *x_d4v);
-
- TSdzvector *CreateVector_dz(int _n);
- TSdzvector *DestroyVector_dz(TSdzvector *x_dzv);
- TSdzmatrix *CreateMatrix_dz(int nrows, int ncols);
- TSdzmatrix *DestroyMatrix_dz(TSdzmatrix *x_dzm);
-
- //+
- TSdmatrix *CreateZeroMatrix_lf(const int nrows, const int ncols);
- TSdmatrix *CreateIdentityMatrix_lf(const int nrows, const int ncols);
- //TSdvector *CreateZerosVector_lf(int _n);
- TSivector *CreateConstantVector_int( const int _n, const int _k);
- TSimatrix *CreateConstantMatrix_int(const int nrows, const int ncols, const int _n);
- TSicellvec *CreateConstantCellvec_int(TSivector *n_iv, const int _n);
- TSicell *CreateConstantCell_int(TSivector *row_iv, TSivector *col_iv, const int _n);
- TSdvector *CreateConstantVector_lf(const int _n, const double _alpha);
- TSdmatrix *CreateConstantMatrix_lf(const int nrows, const int ncols, const double _alpha);
- TSdcellvec *CreateConstantCellvec_lf(TSivector *n_iv, const double _alpha);
- TSdcell *CreateConstantCell_lf(TSivector *row_iv, TSivector *col_iv, const double _alpha);
- TSdvector *CreateDatesVector_lf(int nq_m, int yrstart, int qmstart, int yrend, int qmend);
- //+
- void InitializeConstantVector_lf(TSdvector *x_dv, const double _alpha);
- void InitializeConstantVector_int(TSivector *x_iv, const int _k);
- void InitializeConstantMatrix_lf(TSdmatrix *x_dm, const double _alpha);
- void InitializeDiagonalMatrix_lf(TSdmatrix *x_dm, const double _alpha);
- void InitializeConstantMatrix_int(TSimatrix *x_dm, const int _alpha);
- void InitializeConstantCellvec_lf(TSdcellvec *x_dcv, const double _alpha);
- void InitializeConstantCell_lf(TSdcell *x_dc, const double _alpha);
- void InitializeConstantFourthvec_lf(TSdfourthvec *x_d4v, const double _alpha);
- void InitializeConstantFourth_lf(TSdfourth *x_d4, const double _alpha);
-
-
- void NegateColofMatrix_lf(TSdvector *y_dv, TSdmatrix *x_dm, int _j);
- void InitializeConstantColofMatrix_lf(TSdmatrix *X_dm, int jx, double _alpha);
-
- FILE *tzFopen(char *filename, char *mode);
-#endif
diff --git a/matlab/swz/cstz/bfgsi.m b/matlab/swz/cstz/bfgsi.m
deleted file mode 100644
index b2bf401cc21a988e9ecf16e71beb7ad3986da736..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/bfgsi.m
+++ /dev/null
@@ -1,29 +0,0 @@
-function H = bfgsi(H0,dg,dx)
-% H = bfgsi(H0,dg,dx)
-% dg is previous change in gradient; dx is previous change in x;
-% 6/8/93 version that updates inverse hessian instead of hessian
-% itself.
-% Copyright by Christopher Sims 1996. This material may be freely
-% reproduced and modified.
-dispIndx = 0; % 1: turn on all the diplays on the screen; 0: turn off (Added by T. Zha)
-
-if size(dg,2)>1
- dg=dg';
-end
-if size(dx,2)>1
- dx=dx';
-end
-Hdg = H0*dg;
-dgdx = dg'*dx;
-if (abs(dgdx) >1e-12)
- H = H0 + (1+(dg'*Hdg)/dgdx)*(dx*dx')/dgdx - (dx*Hdg'+Hdg*dx')/dgdx;
-else
- if dispIndx
- disp('bfgs update failed.')
- disp(['|dg| = ' num2str(sqrt(dg'*dg)) '|dx| = ' num2str(sqrt(dx'*dx))]);
- disp(['dg''*dx = ' num2str(dgdx)])
- disp(['|H*dg| = ' num2str(Hdg'*Hdg)])
- end
- H=H0;
-end
-save H.dat H
diff --git a/matlab/swz/cstz/csminit.m b/matlab/swz/cstz/csminit.m
deleted file mode 100644
index 2cdf687dcf241db4e79cc4c43271eb7532959b6d..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/csminit.m
+++ /dev/null
@@ -1,199 +0,0 @@
-function [fhat,xhat,fcount,retcode] = csminit(fcn,x0,f0,g0,badg,H0,varargin)
-% [fhat,xhat,fcount,retcode] = csminit(fcn,x0,f0,g0,badg,H0,...
-% P1,P2,P3,P4,P5,P6,P7,P8)
-% retcodes: 0, normal step. 5, largest step still improves too fast.
-% 4,2 back and forth adjustment of stepsize didn't finish. 3, smallest
-% stepsize still improves too slow. 6, no improvement found. 1, zero
-% gradient.
-%---------------------
-% Modified 7/22/96 to omit variable-length P list, for efficiency and compilation.
-% Places where the number of P's need to be altered or the code could be returned to
-% its old form are marked with ARGLIST comments.
-%
-% Fixed 7/17/93 to use inverse-hessian instead of hessian itself in bfgs
-% update.
-%
-% Fixed 7/19/93 to flip eigenvalues of H to get better performance when
-% it's not psd.
-%
-% Fixed 02/19/05 to correct for low angle problems.
-%
-%tailstr = ')';
-%for i=nargin-6:-1:1
-% tailstr=[ ',P' num2str(i) tailstr];
-%end
-
-dispIndx = 0; % 1: turn on all the diplays on the screen; 0: turn off (Added by T. Zha)
-
-
-%ANGLE = .03; % when output of this variable becomes negative, we have wrong analytical graident
-ANGLE = .005; % works for identified VARs and OLS
-%THETA = .03;
-THETA = .3; %(0<THETA<.5) THETA near .5 makes long line searches, possibly fewer iterations.
-FCHANGE = 1000;
-MINLAMB = 1e-9;
-% fixed 7/15/94
-% MINDX = .0001;
-% MINDX = 1e-6;
-MINDFAC = .01;
-fcount=0;
-lambda=1;
-xhat=x0;
-f=f0;
-fhat=f0;
-g = g0;
-gnorm = norm(g);
-%
-if (gnorm < 1.e-12) & ~badg % put ~badg 8/4/94
- retcode =1;
- dxnorm=0;
- % gradient convergence
-else
- % with badg true, we don't try to match rate of improvement to directional
- % derivative. We're satisfied just to get some improvement in f.
- %
- %if(badg)
- % dx = -g*FCHANGE/(gnorm*gnorm);
- % dxnorm = norm(dx);
- % if dxnorm > 1e12
- % disp('Bad, small gradient problem.')
- % dx = dx*FCHANGE/dxnorm;
- % end
- %else
- % Gauss-Newton step;
- %---------- Start of 7/19/93 mod ---------------
- %[v d] = eig(H0);
- %toc
- %d=max(1e-10,abs(diag(d)));
- %d=abs(diag(d));
- %dx = -(v.*(ones(size(v,1),1)*d'))*(v'*g);
-% toc
- dx = -H0*g;
-% toc
- dxnorm = norm(dx);
- if dxnorm > 1e12
- if dispIndx, disp('Near-singular H problem.'), end
- dx = dx*FCHANGE/dxnorm;
- end
- dfhat = dx'*g0;
- %end
- %
- %
- if ~badg
- % test for alignment of dx with gradient and fix if necessary
- a = -dfhat/(gnorm*dxnorm);
- if a<ANGLE
- dx = dx - (ANGLE*dxnorm/gnorm+dfhat/(gnorm*gnorm))*g;
- % suggested alternate code: ---------------------
- dx = dx*dxnorm/norm(dx); % Added 02/19/05 by CAS. This keeps scale invariant to the angle correction
- % ------------------------------------------------
- dfhat = dx'*g;
- % dxnorm = norm(dx); % Removed 02/19/05 by CAS. This line unnecessary with modification that keeps scale invariant
- if dispIndx, disp(sprintf('Correct for low angle: %g',a)), end
- end
- end
- if dispIndx, disp(sprintf('Predicted improvement: %18.9f',-dfhat/2)), end
- %
- % Have OK dx, now adjust length of step (lambda) until min and
- % max improvement rate criteria are met.
- done=0;
- factor=3;
- shrink=1;
- lambdaMin=0;
- lambdaMax=inf;
- lambdaPeak=0;
- fPeak=f0;
- lambdahat=0;
- while ~done
- if size(x0,2)>1
- dxtest=x0+dx'*lambda;
- else
- dxtest=x0+dx*lambda;
- end
- % home
- f = feval(fcn,dxtest,varargin{:});
- %ARGLIST
- %f = feval(fcn,dxtest,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13);
- % f = feval(fcn,x0+dx*lambda,P1,P2,P3,P4,P5,P6,P7,P8);
- if dispIndx, disp(sprintf('lambda = %10.5g; f = %20.7f',lambda,f )), end
- %debug
- %disp(sprintf('Improvement too great? f0-f: %g, criterion: %g',f0-f,-(1-THETA)*dfhat*lambda))
- if f<fhat
- fhat=f;
- xhat=dxtest;
- lambdahat = lambda;
- end
- fcount=fcount+1;
- shrinkSignal = (~badg & (f0-f < max([-THETA*dfhat*lambda 0]))) | (badg & (f0-f) < 0) ;
- growSignal = ~badg & ( (lambda > 0) & (f0-f > -(1-THETA)*dfhat*lambda) );
- if shrinkSignal & ( (lambda>lambdaPeak) | (lambda<0) )
- if (lambda>0) & ((~shrink) | (lambda/factor <= lambdaPeak))
- shrink=1;
- factor=factor^.6;
- while lambda/factor <= lambdaPeak
- factor=factor^.6;
- end
- %if (abs(lambda)*(factor-1)*dxnorm < MINDX) | (abs(lambda)*(factor-1) < MINLAMB)
- if abs(factor-1)<MINDFAC
- if abs(lambda)<4
- retcode=2;
- else
- retcode=7;
- end
- done=1;
- end
- end
- if (lambda<lambdaMax) & (lambda>lambdaPeak)
- lambdaMax=lambda;
- end
- lambda=lambda/factor;
- if abs(lambda) < MINLAMB
- if (lambda > 0) & (f0 <= fhat)
- % try going against gradient, which may be inaccurate
- if dispIndx, lambda = -lambda*factor^6, end
- else
- if lambda < 0
- retcode = 6;
- else
- retcode = 3;
- end
- done = 1;
- end
- end
- elseif (growSignal & lambda>0) | (shrinkSignal & ((lambda <= lambdaPeak) & (lambda>0)))
- if shrink
- shrink=0;
- factor = factor^.6;
- %if ( abs(lambda)*(factor-1)*dxnorm< MINDX ) | ( abs(lambda)*(factor-1)< MINLAMB)
- if abs(factor-1)<MINDFAC
- if abs(lambda)<4
- retcode=4;
- else
- retcode=7;
- end
- done=1;
- end
- end
- if ( f<fPeak ) & (lambda>0)
- fPeak=f;
- lambdaPeak=lambda;
- if lambdaMax<=lambdaPeak
- lambdaMax=lambdaPeak*factor*factor;
- end
- end
- lambda=lambda*factor;
- if abs(lambda) > 1e20;
- retcode = 5;
- done =1;
- end
- else
- done=1;
- if factor < 1.2
- retcode=7;
- else
- retcode=0;
- end
- end
- end
-end
-if dispIndx, disp(sprintf('Norm of dx %10.5g', dxnorm)), end
diff --git a/matlab/swz/cstz/csminwel.m b/matlab/swz/cstz/csminwel.m
deleted file mode 100644
index 0409569de1d8cf6940bf221dbe302f37945b0c7f..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/csminwel.m
+++ /dev/null
@@ -1,289 +0,0 @@
-function [fh,xh,gh,H,itct,fcount,retcodeh] = csminwel(fcn,x0,H0,grad,crit,nit,varargin)
-%[fhat,xhat,ghat,Hhat,itct,fcount,retcodehat] = csminwel(fcn,x0,H0,grad,crit,nit,varargin)
-% fcn: string naming the objective function to be minimized
-% x0: initial value of the parameter vector
-% H0: initial value for the inverse Hessian. Must be positive definite.
-% grad: Either a string naming a function that calculates the gradient, or the null matrix.
-% If it's null, the program calculates a numerical gradient. In this case fcn must
-% be written so that it can take a matrix argument and produce a row vector of values.
-% crit: Convergence criterion. Iteration will cease when it proves impossible to improve the
-% function value by more than crit.
-% nit: Maximum number of iterations.
-% varargin: A list of optional length of additional parameters that get handed off to fcn each
-% time it is called.
-% Note that if the program ends abnormally, it is possible to retrieve the current x,
-% f, and H from the files g1.mat and H.mat that are written at each iteration and at each
-% hessian update, respectively. (When the routine hits certain kinds of difficulty, it
-% write g2.mat and g3.mat as well. If all were written at about the same time, any of them
-% may be a decent starting point. One can also start from the one with best function value.)
-% NOTE: The display on screen can be turned off by seeting dispIndx=0 in this
-% function. This option is used for the loop operation. T. Zha, 2 May 2000
-% NOTE: You may want to change stps to 1.0e-02 or 1.0e-03 to get a better convergence. August, 2006
-
-Verbose = 0; % 1: turn on all the diplays on the screen; 0: turn off (Added by T. Zha)
-dispIndx = 0; % 1: turn on all the diplays on the screen; 0: turn off (Added by T. Zha)
-
-[nx,no]=size(x0);
-nx=max(nx,no);
-NumGrad= ( ~isstr(grad) | length(grad)==0);
-done=0;
-itct=0;
-fcount=0;
-snit=100;
-%tailstr = ')';
-%stailstr = [];
-% Lines below make the number of Pi's optional. This is inefficient, though, and precludes
-% use of the matlab compiler. Without them, we use feval and the number of Pi's must be
-% changed with the editor for each application. Places where this is required are marked
-% with ARGLIST comments
-%for i=nargin-6:-1:1
-% tailstr=[ ',P' num2str(i) tailstr];
-% stailstr=[' P' num2str(i) stailstr];
-%end
-f0 = eval([fcn '(x0,varargin{:})']);
-%ARGLIST
-%f0 = feval(fcn,x0,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13);
-% disp('first fcn in csminwel.m ----------------') % Jinill on 9/5/95
-if f0 > 1e50, disp('Bad initial parameter.'), return, end
-if NumGrad
- if length(grad)==0
- [g badg] = numgradcd(fcn,x0, varargin{:});
- %ARGLIST
- %[g badg] = numgradcd(fcn,x0,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13);
- else
- badg=any(find(grad==0));
- g=grad;
- end
- %numgradcd(fcn,x0,P1,P2,P3,P4);
-else
- [g badg] = eval([grad '(x0,varargin{:})']);
- %ARGLIST
- %[g badg] = feval(grad,x0,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13);
-end
-retcode3=101;
-x=x0;
-f=f0;
-H=H0;
-cliff=0;
-while ~done
- g1=[]; g2=[]; g3=[];
- %addition fj. 7/6/94 for control
- if dispIndx
- disp('-----------------')
- disp('-----------------')
- %disp('f and x at the beginning of new iteration')
- disp(sprintf('f at the beginning of new iteration, %20.10f',f))
- %-----------Comment out this line if the x vector is long----------------
- disp([sprintf('x = ') sprintf('%15.8g%15.8g%15.8g%15.8g%15.8g\n',x)]);
- end
- %-------------------------
- itct=itct+1;
- [f1 x1 fc retcode1] = csminit(fcn,x,f,g,badg,H,varargin{:});
- %ARGLIST
- %[f1 x1 fc retcode1] = csminit(fcn,x,f,g,badg,H,P1,P2,P3,P4,P5,P6,P7,...
- % P8,P9,P10,P11,P12,P13);
- % itct=itct+1;
- fcount = fcount+fc;
- % erased on 8/4/94
- % if (retcode == 1) | (abs(f1-f) < crit)
- % done=1;
- % end
- % if itct > nit
- % done = 1;
- % retcode = -retcode;
- % end
- if retcode1 ~= 1
- if retcode1==2 | retcode1==4
- wall1=1; badg1=1;
- else
- if NumGrad
- [g1 badg1] = numgradcd(fcn, x1,varargin{:});
- %ARGLIST
- %[g1 badg1] = numgradcd(fcn, x1,P1,P2,P3,P4,P5,P6,P7,P8,P9,...
- % P10,P11,P12,P13);
- else
- [g1 badg1] = eval([grad '(x1,varargin{:})']);
- %ARGLIST
- %[g1 badg1] = feval(grad, x1,P1,P2,P3,P4,P5,P6,P7,P8,P9,...
- % P10,P11,P12,P13);
- end
- wall1=badg1;
- % g1
- save g1 g1 x1 f1 varargin;
- %ARGLIST
- %save g1 g1 x1 f1 P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13;
- end
- if wall1 % & (~done) by Jinill
- % Bad gradient or back and forth on step length. Possibly at
- % cliff edge. Try perturbing search direction.
- %
- %fcliff=fh;xcliff=xh;
- if dispIndx
- disp(' ')
- disp('************************* Random search. *****************************************')
- disp('************************* Random search. *****************************************')
- disp(' ')
- pause(1.0)
- end
- Hcliff=H+diag(diag(H).*rand(nx,1));
- if dispIndx, disp('Cliff. Perturbing search direction.'), end
- [f2 x2 fc retcode2] = csminit(fcn,x,f,g,badg,Hcliff,varargin{:});
- %ARGLIST
- %[f2 x2 fc retcode2] = csminit(fcn,x,f,g,badg,Hcliff,P1,P2,P3,P4,...
- % P5,P6,P7,P8,P9,P10,P11,P12,P13);
- fcount = fcount+fc; % put by Jinill
- if f2 < f
- if retcode2==2 | retcode2==4
- wall2=1; badg2=1;
- else
- if NumGrad
- [g2 badg2] = numgradcd(fcn, x2,varargin{:});
- %ARGLIST
- %[g2 badg2] = numgradcd(fcn, x2,P1,P2,P3,P4,P5,P6,P7,P8,...
- % P9,P10,P11,P12,P13);
- else
- [g2 badg2] = eval([grad '(x2,varargin{:})']);
- %ARGLIST
- %[g2 badg2] = feval(grad,x2,P1,P2,P3,P4,P5,P6,P7,P8,...
- % P9,P10,P11,P12,P13);
- end
- wall2=badg2;
- % g2
- if dispIndx, badg2, end
- save g2 g2 x2 f2 varargin
- %ARGLIST
- %save g2 g2 x2 f2 P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13;
- end
- if wall2
- if dispIndx, disp('Cliff again. Try traversing'), end
- if norm(x2-x1) < 1e-13
- f3=f; x3=x; badg3=1;retcode3=101;
- else
- gcliff=((f2-f1)/((norm(x2-x1))^2))*(x2-x1);
- [f3 x3 fc retcode3] = csminit(fcn,x,f,gcliff,0,eye(nx),varargin{:});
- %ARGLIST
- %[f3 x3 fc retcode3] = csminit(fcn,x,f,gcliff,0,eye(nx),P1,P2,P3,...
- % P4,P5,P6,P7,P8,...
- % P9,P10,P11,P12,P13);
- fcount = fcount+fc; % put by Jinill
- if retcode3==2 | retcode3==4
- wall3=1; badg3=1;
- else
- if NumGrad
- [g3 badg3] = numgradcd(fcn, x3,varargin{:});
- %ARGLIST
- %[g3 badg3] = numgradcd(fcn, x3,P1,P2,P3,P4,P5,P6,P7,P8,...
- % P9,P10,P11,P12,P13);
- else
- [g3 badg3] = eval([grad '(x3,varargin{:})']);
- %ARGLIST
- %[g3 badg3] = feval(grad,x3,P1,P2,P3,P4,P5,P6,P7,P8,...
- % P9,P10,P11,P12,P13);
- end
- wall3=badg3;
- % g3
- if dispIndx, badg3, end
- save g3 g3 x3 f3 varargin;
- %ARGLIST
- %save g3 g3 x3 f3 P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13;
- end
- end
- else
- f3=f; x3=x; badg3=1; retcode3=101;
- end
- else
- f3=f; x3=x; badg3=1;retcode3=101;
- end
- else
- % normal iteration, no walls, or else we're finished here.
- f2=f; f3=f; badg2=1; badg3=1; retcode2=101; retcode3=101;
- end
- else
- f1=f; f2=f; f3=f; retcode2=retcode1; retcode3=retcode1;
- end
- %how to pick gh and xh
- if f3<f & badg3==0
- if dispIndx, ih=3, end
- fh=f3;xh=x3;gh=g3;badgh=badg3;retcodeh=retcode3;
- elseif f2<f & badg2==0
- if dispIndx, ih=2, end
- fh=f2;xh=x2;gh=g2;badgh=badg2;retcodeh=retcode2;
- elseif f1<f & badg1==0
- if dispIndx, ih=1, end
- fh=f1;xh=x1;gh=g1;badgh=badg1;retcodeh=retcode1;
- else
- [fh,ih] = min([f1,f2,f3]);
- if dispIndx, disp(sprintf('ih = %d',ih)), end
- %eval(['xh=x' num2str(ih) ';'])
- switch ih
- case 1
- xh=x1;
- case 2
- xh=x2;
- case 3
- xh=x3;
- end %case
- %eval(['gh=g' num2str(ih) ';'])
- %eval(['retcodeh=retcode' num2str(ih) ';'])
- retcodei=[retcode1,retcode2,retcode3];
- retcodeh=retcodei(ih);
- if exist('gh')
- nogh=isempty(gh);
- else
- nogh=1;
- end
- if nogh
- if NumGrad
- [gh badgh] = feval('numgrad',fcn,xh,varargin{:});
- else
- [gh badgh] = feval('grad', xh,varargin{:});
- end
- end
- badgh=1;
- end
- %end of picking
- %ih
- %fh
- %xh
- %gh
- %badgh
- stuck = (abs(fh-f) < crit);
- if (~badg)&(~badgh)&(~stuck)
- H = bfgsi(H,gh-g,xh-x);
- end
- if Verbose
- if dispIndx
- disp('----')
- disp(sprintf('Improvement on iteration %d = %18.9f',itct,f-fh))
- end
- end
-
- if itct > nit
- if dispIndx, disp('iteration count termination'), end
- done = 1;
- elseif stuck
- if dispIndx, disp('improvement < crit termination'), end
- done = 1;
- end
- rc=retcodeh;
- if rc == 1
- if dispIndx, disp('zero gradient'), end
- elseif rc == 6
- if dispIndx, disp('smallest step still improving too slow, reversed gradient'), end
- elseif rc == 5
- if dispIndx, disp('largest step still improving too fast'), end
- elseif (rc == 4) | (rc==2)
- if dispIndx, disp('back and forth on step length never finished'), end
- elseif rc == 3
- if dispIndx, disp('smallest step still improving too slow'), end
- elseif rc == 7
- if dispIndx, disp('warning: possible inaccuracy in H matrix'), end
- end
-
- f=fh;
- x=xh;
- g=gh;
- badg=badgh;
-end
-% what about making an m-file of 10 lines including numgrad.m
-% since it appears three times in csminwel.m
diff --git a/matlab/swz/cstz/fn_a0freefun.m b/matlab/swz/cstz/fn_a0freefun.m
deleted file mode 100644
index 44ed72737bcfe3c038197b0e7ca6b512b7e8d5d4..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_a0freefun.m
+++ /dev/null
@@ -1,39 +0,0 @@
-function of = fn_a0freefun(b,Ui,nvar,n0,fss,H0inv)
-% of = fn_a0freefun(b,Ui,nvar,n0,fss,H0inv)
-%
-% Negative logPosterior function for squeesed A0 free parameters, which are b's in the WZ notation
-% Note: columns correspond to equations
-%
-% b: sum(n0)-by-1 vector of A0 free parameters
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% nvar: number of endogeous variables
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% fss: nSample-lags (plus ndobs if dummies are included)
-% H0inv: cell(nvar,1). In each cell, posterior inverse of covariance inv(H0) for the ith equation,
-% resembling old SpH in the exponent term in posterior of A0, but not divided by T yet.
-%----------------
-% of: objective function (negative logPosterior)
-%
-% Tao Zha, February 2000
-
-b=b(:); n0=n0(:);
-
-A0 = zeros(nvar);
-n0cum = [0;cumsum(n0)];
-tra = 0.0;
-for kj = 1:nvar
- bj = b(n0cum(kj)+1:n0cum(kj+1));
- A0(:,kj) = Ui{kj}*bj;
- tra = tra + 0.5*bj'*H0inv{kj}*bj; % negative exponential term
-end
-
-[A0l,A0u] = lu(A0);
-
-ada = -fss*sum(log(abs(diag(A0u)))); % negative log determinant of A0 raised to power T
-
-of = ada + tra;
diff --git a/matlab/swz/cstz/fn_a0freegrad.m b/matlab/swz/cstz/fn_a0freegrad.m
deleted file mode 100644
index a48bb38b71b9d7d77b48957b4a3fcafc79cd5ef2..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_a0freegrad.m
+++ /dev/null
@@ -1,42 +0,0 @@
-function [g,badg] = fn_a0freegrad(b,Ui,nvar,n0,fss,H0inv)
-% [g,badg] = a0freegrad(b,Ui,nvar,n0,fss,H0inv)
-% Analytical gradient for a0freefun.m in use of csminwel.m. See Dhrymes's book.
-%
-% b: sum(n0)-by-1 vector of A0 free parameters
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% nvar: number of endogeous variables
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% fss: nSample-lags (plus ndobs if dummies are included)
-% H0inv: cell(nvar,1). In each cell, posterior inverse of covariance inv(H0) for the ith equation,
-% resembling old SpH in the exponent term in posterior of A0, but not divided by T yet.
-%---------------
-% g: sum(n0)-by-1 analytical gradient for a0freefun.m
-% badg: 0, the value that is used in csminwel.m
-%
-% Tao Zha, February 2000. Revised, August 2000
-
-b=b(:); n0 = n0(:);
-
-A0 = zeros(nvar);
-n0cum = [0;cumsum(n0)];
-g = zeros(n0cum(end),1);
-badg = 0;
-
-%*** The derivative of the exponential term w.r.t. each free paramater
-for kj = 1:nvar
- bj = b(n0cum(kj)+1:n0cum(kj+1));
- g(n0cum(kj)+1:n0cum(kj+1)) = H0inv{kj}*bj;
- A0(:,kj) = Ui{kj}*bj;
-end
-B=inv(A0');
-
-%*** Add the derivative of -Tlog|A0| w.r.t. each free paramater
-for ki = 1:sum(n0)
- n = max(find( (ki-n0cum)>0 )); % note, 1<=n<=nvar
- g(ki) = g(ki) - fss*B(:,n)'*Ui{n}(:,ki-n0cum(n));
-end
diff --git a/matlab/swz/cstz/fn_calyrqm.m b/matlab/swz/cstz/fn_calyrqm.m
deleted file mode 100644
index 695c23d96c6fa2a4ad59712979d32996930f653d..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_calyrqm.m
+++ /dev/null
@@ -1,58 +0,0 @@
-function [Myrqm,nMyrqm] = fn_calyrqm(q_m,Byrqm,Eyrqm)
-% [Myrqm,nMyrqm] = fn_calyrqm(q_m,Byrqm,Eyrqm)
-%
-% Given the beginning and end years and quarters (months), export a matrix of all years and
-% quarters (months) for these years and in between
-%
-% q_m: 4 if quarterly and 12 if monthly
-% Byrqm: [year quarter(month)] -- all integers, the begining year and quarter (month)
-% Eyrqm: [year quarter(month)] -- all integers, the end year and quarter (month)
-%-------------------
-% Myrqm: matrix of all years and quarters (months) between and incl. Byrqm and Eyrqm
-% nMyrqm: number of data points incl. Byrqm and Eyrqm
-%
-% Tao Zha, April 2000
-
-if ~isempty(find(Byrqm-round(Byrqm))) | (q_m-round(q_m)) | ~isempty(find(Byrqm-round(Byrqm)))
- error('argin qm, Byrqm, or Eyrqm must of integer')
-elseif Byrqm(1)>Eyrqm(1)
- error('Eyrqm(1) must be equal to or greater than Byrqm(1)')
-elseif Byrqm(1)==Eyrqm(1)
- if Byrqm(2)>Eyrqm(2)
- error('Eyrqm(2) must be equal to or greater than Byrqm(2) because of the same year')
- end
-end
-
-
-Yr = Byrqm(1)+[0:Eyrqm(1)-Byrqm(1)]';
-
-if length(Yr)>=2 % there are years and quarters (months) between Byrqm and Eyrqm
- n=length(Yr)-2;
- C=zeros(n*q_m,2);
- C(:,1) = kron(Yr(2:end-1),ones(q_m,1));
- C(:,2) = kron(ones(n,1),[1:q_m]');
-
- %* initialize a matrix of years and quarters (months) including Byrqm and Eyrqm
- Myrqm = zeros((q_m-Byrqm(2)+1)+Eyrqm(2)+n*q_m,2);
-
- %* Years in between
- n1=q_m-Byrqm(2)+1;
- n2=Eyrqm(2);
- Myrqm(n1+1:end-n2,:) = C;
- %* Beginning year
- for k=1:n1
- Myrqm(k,:) = [Byrqm(1) Byrqm(2)+k-1];
- end
- %* End year
- for k=1:n2
- Myrqm(end-Eyrqm(2)+k,:) = [Eyrqm(1) k];
- end
-else %* all the data are in the same calendar year
- n1=Eyrqm(2)-Byrqm(2)+1;
- Myrqm = zeros(n1,2);
- for k=1:n1
- Myrqm(k,:) = [Byrqm(1) Byrqm(2)+k-1];
- end
-end
-
-nMyrqm = size(Myrqm,1);
diff --git a/matlab/swz/cstz/fn_dataext.m b/matlab/swz/cstz/fn_dataext.m
deleted file mode 100644
index 0eaa3ae18718dc7af9a14448818a0f43ae2db633..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_dataext.m
+++ /dev/null
@@ -1,43 +0,0 @@
-function [xdsube,Brow,Erow] = fn_dataext(Byrqm,Eyrqm,xdatae)
-% xdsube = dataext(Byrqm,Eyrqm,xdatae)
-% Extract subset of xdatae, given Byrqm and Eyrqm
-%
-% Byrqm: [year quarter(month)]: beginning year and period. If Byqm(2)=0, we get annual data.
-% Eyrqm: [year period]: end year and period. If Byrqm(2)=0, it must be Eyrqm(2)=0.
-% xdatae: all data (some of which may be NaN) with the first 2 columns indicating years and periods.
-%----------
-% xdsube: subset of xdatae.
-% Brow: the row number in xdatee that marks the first row of xdsube.
-% Erow: the row number in xdatee that marks the last row of xdsube.
-%
-% Tao Zha, April 2000
-
-if (Byrqm(2)==0) & (Eyrqm(2)~=0)
- error('If annual data, make sure both Byrqm(2) and Eyrqm(2) are zero')
-end
-
-Brow = min(find(xdatae(:,1)==Byrqm(1)));
-if isempty(Brow)
- error('Byrqm is outside the date range indicated by xdatae(:,1:2)!')
-end
-if Byrqm(2)>0
- nadt=Byrqm(2)-xdatae(Brow,2);
- if nadt<0
- error('Byrqm is outside the date range indicated by xdatae(:,1:2)!')
- end
- Brow=Brow+nadt;
-end
-%
-Erow = min(find(xdatae(:,1)==Eyrqm(1)));
-if isempty(Erow)
- error('Eyrqm is outside the date range indicated by xdatae(:,1:2)!')
-end
-if Eyrqm(2)>0
- nadt2=Eyrqm(2)-xdatae(Erow,2);
- if nadt<0
- error('Eyrqm is outside the date range indicated by xdatae(:,1:2)!')
- end
- Erow=Erow+nadt2;
-end
-%
-xdsube = xdatae(Brow:Erow,:); % with dates
diff --git a/matlab/swz/cstz/fn_datana.m b/matlab/swz/cstz/fn_datana.m
deleted file mode 100644
index 91d57321d97757811c9ff3b89e168e347f0ac939..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_datana.m
+++ /dev/null
@@ -1,100 +0,0 @@
-function [yactyrge,yactyre,yactqmyge,yactqmge,yactqme] = fn_datana(xdatae,q_m,vlistlog,vlistper,Byrqm,Eyrqm)
-% [yactyrge,yactyre,yactqmyge,yactqmge,yactqme] = fn_datana(Byrqm,Eyrqm,xdatae,q_m,vlistlog,vlistper)
-%
-% Generate prior period, period-to-period-in-last-year, and annual growth rates
-% For annual rates, works for both calendar and any annual years, depending on Byrqm and Eyrqm
-% If monthly data, we haven't got time to get quarterly growth rates yet.
-%
-% xdatae: all data (logged levels or interest rates/100, some of which may be NaN) with the first
-% 2 columns indicating years and periods.
-% q_m: quarter or month period
-% vlistlog: sublist for logged variables
-% vlistper: sublists for percent variables
-% Byrqm: [year quarter(month)]: beginning year and period. If Byqm(2)~=1, we don't get
-% calendar annual rates. In other words, the first column of yactyge (which
-% indicates years) does not mean calendar years. Byqm(2) must be specified; in other
-% words, it must be not set to 0 as in, say, fn_dataext.
-% Eyrqm: [year period]: end year and period. Eyqm(2) must be specified; in other words, it
-% must be not set to 0 as in, say, fn_dataext.
-% NOTE: if no inputs Byrqm and Eyrqm are specified, all growth rates begin at xdatae(1,1:2).
-%----------
-% yactyrge: annual growth rates with dates in the first 2 columns.
-% yactyre: annual average logged level with dates in the 1st 2 columns.
-% yactqmyge: period-to-period-in-last-year annual growth rates with dates in the first 2 columns.
-% yactqmge: prior-period annualized growth rates with dates in the first 2 columns.
-% yactqme: data (logged levels or interest rates/100) with dates in the first 2 columns.
-% Same as xdatae but with Brow:Erow.
-%
-% Tao Zha, April 2000.
-
-if size(xdatae,1)<2*q_m
- error('We need at least two years of xdatae to get annual rates. Check xdatae!!')
-end
-
-if nargin==4
- Brow=1; Erow=length(xdatae(:,1));
- nyr = floor((Erow-Brow+1)/q_m);
- yrsg = [xdatae(q_m+1,1):xdatae(q_m+1,1)+nyr-2]'; % for annual growth later on
-else
- if Byrqm(2)<1 | Eyrqm(2)<1
- error('This function requires specifying both years and months (quarters) in Byrqm and Eyrqm')
- end
-
- Brow = min(find(xdatae(:,1)==Byrqm(1)));
- if isempty(Brow)
- error('Byrqm is outside the date range of xdatae(:,1:2)!')
- end
- nadt=Byrqm(2)-xdatae(Brow,2);
- if nadt<0
- error('Byrqm is outside the date range indicated by xdatae(:,1:2)!')
- end
- Brow=Brow+nadt;
- %
- Erow = min(find(xdatae(:,1)==Eyrqm(1)));
- if isempty(Brow)
- error('Eyrqm is outside the date range of xdatae(:,1:2)!')
- end
- nadt2=Eyrqm(2)-xdatae(Erow,2);
- if nadt<0
- error('Eyrqm is outside the date range indicated by xdatae(:,1:2)!')
- end
- Erow=Erow+nadt2;
-
- nyr = floor((Erow-Brow+1)/q_m);
- yrsg = [Byrqm(1)+1:Byrqm(1)+nyr-1]'; % for annual growth later on, which will
- % start at Byrqm(1) instead of Byrqm(1)+1
-end
-%
-yactqme = xdatae(Brow:Erow,:); % with dates
-yactqm = yactqme(:,3:end); % only data
-
-%======== prior period change (annaluized rate)
-yactqmg = yactqm(2:end,:); % start at second period to get growth rate
-yactqmg(:,vlistlog) = (yactqm(2:end,vlistlog) - yactqm(1:end-1,vlistlog)) .* q_m;
- % monthly, 12*log(1+growth rate), annualized growth rate
-yactqmg(:,vlistlog) = 100*(exp(yactqmg(:,vlistlog))-1);
-yactqmg(:,vlistper) = 100*yactqmg(:,vlistper);
-yactqmge = [yactqme(2:end,1:2) yactqmg];
-
-%======== change from the last year
-yactqmyg = yactqm(q_m+1:end,:); % start at the last-year period to get growth rate
-yactqmyg(:,vlistlog) = (yactqm(q_m+1:end,vlistlog) - yactqm(1:end-q_m,vlistlog));
-yactqmyg(:,vlistlog) = 100*(exp(yactqmyg(:,vlistlog))-1);
-yactqmyg(:,vlistper) = 100*yactqmyg(:,vlistper);
-yactqmyge = [yactqme(q_m+1:end,1:2) yactqmyg];
-
-%======== annual growth rates
-nvar = length(xdatae(1,3:end));
-ygmts = yactqm(1:nyr*q_m,:); % converted to the multiplication of q_m
-ygmts1 = reshape(ygmts,q_m,nyr,nvar);
-ygmts2 = sum(ygmts1,1) ./ q_m;
-ygmts3 = reshape(ygmts2,nyr,nvar); % converted to annual average series
-%
-yactyrg = ygmts3(2:end,:); % start at the last-year period to get growth rate
-yactyrg(:,vlistlog) = ygmts3(2:end,vlistlog) - ygmts3(1:end-1,vlistlog);
- % annual rate: log(1+growth rate)
-yactyrg(:,vlistlog) = 100*(exp(yactyrg(:,vlistlog))-1);
-yactyrg(:,vlistper) = 100*yactyrg(:,vlistper);
-yactyrge = [yrsg zeros(nyr-1,1) yactyrg];
-yrsg1=[yrsg(1)-1:yrsg(end)]';
-yactyre = [yrsg1 zeros(nyr,1) ygmts3];
diff --git a/matlab/swz/cstz/fn_dataxy.m b/matlab/swz/cstz/fn_dataxy.m
deleted file mode 100644
index cd21674d566a464e3c9616d39b39822e7678b392..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_dataxy.m
+++ /dev/null
@@ -1,147 +0,0 @@
-function [xtx,xty,yty,fss,phi,y,ncoef,xr,Bh,e] = fn_dataxy(nvar,lags,z,mu,indxDummy,nexo)
-% [xtx,xty,yty,fss,phi,y,ncoef,xr,Bh,e] = fn_dataxy(nvar,lags,z,mu,indxDummy,nexo)
-%
-% Export arranged data matrices for future estimation of the VAR.
-% If indxDummy=0, no mu's are used at all and Bh is the OLS estimate.
-% If indxDummy=1, only mu(5) and mu(6) as dummy observations. See fn_rnrprior*.m for using mu(1)-mu(4).
-% See Wagonner and Zha's Gibbs sampling paper.
-%
-% nvar: number of endogenous variables.
-% lags: the maximum length of lag
-% z: T*(nvar+(nexo-1)) matrix of raw or original data (no manipulation involved)
-% with sample size including lags and with exogenous variables other than a constant.
-% Order of columns: (1) nvar endogenous variables; (2) (nexo-1) exogenous variables;
-% (3) constants will be automatically put in the last column.
-% mu: 6-by-1 vector of hyperparameters (the following numbers for Atlanta Fed's forecast), where
-% only mu(5) and mu(6) are used for dummy observations in this function (i.e.,
-% mu(1)-mu(4) are irrelevant here). See fn_rnrprior*.m for using mu(1)-mu(4).
-% mu(1): overall tightness and also for A0; (0.57)
-% mu(2): relative tightness for A+; (0.13)
-% mu(3): relative tightness for the constant term; (0.1)
-% mu(4): tightness on lag decay; (1)
-% mu(5): weight on nvar sums of coeffs dummy observations (unit roots); (5)
-% mu(6): weight on single dummy initial observation including constant
-% (cointegration, unit roots, and stationarity); (5)
-% indxDummy: 1: add dummy observations to the data; 0: no dummy added.
-% nexo: number of exogenous variables. The constant term is the default setting. Besides this term,
-% we have nexo-1 exogenous variables. Optional. If left blank, nexo is set to 1.
-% -------------------
-% xtx: X'X: k-by-k where k=ncoef
-% xty: X'Y: k-by-nvar
-% yty: Y'Y: nvar-by-nvar
-% fss: T: sample size excluding lags. With dummyies, fss=nSample-lags+ndobs.
-% phi: X; T-by-k; column: [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term]
-% y: Y: T-by-nvar where T=fss
-% ncoef: number of coefficients in *each* equation. RHS coefficients only, nvar*lags+nexo
-% xr: the economy size (ncoef-by-ncoef) in qr(phi) so that xr=chol(X'*X) or xr'*xr=X'*X
-% Bh: ncoef-by-nvar estimated reduced-form parameter; column: nvar;
-% row: ncoef=[nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term]
-% e: estimated residual e = y -x*Bh, T-by-nvar
-%
-% Tao Zha, February 2000.
-
-if nargin == 5
- nexo=1; % default for constant term
-elseif nexo<1
- error('We need at least one exogenous term so nexo must >= 1')
-end
-
-%*** original sample dimension without dummy prior
-nSample = size(z,1); % the sample size (including lags, of course)
-sb = lags+1; % original beginning without dummies
-ncoef = nvar*lags+nexo; % number of coefficients in *each* equation, RHS coefficients only.
-
-if indxDummy % prior dummy prior
- %*** expanded sample dimension by dummy prior
- ndobs=nvar+1; % number of dummy observations
- fss = nSample+ndobs-lags;
-
- %
- % **** nvar prior dummy observations with the sum of coefficients
- % ** construct X for Y = X*B + U where phi = X: (T-lags)*k, Y: (T-lags)*nvar
- % ** columns: k = # of [nvar for 1st lag, ..., nvar for last lag, exo var, const]
- % ** Now, T=T+ndobs -- added with "ndobs" dummy observations
- %
- phi = zeros(fss,ncoef);
- %* constant term
- const = ones(fss,1);
- const(1:nvar) = zeros(nvar,1);
- phi(:,ncoef) = const; % the first nvar periods: no or zero constant!
- %* other exogenous (than) constant term
- phi(ndobs+1:end,ncoef-nexo+1:ncoef-1) = z(lags+1:end,nvar+1:nvar+nexo-1);
- exox = zeros(ndobs,nexo);
- phi(1:ndobs,ncoef-nexo+1:ncoef-1) = exox(:,1:nexo-1);
- % this = [] when nexo=1 (no other exogenous than constant)
-
- xdgel = z(:,1:nvar); % endogenous variable matrix
- xdgelint = mean(xdgel(1:lags,:),1); % mean of the first lags initial conditions
- %* Dummies
- for k=1:nvar
- for m=1:lags
- phi(ndobs,nvar*(m-1)+k) = xdgelint(k);
- phi(k,nvar*(m-1)+k) = xdgelint(k);
- % <<>> multiply hyperparameter later
- end
- end
- %* True data
- for k=1:lags
- phi(ndobs+1:fss,nvar*(k-1)+1:nvar*k) = xdgel(sb-k:nSample-k,:);
- % row: T-lags; column: [nvar for 1st lag, ..., nvar for last lag, exo var, const]
- % Thus, # of columns is nvar*lags+nexo = ncoef.
- end
- %
- % ** Y with "ndobs" dummies added
- y = zeros(fss,nvar);
- %* Dummies
- for k=1:nvar
- y(ndobs,k) = xdgelint(k);
- y(k,k) = xdgelint(k);
- % multiply hyperparameter later
- end
- %* True data
- y(ndobs+1:fss,:) = xdgel(sb:nSample,:);
-
- phi(1:nvar,:) = 1*mu(5)*phi(1:nvar,:); % standard Sims and Zha prior
- y(1:nvar,:) = mu(5)*y(1:nvar,:); % standard Sims and Zha prior
- phi(nvar+1,:) = mu(6)*phi(nvar+1,:);
- y(nvar+1,:) = mu(6)*y(nvar+1,:);
-
- [xq,xr]=qr(phi,0);
- xtx=xr'*xr;
- xty=phi'*y;
- [yq,yr]=qr(y,0);
- yty=yr'*yr;
- Bh = xr\(xr'\xty); % xtx\xty where inv(X'X)*(X'Y)
- e=y-phi*Bh;
-else
- fss = nSample-lags;
- %
- % ** construct X for Y = X*B + U where phi = X: (T-lags)*k, Y: (T-lags)*nvar
- % ** columns: k = # of [nvar for 1st lag, ..., nvar for last lag, exo var, const]
- %
- phi = zeros(fss,ncoef);
- %* constant term
- const = ones(fss,1);
- phi(:,ncoef) = const; % the first nvar periods: no or zero constant!
- %* other exogenous (than) constant term
- phi(:,ncoef-nexo+1:ncoef-1) = z(lags+1:end,nvar+1:nvar+nexo-1);
- % this = [] when nexo=1 (no other exogenous than constant)
-
- xdgel = z(:,1:nvar); % endogenous variable matrix
- %* True data
- for k=1:lags
- phi(:,nvar*(k-1)+1:nvar*k) = xdgel(sb-k:nSample-k,:);
- % row: T-lags; column: [nvar for 1st lag, ..., nvar for last lag, exo var, const]
- % Thus, # of columns is nvar*lags+nexo = ncoef.
- end
- %
- y = xdgel(sb:nSample,:);
-
- [xq,xr]=qr(phi,0);
- xtx=xr'*xr;
- xty=phi'*y;
- [yq,yr]=qr(y,0);
- yty=yr'*yr;
- Bh = xr\(xr'\xty); % xtx\xty where inv(X'X)*(X'Y)
- e=y-phi*Bh;
-end
diff --git a/matlab/swz/cstz/fn_ergodp.m b/matlab/swz/cstz/fn_ergodp.m
deleted file mode 100644
index 8c32351ba9b64c434733d430cf3966bf709eec80..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_ergodp.m
+++ /dev/null
@@ -1,16 +0,0 @@
-function gpi = fn_ergodp(P)
-% gpi = fn_ergodp(P)
-% Compute the ergodic probabilities. See Hamilton p.681.
-%
-% P: n-by-n matrix of transition matrix where all elements in each column sum up to 1.
-%-----
-% gpi: n-by-1 vector of ergodic probabilities.
-%
-% Tao Zha August 2000
-
-[gpim,gpid] = eig(P); % m: matrix; d: diagonal
-[gpidv,gpidvinx] = sort(diag(gpid));
-gpidv = fliplr(gpidv);
-gpidvinx = flipud(gpidvinx);
-gpim = gpim(:,gpidvinx);
-gpi = gpim(:,1)/sum(gpim(:,1));
diff --git a/matlab/swz/cstz/fn_fcstidcnd.m b/matlab/swz/cstz/fn_fcstidcnd.m
deleted file mode 100644
index 8fbf866fdab6d4e5abb2676c40604ca849eeb444..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_fcstidcnd.m
+++ /dev/null
@@ -1,306 +0,0 @@
-function [yhat,Estr,rcon,Rcon,u,v,d] = fn_fcstidcnd(valuecon,stepcon,varcon,nstepsm,...
- nconstr,eq_ms,nvar,lags,phil,Aband,Sband,yfore_h,imf3s_h,A0_h,Bh_h,...
- forep,TLindx,TLnumber,nCms,eq_Cms)
-% [yhat,Estr,rcon,Rcon,u,v,d] = fn_fcstidcnd(valuecon,stepcon,varcon,nstepsm,...
-% nconstr,eq_ms,nvar,lags,phil,Aband,Sband,yfore_h,imf3s_h,A0_h,Bh_h,...
-% forep,TLindx,TLnumber,nCms,eq_Cms)
-%
-% Conditional forecasting in the identified model with or without error bands
-% It handles conditions on average values as well, so "valuecon" must be
-% expressed at average (NOT sum) level.
-% Aband is used only once when nconstr>0 and Aband=1, where Gibbs sampler may be used
-% Unconditional forecast when imf3s_h, etc is fixed and nconstr=0.
-%
-% valuecon: vector of values conditioned
-% stepcon: sequence (cell) of steps conditioned; if length(stepcon{i}) > 1, the condition
-% is then an arithmetic average of log(y) over the stepcon{i} period.
-% varcon: vector of variables conditioned
-% nconstr: number of DLS constraints
-% nstepsm: maximum number of steps in all DLS constraints
-% nvar: number of variables in the BVAR model
-% lags: number of lags in the BVAR model
-% phil: the 1-by-(nvar*lags+1) data matrix where k=nvar*lags+1
-% (last period plus lags before the beginning of forecast)
-% Aband: 1: draws from A0 and Bh; 0: no draws
-% Sband: 1: draws from random shocks E; 0: no random shocks
-% yfore_h: uncondtional forecasts: forep-by-nvar. Never used when nconstr=0.
-% In this case, set it to [];
-% imf3s_h: 3-dimensional impulse responses matrix: impsteps-by-nvar shocks-by-nvar responses
-% Never used when nconstr=0. In this case, set it to [];
-% A0_h: A0 contemporaneous parameter matrix
-% Bh_h: reduced-form parameter matrix: k-by-nvar, y(t) = X(t)*Bh+e(t)
-% where X(t) is k-by-nvar and y(t) is 1-by-nvar
-% forep: # of forecast periods (e.g., monthly for a monthly model)
-% TLindx: 1-by-nCms vector of 1's and 0's, indicating tight or loose; 1: tighter, 0: looser
-% Used only when /* (MS draws) is activated. Right now, MS shocks are deterministic.
-% TLnumber: 1-by-nCms vector, lower bound for tight and upper bound for loose
-% nCms: # of LZ conditions
-% eq_Cms: equation location of MS shocks
-% ------
-% yhat: conditional forecasts: forep-by-nvar
-% Estr: backed-out structural shocks (from N(0,1))
-% rcon: vector - the difference between valuecon and log(yfore) (unconditional forecasts)
-% Rcon: k-by-q (q constranits and k=nvar*max(nsteps)) so that
-% Rcon'*e = rcon where e is k-by-1
-% [u,d,v]: svd(Rcon,0)
-%
-%% See Zha's note "Forecast (1)" p. 5, RATS manual (some errors in RATS), etc.
-%
-%% Some notations: y(t+1) = y(t)B1 + e(t+1)inv(A0). e(t+1) is 1-by-n.
-%% Let r(t+1)=e(t+1)inv(A0) + e(t+2)C + .... where inv(A0) is impulse
-%% response at t=1, C at t=2, etc. The row of inv(A0) or C is
-%% all responses to one shock.
-%% Let r be q-by-1 (such as r(1) = r(t+1)
-%% = y(t+1) (constrained) - y(t+1) (forecast)).
-%% Use impulse responses to find out R (k-by-q) where k=nvar*nsteps
-%% where nsteps the largest constrained step. The key of the program
-%% is to creat R using impulse responses
-%% Optimal solution for shock e where R'*e=r and e is k-by-1 is
-%% e = R*inv(R'*R)*r and k>=q
-%
-% Copyright (c) March 1998 by Tao Zha. Revised November 1998;
-% 3/20/99 Disenabled draws of MS shcoks. To enable it, activate /* part
-% 3/20/99 Added A0_h and forep and deleted Cms as input argument. Previous
-% programs may not be compatible.
-% 3/15/2004 There are some BUG problems when calling fn_fcstcnd.m().
-
-
-DLSIdShock = ~isempty(eq_ms); % if not empty, the MS shock is identified as in DLS
-
-impsteps=size(imf3s_h,1);
-if (forep<nstepsm) | (impsteps<nstepsm)
- disp('Increase # of forecast or impulse steps!!')
- disp('Or decrease # of constraints (nconstr) or constrained steps (stepcon(i))!!')
- error('Maximum of conditional steps > # of forecast or impulse steps!!')
-end
-kts = nvar*nstepsm; % k -- ts: total shocks some of which are restricted and others
- % are free.
-%*** initializing
-Rcon = zeros(kts,nconstr); % R: k-by-q
-Econ = zeros(kts,1); % E: k-by-1
-rcon = zeros(nconstr,1); % r: q-by-1
-%rcon=valuecon-diag(yfore(stepcon,varcon)); % another way is to use "loop" below.
-tcwc = nvar*lags; % total coefficients without constant
-phi=phil;
-
-
-
-%----------------------------------------------------
-% Form rcon, Rcon, and Econ (the mean of structural shocks)
-%----------------------------------------------------
-if nconstr
- A0in = reshape(imf3s_h(1,:,:),nvar,nvar); % nvar shocks-by-nvar responses
- for i=1:nconstr
- rcon(i)=length(stepcon{i})*valuecon(i) - ...
- sum(yfore_h(stepcon{i},varcon(i)),1); %<<>>
- Rmat = zeros(nstepsm,nvar);
- r2mat = zeros(nstepsm,1); % simply one identified equation
- % Must be here inside the loop because it's matrix of one column of Rcon
- for j=1:length(stepcon{i})
- if DLSIdShock % Assuming the Fed can't see all other shocks within a month
- Rmat(1:stepcon{i}(j),eq_ms) = Rmat(1:stepcon{i}(j),eq_ms) + ...
- imf3s_h(stepcon{i}(j):-1:1,eq_ms,varcon(i));
- % Rmat: row--nstepsm, column--nvar shocks (here all shocks except
- % the identified one are set to zero) for a particular
- % endogenous variable 'varcon(i)'. See Zha Forcast (1), pp.6-7
- else % Rcon random with (A0,A+)
- Rmat(1:stepcon{i}(j),:) = Rmat(1:stepcon{i}(j),:) + ...
- imf3s_h(stepcon{i}(j):-1:1,:,varcon(i));
- % Rmat: row--nstepsm, column--nvar shocks (here all shocks are
- % *not* set to zero) for a particular endogenous
- % variable 'varcon(i)'. See Zha Forcast (1), pp.6-7
- end
- end
- Rmatt = Rmat'; % Now, nvar-by-nstepsm. I think here is where RATS has an error
- % i.e. "OVERR" is not transposed when overlaid to "CAPR"
- Rcon(:,i)=Rmatt(:); % Rcon: k-by-q where q=nconstr
- end
-
- [u d v]=svd(Rcon,0); %trial
- %???? Can we reduce the time by computing inv(R'*R) directly?
- % rtr = Rcon'*Rcon; %trial
- % rtrinv = inv(Rcon'*Rcon); %trial
- vd=v.*(ones(size(v,2),1)*diag(d)'); %trial
- dinv = 1./diag(d); % inv(diag(d))
- vdinv=v.*(ones(size(v,2),1)*dinv'); %trial
- rtr=vd*vd'; % R'*R
- rtrinv = vdinv*vdinv'; % inv(R'*R)
-
- Econ = Rcon*rtrinv*rcon; % E = R*inv(R'R)*r; the mean of structural shocks
-else
- Econ = zeros(kts,1); % the mean of shocks is zero under no variable condition
- Rcon = NaN;
- rcon = NaN;
- u = NaN;
- d = NaN;
- v = NaN;
-end
-
-
-
-%---------------------------------------
-% No uncertainty at all or only random (A0,A+)
-% In other words, no future shocks
-%---------------------------------------
-if (~Sband) %| (nconstr & (length(eq_ms)==1))
- % length(eq_ms)==1 implies one-one mapping between MS shocks and, say, FFR
- % if nstepsm==nconstr. If this condition does not hold, this procedure
- % is incorrect. I don't have time to fix it now (3/20/99). So I use
- % this as a proximation
- Estr = reshape(Econ,nvar,nstepsm);
- Estr = Estr'; % transpose so that
- % Estr: structural shocks. Row--steps, Column--n shocks
- Estr = [Estr;zeros(forep-nstepsm,nvar)];
- % Now, forep-by-nvar -- ready for forecasts
- Estr(1:nCms,eq_Cms) = TLnumber(:);
- Ures = Estr/A0_h; % nstepsm-by-nvar
- % Ures: reduced-form residuals. Row--steps; Column--n shocks
-
- % ** reconstruct x(t) for y(t+h) = x(t+h-1)*B
- % ** where phi = x(t+h-1) with last column being constant
- %
- yhat = zeros(forep,nvar);
- for k=1:forep
- yhat(k,:) = phi*Bh_h + Ures(k,:);
- phi(1,nvar+1:tcwc) = phi(1,1:tcwc-nvar);
- phi(1,1:nvar) = yhat(k,:);
- %
- end
-
-%---------------------------------------
-% With random future shocks and possibly (A0,A+) depending
-% on if imf3s_h is random
-%---------------------------------------
-else
- %--------------
- % Condition on variables and A random
- %--------------
- if nconstr & Aband
- warning(' ')
- disp('This situation (both E and A random) is still under construction')
- disp('It is closely related to Waggoner and Zha ReStat Gibbs sampling method')
- disp('Please press ctrl-c to abort')
- pause
- elseif nconstr
- %--------------
- % Condition on variables and DLS MS shock, no A random but S random
- %--------------
- if DLSIdShock % other shocks are indepedent of the eq_ms shock
- % 3/20/99 The following may be problematic because Osk should depend
- % on u (A0_h and Bh_h) in general. I haven't worked out any good version
- %/*
- % Osk = randn(kts,1); % other shocks
- % for j=1:nstepsm
- % Osk(nvar*(j-1)+eq_ms)=0; % no shock to the MS or identified equation
- % end
- % Estr = Econ + Osk; % Econ is non zero only at position
- % % eq_ms*j where j=1:nstepsm
- % Estr = reshape(Estr,nvar,nstepsm);
- % Estr = Estr'; % transpose so that
- % % Estr: structural shocks. Row--steps, Column--n shocks
- % Estr = [Estr;randn(forep-nstepsm,nvar)];
- % % Now, forep-by-nvar -- ready for forecasts
- %
- disp('DLS')
- Ome = eye(kts) - u*u'; % note, I-u*u' = I - R*inv(R'*R)*R'
- %[u1 d1 v1] = svd(Ome); % too slow
- [u1 d1] = eig(Ome);
- Stdcon = u1*diag(sqrt(diag(abs(d1)))); % lower triagular chol of conditional variance
- % see Zha's forecast (1), p.17
- tmp1=zeros(nvar,nstepsm);
- tmp1(eq_ms,:)=randn(1,nstepsm);
- tmp2=tmp1(:);
- %Estr1 = Econ + Stdcon*randn(kts,1);
- %jnk = reshape(Stdcon*tmp2,nvar,nstepsm)
- Estr1 = Econ + Stdcon*tmp2;
- Estr2 = reshape(Estr1,nvar,nstepsm);
- Estr2 = Estr2'; % transpose so that
- % Estr2: structural shocks. Row--nstepsm, Column--n shocks
- Estr = [Estr2;randn(forep-nstepsm,nvar)];
- % Now, forep-by-nvar -- ready for forecasts
- else
- Ome = eye(kts) - u*u'; % note, I-u*u' = I - R*inv(R'*R)*R'
- %[u1 d1 v1] = svd(Ome); % too slow
- [u1 d1] = eig(Ome);
- Stdcon = u1*diag(sqrt(diag(abs(d1)))); % lower triagular chol of conditional variance
- % see Zha's forecast (1), p.17
- %--------------
- % Condition on variables and LZ MS shock, no A random but S random
- % This section has not be tested yet, 10/14/98
- %--------------
- if nCms
- Estr1 = Econ + Stdcon*randn(kts,1);
- Estr2 = reshape(Estr1,nvar,nstepsm);
- Estr2 = Estr2'; % transpose so that
- % Estr2: structural shocks. Row--nstepsm, Column--n shocks
- Estr = [Estr2;randn(forep-nstepsm,nvar)];
- % Now, forep-by-nvar -- ready for forecasts
- Estr(1:nCms,eq_Cms) = TLnumber(:);
-
- %/* draw MS shocks
- % for k=1:nCms
- % if TLindx(k) % tighter
- % while (Estr(k,eq_Cms)<TLnumber(k))
- % Estr(k,eq_Cms) = randn(1,1);
- % end
- % else % looser
- % while (Estr(k,eq_Cms)>TLnumber(k))
- % Estr(k,eq_Cms) = randn(1,1);
- % end
- % end
- % end
- %--------------
- % Condition on variables only, no A random but S random
- %--------------
- else
- Estr1 = Econ + Stdcon*randn(kts,1);
- Estr2 = reshape(Estr1,nvar,nstepsm);
- Estr2 = Estr2'; % transpose so that
- % Estr2: structural shocks. Row--nstepsm, Column--n shocks
- Estr = [Estr2;randn(forep-nstepsm,nvar)];
- % Now, forep-by-nvar -- ready for forecasts
- end
- end
- %--------------
- % Condition on LZ MS shocks only, S random and possibly A random depending on
- % if A0_h and Bh_h are random
- %--------------
- else
- if nCms
- Estr = randn(forep,nvar);
- % Now, forep-by-nvar -- ready for forecasts
- Estr(1:nCms,eq_Cms) = TLnumber(:);
-
- %/* draw MS shocks
- % for k=1:nCms
- % if TLindx(k) % tighter
- % while (Estr(k,eq_Cms)<TLnumber(k))
- % Estr(k,eq_Cms) = randn(1,1);
- % end
- % else % looser
- % while (Estr(k,eq_Cms)>TLnumber(k))
- % Estr(k,eq_Cms) = randn(1,1);
- % end
- % end
- % end
- else
- Estr = randn(forep,nvar); % Unconditional forecast
- % Now, forep-by-nvar -- ready for forecasts
- end
- end
- %
-
-
- Ures = Estr/A0_h; % nstepsm-by-nvar
- % Ures: reduced-form residuals. Row--steps; Column--n shocks
-
- % ** reconstruct x(t) for y(t+h) = x(t+h-1)*B
- % ** where phi = x(t+h-1) with last column being constant
- %
- yhat = zeros(forep,nvar);
- for k=1:forep
- yhat(k,:) = phi*Bh_h + Ures(k,:);
- phi(1,nvar+1:tcwc) = phi(1,1:tcwc-nvar);
- phi(1,1:nvar) = yhat(k,:);
- end
-end
diff --git a/matlab/swz/cstz/fn_forecast.m b/matlab/swz/cstz/fn_forecast.m
deleted file mode 100644
index a7e528f5003d7d14da4675b3017088c7ce326b97..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_forecast.m
+++ /dev/null
@@ -1,57 +0,0 @@
-function yhat = fn_forecast(Bh,phi,nn,nexo,Xfexo)
-% yhat = fn_forecast(Bh,phi,nn,nexo,Xfexo)
-% Unconditional forecating without shocks.
-% y_hat(t+h) = c + x_hat(t+h-1)*Bh, X: 1*k; Bh: k*nvar; y_hat: 1*nvar
-%
-% Bh: k-by-nvar, the (posterior) estimate of B.
-% phi: the 1-by-(nvar*lags+nexo) data matrix X where k=nvar*lags+1
-% (last period plus lags before the beginning of forecast).
-% nn: [nvar,lags,nfqm], nfqm: forecast periods (months or quarters).
-% nexo: number of exogenous variables. The constant term is the default setting.
-% Besides this term, we have nexo-1 exogenous variables.
-% Xfexo: nfqm-by-nexo-1 vector of exoenous variables in the forecast horizon where
-% nfqm: number of forecast periods.
-%-----------
-% yhat: nfqm-by-nvar forecast.
-%
-% See fn_forecastsim.m with shocks; fn_forecaststre.m.
-
-if nargin == 3
- nexo=1; % default for constant term
-elseif nexo<1
- error('We need at least one exogenous term so nexo must >= 1')
-end
-
-% ** setup
-nvar = nn(1);
-lags = nn(2);
-nfqm = nn(3);
-tcwx = nvar*lags; % total coefficeint without exogenous variables
-
-if nexo>1
- if (nfqm > size(Xfexo,1))
- disp(' ')
- warning('Make sure the forecast horizon in the exogenous variable matrix Xfexo > forecast periods')
- disp('Press ctrl-c to abort')
- pause
- elseif ((nexo-1) ~= size(Xfexo,2))
- disp(' ')
- warning('Make sure that nexo matchs the exogenous variable matrix Xfexo')
- disp('Press ctrl-c to abort')
- pause
- end
-end
-
-% ** reconstruct x(t) for y(t+h) = x(t+h-1)*B
-% ** where phi = x(t+h-1) with last column being constant
-yhat = zeros(nfqm,nvar);
-for k=1:nfqm
- yhat(k,:) = phi*Bh;
- %*** lagged endogenous variables
- phi(1,nvar+1:tcwx) = phi(1,1:tcwx-nvar);
- phi(1,1:nvar) = yhat(k,:);
- %*** exogenous variables excluding constant terms
- if (nexo>1)
- phi(1,tcwx+1:tcwx+nexo-1) = Xfexo(k,:);
- end
-end
diff --git a/matlab/swz/cstz/fn_foregraph.m b/matlab/swz/cstz/fn_foregraph.m
deleted file mode 100644
index f786837dca38eb267bd71112169d79c45baa8c0c..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_foregraph.m
+++ /dev/null
@@ -1,50 +0,0 @@
-function fn_foregraph(yfore,yacte,keyindx,rnum,cnum,q_m,ylab,forelabel,conlab)
-%
-% Graph annual (or calendar year) forecasts vs actual (all data from "msstart.m")
-%
-% yfore: actual and forecast annual growth data with dates.
-% yacte: actual annual growth data with dates.
-% keyindx: index for the variables to be graphed
-% rnum: number of rows in subplot
-% cnum: number of columns in subplot
-% q_m: if 4 or 12, quarterly or monthly data
-% ylab: string array for the length(keyindx)-by-1 variables
-% forelabel: title label for as of time of forecast
-% conlab: label for what conditions imposed; e.g., conlab = 'All bar MS shocks inspl'
-%-------------
-% No output argument for this graph file
-% See fn_seriesgraph.m, fn_forerrgraph.m.
-%
-% Tao Zha, March 2000
-
-
-vyrs = yfore(:,1);
-hornum = cell(length(vyrs),1); % horizontal year (number)
-count=0;
-for k=vyrs'
- count=count+1;
- jnk=num2str(k);
- hornum{count}=jnk(3:4); % e.g., with '1990', we have '90'
-end
-
-count=0;
-for i = keyindx
- count = count+1;
- subplot(rnum,cnum,count)
- plot(yacte(:,1)+yacte(:,2)/q_m,yacte(:,2+i),yfore(:,1)+yfore(:,2)/q_m,yfore(:,2+i),'--')
-
- if (yfore(1,2)==0) % only for annual growth rates (not for, say, monthly annualized rates)
- set(gca,'XLim',[vyrs(1) vyrs(end)])
- set(gca,'XTick',vyrs)
- set(gca,'XTickLabel',char(hornum))
- end
-
- if i==keyindx(1)
- title(forelabel)
- elseif i>=length(keyindx) %i>=length(keyindx)-1
- xlabel(conlab)
- end
- %
- grid
- ylabel(char(ylab(i)))
-end
diff --git a/matlab/swz/cstz/fn_fprintmatrix.m b/matlab/swz/cstz/fn_fprintmatrix.m
deleted file mode 100644
index f38eb637363697c015fae7994c682618742463d5..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_fprintmatrix.m
+++ /dev/null
@@ -1,42 +0,0 @@
-function fn_fprintmatrix(fid, M, nrows, ncols, indxFloat)
-% Prints the matrix to an ascii file indexed by fid.
-%
-% Inputs:
-% fid: Ascii file id. Example: fid = fopen('outdatainp_3s_stv_tvms6lags.prn','a');
-% M: The matrix to be written to the file.
-% nrows: Number of rows of M.
-% ncols: Number of columns of M.
-% indxFloat: 1 if double;
-% 2 if single;
-% 3 if only 3 significant digits
-% 0 if integer.
-%
-if nrows~=size(M,1)
- nrows
- size(M,1)
- error('fn_fprintmatrix(): Make sure the row number supplied match that of the matrix');
-end
-if ncols~=size(M,2)
- ncols
- size(M,2)
- error('fn_fprintmatrix(): Make sure the column number supplied match that of the matrix');
-end
-for ki=1:nrows
- for kj=1:ncols
- if (indxFloat == 1)
- fprintf(fid,' %.16e ',M((kj-1)*nrows+ki));
- elseif (indxFloat == 2)
- fprintf(fid,' %.8e ',M((kj-1)*nrows+ki));
- elseif (indxFloat == 3)
- fprintf(fid,' %.3e ',M((kj-1)*nrows+ki));
- else
- fprintf(fid,' %d ',M((kj-1)*nrows+ki));
- end
- if (kj==ncols)
- fprintf(fid,'\n');
- end
- end
- if (ki==nrows)
- fprintf(fid,'\n\n');
- end
-end
diff --git a/matlab/swz/cstz/fn_gfmean.m b/matlab/swz/cstz/fn_gfmean.m
deleted file mode 100644
index 9991762b2bfa0eb4c46943059bd43ab93844f09f..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_gfmean.m
+++ /dev/null
@@ -1,41 +0,0 @@
-function [Fmat,gvec] = fn_gfmean(b,P,Vi,nvar,ncoef,n0,np)
-% [Fmat,gvec] = fn_gfmean(b,P,Vi,nvar,ncoef,n0,np)
-%
-% Mean of free lagged parameters g and original lagged parameters F, conditional on comtemporaneous b's
-% See Waggoner and Zha's Gibbs sampling
-%
-% b: sum(n0)-element vector of mean estimate of A0 free parameters
-% P: cell(nvar,1). In each cell, the transformation matrix that affects the posterior mean of A+ conditional on A0.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% nvar: number of endogeous variables
-% ncoef: number of original lagged variables per equation
-% n0: nvar-element vector, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-element vector, ith element represents the number of free A+ parameters in ith equation
-%---------------
-% Fmat: ncoef-by-nvar matrix of original lagged parameters A+. Column corresponding to equation.
-% gvec: sum(np)-by-1 stacked vector of all free lagged parameters A+.
-%
-% Tao Zha, February 2000. Revised, August 2000.
-
-b=b(:); n0=n0(:); np=np(:);
-
-n0cum = [0;cumsum(n0)];
-npcum = [0;cumsum(np)];
-gvec = zeros(npcum(end),1);
-Fmat = zeros(ncoef,nvar); % ncoef: maximum original lagged parameters per equation
-
-if ~(length(b)==n0cum(end))
- error('Make inputs n0 and length(b) match exactly')
-end
-
-for kj=1:nvar
- bj = b(n0cum(kj)+1:n0cum(kj+1));
- gj = P{kj}*bj;
- gvec(npcum(kj)+1:npcum(kj+1)) = gj;
- Fmat(:,kj) = Vi{kj}*gj;
-end
diff --git a/matlab/swz/cstz/fn_gibbsrvar.m b/matlab/swz/cstz/fn_gibbsrvar.m
deleted file mode 100755
index 1e3e8653ddcfaf2f78bb121eafe98fb4d5f949aa..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_gibbsrvar.m
+++ /dev/null
@@ -1,66 +0,0 @@
-function [A0gbs, Wcell] = fn_gibbsrvar(A0gbs,UT,nvar,fss,n0,Indxcol)
-% [A0gbs, Wcell] = fn_gibbsrvar(A0gbs,UT,nvar,fss,n0,Indxcol)
-% One-step Gibbs sampler for restricted VARs in the structural form (including over-identified cases).
-% Reference: "A Gibbs sampler for structural VARs" by D.F. Waggoner and T. Zha, ``
-% Journal of Economic Dynamics & Control (JEDC) 28 (2003) 349-366.
-% See Note Forecast (2) pp. 44-51, 70-71, and Theorem 1 and Section 3.1 in the WZ JEDC paper.
-%
-% A0gbs: the last draw of A0 matrix
-% UT: cell(nvar,1) -- U_i*T_i in the proof of Theorem 1 where
-% (1) a_i = U_i*b_i with b_i being a vector of free parameters
-% (2) T_i (q_i-by-q_i) is from T_i*T_i'= S_i = inv(H0inv{i}/T) where H0inv is the inverse of
-% the covariance martrix NOT divided by fss and S_i is defined in (14) on p.355 of the WZ JEDC paper.
-% nvar: rank of A0 or # of variables
-% fss: effective sample size == nSample (T)-lags+# of dummy observations
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% Indxcol: a row vector indicating random columns this Gibbs draws.
-% When this input is not supplied, the Gibbs draws all columns
-%------------------
-% A0bgs: nvar-by-nvar. New draw of A0 matrix in this Gibbs step
-% Wcell: cell(nvar,1). In each cell, columns of Wcell{i} form an orthonormal basis w_1,...,w_qi in Section 3.1 in the WZ paper. Added 9/04.
-%
-% Written by Tao Zha, August 2000. Revised, September 2004.
-% Copyright (c) by Waggoner and Zha
-
-if (nargin==5), Indxcol=[1:nvar]; end
-
-%---------------- Local loop for Gibbs given last A0gbs ----------
-Wcell = cell(length(Indxcol),1);
-w = zeros(nvar,1);
-for ki=Indxcol % given last A0gbs and generate new A0bgs
- X = A0gbs; % WZ's Section 4.3
- X(:,ki) = 0; % want to find non-zero sw s.t., X'*w=0
-
-
- %*** Solving for w and getting an orthonormal basis. See Theorem 1 and also p.48 in Forecast II
- [jL,Ux] = lu(X');
- jIx0 = min(find(abs(diag(Ux))<eps)); % if isempty(jIx0), then something is wrong here
- w(jIx0+1:end) = 0; % if jIx0+1>end, no effect on w0
- w(jIx0) = 1;
- jA = Ux(1:jIx0-1,1:jIx0-1);
- jb = Ux(1:jIx0-1,jIx0);
- jy = -jA\jb;
- w(1:jIx0-1) = jy;
- % Note: if jIx0=1 (which almost never happens for numerical stability reasons), no effect on w.
-
- %*** Constructing orthonormal basis w_1, ..., w_qi at each Gibbs step
- w0 = UT{ki}'*w;
- w1 = w0/sqrt(sum(w0.^2));
- [W,jnk] = qr(w1); % Columns of W form an orthonormal basis w_1,...,w_qi in Section 3.1 in the WZ paper
-
- %*** Draw beta's according to Theorem 1 in the WZ JEDC paper.
- gkbeta = zeros(n0(ki),1); % qi-by-1: greak beta's
- jstd = sqrt(1/fss);
- gkbeta(2:end) = jstd*randn(n0(ki)-1,1); % for beta_2, ..., beta_qi
- %--- Unnormalized (i.e., not normalized) gamma or 1-d Wishart draw of beta_1 in Theorem 1 of the WZ JEDC paper.
- jr = jstd*randn(fss+1,1);
- if rand(1)<0.5
- gkbeta(1) = sqrt(jr'*jr);
- else
- gkbeta(1) = -sqrt(jr'*jr);
- end
-
- %*** Getting a new ki_th column in A0
- A0gbs(:,ki) = UT{ki}*(W*gkbeta); % n-by-1: U_i*T_i*W*beta;
- Wcell{ki} = W; %q_i-by-1.
-end
diff --git a/matlab/swz/cstz/fn_gibbsrvar_setup.m b/matlab/swz/cstz/fn_gibbsrvar_setup.m
deleted file mode 100755
index 972f55e99d1c77522025ccf04a7a22b20c101eb0..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_gibbsrvar_setup.m
+++ /dev/null
@@ -1,58 +0,0 @@
-function [Tinv,UT,VHphalf,PU,VPU] = fn_gibbsrvar_setup(H0inv, Ui, Hpinv, Pmat, Vi, nvar, fss)
-% [Tinv,UT,VHphalf,PU,VPU] = fn_gibbsrvar_setup.m(H0inv, Ui, Hpinv, Pmat, Vi, fss, nvar)
-% Global setup outside the Gibbs loop to be used by fn_gibbsvar().
-% Reference: "A Gibbs sampler for structural VARs" by D.F. Waggoner and T. Zha, ``
-% Journal of Economic Dynamics & Control (JEDC) 28 (2003) 349-366.
-% See Note Forecast (2) pp. 44-51, 70-71, and Theorem 1 and Section 3.1 in the WZ JEDC paper.
-%
-% H0inv: cell(nvar,1). Not divided by T yet. In each cell, inverse of posterior covariance matrix H0.
-% The exponential term is b_i'*inv(H0)*b_i for the ith equation where b_i = U_i*a0_i.
-% It resembles old SpH or Sbd in the exponent term in posterior of A0, but not divided by T yet.
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation. Imported from dnrprior.m.
-% Hpinv: cell(nvar,1). In each cell, posterior inverse of covariance matrix Hp (A+) for the free parameters
-% g_i = V_i*A+(:,i) in the ith equation.
-% Pmat: cell(nvar,1). In each cell, the transformation matrix that affects the posterior mean of A+ conditional on A0.
-% In other words, the posterior mean (of g_i) = Pmat{i}*b_i where g_i is a column vector of free parameters
-% of A+(:,i)) given b_i (b_i is a column vector of free parameters of A0(:,i)).
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k (ncoef) is a total number of RHS variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation. Imported from dnrprior.m.
-% nvar: number of endogenous variables or rank of A0.
-% fss: effective sample size (in the exponential term) = nSample - lags + ndobs (ndobs = # of dummy observations
-% is set to 0 when fn_rnrprior_covres_dobs() is used where dummy observations are included as part of the explicit prior.
-%-------------
-% Tinv: cell(nvar,1). In each cell, inv(T_i) for T_iT_i'=S_i where S_i is defined on p.355 of the WZ JEDC paper.
-% UT: cell(nvar,1). In each cell, U_i*T_i.
-% VHphalf: cell(nvar,1). In each cell, V_i*sqrt(Hp_i).
-% PU: cell(nvar,1). In each cell, Pmat{i}*U_i where Pmat{i} = P_i defined in (13) on p.353 of the WZ JEDC paper.
-% VPU: cell(nvar,1). In each cell, V_i*P_i*U_i
-%
-% Written by Tao Zha, September 2004.
-% Copyright (c) 2004 by Waggoner and Zha
-
-
-%--- For A0.
-Tinv = cell(nvar,1); % in each cell, inv(T_i) for T_iT_i'=S_i where S_i is defined on p.355 of the WZ JEDC paper.
-UT = cell(nvar,1); % in each cell, U_i*T_i.
-%--- For A+.
-VHphalf = cell(nvar,1); % in each cell, V_i*sqrt(Hp_i).
-PU = cell(nvar,1); % in each cell, Pmat{i}*U_i where Pmat{i} = P_i defined in (13) on p.353 of the WZ JEDC paper.
-VPU = cell(nvar,1); % in each cell, V_i*P_i*U_i
-%
-for ki=1:nvar
- %--- For A0.
- Tinv{ki} = chol(H0inv{ki}/fss); % Tinv_i'*Tinv_i = inv(S_i) ==> T_i*T_i' = S_i where S_i = H0inv{i}/fss is defined on p.355 of the WZ JEDC paper.
- UT{ki} = Ui{ki}/Tinv{ki}; % n-by-qi: U_i*T_i in (14) on p. 255 of the WZ JEDC paper.
- %--- For A+.
- VHphalf{ki} = Vi{ki}/chol(Hpinv{ki}); % where chol(Hpinv_i)*chol(Hpinv_i)'=Hpinv_i.
- PU{ki} = Pmat{ki}*Ui{ki}';
- VPU{ki} = Vi{ki}*PU{ki};
-end
diff --git a/matlab/swz/cstz/fn_imcgraph.m b/matlab/swz/cstz/fn_imcgraph.m
deleted file mode 100644
index dfb6cc23cf3f6869e773037427d0429298244eb9..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_imcgraph.m
+++ /dev/null
@@ -1,107 +0,0 @@
-function scaleout = fn_imcgraph(imf,nvar,imstp,xlab,ylab,indxGimfml,xTick)
-% scaleout = fn_imcgraph(imf,nvar,imstp,xlab,ylab,indxGimfml,xTick)
-% imcgraph: impulse, c (column: shock 1 to N), graph the ML point impulse response
-%
-% imf: imstp-by-nvar^2 matrix of impulse responses, column (responses to 1st shock, responses to 2nd shock
-% etc), row (impusle steps),
-% nvar: number of variables
-% imstp: number of steps of impulse responses
-% xlab,ylab: labels
-% indxGimfml: 1, graph; 0, no graph
-% xTick: optional. Eg: [12 24 36].
-%---------------
-% scaleout: column 1 represents maximums; column 2 minimums. Rows: nvar variables.
-%
-% NOTE: I added "indxGimfml" so this function may not be compatible with programs
-% older than 03/06/99, TZ
-%
-% See imrgraph, fn_imcerrgraph, fn_imc2errgraph, imrerrgraph, fn_gyrfore in RVARcode
-
-if nargin < 7, xTick = []; end
-
-t = 1:imstp;
-temp1=zeros(nvar,1);
-temp2=zeros(nvar,1);
-maxval=zeros(nvar,1);
-minval=zeros(nvar,1);
-for i = 1:nvar
- for j = 1:nvar
- temp1(j)=max(imf(:,(j-1)*nvar+i));
- temp2(j)=min(imf(:,(j-1)*nvar+i));
- end
- maxval(i)=max(temp1);
- minval(i)=min(temp2);
-end
-
-scaleout = [maxval(:) minval(:)];
-
-%--------------
-% Column j: Shock 1 to N; Row i: Responses to
-%-------------
-if indxGimfml
- %figure
- rowlabel = 1;
- for i = 1:nvar % Responses of
- columnlabel = 1;
-
- if minval(i)<0
- if maxval(i)<=0
- yt=[minval(i) 0];
- else
- yt=[minval(i) 0 maxval(i)];
- end
- else % (minval(i) >=0)
- if maxval(i) > 0
- yt=[0 maxval(i)];
- else % (identically zero responses)
- yt=[-1 0 1];
- end
- end
-
-
- scale=[1 imstp minval(i) maxval(i)];
- for j = 1:nvar % To shocks
- k1=(i-1)*nvar+j;
- k2=(j-1)*nvar+i;
- subplot(nvar,nvar,k1)
- plot(t,imf(:,k2),t,zeros(length(imf(:,k2)),1),'r:');
-
- set(gca,'XTick',xTick)
- set(gca,'YTick',yt)
- grid
-
- axis(scale); % put limits on both axes.
- %
- % if maxval(i)>minval(i)
- % set(gca,'YLim',[minval(i) maxval(i)])
- % end
-
-
- if isempty(xTick) %1 % No numbers on both axes
- set(gca,'XTickLabel',' ');
- set(gca,'YTickLabel',' ');
- else % Put numbers on both axes
- if i<nvar
- set(gca,'XTickLabelMode','manual','XTickLabel',[])
- end
- if j>1
- set(gca,'YTickLabel',' ');
- end
- end
-
-
- if rowlabel == 1
- %title(['x' num2str(j)])
- %title(eval(['x' num2str(j)]))
- title(char(xlab(j)))
- end
- if columnlabel == 1
- %ylabel(['x' num2str(i)])
- %ylabel(eval(['x' num2str(i)]))
- ylabel(char(ylab(i)))
- end
- columnlabel = 0;
- end
- rowlabel = 0;
- end
-end
diff --git a/matlab/swz/cstz/fn_impulse.m b/matlab/swz/cstz/fn_impulse.m
deleted file mode 100644
index 38ab1ec88f4edae16a34ace632f882da627137cc..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_impulse.m
+++ /dev/null
@@ -1,59 +0,0 @@
-function imf = fn_impulse(Bh,swish,nn)
-% Computing impulse functions with
-% imf = fn_impulse(Bh,swish,nn)
-% imf is in a format that is the SAME as in RATS.
-% Column: nvar responses to 1st shock,
-% nvar responses to 2nd shock, and so on.
-% Row: steps of impulse responses.
-%-----------------
-% Bh is the estimated reduced form coefficient in the form
-% Y(T*nvar) = XB + U, X: T*k (may include all exogenous terms), B: k*nvar.
-% The matrix form and dimension are the same as "Bh" from the function "sye.m";
-% Column: 1st lag (with nvar variables) to lags (with nvar variables) + const = k.
-% Note: columns correspond to equations.
-% swish is the inv(A0) in the structural model y(t)A0 = e(t).
-% Note: columns corresponding to equations.
-% nn is the numbers of inputs [nvar,lags,# of steps of impulse responses].
-%
-% Written by Tao Zha.
-% Copyright (c) 1994 by Tao Zha
-
-nvar = nn(1);
-lags = nn(2);
-imstep = nn(3); % number of steps for impulse responses
-
-Ah = Bh';
-% Row: nvar equations
-% Column: 1st lag (with nvar variables) to lags (with nvar variables) + const = k.
-
-imf = zeros(imstep,nvar*nvar);
-% Column: nvar responses to 1st shock, nvar responses to 2nd shock, and so on.
-% Row: steps of impulse responses.
-M = zeros(nvar*(lags+1),nvar);
-% Stack lags M's in the order of, e.g., [Mlags, ..., M2,M1;M0]
-M(1:nvar,:) = swish';
-Mtem = M(1:nvar,:); % temporary M.
-% first (initial) responses to 1 standard deviation shock. Row: responses; Column: shocks
-% * put in the form of "imf"
-imf(1,:) = Mtem(:)';
-
-t = 1;
-ims1 = min([imstep-1 lags]);
-while t <= ims1
- Mtem = Ah(:,1:nvar*t)*M(1:nvar*t,:);
- % Row: nvar equations, each for the nvar variables at tth lag
- M(nvar+1:nvar*(t+1),:)=M(1:nvar*t,:);
- M(1:nvar,:) = Mtem;
- imf(t+1,:) = Mtem(:)';
- % stack imf with each step, Row: 6 var to 1st shock, 6 var to 2nd shock, etc.
- t= t+1;
-end
-
-for t = lags+1:imstep-1
- Mtem = Ah(:,1:nvar*lags)*M(1:nvar*lags,:);
- % Row: nvar equations, each for the nvar variables at tth lag
- M(nvar+1:nvar*(t+1),:) = M(1:nvar*t,:);
- M(1:nvar,:)=Mtem;
- imf(t+1,:) = Mtem(:)';
- % stack imf with each step, Row: 6 var to 1st shock, 6 var to 2nd shock, etc.
-end
diff --git a/matlab/swz/cstz/fn_rlrpostr.m b/matlab/swz/cstz/fn_rlrpostr.m
deleted file mode 100644
index a3ea1bf717e8adede02faaabe7736b1839061c2d..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_rlrpostr.m
+++ /dev/null
@@ -1,50 +0,0 @@
-function [P,H0inv,Hpinv] = fn_rlrpostr(xtx,xty,yty,Ptld,H0invtld,Hpinvtld,Ui,Vi)
-% [P,H0inv,Hpinv] = fn_rlrpostr(xtx,xty,yty,Ptld,H0tld,Hptld,Ui,Vi)
-%
-% Exporting random (i.e., random prior) Bayesian posterior matrices with linear restrictions
-% See Waggoner and Zha's Gibbs sampling paper
-%
-% xtx: X'X: k-by-k where k=ncoef
-% xty: X'Y: k-by-nvar
-% yty: Y'Y: nvar-by-nvar
-% Ptld: cell(nvar,1), transformation matrix that affects the (random walk) prior mean of A+ conditional on A0.
-% H0invtld: cell(nvar,1), transformed inv covaraince for free parameters in A0(:,i).
-% Hpinvtld: cell(nvar,1), transformed inv covaraince for free parameters in A+(:,i);
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation. Imported from dnrprior.m.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k (ncoef) is a total number of RHS variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation. Imported from dnrprior.m.
-%-----------------
-% P: cell(nvar,1). In each cell, the transformation matrix that affects the posterior mean of A+ conditional on A0.
-% In other words, the posterior mean (of g_i) = P{i}*b_i where g_i is a column vector of free parameters
-% of A+(:,i)) given b_i (b_i is a column vector of free parameters of A0(:,i)).
-% H0inv: cell(nvar,1). Not divided by T yet. In each cell, inverse of posterior covariance matrix H0.
-% The exponential term is b_i'*inv(H0)*b_i for the ith equation where b_i = U_i*a0_i.
-% It resembles old SpH or Sbd in the exponent term in posterior of A0, but not divided by T yet.
-% Hpinv: cell(nvar,1). In each cell, posterior inverse of covariance matrix Hp (A+) for the free parameters
-% g_i = V_i*A+(:,i) in the ith equation.
-%
-% Tao Zha, February 2000
-
-nvar = size(yty,1);
-
-P = cell(nvar,1); % tld: tilda
-H0inv = cell(nvar,1); % posterior inv(H0), resemble old SpH, but not divided by T yet.
-Hpinv = cell(nvar,1); % posterior inv(Hp).
-
-
-for n=1:nvar % one for each equation
- Hpinv{n} = Vi{n}'*xtx*Vi{n} + Hpinvtld{n};
- P1 = Vi{n}'*xty*Ui{n} + Hpinvtld{n}*Ptld{n};
- P{n} = Hpinv{n}\P1;
- H0inv{n} = Ui{n}'*yty*Ui{n} + H0invtld{n} + Ptld{n}'*Hpinvtld{n}*Ptld{n} ...
- - P1'*P{n}; %P{n} = (Hpinv{n}\P1);
-end
diff --git a/matlab/swz/cstz/fn_rlrprior.m b/matlab/swz/cstz/fn_rlrprior.m
deleted file mode 100644
index a6df3fc5b3a9664fdd0f91da3b8e70cbb2cd5150..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_rlrprior.m
+++ /dev/null
@@ -1,39 +0,0 @@
-function [Ptld,H0invtld,Hpinvtld] = fn_rlrprior(Ui,Vi,Pi,H0multi,Hpmulti,nvar)
-% [Ptld,H0invtld,Hpinvtld] = fn_rlrprior(Ui,Vi,Pi,H0multi,Hpmulti,nvar)
-%
-% Exporting random Bayesian prior with linear restrictions
-% See Waggoner and Zha's Gibbs sampling paper
-%
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation. Imported from dnrprior.m.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k (ncoef) is a total number of RHS variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation. Imported from dnrprior.m.
-% Pi: ncoef-by-nvar matrix for the ith equation under random walk. Same for all equations
-% H0multi: nvar-by-nvar-by-nvar; H0 for different equations under asymmetric prior
-% Hpmulti: ncoef-by-ncoef-by-nvar; H+ for different equations under asymmetric prior
-% nvar: number of endogenous variables
-% --------------------
-% Ptld: cell(nvar,1). The prior mean of g_i is Ptld{i}*b_i;
-% H0invtld: cell(nvar,1). Transformed inv covaraince for b_i, the free parameters in A0(:,i);
-% Hpinvtld: cell(nvar,1). Transformed inv covaraince for g_i, the free parameters in A+(:,i);
-%
-% Tao Zha, February 2000
-
-Ptld = cell(nvar,1); % tld: tilda
-H0invtld = cell(nvar,1); % H0 for different equations under linear restrictions
-Hpinvtld = cell(nvar,1); % H+ for different equations under linear restrictions
-
-for n=1:nvar % one for each equation
- Hpinvtld{n} = Vi{n}'*(Hpmulti(:,:,n)\Vi{n});
- Ptld{n} = (Hpinvtld{n}\Vi{n}')*(Hpmulti(:,:,n)\Pi)*Ui{n};
- H0invtld{n} = Ui{n}'*(H0multi(:,:,n)\Ui{n}) + Ui{n}'*Pi'*(Hpmulti(:,:,n)\Pi)*Ui{n} ...
- - Ptld{n}'*Hpinvtld{n}*Ptld{n};
-end
diff --git a/matlab/swz/cstz/fn_rnrprior_covres_dobs.m b/matlab/swz/cstz/fn_rnrprior_covres_dobs.m
deleted file mode 100644
index bbe7be856a2480eff16db26038b11d8ff2b899a1..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_rnrprior_covres_dobs.m
+++ /dev/null
@@ -1,280 +0,0 @@
-function [Pi,H0multi,Hpmulti,H0invmulti,Hpinvmulti] ...
- = fn_rnrprior_covres_dobs(nvar,q_m,lags,xdgel,mu,indxDummy,hpmsmd,indxmsmdeqn,nexo,asym0,asymp)
-% Differs from fn_rnrprior_covres_dobs_tv(): no linear restrictions (Ui and Vi) have applied yet to this function, but
-% linear restrictions are incorported in fn_rnrprior_covres_dobs_tv().
-%
-% Only works for the nexo=1 (constant term) case. To extend this to other exogenous variables, see fn_dataxy.m. 01/14/03.
-% Differs from fn_rnrprior_covres.m in that dummy observations are included as part of the explicit prior. See Forcast II, pp.68-69b.
-% More general than fn_rnrprior.m because when hpmsmd=0, fn_rnrprior_covres() is the same as fn_rnrprior().
-% Allows for prior covariances for the MS and MD equations to achieve liquidity effects.
-% Exports random Bayesian prior of Sims and Zha with asymmetric rior (but no linear restrictions yet)
-% See Waggoner and Zha's Gibbs sampling paper and TVBVAR NOTES p. 71k.0.
-%
-% nvar: number of endogenous variables
-% q_m: quarter or month
-% lags: the maximum length of lag
-% xdgel: T*nvar endogenous-variable matrix of raw or original data (no manipulation involved) with sample size including lags.
-% Order of columns: (1) nvar endogenous variables; (2) constants will be automatically put in the last column.
-% Used only to get variances of residuals for mu(1)-mu(5) and for dummy observations mu(5) and mu(6).
-% mu: 6-by-1 vector of hyperparameters (the following numbers for Atlanta Fed's forecast), where
-% mu(5) and mu(6) are NOT used here. See fn_dataxy.m for using mu(5) and mu(6).
-% mu(1): overall tightness and also for A0; (0.57)
-% mu(2): relative tightness for A+; (0.13)
-% mu(3): relative tightness for the constant term; (0.1). NOTE: for other
-% exogenous terms, the variance of each exogenous term must be taken into
-% acount to eliminate the scaling factor.
-% mu(4): tightness on lag decay; (1)
-% mu(5): weight on nvar sums of coeffs dummy observations (unit roots); (5)
-% mu(6): weight on single dummy initial observation including constant
-% (cointegration, unit roots, and stationarity); (5)
-% indxDummy: 1: uses dummy observations to form part of an explicit prior; 0: no dummy observations as part of the prior.
-% hpmsmd: 2-by-1 hyperparameters with -1<h1=hpmsmd(1)<=0 for the MS equation and 0<=h2=hpmsmd(2)<1 the MD equation. Consider a1*R + a2*M.
-% The term h1*var(a1)*var(a2) is the prior covariance of a1 and a2 for MS, equivalent to penalizing the same sign of a1 and a2.
-% The term h2*var(a1)*var(a2) is the prior covariance of a1 and a2 for MD, equivalent to penalizing opposite signs of a1 and a2.
-% This will give us a liquidity effect.
-% indxmsmdeqn: 4-by-1 index for the locations of the MS and MD equation and for the locations of M and R.
-% indxmsmdeqn(1) for MS and indxmsmdeqn(2) for MD.
-% indxmsmdeqn(3) for M and indxmsmdeqn(4) for R.
-% nexo: number of exogenous variables (if not specified, nexo=1 (constant) by default).
-% The constant term is always put to the last of all endogenous and exogenous variables.
-% asym0: nvar-by-nvar asymmetric prior on A0. Column -- equation.
-% If ones(nvar,nvar), symmetric prior; if not, relative (asymmetric) tightness on A0.
-% asymp: ncoef-1-by-nvar asymmetric prior on A+ bar constant. Column -- equation.
-% If ones(ncoef-1,nvar), symmetric prior; if not, relative (asymmetric) tightness on A+.
-% --------------------
-% Pi: ncoef-by-nvar matrix for the ith equation under random walk. Same for all equations
-% H0multi: nvar-by-nvar-by-nvar; H0 for different equations under asymmetric prior
-% Hpmulti: ncoef-by-ncoef-by-nvar; H+ for different equations under asymmetric prior
-% H0invmulti: nvar-by-nvar-by-nvar; inv(H0) for different equations under asymmetric prior
-% Hpinvmulti: ncoef-by-ncoef-by-nvar; inv(H+) for different equations under asymmetric prior
-%
-% Tao Zha, February 2000. Revised, September 2000, February, May 2003.
-
-
-
-if (nargin<=8), nexo=1; end
-ncoef = nvar*lags+nexo; % number of coefficients in *each* equation, RHS coefficients only.
-
-H0multi=zeros(nvar,nvar,nvar); % H0 for different equations under asymmetric prior
-Hpmulti=zeros(ncoef,ncoef,nvar); % H+ for different equations under asymmetric prior
-H0invmulti=zeros(nvar,nvar,nvar); % inv(H0) for different equations under asymmetric prior
-Hpinvmulti=zeros(ncoef,ncoef,nvar); % inv(H+) for different equations under asymmetric prior
-
-%*** Constructing Pi for the ith equation under the random walk assumption
-Pi = zeros(ncoef,nvar); % same for all equations
-Pi(1:nvar,1:nvar) = eye(nvar); % random walk
-
-%
-%@@@ Prepared for Bayesian prior
-%
-%
-% ** monthly lag decay in order to match quarterly decay: a*exp(bl) where
-% ** l is the monthly lag. Suppose quarterly decay is 1/x where x=1,2,3,4.
-% ** Let the decay of l1 (a*exp(b*l1)) match that of x1 (say, beginning: 1/1)
-% ** and the decay of l2 (a*exp(b*l2)) match that of x2 (say, end: 1/5),
-% ** we can solve for a and b which are
-% ** b = (log_x1-log_x2)/(l1-l2), and a = x1*exp(-b*l1).
-if q_m==12
- l1 = 1; % 1st month == 1st quarter
- xx1 = 1; % 1st quarter
- l2 = lags; % last month
- xx2 = 1/((ceil(lags/3))^mu(4)); % last quarter
- %xx2 = 1/6; % last quarter
- % 3rd quarter: i.e., we intend to let decay of the 6th month match
- % that of the 3rd quarter, so that the 6th month decays a little
- % faster than the second quarter which is 1/2.
- if lags==1
- b = 0;
- else
- b = (log(xx1)-log(xx2))/(l1-l2);
- end
- a = xx1*exp(-b*l1);
-end
-
-
-
-%
-% *** specify the prior for each equation separately, SZ method,
-% ** get the residuals from univariate regressions.
-%
-sgh = zeros(nvar,1); % square root
-sgsh = sgh; % square
-nSample=size(xdgel,1); % sample size-lags
-yu = xdgel;
-C = ones(nSample,1);
-for k=1:nvar
- [Bk,ek,junk1,junk2,junk3,junk4] = sye([yu(:,k) C],lags);
- clear Bk junk1 junk2 junk3 junk4;
- sgsh(k) = ek'*ek/(nSample-lags);
- sgh(k) = sqrt(sgsh(k));
-end
-% ** prior variance for A0(:,1), same for all equations!!!
-sg0bid = zeros(nvar,1); % Sigma0_bar diagonal only for the ith equation
-for j=1:nvar
- sg0bid(j) = 1/sgsh(j); % sgsh = sigmai^2
-end
-% ** prior variance for lagged and exogeous variables, same for all equations
-sgpbid = zeros(ncoef,1); % Sigma_plus_bar, diagonal, for the ith equation
-for i = 1:lags
- if (q_m==12)
- lagdecay = a*exp(b*i*mu(4));
- end
- %
- for j = 1:nvar
- if (q_m==12)
- % exponential decay to match quarterly decay
- sgpbid((i-1)*nvar+j) = lagdecay^2/sgsh(j); % ith equation
- elseif (q_m==4)
- sgpbid((i-1)*nvar+j) = (1/i^mu(4))^2/sgsh(j); % ith equation
- else
- error('Incompatibility with lags, check the possible errors!!!')
- %warning('Incompatibility with lags, check the possible errors!!!')
- %return
- end
- end
-end
-%
-
-if indxDummy % Dummy observations as part of the explicit prior.
- ndobs=nvar+1; % Number of dummy observations: nvar unit roots and 1 cointegration prior.
- phibar = zeros(ndobs,ncoef);
- %* constant term
- const = ones(nvar+1,1);
- const(1:nvar) = 0.0;
- phibar(:,ncoef) = const; % the first nvar periods: no or zero constant!
-
- xdgelint = mean(xdgel(1:lags,:),1); % mean of the first lags initial conditions
- %* Dummies
- for k=1:nvar
- for m=1:lags
- phibar(ndobs,nvar*(m-1)+k) = xdgelint(k);
- phibar(k,nvar*(m-1)+k) = xdgelint(k);
- % <<>> multiply hyperparameter later
- end
- end
- phibar(1:nvar,:) = 1*mu(5)*phibar(1:nvar,:); % standard Sims and Zha prior
- phibar(ndobs,:) = mu(6)*phibar(ndobs,:);
- [phiq,phir]=qr(phibar,0);
- xtxbar=phir'*phir; % phibar'*phibar. ncoef-by-ncoef. Reduced (not full) rank. See Forcast II, pp.69-69b.
-end
-
-%=================================================
-% Computing the (prior) covariance matrix for A0, no data yet.
-% As proved in pp.69a-69b, Forecast II, the following prior covariance of A0
-% will remain the same after the dummy observations prior is incorporated.
-% The dummy observation prior only affects the prior covariance of A+|A0.
-% See pp.69a-69b for the proof.
-%=================================================
-%
-%
-% ** set up the conditional prior variance sg0bi and sgpbi.
-sg0bida = mu(1)^2*sg0bid; % ith equation
-sgpbida = mu(1)^2*mu(2)^2*sgpbid;
-sgpbida(ncoef-nexo+1:ncoef) = mu(1)^2*mu(3)^2;
- %<<>> No scaling adjustment has been made for exogenous terms other than constant
-sgppbd = sgpbida(nvar+1:ncoef); % corresponding to A++, in a Sims-Zha paper
-
-Hptd = zeros(ncoef);
-Hptdi=Hptd;
-Hptd(ncoef,ncoef)=sgppbd(ncoef-nvar);
-Hptdinv(ncoef,ncoef)=1./sgppbd(ncoef-nvar);
- % condtional on A0i, H_plus_tilde
-
-
-if nargin<10 % the default is no asymmetric information
- asym0 = ones(nvar,nvar); % if not ones, then we have relative (asymmetric) tightness
- asymp = ones(ncoef-1,nvar); % for A+. Column -- equation
-end
-
-%**** Asymmetric Information
-%asym0 = ones(nvar,nvar); % if not ones, then we have relative (asymmetric) tightness
-%asymp = ones(ncoef-1,nvar); % pp: plus without constant. Column -- equation
-%>>>>>> B: asymmetric prior variance for asymp <<<<<<<<
-%
-%for i = 1:lags
-% rowif = (i-1)*nvar+1;
-% rowil = i*nvar;
-% idmatw0 = 0.5; % weight assigned to idmat0 in the formation of asymp
-% if (i==1)
-% asymp(rowif:rowil,:)=(1-idmatw0)*ones(nvar)+idmatw0*idmat0; % first lag
-% % note: idmat1 is already transposed. Column -- equation
-% else
-% %asymp(rowif:rowil,1:nvar) = (1-idmatw0)*ones(nvar)+idmatw0*idmat0;
-% % <<<<<<< toggle +
-% % Note: already transposed, since idmat0 is transposed.
-% % Meaning: column implies equation
-% asymp(rowif:rowil,1:nvar) = ones(nvar);
-% % >>>>>>> toggle -
-% end
-%end
-%
-%>>>>>> E: asymmetric prior variance for asymp <<<<<<<<
-
-
-%=================================================
-% Computing the final covariance matrix (S1,...,Sm) for the prior of A0,
-% and final Gb=(G1,...,Gm) for A+ if asymmetric prior or for
-% B if symmetric prior for A+
-%=================================================
-%
-for i = 1:nvar
- %------------------------------
- % Introduce prior information on which variables "belong" in various equations.
- % In this first trial, we just introduce this information here, in a model-specific way.
- % Eventually this info has to be passed parametricly. In our first shot, we just damp down
- % all coefficients except those on the diagonal.
-
- %*** For A0
- factor0=asym0(:,i);
- sg0bd = sg0bida.*factor0; % Note, this only works for the prior variance Sg(i)
- % of a0(i) being diagonal. If the prior variance Sg(i) is not
- % diagonal, we have to the inverse to get inv(Sg(i)).
- %sg0bdinv = 1./sg0bd;
- % * unconditional variance on A0+
- H0td = diag(sg0bd); % unconditional
- %=== Correlation in the MS equation to get a liquidity effect.
- if (i==indxmsmdeqn(1))
- H0td(indxmsmdeqn(3),indxmsmdeqn(4)) = hpmsmd(1)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- H0td(indxmsmdeqn(4),indxmsmdeqn(3)) = hpmsmd(1)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- elseif (i==indxmsmdeqn(2))
- H0td(indxmsmdeqn(3),indxmsmdeqn(4)) = hpmsmd(2)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- H0td(indxmsmdeqn(4),indxmsmdeqn(3)) = hpmsmd(2)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- end
- H0tdinv = inv(H0td);
- %H0tdinv = diag(sg0bdinv);
- %
- H0multi(:,:,i)=H0td;
- H0invmulti(:,:,i)=H0tdinv;
-
-
- %*** For A+
- if ~(lags==0) % For A1 to remain random walk properties
- factor1=asymp(1:nvar,i);
- sg1bd = sgpbida(1:nvar).*factor1;
- sg1bdinv = 1./sg1bd;
- %
- Hptd(1:nvar,1:nvar)=diag(sg1bd);
- Hptdinv(1:nvar,1:nvar)=diag(sg1bdinv);
- if lags>1
- factorpp=asymp(nvar+1:ncoef-1,i);
- sgpp_cbd = sgppbd(1:ncoef-nvar-1) .* factorpp;
- sgpp_cbdinv = 1./sgpp_cbd;
- Hptd(nvar+1:ncoef-1,nvar+1:ncoef-1)=diag(sgpp_cbd);
- Hptdinv(nvar+1:ncoef-1,nvar+1:ncoef-1)=diag(sgpp_cbdinv);
- % condtional on A0i, H_plus_tilde
- end
- end
- %---------------
- % The dummy observation prior affects only the prior covariance of A+|A0,
- % but not the covariance of A0. See pp.69a-69b for the proof.
- %---------------
- if indxDummy % Dummy observations as part of the explicit prior.
- Hpinvmulti(:,:,i)=Hptdinv + xtxbar;
- Hpmulti(:,:,i) = inv(Hpinvmulti(:,:,i));
- else
- Hpmulti(:,:,i)=Hptd;
- Hpinvmulti(:,:,i)=Hptdinv;
- end
-end
-
-
diff --git a/matlab/swz/cstz/fn_rnrprior_covres_dobs_tv2.m b/matlab/swz/cstz/fn_rnrprior_covres_dobs_tv2.m
deleted file mode 100644
index 9fc6cdbe37d069368ef60ed16437e3b0d902abdb..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_rnrprior_covres_dobs_tv2.m
+++ /dev/null
@@ -1,309 +0,0 @@
-function [Pi_bar,H0tldcell_inv,Hptldcell_inv] ...
- = fn_rnrprior_covres_dobs_tv2(nvar,nStates,indxScaleStates,q_m,lags,xdgel,mu,indxDummy,Ui,Vi,hpmsmd,indxmsmdeqn,nexo,asym0,asymp)
-% Differs from fn_rnrprior_covres_dobs(): linear restrictions (Ui and Vi) have been incorported in fn_rnrprior_covres_dobs_tv?().
-% Differs from fn_rnrprior_covres_dobs_tv(): allows an option to scale up the prior variance by nStates or not scale at all,
-% so that the prior value is the same as the constant VAR when the parameters in all states are the same.
-%
-% Only works for the nexo=1 (constant term) case. To extend this to other exogenous variables, see fn_dataxy.m. 01/14/03.
-% Differs from fn_rnrprior_covres_tv.m in that dummy observations are included as part of the explicit prior. See Forcast II, pp.68-69b.
-% Exports random Bayesian prior of Sims and Zha with asymmetric rior with linear restrictions already applied
-% and with dummy observations (i.e., mu(5) and mu(6)) used as part of an explicit prior.
-% This function allows for prior covariances for the MS and MD equations to achieve liquidity effects.
-% See Waggoner and Zha's Gibbs sampling paper and TVBVAR NOTES pp. 71k.0 and 50-61.
-%
-% nvar: number of endogenous variables
-% nStates: Number of states.
-% indxScaleStates: if 0, no scale adjustment in the prior variance for the number of states in the function fn_rnrprior_covres_dobs_tv2();
-% if 1: allows a scale adjustment, marking the prior variance bigger by the number of states.
-% q_m: quarter or month
-% lags: the maximum length of lag
-% xdgel: T*nvar endogenous-variable matrix of raw or original data (no manipulation involved) with sample size including lags.
-% Order of columns: (1) nvar endogenous variables; (2) constants will be automatically put in the last column.
-% Used only to get variances of residuals for mu(1)-mu(5) and for dummy observations mu(5) and mu(6).
-% mu: 6-by-1 vector of hyperparameters (the following numbers for Atlanta Fed's forecast), where
-% mu(5) and mu(6) are NOT used here. See fn_dataxy.m for using mu(5) and mu(6).
-% mu(1): overall tightness and also for A0; (0.57)
-% mu(2): relative tightness for A+; (0.13)
-% mu(3): relative tightness for the constant term; (0.1). NOTE: for other
-% exogenous terms, the variance of each exogenous term must be taken into
-% acount to eliminate the scaling factor.
-% mu(4): tightness on lag decay; (1)
-% mu(5): weight on nvar sums of coeffs dummy observations (unit roots); (5)
-% mu(6): weight on single dummy initial observation including constant
-% (cointegration, unit roots, and stationarity); (5)
-% NOTE: for this function, mu(5) and mu(6) are not used. See fn_dataxy.m for using mu(5) and mu(6).
-% indxDummy: 1: uses dummy observations to form part of an explicit prior; 0: no dummy observations as part of the prior.
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi*si orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters
-% within the state and si is the number of free states.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation in the order of [a_i for 1st state, ..., a_i for last state].
-% Vi: nvar-by-1 cell. In each cell, k-by-ri*ti orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters within the state and ti is the number of free states.
-% With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. The ith equation is in the order of [nvar variables
-% for 1st lag and 1st state, ..., nvar variables for last lag and 1st state, const for 1st state, nvar
-% variables for 1st lag and 2nd state, nvar variables for last lag and 2nd state, const for 2nd state, and so on].
-% hpmsmd: 2-by-1 hyperparameters with -1<h1=hpmsmd(1)<=0 for the MS equation and 0<=h2=hpmsmd(2)<1 the MD equation. Consider a1*R + a2*M.
-% The term h1*var(a1)*var(a2) is the prior covariance of a1 and a2 for MS, equivalent to penalizing the same sign of a1 and a2.
-% The term h2*var(a1)*var(a2) is the prior covariance of a1 and a2 for MD, equivalent to penalizing opposite signs of a1 and a2.
-% This will give us a liquidity effect. If hpmsmd=0, no such restrictions will be imposed.
-% indxmsmdeqn: 4-by-1 index for the locations of the MS and MD equation and for the locations of M and R.
-% indxmsmdeqn(1) for MS and indxmsmdeqn(2) for MD.
-% indxmsmdeqn(3) for M and indxmsmdeqn(4) for R.
-% nexo: number of exogenous variables (if not specified, nexo=1 (constant) by default).
-% The constant term is always put to the last of all endogenous and exogenous variables.
-% asym0: nvar-by-nvar asymmetric prior on A0. Column -- equation.
-% If ones(nvar,nvar), symmetric prior; if not, relative (asymmetric) tightness on A0.
-% asymp: ncoef-1-by-nvar asymmetric prior on A+ bar constant. Column -- equation.
-% If ones(ncoef-1,nvar), symmetric prior; if not, relative (asymmetric) tightness on A+.
-% --------------------
-% Pi_bar: ncoef-by-nvar matrix for the ith equation under random walk. Same for all equations
-% H0tldcell_inv: cell(nvar,1). The ith cell represents the ith equation, where the dim is
-% qi*si-by-qi*si. The inverse of H0tld on p.60.
-% Hptldcell_inv: cell(nvar,1). The ith cell represents the ith equation, where the dim is
-% ri*ti-by-ri*ti.The inverse of Hptld on p.60.
-%
-% Differs from fn_rnrprior_covres_dobs(): linear restrictions (Ui and Vi) have been incorported in fn_rnrprior_covres_dobs_tv?().
-% Differs from fn_rnrprior_covres_dobs_tv(): allows an option to scale up the prior variance by nStates or not scale at all.
-% so that the prior value is the same as the constant VAR when the parameters in all states are the same.
-% Tao Zha, February 2000. Revised, September 2000, 2001, February, May 2003, May 2004.
-
-
-if nargin<=12, nexo=1; end % <<>>1
-ncoef = nvar*lags+nexo; % Number of coefficients in *each* equation for each state, RHS coefficients only.
-ncoefsts = nStates*ncoef; % Number of coefficients in *each* equation in all states, RHS coefficients only.
-
-H0tldcell_inv=cell(nvar,1); % inv(H0tilde) for different equations under asymmetric prior.
-Hptldcell_inv=cell(nvar,1); % inv(H+tilde) for different equations under asymmetric prior.
-
-%*** Constructing Pi_bar for the ith equation under the random walk assumption
-Pi_bar = zeros(ncoef,nvar); % same for all equations
-Pi_bar(1:nvar,1:nvar) = eye(nvar); % random walk
-
-%
-%@@@ Prepared for Bayesian prior
-%
-%
-% ** monthly lag decay in order to match quarterly decay: a*exp(bl) where
-% ** l is the monthly lag. Suppose quarterly decay is 1/x where x=1,2,3,4.
-% ** Let the decay of l1 (a*exp(b*l1)) match that of x1 (say, beginning: 1/1)
-% ** and the decay of l2 (a*exp(b*l2)) match that of x2 (say, end: 1/5),
-% ** we can solve for a and b which are
-% ** b = (log_x1-log_x2)/(l1-l2), and a = x1*exp(-b*l1).
-if q_m==12
- l1 = 1; % 1st month == 1st quarter
- xx1 = 1; % 1st quarter
- l2 = lags; % last month
- xx2 = 1/((ceil(lags/3))^mu(4)); % last quarter
- %xx2 = 1/6; % last quarter
- % 3rd quarter: i.e., we intend to let decay of the 6th month match
- % that of the 3rd quarter, so that the 6th month decays a little
- % faster than the second quarter which is 1/2.
- if lags==1
- b = 0;
- else
- b = (log(xx1)-log(xx2))/(l1-l2);
- end
- a = xx1*exp(-b*l1);
-end
-
-
-
-%
-% *** specify the prior for each equation separately, SZ method,
-% ** get the residuals from univariate regressions.
-%
-sgh = zeros(nvar,1); % square root
-sgsh = sgh; % square
-nSample=size(xdgel,1); % sample size-lags
-yu = xdgel;
-C = ones(nSample,1);
-for k=1:nvar
- [Bk,ek,junk1,junk2,junk3,junk4] = sye([yu(:,k) C],lags);
- clear Bk junk1 junk2 junk3 junk4;
- sgsh(k) = ek'*ek/(nSample-lags);
- sgh(k) = sqrt(sgsh(k));
-end
-% ** prior variance for A0(:,1), same for all equations!!!
-sg0bid = zeros(nvar,1); % Sigma0_bar diagonal only for the ith equation
-for j=1:nvar
- sg0bid(j) = 1/sgsh(j); % sgsh = sigmai^2
-end
-% ** prior variance for lagged and exogeous variables, same for all equations
-sgpbid = zeros(ncoef,1); % Sigma_plus_bar, diagonal, for the ith equation
-for i = 1:lags
- if (q_m==12)
- lagdecay = a*exp(b*i*mu(4));
- end
- %
- for j = 1:nvar
- if (q_m==12)
- % exponential decay to match quarterly decay
- sgpbid((i-1)*nvar+j) = lagdecay^2/sgsh(j); % ith equation
- elseif (q_m==4)
- sgpbid((i-1)*nvar+j) = (1/i^mu(4))^2/sgsh(j); % ith equation
- else
- error('Incompatibility with lags, check the possible errors!!!')
- %warning('Incompatibility with lags, check the possible errors!!!')
- %return
- end
- end
-end
-%
-if indxDummy % Dummy observations as part of the explicit prior.
- ndobs=nvar+1; % Number of dummy observations: nvar unit roots and 1 cointegration prior.
- phibar = zeros(ndobs,ncoef);
- %* constant term
- const = ones(nvar+1,1);
- const(1:nvar) = 0.0;
- phibar(:,ncoef) = const; % the first nvar periods: no or zero constant!
-
- xdgelint = mean(xdgel(1:lags,:),1); % mean of the first lags initial conditions
- %* Dummies
- for k=1:nvar
- for m=1:lags
- phibar(ndobs,nvar*(m-1)+k) = xdgelint(k);
- phibar(k,nvar*(m-1)+k) = xdgelint(k);
- % <<>> multiply hyperparameter later
- end
- end
- phibar(1:nvar,:) = 1*mu(5)*phibar(1:nvar,:); % standard Sims and Zha prior
- phibar(ndobs,:) = mu(6)*phibar(ndobs,:);
- [phiq,phir]=qr(phibar,0);
- xtxbar=phir'*phir; % phibar'*phibar. ncoef-by-ncoef. Reduced (not full) rank. See Forcast II, pp.69-69b.
-end
-
-
-
-
-
-%=================================================
-% Computing the (prior) covariance matrix for the posterior of A0, no data yet
-%=================================================
-%
-%
-% ** set up the conditional prior variance sg0bi and sgpbi.
-sg0bida = mu(1)^2*sg0bid; % ith equation
-sgpbida = mu(1)^2*mu(2)^2*sgpbid;
-sgpbida(ncoef-nexo+1:ncoef) = mu(1)^2*mu(3)^2;
- %<<>> No scaling adjustment has been made for exogenous terms other than constant
-sgppbd = sgpbida(nvar+1:ncoef); % corresponding to A++, in a Sims-Zha paper
-
-Hptd = zeros(ncoef);
-Hptdi=Hptd;
-Hptd(ncoef,ncoef)=sgppbd(ncoef-nvar);
-Hptdinv(ncoef,ncoef)=1./sgppbd(ncoef-nvar);
- % condtional on A0i, H_plus_tilde
-
-
-if nargin<14 % <<>>1 Default is no asymmetric information
- asym0 = ones(nvar,nvar); % if not ones, then we have relative (asymmetric) tightness
- asymp = ones(ncoef-1,nvar); % for A+. Column -- equation
-end
-
-%**** Asymmetric Information
-%asym0 = ones(nvar,nvar); % if not ones, then we have relative (asymmetric) tightness
-%asymp = ones(ncoef-1,nvar); % pp: plus without constant. Column -- equation
-%>>>>>> B: asymmetric prior variance for asymp <<<<<<<<
-%
-%for i = 1:lags
-% rowif = (i-1)*nvar+1;
-% rowil = i*nvar;
-% idmatw0 = 0.5; % weight assigned to idmat0 in the formation of asymp
-% if (i==1)
-% asymp(rowif:rowil,:)=(1-idmatw0)*ones(nvar)+idmatw0*idmat0; % first lag
-% % note: idmat1 is already transposed. Column -- equation
-% else
-% %asymp(rowif:rowil,1:nvar) = (1-idmatw0)*ones(nvar)+idmatw0*idmat0;
-% % <<<<<<< toggle +
-% % Note: already transposed, since idmat0 is transposed.
-% % Meaning: column implies equation
-% asymp(rowif:rowil,1:nvar) = ones(nvar);
-% % >>>>>>> toggle -
-% end
-%end
-%
-%>>>>>> E: asymmetric prior variance for asymp <<<<<<<<
-
-
-%=================================================
-% Computing the final covariance matrix (S1,...,Sm) for the prior of A0,
-% and final Gb=(G1,...,Gm) for A+ if asymmetric prior or for
-% B if symmetric prior for A+
-%=================================================
-%
-for i = 1:nvar
- %------------------------------
- % Introduce prior information on which variables "belong" in various equations.
- % In this first trial, we just introduce this information here, in a model-specific way.
- % Eventually this info has to be passed parametricly. In our first shot, we just damp down
- % all coefficients except those on the diagonal.
-
- %*** For A0
- factor0=asym0(:,i);
-
- sg0bd = sg0bida.*factor0; % Note, this only works for the prior variance Sg(i)
- % of a0(i) being diagonal. If the prior variance Sg(i) is not
- % diagonal, we have to the inverse to get inv(Sg(i)).
- %sg0bdinv = 1./sg0bd;
- % * unconditional variance on A0+
- H0td = diag(sg0bd); % unconditional
- %=== Correlation in the MS equation to get a liquidity effect.
- if (i==indxmsmdeqn(1))
- H0td(indxmsmdeqn(3),indxmsmdeqn(4)) = hpmsmd(1)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- H0td(indxmsmdeqn(4),indxmsmdeqn(3)) = hpmsmd(1)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- elseif (i==indxmsmdeqn(2))
- H0td(indxmsmdeqn(3),indxmsmdeqn(4)) = hpmsmd(2)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- H0td(indxmsmdeqn(4),indxmsmdeqn(3)) = hpmsmd(2)*sqrt(sg0bida(indxmsmdeqn(3))*sg0bida(indxmsmdeqn(4)));
- end
- H0tdinv = inv(H0td);
- %H0tdinv = diag(sg0bdinv);
- %
- if indxScaleStates
- H0tldcell_inv{i}=NaN;
- else
- H0tldcell_inv{i}=NaN;
- end
-
-
-
- %*** For A+
- if ~(lags==0) % For A1 to remain random walk properties
- factor1=asymp(1:nvar,i);
- sg1bd = sgpbida(1:nvar).*factor1;
- sg1bdinv = 1./sg1bd;
- %
- Hptd(1:nvar,1:nvar)=diag(sg1bd);
- Hptdinv(1:nvar,1:nvar)=diag(sg1bdinv);
- if lags>1
- factorpp=asymp(nvar+1:ncoef-1,i);
- sgpp_cbd = sgppbd(1:ncoef-nvar-1) .* factorpp;
- sgpp_cbdinv = 1./sgpp_cbd;
- Hptd(nvar+1:ncoef-1,nvar+1:ncoef-1)=diag(sgpp_cbd);
- Hptdinv(nvar+1:ncoef-1,nvar+1:ncoef-1)=diag(sgpp_cbdinv);
- % condtional on A0i, H_plus_tilde
- end
- end
- %---------------
- % The dummy observation prior affects only the prior covariance of A+|A0,
- % but not the covariance of A0. See pp.69a-69b for the proof.
- %---------------
- if indxDummy % Dummy observations as part of the explicit prior.
- Hptdinv2 = Hptdinv + xtxbar; % Rename Hptdinv to Hptdinv2 because we want to keep Hptdinv diagonal in the next loop of i.
- else
- Hptdinv2 = Hptdinv;
- end
- if (indxScaleStates)
- Hptldcell_inv{i}=NaN;
- else
- Hptldcell_inv{i}=NaN;
- end
- %Hptdinv_3 = kron(eye(nStates),Hptdinv); % ?????
-end
-
-
diff --git a/matlab/swz/cstz/fn_tran_a2b.m b/matlab/swz/cstz/fn_tran_a2b.m
deleted file mode 100644
index b1dec61ec519f38af7277b3289480317dd6d9e98..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_tran_a2b.m
+++ /dev/null
@@ -1,25 +0,0 @@
-function b = fn_tran_a2b(A0,Ui,nvar,n0)
-% b = fn_tran_a2b(A0,Ui,nvar,n0)
-% Transform A0 to free parameters b's. Note: columns correspond to equations
-% See Waggoner and Zha's ``A Gibbs sampler for structural VARs''
-%
-% A0: nvar-by-nvar, contempareous matrix (columns correspond to equations)
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% nvar: number of endogeous variables
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-%----------------
-% b: sum(n0)-by-1 vector of A0 free parameters
-%
-% Tao Zha, February 2000. Revised, August 2000
-
-n0=n0(:);
-n0cum = [0; cumsum(n0)];
-b=zeros(n0cum(end),1);
-for kj = 1:nvar
- b(n0cum(kj)+1:n0cum(kj+1))=Ui{kj}'*A0(:,kj);
-end
diff --git a/matlab/swz/cstz/fn_tran_b2a.m b/matlab/swz/cstz/fn_tran_b2a.m
deleted file mode 100644
index 47bc8cfce50e61e1c216b9761f30aff39b05c5d3..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_tran_b2a.m
+++ /dev/null
@@ -1,24 +0,0 @@
-function A0 = fn_tran_b2a(b,Ui,nvar,n0)
-% A0 = fn_tran_b2a(b,Ui,nvar,n0)
-% Transform free parameters b's to A0. Note: columns correspond to equations
-%
-% b: sum(n0)-by-1 vector of A0 free parameters
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% nvar: number of endogeous variables
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-%----------------
-% A0: nvar-by-nvar, contempareous matrix (columns correspond to equations)
-%
-% Tao Zha, February 2000. Revised, August 2000.
-
-b=b(:); n0=n0(:);
-A0 = zeros(nvar);
-n0cum = [0; cumsum(n0)];
-for kj = 1:nvar
- A0(:,kj) = Ui{kj}*b(n0cum(kj)+1:n0cum(kj+1));
-end
diff --git a/matlab/swz/cstz/fn_varoots.m b/matlab/swz/cstz/fn_varoots.m
deleted file mode 100644
index 43410e3e0f9c9bffcd85cffa659b4f64af981296..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/fn_varoots.m
+++ /dev/null
@@ -1,30 +0,0 @@
-function rootsinv = fn_varoots(Bhat,nvar,lags)
-%
-% Using eigenvalues to find the inverse of all roots associated with the VAR proceess:
-% y_t' = C + y_{t-1}'*B_1 + ... + Y_{t-p}'*B_p + u_t'.
-% where columns correspond to equations. See also Judge (1), pp.753-755 where rows correspond to equations.
-% Bhat: ncoef-by-nvar where ncoef=nvar*lags+nexo and nvar is the number of endogenous variables.
-% Columns corresponds to equations with
-% ncoef=[nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term]
-% ..., nvar coef in the last lag, and nexo coefficients.
-% Note that entries in the rows of Bhat that > nvar*lags are irrelevant.
-% nvar: number of endogenous variables.
-% lags: number of lags.
-%-------
-% rootsinv: a vector of nvar*lags inverse roots. When > 1, explosive. When all < 1, stationary.
-%
-% Tao Zha, September 2000
-
-
-if size(Bhat,1)<nvar*lags
- disp(' ')
- warning('Make sure that Bhat has at least nvar*lags rows')
- return
-end
-
-%--------- Strack the VAR(p) to the VAR(1) with z_t = Az_{t-1}.
-%
-A1 = diag(ones(nvar*(lags-1),1));
-A2 = [A1 zeros(nvar*(lags-1),nvar)];
-A = [Bhat(1:nvar*lags,:)'; A2];
-rootsinv=eig(A);
diff --git a/matlab/swz/cstz/sye.m b/matlab/swz/cstz/sye.m
deleted file mode 100644
index 498ac9b9f7dcd5850eabee093f47a07fc72c8851..0000000000000000000000000000000000000000
--- a/matlab/swz/cstz/sye.m
+++ /dev/null
@@ -1,84 +0,0 @@
-function [Bh,e,xtx,xty,phi,y,ncoe,xr] = sye(z,lags)
-% Now [Bh,e,xtx,xty,phi,y,ncoe,xr] = sye(z,lags)
-% Old: [Bh,e,xtx,xty,phi,y,ncoe,Sigu,xtxinv] = sye(z,lags)
-%
-% Estimate a system of equations in the form of y(T*nvar) = XB + u,
-% X--phi: T*k, B: k*nvar; where T=sp-lags, k=ncoe,
-%
-% z: (T+lags)-by-(nvar+1) raw data matrix (nvar of variables + constant).
-% lags: number of lags
-%--------------------
-% Bh: k-by-nvar estimated reduced-form parameter; column: nvar;
-% row: k=ncoe=[nvar for 1st lag, ..., nvar for last lag, const]
-% e: estimated residual e = y -xBh, T-by-nvar
-% xtx: X'X: k-by-k
-% xty: X'Y: k-by-nvar
-% phi: X; T-by-k; column: [nvar for 1st lag, ..., nvar for last lag, const]
-% y: Y: T-by-nvar
-% ncoe: number of coeffcients per equation: nvar*lags + 1
-% xr: the economy size (k-by-k) in qr(phi) so that xr=chol(X'*X)
-% Sigu: e'*e: nvar-by-nvar. Note, not divided (undivided) by "nobs"
-% xtxinv: inv(X'X): k-by-k
-%
-% See also syed.m (allowing for more predetermined terms) which has not
-% been yet updated as "sye.m".
-%
-% Note, "lags" is something I changed recently, so it may not be compatible
-% with old programs, 10/15/98 by TAZ.
-%
-% Revised, 5/2/99. Replaced outputs Sigu and xtxinv with xr so that previous
-% programs may be incompatible.
-
-
-% ** setup of orders and lengths **
-[sp,nvar] = size(z); % sp: sample period T include lags
-nvar = nvar-1; % -1: takes out the counting of constant
-
-ess = sp-lags; % effective sample size
-sb = lags+1; % sample beginning
-sl = sp; % sample last period
-ncoe = nvar*lags + 1; % with constant
-
-% ** construct X for Y = X*B + U where phi = X **
-x = z(:,1:nvar);
-C = z(:,nvar+1);
-phi = zeros(ess,ncoe);
-phi(:,ncoe) = C(1:ess);
-for k=1:lags, phi(:,nvar*(k-1)+1:nvar*k) = x(sb-k:sl-k,:); end
-% row: T-lags; column: [nvar for 1st lag, ..., nvar for last lag, const]
-% Thus, # of columns is nvar*lags+1 = ncoef.
-% ** estimate: B, XTX, residuals **
-y = x(sb:sl,:);
-%
-%**** The following, though stable, is too slow *****
-% [u d v]=svd(phi,0); %trial
-% %xtx = phi'*phi; % X'X, k*k (ncoe*ncoe)
-% vd=v.*(ones(size(v,2),1)*diag(d)'); %trial
-% dinv = 1./diag(d); % inv(diag(d))
-% vdinv=v.*(ones(size(v,2),1)*dinv'); %trial
-% xtx=vd*vd';
-% xtxinv = vdinv*vdinv';
-% %xty = phi'*y; % X'Y
-% uy = u'*y; %trial
-% xty = vd*uy; %trial
-% %Bh = xtx\xty; %inv(X'X)*(X'Y), k*m (ncoe*nvar).
-% Bh = xtxinv*xty;
-% %e = y - phi*Bh; % from Y = XB + U, e: (T-lags)*nvar
-% e = y - u*uy;
-%**** The following, though stable, is too slow *****
-
-%===== (Fast but perhaps less accurate) alternative to the above =========
-[xq,xr]=qr(phi,0);
-xtx=xr'*xr;
-xty=phi'*y;
-Bh = xr\(xr'\xty);
-e=y-phi*Bh;
-%===== (Fast but perhaps less accurate) alternative to the above =========
-
-
-%* not numerically stable way of computing e'*e
-%Sigu = y'*y-xty'*Bh;
-%Sigu = y'*(eye(ess)-phi*xtxinv*phi')*y; % probablly better way, commented out
- % by TZ, 2/28/98. See following
-%Sigu = y'*(eye(ess)-u*u')*y; % I think this is the best, TZ, 2/28/98
- % Note, u*u'=x*inv(x'x)*x.
diff --git a/matlab/swz/identification/ftd_2s_caseall_upperchol3v.m b/matlab/swz/identification/ftd_2s_caseall_upperchol3v.m
deleted file mode 100644
index 621a59411a1d5f8311f017cf588dc1035b610e1b..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_2s_caseall_upperchol3v.m
+++ /dev/null
@@ -1,228 +0,0 @@
-function [Ui,Vi,n0,np] = ftd_2s_caseall_upperchol3v(lags,nvar,nStates,indxEqnTv_m,nexo)
-% Case 2&3: Policy a0j and a+j have only time-varying structural variances -- Case 2.
-% All policy and nonpolicy a0j's and the corresponding constant terms are completely time-varying and only the scale
-% of each variable in d+j,1** (excluding the constant term) is time-varying -- Case 3.
-%
-% Variables: Pcom, M2, FFR, y, P, U. Equations: information, policy, money demand, y, P, U.
-% Exporting orthonormal matrices for the deterministic linear restrictions
-% (equation by equation) with time-varying A0 and D+** equations.
-% See Model II.3 on pp.71k-71r in TVBVAR NOTES (and Waggoner and Zha's Gibbs sampling paper and TVBVAR NOTES p.58).
-%
-% lags: Maximum length of lag.
-% nvar: Number of endogeous variables.
-% nStates: Number of states.
-% indxEqnTv_m: nvar-by-2. Stores equation characteristics.
-% 1st column: labels of equations [1:nvar]'.
-% 2nd column: labels of time-varying features with
-% 1: indxConst -- all coefficients are constant,
-% 2: indxStv -- only shocks are time-varying,
-% 3: indxTva0pv -- a0 are freely time-varying and each variable i for d+ is time-varying only by the scale lambda_i(s_t).
-% 4: indxTva0ps -- a0 are freely time-varying and only the scale for the whole of d+ is time-varying.
-% 5: indxTv -- time-varying for all coeffficients (a0 and a+) where the lag length for a+ may be shorter.
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant.
-% So far this function is written to handle one exogenous variable, which is a constant term.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar*nStates-by-qi*si orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters
-% within the state and si is the number of free states.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation in the order of [a_i for 1st state, ..., a_i for last state].
-% Vi: nvar-by-1 cell. In each cell, k*nStates-by-ri*si orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters within the state and si is the number of free states.
-% With this transformation, we have fi = Vi*gi or Vi'*fi = gi where fi is a vector of total original
-% parameters and gi is a vector of free parameters. The ith equation is in the order of [nvar variables
-% for 1st lag and 1st state, ..., nvar variables for last lag and 1st state, const for 1st state, nvar
-% variables for 1st lag and 2nd state, nvar variables for last lag and 2nd state, const for 2nd state, and so on].
-% n0: nvar-by-1, whose ith element represents the number of free A0 parameters in ith equation in *all states*.
-% np: nvar-by-1, whose ith element represents the number of free D+ parameters in ith equation in *all states*.
-%
-% Tao Zha, February 2003
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation in all states.
-np = zeros(nvar,1); % ith element represents the number of free D+ parameters in ith equation in all states.
-
-if (nargin==3)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-end
-
-
-n = nvar*nStates;
-kvar=lags*nvar+nexo; % Maximum number of lagged and exogenous variables in each equation under each state.
-k = kvar*nStates; % Maximum number of lagged and exogenous variables in each equation in all states.
-
-Qi = zeros(n,n,nvar); % 3rd dim: nvar contemporaneous equations.
-Ri = zeros(k,k,nvar); % 1st and 2nd dims: lagged and exogenous equations.
- % Row corresponds to equation with nvar variables for state 1, ..., nvar variables for state nState.
- % 0 means no restriction.
- % 1 and -1 or any other number means the linear combination of the corresponding parameters is restricted to 0.
- % 1 (only 1) means that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time for A0_s.
-%-------------------------------------------------------------
-%
-
-%======== The first equation ===========
-eqninx = 1;
-nreseqn = 2; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 -1 0 0
- 0 1 0 0 -1 0
- 0 0 1 0 0 -1
-
- 0 0 0 0 1 0
- 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 1 0 0 0 0
- 0 0 1 0 0 0
-
- 0 0 0 0 1 0
- 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_*.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The second equation ===========
-eqninx = 2;
-nreseqn = 1; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 -1 0 0
- 0 1 0 0 -1 0
- 0 0 1 0 0 -1
-
- 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 1 0 0 0
-
- 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_3s_case3a.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-
- %==== For freely time-varying A+ for only the first 6 lags.
- %==== Lagged restrictions: zeros on all lags except the first 6 lags in the MS equation.
- % nlagsno0 = 6; % Number of lags to be nonzero.
- % for si=1:nStates
- % for ki = 1:lags-nlagsno0
- % for kj=1:nvar
- % Ri(kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,2) = 1;
- % end
- % end
- % end
- %**** For constant D+_s except the first two lags and the constant term. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- % for si=1:nStates-1
- % for ki=[2*nvar+1:kvar-1]
- % Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- % end
- % end
-end
-
-
-%======== The third equation (money demand) ===========
-eqninx = 3;
-nreseqn = 0; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 -1 0 0
- 0 1 0 0 -1 0
- 0 0 1 0 0 -1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_*.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-
-for ki=1:nvar % initializing loop for each equation
- Ui{ki} = null(Qi(:,:,ki));
- Vi{ki} = null(Ri(:,:,ki));
- n0(ki) = size(Ui{ki},2);
- np(ki) = size(Vi{ki},2);
-end
diff --git a/matlab/swz/identification/ftd_2s_caseall_upperchol4v.m b/matlab/swz/identification/ftd_2s_caseall_upperchol4v.m
deleted file mode 100644
index d83a90b3723b85d45b23be36fb8894876da2a500..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_2s_caseall_upperchol4v.m
+++ /dev/null
@@ -1,331 +0,0 @@
-function [Ui,Vi,n0,np] = ftd_2s_caseall_upperchol4v(lags,nvar,nStates,indxEqnTv_m,nexo)
-% Case 2&3: Policy a0j and a+j have only time-varying structural variances -- Case 2.
-% All policy and nonpolicy a0j's and the corresponding constant terms are completely time-varying and only the scale
-% of each variable in d+j,1** (excluding the constant term) is time-varying -- Case 3.
-%
-% Variables: Pcom, M2, FFR, y, P, U. Equations: information, policy, money demand, y, P, U.
-% Exporting orthonormal matrices for the deterministic linear restrictions
-% (equation by equation) with time-varying A0 and D+** equations.
-% See Model II.3 on pp.71k-71r in TVBVAR NOTES (and Waggoner and Zha's Gibbs sampling paper and TVBVAR NOTES p.58).
-%
-% lags: Maximum length of lag.
-% nvar: Number of endogeous variables.
-% nStates: Number of states.
-% indxEqnTv_m: nvar-by-2. Stores equation characteristics.
-% 1st column: labels of equations [1:nvar]'.
-% 2nd column: labels of time-varying features with
-% 1: indxConst -- all coefficients are constant,
-% 2: indxStv -- only shocks are time-varying,
-% 3: indxTva0pv -- a0 are freely time-varying and each variable i for d+ is time-varying only by the scale lambda_i(s_t).
-% 4: indxTva0ps -- a0 are freely time-varying and only the scale for the whole of d+ is time-varying.
-% 5: indxTv -- time-varying for all coeffficients (a0 and a+) where the lag length for a+ may be shorter.
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant.
-% So far this function is written to handle one exogenous variable, which is a constant term.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar*nStates-by-qi*si orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters
-% within the state and si is the number of free states.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation in the order of [a_i for 1st state, ..., a_i for last state].
-% Vi: nvar-by-1 cell. In each cell, k*nStates-by-ri*si orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters within the state and si is the number of free states.
-% With this transformation, we have fi = Vi*gi or Vi'*fi = gi where fi is a vector of total original
-% parameters and gi is a vector of free parameters. The ith equation is in the order of [nvar variables
-% for 1st lag and 1st state, ..., nvar variables for last lag and 1st state, const for 1st state, nvar
-% variables for 1st lag and 2nd state, nvar variables for last lag and 2nd state, const for 2nd state, and so on].
-% n0: nvar-by-1, whose ith element represents the number of free A0 parameters in ith equation in *all states*.
-% np: nvar-by-1, whose ith element represents the number of free D+ parameters in ith equation in *all states*.
-%
-% Tao Zha, February 2003
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation in all states.
-np = zeros(nvar,1); % ith element represents the number of free D+ parameters in ith equation in all states.
-
-if (nargin==3)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-end
-
-
-n = nvar*nStates;
-kvar=lags*nvar+nexo; % Maximum number of lagged and exogenous variables in each equation under each state.
-k = kvar*nStates; % Maximum number of lagged and exogenous variables in each equation in all states.
-
-Qi = zeros(n,n,nvar); % 3rd dim: nvar contemporaneous equations.
-Ri = zeros(k,k,nvar); % 1st and 2nd dims: lagged and exogenous equations.
- % Row corresponds to equation with nvar variables for state 1, ..., nvar variables for state nState.
- % 0 means no restriction.
- % 1 and -1 or any other number means the linear combination of the corresponding parameters is restricted to 0.
- % 1 (only 1) means that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time for A0_s.
-%-------------------------------------------------------------
-%
-
-%======== The first equation ===========
-eqninx = 1;
-nreseqn = 3; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 -1 0 0 0
- 0 1 0 0 0 -1 0 0
- 0 0 1 0 0 0 -1 0
- 0 0 0 1 0 0 0 -1
-
- 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 1 0 0 0 0 0 0
- 0 0 1 0 0 0 0 0
- 0 0 0 1 0 0 0 0
-
- 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The second equation ===========
-eqninx = 2;
-nreseqn = 2; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 -1 0 0 0
- 0 1 0 0 0 -1 0 0
- 0 0 1 0 0 0 -1 0
- 0 0 0 1 0 0 0 -1
-
- 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 1 0 0 0 0 0
- 0 0 0 1 0 0 0 0
-
- 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_3s_case3a.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-
- %==== For freely time-varying A+ for only the first 6 lags.
- %==== Lagged restrictions: zeros on all lags except the first 6 lags in the MS equation.
- % nlagsno0 = 6; % Number of lags to be nonzero.
- % for si=1:nStates
- % for ki = 1:lags-nlagsno0
- % for kj=1:nvar
- % Ri(kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,2) = 1;
- % end
- % end
- % end
- %**** For constant D+_s except the first two lags and the constant term. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- % for si=1:nStates-1
- % for ki=[2*nvar+1:kvar-1]
- % Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- % end
- % end
-end
-
-
-%======== The third equation ===========
-eqninx = 3;
-nreseqn = 1; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 -1 0 0 0
- 0 1 0 0 0 -1 0 0
- 0 0 1 0 0 0 -1 0
- 0 0 0 1 0 0 0 -1
-
- 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 1 0 0 0 0
-
- 0 0 0 0 0 0 0 1
- ];
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The fourth equation ===========
-eqninx = 4;
-nreseqn = 0; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 -1 0 0 0
- 0 1 0 0 0 -1 0 0
- 0 0 1 0 0 0 -1 0
- 0 0 0 1 0 0 0 -1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-
-
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-
-for ki=1:nvar % initializing loop for each equation
- Ui{ki} = null(Qi(:,:,ki));
- Vi{ki} = null(Ri(:,:,ki));
- n0(ki) = size(Ui{ki},2);
- np(ki) = size(Vi{ki},2);
-end
diff --git a/matlab/swz/identification/ftd_2s_caseall_upperchol6v.m b/matlab/swz/identification/ftd_2s_caseall_upperchol6v.m
deleted file mode 100644
index 4fa71200b891c69370b5acd3cb61f8f9bbaa2ba1..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_2s_caseall_upperchol6v.m
+++ /dev/null
@@ -1,455 +0,0 @@
-function [Ui,Vi,n0,np] = ftd_2s_caseall_upperchol6v(lags,nvar,nStates,indxEqnTv_m,nexo)
-% Case 2&3: Policy a0j and a+j have only time-varying structural variances -- Case 2.
-% All policy and nonpolicy a0j's and the corresponding constant terms are completely time-varying and only the scale
-% of each variable in d+j,1** (excluding the constant term) is time-varying -- Case 3.
-%
-% Variables: Pcom, M2, FFR, y, P, U. Equations: information, policy, money demand, y, P, U.
-% Exporting orthonormal matrices for the deterministic linear restrictions
-% (equation by equation) with time-varying A0 and D+** equations.
-% See Model II.3 on pp.71k-71r in TVBVAR NOTES (and Waggoner and Zha's Gibbs sampling paper and TVBVAR NOTES p.58).
-%
-% lags: Maximum length of lag.
-% nvar: Number of endogeous variables.
-% nStates: Number of states.
-% indxEqnTv_m: nvar-by-2. Stores equation characteristics.
-% 1st column: labels of equations [1:nvar]'.
-% 2nd column: labels of time-varying features with
-% 1: indxConst -- all coefficients are constant,
-% 2: indxStv -- only shocks are time-varying,
-% 3: indxTva0pv -- a0 are freely time-varying and each variable i for d+ is time-varying only by the scale lambda_i(s_t).
-% 4: indxTva0ps -- a0 are freely time-varying and only the scale for the whole of d+ is time-varying.
-% 5: indxTv -- time-varying for all coeffficients (a0 and a+) where the lag length for a+ may be shorter.
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant.
-% So far this function is written to handle one exogenous variable, which is a constant term.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar*nStates-by-qi*si orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters
-% within the state and si is the number of free states.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation in the order of [a_i for 1st state, ..., a_i for last state].
-% Vi: nvar-by-1 cell. In each cell, k*nStates-by-ri*si orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters within the state and si is the number of free states.
-% With this transformation, we have fi = Vi*gi or Vi'*fi = gi where fi is a vector of total original
-% parameters and gi is a vector of free parameters. The ith equation is in the order of [nvar variables
-% for 1st lag and 1st state, ..., nvar variables for last lag and 1st state, const for 1st state, nvar
-% variables for 1st lag and 2nd state, nvar variables for last lag and 2nd state, const for 2nd state, and so on].
-% n0: nvar-by-1, whose ith element represents the number of free A0 parameters in ith equation in *all states*.
-% np: nvar-by-1, whose ith element represents the number of free D+ parameters in ith equation in *all states*.
-%
-% Tao Zha, February 2003
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation in all states.
-np = zeros(nvar,1); % ith element represents the number of free D+ parameters in ith equation in all states.
-
-if (nargin==3)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-end
-
-
-n = nvar*nStates;
-kvar=lags*nvar+nexo; % Maximum number of lagged and exogenous variables in each equation under each state.
-k = kvar*nStates; % Maximum number of lagged and exogenous variables in each equation in all states.
-
-Qi = zeros(n,n,nvar); % 3rd dim: nvar contemporaneous equations.
-Ri = zeros(k,k,nvar); % 1st and 2nd dims: lagged and exogenous equations.
- % Row corresponds to equation with nvar variables for state 1, ..., nvar variables for state nState.
- % 0 means no restriction.
- % 1 and -1 or any other number means the linear combination of the corresponding parameters is restricted to 0.
- % 1 (only 1) means that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time for A0_s.
-%-------------------------------------------------------------
-%
-
-%======== The first equation ===========
-eqninx = 1;
-nreseqn = 5; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 -1 0 0 0 0 0
- 0 1 0 0 0 0 0 -1 0 0 0 0
- 0 0 1 0 0 0 0 0 -1 0 0 0
- 0 0 0 1 0 0 0 0 0 -1 0 0
- 0 0 0 0 1 0 0 0 0 0 -1 0
- 0 0 0 0 0 1 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 1 0 0 0 0
- 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 1 0 0 0 0 0 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 1 0 0 0 0
- 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-
-%======== The second equation ===========
-eqninx = 2;
-nreseqn = 4; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 -1 0 0 0 0 0
- 0 1 0 0 0 0 0 -1 0 0 0 0
- 0 0 1 0 0 0 0 0 -1 0 0 0
- 0 0 0 1 0 0 0 0 0 -1 0 0
- 0 0 0 0 1 0 0 0 0 0 -1 0
- 0 0 0 0 0 1 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 1 0 0 0 0 0 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The third equation ===========
-eqninx = 3;
-nreseqn = 3; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 -1 0 0 0 0 0
- 0 1 0 0 0 0 0 -1 0 0 0 0
- 0 0 1 0 0 0 0 0 -1 0 0 0
- 0 0 0 1 0 0 0 0 0 -1 0 0
- 0 0 0 0 1 0 0 0 0 0 -1 0
- 0 0 0 0 0 1 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_3s_case3a.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-
- %==== For freely time-varying A+ for only the first 6 lags.
- %==== Lagged restrictions: zeros on all lags except the first 6 lags in the MS equation.
- % nlagsno0 = 6; % Number of lags to be nonzero.
- % for si=1:nStates
- % for ki = 1:lags-nlagsno0
- % for kj=1:nvar
- % Ri(kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,2) = 1;
- % end
- % end
- % end
- %**** For constant D+_s except the first two lags and the constant term. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- % for si=1:nStates-1
- % for ki=[2*nvar+1:kvar-1]
- % Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- % end
- % end
-end
-
-
-%======== The fourth equation ===========
-eqninx = 4;
-nreseqn = 2; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 -1 0 0 0 0 0
- 0 1 0 0 0 0 0 -1 0 0 0 0
- 0 0 1 0 0 0 0 0 -1 0 0 0
- 0 0 0 1 0 0 0 0 0 -1 0 0
- 0 0 0 0 1 0 0 0 0 0 -1 0
- 0 0 0 0 0 1 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 0 1 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The fifth equation ===========
-eqninx = 5;
-nreseqn = 1; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 -1 0 0 0 0 0
- 0 1 0 0 0 0 0 -1 0 0 0 0
- 0 0 1 0 0 0 0 0 -1 0 0 0
- 0 0 0 1 0 0 0 0 0 -1 0 0
- 0 0 0 0 1 0 0 0 0 0 -1 0
- 0 0 0 0 0 1 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 0 0 1 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The sixth equation ===========
-eqninx = 6;
-nreseqn = 0; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 -1 0 0 0 0 0
- 0 1 0 0 0 0 0 -1 0 0 0 0
- 0 0 1 0 0 0 0 0 -1 0 0 0
- 0 0 0 1 0 0 0 0 0 -1 0 0
- 0 0 0 0 1 0 0 0 0 0 -1 0
- 0 0 0 0 0 1 0 0 0 0 0 -1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-
-for ki=1:nvar % initializing loop for each equation
- Ui{ki} = null(Qi(:,:,ki));
- Vi{ki} = null(Ri(:,:,ki));
- n0(ki) = size(Ui{ki},2);
- np(ki) = size(Vi{ki},2);
-end
diff --git a/matlab/swz/identification/ftd_2s_caseall_upperchol7v.m b/matlab/swz/identification/ftd_2s_caseall_upperchol7v.m
deleted file mode 100644
index 6c27034d6c861c8ef3862543ecee20d98227b016..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_2s_caseall_upperchol7v.m
+++ /dev/null
@@ -1,525 +0,0 @@
-function [Ui,Vi,n0,np] = ftd_2s_caseall_upperchol7v(lags,nvar,nStates,indxEqnTv_m,nexo)
-% Case 2&3: Policy a0j and a+j have only time-varying structural variances -- Case 2.
-% All policy and nonpolicy a0j's and the corresponding constant terms are completely time-varying and only the scale
-% of each variable in d+j,1** (excluding the constant term) is time-varying -- Case 3.
-%
-% Variables: Pcom, M2, FFR, y, P, U. Equations: information, policy, money demand, y, P, U.
-% Exporting orthonormal matrices for the deterministic linear restrictions
-% (equation by equation) with time-varying A0 and D+** equations.
-% See Model II.3 on pp.71k-71r in TVBVAR NOTES (and Waggoner and Zha's Gibbs sampling paper and TVBVAR NOTES p.58).
-%
-% lags: Maximum length of lag.
-% nvar: Number of endogeous variables.
-% nStates: Number of states.
-% indxEqnTv_m: nvar-by-2. Stores equation characteristics.
-% 1st column: labels of equations [1:nvar]'.
-% 2nd column: labels of time-varying features with
-% 1: indxConst -- all coefficients are constant,
-% 2: indxStv -- only shocks are time-varying,
-% 3: indxTva0pv -- a0 are freely time-varying and each variable i for d+ is time-varying only by the scale lambda_i(s_t).
-% 4: indxTva0ps -- a0 are freely time-varying and only the scale for the whole of d+ is time-varying.
-% 5: indxTv -- time-varying for all coeffficients (a0 and a+) where the lag length for a+ may be shorter.
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant.
-% So far this function is written to handle one exogenous variable, which is a constant term.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar*nStates-by-qi*si orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters
-% within the state and si is the number of free states.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation in the order of [a_i for 1st state, ..., a_i for last state].
-% Vi: nvar-by-1 cell. In each cell, k*nStates-by-ri*si orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters within the state and si is the number of free states.
-% With this transformation, we have fi = Vi*gi or Vi'*fi = gi where fi is a vector of total original
-% parameters and gi is a vector of free parameters. The ith equation is in the order of [nvar variables
-% for 1st lag and 1st state, ..., nvar variables for last lag and 1st state, const for 1st state, nvar
-% variables for 1st lag and 2nd state, nvar variables for last lag and 2nd state, const for 2nd state, and so on].
-% n0: nvar-by-1, whose ith element represents the number of free A0 parameters in ith equation in *all states*.
-% np: nvar-by-1, whose ith element represents the number of free D+ parameters in ith equation in *all states*.
-%
-% Tao Zha, February 2003
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation in all states.
-np = zeros(nvar,1); % ith element represents the number of free D+ parameters in ith equation in all states.
-
-if (nargin==3)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-end
-
-
-n = nvar*nStates;
-kvar=lags*nvar+nexo; % Maximum number of lagged and exogenous variables in each equation under each state.
-k = kvar*nStates; % Maximum number of lagged and exogenous variables in each equation in all states.
-
-Qi = zeros(n,n,nvar); % 3rd dim: nvar contemporaneous equations.
-Ri = zeros(k,k,nvar); % 1st and 2nd dims: lagged and exogenous equations.
- % Row corresponds to equation with nvar variables for state 1, ..., nvar variables for state nState.
- % 0 means no restriction.
- % 1 and -1 or any other number means the linear combination of the corresponding parameters is restricted to 0.
- % 1 (only 1) means that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time for A0_s.
-%-------------------------------------------------------------
-%
-
-%======== The first equation ===========
-eqninx = 1;
-nreseqn = 6; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 0 -1 0 0 0 0 0 0
- 0 1 0 0 0 0 0 0 -1 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 -1 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 -1 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 -1 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 -1 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 1 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 1 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 1 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 1 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 1 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_*.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The second equation ===========
-eqninx = 2;
-nreseqn = 5; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 0 -1 0 0 0 0 0 0
- 0 1 0 0 0 0 0 0 -1 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 -1 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 -1 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 -1 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 -1 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 1 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 1 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 1 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_*.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The third equation ===========
-eqninx = 3;
-nreseqn = 4; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 0 -1 0 0 0 0 0 0
- 0 1 0 0 0 0 0 0 -1 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 -1 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 -1 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 -1 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 -1 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 1 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 0 1 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-
-%======== The fourth equation ===========
-eqninx = 4;
-nreseqn = 3; % Number of linear restrictions for A0(:,eqninx) for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 0 -1 0 0 0 0 0 0
- 0 1 0 0 0 0 0 0 -1 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 -1 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 -1 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 -1 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 -1 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 0 1 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 0 0 1 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
-
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_3s_case3a.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-
- %==== For freely time-varying A+ for only the first 6 lags.
- %==== Lagged restrictions: zeros on all lags except the first 6 lags in the MS equation.
- % nlagsno0 = 6; % Number of lags to be nonzero.
- % for si=1:nStates
- % for ki = 1:lags-nlagsno0
- % for kj=1:nvar
- % Ri(kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,kvar*(si-1)+nlagsno0*nvar+nvar*(ki-1)+kj,2) = 1;
- % end
- % end
- % end
- %**** For constant D+_s except the first two lags and the constant term. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- % for si=1:nStates-1
- % for ki=[2*nvar+1:kvar-1]
- % Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- % end
- % end
-end
-
-
-%======== The fifth equation ===========
-eqninx = 5;
-nreseqn = 2; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 0 -1 0 0 0 0 0 0
- 0 1 0 0 0 0 0 0 -1 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 -1 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 -1 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 -1 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 -1 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 0 0 1 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 0 0 0 1 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The sixth equation ===========
-eqninx = 6;
-nreseqn = 1; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 0 -1 0 0 0 0 0 0
- 0 1 0 0 0 0 0 0 -1 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 -1 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 -1 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 -1 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 -1 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 -1
-
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For time-varying A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:nreseqn*nStates,:,eqninx) = [
- 0 0 0 0 0 0 1 0 0 0 0 0 0 0
-
- 0 0 0 0 0 0 0 0 0 0 0 0 0 1
- ];
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-%======== The seventh equation ===========
-eqninx = 7;
-nreseqn = 0; % Number of linear restrictions for the equation for each state.
-if (indxEqnTv_m(eqninx, 2)<=2)
- %**** For constant A0_s. In the order of [a0j(1),...,a0j(nStates)] for the 2nd dim of Qi.
- Qi(1:(nStates-1)*nvar+nreseqn,:,eqninx) = [
- 1 0 0 0 0 0 0 -1 0 0 0 0 0 0
- 0 1 0 0 0 0 0 0 -1 0 0 0 0 0
- 0 0 1 0 0 0 0 0 0 -1 0 0 0 0
- 0 0 0 1 0 0 0 0 0 0 -1 0 0 0
- 0 0 0 0 1 0 0 0 0 0 0 -1 0 0
- 0 0 0 0 0 1 0 0 0 0 0 0 -1 0
- 0 0 0 0 0 0 1 0 0 0 0 0 0 -1
- ];
- %**** For constant D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
-else % Time-varying equations at least for A0_s. For D+_s, constant-parameter equations in general.
- %**** For D+_s. In the order of [aj+(1),...,aj+(nStates)] for the 2nd dim of Ri.
- if (indxEqnTv_m(eqninx, 2)==3) % For constant D+** except the constant term. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar-1 % -1: no restrictions on the constant term, which is freely time-varying.
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- elseif (indxEqnTv_m(eqninx, 2)==4) % For constant D+**. In the order of [dj**(1),...,dj**(nStates)] for the 2nd dim of Ri.
- for si=1:nStates-1
- for ki=1:kvar
- Ri(kvar*(si-1)+ki,[kvar*(si-1)+ki si*kvar+ki],eqninx) = [1 -1];
- end
- end
- else
- error('.../ftd_2s_caseall_simszha5v.m: Have not got time to deal with the simple case indxEqnTv_m(eqninx, 2)=5.')
- end
-end
-
-
-
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-
-for ki=1:nvar % initializing loop for each equation
- Ui{ki} = null(Qi(:,:,ki));
- Vi{ki} = null(Ri(:,:,ki));
- n0(ki) = size(Ui{ki},2);
- np(ki) = size(Vi{ki},2);
-end
diff --git a/matlab/swz/identification/ftd_RSvensson_4v.m b/matlab/swz/identification/ftd_RSvensson_4v.m
deleted file mode 100644
index a93ff82b771f461ed2cf00e2d4f3c98707299641..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_RSvensson_4v.m
+++ /dev/null
@@ -1,188 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_reac_function_4v(lags,nvar,nexo,indxC0Pres)
-% vlist = [ff+ch fh dpgdp ffr)
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% HERE FIRTS 3 EQUATIONS ARE AR2 AND THE LAST EQUATION IS AN UNRESTRICTED
-% REACTION FUNCTION 2 lags
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-% BN
-
-nvar=4;
-lags=4;
-nexo=1;
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-%======== The first equation ===========
-Qi(1:3,:,1) = [
- 0 1 0 0
- 0 0 1 0
- 0 0 0 1
- ];
-
-%======== The second equation ===========
-Qi(1:2,:,2) = [
- 0 0 1 0
- 0 0 0 1
- ];
-
-%======== The third equation =========== NOTE THAT WE FORBID A
-%CONTEMPORANEOUS IMPACT OF OUTPUTON PRICES TO AVOID A CONSTRAINT THAT
-%INVOLVE A0 and Aplus
-Qi(1:3,:,3) = [
- 1 0 0 0
- 0 1 0 0
- 0 0 0 1
- ];
-
-%======== The fourth equation ===========
-
-
-% Restrictions on the A+ in order to focus strictly on the reaction fucntion
-
-% indicates free parameterers X i
-% Ap = [
-% X X X X
-% X X X X
-% -a1 -b1 X X
-% a1 b1 0 X (1st lag)
-% X X X X
-% X X X X
-% -a2 -b2 X X
-% b2 b2 0 X (2nd lag)
-% X 0 X X
-% X X X X
-% -a3 -b3 X X
-% a3 a3 0 X (3rd lag)
-% X X X X
-% X X X X
-% -a4 -b4 X X
-% a4 b4 0 X (4th lag)
-% X X X X (constant terms)
-% ];
-
-k=nvar*lags+nexo;
-Ri = zeros(k,k,nvar);
-% constraints on IS curve /conso+corporate investment
-for nv=1:2
-for ll=1:lags
-Ri(ll,3+lags*(ll-1),nv)=1;
-Ri(ll,4+lags*(ll-1),nv)=1;
-end
-end
-
-% constraints on IS curve /conso+corporate investment only on the long run
-% impact
-% for nv=1:2
-% for ll=1:lags
-% Ri(1,3+lags*(ll-1),nv)=1;
-% Ri(1,4+lags*(ll-1),nv)=1;
-% end
-% end
-
-
-% constraints on Ph curve / inflation does not react to interest rates
-for ll=1:lags
-Ri(ll,4+lags*(ll-1),3)=1;
-end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_cholesky.m b/matlab/swz/identification/ftd_cholesky.m
deleted file mode 100644
index 74524c47013db1864b92dfe6fd976ea96cc66729..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_cholesky.m
+++ /dev/null
@@ -1,251 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_cholesky(lags,nvar,nexo,indxC0Pres)
-%vlist = [1:4]; % regarding "xdd", % 1: p; 2: id; 3: ik; 4: y.
-%For restricted VARs in the form: y_t'*A0 = x_t'*Ap + e_t', where y_t is a vector of endogenous variables
-% and x_t is a vector of lagged endogenous variables and the constant term (last term).
-% Note that the columns of A0 and Ap correspnd to equations.
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%The restrictions considered here are in the following form where X means unrestricted:
-% A0 = [
-% X 0 X X
-% 0 X X X
-% 0 0 X X
-% 0 0 0 X
-% ];
-% Ap = [
-% X 0 X X
-% 0 X X X
-% 0 0 X X
-% 0 0 X X (1st lag)
-% X 0 X X
-% 0 X X X
-% 0 0 X X
-% 0 0 X X (2nd lag)
-% X 0 X X
-% 0 X X X
-% 0 0 X X
-% 0 0 X X (3rd lag)
-% X 0 X X
-% 0 X X X
-% 0 0 X X
-% 0 0 X X (4th lag)
-% 0 X 0 0 (constant terms)
-% ];
-
-if (0)
- %------------------------ Lower triangular A0 ------------------------------
- %======== The first equation ===========
-
-
- %======== The second equation ===========
- Qi(1:1,:,2) = [
- 1 0 0 0
- ];
-
- %======== The third equation ===========
- Qi(1:2,:,3) = [
- 1 0 0 0
- 0 1 0 0
- ];
-
- %======== The fourth equation ===========
- Qi(1:3,:,4) = [
- 1 0 0 0
- 0 1 0 0
- 0 0 1 0
- ];
-else
- %------------------------ Upper triangular A0 ------------------------------
- %======== The first equation ===========
- Qi(2:4,:,1) = [
- 0 1 0 0
- 0 0 1 0
- 0 0 0 1
- ];
-
- %======== The second equation ===========
- Qi([1 3:4],:,2) = [
- 1 0 0 0
- 0 0 1 0
- 0 0 0 1
- ];
-
- %======== The third equation ===========
- Qi(4:4,:,3) = [
- 0 0 0 1
- ];
-
- %======== The fourth equation ===========
-end
-
-
-%-------------------------- Lag restrictions. ------------------------------------------
-if (1)
- %--- Lag restrictions.
- indxeqn = 1; %Which equation.
- nrestrs = (nvar-1)*lags+1; %Number of restrictions.
- vars_restr = [2:nvar]; %Variables that are restricted: id, ik, and y.
- blags = zeros(nrestrs,k); %k=nvar*lags+1
- cnt = 0;
- for ki = 1:lags
- for kj=vars_restr
- cnt = cnt+1;
- blags(cnt,nvar*(ki-1)+kj) = 1;
- end
- end
- %--- Keep constant zero.
- cnt = cnt+1;
- blags(cnt,end) = 1; %Constant = 0.
- if cnt~=nrestrs
- error('Check lagged restrictions in 1st equation!')
- end
- Ri(1:nrestrs,:,indxeqn) = blags;
-
- %--- Lag restrictions.
- indxeqn = 2; %Which equation.
- nrestrs = (nvar-1)*lags; %Number of restrictions.
- vars_restr = [1 3:nvar]; %Variables that are restricted: id, ik, and y.
- blags = zeros(nrestrs,k); %k=nvar*lags+1
- cnt = 0;
- for ki = 1:lags
- for kj=vars_restr
- cnt = cnt+1;
- blags(cnt,nvar*(ki-1)+kj) = 1;
- end
- end
- Ri(1:nrestrs,:,indxeqn) = blags;
-
- %--- Lag restrictions.
- indxeqn = 3; %Which equation.
- nrestrs = 1; %Number of restrictions.
- blags = zeros(nrestrs,k);
- cnt = 0;
- %--- Keep constant zero.
- cnt = cnt+1;
- blags(cnt,end) = 1; %Constant = 0.
- if cnt~=nrestrs
- error('Check lagged restrictions in 1st equation!')
- end
- Ri(1:nrestrs,:,indxeqn) = blags;
-
- %--- Lag restrictions.
- indxeqn = 4; %Which equation.
- nrestrs = 1; %Number of restrictions.
- blags = zeros(nrestrs,k);
- cnt = 0;
- %--- Keep constant zero.
- cnt = cnt+1;
- blags(cnt,end) = 1; %Constant = 0.
- if cnt~=nrestrs
- error('Check lagged restrictions in 1st equation!')
- end
- Ri(1:nrestrs,:,indxeqn) = blags;
-end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-% This type of restriction is used for the New-Keysian model studied by Leeper and Zha
-% "Assessing Simple Policy Rules: A View from a Complete Macroeconomic Model" published
-% by St. Louis Fed Review.
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_non_rec_5v.m b/matlab/swz/identification/ftd_non_rec_5v.m
deleted file mode 100644
index e7ae075494c04fe997c50a2f7a418e0fd4e3f78e..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_non_rec_5v.m
+++ /dev/null
@@ -1,192 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_upperchol5v(lags,nvar,nexo,indxC0Pres)
-% vlist = [127 124 93 141 21]; % 1: GDP; 2: GDP deflator 124 (consumption deflator 79); 3: R; 4: M3 141 (M2 140); 5: exchange rate 21.
-% varlist={'y', 'P', 'R', 'M3', 'Ex'};
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-%======== The first equation ===========
-Qi(1:4,:,1) = [
- 0 1 0 0 0
- 0 0 1 0 0
- 0 0 0 1 0
- 0 0 0 0 1
- ];
-
-%======== The second equation ===========
-Qi(1:3,:,2) = [
- 0 0 1 0 0
- 0 0 0 1 0
- 0 0 0 0 1
- ];
-
-%======== The third equation ===========
-Qi(1:2,:,3) = [
- 0 0 0 1 0
- 0 0 0 0 1
- ];
-
-
-%======== The fourth equation ===========
-%Qi(1:1,:,4) = [
-% 0 0 0 0 1
-% ];
-
-
-%======== The fifth equation ===========
-
-Qi(1:3,:,5) = [
- 1 0 0 0 0
- 0 1 0 0 0
- 0 0 1 0 0
- ];
-
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_simszha5v.m b/matlab/swz/identification/ftd_simszha5v.m
deleted file mode 100644
index a2092fb3e8d374d4b742af6a930022f00c6c79d3..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_simszha5v.m
+++ /dev/null
@@ -1,190 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_simszha5v(lags,nvar,nexo,indxC0Pres)
-%vlist = [21 141 93 127 124]; % 1: Pcom 2 (exchange rate 21); 2: M3 141 (M2 140); 3: R; 4: GDP; 5: GDP deflator 124 (consumption deflator 79).
-%varlist={'Ex', 'M3', 'R', 'y','P'};
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-
-%======== The first equation: information sector ===========
-
-
-%======== The second equation: monetary policy ===========
-%Qi(1:2,:,2) = [
-% 0 0 0 1 0
-% 0 0 0 0 1
-% ]; % Respond to Pcom.
-Qi(1:3,:,2) = [
- 1 0 0 0 0
- 0 0 0 1 0
- 0 0 0 0 1
- ]; % Not respond to Pcom.
-
-%======== The third equation: money demand ===========
-Qi(1,:,3) = [
- 1 0 0 0 0
- ];
-
-%======== The fourth equation: y equation ===========
-Qi(1:4,:,4) = [
- 1 0 0 0 0
- 0 1 0 0 0
- 0 0 1 0 0
- 0 0 0 0 1
- ];
-
-%======== The fifth equation: p equation ===========
-Qi(1:3,:,5) = [
- 1 0 0 0 0
- 0 1 0 0 0
- 0 0 1 0 0
- ];
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_upperchol3v.m b/matlab/swz/identification/ftd_upperchol3v.m
deleted file mode 100644
index 4376b3c5d5a56b0d6c15c56912aef46142b77d61..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_upperchol3v.m
+++ /dev/null
@@ -1,170 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_upperchol3v(lags,nvar,nexo,indxC0Pres)
-%vlist = [20 6 3 44 1 10]; % regarding "xdd", Pcom (Poil or imfcom), M2, FFR, GDP, CPI (or PCE), and U.
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-
-%======== The first equation ===========
-Qi(1:2,:,1) = [
- 0 1 0
- 0 0 1
- ];
-
-%======== The second equation ===========
-Qi(1:1,:,2) = [
- 0 0 1
- ];
-
-
-%======== The third equation ===========
-
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_upperchol4v.m b/matlab/swz/identification/ftd_upperchol4v.m
deleted file mode 100644
index 78c9a7c5142192a3ae03a623eb1b9baa266b34c8..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_upperchol4v.m
+++ /dev/null
@@ -1,178 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_upperchol4v(lags,nvar,nexo,indxC0Pres)
-% vlist = [127 124 93 141 21]; % 1: GDP; 2: GDP deflator 124 (consumption deflator 79); 3: R; 4: M3 141 (M2 140); 5: exchange rate 21.
-% varlist={'y', 'P', 'R', 'M3', 'Ex'};
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-%======== The first equation ===========
-Qi(1:3,:,1) = [
- 0 1 0 0
- 0 0 1 0
- 0 0 0 1
- ];
-
-%======== The second equation ===========
-Qi(1:2,:,2) = [
- 0 0 1 0
- 0 0 0 1
- ];
-
-%======== The third equation ===========
-Qi(1:1,:,3) = [
- 0 0 0 1
- ];
-
-
-%======== The fourth equation ===========
-
-
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_upperchol5v.m b/matlab/swz/identification/ftd_upperchol5v.m
deleted file mode 100644
index e1dfaa18d54e64f0e2073fee6cc65cc5bfd362b4..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_upperchol5v.m
+++ /dev/null
@@ -1,187 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_upperchol5v(lags,nvar,nexo,indxC0Pres)
-% vlist = [127 124 93 141 21]; % 1: GDP; 2: GDP deflator 124 (consumption deflator 79); 3: R; 4: M3 141 (M2 140); 5: exchange rate 21.
-% varlist={'y', 'P', 'R', 'M3', 'Ex'};
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-%======== The first equation ===========
-Qi(1:4,:,1) = [
- 0 1 0 0 0
- 0 0 1 0 0
- 0 0 0 1 0
- 0 0 0 0 1
- ];
-
-%======== The second equation ===========
-Qi(1:3,:,2) = [
- 0 0 1 0 0
- 0 0 0 1 0
- 0 0 0 0 1
- ];
-
-%======== The third equation ===========
-Qi(1:2,:,3) = [
- 0 0 0 1 0
- 0 0 0 0 1
- ];
-
-
-%======== The fourth equation ===========
-Qi(1:1,:,4) = [
- 0 0 0 0 1
- ];
-
-
-%======== The fifth equation ===========
-
-
-
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_upperchol6v.m b/matlab/swz/identification/ftd_upperchol6v.m
deleted file mode 100644
index fb09e9298fc941716655b156f2ce718d488a48d7..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_upperchol6v.m
+++ /dev/null
@@ -1,194 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_upperchol6v(lags,nvar,nexo,indxC0Pres)
-% vlist = [127 124 2 93 141 21]; % 1: Pcom 2 (exchange rate 21); 2: M3 141 (M2 140); 3: R; 4: GDP; 5: GDP deflator 124 (consumption deflator 79).
-% varlist={'y', 'P', 'Pcom', 'R', 'M3', 'Ex'};
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-%======== The first equation ===========
-Qi(1:5,:,1) = [
- 0 1 0 0 0 0
- 0 0 1 0 0 0
- 0 0 0 1 0 0
- 0 0 0 0 1 0
- 0 0 0 0 0 1
- ];
-
-%======== The second equation ===========
-Qi(1:4,:,2) = [
- 0 0 1 0 0 0
- 0 0 0 1 0 0
- 0 0 0 0 1 0
- 0 0 0 0 0 1
- ];
-
-%======== The third equation ===========
-Qi(1:3,:,3) = [
- 0 0 0 1 0 0
- 0 0 0 0 1 0
- 0 0 0 0 0 1
- ];
-
-
-%======== The fourth equation ===========
-Qi(1:2,:,4) = [
- 0 0 0 0 1 0
- 0 0 0 0 0 1
- ];
-
-
-%======== The fifth equation ===========
-Qi(1:1,:,5) = [
- 0 0 0 0 0 1
- ];
-
-
-%======== The sixth equation ===========
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/ftd_upperchol7v.m b/matlab/swz/identification/ftd_upperchol7v.m
deleted file mode 100644
index 31ce836cf09fce94fac0f42e615fa629fac65717..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/ftd_upperchol7v.m
+++ /dev/null
@@ -1,204 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = ftd_upperchol7v(lags,nvar,nexo,indxC0Pres)
-% vlist = [127 124 2 93 141 21]; % 1: Pcom 2 (exchange rate 21); 2: M3 141 (M2 140); 3: R; 4: GDP; 5: GDP deflator 124 (consumption deflator 79).
-% varlist={'y', 'P', 'Pcom', 'R', 'M3', 'Ex'};
-%
-% Exporting orthonormal matrices for the deterministic linear restrictions (equation by equation)
-% See Waggoner and Zha's Gibbs sampling paper.
-%
-% q_m: quarter or month
-% lags: the maximum length of lag
-% nvar: number of endogeous variables
-% nexo: number of exogenous variables. If nexo is not supplied, nexo=1 as default for a constant
-% indxC0Pres: index for cross-A0-A+ restrictions. if 1: cross-A0-and-A+ restrictions; 0: idfile is all we have
-% Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-% These restrictions have to be manually and carefully keyed in.
-%-----------------
-% Ui: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
-% equation contemporaneous restriction matrix where qi is the number of free parameters.
-% With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
-% of total original parameters and bi is a vector of free parameters. When no
-% restrictions are imposed, we have Ui = I. There must be at least one free
-% parameter left for the ith equation.
-% Vi: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
-% equation lagged restriction matrix where k is a total of exogenous variables and
-% ri is the number of free parameters. With this transformation, we have fi = Vi*gi
-% or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
-% vector of free parameters. There must be at least one free parameter left for
-% the ith equation.
-% n0: nvar-by-1, ith element represents the number of free A0 parameters in ith equation
-% np: nvar-by-1, ith element represents the number of free A+ parameters in ith equation
-% ixmC0Pres: neq_cres-by-1 cell. Effective only if indxC0Pres=1, otherwise equals NaN.
-% neq_cres is the number of equations in which cross-A0-A+ restrictions occur.
-% In the jth cell representing equation, we have 4 columns:
-% 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% 4th: the number s such that f_j(i) = s * a_j(h) holds.
-%
-% Tao Zha, May 2000
-
-
-
-Ui = cell(nvar,1); % initializing for contemporaneous endogenous variables
-Vi = cell(nvar,1); % initializing for lagged and exogenous variables
-n0 = zeros(nvar,1); % ith element represents the number of free A0 parameters in ith equation
-np = zeros(nvar,1); % ith element represents the number of free A+ parameters in ith equation
-
-if (nargin==2)
- nexo = 1; % 1: constant as default where nexo must be a nonnegative integer
-elseif (nargin==3)
- indxC0Pres = 0; % default is no cross-A0-and-A+ restrictions.
-end
-
-k = lags*nvar+nexo; % maximum number of lagged and exogenous variables in each equation
-
-Qi = zeros(nvar,nvar,nvar); % for nvar contemporaneous equations
-Ri = zeros(k,k,nvar); % for nvar lagged and exogenous equations
- % Row corresponds to equation. 0 means no restriction.
- % 1 means exclusion restriction such that the corresponding parameter is restricted to 0.
-
-%nfvar = 6; % number of foreign (Granger causing) variables
-%nhvar = nvar-nfvar; % number of home (affected) variables.
-
-
-%-------------------------------------------------------------
-% Beginning the manual input of the restrictions one quation at a time
-%-------------------------------------------------------------
-%
-%======== The first equation ===========
-Qi(1:6,:,1) = [
- 0 1 0 0 0 0 0
- 0 0 1 0 0 0 0
- 0 0 0 1 0 0 0
- 0 0 0 0 1 0 0
- 0 0 0 0 0 1 0
- 0 0 0 0 0 0 1
- ];
-
-%======== The second equation ===========
-Qi(1:5,:,2) = [
- 0 0 1 0 0 0 0
- 0 0 0 1 0 0 0
- 0 0 0 0 1 0 0
- 0 0 0 0 0 1 0
- 0 0 0 0 0 0 1
- ];
-
-%======== The third equation ===========
-Qi(1:4,:,3) = [
- 0 0 0 1 0 0 0
- 0 0 0 0 1 0 0
- 0 0 0 0 0 1 0
- 0 0 0 0 0 0 1
- ];
-
-%======== The fourth equation ===========
-Qi(1:3,:,4) = [
- 0 0 0 0 1 0 0
- 0 0 0 0 0 1 0
- 0 0 0 0 0 0 1
- ];
-
-
-%======== The fifth equation ===========
-Qi(1:2,:,5) = [
- 0 0 0 0 0 1 0
- 0 0 0 0 0 0 1
- ];
-
-
-%======== The sixth equation ===========
-Qi(1:1,:,6) = [
- 0 0 0 0 0 0 1
- ];
-
-
-%======== The seventh equation ===========
-
-%===== Lagged restrictions in foreign (Granger causing) block
-%nfbres = lags*(nvar-nfvar); % number of block restrictions in each foreign equation
-%bfor = zeros(nfbres,k); % each foreign equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:nvar-nfvar
-% cnt=cnt+1;
-% bfor(cnt,nvar*(ki-1)+nfvar+kj) = 1;
-% end
-%end
-%%
-%if cnt~=nfbres
-% error('Check lagged restrictions in foreign equations!')
-%end
-%%
-%for kj=1:nfvar
-% Ri(1:nfbres,:,kj) = bfor;
-%end
-
-
-%===== Lagged restrictions in home (affected) block
-%
-%~~~~~ selected domestic equations
-%dlrindx = nfvar+1; %[nfvar+1 nfvar+2]; % index for relevant home equations
-%rfvindx = []; %[6]; %[1 2 3 5]; % index for restricted foreign variables (e.g., Poil, M2, FFR, P).
-%%nf2hvar = nfvar-length(rfvindx); % number of free parameters -- foreign variables entering the home sector
-%nhbres = lags*length(rfvindx); % number of block restrictions in each home equation
-%bhom = zeros(nhbres,k); % each home equation
-%cnt=0;
-%for ki = 1:lags
-% for kj=1:length(rfvindx)
-% cnt=cnt+1;
-% bhom(cnt,nvar*(ki-1)+rfvindx(kj)) = 1;
-% end
-%end
-%%
-%if cnt~=nhbres
-% error('Check lagged restrictions in domestic equations!')
-%end
-%%
-%for kj=dlrindx
-% Ri(1:nhbres,:,kj) = bhom;
-%end
-
-
-for n=1:nvar % initializing loop for each equation
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-
-
-%(2)-------------------------------------------------------------
-% Cross-A0-and-A+ rerestrictions one quation at a time
-% i.e., the first, second, ..., kjth, ..., equation
-%(2)-------------------------------------------------------------
-%
-if indxC0Pres
- neq_cres = 3; % the number of equations in which cross-A0-A+ restrictions occur.
- ixmC0Pres = cell(neq_cres,1); % in each cell representing equation, we have 4 columns:
- % 1st: the jth column (equation) of A+ or A0: f_j or a_j
- % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
- % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
- % 4th: the number s such that f_j(i) = s * a_j(h) holds.
- %** 1st equation
- ixmC0Pres{1} = [1 2 2 1
- 1 7 1 1];
- %** 2nd equation
- ixmC0Pres{2} = [2 2 2 2];
- %** 3rd equation
- ixmC0Pres{3} = [3 7 1 1
- 3 2 2 1];
-
-
-% % 4 columns.
-% ncres = 5; % manually key in the number of cross-A0-A+ restrictions
-
-% % 1st: the jth column (equation) of A+ or A0: f_j or a_j
-% % 2nd: the ith element f_j(i) -- the ith element in the jth column of A+
-% % 3rd: the hth element a_j(h) -- the hth element in the jth column of A0
-% % 4th: the number s such that f_j(i) = s * a_j(h) holds.
-else
- ixmC0Pres = NaN;
-end
-
diff --git a/matlab/swz/identification/upper_cholesky.m b/matlab/swz/identification/upper_cholesky.m
deleted file mode 100644
index 8c41339ac06faf0f948dad6df563259e7e1df544..0000000000000000000000000000000000000000
--- a/matlab/swz/identification/upper_cholesky.m
+++ /dev/null
@@ -1,29 +0,0 @@
-function [Ui,Vi,n0,np,ixmC0Pres] = upper_cholesky(lags,nvar,nexo,indxC0Pres)
-
-Ui = cell(nvar,1);
-Vi = cell(nvar,1);
-n0 = zeros(nvar,1);
-np = zeros(nvar,1);
-if (nargin==2)
- nexo = 1;
-elseif (nargin==3)
- indxC0Pres = 0;
-end
-k = lags*nvar+nexo;
-Qi = zeros(nvar,nvar,nvar);
-Ri = zeros(k,k,nvar);
-
-for ii=2:nvar
- Pi=diag(diag(ones(nvar-ii+1)),ii-1);
- Qi(:,:,ii-1)=Pi(1:nvar,1:nvar);
- Qi(:,:,nvar)=zeros(nvar,nvar);
-end
-
-for n=1:nvar
- Ui{n} = null(Qi(:,:,n));
- Vi{n} = null(Ri(:,:,n));
- n0(n) = size(Ui{n},2);
- np(n) = size(Vi{n},2);
-end
-
-ixmC0Pres = NaN;
\ No newline at end of file
diff --git a/matlab/swz/mhm_specification/MHM_input.dat b/matlab/swz/mhm_specification/MHM_input.dat
deleted file mode 100644
index 3085c7e5289c630af42492416a272ade3df6b04a..0000000000000000000000000000000000000000
--- a/matlab/swz/mhm_specification/MHM_input.dat
+++ /dev/null
@@ -1,29 +0,0 @@
-
-//------------- 1st set of posterior draws to find optimal scales for Metropolis. ---------------
-//== number draws for first burn-in ==// //For determining the Metropolis scales only.
-30000
-
-//------------- 2nd set of posterior draws to to throw away the initial draws. ---------------
-//------------- MCMC burn-in draws once the Metropolis scales are fixed. --------------
-//== number draws for second burn-in ==//
-10000
-
-//--------------- 1st set of draws from the posterior ----------------
-//== number draws to estimate mean and variance ==//
-200000
-
-//--------------- 2nd set of saved draws from the posterior: saved draws AFTER thinning ----------------
-//== number draws for modified harmonic mean process ==//
-1000000
-
-//--------------- Only applied to MHM process: thinnning factor * 2nd set of saved posterior draws ----------------
-//== thinning factor for modified harmonic mean process ==//
-1
-
-//------- 1st stage: computing all three tightness factors for Dirichlet. ---------
-//------- 2nd stage: hard-code the second scale factor (in principle, we can do all three). ---------
-//== scale values for Dirichlet distribution ==//
-3
-
-1.0 1.5 2.0
-
diff --git a/matlab/swz/msstart2.m b/matlab/swz/msstart2.m
deleted file mode 100644
index 31012b85ba85356fa8da06ab84412276a2501ecd..0000000000000000000000000000000000000000
--- a/matlab/swz/msstart2.m
+++ /dev/null
@@ -1,794 +0,0 @@
-%function msstart2(options_)
-% This .m file is called for point graphics or error bands and
-% It starts for both data and Bayesian estimation (when IxEstimat==0,
-% no estimation but only data analysis), which allows you to set
-% (a) available data range,
-% (b) sample range,
-% (c) rearrangement of actual data such as mlog, qg, yg
-% (d) conditions of shocks 'Cms',
-% (c) conditions of variables 'nconstr',
-% (e) soft conditions 'nbancon,'
-% (f) produce point conditional forecast (at least conditions on variables).
-%
-% February 2004
-
-% ** ONLY UNDER UNIX SYSTEM
-%path(path,'/usr2/f1taz14/mymatlab')
-
-%addpath('C:\SoftWDisk\MATLAB6p5\toolbox\cstz')
-
-
-msstart_setup
-%===========================================
-% Exordium II
-%===========================================
-%options_.ms.ncsk = 0; % conditional directly on shoocks. Unlike Cms, not on variables that back out shocks
-%options_.ms.nstd = 6; % number of standard deviations to cover the range in which distributions are put to bins
-%options_.ms.ninv = 1000; % the number of bins for grouping, say, impulse responses
-%options_.ms.Indxcol = [1:nvar]; % a vector of random columns in which MC draws are made.
-%
-%options_.ms.indxparr = 1; % 1: parameters random; 0: no randomness in parameters
- % Note, when 0, there is no effect from the values of options_.ms.IndxAp, options_.ms.Aband, etc.
-%options_.ms.indxovr = 0; % 1: distributions for other variables of interest; 0: no distribution.
- % Example: joint distribution of a(1) and a(2). Only for specific purposes
-%options_.ms.Aband = 1; % 1: error bands with only A0 and A+ random.
-%options_.ms.IndxAp = 1; % 1: generate draws of A+; 0: no such draws.
- % Note: when options_.ms.IndxAp=0, there is no effect from the values of options_.ms.options_.ms.options_.ms.options_.ms.indximf, IndxFore,
- % or options_.ms.apband.
-%options_.ms.apband = 1; % 1: error bands for A+; 0: no error bands for A+.
-%*** The following (impulse responses and forecasts) is used only if options_.ms.IndxAp=1
-%options_.ms.indximf = 1; % 1: generate draws of impulse responses; 0: no such draws (thus no effect
- % from options_.ms.imfband)
-%options_.ms.imfband = 1; % 1: error bands for impulse responses; 0: no error bands
-%options_.ms.indxfore = 0; % 1: generate draws of forecasts; 0: no such draws (thus no effect from options_.ms.foreband)
-%options_.ms.foreband = 0; % 1: error bands for out-of-sample forecasts; 0: no error bands
-%
-%options_.ms.indxgforhat = 1; % 1: plot unconditoinal forecasts; 0: no such plot
-rnum = nvar; % number of rows in the graph
-cnum = 1; % number of columns in the graph
-if rnum*cnum<nvar
- warning('rnum*cnum must be at least as large as nvar')
- disp('Hit any key to continue, or ctrl-c to abort')
- pause
-end
-%options_.ms.indxgimfhat = 1; % 1: plot ML impulse responses; 0: no plot
-%options_.ms.indxestima = 1; %1: ML estimation; 0: no estimation and data only
-%
-IndxNmlr = [1 0 0 0 0 0]; % imported by nmlzvar.m
- % Index for which normalization rule to choose
- % Only one of the elments in IndxNmlr can be non-zero
- % IndxNmlr(1): ML A distance rule (supposed to be the best)
- % IndxNmlr(2): ML Ahat distance rule (to approximate IndxNmlr(1))
- % IndxNmlr(3): ML Euclidean distance rule (not invariant to scale)
- % IndxNmlr(4): Positive diagonal rule
- % IndxNmlr(5): Positive inv(A) diagonal rule (if ~IndxNmlr(5), no need for A0inu,
- % so let A0inu=[])
- % IndxNmlr(6): Assigned postive rule (such as off-diagonal elements). Added 1/3/00
-
-
-%%%%----------------------------------------
-% Hard conditions directly on variables
-%
-%options_.ms.indxgdls = 1; % 1: graph point forecast on variables; 0: disable
-nconstr1=nfqm; % number of the 1st set of constraints
-nconstr2=options_.ms.forecast ; % number of the 2nd set of constraints
-nconstr=nconstr1+nconstr2; % q: 4 years -- 4*12 months.
- % When 0, no conditions directly on variables <<>>
-nconstr=0 %6*nconstr1;
-options_.ms.eq_ms = []; % location of MS equation; if [], all shocks
-PorR = [4*ones(nconstr1,1);2*ones(nconstr1,1);3*ones(nconstr1,1)]; % the variable conditioned. 1: Pcm; 3: FFR; 4: CPI
-PorR = [PorR;1*ones(nconstr1,1);5*ones(nconstr1,1);6*ones(nconstr1,1)];
-%PorR = [3 5]; % the variable conditioned. 3: FFR; 5: CPI
-%PorR = 3;
-
-%%%%----------------------------------------
-% Conditions directly on future shocks
-%
-%options_.ms.cms = 0 % 1: condition on ms shocks; 0: disable this and "fidcnderr.m" gives
- % unconditional forecasts if nconstr = 0 as well; <<>>
-%options_.ms.ncms = 0; % number of the stance of policy; 0 if no tightening or loosening
-%options_.ms.eq_cms = 1; % location of MS shocks
-options_.ms.tlindx = 1*ones(1,options_.ms.ncms); % 1-by-options_.ms.ncms vector; 1: tightening; 0: loosen
-options_.ms.tlnumber = [0.5 0.5 0 0]; %94:4 % [2 2 1.5 1.5]; %79:9 %[1.5 1.5 1 1]; 90:9
- % 1-by-options_.ms.ncms vector; cut-off point for MS shocks
-TLmean = zeros(1,options_.ms.ncms);
- % unconditional, i.e., 0 mean, for the final report in the paper
-if options_.ms.cms
- options_.ms.eq_ms = [];
- % At least at this point, it makes no sense to have DLS type of options_.ms.eq_ms; 10/12/98
- if all(isfinite(options_.ms.tlnumber))
- for k=1:options_.ms.ncms
- TLmean(k) = lcnmean(options_.ms.tlnumber(k),options_.ms.tlindx(k));
- % shock mean magnitude. 1: tight; 0: loose
- % Never used for any subsequent computation but
- % simply used for the final report in the paper.
- %options_.ms.tlnumber(k) = fzero('lcutoff',0,[],[],TLmean(k))
- % get an idea about the cutoff point given TLmean instead
-
- end
- end
-else
- options_.ms.ncms = 0; % only for the use of the graph by msprobg.m
- options_.ms.tlnumber = NaN*ones(1,options_.ms.ncms);
- % -infinity, only for the use of the graph by msprobg.m
-end
-
-
-%%%%----------------------------------------
-% Soft conditions on variables
-%
-%cnum = 0 % # of band condtions; when 0, disable this option
- % Note (different from "fidencon") that each condition corres. to variable
-%options_.ms.banact = 1; % 1: use infor on actual; 0: preset without infor on actual
-if cnum
- banindx = cell(cnum,1); % index for each variable or conditon
- banstp = cell(cnum,1); % steps: annual in general
- banvar = zeros(cnum,1); % varables: annual in general
- banval = cell(cnum,1); % band value (each variable occupy a cell)
- badval{1} = zeros(length(banstp{1}),2); % 2: lower or higher bound
-
- banstp{1} = 1:4; % 3 or 4 years
- banvar(1) = 3; % 3: FFR; 5: CPI
- if ~options_.ms.banact
- for i=1:length(banstp{1})
- banval{1}(i,:) = [5.0 10.0];
- end
- end
-end
-%
-pause(1)
-disp(' ')
-disp('For uncondtional forecasts, set nconstr = options_.ms.cms = cnum = 0')
-pause(1)
-%
-%=================================================
-%====== End of exordium ==========================
-%=================================================
-
-
-
-
-
-%(1)--------------------------------------
-% Further data analysis
-%(1)--------------------------------------
-%
-if (options_.ms.freq==12)
- nStart=(yrStart-options_.ms.initial_year )*12+qmStart-options_.ms.initial_subperiod ; % positive number of months at the start
- nEnd=(yrEnd-options_.ms.final_year )*12+qmEnd-options_.ms.final_subperiod ; % negative number of months towards end
-elseif (options_.ms.freq==4)
- nStart=(yrStart-options_.ms.initial_year )*4+qmStart-options_.ms.initial_subperiod ; % positive number of months at the start
- nEnd=(yrEnd-options_.ms.final_year )*4+qmEnd-options_.ms.final_subperiod ; % negative number of months towards end
-else
- disp('Warning: this code is only good for monthly/quarterly data!!!')
- return
-end
-%
-if nEnd>0 | nStart<0
- disp('Warning: this particular sample consider is out of bounds of the data!!!')
- return
-end
-%*** Note, both xdgel and xdata have the same start with the specific sample
-xdgel=options_.data(nStart+1:nData+nEnd,options_.ms.vlist);
- % gel: general options_.data within sample (nSample)
-if ~(nSample==size(xdgel,1))
- warning('The sample size (including options_.ms.nlags ) and data are incompatible')
- disp('Check to make sure nSample and size(xdgel,1) are the same')
- return
-end
-%
-baddata = find(isnan(xdgel));
-if ~isempty(baddata)
- warning('Some data for this selected sample are actually unavailable.')
- disp('Hit any key to continue, or ctrl-c to abort')
- pause
-end
-%
-if options_.ms.initial_subperiod ==1
- yrB = options_.ms.initial_year ; qmB = options_.ms.initial_subperiod ;
-else
- yrB = options_.ms.initial_year +1; qmB = 1;
-end
-yrF = options_.ms.final_year ; qmF = options_.ms.final_subperiod ;
-[Mdate,tmp] = fn_calyrqm(options_.ms.freq,[options_.ms.initial_year options_.ms.initial_subperiod ],[options_.ms.final_year options_.ms.final_subperiod ]);
-xdatae=[Mdate options_.data(1:nData,options_.ms.vlist)];
- % beyond sample into forecast horizon until the end of the data options_.ms.final_year :options_.ms.final_subperiod
- % Note: may contain NaN data. So must be careful about its use
-
-%=========== Obtain prior-period, period-to-last period, and annual growth rates
-[yactyrge,yactyre,yactqmyge,yactqmge,yactqme] = fn_datana(xdatae,options_.ms.freq,options_.ms.log_var,options_.ms.percent_var,[yrB qmB],[yrF qmF]);
-qdates = zeros(size(yactqmyge,1),1);
-for ki=1:length(qdates)
- qdates(ki) = yactqmyge(1,1) + (yactqmyge(1,2)+ki-2)/options_.ms.freq;
-end
-for ki=1:nvar
- figure
- plot(qdates, yactqmyge(:,2+ki)/100)
- xlabel(options_.ms.varlist{ki})
-end
-save outactqmygdata.prn yactqmyge -ascii
-
-
-
-%=========== Write the output on the screen or to a file in an organized way ==============
-%disp([sprintf('%4.0f %2.0f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f\n',yactyrge')])
-spstr1 = 'disp([sprintf(';
-spstr2 = '%4.0f %2.0f';
-yactyrget=yactyrge';
-for ki=1:length(options_.ms.vlist)
- if ki==length(options_.ms.vlist)
- spstr2 = [spstr2 ' %8.3f\n'];
- else
- spstr2 = [spstr2 ' %8.3f'];
- end
-end
-spstr = [spstr1 'spstr2' ', yactyrget)])'];
-eval(spstr)
-
-%
-fid = fopen('outyrqm.prn','w');
-%fprintf(fid,'%4.0f %2.0f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f\n',yactyrge');
-fpstr1 = 'fprintf(fid,';
-fpstr2 = '%4.0f %2.0f';
-for ki=1:nvar
- if ki==nvar
- fpstr2 = [fpstr2 ' %8.3f\n'];
- else
- fpstr2 = [fpstr2 ' %8.3f'];
- end
-end
-fpstr = [fpstr1 'fpstr2' ', yactyrget);'];
-eval(fpstr)
-fclose(fid);
-
-
-
-if options_.ms.indxestima
- %(2)----------------------------------------------------------------------------
- % Estimation
- % ML forecast and impulse responses
- % Hard or soft conditions for conditional forecasts
- %(2)----------------------------------------------------------------------------
- %
- %* Arranged data information, WITHOUT dummy obs when 0 after mu is used. See fn_rnrprior_covres_dobs.m for using the dummy
- % observations as part of an explicit prior.
- [xtx,xty,yty,fss,phi,y,ncoef,xr,Bh] = fn_dataxy(nvar,options_.ms.nlags ,xdgel,mu,0,nexo);
- if qmStart+options_.ms.nlags -options_.ms.dummy_obs >0
- qmStartEsti = rem(qmStart+options_.ms.nlags -options_.ms.dummy_obs ,options_.ms.freq); % dummy observations are included in the sample.
- if (~qmStartEsti)
- qmStartEsti = options_.ms.freq;
- end
- yrStartEsti = yrStart + floor((qmStart+options_.ms.nlags -options_.ms.dummy_obs )/(options_.ms.freq+0.01));
- % + 0.01 (or any number < 1) is used so that qmStart+options_.ms.nlags -options_.ms.dummy_obs ==?*options_.ms.freq doesn't give us an extra year forward.
- else
- qmStartEsti = options_.ms.freq + rem(qmStart+options_.ms.nlags -options_.ms.dummy_obs ,options_.ms.freq); % dummy observations are included in the sample.
- if (qmStart+options_.ms.nlags -options_.ms.dummy_obs ==0)
- yrStartEsti = yrStart - 1; % one year back.
- else
- yrStartEsti = yrStart + floor((qmStart+options_.ms.nlags -options_.ms.dummy_obs )/(options_.ms.freq-0.01));
- % - 0.01 (or any number < 1) is used so that qmStart+options_.ms.nlags -options_.ms.dummy_obs ==-?*options_.ms.freq give us an extra year back.
- end
- end
- dateswd = fn_dataext([yrStartEsti qmStartEsti],[yrEnd qmEnd],xdatae(:,[1:2])); % dates with dummies
- phie = [dateswd phi];
- ye = [dateswd y];
-
- %* Obtain linear restrictions
- [Uiconst,Viconst,n0,np,ixmC0Pres] = feval(options_.ms.restriction_fname,options_.ms.nlags ,nvar,nexo,options_.ms.cross_restrictions );
- if min(n0)==0
- disp(' ')
- warning('A0: restrictions in dlrprior.m give no free parameter in one of equations')
- disp('Press ctrl-c to abort')
- pause
- elseif min(np)==0
- disp(' ')
- warning('Ap: Restrictions in dlrprior.m give no free parameter in one of equations')
- disp('Press ctrl-c to abort')
- pause
- end
-
- if options_.ms.contemp_reduced_form
- Uiconst=cell(nvar,1); Viconst=cell(ncoef,1);
- for kj=1:nvar
- Uiconst{kj} = eye(nvar); Viconst{kj} = eye(ncoef);
- end
- end
-
- if options_.ms.bayesian_prior
- %*** Obtains asymmetric prior (with no linear restrictions) with dummy observations as part of an explicit prior (i.e,
- % reflected in Hpmulti and Hpinvmulti). See Forecast II, pp.69a-69b for details.
- if 1 % Liquidity effect prior on both MS and MD equations.
- [Pi,H0multi,Hpmulti,H0invmulti,Hpinvmulti] = fn_rnrprior_covres_dobs(nvar,options_.ms.freq,options_.ms.nlags ,xdgel,mu,indxDummy,hpmsmd,indxmsmdeqn);
- else
- [Pi,H0multi,Hpmulti,H0invmulti,Hpinvmulti] = fn_rnrprior(nvar,options_.ms.freq,options_.ms.nlags ,xdgel,mu);
- end
-
- %*** Combines asymmetric prior with linear restrictions
- [Ptld,H0invtld,Hpinvtld] = fn_rlrprior(Uiconst,Viconst,Pi,H0multi,Hpmulti,nvar);
-
- %*** Obtains the posterior matrices for estimation and inference
- [Pmat,H0inv,Hpinv] = fn_rlrpostr(xtx,xty,yty,Ptld,H0invtld,Hpinvtld,Uiconst,Viconst);
-
- if options_.ms.contemp_reduced_form
- %*** Obtain the ML estimate
- A0hatinv = chol(H0inv{1}/fss); % upper triangular but lower triangular choleski
- A0hat=inv(A0hatinv);
- a0indx = find(A0hat);
- else
- %*** Obtain the ML estimate
- % load idenml
- x = 10*rand(sum(n0),1);
- H0 = eye(sum(n0));
- crit = 1.0e-9;
- nit = 10000;
- %
- tic
- [fhat,xhat,grad,Hhat,itct,fcount,retcodehat] = ...
- csminwel('fn_a0freefun',x,H0,'fn_a0freegrad',crit,nit,Uiconst,nvar,n0,fss,H0inv);
- endtime = toc
-
- A0hat = fn_tran_b2a(xhat,Uiconst,nvar,n0)
- A0hatinv = inv(A0hat);
- fhat
- xhat
- grad
- itct
- fcount
- retcodehat
- save outm endtime xhat A0hat A0hatinv grad fhat itct itct fcount retcodehat
- end
- else
- %*** Obtain the posterior matrices for estimation and inference
- [Pmat,H0inv,Hpinv] = fn_dlrpostr(xtx,xty,yty,Uiconst,Viconst);
-
- if options_.ms.contemp_reduced_form
- %*** Obtain the ML estimate
- A0hatinv = chol(H0inv{1}/fss); % upper triangular but lower triangular choleski
- A0hat=inv(A0hatinv);
- a0indx = find(A0hat);
- else
- %*** Obtain the ML estimate
- % load idenml
- x = 10*rand(sum(n0),1);
- H0 = eye(sum(n0));
- crit = 1.0e-9;
- nit = 10000;
- %
- tic
- [fhat,xhat,grad,Hhat,itct,fcount,retcodehat] = ...
- csminwel('fn_a0freefun',x,H0,'fn_a0freegrad',crit,nit,Uiconst,nvar,n0,fss,H0inv);
- endtime = toc
-
- A0hat = fn_tran_b2a(xhat,Uiconst,nvar,n0)
- A0hatinv = inv(A0hat);
- fhat
- xhat
- grad
- itct
- fcount
- retcodehat
- save outm endtime xhat A0hat A0hatinv grad fhat itct itct fcount retcodehat
- end
- end
-
- %**** impulse responses
- swish = A0hatinv; % each column corresponds to an equation
- if options_.ms.contemp_reduced_form
- xhat = A0hat(a0indx);
- Bhat=Pmat{1};
- Fhat = Bhat*A0hat;
- ghat = NaN;
- else
- xhat = fn_tran_a2b(A0hat,Uiconst,nvar,n0);
- [Fhat,ghat] = fn_gfmean(xhat,Pmat,Viconst,nvar,ncoef,n0,np);
- if options_.ms.cross_restrictions
- Fhatur0P = Fhat; % ur: unrestriced across A0 and A+
- for ki = 1:size(ixmC0Pres,1) % loop through the number of equations in which
- % cross-A0-A+ restrictions occur. See St. Louis Note p.5.
- ixeq = ixmC0Pres{ki}(1,1); % index for the jth equation in consideration.
- Lit = Viconst{ixeq}(ixmC0Pres{ki}(:,2),:); % transposed restriction matrix Li
- % V_j(i,:) in f_j(i) = V_j(i,:)*g_j
- ci = ixmC0Pres{ki}(:,4) .* A0hat(ixmC0Pres{ki}(:,3),ixeq);
- % s * a_j(h) in the restriction f_j(i) = s * a_j(h).
- LtH = Lit/Hpinv{ixeq};
- HLV = LtH'/(LtH*Lit');
- gihat = Viconst{ixeq}'*Fhatur0P(:,ixeq);
- Fhat(:,ixeq) = Viconst{ixeq}*(gihat + HLV*(ci-Lit*gihat));
- end
- end
- Bhat = Fhat/A0hat; % ncoef-by-nvar reduced form lagged parameters.
- end
- nn = [nvar options_.ms.nlags imstp];
- imfhat = fn_impulse(Bhat,swish,nn); % in the form that is congenial to RATS
- imf3hat=reshape(imfhat,size(imfhat,1),nvar,nvar);
- % imf3: row--steps, column--nvar responses, 3rd dimension--nvar shocks
- imf3shat=permute(imf3hat,[1 3 2]);
- % imf3s: permuted so that row--steps, column--nvar shocks,
- % 3rd dimension--nvar responses
- % Note: reshape(imf3s(1,:,:),nvar,nvar) = A0in (columns -- equations)
- if options_.ms.indxgimfhat
- figure
- end
- scaleout = fn_imcgraph(imfhat,nvar,imstp,xlab,ylab,options_.ms.indxgimfhat);
- imfstd = max(abs(scaleout)'); % row: nvar (largest number); used for standard deviations
-
- %
- % %**** save stds. of both data and impulse responses in idfile1
- % temp = [std(yactqmyge(:,3:end)); std(yactyrge(:,3:end)); imfstd]; %<<>>
- % save idenyimstd.prn temp -ascii % export forecast and impulse response to the file "idenyimstd.prn", 3-by-nvar
- % %
- % %**** save stds. of both data and impulse responses in idfile1
- % temp = [std(yactqmyge(:,3:end)); std(yactyrge(:,3:end)); imfstd]; %<<>>
- % save idenyimstd.prn temp -ascii % export forecast and impulse response to the file "idenyimstd.prn", 3-by-nvar
- % if options_.ms.indxparr
- % idfile1='idenyimstd';
- % end
-
- %=====================================
- % Now, out-of-sample forecasts. Note: Hm1t does not change with A0.
- %=====================================
- %
- % * updating the last row of X (phi) with the current (last row of) y.
- tcwx = nvar*options_.ms.nlags ; % total coefficeint without exogenous variables
- phil = phi(size(phi,1),:);
- phil(nvar+1:tcwx) = phil(1:tcwx-nvar);
- phil(1:nvar) = y(end,:);
- %*** exogenous variables excluding constant terms
- if (nexo>1)
- Xexoe = fn_dataext([yrEnd qmEnd],[yrEnd qmEnd],xdatae(:,[1:2 2+nvar+1:2+nvar+nexo-1]));
- phil(1,tcwx+1:tcwx+nexo-1) = Xexoe(1,3:end);
- end
- %
- %*** ML unconditional point forecast
- nn = [nvar options_.ms.nlags nfqm];
- if nexo<2
- yforehat = fn_forecast(Bhat,phil,nn); % nfqm-by-nvar, in log
- else
- Xfexoe = fn_dataext(fdates(1,:),fdates(numel(fdates),:),xdatae(:,[1:2 2+nvar+1:2+nvar+nexo-1]));
- %Xfexoe = fn_dataext(fdates(1,:),fdates(end,:),xdatae(:,[1:2 2+nvar+1:2+nvar+nexo-1]));
- yforehat = fn_forecast(Bhat,phil,nn,nexo,Xfexoe(:,3:end)); % nfqm-by-nvar, in log
- end
- yforehate = [fdates yforehat];
- %
- yact1e = fn_dataext([yrEnd-nayr 1],[yrEnd qmEnd],xdatae(:,1:nvar+2));
- if options_.ms.real_pseudo_forecast
- %yact2e = fn_dataext([yrEnd-nayr 1],E2yrqm,xdatae);
- yact2e = fn_dataext([yrEnd-nayr 1],[fdates(end,1) options_.ms.freq],xdatae(:,1:nvar+2));
- else
- yact2e=yact1e;
- end
- yafhate = [yact1e; yforehate]; % actual and forecast
- %
- %===== Converted to mg, qg, and calendar yg
- %
- [yafyrghate,yafyrhate,yafqmyghate] = fn_datana(yafhate,options_.ms.freq,options_.ms.log_var(1:nlogeno),options_.ms.percent_var(1:npereno));
- % actual and forecast growth rates
- [yact2yrge,yact2yre,yact2qmyge] = fn_datana(yact2e,options_.ms.freq,options_.ms.log_var(1:nlogeno),options_.ms.percent_var(1:npereno));
- % only actual growth rates
- yafyrghate
- if options_.ms.indxgforhat
- keyindx = [1:nvar];
- conlab=['unconditional'];
-
- figure
- yafyrghate(:,3:end) = yafyrghate(:,3:end)/100;
- yact2yrge(:,3:end) = yact2yrge(:,3:end)/100;
- fn_foregraph(yafyrghate,yact2yrge,keyindx,rnum,cnum,options_.ms.freq,ylab,forelabel,conlab)
- end
-
- %-------------------------------------------------
- % Setup for point conditional forecast
- % ML Conditional Forecast
- %-------------------------------------------------
- %
- %% See Zha's note "Forecast (1)" p. 5, RATS manual (some errors in RATS), etc.
- %
- %% Some notations: y(t+1) = y(t)B1 + e(t+1)inv(A0). e(t+1) is 1-by-n.
- %% Let r(t+1)=e(t+1)inv(A0) + e(t+2)C + .... where inv(A0) is impulse
- %% response at t=1, C at t=2, etc. The row of inv(A0) or C is
- %% all responses to one shock.
- %% Let r be q-by-1 (such as r(1) = r(t+1)
- %% = y(t+1) (constrained) - y(t+1) (forecast)).
- %% Use impulse responses to find out R (k-by-q) where k=nvar*nsteps
- %% where nsteps the largest constrained step. The key of the program
- %% is to creat R using impulse responses
- %% Optimal solution for shock e where R'*e=r and e is k-by-1 is
- %% e = R*inv(R'*R)*r.
- %
-
- if (nconstr > 0)
- %*** initializing
- stepcon=cell(nconstr,1); % initializing, value y conditioned
- valuecon=zeros(nconstr,1); % initializing, value y conditioned
- varcon=zeros(nconstr,1); % initializing, endogous variables conditioned
- varcon(:)=PorR; % 1: Pcm; 3: FFR; 5: CPI
-
- %
- for i=1:nconstr
- if i<=nconstr1
- stepcon{i}=i; % FFR
- elseif i<=2*nconstr1
- stepcon{i}=i-nconstr1; % FFR
- elseif i<=3*nconstr1
- stepcon{i}=i-2*nconstr1; % FFR
- elseif i<=4*nconstr1
- stepcon{i}=i-3*nconstr1; % FFR
- elseif i<=5*nconstr1
- stepcon{i}=i-4*nconstr1; % FFR
- elseif i<=6*nconstr1
- stepcon{i}=i-5*nconstr1; % FFR
- end
- end
-
-% for i=1:nconstr
-% stepcon{i}=i; % FFR
-% end
-
-% bend=12;
-% stepcon{1}=[1:bend]'; % average over
-% stepcon{nconstr1+1}=[1:options_.ms.freq-qmSub]'; % average over the remaing months in 1st forecast year
-% stepcon{nconstr1+2}=[options_.ms.freq-qmSub+1:options_.ms.freq-qmSub+12]'; % average over 12 months next year
-% stepcon{nconstr1+3}=[options_.ms.freq-qmSub+13:options_.ms.freq-qmSub+24]'; % average over 12 months. 3rd year
-% stepcon{nconstr1+4}=[options_.ms.freq-qmSub+25:options_.ms.freq-qmSub+36]'; % average over 12 months. 4th year
-
-% %**** avearage condition over, say, options_.ms.freq periods
-% if qmEnd==options_.ms.freq
-% stepcon{1}=[1:options_.ms.freq]'; % average over the remaing periods in 1st forecast year
-% else
-% stepcon{1}=[1:options_.ms.freq-qmEnd]'; % average over the remaing periods in 1st forecast year
-% end
-% for kj=2:nconstr
-% stepcon{kj}=[length(stepcon{kj-1})+1:length(stepcon{kj-1})+options_.ms.freq]'; % average over 12 months next year
-% end
-
- if options_.ms.real_pseudo_forecast
-% %*** conditions in every period
-% for i=1:nconstr
-% valuecon(i) = yact(actup+i,varcon(i));
-% %valuecon(i) = mean( yact(actup+1:actup+bend,varcon(i)) );
-% %valuecon(i) = 0.060; % 95:01
-% %valuecon(i) = (0.0475+0.055)/2; % 94:10
-% end
-
-% %*** average condtions over,say, options_.ms.freq periods.
-% for i=nconstr1+1:nconstr1+nconstr2
-% i=1;
-% valuecon(nconstr1+i) = ( ( mean(ylast12Cal(:,varcon(nconstr1+i)),1) + ...
-% log(1+yactCalyg(yAg-yFg+i,varcon(nconstr1+i))/100) )*options_.ms.freq - ...
-% yCal_1(:,varcon(nconstr1+i)) ) ./ length(stepcon{nconstr1+i});
-% % the same as unconditional "yactCalyg" 1st calendar year
-% i=2;
-% valuecon(nconstr1+i) = mean(ylast12Cal(:,varcon(nconstr1+i))) + ...
-% log(1+yactCalyg(yAg-yFg+1,varcon(nconstr1+i))/100) ...
-% + log(1+yactCalyg(yAg-yFg+i,varcon(nconstr1+i))/100);
-% % the same as actual "yactCalgy" 2nd calendar year
-% i=3;
-% valuecon(nconstr1+i) = valuecon(nconstr1+i-1) + ...
-% log(1+yactCalyg(yAg-yFg+i,varcon(nconstr1+i))/100);
-% % the same as actual "yactCalgy" 3rd calendar year
-% %i=4;
-% %valuecon(nconstr1+i) = valuecon(nconstr1+i-1) + ...
-% % log(1+yactCalyg(yAg-yFg+i,varcon(nconstr1+i))/100);
-% % the same as actual "yactCalgy" 4th calendar year
-% end
-
- %*** conditions in every period
- vpntM = fn_dataext(E1yrqm, E2yrqm,xdatae); % point value matrix with dates
- % vaveM = fn_dataext([yrEnd+1 0],[yrEnd+options_.ms.forecast 0],yact2yre); % average value matrix with dates
- for i=1:nconstr
- if i<=nconstr1
- valuecon(i) = vpntM(i,2+varcon(i)); % 2: first 2 elements are dates
- elseif i<=2*nconstr1
- valuecon(i) = vpntM(i-nconstr1,2+varcon(i));
- elseif i<=3*nconstr1
- valuecon(i) = vpntM(i-2*nconstr1,2+varcon(i));
- elseif i<=4*nconstr1
- valuecon(i) = vpntM(i-3*nconstr1,2+varcon(i));
- elseif i<=5*nconstr1
- valuecon(i) = vpntM(i-4*nconstr1,2+varcon(i));
- elseif i<=6*nconstr1
- valuecon(i) = vpntM(i-5*nconstr1,2+varcon(i));
- end
- end
-
-% %*** average condtions over,say, options_.ms.freq periods.
-% if qmEnd==options_.ms.freq
-% vaveM = fn_dataext([yrEnd+1 0],[yrEnd+options_.ms.forecast 0],yact2yre); % average value matrix with dates
-% valuecon(1) = vaveM(1,2+varcon(1)); % 2: first 2 elements are dates
-% else
-% vaveM = fn_dataext([yrEnd 0],[yrEnd+options_.ms.forecast 0],yact2yre); % average value matrix with dates
-% yactrem = fn_dataext([yrEnd qmEnd+1],[yrEnd options_.ms.freq],xdatae);
-% valuecon(1) = sum(yactrem(:,2+varcon(1)),1)/length(stepcon{1});
-% % 2: first 2 elements are dates
-% end
-% for kj=2:nconstr
-% valuecon(kj) = vaveM(kj,2+varcon(kj)); % 2: first 2 elements are dates
-% end
- else
- vpntM = dataext([yrEnd qmEnd+1],[yrEnd qmEnd+2],xdatae); % point value matrix with dates
- for i=1:nconstr
- if i<=nconstr1
- valuecon(i) = vpntM(i,2+varcon(i)); % 2: first 2 elements are dates; Poil
- elseif i<=2*nconstr1
- valuecon(i) = vpntM(i-nconstr1,2+varcon(i)); % 2: first 2 elements are dates; M2
- elseif i<=3*nconstr1
- valuecon(i) = vpntM(i-2*nconstr1,2+varcon(i)); % 2: first 2 elements are dates; FFR
- elseif i<=4*nconstr1
- valuecon(i) = vpntM(i-3*nconstr1,2+varcon(i)); % 2: first 2 elements are dates; CPI
- elseif i<=5*nconstr1
- valuecon(i) = vpntM(i-4*nconstr1,2+varcon(i)); % 2: first 2 elements are dates; U
- elseif i<=5*nconstr1+nconstr2
- valuecon(i)=xdata(end,5)+(i-5*nconstr1)*log(1.001)/options_.ms.freq; %CPI
- elseif i<=5*nconstr1+2*nconstr2
- valuecon(i)=0.0725; %FFR
- else
- valuecon(i)=xdata(end,6)+(i-5*nconstr1-2*nconstr2)*0.01/nfqm; %U
- end
- end
- %valuecon(i) = 0.060; % 95:01
- end
- else
- valuecon = [];
- stepcon = [];
- varcon = [];
- end
-
- nstepsm = 0; % initializing, the maximum step in all constraints
- for i=1:nconstr
- nstepsm = max([nstepsm max(stepcon{i})]);
- end
-
- if cnum
- if options_.ms.real_pseudo_forecast & options_.ms.banact
- for i=1:length(banstp{1})
- banval{1}(1:length(banstp{1}),1) = ...
- yactCalyg(yAg-yFg+1:yAg-yFg+length(banstp{1}),banvar(1)) - 2;
- banval{1}(1:length(banstp{1}),2) = ...
- yactCalyg(yAg-yFg+1:yAg-yFg+length(banstp{1}),banvar(1)) + 2;
- end
- end
- end
-
-
- %===================================================
- % ML conditional forecast
- %===================================================
- %/*
- [ychat,Estr,rcon] = fn_fcstidcnd(valuecon,stepcon,varcon,nstepsm,...
- nconstr,options_.ms.eq_ms,nvar,options_.ms.nlags ,phil,0,0,yforehat,imf3shat,A0hat,Bhat,...
- nfqm,options_.ms.tlindx,options_.ms.tlnumber,options_.ms.ncms,options_.ms.eq_cms);
- ychate = [fdates ychat];
- yachate = [yact1e; ychate]; % actual and condtional forecast
- %===== Converted to mg, qg, and calendar yg
- [yacyrghate,yacyrhate,yacqmyghate] = fn_datana(yachate,options_.ms.freq,options_.ms.log_var(1:nlogeno),options_.ms.percent_var(1:npereno));
- % actual and conditional forecast growth rates
- if options_.ms.indxgdls & nconstr
- keyindx = [1:nvar];
- % conlab=['conditional on' ylab{PorR(1)}];
- conlab=['v-conditions'];
-
- figure
- fn_foregraph(yafyrghate,yact2yrge,keyindx,rnum,cnum,options_.ms.freq,ylab,forelabel,conlab)
- end
-
- if options_.ms.ncsk
- Estr = zeros(nfqm,nvar);
- Estr(1:2,:) = [
- -2.1838 -1.5779 0.53064 -0.099425 -0.69269 -1.0391
- 1.9407 3.3138 -0.10563 -0.55457 -0.68772 1.3534
- ];
- Estr(3:6,3) = [0.5*ones(1,4)]'; % MD shocks
-
- Estr(3:10,2) = [1.5 1.5 1.5*ones(1,6)]'; % MS shocks
-
- %Estr(3:6,6) = 1*ones(4,1); % U shocks
- %Estr(8:11,4) = 1*ones(4,1); % y shocks
-
- %Estr(3:10,2) = [2.5 2.5 1.5*ones(1,6)]'; % MS shocks alone
-
- nn = [nvar options_.ms.noptions_.ms.nlags nfqm];
- ycEhat = forefixe(A0hat,Bhat,phil,nn,Estr);
- ycEhate = [fdates ycEhat];
- yacEhate = [yact1e; ycEhate]; % actual and condtional forecast
- %===== Converted to mg, qg, and calendar yg
- [yacEyrghate,yacEyrhate,yacEqmyghate] = datana(yacEhate,options_.ms.freq,options_.ms.log_var(1:nlogeno),options_.ms.percent_var(1:npereno));
- % actual and conditional forecast growth rates
- disp([sprintf('%4.0f %2.0f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f\n',yacEyrghate')])
-
- if 1
- keyindx = [1:nvar];
- % conlab=['conditional on' ylab{PorR(1)}];
- conlab=['shock-conditions'];
-
- figure
- gyrfore(yacEyrghate,yact2yrge,keyindx,rnum,cnum,ylab,forelabel,conlab)
- end
- end
-
- %-----------------------------------------------------------
- % Compute structural shocks for the whole sample period excluding dummy observations.
- %-----------------------------------------------------------
- ywod = y(options_.ms.dummy_obs +1:end,:); % without dummy observations
- phiwod=phi(options_.ms.dummy_obs +1:end,:); % without dummy observations
- eplhat=ywod*A0hat-phiwod*Fhat;
- qmStartWod = mod(qmStart+options_.ms.nlags ,options_.ms.freq);
- if (~qmStartWod)
- qmStartWod = options_.ms.freq;
- end
- yrStartWod = yrStart + floor((qmStart+options_.ms.nlags -1)/options_.ms.freq);
- dateswod = fn_dataext([yrStartWod qmStartWod],[yrEnd qmEnd],xdatae(:,[1:2]));
- eplhate = [dateswod eplhat];
-
- Aphat = Fhat;
-end
-
-%----------------------------------------
-% Tests for LR, HQ, Akaike, Schwarz. The following gives a guidance.
-% But the computation has to be done in a different M file by exporting fhat's
-% from different idfile's.
-%----------------------------------------
-%
-%if ~options_.ms.contemp_reduced_form
-% SpHR=A0in'*A0in;
-%end
-%%
-%if ~isnan(SpHR) & ~options_.ms.contemp_reduced_form
-% warning(' ')
-% disp('Make sure you run the program with options_.ms.contemp_reduced_form =1 first.')
-% disp('Otherwise, the following test results such as Schwartz are incorrect.')
-% disp('All other results such as A0ml and imfs, however, are correct.')
-% disp('Press anykey to contintue or ctrl-c to stop now')
-% pause
-
-% load SpHUout
-
-% logLHU=-fss*sum(log(diag(chol(SpHU)))) -0.5*fss*nvar % unrestricted logLH
-
-% logLHR=-fhat % restricted logLH
-% tra = reshape(SpHU,nvar*nvar,1)'*reshape(A0*A0',nvar*nvar,1);
-% df=(nvar*(nvar+1)/2 - length(a0indx));
-% S=2*(logLHU-logLHR);
-% SC = (nvar*(nvar+1)/2 - length(a0indx)) * log(fss);
-% disp(['T -- effective sample size: ' num2str(fss)])
-% disp(['Trace in the overidentified posterior: ' num2str(tra)])
-% disp(['Chi2 term -- 2*(logLHU-logLHR): ' num2str(S)])
-% disp(['Degrees of freedom: ' num2str(df)])
-% disp(['SC -- df*log(T): ' num2str(SC)])
-% disp(['Akaike -- 2*df: ' num2str(2*df)])
-% disp(['Classical Asymptotic Prob at chi2 term: ' num2str(cdf('chi2',S,df))])
-
-% %*** The following is the eigenanalysis in the difference between
-% %*** unrestricted (U) and restricted (R)
-% norm(A0'*SpHU*A0-diag(diag(ones(6))))/6;
-% norm(SpHU-A0in'*A0in)/6;
-
-% corU = corr(SpHU);
-% corR = corr(SpHR);
-
-% [vU,dU]=eigsort(SpHU,1);
-% [vR,dR]=eigsort(SpHR,1);
-
-% [log(diag(dU)) log(diag(dR)) log(diag(dU))-log(diag(dR))];
-
-% sum(log(diag(dU)));
-% sum(log(diag(dR)));
-%else
-% disp('To run SC test, turn options_.ms.contemp_reduced_form =1 first and then turn options_.ms.contemp_reduced_form =0')
-%end
-
-
-%***** Simply regression
-%X=[phi(:,3) y(:,2)-phi(:,2) y(:,1)-phi(:,7) ones(fss,1)];
-%� Y=y(:,3);
-%� b=regress(Y,X)
-
-%=== Computes the roots for the whole system.
-rootsinv = fn_varoots(Bhat,nvar,options_.ms.nlags )
-abs(rootsinv)
-
-
-bhat =xhat;
-n0const=n0; % For constant parameter models.
-n0const=n0; % For constant parameter models.
-npconst=np; % For constant parameter models.
-save outdata_a0dp_const A0hat bhat Aphat n0const
diff --git a/matlab/swz/msstart_setup.m b/matlab/swz/msstart_setup.m
deleted file mode 100644
index 6411e07016943c6e34a75feff4eb7628fc7ea990..0000000000000000000000000000000000000000
--- a/matlab/swz/msstart_setup.m
+++ /dev/null
@@ -1,154 +0,0 @@
-%function []= msstart_setup(options_)
-
-% ** ONLY UNDER UNIX SYSTEM
-%path(path,'/usr2/f1taz14/mymatlab')
-
-
-
-%===========================================
-% Exordium I
-%===========================================
-format short g % format
-%
-%options_.ms.freq = 4; % quarters or months
-%options_.ms.initial_year=1959; % beginning of the year
-%options_.ms.initial_subperiod=1; % begining of the quarter or month
-%options_.ms.final_year=2005; % final year
-%options_.ms.final_subperiod=4; % final month or quarter
-nData=(options_.ms.final_year-options_.ms.initial_year)*options_.ms.freq + (options_.ms.final_subperiod-options_.ms.initial_subperiod+1);
- % total number of the available data -- this is all you have
-
-%*** Load data and series
-%load datainf_argen.prn % the default name for the variable is "options_.ms.data".
-%load datacbogdpffr.prn
-%options_.ms.data = datacbogdpffr;
-%clear datacbogdpffr;
-[nt,ndv]=size(options_.data);
-if nt~=nData
- disp(' ')
- warning(sprintf('nt=%d, Caution: not equal to the length in the data',nt));
- %disp(sprintf('nt=%d, Caution: not equal to the length in the data',nt));
- disp('Press ctrl-c to abort')
- return
-end
-%--------
-%1 CBO output gap -- log(x_t)-log(x_t potential)
-%2 GDP deflator -- (P_t/P_{t-1})^4-1.0
-%2 FFR/100.
-options_.ms.vlist = [1:size(options_.varobs,1)]; % 1: U; 4: PCE inflation.
-options_.ms.varlist=cellstr(options_.varobs);
-%options_.ms.log_var = [ ]; % subset of "options_.ms.vlist. Variables in log level so that differences are in **monthly** growth, unlike R and U which are in annual percent (divided by 100 already).
-options_.ms.percent_var = [1:size(options_.varobs,1)]; % subset of "options_.ms.vlist"
-%options_.ms.restriction_fname='ftd_upperchol3v'; %Only used by msstart2.m.
-ylab = options_.ms.varlist;
-xlab = options_.ms.varlist;
-
-%----------------
-nvar = length(options_.ms.vlist); % number of endogenous variables
-nlogeno = length(options_.ms.log_var) % number of endogenous variables in options_.ms.log_var
-npereno = length(options_.ms.percent_var) % number of endogenous variables in options_.ms.percent_var
-if (nvar~=(nlogeno+npereno))
- disp(' ')
- warning('Check xlab, nlogeno or npereno to make sure of endogenous variables in options_.ms.vlist')
- disp('Press ctrl-c to abort')
- return
-elseif (nvar==length(options_.ms.vlist))
- nexo=1; % only constants as an exogenous variable. The default setting.
-elseif (nvar<length(options_.ms.vlist))
- nexo=length(options_.ms.vlist)-nvar+1;
-else
- disp(' ')
- warning('Make sure there are only nvar endogenous variables in options_.ms.vlist')
- disp('Press ctrl-c to abort')
- return
-end
-
-
-%------- A specific sample is considered for estimation -------
-yrStart=options_.ms.initial_year;
-qmStart=options_.ms.initial_subperiod;
-yrEnd=options_.ms.final_year;
-qmEnd=options_.ms.final_subperiod;
-%options_.ms.forecast = 4; % number of years for forecasting
-if options_.ms.forecast<1
- error('To be safe, the number of forecast years should be at least 1')
-end
-ystr=num2str(yrEnd);
-forelabel = [ ystr(3:4) ':' num2str(qmEnd) ' Forecast'];
-
-nSample=(yrEnd-yrStart)*options_.ms.freq + (qmEnd-qmStart+1);
-if qmEnd==options_.ms.freq
- E1yrqm = [yrEnd+1 1]; % first year and quarter (month) after the sample
-else
- E1yrqm = [yrEnd qmEnd+1]; % first year and quarter (month) after the sample
-end
-E2yrqm = [yrEnd+options_.ms.forecast qmEnd]; % end at the last month (quarter) of a calendar year after the sample
-[fdates,nfqm]=fn_calyrqm(options_.ms.freq,E1yrqm,E2yrqm); % forecast dates and number of forecast dates
-[sdates,nsqm] = fn_calyrqm(options_.ms.freq,[yrStart qmStart],[yrEnd qmEnd]);
- % sdates: dates for the whole sample (including options_.ms.nlags)
-if nSample~=nsqm
- warning('Make sure that nSample is consistent with the size of sdates')
- disp('Hit any key to continue, or ctrl-c to abort')
- pause
-end
-imstp = 4*options_.ms.freq; % <<>> impulse responses (4 years)
-nayr = 4; %options_.ms.forecast; % number of years before forecasting for plotting.
-
-
-%------- Prior, etc. -------
-%options_.ms.nlags = 4; % number of options_.ms.nlags
-%options_.ms.cross_restrictions = 0; % 1: cross-A0-and-A+ restrictions; 0: options_.ms.restriction_fname is all we have
- % Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-%options_.ms.contemp_reduced_form = 0; % 1: contemporaneous recursive reduced form; 0: restricted (non-recursive) form
-%options_.ms.real_pseudo_forecast = 0; % 1: options_.ms.real_pseudo_forecast forecasts; 0: real time forecasts
-%options_.ms.bayesian_prior = 1; % 1: Bayesian prior; 0: no prior
-indxDummy = options_.ms.bayesian_prior; % 1: add dummy observations to the data; 0: no dummy added.
-%options_.ms.dummy_obs = 0; % No dummy observations for xtx, phi, fss, xdatae, etc. Dummy observations are used as an explicit prior in fn_rnrprior_covres_dobs.m.
-%if indxDummy
-% options_.ms.dummy_obs=nvar+1; % number of dummy observations
-%else
-% options_.ms.dummy_obs=0; % no dummy observations
-%end
-%=== The following mu is effective only if options_.ms.bayesian_prior==1.
-mu = zeros(6,1); % hyperparameters
-mu = zeros(6,1); % hyperparameters
-mu(1) = 0.57;
-mu(2) = 0.13;
-mu(3) = 0.1;
-mu(4) = 1.5; %1.4 or 1.5, faster decay, produces much better inflation forecast.
-mu(5) = 5; %10;
-mu(6) = 5; %10;
-% mu(1): overall tightness and also for A0;
-% mu(2): relative tightness for A+;
-% mu(3): relative tightness for the constant term;
-% mu(4): tightness on lag decay; (1)
-% mu(5): weight on nvar sums of coeffs dummy observations (unit roots);
-% mu(6): weight on single dummy initial observation including constant
-% (cointegration, unit roots, and stationarity);
-%
-%
-hpmsmd = [0.0; 0.0];
-indxmsmdeqn = [0; 0; 0; 0]; %This option disenable using this in fn_rnrprior_covres_dobs.m
-
-
-tdf = 3; % degrees of freedom for t-dist for initial draw of the MC loop
-nbuffer = 100; % a block or buffer of draws (buffer) that is saved to the disk (not memory)
-ndraws1=1*nbuffer; % 1st part of Monte Carlo draws
-ndraws2=10*ndraws1 % 2nd part of Monte Carlo draws
-seednumber = 0; %7910; %472534; % if 0, random state at each clock time
- % good one 420 for [29 45], [29 54]
-if seednumber
- randn('state',seednumber);
- rand('state',seednumber);
-else
- randn('state',fix(100*sum(clock)));
- rand('state',fix(100*sum(clock)));
-end
-% nstarts=1 % number of starting points
-% imndraws = nstarts*ndraws2; % total draws for impulse responses or forecasts
-%<<<<<<<<<<<<<<<<<<<
-
-
-
-
-
diff --git a/matlab/swz/switching_specification/specification_2v.dat b/matlab/swz/switching_specification/specification_2v.dat
deleted file mode 100644
index e341c610d256ebdda20dd1b7f44defc9a8ba36f1..0000000000000000000000000000000000000000
--- a/matlab/swz/switching_specification/specification_2v.dat
+++ /dev/null
@@ -1,71 +0,0 @@
-/******************************************************************************/
-/********************* Markov State Variable Information **********************/
-/******************************************************************************/
-
-//== Flat Independent Markov States and Simple Restrictions ==//
-
-
-//This number is NOT used but read in.
-//== Number Observations ==//
-200
-
-//== Number Independent State Variables ==//
-1
-
-//=====================================================//
-//== state_variable[i] (1 <= i <= n_state_variables) ==//
-//=====================================================//
-//== Number of states for state_variable[1] ==//
-2
-
-//== 03/15/06: DW TVBVAR code reads the data below and overwrite the prior data read somewhere else if any.
-//== Each column contains the parameters for a Dirichlet prior on the corresponding
-//== column of the transition matrix. Each element must be positive. For each column,
-//== the relative size of the prior elements determine the relative size of the elements
-//== of the transition matrix and overall larger sizes implies a tighter prior.
-//== Transition matrix prior for state_variable[1]. (n_states x n_states) ==//
- 5.6666666666666661e+000 1.0000000000000000e+000
- 1.0000000000000000e+000 5.6666666666666661e+000
-
-
-//== Free Dirichet dimensions for state_variable[1] ==//
-2 2
-
-//== The jth restriction matrix is n_states-by-free[j]. Each row of the restriction
-//== matrix has exactly one non-zero entry and the sum of each column must be one.
-//== Column restrictions for state_variable[1] ==//
-1 0
-0 1
-
-1 0
-0 1
-
-
-/******************************************************************************/
-/******************************* VAR Parameters *******************************/
-/******************************************************************************/
-//NOT read
-//== Number Variables ==//
-3
-
-//NOT read
-//== Number Lags ==//
-3
-
-//NOT read
-//== Exogenous Variables ==//
-1
-
-//== nvar x n_state_variables matrix. In the jth row, a non-zero value implies that
-this state variable controls the jth column of A0 and Aplus
-//== Controlling states variables for coefficients ==//
-0
-0
-0
-
-//== nvar x n_state_variables matrix. In the jth row, a non-zero value implies that
-this state variable controls the jth diagonal element of Xi
-//== Controlling states variables for variance ==//
- 1
- 1
- 1
diff --git a/matlab/swz/switching_specification/specification_2v2c.dat b/matlab/swz/switching_specification/specification_2v2c.dat
deleted file mode 100644
index e0bc2f6d9e2182e38581d29428a8e1801845d9f7..0000000000000000000000000000000000000000
--- a/matlab/swz/switching_specification/specification_2v2c.dat
+++ /dev/null
@@ -1,98 +0,0 @@
-/******************************************************************************/
-/********************* Markov State Variable Information **********************/
-/******************************************************************************/
-
-//== Flat Independent Markov States and Simple Restrictions ==//
-
-
-//This number is NOT used but read in.
-//== Number Observations ==//
-200
-
-//== Number Independent State Variables ==//
-2
-
-//=====================================================//
-//== state_variable[i] (1 <= i <= n_state_variables) ==//
-//=====================================================//
-//== Number of states for state_variable[1] ==//
-2
-
-//== 03/15/06: DW TVBVAR code reads the data below and overwrite the prior data read somewhere else if any.
-//== Each column contains the parameters for a Dirichlet prior on the corresponding
-//== column of the transition matrix. Each element must be positive. For each column,
-//== the relative size of the prior elements determine the relative size of the elements
-//== of the transition matrix and overall larger sizes implies a tighter prior.
-//== Transition matrix prior for state_variable[1]. (n_states x n_states) ==//
- 5.6666666666666661e+000 1.0000000000000000e+000
- 1.0000000000000000e+000 5.6666666666666661e+000
-
-
-//== Free Dirichet dimensions for state_variable[1] ==//
-2 2
-
-//== The jth restriction matrix is n_states-by-free[j]. Each row of the restriction
-//== matrix has exactly one non-zero entry and the sum of each column must be one.
-//== Column restrictions for state_variable[1] ==//
-1 0
-0 1
-
-1 0
-0 1
-
-
-//== Number of states for state_variable[2] ==//
-2
-
-//== Each column contains the parameters for a Dirichlet prior on the corresponding
-//== column of the transition matrix. Each element must be positive. For each column,
-//== the relative size of the prior elements determine the relative size of the elements
-//== of the transition matrix and overall larger sizes implies a tighter prior.
-//== Transition matrix prior for state_variable[2]. (n_states x n_states) ==//
- 5.6666666666666661e+000 1.0000000000000000e+000
- 1.0000000000000000e+000 5.6666666666666661e+000
-
-//== Free Dirichet dimensions for state_variable[2] ==//
-2 2
-
-//== The jth restriction matrix is n_states x free[j]. Each row of the restriction
-//== matrix has exactly one non-zero entry and the sum of each column must be one.
-//== Column restrictions for state_variable[2] ==//
-1 0
-0 1
-
-1 0
-0 1
-
-/******************************************************************************/
-/******************************* VAR Parameters *******************************/
-/******************************************************************************/
-//NOT read
-//== Number Variables ==//
-3
-
-//NOT read
-//== Number Lags ==//
-3
-
-//NOT read
-//== Exogenous Variables ==//
-1
-
-//== nvar x n_state_variables matrix. In the jth row, a non-zero value implies that
-this state variable controls the jth column of A0 and Aplus
-//== Controlling states variables for coefficients ==//
-0 1
-0 1
-0 1
-0 1
-0 1
-
-//== nvar x n_state_variables matrix. In the jth row, a non-zero value implies that
-this state variable controls the jth diagonal element of Xi
-//== Controlling states variables for variance ==//
- 1 0
- 1 0
- 1 0
- 1 0
- 1 0
diff --git a/matlab/swz/swz_mardd.m b/matlab/swz/swz_mardd.m
deleted file mode 100644
index e27b085262ee26312d3de55f95a88d9dea6eb5f9..0000000000000000000000000000000000000000
--- a/matlab/swz/swz_mardd.m
+++ /dev/null
@@ -1,182 +0,0 @@
-function swz_mardd(options_)
-% Applies to both linear and exclusion restrictions.
-% (1) Marginal likelihood function p(Y) for constant structural VAR models, using Chib (1995)'s ``Marginal Likelihood from the Gibbs Output'' in JASA.
-% (2) Conditional likelihood function f(Y|A0, A+) on the ML estimate for constant exclusion-identified models.
-% See Forecast (II) pp.67-80.
-%
-% Tao Zha, September 1999. Quick revisions, May 2003. Final revision, September 2004.
-
-msstart2 % start the program in which everyhting is initialized through msstart2.m
-if ~options_.ms.indxestima
- warning(' ')
- disp('You must set IxEstima=1 in msstart to run this program')
- disp('Press ctrl-c to abort now')
- pause
-end
-
-A0xhat = zeros(size(A0hat));
-Apxhat = zeros(size(Aphat));
-if (0)
- %Robustness check to see if the same result is obtained with the purterbation of the parameters.
- for k=1:nvar
- bk = Uiconst{k}'*A0hat(:,k);
- gk = Viconst{k}'*Aphat(:,k);
- A0xhat(:,k) = Uiconst{k}*(bk + 5.2*randn(size(bk))); % Perturbing the posterior estimate.
- Apxhat(:,k) = Viconst{k}*(gk + 5.2*randn(size(gk))); % Perturbing the posterior estimate.
- end
-else
- %At the posterior estimate.
- A0xhat = A0hat; % ML estimate of A0
- Apxhat = Aphat; % ML estimate of A+
-end
-%--- Rename variables.
-YatYa = yty;
-XatYa = xty;
-ytx = xty';
-YatXa = ytx;
-XatXa = xtx;
-
-
-
-%--------- The log value of p(A0,A+) at some point such as the peak ----------
-vlog_a0p = 0;
-Yexpt=0; % exponential term for Y in p(Y|A0,A+) at some point such as the peak
-Apexpt=0.0; % 0.0 because we have chosen posterior estimate of A+ as A+*. Exponential term for A+ conditional on A0 and Y
-%======= Computing the log prior pdf of a0a+ and the exponential term for Y in p(Y|A0,A+).
-for k=1:nvar
- a0k = A0xhat(:,k); % meaningful parameters in the kth equation.
- apk = Apxhat(:,k); % meaningful parameters in the kth equation.
-
- %--- Prior settings.
- S0bar = H0invtld{k}; %See Claim 2 on p.69b.
- Spbar = Hpinvtld{k};
- bk = Uiconst{k}'*a0k; % free parameters in the kth equation.
- gk = Viconst{k}'*apk; % free parameters in the kth equation.
- gbark = Ptld{k}*bk; % bar: prior
-
- %--- The exponential term for Y in p(Y|A0,A+)
- Yexpt = Yexpt - 0.5*(a0k'*YatYa*a0k - 2*apk'*XatYa*a0k + apk'*XatXa*apk);
- %--- The log prior pdf.
- vlog_a0p = vlog_a0p - 0.5*(size(Uiconst{k},2)+size(Viconst{k},2))*log(2*pi) + 0.5*log(abs(det(S0bar))) + ...
- 0.5*log(abs(det(Spbar))) - 0.5*(bk'*S0bar*bk+(gk-gbark)'*Spbar*(gk-gbark));
- %--- For p(A+|Y,a0) only.
- tmpd = gk - Pmat{k}*bk;
- Apexpt = Apexpt - 0.5*tmpd'*(Hpinv{k}*tmpd);
-end
-vlog_a0p
-
-%--------- The log value of p(Y|A0,A+) at some point such as the peak. ----------
-%--------- Note that logMarLHres is the same as vlog_Y_a, just to double check. ----------
-vlog_Y_a = -0.5*nvar*fss*log(2*pi) + fss*log(abs(det(A0xhat))) + Yexpt
- % a: given a0 and a+
-logMarLHres = 0; % Initialize log of the marginal likelihood (restricted or constant parameters).
-for ki=1:fss %ndobs+1:fss % Forward recursion to get the marginal likelihood. See F on p.19 and pp. 48-49.
- %---- Restricted log marginal likelihood function (constant parameters).
- [A0l,A0u] = lu(A0xhat);
- ada = sum(log(abs(diag(A0u)))); % log|A0|
- termexp = y(ki,:)*A0xhat - phi(ki,:)*Apxhat; % 1-by-nvar
- logMarLHres = logMarLHres - (0.5*nvar)*log(2*pi) + ada - 0.5*termexp*termexp'; % log value
-end
-logMarLHres
-
-
-%--------- The log value of p(A+|Y,A0) at some point such as the peak ----------
-totparsp = 0.0;
-tmpd = 0.0;
-for k=1:nvar
- totparsp = totparsp + size(Viconst{k},2);
- tmpd = tmpd + 0.5*log(abs(det(Hpinv{k})));
-end
-vlog_ap_Ya0 = -0.5*totparsp*log(2*pi) + tmpd + Apexpt;
-
-
-
-
-%===================================
-% Compute p(a0,k|Y,ao) at some point such as the peak (in this situation, we simply
-% generate results from the original Gibbs sampler). See FORECAST (2) pp.70-71
-%===================================
-%--- Global set up for Gibbs.
-[Tinv,UT] = fn_gibbsrvar_setup(H0inv, Uiconst, Hpinv, Pmat, Viconst, nvar, fss);
-%
-vlog_a0_Yao = zeros(nvar,1);
- % the log value of p(a0k|Y,ao) where ao: other a's at some point such as the peak of ONLY some a0's
-vlog=zeros(ndraws2,1);
-tic
-for k=1:nvar
- bk = Uiconst{k}'*A0xhat(:,k);
- indx_ks=[k:nvar]; % the columns that exclude 1-(k-1)th columns
- A0gbs0 = A0hat; % starting at some point such as the peak
- nk = n0(k);
-
- if k<nvar
- %--------- The 1st set of draws to be tossed away. ------------------
- for draws = 1:ndraws1
- if ~mod(draws,nbuffer)
- disp(' ')
- disp(sprintf('The %dth column or equation in A0 with %d 1st tossed-away draws in Gibbs',k,draws))
- end
- A0gbs1 = fn_gibbsrvar(A0gbs0,UT,nvar,fss,n0,indx_ks);
- A0gbs0=A0gbs1; % repeat the Gibbs sampling
- end
-
-
- %--------- The 2nd set of draws to be used. ------------------
- for draws = 1:ndraws2
- if ~mod(draws,nbuffer)
- disp(' ')
- disp(sprintf('The %dth column or equation in A0 with %d usable draws in Gibbs',k,draws))
- end
- [A0gbs1, Wcell] = fn_gibbsrvar(A0gbs0,UT,nvar,fss,n0,indx_ks);
- %------ See p.71, Forecast (II).
- %------ Computing p(a0_k|Y,a_others) at some point such as the peak along the dimensions of indx_ks.
- Vk = Tinv{k}\Wcell{k}; %V_k on p.71 of Forecast (II).
- gbeta = Vk\bk; % inv(V_k)*b_k on p.71 of Forecast (II) where alpha_k = b_k in our notation.
- [Vtq,Vtr]=qr(Vk',0); %To get inv(V_k)'*inv(V_k) in (*) on p.71 of Forecast (II).
- %
- vlog(draws) = 0.5*(fss+nk)*log(fss)-log(abs(det(Vk)))-0.5*(nk-1)*log(2*pi)-...
- 0.5*(fss+1)*log(2)-gammaln(0.5*(fss+1))+fss*log(abs(gbeta(1)))-...
- 0.5*fss*bk'*(Vtr\(Vtr'\bk));
-
- A0gbs0=A0gbs1; % repeat the Gibbs sampling
- end
- vlogm=max(vlog);
- qlog=vlog-vlogm;
- vlogxhat=vlogm-log(ndraws2)+log(sum(exp(qlog)));
- vlog_a0_Yao(k) = vlogxhat;
- % The log value of p(a0_k|Y,a_others) where a_others: other a's at some point such as the peak of ONLY some a0's
- else
- disp(' ')
- disp(sprintf('The last(6th) column or equation in A0 with no Gibbs draws'))
- [A0gbs1, Wcell] = fn_gibbsrvar(A0gbs0,UT,nvar,fss,n0,indx_ks)
- %------ See p.71, Forecast (II).
- %------ Computing p(a0_k|Y,a_others) at some point such as the peak along the dimensions of indx_ks.
- Vk = Tinv{k}\Wcell{k}; %V_k on p.71 of Forecast (II).
- gbeta = Vk\bk; % inv(V_k)*b_k on p.71 of Forecast (II) where alpha_k = b_k in our notation.
- [Vtq,Vtr]=qr(Vk',0); %To get inv(V_k)'*inv(V_k) in (*) on p.71 of Forecast (II).
- %
- vloglast = 0.5*(fss+nk)*log(fss)-log(abs(det(Vk)))-0.5*(nk-1)*log(2*pi)-...
- 0.5*(fss+1)*log(2)-gammaln(0.5*(fss+1))+fss*log(abs(gbeta(1)))-...
- 0.5*fss*bk'*(Vtr\(Vtr'\bk));
- vlog_a0_Yao(k) = vloglast;
- end
-end
-timimutes=toc/60
-ndraws2
-
-disp('Prior pdf -- log(p(a0hat, a+hat)):');
-vlog_a0p
-disp('LH pdf -- log(p(Y|a0hat, a+hat)):');
-vlog_Y_a
-disp('Posterior Kernal -- logp(ahat) + logp(Y|ahat):');
-vlog_Y_a + vlog_a0p
-disp('Posterior pdf -- log(p(a0_i_hat|a0_other_hat, Y)):');
-vlog_a0_Yao
-disp('Posterior pdf -- log(p(aphat|a0hat, Y)):');
-vlog_ap_Ya0
-
-%--------- The value of marginal density p(Y) ----------
-disp(' ');
-disp(' ');
-disp('************ Marginal Likelihood of Y or Marginal Data Density: ************');
-vlogY = vlog_a0p+vlog_Y_a-sum(vlog_a0_Yao)-vlog_ap_Ya0
diff --git a/matlab/swz/swz_sbvar.m b/matlab/swz/swz_sbvar.m
deleted file mode 100644
index bdea69b894baa2aa933589996a682b48fe3d76dd..0000000000000000000000000000000000000000
--- a/matlab/swz/swz_sbvar.m
+++ /dev/null
@@ -1,23 +0,0 @@
-function swz_sbvar(ms_flag, M, options)
-
-dynareroot = strrep(which('dynare'),'dynare.m','');
-swz_root = [dynareroot '/swz'];
-
-addpath([swz_root '/cstz']);
-addpath([swz_root '/identification']);
-addpath([swz_root '/switching_specification']);
-addpath([swz_root '/mhm_specification']);
-
-options.data = read_variables(options.datafile,options.varobs,[],options.xls_sheet,options.xls_range);
-
-options.ms.output_file_tag = M.fname;
-%options.ms.markov_file = 'specification_2v2c.dat';
-%options.ms.mhm_file = 'MHM_input.dat';
-%options.ms.restriction_fname = 'ftd_upperchol3v';
-
-
-if ms_flag == 1
- sz_prd(options)
-else
- swz_mardd(options);
-end
diff --git a/matlab/swz/sz_prd.m b/matlab/swz/sz_prd.m
deleted file mode 100644
index ce05381c9d55ce7d9a565f8eb0004b6cdeaec225..0000000000000000000000000000000000000000
--- a/matlab/swz/sz_prd.m
+++ /dev/null
@@ -1,553 +0,0 @@
-function sz_prd(options_)
-%==========================================================================
-%== Directory structure
-%==========================================================================
-
-%generation of mhm file
-generateMHM_input(options_);
-
-swz_root = strrep(which('swz_sbvar'),'/swz_sbvar.m','');
-
-% path for C executables
-%c_path='./c-executables';
-c_path = [swz_root '/bin'];
-
-% path for Markov specification
-m_spec_path=[swz_root '/switching_specification'];
-
-% path for MHM specification
-mhm_spec_path=[swz_root '/mhm_specification'];
-
-%==========================================================================
-%== Output control
-%==========================================================================
-% tag for output files %create an option
-%options_.ms.output_file_tag='test_2v';
-
-% 1 to create init_<options_.ms.output_file_tag>.dat, 0 otherwise
-%options_.ms.create_initialization_file = 1; %0 originally
-
-% 1 to perform estimation, 0 otherwise
-%options_.ms.estimate_msmodel = 1;
-
-% 1 to perform estimation, 0 otherwise
-%options_.ms.compute_mdd = 1;
-
-% 1 to compute probabilites, 0 otherwise
-%options_.ms.compute_probabilities = 1;%1 in the original
-
-% 1 to Prints draws of the posterior
-%options_.ms.print_draws = 1;
-%options_.ms.n_draws=1000;
-%options_.ms.thinning_factor=1;
-
-%==========================================================================
-%== Markov Process Specification File
-%==========================================================================
-%options_.ms.markov_file = 'specification_2v2c.dat'; %create an option
-markov_file = [options_.ms.markov_file '.dat'];
-
-%==========================================================================
-%== Markov Process Specification File
-%==========================================================================
-%options_.ms.mhm_file = 'MHM_input.dat';
-
-
-mhm_file = [mhm_spec_path '/MHM_input.dat'];
-%options_.ms.proposal_draws = 100000;
-
-%==========================================================================
-%== Var Specification
-%==========================================================================
-% Number of options_.ms.nlags
-%options_.ms.nlags = 4;
-
-% Var restriction function
-%options_.ms.restriction_fname = 'ftd_upperchol3v'; %create an option
-
-
-%==========================================================================
-%== BVAR prior
-%==========================================================================
-
-%=== The following mu is effective only if indxPrior==1.
-mu = zeros(6,1); % hyperparameters
-
-% mu(1): overall tightness for A0 and Aplus
-mu(1) = 1.0;
-
-% mu(2): relative tightness for Aplus
-mu(2) = 1.0;
-
-% mu(3): relative tightness for the constant term
-mu(3) = 0.1;
-
-% mu(4): tightness on lag decay. (1.2 - 1.5 faster decay produces better
-% inflation forecasts
-mu(4) = 1.2;
-
-% mu(5): weight on nvar sums of coeffs dummy observations (unit roots).
-mu(5) = 1;
-
-% mu(6): weight on single dummy initial observation including constant
-% (cointegration, unit roots, and stationarity).
-mu(6) = 1;
-
-% Alpha on p. 66 for squared time-varying structural shock lambda.
-galp = 1.0;
-
-% Beta on p. 66 for squared time-varying structural shock lambda.
-gbeta = 1.0;
-
-% Case 3 (no state change across options_.ms.nlags (l) but allows all variables for a
-% given lag to switch states). Normal prior variance for glamda
-% (nvar-by-nvar for each state) for different variables in lagged D+. See
-% p.71v.
-gsig2_lmdm = 50^2;
-
-
-%==========================================================================
-%== Data
-%==========================================================================
-% Read in data to produce rectangular array named xdd. Each column is one
-% data series.
-%load ./data/artificial_data
-xdd=options_.data;
-
-% Information about timing of the data for consistancy checks
-% quarters (4) or months (12)
-%q_m = 4;
-%options_.ms.freq = 4;
-q_m = options_.ms.freq;
-% beginning year in data set
-%yrBin=1978;
-%options_.ms.initial_year = 1959;
-yrBin=options_.ms.initial_year;
-% beginning quarter or month in data set
-%qmBin=1;
-%options_.ms.initial_subperiod = 1;
-qmBin=options_.ms.initial_subperiod;
-% final year in data set
-%yrFin=2007;
-%options_.ms.final_year = 2005;
-yrFin=options_.ms.final_year;
-% final month or quarter in data set
-%qmFin=4;
-%options_.ms.final_subperiod = 4;
-qmFin=options_.ms.final_subperiod;
-% first year to use in estimation
-%yrStart=yrBin;
-yrStart=options_.ms.initial_year;
-% first quarter or month to use in estimation
-%qmStart=qmBin;
-qmStart=options_.ms.initial_subperiod;
-% last year to use in estimation
-%yrEnd=yrFin;
-yrEnd=options_.ms.final_year;
-% last quater or month to use in estimation
-%qmEnd=qmFin;
-qmEnd=options_.ms.final_subperiod;
-% Log variables in xdd
-logindx = [];
-
-% Convert percent to decimal in xdd
-pctindx = [];
-
-% Select the variable to use and rearrange columns if desired
-%vlist = [3 1 2];
-%options_.ms.vlist = [1 2 3];
-options_.ms.vlist = [1:size(options_.varobs,1)];
-vlist1=options_.ms.vlist;
-
-%==========================================================================
-%== Linux or Windows system - differences in some naming conventions
-%==========================================================================
-use_linux = 1;
-
-
-%==========================================================================
-%== Random number seed for selecting starting point in constant parameter
-%== optimization.
-%==========================================================================
-% Set to zero to set from clock
-seednumber = 7910;
-if seednumber
- randn('state',seednumber);
- rand('state',seednumber);
-else
- rand('state',fix(100*sum(clock)));
- randn('state',1000000000*rand);
- rand('state',1000000000*rand);
-end
-
-%==========================================================================
-%==========================================================================
-%==========================================================================
-%== Beginning of code. Modify below at own risk.
-%==========================================================================
-
-% options that may at some point become user specified
-%indxC0Pres = 0; % 1: cross-A0-and-A+ restrictions; 0: idfile_const is all we have
-indxC0Pres =options_.ms.cross_restrictions;
- % Example for indxOres==1: restrictions of the form P(t) = P(t-1).
-%Rform = 0; % 1: contemporaneous recursive reduced form; 0: restricted (non-recursive) form
-Rform =options_.ms.contemp_reduced_form;
-% % % Pseudo = 0; % 1: Pseudo forecasts; 0: real time forecasts
-%indxPrior = 1; % 1: Bayesian prior; 0: no prior
-indxPrior =options_.ms.bayesian_prior;
-%indxDummy = indxPrior; % 1: add dummy observations to the data; 0: no dummy added.
-indxDummy = options_.ms.bayesian_prior;
-%ndobs = 0; % No dummy observations for xtx, phi, fss, xdatae, etc. Dummy observations are used as an explicit prior in fn_rnrprior_covres_dobs.m.
-ndobs =options_.ms.dummy_obs;
-%if indxDummy
-% ndobs=nvar+1; % number of dummy observations
-%else
-% ndobs=0; % no dummy observations
-%end
-
-%
-hpmsmd = [0.0; 0.0];
-indxmsmdeqn = [0; 0; 0; 0]; %This option disenable using this in fn_rnrprior_covres_dobs.m
-
-nStates = -1;
-
-
-%==========================================================================
-%== Create initialization file
-%==========================================================================
-if options_.ms.create_initialization_file == 1
- %======================================================================
- %== Check and setup data
- %======================================================================
- % log data
- xdd(:,logindx) = log(xdd(:,logindx));
-
- % convert percentage to decimal
- xdd(:,pctindx)=.01*xdd(:,pctindx);
-
- if (q_m ~= 12) && (q_m ~= 4)
- disp('Warning: data must be monthly or quarterly!')
- return
- end
-
- % number of data points
- nData=(yrFin-yrBin)*q_m + (qmFin-qmBin+1);
- % number of data points in estimation sample
- nSample=(yrEnd-yrStart)*q_m + (qmEnd-qmEnd+1);
- % number of periods not used at beginning of data (non-negative number)
- nStart=(yrStart-yrBin)*q_m + (qmStart-qmBin);
- % number of periods not used at end of data (non-positive number)
- nEnd=(yrEnd-yrFin)*q_m + (qmEnd-qmFin);
-
- if (nEnd > 0) || (nStart < 0)
- disp('Warning: desired estimation period not in data set!')
- return
- end
- if (nSample <= 0)
- disp('Warning: no data points in estimation period!')
- return
- end
-
- % reorder variables and create estimation data set
- xdgel=xdd(nStart+1:nData+nEnd,vlist1);
-
- % bad data points
- baddata = find(isnan(xdgel));
- if ~isempty(baddata)
- disp('Warning: some data for estimation period are unavailable.')
- return
- end
-
- % set nvar and nexo
- nvar=size(xdgel,2);
- nexo=1;
-
- % Arranged data information, WITHOUT dummy obs when 0 after mu is used.
- % See fn_rnrprior_covres_dobs.m for using the dummy observations as part of
- % an explicit prior.
- [xtx,xty,yty,fss,phi,y,ncoef,xr,Bh] = fn_dataxy(nvar,options_.ms.nlags,xdgel,mu,0,nexo);
-
-
- %======================================================================
- %== Linear Restrictions
- %======================================================================
- if Rform
- Ui=cell(nvar,1); Vi=cell(ncoef,1);
- for kj=1:nvar
- Ui{kj} = eye(nvar); Vi{kj} = eye(ncoef);
- end
- else
- eval(['[Ui,Vi,n0,np,ixmC0Pres] = ' options_.ms.restriction_fname '(options_.ms.nlags,nvar,nexo,indxC0Pres);'])
- if min(n0)==0
- disp('A0: restrictions give no free parameters in one of equations')
- return
- elseif min(np)==0
- disp('Aplus: Restrictions in give no free parameters in one of equations')
- return
- end
- end
-
-
- %======================================================================
- %== Estimation
- %======================================================================
- if indxPrior
- %*** Obtains asymmetric prior (with no linear restrictions) with dummy observations as part of an explicit prior (i.e,
- % reflected in Hpmulti and Hpinvmulti). See Forecast II, pp.69a-69b for details.
- if 1 % Liquidity effect prior on both MS and MD equations.
- [Pi,H0multi,Hpmulti,H0invmulti,Hpinvmulti] = fn_rnrprior_covres_dobs(nvar,q_m,options_.ms.nlags,xdgel,mu,indxDummy,hpmsmd,indxmsmdeqn);
- else
- [Pi,H0multi,Hpmulti,H0invmulti,Hpinvmulti] = fn_rnrprior(nvar,q_m,options_.ms.nlags,xdgel,mu);
- end
-
- %*** Combines asymmetric prior with linear restrictions
- [Ptld,H0invtld,Hpinvtld] = fn_rlrprior(Ui,Vi,Pi,H0multi,Hpmulti,nvar);
-
- %*** Obtains the posterior matrices for estimation and inference
- [Pmat,H0inv,Hpinv] = fn_rlrpostr(xtx,xty,yty,Ptld,H0invtld,Hpinvtld,Ui,Vi);
- else
- %*** Obtain the posterior matrices for estimation and inference
- [Pmat,H0inv,Hpinv] = fn_dlrpostr(xtx,xty,yty,Ui,Vi);
- end
-
- if Rform
- %*** Obtain the ML estimate
- A0hatinv = chol(H0inv{1}/fss); % upper triangular but lower triangular choleski
- A0hat=inv(A0hatinv);
-
- Aphat = Pmat{1}*A0hat;
- else
- %*** Obtain the ML estimate
- % load idenml
- x = 10*rand(sum(n0),1);
- H0 = eye(sum(n0));
- crit = 1.0e-9;
- nit = 10000;
- %
- tic
- [fhat,xhat,grad,Hhat,itct,fcount,retcodehat] = csminwel('fn_a0freefun',x,H0,'fn_a0freegrad',crit,nit,Ui,nvar,n0,fss,H0inv);
- endtime = toc
-
- A0hat = fn_tran_b2a(xhat,Ui,nvar,n0);
-
- xhat = fn_tran_a2b(A0hat,Ui,nvar,n0);
- [Aphat,ghat] = fn_gfmean(xhat,Pmat,Vi,nvar,ncoef,n0,np);
- if indxC0Pres
- Fhatur0P = Fhat; % ur: unrestriced across A0 and A+
- for ki = 1:size(ixmC0Pres,1) % loop through the number of equations in which
- % cross-A0-A+ restrictions occur. See St. Louis Note p.5.
- ixeq = ixmC0Pres{ki}(1,1); % index for the jth equation in consideration.
- Lit = Vi{ixeq}(ixmC0Pres{ki}(:,2),:); % transposed restriction matrix Li
- % V_j(i,:) in f_j(i) = V_j(i,:)*g_j
- ci = ixmC0Pres{ki}(:,4) .* A0hat(ixmC0Pres{ki}(:,3),ixeq);
- % s * a_j(h) in the restriction f_j(i) = s * a_j(h).
- LtH = Lit/Hpinv{ixeq};
- HLV = LtH'/(LtH*Lit');
- gihat = Vi{ixeq}'*Fhatur0P(:,ixeq);
- Aphat(:,ixeq) = Vi{ixeq}*(gihat + HLV*(ci-Lit*gihat));
- end
- end
- end
-
-
- %======================================================================
- %== Create matlab initialization file
- %======================================================================
- matlab_filename = ['matlab_',options_.ms.output_file_tag,'.prn'];
- fidForC = fopen(matlab_filename,'w');
-
- fprintf(fidForC,'\n%s\n','//== gxia: alpha parameter for gamma prior of xi ==//');
- fprintf(fidForC,' %20.15f ', galp);
- fprintf(fidForC, '\n\n');
-
- fprintf(fidForC,'\n%s\n','//== gxib: beta parameter for gamma prior of xi ==//');
- fprintf(fidForC,' %20.15f ', gbeta);
- fprintf(fidForC, '\n\n');
-
- fprintf(fidForC,'\n%s\n','//== glamdasig: sigma parameter for normal prior of lamda ==//');
- fprintf(fidForC,' %20.15f ', sqrt(gsig2_lmdm));
- fprintf(fidForC, '\n\n');
-
- %=== lags, nvar, nStates, sample size (excluding options_.ms.nlags where, with dummyies, fss=nSample-options_.ms.nlags+ndobs).
- fprintf(fidForC,'\n%s\n','//== lags, nvar, nStates, T ==//');
- fprintf(fidForC,' %d %d %d %d\n\n\n',options_.ms.nlags, nvar, nStates, fss);
-
- %=== A0hat nvar-by-nvar from the constant VAR.
- fprintf(fidForC,'\n%s\n','//== A0hat: nvar-by-nvar ==//');
- indxFloat = 1;
- xM = A0hat;
- nrows = nvar;
- ncols = nvar;
- fn_fprintmatrix(fidForC, xM, nrows, ncols, indxFloat)
-
- %=== Aphat ncoef-by-nvar from the constant VAR.
- %=== Each column of Aphat is in the order of [nvar variables for 1st lag, ..., nvar variables for last lag, constant term].
- fprintf(fidForC,'\n%s\n','//== Aphat: ncoef(lags*nvar+1)-by-nvar ==//');
- indxFloat = 1;
- xM = Aphat;
- nrows = ncoef;
- ncols = nvar;
- fn_fprintmatrix(fidForC, xM, nrows, ncols, indxFloat)
-
- %=== n0const: nvar-by-1, whose ith element represents the number of free A0 parameters in ith equation for the case of constant parameters.
- fprintf(fidForC,'\n%s\n','//== n0const: nvar-by-1 ==//');
- indxFloat = 0;
- xM = n0;
- nrows = 1;
- ncols = nvar;
- fn_fprintmatrix(fidForC, xM', nrows, ncols, indxFloat)
-
- %=== npconst: nvar-by-1, whose ith element represents the number of free A+ parameters in ith equation for the case of constant parameters.
- fprintf(fidForC,'\n%s\n','//== npconst: nvar-by-1 ==//');
- indxFloat = 0;
- xM = np;
- nrows = 1;
- ncols = nvar;
- fn_fprintmatrix(fidForC, xM', nrows, ncols, indxFloat)
-
- %=== Uiconst: nvar-by-1 cell. In each cell, nvar-by-qi orthonormal basis for the null of the ith
- % equation contemporaneous restriction matrix where qi is the number of free parameters.
- % With this transformation, we have ai = Ui*bi or Ui'*ai = bi where ai is a vector
- % of total original parameters and bi is a vector of free parameters. When no
- % restrictions are imposed, we have Ui = I. There must be at least one free
- % parameter left for the ith equation.
- fprintf(fidForC,'\n%s\n','//== Uiconst: cell(nvar,1) and nvar-by-n0const(i) for the ith cell (equation) ==//');
- for i_=1:nvar
- fn_fprintmatrix(fidForC, Ui{i_}, nvar, n0(i_), 1);
- end
-
- %=== Viconst: nvar-by-1 cell. In each cell, k-by-ri orthonormal basis for the null of the ith
- % equation lagged restriction matrix where k is a total of exogenous variables and
- % ri is the number of free parameters. With this transformation, we have fi = Vi*gi
- % or Vi'*fi = gi where fi is a vector of total original parameters and gi is a
- % vector of free parameters. There must be at least one free parameter left for
- % the ith equation.
- fprintf(fidForC,'\n%s\n','//== Viconst: cell(nvar,1) and ncoef-by-n0const(i) for the ith cell (equation) ==//');
- for i_=1:nvar
- fn_fprintmatrix(fidForC, Vi{i_}, ncoef, np(i_), 1);
- end
-
- %=== H0barconstcell: cell(nvar,1) (equations) and n-by-n for each cell (equaiton).
- %=== H0barconst: prior covariance matrix for each column of A0 under asymmetric prior (including SZ dummy obs.) with NO linear restrictions imposed yet.
- fprintf(fidForC,'\n%s\n','//== H0barconstcell: cell(nvar,1) and n-by-n for the ith cell (equation) ==//');
- for i_=1:nvar
- fn_fprintmatrix(fidForC, H0multi(:,:,i_), nvar, nvar, 1);
- end
-
- %=== Hpbarconstcell: cell(nvar,1) (equations) and ncoef-by-ncoef for each cell (equaiton).
- %=== Hpbarconst: prior covariance matrix for each column of A+ under asymmetric prior (including SZ dummy obs.) with NO linear restrictions imposed yet.
- fprintf(fidForC,'\n%s\n','//== Hpbarconstcell: cell(nvar,1) and ncoef-by-ncoef for the ith cell (equation) ==//');
- for i_=1:nvar
- fn_fprintmatrix(fidForC, Hpmulti(:,:,i_), ncoef, ncoef, 1);
- end
-
- %=== phi: X; T-by-k; column: [nvar for 1st lag, ..., nvar for last lag, other exogenous terms, const term]
- fprintf(fidForC,'\n%s\n','//== Xright -- X: T-by-ncoef ==//');
- xM = phi;
- nrows = fss;
- ncols = ncoef;
- for ki=1:nrows
- for kj=1:ncols
- fprintf(fidForC,' %20.15f ',xM((kj-1)*nrows+ki));
- if (kj==ncols)
- fprintf(fidForC,'\n');
- end
- end
- if (ki==nrows)
- fprintf(fidForC,'\n\n');
- end
- end
-
- %=== y: Y: T-by-nvar where T=fss
- fprintf(fidForC,'\n%s\n','//== Yleft -- Y: T-by-nvar ==//');
- xM = y;
- nrows = fss;
- ncols = nvar;
- for ki=1:nrows
- for kj=1:ncols
- fprintf(fidForC,' %20.15f ',xM((kj-1)*nrows+ki));
- if (kj==ncols)
- fprintf(fidForC,'\n');
- end
- end
- if (ki==nrows)
- fprintf(fidForC,'\n\n');
- end
- end
-
- fclose(fidForC);
-
- %======================================================================
- %== Create C initialization filename
- %======================================================================
- if use_linux == 1
- create_init_file=[c_path,'/sbvar_init_file ',matlab_filename,' ',m_spec_path,'/',markov_file,' ',options_.ms.output_file_tag];
- system(create_init_file) %Run operating system command and return result
- else
- create_init_file=[c_path,'\sbvar_init.exe ',matlab_filename,' ',m_spec_path,'\',markov_file,' ',options_.ms.output_file_tag];
- dos(create_init_file)
- end
-
-end
-
-%==========================================================================
-%== Perform estimation
-%==========================================================================
-if options_.ms.estimate_msmodel == 1
- if use_linux == 1
- perform_estimation=[c_path,'/sbvar_estimate -ft ',options_.ms.output_file_tag];
- system(perform_estimation)
- else
- perform_estimation=[c_path,'\sbvar_estimate.exe -ft ',options_.ms.output_file_tag];
- dos(perform_estimation)
- end
-end
-
-
-%==========================================================================
-%== Compute marginal data density
-%==========================================================================
-if options_.ms.compute_mdd == 1
- if use_linux == 1
- compute_mdd1=[c_path,'/sbvar_mhm_1 -ft ',options_.ms.output_file_tag,' -fi ',mhm_spec_path,'/',mhm_file];
- system(compute_mdd1);
- compute_mdd2=[c_path,'/sbvar_mhm_2 -ft ',options_.ms.output_file_tag,' -d ',int2str(options_.ms.proposal_draws),' -t 3'];
- system(compute_mdd2);
- else
- compute_mdd1=[c_path,'\sbvar_mhm_1.exe -ft ',options_.ms.output_file_tag,' -fi ',mhm_spec_path,'/',mhm_file];
- system(compute_mdd1);
- compute_mdd2=[c_path,'\sbvar_mhm_2.exe -ft ',options_.ms.output_file_tag,' -d ',int2str(options_.ms.proposal_draws),' -t 3'];
- system(compute_mdd2);
- end
-end
-
-
-%==========================================================================
-%== Compute posterior mode regime probabilities
-%==========================================================================
-if options_.ms.compute_probabilities == 1 %error registers here
- if use_linux == 1
- compute_prob=[c_path,'/sbvar_probabilities -ft ',options_.ms.output_file_tag];
- system(compute_prob);
- else
- compute_prob=[c_path,'\sbvar_probabilities -ft ',options_.ms.output_file_tag];
- system(compute_prob);
- end
-end
-
-%==========================================================================
-%== Print Draws
-%==========================================================================
-if options_.ms.print_draws == 1 %error here as well
- if use_linux == 1
- print_draws=[c_path,'/sbvar_draws -ft ',options_.ms.output_file_tag,' -i ',int2str(options_.ms.n_draws),' -t ',int2str(options_.ms.thinning_factor)];
- system(print_draws);
- else
- print_draws=[c_path,'\sbvar_draws -ft ',options_.ms.output_file_tag,' -i ',int2str(options_.ms.n_draws),' -t ',int2str(options_.ms.thinning_factor)];
- system(print_draws);
- end
-end
-
-
-
-
diff --git a/mex/sources/estimation/DsgeLikelihood.cpp b/mex/sources/estimation/DsgeLikelihood.cpp
deleted file mode 100644
index ed0625d04c7a53b59f74a3e8965394b1afe462e2..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/DsgeLikelihood.cpp
+++ /dev/null
@@ -1,797 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-
-#include "mexutils.h"
-#include "DsgeLikelihood.h"
-#include "utils.h"
-#include "disclyap_fast.h"
-#include "ts_exception.h"
-#include "dynamic_dll.h"
-
-DsgeLikelihood::DsgeLikelihood( Vector& inA_init, GeneralMatrix& inQ, GeneralMatrix& inR,
- GeneralMatrix& inT, GeneralMatrix& inZ, GeneralMatrix& inPstar, GeneralMatrix& inPinf,
- GeneralMatrix& inH, const GeneralMatrix&inData, GeneralMatrix&inY,
- const int INnumPeriods, // const int INnumVarobs, // const int INnumTimeObs,
- const int INorder, const int INendo_nbr, const int INexo_nbr, const int INnstatic,
- const int INnpred, const int INnfwrd, const int INnum_of_observations, const bool INno_more_missing_observations,
- const vector<int>& INorder_var, const vector<int>& INmfys, const vector<int>& INmf1,
- Vector& INxparam1, const int INnum_dp, Vector& INdeepParams,
- const Vector& INub, const Vector& INlb, const vector<int>&INpshape,
- const Vector&INp6, const Vector&INp7, const Vector&INp3, const Vector&INp4,
- Vector& INSteadyState, Vector& INconstant, GeneralParams& INdynareParams, //GeneralParams& parameterDescription,
- GeneralParams& INdr, GeneralMatrix& INkstate, GeneralMatrix& INghx, GeneralMatrix& INghu,
- GeneralMatrix& INaux, vector<int>&INiv, vector<int>&INic
- ,const int jcols, const char *dfExt)//, KordpDynare& kOrdModel, Approximation& INapprox )
- :a_init(inA_init), Q(inQ), R(inR), T(inT), Z(inZ), Pstar(inPstar), Pinf(inPinf), H(inH), data(inData), Y(inY),
- numPeriods(INnumPeriods), numVarobs(inData.numRows()), numTimeObs(inData.numCols()),
- order(INorder), endo_nbr(INendo_nbr ), exo_nbr(INexo_nbr), nstatic(INnstatic), npred(INnpred),
- nfwrd(INnfwrd), number_of_observations(INnum_of_observations), no_more_missing_observations(INno_more_missing_observations),
- order_var(INorder_var), mfys(INmfys), mf(INmf1), xparam1(INxparam1),
- num_dp(INnum_dp), deepParams(INdeepParams), //num_dp((int)dynareParams.getDoubleField(string("np),// no of deep params
- param_ub(INub), param_lb(INlb),pshape(INpshape), //pshape(dynareParams.getIntVectorField(string("pshape),
- p6(INp6), p7(INp7), p3(INp3), p4(INp4), SteadyState(INSteadyState),
- constant(INconstant), dynareParams(INdynareParams),
- dr(INdr), kstate(INkstate), ghx(INghx),ghu(INghu),
- aux(INaux), iv(INiv), ic(INic)
- //, model(kOrdModel), approx(INapprox )
- {
-
- /*****
- bayestOptions_("caller","bayestopt_");
- options_("caller","options_");
- M_Options_("caller","M_");
- dr_("caller","dr");
- oo_("caller","oo_");
- *********/
- // setting some frequently used common variables that do not need updating
- //std::vector<double>* vll=new std::vector<double> (nper);
-// vll=new std::vector<double> (numTimeObs);// vector of likelihoods
- vll=new vector<double>(numTimeObs);// vector of likelihoods
- kalman_algo=(int)dynareParams.getDoubleField(string("kalman_algo"));
- presampleStart=1+(int)dynareParams.getDoubleField(string("presample"));
- mode_compute=(int)dynareParams.getDoubleField(string("mode_compute"));
-#ifdef DEBUG
- mexPrintf("mode_compute=%d presampleStart=%d \n", mode_compute,presampleStart);
-#endif
-
- // Pepare data for Constructing k-order-perturbation classes
- //const char *
- string& fname=dynareParams.getStringField(string("fname"));
- fName = (char *)fname.c_str();
- double qz_criterium = dynareParams.getDoubleField(string("qz_criterium"));//qz_criterium = 1+1e-6;
- int nMax_lag =(int)dynareParams.getDoubleField(string("maximum_lag"));
- const int nBoth=(int)dr.getDoubleField(string("nboth"));
- const int nPred = npred-nBoth; // correct nPred for nBoth.
- //vector<int> *var_order_vp = &order_var;
-#ifdef DEBUG
- mexPrintf("fName %s qz_criterium=%f nMax_lag=%d nPred=%d :Construction of vCov\n", fName,qz_criterium,nMax_lag,nPred);
-#endif
- vCov = new TwoDMatrix(Q);
- // the lag, current and lead blocks of the jacobian respectively
- llincidence = new TwoDMatrix (dynareParams.getMatrixField(string("lead_lag_incidence")));
-#ifdef DEBUG
- mexPrintf("Construction of casOrdEndoNames\n");
-#endif
- charArraySt * casOrdEndoNames=dynareParams.getCharArrayField(string("var_order_endo_names"));
-#ifdef DEBUG
- mexPrintf("Construction of endoNamesMX\n");
-#endif
- const char **endoNamesMX=(const char ** )casOrdEndoNames->charArrayPtr;
-
-#ifdef DEBUG
- for (int i = 0; i < endo_nbr; i++)
- {
- mexPrintf("k_ord_perturbation: EndoNameList[%d][0]= %s.\n", i, endoNamesMX[i]);
- }
-#endif
-
- charArraySt * casExoNames=dynareParams.getCharArrayField(string("exo_names"));
- const char **exoNamesMX=(const char ** )casExoNames->charArrayPtr;
-
- Vector &NNZD =dynareParams.getDoubleVectorField(string("NNZDerivatives"));
-
- const int nSteps = 0; // Dynare++ solving steps, for time being default to 0 = deterministic steady state
- const double sstol = 1.e-13; //NL solver tolerance from
-
-
- // Construct k-order-perturbation classes
-
- THREAD_GROUP::max_parallel_threads = 2; //params.num_threads;
-
- try
- {
- // make journal name and journal
- std::string jName(fName); //params.basename);
- jName += ".jnl";
- journal= new Journal(jName.c_str());
-#ifdef DEBUG
- mexPrintf("k_order_perturbation: Calling dynamicDLL constructor.\n");
-#endif
- dynamicDLLp=new DynamicModelDLL (fName, endo_nbr, jcols, nMax_lag, exo_nbr, dfExt);
-
- // intiate tensor library
-#ifdef DEBUG
- mexPrintf("k_order_perturbation: Call tls init order:%d, size: %d\n", order, nstatic+2*nPred+3*nBoth+2*nfwrd+exo_nbr);
-#endif
- tls.init(order, nstatic+2*nPred+3*nBoth+2*nfwrd+exo_nbr);
-
-#ifdef DEBUG
- mexPrintf("estimation: Calling dynare model constructor .\n");
-#endif
- // make KordpDynare object
- model=new KordpDynare (endoNamesMX, endo_nbr, exoNamesMX, exo_nbr, num_dp,//nPar, // paramNames,
- &SteadyState, vCov, &deepParams /*modParams*/, nstatic, nPred, nfwrd, nBoth,
- jcols, &NNZD, nSteps, order, *journal, *dynamicDLLp,
- sstol, &order_var /*var_order_vp*/, llincidence, qz_criterium);
-
- // construct main K-order approximation class
-#ifdef DEBUG
- mexPrintf("estimation: Call Approximation constructor with qz_criterium=%f \n", qz_criterium);
-#endif
- approx= new Approximation(*model, *journal, nSteps, false, qz_criterium);
- // run stochastic steady
-#ifdef DEBUG
- mexPrintf("estimation:k_order_perturbation and Approximation created.\n");
-#endif
- }
- catch (const KordException &e)
- {
- printf("Caugth Kord exception: ");
- e.print();
- mexPrintf("Caugth Kord exception: %s", e.get_message());
- std::string errfile(fName); //(params.basename);
- errfile += "_error.log";
- FILE *errfd = NULL;
- if (NULL == (errfd = fopen(errfile.c_str(), "wb")))
- {
- fprintf(stderr, "Couldn't open %s for writing.\n", errfile.c_str());
- return; // e.code();
- }
- fprintf(errfd, "Caugth Kord exception: %s", e.get_message());
- fclose(errfd);
- return; // e.code();
- }
- catch (const TLException &e)
- {
- printf("Caugth TL exception: ");
- e.print();
- return; // 255;
- }
- catch (SylvException &e)
- {
- printf("Caught Sylv exception: ");
- e.printMessage();
- return; // 255;
- }
- catch (const DynareException &e)
- {
- printf("Caught KordpDynare exception: %s\n", e.message());
- mexPrintf("Caugth Dynare exception: %s", e.message());
- std::string errfile(fName); //(params.basename);
- errfile += "_error.log";
- FILE *errfd = NULL;
- if (NULL == (errfd = fopen(errfile.c_str(), "wb")))
- {
- fprintf(stderr, "Couldn't open %s for writing.\n", errfile.c_str());
- return; // e.code();
- }
- fprintf(errfd, "Caugth KordDynare exception: %s", e.message());
- fclose(errfd);
- return; // 255;
- }
- catch (const ogu::Exception &e)
- {
- printf("Caught ogu::Exception: ");
- e.print();
- mexPrintf("Caugth general exception: %s", e.message());
- std::string errfile(fName); //(params.basename);
- errfile += "_error.log";
- FILE *errfd = NULL;
- if (NULL == (errfd = fopen(errfile.c_str(), "wb")))
- {
- fprintf(stderr, "Couldn't open %s for writing.\n", errfile.c_str());
- return; // e.code();
- }
- e.print(errfd);
- fclose(errfd);
- return; // 255;
- } //catch
- };
-
-
-DsgeLikelihood::~DsgeLikelihood()
- {
-
-// delete llincidence;
-// delete vCov;
- delete approx;
- delete model;
- delete dynamicDLLp;
- delete journal;
- delete vll;
- delete &H;
- delete &Q;
- delete &kstate;
- delete &pshape;
- delete &ghx;
- delete &ghu;
- delete &dynareParams;
- delete &dr;
- delete &aux;
- delete &iv;
- delete ⁣
-/******** deleting Vectors Crashes !************
- delete &SteadyState;
- delete ¶m_ub;
- delete ¶m_lb;
- delete &p6;
- delete &p7;
- delete &p3;
- delete &p4;
- delete &xparam1;
- delete &deepParams;
-**********/
- }
-
-double
-DsgeLikelihood::CalcLikelihood(Vector& xparams)
-// runs all routines needed to calculate likelihood
- {
- likelihood=0.0;
- info=0;
- xparam1=xparams;
- /*******************************
- * loop for each sub-sample period
- ********************************/
- for (int sslc=0;sslc<numPeriods;++sslc)
- {
-
- /*****************************************************************************--
- % 1. Get the structural parameters & define penalties
- ******************************************************************************-*/
- cost_flag = 1;
- int i;
- if (mode_compute != 1)
- {
- // vector<int>kk(0);
- double qdelta=0;
- for(i=0;i<xparam1.length();++i)
- {
- if(xparam1[i]<param_lb[i]) // kk.push_back[i+1];
- qdelta+=(xparam1[i]-param_lb[i])*(xparam1[i]-param_lb[i]);
- }
- if ( qdelta>0) // i.e. kk.size()>0)
- {
- // fval = bayestopt_.penalty+sum((bayestopt_.lb(k)-xparam1(k)).^2);
- likelihood = penalty+qdelta;
- cost_flag = 0;
- info = 41;
- return likelihood;
- }
- qdelta=0;
- // kk.clear();
- for(i=0;i<xparam1.length();++i)
- {
- if(xparam1[i]>param_ub[i]) // kk.push_back[i+1];
- qdelta+=(xparam1[i]-param_ub[i])*(xparam1[i]-param_ub[i]);
- }
- if ( qdelta>0) // i.e. kk.size()>0)
- {
- //fval = bayestopt_.penalty+sum((xparam1(k)-bayestopt_.ub(k)).^2);
- likelihood = penalty+qdelta;
- cost_flag = 0;
- info = 42;
- return likelihood;
- }
- } // mode compute
-#ifdef DEBUG
- mexPrintf("Calling of updataeHQparams\n");
-#endif
- if(info=updateQHparams()) // updates Q and H matrices and deep parameters
- {
-#ifdef DEBUG
- mexPrintf("Failing of updataeHQparams info =%d\n", info);
-#endif
- return likelihood;
- }
- /*****************************************************************************--
- % 2. call model setup & reduction program and pre-filter data
- // dynare_resolve(() // ... comes here doing:
- // resol:
- // check if ys is steady state and calculate one i not
- // dr
- // kalman_transition_matrix(out: A,B, in dr)
- // IN: bayestopt_.restrict_var_list, bayestopt_.restrict_columns, bayestopt_.restrict_aux, )
- ***************************************************************/
-#ifdef DEBUG
- mexPrintf(" *********** Calling dynareResolveDR *********** \n");
-#endif
- if (info = dynareResolveDR (iv,ic, aux)) //OUT: [T,R,SteadyState],
- {
-#ifdef DEBUG
- mexPrintf("Failing of dynareResolveDR info =%d\n", info);
-#endif
- return likelihood=penalty;
- }
-
- /*****************************************************************************--
- % 2.b pre-filter and detrend data
- ******************************************************************************-*/
-#ifdef DEBUG
- mexPrintf("*********** pre-filter and detrend data *********** \n");
-#endif
-
- //if options_.noconstant
- if ((int)dynareParams.getDoubleField(string("noconstant")))
- constant.zeros();
- else
- {
- //if options_.loglinear
- if ((int)dynareParams.getDoubleField(string("loglinear")))
- {
- for (i =0;i<numVarobs;++i)
- constant[i] = log(SteadyState[mfys[i]-1]);
- }
- else
- {
- for (i =0;i<numVarobs;++i)
- constant[i] = SteadyState[mfys[i]-1];
- }
- }
- Vector trend_coeff(numVarobs);
- //trend = repmat(constant,1,gend);
- GeneralMatrix constMx(constant.base(),numVarobs,1);
-#ifdef DEBUG
- mexPrintf("Calling constMx.repmat numTimeObs=%d\n",numTimeObs);
-#endif
- GeneralMatrix&trend = constMx.repmat(1,numTimeObs);
-
- //if bayestopt_.with_trend
- /************************************
- if ((int)dynareParams.getDoubleField(string("with_trend")))
- {
- trend_coeff.zeros();
- // GeneralMatrix& mt = dynareParams.getMatrixField(string("trend_coeffs"));
- // Vector vt(mt.base, MAX(mt.numCols(), mt.numRows()));
- Vector& vtc = dynareParams.getDoubleVectorField(string("trend_coeffs"));
- for (i=0;i<vtc.length();++i)
- {
- if (vtc[i]!=0.0)
- trend_coeff[i] = vtc[i];
- }
- //trend = repmat(constant,1,gend)+trend_coeff*[1:gend];
- GeneralMatrix trend_coefMx(numVarobs, numTimeObs);
- for (i=1;i<=numTimeObs;++i)
- for (int j=0;j<numVarobs;++j)
- trend_coefMx.get(j,i)=trend_coeff[j]*i;
-
- trend.add(1,trend_coefMx);
- }
- *************************************/
- presampleStart =(int) dynareParams.getDoubleField(string("presample"))+1;
- int no_missing_data_flag = (number_of_observations==numTimeObs*numVarobs);
- //Y =data-trend;
- Y=data;
-#ifdef DEBUG
- mexPrintf("Calling Y.add( trend) in GeneralMatrices\n");
-#endif
- Y.add(-1,trend);
-
- /*****************************************************************************
- % 3. Initial condition of the Kalman filter
- *******************************************************************************/
-#ifdef DEBUG
- mexPrintf("Calling InitiateKalmanMatrices\n");
-#endif
- if( InitiateKalmanMatrices())
- return likelihood=penalty;
-
- /*****************************************************************************
- // 4. Likelihood evaluation
- // choose and run KF to get likelihood fval
- *****************************************************************************/
- likelihood+=KalmanFilter(0.000001, false);// calls Kalman
- /****************************************************************************
- // Adds prior if necessary
- ****************************************************************************/
- //likelihood-= priordens(xparam1,pshape,p6,p7,p3,p4);//fval = (likelihood-lnprior);
- //options_.kalman_algo = kalman_algo;
- } // end sub-sample loop
-#ifdef DEBUG
- mexPrintf("End of CallcLlikelihood returning likelihood=%f\n", likelihood);
-#endif
- return likelihood;
- }
-
-/**************************************************
-* lower level, private Member functions definitions
-***************************************************/
-
-
-/*****************************************************************************--
-% 1. Get the structural parameters & define penalties
-******************************************************************************-*/
-int
-DsgeLikelihood::updateQHparams()// updates Q and H matrices and deep parameters
- {
- int i=0, offset=0, nv=0, k, k1, k2, info=0;
-#ifdef DEBUG
- mexPrintf("Setting of Q \n");
-#endif
- delete &Q;
- Q = dynareParams.getMatrixField(string("Sigma_e"));
-#ifdef DEBUG
- mexPrintf("Setting of H \n");
-#endif
- delete &H;
- H = dynareParams.getMatrixField(string("H"));
- nv=(int)dynareParams.getDoubleField(string("nvx"));
- if(nv)
- {
-#ifdef DEBUG
- mexPrintf("Setting of Q var_exo\n");
-#endif
-// if(&estvx) delete &estvx;
- GeneralMatrix&estvx=dynareParams.getMatrixField(string("var_exo"));
- for (i=0;i<nv;++i)
- {
- k =(int)estvx.get(i,0)-1;
- Q.get(k,k) = xparam1[i]*xparam1[i];
- }
- offset = nv;
- delete &estvx;
- }
- nv=(int)dynareParams.getDoubleField(string("nvn"));
- if(nv)
- {
-#ifdef DEBUG
- mexPrintf("Setting of H var_endo\n");
-#endif
- GeneralMatrix&estvn=dynareParams.getMatrixField(string("var_endo"));
- for (i=0;i<nv;++i)
- {
- k =(int)estvn.get(i,0)-1;
- H.get(k,k) = xparam1[i+offset]*xparam1[i+offset];
- }
- offset += nv;
- delete &estvn;
- }
- //if estim_params_.ncx
- //for i=1:estim_params_.ncx
- nv=(int)dynareParams.getDoubleField(string("ncx"));
- if(nv)
- {
-#ifdef DEBUG
- mexPrintf("Setting of Q corrx\n");
-#endif
- GeneralMatrix&corrx=dynareParams.getMatrixField(string("corrx"));
- for (i=0;i<nv;++i)
- {
- k1 =(int)corrx.get(i,0)-1;
- k2 =(int)corrx.get(i,1)-1;
- Q.get(k1,k2) = xparam1[i+offset]*sqrt(Q.get(k1,k1)*Q.get(k2,k2));
- Q.get(k2,k1) = Q.get(k1,k2);
- }
- // [CholQ,testQ] = chol(Q);
- delete &corrx;
- int testQ=0;
- try
- {
- NormCholesky chol(Q);
- }
- catch(const TSException &e)
- {
- // if (string(e.getMessage())==sting("The matrix is not positive definite in NormCholesky constructor"))
- if (0==strncmp(e.getMessage(),"The matrix is not positive definite in NormCholesky constructor",35))
- testQ=1;
- else
- {
- printf("Caugth unhandled TS exception with Q matrix: ");
- likelihood=penalty;
- TS_RAISE(e.getMessage());
- }
- }
- if (testQ)
- {
- // The variance-covariance matrix of the structural innovations is not definite positive.
- // We have to compute the eigenvalues of this matrix in order to build the penalty.
- double delta=0;
- VDVFact eigQ(Q); // get eigenvalues
- //k = find(a < 0);
- if(eigQ.hasConverged())
- {
- const Vector& evQ=eigQ.getD();
- for (i=0;i<evQ.length();++i)
- if (evQ[i]<0)
- delta-=evQ[i];
- }
-
- likelihood = penalty+delta;// +sum(-a(k));
- cost_flag = 0;
- info = 43;
- return info;
- }
- //offset = offset+estim_params_.ncx;
- offset += nv;
- }//end
-
- //if estim_params_.ncn
- //for i=1:estim_params_.ncn
- nv=(int)dynareParams.getDoubleField(string("ncn"));
- if(nv)
- {
-#ifdef DEBUG
- mexPrintf("Setting of H corrn\n");
-#endif
- GeneralMatrix&corrn=dynareParams.getMatrixField(string("corrn"));
- vector<int>&lgyidx2varobs= dynareParams.getIntVectorField(string("lgyidx2varobs"));
- for (i=0;i<nv;++i)
- {
- // k1 = options_.lgyidx2varobs(estim_params_.corrn(i,1));
- // k2 = options_.lgyidx2varobs(estim_params_.corrn(i,2));
- k1 = lgyidx2varobs[(int)corrn.get(i,0)-1];
- k2 = lgyidx2varobs[(int)corrn.get(i,1)-1];
- // H(k1,k2) = xparam1(i+offset)*sqrt(H(k1,k1)*H(k2,k2));
- // H(k2,k1) = H(k1,k2);
- H.get(k1,k2) = xparam1[i+offset]*sqrt(H.get(k1,k1)*H.get(k2,k2));
- H.get(k2,k1) = H.get(k1,k2);
- }
- delete &corrn;
-
- //[CholH,testH] = chol(H);
- int testH=0;
- try
- {
- NormCholesky chol(H);
- }
- catch(const TSException &e)
- {
- // if (string(e.getMessage)==sting("The matrix is not positive definite in NormCholesky constructor"))
- if (0==strncmp(e.getMessage(),"The matrix is not positive definite in NormCholesky constructor",35))
- testH=1;
- else
- {
- printf("Caugth unhandled TS exception with H matrix: ");
- likelihood=penalty;
- TS_RAISE((const char*)e.getMessage());
- }
- }
- if (testH)
- {
- //a = diag(eig(H));
- double delta=0;
- VDVFact eigH(H); // get eigenvalues
- //k = find(a < 0);
- if(eigH.hasConverged())
- {
- const Vector& evH=eigH.getD();
- for (i=0;i<evH.length();++i)
- if (evH[i]<0)
- delta-=evH[i];
- }
- likelihood = penalty+delta; // +sum(-a(k));
- cost_flag = 0;
- info = 44;
- return info;
- }; // end if
- //offset = offset+estim_params_.ncn;
- offset += nv;
- }
-
- //if estim_params_.np > 0 // i.e. num of deep parameters >0
- // M_.params(estim_params_.param_vals(:,1)) = xparam1(offset+1:end);
- if(num_dp > 0)
- {
-// if(xparam1.length()>=offset+num_dp)
-// memcpy(deepParams.base(), xparam1.base()+offset*sizeof(double),num_dp*sizeof(double));
- if(xparam1.length()>=offset+num_dp)
- deepParams=Vector(xparam1,offset,num_dp);
- else
- TS_RAISE("Inssuficient length of the xparam1 parameters vector");
- }
-#ifdef DEBUG
- mexPrintf("End of Setting of HQ params\n");
-#endif
-
- /**********
- M_.Sigma_e = Q;
- M_.H = H;
- ******************/
- return info;
- };
-
-/*****************************************************************************--
-% 3. Initial condition of the Kalman filter
-******************************************************************************-*/
-int
-DsgeLikelihood::InitiateKalmanMatrices()
- {
- int np = T.numRows();// size(T,1);
- double lyapunov_tol=dynareParams.getDoubleField(string("lyapunov_tol"));
-// int lik_init=(int)dynareParams.getDoubleField(string("lik_init"));
- //if options_.lik_init == 1 % Kalman filter
-// GeneralMatrix RQRt(R,Q); // R*Q
- GeneralMatrix RQ(R,Q); // R*Q
-#ifdef DEBUG
- mexPrintf("Calling RQRt.multRightTrans(R)\n");
-#endif
-// GeneralMatrix::md_length=RQRt.numRows();
- //RQRt.md_length=RQRt.numRows();
-
-// RQRt.multRightTrans(R); // R*Q*Rt
-// GeneralMatrix RQRt(np,np);
-// RQRt.zeros();
-// RQRt.multAndAdd(RQ,R, "T", 1.0);
- GeneralMatrix RQRt(RQ,R, "T");
-#ifdef DEBUG
- for (int i=0;i<RQRt.numRows();++i)
- {
- for (int j=0;j<RQRt.numCols();++j)
- mexPrintf(" %f ", RQRt.get(i,j));
- mexPrintf("\n");
- }
-#endif
- GeneralMatrix Ptmp(np,np);
- Ptmp.zeros();
- //Pstar = lyapunov_symm (T,R*Q*R',options_.qz_criterium,options_.lyapunov_complex_threshold)
-#ifdef DEBUG
- mexPrintf("Calling disclyap_fast to initialise Pstar:\n");
-#endif
-
- try
- {
- disclyap_fast(T,RQRt,Ptmp, lyapunov_tol, 0); // 1 to check chol
- Pstar=Ptmp;
-#ifdef DEBUG
- Pstar.print();
- mexPrintf("Initialise Pinf\n");
-#endif
- //Pinf=[]
- Pinf.zeros();
- }
- catch(const TSException &e)
- {
- if (0==strncmp(e.getMessage(),"The matrix is not positive definite in NormCholesky constructor",35))
- {
- printf(e.getMessage());
-#ifdef MATLAB
- mexPrintf(e.getMessage());
-#endif
- likelihood=penalty;
- return 1;
- }
- else
- {
- printf("Caugth unhandled TS exception with H matrix: ");
-#ifdef MATLAB
- mexPrintf("Caugth unhandled TS exception with H matrix: ");
-#endif
- likelihood=penalty;
- TS_RAISE((const char*)e.getMessage());
- }
- }
-
- //a=zeros(size(T,1),1);
- a_init.zeros();
-
- //if (lik_init == 2)// Old Diffuse Kalman filter
- // Pstar = options_.Harvey_scale_factor*eye(np);
- //Pinf = [];
- //else if (lik_init == 3) // Diffuse Kalman filter
- // else ...
-
- return 0;
- }
-
-
- /*****************************************************************************
- // 4. Likelihood evaluation
- // choose and run KF to get likelihood fval
-*****************************************************************************/
-double
-DsgeLikelihood::KalmanFilter(double riccatiTol=0.000001,bool uni = false)
- {
- bool diffuse=false;
- double loglik;
-
- try
- {
- // make input matrices
- int start = presampleStart;
- int nper=Y.numCols();
-#ifdef DEBUG
- mexPrintf("kalman_filter: periods=%d start=%d, a.length=%d, uni=%d diffuse=%d\n", nper, start,a_init.length(), uni, diffuse);
- Pstar.print(); Z.print(); H.print(); T.print(); R.print(); Q.print(); Y.print();
-#endif
-
- // make storage for output
- int per;
- int d;
- // create state init
- StateInit* init = NULL;
-
- if (diffuse||uni)
- {
- if (diffuse)
- {
- init = new StateInit(Pstar, Pinf, a_init);
- }
- else
- {
- init = new StateInit(Pstar, a_init);
- }
- // fork, create objects and do filtering
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- if (uni)
- {
- KalmanUniTask kut(kt);
- loglik = kut.filter(per, d, (start-1), vll);
- per = per / Y.numRows();
- d = d / Y.numRows();
- }
- else
- {
-#ifdef KF_TIMING_LOOP
- mexPrintf("kalman_filter: starting 1000 loops\n");
- for (int tt=0;tt<1000;++tt)
- {
-#endif
- loglik = kt.filter(per, d, (start-1), vll);
-#ifdef KF_TIMING_LOOP
- }
- mexPrintf("kalman_filter: finished 1000 loops\n");
-#endif
- }
- }
- else // basic Kalman
- {
- init = new StateInit(Pstar, a_init);
- BasicKalmanTask bkt(Y, Z, H, T, R, Q, *init, riccatiTol);
-#ifdef KF_TIMING_LOOP
- mexPrintf("kalman_filter: starting 1000 loops\n");
- for (int tt=0;tt<1000;++tt)
- {
-#endif
- loglik = bkt.filter( per, d, (start-1), vll);
-#ifdef DEBUG
- mexPrintf("Basickalman_filter: loglik=%f \n", loglik);
-#endif
-#ifdef KF_TIMING_LOOP
- }
- mexPrintf("Basickalman_filter: finished 1000 loops\n");
-#endif
-
- }
- // destroy init
- delete init;
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
- return loglik;
- }
-
diff --git a/mex/sources/estimation/DsgeLikelihood.h b/mex/sources/estimation/DsgeLikelihood.h
deleted file mode 100644
index 277f5cc830d7b6e3416444f8aa20f3e0e070da0b..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/DsgeLikelihood.h
+++ /dev/null
@@ -1,144 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-#include "Estimation.h"
-#include "k_ord_dynare.h"
-#include "kalman.h"
-#include "math.h"
-#include "disclyap_fast.h"
-
-#include <cstring>
-
-#include <cctype>
-
-
-class DsgeLikelihood
- {
- double likelihood; // sum of vector of KF step log likelihoods
- vector<double>* vll; // vector of KF step log likelihoods
-
- Vector& a_init;//initial value of the state, usually set to 0.
- GeneralMatrix& Q;// Kalman Matrices
- GeneralMatrix& R;
- GeneralMatrix& T;
- GeneralMatrix& Z;
- GeneralMatrix& Pstar;
- GeneralMatrix& Pinf;
- GeneralMatrix& H;
- const GeneralMatrix& data;
- GeneralMatrix& Y;
- //GeneralMatrix& currentDataSubSample;
- //int periodStart, periodEnd; // start and end of current sub sample
- const int numPeriods;//=1; number of structural change periods
- const int numVarobs; // number of observed variables in the observation vector at time t.
- const int numTimeObs; // number of obsevations (vectors) in the time series
- const int order;
- const int endo_nbr;
- const int exo_nbr;
- const int nstatic;
- const int npred;
- const int nfwrd;
- char *fName;
- int presampleStart;
- int kalman_algo; // type of kalman algorithm: multi- or uni-variate
- int mode_compute;
- int info;
- double penalty;
- int cost_flag;
- const int number_of_observations;
- const bool no_more_missing_observations;
- const vector<int>& order_var;
- const vector<int>& mfys;
- const vector<int>& mf; // positions of observed variables in restricted state vector for likelihood computation.
- Vector& xparam1; // all estimated parameters incl sderrs
- const int num_dp; // number of deep parameters
- Vector& deepParams; // estimated deep parameters subset of xparam1 only
- const Vector& param_ub; // upper and lower bounds
- const Vector& param_lb;
- const vector<int>&pshape;
- const Vector& p6;
- const Vector& p7;
- const Vector& p3;
- const Vector& p4;
- Vector& SteadyState;
- Vector& constant;
- GeneralParams& dynareParams;
- //GeneralParams& parameterDescription;
- GeneralParams& dr;
-
- GeneralMatrix& aux; //= dynareParams.getMatrixField(string("restrict_aux"));
- vector<int>&iv; //= dynareParams.getIntVectorField(string("restrict_var_list"));
- vector<int>⁣ //= dynareParams.getIntVectorField(string("restrict_columns"));
-
- GeneralMatrix& kstate;
- GeneralMatrix& ghx;
- GeneralMatrix& ghu;
-
- DynamicModelDLL* dynamicDLLp;
- Journal *journal;
- KordpDynare* model;// to be initialised by high level calling function
- Approximation* approx;
- TwoDMatrix *llincidence;
- TwoDMatrix *vCov;
- //friend class BasicKalmanTask;
- //BasicKalmanTask bkt;
- //friend class KalmanUniTask;
- //KalmanUniTask ukt;// univariate
- // member functions
- MexStructParam& SetDRModel(MexStructParam¶ms);
- // void disclyap_fast(const GeneralMatrix &G, const GeneralMatrix & V, GeneralMatrix &X, double tol = 1e-16, int flag_ch=0);
- GeneralMatrix& SolveDRkOrderPert();//calls k-order pert or whatever;
- int dynareResolveDR(vector<int>&iv,vector<int>&ic,GeneralMatrix& aux); // returns int info, ys, and TT and RR Decision Rule
- int SolveDRModel(const int endo_nbr, const int exo_nbr, const int nstatic, const int npred, int nfwrd);//int dr1(); // returns int info and updated dr
- int updateQHparams();// updates Q and H matrices and deep parameters
- int InitiateKalmanMatrices();
- void DataPreparation(MexStructParam¶ms, const GeneralMatrix &data);
- double KalmanFilter(double riccatiTol,bool uni);// calls Kalman
-
- public:
- DsgeLikelihood( Vector& inA_init, GeneralMatrix& inQ, GeneralMatrix& inR,
- GeneralMatrix& inT, GeneralMatrix& inZ, GeneralMatrix& inPstar, GeneralMatrix& inPinf,
- GeneralMatrix& inH, const GeneralMatrix&inData, GeneralMatrix&inY,
- const int INnumPeriods, // const int INnumVarobs, // const int INnumTimeObs,
- const int INorder, const int INendo_nbr, const int INexo_nbr, const int INnstatic,
- const int INnpred, const int INnfwrd, const int INnum_of_observations, const bool INno_more_missing_observations,
- const vector<int>& INorder_var, const vector<int>& INmfys, const vector<int>& INmf,
- Vector& INxparam1, const int INnum_dp, Vector& INdeepParams,
- const Vector& INub, const Vector& INlb, const vector<int>&INpshape,
- const Vector&INp6, const Vector&INp7, const Vector&INp3, const Vector&INp4,
- Vector& INSteadyState, Vector& INconstant, GeneralParams& INdynareParams,
- //GeneralParams& parameterDescription,
- GeneralParams& INdr, GeneralMatrix& INkstate, GeneralMatrix& INghx, GeneralMatrix& INghu,
- GeneralMatrix& aux, vector<int>&iv, vector<int>&ic
- ,const int jcols, const char *dfExt); //, KordpDynare& inModel, Approximation& INapprox );
- DsgeLikelihood( const Vector¶ms,const GeneralMatrix&data, const vector<int>& data_index, const int gend,
- const int number_of_observations, const bool no_more_missing_observations);//, KordpDynare& model ); // constructor, and
- DsgeLikelihood( GeneralParams& options_,GeneralParams& M_,GeneralParams& bayestopt_, GeneralMatrix& inData,
- KordpDynare& model); // constructor
- ~DsgeLikelihood();// destructor
- double CalcLikelihood(Vector& xparams);// runs all routines needed to calculate likelihood
- double getLik(){return likelihood;}
- int getInfo(){return info;}
- int getCostFlag(){return cost_flag;}
- Vector& getSteadyState(){ return SteadyState;}
-
- vector<double>& getLikVector() {return *vll;} // vector of log likelihoods for each Kalman step
- //GeneralMatrix&lyapunov_symm(const GeneralMatrix &G, const GeneralMatrix & V);
- };
-
-
diff --git a/mex/sources/estimation/Estimation.h b/mex/sources/estimation/Estimation.h
deleted file mode 100644
index 508383fa61ce95a324dcf880975b3c380a67cea0..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/Estimation.h
+++ /dev/null
@@ -1,44 +0,0 @@
-/*
- * Copyright (C) 2008-2009 Dynare Team
- *
- * This file is part of Dynare.
- *
- * Dynare is free software: you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * Dynare is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with Dynare. If not, see <http://www.gnu.org/licenses/>.
- */
-#ifndef ESTIMATION_H
-#define ESTIMATION_H
-//#include "k_ord_dynare.h"
-#include "kalman.h"
-#include "math.h"
-#include "disclyap_fast.h"
-#include "Mexutils.h"
-#include "estutils.h"
-
-#include <cstring>
-
-#include <cctype>
-
-class DsgeLikelihood;//GeneralParams;
-
-class Estimation
- {
- double logLikelihood;
- //instance MexStruct
- GeneralParams& gParams;
- DsgeLikelihood& DsgeLik;
-public:
- double getLikelihood()
- {return logLikelihood;};
- };
-#endif
\ No newline at end of file
diff --git a/mex/sources/estimation/MexUtils.cpp b/mex/sources/estimation/MexUtils.cpp
deleted file mode 100644
index aaaa12ec3571b049f2b10acb1278bf7daef05866..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/MexUtils.cpp
+++ /dev/null
@@ -1,573 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-#include "mexutils.h"
-
-
-MexStruct::MexStruct( const int numparstruct):
-numParStruct(numparstruct), structName(string(""))
- {
- // get Dynare mexSturcture pointers and store them locally
-#ifdef DEBUG
- mexPrintf("MexStruct reserve=%d \n", numParStruct);
-#endif
- parStruct.reserve(numParStruct);
- parStructBase.reserve(numParStruct);
- for (int i=0;i<numParStruct;++i)
- {
- parStruct[i]=mexGetVariablePtr("caller", DynareParamStructsNm[i]);
- parStructBase[i]=caller;
-#ifdef DEBUG
- mexPrintf("MexStruct to insert i=%d parStructNm[i]=%s using base[i]=%d %s\n", i, DynareParamStructsNm[i], parStructBase[i], mexBase[parStructBase[i]]);
-#endif
- // get field names into the map:
- pair <map<string, int>::iterator, bool> ret;
- int j=0;
- const char* field;
- while ((field=mxGetFieldNameByNumber(parStruct[i],j))!=NULL)
- {
-#ifdef DEBUG
- mexPrintf("MexStruct insert field= %s\n", field);
-#endif
- ret=parNamStructMap.insert(make_pair(string(field),i));
- if (!ret.second)
- mexPrintf("MexStruct failed to insert field %s from struct %d %s using base %d %s\n"
- , field, i, DynareParamStructsNm[i], parStructBase[i], mexBase[parStructBase[i]]);
-// mexErrMsgTxt("MexStruct: Failed to insert param \n");
- j++;
- }
- }
-#ifdef DEBUG
- mexPrintf("MexStruct insert finished \n");
-#endif
- }
-
-MexStructParam&
-MexStruct::getMexStructField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- return *(new MexStructParam(mxf, this, field));
- }
-
-void *
-MexStruct::getField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- return mxGetData(mxf);
- }
-
-GeneralMatrix &
-MexStruct::getMatrixField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- return *(new GeneralMatrix(mxGetPr(mxf), mxGetM(mxf), mxGetN(mxf))) ;
- }
-
-double&
-MexStruct::getDoubleField(const string& field)
- {
- const mxArray* mxf = getMxField( field);
- if (!mxIsDouble(mxf))
- mexErrMsgTxt("Input must be of type double.");
-// double ret=mxGetScalar(mxf);
-// return ret;
- double *ret=(new double);
- *ret=mxGetScalar(mxf);
- return *ret;
- }
-
-string&
-MexStruct::getStringField(const string& field)
- {
- mxArray* mxf = getMxField( field);
- if (!mxIsChar(mxf))
- mexErrMsgTxt("Input must be of type char.");
- return *(new string(mxArrayToString(mxf)));
- }
-
-char *
-MexStruct::getCharField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- if (!mxIsChar(mxf))
- mexErrMsgTxt("Input must be of type char.");
- return mxArrayToString(mxf);
- }
-
-vector<string>&
-MexStruct::getStringVectorField(const string& field)
- {
- charArraySt * cap = getCharArrayField(field);
- vector <string>*sv=(new vector<string>(cap->len));
- for (int i= 0; i<cap->len;++i)
- (*sv)[i]=string(cap->charArrayPtr[i]);
- return *sv;
- }
-
-vector<int>&
-MexStruct::getIntVectorField(const string& field)
- {
- mxArray* mxfp = getMxField( field);
- if (MIN(mxGetM(mxfp),mxGetN(mxfp))!=1)
- throw SYLV_MES_EXCEPTION("Int vector is a 2D Matrix .");
- double* dparams = (double *) mxGetData(mxfp);
- int npar = (int) MAX(mxGetM(mxfp), mxGetN(mxfp));
- vector<int> *vars = (new vector<int>(npar));
- for (int v = 0; v < npar; v++)
- {
- (*vars)[v] = (int)(*(dparams++)); //[v];
-#ifdef DEBUG
- mexPrintf("%s[%d]=%d.\n", field.c_str() , v, (*vars)[v]);
-#endif
- }
-
- return *vars;
- };
-
-
-Vector&
-MexStruct::getDoubleVectorField(const string& field)
- {
- mxArray* mxfp = getMxField( field);
- if (MIN(mxGetM(mxfp), mxGetN(mxfp))!=1)
- throw SYLV_MES_EXCEPTION("Double Vector is a 2D Matrix .");
- double* dparams = (double *) mxGetData(mxfp);
- int npar = (int) MAX(mxGetM(mxfp), mxGetN(mxfp));
- Vector *vars = (new Vector(dparams,npar));
- return *vars;
- };
-
-
-
-charArraySt *
-MexStruct::getCharArrayField( const string& field)
- {
- mxArray* mxfp = getMxField( field);
- const int len = (int) mxGetM(mxfp);
- const int width = (int) mxGetN(mxfp);
- if (!mxIsChar(mxfp))
- mexErrMsgTxt("Input must be of type char.");
-
- charArraySt * cap=new charArraySt;
- cap->charArrayPtr = (char**)MxArrayToStringArray(mxfp, len, width);
- cap->len=len;
- return cap;
- }
-
-void
-MexStruct::ReorderCols(GeneralMatrix &tdx, const vector<int> &vOrder)
- {MexStructParam::ReorderCols(tdx,vOrder, "static");};
-
-
-void
-MexStruct::setField( const string& field, const string& val)
- {
- mxArray *newVal=mxCreateString(val.c_str());
- UpdateMexField( field, newVal);
- }
- /*******
- {
- mxArray *fp = mxGetField(mexStruct, 0, field);
- mxDestroy(fp)
- mxSetField(mexStruct,0,field, newVal);
- }
- ***************/
-
-void
-MexStruct::setField( const string& field, const double val)
- {
- mxArray *newVal=mxCreateDoubleScalar(val);
- UpdateMexField( field, newVal);
- }
-
-void
-MexStruct::setField( const string& field, const GeneralMatrix& gmval)
- {
- mxArray *newVal=mxCreateDoubleMatrix(gmval.numRows(),gmval.numCols(),mxREAL);
- memcpy(mxGetPr(newVal),gmval.base(),gmval.numRows()*gmval.numCols()*sizeof(double));
- UpdateMexField( field, newVal);
- }
-
-void
-MexStruct::UpdateMexField( const string& field, mxArray *newVal)
- {
- StructBaseNameMap* dpsm=getMxFieldStruct(field);
- mxArray *sp =mexGetVariable(dpsm->baseName, dpsm->structName);
- if (sp == NULL )
- {
- mexPrintf("Variable not found : base: %s, structName %s\n", dpsm->baseName, dpsm->structName);
- mexErrMsgTxt(" \n");
- }
- mxArray *fp = mxGetField(sp, 0, field.c_str());
- mxDestroyArray(fp);
- mxSetField(sp,0,field.c_str(), newVal);
- mexPutVariable(dpsm->baseName, dpsm->structName, sp);
- //mxDestroyArray(newVal);
- }
-
-/***********************************************
-* MexStructParam
-* holds single Matlab structure passed as parameter
-***********************************************/
-
-MexStructParam&
-MexStructParam::getMexStructField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- return *(new MexStructParam(mxf, this, field));
- }
-
-void *
-MexStructParam::getField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- return mxGetData(mxf);
- }
-
-double&
-MexStructParam::getDoubleField(const string& field)
- {
- const mxArray* mxf = getMxField( field);
- if (!mxIsDouble(mxf))
- mexErrMsgTxt("Input must be of type double.");
- double *ret=(new double);
- *ret=mxGetScalar(mxf);
- return *ret;
- }
-
-GeneralMatrix&
-MexStructParam::getMatrixField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- return *(new GeneralMatrix(mxGetPr(mxf), mxGetM(mxf), mxGetN(mxf)) );
- }
-
-string&
-MexStructParam::getStringField(const string& field)
- {
- mxArray* mxf = getMxField( field);
- if (!mxIsChar(mxf))
- mexErrMsgTxt("Input must be of type char.");
- return *(new string(mxArrayToString(mxf)));
- }
-
-char *
-MexStructParam::getCharField( const string& field)
- {
- mxArray* mxf = getMxField( field);
- if (!mxIsChar(mxf))
- mexErrMsgTxt("Input must be of type char.");
- return mxArrayToString(mxf);
- }
-
-vector<string>&
-MexStructParam::getStringVectorField(const string& field)
- {
- charArraySt * cap = getCharArrayField( field);
- vector <string>*sv= (new vector<string>(cap->len));
- for (int i= 0; i<cap->len;++i)
- (*sv)[i]=string(cap->charArrayPtr[i]);
- return *sv;
- }
-
-vector<int>&
-MexStructParam::getIntVectorField(const string& field)
- {
- mxArray* mxfp = getMxField( field);
- if (MIN(mxGetM(mxfp), mxGetN(mxfp))!=1)
- throw SYLV_MES_EXCEPTION("Int vector is a 2D Matrix .");
- double* dparams = (double *) mxGetData(mxfp);
- int npar = (int) MAX(mxGetM(mxfp), mxGetN(mxfp));
- vector<int> *vars = (new vector<int>(npar));
- for (int v = 0; v < npar; v++)
- {
- (*vars)[v] = (int)(*(dparams++)); //[v];
-#ifdef DEBUG
- mexPrintf("%s[%d]=%d.\n", field.c_str(), v, (*vars)[v]);
-#endif
- }
-
- return *vars;
- };
-
-
-Vector&
-MexStructParam::getDoubleVectorField(const string& field)
- {
- mxArray* mxfp = getMxField( field);
- if (MIN(mxGetM(mxfp), mxGetN(mxfp))!=1)
- throw SYLV_MES_EXCEPTION("Double Vector is a 2D Matrix .");
- double* dparams = (double *) mxGetData(mxfp);
- int npar = (int) MAX(mxGetM(mxfp), mxGetN(mxfp));
- Vector *vars = (new Vector(dparams,npar));
- return *vars;
- };
-
-
-
-
-charArraySt *
-MexStructParam::getCharArrayField( const string& field)
- {
- mxArray* mxfp = getMxField( field);
- const int len = (int) mxGetM(mxfp);
- const int width = (int) mxGetN(mxfp);
- if (!mxIsChar(mxfp))
- mexErrMsgTxt("Input must be of type char.");
-
- charArraySt * cap=new charArraySt;
- cap->charArrayPtr = (char**)MxArrayToStringArray(mxfp, len, width);
- cap->len=len;
- return cap;
- }
-
-void
-MexStructParam::setField( const string& field, const string& val)
- {
- mxArray *newVal=mxCreateString(val.c_str());
- mxSetField((mxArray*)parStruct,0,field.c_str(), newVal);
- //UpdateMexField( field, newVal);
- }
- /*******
- {
- mxArray *fp = mxGetField(mexStruct, 0, field);
- mxDestroy(fp)
- mxSetField(mexStruct,0,field, newVal);
- }
- ***************/
-
-void
-MexStructParam::setField( const string& field, const double val)
- {
- mxArray *newVal=mxCreateDoubleScalar(val);
- mxSetField((mxArray*)parStruct,0,field.c_str(), newVal);
- //UpdateMexField( field, newVal);
- }
-
-void
-MexStructParam::setField( const string& field, const GeneralMatrix& gmval)
- {
- mxArray *newVal=mxCreateDoubleMatrix(gmval.numRows(),gmval.numCols(),mxREAL);
- memcpy(mxGetPr(newVal),gmval.base(),gmval.numRows()*gmval.numCols()*sizeof(double));
- mxSetField((mxArray*)parStruct,0,field.c_str(), newVal);
- //UpdateMexField( field, newVal);
- }
-
-void
-MexStructParam::UpdateMexField( const string& field, mxArray *newVal)
- {
-
- mxSetField((mxArray*)parStruct,0,field.c_str(), newVal);
-
- /************
- if (parStructParent!=NULL)
- parStructParent->setField(field,newVal);
- else
- {
-
- mxArray *sp =mexGetVariable("caller",structName);
- if (sp == NULL )
- {
- mexPrintf("Variable not found : base: %s, structName %s\n", dpsm->baseName, dpsm->structName);
- mexErrMsgTxt(" \n");
- }
- mxArray *fp = mxGetField(sp, 0, field.c_str());
- mxDestroyArray(fp);
- mxSetField(sp,0,field.c_str(), newVal);
- mexPutVariable(dpsm->baseName, dpsm->structName, sp);
- //mxDestroyArray(newVal);
- }
- ************/
- }
-
-
-
-
-/************************************
-* Reorder first variables in a vector
-* according to order given in varsOrder
-
-************************************/
-
-void
-//MexStructParam::ReorderCols(GeneralMatrix &tdx, const vector<int> *vOrder)
-MexStructParam::ReorderCols(GeneralMatrix &tdx, const vector<int> &vOrder, char* stat)
-{
-
- if (tdx.numCols() > vOrder.size())
- {
- mexPrintf(" Error in ReorderColumns - size of order var is too small");
- return;
- }
-// GeneralMatrix tmp(*tdx); // temporary 2D matrix
- GeneralMatrix tmpR(tdx); // temporary 2D matrix
-// GeneralMatrix &tmpR = tmp;
- tdx.zeros(); // empty original matrix
- // reorder the columns
- try
- {
- for (int i = 0; i < tdx.numCols(); i++)
- tdx.copyColumns(tmpR, (vOrder)[i],vOrder[i], i);
-// tdx->copyColumn(tmpR, (*vOrder)[i], i);
- }
- catch (const SylvException &e)
- {
- printf("Caugth exception in ReorderColumns: ");
- e.printMessage();
- return; // 255;
- }
- catch (...)
- {
- mexPrintf(" Error in ReorderColumns - wrong index?");
- }
-}
-void
-MexStructParam::ReorderCols(GeneralMatrix &tdx, const int *vOrder)
-{
-
-// GeneralMatrix tmp(*tdx); // temporary 2D matrix
- GeneralMatrix tmpR(tdx); // temporary 2D matrix
-// GeneralMatrix &tmpR = tdztmp;
- tdx.zeros(); // empty original matrix
- // reorder the columns
- try
- {
- for (int i = 0; i < tdx.numCols(); i++)
- tdx.copyColumns(tmpR, vOrder[i],vOrder[i], i);
- }
- catch (const SylvException &e)
- {
- printf("Caugth SYLV_EXCEPTION in ReorderColumns: ");
- e.printMessage();
- return; // 255;
- }
- catch (...)
- {
- mexPrintf(" Error in ReorderColumns - wrong index?");
- }
-}
-
-/**************
-void
-//MexStructParam::ReorderCols(GeneralMatrix *tdx, const vector<int> *vOrder)
-MexStructParam::ReorderCols(GeneralMatrix *tdx, const vector<int> &vOrder)
-{
-
- if (tdx->ncols() > vOrder->size())
- {
- mexPrintf(" Error in ReorderColumns - size of order var is too small");
- return;
- }
- GeneralMatrix tmp(*tdx); // temporary 2D matrix
-// GeneralMatrix& tmpR(tdx); // temporary 2D matrix
- GeneralMatrix &tmpR = tmp;
- tdx->zeros(); // empty original matrix
- // reorder the columns
- try
- {
- for (int i = 0; i < tdx->ncols(); i++)
- tdx->copyColumn(tmpR, (vOrder)[i], i);
-// tdx->copyColumn(tmpR, (*vOrder)[i], i);
- }
- catch (const TLException &e)
- {
- printf("Caugth TL exception in ReorderColumns: ");
- e.print();
- return; // 255;
- }
- catch (...)
- {
- mexPrintf(" Error in ReorderColumns - wrong index?");
- }
-}
-void
-MexStructParam::ReorderCols(GeneralMatrix *tdx, const int *vOrder)
-{
-
- GeneralMatrix tmp(*tdx); // temporary 2D matrix
-// GeneralMatrix tmpR(tdx); // temporary 2D matrix
- GeneralMatrix &tmpR = tdztmp;
- tdx->zeros(); // empty original matrix
- // reorder the columns
- try
- {
- for (int i = 0; i < tdx->ncols(); i++)
- tdx->copyColumn(tmpR, vOrder[i], i);
- }
- catch (const TLException &e)
- {
- printf("Caugth TL exception in ReorderColumns: ");
- e.print();
- return; // 255;
- }
- catch (...)
- {
- mexPrintf(" Error in ReorderColumns - wrong index?");
- }
-}
-
-*******************/
-//////////////////////////////////////////////////////
-// Convert Matlab string array to C type array of string pointers
-// Poblem is that Matlab mx function returns a long string concatenated by columns rather than rows
-// hence a rather low level approach is needed
-///////////////////////////////////////////////////////
-const char **
-MxArrayToStringArray(const mxArray *mxFldp, const int len, const int width)
- {
- char *cNamesCharStr = mxArrayToString(mxFldp);
- const char **ret = MxArrayToStringArray(cNamesCharStr, len, width);
- return ret;
- }
-
-const char **
-MxArrayToStringArray(const char *cNamesCharStr, const int len=1, const int width=1)
- {
- char cNamesMX[len][width+1]; //
-#ifdef DEBUG
- mexPrintf("loop MxArrayToStringArray cNamesCharStr = %s \n", cNamesCharStr);
-#endif
- for (int i = 0; i < width; i++)
- {
- for (int j = 0; j < len; j++)
- {
- // Allow alphanumeric and underscores "_" only:
- if (isalnum(cNamesCharStr[j+i*len]) || ('_' == cNamesCharStr[j+i*len]))
- {
- cNamesMX[j][i] = cNamesCharStr[j+i*len];
- }
- else cNamesMX[j][i] = '\0';
- }
- }
- const char **ret = (const char **) mxCalloc(len, sizeof(char *));
- for (int j = 0; j < len; j++)
- {
- cNamesMX[j][width] = '\0';
-#ifdef DEBUG
- // mexPrintf("String [%d]= %s \n", j, cNamesMX[j]);
-#endif
- char *token = (char *) mxCalloc(strlen(cNamesMX[j])+1, sizeof(char));
- strcpy(token, cNamesMX[j]);
- ret[j] = token;
-#ifdef DEBUG
- mexPrintf("ret [%d]= %s \n", j, ret[j]);
-#endif
- }
- return ret;
- }
diff --git a/mex/sources/estimation/MexUtils.h b/mex/sources/estimation/MexUtils.h
deleted file mode 100644
index 7a1ccdf37ec060d32cb5de84f3a86ee8bf0b852f..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/MexUtils.h
+++ /dev/null
@@ -1,229 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-#ifndef MEXUTILS_H
-#define MEXUTILS_H
-#include <utility>
-#include <vector>
-#include "ioutils.h"
-#include "mex.h"
-#include "matrix.h"
-//#include "SylvException.h"
-#define MIN(X,Y) ((X) < (Y) ? (X) : (Y))
-#define MAX(X,Y) ((X) > (Y) ? (X) : (Y))
-
-
-//#include "k_ord_dynare.h"
-//using namespace std;
-enum {base, caller, global};
-enum {M_, oo_, options_,bayestopt_, estim_params_, dr};
-extern const char *DynareParamStructsNm [];
-extern const char* mexBase[];
-
-const int numParStructs=5;
-//#define numParStructsM 6
-
-
-/**
-struct DynareParamsStructMap
-{ char * paramName;
-int dynParStruct;
-}
-
- struct DynareParamsStructBasePair
- {
- int dynParStruct;
- int mexBase;
- }
-**/
-
-
-
-struct StructBaseNameMap
- { char* baseName;
-char* structName;
- };
-
-class MexStructParam;
-
-class MexStruct :public virtual GeneralParams
- {
- vector <int> parStructBase;
- vector <const mxArray*> parStruct; // array of struct pointers
- map <string, int> parNamStructMap; // which struct par belongs
- const int numParStruct;
- const string structName;
-
- mxArray* getMxField( const string& field)
- {
- map<string, int>::iterator it=parNamStructMap.find(field);
- if (it==parNamStructMap.end())
- {
- mexPrintf("getMxField:no parameter with such name");
- throw(SYLV_MES_EXCEPTION("getMxField:no parameter with such name"));
- }
- return mxGetField(parStruct[it->second], 0, field.c_str() );
- }
-
- StructBaseNameMap* getMxFieldStruct( const string& field)
- {
- map<string, int>::iterator it=parNamStructMap.find(field);
- if (it==parNamStructMap.end())
- throw(SYLV_MES_EXCEPTION("no parameter with such name"));
- StructBaseNameMap* dpsm=new StructBaseNameMap;
- dpsm->baseName=(char*)mexBase[parStructBase[it->second]];
- dpsm->structName=(char*)DynareParamStructsNm[it->second];
-
- return dpsm;
- }
-
-// void ReorderCols(GeneralMatrix* tdx, const vector<int>*vOrder);
-// {KordpDynare::ReorderCols((TwoDMatrix*) tdx, *vOrder)};
-// void ReorderCols(GeneralMatrix* tdx, const char*vOrder);
-// {KordpDynare::ReorderCols((TwoDMatrix*) tdx, *vOrder)};
- public:
- MexStruct(int numParStr=1);
- /**
- MexStruct( char *sBases, char * mexStructNames, int numParStr=1)
- : base(sBases), structName(mexStructNames), numParStruct(numParStr)
- {
-
- mexStruct=mexGetVariable(base, structName);
- }
- **/
- ~MexStruct(){};
- void *
- getMxArrayField(const string& field)
- {
- return getMxField( field);
- }
- string& name(){return *(new string(structName));};
- MexStructParam& getMexStructField( const string& field);
- GeneralParams& getStructField( const string& field)
- {return (GeneralParams&) getMexStructField( field);};
- void * getField( const string& field);
- double& getDoubleField(const string& field);
- string& getStringField(const string& field);
- vector<string>& getStringVectorField(const string& field);
- vector<int>& getIntVectorField(const string& field);
- Vector& getDoubleVectorField(const string& field);
- char * getCharField( const string& field);
- charArraySt * getCharArrayField( const string& field);
- GeneralMatrix & getMatrixField( const string& field);
- void ReorderCols(GeneralMatrix& tdx, const vector<int>&vOrder);
-// (MexStructParam::ReorderCols(tdx, vOrder););
-// static void ReorderCols(GeneralMatrix& tdx, const int*vOrder);
-// (MexStructParam::ReorderCols(tdx, vOrder););
- void setField(const string& field, const string& newVal);
- void setField(const string& field, const double val);
- void setField(const string& field, const GeneralMatrix& val);
- void UpdateMexField( const string& field, mxArray *newVal);
- //void putMexStruct();//{mexPutVariable(base, structName, mexStruct);};
- };
-
-/***********************************************
-* MexStructParam
-* holds single Matlab structure passed as parameter
-***********************************************/
-
-class MexStructParam :public virtual GeneralParams
- {
- const mxArray* parStruct; // struct pointer
- const GeneralParams* parStructParent; // if any
- const string structName; // if any, param name of the structure in its parent.
-
- mxArray* getMxField( const string& field)
- {
- return mxGetField(parStruct, 0, field.c_str());
- }
-
-// void ReorderCols(GeneralMatrix* tdx, const vector<int>*vOrder);
-// void ReorderCols(GeneralMatrix* tdx, const char*vOrder);
-
- public:
- MexStructParam(const mxArray* paramStruct, const GeneralParams* parent, const string& name):
- parStruct(paramStruct), parStructParent(parent), structName(name) {};
- MexStructParam( const mxArray* paramStruct, const GeneralParams* parent):
- parStruct(paramStruct), parStructParent(parent), structName(string("")){};
- MexStructParam(const mxArray* paramStruct, const string& name):
- parStruct(paramStruct), parStructParent(NULL), structName(name){};
- ~MexStructParam(){};
- void *
- getMxArrayField(const string& field)
- {
- return getMxField( field);
- }
- string& name(){return *(new string(structName));};
- MexStructParam& getMexStructField( const string& field);
- GeneralParams& getStructField( const string& field)
- {return (GeneralParams&) getMexStructField( field);};
- void * getField( const string& field);
- double& getDoubleField(const string& field);
- string& getStringField(const string& field);
- vector<string>& getStringVectorField(const string& field);
- vector<int>& getIntVectorField(const string& field);
- Vector& getDoubleVectorField(const string& field);
- char * getCharField( const string& field);
- charArraySt * getCharArrayField( const string& field);
- GeneralMatrix & getMatrixField( const string& field);
- void ReorderCols(GeneralMatrix& tdx, const vector<int>&vOrder)
- {ReorderCols(tdx, vOrder, "stat");};
- static void ReorderCols(GeneralMatrix& tdx, const vector<int>&vOrder, char*stat);
- static void ReorderCols(GeneralMatrix& tdx, const int*vOrder);
- void setField(const string& field, const string& newVal);
- void setField(const string& field, const double val);
- void setField(const string& field, const GeneralMatrix& val);
- void UpdateMexField( const string& field, mxArray *newVal);
- //void putMexStruct();//{mexPutVariable(base, structName, mexStruct);};
- };
-
- /***************
- class ConstMexStruct :public GeneralParams
- {
- const mxArray* mexStruct;
- DynareParamsStructMap dynpsm;
-
- const char *base; // one of: base, caller, global
- const char *structName;
- MexStruct( char *sBase, char * mexStructName)
- : base(sBase), structName(mexStructName)
- {
- mexStruct=mexGetVariablePtr(base, structName);
- }
- virtual ~MexStruct(){};
- mxArray *
- getField(string& field)
- {
- return mxGetField(mexStruct, 0, field);
- }
- };
-
-*******************/
-
-//////////////////////////////////////////////////////
-// Convert Matlab Dynare string array to C type array of string pointers
-// Poblem is that Matlab mx function returns a long string concatenated by columns rather than rows
-// hence a rather low level approach is needed
-///////////////////////////////////////////////////////
-const char **
-MxArrayToStringArray(const mxArray *mxFldp, const int len, const int width);
-const char **
-MxArrayToStringArray(const char *cNamesCharStr, const int len, const int width);
-
-
-#endif
\ No newline at end of file
diff --git a/mex/sources/estimation/dr1.cpp b/mex/sources/estimation/dr1.cpp
deleted file mode 100644
index f3a7f81d49dda1b3162f6b1b4e2a2e576f69fa7e..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/dr1.cpp
+++ /dev/null
@@ -1,303 +0,0 @@
-/*
- * Copyright (C) 2008-2009 Dynare Team
- *
- * This file is part of Dynare.
- *
- * Dynare is free software: you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * Dynare is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with Dynare. If not, see <http://www.gnu.org/licenses/>.
- */
-
-/***********************************************
-% Based on Dynare Matlab
-% function [dr,info,M_,options_,oo_] = SetDRModel(dr,task,M_,options_,oo_)
-% formerly known as dr1 in Matalb Dynare
-% Computes the reduced form solution of a rational expectation model (first or second order
-% approximation of the stochastic model around the deterministic steady state).
-%
-%
-********************************************************************/
-#include "mexutils.h"
-#include "DsgeLikelihood.h"
-
-int
-DsgeLikelihood::SolveDRModel(const int endo_nbr, const int exo_nbr, const int nstatic, const int npred, int nfwrd)//dr1()
- {
- int infoDR = 0;
- int i;
-
- // % expanding system for Optimal Linear Regulator
- if ((int)dynareParams.getDoubleField(string("ramsey_policy")))
- throw SYLV_MES_EXCEPTION("K-order-perturbation can not soleve for Ramsey policy");
- else // dr=set_state_space(dr,M_); - to be done prior to calling estaimte!!
- {
- if (order ==1)
- {
- try
- {
- GeneralMatrix& ghx_u=SolveDRkOrderPert();//(dr,task,M_,options_, oo_ , ['.' mexext]);
- //SteadyState=ysteady;
- if (ghx_u.isZero())
- {
- mexPrintf("******** ghx_u is Zero ! *******\n");
- //throw(1);
- }
-/**********/
- int sss= ghx_u.numCols();
-#ifdef DEBUG
- mexPrintf("*********GHX_U colos %d then Allocate GHX and GHU *********\n", sss);
- ghx_u.print();
-#endif
- vector<int>span2nx(sss-exo_nbr);
- for (i=0;i<sss-exo_nbr;++i)
- span2nx[i]=i+1;
- //ghx= ( (ghx_u, nullVec,span2nx));//ghx_u(:,1:sss-M_.exo_nbr);
- GeneralMatrix gh_x (ghx_u, nullVec,span2nx);//ghx_u(:,1:sss-M_.exo_nbr);
-#ifdef DEBUG
- mexPrintf("*********GH_X*********\n");
- gh_x.print();
-#endif
- ghx= gh_x;
-#ifdef DEBUG
- mexPrintf("*********GHX*********\n");
- ghx.print();
-#endif
- vector<int>spannx2end(exo_nbr);
- for (i=0;i<exo_nbr;++i)
- spannx2end[i]=sss-exo_nbr+i+1;
- ghu= ( GeneralMatrix(ghx_u, nullVec,spannx2end)); //ghx_u(:,sss-M_.exo_nbr+1:end);
-/**********
- //Test only:
- ghu=dr.getMatrixField(string("ghu"));
- ghx=dr.getMatrixField(string("ghx"));
-********/
-#ifdef DEBUG
- mexPrintf("*********GHU*********\n");
- ghu.print();
-// ghx.print();
-#endif
-
- // end test
- delete &ghx_u;
- }
- catch(int e)
- {
- throw SYLV_MES_EXCEPTION("Problem with using k_order perturbation solver ");
- info = 4;
- penalty = 1000; // info(2)
- infoDR=info;
- return infoDR;
- }//end
- }
- else //if options_.order >1
- {
- throw SYLV_MES_EXCEPTION("can not use order != 1 for estimation yet!");
- info = 4;
- penalty = 1000;//info(2) = 1000;
- infoDR=info;
- return infoDR;
- };// end if
-
- if ((int)dynareParams.getDoubleField(string("loglinear")) == 1)
- {
-#ifdef DEBUG
- mexPrintf("setting SolveDRModel loglinear results\n");
-#endif
- //k = find(dr.kstate(:,2) <= M_.maximum_endo_lag+1);
- vector<int>kk(0);
- int maximum_endo_lag= (int)dynareParams.getDoubleField(string("maximum_endo_lag"));
- for(i=0;i<kstate.numRows();++i)
- if ( kstate.get(i,1)<=maximum_endo_lag+1)
- kk.push_back(i+1);
-
- //klag = dr.kstate(k,[1 2]);
- vector<int>kk2(2);
- kk2[0]=1;
- kk2[1]=2;
-#ifdef DEBUG
- mexPrintf("setting klag for loglinear results\n");
-#endif
- GeneralMatrix klag (kstate, kk,kk2);
-
- //k1 = dr.order_var;
- vector<int>k1klag(0);
-#ifdef DEBUG
- mexPrintf("setting k1klag for loglinear results\n");
-#endif
- for (i=0; i< klag.numRows();++i)
- if ((int) klag.get(i, 0)>0)
- k1klag.push_back(order_var[(int) klag.get(i, 0)-1]);
-
- //dr.ghx = repmat(1./dr.ys(k1),1,size(dr.ghx,2)).*dr.ghx.* ...
- // ...repmat(dr.ys(k1(klag(:,1)))',size(dr.ghx,1),1);
- Vector invOrdSS(endo_nbr);//SteadyState.length());
- for (i=0;i<endo_nbr;++i)
- invOrdSS[i]=1/SteadyState[order_var[i]-1];
-
-#ifdef DEBUG
- mexPrintf("setting mInvOrdSS for loglinear results\n");
-#endif
- GeneralMatrix mInvOrdSS(invOrdSS.base(),endo_nbr,1);
-#ifdef DEBUG
- mInvOrdSS.print();
- mexPrintf("SolveDRModel Call repmat 1 for loglinear ghx results\n");
-#endif
- GeneralMatrix&repInvSSx=mInvOrdSS.repmat(1,ghx.numCols());
-
- Vector k1klagSS(k1klag.size());
- for (i=0;i<k1klag.size();++i)
- k1klagSS[i]=SteadyState[k1klag[i]-1];
-
- // GeneralMatrix mSSt(SteadyState.base(),1,endo_nbr);
- // GeneralMatrix mk1klagSSt(mSSt, k1klag,nullVec);
-
- GeneralMatrix mk1klagSSt(k1klagSS.base(), 1,k1klag.size());
-#ifdef DEBUG
- mk1klagSSt.print();
- repInvSSx.print();
- mexPrintf("SolveDRModel Call repmat 2 for loglinear ghx results\n");
-#endif
- GeneralMatrix&repk1klagSSt=mk1klagSSt.repmat(ghx.numRows(),1);
-#ifdef DEBUG
- mexPrintf("Final setting SolveDRModel loglinear ghx results\n");
-#endif
- ghx.multElements(repInvSSx);
- ghx.multElements(repk1klagSSt);
-
- //dr.ghu = repmat(1./dr.ys(k1),1,size(dr.ghu,2)).*dr.ghu;
-#ifdef DEBUG
- mexPrintf("SolveDRModel Call repmat 1 for loglinear ghu results\n");
-#endif
- GeneralMatrix&repInvSSu=mInvOrdSS.repmat(1,ghu.numCols());
-#ifdef DEBUG
- mexPrintf("Final setting SolveDRModel loglinear ghu results\n");
-#endif
- ghu.multElements(repInvSSu);
- delete &repk1klagSSt;
- delete &repInvSSu;
- delete &repInvSSx;
-#ifdef DEBUG
- mexPrintf("Final loglinear ghu and ghx results\n");
- ghu.print();
- ghx.print();
-#endif
- };//end if
- }
- return infoDR;
- }
-
-
-/********************************************************************
-* Solve the reduced DR k-order-model
-*********************************************************************/
-GeneralMatrix&
-DsgeLikelihood::SolveDRkOrderPert() //kOrderPerturbation
- {
-// GeneralMatrix nullMat(0,0);
- model->getParams()=deepParams;
- model->getSteady()=SteadyState;
- GeneralMatrix* dgyu=new GeneralMatrix (ghu.numRows(), ghx.numCols()+ghu.numCols());
- dgyu->zeros();
-
- try
- {
-
-#ifdef DEBUG
- mexPrintf(" DeepParams:.\n");
- deepParams.print();
- mexPrintf(" Calling walkStochSteady with Params:.\n");
- model->getParams().print();
-#endif
-
- approx->walkStochSteady();
-#ifdef DEBUG
- mexPrintf("End of walkStochSteady - write map.\n");
-#endif
- // Write derivative outputs into memory map
- map<string, ConstTwoDMatrix> mm;
- approx->getFoldDecisionRule().writeMMap(&mm);
-#ifdef DEBUG
- mexPrintf("k_order_perturbation: Map print: \n");
- approx->getFoldDecisionRule().print();
-#endif
-#ifdef DEBUG
- mexPrintf("k_order_perturbation: Map print: \n");
- for (map<string, ConstTwoDMatrix>::const_iterator cit = mm.begin();
- cit != mm.end(); ++cit)
- {
- mexPrintf("k_order_perturbation: Map print: string: %s , g:\n", (*cit).first.c_str());
- (*cit).second.print();
- }
-#endif
- // get latest ysteady
-// SteadyState=model->getSteady();
-#ifdef DEBUG
-// mexPrintf("Steady State\n");
-// SteadyState.print();
-#endif
-
-
- // developement of the output.
-#ifdef DEBUG
- mexPrintf("k_order_perturbation: Filling outputs.\n");
-#endif
- int ii=1;
- // Set the output pointer to the combined output matrix gyu = [gy gu].
- for (map<string, ConstTwoDMatrix>::const_iterator cit = mm.begin();
- ((cit != mm.end()) && (ii < 4)); ++cit)
- {
- if ((*cit).first!="g_0" && ii==2)
- {
- dgyu->getData() = (*cit).second.getData();
-#ifdef DEBUG
- mexPrintf("k_order_perturbation: cit %d numRows %d numCols %d print: \n", ii, (*cit).second.numRows(), (*cit).second.numCols());
- (*cit).second.print();
- mexPrintf("k_order_perturbation: dguy output %d print: \n", ii);
- dgyu->print(); //!! This print Crashes???
-#endif
- return *dgyu;
- }
- ++ii;
- }
- return *dgyu;
- }
- catch (const KordException &e)
- {
- printf("Caugth Kord exception in SolveDRkOrderPert: ");
- e.print();
- mexPrintf("Caugth Kord exception: %s", e.get_message());
- }
- catch (const TLException &e)
- {
- printf("Caugth TL exception in SolveDRkOrderPert: ");
- mexPrintf("Caugth TL exception in SolveDRkOrderPert: ");
- e.print();
- }
- catch (SylvException &e)
- {
- printf("Caught Sylv exception in SolveDRkOrderPert: ");
- mexPrintf("Caught Sylv exception in SolveDRkOrderPert: ");
- e.printMessage();
- }
- catch (const DynareException &e)
- {
- printf("Caught KordpDynare exception in SolveDRkOrderPert: %s\n", e.message());
- mexPrintf("Caugth Dynare exception in SolveDRkOrderPert: %s", e.message());
- }
- catch (const ogu::Exception &e)
- {
- printf("Caught ogu::Exception in SolveDRkOrderPert: ");
- e.print();
- mexPrintf("Caugth general exception inSolveDRkOrderPert: %s", e.message());
- } //catch
- }; // end of mexFunction()
-
diff --git a/mex/sources/estimation/dynare_resolve.cpp b/mex/sources/estimation/dynare_resolve.cpp
deleted file mode 100644
index 5bbfb62d8361675b892f15e18af2ecd79dc5a6da..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/dynare_resolve.cpp
+++ /dev/null
@@ -1,199 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-/*****************************************************
-% Based on Matlab Dynare
-% function [int info] = dynare_resolve(ys,iv,ic,aux)
-%
-% function [A,B,ys,info] = dynare_resolve(iv,ic,aux)
-% Computes the linear approximation and the matrices A and B of the
-% transition equation and doing:
-% check if ys is steady state
-% dr
-% kalman_transition_matrix
-%
-% INPUTS
-% iv: selected variables (observed and state variables)
-% ic: state variables position in the transition matrix columns
-% aux: indices for auxiliary equations
-%
-% MODIFIES
-% A: matrix of predetermined variables effects in linear solution (ghx)
-% B: matrix of shocks effects in linear solution (ghu)
-% ys: steady state of original endogenous variables
-%
-% OUTPUTS
-% info=1: the model doesn't determine the current variables '...' uniquely
-% info=2: MJDGGES returns the following error code'
-% info=3: Blanchard Kahn conditions are not satisfied: no stable '...' equilibrium
-% info=4: Blanchard Kahn conditions are not satisfied:'...' indeterminacy
-% info=5: Blanchard Kahn conditions are not satisfied:'...' indeterminacy due to rank failure
-% info=20: can't find steady state info(2) contains sum of sqare residuals
-% info=30: variance can't be computed
-%
-% SPECIAL REQUIREMENTS
-% none
-********************************************************************/
-
-#include "dsgeLikelihood.h"
-
-int
-DsgeLikelihood::dynareResolveDR(vector<int>&iv,vector<int>&ic,GeneralMatrix& aux) // i.e. dynare_resolve()
- {
- //here comes a subset of [oo_.dr,info] = resol(oo_.steady_state,0);
- // check if ys is steady state and calcluate new one if not
- // testing for steadystate file: To Be Icluded at a later stage
-
-#ifdef DEBUG
- mexPrintf("Calling SolveDRModel\n");
-#endif
- // [dr,info,M_,options_,oo_] = dr1(dr,check_flag,M_,options_,oo_);
- int DRinfo = SolveDRModel(endo_nbr,exo_nbr,nstatic, npred, nfwrd); //formerly known as dr1 in Matalb Dynare, i.e.
- if (DRinfo)
- {
- info = DRinfo;
- return DRinfo;
- }
-
- // End of resol: now rest of dynare_resolve:
-
- // if nargin == 0
- // if (iv.size()==0)
-#ifdef DEBUG
- mexPrintf(" if iv==NULL\n");
-#endif
- if (&iv==NULL)
- {
-#ifdef DEBUG
- mexPrintf(" construct iv\n");
-#endif
- //iv = (1:endo_nbr)';
- for (int i=1;i<=endo_nbr;++i)
- iv.push_back(i);//= (1:endo_nbr)';
- }
- // if (ic.size()==0)
-#ifdef DEBUG
- mexPrintf(" if ic==NULL\n");
-#endif
- if (&ic==NULL)
- {
-#ifdef DEBUG
- mexPrintf(" construct ic\n");
-#endif
- //ic = [ nstatic+(1:npred) endo_nbr+(1:size(oo_.dr.ghx,2)-npred) ]';
- //ic(npred+ghx.numCols());
- for(int i=0;i<npred;++i)
- {
- ic.push_back(i+nstatic+1);
- }
- for(int j=0;j<ghx.numCols()-npred;++j)
- ic.push_back(j+endo_nbr+1);
- }
-
-#ifdef DEBUG
- mexPrintf(" if aux==NULL\n");
-#endif
- if (&aux==NULL)
- {
-#ifdef DEBUG
- mexPrintf(" construct aux\n");
-#endif
- int i;
- aux =dr.getMatrixField(string("transition_auxiliary_variables"));
- //k = find(aux(:,2) > npred);
- //aux(:,2) = aux(:,2) + nstatic;
- vector<int>k(0);
- for (i=0; i< aux.numRows();++i)
- {
- if (aux.get(i,1)>npred)
- k.push_back(i+1);
- aux.get(i, 1)+=nstatic;
- }
-
- //aux(k,2) = aux(k,2) + oo_.dr.nfwrd;
- for ( i=0; i< k.size();++i)
- aux.get(k[i]-1,1) +=nfwrd;
- }//end if
-
-#ifdef DEBUG
- mexPrintf("[A,B] = kalman_transition_matrix\n");
-#endif
-
- // here is the content of [T R]=[A,B] = kalman_transition_matrix(oo_.dr,iv,ic,aux,M_.exo_nbr);
-
- int n_iv = iv.size();//length(iv);
- int n_ir1 = aux.numRows();// size(aux,1);
- int nr = n_iv + n_ir1;
-
- // GeneralMatrix A=*(new GeneralMatrix (nr,nr));
- // A.zeros();
- // GeneralMatrix B=*(new GeneralMatrix(nr,exo_nbr));
- // B.zeros();
- T.zeros();
- R.zeros();
- vector<int>i_n_iv(n_iv);
- for (int i=0;i<n_iv;++i)
- i_n_iv[i]=i+1;//= (1:n_iv)';
-
-#ifdef DEBUG
- mexPrintf("T=A assign by vec\n");
-#endif
- //A(i_n_iv,ic) = dr.ghx(iv,:);
- //A.AssignByVectors (i_n_iv,ic, ghx, iv, nullVec);//dr.ghx(iv,:);
- T.AssignByVectors (i_n_iv,ic, ghx, iv, nullVec);//dr.ghx(iv,:);
-#ifdef DEBUG
- mexPrintf("Completed T=A assign by vec\n");
- T.print();
-#endif
- if (n_ir1 > 0)
- {
- //A(n_iv+1:end,:) = sparse(aux(:,1),aux(:,2),ones(n_ir1,1),n_ir1,nr);
-
-#ifdef DEBUG
- mexPrintf("Create sparse\n");
-#endif
- GeneralMatrix sparse(n_ir1,nr);
- for (int i=0;i<n_ir1;++i)
- sparse.get((int)aux.get(i,0)-1,(int)aux.get(i,1)-1)=1;
-
- /* vector<int>span2end(A.numRows()-n_iv);
- for (int i=0;i<A.numRows()-n_iv;++i)
- span2end[i]=i+n_iv+1;
- A.place(sparse,n_iv,0); and T=A;
- */
-#ifdef DEBUG
- mexPrintf("T.place (sparse,n_iv,0)\n");
-#endif
- T.place(sparse,n_iv,0);
- }
-
-#ifdef DEBUG
- mexPrintf("R=B assign by vec R rows %d cols %d \n", R.numRows(), R.numCols());
-#endif
- //B(i_n_iv,:) = dr.ghu(iv,:); and R=B;
- R.AssignByVectors(i_n_iv, nullVec, ghu, iv, nullVec);
-#ifdef DEBUG
- mexPrintf("Completed R=B assign by vec\n");
- R.print();
-#endif
-
- // ys = oo_.dr.ys;
- // GeneralMatrix&ysmx = dr.getMatrixField(string("ys"));
- // SteadyState=ysmx.getData();
- return DRinfo;
- }
diff --git a/mex/sources/estimation/ioutils.h b/mex/sources/estimation/ioutils.h
deleted file mode 100644
index b7be90f178aa3f19c9feabfb3a7ff7536726e7b7..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/ioutils.h
+++ /dev/null
@@ -1,75 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-#ifndef IOUTILS_H
-#define IOUTILS_H
-#include "GeneralMatrix.h"
-#include "SylvException.h"
-#include <map>
-#include <string>
-//using namespace std;
-
-
-struct charArraySt
- {
- char ** charArrayPtr;
- int len;
- };
-
-class GeneralParams
- {
-// map <string, int> params;
-// const char *structName;
-public:
- GeneralParams(){};
- virtual ~GeneralParams(){};
- virtual string& name()=0;
- virtual void *
- getField(const string& field)=0;
- virtual double&
- getDoubleField(const string& field)=0;
- virtual string &
- getStringField(const string& field)=0;
- virtual vector<string>&
- getStringVectorField(const string& field)=0;
- virtual vector<int>&
- getIntVectorField(const string& field)=0;
- virtual Vector&
- getDoubleVectorField(const string& field)=0;
- virtual GeneralParams&
- getStructField( const string& field)=0;
- virtual char *
- getCharField(const string& field)=0;
- virtual charArraySt *
- getCharArrayField( const string& field)=0;
- // uses General Matrix from sylv library
- virtual GeneralMatrix&
- getMatrixField(const string& field)=0;
- virtual void ReorderCols(GeneralMatrix& tdx, const vector<int>&vOrder)=0;
-// virtual void ReorderCols(GeneralMatrix& tdx, const int*vOrder)=0;
- virtual void
- // overloaded pramater update "set" methods:
- setField(const string& field, const string&newVal)=0;
- virtual void
- setField(const string& field, const double val)=0;
- virtual void
- setField(const string& field, const GeneralMatrix& val)=0;
- };
-
-
-#endif
diff --git a/mex/sources/estimation/tests/DsgeLikelihood_mexf.cpp b/mex/sources/estimation/tests/DsgeLikelihood_mexf.cpp
deleted file mode 100644
index d2c67ce74af58fcfd3abd0c7189c0d3015c7311b..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/tests/DsgeLikelihood_mexf.cpp
+++ /dev/null
@@ -1,302 +0,0 @@
-/*
- * Copyright (C) 2008-2009 Dynare Team
- *
- * This file is part of Dynare.
- *
- * Dynare is free software: you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation, either version 3 of the License, or
- * (at your option) any later version.
- *
- * Dynare is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with Dynare. If not, see <http://www.gnu.org/licenses/>.
- */
-
-
-// set_state_space and kstate preamble
-// should be performed before calling DageLikelihood, not repeatedly withing dr1.
-
-/******************************************
-* mexFunction: Matlab Inerface point and the main application driver
-* for DsgeLikelihood
-*****************************************************************
-% function [fval,cost_flag,ys,trend_coeff,info] = DsgeLikelihood(xparam1,gend,data,data_index,
-% number_of_observations,no_more_missing_observations)
-% Evaluates the posterior kernel of a dsge model.
-%
-% INPUTS
-% xparam1 [double] vector of model parameters.
-% gend [integer] scalar specifying the number of observations.
-% data [double] matrix of data
-% data_index [cell] cell of column vectors
-% number_of_observations [integer]
-% no_more_missing_observations [integer]
-%
-% OUTPUTS
-% fval : value of the posterior kernel at xparam1.
-% cost_flag : zero if the function returns a penalty, one otherwise.
-% ys : steady state of original endogenous variables
-% trend_coeff :
-% info : vector of informations about the penalty:
-% 41: one (many) parameter(s) do(es) not satisfied the lower bound
-% 42: one (many) parameter(s) do(es) not satisfied the upper bound
-% vll : vector of time-step log-likelihoods at xparam1.
-%
-*****************************************************************/
-#include "DsgeLikelihood.h"
-
-#include "mexutils.h"
-
-extern const char *DynareParamStructsNm []={"M_", "oo_", "options_", "bayestopt_", "estim_params_", "dr"};
-extern const char* mexBase[]={"base", "caller", "global"};
-
-extern "C" {
-
-void
-mexFunction(int nlhs, mxArray *plhs[],
- int nrhs, const mxArray *prhs[])
-{
- if (nrhs < 6)
- mexErrMsgTxt("Must have at least 6 input parameters.\n");
- if (nlhs == 0)
- mexErrMsgTxt("Must have at least 1 output parameter.\n");
-
- GeneralMatrix params(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- if(1!= MIN(params.numCols(),params.numRows()))
- throw SYLV_MES_EXCEPTION("Vextor is 2D Matrix!");
- Vector xparam1(params.getData());//(params.base(), MAX(params.numCols(),params.numRows()));
- const int nper = (const int)mxGetScalar(prhs[1]); //gend
- GeneralMatrix data(mxGetPr(prhs[2]), mxGetM(prhs[2]), mxGetN(prhs[2]));
- const int num_of_observations = (const int)mxGetScalar(prhs[4]);
- const bool no_more_missing_observations= (const bool)mxGetScalar(prhs[5]);
-
-
-
- const char *dfExt = NULL; //Dyanamic file extension, e.g.".dll" or .mexw32;
- if (prhs[5] != NULL)
- {
- const mxArray *mexExt = prhs[6];
- dfExt = mxArrayToString(mexExt);
- }
-
-#ifdef DEBUG
- mexPrintf("estimation: mexExt=%s.\n", dfExt);
-#endif
-/***********
-***************/
- int numPeriods=1;
-
- //MexStruct dynareParams();
- MexStruct& dynareParams=*(new MexStruct(numParStructs));
-#ifdef DEBUG
- mexPrintf("getting dr\n");
-#endif
- MexStructParam& dr=dynareParams.getMexStructField("dr");
- vector<int>&mfys=dynareParams.getIntVectorField("mfys");
- vector<int>&mf=dynareParams.getIntVectorField("mf1");
-#ifdef DEBUG
- mexPrintf("getting SS\n");
-#endif
- Vector& SteadyState=dr.getDoubleVectorField(string("ys"));
-#ifdef DEBUG
- int gg;
- for ( gg=0;gg<SteadyState.length();++gg)
- mexPrintf("SteadyState %d = %f\n", gg, SteadyState[gg]);
-#endif
-
- int numVarobs=data.numRows();
-
- Vector constant(numVarobs);//=*(new Vector(numVarobs));// = *(new Vector(nobs));
- GeneralMatrix&kstate = dr.getMatrixField(string("kstate"));
- vector<int>&order_var = dr.getIntVectorField(string("order_var"));
-#ifdef DEBUG
- for ( gg=0;gg<order_var.size();++gg)
- mexPrintf("order_var %d = %d\n", gg, order_var[gg]);
-#endif
- int order=(int)dynareParams.getDoubleField(string("order"));
- int endo_nbr = (int)dynareParams.getDoubleField(string("endo_nbr"));
- int exo_nbr = (int)dynareParams.getDoubleField(string("exo_nbr"));
- int nstatic = (int)dr.getDoubleField(string("nstatic"));
- int npred = (int)dr.getDoubleField(string("npred"));
- int nfwrd = (int)dr.getDoubleField(string("nfwrd"));
- Vector& ub=dynareParams.getDoubleVectorField(string("ub"));
- Vector& lb=dynareParams.getDoubleVectorField(string("lb"));
-#ifdef DEBUG
- for ( gg=0;gg<lb.length();++gg)
- mexPrintf("lb %d = %f\n", gg, lb[gg]);
-#endif
- int num_dp=(int)dynareParams.getDoubleField(string("np"));// no of deep params
- Vector& deepParams=*(new Vector(num_dp));
- vector<int>&pshape=dynareParams.getIntVectorField(string("pshape"));
- Vector& p6= dynareParams.getDoubleVectorField(string("p6"));
- Vector& p7= dynareParams.getDoubleVectorField(string("p7"));
- Vector& p3= dynareParams.getDoubleVectorField(string("p3"));
- Vector& p4= dynareParams.getDoubleVectorField(string("p4"));
-
- //const int jcols = nExog+nEndo+nsPred+nsForw; // Num of Jacobian columns
- int nsPred=(int)dr.getDoubleField(string("nspred"));
- int nsForw=(int)dr.getDoubleField(string("nsfwrd"));
- const int jcols = exo_nbr+endo_nbr+nsPred+nsForw;
-#ifdef DEBUG
- mexPrintf("jcols = %d, exo_nbr=%d\n", jcols, exo_nbr);
-#endif
-
- GeneralMatrix& aux = dynareParams.getMatrixField(string("restrict_aux"));
- vector<int>&iv= dynareParams.getIntVectorField(string("restrict_var_list"));
- vector<int>&ic= dynareParams.getIntVectorField(string("restrict_columns"));
-
- int nr=iv.size()+aux.numRows(); // Size of T matrix
- Vector& a_init=*(new Vector(nr));
- a_init.zeros();
-
- GeneralMatrix& Q = dynareParams.getMatrixField(string("Sigma_e"));
-#ifdef DEBUG
- Q.print();
-#endif
- GeneralMatrix& Hrtmp = dynareParams.getMatrixField(string("H"));
- GeneralMatrix * Hp;
- if (Hrtmp.numCols()==0 || Hrtmp.numRows()==0)
- {
- delete &Hrtmp;
- Hp = new GeneralMatrix(numVarobs,numVarobs);
- Hp->zeros();
-#ifdef DEBUG
- mexPrintf("finished local initialising of H \n");
-#endif
- }
- else
- Hp=&Hrtmp;
-
- GeneralMatrix& H=*Hp;
- GeneralMatrix Y(data.numRows(),data.numCols());
- GeneralMatrix T(nr,nr);
- GeneralMatrix Z(numVarobs,nr);
- Z.zeros();
- for (int i = 0;i<numVarobs;++i)
- Z.get(i,mf[i]-1)=1;
- GeneralMatrix Pstar(nr,nr);
- GeneralMatrix R(nr,exo_nbr);
- GeneralMatrix ghx(endo_nbr,nsPred);
- GeneralMatrix ghu(endo_nbr,exo_nbr);
-
-//Pinf=[]
- GeneralMatrix Pinf (nr,nr);
- Pinf.zeros();
-double loglikelihood;
- try
- {
-
-#ifdef DEBUG
- mexPrintf("Try construction of DsgeLikelihood\n");
-#endif
- DsgeLikelihood dl( a_init, Q, R,T, Z, Pstar, Pinf, H,data,Y,
- numPeriods, // const int INnumVarobs, // const int INnumTimeObs,
- order, endo_nbr, exo_nbr, nstatic, npred,nfwrd, num_of_observations,
- no_more_missing_observations, order_var, mfys, mf, xparam1,
- num_dp, deepParams, ub, lb, pshape, p6, p7, p3, p4, SteadyState, constant,
- dynareParams, dr, kstate, ghx, ghu, aux, iv, ic, jcols, dfExt);
-
-#ifdef DEBUG
- mexPrintf("Try CalcLikelihood\n");
-#endif
-#ifdef LL_TIMING_LOOP
- mexPrintf("DsgeLikelihood::CalcLikelihood: starting 1000 loops\n");
- for (int tt=0;tt<1000;++tt)
- {
-#endif
-
- loglikelihood=dl.CalcLikelihood(xparam1);
-#ifdef LL_TIMING_LOOP
- }
- mexPrintf("DsgeLikelihood::CalcLikelihood: finished 1000 loops\n");
-#endif
-/*****************************************************************
-% OUTPUTS
-% fval : value of the posterior kernel at xparam1.
-% cost_flag : zero if the function returns a penalty, one otherwise.
-% ys : steady state of original endogenous variables
-% trend_coeff :
-% info : vector of informations about the penalty:
-% vll : vector of time-step log-likelihoods at xparam1.
-*****************************************************************/
-#ifdef DEBUG
- mexPrintf("Try Outputs with nper=%d, loglikelihood = %f\n",nper,loglikelihood);
-#endif
- if (nlhs >= 1)
- plhs[0] = mxCreateDoubleScalar(loglikelihood);
- if (nlhs >= 2)
- plhs[1] = mxCreateDoubleScalar((double)dl.getCostFlag());
- if (nlhs >= 3)
- {
- plhs[2] = mxCreateDoubleMatrix(endo_nbr, 1, mxREAL);
- Vector vss(mxGetPr(plhs[2]),endo_nbr);
-
-#ifdef DEBUG
- mexPrintf("SteadyState size %d \n", dl.getSteadyState().length());
- dl.getSteadyState().print() ;
- mexPrintf("Try getSteadyState into vss size %d \n", vss.length());
-#endif
- vss= dl.getSteadyState();
- }
-/*********************
- if (nlhs >= 4)
- plhs[3] = mxCreateDoubleScalar((double)dl.getCostFlag());
- if (nlhs >= 5)
- plhs[4] = mxCreateDoubleMatrix(numVarobs,1, mxREAL);//dummy trend_coeff
- if (nlhs >= 6)
- {
- // output full log-likelihood array
- // Set the output pointer to the array of log likelihood.
- std::vector<double>& vll=dl.getLikVector();
- plhs[5] = mxCreateDoubleMatrix(nper,1, mxREAL);
- double * mxll= mxGetPr(plhs[5]);
- // assign likelihood array
- for (int j=0;j<nper;++j)
- {
- mxll[j]=vll[j];
-#ifdef DEBUG
- mexPrintf("mxll[%d]=%f vll[%d]=%f\n",j, mxll[j], i, vll[j]);
-#endif
- }
- }
-*********************/
- }
- catch (const KordException &e)
- {
- printf("Caugth Kord exception: ");
- e.print();
- mexPrintf("Caugth Kord exception: %s", e.get_message());
- return; // e.code();
- }
- catch (const TLException &e)
- {
- printf("Caugth TL exception: ");
- e.print();
- return; // 255;
- }
- catch (SylvException &e)
- {
- printf("Caught Sylv exception: ");
- e.printMessage();
- return; // 255;
- }
- catch (const DynareException &e)
- {
- printf("Caught KordpDynare exception: %s\n", e.message());
- mexPrintf("Caugth Dynare exception: %s", e.message());
- return; // 255;
- }
- catch (const ogu::Exception &e)
- {
- printf("Caught ogu::Exception: ");
- e.print();
- mexPrintf("Caugth general exception: %s", e.message());
- return; // 255;
- } //catch
- }; // end of mexFunction()
-}; // end of extern C
diff --git a/mex/sources/estimation/tests/global_access_test.cpp b/mex/sources/estimation/tests/global_access_test.cpp
deleted file mode 100644
index 7025b881ce065c3536f2c9d78a7cc471ca8cc765..0000000000000000000000000000000000000000
--- a/mex/sources/estimation/tests/global_access_test.cpp
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "mex.h"
-#include "matrix.h"
-
-extern "C" {
-
- // mexFunction: Matlab Inerface point and the main application driver
-
-void
-mexFunction(int nlhs, mxArray *plhs[],
- int nrhs, const mxArray *prhs[])
- {
-// const char *base="base";
- mxArray* options_ = mexGetVariable("caller", "options_");
-
- int kOrder;
- mxArray *mxFldp = mxGetField(options_, 0, "order");
- if (mxIsNumeric(mxFldp))
- kOrder = (int) mxGetScalar(mxFldp);
- else
- kOrder = 1;
-
- mexPrintf("order: %d \n",kOrder);
- int new_order=23;
- mxArray *mxNewOrder=mxCreateDoubleScalar((double) new_order);
- mxSetField(options_,0,"order", mxNewOrder);
- mexPutVariable("caller", "options_", options_);
- }
-}
-
-
-
-
diff --git a/mex/sources/kalman/cc/Makefile b/mex/sources/kalman/cc/Makefile
deleted file mode 100644
index db5fc8dbaaf9fc83939dbb726f20e593ee552022..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/Makefile
+++ /dev/null
@@ -1,64 +0,0 @@
-# $Id: Makefile 531 2005-11-30 13:49:48Z kamenik $
-# Copyright 2005, Ondra Kamenik
-
-#DEBUG = yes
-
-LD_LIBS := -llapack -lcblas -lf77blas -latlas -lg2c
-CC_FLAGS := -DMATLAB -DWINDOWS -DNO_BLAS_H -DNO_LAPACK_H \
- -fpic -Wall -I../sylv/cc \
- -I$(MATLAB_PATH)/extern/include #-pg
-
-ifeq ($(DEBUG),yes)
- CC_FLAGS := -DDEBUG $(CC_FLAGS) -g
-else
- CC_FLAGS := $(CC_FLAGS) -O3
-endif
-
-# Added by GP
-# LDFLAGS := -llapack -lcblas -lf77blas -latlas -lg2c -lstdc++ -lmingw32
- LDFLAGS := -Wl,--library-path $(LD_LIBRARY_PATH) \
- -Wl,-L$(MATLAB_PATH)/extern/lib/win32/microsoft/ \
- -Wl,-llibmex -Wl,-llibmx -Wl,-llibmwlapack -Wl,-llibdflapack \
- -lg2c -lmingw32 -lstdc++ $(LDFLAGS)
-
-# -Wl,-L'f:/CygWin/usr/local/atlas/lib' \
-# -Wl,-L'f:/CygWin/lib' \
-# $(LDFLAGS)
- LD_LIBS :=$(LDFLAGS)
-# end add
-
-matrix_interface := GeneralMatrix Vector SylvException
-matobjs := $(patsubst %, ../sylv/cc/%.o, $(matrix_interface))
-mathsource := $(patsubst %, ../sylv/cc/%.h, $(matrix_interface))
-matcppsource := $(patsubst %, ../sylv/cc/%.cpp, $(matrix_interface))
-cwebsource := $(wildcard *.cweb)
-# cppsource := $(patsubst %.cweb,%.cpp,$(cwebsource))
-cppsource := $(wildcard *.cpp)
-hsource := $(wildcard *.h)
-objects := $(patsubst %.cpp,%.o,$(cppsource))
-hwebsource := $(wildcard *.hweb)
-
-dummy.ch:
- touch dummy.ch
-
-# %.cpp: %.cweb dummy.ch
-# ctangle -bhp $*.cweb dummy.ch $*.cpp
-
-# %.h: %.hweb dummy.ch
-# ctangle -bhp $*.hweb dummy.ch $*.h
-
-%.o: %.cpp $(hsource) $(mathsource)
- c++ $(CC_FLAGS) -c $*.cpp
-
-all: $(objects) # $(cppsource) $(hsource)
-
-doc: main.web $(hwebsource) $(cwebsource)
- cweave -bhp main.web
- pdftex main
- mv main.pdf ts.pdf
-
-clear:
- rm -f *.o
- rm -f *.{pdf,dvi,log,scn,idx,toc}
-# rm -f *.cpp
-# rm -f *.h
diff --git a/mex/sources/kalman/cc/disclyap_fast.cpp b/mex/sources/kalman/cc/disclyap_fast.cpp
deleted file mode 100644
index 3b66c295c5927ccaf7ea7e1e97e41df1e233bf7c..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/disclyap_fast.cpp
+++ /dev/null
@@ -1,102 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-/****************************************************************
-% function X=disclyap_fast(G,V,tol,ch)
-%
-% Solve the discrete Lyapunov Equation
-% X=G*X*G'+V
-% Using the Doubling Algorithm
-%
-% INPUT:
-% G and V - square General matrices of same size
-% tol - double tollerance level
-% flag_ch - integer flag: if 1 check if the result is positive
-% definite and generate an error message if it is not
-% OUTPUT:
-% on completion V - square General matrice contains solution
-%
-% based on work of Joe Pearlman and Alejandro Justiniano
-% 3/5/2005
-% C++ version 28/07/09 by Dynare team
-****************************************************************/
-#include "ts_exception.h"
-#include "cppblas.h"
-#include "GeneralMatrix.h"
-//#include "Vector.h"
-#include "SylvException.h"
-#include "utils.h"
-#include "mex.h"
-
-void disclyap_fast(const GeneralMatrix &G, const GeneralMatrix & V, GeneralMatrix &X, double tol = 1e-16, int flag_ch=0)
- {
- /**
- if nargin == 2 | isempty( ch ) == 1
- flag_ch = 0;
- else
- flag_ch = 1;
- end
- **/
- //P0=V;
- GeneralMatrix P0(V);
- //A0=G;
- GeneralMatrix A0(G);
-
- //n=size(G,1);
- int n= A0.numCols();
- const double alpha=1.0;
- const double half=0.5;
- const double neg_alpha=-1.0;
- const double omega=0.0;
-
- GeneralMatrix A1(n,n);
- GeneralMatrix Ptmp(n,n);
- GeneralMatrix P1(P0);
- GeneralMatrix I(n,n);
- I.unit();
- bool matd=true;
- while (matd ) // matrix diff > tol
- {
- //P1=P0+A0*P0*A0';
- // first step Ptmp=P0*A0';
- // DGEMM: C := alpha*op( A )*op( B ) + beta*C,
- BLAS_dgemm("N", "T", &n, &n, &n, &alpha, P0.base(), &n,
- A0.base(), &n, &omega, Ptmp.base(), &n);
- // P1=P0+A0*Ptmp;
- BLAS_dgemm("N", "N", &n, &n, &n, &alpha, A0.base(), &n,
- Ptmp.base(), &n, &alpha, P1.base(), &n);
- // A1=A0*A0;
- // A0=A1 (=A0*A0);
- // A0.multRight(A0);
- BLAS_dgemm("N", "N", &n, &n, &n, &alpha, A0.base(), &n,
- A0.base(), &n, &omega, A1.base(), &n);
-
- // check if max( max( abs( P1 - P0 ) ) )>tol
- matd=P0.isDiffSym(P1, tol);
- P0=P1;
- A0=A1;
- }//end while
-
- // X=P0=(P0+P0')/2;
- BLAS_dgemm("T", "N", &n, &n, &n, &half, P1.base(), &n,
- I.base(), &n, &half, P0.base(), &n);
- X=P0;
- // Check that X is positive definite
- if (flag_ch==1)
- NormCholesky chol(P0);
- }
diff --git a/mex/sources/kalman/cc/disclyap_fast.h b/mex/sources/kalman/cc/disclyap_fast.h
deleted file mode 100644
index abf7bca34485c280c9007b01dcbcaa6dc4df908c..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/disclyap_fast.h
+++ /dev/null
@@ -1,34 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-/****************************************************************
-% function X=disclyap_fast(G,V,ch)
-%
-% Solve the discrete Lyapunov Equation
-% X=G*X*G'+V
-% Using the Doubling Algorithm
-%
-% If ch is defined then the code will check if the resulting X
-% is positive definite and generate an error message if it is not
-%
-% based on work of Joe Pearlman and Alejandro Justiniano
-% 3/5/2005
-% C++ version 28/07/09 by Dynare team
-****************************************************************/
-#include "GeneralMatrix.h"
-void disclyap_fast(const GeneralMatrix &G, const GeneralMatrix & V, GeneralMatrix &X, double tol, int ch);
diff --git a/mex/sources/kalman/cc/kalman.cpp b/mex/sources/kalman/cc/kalman.cpp
deleted file mode 100644
index 1d53280ee2944208721cf942f708eefad10dc06f..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/kalman.cpp
+++ /dev/null
@@ -1,2481 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-/*****************
-The file is divided into two parts, routines for multivariate filtering
-and smoothing and univariate ones. The only reason for keeping these in one
-file, is that the univariate routines use code bits from multivariate
-routines.
-*****************/
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "cppblas.h"
-//#include "cpplapack.h"
-
-#include <math.h>
-#include <float.h>
-#include <cmath>
-
-/*****************
-We delete everything which is not |NULL|. This is important, since
-it may happen that the reults are not filled completely. (For instance
-in the beginning or if error eccurred.)
-*****************/
-
-FilterResults::~FilterResults()
- {
- for(unsigned int i= 0;i<Finv.size();i++){
- if(Finv[i])
- delete Finv[i];
- if(v[i])
- delete v[i];
- if(L[i])
- delete L[i];
- if(a[i])
- delete a[i];
- if(P[i])
- delete P[i];
- }
- }
-
- /*****************
- We delete what is allocated and is in the way of the new data. Then
- set the new data as copies.
-*****************/
-void
-FilterResults::set(int t,const PLUFact&FFinv,const Vector&vv,
- const GeneralMatrix&LL,const Vector&aa,
- const GeneralMatrix&PP,double ll)
- {
- TS_RAISE_IF(t<1||t> (int)Finv.size()+1,
- "Wrong time for FilterResults::set");
-
- int tm= t-1;
- if(Finv[tm])
- delete Finv[tm];
- if(v[tm])
- delete v[tm];
- if(L[tm])
- delete L[tm];
- if(a[tm])
- delete a[tm];
- if(P[tm])
- delete P[tm];
-
- if(t> maxt)
- maxt= t;
-
- Finv[tm]= new PLUFact(FFinv);
- v[tm]= new Vector(vv);
- L[tm]= new GeneralMatrix(LL);
- a[tm]= new Vector(aa);
- P[tm]= new GeneralMatrix(PP);
- loglik[tm]= ll;
- }
-
-const PLUFact&FilterResults::getFInverse(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getFInverse");
- return*(Finv[t-1]);
- }
-
-const Vector&FilterResults::getV(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getV");
- return*(v[t-1]);
- }
-
-const GeneralMatrix&FilterResults::getL(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getL");
- return*(L[t-1]);
- }
-
-const Vector&FilterResults::getA(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getA");
- return*(a[t-1]);
- }
-
-const GeneralMatrix&FilterResults::getP(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getP");
- return*(P[t-1]);
- }
-
- /*****************
- This adds all the log likelihoods for all periods. If some periods
- in the results have not been set, these are initialized to zeros and
- thus this method is pretty safe but may not be if the likelihood tends to
- be far lower or higher than 0.
-*****************/
-
-double
-FilterResults::getLogLikelihood()const
- {
- double res= 0.0;
- for(unsigned int i= 0;i<loglik.size();i++)
- res+= loglik[i];
- return res;
- }
-
-double
-FilterResults::getLogLikelihood(int start)const
- {
- double res= 0.0;
- for(unsigned int i= start;i<loglik.size();i++)
- res+= loglik[i];
- return res;
- }
-
-double
-FilterResults::getLogLikelihood(std::vector<double>* vloglik)const
- {
- double res= 0.0;
- for(unsigned int i= 0;i<loglik.size();i++)
- res+= loglik[i];
- *vloglik= loglik;
- return res;
- }
-
-double
-FilterResults::getLogLikelihood(int start,std::vector<double>* vloglik)const
- {
- double res= 0.0;
- for(unsigned int i= start;i<loglik.size();i++)
- res+= loglik[i];
- *vloglik= loglik;
- return res;
- }
-
-DiffuseFilterResults::~DiffuseFilterResults()
- {
- for(unsigned int i= 0;i<L_1.size();i++){
- if(L_1[i])
- delete L_1[i];
- if(Pinf[i])
- delete Pinf[i];
- if(F_2[i])
- delete F_2[i];
- }
- }
-
-
-bool
-DiffuseFilterResults::isFinfRegular(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterResults::isFinfRegular");
- return Finf_reg[t-1];
- }
-
-
-
-bool
-DiffuseFilterResults::isPinfZero(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterResults::isPinfZero");
- return Pinf_zero[t-1];
- }
-
- /*****************
- Here we raise an error on attempt to retrieve inverse of $F_\infty$
- for a period in which it was not regular. Caller has to call
- |isFinfRegular| first.
-*****************/
-
-const PLUFact&DiffuseFilterResults::getFinfInverse(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterResults::getFinfInverse");
- TS_RAISE_IF(!isFinfRegular(t),
- "Finf not regular in the period in DiffuseFilterResults::getFinfInverse");
- return getFInverse(t);
- }
-
- /*****************
- Here we issue an error on attempt to retrieve inverse of $F_*$ for a
- period when $F_\infty$ was regular.
-*****************/
-
-const PLUFact&DiffuseFilterResults::getFstarInverse(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterResults::getFstarInverse");
- TS_RAISE_IF(isFinfRegular(t),
- "Finf not zero in the period in DiffuseFilterResults::getFstarInverse");
- return getFInverse(t);
- }
-
- /*****************
- This should be called only when $F_\infty$ was regular, we raise an
- error otherwise.
-*****************/
-
-const GeneralMatrix&DiffuseFilterResults::getF2(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getF2");
- TS_RAISE_IF(!isFinfRegular(t),
- "Finf not regular in the period in DiffuseFilterResults::getF2");
- return*(F_2[t-1]);
- }
-
- /*****************
- This should be called only when $F_\infty$ was regular, we raise an
- error otherwise.
-*****************/
-
-const GeneralMatrix&DiffuseFilterResults::getL1(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getL1");
- TS_RAISE_IF(!isFinfRegular(t),
- "Finf not regular in the period in DiffuseFilterResults::getL1");
- return*(L_1[t-1]);
- }
-
- /*****************
- The $P_\infty$ should be retrieved only if it is not zero, (these
- are all diffuse periods)
-*****************/
-
-const GeneralMatrix&DiffuseFilterResults::getPinf(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterResults::getPinf");
- TS_RAISE_IF(isPinfZero(t),
- "Pinf is zero in the period in DiffuseFilterResults::getPinf");
- return*(L_1[t-1]);
- }
-
- /*****************
- This sets the diffuse results for diffuse periods when
- $F_\infty$ is regular. Note that in this case the inverse
- $F_\infty^{-1}$ is stored as $F^{-1}$ of |FilterResults|, and thus is
- returned by call |getFinfInverse|. Also, $L^{(0)}$ is stored as $L$ of
- |FilterResults|, and retrieved by |getL0()| which is equivalent to
- |FilterResults::getL()| (see |@<|DiffuseFilterResults| class
- declaration@>|).
-*****************/
-
-void DiffuseFilterResults::set(int t,const PLUFact&FFinv,const GeneralMatrix&FF_2,
- const Vector&vv,const GeneralMatrix&LL_0,
- const GeneralMatrix&LL_1,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll)
- {
- FilterResults::set(t,FFinv,vv,LL_0,aa,PPstar,ll);
-
- int tm= t-1;
- if(L_1[tm])
- delete L_1[tm];
- if(Pinf[tm])
- delete Pinf[tm];
- if(F_2[tm])
- delete F_2[tm];
-
- L_1[tm]= new GeneralMatrix(LL_1);
- Pinf[tm]= new GeneralMatrix(PPinf);
- F_2[tm]= new GeneralMatrix(FF_2);
- Finf_reg[tm]= true;
- Pinf_zero[tm]= false;
- }
-
- /*****************
- This sets the diffuse results for diffuse period when the $F_\infty$
- is zero. We do not set $F^{(2)}$, and we set $F_*^{-1}$ instead of
- $F_\infty^{-1}$.
-*****************/
-
-void DiffuseFilterResults::set(int t,const PLUFact&FFstarinv,const Vector&vv,
- const GeneralMatrix&LL_0,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll)
- {
- FilterResults::set(t,FFstarinv,vv,LL_0,aa,PPstar,ll);
-
- int tm= t-1;
- if(Pinf[tm])
- delete Pinf[tm];
- Pinf[tm]= new GeneralMatrix(PPinf);
-
- Finf_reg[tm]= false;
- Pinf_zero[tm]= false;
- }
-
- /*****************
- This returns number of initial diffuse periods (those having
- $P_\infty$ non-zero)
-*****************/
-
-int DiffuseFilterResults::getDiffusePeriods()const
- {
- int d= maxt;
- while(d> 1&&isPinfZero(d))
- d--;
- return d;
- }
-
-
-;
-
-SmootherResults::~SmootherResults()
- {
- for(unsigned int i= 0;i<alpha.size();i++){
- if(alpha[i])
- delete alpha[i];
- if(eta[i])
- delete eta[i];
- if(V[i])
- delete V[i];
- }
- }
-
-;
-
-void SmootherResults::set(int t,const Vector&aalpha,const Vector&eeta,
- const GeneralMatrix&VV)
- {
- TS_RAISE_IF(t<1||t> (int)alpha.size()+1,
- "Wrong time for SmootherResults::set");
- if(t<mint)
- mint= t;
- int tm= t-1;
- if(alpha[tm])
- delete alpha[tm];
- if(eta[tm])
- delete eta[tm];
- if(V[tm])
- delete V[tm];
-
- alpha[tm]= new Vector(aalpha);
- eta[tm]= new Vector(eeta);
- V[tm]= new GeneralMatrix(VV);
- }
-
- /*****************
- This takes a |SmootherResults| coming from a univariate filter with
- a given number of observations at one time. This number of
- observations becomes a periodicity in the univariate
- |SmootherResults|. If this perioidicty is 10, we take data for
- $t=10,20,30,\ldots$.)
-*****************/
-
-void SmootherResults::import(const SmootherResults&sres,int period)
- {
- TS_RAISE_IF(period*alpha.size()!=sres.alpha.size(),
- "Results lengths not compatible with period in SmootherResults::import");
- TS_RAISE_IF(sres.mint!=1,
- "Results not finished in SmootherResults::import");
- for(unsigned int tm= 0;tm<alpha.size();tm++){
- if(alpha[tm])
- delete alpha[tm];
- if(eta[tm])
- delete eta[tm];
- if(V[tm])
- delete V[tm];
- alpha[tm]= new Vector((const Vector&)*sres.alpha[(tm+1)*period-1]);
- eta[tm]= new Vector((const Vector&)*sres.eta[(tm+1)*period-1]);
- V[tm]= new GeneralMatrix((const GeneralMatrix&)*sres.V[(tm+1)*period-1]);
- }
-
- mint= 1;
- }
-
- /*****************
- This saves |alpha| to the given matrix.
-*****************/
-
-void
-SmootherResults::exportAlpha(GeneralMatrix&out)const
- {
- TS_RAISE_IF(mint> 1,
- "Results not finished in SmootherResults::exportAlpha");
- TS_RAISE_IF(out.numCols()!=(int)alpha.size(),
- "Wrong number of columns in SmootherResults::exportAlpha");
- TS_RAISE_IF(alpha[0]->length()!=out.numRows(),
- "Wrong number of rows in SmootherResults::exportAlpha");
- for(unsigned int tm= 0;tm<alpha.size();tm++)
- {
- Vector outi(out,tm);
- outi= (const Vector&)(*alpha[tm]);
- }
- }
-
- /*****************
- This saves |eta| to the given matrix.
-*****************/
-
-void
-SmootherResults::exportEta(GeneralMatrix&out)const
- {
- TS_RAISE_IF(mint> 1,
- "Results not finished in SmootherResults::exportEta");
- TS_RAISE_IF(out.numCols()!=(int)eta.size(),
- "Wrong number of columns in SmootherResults::exportEta");
- TS_RAISE_IF(eta[0]->length()!=out.numRows(),
- "Wrong number of rows in SmootherResults::exportEta");
- for(unsigned int tm= 0;tm<eta.size();tm++)
- {
- Vector outi(out,tm);
- outi= (const Vector&)(*eta[tm]);
- }
- }
-
- /*****************
- This saves $V$ to the given two dimensional matrix. We store the $V$
- matrices one by one columnwise. The storage corresponds to Matlab
- storage of three dimensional matrices.
-*****************/
-
-void SmootherResults::exportV(GeneralMatrix&out)const
- {
- TS_RAISE_IF(mint> 1,
- "Results not finished in SmootherResults::exportV");
- int m= V[0]->numRows();
- TS_RAISE_IF(out.numCols()!=(int)V.size()*m,
- "Wrong number of columns in SmootherResults::exportV");
- TS_RAISE_IF(m!=out.numRows(),
- "Wrong number of rows in SmootherResults::exportV");
- for(unsigned int tm= 0;tm<V.size();tm++)
- {
- GeneralMatrix outi(out,0,tm*m,m,m);
- outi= (const GeneralMatrix&)(*V[tm]);
- }
- }
-
-BasicKalmanTask::BasicKalmanTask(const GeneralMatrix&d,const GeneralMatrix&ZZ,
- const GeneralMatrix&HH,const GeneralMatrix&TT,
- const GeneralMatrix&RR,const GeneralMatrix&QQ,
- const StateInit&init_state, const double rTol)
- : // ssf(Z,H,T,R,Q),
-data(d), Zt(*(new ConstGeneralMatrix(ZZ))),
-Ht(*(new ConstGeneralMatrix(HH))),
-Tt(*(new ConstGeneralMatrix(TT))),
-Rt(*(new ConstGeneralMatrix(RR))),
-Qt(*(new ConstGeneralMatrix(QQ))),
-init(init_state),
-riccatiTol(rTol)
- {
- TS_RAISE_IF(d.numRows()!=Zt.numRows(),
- "Data not compatible with BasicKalmanTask constructor");
- // TS_RAISE_IF(ssf.m!=init.getM(),
- // "State initialization not compatible with SSF in KalmanTask constructor");
- }
-
-BasicKalmanTask::BasicKalmanTask(const GeneralMatrix&d,const ConstGeneralMatrix&ZZ,
- const ConstGeneralMatrix&HH,const ConstGeneralMatrix&TT,
- const ConstGeneralMatrix&RR,const ConstGeneralMatrix&QQ,
- const StateInit&init_state, const double rTol)
- : // ssf(Z,H,T,R,Q),
-data(d), Zt(ZZ), Ht(HH), Tt(TT), Rt(RR), Qt(QQ),init(init_state), riccatiTol(rTol)
- {
- TS_RAISE_IF(d.numRows()!=Zt.numRows(),
- "Data not compatible with BasicKalmanTask constructor");
- // TS_RAISE_IF(ssf.m!=init.getM(),
- // "State initialization not compatible with SSF in KalmanTask constructor");
- }
-
-
-BasicKalmanTask::~BasicKalmanTask()
- {
- if (&Zt);
- delete &Zt;
- if (&Ht);
- delete &Ht;
- if (&Tt);
- delete &Tt;
- if (&Rt);
- delete &Rt;
- if (&Qt);
- delete &Qt;
- }
-
-KalmanTask::KalmanTask(const GeneralMatrix&d,const GeneralMatrix&Z,
- const GeneralMatrix&H,const GeneralMatrix&T,
- const GeneralMatrix&R,const GeneralMatrix&Q,
- const StateInit&init_state)
- :ssf(Z,H,T,R,Q),
- data(d),
- init(init_state)
- {
- TS_RAISE_IF(d.numRows()!=Z.numRows(),
- "Data not compatible with SSF in KalmanTask constructor");
- TS_RAISE_IF(ssf.m!=init.getM(),
- "State initialization not compatible with SSF in KalmanTask constructor");
- }
-
-KalmanTask::KalmanTask(const GeneralMatrix&d,const TMatrix&Z,
- const TMatrix&H,const TMatrix&T,
- const TMatrix&R,const TMatrix&Q,
- const StateInit&init_state)
- :ssf(Z,H,T,R,Q),
- data(d),
- init(init_state)
- {
- TS_RAISE_IF(d.numRows()!=Z.numRows(),
- "Data not compatible with SSF in KalmanTask constructor");
- TS_RAISE_IF(ssf.m!=init.getM(),
- "State initialization not compatible with SSF in KalmanTask constructor");
- }
-
- /*****************
- This is a public interface to mechanism that filters data and returns
- the data loglikelihood. In addition,
- it returns the number of periods |per| successfully filtered. If the
- filter failed to filter entire data, than the resulting |per| is less
- than a number of columns in the |data|. This might be caused by
- singular $F$ matrix, or by singular and non-zero $F_\infty$
- matrix. Further it returns a number od diffuse initial periods, in
- case of non-diffuse initialization, zero is returned.
-*****************/
-double
-KalmanTask::filter(int&per,int&d)const
- {
- if(!init.isDiffuse())
- {
- FilterResults fres(data.numCols());
- filterNonDiffuse(init.getA(),init.getPstar(),1,fres);
- d= 0;
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood();
- }
- else
- {
- DiffuseFilterResults fres(data.numCols());
- filterDiffuse(init.getA(),init.getPstar(),init.getPinf(),
- 1,fres);
- d= fres.getDiffusePeriods();
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood();
- }
- return 0.0;
- }
-
-double
-KalmanTask::filter(int&per,int&d, int start, std::vector<double>* vll)const
- {
- if(!init.isDiffuse())
- {
- FilterResults fres(data.numCols());
- filterNonDiffuse(init.getA(),init.getPstar(),1,fres);
- d= 0;
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood(start, vll);
- }
- else
- {
- DiffuseFilterResults fres(data.numCols());
- filterDiffuse(init.getA(),init.getPstar(),init.getPinf(),
- 1,fres);
- d= fres.getDiffusePeriods();
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood(start, vll);
- }
- return 0.0;
- }
-
-double
-BasicKalmanTask::filter(int&per,int&d, int start, std::vector<double>* vll)const
- {
- d= 0;
- per= vll->size() ;
- return filterNonDiffuse(init.getA(),init.getPstar(), start, vll);
- }
-
-/*****************
- This is public interface that runs a filter followed by a smoother.
- In addition to things returned by |KalmanTask::filter|, it fills also
- |SmootherResults|, which must be initialized to the number of columns
- of the |data|.
-*****************/
-double
-KalmanTask::filter_and_smooth(SmootherResults&sres,
- int&per,int&d)const
- {
- if(!init.isDiffuse())
- {
- FilterResults fres(data.numCols());
- filterNonDiffuse(init.getA(),init.getPstar(),1,fres);
- d= 0;
- per= fres.getMaxT();
- if(fres.hasFinished())
- {
- smootherNonDiffuse(fres,sres);
- return fres.getLogLikelihood();
- }
- }
- else
- {
- DiffuseFilterResults fres(data.numCols());
- filterDiffuse(init.getA(),init.getPstar(),init.getPinf(),
- 1,fres);
- d= fres.getDiffusePeriods();
- per= fres.getMaxT();
- if(fres.hasFinished())
- {
- smootherDiffuse(fres,sres);
- return fres.getLogLikelihood();
- }
- }
- return 0.0;
- }
-
-
-/*****************
- This runs a Basic non-diffuse filter with the given $t$, $a_t$ and
- $P_t$. It fills the |FilterResults|.
-
- First we check that the passed $P_t$ is positive definite by checking
- that it has not negative diagonal and is symmetric diagonally
- dominant. This is not equivalent to positive definitness but it excludes
- ``much'' of indefinite matrices. This check is important since this
- routine is called from a diffuse filter and it is possible due to a
- wrong guess/calculation of a number of diffuse periods that numerical
- instability and roundoff errors make the matrix $P_*$ broken.
-
- Then we cycle until the end of period and perform a classical Kalman
- filter operations.
-*****************/
-double
-BasicKalmanTask::filterNonDiffuse(const Vector&a,const GeneralMatrix&P,
- int start, std::vector<double>* vll)const
- {
- double loglik=0;
- Vector at(a);
- GeneralMatrix Pt(P);
-// GeneralMatrix PtZeros(Pt.numRows(), Pt.numCols());
-// PtZeros.zeros();
- if(TSUtils::hasNegativeDiagonal(Pt)||!TSUtils::isSymDiagDominant(Pt))
- return 0.0;
- const int m=Pt.numRows();
- const int n=Zt.numRows();
- int inc =1;
- const int rcols= Rt.numCols();
- GeneralMatrix Ft (Ht.numRows(), Ht.numCols() );
- PLUFact Ftinv(Ht.numRows(), Ht.numCols());
- GeneralMatrix Lt(Tt);
- GeneralMatrix PtLttrans(m,m);
- GeneralMatrix PtOld(m,m);
- GeneralMatrix Mt(m,n);
- GeneralMatrix Kt(m,n);
- GeneralMatrix KtTransTmp(n,m); // perm space for temp Kt trans
- GeneralMatrix QtRttrans(rcols,Rt.numRows());
-
- bool isTunit=0;// Tt->isUnit();
- bool isQzero= Qt.isZero();
- bool isRzero= Rt.isZero();
- const double alpha=1.0;
- const double neg_alpha=-1.0;
- const double omega=0.0;
- Vector vt(n);
- Vector Finvv(n);
- Vector atsave(m);//((const Vector&)at);
- int p;
- int t= 1;
- double vFinvv,ll;
- bool nonSteady=true;
- for(;t<=data.numCols()&&nonSteady;++t)
- {
-// ConstVector yt(data,t-1);
-
- /*****************
- This calculates $$v_t = y_t - Z_t*a_t.$$
- *****************/
-// Vector vt(yt);
-// vt=yt;
- memcpy(vt.base(), &(data.get(0,t-1)), n*sizeof(double));
-// Zt.multsVec(vt,at);
- BLAS_dgemv("N", &n, &m, &neg_alpha, Zt.base(), &n, at.base(),
- &inc, &alpha, vt.base(), &inc);
-
- /*****************
- This calculates $$F_t = Z_tP_tZ_t^T+H_t.$$
- *****************/
-// GeneralMatrix Mt(Pt,Zt,"trans");
- BLAS_dgemm("N", "T", &m, &n, &m, &alpha, Pt.base(), &m,
- Zt.base(), &n, &omega, Mt.base(), &m);
-
-// GeneralMatrix Ft(Ht);
- Ft=Ht;
-// Ft.multAndAdd(Zt,ConstGeneralMatrix(Mt));
- // DGEMM: C := alpha*op( A )*op( B ) + beta*C,
- BLAS_dgemm("N", "N", &n, &n, &m, &alpha, Zt.base(), &n,
- Mt.base(), &m, &alpha, Ft.base(), &n);
-
-// PLUFact Ftinv(Ft);
-// if(!Ftinv.isRegular())
-// return 0.0;
- Ftinv=Ft;
- /*****************
- This calculates $$K_t = T_tP_tZ_t^TF_t^{-1}.$$
- *****************/
-// GeneralMatrix Kt(Tt,Mt);
- BLAS_dgemm("N", "N", &m, &n, &m, &alpha, Tt.base(), &m,
- Mt.base(), &m, &omega, Kt.base(), &m);
-// Ftinv.multInvRight(Kt);
- Ftinv.multInvRight(Kt, KtTransTmp); // using perm space for temp KT trans
-// Kt.multInvRight(Ft);
-
- /*****************
- This calculates $$L_t = T_t-K_tZ_t.$$
- *****************/
- //GeneralMatrix Lt(Tt);
- Lt=Tt;
- //Lt.multAndAdd(ConstGeneralMatrix(Kt),Zt,-1.0);
- // DGEMM: C := alpha*op( A )*op( B ) + beta*C,
- BLAS_dgemm("N", "N", &m, &m, &n, &neg_alpha, Kt.base(), &m,
- Zt.base(), &n, &alpha, Lt.base(), &m);
-
-
- /*****************
- Here we calc likelihood and store results.
- *****************/
- // double ll= calcStepLogLik(Ftinv,vt);
- p= Ftinv.numRows();
- Finvv=vt;
- Ftinv.multInvLeft(Finvv);
- vFinvv= vt.dot(Finvv);
- ll=-0.5*(p*log(2*M_PI)+Ftinv.getLogDeterminant()+vFinvv);
-
- // fres.set(t,Ftinv,vt,Lt,at,Pt,ll);
- (*vll)[t-1]=ll;
- if (t>start) loglik+=ll;
-
- if(t<data.numCols())
- {
- /*****************
- This calculates $$a_{t+1} = T_ta_t + K_tv_t.$$
- *****************/
- if(!isTunit)
- {
-// Vector atsave((const Vector&)at);
- atsave=at;
- Tt.multVec(0.0,at,1.0,atsave);
- }
- Kt.multVec(1.0,at,1.0,ConstVector(vt));
-
- /*****************
- This calculates $$P_{t+1} = T_tP_tL_t^T + R_tQ_tR_t^T.$$
- *****************/
- PtOld=Pt;
-// GeneralMatrix PtLttrans(Pt,Lt,"trans");
- // DGEMM: C := alpha*op( A )*op( B ) + beta*C,
- BLAS_dgemm("N", "T", &m, &m, &m, &alpha, Pt.base(), &m,
- Lt.base(), &m, &omega, PtLttrans.base(), &m);
- if(!isTunit)
- {
-// Pt.zeros();
-// Pt=PtZeros;
-// Pt.multAndAdd(Tt,ConstGeneralMatrix(PtLttrans));
- // DGEMM: C := alpha*op( A )*op( B ) + beta*C,
- BLAS_dgemm("N", "N", &m, &m, &m, &alpha, Tt.base(), &m,
- PtLttrans.base(), &m, &omega, Pt.base(), &m);
- }
- else
- {
- Pt= (const GeneralMatrix&)PtLttrans;
- }
- if(!isRzero&&!isQzero)
- {
-// GeneralMatrix QtRttrans(Qt,Rt,"trans");
- BLAS_dgemm("N", "T", &rcols, &m, &rcols, &alpha, Qt.base(), &rcols,
- Rt.base(), &m, &omega, QtRttrans.base(), &rcols);
-
- // Pt.multAndAdd(Rt,ConstGeneralMatrix(QtRttrans));
- // DGEMM: C := alpha*op( A )*op( B ) + beta*C,
- BLAS_dgemm("N", "N", &m, &m, &rcols, &alpha, Rt.base(), &m,
- QtRttrans.base(), &rcols, &alpha, Pt.base(), &m);
- }
- if (PtOld.isDiffSym(Pt, riccatiTol)==false)
- nonSteady=false;
- }
- }
-
-
-// for(;t<=data.numCols();t++)
-// {
-// ConstVector yt(data,t-1);
-// }
-
- // Steady
- double detF=p*log(2*M_PI)+Ftinv.getLogDeterminant();
-#ifdef DEBUG
- if (nonSteady==false)
- mexPrintf("Basickalman_filter Steady at t=%d / %d \n", t,data.numCols());
-#endif
-
- for(;t<=data.numCols();++t)
- {
- /*****************
- This calculates $$v_t = y_t - Z_t*a_t.$$
- *****************/
- memcpy(vt.base(), &(data.get(0,t-1)), n*sizeof(double));
-// Zt.multsVec(vt,at);
- BLAS_dgemv("N", &n, &m, &neg_alpha, Zt.base(), &n, at.base(),
- &inc, &alpha, vt.base(), &inc);
-
- /*****************
- Here we calc likelihood and store results.
- *****************/
- // double ll= calcStepLogLik(Ftinv,vt);
- Finvv=vt;
- Ftinv.multInvLeft(Finvv);
- vFinvv= vt.dot(Finvv);
- ll=-0.5*(detF+vFinvv);
-
- // fres.set(t,Ftinv,vt,Lt,at,Pt,ll);
- (*vll)[t-1]=ll;
- if (t>start) loglik+=ll;
-
- if(t<data.numCols())
- {
- /*****************
- This calculates $$a_{t+1} = T_ta_t + K_tv_t.$$
- *****************/
- atsave=at;
- Tt.multVec(0.0,at,1.0,atsave);
- Kt.multVec(1.0,at,1.0,ConstVector(vt));
- }
- }
-
- return loglik;
- }
-
-
- double
- BasicKalmanTask::calcStepLogLik(const PLUFact&Finv,const Vector&v)
- {
- int p= Finv.numRows();
- Vector Finvv(v);
- Finv.multInvLeft(Finvv);
- double vFinvv= v.dot(Finvv);
- return-0.5*(p*log(2*M_PI)+Finv.getLogDeterminant()+vFinvv);
- }
-
-
-/*****************
-This runs a non-diffuse filter with the given $t$, $a_t$ and
-$P_t$. It fills the |FilterResults|.
-
-First we check that the passed $P_t$ is positive definite by checking
-that it has not negative diagonal and is symmetric diagonally
-dominant. This is not equivalent to positive definitness but it excludes
-``much'' of indefinite matrices. This check is important since this
-routine is called from a diffuse filter and it is possible due to a
-wrong guess/calculation of a number of diffuse periods that numerical
-instability and roundoff errors make the matrix $P_*$ broken.
-
-Then we cycle until the end of period and perform a classical Kalman
-filter operations.
-*****************/
-void
-KalmanTask::filterNonDiffuse(const Vector&a,const GeneralMatrix&P,
-int first,FilterResults&fres)const
- {
- Vector at(a);
- GeneralMatrix Pt(P);
- if(TSUtils::hasNegativeDiagonal(Pt)||!TSUtils::isSymDiagDominant(Pt))
- return;
-
- for(int t= first;t<=data.numCols();t++)
- {
- ConstVector yt(data,t-1);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- ConstGeneralMatrix Ht(((const TMatrix&)*ssf.H)[t]);
- ConstGeneralMatrix Tt(((const TMatrix&)*ssf.T)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isTunit= ssf.T->isUnit(t);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
- /*****************
- This calculates $$v_t = y_t - Z_t*a_t.$$
- *****************/
- Vector vt(yt);
- Zt.multsVec(vt,at);
-
- /*****************
- This calculates $$F_t = Z_tP_tZ_t^T+H_t.$$
- *****************/
- GeneralMatrix Mt(Pt,Zt,"trans");
- GeneralMatrix Ft(Ht);
- Ft.multAndAdd(Zt,ConstGeneralMatrix(Mt));
-
-
- PLUFact Ftinv(Ft);
- if(!Ftinv.isRegular())
- return;
-
- /*****************
- This calculates $$K_t = T_tP_tZ_t^TF_t^{-1}.$$
- *****************/
- GeneralMatrix Kt(Tt,Mt);
- Ftinv.multInvRight(Kt);
-
- /*****************
- This calculates $$L_t = T_t-K_tZ_t.$$
- *****************/
- GeneralMatrix Lt(Tt);
- Lt.multAndAdd(ConstGeneralMatrix(Kt),Zt,-1.0);
-
-
- /*****************
- Here we calc likelihood and store results.
- *****************/
- double ll= calcStepLogLik(Ftinv,vt);
- fres.set(t,Ftinv,vt,Lt,at,Pt,ll);
-
- if(t<data.numCols())
- {
- /*****************
- This calculates $$a_{t+1} = T_ta_t + K_tv_t.$$
- *****************/
- if(!isTunit)
- {
- Vector atsave((const Vector&)at);
- Tt.multVec(0.0,at,1.0,atsave);
- }
- Kt.multVec(1.0,at,1.0,ConstVector(vt));
-
- /*****************
- This calculates $$P_{t+1} = T_tP_tL_t^T + R_tQ_tR_t^T.$$
- *****************/
- GeneralMatrix PtLttrans(Pt,Lt,"trans");
- if(!isTunit)
- {
- Pt.zeros();
- Pt.multAndAdd(Tt,ConstGeneralMatrix(PtLttrans));
- }
- else
- {
- Pt= (const GeneralMatrix&)PtLttrans;
- }
- if(!isRzero&&!isQzero)
- {
- GeneralMatrix QtRttrans(Qt,Rt,"trans");
- Pt.multAndAdd(Rt,ConstGeneralMatrix(QtRttrans));
- }
- }
- }
- }
-
-/*****************
-This runs a diffuse filter. Similarly as for
-|KalmanTask::filterNonDiffuse| the filter is started with a given $t$,
-$a_t$, $P_*$, and $P_\infty$ and stores the results to
-|DiffuseFilterResults| |fres|.
-
-This executes the diffuse multivariate filter period by period and if
-the variance of states $P=P_*+\kappa P_\infty$ is finite for
-$kappa->oo $, then we switch to |KalmanTask::filterNonDiffuse|.
-
-The switching has two reasons:
-The first is that the non-diffuse filter is computationally more efficient
-(since it avoids multiplications of zero matrices). The second reason
-is much more important. As $P_\infty$ approaches to zero, then
-$F_\infty=Z P_\infty Z^T$ approaches to zero and might contain severe
-roundoffs. All the operations employing its inverse, $F_\infty^{-1}$,
-will commit very bad roundoff errors, and the results will become
-unusable. That is why it is important to not only switch to
-non-diffuse filter, but also to switch at the right period.
-
-In theory, the period $d$ of switching is equal to a number of
-(univariate) observations for which $F_\infty$ is regular. This is
-because the regular $F_\infty=ZP_\infty Z^T$ conveys some information
-to $P=P_*+\kappa P_\infty$. However, it is only a theoretical result;
-in real floating point world it is difficult to recognize a regular
-matrix in this process. Moreover, the $F_\infty$ might be singular and
-still convey some information for the diffuse elements since it might
-have non-zero rank.
-
-In this implementation, we use the above idea with the following test
-for regularity of $F_\infty$. $F_\infty$ is considered to be regular,
-if its PLU factorization yields a condition number estimate less than
-$10^10$. During the process it might happen that $P_\infty$ is
-indefinite. In this case we correct it by setting its negative
-eigenvalues to zero. So $F_\infty=ZP_\infty Z$ is always positive
-semidefinite, so no tests for a sign of its determinant are
-necessary. Further, the test for $F_\infty=0$ here is equivalent to an
-exact match. This can be done since the roundoff errors are believed
-to be eliminated during correcting the $P_\infty$ matrix, where not
-only negative eigenvalues but also very small positive eigenvalues are
-corrected to zeros. In neither case, this is if $F_\infty$ is regular
-and still is non-zero, we raise end the filter. This error can be
-recognized by |FilterResults::per| less than a number of periods.
-
-This is just one of many ways, how to implement this non-continuous
-algorithm. It is theoretically continuous (since the non-diffuse
-periods having $P_\infty$ zero are covered by the branch where
-$F_\infty=0$). However, it is computationally discontinuous, since the
-calcs depend on when we switch to non-diffuse filter. Because of the
-roundoff errors we are uncertain about the switch. An experience shows
-that if we switch late, the results can be very bad due to roundoff
-errors implied by late switch, if we switch too early, the results
-might be wrong since we neglect some uncertainity.
-
-Main decision point is |ndiff|. Whenever |ndiff<=0|, we consider
-$P_\infty$ as zero and carry on as in non-diffuse filter.
-*****************/
-
-void
-KalmanTask::filterDiffuse(const Vector&a,const GeneralMatrix&Pstar,
-const GeneralMatrix&Pinf,int first,
-DiffuseFilterResults&fres)const
- {
- Vector at(a);
- GeneralMatrix Ptstar(Pstar);
- GeneralMatrix Ptinf(Pinf);
- int ndiff= init.getNDiff();
- for(int t= first;t<=data.numCols();t++)
- {
-
- /*****************
- If $P_\infty$ is exactly zero, then we run the non-diffuse
- filter. The $P_\infty$ might become exactly zero by negative or zero
- |ndiff|, or by $P\infty$ definitness correction.
- *****************/
- if(TSUtils::isZero(Ptinf))
- {
- filterNonDiffuse(at,Ptstar,t,fres);
- return;
- }
-
- ConstVector yt(data,t-1);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- ConstGeneralMatrix Ht(((const TMatrix&)*ssf.H)[t]);
- ConstGeneralMatrix Tt(((const TMatrix&)*ssf.T)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isTunit= ssf.T->isUnit(t);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
- /*****************
- This calculates $$v_t = y_t - Z_t*a_t.$$
- *****************/
- Vector vt(yt);
- Zt.multsVec(vt,at);
-
-
- /*****************
- This calculates $$M_{*,t} = P_{*,t}Z_t^T.$$
- *****************/
- GeneralMatrix Mtstar(Ptstar,Zt,"trans");
-
- /*****************
- This calculates $$F_{*,t} = Z_tP_{*,t}^T+H_t.$$
- *****************/
- GeneralMatrix Ftstar(Ht);
- Ftstar.multAndAdd(Zt,ConstGeneralMatrix(Mtstar));
-
- /*****************
- This calculates $$M_{\infty,t} = P_{\infty,t}Z_t^T.$$
- *****************/
- GeneralMatrix Mtinf(Ptinf,Zt,"trans");
-
- /*****************
- This calculates $$F_{\infty,t} = Z_tP_{\infty,t}Z_t^T.$$
- *****************/
- GeneralMatrix Ftinf(Zt,ConstGeneralMatrix(Mtinf));
-
-
- PLUFact Ftinfinv(Ftinf);
- if(Ftinfinv.isRegular()&&Ftinfinv.getRcond()> 1.e-10)
- {
- ndiff-= ssf.p;
-
- /*****************
- We calculate all other matrices, and if we have not come to the end,
- also $a_{t+1}$, $P_{*,t+1}$ and $P_{\infty,t+1}$. If |ndiff<=0|, we
- set $P_{\infty,t+1}=0$. The matrix can be set to zero even if it is
- not positive semidefinite in the code correcting definitness of
- $P_\infty$.
- *****************/
-
- /*****************
- This calculates $$F_t^{(2)} = -F_{\infty,t}^{-1}F_{*,t}F_{\infty,t}^{-1}.$$
- *****************/
- GeneralMatrix Ft_2(Ftstar);
- Ftinfinv.multInvRight(Ft_2);
- Ftinfinv.multInvLeft(Ft_2);
- Ft_2.mult(-1.0);
-
- /*****************
- This calculates $$K_t^{(0)} = T_tM_{\infty,t}F_t^{(1)}.$$
- *****************/
- GeneralMatrix Kt_0(Tt,Mtinf);
- Ftinfinv.multInvRight(Kt_0);
-
- /*****************
- This calculates $$K_t^{(1)} = T_t(M_{\infty,t}F_t^{(2)}+M_{*,t}F_t^{(1)}).$$
- *****************/
- GeneralMatrix Kt_1(Mtstar);
- Ftinfinv.multInvRight(Kt_1);
- Kt_1.multAndAdd(Mtinf,Ft_2);
- if(!isTunit)
- Kt_1.multLeft(Tt);
-
- /*****************
- This calculates $$L_t^{(0)} = T_t-K_t^{(0)}Z_t.$$
- *****************/
- GeneralMatrix Lt_0(Tt);
- Lt_0.multAndAdd(ConstGeneralMatrix(Kt_0),Zt,-1.0);
-
- /*****************
- This calculates $$L_t^{(1)} = -K_t^{(1)}Z_t.$$
- *****************/
- GeneralMatrix Lt_1(Kt_1,Zt);
- Lt_1.mult(-1.0);
-
- /*****************
- This calculates log likelihood and store results
- *****************/
- double ll= -0.5*(ssf.p*log(2*M_PI)+Ftinfinv.getLogDeterminant());
- fres.set(t,Ftinfinv,Ft_2,vt,Lt_0,Lt_1,at,Pstar,Pinf,ll);
-
- if(t<data.numCols())
- {
- if(!isTunit)
- {
- Vector atsave((const Vector&)at);
- Tt.multVec(0.0,at,1.0,atsave);
- }
- Kt_0.multVec(1.0,at,1.0,vt);
-
- /*****************
- This calculates
- $$P_{*,t+1} = T_t(P_{*,t}L_t^{(0)T}+P_{\infty,t}L_t^{(1)T})+R_tQ_tR_t^T.$$
- *****************/
- GeneralMatrix tmp(Ptstar,Lt_0,"trans");
- tmp.multAndAdd(Ptinf,Lt_1,"trans");
- if(!isTunit)
- Ptstar.mult(Tt,ConstGeneralMatrix(tmp));
- else
- Ptstar= (const GeneralMatrix&)tmp;
- if(!isQzero&&!isRzero)
- {
- GeneralMatrix QtRttrans(Qt,Rt,"trans");
- Ptstar.multAndAdd(Rt,ConstGeneralMatrix(QtRttrans));
- }
-
- /*****************
- We call |TSUtils::correctDefinitness| only if it has a negative
- diagonal or it is not diagonall dominant. We could call the routine in
- all any case, but it is costly.
- *****************/
- if(TSUtils::hasNegativeDiagonal(Ptstar)||!TSUtils::isSymDiagDominant(Ptstar))
- TSUtils::correctDefinitness(Ptstar);
-
- /*****************
- This calculates $$P_{\infty,t+1} = T_tP_{\infty,t}L_t^{(0)T}.$$ Due
- to possible roundoff errors, the resulting matrix might not be
- symmetric, so we amend it by putting it to ${1\over
- 2}(P_{\infty,t+1}+P_{\infty,t+1}^T)$.
- *****************/
- if(!isTunit)
- Ptinf.multLeft(Tt);
- Ptinf.multRightTrans(Lt_0);
- TSUtils::correctSymmetricity(Ptinf);
-
- /*****************
- We check the semidefinitness of new $P_{\infty,t+1}$. If it is not,
- then the roundoff error is guilty for the mess and we have to correct
- the matrix to be semidefinite.
- *****************/
- if(TSUtils::hasNegativeDiagonal(Ptinf)||!TSUtils::isSymDiagDominant(Ptinf))
- TSUtils::correctDefinitness(Ptinf);
-
- if(ndiff<=0)
- Ptinf.zeros();
- }
- }
- else if(TSUtils::isZero(Ftinf))
- {
- /*****************
- If $F_{*,t}$ is not regular, we return and the filter has not
- finished. The regularity is checked exactly.
- *****************/
- PLUFact Ftstarinv(Ftstar);
- if(!Ftstarinv.isRegular())
- {
- return;
- }
-
- /*****************
- This calculates $$K_t^{(0)} = T_tM_{*,t}F_{*,t}^{-1}.$$
- *****************/
- GeneralMatrix Kt_0(Tt,Mtstar);
- Ftstarinv.multInvRight(Kt_0);
-
- /*****************
- This calculates $$L_t^{(0)} = T_t-K_t^{(0)}Z_t.$$
- *****************/
- GeneralMatrix Lt_0(Tt);
- Lt_0.multAndAdd(ConstGeneralMatrix(Kt_0),Zt,-1.0);
-
-
- /*****************
- This calculates log likelihood and store results
- *****************/
- double ll= calcStepLogLik(Ftstarinv,vt);
- fres.set(t,Ftstarinv,vt,Lt_0,at,Ptstar,Ptinf,ll);
-
-
- if(t<data.numCols())
- {
- /*****************
- This calculates $$a_{t+1} = T_ta_t+K_t^{(0)}v_t.$$
- *****************/
- if(!isTunit)
- {
- Vector atsave((const Vector&)at);
- Tt.multVec(0.0,at,1.0,atsave);
- }
- Kt_0.multVec(1.0,at,1.0,vt);
-
- /*****************
- This calculates $$P_{\infty,t+1} = T_tP_{\infty,t}T_t^T.$$
- *****************/
- if(!isTunit)
- {
- GeneralMatrix PtinfTttrans(Ptinf,Tt,"trans");
- Ptinf.mult(Tt,ConstGeneralMatrix(PtinfTttrans));
- }
- if(TSUtils::hasNegativeDiagonal(Ptinf)||!TSUtils::isSymDiagDominant(Ptinf))
- TSUtils::correctDefinitness(Ptinf);
-
- /*****************
- This calculates $$P_{*,t+1} = T_tP_{*,t}L_t^{(0)T}+R_tQ_tR_t^T.$$
- *****************/
- GeneralMatrix PtstarLt_0trans(Ptstar,Lt_0,"trans");
- if(!isTunit)
- Ptstar.mult(Tt,ConstGeneralMatrix(PtstarLt_0trans));
- else
- Ptstar= (const GeneralMatrix&)PtstarLt_0trans;
- if(!isQzero&&!isRzero)
- {
- GeneralMatrix QtRttrans(Qt,Rt,"trans");
- Ptstar.multAndAdd(Rt,ConstGeneralMatrix(QtRttrans));
- }
-
- if(TSUtils::hasNegativeDiagonal(Ptstar)||!TSUtils::isSymDiagDominant(Ptstar))
- TSUtils::correctDefinitness(Ptstar);
- }
- }
- else
- {
- return;
- }
- }
- }
-
-
- /*****************
- This executes only one step of smoother non-diffuse step. It takes
- $r_t$, and $N_t$ and outputs $\alpha_t$, $V_t$ and $\eta_t$. The code is clear.
- *****************/
- void
- KalmanTask::smootherNonDiffuseStep(int t,const FilterResults&fres,
- Vector&rt,GeneralMatrix&Nt,
- Vector&alphat,GeneralMatrix&Vt,
- Vector&etat)const
- {
- const PLUFact&Ftinv= fres.getFInverse(t);
- const Vector&vt= fres.getV(t);
- const GeneralMatrix&Lt= fres.getL(t);
- const Vector&at= fres.getA(t);
- const GeneralMatrix&Pt= fres.getP(t);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
-
- /*****************
- Calculate $$\eta_t = Q_tR_t^Tr_t.$$
- *****************/
- etat.zeros();
- if(!isQzero&&!isRzero){
- Rt.multVecTrans(0.0,etat,1.0,rt);
- Vector etatsav((const Vector&)etat);
- Qt.multVec(0.0,etat,1.0,etatsav);
- }
-
-
-
- /*****************
- This calculates $$r_{t-1} = Z^T_tF_t^{-1}v_t + L^T_tr_t.$$
- *****************/
- Vector rtsav((const Vector&)rt);
- Lt.multVecTrans(0.0,rt,1.0,rtsav);
- Vector Ftinvvt(vt);
- Ftinv.multInvLeft(Ftinvvt);
- Zt.multVecTrans(1.0,rt,1.0,Ftinvvt);
-
-
-
- /*****************
- This calculates $$N_{t-1} = Z^T_tF_t^{-1}Z_t+L^T_tN_tL_t.$$
- *****************/
- GeneralMatrix NtLt(Nt,Lt);
- Nt.zeros();
- Nt.multAndAdd(Lt,"trans",NtLt);
- GeneralMatrix FtinvZt(Zt);
- Ftinv.multInvLeft(FtinvZt);
- Nt.multAndAdd(Zt,"trans",ConstGeneralMatrix(FtinvZt));
-
-
-
- /*****************
- This calculates $$\alpha_t = a_t + P_tr_{t-1}.$$
- *****************/
- alphat= (const Vector&)at;
- Pt.multVec(1.0,alphat,1.0,rt);
-
-
- /*****************
- This calculates $$V_t = P_t - P_tN_{t-1}P_t.$$
- *****************/
- Vt= (const GeneralMatrix&)Pt;
- GeneralMatrix NtPt(Nt,Pt);
- Vt.multAndAdd(Pt,NtPt,-1.0);
-
- }
-
- /*****************
- The non-diffuse smoother just performs a series of
- |KalmanTask::smootherNonDiffuseStep|.
- *****************/
- void
- KalmanTask::smootherNonDiffuse(const FilterResults&fres,
- SmootherResults&sres)const
- {
- Vector rt(ssf.m);
- rt.zeros();
- GeneralMatrix Nt(ssf.m,ssf.m);
- Nt.zeros();
- for(int t= data.numCols();t>=1;t--)
- {
- Vector alphat(ssf.m);
- GeneralMatrix Vt(ssf.m,ssf.m);
- Vector etat(ssf.r);
- smootherNonDiffuseStep(t,fres,rt,Nt,alphat,Vt,etat);
- sres.set(t,alphat,etat,Vt);
- }
- }
-
- /*****************
- Here we cycle from $t=T,\ldots, 1$. Whenever $P_\infty$ is zero, we
- perform the non-diffuse step. Otherwise we permorn a common code to
- diffuse smoothing and then fork according to regularity of $F_\infty$.
- *****************/
- void
- KalmanTask::smootherDiffuse(const DiffuseFilterResults&fres,
- SmootherResults&sres)const
- {
- Vector rt_0(ssf.m);
- Vector rt_1(ssf.m);
- GeneralMatrix Nt_0(ssf.m,ssf.m);
- GeneralMatrix Nt_1(ssf.m,ssf.m);
- GeneralMatrix Nt_2(ssf.m,ssf.m);
- rt_0.zeros();
- rt_1.zeros();
- Nt_0.zeros();
- Nt_1.zeros();
- Nt_2.zeros();
-
- for(int t= data.numCols();t>=1;t--)
- {
- Vector alphat(ssf.m);
- GeneralMatrix Vt(ssf.m,ssf.m);
- Vector etat(ssf.r);
- if(fres.isPinfZero(t))
- {
- smootherNonDiffuseStep(t,fres,rt_0,Nt_0,alphat,Vt,etat);
- }
- else
- {
- const Vector&vt= fres.getV(t);
- const GeneralMatrix&Lt_0= fres.getL0(t);
- const Vector&at= fres.getA(t);
- const GeneralMatrix&Ptstar= fres.getPstar(t);
- const GeneralMatrix&Ptinf= fres.getPinf(t);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Tt(((const TMatrix&)*ssf.T)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isTunit= ssf.T->isUnit(t);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
- /*****************
- Calculate $$\eta_t =Q_tR_tr_t^{(0)}.$$
- *****************/
- etat.zeros();
- if(!isQzero&&!isRzero)
- {
- Rt.multVecTrans(0.0,etat,1.0,rt_0);
- Vector etatsav((const Vector&)etat);
- Qt.multVec(0.0,etat,1.0,etatsav);
- }
-
- if(!fres.isFinfRegular(t))
- {
- /*****************
- We call here |smootherNonDiffuseStep| and calculate $r_{t-1}^{(1)}$,
- $N_{t-1}^{(1)}$, $N_{t-1}^{(2)}$ and correct for $\alpha_t$.
- *****************/
- smootherNonDiffuseStep(t,fres,rt_0,Nt_0,alphat,Vt,etat);
-
- /*****************
- This calculates $$r_{t-1}^{(1)} = T^T_tr_t^{(1)}.$$
- *****************/
- if(!isTunit)
- {
- Vector rt_1sav((const Vector&)rt_1);
- rt_1.zeros();
- Tt.multVecTrans(0.0,rt_1,1.0,rt_1sav);
- }
-
- /*****************
- This corrects $\alpha_t$ after|KalmanTask::smootherNonDiffuseStep|.
- This adds $P_{\infty,t}r_{t-1}^{(1)}$ to $\alpha_t$.
- *****************/
- Ptinf.multVec(1.0,alphat,1.0,rt_1);
-
- /*****************
- This calculates $$N_{t-1}^{(1)} = T_t^TN_t^{(1)}L_t^{(0)}.$$
- *****************/
- if(!isTunit)
- {
- GeneralMatrix Nt_1Lt_0(Nt_1,Lt_0);
- Nt_1.zeros();
- Nt_1.multAndAdd(Tt,"trans",ConstGeneralMatrix(Nt_1Lt_0));
- }
- else
- Nt_1.mult(Nt_1,Lt_0);
-
- /*****************
- This calculates $$N_{t-1}^{(2)} = T_t^TN_t^{(2)}T_t.$$
- *****************/
- if(!isTunit)
- {
- GeneralMatrix Nt_2Tt(Nt_2,Tt);
- Nt_2.zeros();
- Nt_2.multAndAdd(Tt,"trans",ConstGeneralMatrix(Nt_2Tt));
- }
-
- }
- else
- {
- const GeneralMatrix&Lt_1= fres.getL1(t);
- const GeneralMatrix&Ft_2= fres.getF2(t);
- const PLUFact&Ftinfinv= fres.getFinfInverse(t);
-
- /*****************
- This calculates $$r_{t-1}^{(1)} = Z^T_tF_{\infty,t}^{-1}v_t^{(0)} +
- L_t^{(0)T}r_t^{(1)} + L_t^{(1)T}r_t^{(0)}.$$
- *****************/
- Vector rt_1sav((const Vector&)rt_1);
- Lt_0.multVecTrans(0.0,rt_1,1.0,rt_1sav);
- Lt_1.multVecTrans(1.0,rt_1,1.0,rt_0);
- Vector Ftinfinvvt(vt);
- Ftinfinv.multInvLeft(Ftinfinvvt);
- Zt.multVecTrans(1.0,rt_1,1.0,Ftinfinvvt);
-
- /*****************
- This calculates $$r_{t-1}^{(0)} = L_t^{(0)}r_t^{(0)}.$$
- *****************/
- Vector rt_0sav((const Vector&)rt_0);
- Lt_0.multVecTrans(0.0,rt_0,1.0,rt_0sav);
-
- /*****************
- This calculates
- $$N_{t-1}^{(2)} = Z_t^TF_t^{(2)}Z_t + L_t^{(0)T}N_t^{(2)}L_t^{(0)}+
- L_t^{(0)T}N_t^{(1)}L_t^{(1)} + L_t^{(1)T}N_t^{(1)}L_t^{(0)}
- + L_t^{(1)T}N_t^{(0)}L_t^{(1)}.
- $$
- *****************/
- GeneralMatrix Nt_2sav((const GeneralMatrix&)Nt_2);
- Nt_2.zeros();
- GeneralMatrix Ft_2Zt(Ft_2,Zt);
- Nt_2.multAndAdd(Zt,"trans",ConstGeneralMatrix(Ft_2Zt));
- GeneralMatrix Nt_2Lt_0(Nt_2sav,Lt_0);
- Nt_2.multAndAdd(Lt_0,"trans",Nt_2Lt_0);
- GeneralMatrix Nt_1Lt_1(Nt_1,Lt_1);
- Nt_2.multAndAdd(Lt_0,"trans",Nt_1Lt_1);
- GeneralMatrix Nt_1Lt_0(Nt_1,Lt_0);
- Nt_2.multAndAdd(Lt_1,"trans",Nt_1Lt_0);
- GeneralMatrix Nt_0Lt_1(Nt_0,Lt_1);
- Nt_2.multAndAdd(Lt_1,"trans",Nt_0Lt_1);
-
- /*****************
- This calculates
- $$N_{t-1}^{(1)} = Z_t^TF_t^{(1)}Z_t + L_t^{(0)T}N_t^{(1)}L_t^{(0)}+
- L_t^{(1)T}N_t^{(0)}L_t^{(0)}.$$ |Nt_1Lt_0| was set in |@<calculate
- $N_{t-1}^{(2)}$ for diffuse smoother and regular $F_{\infty,t}$@>|.
- *****************/
- Nt_1.zeros();
- GeneralMatrix FtinfinvZt(Zt);
- Ftinfinv.multInvLeft(FtinfinvZt);
- Nt_1.multAndAdd(Zt,"trans",ConstGeneralMatrix(FtinfinvZt));
- Nt_1.multAndAdd(Lt_0,"trans",Nt_1Lt_0);
- GeneralMatrix Nt_0Lt_0(Nt_0,Lt_0);
- Nt_1.multAndAdd(Lt_1,"trans",Nt_0Lt_0);
-
- /*****************
- This calculates $$N_{t-1}^{(0)} = L_t^{(0)T}N_t^{(0)}L_t^{(0)}.$$
- |Nt_0Lt_0| was set in |@<calculate $N_{t-1}^{(1)}$ for diffuse
- smoother and regular $F_{\infty,t}$@>|.
- *****************/
- Nt_0.zeros();
- Nt_0.multAndAdd(Lt_0,"trans",Nt_0Lt_0);
-
- /*****************
- This calculates $$\alpha_t = a_t^{(0)} + P_{*,t}r_{t-1}^{(0)} + P_{\infty,t}r_{t-1}^{(1)}.$$
- for diffuse smoother and regular $F_{\infty,t}
- *****************/
- alphat= (const Vector&)at;
- Ptstar.multVec(1.0,alphat,1.0,rt_0);
- Ptinf.multVec(1.0,alphat,1.0,rt_1);
- }
-
- /*****************
- This calculates $$V_t = P_{*,t} - P_{*,t}N_{t-1}^{(0)}P_{*,t}
- - P_{\infty,t}N_{t-1}^{(1)}P_{*,t} -(P_{\infty,t}N_{t-1}^{(1)}P_{*,t})^T
- - P_{\infty,t}N_{t-1}^{(2)}P_{\infty,t}.$$
- *****************/
- Vt= (const GeneralMatrix&)Ptstar;
- GeneralMatrix Nt_0Ptstar(Nt_0,Ptstar);
- Vt.multAndAdd(Ptstar,Nt_0Ptstar,-1.0);
- GeneralMatrix Nt_2Ptinf(Nt_2,Ptinf);
- Vt.multAndAdd(Ptinf,Nt_2Ptinf,-1.0);
- GeneralMatrix Nt_1Ptstar(Nt_1,Ptstar);
- GeneralMatrix PtinfNt_1Ptstar(Ptinf,Nt_1Ptstar);
- Vt.add(-1.0,PtinfNt_1Ptstar);
- Vt.add(-1.0,PtinfNt_1Ptstar,"trans");
-
- }// end if/else
- sres.set(t,alphat,etat,Vt);
- }// end for
- }
-
-
- /*****************
- This evaluates a step loglikelihood as
- \log p(y_t\vert Y_{t-1})=-{1\over 2}\left[p\log(2\pi)+\log\vert F_t\vert+
- v_t^TF_t^{-1}v_t\right]$$
- This is a static method.
- *****************/
-
- double
- KalmanTask::calcStepLogLik(const PLUFact&Finv,const Vector&v)
- {
- int p= Finv.numRows();
- Vector Finvv(v);
- Finv.multInvLeft(Finvv);
- double vFinvv= v.dot(Finvv);
- return-0.5*(p*log(2*M_PI)+Finv.getLogDeterminant()+vFinvv);
- }
-
-
- FilterUniResults::~FilterUniResults()
- {
- for(unsigned int i= 0;i<F.size();i++){
- if(L[i])
- delete L[i];
- if(a[i])
- delete a[i];
- if(P[i])
- delete P[i];
- }
- }
-
- ;
-
- void
- FilterUniResults::set(int t,double FF,double vv,
- const GeneralMatrix&LL,const Vector&aa,
- const GeneralMatrix&PP,double ll)
- {
- TS_RAISE_IF(t<1||t> (int)L.size()+1,
- "Wrong time for FilterUniResults::set");
-
- int tm= t-1;
- if(L[tm])
- delete L[tm];
- if(a[tm])
- delete a[tm];
- if(P[tm])
- delete P[tm];
-
- if(t> maxt)
- maxt= t;
-
- F[tm]= FF;
- v[tm]= vv;
- L[tm]= new GeneralMatrix(LL);
- a[tm]= new Vector(aa);
- P[tm]= new GeneralMatrix(PP);
- loglik[tm]= ll;
- }
-
- ;
-
- double FilterUniResults::getF(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterUniResults::getF");
- return F[t-1];
- }
-
- ;
-
- double FilterUniResults::getV(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterUniResults::getV");
- return v[t-1];
- }
-
- ;
-
- const GeneralMatrix&FilterUniResults::getL(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterUniResults::getL");
- return*(L[t-1]);
- }
-
- ;
-
- const Vector&FilterUniResults::getA(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterUniResults::getA");
- return*(a[t-1]);
- }
-
- ;
-
- const GeneralMatrix&FilterUniResults::getP(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterUniResults::getP");
- return*(P[t-1]);
- }
-
- /*****************
- This adds all the log likelihoods for all periods. If some periods
- in the results have not been set, these are initialized to zeros and
- thus this method is pretty safe but may not be if the likelihood tends to
- be far lower or higher than 0.
- *****************/
- double
- FilterUniResults::getLogLikelihood()const
- {
- double res= 0.0;
- for(unsigned int i= 0;i<loglik.size();i++)
- res+= loglik[i];
- return res;
- }
-
- double
- FilterUniResults::getLogLikelihood(int start)const
- {
- double res= 0.0;
- for(unsigned int i= start;i<loglik.size();i++)
- res+= loglik[i];
- return res;
- }
-
- double
- FilterUniResults::getLogLikelihood(std::vector<double>* vloglik)const
- {
- double res= 0.0;
- for(unsigned int i= 0;i<loglik.size();i++)
- res+= loglik[i];
- *vloglik= loglik;
- return res;
- }
-
- double
- FilterUniResults::getLogLikelihood(int start,std::vector<double>* vloglik)const
- {
- double res= 0.0;
- for(unsigned int i= start;i<loglik.size();i++)
- res+= loglik[i];
- *vloglik= loglik;
- return res;
- }
-
-
- DiffuseFilterUniResults::~DiffuseFilterUniResults()
- {
- for(unsigned int i= 0;i<L_1.size();i++){
- if(L_1[i])
- delete L_1[i];
- if(Pinf[i])
- delete Pinf[i];
- }
- }
-
- ;
-
- bool
- DiffuseFilterUniResults::isFinfRegular(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterUniResults::isFinfRegular");
- return Finf_reg[t-1];
- }
-
- ;
-
- bool
- DiffuseFilterUniResults::isPinfZero(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterUniResults::isPinfZero");
- return Pinf_zero[t-1];
- }
-
- ;
-
- double
- DiffuseFilterUniResults::getFinf(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterUniResults::getFinf");
- TS_RAISE_IF(!isFinfRegular(t),
- "Finf not regular in the period in DiffuseFilterUniResults::getFinf");
- return getF(t);
- }
-
- ;
-
- double
- DiffuseFilterUniResults::getFstar(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterUniResults::getFstar");
- TS_RAISE_IF(isFinfRegular(t),
- "Finf not zero in the period in DiffuseFilterUniResults::getFstar");
- return getF(t);
- }
-
-
- ;
-
- double
- DiffuseFilterUniResults::getF2(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for DiffuseFilterUniResults::getF2");
- TS_RAISE_IF(!isFinfRegular(t),
- "Finf not regular in the period in DiffuseFilterUniResults::getF2");
- return F_2[t-1];
- }
-
- ;
-
- const
- GeneralMatrix&DiffuseFilterUniResults::getL1(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterUniResults::getL1");
- TS_RAISE_IF(!isFinfRegular(t),
- "Finf not regular in the period in DiffuseFilterUniResults::getL1");
- return*(L_1[t-1]);
- }
-
- ;
-
- const
- GeneralMatrix&DiffuseFilterUniResults::getPinf(int t)const
- {
- TS_RAISE_IF(t<1||t> maxt,
- "Wrong time for FilterUniResults::getPinf");
- TS_RAISE_IF(isPinfZero(t),
- "Pinf is zero in the period in DiffuseFilterUniResults::getPinf");
- return*(Pinf[t-1]);
- }
-
- ;
-
- void
- DiffuseFilterUniResults::set(int t,double FF,double FF_2,
- double vv,const GeneralMatrix&LL_0,
- const GeneralMatrix&LL_1,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll)
- {
- FilterUniResults::set(t,FF,vv,LL_0,aa,PPstar,ll);
-
- int tm= t-1;
- if(L_1[tm])
- delete L_1[tm];
- if(Pinf[tm])
- delete Pinf[tm];
-
- L_1[tm]= new GeneralMatrix(LL_1);
- Pinf[tm]= new GeneralMatrix(PPinf);
- F_2[tm]= FF_2;
- Finf_reg[tm]= true;
- Pinf_zero[tm]= false;
- }
-
- ;
-
- void
- DiffuseFilterUniResults::set(int t,double FFstar,double vv,
- const GeneralMatrix&LL_0,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll)
- {
- FilterUniResults::set(t,FFstar,vv,LL_0,aa,PPstar,ll);
-
- int tm= t-1;
- if(Pinf[tm])
- delete Pinf[tm];
- Pinf[tm]= new GeneralMatrix(PPinf);
-
- Finf_reg[tm]= false;
- Pinf_zero[tm]= false;
- }
-
- ;
-
- int
- DiffuseFilterUniResults::getDiffusePeriods()const
- {
- int d= maxt;
- while(d> 1&&isPinfZero(d))
- d--;
- return d;
- }
-
- /*****************
- @ This converts a multivariate |KalmanTask| to univariate
- |KalmanUniTask|. It unfolds time dimension so that at each time only
- one univariate observation comes. The measurment equation is
- transformed so that the measurment errors would not be correlated.
- *****************/
- KalmanUniTask::KalmanUniTask(const KalmanTask&kt)
- :me(kt.data,*(kt.ssf.Z),*(kt.ssf.H)),
- ssf(TMatrixCycle(*(me.Z),"rows"),TScalarCycle(*(me.H)),
- TMatrixPadUnit(*(kt.ssf.T),kt.data.numRows()),
- TMatrixPadZero(*(kt.ssf.R),kt.data.numRows()),
- TMatrixPadZero(*(kt.ssf.Q),kt.data.numRows())),
- data(me.y.base(),1,me.y.numRows()*me.y.numCols()),
- init(kt.init)
- {
- }
-
-
- double
- KalmanUniTask::filter(int&per,int&d)const
- {
- if(!init.isDiffuse())
- {
- FilterUniResults fres(data.numCols());
- filterNonDiffuse(init.getA(),init.getPstar(),1,fres);
- d= 0;
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood();
- }
- else
- {
- DiffuseFilterUniResults fres(data.numCols());
- filterDiffuse(init.getA(),init.getPstar(),init.getPinf(),
- 1,fres);
- d= fres.getDiffusePeriods();
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood();
- }
- return 0.0;
- }
-
- double
- KalmanUniTask::filter(int&per,int&d, int start, std::vector<double>* vll)const
- {
- if(!init.isDiffuse())
- {
- FilterUniResults fres(data.numCols());
- filterNonDiffuse(init.getA(),init.getPstar(),1,fres);
- d= 0;
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood(start,vll);
- }
- else
- {
- DiffuseFilterUniResults fres(data.numCols());
- filterDiffuse(init.getA(),init.getPstar(),init.getPinf(),
- 1,fres);
- d= fres.getDiffusePeriods();
- per= fres.getMaxT();
- if(fres.hasFinished())
- return fres.getLogLikelihood(start,vll);
- }
- return 0.0;
- }
-
- double
- KalmanUniTask::filter_and_smooth(SmootherResults&sres,
- int&per,int&d)const
- {
- if(!init.isDiffuse())
- {
- FilterUniResults fres(data.numCols());
- filterNonDiffuse(init.getA(),init.getPstar(),1,fres);
- d= 0;
- per= fres.getMaxT();
- if(fres.hasFinished())
- {
- smootherNonDiffuse(fres,sres);
- return fres.getLogLikelihood();
- }
- }
- else
- {
- DiffuseFilterUniResults fres(data.numCols());
- filterDiffuse(init.getA(),init.getPstar(),init.getPinf(),
- 1,fres);
- d= fres.getDiffusePeriods();
- per= fres.getMaxT();
- if(fres.hasFinished())
- {
- smootherDiffuse(fres,sres);
- return fres.getLogLikelihood();
- }
- }
- return 0.0;
- }
-
- /*****************
- This filters univariate data starting at given $t$, $a_t$ and
- $P_t$. If at some period $F_t\leq 0$, than we end and the filter
- results are not finished.
- *****************/
- void
- KalmanUniTask::filterNonDiffuse(const Vector&a,const GeneralMatrix&P,
- int first,FilterUniResults&fres)const
- {
- Vector at(a);
- GeneralMatrix Pt(P);
- for(int t= first;t<=data.numCols();t++){
- double yt= data.get(0,t-1);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- double Ht= ((const TScalar&)*ssf.H)[t];
- ConstGeneralMatrix Tt(((const TMatrix&)*ssf.T)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isTunit= ssf.T->isUnit(t);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
-
- double vt= at.dot(Zt.getData());
- vt= yt-vt;
-
- Vector Mt(ssf.m);
- Mt.zeros();
- Pt.multVec(0.0,Mt,1.0,Zt.getData());
- double Ft= Mt.dot(Zt.getData());
- Ft+= Ht;
-
- if(Ft<=0.0)
- return;
-
- Vector Kt(ssf.m);
- Kt.zeros();
- if(isTunit)
- Kt.add(1.0/Ft,Mt);
- else
- Tt.multVec(0.0,Kt,1.0/Ft,Mt);
-
- GeneralMatrix Lt(Tt);
- Lt.multAndAdd(ConstGeneralMatrix(Kt.base(),ssf.m,1),Zt,-1.0);
-
- double ll= calcStepLogLik(Ft,vt);
- fres.set(t,Ft,vt,Lt,at,Pt,ll);
-
- if(t<data.numCols())
- {
-
- if(!isTunit)
- {
- Vector atsave((const Vector&)at);
- Tt.multVec(0.0,at,1.0,atsave);
- }
- at.add(vt,Kt);
-
-
- GeneralMatrix PtLttrans(Pt,Lt,"trans");
- if(!isTunit)
- {
- Pt.zeros();
- Pt.multAndAdd(Tt,ConstGeneralMatrix(PtLttrans));
- }
- else
- {
- Pt= (const GeneralMatrix&)PtLttrans;
- }
- if(!isRzero&&!isQzero)
- {
- GeneralMatrix QtRttrans(Qt,Rt,"trans");
- Pt.multAndAdd(Rt,ConstGeneralMatrix(QtRttrans));
- }
- }
- }
- }
-
- /*****************
- This is a univariate version of |KalmanTask::filterDiffuse|. The
- decision whether $F_\infty$ is regular or zero is simpler here, yet
- the algorithm is not numerically stable. We recognize $d$ in the same
- way as in |KalmanTask::filterDiffuse|. It may still happen that small
- non-zero $F_t$ implies a wrong $P_{\infty,t+1}$, or zero $F_t$ which
- should be positive causes $d$ to be missed and numerical error is
- committed in $P_{\infty,t+1}$.
-
- So, as in |KalmanTask::filterDiffuse| we use |ndiff| and cancel it by
- one for periods for which $F_t$ is non-zero. If $P_\infty$ is not
- positive definite, we set it to zero.
- *****************/
- void
- KalmanUniTask::filterDiffuse(const Vector&a,const GeneralMatrix&Pstar,
- const GeneralMatrix&Pinf,int first,
- DiffuseFilterUniResults&fres)const
- {
- Vector at(a);
- GeneralMatrix Ptstar(Pstar);
- GeneralMatrix Ptinf(Pinf);
- int ndiff= init.getNDiff();
- for(int t= first;t<=data.numCols();t++){
-
- /*****************
- This is the same code as |@<run non-diffuse filter
- but it is semantically different, so we copy the code here.
- *****************/
- if(TSUtils::isZero(Ptinf))
- {
- filterNonDiffuse(at,Ptstar,t,fres);
- return;
- }
-
- double yt= data.get(0,t-1);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- double Ht= ((const TScalar&)*ssf.H)[t];
- ConstGeneralMatrix Tt(((const TMatrix&)*ssf.T)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isTunit= ssf.T->isUnit(t);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
- double vt= at.dot(Zt.getData());
- vt= yt-vt;
-
- Vector Mtstar(ssf.m);
- Mtstar.zeros();
- Ptstar.multVec(0.0,Mtstar,1.0,Zt.getData());
-
- double Ftstar= Mtstar.dot(Zt.getData());
- Ftstar+= Ht;
-
- Vector Mtinf(ssf.m);
- Mtinf.zeros();
- Ptinf.multVec(0.0,Mtinf,1.0,Zt.getData());
-
- double Ftinf= Mtinf.dot(Zt.getData());
- if(Ftinf<2*DBL_EPSILON)
- Ftinf= 0.0;
-
- if(Ftinf> 0.0)
- {
- ndiff--;
-
- double Ft_2= -Ftstar/Ftinf/Ftinf;
-
- Vector Kt_0(ssf.m);
- Kt_0.zeros();
- if(!isTunit)
- Tt.multVec(0.0,Kt_0,1.0/Ftinf,Mtinf);
- else
- Kt_0.add(1.0/Ftinf,Mtinf);
-
- Vector Kt_1tmp(ssf.m);
- Kt_1tmp.zeros();
- Kt_1tmp.add(Ft_2,Mtinf);
- Kt_1tmp.add(1.0/Ftinf,Mtstar);
- Vector Kt_1(ssf.m);
- if(!isTunit)
- {
- Kt_1.zeros();
- Tt.multVec(0.0,Kt_1,1.0,Kt_1tmp);
- }
- else
- {
- Kt_1= (const Vector&)Kt_1tmp;
- }
-
- GeneralMatrix Lt_0(Tt);
- Lt_0.multAndAdd(ConstGeneralMatrix(Kt_0.base(),ssf.m,1),Zt,-1.0);
-
-
- GeneralMatrix Lt_1(ConstGeneralMatrix(Kt_1.base(),ssf.m,1),Zt);
- Lt_1.mult(-1.0);
-
-
- double ll= -0.5*(log(2*M_PI)+log(Ftinf));
- fres.set(t,Ftinf,Ft_2,vt,Lt_0,Lt_1,at,Pstar,Pinf,ll);
-
- if(t<data.numCols())
- {
- /*****************
- This calculates $$a_{t+1} = T_ta_t+K_t^{(0)}v_t.$$
- *****************/
- if(!isTunit)
- {
- Vector atsave((const Vector&)at);
- Tt.multVec(0.0,at,1.0,atsave);
- }
- at.add(vt,Kt_0);
-
- GeneralMatrix tmp(Ptstar,Lt_0,"trans");
- tmp.multAndAdd(Ptinf,Lt_1,"trans");
- if(!isTunit)
- Ptstar.mult(Tt,ConstGeneralMatrix(tmp));
- else
- Ptstar= (const GeneralMatrix&)tmp;
- if(!isQzero&&!isRzero)
- {
- GeneralMatrix QtRttrans(Qt,Rt,"trans");
- Ptstar.multAndAdd(Rt,ConstGeneralMatrix(QtRttrans));
- }
-
- if(TSUtils::hasNegativeDiagonal(Ptstar)||!TSUtils::isSymDiagDominant(Ptstar))
- TSUtils::correctDefinitness(Ptstar);
-
- if(!isTunit)
- Ptinf.multLeft(Tt);
- Ptinf.multRightTrans(Lt_0);
- TSUtils::correctSymmetricity(Ptinf);
-
-
-
- if(TSUtils::hasNegativeDiagonal(Ptinf)||!TSUtils::isSymDiagDominant(Ptinf))
- TSUtils::correctDefinitness(Ptinf);
-
- if(ndiff==0)
- Ptinf.zeros();
- }
-
- }
- else
- {
- if(Ftstar==0.0)
- {
- return;
- }
- Vector Kt_0(ssf.m);
- Kt_0.zeros();
- if(!isTunit)
- Tt.multVec(0.0,Kt_0,1.0/Ftstar,Mtstar);
- else
- Kt_0.add(1.0/Ftstar,Mtstar);
-
- GeneralMatrix Lt_0(Tt);
- Lt_0.multAndAdd(ConstGeneralMatrix(Kt_0.base(),ssf.m,1),Zt,-1.0);
-
- double ll= calcStepLogLik(Ftstar,vt);
- fres.set(t,Ftstar,vt,Lt_0,at,Ptstar,Ptinf,ll);
-
- if(t<data.numCols())
- {
- if(!isTunit)
- {
- Vector atsave((const Vector&)at);
- Tt.multVec(0.0,at,1.0,atsave);
- }
- at.add(vt,Kt_0);
-
- if(!isTunit)
- {
- GeneralMatrix PtinfTttrans(Ptinf,Tt,"trans");
- Ptinf.mult(Tt,ConstGeneralMatrix(PtinfTttrans));
- }
-
- if(TSUtils::hasNegativeDiagonal(Ptinf)||!TSUtils::isSymDiagDominant(Ptinf))
- TSUtils::correctDefinitness(Ptinf);
-
- GeneralMatrix PtstarLt_0trans(Ptstar,Lt_0,"trans");
- if(!isTunit)
- Ptstar.mult(Tt,ConstGeneralMatrix(PtstarLt_0trans));
- else
- Ptstar= (const GeneralMatrix&)PtstarLt_0trans;
- if(!isQzero&&!isRzero)
- {
- GeneralMatrix QtRttrans(Qt,Rt,"trans");
- Ptstar.multAndAdd(Rt,ConstGeneralMatrix(QtRttrans));
- }
-
-
- if(TSUtils::hasNegativeDiagonal(Ptstar)||!TSUtils::isSymDiagDominant(Ptstar))
- TSUtils::correctDefinitness(Ptstar);
-
- }
-
- }
- }
- }
-
-
- void
- KalmanUniTask::smootherNonDiffuseStep(int t,const FilterUniResults&fres,
- Vector&rt,GeneralMatrix&Nt,
- Vector&alphat,GeneralMatrix&Vt,
- Vector&etat)const
- {
- double Ft= fres.getF(t);
- double vt= fres.getV(t);
- const GeneralMatrix&Lt= fres.getL(t);
- const Vector&at= fres.getA(t);
- const GeneralMatrix&Pt= fres.getP(t);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
-
-
- etat.zeros();
- if(!isQzero&&!isRzero)
- {
- Rt.multVecTrans(0.0,etat,1.0,rt);
- Vector etatsav((const Vector&)etat);
- Qt.multVec(0.0,etat,1.0,etatsav);
- }
-
- Vector rtsav((const Vector&)rt);
- Lt.multVecTrans(0.0,rt,1.0,rtsav);
- rt.add(vt/Ft,Zt.getData());
-
- GeneralMatrix NtLt(Nt,Lt);
- Nt.zeros();
- Nt.multAndAdd(Lt,"trans",NtLt);
- Nt.multAndAdd(Zt,"trans",Zt,1.0/Ft);
-
- alphat= (const Vector&)at;
- Pt.multVec(1.0,alphat,1.0,rt);
-
- Vt= (const GeneralMatrix&)Pt;
- GeneralMatrix NtPt(Nt,Pt);
- Vt.multAndAdd(Pt,NtPt,-1.0);
- }
-
-
- void
- KalmanUniTask::smootherNonDiffuse(const FilterUniResults&fres,
- SmootherResults&sres)const
- {
- Vector rt(ssf.m);
- rt.zeros();
- GeneralMatrix Nt(ssf.m,ssf.m);
- Nt.zeros();
- for(int t= data.numCols();t>=1;t--){
- Vector alphat(ssf.m);
- GeneralMatrix Vt(ssf.m,ssf.m);
- Vector etat(ssf.r);
- smootherNonDiffuseStep(t,fres,rt,Nt,alphat,Vt,etat);
- sres.set(t,alphat,etat,Vt);
- }
- }
-
- void
- KalmanUniTask::smootherDiffuse(const DiffuseFilterUniResults&fres,
- SmootherResults&sres)const
- {
-
- Vector rt_0(ssf.m);
- Vector rt_1(ssf.m);
- GeneralMatrix Nt_0(ssf.m,ssf.m);
- GeneralMatrix Nt_1(ssf.m,ssf.m);
- GeneralMatrix Nt_2(ssf.m,ssf.m);
- rt_0.zeros();
- rt_1.zeros();
- Nt_0.zeros();
- Nt_1.zeros();
- Nt_2.zeros();
-
-
- for(int t= data.numCols();t>=1;t--)
- {
- Vector alphat(ssf.m);
- GeneralMatrix Vt(ssf.m,ssf.m);
- Vector etat(ssf.r);
- if(fres.isPinfZero(t))
- {
- smootherNonDiffuseStep(t,fres,rt_0,Nt_0,alphat,Vt,etat);
- }
- else
- {
- double vt= fres.getV(t);
- const GeneralMatrix&Lt_0= fres.getL0(t);
- const Vector&at= fres.getA(t);
- const GeneralMatrix&Ptstar= fres.getPstar(t);
- const GeneralMatrix&Ptinf= fres.getPinf(t);
- ConstGeneralMatrix Zt(((const TMatrix&)*ssf.Z)[t]);
- ConstGeneralMatrix Qt(((const TMatrix&)*ssf.Q)[t]);
- ConstGeneralMatrix Tt(((const TMatrix&)*ssf.T)[t]);
- ConstGeneralMatrix Rt(((const TMatrix&)*ssf.R)[t]);
- bool isTunit= ssf.T->isUnit(t);
- bool isQzero= ssf.Q->isZero(t);
- bool isRzero= ssf.R->isZero(t);
-
- etat.zeros();
- if(!isQzero&&!isRzero)
- {
- Rt.multVecTrans(0.0,etat,1.0,rt_0);
- Vector etatsav((const Vector&)etat);
- Qt.multVec(0.0,etat,1.0,etatsav);
- }
-
- if(!fres.isFinfRegular(t))
- {
- smootherNonDiffuseStep(t,fres,rt_0,Nt_0,alphat,Vt,etat);
- if(!isTunit)
- {
- Vector rt_1sav((const Vector&)rt_1);
- rt_1.zeros();
- Tt.multVecTrans(0.0,rt_1,1.0,rt_1sav);
- }
-
- Ptinf.multVec(1.0,alphat,1.0,rt_1);
-
- if(!isTunit)
- {
- GeneralMatrix Nt_1Lt_0(Nt_1,Lt_0);
- Nt_1.zeros();
- Nt_1.multAndAdd(Tt,"trans",ConstGeneralMatrix(Nt_1Lt_0));
- }
- else
- Nt_1.mult(Nt_1,Lt_0);
-
-
- if(!isTunit)
- {
- GeneralMatrix Nt_2Tt(Nt_2,Tt);
- Nt_2.zeros();
- Nt_2.multAndAdd(Tt,"trans",ConstGeneralMatrix(Nt_2Tt));
- }
-
- }
- else
- {
- const GeneralMatrix&Lt_1= fres.getL1(t);
- double Ft_2= fres.getF2(t);
- double Ftinf= fres.getFinf(t);
-
-
- Vector rt_1sav((const Vector&)rt_1);
- Lt_0.multVecTrans(0.0,rt_1,1.0,rt_1sav);
- Lt_1.multVecTrans(1.0,rt_1,1.0,rt_0);
- rt_1.add(vt/Ftinf,Zt.getData());
-
-
- Vector rt_0sav((const Vector&)rt_0);
- Lt_0.multVecTrans(0.0,rt_0,1.0,rt_0sav);
-
- GeneralMatrix Nt_2sav((const GeneralMatrix&)Nt_2);
- Nt_2.zeros();
- Nt_2.multAndAdd(Zt,"trans",Zt,Ft_2);
- GeneralMatrix Nt_2Lt_0(Nt_2sav,Lt_0);
- Nt_2.multAndAdd(Lt_0,"trans",Nt_2Lt_0);
- GeneralMatrix Nt_1Lt_1(Nt_1,Lt_1);
- Nt_2.multAndAdd(Lt_0,"trans",Nt_1Lt_1);
- GeneralMatrix Nt_1Lt_0(Nt_1,Lt_0);
- Nt_2.multAndAdd(Lt_1,"trans",Nt_1Lt_0);
- GeneralMatrix Nt_0Lt_1(Nt_0,Lt_1);
- Nt_2.multAndAdd(Lt_1,"trans",Nt_0Lt_1);
-
-
-
- Nt_1.zeros();
- Nt_1.multAndAdd(Zt,"trans",Zt,1.0/Ftinf);
- Nt_1.multAndAdd(Lt_0,"trans",Nt_1Lt_0);
- GeneralMatrix Nt_0Lt_0(Nt_0,Lt_0);
- Nt_1.multAndAdd(Lt_1,"trans",Nt_0Lt_0);
-
- Nt_0.zeros();
- Nt_0.multAndAdd(Lt_0,"trans",Nt_0Lt_0);
-
- alphat= (const Vector&)at;
- Ptstar.multVec(1.0,alphat,1.0,rt_0);
- Ptinf.multVec(1.0,alphat,1.0,rt_1);
- }
-
- Vt= (const GeneralMatrix&)Ptstar;
- GeneralMatrix Nt_0Ptstar(Nt_0,Ptstar);
- Vt.multAndAdd(Ptstar,Nt_0Ptstar,-1.0);
- GeneralMatrix Nt_2Ptinf(Nt_2,Ptinf);
- Vt.multAndAdd(Ptinf,Nt_2Ptinf,-1.0);
- GeneralMatrix Nt_1Ptstar(Nt_1,Ptstar);
- GeneralMatrix PtinfNt_1Ptstar(Ptinf,Nt_1Ptstar);
- Vt.add(-1.0,PtinfNt_1Ptstar);
- Vt.add(-1.0,PtinfNt_1Ptstar,"trans");
-
-
- }
- sres.set(t,alphat,etat,Vt);
- }
- }
-
-
- double
- KalmanUniTask::calcStepLogLik(double F,double v)
- {
- return-0.5*(log(2*M_PI)+log(F)+v*v/F);
- }
-
-
-
diff --git a/mex/sources/kalman/cc/kalman.h b/mex/sources/kalman/cc/kalman.h
deleted file mode 100644
index c9ee00e6291ebb22be652fe9723dbcb1861fae92..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/kalman.h
+++ /dev/null
@@ -1,339 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-/*************
-This file defines two most important classes: |KalmanTask| and
-|KalmanUniTask|. Both define a linear filtering and smoothing problem;
-one for multivariate observations, the other for univariate
-observations. The Kalman task consists of three things: the state
-space, observed data, and initialization.
-
-In addition to these two classes, we have also an abstraction for
-filter results, for diffuse filter results and smoother results. These
-are only containers of series of matrices and vectors. The filter
-results are used as an input for smoothing.
-
-The important convention is that whenever a parameter $t$ stands for a
-time period (which is always), it starts from 1 (not zero as in
-C/C++).
-
-In this file, we use the same naming scheme as in Durbin \& Koopman.
-*************/
-
-#ifndef KALMAN_H
-#define KALMAN_H
-
-#include "state_init.h"
-#include "ssf.h"
-#include "ssf_uni.h"
-#include "utils.h"
-
-#include <vector>
-
-/*************
-This is an output of the filtering and input for the smoothing. This
-class is inherited by |DiffuseFilterResults| which enriches the
-|FilterResults| with additional information coming from the diffuse
-periods.
-
-The object is initialized for a given number of periods, and maintains
-a number of periods for which the filter results were set. If this
-number, |maxt|, is less than the number of overall periods, it means
-that the filter has not finished.
-**************/
-class FilterResults{
- protected:
- std::vector<PLUFact*> Finv;
- std::vector<Vector*> v;
- std::vector<GeneralMatrix*> L;
- std::vector<Vector*> a;
- std::vector<GeneralMatrix*> P;
- std::vector<double> loglik;
- int maxt;
- public:
- FilterResults(int num)
- :Finv(num,(PLUFact*)0),v(num,(Vector*)0),L(num,(GeneralMatrix*)0),
- a(num,(Vector*)0),P(num,(GeneralMatrix*)0),loglik(num,0.0),maxt(0)
- {}
- virtual~FilterResults();
- void set(int t,const PLUFact&FFinv,const Vector&vv,
- const GeneralMatrix&LL,const Vector&aa,
- const GeneralMatrix&P,double ll);
- int getMaxT()const
- {return maxt;}
- bool hasFinished()const
- {return maxt==(int)Finv.size();}
- const PLUFact&getFInverse(int t)const;
- const Vector&getV(int t)const;
- const GeneralMatrix&getL(int t)const;
- const Vector&getA(int t)const;
- const GeneralMatrix&getP(int)const;
- double getLogLikelihood()const;
- double getLogLikelihood(int start)const;
- double getLogLikelihood(std::vector<double> *vloglik)const;
- double getLogLikelihood(int start,std::vector<double> *vloglik)const;
- };
-
-
-class DiffuseFilterResults:public FilterResults{
- protected:
- std::vector<GeneralMatrix*> L_1;
- std::vector<GeneralMatrix*> Pinf;
- std::vector<GeneralMatrix*> F_2;
- std::vector<bool> Finf_reg;
- std::vector<bool> Pinf_zero;
- public:
- DiffuseFilterResults(int num)
- :FilterResults(num),
- L_1(num,(GeneralMatrix*)0),
- Pinf(num,(GeneralMatrix*)0),
- F_2(num,(GeneralMatrix*)0),
- Finf_reg(num,true),
- Pinf_zero(num,true)
- {}
- virtual~DiffuseFilterResults();
- void set(int t,const PLUFact&FFinfinv,const GeneralMatrix&FF_2,
- const Vector&vv,const GeneralMatrix&LL_0,
- const GeneralMatrix&LL_1,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll);
- void set(int t,const PLUFact&FFstarinv,const Vector&vv,
- const GeneralMatrix&LL_0,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll);
- int getDiffusePeriods()const;
- bool isFinfRegular(int t)const;
- bool isPinfZero(int t)const;
- const PLUFact&getFinfInverse(int t)const;
- const PLUFact&getFstarInverse(int t)const;
- const GeneralMatrix&getF2(int t)const;
- const GeneralMatrix&getL0(int t)const
- {return getL(t);}
- const GeneralMatrix&getL1(int t)const;
- const GeneralMatrix&getPstar(int t)const
- {return getP(t);}
- const GeneralMatrix&getPinf(int t)const;
- };
-
-class SmootherResults{
- protected:
- std::vector<Vector*> alpha;
- std::vector<Vector*> eta;
- std::vector<GeneralMatrix*> V;
- int mint;
- public:
- SmootherResults(int num)
- :alpha(num,(Vector*)0),eta(num,(Vector*)0),
- V(num,(GeneralMatrix*)0),
- mint(num+1){}
- virtual~SmootherResults();
- void set(int t,const Vector&aalpha,const Vector&eeta,
- const GeneralMatrix&VV);
- void import(const SmootherResults&sres,int period);
- void exportAlpha(GeneralMatrix&out)const;
- void exportEta(GeneralMatrix&out)const;
- void exportV(GeneralMatrix&out)const;
- };
-
-
-class BasicKalmanTask{
-// friend class KalmanUniTask;
-// SSForm ssf;
- const GeneralMatrix &data;
- const ConstGeneralMatrix &Zt;
- const ConstGeneralMatrix &Ht;
- const ConstGeneralMatrix &Tt;
- const ConstGeneralMatrix &Rt;
- const ConstGeneralMatrix &Qt;
- const StateInit&init;
- const double riccatiTol;
- public:
- BasicKalmanTask(const GeneralMatrix&d,const GeneralMatrix&ZZ,
- const GeneralMatrix&HH,const GeneralMatrix&TT,
- const GeneralMatrix&RR,const GeneralMatrix&QQ,
- const StateInit&init_state, const double riccatiTol);
-// BasicKalmanTask(const GeneralMatrix&d,const TMatrix&Z,
-// const TMatrix&H,const TMatrix&T,
-// const TMatrix&R,const TMatrix&Q,
-// const StateInit&init_state);
- BasicKalmanTask(const GeneralMatrix&d,const ConstGeneralMatrix&ZZ,
- const ConstGeneralMatrix&HH,const ConstGeneralMatrix&TT,
- const ConstGeneralMatrix&RR,const ConstGeneralMatrix&QQ,
- const StateInit&init_state, const double riccatiTol);
- virtual ~BasicKalmanTask();
-// double filter(int&per,int&d)const;
-// double filter(int&per,int&d, int start, std::vector<double>* vll)const;
- double filter(int&per,int&d,int start, std::vector<double>* vll)const;
-// double filter_and_smooth(SmootherResults&sres,int&per,int&d)const;
- protected:
- double filterNonDiffuse(const Vector&a,const GeneralMatrix&Pstar,
- int start, std::vector<double>* vll) const; //int first,FilterResults&fres)const;
-// void filterDiffuse(const Vector&a,const GeneralMatrix&Pstar,
-// const GeneralMatrix&Pinf,int first,
-// DiffuseFilterResults&fres)const;
-// void smootherNonDiffuse(const FilterResults&fres,SmootherResults&sres)const;
-// void smootherDiffuse(const DiffuseFilterResults&fres,SmootherResults&sres)const;
-// void smootherNonDiffuseStep(int t,const FilterResults&fres,
-// Vector&rt,GeneralMatrix&Nt,
-// Vector&alphat,GeneralMatrix&Vt,
-// Vector&etat)const;
- static double calcStepLogLik(const PLUFact&Finv,const Vector&v);
- };
-
-
-class KalmanUniTask;
-class KalmanTask{
- friend class KalmanUniTask;
- SSForm ssf;
- ConstGeneralMatrix data;
- const StateInit&init;
- public:
- KalmanTask(const GeneralMatrix&d,const GeneralMatrix&Z,
- const GeneralMatrix&H,const GeneralMatrix&T,
- const GeneralMatrix&R,const GeneralMatrix&Q,
- const StateInit&init_state);
- KalmanTask(const GeneralMatrix&d,const TMatrix&Z,
- const TMatrix&H,const TMatrix&T,
- const TMatrix&R,const TMatrix&Q,
- const StateInit&init_state);
- double filter(int&per,int&d)const;
- double filter(int&per,int&d, int start, std::vector<double>* vll)const;
- double filter_and_smooth(SmootherResults&sres,int&per,int&d)const;
- protected:
- void filterNonDiffuse(const Vector&a,const GeneralMatrix&Pstar,
- int first,FilterResults&fres)const;
- void filterDiffuse(const Vector&a,const GeneralMatrix&Pstar,
- const GeneralMatrix&Pinf,int first,
- DiffuseFilterResults&fres)const;
- void smootherNonDiffuse(const FilterResults&fres,SmootherResults&sres)const;
- void smootherDiffuse(const DiffuseFilterResults&fres,SmootherResults&sres)const;
- void smootherNonDiffuseStep(int t,const FilterResults&fres,
- Vector&rt,GeneralMatrix&Nt,
- Vector&alphat,GeneralMatrix&Vt,
- Vector&etat)const;
- static double calcStepLogLik(const PLUFact&Finv,const Vector&v);
- };
-
-class FilterUniResults{
- protected:
- std::vector<double> F;
- std::vector<double> v;
- std::vector<GeneralMatrix*> L;
- std::vector<Vector*> a;
- std::vector<GeneralMatrix*> P;
- std::vector<double> loglik;
- int maxt;
- public:
- FilterUniResults(int num)
- :F(num,0.0),v(num,0.0),L(num,(GeneralMatrix*)0),
- a(num,(Vector*)0),P(num,(GeneralMatrix*)0),loglik(num,0.0),maxt(0)
- {}
- virtual~FilterUniResults();
- void set(int t,double F,double vv,
- const GeneralMatrix&LL,const Vector&aa,
- const GeneralMatrix&P,double ll);
- int getMaxT()const
- {return maxt;}
- bool hasFinished()const
- {return maxt==(int)F.size();}
- double getF(int t)const;
- double getV(int t)const;
- const GeneralMatrix&getL(int t)const;
- const Vector&getA(int t)const;
- const GeneralMatrix&getP(int)const;
- double getLogLikelihood()const;
- double getLogLikelihood(int start)const;
- double getLogLikelihood(std::vector<double>* vloglik)const;
- double getLogLikelihood(int start,std::vector<double>* vloglik)const;
- };
-
-
-class DiffuseFilterUniResults:public FilterUniResults{
- protected:
- std::vector<GeneralMatrix*> L_1;
- std::vector<GeneralMatrix*> Pinf;
- std::vector<double> F_2;
- std::vector<bool> Finf_reg;
- std::vector<bool> Pinf_zero;
- public:
- DiffuseFilterUniResults(int num)
- :FilterUniResults(num),
- L_1(num,(GeneralMatrix*)0),
- Pinf(num,(GeneralMatrix*)0),
- F_2(num,0.0),
- Finf_reg(num,true),
- Pinf_zero(num,true)
- {}
- virtual~DiffuseFilterUniResults();
- void set(int t,double FFinf,double FF_2,
- double vv,const GeneralMatrix&LL_0,
- const GeneralMatrix&LL_1,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll);
- void set(int t,double FFstar,double vv,
- const GeneralMatrix&LL_0,const Vector&aa,
- const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- double ll);
- int getDiffusePeriods()const;
- bool isFinfRegular(int t)const;
- bool isPinfZero(int t)const;
- double getFinf(int t)const;
- double getFstar(int t)const;
- double getF2(int t)const;
- const GeneralMatrix&getL0(int t)const
- {return getL(t);}
- const GeneralMatrix&getL1(int t)const;
- const GeneralMatrix&getPstar(int t)const
- {return getP(t);}
- const GeneralMatrix&getPinf(int t)const;
- };
-
-
-class KalmanUniTask{
- private:
- MesEquation me;
- protected:
- SSFormUni ssf;
- ConstGeneralMatrix data;
- const StateInit&init;
- public:
- KalmanUniTask(const KalmanTask&kt);
- double filter(int&per,int&d)const;
- double filter(int&per,int&d, int start, std::vector<double>* vll)const;
- double filter_and_smooth(SmootherResults&sres,int&per,int&d)const;
- protected:
- void filterNonDiffuse(const Vector&a,const GeneralMatrix&Pstar,
- int first,FilterUniResults&fres)const;
- void filterDiffuse(const Vector&a,const GeneralMatrix&Pstar,
- const GeneralMatrix&Pinf,int first,
- DiffuseFilterUniResults&fres)const;
- void smootherNonDiffuse(const FilterUniResults&fres,SmootherResults&sres)const;
- void smootherDiffuse(const DiffuseFilterUniResults&fres,SmootherResults&sres)const;
- void smootherNonDiffuseStep(int t,const FilterUniResults&fres,
- Vector&rt,GeneralMatrix&Nt,
- Vector&alphat,GeneralMatrix&Vt,
- Vector&etat)const;
- static double calcStepLogLik(double F,double v);
- };
-
-
-#endif
-
diff --git a/mex/sources/kalman/cc/ssf.cpp b/mex/sources/kalman/cc/ssf.cpp
deleted file mode 100644
index 44e69d88aff13bff8413c1bfcd5030d9dca5607d..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/ssf.cpp
+++ /dev/null
@@ -1,323 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#include "ssf.h"
-#include "ts_exception.h"
-#include "utils.h"
-
-#include <vector>
-
-
-TMatrixCycle::TMatrixCycle(int n,int nr,int nc)
-:matrices(new GeneralMatrix*[n]),num(n),nrows(nr),ncols(nc)
- {
- for(int i= 0;i<num;i++)
- matrices[i]= NULL;
- }
-
-;
-
-TMatrixCycle::TMatrixCycle(const TMatrixCycle&m)
-:matrices(new GeneralMatrix*[m.num]),num(m.num),
-nrows(m.nrows),ncols(m.ncols)
- {
- for(int i= 0;i<num;i++)
- if(m.matrices[i])
- matrices[i]= new GeneralMatrix(*(m.matrices[i]));
- else
- matrices[i]= NULL;
- }
-
-;
-
-TMatrixCycle::TMatrixCycle(const GeneralMatrix&m)
-:matrices(new GeneralMatrix*[m.numRows()]),num(m.numRows()),
-nrows(1),ncols(m.numCols())
- {
- for(int i= 0;i<num;i++)
- matrices[i]= new GeneralMatrix(m,i,0,1,ncols);
- }
-
-;
-
-TMatrixCycle::TMatrixCycle(const TMatrix&m,const char*dummy)
-:matrices(new GeneralMatrix*[m.numRows()*m.period()]),
-num(m.numRows()*m.period()),nrows(1),ncols(m.numCols())
- {
- TS_RAISE_IF(m.period()==0,
- "Infinite period in TMatrixCycle constructor");
- for(int i= 0;i<m.period();i++)
- for(int j= 0;j<m.numRows();j++)
- matrices[i*m.numRows()+j]
- = new GeneralMatrix(m[i],j,0,1,ncols);
- }
-
-;
-
-TMatrixCycle::~TMatrixCycle()
- {
- for(int i= 0;i<num;i++)
- delete matrices[i];
- delete[]matrices;
- }
-
-;
-
-const GeneralMatrix&TMatrixCycle::operator[](int t)const
- {
- int i= (t-1)%num;
- TS_RAISE_IF(matrices[i]==NULL,
- "The matrix has not ben set in TMatrixCycle::operator[]");
- return*(matrices[i]);
- }
-
-GeneralMatrix&TMatrixCycle::operator[](int t)
- {
- int i= (t-1)%num;
- TS_RAISE_IF(matrices[i]==NULL,
- "The matrix has not ben set in TMatrixCycle::operator[]");
- return*(matrices[i]);
- }
-
-;
-
-void TMatrixCycle::set(int t,const GeneralMatrix&m)
- {
- TS_RAISE_IF(m.numRows()!=numRows()||m.numCols()!=numCols(),
- "Wrong matrix dimensions for TMatrixCycle::set");
- int i= (t-1)%num;
- if(matrices[i])
- delete matrices[i];
- matrices[i]= new GeneralMatrix(m);
- }
-
-;
-
-TMatrixPadUnit::TMatrixPadUnit(const TMatrix&m,int s)
-:tmat(m.clone()),skip(s),unit(m.numRows(),m.numRows())
- {
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "TMatrix not square in TMatrixPadUnit constructor");
- unit.zeros();
- for(int i= 0;i<numRows();i++)
- unit.get(i,i)= 1.0;
- }
-
-;
-
-const GeneralMatrix&TMatrixPadUnit::operator[](int t)const
- {
- if(isUnit(t))
- return unit;
- else
- return(*tmat)[t/skip];
- }
-
-
-GeneralMatrix&TMatrixPadUnit::operator[](int t)
- {
- TS_RAISE_IF(isUnit(t),
- "Attempt to return non-const unit in TMatrixPadUnit::operator[]");
- return(*tmat)[t/skip];
- }
-
-
-TMatrixPadZero::TMatrixPadZero(const TMatrix&m,int s)
-:tmat(m.clone()),skip(s),zero(m.numRows(),m.numCols())
- {
- zero.zeros();
- }
-
-
-const GeneralMatrix&TMatrixPadZero::operator[](int t)const
- {
- if(isZero(t))
- return zero;
- else
- return(*tmat)[t/skip];
- }
-
-
-GeneralMatrix&TMatrixPadZero::operator[](int t)
- {
- TS_RAISE_IF(isZero(t),
- "Attempt to return non-const zero in TMatrixPadZero::operator[]");
- return(*tmat)[t/skip];
- }
-
-
-
-SSForm::SSForm(const TMatrix&zz,const TMatrix&hh,const TMatrix&tt,
- const TMatrix&rr,const TMatrix&qq)
- :Z(zz.clone()),
- H(hh.clone()),
- T(tt.clone()),
- R(rr.clone()),
- Q(qq.clone()),
- p(zz.numRows()),m(zz.numCols()),r(qq.numRows())
- {
- TS_RAISE_IF(T->numRows()!=m||T->numCols()!=m||
- H->numRows()!=p||H->numCols()!=p||
- R->numRows()!=m||R->numCols()!=r||
- Q->numCols()!=r,
- "Wrong TMatrix dimension in SSForm constructor");
- }
-
-
-SSForm::SSForm(const GeneralMatrix&zz,const GeneralMatrix&hh,
- const GeneralMatrix&tt,const GeneralMatrix&rr,
- const GeneralMatrix&qq)
- :Z(new TMatrixInvariant(zz)),
- H(new TMatrixInvariant(hh)),
- T(new TMatrixInvariant(tt)),
- R(new TMatrixInvariant(rr)),
- Q(new TMatrixInvariant(qq)),
- p(zz.numRows()),m(zz.numCols()),r(qq.numRows())
- {
- TS_RAISE_IF(T->numRows()!=m||T->numCols()!=m||
- H->numRows()!=p||H->numCols()!=p||
- R->numRows()!=m||R->numCols()!=r||
- Q->numCols()!=r,
- "Wrong TMatrix dimension in SSForm constructor");
- }
-
-
-SSForm::SSForm(const SSForm&f)
-:Z(f.Z->clone()),
-H(f.H->clone()),
-T(f.T->clone()),
-R(f.R->clone()),
-Q(f.Q->clone()),
-p(f.p),m(f.m),r(f.r)
- {}
-
-
-
-SSForm::~SSForm()
- {
- delete Z;
- delete H;
- delete T;
- delete R;
- delete Q;
- }
-
-
-MesEquation::MesEquation(const GeneralMatrix&data,const TMatrix&zz,
- const TMatrix&hh)
- :y(data),
- Z((zz.period()*hh.period()==1)?(TMatrix*)new TMatrixInvariant(zz[1]):
- (zz.period()*hh.period()==0)?(TMatrix*)new TMatrixCycle(y.numCols(),
- zz.numRows(),zz.numCols())
- :(TMatrix*)new TMatrixCycle(zz.period()*hh.period(),zz.numRows(),zz.numCols())),
- H((zz.period()*hh.period()==1)?(TMatrix*)new TMatrixInvariant(hh[1]):
- (zz.period()*hh.period()==0)?(TMatrix*)new TMatrixCycle(y.numCols(),
- hh.numRows(),hh.numCols())
- :(TMatrix*)new TMatrixCycle(zz.period()*hh.period(),hh.numRows(),hh.numCols()))
- {
- TS_RAISE_IF(y.numRows()!=Z->numRows()||y.numRows()!=H->numRows()||
- y.numRows()!=H->numCols(),
- "Incompatible dimension in MesEquation constructor");
-
- int mper= zz.period()*hh.period();
- if(mper==1)
- {
- construct_invariant();
- }
- else
- {
- std::vector<NormCholesky*> chols;
- int per= (mper==0)?y.numCols():mper;
- for(int t= 1;t<=per;t++)
- {
- GeneralMatrix ycol(y,0,t-1,y.numRows(),1);
- int hi= t;
- if(hh.period()> 0)
- hi= (t-1)%hh.period()+1;
- NormCholesky*ch;
- if(hh.period()==0)
- {
- ch= new NormCholesky(hh[t]);
- }
- else if(hi-1>=(int)chols.size())
- {
- ch= new NormCholesky(hh[t]);
- chols.push_back(ch);
- }
- else
- {
- ch= chols[hi-1];
- }
- ch->getL().multInvLeftUnit(ycol);
- if(t-1<mper)
- {
- GeneralMatrix Zt(zz[t]);
- ch->getL().multInvLeftUnit(Zt);
- ((TMatrixCycle*)Z)->set(t,Zt);
- GeneralMatrix Ht(hh.numRows(),hh.numRows());
- Ht.zeros();
- for(int i= 0;i<Ht.numRows();i++)
- Ht.get(i,i)= ch->getD()[i];
- ((TMatrixCycle*)H)->set(t,Ht);
- }
- if(hh.period()==0)
- delete ch;
- }
- for(unsigned int i= 0;i<chols.size();i++)
- delete chols[i];
- }
- }
-
-MesEquation::MesEquation(const GeneralMatrix&data,const GeneralMatrix&zz,
- const GeneralMatrix&hh)
- :y(data),
- Z(new TMatrixInvariant(zz)),
- H(new TMatrixInvariant(hh))
- {
- TS_RAISE_IF(y.numRows()!=Z->numRows()||y.numRows()!=H->numRows()||
- y.numRows()!=H->numCols(),
- "Incompatible dimension in MesEquation constructor");
-
- construct_invariant();
- }
-
-
-MesEquation::~MesEquation()
- {
- delete Z;
- delete H;
- }
-
-void MesEquation::construct_invariant()
- {
- if(!TSUtils::isDiagonal((*H)[1]))
- {
- NormCholesky chol((*H)[1]);
- chol.getL().multInvLeftUnit(y);
- chol.getL().multInvLeftUnit((*Z)[1]);
- (*H)[1].zeros();
- for(int i= 0;i<H->numRows();i++)
- (*H)[1].get(i,i)= chol.getD()[i];
- }
- }
-
-;
-
diff --git a/mex/sources/kalman/cc/ssf.h b/mex/sources/kalman/cc/ssf.h
deleted file mode 100644
index 30dfb2d431675eaa36311654769e33a9a9333e86..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/ssf.h
+++ /dev/null
@@ -1,193 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#ifndef SSF_H
-#define SSF_H
-
-#include "GeneralMatrix.h"
-
-
-class TMatrix{
- public:
- virtual const GeneralMatrix&operator[](int t)const= 0;
- virtual GeneralMatrix&operator[](int t)= 0;
- virtual int numRows()const= 0;
- virtual int numCols()const= 0;
- virtual int period()const= 0;
- virtual bool isZero(int t)const= 0;
- virtual bool isUnit(int t)const= 0;
- virtual~TMatrix(){}
- virtual TMatrix*clone()const= 0;
- };
-
-
-class TMatrixInvariant:public TMatrix,public GeneralMatrix{
- public:
- TMatrixInvariant(const GeneralMatrix&m)
- :GeneralMatrix(m){}
- TMatrixInvariant(const TMatrixInvariant&m)
- :GeneralMatrix(m){}
- const GeneralMatrix&operator[](int t)const
- {return*this;}
- GeneralMatrix&operator[](int t)
- {return*this;}
- int numRows()const
- {return GeneralMatrix::numRows();}
- int numCols()const
- {return GeneralMatrix::numCols();}
- int period()const
- {return 1;}
- bool isZero(int t)const
- {return false;}
- bool isUnit(int t)const
- {return false;}
- TMatrix*clone()const
- {return new TMatrixInvariant(*this);}
- };
-
-
-
-class TMatrixCycle:public TMatrix{
- protected:
- GeneralMatrix**const matrices;
- int num;
- int nrows;
- int ncols;
- public:
- TMatrixCycle(int n,int nr,int nc);
- TMatrixCycle(const TMatrixCycle&m);
-
- TMatrixCycle(const GeneralMatrix&m);
-
- TMatrixCycle(const TMatrix&m,const char*dummy);
- ~TMatrixCycle();
- const GeneralMatrix&operator[](int t)const;
- GeneralMatrix&operator[](int t);
- int numRows()const
- {return nrows;}
- int numCols()const
- {return ncols;}
- int period()const
- {return num;}
- bool isZero(int t)const
- {return false;}
- bool isUnit(int t)const
- {return false;}
- TMatrix*clone()const
- {return new TMatrixCycle(*this);}
- void set(int t,const GeneralMatrix&m);
- };
-
-
-class TMatrixPadUnit:public TMatrix{
- TMatrix*const tmat;
- int skip;
- GeneralMatrix unit;
- public:
- TMatrixPadUnit(const TMatrix&m,int s);
- TMatrixPadUnit(const TMatrixPadUnit&m)
- :tmat(m.tmat->clone()),skip(m.skip),unit(m.unit){}
- ~TMatrixPadUnit()
- {delete tmat;}
- const GeneralMatrix&operator[](int t)const;
- GeneralMatrix&operator[](int t);
- int numRows()const
- {return tmat->numRows();}
- int numCols()const
- {return tmat->numCols();}
- int period()const
- {return skip*tmat->period();}
- bool isZero(int t)const
- {return false;}
- bool isUnit(int t)const
- {return(t/skip)*skip!=t;}
- TMatrix*clone()const
- {return new TMatrixPadUnit(*this);}
- };
-
-
-class TMatrixPadZero:public TMatrix{
- TMatrix*const tmat;
- int skip;
- GeneralMatrix zero;
- public:
- TMatrixPadZero(const TMatrix&m,int s);
- TMatrixPadZero(const TMatrixPadZero&m)
- :tmat(m.tmat->clone()),skip(m.skip),zero(m.zero){}
- ~TMatrixPadZero()
- {delete tmat;}
- const GeneralMatrix&operator[](int t)const;
- GeneralMatrix&operator[](int t);
- int numRows()const
- {return tmat->numRows();}
- int numCols()const
- {return tmat->numCols();}
- int period()const
- {return skip*tmat->period();}
- bool isUnit(int t)const
- {return false;}
- bool isZero(int t)const
- {return(t/skip)*skip!=t;}
- TMatrix*clone()const
- {return new TMatrixPadZero(*this);}
- };
-
-
-
-struct SSForm{
- TMatrix*const Z;
- TMatrix*const H;
- TMatrix*const T;
- TMatrix*const R;
- TMatrix*const Q;
- const int p;
- const int m;
- const int r;
-
- SSForm(const TMatrix&zz,const TMatrix&hh,const TMatrix&tt,
- const TMatrix&rr,const TMatrix&qq);
- SSForm(const GeneralMatrix&zz,const GeneralMatrix&hh,
- const GeneralMatrix&tt,const GeneralMatrix&rr,
- const GeneralMatrix&qq);
- SSForm(const SSForm&f);
-
- ~SSForm();
- };
-
-
-struct MesEquation{
- GeneralMatrix y;
- TMatrix*const Z;
- TMatrix*const H;
-
- MesEquation(const GeneralMatrix&data,const GeneralMatrix&zz,
- const GeneralMatrix&hh);
- MesEquation(const GeneralMatrix&data,const TMatrix&zz,
- const TMatrix&hh);
- ~MesEquation();
- protected:
- void construct_invariant();
- };
-
-
-;
-#endif
-
diff --git a/mex/sources/kalman/cc/ssf_uni.cpp b/mex/sources/kalman/cc/ssf_uni.cpp
deleted file mode 100644
index 3f39d543da8627a82912b3509520bf4c270701c3..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/ssf_uni.cpp
+++ /dev/null
@@ -1,166 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#include "ssf_uni.h"
-#include "ts_exception.h"
-
-
-TScalarCycle::TScalarCycle(int n)
-:ss(new double[n]),flags(new bool[n]),num(n)
- {
- for(int i= 0;i<num;i++)
- flags[i]= false;
- }
-
-;
-
-TScalarCycle::TScalarCycle(const TScalarCycle&c)
-:ss(new double[c.num]),flags(new bool[c.num]),num(c.num)
- {
- for(int i= 0;i<num;i++){
- flags[i]= c.flags[i];
- ss[i]= c.ss[i];
- }
- }
-
-;
-
-TScalarCycle::TScalarCycle(const GeneralMatrix&m)
-:ss(new double[m.numRows()]),flags(new bool[m.numRows()]),
-num(m.numRows())
- {
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "Matrix is not diagonal in TScalarCycle diagonal constructor");
- for(int i= 0;i<m.numRows();i++){
- ss[i]= m.get(i,i);
- flags[i]= true;
- }
- }
-
-;
-
-TScalarCycle::TScalarCycle(const TMatrix&m)
-:ss(new double[m.numRows()*m.period()]),
-flags(new bool[m.numRows()*m.period()]),
-num(m.numRows()*m.period())
- {
- TS_RAISE_IF(m.period()==0,
- "Infinite period in TScalarCycle diagonal constructor");
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "TMatrix is not diagonal in TScalarCycle diagonal constructor");
- for(int i= 0;i<m.period();i++)
- for(int j= 0;j<m.numRows();j++){
- ss[i*m.numRows()+j]= m[i].get(j,j);
- flags[i*m.numRows()+j]= true;
- }
- }
-
-
-;
-
-TScalarCycle::~TScalarCycle()
- {
- delete[]flags;
- delete[]ss;
- }
-
-;
-
-const double&TScalarCycle::operator[](int t)const
- {
- int i= (t-1)%num;
- TS_RAISE_IF(!flags[i],
- "The scalar has not been set in TScalarCycle::operator[]");
- return ss[i];
- }
-
-
-;
-
-void TScalarCycle::set(int t,double s)
- {
- int i= (t-1)%num;
- flags[i]= true;
- ss[i]= s;
- }
-
-;
-
-SSFormUni::SSFormUni(const TMatrix&zz,const TScalar&hh,const TMatrix&tt,
- const TMatrix&rr,const TMatrix&qq)
- :Z(zz.clone()),
- H(hh.clone()),
- T(tt.clone()),
- R(rr.clone()),
- Q(qq.clone()),
- m(zz.numCols()),r(qq.numRows())
- {
- TS_RAISE_IF(T->numRows()!=m||T->numCols()!=m||
- R->numRows()!=m||R->numCols()!=r||
- Q->numCols()!=r,
- "Wrong TMatrix dimension in SSFormUni constructor");
- TS_RAISE_IF(Z->numRows()!=1,
- "Z is not univariate in SSFormUni constructor");
- }
-
-;
-
-SSFormUni::SSFormUni(const GeneralMatrix&zz,double hh,
- const GeneralMatrix&tt,const GeneralMatrix&rr,
- const GeneralMatrix&qq)
- :Z(new TMatrixInvariant(zz)),
- H(new TScalarInvariant(hh)),
- T(new TMatrixInvariant(tt)),
- R(new TMatrixInvariant(rr)),
- Q(new TMatrixInvariant(qq)),
- m(zz.numCols()),r(qq.numRows())
- {
- TS_RAISE_IF(T->numRows()!=m||T->numCols()!=m||
- R->numRows()!=m||R->numCols()!=r||
- Q->numCols()!=r,
- "Wrong TMatrix dimension in SSFormUni constructor");
- TS_RAISE_IF(Z->numRows()!=1,
- "Z is not univariate in SSFormUni constructor");
- }
-
-SSFormUni::SSFormUni(const SSFormUni&ssfu)
-:Z(ssfu.Z->clone()),
-H(ssfu.H->clone()),
-T(ssfu.T->clone()),
-R(ssfu.R->clone()),
-Q(ssfu.Q->clone()),
-m(ssfu.m),r(ssfu.r)
- {}
-
-
-
-SSFormUni::~SSFormUni()
- {
- delete Z;
- delete H;
- delete T;
- delete R;
- delete Q;
- }
-
-
-;
-
diff --git a/mex/sources/kalman/cc/ssf_uni.h b/mex/sources/kalman/cc/ssf_uni.h
deleted file mode 100644
index a0d0ba65deab1a59beb3c7071d1694da22c54285..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/ssf_uni.h
+++ /dev/null
@@ -1,101 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#ifndef SSF_UNI_H
-#define SSF_UNI_H
-
-#include "ssf.h"
-
-
-class TScalar{
- public:
- virtual const double&operator[](int t)const= 0;
- virtual~TScalar(){}
- virtual int period()const= 0;
- virtual TScalar*clone()const= 0;
- };
-
-;
-
-class TScalarInvariant:public TScalar{
- protected:
- double s;
- public:
- TScalarInvariant(double ss)
- :s(ss){}
- TScalarInvariant(const TScalarInvariant&c)
- :s(c.s){}
- const double&operator[](int t)const
- {return s;}
-
- int period()const
- {return 1;}
- TScalar*clone()const
- {return new TScalarInvariant(*this);}
- };
-
-;
-
-class TScalarCycle:public TScalar{
- protected:
- double*const ss;
- bool*const flags;
- int num;
- public:
- TScalarCycle(int n);
- TScalarCycle(const TScalarCycle&c);
-
- TScalarCycle(const GeneralMatrix&m);
-
- TScalarCycle(const TMatrix&m);
- ~TScalarCycle();
- const double&operator[](int t)const;
- int period()const
- {return num;}
- TScalar*clone()const
- {return new TScalarCycle(*this);}
- void set(int t,double s);
- };
-
-;
-
-struct SSFormUni{
- TMatrix*const Z;
- TScalar*const H;
- TMatrix*const T;
- TMatrix*const R;
- TMatrix*const Q;
- const int m;
- const int r;
-
- SSFormUni(const TMatrix&zz,const TScalar&hh,const TMatrix&tt,
- const TMatrix&rr,const TMatrix&qq);
- SSFormUni(const GeneralMatrix&zz,double hh,
- const GeneralMatrix&tt,const GeneralMatrix&rr,
- const GeneralMatrix&qq);
- SSFormUni(const SSFormUni&ssfu);
- ~SSFormUni();
- };
-
-;
-
-#endif
-
diff --git a/mex/sources/kalman/cc/state_init.cpp b/mex/sources/kalman/cc/state_init.cpp
deleted file mode 100644
index d0d5ce79f3778ced11734e57747bcd6383a915de..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/state_init.cpp
+++ /dev/null
@@ -1,59 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#include "state_init.h"
-#include "ts_exception.h"
-#include "utils.h"
-
-
-StateInit::StateInit(const GeneralMatrix&PPstar,const Vector&aa)
-:m(PPstar.numRows()),ndiffuse(0),Pstar(PPstar),
-Pinf(m,m),a(aa)
- {
- TS_RAISE_IF(Pstar.numRows()!=Pstar.numCols(),
- "Pstar not square in StateInit non-diffuse constructor");
- TS_RAISE_IF(m!=a.length(),
- "Bad length of initial state vector in StateInit non-diffuse constructor");
- Pinf.zeros();
- }
-
-;
-
-StateInit::StateInit(const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- const Vector&aa)
- :m(PPstar.numRows()),ndiffuse(0),Pstar(PPstar),
- Pinf(PPinf),a(aa)
- {
- TS_RAISE_IF(m!=Pstar.numCols()||m!=Pinf.numRows()||
- m!=Pinf.numCols()||m!=a.length(),
- "Wrong dimensions for StateInit diffuse constructor");
- TS_RAISE_IF(!TSUtils::isDiagonal(Pinf),
- "Pinf is not diagonal in StateInit diffuse constructor");
-
- for(int i= 0;i<m;i++)
- if(Pinf.get(i,i)!=0.0)
- ndiffuse++;
- }
-
-
-
-;
-
diff --git a/mex/sources/kalman/cc/state_init.h b/mex/sources/kalman/cc/state_init.h
deleted file mode 100644
index d9c28359851626a2a2ff7be2ba26eb4fe55684ae..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/state_init.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#ifndef STATE_INIT_H
-#define STATE_INIT_H
-
-#include "GeneralMatrix.h"
-
-
-class StateInit{
- const int m;
- int ndiffuse;
- GeneralMatrix Pstar;
- GeneralMatrix Pinf;
- Vector a;
- public:
- StateInit(const GeneralMatrix&PPstar,const Vector&aa);
- StateInit(const GeneralMatrix&PPstar,const GeneralMatrix&PPinf,
- const Vector&aa);
- StateInit(const StateInit&init)
- :m(init.m),ndiffuse(init.ndiffuse),Pstar(init.Pstar),
- Pinf(init.Pinf),a(init.a){}
- virtual~StateInit(){}
- int getM()const
- {return m;}
- bool isDiffuse()const
- {return ndiffuse> 0;}
- const Vector&getA()const
- {return a;}
- const GeneralMatrix&getPstar()const
- {return Pstar;}
- const GeneralMatrix&getPinf()const
- {return Pinf;}
- int getNDiff()const
- {return ndiffuse;}
- };
-
-
-;
-
-#endif
-
diff --git a/mex/sources/kalman/cc/ts_exception.h b/mex/sources/kalman/cc/ts_exception.h
deleted file mode 100644
index 1079495de1975a1a111d77a0274b2b7621c3dc55..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/ts_exception.h
+++ /dev/null
@@ -1,64 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#ifndef TS_EXCEPTION_H
-#define TS_EXCEPTION_H
-
-#include <stdio.h>
-#include <string.h>
-
-#ifdef MATLAB
-#include "mex.h"
-#endif
-
-#define TS_RAISE(mes) \
-throw TSException(__FILE__, __LINE__, mes);
-
-#define TS_RAISE_IF(expr, mes) \
-if (expr) throw TSException(__FILE__, __LINE__, mes);
-
-
-class TSException{
- char fname[50];
- int lnum;
- char message[500];
- public:
- TSException(const char*f,int l,const char*mes)
- {
- strncpy(fname,f,50);fname[49]= '\0';
- strncpy(message,mes,500);message[499]= '\0';
- lnum= l;
- }
- virtual void print()const
- {
- printf("At %s:%d:%s\n",fname,lnum,message);
-#ifdef MATLAB
- mexPrintf("At %s:%d:%s\n",fname,lnum,message);
-#endif
- }
-
- virtual const char*getMessage()const
- {return message;}
- };
-
-;
-#endif
-
diff --git a/mex/sources/kalman/cc/utils.cpp b/mex/sources/kalman/cc/utils.cpp
deleted file mode 100644
index ec829f098bedd05523f3940e3ce707133f78025b..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/utils.cpp
+++ /dev/null
@@ -1,411 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#include "utils.h"
-#include "ts_exception.h"
-#include "cppblas.h"
-#include "cpplapack.h"
-
-#include <math.h>
-#include <cmath>
-#include <float.h>
-
-
-LowerTriangle::LowerTriangle(const GeneralMatrix&m)
-:GeneralMatrix(m)
- {
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "The matrix is not square in LowerTriangle constructor");
- }
-
-
-void LowerTriangle::multInvLeft(GeneralMatrix&m)const
- {
- TS_RAISE_IF(numCols()!=m.numRows(),
- "Wrong dimensions of the matrix for LowerTriangle::multInvLeft");
- int mrows= m.numRows();
- int mcols= m.numCols();
- double alpha= 1.0;
- int ld= getLD();
- int ldm= m.getLD();
- BLAS_dtrsm("L","L","N","N",&mrows,&mcols,&alpha,getData().base(),
- &ld,m.getData().base(),&ldm);
- }
-
-;
-
-void LowerTriangle::multInvLeftUnit(GeneralMatrix&m)const
- {
- TS_RAISE_IF(numCols()!=m.numRows(),
- "Wrong dimensions of the matrix for LowerTriangle::multInvLeftUnit");
- int mrows= m.numRows();
- int mcols= m.numCols();
- double alpha= 1.0;
- int ld= getLD();
- int ldm= m.getLD();
- BLAS_dtrsm("L","L","N","U",&mrows,&mcols,&alpha,getData().base(),
- &ld,m.getData().base(),&ldm);
- }
-
-
-;
-
-NormCholesky::NormCholesky(const GeneralMatrix&a)
-:L(a),D(a.numRows())
- {
- TS_RAISE_IF(a.numRows()!=a.numCols(),
- "The matrix is not square in NormCholesky constructor");
-
- int lrows= L.numRows();
- int ldl= L.getLD();
- int info;
- LAPACK_dpotrf("L",&lrows,L.getData().base(),&ldl,&info);
- TS_RAISE_IF(info> 0,
- "The matrix is not positive definite in NormCholesky constructor");
- TS_RAISE_IF(info<0,
- "Internal error in NormCholesky constructor");
-
- for(int i= 0;i<L.numRows();i++)
- for(int j= i+1;j<L.numCols();j++)
- L.get(i,j)= 0.0;
-
- for(int j= 0;j<L.numCols();j++){
- double d= L.get(j,j);
- Vector Lj(L,j);
- Lj.mult(1.0/d);
- D[j]= d*d;
- }
-
- }
-
-;
-
-PLUFact::PLUFact(const GeneralMatrix&m)
-:inv(m.numRows()*m.numCols()),ipiv(new int[m.numRows()]),
-rows(m.numRows())
- {
- TS_RAISE_IF(!m.isFinite(),
- "Matrix is not finite in PLUFact constructor");
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "Matrix not square in PLUFact constructor");
- inv= m.getData();
- LAPACK_dgetrf(&rows,&rows,inv.base(),&rows,ipiv,&info);
- TS_RAISE_IF(info<0,
- "Internal error in PLUFact constructor");
-
- double mnorm= m.getNormInf();
- double*work= new double[4*rows];
- int*iwork= new int[rows];
- int infotmp;
- LAPACK_dgecon("I",&rows,inv.base(),&rows,&mnorm,&rcond,work,
- iwork,&infotmp);
- delete[]iwork;
- delete[]work;
- TS_RAISE_IF(infotmp<0,
- "Internal error in PLUFact constructor");
-
- ;
- calcDetSign();
- }
-
-
-PLUFact::PLUFact(const PLUFact&fact)
-:inv(fact.inv),ipiv(new int[fact.rows]),
-rows(fact.rows),rcond(fact.rcond),detsign(fact.detsign),info(fact.info)
- {
- memcpy(ipiv,fact.ipiv,rows*sizeof(int));
- }
-
-PLUFact::PLUFact(const int nc,const int nr )
- :inv(nr*nc),ipiv(new int[nr]),rows(nr)
- {
- TS_RAISE_IF(nr!=nc,
- "Matrix not square in PLUFact constructor");
- }
-
-const PLUFact&
-PLUFact::operator = (const GeneralMatrix&m)
- {
- TS_RAISE_IF(!m.isFinite(),
- "Matrix is not finite in PLUFact assignement");
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "Matrix not square in PLUFact assignement");
- TS_RAISE_IF(m.numRows()!=rows,
- "Matrix not matching PLUFact size for assignement");
- inv= m.getData();
- LAPACK_dgetrf(&rows,&rows,inv.base(),&rows,ipiv,&info);
- TS_RAISE_IF(info<0,
- "Internal error in PLUFact assignement");
-
- double mnorm= m.getNormInf();
- double*work= new double[4*rows];
- int*iwork= new int[rows];
- int infotmp;
- LAPACK_dgecon("I",&rows,inv.base(),&rows,&mnorm,&rcond,work,
- iwork,&infotmp);
- delete[]iwork;
- delete[]work;
- TS_RAISE_IF(infotmp<0,
- "Internal error in PLUFact assignement");
- calcDetSign();
- return *this;
- }
-
-;
-
-void PLUFact::PL_dgetrs(const char*trans,double*b,int ldb,int bcols)const
- {
- if(rows> 0){
- int info;
- LAPACK_dgetrs(trans,&rows,&bcols,inv.base(),&rows,ipiv,b,&ldb,&info);
- TS_RAISE_IF(info<0,
- "Internal error in PLUFact::dgetrs");
- }
- }
-
-;
-
-void PLUFact::multInvLeft(GeneralMatrix&a)const
- {
- TS_RAISE_IF(rows!=a.numRows(),
- "Wrong dimension of the matrix in PLUFact::multInvLeft");
- PL_dgetrs("N",a.getData().base(),a.getLD(),a.numCols());
- }
-
-;
-
-void PLUFact::multInvRight(GeneralMatrix&a)const
- {
- GeneralMatrix atrans(a,"trans");
- TS_RAISE_IF(rows!=atrans.numRows(),
- "Wrong dimension of the matrix in PLUFact::multInvRight");
- PL_dgetrs("T",atrans.getData().base(),atrans.getLD(),atrans.numCols());
- for(int i= 0;i<a.numRows();i++)
- for(int j= 0;j<a.numCols();j++)
- a.get(i,j)= atrans.get(j,i);
- }
-
-// pass also a temporary GM space for atrans to avoid matrix construction:
-void PLUFact::multInvRight(GeneralMatrix&a, GeneralMatrix&atrans)const
- {
- TS_RAISE_IF(rows!=atrans.numRows(),
- "Wrong dimension of the matrix in PLUFact::multInvRight");
- for(int i= 0;i<a.numRows();i++)
- for(int j= 0;j<a.numCols();j++)
- atrans.get(j,i)= a.get(i,j);
- PL_dgetrs("T",atrans.getData().base(),atrans.getLD(),atrans.numCols());
- for(int i= 0;i<a.numRows();i++)
- for(int j= 0;j<a.numCols();j++)
- a.get(i,j)= atrans.get(j,i);
- }
-;
-
-void PLUFact::multInvLeft(Vector&a)const
- {
- TS_RAISE_IF(rows!=a.length(),
- "Wrong dimension of the vector in PLUFact::multInvLeft");
- TS_RAISE_IF(a.skip()!=1,
- "Not implemented error in PLUFact::multInvLeft");
- PL_dgetrs("N",a.base(),a.length(),1);
- }
-
-;
-
-void PLUFact::multInvRight(Vector&a)const
- {
- TS_RAISE_IF(rows!=a.length(),
- "Wrong dimension of the vector in PLUFact::multInvLeft");
- TS_RAISE_IF(a.skip()!=1,
- "Not implemented error in PLUFact::multInvLeft");
- PL_dgetrs("T",a.base(),a.length(),1);
- }
-
-
-;
-
-double PLUFact::getDeterminant()const
- {
- double res= 1;
- for(int i= 0;i<rows;i++)
- res*= std::abs(inv[(rows+1)*i]);
- return detsign*res;
- }
-
-;
-
-double PLUFact::getLogDeterminant()const
- {
- double res= 0;
- for(int i= 0;i<rows;i++)
- res+= log(std::abs(inv[(rows+1)*i]));
- TS_RAISE_IF(detsign==-1,
- "Negative determinant in PLUFact::getLogDeterminant");
- return res;
- }
-
-;
-
-void PLUFact::calcDetSign()
- {
- detsign= 1;
-
- for(int i= 0;i<rows;i++)
- if(ipiv[i]!=i+1)
- detsign*= -1;
-
- for(int i= 0;i<rows;i++)
- if(inv[i*(rows+1)]<0)
- detsign*= -1;
-
- }
-
-;
-
-void PLUFact::print()const
- {
- for(int i= 0;i<rows;i++)
- printf(" %d",ipiv[i]);
- printf("\n");
- for(int i= 0;i<rows;i++){
- for(int j= 0;j<rows;j++)
- printf(" %15.12g",inv[j*rows+i]);
- printf("\n");
- }
- }
-
-;
-
-VDVFact::VDVFact(const GeneralMatrix&m)
-:V(m),D(m.numRows())
- {
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "Matrix is not square in VDVFact constructor");
-
- int n= m.numRows();
- int lda= V.getLD();
- double tmpwork;
- int lwork= -1;
- int info;
- LAPACK_dsyev("V","U",&n,V.base(),&lda,D.base(),&tmpwork,&lwork,&info);
- lwork= (int)tmpwork;
- double*work= new double[lwork];
- LAPACK_dsyev("V","U",&n,V.base(),&lda,D.base(),work,&lwork,&info);
- delete[]work;
-
- TS_RAISE_IF(info<0,
- "Internal error in VDVFact constructor");
- converged= true;
- if(info)
- converged= false;
- }
-
-
-;
-
-bool TSUtils::isDiagonal(const ConstGeneralMatrix&m)
- {
- bool res= (m.numCols()==m.numRows());
- for(int i= 0;i<m.numRows()&&res;i++)
- for(int j= i+1;j<m.numCols()&&res;j++)
- if(m.get(i,j)!=0.0||m.get(j,i)!=0.0)
- res= false;
- return res;
- }
-
-;
-
-bool TSUtils::isZero(const ConstGeneralMatrix&m)
- {
- bool res= true;
- for(int i= 0;i<m.numRows()&&res;i++)
- for(int j= 0;j<m.numCols()&&res;j++)
- if(m.get(i,j)!=0.0)
- res= false;
- return res;
- }
-
-;
-
-bool TSUtils::hasNegativeDiagonal(const ConstGeneralMatrix&m)
- {
- int r= m.numRows()<m.numCols()?m.numRows():m.numCols();
- bool res= false;
- for(int i= 0;i<r&&!res;i++)
- res= m.get(i,i)<0.0;
- return res;
- }
-
-;
-
-bool TSUtils::isSymDiagDominant(const ConstGeneralMatrix&m)
- {
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "The matrix is not square in TSUtils::isSymDiagDominant");
-
- bool res= true;
- for(int i= 0;i<m.numRows()&&res;i++)
- for(int j= i+1;j<m.numCols()&&res;j++)
- res= 2*std::abs(m.get(i,j))<=
- std::abs(m.get(i,i))+std::abs(m.get(j,j));
- return res;
- }
-
-;
-
-double TSUtils::correctDefinitness(GeneralMatrix&m)
- {
- VDVFact f(m);
- if(!f.hasConverged())
- return-1;
-
- Vector d(f.getD());
- double correct= 0;
- int i= 0;
- while(i<d.length()&&d[i]<2*DBL_EPSILON){
- correct+= d[i]*d[i];
- d[i]= 0.0;
- i++;
- }
-
- m= f.getV();
- for(int i= 0;i<d.length();i++){
- Vector mi(m,i);
- mi.mult(d[i]);
- }
- m.multRightTrans(f.getV());
-
- return sqrt(correct);
- }
-
-;
-
-void TSUtils::correctSymmetricity(GeneralMatrix&m)
- {
- TS_RAISE_IF(m.numRows()!=m.numCols(),
- "Matrix is not square in TSUtils::correctSymmetricity");
- GeneralMatrix tmp((const GeneralMatrix&)m,"trans");
- m.add(1.0,tmp);
- m.mult(0.5);
- }
-
-
-;
-
diff --git a/mex/sources/kalman/cc/utils.h b/mex/sources/kalman/cc/utils.h
deleted file mode 100644
index 317dc347ec59ef093180ee3f36d2c08d42620fc5..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/cc/utils.h
+++ /dev/null
@@ -1,121 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-#ifndef UTILS_H
-#define UTILS_H
-
-#include "GeneralMatrix.h"
-
-
-class LowerTriangle:public GeneralMatrix{
- public:
- LowerTriangle(const GeneralMatrix&m);
- LowerTriangle(const LowerTriangle&t)
- :GeneralMatrix(t){}
- void multInvLeft(GeneralMatrix&m)const;
- void multInvLeftUnit(GeneralMatrix&m)const;
- };
-
-;
-
-class NormCholesky{
- LowerTriangle L;
- Vector D;
- public:
- NormCholesky(const GeneralMatrix&m);
- NormCholesky(const NormCholesky&chol)
- :L(chol.L),D(chol.D){}
- const LowerTriangle&getL()const
- {return L;}
- const Vector&getD()const
- {return D;}
- };
-
-;
-
-class PLUFact{
- Vector inv;
- int*ipiv;
- int rows;
- double rcond;
- int detsign;
- int info;
- public:
- PLUFact(const GeneralMatrix&m);
- PLUFact(const PLUFact&plu);
- PLUFact(const int nc,const int nr );
- virtual~PLUFact()
- {delete[]ipiv;}
- const PLUFact& operator = (const GeneralMatrix&m);
- void multInvLeft(GeneralMatrix&a)const;
- void multInvRight(GeneralMatrix&a)const;
- // pass temporary GM space for atrans to avoid matrix construction:
- void multInvRight(GeneralMatrix&a, GeneralMatrix&atrans)const;
- void multInvLeft(Vector&a)const;
- void multInvRight(Vector&a)const;
- bool isRegular()const
- {return info==0;}
- double getDeterminant()const;
- double getLogDeterminant()const;
- int getDetSign()const
- {return detsign;}
- int numRows()const
- {return rows;}
- double getRcond()const
- {return rcond;}
- void print()const;
- private:
- void PL_dgetrs(const char*trans,double*b,int ldb,int bcols)const;
- void calcDetSign();
- };
-
-;
-
-class VDVFact{
- GeneralMatrix V;
- Vector D;
- bool converged;
- public:
- VDVFact(const GeneralMatrix&m);
- const GeneralMatrix&getV()const
- {return V;}
- const Vector&getD()const
- {return D;}
- bool hasConverged()const
- {return converged;}
- };
-
-
-;
-
-struct TSUtils{
- static bool isDiagonal(const ConstGeneralMatrix&m);
- static bool isZero(const ConstGeneralMatrix&m);
- static bool hasNegativeDiagonal(const ConstGeneralMatrix&m);
- static bool isSymDiagDominant(const ConstGeneralMatrix&m);
- static double correctDefinitness(GeneralMatrix&m);
- static void correctSymmetricity(GeneralMatrix&m);
- };
-
-;
-
-#endif
-
diff --git a/mex/sources/kalman/matlab/Makefile b/mex/sources/kalman/matlab/Makefile
deleted file mode 100644
index bfd5947a1058f4068e74a18cbc2a269899da49bd..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/Makefile
+++ /dev/null
@@ -1,134 +0,0 @@
-# $Id: Makefile 531 2005-11-30 13:49:48Z kamenik $
-# Copyright 2005, Ondra Kamenik
-
-
-#DEBUG = yes
-
-#LD_LIBS := -llapack -lcblas -lf77blas -latlas -lg2c
-
-#CC_FLAGS := -DWINDOWS -mno-cygwin
-
-CC_FLAGS := -DMATLAB -DNO_BLAS_H -DNO_LAPACK_H \
- -Wall -fpic -I../qt/cc -I../sylv/cc -I../cc \
- -I$(MATLAB_PATH)/extern/include #-pg
-
-ifeq ($(DEBUG),yes)
- CC_FLAGS := -DDEBUG $(CC_FLAGS) -g
-# CC_FLAGS := -DTIMING_LOOP -DDEBUG $(CC_FLAGS) -g #-pg #-Wl,-pg
- KALMANLIB := kalmanlib_dbg.a
-else
-# CC_FLAGS := $(CC_FLAGS) -O3
- CC_FLAGS := -DTIMING_LOOP $(CC_FLAGS) -O3
- KALMANLIB := kalmanlib.a
-endif
-
-# Added by GP
-# LDFLAGS := -llapack -lcblas -lf77blas -latlas -lg2c -lstdc++ -lmingw32
- #LDFLAG := -Wl,--library-path $(LD_LIBRARY_PATH)
- #-Wl,-L'C:/MinGW/lib/gcc-lib/i686-pc-mingw32/4.0.4'
- #-Wl,-llibmex -Wl,-llibmx -Wl,-llibmwlapack -Wl,-llibdflapack -lf95
- #-lg2c -lmingw32 kalmanlib.def -Wl,-lmwm_ir
- #-Wl,-L'f:/CygWin/lib'
- #LD_LIBS := -Wl,--library-path
- # -Wl,-L'/usr/lib'
-
- LD_LIBS := -Wl,-rpath-link,$(MATLAB_PATH)/bin/glnxa64 \
- -Wl,-L$(MATLAB_PATH)/bin/glnxa64 \
- -Wl,-lmex -lmx -lmwlapack -lmwblas -lmat -lm \
- -Wl,-lstdc++ $(LDFLAGS)
-
- #-Wl,-L'/usr/lib'
-
-# -Wl,-L'f:/CygWin/usr/local/atlas/lib'
-# -Wl,-L'f:/CygWin/lib'
-# -Wl,-L'f:/MinGW/lib'
-# $(LDFLAGS)
-# LD_LIBS :=$(LDFLAGS)
-# end add
-
-matrix_interface := GeneralMatrix Vector SylvException
-matobjs := $(patsubst %, ../sylv/cc/%.o, $(matrix_interface))
-mathsource := $(patsubst %, ../sylv/cc/%.h, $(matrix_interface))
-matcppsource := $(patsubst %, ../sylv/cc/%.cpp, $(matrix_interface))
-qtf90source := $(wildcard ../qt/f90/*.f90)
-qtobjs := $(patsubst %.f90,%.o,$(qtf90source))
-# cppsource := $(patsubst %.cweb,%.cpp,$(cwebsource))
-kalmancppsource := $(wildcard ../cc/*.cpp)
-kalmanhsource := $(wildcard ../cc/*.h)
-kalmanobjects := $(patsubst %.cpp,%.o,$(kalmancppsource))
-cppsource := $(wildcard *.cpp)
-hsource := $(wildcard *.h)
-objects := $(patsubst %.cpp,%.o,$(cppsource))
-hwebsource := $(wildcard *.hweb)
-cwebsource := $(wildcard *.cweb)
-
-dummy.ch:
- touch dummy.ch
-
-# %.cpp: %.cweb dummy.ch
-# ctangle -bhp $*.cweb dummy.ch $*.cpp
-
-# %.h: %.hweb dummy.ch
-# ctangle -bhp $*.hweb dummy.ch $*.h
-
-#%.o: %.cpp $(hsource) $(cppsource) #$(kalmanhsource) $(mathsource)
-
-%.o: %.cpp $(hsource) $(cppsource)
- c++ $(CC_FLAGS) -c $*.cpp
-
-
-$(KALMANLIB): $(objects) # $(matobjs) $(qtobjs) #$(kalmanobjects)
- ar cr $(KALMANLIB) $(kalmanobjects) $(matobjs) $(qtobjs)
- ranlib $(KALMANLIB)
-
-kalman_smoother_dll.dll: kalman_smoother.o $(KALMANLIB) #$(hsource) $(cppsource)
- gcc -shared $(CC_FLAGS) -o kalman_smoother_dll.dll kalman_smoother.o \
- kalmanlib.a $(LD_LIBS)
-
-minv.dll: minv.o $(KALMANLIB) # $(hsource) $(cppsource)
- gcc -shared $(CC_FLAGS) -o minv.dll minv.o \
- kalmanlib.a $(LD_LIBS)
-
-gmvm.dll: gmvm.o $(KALMANLIB) # $(hsource) $(cppsource)
- gcc -shared $(CC_FLAGS) -o gmvm.dll gmvm.o \
- kalmanlib.a $(LD_LIBS)
-
-qtamvm.dll: qtamvm.o $(KALMANLIB) # $(hsource) $(cppsource)
- gcc -shared $(CC_FLAGS) -o qtamvm.dll qtamvm.o \
- kalmanlib.a $(LD_LIBS)
-
-qtmvm.dll: qtmvm.o $(KALMANLIB) # $(hsource) $(cppsource)
- gcc -shared $(CC_FLAGS) -o qtmvm.dll qtmvm.o \
- kalmanlib.a $(LD_LIBS)
-
-disclyap_fast_dll.dll: disclyap_fast_dll.o $(KALMANLIB) # $(hsource) $(cppsource)
- gcc -shared $(CC_FLAGS) -o disclyap_fast_dll.dll disclyap_fast_dll.o \
- $(KALMANLIB) $(LD_LIBS) kalmanlib.def
-
-kalman_filter_dll.dll: kalman_filters.o $(KALMANLIB) # $(hsource) $(cppsource)
- gcc -shared $(CC_FLAGS) -o kalman_filter_dll.dll kalman_filters.o \
- $(KALMANLIB) $(LD_LIBS)
-
-kalman_filters_testx.exe: kalman_filters_testx.o $(KALMANLIB) # $(hsource) $(cppsource)
- gcc $(CC_FLAGS) -pg -o kalman_filters_testx.exe kalman_filters_testx.o \
- $(KALMANLIB) $(LD_LIBS)
-
-all: $(objects) $(KALMANLIB) kalman_smoother_dll.dll kalman_filter_dll.dll # $(cppsource) $(hsource) $(kalmanhsource) $(kalmancppsource)
-
-#kalman_filter_loop.o: kalman_filters.cpp
-# c++ -DTIMING_LOOP $(CC_FLAGS) -o kalman_filter_loop.o kalman_filters.cpp
-
-#kalman_filter_loop.dll: kalman_filter_loop.o kalmanlib.a # $(hsource) $(cppsource)
-# gcc -shared -DTIMING_LOOP $(CC_FLAGS) -o kalman_filter_loop.dll kalman_filter_loop.o \
-# kalmanlib.a $(LD_LIBS)
-
-doc: main.web $(hwebsource) $(cwebsource)
- cweave -bhp main.web
- pdftex main
- mv main.pdf ts.pdf
-
-clear:
- rm -f *.o
- rm -f *.{pdf,dvi,log,scn,idx,toc}
-# rm -f *.cpp
-# rm -f *.h
diff --git a/mex/sources/kalman/matlab/Makefile_mex b/mex/sources/kalman/matlab/Makefile_mex
deleted file mode 100644
index 78f58581286fe234d814223f3d06a68416654e32..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/Makefile_mex
+++ /dev/null
@@ -1,80 +0,0 @@
-# $Id: Makefile 532 2005-11-30 13:51:33Z kamenik $
-
-# Copyright 2005, Ondra Kamenik
-
-CC = gcc
-CC_FLAGS = -Wall -I../../sylv/cc/
-LDFLAGS = -llapack -lcblas -lf77blas -latlas -lg2c -lstdc++
-
-ifeq ($(DEBUG),yes)
- CC_FLAGS := $(CC_FLAGS) -g
-else
- CC_FLAGS := $(CC_FLAGS) -O3
-endif
-
-ifeq ($(OS),Windows_NT)
- CC_FLAGS := -mno-cygwin $(CC_FLAGS)
- LDFLAGS := -mno-cygwin $(LDFLAGS)
- ARCH := w32
- MEX_SUFFIX = dll
-else
- LDFLAGS := $(LDFLAGS)
- ARCH := linux
- MEX_SUFFIX = mexglx
-endif
-
-matrix_interface := GeneralMatrix Vector SylvException
-matobjs := $(patsubst %, ../../sylv/cc/%.o, $(matrix_interface))
-mathsource := $(patsubst %, ../../sylv/cc/%.h, $(matrix_interface))
-matcppsource := $(patsubst %, ../../sylv/cc/%.cpp, $(matrix_interface))
-
-tscwebsource := $(wildcard ../cc/*.cweb)
-tscppsource := $(patsubst %.cweb,%.cpp,$(tscwebsource))
-tshwebsource := $(wildcard ../cc/*.hweb)
-tshsource := $(patsubst %.hweb,%.h,$(tshwebsource))
-tsobjects := $(patsubst %.cweb,%.o,$(tscwebsource))
-
-cppsource := $(wildcard *.cpp)
-mexobjects := $(patsubst %.cpp,%_.$(MEX_SUFFIX),$(cppsource))
-
-all: $(mexobjects)
-
-../cc/dummy.ch:
- make -C ../cc dummy.ch
-
-../cc/%.cpp: ../cc/%.cweb ../cc/dummy.ch
- make -C ../cc $*.cpp
-
-../cc/%.h: ../cc/%.hweb ../cc/dummy.ch
- make -C ../cc $*.h
-
-../cc/%.o: ../cc/%.cpp $(tshsource)
- make -C ../cc $*.o
-
-tslib.a: $(tshwebsource) $(tscwebsoure) $(tshsource) $(tscppsource) \
- $(mathsource) $(matcppsource) \
- $(tsobjects) $(matobjs)
- ar cr tslib.a $(tsobjects) $(matobjs)
- ranlib tslib.a
-
-# to compile mex objects for Windows do:
-# 1. install gnumex
-# 2. create mexopts.bat via gnumex in this directory, specify MinGW compilation, and dll output
-# 3. change -Ic:/MATLAB7/extern/include according your Matlab setup
-# 4. pray it works
-%_.$(MEX_SUFFIX): %.cpp $(tshwebsource) $(tscwebsoure) $(tshsource) $(tscppsource) \
- $(mathsource) $(matcppsource) \
- tslib.a
-ifeq ($(OS),Windows_NT)
- mex.bat -I../../sylv/cc/ -I../cc COMPFLAGS\#"-c -DMATLAB_MEX_FILE" OPTIMFLAGS\#"-O3 -fexceptions -Ic:/MATLAB7/extern/include" GM_ADD_LIBS\#"$(LDFLAGS)" $*.cpp tslib.a
-else
- mex -cxx -I../../sylv/cc/ -I../cc $*.cpp CFLAGS="$(CC_FLAGS) -fexceptions" tslib.a $(LDFLAGS)
-endif
- mv $*.$(MEX_SUFFIX) $*_.$(MEX_SUFFIX)
-
-clear:
- rm -f tslib.a
- rm -f *.mexglx
- rm -f *.dll
- make -C ../testing clear
- make -C ../cc clear
diff --git a/mex/sources/kalman/matlab/diffuse_kalman_filter.cpp b/mex/sources/kalman/matlab/diffuse_kalman_filter.cpp
deleted file mode 100644
index fbb6dd6a0dcc614d52f877098103594e9e141086..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/diffuse_kalman_filter.cpp
+++ /dev/null
@@ -1,153 +0,0 @@
-// $Id: kalman_filter.cpp 532 2005-11-30 13:51:33Z kamenik $
-
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides an interface to KalmanTask::filter.
-
-/******************************************************
-% kalman_filter.cpp : Defines the entry point for
-% Computing the likelihood of a stationnary state space model.
-% It is called from Dynare DsgeLikelihood.m,
-%
-% function [LIK, lik] = kalman_filter_dll(T,R,Q,H,P,Y,start,Z/mf[, kalman_tol,riccati_tol])
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% R [double] mm*rr matrix, mapping structural innovations to state variables.
-% Q [double] rr*rr covariance matrix of the structural innovations.
-% H [double] pp*pp (or 1*1 =0 if no measurement error) covariance matrix of the measurement errors.
-% P [double] mm*mm variance-covariance matrix with stationary variables
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% Z or mf: [double] Z: pp*mm matrix mapping state to pp observations
-% Alternative parameters
-% mf [integer] pp*1 vector of indices - alternative to Z matrix.
-% Additional optional parameters
-% kalman_tol [double] scalar, tolerance parameter (rcond).
-% riccati_tol [double] scalar, tolerance parameter (riccati iteration).
-%
-% OUTPUTS
-% LIK [double] scalar, likelihood
-% lik [double] vector, density of observations in each period.
-%
-% REFERENCES
-% See "Filtering and Smoothing of State Vector for Diffuse State Space
-% Models", S.J. Koopman and J. Durbin (2003, in Journal of Time Series
-% Analysis, vol. 24(1), pp. 85-98).
-%
-% NOTES
-% The vector "lik" is used to evaluate the jacobian of the likelihood.
-**********************************************************/
-
-
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
- if (nrhs < 8 || nrhs > 10)
- mexErrMsgTxt("Must have 8, 9, or 10 input parameters.\n");
- if (nlhs < 1 || nlhs > 3)
- mexErrMsgTxt("Must have 1, 2, or 3 output parameters.\n");
- int start = 1; // default start of likelihood calculation
- try
- {
- // make input matrices
- GeneralMatrix T(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- GeneralMatrix R(mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- GeneralMatrix Q(mxGetPr(prhs[2]), mxGetM(prhs[2]), mxGetN(prhs[2]));
- GeneralMatrix H(mxGetPr(prhs[3]), mxGetM(prhs[3]), mxGetN(prhs[3]));
- GeneralMatrix Pinf(mxGetPr(prhs[4]), mxGetM(prhs[4]), mxGetN(prhs[4]));
- GeneralMatrix P(mxGetPr(prhs[5]), mxGetM(prhs[5]), mxGetN(prhs[5]));
- GeneralMatrix Y(mxGetPr(prhs[6]), mxGetM(prhs[6]), mxGetN(prhs[6]));
- if (nrhs>6) start = (int)mxGetScalar(prhs[7]);
- GeneralMatrix Z(mxGetPr(prhs[8]), mxGetM(prhs[8]), mxGetN(prhs[8]));
- int nper = mxGetN(prhs[5]); // no of periods
- GeneralMatrix a( mxGetN(prhs[0]), 1);// initiate inital state to 0s
- a.zeros();
-#ifdef DEBUG
- mexPrintf("kalman_filter: periods = %d ", nper);
-#endif
- // make storage for output
- double loglik;
- int per;
- int d;
- // output for full log-likelihood array
- std::vector<double>* vll=new std::vector<double> (nper);
- // create state init
- StateInit* init = NULL;
- init = new StateInit(P, Pinf, a.getData());
- // fork, create objects and do filtering
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- // developement of the output.
-#ifdef DEBUG
- mexPrintf("kalman_filter: running and filling outputs.\n");
-#endif
- loglik = kt.filter(per, d, (start-1), vll);
- // destroy init
- delete init;
-
- // create output and upload output data
- if (nlhs >= 1)
- plhs[0] = mxCreateDoubleScalar(loglik);
- if (nlhs >= 2)
- {
- // output full log-likelihood array
- /* Set the output pointer to the array of log likelihood. */
- plhs[1] = mxCreateDoubleMatrix(nper,1, mxREAL);
- double * mxll= mxGetPr(plhs[1]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxll[j]=(*vll)[j];
- }
- if (nlhs >= 3)
- {
- plhs[1] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[2]))) = per;
- }
- if (nlhs == 4)
- {
- plhs[2] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[3]))) = d;
- }
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
- }
- };
diff --git a/mex/sources/kalman/matlab/disclyap_fast_dll.cpp b/mex/sources/kalman/matlab/disclyap_fast_dll.cpp
deleted file mode 100644
index 7fe1ac8327c1d3f966827a50c4217a7df5ed3881..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/disclyap_fast_dll.cpp
+++ /dev/null
@@ -1,89 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-/****************************************************************
-% entry Matlab DLL for function X=disclyap_fast(G,V,ch)
-%
-% which solve the discrete Lyapunov Equation
-% X=G*X*G'+V
-% Using the Doubling Algorithm
-%
-% If ch is defined then the code will check if the resulting X
-% is positive definite and generate an error message if it is not
-%
-****************************************************************/
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "SylvException.h"
-#include "mex.h"
-#include "disclyap_fast.h"
-
-//void disclyap_fast(GeneralMatrix &G,GeneralMatrix & V, double tol= 1e-16, int ch=0);
-
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
-
- if (nrhs < 2 || nrhs > 4)
- mexErrMsgTxt("Must have 2, 3 or 4 input parameters.\n");
- if (nlhs != 1 )
- mexErrMsgTxt("Must have 1 output parameters.\n");
- int cholCheck = 0;
- double LyapTol=1e-06;
- try
- {
- // make input matrices
- int s = mxGetM(prhs[0]);
- GeneralMatrix G(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- GeneralMatrix V(mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
-
- // create output
- plhs[0] = mxCreateDoubleMatrix(mxGetM(prhs[0]),mxGetN(prhs[0]), mxREAL);
- GeneralMatrix X(mxGetPr(plhs[0]),mxGetM(plhs[0]),mxGetN(plhs[0]));
- if (nrhs > 2)
- LyapTol = (double)mxGetScalar(prhs[2]);
- if (nrhs > 3)
- cholCheck = (int)mxGetScalar(prhs[3]);
-
-#ifdef TIMING_LOOP
- for (int tt=0;tt<1000;++tt)
- {
-#endif
- disclyap_fast(G, V, X, LyapTol, cholCheck);
-#ifdef TIMING_LOOP
- }
- mexPrintf("disclyap_fast: finished 1000 loops");
-#endif
-
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
-
- } // mexFunction
- }; // extern 'C'
diff --git a/mex/sources/kalman/matlab/gendata.m b/mex/sources/kalman/matlab/gendata.m
deleted file mode 100644
index b9fabbe7a42953b707581bd442117402b63f30f4..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/gendata.m
+++ /dev/null
@@ -1,30 +0,0 @@
-% [y,epsilon,alpha,eta] = gendata(T, ssf, a0)
-%
-% generates random data of the length T for the given state space form
-% and initial state
-
-% $Id: gendata.m 532 2005-11-30 13:51:33Z kamenik $
-% Copyright 2005, Ondra Kamenik
-
-function [y,epsilon,alpha,eta] = gendata(T, ssf, a0)
-
- m = size(ssf.T, 1);
- p = size(ssf.Z, 1);
- r = size(ssf.R, 2);
-
- cholH = chol(ssf.H);
- cholQ = chol(ssf.Q);
-
- epsilon = cholH*randn(p,T);
- eta = cholQ*randn(r, T);
-
- y = zeros(p, T);
- alpha = zeros(m,T);
- alpha(:,1) = a0;
-
- for t = 1:T
- y(:,t) = ssf.Z*alpha(:,t) + epsilon(:,t);
- if t ~= T
- alpha(:,t+1) = ssf.T*alpha(:,t) + ssf.R*eta(:,t);
- end
- end
diff --git a/mex/sources/kalman/matlab/gmvm.cpp b/mex/sources/kalman/matlab/gmvm.cpp
deleted file mode 100644
index 87f9f782509bac89f3a09e68c724a6abf1938abd..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/gmvm.cpp
+++ /dev/null
@@ -1,122 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to QT f90 library by Andrea Pagano
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-% function [a] = qtmvm(QT,a)
-%
-% 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
-% 2. Ta = LdV(Ld;a;n)+TV(T1;a;n).
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-%
-% OUTPUTS
-% Tinverse [double] mm*mm transition matrix of the state equation.
-**********************************************************/
-
-#include "qt.h"
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
-
- if (nrhs < 2 )
- mexErrMsgTxt("Must have min 2 input parameters.\n");
- if (nlhs < 1 )
- mexErrMsgTxt("Must have min 1 output parameters.\n")
-
- ;
- //int start = 1; // default start of likelihood calculation
- // test for univariate case
- try
- {
- // make input matrices
- int n=mxGetM(prhs[0]);
-
- ConstGeneralMatrix QT(mxGetPr(prhs[0]), n, mxGetN(prhs[0]));
- // ConstGeneralMatrix a (mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- ConstVector a (mxGetPr(prhs[1]), n);
-
- // create output and upload output data
- plhs[0] = mxCreateDoubleMatrix(mxGetM(prhs[1]),1, mxREAL);// mxGetM(prhs[1]), mxREAL);
- // double * mxinv= mxGetPr(plhs[0]);
- // GeneralMatrix Ta(mxGetPr(plhs[0]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- Vector Ta (mxGetPr(plhs[0]), n);
- // Tinv.unit();
- // Ta.zeros();
-
-
- // make storage for output
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (nrhs >2 )
- loops = (int)mxGetScalar(prhs[2]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-#ifdef DEBUG
- // QT.print();
-#endif
- QT.multVec(0.0, Ta, 1.0, a);
-
-#ifdef DEBUG
- Ta.print();
-#endif
-#ifdef TIMING_LOOP
- }
- mexPrintf("gmvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- /* if (nlhs >= 1)
- {
- plhs[0] = mxCreateNumericMatrix(mxGetM(prhs[0]), mxGetM(prhs[0]), mxINT32_CLASS, mxREAL);
- double * mxinv= mxGetPr(plhs[0]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxinv[j]=(*vll)[j];
- }
- */
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
-
- } // mexFunction
- }; // extern 'C'
diff --git a/mex/sources/kalman/matlab/kalman_filter.m b/mex/sources/kalman/matlab/kalman_filter.m
deleted file mode 100644
index 27e14c082d6c41db721cde03d64020a526ad7bf4..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalman_filter.m
+++ /dev/null
@@ -1,37 +0,0 @@
-%
-% SYNOPSIS
-%
-% [loglik,per,d] = kalman_filter(Z,H,T,R,Q,Y,a,P)
-% [loglik,per,d] = kalman_filter(Z,H,T,R,Q,Y,a,P,flag)
-% [loglik,per,d] = kalman_filter(Z,H,T,R,Q,Y,a,Pstar,Pinf)
-% [loglik,per,d] = kalman_filter(Z,H,T,R,Q,Y,a,Pstar,Pinf,flag)
-%
-% SEMANTICS
-%
-% The first two commands run a Kalman filter for non-diffuse
-% initial conditions, the other two for diffuse initial conditions.
-%
-% Input:
-% Z,H,T,R,Q gives a state space form
-% Y observed data (columns correspond to periods)
-% a mean of initial state
-% P covariance of initial non-diffuse state
-% Pstar finite part of covariance of initial diffuse state
-% Pinf infinite part of covariance of initial diffuse state
-% flag string starting with 'u', or 'U' runs a univariate
-% form of the filter; if omitted, a multivariate version
-% is run by default
-%
-% Output:
-% loglik data log likelihood
-% per number of succesfully filtered periods; if no error
-% then per equals to the number of columns of Y
-% d number of initial periods for which the state is
-% still diffuse (d is always 0 for non-diffuse case)
-%
-% Copyright 2005, Ondra Kamenik
-%
-
-function [loglik, per, d] = kalman_filter(varargin)
-
- [loglik, per, d] = kalman_filter_(varargin{:});
diff --git a/mex/sources/kalman/matlab/kalman_filter_Z.cpp b/mex/sources/kalman/matlab/kalman_filter_Z.cpp
deleted file mode 100644
index 270fd2fe470223784ab5291104b5123bdf69a034..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalman_filter_Z.cpp
+++ /dev/null
@@ -1,167 +0,0 @@
-// $Id: kalman_filter.cpp 532 2005-11-30 13:51:33Z kamenik $
-
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides an interface to KalmanTask::filter.
-
-/******************************************************
-% kalman_filter.cpp : Defines the entry point for
-% Computing the likelihood of a stationnary state space model.
-% It is called from Dynare DsgeLikelihood.m,
-%
-% function [LIK, lik] = kalman_filter_dll(T,R,Q,H,P,Y,start,Z/mf[, kalman_tol,riccati_tol])
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% R [double] mm*rr matrix, mapping structural innovations to state variables.
-% Q [double] rr*rr covariance matrix of the structural innovations.
-% H [double] pp*pp (or 1*1 =0 if no measurement error) covariance matrix of the measurement errors.
-% P [double] mm*mm variance-covariance matrix with stationary variables
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% Z or mf: [double] Z: pp*mm matrix mapping state to pp observations
-% Alternative parameters
-% mf [integer] pp*1 vector of indices - alternative to Z matrix.
-% Additional optional parameters
-% kalman_tol [double] scalar, tolerance parameter (rcond).
-% riccati_tol [double] scalar, tolerance parameter (riccati iteration).
-%
-% OUTPUTS
-% LIK [double] scalar, likelihood
-% lik [double] vector, density of observations in each period.
-%
-% REFERENCES
-% See "Filtering and Smoothing of State Vector for Diffuse State Space
-% Models", S.J. Koopman and J. Durbin (2003, in Journal of Time Series
-% Analysis, vol. 24(1), pp. 85-98).
-%
-% NOTES
-% The vector "lik" is used to evaluate the jacobian of the likelihood.
-**********************************************************/
-
-
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
- if (nrhs < 8 || nrhs > 10)
- mexErrMsgTxt("Must have 8, 9, or 10 input parameters.\n");
- if (nlhs < 1 || nlhs > 3)
- mexErrMsgTxt("Must have 1, 2, or 3 output parameters.\n");
-
- // test for univariate case
- bool uni = false;
- const mxArray* const last = prhs[nrhs-1];
- if (mxIsChar(last)
- && ((*mxGetChars(last)) == 'u' || (*mxGetChars(last)) == 'U'))
- uni = true;
-
- // test for diffuse case
- bool diffuse = false;
- if ((mxIsChar(last) && nrhs == 10) ||
- (!mxIsChar(last) && nrhs == 9))
- diffuse = true;
-
- int start = 1; // default start of likelihood calculation
- try
- {
- // make input matrices
- GeneralMatrix T(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- GeneralMatrix R(mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- GeneralMatrix Q(mxGetPr(prhs[2]), mxGetM(prhs[2]), mxGetN(prhs[2]));
- GeneralMatrix H(mxGetPr(prhs[3]), mxGetM(prhs[3]), mxGetN(prhs[3]));
- GeneralMatrix P(mxGetPr(prhs[4]), mxGetM(prhs[4]), mxGetN(prhs[4]));
- GeneralMatrix Y(mxGetPr(prhs[5]), mxGetM(prhs[5]), mxGetN(prhs[5]));
- if (nrhs>6) start = (int)mxGetScalar(prhs[6]);
- GeneralMatrix Z(mxGetPr(prhs[7]), mxGetM(prhs[7]), mxGetN(prhs[7]));
- int nper = mxGetN(prhs[5]); // no of periods
- GeneralMatrix a( mxGetN(prhs[0]), 1);// initiate inital state to 0s
- a.zeros();
-#ifdef DEBUG
- mexPrintf("kalman_filter: periods = %d ", nper);
-#endif
-
- // make storage for output
- double loglik;
- int per;
- int d;
- // output for full log-likelihood array
- std::vector<double>* vll=new std::vector<double> (nper);
- // create state init
- StateInit* init = NULL;
- init = new StateInit(P, a.getData());
- // fork, create objects and do filtering
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- // developement of the output.
-#ifdef DEBUG
- mexPrintf("kalman_filter: running and filling outputs.\n");
-#endif
- loglik = kt.filter(per, d, (start-1), vll);
- // destroy init
- delete init;
-
- // create output and upload output data
- if (nlhs >= 1)
- plhs[0] = mxCreateDoubleScalar(loglik);
- if (nlhs >= 2)
- {
- // output full log-likelihood array
- /* Set the output pointer to the array of log likelihood. */
- plhs[1] = mxCreateDoubleMatrix(nper,1, mxREAL);
- double * mxll= mxGetPr(plhs[1]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxll[j]=(*vll)[j];
- }
- if (nlhs >= 3)
- {
- plhs[1] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[2]))) = per;
- }
- if (nlhs == 4)
- {
- plhs[2] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[3]))) = d;
- }
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
- }
- };
diff --git a/mex/sources/kalman/matlab/kalman_filters.cpp b/mex/sources/kalman/matlab/kalman_filters.cpp
deleted file mode 100644
index f9411f1daa123ce0bfe3c4f0952b3b19487b90c3..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalman_filters.cpp
+++ /dev/null
@@ -1,209 +0,0 @@
-// $Id: kalman_filter.cpp 532 2005-11-30 13:51:33Z kamenik $
-
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides an interface to KalmanTask::filter.
-
-/******************************************************
-% kalman_filter.cpp : Defines the entry point for
-% Computing the likelihood of a stationnary state space model.
-% It is called from Dynare DsgeLikelihood.m,
-%
-% function [loglik per d vll] = kalman_filter_dll(T,R,Q,H,Y,start,a, Z, P. [Pinf | u/U flag]
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% R [double] mm*rr matrix, mapping structural innovations to state variables.
-% Q [double] rr*rr covariance matrix of the structural innovations.
-% H [double] pp*pp (or 1*1 =0 if no measurement error) covariance matrix of the measurement errors.
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% Z [double] pp*mm matrix mapping state to pp observations
-% a [vector] mm vector of initial state, usually of 0s
-% P [double] mm*mm variance-covariance matrix with stationary variables
-% Pinf [optional] [double] mm*mm variance-covariance matrix with stationary variables
-% u/U [optional] [char] u/U univariate
-% OUTPUTS
-% loglik [double] scalar, total likelihood
-% per [int] number of succesfully filtered periods; if no error
-% [int] then per equals to the number of columns of Y
-% d number of initial periods for which the state is
-% still diffuse (d is always 0 for non-diffuse case)
-% vll [double] vector, density of observations in each period.
-%
-% REFERENCES
-% See "Filtering and Smoothing of State Vector for Diffuse State Space
-% Models", S.J. Koopman and J. Durbin (2003, in Journal of Time Series
-% Analysis, vol. 24(1), pp. 85-98).
-%
-% NOTES
-% The vector "vll" is used to evaluate the jacobian of the likelihood.
-**********************************************************/
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
-
- if (nrhs < 9 || nrhs > 11)
- mexErrMsgTxt("Must have 9, 10 or 11 input parameters.\n");
- if (nlhs < 1 || nlhs > 4)
- mexErrMsgTxt("Must have 1, 2, 3 or 4 output parameters.\n");
- //int start = 1; // default start of likelihood calculation
- // test for univariate case
- bool uni = false;
- double riccatiTol=0.000001;
- const mxArray* const last = prhs[nrhs-1];
- if (mxIsChar(last)
- && ((*mxGetChars(last)) == 'u' || (*mxGetChars(last)) == 'U'))
- uni = true;
-
- // test for diffuse case
- bool diffuse = false;
- if ((mxIsChar(last) && nrhs == 11) ||
- (!mxIsChar(last) && nrhs == 10))
- diffuse = true;
-
- try {
- // make input matrices
- GeneralMatrix T(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- GeneralMatrix R(mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- GeneralMatrix Q(mxGetPr(prhs[2]), mxGetM(prhs[2]), mxGetN(prhs[2]));
- GeneralMatrix H(mxGetPr(prhs[3]), mxGetM(prhs[3]), mxGetN(prhs[3]));
- GeneralMatrix Y(mxGetPr(prhs[4]), mxGetM(prhs[4]), mxGetN(prhs[4]));
- int start = (int)mxGetScalar(prhs[5]);
- GeneralMatrix Z(mxGetPr(prhs[6]), mxGetM(prhs[6]), mxGetN(prhs[6]));
- GeneralMatrix a(mxGetPr(prhs[7]), mxGetM(prhs[7]), mxGetN(prhs[7]));
- GeneralMatrix P(mxGetPr(prhs[8]), mxGetM(prhs[8]), mxGetN(prhs[8]));
-
- int nper=Y.numCols();
-#ifdef DEBUG
- mexPrintf("kalman_filter: periods=%d start=%d, a.length=%d, uni=%d diffuse=%d\n", nper, start,a.numRows(), uni, diffuse);
-#endif
-
- // make storage for output
- double loglik;
- int per;
- int d;
- // create state init
- StateInit* init = NULL;
- std::vector<double>* vll=new std::vector<double> (nper);
- if (diffuse||uni)
- {
- if (diffuse)
- {
- GeneralMatrix Pinf(mxGetPr(prhs[9]), mxGetM(prhs[9]), mxGetN(prhs[9]));
- init = new StateInit(P, Pinf, a.getData());
- }
- else
- {
- init = new StateInit(P, a.getData());
- }
- // fork, create objects and do filtering
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- if (uni)
- {
- KalmanUniTask kut(kt);
- loglik = kut.filter(per, d, (start-1), vll);
- per = per / Y.numRows();
- d = d / Y.numRows();
- }
- else
- {
-#ifdef TIMING_LOOP
- for (int tt=0;tt<1000;++tt)
- {
-#endif
- loglik = kt.filter(per, d, (start-1), vll);
-#ifdef TIMING_LOOP
- }
- mexPrintf("kalman_filter: finished 1000 loops");
-#endif
- }
- }
- else // basic Kalman
- {
- init = new StateInit(P, a.getData());
- BasicKalmanTask bkt(Y, Z, H, T, R, Q, *init, riccatiTol);
-#ifdef TIMING_LOOP
- for (int tt=0;tt<1000;++tt)
- {
-#endif
- loglik = bkt.filter( per, d, (start-1), vll);
-#ifdef DEBUG
- mexPrintf("Basickalman_filter: loglik=%f \n", loglik);
-#endif
-#ifdef TIMING_LOOP
- }
- mexPrintf("Basickalman_filter: finished 1000 loops");
-#endif
-
- }
- // destroy init
- delete init;
-
- // create output and upload output data
- if (nlhs >= 1)
- plhs[0] = mxCreateDoubleScalar(loglik);
- if (nlhs >= 2) {
- plhs[1] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[1]))) = per;
- }
- if (nlhs >= 3) {
- plhs[2] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[2]))) = d;
- }
- if (nlhs >= 4)
- {
- // output full log-likelihood array
- /* Set the output pointer to the array of log likelihood. */
- plhs[3] = mxCreateDoubleMatrix(nper,1, mxREAL);
- double * mxll= mxGetPr(plhs[3]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxll[j]=(*vll)[j];
- }
- delete vll;
-
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
-
- } // mexFunction
- }; // extern 'C'
diff --git a/mex/sources/kalman/matlab/kalman_filters.m b/mex/sources/kalman/matlab/kalman_filters.m
deleted file mode 100644
index c827c0e089b56c1b94da614d71dd0eb9c4bbb6da..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalman_filters.m
+++ /dev/null
@@ -1,61 +0,0 @@
-% function [LIK per d lik] = kalman_filters(T,R,Q,H,Y,start,Z,a,P,[Pinf |u/U flag])
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% R [double] mm*rr matrix, mapping structural innovations to state variables.
-% Q [double] rr*rr covariance matrix of the structural innovations.
-% H [double] pp*pp (or 1*1 =0 if no measurement error) covariance matrix of the measurement errors.
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% Z [double] pp*mm matrix mapping state to pp observations
-% a [vector] mm vector of mean initial state, usually of 0s
-% P [double] mm*mm variance-covariance matrix with stationary variables
-% Pinf [optional] [double] mm*mm variance-covariance matrix with stationary variables
-% [u/U]flag [optional] [char] u/U univariate falg
-%
-% SYNOPSIS
-%
-% [LIK,per,d,lik] = kalman_filters(T,R,Q,H,Y,start,a, Z,P)
-% [LIK,per,d,lik] = kalman_filters(T,R,Q,H,Y,start,a, Z,P,flag)
-% [LIK,per,d,lik] = kalman_filters(T,R,Q,H,Y,start,a, Z,Pstar,Pinf)
-% [LIK,per,d,lik] = kalman_filters(T,R,Q,H,Y,start,a, Z, Pstar, Pinf, flag)
-%
-% SEMANTICS
-%
-% The first two commands run a Kalman filter for non-diffuse initial conditions,
-% univariate or multivariate, the other two for diffuse initial conditions.
-%
-%
-% Output:
-% LIK data log likelihood
-% per number of succesfully filtered periods; if no error
-% then per equals to the number of columns of Y
-% d number of initial periods for which the state is
-% still diffuse (d is always 0 for non-diffuse case)
-%
-% Copyright 2005, Ondra Kamenik
-%
-
-%function [LIK per d lik] = kalman_filters(varargin)
-function [LIK per d lik] = kalman_filters(T,R,Q,H,Y,start,Z,a,P,varargin)
-if isempty(H)
- H=zeros(size(Y,1), size(Y,1))
-elseif H==0
- H=zeros(size(Y,1), size(Y,1))
-end
-if isempty(a)
- a=zeros(size(T,1),1)
-elseif a==0
- a=zeros(size(T,1),1)
-end
-if size(Z,1)== 1 && size(Z,2)==size(Y,1) && size(Y,1)> 1
- ZM=zeros(size(Y,1), size(T,2))
- for i = 1:size(Y,1)
- ZM(i,Z(i))=1
- end
-else
- ZM=Z;
-end
-% run basic multivariate kalman filter
-[LIK per d lik] = kalman_filter_dll(T,R,Q,H,Y,start,ZM,a, P);
-
diff --git a/mex/sources/kalman/matlab/kalman_filters_testx.cpp b/mex/sources/kalman/matlab/kalman_filters_testx.cpp
deleted file mode 100644
index e76fee083c4b443d3f373621aaa0dfd2151cd34b..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalman_filters_testx.cpp
+++ /dev/null
@@ -1,324 +0,0 @@
-// $Id: kalman_filter.cpp 532 2005-11-30 13:51:33Z kamenik $
-
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides an interface to KalmanTask::filter.
-
-/******************************************************
-% kalman_filter.cpp : Defines the entry point for
-% Computing the likelihood of a stationnary state space model.
-% It is called from Dynare DsgeLikelihood.m,
-%
-% function [loglik per d vll] = kalman_filter_dll(T,R,Q,H,Y,start,a, Z, P. [Pinf | u/U flag]
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% R [double] mm*rr matrix, mapping structural innovations to state variables.
-% Q [double] rr*rr covariance matrix of the structural innovations.
-% H [double] pp*pp (or 1*1 =0 if no measurement error) covariance matrix of the measurement errors.
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% Z [double] pp*mm matrix mapping state to pp observations
-% a [vector] mm vector of initial state, usually of 0s
-% P [double] mm*mm variance-covariance matrix with stationary variables
-% Pinf [optional] [double] mm*mm variance-covariance matrix with stationary variables
-% u/U [optional] [char] u/U univariate
-% OUTPUTS
-% loglik [double] scalar, total likelihood
-% per [int] number of succesfully filtered periods; if no error
-% [int] then per equals to the number of columns of Y
-% d number of initial periods for which the state is
-% still diffuse (d is always 0 for non-diffuse case)
-% vll [double] vector, density of observations in each period.
-%
-% REFERENCES
-% See "Filtering and Smoothing of State Vector for Diffuse State Space
-% Models", S.J. Koopman and J. Durbin (2003, in Journal of Time Series
-% Analysis, vol. 24(1), pp. 85-98).
-%
-% NOTES
-% The vector "vll" is used to evaluate the jacobian of the likelihood.
-**********************************************************/
-
-#include <iostream>
-using namespace std;
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-
-#include "mex.h"
-
-/*************************************
-* This main() is for testing kalman DLL entry point by linking to
-* the kalman library statically and passing its hard-coded data:
-* parameters, covar,
-***************************************/
-
-
-int main(int argc, char* argv[])
-//main (int nrhs, mxArray* plhs[],
- {
- int nrhs=9;
- int nlhs=4;
- if (nrhs < 9 || nrhs > 11)
- mexErrMsgTxt("Must have 9, 10 or 11 input parameters.\n");
- if (nlhs < 1 || nlhs > 4)
- mexErrMsgTxt("Must have 1, 2, 3 or 4 output parameters.\n");
- //int start = 1; // default start of likelihood calculation
- // test for univariate case
- bool uni = false;
-// const mxArray* const last = prhs[nrhs-1];
-// if (mxIsChar(last)
-// && ((*mxGetChars(last)) == 'u' || (*mxGetChars(last)) == 'U'))
-// uni = true;
-
- // test for diffuse case
- bool diffuse = false;
-// if ((mxIsChar(last) && nrhs == 11) ||
-// (!mxIsChar(last) && nrhs == 10))
-// diffuse = true;
-
- double Tmat[]={// need to pass transposed matrices!!??
-
- 0, 0, 0, 0, 0, 0, 0, 0,
- -0.0013, 0.5000, 0.0000, -0.0000, 0.0188, -0.0013, 0.1182, -0.0017,
- 0.2158, 0.0000, 0.9502, -0.0000, 0.0127, 0.2158, 0.0438, -0.0088,
- 0.0273, -0.0000, -0.0000, 0.8522, -0.1260, -0.8249, -0.4720, 0.0356,
- -0.0716, -0.0000, 0.0000, 0.0000, 0.5491, -0.0716, -0.9573, -0.0935,
- -0.0000, -0.0000, 0.0000, -0.0000, -0.0000, -0.0000, 0.0000, -0.0000,
- 0, 0, 0, 0, 0, 0, 0, 0,
- 0.6464, 0.0000, -0.0000, -0.0000, 0.0573, 0.6464, 0.2126, 0.8441
-
-
- // 0 ,-0.001294119891461, 0.21578807493606 ,0.027263201686985, -0.071633450625617, -0, 0, 0.646379181371765,
- // 0, 0.5, 0, -0, -0, -0, 0, 0,
- // 0, 0, 0.9502, -0, 0, 0, 0, -0,
- // 0, -0, -0, 0.8522, 0, -0, 0, -0,
- // 0, 0.018758765757513, 0.012692095232426, -0.126035674083997, 0.549074256326045, -0, 0, 0.05730910985981,
- // 0, -0.001294119891461, 0.21578807493606, -0.824936798313015, -0.071633450625617, -0, 0, 0.646379181371766,
- // 0, 0.118192240459753, 0.04380066554165, -0.471963836695487, -0.957255289691476, 0, 0, 0.212592467520726,
- // 0, -0.00168993250228, -0.008835241183444, 0.035601779209991, -0.093542875943306, -0, 0, 0.844077271823789
- };
-
- double Rmat[]={// need to pass transposed matrices!!??
- 0.2271, 0, 1.0000, 0, 0.0134, 0.2271, 0.0461, -0.0093,
- 0.0320, 0, 0, 1.0000, -0.1479, -0.9680, -0.5538, 0.0418,
- -0.0026, 1.0000, 0, 0, 0.0375, -0.0026, 0.2364, -0.0034,
- -0.0895, 0, 0, 0, 0.6863, -0.0895, -1.1966, -0.1169
-
-// 0.2271, 0.0320, -0.0026, -0.0895,
-// 0, 0, 1.0000, 0,
-// 1.0000, 0, 0, 0,
-// 0, 1.0000, 0, 0,
-// 0.0134, -0.1479, 0.0375, 0.6863,
-// 0.2271, -0.9680, -0.0026, -0.0895,
-// 0.0461, -0.5538, 0.2364, -1.1966,
-// -0.0093, 0.0418, -0.0034, -0.1169
- };
- double Qmat[]={
- 0.0931, 0, 0, 0,
- 0, 0.1849, 0, 0,
- 0, 0, 0.0931, 0,
- 0, 0, 0, 0.0100
- };
-
- double Zmat[]={ // need to pass transposed matrices!!??
- 0, 0, 1, 0,
- 0, 0, 0, 0,
- 0, 0, 0, 0,
- 0, 0, 0, 0,
- 0, 0, 0 , 1,
- 0, 0, 0, 0,
- 1, 0, 0, 0,
- 0, 1, 0, 0
-// 0, 0, 0, 0, 0, 0, 1, 0,
-// 0, 0, 0, 0, 0, 0, 0, 1,
-// 1, 0, 0, 0, 0, 0, 0, 0,
-// 0, 0, 0, 0, 1, 0, 0, 0
- };
- double Ymat[]={
- -0.4073, 0.2674, 0.2896, 0.0669, 0.1166, -0.1699, -0.2518, -0.0562, -0.3269,-0.0703,-0.1046, -0.4888 ,-0.3524, -0.2485 ,-0.587, -0.4546, -0.397, -0.2353, -0.0352 -0.2171, -0.3754, -0.4322, -0.4572, -0.4903, -0.4518, -0.6435, -0.6304 ,-0.4148, -0.2892, -0.4318, -0.601, -0.4148, -0.4315, -0.3531, -0.8053, -0.468, -0.4263,
- 3.1739, 3.738 , 3.8285, 3.3342, 3.7447, 3.783, 3.1039, 2.8413, 3.0338, 0.3669, 0.0847 ,0.0104, 0.2115, -0.6649, -0.9625, -0.733, -0.8664, -1.4441, -1.0179, -1.2729 ,-1.9539, -1.4427, -2.0371, -1.9764, -2.5654, -2.857, -2.5842, -3.0427, -2.8312, -2.332, -2.2768, -2.1816, -2.1043, -1.8969, -2.2388, -2.1679, -2.1172,
- 3.2174, 3.1903, 3.3396, 3.1358, 2.8625, 3.3546, 2.4609, 1.9534, 0.9962, -0.7904,-1.1672, -1.2586, -1.3593, -1.3443 ,-0.9413, -0.6023, -0.4516, -0.5129, -0.8741, -1.0784, -1.4091, -1.3627, -1.5731, -1.6037 -1.8814, -2.1482 ,-1.3597, -1.1855, -1.1122, -0.8424, -0.9747, -1.1385, -1.4548, -1.4284, -1.4633, -1.0621, -0.7871,
- 0.8635, 0.9058, 0.7656, 0.7936, 0.8631, 0.9074, 0.9547, 1.2045, 1.085, 0.9178, 0.5242, 0.3178 ,0.1472, 0.0227, -0.0799, -0.0611, -0.014, 0.1132, 0.1774, 0.0782, 0.0436, -0.1596, -0.2691, -0.2895, -0.3791, -0.402, -0.4166 ,-0.4037, -0.3636, -0.4075, -0.4311, -0.447, -0.5111, -0.6274, -0.7261, -0.6974, -0.5012
-
- };
-
- try {
- // make input matrices
- GeneralMatrix T(Tmat, 8, 8);
- GeneralMatrix R(Rmat, 8, 4);
- GeneralMatrix Q(Qmat, 4, 4);
- GeneralMatrix H(4, 4);
- H.zeros();
-/*********use simlated data for time being *********/
- GeneralMatrix Y( 4, 109);
- Y.zeros();
- for (int i=0;i<4;++i)
- {
- for (int j=0;j<109;++j)
- {
- Y.get(i,j)= ((double) ( rand() % 10 -5.0))/2.0;
-#ifdef DEBUG
- mexPrintf("Y [%d %d] =%f, \n", i, j,Y.get(i,j));
-#endif
-
- }
- }
-/***********
- GeneralMatrix Y(Ymat, 4, 109);
- for (int i=0;i<4;++i)
- {
- for (int j=0;j<109;++j)
- {
-#ifdef DEBUG
- mexPrintf("Y [%d %d] =%f, \n", i, j,Y.get(i,j));
-#endif
- }
- }
-***********/
- double riccatiTol=0.000000000001;
- int start = 1;
- GeneralMatrix Z(Zmat, 4, 8);
- GeneralMatrix a(8, 1);
- a.zeros();
- GeneralMatrix P( 8, 8);
- P.zeros();
- for (int i=0;i<8;++i)
- P.get(i,i)=10.0;
-
- int nper=Y.numCols();
-#ifdef DEBUG
- mexPrintf("kalman_filter: periods=%d start=%d, a.length=%d, uni=%d diffuse=%d\n", nper, start,a.numRows(), uni, diffuse);
-#endif
-
- // make storage for output
- double loglik=-1.1111;
- int per;
- int d;
- // create state init
- StateInit* init = NULL;
- std::vector<double>* vll=new std::vector<double> (nper);
- bool basicKF=true;//false;
- if (diffuse||uni||basicKF==false)
- {
- if (diffuse)
- {
- GeneralMatrix Pinf(P.numRows(),P.numCols());
- Pinf.zeros();
- init = new StateInit(P, Pinf, a.getData());
- }
- else
- {
- init = new StateInit(P, a.getData());
- }
- // fork, create objects and do filtering
- #ifdef TIMING_LOOP
- for (int tt=0;tt<10000;++tt)
- {
- #endif
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- if (uni)
- {
- KalmanUniTask kut(kt);
- loglik = kut.filter(per, d, (start-1), vll);
- per = per / Y.numRows();
- d = d / Y.numRows();
- }
- else
- {
- loglik = kt.filter(per, d, (start-1), vll);
- }
- #ifdef TIMING_LOOP
- // mexPrintf("kalman_filter: finished %d loops", tt);
- }
- mexPrintf("kalman_filter: finished 10,000 loops");
- #endif
-
- }
- else // basic Kalman
- {
- init = new StateInit(P, a.getData());
- BasicKalmanTask bkt(Y, Z, H, T, R, Q, *init, riccatiTol);
-#ifdef TIMING_LOOP
- for (int tt=0;tt<10000;++tt)
- {
-#endif
- loglik = bkt.filter( per, d, (start-1), vll);
-#ifdef DEBUG
-// mexPrintf("Basickalman_filter: loglik=%f \n", loglik);
-// cout << "loglik " << loglik << "\n";
-#endif
-#ifdef TIMING_LOOP
- }
- mexPrintf("Basickalman_filter: finished 10,000 loops");
-#endif
-
- }
-
-
- // destroy init
- delete init;
- mexPrintf("logLik = %f \n", loglik);
- delete vll;
- // create output and upload output data
-/************
- if (nlhs >= 1)
- plhs[0] = mxCreateDoubleScalar(loglik);
- if (nlhs >= 2) {
- plhs[1] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[1]))) = per;
- }
- if (nlhs >= 3) {
- plhs[2] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[2]))) = d;
- }
- if (nlhs >= 4)
- {
- // output full log-likelihood array
- // Set the output pointer to the array of log likelihood.
- plhs[3] = mxCreateDoubleMatrix(nper,1, mxREAL);
- double * mxll= mxGetPr(plhs[3]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxll[j]=(*vll)[j];
- }
-******************************/
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
-
- // } // mexFunction
- }; // main extern 'C'
diff --git a/mex/sources/kalman/matlab/kalman_smoother.cpp b/mex/sources/kalman/matlab/kalman_smoother.cpp
deleted file mode 100644
index e457a7bcb9b7e04ddd557c89be61a93038139d53..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalman_smoother.cpp
+++ /dev/null
@@ -1,141 +0,0 @@
-/* $Id: kalman_smoother.cpp 532 2005-11-30 13:51:33Z kamenik $
-*
-*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides an interface to KalmanTask::filter.
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nhls, mxArray* plhs[],
- int nhrs, const mxArray* prhs[])
- {
- if (nhrs < 8 || nhrs > 10)
- mexErrMsgTxt("Must have 8, 9, or 10 input parameters.\n");
- if (nhls < 1 || nhls > 6)
- mexErrMsgTxt("Must have 1, 2,.. or 6 output parameters.\n");
-
- // test for univariate case
- bool uni = false;
- const mxArray* const last = prhs[nhrs-1];
- if (mxIsChar(last)
- && ((*mxGetChars(last)) == 'u' || (*mxGetChars(last)) == 'U'))
- uni = true;
-
- // test for diffuse case
- bool diffuse = false;
- if ((mxIsChar(last) && nhrs == 10) ||
- (!mxIsChar(last) && nhrs == 9))
- diffuse = true;
-
- try {
- // make input matrices
- GeneralMatrix Z(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- GeneralMatrix H(mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- GeneralMatrix T(mxGetPr(prhs[2]), mxGetM(prhs[2]), mxGetN(prhs[2]));
- GeneralMatrix R(mxGetPr(prhs[3]), mxGetM(prhs[3]), mxGetN(prhs[3]));
- GeneralMatrix Q(mxGetPr(prhs[4]), mxGetM(prhs[4]), mxGetN(prhs[4]));
- GeneralMatrix Y(mxGetPr(prhs[5]), mxGetM(prhs[5]), mxGetN(prhs[5]));
- GeneralMatrix a(mxGetPr(prhs[6]), mxGetM(prhs[6]), mxGetN(prhs[6]));
- GeneralMatrix P(mxGetPr(prhs[7]), mxGetM(prhs[7]), mxGetN(prhs[7]));
-
- // make storage for output
- double loglik;
- int per;
- int d;
- SmootherResults sres(Y.numCols());
-
- // create state init
- StateInit* init = NULL;
- if (diffuse) {
- GeneralMatrix Pinf(mxGetPr(prhs[8]), mxGetM(prhs[8]), mxGetN(prhs[8]));
- init = new StateInit(P, Pinf, a.getData());
- } else {
- init = new StateInit(P, a.getData());
- }
- // fork, create objects and do filtering and smoothing
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- if (uni) {
- KalmanUniTask kut(kt);
- SmootherResults sres_uni(Y.numRows()*Y.numCols());
- loglik = kut.filter_and_smooth(sres_uni, per, d);
- per = per / Y.numRows();
- d = d / Y.numRows();
- sres.import(sres_uni, Y.numRows());
- } else {
- loglik = kt.filter_and_smooth(sres, per, d);
- // loglik = kt.filter(per, d);
- }
- // destroy init
- delete init;
-
- // create output and upload output data
- if (nhls >= 1)
- plhs[0] = mxCreateDoubleScalar(loglik);
- if (nhls >= 2) {
- plhs[1] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[1]))) = per;
- }
- if (nhls >= 3) {
- plhs[2] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[2]))) = d;
- }
- if (nhls >= 4) {
- plhs[3] = mxCreateNumericMatrix(T.numRows(), Y.numCols(), mxDOUBLE_CLASS, mxREAL);
- if (per == Y.numCols()) {
- GeneralMatrix tmp(mxGetPr(plhs[3]), T.numRows(), Y.numCols());
- sres.exportAlpha(tmp);
- }
- }
- if (nhls >= 5) {
- plhs[4] = mxCreateNumericMatrix(R.numCols(), Y.numCols(), mxDOUBLE_CLASS, mxREAL);
- if (per == Y.numCols()) {
- GeneralMatrix tmp(mxGetPr(plhs[4]), R.numCols(), Y.numCols());
- sres.exportEta(tmp);
- }
- }
- if (nhls >= 6) {
- int dims[3]; dims[0] = T.numRows();
- dims[1] = T.numRows(); dims[2] = Y.numCols();
- plhs[5] = mxCreateNumericMatrix(3, dims[0], mxDOUBLE_CLASS, mxREAL);
- if (per == Y.numCols()) {
- GeneralMatrix tmp(mxGetPr(plhs[5]), T.numRows(),
- T.numRows()*Y.numCols());
- sres.exportV(tmp);
- }
- }
- } catch (const TSException& e) {
- mexErrMsgTxt(e.getMessage());
- } catch (SylvException& e) {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
- }
-};
diff --git a/mex/sources/kalman/matlab/kalman_smoother.m b/mex/sources/kalman/matlab/kalman_smoother.m
deleted file mode 100644
index 046813ef655f762eb8082d65ed18094be3274f11..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalman_smoother.m
+++ /dev/null
@@ -1,41 +0,0 @@
-%
-% SYNOPSIS
-%
-% [loglik,per,d,alpha,eta,V] = kalman_smoother(Z,H,T,R,Q,Y,a,P)
-% [loglik,per,d,alpha,eta,V] = kalman_smoother(Z,H,T,R,Q,Y,a,P,flag)
-% [loglik,per,d,alpha,eta,V] = kalman_smoother(Z,H,T,R,Q,Y,a,Pstar,Pinf)
-% [loglik,per,d,alpha,eta,V] = kalman_smoother(Z,H,T,R,Q,Y,a,Pstar,Pinf,flag)
-%
-% SEMANTICS
-%
-% The first two commands run a Kalman filter and smoother for non-diffuse initial
-% conditions, the other two for diffuse initial conditions.
-%
-% Input:
-% Z,H,T,R,Q gives a state space form
-% Y observed data (columns correspond to periods)
-% a mean of initial state
-% P covariance of initial non-diffuse state
-% Pstar finite part of covariance of initial diffuse state
-% Pinf infinite part of covariance of initial diffuse state
-% flag string starting with 'u', or 'U' runs a univariate
-% form of the filter; if omitted, a multivariate version
-% is run by default
-%
-% Output:
-% loglik data log likelihood
-% per number of succesfully filtered periods; if no error
-% then per equals to the number of columns of Y
-% d number of initial periods for which the state is
-% still diffuse (d is always 0 for non-diffuse case)
-% alpha matrix of smoothed states; columns are periods
-% eta matrix of smoothed shocks; columns are periods
-% V 3D array of smoothed state variances; V(:,:,t) is
-% smoothed state variance-covariance at time t
-%
-% Copyright 2005, Ondra Kamenik
-%
-
-function [loglik,per,d,alpha,eta,V] = kalman_smoother(varargin)
-
- [loglik,per,d,alpha,eta,V] = kalman_smoother_(varargin{:});
diff --git a/mex/sources/kalman/matlab/kalmandll_test.m b/mex/sources/kalman/matlab/kalmandll_test.m
deleted file mode 100644
index d3197b9b85d1a3341f4767317076c83da9ff1a71..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalmandll_test.m
+++ /dev/null
@@ -1,23 +0,0 @@
-function [LIKDLL loglik]=kalmandll_test(T,mf,R,Q,H,Pstar,Pinf,data,start)
-
-if isempty(H)
- H=zeros(size(data,1), size(data,1))
-elseif H==0
- H=zeros(size(data,1), size(data,1))
-end
-Z=zeros(size(data,1), size(T,2))
-for i = 1:size(data,1)
-Z(i,mf(i))=1
-end
-%LIKDLL= kalman_filter_dll8(T,Z,R,Q,H,Pstar,data,start)
-%[loglik,per,d] = kalman_filter_dll(Z,H,T,R,Q,data,a,Pstar)
-[LIK2 lik2] = kalman_filter(T,R,Q,H,Pstar,data,start,mf,options_.kalman_tol,options_.riccati_tol)
-if isempty(Pinf)
- Pinf=zeros(size(T));
-elseif Pinf==0
- Pinf=zeros(size(T));
-end
-% test DiffuseLikelihoodH1
-%[loglikd1,per,d] = kalman_filter_dll(Z,H,T,R,Q,data,a,Pstar,Pinf)
-[LIKdlikd ] = diffuse_kalman_filter(T,R,Q,H,Pinf,Pstar,data,start,Z,options_.kalman_tol,options_.riccati_tol)
-%loglikd2 = dynare_filter(Z,H,T,R,Q,data,Pstar,Pinf)
diff --git a/mex/sources/kalman/matlab/kalmanlib.def b/mex/sources/kalman/matlab/kalmanlib.def
deleted file mode 100644
index 9d27b788be68646619e33b7a70e1ad3e9492c3cf..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/kalmanlib.def
+++ /dev/null
@@ -1,2 +0,0 @@
-EXPORTS
-mexFunction
diff --git a/mex/sources/kalman/matlab/mexopts.bat b/mex/sources/kalman/matlab/mexopts.bat
deleted file mode 100644
index 53173853d9604ef287bbfaa7483818bfbd7de5d1..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/mexopts.bat
+++ /dev/null
@@ -1,58 +0,0 @@
-@echo off
-rem C:\ondra\tmp\dynare++\extern\matlab\mexopts.bat
-rem Generated by gnumex.m script in c:\fs\gnumex-1.11
-rem gnumex version: 1.11
-rem Compile and link options used for building MEX etc files with
-rem the Mingw/Cygwin tools. Options here are:
-rem Mingw linking
-rem Mex (*.dll) creation
-rem Safe linking to temporary libraries
-rem Language: C / C++
-rem Compiling for pentium and above
-rem Matlab version 7
-rem
-set MATLAB=C:\MATLAB7
-set GM_PERLPATH=C:\MATLAB7\sys\perl\win32\bin\perl.exe
-set GM_UTIL_PATH=c:\fs\gnumex-1.11
-set PATH=c:\fs\mingw\bin;%PATH%
-rem
-rem Added libraries for linking
-set GM_ADD_LIBS=
-rem
-rem Type of file to compile (mex or engine)
-set GM_MEXTYPE=mex
-rem
-rem Language for compilation
-set GM_MEXLANG=c
-rem
-rem def files to be converted to libs
-set GM_DEFS2LINK=libmx.def;libmex.def;libmat.def;
-rem
-rem dlltool command line
-set GM_DLLTOOL=dlltool
-rem
-rem compiler options; add compiler flags to compflags as desired
-set NAME_OBJECT=-o
-set COMPILER=gcc
-set COMPFLAGS=-c -DMATLAB_MEX_FILE
-set OPTIMFLAGS=-O3 -malign-double -fno-exceptions -mcpu=pentium
-set DEBUGFLAGS=-g
-set CPPCOMPFLAGS=%COMPFLAGS% -x c++
-set CPPOPTIMFLAGS=%OPTIMFLAGS%
-set CPPDEBUGFLAGS=%DEBUGFLAGS%
-rem
-rem NB Library creation commands occur in linker scripts
-rem
-rem Linker parameters
-set LINKER=%GM_PERLPATH% %GM_UTIL_PATH%\linkmex.pl
-set LINKFLAGS=
-set CPPLINKFLAGS=GM_ISCPP
-set LINKOPTIMFLAGS=-s
-set LINKDEBUGFLAGS=-g -Wl,--image-base,0x28000000\n
-set LINK_FILE=
-set LINK_LIB=
-set NAME_OUTPUT=-o %OUTDIR%%MEX_NAME%.dll
-rem
-rem Resource compiler parameters
-set RC_COMPILER=%GM_PERLPATH% %GM_UTIL_PATH%\rccompile.pl -o %OUTDIR%mexversion.res
-set RC_LINKER=
diff --git a/mex/sources/kalman/matlab/minv.cpp b/mex/sources/kalman/matlab/minv.cpp
deleted file mode 100644
index 3bef4319e016a2fdaedd13faff5befa3cd173d71..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/minv.cpp
+++ /dev/null
@@ -1,108 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides a matrix inversion
-
-/******************************************************
-% function [Tinv] = minv(T)
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-
-% OUTPUTS
-% Tinverse [double] mm*mm transition matrix of the state equation.
-**********************************************************/
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
-
- if (nrhs < 1 )
- mexErrMsgTxt("Must have min 1 input parameters.\n");
- if (nlhs < 1 )
- mexErrMsgTxt("Must have min 1 output parameters.\n")
-
- ;
- //int start = 1; // default start of likelihood calculation
- // test for univariate case
- try
- {
- // make input matrices
- ConstGeneralMatrix T(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- // create output and upload output data
- plhs[0] = mxCreateDoubleMatrix(mxGetM(prhs[0]), mxGetM(prhs[0]), mxREAL);
-// double * mxinv= mxGetPr(plhs[0]);
- GeneralMatrix Tinv(mxGetPr(plhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
-// Tinv.unit();
-// Tinv.zeros();
-
-
- // make storage for output
-
-#ifdef TIMING_LOOP
- int loops=1000;
- if (nrhs >1 )
- loops = (int)mxGetScalar(prhs[1]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
- Tinv.unit();
- T.multInvLeft(Tinv);
- //Tinv.print();
-
-#ifdef TIMING_LOOP
- }
- mexPrintf("minv: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
-/* if (nlhs >= 1)
- {
- plhs[0] = mxCreateNumericMatrix(mxGetM(prhs[0]), mxGetM(prhs[0]), mxINT32_CLASS, mxREAL);
- double * mxinv= mxGetPr(plhs[0]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxinv[j]=(*vll)[j];
- }
-*/
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
-
- } // mexFunction
- }; // extern 'C'
diff --git a/mex/sources/kalman/matlab/qtamvm.cpp b/mex/sources/kalman/matlab/qtamvm.cpp
deleted file mode 100644
index 5fadf8ecbb449d5b1c82f632b18a7de2cff7e167..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/qtamvm.cpp
+++ /dev/null
@@ -1,148 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to QT f90 library by Andrea Pagano
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-% function [a] = qtmvm(QT,a)
-%
-% 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
-% 2. Ta = LdV(Ld;a;n)+TV(T1;a;n).
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% a [double] mm state vector.
-%
-% OUTPUTS
-% Tinverse [double] mm*mm transition matrix of the state equation.
-**********************************************************/
-
-#include "qt.h"
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
-
- if (nrhs < 2 )
- mexErrMsgTxt("Must have min 2 input parameters.\n");
- if (nlhs < 1 )
- mexErrMsgTxt("Must have min 1 output parameters.\n")
-
- ;
- //int start = 1; // default start of likelihood calculation
- // test for univariate case
- try
- {
- // make input matrices
- int n=mxGetM(prhs[0]);
-
- double *T1, *Ld, *TV ;
- double * QT=mxGetPr(prhs[0]);
- // ConstGeneralMatrix a (mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- double *a =(mxGetPr(prhs[1]));
-
- // create output and upload output data
- plhs[0] = mxCreateDoubleMatrix(mxGetM(prhs[1]),1, mxREAL);// mxGetM(prhs[1]), mxREAL);
- // double * mxinv= mxGetPr(plhs[0]);
- // GeneralMatrix Ta(mxGetPr(plhs[0]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- double * Ta =mxGetPr(plhs[0]);
- // Tinv.unit();
- // Ta.zeros();
-
- T1=(double *)mxCalloc(n*n, sizeof(double));
- Ld=(double *)mxCalloc(n*n,sizeof(double));
- TV=(double *)mxCalloc(n, sizeof(double));
-
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (nrhs >2 )
- loops = (int)mxGetScalar(prhs[2]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-#ifdef DEBUG
- // QT.print();
-#endif
- // 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
- // double *T1, *Ld, *dTa;//, dT1=-7.77;
-// mexPrintf("start dT1 = %f\n", dT1);
-// dT1 = qt2t_(QT.base() ,&n) ;
-// mexPrintf("end dT1 = %f\n", dT1);
- //T1=&dT1;
-
- qt2t_(T1, QT ,&n) ;
-// T1=*T1p;
-// GeneralMatrix T1gm(T1,n,n);
-// Ld = qt2ld_(QT.base(),&n);
- qt2ld_(Ld , QT,&n);
- // 2. Ta = LdV(Ld;a;n)+TV(T1;a;n).
-// dTa = ldv_(Ld,a.base() ,&n);
- //Vector Ta( n);
- ldv_(Ta, Ld,a ,&n);
-// Ta2 = tv_(T1,a.base(),&n);
- tv_(TV, T1 ,a,&n);
-// Ta.add(1.0,ConstVector(Ta2.base(), n));
-// Ta.add(1.0,TV);
- for (int j=0; j<n;++j)
- Ta[j]+=TV[j];
-
-
-#ifdef TIMING_LOOP
- }
- mexPrintf("QT array mvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- /* if (nlhs >= 1)
- {
- plhs[0] = mxCreateNumericMatrix(mxGetM(prhs[0]), mxGetM(prhs[0]), mxINT32_CLASS, mxREAL);
- double * mxinv= mxGetPr(plhs[0]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxinv[j]=(*vll)[j];
- }
- */
- mxFree(T1);
- mxFree(Ld);
- mxFree(TV);
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
-
- } // mexFunction
- }; // extern 'C'
diff --git a/mex/sources/kalman/matlab/qtmvm.cpp b/mex/sources/kalman/matlab/qtmvm.cpp
deleted file mode 100644
index 1c06ff968bc7d94f53b9eb0d96804e38fa629634..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/qtmvm.cpp
+++ /dev/null
@@ -1,155 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to QT f90 library by Andrea Pagano
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-% function [a] = qtmvm(QT,a)
-%
-% 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
-% 2. Ta = LdV(Ld;a;n)+TV(T1;a;n).
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% a [double] mm state vector.
-%
-% OUTPUTS
-% Tinverse [double] mm*mm transition matrix of the state equation.
-**********************************************************/
-
-#include "qt.h"
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
-
- if (nrhs < 2 )
- mexErrMsgTxt("Must have min 2 input parameters.\n");
- if (nlhs < 1 )
- mexErrMsgTxt("Must have min 1 output parameters.\n")
-
- ;
- //int start = 1; // default start of likelihood calculation
- // test for univariate case
- try
- {
- // make input matrices
- int n=mxGetM(prhs[0]);
-
- ConstGeneralMatrix QT(mxGetPr(prhs[0]), n, mxGetN(prhs[0]));
- // ConstGeneralMatrix a (mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- Vector a (mxGetPr(prhs[1]), n);
-
- // create output and upload output data
- plhs[0] = mxCreateDoubleMatrix(mxGetM(prhs[1]),1, mxREAL);// mxGetM(prhs[1]), mxREAL);
- // double * mxinv= mxGetPr(plhs[0]);
- // GeneralMatrix Ta(mxGetPr(plhs[0]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- Vector Ta (mxGetPr(plhs[0]), n);
- // Tinv.unit();
- // Ta.zeros();
-
- GeneralMatrix T1gm(n,n);
- GeneralMatrix Ld(n,n);
- Vector TV( n);
-
- // make storage for output
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (nrhs >2 )
- loops = (int)mxGetScalar(prhs[2]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-#ifdef DEBUG
- // QT.print();
-#endif
- // 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
- // double *T1, *Ld, *dTa;//, dT1=-7.77;
-// mexPrintf("start dT1 = %f\n", dT1);
-// dT1 = qt2t_(QT.base() ,&n) ;
-// mexPrintf("end dT1 = %f\n", dT1);
- //T1=&dT1;
-
- qt2t_(T1gm.base(), QT.base() ,&n) ;
-// T1=*T1p;
-// GeneralMatrix T1gm(T1,n,n);
-#ifdef DEBUG
- T1gm.print();
-#endif
-// Ld = qt2ld_(QT.base(),&n);
- qt2ld_(Ld.base() , QT.base(),&n);
-#ifdef DEBUG
- Ld.print();
-#endif
- // 2. Ta = LdV(Ld;a;n)+TV(T1;a;n).
-// dTa = ldv_(Ld,a.base() ,&n);
- //Vector Ta( n);
- ldv_(Ta.base(), Ld.base(),a.base() ,&n);
-// Ta= (ConstVector(dTa, n));
-// Vector Ta(dTa, n);
-#ifdef DEBUG
- Ta.print();
-#endif
-// Ta2 = tv_(T1,a.base(),&n);
- tv_(TV.base(), T1gm.base() ,a.base(),&n);
-// Ta.add(1.0,ConstVector(Ta2.base(), n));
- Ta.add(1.0,TV);
-#ifdef DEBUG
- Ta.print();
-#endif
-#ifdef TIMING_LOOP
- }
- mexPrintf("QTmvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- /* if (nlhs >= 1)
- {
- plhs[0] = mxCreateNumericMatrix(mxGetM(prhs[0]), mxGetM(prhs[0]), mxINT32_CLASS, mxREAL);
- double * mxinv= mxGetPr(plhs[0]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxinv[j]=(*vll)[j];
- }
- */
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
-
- } // mexFunction
- }; // extern 'C'
diff --git a/mex/sources/kalman/matlab/univariate_diffuse_kalman_filter.cpp b/mex/sources/kalman/matlab/univariate_diffuse_kalman_filter.cpp
deleted file mode 100644
index c0b5d7a6ce9f5449f89bef04a9d2740ce17344f3..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/univariate_diffuse_kalman_filter.cpp
+++ /dev/null
@@ -1,158 +0,0 @@
-// $Id: kalman_filter.cpp 532 2005-11-30 13:51:33Z kamenik $
-
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides an interface to KalmanTask::filter.
-
-/******************************************************
-% kalman_filter.cpp : Defines the entry point for
-% Computing the likelihood of a stationnary state space model.
-% It is called from Dynare DsgeLikelihood.m,
-%
-% function [LIK, lik] = kalman_filter_dll(T,R,Q,H,P,Y,start,Z/mf[, kalman_tol,riccati_tol])
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% R [double] mm*rr matrix, mapping structural innovations to state variables.
-% Q [double] rr*rr covariance matrix of the structural innovations.
-% H [double] pp*pp (or 1*1 =0 if no measurement error) covariance matrix of the measurement errors.
-% P [double] mm*mm variance-covariance matrix with stationary variables
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% Z or mf: [double] Z: pp*mm matrix mapping state to pp observations
-% Alternative parameters
-% mf [integer] pp*1 vector of indices - alternative to Z matrix.
-% Additional optional parameters
-% kalman_tol [double] scalar, tolerance parameter (rcond).
-% riccati_tol [double] scalar, tolerance parameter (riccati iteration).
-%
-% OUTPUTS
-% LIK [double] scalar, likelihood
-% lik [double] vector, density of observations in each period.
-%
-% REFERENCES
-% See "Filtering and Smoothing of State Vector for Diffuse State Space
-% Models", S.J. Koopman and J. Durbin (2003, in Journal of Time Series
-% Analysis, vol. 24(1), pp. 85-98).
-%
-% NOTES
-% The vector "lik" is used to evaluate the jacobian of the likelihood.
-**********************************************************/
-
-
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
- if (nrhs < 8 || nrhs > 10)
- mexErrMsgTxt("Must have 8, 9, or 10 input parameters.\n");
- if (nlhs < 1 || nlhs > 3)
- mexErrMsgTxt("Must have 1, 2, or 3 output parameters.\n");
-
- int start = 1; // default start of likelihood calculation
- try
- {
- // make input matrices
- GeneralMatrix T(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- GeneralMatrix R(mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- GeneralMatrix Q(mxGetPr(prhs[2]), mxGetM(prhs[2]), mxGetN(prhs[2]));
- GeneralMatrix H(mxGetPr(prhs[3]), mxGetM(prhs[3]), mxGetN(prhs[3]));
- GeneralMatrix Pinf(mxGetPr(prhs[4]), mxGetM(prhs[4]), mxGetN(prhs[4]));
- GeneralMatrix P(mxGetPr(prhs[5]), mxGetM(prhs[5]), mxGetN(prhs[5]));
- GeneralMatrix Y(mxGetPr(prhs[6]), mxGetM(prhs[6]), mxGetN(prhs[6]));
- if (nrhs>6) start = (int)mxGetScalar(prhs[7]);
- GeneralMatrix Z(mxGetPr(prhs[8]), mxGetM(prhs[8]), mxGetN(prhs[8]));
- int nper = mxGetN(prhs[5]); // no of periods
- GeneralMatrix a( mxGetN(prhs[0]), 1);// initiate inital state to 0s
- a.zeros();
-#ifdef DEBUG
- mexPrintf("kalman_filter: periods = %d ", nper);
-#endif
-
- // make storage for output
- double loglik;
- int per;
- int d;
- // output for full log-likelihood array
- std::vector<double>* vll=new std::vector<double> (nper);
- // create state init
- StateInit* init = NULL;
- init = new StateInit(P, Pinf, a.getData());
- // fork, create objects and do filtering
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- // developement of the output.
-#ifdef DEBUG
- mexPrintf("kalman_filter: running and filling outputs.\n");
-#endif
- KalmanUniTask kut(kt);
- loglik = kut.filter(per, d, (start-1), vll);
- per = per / Y.numRows();
- d = d / Y.numRows();
- // destroy init
- delete init;
-
- // create output and upload output data
- if (nlhs >= 1)
- plhs[0] = mxCreateDoubleScalar(loglik);
- if (nlhs >= 2)
- {
- // output full log-likelihood array
- /* Set the output pointer to the array of log likelihood. */
- plhs[1] = mxCreateDoubleMatrix(nper,1, mxREAL);
- double * mxll= mxGetPr(plhs[1]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxll[j]=(*vll)[j];
- }
- if (nlhs >= 3)
- {
- plhs[1] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[2]))) = per;
- }
- if (nlhs == 4)
- {
- plhs[2] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[3]))) = d;
- }
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
- }
- };
diff --git a/mex/sources/kalman/matlab/univariate_kalman_filter.cpp b/mex/sources/kalman/matlab/univariate_kalman_filter.cpp
deleted file mode 100644
index ecd5caa0f65270ecf95f204c1be74064e663ba26..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/matlab/univariate_kalman_filter.cpp
+++ /dev/null
@@ -1,156 +0,0 @@
-// $Id: kalman_filter.cpp 532 2005-11-30 13:51:33Z kamenik $
-
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/* derived from c++kalman_filter library by O. Kamenik */
-
-// This provides an interface to KalmanTask::filter.
-
-/******************************************************
-% kalman_filter.cpp : Defines the entry point for
-% Computing the likelihood of a stationnary state space model.
-% It is called from Dynare DsgeLikelihood.m,
-%
-% function [LIK, lik] = kalman_filter_dll(T,R,Q,H,P,Y,start,Z/mf[, kalman_tol,riccati_tol])
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% R [double] mm*rr matrix, mapping structural innovations to state variables.
-% Q [double] rr*rr covariance matrix of the structural innovations.
-% H [double] pp*pp (or 1*1 =0 if no measurement error) covariance matrix of the measurement errors.
-% P [double] mm*mm variance-covariance matrix with stationary variables
-% Y [double] pp*smpl matrix of (detrended) data, where pp is the maximum number of observed variables.
-% start [integer] scalar, likelihood evaluation starts at 'start'.
-% Z or mf: [double] Z: pp*mm matrix mapping state to pp observations
-% Alternative parameters
-% mf [integer] pp*1 vector of indices - alternative to Z matrix.
-% Additional optional parameters
-% kalman_tol [double] scalar, tolerance parameter (rcond).
-% riccati_tol [double] scalar, tolerance parameter (riccati iteration).
-%
-% OUTPUTS
-% LIK [double] scalar, likelihood
-% lik [double] vector, density of observations in each period.
-%
-% REFERENCES
-% See "Filtering and Smoothing of State Vector for Diffuse State Space
-% Models", S.J. Koopman and J. Durbin (2003, in Journal of Time Series
-% Analysis, vol. 24(1), pp. 85-98).
-%
-% NOTES
-% The vector "lik" is used to evaluate the jacobian of the likelihood.
-**********************************************************/
-
-
-
-#include "kalman.h"
-#include "ts_exception.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include "mex.h"
-
-extern "C" {
- void mexFunction(int nlhs, mxArray* plhs[],
- int nrhs, const mxArray* prhs[])
- {
- if (nrhs < 8 || nrhs > 10)
- mexErrMsgTxt("Must have 8, 9, or 10 input parameters.\n");
- if (nlhs < 1 || nlhs > 3)
- mexErrMsgTxt("Must have 1, 2, or 3 output parameters.\n");
- int start = 1; // default start of likelihood calculation
- try
- {
- // make input matrices
- GeneralMatrix T(mxGetPr(prhs[0]), mxGetM(prhs[0]), mxGetN(prhs[0]));
- GeneralMatrix R(mxGetPr(prhs[1]), mxGetM(prhs[1]), mxGetN(prhs[1]));
- GeneralMatrix Q(mxGetPr(prhs[2]), mxGetM(prhs[2]), mxGetN(prhs[2]));
- GeneralMatrix H(mxGetPr(prhs[3]), mxGetM(prhs[3]), mxGetN(prhs[3]));
- GeneralMatrix P(mxGetPr(prhs[4]), mxGetM(prhs[4]), mxGetN(prhs[4]));
- GeneralMatrix Y(mxGetPr(prhs[5]), mxGetM(prhs[5]), mxGetN(prhs[5]));
- if (nrhs>6) start = (int)mxGetScalar(prhs[6]);
- GeneralMatrix Z(mxGetPr(prhs[7]), mxGetM(prhs[7]), mxGetN(prhs[7]));
- int nper = mxGetN(prhs[5]); // no of periods
- GeneralMatrix a( mxGetN(prhs[0]), 1);// initiate inital state to 0s
- a.zeros();
-#ifdef DEBUG
- mexPrintf("kalman_filter: periods = %d ", nper);
-#endif
-
- // make storage for output
- double loglik;
- int per;
- int d;
- // output for full log-likelihood array
- std::vector<double>* vll=new std::vector<double> (nper);
- // create state init
- StateInit* init = NULL;
- init = new StateInit(P, a.getData());
- // fork, create objects and do filtering
- KalmanTask kt(Y, Z, H, T, R, Q, *init);
- // developement of the output.
-#ifdef DEBUG
- mexPrintf("kalman_filter: running and filling outputs.\n");
-#endif
- KalmanUniTask kut(kt);
- loglik = kut.filter(per, d, (start-1), vll);
- per = per / Y.numRows();
- d = d / Y.numRows();
- // destroy init
- delete init;
-
- // create output and upload output data
- if (nlhs >= 1)
- plhs[0] = mxCreateDoubleScalar(loglik);
- if (nlhs >= 2)
- {
- // output full log-likelihood array
- /* Set the output pointer to the array of log likelihood. */
- plhs[1] = mxCreateDoubleMatrix(nper,1, mxREAL);
- double * mxll= mxGetPr(plhs[1]);
- // allocate likelihood array
- for (int j=0;j<nper;++j)
- mxll[j]=(*vll)[j];
- }
- if (nlhs >= 3)
- {
- plhs[1] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[2]))) = per;
- }
- if (nlhs == 4)
- {
- plhs[2] = mxCreateNumericMatrix(1, 1, mxINT32_CLASS, mxREAL);
- (*((int*)mxGetData(plhs[3]))) = d;
- }
- }
- catch (const TSException& e)
- {
- mexErrMsgTxt(e.getMessage());
- }
- catch (SylvException& e)
- {
- char mes[300];
- e.printMessage(mes, 299);
- mexErrMsgTxt(mes);
- }
- }
- };
diff --git a/mex/sources/kalman/qt/FortranSubroutines.zip b/mex/sources/kalman/qt/FortranSubroutines.zip
deleted file mode 100644
index 5a69ed6b9b3152ef05a1a2951933c250ae537710..0000000000000000000000000000000000000000
Binary files a/mex/sources/kalman/qt/FortranSubroutines.zip and /dev/null differ
diff --git a/mex/sources/kalman/qt/cc/qt.h b/mex/sources/kalman/qt/cc/qt.h
deleted file mode 100644
index 1e40ccfd6f774d33cacbd6ba4c6c5127422ed8e2..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/cc/qt.h
+++ /dev/null
@@ -1,37 +0,0 @@
-
-#ifndef QT_H
-#define QT_H
-
-#define C_CHAR const char*
-#define BLINT int*
-#define C_BLINT const int*
-#define C_BLDOU const double*
-#define BLDOU double*
-
-
-extern "C"{
-void ldm_(BLDOU, C_BLDOU, C_BLDOU, C_BLINT);
-void ldsld_(BLDOU, C_BLDOU, C_BLDOU, C_BLINT);
-void ldv_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void mtt_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void qt2ld_(BLDOU,C_BLDOU, C_BLINT);
-void qt2t_(BLDOU, C_BLDOU, C_BLINT);
-void s2d_(BLDOU,C_BLDOU, C_BLINT);
-void s2u_(BLDOU,C_BLDOU, C_BLINT);
-void td_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void tm_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void tstt_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void tt_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void tu_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void tut_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void tv_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-void qtv_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-#ifdef WINDOWS
-void qtv_1__(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-#else
-void qtv_1_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-#endif
-void qtsqtt_(BLDOU,C_BLDOU, C_BLDOU, C_BLINT);
-
-};
-#endif
diff --git a/mex/sources/kalman/qt/f90/LdM.f90 b/mex/sources/kalman/qt/f90/LdM.f90
deleted file mode 100644
index 8f9f1a76513f6bbefa3c120c82b05cdbed1b6051..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/LdM.f90
+++ /dev/null
@@ -1,24 +0,0 @@
-subroutine LdM(X,Ld,M,n)
-! COMPUTATIONAL SUBROUTINE: LdM=Ld*M; Ld lower diagonal matrix; M arbitrary
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: Ld(n,n)
-real(8), intent(in) :: M(n,n)
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j
-
-
-X=0.0*M
-
-do i=2,n
-if ((Ld(i,i-1)/=0.0)) then
-do j=1,n
-X(i,j)=Ld(i,i-1)*M(i-1,j)
-end do
-end if
-end do
-
-return
-end subroutine LdM
\ No newline at end of file
diff --git a/mex/sources/kalman/qt/f90/LdSLd.f90 b/mex/sources/kalman/qt/f90/LdSLd.f90
deleted file mode 100644
index 1fd861143f5a121a850821af22299356feb5477c..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/LdSLd.f90
+++ /dev/null
@@ -1,34 +0,0 @@
-subroutine LdSLd(X,Ld,S,n)
-! COMPUTATIONAL SUBROUTINE: LdM=Ld*S*Ld; Ld lower diagonal matrix; S symmetric
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: Ld(n,n)
-real(8), intent(in) :: S(n,n)
-real(8), intent(out) :: X(n,n)
-integer(4), dimension(1,n) :: vk
-
-
-integer(4) :: i,j, jj, h
-
-
-h=0.0
-do i=2,n
-if ((Ld(i,i-1)/= 0.0)) then
-h=h+1.0
-vk(1,h)=i
-end if
-end do
-if (h==0.0) then
-X=0*S
-return
-end if
-do j=1,h
-do jj=1,h
-X(vk(1,j),vk(1,jj))=Ld(vk(1,j),vk(1,j)-1)*S(vk(1,j)-1,vk(1,jj)-1)*Ld(vk(1,jj),vk(1,jj)-1)
-end do
-end do
-
-return
-end subroutine LdSLd
diff --git a/mex/sources/kalman/qt/f90/LdV.f90 b/mex/sources/kalman/qt/f90/LdV.f90
deleted file mode 100644
index 66671a7493adf1ae927e45aadc400e1765e70ddd..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/LdV.f90
+++ /dev/null
@@ -1,17 +0,0 @@
-subroutine LdV(X,Ld,v,n)
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: ld(n,n)
-real(8), intent(in) :: v(n,1)
-real(8), intent(out) :: X(n,1)
-integer(4) :: i
-
-X=0*v
-
-do i=2,n
-X(i,1)=Ld(i,i-1)*v(i-1,1)
-end do
-
-return
-end subroutine LdV
diff --git a/mex/sources/kalman/qt/f90/MTt.f90 b/mex/sources/kalman/qt/f90/MTt.f90
deleted file mode 100644
index 54daa7d1a9557d2eb9e25b55500f72a2fef5405a..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/MTt.f90
+++ /dev/null
@@ -1,31 +0,0 @@
-subroutine MTt(X,M,Tt,n)
-! COMPUTATIONAL SUBROUTINE TUt=T*Ut T upper triangular; U striclty lower triangular
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: M(n,n)
-real(8), intent(in) :: Tt(n,n)
-real(8), intent(out) :: X(n,n)
-
-integer(4) :: i,j,k
-
-real(8) :: stemp
-
-
-
-X=0.0*M
-
-do i=1,n
-do j=1,n
-stemp = 0.0
-do k = j,n
-stemp = stemp + M(i,k+i) * Tt(k+i,j)
-end do
-X(i,j)=stemp
-end do
-
-end do
-
-return
-end subroutine MTt
\ No newline at end of file
diff --git a/mex/sources/kalman/qt/f90/Makefile b/mex/sources/kalman/qt/f90/Makefile
deleted file mode 100644
index 4549a0fb2126e2910347c65af7a89ecb4c05254c..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/Makefile
+++ /dev/null
@@ -1,37 +0,0 @@
-# $Header: /var/lib/cvs/dynare_cpp/sylv/cc/Makefile,v 1.4 2005/01/18 21:28:26 kamenik Exp $
-
-# Tag $Name: $
-FF=gfortran
-
-CC_FLAGS := -Wall -Winline -fpic
-#CC_FLAGS := -Wall -Winline -I../testing -I../cc -DMATLAB \
-# $(CC_INCLUDE_PATH) -I$(MATLAB_PATH)/extern/include #-pg
-
-LDFLAGS = -Wl,-L$(MATLAB_PATH)/extern/lib/win32/microsoft/ \
- -Wl,-llibmex -Wl,-llibmx -Wl,-llibmwlapack -Wl,-llibdflapack \
- -lg2c -lmingw32 -lstdc++
-
-LD_LIBS=$(LDFLAGS)
-
-ifeq ($(DEBUG),yes)
-# CC_FLAGS := $(CC_FLAGS) -g -DTL_DEBUG=2
- CC_FLAGS := $(CC_FLAGS) -g -DPOSIX_THREADS
-else
- CC_FLAGS := $(CC_FLAGS) -O3
-endif
-
-ifeq ($(OS),Windows_NT)
- CC_FLAGS := -mno-cygwin -mthreads $(CC_FLAGS)
-endif
-
-
-objects := $(patsubst %.f90,%.o,$(wildcard *.f90))
-
-all: $(objects)
-
-clear:
- rm -f *.o
-
-%.o : %.f90
- $(FF) $(CC_FLAGS) $(EXTERN_DEFS) -c $*.f90
-
diff --git a/mex/sources/kalman/qt/f90/QT2Ld.f90 b/mex/sources/kalman/qt/f90/QT2Ld.f90
deleted file mode 100644
index f542fecada5788d12d0c6f7361300dc496280001..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/QT2Ld.f90
+++ /dev/null
@@ -1,26 +0,0 @@
-subroutine QT2Ld(X,QT,n)
-! COMPUTATIONAL SUBROUTINE: extracts lower diagonal from Quasi triangular matrix
-
-! COMPUTATIONAL SUBROUTINE: extracts lower diagonal from Quasi triangular matrix
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: QT(n,n)
-real(8), intent(out) :: X(n,n)
-integer(4) :: i
-
-
-
-
-
-X=0.0*QT
-
-
-do i=2,n
-if (QT(i,i-1)/=0.0) then
-X(i,i-1)=QT(i,i-1)
-end if
-end do
-
-return
-end subroutine QT2Ld
diff --git a/mex/sources/kalman/qt/f90/QT2T.f90 b/mex/sources/kalman/qt/f90/QT2T.f90
deleted file mode 100644
index 0eef455ecaf8116e96dea5dd94e352827e1437c9..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/QT2T.f90
+++ /dev/null
@@ -1,20 +0,0 @@
-subroutine QT2T(X,QT,n)
-! COMPUTATIONAL SUBROUTINE: extracts upper triangular from Quasi triangular matrix
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: QT(n,n)
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j
-
-
-X=0.0*QT
-do i=1,n
-do j=i,n
-X(i,j)=QT(i,j)
-end do
-end do
-
-return
-end subroutine QT2T
diff --git a/mex/sources/kalman/qt/f90/QTSQTt.f90 b/mex/sources/kalman/qt/f90/QTSQTt.f90
deleted file mode 100644
index 0878f197de7ea9365f3e9949ee2075d6a34ce686..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/QTSQTt.f90
+++ /dev/null
@@ -1,50 +0,0 @@
-subroutine QTSQTt(X,QT,S,n)
-! COMPUTATIONAL SUBROUTINE X=QT*SQT' QT upper quasi-triangular; S symmetric
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: QT(n,n)
-real(8), intent(in) :: S(n,n)
-
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j,k,h,k0
-
-real(8) :: stemp
-
-X=0*S
-do i=1,n
-do j=i, n
-if (i > 1 .AND. (QT(i,i-1)/= 0.0)) then
-h=i-1
-else
-h=i
-end if
-if (j > 1 .AND. (QT(j,j-1)/= 0.0)) then
-k=j-1
-k0=k
-else
-k=j
-k0=k
-end if
-stemp=0
-do while (h <= n)
-do while (k <= n)
-stemp=stemp+QT(i,h)*S(h,k)*QT(j,k)
-k=k+1
-end do
-k=k0
-h=h+1
-end do
-X(i,j)=stemp
-if (i /= j) then
-X(j,i)=stemp
-end if
-end do
-end do
-
-
-
-
-return
-end subroutine QTSQTt
diff --git a/mex/sources/kalman/qt/f90/QTV.f90 b/mex/sources/kalman/qt/f90/QTV.f90
deleted file mode 100644
index fbe2cc5e4b8123b4dfb7cb27cab1790cf4a24d72..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/QTV.f90
+++ /dev/null
@@ -1,33 +0,0 @@
-subroutine QTV(X,QT,V,n)
-! COMPUTATIONAL SUBROUTINE: X=QT*V QT upper quasi-triangular; V vector
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: QT(n,n)
-real(8), intent(in) :: V(n,1)
-
-real(8), intent(out) :: X(n,1)
-
-integer(4) :: i,k
-
-real(8) :: stemp
-
-
-
-do i=1,n
-stemp = 0.0
-if (i > 1 .AND. (QT(i,i-1)/= 0.0)) then
-stemp = QT(i,i-1)*v(i-1,1)
-end if
-
-do k = 0,n-i
-stemp = stemp + QT(i,k+i) * V(k+i,1)
-end do
-X(i,1)=stemp
-end do
-
-return
-end subroutine QTV
-
-
diff --git a/mex/sources/kalman/qt/f90/QTV_1.f90 b/mex/sources/kalman/qt/f90/QTV_1.f90
deleted file mode 100644
index 598cf04d07eaee1b87420fd5b28f861e02cfb72e..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/QTV_1.f90
+++ /dev/null
@@ -1,33 +0,0 @@
-subroutine QTV_1(X,QT,V,n)
-! COMPUTATIONAL SUBROUTINE: X=QT*V QT upper quasi-triangular; V vector
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: QT(n,n)
-real(8), intent(in) :: V(n,1)
-
-real(8), intent(out) :: X(n,1)
-
-integer(4) :: i,k
-
-real(8) :: stemp
-
-X=0*V
-
-do i=1,n
-stemp = 0.0
-if (i > 1 .AND. (QT(i,i-1)/= 0.0)) then
-stemp = QT(i,i-1)*v(i-1,1)
-end if
-
-do k = 0,n-i
-stemp = stemp + QT(i,k+i) * V(k+i,1)
-end do
-X(i,1)=stemp
-end do
-
-return
-end subroutine QTV_1
-
-
diff --git a/mex/sources/kalman/qt/f90/S2D.f90 b/mex/sources/kalman/qt/f90/S2D.f90
deleted file mode 100644
index 432a730167386c684f6ccef5e59bc5059fa709b0..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/S2D.f90
+++ /dev/null
@@ -1,19 +0,0 @@
-subroutine S2D(X,S,n)
-! COMPUTATIONAL SUBROUTINE TUt=T*Ut T upper triangular; U striclty upper triangular
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: S(n,n)
-real(8), intent(out) :: X(n,n)
-
-integer(4) :: i
-
-
-
-X=0.0*S
-do i=1,n
-X(i,i)=sqrt(S(i,i))
-end do
-return
-end subroutine S2D
diff --git a/mex/sources/kalman/qt/f90/S2U.f90 b/mex/sources/kalman/qt/f90/S2U.f90
deleted file mode 100644
index d7ce4dece44b18a9df120acd5e8c742c84d57060..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/S2U.f90
+++ /dev/null
@@ -1,23 +0,0 @@
-subroutine S2U(X,S,n)
-! COMPUTATIONAL SUBROUTINE: S2U extracts striclty upper triangular from symmetric
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: S(n,n)
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j
-
-
-
-
-
-X=0.0*S
-do i=1,n
-do j=i+1,n
-X(i,j)=S(i,j)
-end do
-end do
-
-return
-end subroutine S2U
diff --git a/mex/sources/kalman/qt/f90/TD.f90 b/mex/sources/kalman/qt/f90/TD.f90
deleted file mode 100644
index 59dd31f31c6c08aea437e02cd15321d4928b672d..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/TD.f90
+++ /dev/null
@@ -1,22 +0,0 @@
-subroutine TD(X,T,D,n)
-! COMPUTATIONAL SUBROUTINE TUt=T*D T upper triangular; D diagonal
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: T(n,n)
-real(8), intent(in) :: D(n,n)
-
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j
-
-
-X=0.0*T
-do i=1,n
-do j=i,n
-X(i,j)=T(i,j)*D(j,j)
-end do
-end do
-
-return
-end subroutine TD
diff --git a/mex/sources/kalman/qt/f90/TM.f90 b/mex/sources/kalman/qt/f90/TM.f90
deleted file mode 100644
index 4e0f2f1fb58e7e416360a2a1985181f8b07ef6d0..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/TM.f90
+++ /dev/null
@@ -1,29 +0,0 @@
-subroutine TM(X,T,M,n)
-! COMPUTATIONAL SUBROUTINE: TM=T*M T upper triangular; M arbitrary
-
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: T(n,n)
-real(8), intent(in) :: M(n,n)
-
-real(8), intent(out) :: X(n,n)
-
-integer(4) :: i,j,k
-
-real(8) :: stemp
-
-
-do i=1,n
-do j=1,n
-stemp = 0.0
-do k = 0,n-i
-stemp = stemp + T(i,k+i) * M(k+i,j)
-end do
-X(i,j)=stemp
-end do
-end do
-
-return
-end subroutine TM
diff --git a/mex/sources/kalman/qt/f90/TSTt.f90 b/mex/sources/kalman/qt/f90/TSTt.f90
deleted file mode 100644
index d44ffd76d15e56c7255fcb63125eb116e655b045..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/TSTt.f90
+++ /dev/null
@@ -1,34 +0,0 @@
-subroutine TSTt(X,T,S,n)
-! COMPUTATIONAL SUBROUTINE TUt=T*Ut T upper triangular; U striclty lower triangular
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: T(n,n)
-real(8), intent(in) :: S(n,n)
-
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j,k,h
-
-real(8) :: stemp
-
-
-X=0.0*S
-
-do i=1,n
-do j=1,n
-stemp = 0.0
-do h = i,n
-do k = j,n
-stemp = stemp + T(i,h) * S(h,k) * T(j,k)
-end do
-end do
-X(i,j)=stemp
-X(j,i)=stemp
-
-end do
-
-end do
-
-return
-end subroutine TSTt
diff --git a/mex/sources/kalman/qt/f90/TT.f90 b/mex/sources/kalman/qt/f90/TT.f90
deleted file mode 100644
index 5024942e06301148c7eef7e72328dfe925e7a34a..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/TT.f90
+++ /dev/null
@@ -1,29 +0,0 @@
-subroutine TT(X, T1,T2,n)
-! COMPUTATIONAL SUBROUTINE TUt=T*Ut T upper triangular; U striclty lower triangular
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: T1(n,n)
-real(8), intent(in) :: T2(n,n)
-
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j,k,h
-
-real(8) :: stemp
-
-X=0.0*T1
-
-do i=1,n
-do j=1,n
-stemp = 0.0
-do k = 0,n-i
-stemp = stemp + T1(i,k+i) * T2(k+i,j)
-end do
-X(i,j)=stemp
-end do
-
-end do
-
-return
-end subroutine TT
\ No newline at end of file
diff --git a/mex/sources/kalman/qt/f90/TU.f90 b/mex/sources/kalman/qt/f90/TU.f90
deleted file mode 100644
index 1bcdd253a48b4eff2830f62454265efa0c52f1f5..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/TU.f90
+++ /dev/null
@@ -1,31 +0,0 @@
-subroutine TU(X,T,U,n)
-! COMPUTATIONAL SUBROUTINE: TU=T*U; T upper triangular matrix; U strictly upper triangular
-
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: T(n,n)
-real(8), intent(in) :: U(n,n)
-
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j,k
-
-real(8) :: stemp
-
-
-X=0.0*T
-
-
-do i=1,n-1
-do j=i+1,n
-stemp = 0.0
-do k = i,j-1
-stemp = stemp + T(i,k) * U(k,j)
-end do
-X(i,j)=stemp
-end do
-end do
-
-return
-end subroutine TU
diff --git a/mex/sources/kalman/qt/f90/TUt.f90 b/mex/sources/kalman/qt/f90/TUt.f90
deleted file mode 100644
index 05078704464e86d5a180c6201269a4bc13dc6df4..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/TUt.f90
+++ /dev/null
@@ -1,29 +0,0 @@
-subroutine TUt(X,T,Ut,n)
-! COMPUTATIONAL SUBROUTINE TUt=T*Ut T upper triangular; U striclty lower triangular
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: T(n,n)
-real(8), intent(in) :: Ut(n,n)
-
-real(8), intent(out) :: X(n,n)
-integer(4) :: i,j,k,h
-
-real(8) :: stemp
-
-
-X=0.0*T
-do i=1,n
-do j=1,n-1
-h=max(i,j)
-stemp = 0.0
-do k = 0,n-h
-stemp = stemp + T(i,k+h) * Ut(k+h,j)
-end do
-X(i,j)=stemp
-end do
-end do
-
-return
-end subroutine TUt
\ No newline at end of file
diff --git a/mex/sources/kalman/qt/f90/TV.f90 b/mex/sources/kalman/qt/f90/TV.f90
deleted file mode 100644
index bdc651f7ef72d16a48d564336d01a5c62e5ef2a0..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/f90/TV.f90
+++ /dev/null
@@ -1,27 +0,0 @@
-subroutine TV(X,T,V,n)
-! COMPUTATIONAL SUBROUTINE: TV=T*V T upper triangular; V vector
-
-implicit none
-
-integer(4), intent(in) :: n
-real(8), intent(in) :: T(n,n)
-real(8), intent(in) :: V(n,1)
-
-real(8), intent(out) :: X(n,1)
-
-integer(4) :: i,k
-
-real(8) :: stemp
-
-
-
-do i=1,n
-stemp = 0.0
-do k = 0,n-i
-stemp = stemp + T(i,k+i) * V(k+i,1)
-end do
-X(i,1)=stemp
-end do
-
-return
-end subroutine TV
diff --git a/mex/sources/kalman/qt/test/Makefile b/mex/sources/kalman/qt/test/Makefile
deleted file mode 100644
index 566cd7dfb3269c4da531373b355edfd4e94a856f..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/Makefile
+++ /dev/null
@@ -1,85 +0,0 @@
-# $Id: Makefile 531 2005-11-30 13:49:48Z kamenik $
-# Copyright 2005, Ondra Kamenik
-
-#DEBUG = yes
-
-#LD_LIBS := -llapack -lcblas -lf77blas -latlas -lg2c
-#-mno-cygwin -DWINDOWS
-CC_FLAGS := -DMATLAB -DNO_BLAS_H -DNO_LAPACK_H \
- -Wall -I../cc -I../../sylv/cc -I../cc \
- -I$(MATLAB_PATH)/extern/include #-pg
-
-ifeq ($(DEBUG),yes)
- CC_FLAGS := -DDEBUG $(CC_FLAGS) -g -pg
-# CC_FLAGS := -DTIMING_LOOP -DDEBUG $(CC_FLAGS) -g
- KALMANLIB := kalmanlib_dbg.a
-else
-# CC_FLAGS := $(CC_FLAGS) -O3
- CC_FLAGS := -DTIMING_LOOP $(CC_FLAGS) -O3
- KALMANLIB := kalmanlib.a
-endif
-
-# Added by GP
-# LDFLAGS := -llapack -lcblas -lf77blas -latlas -lg2c -lstdc++ -lmingw32
- #LDFLAGS := -Wl,--library-path $(LD_LIBRARY_PATH)
- # -Wl,-L'f:/MinGW/lib'
- #-Wl,-L'C:/MinGW/lib/gcc-lib/i686-pc-mingw32/4.0.4' -Wl,-L'C:/MinGW/lib'
-
- LD_LIBS := -Wl,-rpath-link,$(MATLAB_PATH)/bin/glnxa64 \
- -Wl,-L$(MATLAB_PATH)/bin/glnxa64 \
- -Wl,-lmex -lmx -lmwlapack -lmwblas -lmat -lm \
- -Wl,-lstdc++ -lgfortran $(LDFLAGS)
-
-# -Wl,-L'f:/CygWin/usr/local/atlas/lib'
-# -Wl,-L'f:/CygWin/lib'
-# $(LDFLAGS)
-# LD_LIBS :=$(LDFLAGS)
-# end add
-
-#matrix_interface := GeneralMatrix Vector SylvException
-#matobjs := $(patsubst %, ../sylv/cc/%.o, $(matrix_interface))
-#mathsource := $(patsubst %, ../sylv/cc/%.h, $(matrix_interface))
-#matcppsource := $(patsubst %, ../sylv/cc/%.cpp, $(matrix_interface))
-qtf90source := $(wildcard ../f90/*.f90)
-qtobjs := $(patsubst %.f90,%.o,$(qtf90source))
-cppsource := $(wildcard *.cpp)
-hsource := $(wildcard *.h)
-objects := $(patsubst %.cpp,%.o,$(cppsource))
-
-dummy.ch:
- touch dummy.ch
-
-
-%.o: %.cpp $(hsource) $(cppsource)
- c++ $(CC_FLAGS) -c $*.cpp
-
-dgemmmtm_exe.exe: dgemmmtm_exe.o $(objects) $(qtobjs) $(hsource) $(cppsource)
- gcc $(CC_FLAGS) -o dgemmmtm_exe.exe dgemmmtm_exe.o ascii_array.o \
- $(qtobjs) $(LD_LIBS)
-
-qtmmmtm_exe.exe: qtmmmtm_exe.o $(objects) $(qtobjs) $(hsource) $(cppsource)
- gcc $(CC_FLAGS) -o qtmmmtm_exe.exe qtmmmtm_exe.o ascii_array.o \
- $(qtobjs) $(LD_LIBS)
-
-dgemvm_exe.exe: dgemvm_exe.o $(qtobjs) $(hsource) $(cppsource)
- gcc $(CC_FLAGS) -o dgemvm_exe.exe dgemvm_exe.o ascii_array.o \
- $(qtobjs) $(LD_LIBS)
-
-qtamvm_exe.exe: qtamvm_exe.o $(qtobjs) $(hsource) $(cppsource)
- gcc $(CC_FLAGS) -o qtamvm_exe.exe qtamvm_exe.o ascii_array.o \
- $(qtobjs) $(LD_LIBS)
-
-qtvmvm_exe.exe: qtvmvm_exe.o $(qtobjs) $(hsource) $(cppsource)
- gcc $(CC_FLAGS) -o qtvmvm_exe.exe qtvmvm_exe.o ascii_array.o \
- $(qtobjs) $(LD_LIBS)
-
-qtv1mvm_exe.exe: qtv1mvm_exe.o $(qtobjs) $(hsource) $(cppsource)
- gcc $(CC_FLAGS) -o qtv1mvm_exe.exe qtv1mvm_exe.o ascii_array.o \
- $(qtobjs) $(LD_LIBS)
-
-all: $(objects) dgemmmtm_exe.exe qtmmmtm_exe.exe qtv1mvm_exe.exe dgemvm_exe.exe qtvmvm_exe.exe qtamvm_exe.exe # $(cppsource) $(hsource) $(kalmanhsource) $(kalmancppsource)
-
-clear:
- rm -f *.o
- rm -f *.a
- rm -f *.{exe,dll}
diff --git a/mex/sources/kalman/qt/test/QT_tab b/mex/sources/kalman/qt/test/QT_tab
deleted file mode 100644
index d5eeaa43224e09fa123a07294a75f68843efbe5c..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/QT_tab
+++ /dev/null
@@ -1,11 +0,0 @@
-0.153060262389052 0.001380442914015 0.001695719778633 -0.096495788866461 -0.006326378534057 0.000968937494692 0.00940481674898 -0.003274924112445 0.001481132666149 0.004112932319104 -0.012701307804641
-0 0.073952133671219 -0.001504207761519 0.057433281320695 0.009662045343528 0.006617685912409 0.013462091408161 0.007891283166287 0.00060603779672 0.003369481465008 0.018748481144843
-0 0 0.016722949277241 -0.043158612323585 -0.004579527748968 0.014353708194285 -0.002590188137874 0.015728887447029 -0.000497609190313 -0.000142760660804 -0.019083813953199
-0 0 0 0.265453840405543 0.00050417813553 0.002313090008356 0.027009998927894 -0.00302237841155 -0.006605759131604 -0.009638158849163 0.01228621141328
-0 0 0 0 0.040159616212026 -0.035581727103737 -0.016954216473738 -0.007949691886576 0.003628861926114 -0.001291923621455 0.039842615500298
-0 0 0 0 0 0.10084154296869 -0.001042311199417 -0.005382521361517 0.001696402254541 -0.000540820717391 0.023206920949216
-0 0 0 0 0 0 0.054131830294643 -0.020987700402038 0.000402689298563 -0.000018817482395 0.001917827090534
-0 0 0 0 0 0 0 0.14427448853052 -0.000904268210001 -0.004155316544672 0.018404810011954
-0 0 0 0 0 0 0 0 0.009309814517978 0.000447330038827 0.00529992488884
-0 0 0 0 0 0 0 0 0 0.005213746475416 0.012395564932675
-0 0 0 0 0 0 0 0 0 0 0.026158448255444
\ No newline at end of file
diff --git a/mex/sources/kalman/qt/test/QTmatlabTest.m b/mex/sources/kalman/qt/test/QTmatlabTest.m
deleted file mode 100644
index 3ae646523e8bc0119e4e80ad295924e611897e47..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/QTmatlabTest.m
+++ /dev/null
@@ -1,45 +0,0 @@
-size=100;
-AA=rand(size);
-BB=rand(size);
-[QT1 QT2 U1 U2]=qz(AA,BB);
-
-a=rand(size,1);
-
-Loops=10000
-
-% Calling QT without use of Sylv Vector and General Matrix
-t = clock;
-[AAAA]=qtamvm(QT1,a,Loops);
-QTcpp_noSylv_TaInnerLoop_time=etime(clock, t)
-
-% Calling QT using of Sylv Vector and General Matrix
-t = clock;
-[AAAA]=qtmvm(QT1,a,Loops);
-QTcppTaInnerLoop_time=etime(clock, t)
-
-t = clock;
-[AAAA]=qtmvm_sub(QT1,a,Loops);
-QTcppTaInnerLoop_time=etime(clock, t)
-
-t = clock;
-for tt=1:Loops%0
-[AAAA]=qtmvm_sub(QT1,a,1);
-end
-QTcppTaOuterLoop_time=etime(clock, t)
-
-t = clock;
-[AAAA]=gmvm(QT1,a,Loops);
-GMcppTaInnrLoop_time=etime(clock, t)
-
-t = clock;
-for tt=1:Loops%0
-[AAAA]=gmvm(QT1,a,1);
-end
-GMcppTaOuterLoop_time=etime(clock, t)
-
-t = clock;
-for tt=1:Loops%0
-MTA=QT1*a;
-end
-matlabTa_time=etime(clock, t)
-
diff --git a/mex/sources/kalman/qt/test/aa_dat b/mex/sources/kalman/qt/test/aa_dat
deleted file mode 100644
index cdf5c02e47757424915f078ffc61199ad0deb11b..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/aa_dat
+++ /dev/null
@@ -1,11 +0,0 @@
-0.130845306698951
-0.784832609671869
-0.213653301284573
-0.81536432324564
-0.021265975953734
-0.226338606586172
-0.447782600002914
-0.43948408700417
-0.687965758422965
-0.34628969510696
-0.996770191062048
\ No newline at end of file
diff --git a/mex/sources/kalman/qt/test/ascii_array.cpp b/mex/sources/kalman/qt/test/ascii_array.cpp
deleted file mode 100644
index 958b6fdb855eefc16530e2afbe505f2a9f8ed0e1..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/ascii_array.cpp
+++ /dev/null
@@ -1,84 +0,0 @@
-// ascii_matrix.cpp
-// Based on work of 2005, Ondra Kamenik
-
-#include "ascii_array.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <iostream>
-
-#include <fstream>
-#include <string>
-
-// if the file doesn't exist, the number array is empty
-void
-AsciiNumberArray::GetMX(const char* fname, int INrows, int INcols)
- {
- rows = 0;
- cols = INcols;
-
- std::ifstream file(fname);
- std::string line;
-
- data=(double*)calloc(INcols*INrows,sizeof(double));
- while (getline(file, line))
- {
- rows++;
- int icols = 0;
- const char delims[] = " \r\n\t";
- char* lineptr = strdup(line.c_str());
- char* tok = strtok(lineptr, delims);
- while (tok)
- {
- icols++;
- double item;
- if (1 != sscanf(tok, "%lf", &item))
- {
- fprintf(stderr, "Couldn't parse a token %s as double.\n", tok);
- exit(1);
- }
- data[(rows-1)*INcols+icols-1]=item;
- tok = strtok(NULL, delims);
- }
- free(lineptr);
- if (cols)
- {
- if (cols != icols)
- {
- fprintf(stderr, "Asserted a different number of columns.\n");
- exit(1);
- }
- }
- else
- {
- cols = icols;
- }
- }
- }
-
-
-void
-AsciiNumberArray::WriteMX()
- {
- std::ofstream outFile(strcat(fname, "_out"));
- for (int i = 0; i < rows; i++)
- {
- for (int j = 0; j < cols; j++)
- {
- outFile << data[i*cols+j] << "\t";
- }
- outFile << std::endl;
- }
- outFile.close();
- }
-
-
-void WriteMX(char* fname, double* data, int rows, int cols)
- {
- AsciiNumberArray OutArray;
- OutArray.fname=fname;
- OutArray.rows=rows;
- OutArray.cols=cols;
- OutArray.data=data;
- OutArray.WriteMX();
- }
diff --git a/mex/sources/kalman/qt/test/ascii_array.h b/mex/sources/kalman/qt/test/ascii_array.h
deleted file mode 100644
index aba3ab6f14859601c0fd16668ed1d28cdb57ed93..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/ascii_array.h
+++ /dev/null
@@ -1,15 +0,0 @@
-// ascii_matrix.h
-// Based on work of Ondra Kamenik
-
-
-struct AsciiNumberArray {
- int rows;
- int cols;
- double * data;
- char* fname;
- void GetMX(const char* fname, int rows, int cols);
- void WriteMX();
-};
-
-void WriteMX(char* fname, double* data, int rows, int cols);
-
diff --git a/mex/sources/kalman/qt/test/dgemmmtm_exe.cpp b/mex/sources/kalman/qt/test/dgemmmtm_exe.cpp
deleted file mode 100644
index 51a3ede7c2f716a80619e64b8139f720e59734b4..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/dgemmmtm_exe.cpp
+++ /dev/null
@@ -1,117 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to BLAS dgemv f90 library function
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-%
-% use:
-% dgemmmtm_exe QTt_file SS_file size [loops - if enabled]
-%
-% NOTE: due to fortran matrix orientation, input matrices need to be passed
-% as transposed so QTt instead QT
-%
-%
-% INPUTS
-% QT [double] mm*mm transition matrix of the state equation.
-% SS [double] mm*mm state cov matrix.
-%
-% OUTPUTS
-% TSTt update [double] mm*mm state cov matrix updated.
-% as file: a_file_out
-**********************************************************/
-
-#include "cppblas.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <math.h>
-#include "ascii_array.h"
-#include <iostream>
-#include <stdexcept>
-#include <malloc.h>
-
-int main(int argc, char* argv[])
- {
-
- if (argc < 3 )
- {
- printf("Must have min 2 input parameters.\n");
- exit(1);
- }
-
- try
- {
- // make input matrices
- int n=atoi(argv[3]);
- double *TSTt, *TS ;
- AsciiNumberArray QT, SS;
- QT.GetMX(argv[1],n,n);
- SS.GetMX(argv[2],n,n);
- const double alpha=1.0;
- const double beta=0.0;
- // create output and upload output data
- TS=(double *)calloc(n*n, sizeof(double));
- TSTt=(double *)calloc(n*n, sizeof(double));
-
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (argc >3 )
- loops = atoi(argv[4]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-
-/* DGEMM performs one of the matrix-matrix operations
-*
-* C := alpha*op( A )*op( B ) + beta*C,
-*
-* where op( X ) is one of
-*
-* op( X ) = X or op( X ) = X',
-*
-* void BLAS_dgemm(BLCHAR transa, BLCHAR transb, CONST_BLINT m, CONST_BLINT n,
-* CONST_BLINT k, CONST_BLDOU alpha, CONST_BLDOU a, CONST_BLINT lda,
-* CONST_BLDOU b, CONST_BLINT ldb, CONST_BLDOU beta,
-* BLDOU c, CONST_BLINT ldc);
-*
-* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
-*
-*/
- BLAS_dgemm("N", "N", &n, &n, &n, &alpha, QT.data, &n, SS.data, &n, &beta, TS, &n);
-
- BLAS_dgemm("N", "T", &n, &n, &n, &alpha, TS, &n, QT.data, &n, &beta, TSTt, &n);
-
-#ifdef TIMING_LOOP
- }
- printf("QT array mvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- WriteMX(argv[2], TSTt,n,n);
- free(TSTt);
- free(TS);
- }
- catch (std::exception e)
- {
- std::cout <<"Error" << std::endl;
- }
-
- }; //main
diff --git a/mex/sources/kalman/qt/test/dgemvm_exe.cpp b/mex/sources/kalman/qt/test/dgemvm_exe.cpp
deleted file mode 100644
index 387f2c5a97333788b468dbb1e1c5cbb3d27dde12..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/dgemvm_exe.cpp
+++ /dev/null
@@ -1,104 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to BLAS dgemv f90 library function
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-% function [a] = dgevm(QT,a)
-%
-% use:
-% dgemvm_exe QTt_file a_file size [loops - if enabled]
-%
-% NOTE: due to fortran matrix orientation, input matrices need to be passed
-% as transposed so QTt instead QT
-%
-% 1. Ta = dgemv(Ld;a;n)+TV(T1;a;n).
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% a [double] mm state vector.
-%
-% OUTPUTS
-% a update [double] mm vector of the state equation.
-% as file: a_file_out
-**********************************************************/
-
-#include "cppblas.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <math.h>
-#include "ascii_array.h"
-#include <iostream>
-#include <stdexcept>
-#include <malloc.h>
-
-int main(int argc, char* argv[])
- {
-
- if (argc < 3 )
- {
- printf("Must have min 2 input parameters.\n");
- exit(1);
- }
-
- try
- {
- // make input matrices
- int n=atoi(argv[3]);
- double *Ta ;
- AsciiNumberArray QT, a;
- QT.GetMX(argv[1],n,n);
- a.GetMX(argv[2],n,1);
- const double alpha=1.0;
- const double beta=0.0;
- int inc =1;
- // create output and upload output data
- Ta=(double *)calloc(n, sizeof(double));
-
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (argc >3 )
- loops = atoi(argv[4]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-// void BLAS_dgemv(BLCHAR trans, CONST_BLINT m, CONST_BLINT n, CONST_BLDOU alpha,
-// CONST_BLDOU a, CONST_BLINT lda, CONST_BLDOU x, CONST_BLINT incx,
-// CONST_BLDOU beta, BLDOU y, CONST_BLINT incy);
-
- BLAS_dgemv("N", &n, &n, &alpha, QT.data, &n, a.data, &inc, &beta, Ta, &inc);
-
-
-#ifdef TIMING_LOOP
- }
- printf("QT array mvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- WriteMX(argv[2], Ta,n,1);
- free(Ta);
- }
- catch (std::exception e)
- {
- std::cout <<"Error" << std::endl;
- }
-
- }; //main
diff --git a/mex/sources/kalman/qt/test/qtamvm_exe.cpp b/mex/sources/kalman/qt/test/qtamvm_exe.cpp
deleted file mode 100644
index ca1758790754bc449fcf0f783c769941aec0ee4c..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/qtamvm_exe.cpp
+++ /dev/null
@@ -1,115 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to QT f90 library by Andrea Pagano
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-% function [a] = qtamvm(QT,a)
-%
-% use:
-% qtamvm_exe QTt_file a_file size [loops - if enabled]
-%
-% NOTE: due to fortran matrix orientation, input matrices need to be passed
-% as transposed so QTt instead QT
-%
-% 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
-% 2. Ta = LdV(Ld;a;n)+TV(T1;a;n).
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% a [double] mm state vector.
-%
-% OUTPUTS
-% a update [double] mm vector of the state equation.
-% as file: a_file_out
-**********************************************************/
-
-#include "qt.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <math.h>
-#include "ascii_array.h"
-#include <iostream>
-#include <stdexcept>
-#include <malloc.h>
-
-int main(int argc, char* argv[])
- {
-
- if (argc < 3 )
- {
- printf("Must have min 2 input parameters.\n");
- exit(1);
- }
-
- try
- {
- // make input matrices
- int n=atoi(argv[3]);
- double *T1, *Ld, *TV, * Ta ;
- AsciiNumberArray QT, a;
- QT.GetMX(argv[1],n,n);
- a.GetMX(argv[2],n,1);
- T1=(double *)calloc(n*n, sizeof(double));
- Ld=(double *)calloc(n*n,sizeof(double));
- TV=(double *)calloc(n, sizeof(double));
- // create output and upload output data
- Ta=(double *)calloc(n, sizeof(double));
-
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (argc >3 )
- loops = atoi(argv[4]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-#ifdef DEBUG
- // QT.print();
-#endif
- // 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
- qt2t_(T1, QT.data ,&n) ;
- qt2ld_(Ld , QT.data,&n);
- // 2. Ta = LdV(Ld;a;n)+TV(T1;a;n).
- ldv_(Ta, Ld,a.data ,&n);
- tv_(TV, T1 ,a.data,&n);
-// Ta.add(1.0,TV);
- for (int j=0; j<n;++j)
- Ta[j]+=TV[j];
-
-
-#ifdef TIMING_LOOP
- }
- printf("QT array mvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- WriteMX(argv[2], Ta,n,1);
- free(T1);
- free(Ld);
- free(TV);
- free(Ta);
- }
- catch (std::exception e)
- {
- std::cout <<"Error" << std::endl;
- }
-
- }; //main
diff --git a/mex/sources/kalman/qt/test/qtmmmtm_exe.cpp b/mex/sources/kalman/qt/test/qtmmmtm_exe.cpp
deleted file mode 100644
index 6f56d4449bc23e3b04a23092a7d3bbe35ff4522b..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/qtmmmtm_exe.cpp
+++ /dev/null
@@ -1,100 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to BLAS dgemm library function
-% to multiply Quasi trinagular matrix (T) with another matrix
-%
-% use:
-% dgemmmtm_exe QTt_file SS_file size [loops - if enabled]
-%
-% NOTE: due to fortran matrix orientation, input matrices need to be passed
-% as transposed so QTt instead QT
-%
-%
-% INPUTS
-% QT [double] mm*mm transition matrix of the state equation.
-% SS [double] mm*mm state cov matrix.
-%
-% OUTPUTS
-% TSTt update [double] mm*mm state cov matrix updated.
-% as file: a_file_out
-**********************************************************/
-
-#include "qt.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <math.h>
-#include "ascii_array.h"
-#include <iostream>
-#include <stdexcept>
-#include <malloc.h>
-
-int main(int argc, char* argv[])
- {
-
- if (argc < 3 )
- {
- printf("Must have min 2 input parameters.\n");
- exit(1);
- }
-
- try
- {
- // make input matrices
- int n=atoi(argv[3]);
- double *TSTt ;
- AsciiNumberArray QT, SS;
- QT.GetMX(argv[1],n,n);
- SS.GetMX(argv[2],n,n);
- // create output and upload output data
- TSTt=(double *)calloc(n*n, sizeof(double));
-
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (argc >3 )
- loops = atoi(argv[4]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-
-/* qtsqtt_ performs one of the matrix-matrix operations
-*
-* C := QT*S*QT'
-*/
-
- qtsqtt_(TSTt, QT.data, SS.data, &n);
-
-
-#ifdef TIMING_LOOP
- }
- printf("QT array mvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- WriteMX(argv[2], TSTt,n,n);
- free(TSTt);
- }
- catch (std::exception e)
- {
- std::cout <<"Error" << std::endl;
- }
-
- }; //main
diff --git a/mex/sources/kalman/qt/test/qtv1mvm_exe.cpp b/mex/sources/kalman/qt/test/qtv1mvm_exe.cpp
deleted file mode 100644
index f4f8ba6d66282b790950025fcb3fb2493ab23e84..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/qtv1mvm_exe.cpp
+++ /dev/null
@@ -1,105 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to QT f90 library by Andrea Pagano
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-% function [a] = qtvmvm(QT,a)
-%
-% use:
-% qtvmvm_exe QTt_file a_file size [loops - if enabled]
-%
-% NOTE: due to fortran matrix orientation, input matrices need to be passed
-% as transposed so QTt instead QT
-%
-% 2. Ta = QTV(T1;a;n).
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% a [double] mm state vector.
-%
-% OUTPUTS
-% a update [double] mm vector of the state equation.
-% as file: a_file_out
-**********************************************************/
-
-#include "qt.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <math.h>
-#include "ascii_array.h"
-#include <iostream>
-#include <stdexcept>
-#include <malloc.h>
-
-int main(int argc, char* argv[])
- {
-
- if (argc < 3 )
- {
- printf("Must have min 2 input parameters.\n");
- exit(1);
- }
-
- try
- {
- // make input matrices
- int n=atoi(argv[3]);
- double *Ta ;
- AsciiNumberArray QT, a;
- QT.GetMX(argv[1],n,n);
- a.GetMX(argv[2],n,1);
- // create output and upload output data
- Ta=(double *)calloc(n, sizeof(double));
-
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (argc >3 )
- loops = atoi(argv[4]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-#ifdef DEBUG
- // QT.print();
-#endif
- // 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
-#ifdef WINDOWS
- qtv_1__(Ta, QT.data, a.data, &n) ;
-#else
- qtv_1_(Ta, QT.data, a.data, &n) ;
-#endif
-
-
-#ifdef TIMING_LOOP
- }
- printf("QT array mvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- WriteMX(argv[2], Ta,n,1);
- free(Ta);
- }
- catch (std::exception e)
- {
- std::cout <<"Error" << std::endl;
- }
-
- }; //main
diff --git a/mex/sources/kalman/qt/test/qtvmvm_exe.cpp b/mex/sources/kalman/qt/test/qtvmvm_exe.cpp
deleted file mode 100644
index f0269c63e87ff6721154908a4a285df659e97b3d..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/qt/test/qtvmvm_exe.cpp
+++ /dev/null
@@ -1,101 +0,0 @@
-/*
-* Copyright (C) 2008-2009 Dynare Team
-*
-* This file is part of Dynare.
-*
-* Dynare is free software: you can redistribute it and/or modify
-* it under the terms of the GNU General Public License as published by
-* the Free Software Foundation, either version 3 of the License, or
-* (at your option) any later version.
-*
-* Dynare is distributed in the hope that it will be useful,
-* but WITHOUT ANY WARRANTY; without even the implied warranty of
-* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-* GNU General Public License for more details.
-*
-* You should have received a copy of the GNU General Public License
-* along with Dynare. If not, see <http://www.gnu.org/licenses/>.
-*/
-
-/******************************************************
-%
-% This provides an interface to QT f90 library by Andrea Pagano
-% to multiply Quasi trinagular matrix (T) with a vector a
-%
-% function [a] = qtvmvm(QT,a)
-%
-% use:
-% qtvmvm_exe QTt_file a_file size [loops - if enabled]
-%
-% NOTE: due to fortran matrix orientation, input matrices need to be passed
-% as transposed so QTt instead QT
-%
-% 2. Ta = QTV(T1;a;n).
-%
-% INPUTS
-% T [double] mm*mm transition matrix of the state equation.
-% a [double] mm state vector.
-%
-% OUTPUTS
-% a update [double] mm vector of the state equation.
-% as file: a_file_out
-**********************************************************/
-
-#include "qt.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <math.h>
-#include "ascii_array.h"
-#include <iostream>
-#include <stdexcept>
-#include <malloc.h>
-
-int main(int argc, char* argv[])
- {
-
- if (argc < 3 )
- {
- printf("Must have min 2 input parameters.\n");
- exit(1);
- }
-
- try
- {
- // make input matrices
- int n=atoi(argv[3]);
- double *Ta ;
- AsciiNumberArray QT, a;
- QT.GetMX(argv[1],n,n);
- a.GetMX(argv[2],n,1);
- // create output and upload output data
- Ta=(double *)calloc(n, sizeof(double));
-
-
-#ifdef TIMING_LOOP
- int loops=1;//000;
- if (argc >3 )
- loops = atoi(argv[4]);
- for (int tt=0;tt<loops;++tt)
- {
-#endif
-#ifdef DEBUG
- // QT.print();
-#endif
- // 1. T1 = QT2T(QT;n) and Ld = QT2Ld(QT;n);
- qtv_(Ta, QT.data, a.data, &n) ;
-
-
-#ifdef TIMING_LOOP
- }
- printf("QT array mvm: finished: %d loops\n",loops);
-#endif
- // create output and upload output data
- WriteMX(argv[2], Ta,n,1);
- free(Ta);
- }
- catch (std::exception e)
- {
- std::cout <<"Error" << std::endl;
- }
-
- }; //main
diff --git a/mex/sources/kalman/sylv/cc/GeneralMatrix.cpp b/mex/sources/kalman/sylv/cc/GeneralMatrix.cpp
deleted file mode 100644
index a0ba0ccb273607d78298173d4972d4d11ccf374d..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/GeneralMatrix.cpp
+++ /dev/null
@@ -1,825 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/GeneralMatrix.cpp,v 1.4 2004/11/24 20:41:59 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-
-#include "SylvException.h"
-#include "GeneralMatrix.h"
-
-#include "cppblas.h"
-#include "cpplapack.h"
-
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#include <cmath>
-#include <limits>
-
-//vector<int>nullVec(0);
-int GeneralMatrix::md_length = 32;
-
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& m)
-: data(m.rows*m.cols), rows(m.rows), cols(m.cols), ld(m.rows)
- {
- copy(m);
- }
-
-GeneralMatrix::GeneralMatrix(const ConstGeneralMatrix& m)
-: data(m.rows*m.cols), rows(m.rows), cols(m.cols), ld(m.rows)
- {
- copy(m);
- }
-
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& m, const char* dummy)
-: data(m.rows*m.cols), rows(m.cols), cols(m.rows), ld(m.cols)
- {
- for (int i = 0; i < m.rows; i++)
- for (int j = 0; j < m.cols; j++)
- get(j,i) = m.get(i,j);
- }
-
-GeneralMatrix::GeneralMatrix(const ConstGeneralMatrix& m, const char* dummy)
-: data(m.rows*m.cols), rows(m.cols), cols(m.rows), ld(m.cols)
- {
- for (int i = 0; i < m.rows; i++)
- for (int j = 0; j < m.cols; j++)
- get(j,i) = m.get(i,j);
- }
-
-
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& m, int i, int j, int nrows, int ncols)
-: data(nrows*ncols), rows(nrows), cols(ncols), ld(nrows)
- {
- copy(m, i, j);
- }
-
-GeneralMatrix::GeneralMatrix(GeneralMatrix& m, int i, int j, int nrows, int ncols)
-: data(m.base()+m.ld*j+i, m.ld*(ncols-1)+nrows), rows(nrows), cols(ncols), ld(m.ld)
- {}
-
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& a, const GeneralMatrix& b)
-: data(a.rows*b.cols), rows(a.rows), cols(b.cols), ld(a.rows)
- {
- gemm("N", a, "N", b, 1.0, 0.0);
- }
-
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& a, const GeneralMatrix& b, const char* dum)
-: data(a.rows*b.rows), rows(a.rows), cols(b.rows), ld(a.rows)
- {
- gemm("N", a, "T", b, 1.0, 0.0);
- }
-
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& a, const char* dum, const GeneralMatrix& b)
-: data(a.cols*b.cols), rows(a.cols), cols(b.cols), ld(a.cols)
- {
- gemm("T", a, "N", b, 1.0, 0.0);
- }
-
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& a, const char* dum1,
- const GeneralMatrix& b, const char* dum2)
- : data(a.cols*b.rows), rows(a.cols), cols(b.rows), ld(a.cols)
- {
- gemm("T", a, "T", b, 1.0, 0.0);
- }
-
-/* generate new matrix b as subset or whole of matrix a but reordered by
-vrows and vcols as Matlab b=a(vrows,vcols) where vectors vrows and vcols start from 1.
-It ignores non-positive elements passing zero length vector is equivalent
-to Matlab operator ":" = all elements of that dimension in its order */
-GeneralMatrix::GeneralMatrix(const GeneralMatrix& a, const vector<int>&vrows, const vector<int>&vcols)
- {
- int nrows=0, ncols=0;
- if (vrows.size()==0 && vcols.size()==0)
- {
- *this=a;
- return;
- }
- else
- {
- if (vrows.size()==0)
- nrows=a.numRows();
- else
- {
- for (int i=0;i<vrows.size();++i)
- {
- if (vrows[i]>0)
- nrows++;
- else
- throw SYLV_MES_EXCEPTION("Non-positive indices in construction by vector.");
- }
- }
- if (nrows>a.numRows())
- throw SYLV_MES_EXCEPTION("Wrong dimensions for construction by vector.");
-
- if (vcols.size()==0)
- ncols=a.numCols();
- else
- {
- for (int i=0;i<vcols.size();++i)
- {
- if (vcols[i]>0)
- ncols++;
- else
- throw SYLV_MES_EXCEPTION("Non-positive indices in construction by vector.");
- }
- }
- if (ncols>a.numCols())
- throw SYLV_MES_EXCEPTION("Wrong dimensions for construction by vector.");
-
- data= *(new Vector(nrows*ncols));
- rows=nrows;
- cols=ncols;
- if(nrows*ncols==0) return;
-
- for (int i=0;i<nrows;++i)
- {
- for (int j=0;j<nrows;++j)
- if (vrows.size()!=0 && vcols.size()!=0)
- {
- if (vrows[i]>0 && vcols[j] >0)
- get(i,j)=a.get(vrows[i]-1, vcols[j]-1);
- }
- else if (vrows.size()!=0 && vcols.size()==0)
- {
- if (vrows[i]>0 )
- get(i,j)=a.get(vrows[i]-1, j);
- }
- else if (vrows.size()==0 && vcols.size()!=0)
- {
- if (vcols[j] >0)
- get(i,j)=a.get(i, vcols[j]-1);
- }
- }
- }
- }
-
-
-
-GeneralMatrix::~GeneralMatrix()
- {
- }
-
-
-/* Matlab element product: this = this .*m */
-void
-GeneralMatrix::multElements(const GeneralMatrix& m)
- {
- if(cols!=m.numCols() || rows!=m.numRows())
- throw SYLV_MES_EXCEPTION("multiply Element porduct: matrices must be same dimension.");
- for (int i=0;i<cols;++i)
- for (int j=0;j<rows;++j)
- get(i,j)*=m.get(i,j);
- };
-
-
-/* emulates Matlab repmat: new matrix = multv*multh*this */
-GeneralMatrix&
-GeneralMatrix::repmat(int multv, int multh)
- {
- GeneralMatrix* repMat=(new GeneralMatrix ( multv*rows, multh*cols));
- for (int i=0;i<multv;++i)
- for (int j=0;j<multh;++j)
- (*repMat).place(*this, multv*i, multh*j);
- return *repMat;
- };
-
-
-void GeneralMatrix::place(const ConstGeneralMatrix& m, int i, int j)
- {
- if (i + m.numRows() > numRows() ||
- j + m.numCols() > numCols())
- throw SYLV_MES_EXCEPTION("Bad submatrix placement, matrix dimensions exceeded.");
-
- GeneralMatrix tmpsub(*this, i, j, m.numRows(), m.numCols());
- tmpsub.copy(m);
- }
-
-/* this = a*b */
-void GeneralMatrix::mult(const ConstGeneralMatrix& a, const ConstGeneralMatrix& b)
- {
- gemm("N", a, "N", b, 1.0, 0.0);
- }
-
-/* this = this + scalar*a*b */
-void GeneralMatrix::multAndAdd(const ConstGeneralMatrix& a, const ConstGeneralMatrix& b,
- double mult)
- {
- gemm("N", a, "N", b, mult, 1.0);
- }
-
-
-/* this = this + scalar*a*b' */
-void GeneralMatrix::multAndAdd(const ConstGeneralMatrix& a, const ConstGeneralMatrix& b,
- const char* dum, double mult)
- {
- gemm("N", a, "T", b, mult, 1.0);
- }
-
-/* this = this + scalar*a'*b */
-void GeneralMatrix::multAndAdd(const ConstGeneralMatrix& a, const char* dum,
- const ConstGeneralMatrix& b, double mult)
- {
- gemm("T", a, "N", b, mult, 1.0);
- }
-
-/* this = this + scalar*a'*b' */
-void GeneralMatrix::multAndAdd(const ConstGeneralMatrix& a, const char* dum1,
- const ConstGeneralMatrix& b, const char* dum2, double mult)
- {
- gemm("T", a, "T", b, mult, 1.0);
- }
-
-void GeneralMatrix::addOuter(const ConstVector& a, double mult)
- {
- if (numRows() != numCols())
- throw SYLV_MES_EXCEPTION("Matrix is not square in GeneralMatrix::addOuter.");
- if (numRows() != a.length())
- throw SYLV_MES_EXCEPTION("Wrong length of a vector in GeneralMatrix::addOuter.");
-
- // since BLAS dsyr (symmetric rank 1 update) assumes symmetricity, we do this manually
- for (int i = 0; i < numRows(); i++)
- for (int j = i; j < numRows(); j++) {
- double s = mult*a[i]*a[j];
- get(i,j) = get(i,j) + s;
- if (i != j)
- get(j,i) = get(j,i) + s;
- }
- }
-
-
-void GeneralMatrix::multRight(const ConstGeneralMatrix& m)
- {
- gemm_partial_right("N", m, 1.0, 0.0);
- }
-
-void GeneralMatrix::multLeft(const ConstGeneralMatrix& m)
- {
- gemm_partial_left("N", m, 1.0, 0.0);
- }
-
-void GeneralMatrix::multRightTrans(const ConstGeneralMatrix& m)
- {
- gemm_partial_right("T", m, 1.0, 0.0);
- }
-
-void GeneralMatrix::multLeftTrans(const ConstGeneralMatrix& m)
- {
- gemm_partial_left("T", m, 1.0, 0.0);
- }
-
-
-/* this = this * A^(-1) */
-void
-GeneralMatrix::multInvRight( GeneralMatrix&A)
- {
- // check or allocate tmp space for Transpose *this
- /**
- if (tmpGMp)
- {
- if (tmpGMp->numCols()!=rows || tmpGMp->numRows()!=cols)
- delete (tmpGMp);
- }
- if (!tmpGMp)
- ********/
- tmpGMp= new GeneralMatrix(cols,rows); // allocate space only once if and when needed!
-
- // tmpGMp=(*this)' i.e. Transpose (*this)
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- tmpGMp->get(j,i) = get(i,j);
- // check A and this suiability
- const int mcols=A.numCols();
- if (A.numRows() != mcols) {
- throw SYLV_MES_EXCEPTION("The matrix is not square for inversion.");
- }
- if (cols != A.numRows()) {
- throw SYLV_MES_EXCEPTION("Wrong dimensions for matrix inverse mutliply.");
- }
-
- if (rows > 0)
- {
- /* out =tmpGMp out = inv(A')*(*this)' = inv(A')*(*tmpGMp) */
- int* ipiv = new int[cols];
- int info;
- const int mld=A.getLD();
- LAPACK_dgetrf(&cols, &cols, A.base(), &cols, ipiv, &info);
- LAPACK_dgetrs("T", &cols, &mcols, A.base(), &cols, ipiv, tmpGMp->base(),
- &mld, &info);
- delete [] ipiv;
- // *this= Transpose(tmpGMp out)
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) = tmpGMp->get(j,i);
- }
- delete tmpGMp;
- }
-
-
-// here we must be careful for ld
-void GeneralMatrix::zeros()
- {
- if (ld == rows)
- data.zeros();
- else {
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) = 0;
- }
- }
-
-void GeneralMatrix::unit()
- {
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- if (i == j)
- get(i,j) = 1.0;
- else
- get(i,j) = 0.0;
- }
-
-void GeneralMatrix::nans()
- {
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) = std::numeric_limits<double>::quiet_NaN();
- }
-
-void GeneralMatrix::infs()
- {
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) = std::numeric_limits<double>::infinity();
- }
-
-
-// here we must be careful for ld
-void GeneralMatrix::mult(double a)
- {
- if (ld == rows)
- data.mult(a);
- else {
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) *= a;
- }
- }
-
-// here we must be careful for ld
-void GeneralMatrix::add(double a, const ConstGeneralMatrix& m)
- {
- if (m.numRows() != rows || m.numCols() != cols)
- throw SYLV_MES_EXCEPTION("Matrix has different size in GeneralMatrix::add.");
-
- if (ld == rows && m.ld == m.rows)
- data.add(a, m.data);
- else {
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) += a*m.get(i,j);
- }
- }
-
-void GeneralMatrix::add(double a, const ConstGeneralMatrix& m, const char* dum)
- {
- if (m.numRows() != cols || m.numCols() != rows)
- throw SYLV_MES_EXCEPTION("Matrix has different size in GeneralMatrix::add.");
-
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) += a*m.get(j,i);
- }
-
-
-bool GeneralMatrix::isDiff(const GeneralMatrix& m, const double tol=0.0)const
- {
- if (m.numRows() != rows || m.numCols() != cols)
- throw SYLV_MES_EXCEPTION("Matrix has different size in GeneralMatrix::isDiff.");
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- if (fabs(get(i,j) - m.get(i,j))>tol)
- return true;
- return false;
- }
-
-bool GeneralMatrix::isDiffSym(const GeneralMatrix& m, const double tol=0.0)const
- {
- if (m.numRows() != rows || m.numCols() != cols || m.numRows() != cols || m.numCols() != rows)
- throw SYLV_MES_EXCEPTION("Matrix has different size or not square in GeneralMatrix::isDiffSym.");
- for (int i = 0; i < cols; i++)
- for (int j = 0; i+j < cols ; j++) // traverse the upper triangle only
- if (fabs(get(j,j+i) - m.get(j,j+i))>tol) // along diagonals where higher changes occur
- return true;
- return false;
- }
-
-
-/* x = scalar(a)*x + scalar(b)*this*d */
-void GeneralMatrix::multVec(double a, Vector& x, double b, const ConstVector& d) const
- {
- if (x.length() != rows || cols != d.length()) {
- throw SYLV_MES_EXCEPTION("Wrong dimensions for vector multiply.");
- }
- if (rows > 0) {
- int mm = rows;
- int nn = cols;
- double alpha = b;
- int lda = ld;
- int incx = d.skip();
- double beta = a;
- int incy = x.skip();
- BLAS_dgemv("N", &mm, &nn, &alpha, data.base(), &lda, d.base(), &incx,
- &beta, x.base(), &incy);
- }
-
- }
-
-void GeneralMatrix::copy(const ConstGeneralMatrix& m, int ioff, int joff)
- {
- for (int i = 0; i < rows; i++)
- for (int j = 0; j < cols; j++)
- get(i,j) = m.get(i+ioff,j+joff);
- }
-
-
-void
-GeneralMatrix::copy(const ConstGeneralMatrix& m)
- {
- memcpy(data.base() ,m.getData().base() ,m.numCols()*m.numRows()*sizeof(double));
- };
-
-void
-GeneralMatrix::copy(const GeneralMatrix& m)
- {
- memcpy(data.base(),m.getData().base(),m.numCols()*m.numRows()*sizeof(double));
- };
-
-void
-GeneralMatrix::copyColumns(const GeneralMatrix& m, int istart, int iend, int ito)
- {
- if ((rows!=m.numRows())|| istart<iend|| istart> m.numCols()-1 || iend> m.numCols()-1
- || ito> cols-1 )
- throw SYLV_MES_EXCEPTION("Wrong dimensions for copying matrix columns.");
-
- memcpy(data.base()+ito*rows*sizeof(double)
- ,m.getData().base()+istart*rows*sizeof(double)
- ,(iend-istart+1)*rows*sizeof(double));
- };
-
-
-
-/* emulates Matlab command A(a,b)=B(c,d) where a,b,c,d are vectors or ":")*/
-void
-GeneralMatrix::AssignByVectors(GeneralMatrix& a, const vector<int>& vToRows, const vector<int>& vToCols
- , const GeneralMatrix& b, const vector<int>& vrows, const vector<int>& vcols)
- {
- int nrows=0, ncols=0, tonrows=0, toncols=0;
- const vector<int> *vpToCols=0, *vpToRows=0, *vpRows=0, *vpCols=0;
- vector<int> *tmpvpToCols=0, *tmpvpToRows=0, *tmpvpRows=0, *tmpvpCols=0;
-
- if (vToRows.size()==0 && vToCols.size()==0 &&vrows.size()==0 && vcols.size()==0)
- a=b;
- else
- {
- if (vToRows.size()==0)
- {
- tonrows=a.numRows();
-// vpToRows=new vector<int>(tonrows);
- tmpvpToRows=new vector<int>(tonrows);
- for (int i=0;i<tonrows;++i)
- (*tmpvpToRows)[i]=i+1;
- vpToRows=(const vector<int>*)tmpvpToRows;
- }
- else
- {
- for (int i=0;i<vToRows.size();++i)
- {
- if (vToRows[i]>0)
- tonrows++;
- else
- throw SYLV_MES_EXCEPTION("Non-positive indices in assignment by vector.");
- }
- vpToRows=&vToRows;
- }
- if (tonrows>a.numRows())
- throw SYLV_MES_EXCEPTION("Wrong dimensions for assignment by vector.");
-
- if (vToCols.size()==0)
- {
- toncols=a.numCols();
- tmpvpToCols=new vector<int>(toncols);
- for (int i=0;i<toncols;++i)
- (*tmpvpToCols)[i]=i+1;
- vpToCols=(const vector<int>*)tmpvpToCols;
- }
- else
- {
- for (int i=0;i<vToCols.size();++i)
- {
- if (vToCols[i]>0)
- toncols++;
- else
- throw SYLV_MES_EXCEPTION("Non-positive indices in assignment by vector.");
- }
- vpToCols=&vToCols;
- }
- if (toncols>a.numCols())
- throw SYLV_MES_EXCEPTION("Wrong dimensions for assignment by vector.");
-
- if (vrows.size()==0)
- {
- nrows=b.numRows();
- tmpvpRows=new vector<int>(nrows);
- for (int i=0;i<nrows;++i)
- (*tmpvpToRows)[i]=i+1;
- vpRows=(const vector<int>*)tmpvpRows;
- }
- else
- {
- for (int i=0;i<vrows.size();++i)
- {
- if (vrows[i]>0)
- nrows++;
- else
- throw SYLV_MES_EXCEPTION("Non-positive indices in assignment by vector.");
- }
- vpRows=&vrows;
- }
- if (nrows>b.numRows())
- throw SYLV_MES_EXCEPTION("Wrong dimensions for assignment by vector.");
-
- if (vcols.size()==0)
- {
- ncols=b.numCols();
- tmpvpCols=new vector<int>(ncols);
- for (int i=0;i<ncols;++i)
- (*tmpvpCols)[i]=i+1;
- vpCols=(const vector<int>*)tmpvpCols;
- }
- else
- {
- for (int i=0;i<vcols.size();++i)
- {
- if (vcols[i]>0)
- ncols++;
- else
- throw SYLV_MES_EXCEPTION("Non-positive indices in assignment by vector.");
- }
- vpCols=&vcols;
- }
- if (ncols>b.numCols())
- throw SYLV_MES_EXCEPTION("Wrong dimensions for assignment by vector.");
-
- if (tonrows!=nrows || toncols!=ncols)
- throw SYLV_MES_EXCEPTION("Wrong indices dimensions for assignment by vector.");
-
- if(!(nrows*ncols==0 || tonrows*toncols==0))
- {
- for (int i=0;i<nrows;++i)
- {
- for (int j=0;j<nrows;++j)
- a.get((*vpToRows)[i]-1,(*vpToCols)[j]-1)=b.get((*vpRows)[i]-1, (*vpCols)[j]-1);
- }
- }
- if (tmpvpToCols) delete(tmpvpToCols);
- if (tmpvpToRows) delete(tmpvpToRows);
- if (tmpvpRows) delete(tmpvpRows);
- if (tmpvpCols) delete(tmpvpCols);
- }
- }
-
-
-void GeneralMatrix::gemm(const char* transa, const ConstGeneralMatrix& a,
- const char* transb, const ConstGeneralMatrix& b,
- double alpha, double beta)
- {
- int opa_rows = a.numRows();
- int opa_cols = a.numCols();
- if (!strcmp(transa, "T")) {
- opa_rows = a.numCols();
- opa_cols = a.numRows();
- }
- int opb_rows = b.numRows();
- int opb_cols = b.numCols();
- if (!strcmp(transb, "T")) {
- opb_rows = b.numCols();
- opb_cols = b.numRows();
- }
-
- if (opa_rows != numRows() ||
- opb_cols != numCols() ||
- opa_cols != opb_rows) {
- throw SYLV_MES_EXCEPTION("Wrong dimensions for matrix multiplication.");
- }
-
- int m = opa_rows;
- int n = opb_cols;
- int k = opa_cols;
- int lda = a.ld;
- int ldb = b.ld;
- int ldc = ld;
- if (lda > 0 && ldb > 0 && ldc > 0) {
- BLAS_dgemm(transa, transb, &m, &n, &k, &alpha, a.data.base(), &lda,
- b.data.base(), &ldb, &beta, data.base(), &ldc);
- } else if (numRows()*numCols() > 0) {
- if (beta == 0.0)
- zeros();
- else
- mult(beta);
- }
- }
-
-void GeneralMatrix::gemm_partial_left(const char* trans, const ConstGeneralMatrix& m,
- double alpha, double beta)
- {
- int icol;
- for (icol = 0; icol + md_length < cols; icol += md_length) {
- GeneralMatrix incopy((const GeneralMatrix&)*this, 0, icol, rows, md_length);
- GeneralMatrix inplace((GeneralMatrix&)*this, 0, icol, rows, md_length);
- inplace.gemm(trans, m, "N", ConstGeneralMatrix(incopy), alpha, beta);
- }
- if (cols > icol) {
- GeneralMatrix incopy((const GeneralMatrix&)*this, 0, icol, rows, cols - icol);
- GeneralMatrix inplace((GeneralMatrix&)*this, 0, icol, rows, cols - icol);
- inplace.gemm(trans, m, "N", ConstGeneralMatrix(incopy), alpha, beta);
- }
- }
-
-void GeneralMatrix::gemm_partial_right(const char* trans, const ConstGeneralMatrix& m,
- double alpha, double beta)
- {
- int irow;
- for (irow = 0; irow + md_length < rows; irow += md_length) {
- GeneralMatrix incopy((const GeneralMatrix&)*this, irow, 0, md_length, cols);
- GeneralMatrix inplace((GeneralMatrix&)*this, irow, 0, md_length, cols);
- inplace.gemm("N", ConstGeneralMatrix(incopy), trans, m, alpha, beta);
- }
- if (rows > irow) {
- GeneralMatrix incopy((const GeneralMatrix&)*this, irow, 0, rows - irow, cols);
- GeneralMatrix inplace((GeneralMatrix&)*this, irow, 0, rows - irow, cols);
- inplace.gemm("N", ConstGeneralMatrix(incopy), trans, m, alpha, beta);
- }
- }
-
-ConstGeneralMatrix::ConstGeneralMatrix(const GeneralMatrix& m, int i, int j, int nrows, int ncols)
-: data(m.getData(), j*m.getLD()+i, (ncols-1)*m.getLD()+nrows), rows(nrows), cols(ncols), ld(m.getLD())
- {
- // can check that the submatirx is fully in the matrix
- }
-
-ConstGeneralMatrix::ConstGeneralMatrix(const ConstGeneralMatrix& m, int i, int j, int nrows, int ncols)
-: data(m.getData(), j*m.getLD()+i, (ncols-1)*m.getLD()+nrows), rows(nrows), cols(ncols), ld(m.getLD())
- {
- // can check that the submatirx is fully in the matrix
- }
-
-
-ConstGeneralMatrix::ConstGeneralMatrix(const GeneralMatrix& m)
-: data(m.data), rows(m.rows), cols(m.cols), ld(m.ld) {}
-
-
-double ConstGeneralMatrix::getNormInf() const
- {
- double norm = 0.0;
- for (int i = 0; i < numRows(); i++) {
- ConstVector rowi(data.base()+i, ld, cols);
- double normi = rowi.getNorm1();
- if (norm < normi)
- norm = normi;
- }
- return norm;
- }
-
-double ConstGeneralMatrix::getNorm1() const
- {
- double norm = 0.0;
- for (int j = 0; j < numCols(); j++) {
- ConstVector colj(data.base()+ld*j, 1, rows);
- double normj = colj.getNorm1();
- if (norm < normj)
- norm = normj;
- }
- return norm;
- }
-
-/* x = scalar(a)*x + scalar(b)*this*d */
-void ConstGeneralMatrix::multVec(double a, Vector& x, double b, const ConstVector& d) const
- {
- if (x.length() != rows || cols != d.length()) {
- throw SYLV_MES_EXCEPTION("Wrong dimensions for vector multiply.");
- }
- if (rows > 0) {
- int mm = rows;
- int nn = cols;
- double alpha = b;
- int lda = ld;
- int incx = d.skip();
- double beta = a;
- int incy = x.skip();
- BLAS_dgemv("N", &mm, &nn, &alpha, data.base(), &lda, d.base(), &incx,
- &beta, x.base(), &incy);
- }
-
- }
-
-void ConstGeneralMatrix::multVecTrans(double a, Vector& x, double b,
- const ConstVector& d) const
- {
- if (x.length() != cols || rows != d.length()) {
- throw SYLV_MES_EXCEPTION("Wrong dimensions for vector multiply.");
- }
- if (rows > 0) {
- int mm = rows;
- int nn = cols;
- double alpha = b;
- int lda = rows;
- int incx = d.skip();
- double beta = a;
- int incy = x.skip();
- BLAS_dgemv("T", &mm, &nn, &alpha, data.base(), &lda, d.base(), &incx,
- &beta, x.base(), &incy);
- }
- }
-
-/* m = inv(this)*m */
-void ConstGeneralMatrix::multInvLeft(const char* trans, int mrows, int mcols, int mld, double* d) const
- {
- if (rows != cols) {
- throw SYLV_MES_EXCEPTION("The matrix is not square for inversion.");
- }
- if (cols != mrows) {
- throw SYLV_MES_EXCEPTION("Wrong dimensions for matrix inverse mutliply.");
- }
-
- if (rows > 0) {
- GeneralMatrix inv(*this);
- int* ipiv = new int[rows];
- int info;
- LAPACK_dgetrf(&rows, &rows, inv.getData().base(), &rows, ipiv, &info);
- LAPACK_dgetrs(trans, &rows, &mcols, inv.base(), &rows, ipiv, d,
- &mld, &info);
- delete [] ipiv;
- }
- }
-
-/* m = inv(this)*m */
-void ConstGeneralMatrix::multInvLeft(GeneralMatrix& m) const
- {
- multInvLeft("N", m.numRows(), m.numCols(), m.getLD(), m.getData().base());
- }
-
-/* m = inv(this')*m */
-void ConstGeneralMatrix::multInvLeftTrans(GeneralMatrix& m) const
- {
- multInvLeft("T", m.numRows(), m.numCols(), m.getLD(), m.getData().base());
- }
-
-/* d = inv(this)*d */
-void ConstGeneralMatrix::multInvLeft(Vector& d) const
- {
- if (d.skip() != 1) {
- throw SYLV_MES_EXCEPTION("Skip!=1 not implemented in ConstGeneralMatrix::multInvLeft(Vector&)");
- }
-
- multInvLeft("N", d.length(), 1, d.length(), d.base());
- }
-
-/* d = inv(this')*d */
-void ConstGeneralMatrix::multInvLeftTrans(Vector& d) const
- {
- if (d.skip() != 1) {
- throw SYLV_MES_EXCEPTION("Skip!=1 not implemented in ConstGeneralMatrix::multInvLeft(Vector&)");
- }
-
- multInvLeft("T", d.length(), 1, d.length(), d.base());
- }
-
-
-bool ConstGeneralMatrix::isFinite() const
- {
- for (int i = 0; i < numRows(); i++)
- for (int j = 0; j < numCols(); j++)
- if (! std::isfinite(get(i,j)))
- return false;
- return true;
- }
-
-bool ConstGeneralMatrix::isZero() const
- {
- for (int i = 0; i < numRows(); i++)
- for (int j = 0; j < numCols(); j++)
- if (get(i,j) != 0.0)
- return false;
- return true;
- }
-
-void ConstGeneralMatrix::print() const
- {
- printf("rows=%d, cols=%d\n",rows, cols);
- for (int i = 0; i < rows; i++) {
- printf("row %d:\n",i);
- for (int j = 0; j < cols; j++) {
- printf("%6.3g ",get(i,j));
- }
- printf("\n");
- }
- }
diff --git a/mex/sources/kalman/sylv/cc/GeneralMatrix.h b/mex/sources/kalman/sylv/cc/GeneralMatrix.h
deleted file mode 100644
index 4afd0723d1b035fd0a5ad0c2f343be8003eeeeeb..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/GeneralMatrix.h
+++ /dev/null
@@ -1,355 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/GeneralMatrix.h,v 1.3 2004/11/24 20:41:59 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-#ifndef GENERAL_MATRIX_H
-#define GENERAL_MATRIX_H
-
-#include "Vector.h"
-#include <vector>
-using namespace std;
-//#define nullVec (const vector<int>(0))
-const vector<int>nullVec(0);
-
-class GeneralMatrix;
-
-class ConstGeneralMatrix {
- friend class GeneralMatrix;
- protected:
- ConstVector data;
- int rows;
- int cols;
- int ld;
- public:
- ConstGeneralMatrix(const double* d, int m, int n)
- : data(d, m*n), rows(m), cols(n), ld(m) {}
- ConstGeneralMatrix(const GeneralMatrix& m);
- ConstGeneralMatrix(const GeneralMatrix& m, int i, int j, int nrows, int ncols);
- ConstGeneralMatrix(const ConstGeneralMatrix& m, int i, int j, int nrows, int ncols);
- virtual ~ConstGeneralMatrix() {}
-
- const double& get(int i, int j) const
- {return data[j*ld+i];}
- int numRows() const {return rows;}
- int numCols() const {return cols;}
- int getLD() const {return ld;}
- const double* base() const {return data.base();}
- const ConstVector& getData() const {return data;}
-
- double getNormInf() const;
- double getNorm1() const;
- /* x = scalar(a)*x + scalar(b)*this*d */
- void multVec(double a, Vector& x, double b, const ConstVector& d) const;
- /* x = scalar(a)*x + scalar(b)*this'*d */
- void multVecTrans(double a, Vector& x, double b, const ConstVector& d) const;
- /* x = x + this*d */
- void multaVec(Vector& x, const ConstVector& d) const
- {multVec(1.0, x, 1.0, d);}
- /* x = x + this'*d */
- void multaVecTrans(Vector& x, const ConstVector& d) const
- {multVecTrans(1.0, x, 1.0, d);}
- /* x = x - this*d */
- void multsVec(Vector& x, const ConstVector& d) const
- {multVec(1.0, x, -1.0, d);}
- /* x = x - this'*d */
- void multsVecTrans(Vector& x, const ConstVector& d) const
- {multVecTrans(1.0, x, -1.0, d);}
- /* m = inv(this)*m */
- void multInvLeft(GeneralMatrix& m) const;
- /* m = inv(this')*m */
- void multInvLeftTrans(GeneralMatrix& m) const;
- /* d = inv(this)*d */
- void multInvLeft(Vector& d) const;
- /* d = inv(this')*d */
- void multInvLeftTrans(Vector& d) const;
-
- bool isFinite() const;
- /** Returns true of the matrix is exactly zero. */
- bool isZero() const;
- virtual void print() const;
- protected:
- void multInvLeft(const char* trans, int mrows, int mcols, int mld, double* d) const;
- };
-
-
-class GeneralMatrix {
- friend class ConstGeneralMatrix;
- protected:
- Vector data;
- int rows;
- int cols;
- int ld;
- GeneralMatrix * tmpGMp;
-public:
- GeneralMatrix(int m, int n)
- : data(m*n), rows(m), cols(n), ld(m) {}
- GeneralMatrix(const double* d, int m, int n)
- : data(d, m*n), rows(m), cols(n), ld(m) {}
- GeneralMatrix(double* d, int m, int n)
- : data(d, m*n), rows(m), cols(n), ld(m) {}
- GeneralMatrix(const GeneralMatrix& m);
- GeneralMatrix(const ConstGeneralMatrix& m);
- GeneralMatrix(const GeneralMatrix&m, const char* dummy); // transpose
- GeneralMatrix(const ConstGeneralMatrix&m, const char* dummy); // transpose
- GeneralMatrix(const GeneralMatrix& m, int i, int j, int nrows, int ncols);
- GeneralMatrix(GeneralMatrix& m, int i, int j, int nrows, int ncols);
- /* this = a*b */
- GeneralMatrix(const GeneralMatrix& a, const GeneralMatrix& b);
- /* this = a*b' */
- GeneralMatrix(const GeneralMatrix& a, const GeneralMatrix& b, const char* dum);
- /* this = a'*b */
- GeneralMatrix(const GeneralMatrix& a, const char* dum, const GeneralMatrix& b);
- /* this = a'*b */
- GeneralMatrix(const GeneralMatrix& a, const char* dum1,
- const GeneralMatrix& b, const char* dum2);
-
- /* generate new matrix b as subset or whole of matrix a but
- reordered by vrows and vcols as Matlab b=a(vrows,vcols)
- ignores non-positive elements and passing zero length vector is equivalent to
- Matlab operator ":" = all elements of that dimension in its order */
-
- GeneralMatrix(const GeneralMatrix& a, const vector<int>& vrows, const vector<int>& vcols);
- GeneralMatrix(const ConstGeneralMatrix& a, const vector<int> &vrows, const vector<int> &vcols)
- {GeneralMatrix(GeneralMatrix(a), vrows, vcols);};
-
- virtual ~GeneralMatrix();
- const GeneralMatrix& operator=(const GeneralMatrix& m)
- {
- if (this!=&m)
- {
- if (rows==m.rows && cols==m.cols && ld==m.ld && data.base()!=m.data.base() )
- copy(m);
- else
- {
- data=m.data; rows=m.rows; cols=m.cols; ld=m.ld;
- }
- }
- return *this;
- }
-
- /* emulate Matlab repmat: new matrix = multv*multh*this */
- GeneralMatrix& repmat(int multv, int multh);
-
- const double& get(int i, int j) const
- {return data[j*ld+i];}
- double& get(int i, int j)
- {return data[j*ld+i];}
- int numRows() const {return rows;}
- int numCols() const {return cols;}
- int getLD() const {return ld;}
- double* base() {return data.base();}
- const double* base() const {return data.base();}
- Vector& getData() {return data;}
- const Vector& getData() const {return data;}
-
- double getNormInf() const
- {return ConstGeneralMatrix(*this).getNormInf();}
- double getNorm1() const
- {return ConstGeneralMatrix(*this).getNorm1();}
-
- /* place matrix m to the position (i,j) */
- void place(const ConstGeneralMatrix& m, int i, int j);
- void place(const GeneralMatrix& m, int i, int j)
- {place(ConstGeneralMatrix(m), i, j);}
-
- /* this = a*b */
- void mult(const ConstGeneralMatrix& a, const ConstGeneralMatrix& b);
- void mult(const GeneralMatrix& a, const GeneralMatrix& b)
- {mult(ConstGeneralMatrix(a), ConstGeneralMatrix(b));}
-
- /* this = this + scalar*a*b */
- void multAndAdd(const ConstGeneralMatrix& a, const ConstGeneralMatrix& b,
- double mult=1.0);
- void multAndAdd(const GeneralMatrix& a, const GeneralMatrix& b,
- double mult=1.0)
- {multAndAdd(ConstGeneralMatrix(a), ConstGeneralMatrix(b), mult);}
-
- /* this = this + scalar*a*b' */
- void multAndAdd(const ConstGeneralMatrix& a, const ConstGeneralMatrix& b,
- const char* dum, double mult=1.0);
- void multAndAdd(const GeneralMatrix& a, const GeneralMatrix& b,
- const char* dum, double mult=1.0)
- {multAndAdd(ConstGeneralMatrix(a), ConstGeneralMatrix(b), dum, mult);}
-
- /* this = this + scalar*a'*b */
- void multAndAdd(const ConstGeneralMatrix& a, const char* dum, const ConstGeneralMatrix& b,
- double mult=1.0);
- void multAndAdd(const GeneralMatrix& a, const char* dum, const GeneralMatrix& b,
- double mult=1.0)
- {multAndAdd(ConstGeneralMatrix(a), dum, ConstGeneralMatrix(b), mult);}
-
- /* this = this + scalar*a'*b' */
- void multAndAdd(const ConstGeneralMatrix& a, const char* dum1,
- const ConstGeneralMatrix& b, const char* dum2, double mult=1.0);
- void multAndAdd(const GeneralMatrix& a, const char* dum1,
- const GeneralMatrix& b, const char* dum2, double mult=1.0)
- {multAndAdd(ConstGeneralMatrix(a), dum1, ConstGeneralMatrix(b),dum2, mult);}
-
- /* this = this + scalar*a*a' */
- void addOuter(const ConstVector& a, double mult=1.0);
- void addOuter(const Vector& a, double mult=1.0)
- {addOuter(ConstVector(a), mult);}
-
- /* this = this * m */
- void multRight(const ConstGeneralMatrix& m);
- void multRight(const GeneralMatrix& m)
- {multRight(ConstGeneralMatrix(m));}
-
- /* this = m * this */
- void multLeft(const ConstGeneralMatrix& m);
- void multLeft(const GeneralMatrix& m)
- {multLeft(ConstGeneralMatrix(m));}
-
- /* this = this * m' */
- void multRightTrans(const ConstGeneralMatrix& m);
- void multRightTrans(const GeneralMatrix& m)
- {multRightTrans(ConstGeneralMatrix(m));}
-
- /* this = m' * this */
- void multLeftTrans(const ConstGeneralMatrix& m);
- void multLeftTrans(const GeneralMatrix& m)
- {multLeftTrans(ConstGeneralMatrix(m));}
-
- /* Matlab element product: this = this .*m */
- void multElements(const GeneralMatrix& m);
- void multElements(const ConstGeneralMatrix& m)
- {multElements(GeneralMatrix(m));}
-
-
- /* this = this * m^(-1) */
- void multInvRight(GeneralMatrix&m);
-
- /* x = scalar(a)*x + scalar(b)*this*d */
- void multVec(double a, Vector& x, double b, const ConstVector& d) const;
-// {ConstGeneralMatrix(*this).multVec(a, x, b, d);}
-
- /* x = scalar(a)*x + scalar(b)*this'*d */
- void multVecTrans(double a, Vector& x, double b, const ConstVector& d) const
- {ConstGeneralMatrix(*this).multVecTrans(a, x, b, d);}
-
- /* x = x + this*d */
- void multaVec(Vector& x, const ConstVector& d) const
- {ConstGeneralMatrix(*this).multaVec(x, d);}
-
- /* x = x + this'*d */
- void multaVecTrans(Vector& x, const ConstVector& d) const
- {ConstGeneralMatrix(*this).multaVecTrans(x, d);}
-
- /* x = x - this*d */
- void multsVec(Vector& x, const ConstVector& d) const
- {ConstGeneralMatrix(*this).multsVec(x, d);}
-
- /* x = x - this'*d */
- void multsVecTrans(Vector& x, const ConstVector& d) const
- {ConstGeneralMatrix(*this).multsVecTrans(x, d);}
-
- /* this = zero */
- void zeros();
-
- /** this = unit (on main diagonal) */
- void unit();
-
- /* this = NaN */
- void nans();
-
- /* this = Inf */
- void infs();
-
- /* this = scalar*this */
- void mult(double a);
-
- /* this = this + scalar*m */
- void add(double a, const ConstGeneralMatrix& m);
- void add(double a, const GeneralMatrix& m)
- {add(a, ConstGeneralMatrix(m));}
-
- /* this = this + scalar*m' */
- void add(double a, const ConstGeneralMatrix& m, const char* dum);
- void add(double a, const GeneralMatrix& m, const char* dum)
- {add(a, ConstGeneralMatrix(m), dum);}
-
- /* Returns true if this and m matrices are different for more than tolerance tol */
- bool isDiff(const GeneralMatrix& m, const double tol)const;
- bool isDiffSym(const GeneralMatrix& m, const double tol)const;
- bool isDiffUpprTriang(const GeneralMatrix& m, const double tol=0.0)const
- {return isDiffSym(m, tol);}
-
- bool isFinite() const
- {return (ConstGeneralMatrix(*this)).isFinite();}
-
- bool isZero() const
- {return (ConstGeneralMatrix(*this)).isZero();}
-
- virtual void print() const
- {ConstGeneralMatrix(*this).print();}
-
- void copyColumns(const GeneralMatrix& m, int istart, int iend, int ito);
- void copyColumns(const ConstGeneralMatrix& m, int istart, int iend, int ito)
- {copyColumns(GeneralMatrix( m), istart, iend, ito);};
-
-
- /* emulates Matlab command A(a,b)=B(c,d) where a,b,c,d are Matlab index vectors starting from 1 or ":") */
- static void AssignByVectors(GeneralMatrix& a, const vector<int>& vToRows, const vector<int>& vToCols
- , const GeneralMatrix& b, const vector<int>& vrows, const vector<int>& vcols);
- static void AssignByVectors(GeneralMatrix& a, const vector<int>& vToRows, const vector<int>& vToCols
- , const ConstGeneralMatrix& b, const vector<int> &vrows, const vector<int> &vcols)
- {AssignByVectors(a, vToRows, vToCols, GeneralMatrix(b), vrows, vcols);};
- void AssignByVectors(const vector<int>& vToRows, const vector<int>& vToCols
- , const GeneralMatrix& b, const vector<int>& vrows, const vector<int>& vcols)
- {AssignByVectors( *this, vToRows, vToCols, b, vrows, vcols);};
- void AssignByVectors( const vector<int>& vToRows, const vector<int>& vToCols
- , const ConstGeneralMatrix& b, const vector<int> &vrows, const vector<int> &vcols)
- {AssignByVectors(*this, vToRows, vToCols, GeneralMatrix(b), vrows, vcols);};
- void AssignByVectors( const GeneralMatrix& b, const vector<int>& vrows, const vector<int>& vcols)
- {AssignByVectors( *this, nullVec, nullVec, b, vrows, vcols);};
- void AssignByVectors( const ConstGeneralMatrix& b, const vector<int> &vrows, const vector<int> &vcols)
- {AssignByVectors(*this, nullVec, nullVec, GeneralMatrix(b), vrows, vcols);};
- void AssignByVectors(const vector<int>& vToRows, const vector<int>& vToCols, const GeneralMatrix& b)
- {AssignByVectors( *this, vToRows, vToCols, b, nullVec, nullVec);};
- void AssignByVectors( const vector<int>& vToRows, const vector<int>& vToCols, const ConstGeneralMatrix& b)
- {AssignByVectors(*this, vToRows, vToCols, GeneralMatrix(b), nullVec, nullVec);};
-
-
-private:
- void copy(const ConstGeneralMatrix& m, int ioff , int joff );
- void copy(const GeneralMatrix& m, int ioff , int joff )
- {copy(ConstGeneralMatrix(m), ioff, joff);}
- void copy(const ConstGeneralMatrix& m);
- void copy(const GeneralMatrix& m);
- void gemm(const char* transa, const ConstGeneralMatrix& a,
- const char* transb, const ConstGeneralMatrix& b,
- double alpha, double beta);
- void gemm(const char* transa, const GeneralMatrix& a,
- const char* transb, const GeneralMatrix& b,
- double alpha, double beta)
- {gemm(transa, ConstGeneralMatrix(a), transb, ConstGeneralMatrix(b),
- alpha, beta);}
-
- /* this = this * op(m) (without whole copy of this) */
- void gemm_partial_right(const char* trans, const ConstGeneralMatrix& m,
- double alpha, double beta);
- void gemm_partial_right(const char* trans, const GeneralMatrix& m,
- double alpha, double beta)
- {gemm_partial_right(trans, ConstGeneralMatrix(m), alpha, beta);}
-
- /* this = op(m) *this (without whole copy of this) */
- void gemm_partial_left(const char* trans, const ConstGeneralMatrix& m,
- double alpha, double beta);
- void gemm_partial_left(const char* trans, const GeneralMatrix& m,
- double alpha, double beta)
- {gemm_partial_left(trans, ConstGeneralMatrix(m), alpha, beta);}
-
- /* number of rows/columns for copy used in gemm_partial_* */
- static int md_length;
-};
-
-
-
-
-
-#endif /* GENERAL_MATRIX_H */
-
-
-// Local Variables:
-// mode:C++
-// End:
diff --git a/mex/sources/kalman/sylv/cc/Makefile b/mex/sources/kalman/sylv/cc/Makefile
deleted file mode 100644
index 97edb6a6b89e6f02e09622234fe4c789549a3e70..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/Makefile
+++ /dev/null
@@ -1,41 +0,0 @@
-# $Header: /var/lib/cvs/dynare_cpp/sylv/cc/Makefile,v 1.4 2005/01/18 21:28:26 kamenik Exp $
-
-# Tag $Name: $
-
-CC_FLAGS := -Wall -Winline -fpic -I../testing -I../cc -DMATLAB \
- $(CC_INCLUDE_PATH) -I$(MATLAB)/extern/include #-pg
-
-LDFLAGS = -Wl,-L$(MATLAB_PATH)/extern/lib/win32/microsoft/ \
- -Wl,-llibmex -Wl,-llibmx -Wl,-llibmwlapack -Wl,-llibdflapack \
- -lg2c -lmingw32 -lstdc++
-
-LD_LIBS=$(LDFLAGS)
-
-ifeq ($(DEBUG),yes)
-# CC_FLAGS := $(CC_FLAGS) -g -DTL_DEBUG=2
- CC_FLAGS := $(CC_FLAGS) -g -DPOSIX_THREADS
-else
- CC_FLAGS := $(CC_FLAGS) -O3
-endif
-
-ifeq ($(OS),Windows_NT)
- CC_FLAGS := -mno-cygwin -mthreads $(CC_FLAGS)
-endif
-
-
-objects := $(patsubst %.cpp,%.o,$(wildcard *.cpp))
-headers := $(wildcard *.h)
-
-all: $(objects)
-
-sylvester.a: $(objects)
- ar cr sylvester.a $(objects)
- ranlib sylvester.a
-
-clear:
- rm -f *.o
- rm -f sylvester.a
-
-%.o : %.cpp $(headers)
- $(CC) $(CC_FLAGS) $(EXTERN_DEFS) -c $*.cpp
-
diff --git a/mex/sources/kalman/sylv/cc/SylvException.cpp b/mex/sources/kalman/sylv/cc/SylvException.cpp
deleted file mode 100644
index 5d5826f8859c46c07be8db8a8e74ec9db75d1d18..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/SylvException.cpp
+++ /dev/null
@@ -1,69 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/SylvException.cpp,v 1.2 2004/10/01 10:30:40 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-#include "SylvException.h"
-
-#include <string.h>
-#include <stdio.h>
-
-SylvException::SylvException(const char* f, int l, const SylvException* s)
-{
- strcpy(file,f);
- line = l;
- source = s;
-}
-
-SylvException::~SylvException()
-{
- if (source != NULL) {
- delete source;
- }
-}
-
-void SylvException::printMessage() const
-{
- char mes[1500];
- mes[0] = '\0';
- printMessage(mes, 1499);
- printf(mes);
-}
-
-int SylvException::printMessage(char* str, int maxlen) const
-{
- int remain = maxlen;
- if (source != NULL) {
- remain = source->printMessage(str, maxlen);
- }
- char aux[100];
- sprintf(aux, "From %s:%d\n", file, line);
- int newremain = remain - strlen(aux);
- if (newremain < 0) {
- aux[remain] = '\0';
- newremain = 0;
- }
- strcat(str, aux);
- return newremain;
-}
-
-SylvExceptionMessage::SylvExceptionMessage(const char* f, int i,
- const char* mes)
- : SylvException(f,i,NULL)
-{
- strcpy(message,mes);
-}
-
-int SylvExceptionMessage::printMessage(char* str, int maxlen) const
-{
- char aux[600];
- sprintf(aux, "At %s:%d:%s\n", file, line, message);
- int newremain = maxlen - strlen(aux);
- if (newremain < 0) {
- aux[maxlen] = '\0';
- newremain = 0;
- }
- strcat(str, aux);
- return newremain;
-}
-
-
diff --git a/mex/sources/kalman/sylv/cc/SylvException.h b/mex/sources/kalman/sylv/cc/SylvException.h
deleted file mode 100644
index f3c22338a673772f3dfb531d6b369a45e8597671..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/SylvException.h
+++ /dev/null
@@ -1,39 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/SylvException.h,v 1.1.1.1 2004/06/04 13:00:44 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-#ifndef SYLV_EXCEPTION_H
-#define SYLV_EXCEPTION_H
-
-#include "SylvMemory.h"
-
-
-class SylvException : public MallocAllocator {
-protected:
- char file[50];
- int line;
- const SylvException* source;
-public:
- SylvException(const char* f, int l, const SylvException* s);
- virtual ~SylvException();
- virtual int printMessage(char* str, int maxlen) const;
- void printMessage() const;
-};
-
-class SylvExceptionMessage : public SylvException {
- char message[500];
-public:
- SylvExceptionMessage(const char* f, int l, const char* mes);
- virtual int printMessage(char* str, int maxlen) const;
-};
-
-// define macros:
-#define SYLV_EXCEPTION(exc) (SylvException(__FILE__, __LINE__, exc))
-#define SYLV_MES_EXCEPTION(mes) (SylvExceptionMessage(__FILE__, __LINE__, mes))
-
-#endif /* SYLV_EXCEPTION_H */
-
-
-// Local Variables:
-// mode:C++
-// End:
diff --git a/mex/sources/kalman/sylv/cc/SylvMemory.h b/mex/sources/kalman/sylv/cc/SylvMemory.h
deleted file mode 100644
index 9f89c06cd7ee4e26ff638a71762c60c46f1339ac..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/SylvMemory.h
+++ /dev/null
@@ -1,63 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/SylvMemory.h,v 1.1.1.1 2004/06/04 13:00:49 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-#ifndef SYLV_MEMORY_H
-#define SYLV_MEMORY_H
-
-//#include "SylvParams.h"
-
-#include <new>
-
-class MallocAllocator {
-#ifdef USE_MEMORY_POOL
-public:
- void* operator new(size_t size);
- void* operator new[](size_t size);
- void operator delete(void* p);
- void operator delete[](void* p);
-#endif
-};
-/*
-#ifdef USE_MEMORY_POOL
-void* operator new(size_t size);
-void* operator new[](size_t size);
-void operator delete(void* p);
-void operator delete[](void* p);
-#endif
-
-class SylvMemoryPool {
- char* base;
- size_t length;
- size_t allocated;
- bool stack_mode;
- SylvMemoryPool(const SylvMemoryPool&);
- const SylvMemoryPool& operator=(const SylvMemoryPool&);
-public:
- SylvMemoryPool();
- ~SylvMemoryPool();
- void init(size_t size);
- void* allocate(size_t size);
- void free(void* p);
- void reset();
- void setStackMode(bool);
-};
-
-class SylvMemoryDriver {
- SylvMemoryDriver(const SylvMemoryDriver&);
- const SylvMemoryDriver& operator=(const SylvMemoryDriver&);
-public:
- SylvMemoryDriver(int num_d, int m, int n, int order);
- SylvMemoryDriver(const SylvParams& pars, int num_d, int m, int n, int order);
- static void setStackMode(bool);
- ~SylvMemoryDriver();
-protected:
- void allocate(int num_d, int m, int n, int order);
-};
-*/
-#endif /* SYLV_MEMORY_H */
-
-
-// Local Variables:
-// mode:C++
-// End:
diff --git a/mex/sources/kalman/sylv/cc/Vector.cpp b/mex/sources/kalman/sylv/cc/Vector.cpp
deleted file mode 100644
index adb6bdbe46309cc9d0c6d8df192dfcb56ae112e0..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/Vector.cpp
+++ /dev/null
@@ -1,370 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/Vector.cpp,v 1.1.1.1 2004/06/04 13:01:13 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-
-#include "Vector.h"
-#include "GeneralMatrix.h"
-#include "SylvException.h"
-#include "cppblas.h"
-
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#include <cmath>
-#include <algorithm>
-#include <limits>
-
-using namespace std;
-
-ZeroPad zero_pad;
-
-Vector::Vector(const ConstVector& v)
-: len(v.length()), s(1), data(new double[len]), destroy(true)
- {
- copy(v.base(), v.skip());
- }
-
-const Vector& Vector::operator=(const Vector& v)
- {
- if (this == &v)
- return *this;
-
- if (v.length() != length()) {
- throw SYLV_MES_EXCEPTION("Attempt to assign vectors with different lengths.");
- }
- if (s == v.s &&
- (data <= v.data && v.data < data+len*s ||
- v.data <= data && data < v.data+v.len*v.s) &&
- (data-v.data) % s == 0) {
- printf("this destroy=%d, v destroy=%d, data-v.data=%d, len=%d\n", destroy, v.destroy, data-v.data, len);
- throw SYLV_MES_EXCEPTION("Attempt to assign overlapping vectors.");
- }
- copy(v.base(), v.skip());
- return *this;
- }
-
-const Vector& Vector::operator=(const ConstVector& v)
- {
- if (v.length() != length()) {
- throw SYLV_MES_EXCEPTION("Attempt to assign vectors with different lengths.");
- }
- if (v.skip() == 1 && skip() == 1 && (
- (base() < v.base() + v.length() && base() >= v.base()) ||
- (base() + length() < v.base() + v.length() &&
- base() + length() > v.base()))) {
- throw SYLV_MES_EXCEPTION("Attempt to assign overlapping vectors.");
- }
- copy(v.base(), v.skip());
- return *this;
- }
-
-void Vector::copy(const double* d, int inc)
- {
- int n = length();
- int incy = skip();
- BLAS_dcopy(&n, d, &inc, base(), &incy);
- }
-
-Vector::Vector(Vector& v, int off, int l)
-: len(l), s(v.skip()), data(v.base()+off*v.skip()), destroy(false)
- {
- if (off < 0 || off + length() > v.length())
- throw SYLV_MES_EXCEPTION("Subvector not contained in supvector.");
- }
-
-Vector::Vector(const Vector& v, int off, int l)
-: len(l), s(1), data(new double[len]), destroy(true)
- {
- if (off < 0 || off + length() > v.length())
- throw SYLV_MES_EXCEPTION("Subvector not contained in supvector.");
- copy(v.base()+off*v.skip(), v.skip());
- }
-
-Vector::Vector(GeneralMatrix& m, int col)
-: len(m.numRows()), s(1), data(&(m.get(0, col))), destroy(false)
- {
- }
-
-Vector::Vector(int row, GeneralMatrix& m)
-: len(m.numCols()), s(m.getLD()), data(&(m.get(row, 0))), destroy(false)
- {
- }
-
-bool Vector::operator==(const Vector& y) const
- {
- return ConstVector(*this) == y;
- }
-
-bool Vector::operator!=(const Vector& y) const
- {
- return ConstVector(*this) != y;
- }
-
-bool Vector::operator<(const Vector& y) const
- {
- return ConstVector(*this) < y;
- }
-
-bool Vector::operator<=(const Vector& y) const
- {
- return ConstVector(*this) <= y;
- }
-
-bool Vector::operator>(const Vector& y) const
- {
- return ConstVector(*this) > y;
- }
-
-bool Vector::operator>=(const Vector& y) const
- {
- return ConstVector(*this) >= y;
- }
-
-void Vector::zeros()
- {
- if (skip() == 1) {
- double* p = base();
- for (int i = 0; i < length()/ZeroPad::length;
- i++, p += ZeroPad::length)
- memcpy(p, zero_pad.getBase(), sizeof(double)*ZeroPad::length);
- for ( ; p < base()+length(); p++)
- *p = 0.0;
- } else {
- for (int i = 0; i < length(); i++)
- operator[](i) = 0.0;
- }
- }
-
-void Vector::nans()
- {
- for (int i = 0; i < length(); i++)
- operator[](i) = std::numeric_limits<double>::quiet_NaN();
- }
-
-void Vector::infs()
- {
- for (int i = 0; i < length(); i++)
- operator[](i) = std::numeric_limits<double>::infinity();
- }
-
-Vector::~Vector()
- {
- if (destroy) {
- delete [] data;
- }
- }
-
-void Vector::rotatePair(double alpha, double beta1, double beta2, int i)
- {
- double tmp = alpha*operator[](i) - beta1*operator[](i+1);
- operator[](i+1) = alpha*operator[](i+1) - beta2*operator[](i);
- operator[](i) = tmp;
- }
-
-void Vector::add(double r, const Vector& v)
- {
- add(r, ConstVector(v));
- }
-
-void Vector::add(double r, const ConstVector& v)
- {
- int n = length();
- int incx = v.skip();
- int incy = skip();
- BLAS_daxpy(&n, &r, v.base(), &incx, base(), &incy);
- }
-
-void Vector::add(const double* z, const Vector& v)
- {
- add(z, ConstVector(v));
- }
-
-void Vector::add(const double* z, const ConstVector& v)
- {
- int n = length()/2;
- int incx = v.skip();
- int incy = skip();
- BLAS_zaxpy(&n, z, v.base(), &incx, base(), &incy);
- }
-
-void Vector::mult(double r)
- {
- int n = length();
- int incx = skip();
- BLAS_dscal(&n, &r, base(), &incx);
- }
-
-void Vector::mult2(double alpha, double beta1, double beta2,
- Vector& x1, Vector& x2,
- const Vector& b1, const Vector& b2)
- {
- x1.zeros();
- x2.zeros();
- mult2a(alpha, beta1, beta2, x1, x2, b1, b2);
- }
-
-void Vector::mult2a(double alpha, double beta1, double beta2,
- Vector& x1, Vector& x2,
- const Vector& b1, const Vector& b2)
- {
- x1.add(alpha, b1);
- x1.add(-beta1, b2);
- x2.add(alpha, b2);
- x2.add(-beta2, b1);
- }
-
-double Vector::getNorm() const
- {
- ConstVector v(*this);
- return v.getNorm();
- }
-
-double Vector::getMax() const
- {
- ConstVector v(*this);
- return v.getMax();
- }
-
-double Vector::getNorm1() const
- {
- ConstVector v(*this);
- return v.getNorm1();
- }
-
-double Vector::dot(const Vector& y) const
- {
- return ConstVector(*this).dot(ConstVector(y));
- }
-
-bool Vector::isFinite() const
- {
- return (ConstVector(*this)).isFinite();
- }
-
-void Vector::print() const
- {
- for (int i = 0; i < length(); i++) {
- printf("%d\t%8.4g\n", i, operator[](i));
-#ifdef MATLAB
-//#include "mex.h"
- mexPrintf("%d\t%8.4g\n", i, operator[](i));
-#endif
- }
- }
-
-
-ConstVector::ConstVector(const Vector& v, int off, int l)
-: BaseConstVector(l, v.skip(), v.base() + v.skip()*off)
- {
- if (off < 0 || off + length() > v.length()) {
- throw SYLV_MES_EXCEPTION("Subvector not contained in supvector.");
- }
- }
-
-ConstVector::ConstVector(const ConstVector& v, int off, int l)
-: BaseConstVector(l, v.skip(), v.base() + v.skip()*off)
- {
- if (off < 0 || off + length() > v.length()) {
- throw SYLV_MES_EXCEPTION("Subvector not contained in supvector.");
- }
- }
-
-ConstVector::ConstVector(const double* d, int skip, int l)
-: BaseConstVector(l, skip, d)
- {
- }
-
-ConstVector::ConstVector(const ConstGeneralMatrix& m, int col)
-: BaseConstVector(m.numRows(), 1, &(m.get(0, col)))
- {
- }
-
-ConstVector::ConstVector(int row, const ConstGeneralMatrix& m)
-: BaseConstVector(m.numCols(), m.getLD(), &(m.get(row, 0)))
- {
- }
-
-bool ConstVector::operator==(const ConstVector& y) const
- {
- if (length() != y.length())
- return false;
- if (length() == 0)
- return true;
- int i = 0;
- while (i < length() && operator[](i) == y[i])
- i++;
- return i == length();
- }
-
-bool ConstVector::operator<(const ConstVector& y) const
- {
- int i = std::min(length(), y.length());
- int ii = 0;
- while (ii < i && operator[](ii) == y[ii])
- ii++;
- if (ii < i)
- return operator[](ii) < y[ii];
- else
- return length() < y.length();
- }
-
-double ConstVector::getNorm() const
- {
- double s = 0;
- for (int i = 0; i < length(); i++) {
- s+=operator[](i)*operator[](i);
- }
- return sqrt(s);
- }
-
-double ConstVector::getMax() const
- {
- double r = 0;
- for (int i = 0; i < length(); i++) {
- if (abs(operator[](i))>r)
- r = abs(operator[](i));
- }
- return r;
- }
-
-double ConstVector::getNorm1() const
- {
- double norm = 0.0;
- for (int i = 0; i < length(); i++) {
- norm += abs(operator[](i));
- }
- return norm;
- }
-
-double ConstVector::dot(const ConstVector& y) const
- {
- if (length() != y.length())
- throw SYLV_MES_EXCEPTION("Vector has different length in ConstVector::dot.");
- int n = length();
- int incx = skip();
- int incy = y.skip();
- return BLAS_ddot(&n, base(), &incx, y.base(), &incy);
- }
-
-bool ConstVector::isFinite() const
- {
- int i = 0;
- while (i < length() && isfinite(operator[](i)))
- i++;
- return i == length();
- }
-
-void ConstVector::print() const
- {
- for (int i = 0; i < length(); i++) {
- printf("%d\t%8.4g\n", i, operator[](i));
- }
- }
-
-
-ZeroPad::ZeroPad()
- {
- for (int i = 0; i < length; i++)
- pad[i] = 0.0;
- }
diff --git a/mex/sources/kalman/sylv/cc/Vector.h b/mex/sources/kalman/sylv/cc/Vector.h
deleted file mode 100644
index cbe9613005a679f0179e2db2702dada6410af493..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/Vector.h
+++ /dev/null
@@ -1,184 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/Vector.h,v 1.1.1.1 2004/06/04 13:01:13 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-#ifndef VECTOR_H
-#define VECTOR_H
-
-/* NOTE! Vector and ConstVector have not common super class in order
- * to avoid running virtual method invokation mechanism. Some
- * members, and methods are thus duplicated */
-
-
-#ifdef MATLAB
-#include "mex.h"
-#define printf mexPrintf
-#endif
-
-#include <stdio.h>
-
-class GeneralMatrix;
-class ConstVector;
-
-class Vector {
-protected:
- int len;
- int s;
- double* data;
- bool destroy;
-public:
- Vector() : len(0), s(1), data(0), destroy(false) {}
- Vector(int l) : len(l), s(1), data(new double[l]), destroy(true) {}
- Vector(Vector& v) : len(v.length()), s(v.skip()), data(v.base()), destroy(false) {}
- Vector(const Vector& v)
- : len(v.length()), s(1), data(new double[len]), destroy(true)
- {copy(v.base(), v.skip());}
- Vector(const ConstVector& v);
- Vector(const double* d, int l)
- : len(l), s(1), data(new double[len]), destroy(true)
- {copy(d, 1);}
- Vector(double* d, int l)
- : len(l), s(1), data(d), destroy(false) {}
- Vector(double* d, int skip, int l)
- : len(l), s(skip), data(d), destroy(false) {}
- Vector(Vector& v, int off, int l);
- Vector(const Vector& v, int off, int l);
- Vector(GeneralMatrix& m, int col);
- Vector(int row, GeneralMatrix& m);
- const Vector& operator=(const Vector& v);
- const Vector& operator=(const ConstVector& v);
- double& operator[](int i)
- {return data[s*i];}
- const double& operator[](int i) const
- {return data[s*i];}
- const double* base() const
- {return data;}
- double* base()
- {return data;}
- int length() const
- {return len;}
- int skip() const
- {return s;}
-
- /** Exact equality. */
- bool operator==(const Vector& y) const;
- bool operator!=(const Vector& y) const;
- /** Lexicographic ordering. */
- bool operator<(const Vector& y) const;
- bool operator<=(const Vector& y) const;
- bool operator>(const Vector& y) const;
- bool operator>=(const Vector& y) const;
-
- virtual ~Vector();
- void zeros();
- void nans();
- void infs();
- bool toBeDestroyed() const {return destroy;}
- void rotatePair(double alpha, double beta1, double beta2, int i);
- void add(double r, const Vector& v);
- void add(double r, const ConstVector& v);
- void add(const double* z, const Vector& v);
- void add(const double* z, const ConstVector& v);
- void mult(double r);
- double getNorm() const;
- double getMax() const;
- double getNorm1() const;
- double dot(const Vector& y) const;
- bool isFinite() const;
- void print() const;
-
- /* multiplies | alpha -beta1| |b1| |x1|
- | |\otimes I .| | = | |
- | -beta2 alpha| |b2| |x2|
- */
- static void mult2(double alpha, double beta1, double beta2,
- Vector& x1, Vector& x2,
- const Vector& b1, const Vector& b2);
- /* same, but adds instead of set */
- static void mult2a(double alpha, double beta1, double beta2,
- Vector& x1, Vector& x2,
- const Vector& b1, const Vector& b2);
- /* same, but subtracts instead of add */
- static void mult2s(double alpha, double beta1, double beta2,
- Vector& x1, Vector& x2,
- const Vector& b1, const Vector& b2)
- {mult2a(-alpha, -beta1, -beta2, x1, x2, b1, b2);}
-private:
- void copy(const double* d, int inc);
- const Vector& operator=(int); // must not be used (not implemented)
- const Vector& operator=(double); // must not be used (not implemented)
-};
-
-
-class BaseConstVector {
-protected:
- int len;
- int s;
- const double* data;
-public:
- BaseConstVector(int l, int si, const double* d) : len(l), s(si), data(d) {}
- BaseConstVector(const BaseConstVector& v) : len(v.len), s(v.s), data(v.data) {}
- const BaseConstVector& operator=(const BaseConstVector& v)
- {len = v.len; s = v.s; data = v.data; return *this;}
- const double& operator[](int i) const
- {return data[s*i];}
- const double* base() const
- {return data;}
- int length() const
- {return len;}
- int skip() const
- {return s;}
-};
-
-class ConstGeneralMatrix;
-
-class ConstVector : public BaseConstVector {
-public:
- ConstVector(const Vector& v) : BaseConstVector(v.length(), v.skip(), v.base()) {}
- ConstVector(const ConstVector& v) : BaseConstVector(v) {}
- ConstVector(const double* d, int l) : BaseConstVector(l, 1, d) {}
- ConstVector(const Vector& v, int off, int l);
- ConstVector(const ConstVector& v, int off, int l);
- ConstVector(const double* d, int skip, int l);
- ConstVector(const ConstGeneralMatrix& m, int col);
- ConstVector(int row, const ConstGeneralMatrix& m);
-
- virtual ~ConstVector() {}
- /** Exact equality. */
- bool operator==(const ConstVector& y) const;
- bool operator!=(const ConstVector& y) const
- {return ! operator==(y);}
- /** Lexicographic ordering. */
- bool operator<(const ConstVector& y) const;
- bool operator<=(const ConstVector& y) const
- {return operator<(y) || operator==(y);}
- bool operator>(const ConstVector& y) const
- {return ! operator<=(y);}
- bool operator>=(const ConstVector& y) const
- {return ! operator<(y);}
-
- double getNorm() const;
- double getMax() const;
- double getNorm1() const;
- double dot(const ConstVector& y) const;
- bool isFinite() const;
- void print() const;
-};
-
-class ZeroPad {
-public:
- //static const int length = 16;
- enum { length = 16};
-private:
- double pad[16];
-public:
- ZeroPad();
- const double* getBase() const {return pad;}
-};
-
-#endif /* VECTOR_H */
-
-
-// Local Variables:
-// mode:C++
-// End:
diff --git a/mex/sources/kalman/sylv/cc/cppblas.h b/mex/sources/kalman/sylv/cc/cppblas.h
deleted file mode 100644
index 65df7aeb4bcad6abf6f504e5267f16ecce062e85..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/cppblas.h
+++ /dev/null
@@ -1,68 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/cppblas.h,v 1.2 2004/11/24 20:42:52 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-#ifndef CPPBLAS_H
-#define CPPBLAS_H
-
-#if defined(MATLAB) && !defined(__linux__)
-#define BLAS_dgemm dgemm
-#define BLAS_dgemv dgemv
-#define BLAS_dtrsv dtrsv
-#define BLAS_dtrmv dtrmv
-#define BLAS_daxpy daxpy
-#define BLAS_dcopy dcopy
-#define BLAS_zaxpy zaxpy
-#define BLAS_dscal dscal
-#define BLAS_dtrsm dtrsm
-#define BLAS_ddot ddot
-#else /* defined(MATLAB) && !defined(__linux__) */
-#define BLAS_dgemm dgemm_
-#define BLAS_dgemv dgemv_
-#define BLAS_dtrsv dtrsv_
-#define BLAS_dtrmv dtrmv_
-#define BLAS_daxpy daxpy_
-#define BLAS_dcopy dcopy_
-#define BLAS_zaxpy zaxpy_
-#define BLAS_dscal dscal_
-#define BLAS_dtrsm dtrsm_
-#define BLAS_ddot ddot_
-#endif /* defined(MATLAB) && !defined(__linux__) */
-
-#define BLCHAR const char*
-#define CONST_BLINT const int*
-#define CONST_BLDOU const double*
-#define BLDOU double*
-
-extern "C" {
- void BLAS_dgemm(BLCHAR transa, BLCHAR transb, CONST_BLINT m, CONST_BLINT n,
- CONST_BLINT k, CONST_BLDOU alpha, CONST_BLDOU a, CONST_BLINT lda,
- CONST_BLDOU b, CONST_BLINT ldb, CONST_BLDOU beta,
- BLDOU c, CONST_BLINT ldc);
- void BLAS_dgemv(BLCHAR trans, CONST_BLINT m, CONST_BLINT n, CONST_BLDOU alpha,
- CONST_BLDOU a, CONST_BLINT lda, CONST_BLDOU x, CONST_BLINT incx,
- CONST_BLDOU beta, BLDOU y, CONST_BLINT incy);
- void BLAS_dtrsv(BLCHAR uplo, BLCHAR trans, BLCHAR diag, CONST_BLINT n,
- CONST_BLDOU a, CONST_BLINT lda, BLDOU x, CONST_BLINT incx);
- void BLAS_dtrmv(BLCHAR uplo, BLCHAR trans, BLCHAR diag, CONST_BLINT n,
- CONST_BLDOU a, CONST_BLINT lda, BLDOU x, CONST_BLINT incx);
- void BLAS_daxpy(CONST_BLINT n, CONST_BLDOU a, CONST_BLDOU x, CONST_BLINT incx,
- BLDOU y, CONST_BLINT incy);
- void BLAS_dcopy(CONST_BLINT n, CONST_BLDOU x, CONST_BLINT incx,
- BLDOU y, CONST_BLINT incy);
- void BLAS_zaxpy(CONST_BLINT n, CONST_BLDOU a, CONST_BLDOU x, CONST_BLINT incx,
- BLDOU y, CONST_BLINT incy);
- void BLAS_dscal(CONST_BLINT n, CONST_BLDOU a, BLDOU x, CONST_BLINT incx);
- void BLAS_dtrsm(BLCHAR side, BLCHAR uplo, BLCHAR transa, BLCHAR diag, CONST_BLINT m,
- CONST_BLINT n, CONST_BLDOU alpha, CONST_BLDOU a, CONST_BLINT lda,
- BLDOU b, CONST_BLINT ldb);
- double BLAS_ddot(CONST_BLINT n, CONST_BLDOU x, CONST_BLINT incx, CONST_BLDOU y,
- CONST_BLINT incy);
-};
-
-
-#endif /* CPPBLAS_H */
-
-// Local Variables:
-// mode:C++
-// End:
diff --git a/mex/sources/kalman/sylv/cc/cpplapack.h b/mex/sources/kalman/sylv/cc/cpplapack.h
deleted file mode 100644
index bee6a4394160e29289cec8f2e3502337d6cae4e6..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/sylv/cc/cpplapack.h
+++ /dev/null
@@ -1,82 +0,0 @@
-/* $Header: /var/lib/cvs/dynare_cpp/sylv/cc/cpplapack.h,v 1.3 2004/11/24 20:43:10 kamenik Exp $ */
-
-/* Tag $Name: $ */
-
-#ifndef CPPLAPACK_H
-#define CPPLAPACK_H
-
-#if defined(MATLAB) && !defined(__linux__)
-#define LAPACK_dgetrs dgetrs
-#define LAPACK_dgetrf dgetrf
-#define LAPACK_dgees dgees
-#define LAPACK_dgecon dgecon
-#define LAPACK_dtrexc dtrexc
-#define LAPACK_dtrsyl dtrsyl
-#define LAPACK_dpotrf dpotrf
-#define LAPACK_dgges dgges
-#define LAPACK_dsyev dsyev
-#define LAPACK_dsyevr dsyevr
-#else /* MATLAB */
-#define LAPACK_dgetrs dgetrs_
-#define LAPACK_dgetrf dgetrf_
-#define LAPACK_dgees dgees_
-#define LAPACK_dgecon dgecon_
-#define LAPACK_dtrexc dtrexc_
-#define LAPACK_dtrsyl dtrsyl_
-#define LAPACK_dpotrf dpotrf_
-#define LAPACK_dgges dgges_
-#define LAPACK_dsyev dsyev_
-#define LAPACK_dsyevr dsyevr_
-#endif /* MATLAB */
-
-#define LACHAR const char*
-#define CONST_LAINT const int*
-#define LAINT int*
-#define CONST_LADOU const double*
-#define LADOU double*
-typedef int (*DGGESCRIT)(const double*, const double*, const double*);
-
-extern "C" {
- void LAPACK_dgetrs(LACHAR trans, CONST_LAINT n, CONST_LAINT nrhs,
- CONST_LADOU a, CONST_LAINT lda, CONST_LAINT ipiv,
- LADOU b, CONST_LAINT ldb, LAINT info);
- void LAPACK_dgetrf(CONST_LAINT m, CONST_LAINT n, LADOU a,
- CONST_LAINT lda, LAINT ipiv, LAINT info);
- void LAPACK_dgees(LACHAR jobvs, LACHAR sort, const void* select,
- CONST_LAINT n, LADOU a, CONST_LAINT lda, LAINT sdim,
- LADOU wr, LADOU wi, LADOU vs, CONST_LAINT ldvs,
- LADOU work, CONST_LAINT lwork, const void* bwork, LAINT info);
- void LAPACK_dgecon(LACHAR norm, CONST_LAINT n, CONST_LADOU a, CONST_LAINT lda,
- CONST_LADOU anorm, LADOU rnorm, LADOU work, LAINT iwork,
- LAINT info);
- void LAPACK_dtrexc(LACHAR compq, CONST_LAINT n, LADOU t, CONST_LAINT ldt,
- LADOU q, CONST_LAINT ldq, LAINT ifst, LAINT ilst, LADOU work,
- LAINT info);
- void LAPACK_dtrsyl(LACHAR trana, LACHAR tranb, CONST_LAINT isgn, CONST_LAINT m,
- CONST_LAINT n, CONST_LADOU a, CONST_LAINT lda, CONST_LADOU b,
- CONST_LAINT ldb, LADOU c, CONST_LAINT ldc, LADOU scale,
- LAINT info);
- void LAPACK_dpotrf(LACHAR uplo, CONST_LAINT n, LADOU a, CONST_LAINT lda,
- LAINT info);
- void LAPACK_dgges(LACHAR jobvsl, LACHAR jobvsr, LACHAR sort, DGGESCRIT delztg,
- CONST_LAINT n, LADOU a, CONST_LAINT lda, LADOU b, CONST_LAINT ldb,
- LAINT sdim, LADOU alphar, LADOU alphai, LADOU beta,
- LADOU vsl, CONST_LAINT ldvsl, LADOU vsr, CONST_LAINT ldvsr,
- LADOU work, CONST_LAINT lwork, LAINT bwork, LAINT info);
- void LAPACK_dsyev(LACHAR jobz, LACHAR uplo, CONST_LAINT n, LADOU a, CONST_LAINT lda,
- LADOU w, LADOU work, CONST_LAINT lwork, LAINT info);
- void LAPACK_dsyevr(LACHAR jobz, LACHAR range, LACHAR uplo, CONST_LAINT n, LADOU a,
- CONST_LAINT lda, LADOU lv, LADOU vu, CONST_LAINT il, CONST_LAINT iu,
- CONST_LADOU abstol, LAINT m, LADOU w, LADOU z, CONST_LAINT ldz,
- LAINT isuppz, LADOU work, CONST_LAINT lwork, LAINT iwork, CONST_LAINT liwork,
- LAINT info);
-};
-
-
-#endif /* CPPLAPACK_H */
-
-
-// Local Variables:
-// mode:C++
-// End:
-
diff --git a/mex/sources/kalman/testing/Makefile b/mex/sources/kalman/testing/Makefile
deleted file mode 100644
index 60c4fc16b71901aadf116d0a776eb75324bfdf91..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/Makefile
+++ /dev/null
@@ -1,65 +0,0 @@
-# $Id: Makefile 534 2005-11-30 13:58:11Z kamenik $
-# Copyright 2005, Ondra Kamenik
-
-#LD_LIBS := -llapack -lcblas -lf77blas -latlas -lg2c
-#CC_FLAGS := -Wall -I../cc -I../../sylv/cc
-
-CC_FLAGS := -Wall -I../cc -I../sylv/cc
-
-
-DEBUG = yes
-MATLAB = 1
-
-# Added by GP
-# LDFLAGS := -llapack -lcblas -lf77blas -latlas -lg2c -lstdc++ -lmingw32
- LDFLAGS := -Wl,--library-path $(LD_LIBRARY_PATH) \
- -Wl,-L'f:/MinGW/lib' \
- -Wl,-L"c:/Program Files"/MATLAB_SV71/extern/lib/win32/microsoft/ \
- -Wl,-llibmex -Wl,-llibmx -Wl,-llibmwlapack -Wl,-llibdflapack \
- -lg2c -lmingw32 -lstdc++ $(LDFLAGS)
-
-# -Wl,-L'f:/CygWin/usr/local/atlas/lib' \
-# -Wl,-L'f:/CygWin/lib' \
-# $(LDFLAGS)
-
- LD_LIBS :=$(LDFLAGS)
-# end add
-
-ifeq ($(DEBUG),yes)
- CC_FLAGS := $(CC_FLAGS) -g
-else
- CC_FLAGS := $(CC_FLAGS) -O2
-endif
-
-matrix_interface := GeneralMatrix Vector SylvException
-matobjs := $(patsubst %, ../sylv/cc/%.o, $(matrix_interface))
-mathsource := $(patsubst %, ../sylv/cc/%.h, $(matrix_interface))
-#cwebsource := $(wildcard ../cc/*.cweb)
-cppsource := $(wildcard ../cc/*.cpp)
-#cppsource := $(patsubst %.cweb,%.cpp,$(cwebsource))
-mainobjects := $(patsubst %.cpp,%.o,$(cppsource))
-#objects := $(patsubst %.cpp,%.o, *.cpp)
-objects := $(wildcard *.o)
-#hwebsource := $(wildcard ../cc/*.hweb)
-hsource := $(wildcard ../cc/*.h)
-#hsource := $(patsubst %.hweb,%.h,$(hwebsource))
-
-../cc/dummy.ch:
- make -C ../cc dummy.ch
-
-../cc/%.o: ../cc/%.cpp $(hsource) $(mathsource)
- make -C ../cc $*.o
-
-%.o: %.cpp $(hsource) ascii_matrix.h
- c++ $(CC_FLAGS) -c $*.cpp
-
-#tests: $(hmainsource) $(cppmainsource) $(hsource) $(cppsource) objects) \
-
-tests: $(hsource) $(cppsource) $(mainobjects) \
- tests.o ascii_matrix.o
- c++ $(CC_FLAGS) $(mainobjects) $(matobjs) ascii_matrix.o tests.o -o tests $(LD_LIBS)
-
-clear:
- make -C ../cc clear
- rm -f *.o
- rm -f tests
diff --git a/mex/sources/kalman/testing/ascii_matrix.cpp b/mex/sources/kalman/testing/ascii_matrix.cpp
deleted file mode 100644
index 97749de7bd84bf2ead24dfde00f9fde4e62a656a..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/ascii_matrix.cpp
+++ /dev/null
@@ -1,56 +0,0 @@
-// $Id: ascii_matrix.cpp 534 2005-11-30 13:58:11Z kamenik $
-// Copyright 2005, Ondra Kamenik
-
-#include "ascii_matrix.h"
-
-#include <stdio.h>
-#include <string.h>
-
-#include <fstream>
-#include <string>
-
-// if the file doesn't exist, the number array is empty
-void AsciiNumberArray::parse(const char* fname)
-{
- rows = 0;
- cols = 0;
-
- std::ifstream file(fname);
- std::string line;
-
- while (getline(file, line)) {
- rows++;
- int icols = 0;
- const char delims[] = " \r\n\t";
- char* lineptr = strdup(line.c_str());
- char* tok = strtok(lineptr, delims);
- while (tok) {
- icols++;
- double item;
- if (1 != sscanf(tok, "%lf", &item)) {
- fprintf(stderr, "Couldn't parse a token %s as double.\n", tok);
- exit(1);
- }
- data.push_back(item);
- tok = strtok(NULL, delims);
- }
- free(lineptr);
- if (cols) {
- if (cols != icols) {
- fprintf(stderr, "Asserted a different number of columns.\n");
- exit(1);
- }
- } else {
- cols = icols;
- }
- }
-}
-
-
-AsciiMatrix::AsciiMatrix(const AsciiNumberArray& na)
- : GeneralMatrix(na.rows, na.cols)
-{
- for (int i = 0; i < numRows(); i++)
- for (int j = 0; j < numCols(); j++)
- get(i, j) = na.data[i*numCols()+j];
-}
diff --git a/mex/sources/kalman/testing/ascii_matrix.h b/mex/sources/kalman/testing/ascii_matrix.h
deleted file mode 100644
index b654b9655ea0108127452eca0a7a9d475903b930..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/ascii_matrix.h
+++ /dev/null
@@ -1,24 +0,0 @@
-// $Id: ascii_matrix.h 534 2005-11-30 13:58:11Z kamenik $
-// Copyright 2005, Ondra Kamenik
-
-#include "GeneralMatrix.h"
-
-#include <vector>
-#include <string>
-
-struct AsciiNumberArray {
- int rows;
- int cols;
- std::vector<double> data;
- AsciiNumberArray(const char* fname)
- {parse(fname);}
- AsciiNumberArray(std::string fname)
- {parse(fname.c_str());}
-protected:
- void parse(const char* fname);
-};
-
-class AsciiMatrix : public GeneralMatrix {
-public:
- AsciiMatrix(const AsciiNumberArray& na);
-};
diff --git a/mex/sources/kalman/testing/dynare_filter.m b/mex/sources/kalman/testing/dynare_filter.m
deleted file mode 100644
index 4fa46853c6c584007f3e177191915e93e3876b89..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/dynare_filter.m
+++ /dev/null
@@ -1,33 +0,0 @@
-%
-% loglik = dynare_filter(Z,H,T,R,Q,Y,Pstar,Pinf)
-%
-% This is just an interface to DiffuseLikelihoodH1 of Dynare. It
-% takes state space in the form
-% y_t = Z*alpha_t + epsilon_t
-% alpha_{t+1} = T*alpha_t + R*eta_t
-% where epsilon covariance is H, eta covariance is Q
-%
-% It returns log likelihood.
-%
-% Copyright 2005, Ondra Kamenik
-
-% $Id: dynare_filter.m 534 2005-11-30 13:58:11Z kamenik $
-
-function lik = dynare_filter(Z,H,T,R,Q,Y,Pstar,Pinf)
- global bayestopt_ options_
-
- pp = size(Z,1);
- mm = size(T,1);
- rr = size(R,2);
- dT = [zeros(pp,pp) Z*T; zeros(mm,pp) T];
- dR = [eye(pp) Z*R; zeros(mm,pp) R];
- dQ = [zeros(pp,pp) zeros(pp,rr); zeros(rr,pp) Q];
- dPinf = [zeros(pp,pp) zeros(pp,mm); zeros(mm,pp) Pinf];
- dPstar = [Z*Pstar*Z' Z*Pstar; Pstar*Z' Pstar];
-
- bayestopt_.mf = [1:pp];
- options_.kalman_tol = 1e-10;
-
- lik = DiffuseLikelihoodH1(dT,dR,dQ,H,dPinf,dPstar,Y,zeros(pp,size(Y,2)),1);
-
-
diff --git a/mex/sources/kalman/testing/dynare_smoother.m b/mex/sources/kalman/testing/dynare_smoother.m
deleted file mode 100644
index 29c801c62f9365eb4198a3b49be0583aa5df9938..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/dynare_smoother.m
+++ /dev/null
@@ -1,37 +0,0 @@
-%
-% [alpha,epsilon,eta] = dynare_smoother(Z,H,T,R,Q,Y,Pstar,Pinf)
-%
-% This is just an interface to DiffuseKalmanSmootherH1 of Dynare. It
-% takes state space in the form
-% y_t = Z*alpha_t + epsilon_t
-% alpha_{t+1} = T*alpha_t + R*eta_t
-% where epsilon covariance is H, eta covariance is Q
-%
-% It returns smoothed alpha, epsilon and eta.
-%
-% Copyright 2005, Ondra Kamenik
-
-% $Id: dynare_smoother.m 534 2005-11-30 13:58:11Z kamenik $
-
-function [alpha,epsilon,eta] = dynare_smoother(Z,H,T,R,Q,Y,Pstar,Pinf)
- global options_
-
- pp = size(Z,1);
- mm = size(T,1);
- rr = size(R,2);
- dT = [zeros(pp,pp) Z*T; zeros(mm,pp) T];
- dR = [eye(pp) Z*R; zeros(mm,pp) R];
- dQ = [zeros(pp,pp) zeros(pp,rr); zeros(rr,pp) Q];
- dPinf = [Z*Pinf*Z' Z*Pinf; Pinf*Z' Pinf];
- dPstar = [Z*Pstar*Z' Z*Pstar; Pstar*Z' Pstar];
-
- mf = [1:pp];
- options_.kalman_tol = 1e-10;
- options_.nk = 0;
-% if you want DiffuseKalmanSmootherH3, uncomment the following and set
-% diffuse_d (possibly empty [])
-% options_.diffuse_d = [7];
-
- [alpha,epsilon,eta] = DiffuseKalmanSmootherH1(dT,dR,dQ,H,dPinf,dPstar,Y,zeros(pp,size(Y,2)),pp,mm+pp,size(Y,2),mf);
- alpha = alpha(pp+1:end,:);
- eta = eta(pp+1:end,:);
diff --git a/mex/sources/kalman/testing/kalmandll_test.m b/mex/sources/kalman/testing/kalmandll_test.m
deleted file mode 100644
index 87ad5aa04edabe6a6ea03fb8a0e9e8f7c21febdf..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/kalmandll_test.m
+++ /dev/null
@@ -1,20 +0,0 @@
-function [LIKDLL loglik]=kalmandll_test(T,mf,R,Q,H,Pstar,Pinf,data,start)
-
-if isempty(H)
- H=zeros(size(data,1), size(data,1))
-elseif H==0
- H=zeros(size(data,1), size(data,1))
-end
-Z=zeros(size(data,1), size(T,2))
-for i = 1:size(data,1)
-Z(i,mf(i))=1
-end
-LIKDLL= kalman_filter_dll4(T,Z,R,Q,H,Pstar,data,start)
-%Y=data;
-if isempty(Pinf)
- Pinf=zeros(size(T));
-elseif Pinf==0
- Pinf=zeros(size(T));
-end
-% test DiffuseLikelihoodH1
-loglik = dynare_filter(Z,H,T,R,Q,data,Pstar,Pinf)
\ No newline at end of file
diff --git a/mex/sources/kalman/testing/test_data.tgz b/mex/sources/kalman/testing/test_data.tgz
deleted file mode 100644
index 6decfec0b491985196e184b8dd855fd661c753bf..0000000000000000000000000000000000000000
Binary files a/mex/sources/kalman/testing/test_data.tgz and /dev/null differ
diff --git a/mex/sources/kalman/testing/tests.asv b/mex/sources/kalman/testing/tests.asv
deleted file mode 100644
index ebcc6f71bd71862fc1926955383019a3f11c3171..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/tests.asv
+++ /dev/null
@@ -1,311 +0,0 @@
-// $Id: tests.cpp 534 2005-11-30 13:58:11Z kamenik $
-// Copyright 2005, Ondra Kamenik
-
-#include "../cc/kalman.h"
-#include "../cc/ts_exception.h"
-#include "ascii_matrix.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include <sys/time.h>
-#include <math.h>
-
-
-// gettimeofday for MinGW
-#ifdef __MINGW32__
-#define _W32_FT_OFFSET (116444736000000000LL)
-
-typedef struct _filetime {
- unsigned long dwLowDateTime;
- unsigned long dwHighDateTime;
-} filetime;
-
-extern "C" {
- void __stdcall GetSystemTimeAsFileTime(filetime*);
-};
-
-typedef union {
- long long ns100; // time since 1 Jan 1601 in 100ns units
- filetime ft;
-} w32_ftv;
-
-void D_gettimeofday(struct timeval* p, struct timezone* tz)
-{
- w32_ftv _now;
- GetSystemTimeAsFileTime( &(_now.ft) );
- p->tv_usec=(long)((_now.ns100 / 10LL) % 1000000LL );
- p->tv_sec= (long)((_now.ns100-_W32_FT_OFFSET)/10000000LL);
- return;
-}
-
-#else
-#define D_gettimeofday gettimeofday
-#endif // gettimeofday for MinGW
-
-
-struct AsciiKalmanTask {
- AsciiMatrix Z;
- AsciiMatrix H;
- AsciiMatrix T;
- AsciiMatrix R;
- AsciiMatrix Q;
- AsciiMatrix Pstar;
- AsciiMatrix Pinf;
- AsciiMatrix a;
- AsciiMatrix Y;
- AsciiKalmanTask(const char* prefix)
- : Z(std::string(prefix) + "_Z.dat"),
- H(std::string(prefix) + "_H.dat"),
- T(std::string(prefix) + "_T.dat"),
- R(std::string(prefix) + "_R.dat"),
- Q(std::string(prefix) + "_Q.dat"),
- Pstar(std::string(prefix) + "_Pstar.dat"),
- Pinf(std::string(prefix) + "_Pinf.dat"),
- a(std::string(prefix) + "_a.dat"),
- Y(std::string(prefix) + "_Y.dat")
- {}
-};
-
-// WallTimer class. Constructor saves the wall time, destructor
-// cancels the current time from the saved, and prints the message
-// with time information
-class WallTimer {
- char mes[100];
- struct timeval start;
- bool new_line;
-public:
- WallTimer(const char* m, bool nl = true)
- {strcpy(mes, m);new_line = nl; D_gettimeofday(&start, NULL);}
- ~WallTimer()
- {
- struct timeval end;
- D_gettimeofday(&end, NULL);
- printf("%s%8.4g", mes,
- end.tv_sec-start.tv_sec + (end.tv_usec-start.tv_usec)*1.0e-6);
- if (new_line)
- printf("\n");
- }
-};
-
-/****************************************************/
-/* declaration of TestRunnable class */
-/****************************************************/
-class TestRunnable {
- char name[100];
-public:
- TestRunnable(const char* n)
- {strncpy(name, n, 100);}
- bool test() const;
- virtual bool run() const =0;
- const char* getName() const
- {return name;}
-protected:
- static bool filter_and_smoother(const char* prefix, bool diffuse_flag);
-};
-
-bool TestRunnable::test() const
-{
- printf("Running test <%s>\n",name);
- bool passed;
- {
- WallTimer tim("Wall clock time ", false);
- passed = run();
- }
- if (passed) {
- printf("............................ passed\n\n");
- return passed;
- } else {
- printf("............................ FAILED\n\n");
- return passed;
- }
-}
-
-/****************************************************/
-/* definition of TestRunnable static methods */
-/****************************************************/
-bool TestRunnable::filter_and_smoother(const char* prefix, bool diffuse_flag)
-{
- AsciiKalmanTask akt(prefix);
- StateInit* init;
- if (diffuse_flag)
- init = new StateInit(akt.Pstar, akt.Pinf, akt.a.getData());
- else
- init = new StateInit(akt.Pstar, akt.a.getData());
-
- KalmanTask kt(akt.Y, akt.Z, akt.H, akt.T, akt.R, akt.Q, *init);
-
- // multivariate
- int per;
- int d;
- double ll;
- GeneralMatrix alpha(akt.T.numRows(), akt.Y.numCols());
- GeneralMatrix eta(akt.R.numCols(), akt.Y.numCols());
- GeneralMatrix V(akt.T.numRows(), akt.T.numRows()*akt.Y.numCols());
- SmootherResults sres(akt.Y.numCols());
- {
- WallTimer tim("\tMultivariate time ", true);
- ll = kt.filter_and_smooth(sres, per, d);
- printf("\t\tll=%f per=%d d=%d\n", ll, per, d);
- if (per == akt.Y.numCols()) {
- sres.exportAlpha(alpha);
- sres.exportEta(eta);
- sres.exportV(V);
- } else {
- printf("\t\tNot finished.\n");
- }
- }
-
- // univariate
- KalmanUniTask kut(kt);
- int per1;
- int d1;
- double ll1;
- GeneralMatrix alpha1(akt.T.numRows(), akt.Y.numCols());
- GeneralMatrix eta1(akt.R.numCols(), akt.Y.numCols());
- GeneralMatrix V1(akt.T.numRows(), akt.T.numRows()*akt.Y.numCols());
- SmootherResults sres1(akt.Y.numCols()*akt.Y.numRows());
- {
- WallTimer tim("\tUnivariate time ", true);
- int dd;
- ll1 = kut.filter_and_smooth(sres1, per1, dd);
- per1 /= akt.Y.numRows();
- d1 = dd/akt.Y.numRows();
- printf("\t\tll=%f per=%d d=%d(%d)\n", ll1, per1, d1, dd);
- if (per1 == akt.Y.numCols()) {
- SmootherResults sres_uni(akt.Y.numCols());
- sres_uni.import(sres1, akt.Y.numRows());
- sres_uni.exportAlpha(alpha1);
- sres_uni.exportEta(eta1);
- sres_uni.exportV(V1);
- } else {
- printf("\t\tNot finished.\n");
- }
- }
-
- // compare
- if (per == per1 && per == akt.Y.numCols()) {
- WallTimer tim("\tComparison time ", true);
- alpha.add(-1.0, alpha1);
- eta.add(-1.0, eta1);
- V.add(-1.0, V1);
- int maxd = std::max(d,d1);
- for (int t = 1; t <= maxd; t++) {
- Vector alphat(alpha, t-1);
- printf("\t\tt=%d alpha error %10.6g\n",t,alphat.getMax());
- Vector etat(eta, t-1);
- printf("\t\tt=%d eta error %10.6g\n",t,etat.getMax());
- GeneralMatrix Vt(V, 0, (t-1)*akt.T.numRows(), akt.T.numRows(), akt.T.numRows());
- printf("\t\tt=%d V error %10.6g\n",t,V.getData().getMax());
- }
- GeneralMatrix alpha_rest(alpha, 0, maxd, akt.T.numRows(), alpha.numCols()-maxd);
- printf("\t\tt=%d.. alpha error %10.6g\n",maxd+1,alpha_rest.getData().getMax());
- GeneralMatrix eta_rest(eta, 0, maxd, akt.R.numCols(), eta.numCols()-maxd);
- printf("\t\tt=%d.. eta error %10.6g\n",maxd+1,eta_rest.getData().getMax());
- GeneralMatrix V_rest(V, 0, maxd*akt.T.numRows(), akt.T.numRows(),
- V.numCols()-maxd*akt.T.numRows());
- printf("\t\tt=%d.. V error %10.6g\n",maxd+1,V_rest.getData().getMax());
- }
-
- delete init;
-
- return true;
-}
-
-
-/****************************************************/
-/* definition of TestRunnable subclasses */
-/****************************************************/
-class SmallNonDiffuse : public TestRunnable {
-public:
- SmallNonDiffuse()
- : TestRunnable("Non-diffuse small (p=2,m=3,r=4)") {}
-
- bool run() const
- {
- filter_and_smoother("small2x3x4", false);
- return true;
- }
-};
-
-class SmallDiffuse : public TestRunnable {
-public:
- SmallDiffuse()
- : TestRunnable("Diffuse small (p=2,m=3,r=4)") {}
-
- bool run() const
- {
- return filter_and_smoother("small2x3x4", true);
- }
-};
-
-class MiddleNonDiffuse : public TestRunnable {
-public:
- MiddleNonDiffuse()
- : TestRunnable("Non-diffuse middle (p=10,m=15,r=12)") {}
-
- bool run() const
- {
- return filter_and_smoother("10x15x12", false);
- }
-};
-
-class MiddleDiffuse : public TestRunnable {
-public:
- MiddleDiffuse()
- : TestRunnable("Diffuse middle (p=10,m=15,r=12)") {}
-
- bool run() const
- {
- return filter_and_smoother("10x15x12", true);
- }
-};
-
-class SOEDiffuse : public TestRunnable {
-public:
- SOEDiffuse()
- : TestRunnable("Diffuse soe (p=8,m=25,r=15)") {}
-
- bool run() const
- {
- return filter_and_smoother("soe8x25x15", true);
- }
-};
-
-int main()
-{
- TestRunnable* all_tests[50];
- // fill in vector of all tests
- int num_tests = 0;
- all_tests[num_tests++] = new SmallNonDiffuse();
- all_tests[num_tests++] = new SmallDiffuse();
- all_tests[num_tests++] = new MiddleNonDiffuse();
- all_tests[num_tests++] = new MiddleDiffuse();
- all_tests[num_tests++] = new SOEDiffuse();
-
- // launch the tests
- int success = 0;
- for (int i = 0; i < num_tests; i++) {
- try {
- if (all_tests[i]->test())
- success++;
- } catch (const TSException& e) {
- printf("Caugth TS exception in <%s>:\n", all_tests[i]->getName());
- e.print();
- } catch (SylvException& e) {
- printf("Caught Sylv exception in <%s>:\n", all_tests[i]->getName());
- e.printMessage();
- }
- }
-
- printf("There were %d tests that failed out of %d tests run.\n",
- num_tests - success, num_tests);
-
- // destroy
- for (int i = 0; i < num_tests; i++) {
- delete all_tests[i];
- }
-
- return 0;
-}
diff --git a/mex/sources/kalman/testing/tests.cpp b/mex/sources/kalman/testing/tests.cpp
deleted file mode 100644
index c73f0c4ec9fe88e7a69fa7d7c779187982f9943d..0000000000000000000000000000000000000000
--- a/mex/sources/kalman/testing/tests.cpp
+++ /dev/null
@@ -1,311 +0,0 @@
-// $Id: tests.cpp 534 2005-11-30 13:58:11Z kamenik $
-// Copyright 2005, Ondra Kamenik
-
-#include "../cc/kalman.h"
-#include "../cc/ts_exception.h"
-#include "ascii_matrix.h"
-
-#include "GeneralMatrix.h"
-#include "Vector.h"
-#include "SylvException.h"
-
-#include <sys/time.h>
-#include <math.h>
-
-
-// gettimeofday for MinGW
-#ifdef __MINGW32__
-#define _W32_FT_OFFSET (116444736000000000LL)
-
-typedef struct _filetime {
- unsigned long dwLowDateTime;
- unsigned long dwHighDateTime;
-} filetime;
-
-extern "C" {
- void __stdcall GetSystemTimeAsFileTime(filetime*);
-};
-
-typedef union {
- long long ns100; // time since 1 Jan 1601 in 100ns units
- filetime ft;
-} w32_ftv;
-
-void D_gettimeofday(struct timeval* p, struct timezone* tz)
-{
- w32_ftv _now;
- GetSystemTimeAsFileTime( &(_now.ft) );
- p->tv_usec=(long)((_now.ns100 / 10LL) % 1000000LL );
- p->tv_sec= (long)((_now.ns100-_W32_FT_OFFSET)/10000000LL);
- return;
-}
-
-#else
-#define D_gettimeofday gettimeofday
-#endif // gettimeofday for MinGW
-
-
-struct AsciiKalmanTask {
- AsciiMatrix Z;
- AsciiMatrix H;
- AsciiMatrix T;
- AsciiMatrix R;
- AsciiMatrix Q;
- AsciiMatrix Pstar;
- AsciiMatrix Pinf;
- AsciiMatrix a;
- AsciiMatrix Y;
- AsciiKalmanTask(const char* prefix)
- : Z(std::string(prefix) + "_Z.dat"),
- H(std::string(prefix) + "_H.dat"),
- T(std::string(prefix) + "_T.dat"),
- R(std::string(prefix) + "_R.dat"),
- Q(std::string(prefix) + "_Q.dat"),
- Pstar(std::string(prefix) + "_Pstar.dat"),
- Pinf(std::string(prefix) + "_Pinf.dat"),
- a(std::string(prefix) + "_a.dat"),
- Y(std::string(prefix) + "_Y.dat")
- {}
-};
-
-// WallTimer class. Constructor saves the wall time, destructor
-// cancels the current time from the saved, and prints the message
-// with time information
-class WallTimer {
- char mes[100];
- struct timeval start;
- bool new_line;
-public:
- WallTimer(const char* m, bool nl = true)
- {strcpy(mes, m);new_line = nl; D_gettimeofday(&start, NULL);}
- ~WallTimer()
- {
- struct timeval end;
- D_gettimeofday(&end, NULL);
- printf("%s%8.4g", mes,
- end.tv_sec-start.tv_sec + (end.tv_usec-start.tv_usec)*1.0e-6);
- if (new_line)
- printf("\n");
- }
-};
-
-/****************************************************/
-/* declaration of TestRunnable class */
-/****************************************************/
-class TestRunnable {
- char name[100];
-public:
- TestRunnable(const char* n)
- {strncpy(name, n, 100);}
- bool test() const;
- virtual bool run() const =0;
- const char* getName() const
- {return name;}
-protected:
- static bool filter_and_smoother(const char* prefix, bool diffuse_flag);
-};
-
-bool TestRunnable::test() const
-{
- printf("Running test <%s>\n",name);
- bool passed;
- {
- WallTimer tim("Wall clock time ", false);
- passed = run();
- }
- if (passed) {
- printf("............................ passed\n\n");
- return passed;
- } else {
- printf("............................ FAILED\n\n");
- return passed;
- }
-}
-
-/****************************************************/
-/* definition of TestRunnable static methods */
-/****************************************************/
-bool TestRunnable::filter_and_smoother(const char* prefix, bool diffuse_flag)
-{
- AsciiKalmanTask akt(prefix);
- StateInit* init;
- if (diffuse_flag)
- init = new StateInit(akt.Pstar, akt.Pinf, akt.a.getData());
- else
- init = new StateInit(akt.Pstar, akt.a.getData());
-
- KalmanTask kt(akt.Y, akt.Z, akt.H, akt.T, akt.R, akt.Q, *init);
-
- // multivariate
- int per;
- int d;
- double ll;
- GeneralMatrix alpha(akt.T.numRows(), akt.Y.numCols());
- GeneralMatrix eta(akt.R.numCols(), akt.Y.numCols());
- GeneralMatrix V(akt.T.numRows(), akt.T.numRows()*akt.Y.numCols());
- SmootherResults sres(akt.Y.numCols());
- {
- WallTimer tim("\tMultivariate time ", true);
- ll = kt.filter_and_smooth(sres, per, d);
- printf("\t\tll=%f per=%d d=%d\n", ll, per, d);
- if (per == akt.Y.numCols()) {
- sres.exportAlpha(alpha);
- sres.exportEta(eta);
- sres.exportV(V);
- } else {
- printf("\t\tNot finished.\n");
- }
- }
-
- // univariate
- KalmanUniTask kut(kt);
- int per1;
- int d1;
- double ll1;
- GeneralMatrix alpha1(akt.T.numRows(), akt.Y.numCols());
- GeneralMatrix eta1(akt.R.numCols(), akt.Y.numCols());
- GeneralMatrix V1(akt.T.numRows(), akt.T.numRows()*akt.Y.numCols());
- SmootherResults sres1(akt.Y.numCols()*akt.Y.numRows());
- {
- WallTimer tim("\tUnivariate time ", true);
- int dd;
- ll1 = kut.filter_and_smooth(sres1, per1, dd);
- per1 /= akt.Y.numRows();
- d1 = dd/akt.Y.numRows();
- printf("\t\tll=%f per=%d d=%d(%d)\n", ll1, per1, d1, dd);
- if (per1 == akt.Y.numCols()) {
- SmootherResults sres_uni(akt.Y.numCols());
- sres_uni.import(sres1, akt.Y.numRows());
- sres_uni.exportAlpha(alpha1);
- sres_uni.exportEta(eta1);
- sres_uni.exportV(V1);
- } else {
- printf("\t\tNot finished.\n");
- }
- }
-
- // compare
- if (per == per1 && per == akt.Y.numCols()) {
- WallTimer tim("\tComparison time ", true);
- alpha.add(-1.0, alpha1);
- eta.add(-1.0, eta1);
- V.add(-1.0, V1);
- int maxd = std::max(d,d1);
- for (int t = 1; t <= maxd; t++) {
- Vector alphat(alpha, t-1);
- printf("\t\tt=%d alpha error %10.6g\n",t,alphat.getMax());
- Vector etat(eta, t-1);
- printf("\t\tt=%d eta error %10.6g\n",t,etat.getMax());
- GeneralMatrix Vt(V, 0, (t-1)*akt.T.numRows(), akt.T.numRows(), akt.T.numRows());
- printf("\t\tt=%d V error %10.6g\n",t,V.getData().getMax());
- }
- GeneralMatrix alpha_rest(alpha, 0, maxd, akt.T.numRows(), alpha.numCols()-maxd);
- printf("\t\tt=%d.. alpha error %10.6g\n",maxd+1,alpha_rest.getData().getMax());
- GeneralMatrix eta_rest(eta, 0, maxd, akt.R.numCols(), eta.numCols()-maxd);
- printf("\t\tt=%d.. eta error %10.6g\n",maxd+1,eta_rest.getData().getMax());
- GeneralMatrix V_rest(V, 0, maxd*akt.T.numRows(), akt.T.numRows(),
- V.numCols()-maxd*akt.T.numRows());
- printf("\t\tt=%d.. V error %10.6g\n",maxd+1,V_rest.getData().getMax());
- }
-
- delete init;
-
- return true;
-}
-
-
-/****************************************************/
-/* definition of TestRunnable subclasses */
-/****************************************************/
-class SmallNonDiffuse : public TestRunnable {
-public:
- SmallNonDiffuse()
- : TestRunnable("Non-diffuse small (p=2,m=3,r=4)") {}
-
- bool run() const
- {
- filter_and_smoother("small2x3x4", false);
- return true;
- }
-};
-
-class SmallDiffuse : public TestRunnable {
-public:
- SmallDiffuse()
- : TestRunnable("Diffuse small (p=2,m=3,r=4)") {}
-
- bool run() const
- {
- return filter_and_smoother("small2x3x4", true);
- }
-};
-
-class MiddleNonDiffuse : public TestRunnable {
-public:
- MiddleNonDiffuse()
- : TestRunnable("Non-diffuse middle (p=10,m=15,r=12)") {}
-
- bool run() const
- {
- return filter_and_smoother("10x15x12", false);
- }
-};
-
-class MiddleDiffuse : public TestRunnable {
-public:
- MiddleDiffuse()
- : TestRunnable("Diffuse middle (p=10,m=15,r=12)") {}
-
- bool run() const
- {
- return filter_and_smoother("10x15x12", true);
- }
-};
-
-class SOEDiffuse : public TestRunnable {
-public:
- SOEDiffuse()
- : TestRunnable("Diffuse soe (p=8,m=25,r=15)") {}
-
- bool run() const
- {
- return filter_and_smoother("soe8x25x15", true);
- }
-};
-
-int main()
-{
- TestRunnable* all_tests[50];
- // fill in vector of all tests
- int num_tests = 0;
- all_tests[num_tests++] = new SmallNonDiffuse();
- all_tests[num_tests++] = new SmallDiffuse();
- all_tests[num_tests++] = new MiddleNonDiffuse();
- all_tests[num_tests++] = new MiddleDiffuse();
- all_tests[num_tests++] = new SOEDiffuse();
-
- // launch the tests
- int success = 0;
- for (int i = 0; i < num_tests; i++) {
- try {
- if (all_tests[i]->test())
- success++;
- } catch (const TSException& e) {
- printf("Caugth TS exception in <%s>:\n", all_tests[i]->getName());
- e.print();
- } catch (SylvException& e) {
- printf("Caught Sylv exception in <%s>:\n", all_tests[i]->getName());
- e.printMessage();
- }
- }
-
- printf("There were %d tests that failed out of %d tests run.\n",
- num_tests - success, num_tests);
-
- // destroy
- for (int i = 0; i < num_tests; i++) {
- delete all_tests[i];
- }
-
- return 0;
-}