%% (Internal) Design the wavelet decomposition filters for wavedet algorithm
%
% Prototype:
% ----------
% q_filters = qs_filter_design(scales, fs, N);
%
% Description:
% ------------
% Mimics the transfer function of the filters used for ECG delineation in
% [Martinez et al. 2004] for an arbitrary sampling frequency and filter order N.
%
% Martinez et al. "A Wavelet-Based ECG Delineator: Evaluation on Standard
% Databases" IEEE TRANSACTIONS ON BIOMEDICAL ENGINEERING, VOL. 51, NO. 4,
% APRIL 2004.
%
% WARNING :
% ---------
% As this routines iterates through several configurations in order to
% converge, the user should check the transfer functions of the filters. My
% suggestion is once you obtain a desired filter bank for a given Fs or
% configuration, save or cache it in a .mat file in order to use it during
% operation. For example, if you usually work with signals sampled at 360
% Hz, a good choice is to have a cached version of the filters for this Fs
% in a .mat file called "wt_filters_6 scales_360 Hz.mat". You can use this
% function on-line with your algorithm at your own risk.
%
% Examples :
% ----------
%
% q_filters = qs_filter_design(4, 250);
%
% q_filters = qs_filter_design(5, 360);
%
% q_filters = qs_filter_design(6, 1000);
%
% you can check filter characteristics using:
%
% fss = [250 360 500 1000]; %Hz
% for fs  = fss
%     fvtool(q_filters, 'fs', fs )
% end
%
% Author: Mariano Llamedo Soria (llamedom at frba.utn.edu.ar)
% Version: 0.1 beta
% Birthdate: 17/2/11
% Last update: 22/02/13
% Copyright 2008-2015
%
function q_filters = qs_filter_design(scales, fs, N)

design_iter_attemps = 10;

if( nargin < 2 || isempty(fs) )
    fs = 250; %Hz
end

if( nargin < 3 || isempty(N) )
    %valor emp�rico obtenido de varios dise�os.
    N = max(10, round(fs*4/30 + 16+2/3));
end

%Pruebo que N no sea demasiado distinto a lo recomendable.
recommended_N = max(10, round(fs*4/30 + 16+2/3));
if( abs(N - recommended_N) > 0.1*N )
    warning(['Check the transfer functions of the differentiator filters designed. Recommended order N = ' num2str(recommended_N) ]);
end

%frecuencia a la que est� dise�ado el delineador, y que se toma para
%referencia para que las escalas signifiquen lo mismo a cualquier Fs.
f_ref = 250; %Hz
f_ratio = f_ref/fs;

% Funciones de transferencia correctas para el dise�o de los filtros utilizadas
% por el wavedet a 250 Hz.
empirical_tf = { ...
    [2;-2] ...
    [0.250000000000000;0.750000000000000;0.500000000000000;-0.500000000000000;-0.750000000000000;-0.250000000000000;] ...
    [0.0312500000000000;0.0937500000000000;0.187500000000000;0.312500000000000;0.343750000000000;0.281250000000000;0.125000000000000;-0.125000000000000;-0.281250000000000;-0.343750000000000;-0.312500000000000;-0.187500000000000;-0.0937500000000000;-0.0312500000000000;] ...
    [0.00390625000000000;0.0117187500000000;0.0234375000000000;0.0390625000000000;0.0585937500000000;0.0820312500000000;0.109375000000000;0.140625000000000;0.160156250000000;0.167968750000000;0.164062500000000;0.148437500000000;0.121093750000000;0.0820312500000000;0.0312500000000000;-0.0312500000000000;-0.0820312500000000;-0.121093750000000;-0.148437500000000;-0.164062500000000;-0.167968750000000;-0.160156250000000;-0.140625000000000;-0.109375000000000;-0.0820312500000000;-0.0585937500000000;-0.0390625000000000;-0.0234375000000000;-0.0117187500000000;-0.00390625000000000;] ...
    [0.000488281250000000;0.00146484375000000;0.00292968750000000;0.00488281250000000;0.00732421875000000;0.0102539062500000;0.0136718750000000;0.0175781250000000;0.0219726562500000;0.0268554687500000;0.0322265625000000;0.0380859375000000;0.0444335937500000;0.0512695312500000;0.0585937500000000;0.0664062500000000;0.0727539062500000;0.0776367187500000;0.0810546875000000;0.0830078125000000;0.0834960937500000;0.0825195312500000;0.0800781250000000;0.0761718750000000;0.0708007812500000;0.0639648437500000;0.0556640625000000;0.0458984375000000;0.0346679687500000;0.0219726562500000;0.00781250000000000;-0.00781250000000000;-0.0219726562500000;-0.0346679687500000;-0.0458984375000000;-0.0556640625000000;-0.0639648437500000;-0.0708007812500000;-0.0761718750000000;-0.0800781250000000;-0.0825195312500000;-0.0834960937500000;-0.0830078125000000;-0.0810546875000000;-0.0776367187500000;-0.0727539062500000;-0.0664062500000000;-0.0585937500000000;-0.0512695312500000;-0.0444335937500000;-0.0380859375000000;-0.0322265625000000;-0.0268554687500000;-0.0219726562500000;-0.0175781250000000;-0.0136718750000000;-0.0102539062500000;-0.00732421875000000;-0.00488281250000000;-0.00292968750000000;-0.00146484375000000;-0.000488281250000000;] ...
    [6.10351562500000e-05;0.000183105468750000;0.000366210937500000;0.000610351562500000;0.000915527343750000;0.00128173828125000;0.00170898437500000;0.00219726562500000;0.00274658203125000;0.00335693359375000;0.00402832031250000;0.00476074218750000;0.00555419921875000;0.00640869140625000;0.00732421875000000;0.00830078125000000;0.00933837890625000;0.0104370117187500;0.0115966796875000;0.0128173828125000;0.0140991210937500;0.0154418945312500;0.0168457031250000;0.0183105468750000;0.0198364257812500;0.0214233398437500;0.0230712890625000;0.0247802734375000;0.0265502929687500;0.0283813476562500;0.0302734375000000;0.0322265625000000;0.0339965820312500;0.0355834960937500;0.0369873046875000;0.0382080078125000;0.0392456054687500;0.0401000976562500;0.0407714843750000;0.0412597656250000;0.0415649414062500;0.0416870117187500;0.0416259765625000;0.0413818359375000;0.0409545898437500;0.0403442382812500;0.0395507812500000;0.0385742187500000;0.0374145507812500;0.0360717773437500;0.0345458984375000;0.0328369140625000;0.0309448242187500;0.0288696289062500;0.0266113281250000;0.0241699218750000;0.0215454101562500;0.0187377929687500;0.0157470703125000;0.0125732421875000;0.00921630859375000;0.00567626953125000;0.00195312500000000;-0.00195312500000000;-0.00567626953125000;-0.00921630859375000;-0.0125732421875000;-0.0157470703125000;-0.0187377929687500;-0.0215454101562500;-0.0241699218750000;-0.0266113281250000;-0.0288696289062500;-0.0309448242187500;-0.0328369140625000;-0.0345458984375000;-0.0360717773437500;-0.0374145507812500;-0.0385742187500000;-0.0395507812500000;-0.0403442382812500;-0.0409545898437500;-0.0413818359375000;-0.0416259765625000;-0.0416870117187500;-0.0415649414062500;-0.0412597656250000;-0.0407714843750000;-0.0401000976562500;-0.0392456054687500;-0.0382080078125000;-0.0369873046875000;-0.0355834960937500;-0.0339965820312500;-0.0322265625000000;-0.0302734375000000;-0.0283813476562500;-0.0265502929687500;-0.0247802734375000;-0.0230712890625000;-0.0214233398437500;-0.0198364257812500;-0.0183105468750000;-0.0168457031250000;-0.0154418945312500;-0.0140991210937500;-0.0128173828125000;-0.0115966796875000;-0.0104370117187500;-0.00933837890625000;-0.00830078125000000;-0.00732421875000000;-0.00640869140625000;-0.00555419921875000;-0.00476074218750000;-0.00402832031250000;-0.00335693359375000;-0.00274658203125000;-0.00219726562500000;-0.00170898437500000;-0.00128173828125000;-0.000915527343750000;-0.000610351562500000;-0.000366210937500000;-0.000183105468750000;-6.10351562500000e-05;] ...
                };

Grid_size = 1024;

% Creo una grilla de muestreo en frecuencia logaritmica para que la
% zona en que derivan los filtros sea una recta de pendiente constante.
F_log = logspace(-3, min(0, log10(fs/f_ref)), Grid_size) * pi;

filter_count = 1;

for ii = rowvec(scales)

    [g_amp F] = freqz(empirical_tf{ii},1, F_log);
    F = F * f_ratio / pi;
    g_amp = abs(g_amp);

    %averiguo hasta qu� muestra se comporta como un derivador, ya que ser�
    %un par�metro de dise�o.
    slope_aux = diff( log10(g_amp) );
    end_diff_idx = find(slope_aux < 0.95*slope_aux(1), 1, 'first');

    %dise�o un derivador hasta dicha frecuencia, con una banda de
    %transici�n dada por la expresion , cuando sea posible.
    ftrans = min(70, 251 * exp(-0.63*ii));
    diff_order = round(N*1.8.^((ii*0.4 -0.6)));
    %Los N tienen que ser necesariamente pares para el dise�o del derivador.
    if( rem(diff_order,2) ~= 0 )
        diff_order = diff_order + 1;
    end

    [msgstr, msgid] = lastwarn;
    %itero hasta que se dise�a correctamente.
    jj = 0;
    effective_order = diff_order;
    aux_seq = linspace(0.5,1.1,design_iter_attemps);
    while( jj < design_iter_attemps )
        d = fdesign.differentiator('n,fp,fst', effective_order, F(end_diff_idx), min( 0.95, F(end_diff_idx)+(ftrans*2/fs) ) );
        try
            Hd = design(d,'equiripple');
            [~, msgid] = lastwarn('','');
        catch MException
            %on error, force iteration with different config.
            msgid = 'signal:firpm:DidNotConverge';
        end
        if(strcmpi(msgid,'signal:firpm:DidNotConverge'))
            %fallo en la convergencia, iteramos de nuevo.
            %recorro linealmente por el rango +10:-50%
            effective_order = round(diff_order * aux_seq(jj+1));
            %Los effective_order tienen que ser necesariamente pares para el dise�o del derivador.
            if( rem(effective_order,2) ~= 0 )
                effective_order = effective_order + 1;
            end
            jj = jj + 1;
        else
            jj = design_iter_attemps;
        end
    end

    if(strcmpi(msgid,'signal:firpm:DidNotConverge'))
    %fallo en la convergencia, reportamos el error.
        error('qs_filter_design:Impossible2Design', 'Impossible to design the differentiator filter. Please try another N value, or check the filters transfer functions manually.')
    end

    %Vuelvo a ver la transferencia real del derivador dise�ado y del filtro
    %a emular para que tengan una respuesta similar en la zona en que se
    %comporta como derivador. Averiguo el factor de escala entre ambas
    %transferencias.
    g_amp_emp = freqz(empirical_tf{ii},1, F_log);
    g_amp_emp = abs(g_amp_emp);

    g_amp_real = freqz(Hd, F * pi);
    g_amp_real = abs(g_amp_real);

    aux_idx = round(end_diff_idx/2);
    aux_scale = g_amp_emp(aux_idx)/g_amp_real(aux_idx);

    %Escalo la zona del derivador.
    Hd.Numerator = Hd.Numerator * aux_scale;
    g_amp_real = g_amp_real * aux_scale;

    %ahora dise�o un filtro de compensaci�n para que la zona en que no se
    %deriva sea similar al filtro de referencia. Esta ir� desde el m�ximo
    %de la transferencia pasobanda hasta donde haya una amplitud mayor a
    %0.5 veces.
    [~, max_idx] = max(g_amp);

    aux_3db_unique = find( g_amp_real > 0.5 & g_amp_emp > 0.5, 1, 'last');

    if( max_idx >= aux_3db_unique)
        max_idx = end_diff_idx;
    end
    aux_idx = max_idx:aux_3db_unique;

    %Creo una grilla de frecuencia - magnitud arbitraria para el dise�o del
    %filtro. Esta transferencia no deber� afectar la zona derivadora (H(w)
    %= 1) y compensar la zona indicada por aux_idx, emulando la
    %transferencia de referencia y teniendo un valor de atenuaci�n
    %considerable en Nyquist (H(w) = 1e-3)
    F_comp = [0 max(0.9*F(end_diff_idx), (F(max_idx)-F(end_diff_idx))/2) F(aux_idx) 1];
    g_amp_comp = [1 1 g_amp(aux_idx)./g_amp_real(aux_idx) 1e-3];
    W = ones(1, length(F_comp));
    W(3:end-1) = 10;

    %Se dise�a el filtro
    d = fdesign.arbmag('N,F,A', diff_order, F_comp, g_amp_comp);
    Hd_comp = design(d,'firls', 'weights', W, 'FilterStructure', 'dfsymfir');

    % y se cascadea al original.
    Hd = dfilt.cascade(Hd, Hd_comp);

    q_filters(filter_count) = Hd;

    filter_count = filter_count + 1;

end


function  [C,phi,S12,confC,phierr,Cerr]=cohmathelper(J,err,Nsp)
% Helper function called by coherency matrix computations.
%
% Usage: [C,phi,S12,confC,phierr,Cerr]=cohmathelper(J,err,Nsp)
% Inputs:
% J   : Fourier transforms of data
% err : [0 p] or 0 for no errors; [1 p] for theoretical confidence level,
%       [2 p] for Jackknife (p - p value)
% Nsp : pass the number of spikes in each channel if finite size corrections are desired
%
% Outputs:
%
% C   : coherence
% phi : phase of coherency
% S12 : cross spectral matrix
% confC : confidence level for coherency - only for err(1)>=1
%       phierr - standard deviation for phi (note that the routine gives phierr as phierr(1,...)
%                and phierr(2,...) in order to incorporate Jackknife (eventually).
%                Currently phierr(1,...)=phierr(2,...). Note that phi + 2 phierr(1,...) and phi -2
%                phierr(2,...) will give 95% confidence bands for phi - only for err(1)>=1
% Cerr  : error bars for coherency (only for Jackknife estimates)-only for err(1)=2
%

errtype=err(1);
trialave=0;
[nf,K,Ch]=size(J);
clear K
confC=zeros(Ch,Ch);
C=zeros(nf,Ch,Ch);
S12=zeros(nf,Ch,Ch);
phi=zeros(nf,Ch,Ch);
phierr=zeros(2,nf,Ch,Ch);
if errtype==2; Cerr=zeros(2,nf,Ch,Ch);end;

for ch1=1:Ch;
     J1=squeeze(J(:,:,ch1));
     C(1:nf,ch1,ch1)=1;
     phi(1:nf,ch1,ch1)=0;
%      if errtype==2;
%           phierr(1:nf,ch1,ch1)=0;
%           Cerr(1:2,1:nf,ch1,ch1)=0;
%      elseif errtype==1
%            phierr(1:2,1:nf,ch1,ch1)=0;
%      end;
     s1=squeeze(mean(conj(J1).*J1,2));
     for ch2=1:ch1-1;
          J2=squeeze(J(:,:,ch2));
          s12=squeeze(mean(conj(J1).*J2,2));
          s2=squeeze(mean(conj(J2).*J2,2));
          C12=s12./sqrt(s1.*s2);
          C(:,ch1,ch2)=abs(C12);
          C(:,ch2,ch1)=C(:,ch1,ch2);
          phi(:,ch1,ch2)=angle(C12);
          phi(:,ch2,ch1)=phi(:,ch1,ch2);
          S12(:,ch1,ch2)=s12;
          S12(:,ch2,ch1)=S12(:,ch1,ch2);
          if errtype==2
             if nargin<3;
                 [conf,phie,Ce]=coherr(abs(C12),J1,J2,err,trialave);
             else
                 [conf,phie,Ce]=coherr(abs(C12),J1,J2,err,trialave,Nsp(ch1),Nsp(ch2));
             end
             confC(ch1,ch2)=conf;
             phierr(1,:,ch1,ch2)=phie;phierr(2,:,ch1,ch2)=phie;
             Cerr(1,:,ch1,ch2)=Ce(1,:);
             Cerr(2,:,ch1,ch2)=Ce(2,:);
             confC(ch2,ch1)=conf;
             phierr(1,:,ch2,ch1)=phie;phierr(2,:,ch2,ch1)=phie;
             Cerr(:,:,ch2,ch1)=Ce;
          elseif errtype==1
             if nargin<3;
                 [conf,phie]=coherr(abs(C12),J1,J2,err,trialave);
             else
                 [conf,phie]=coherr(abs(C12),J1,J2,err,trialave,Nsp(ch1),Nsp(ch2));
             end
             confC(ch1,ch2)=conf;
             phierr(1,:,ch1,ch2)=phie;phierr(2,:,ch1,ch2)=phie;
             confC(ch2,ch1)=conf;
             phierr(1,:,ch2,ch1)=phie;phierr(2,:,ch2,ch1)=phie;
          end;
     end;
end;


function [beta_gibbs,F_gibbs,gamma_gibbs,L_gibbs,phi_gibbs,sigma_gibbs,lambda_t_gibbs,sigma_t_gibbs,sbar,favar,It,Bu]=...
    favar_stvol2gibbs(Xbart,yt,beta0,omega0,alpha0,delta0,gamma0,zeta0,f0,upsilon0,betahat,sigmahat,I_o,omega,T,n,q,It,Bu,pick,pickf,favar,data_endo,lags)

%% preliminaries
% initialise variables
nfactorvar=favar.nfactorvar;
numpc=favar.numpc;
favarX=favar.X(:,favar.plotX_index);
onestep=favar.onestep;
Sigma=bear.nspd(favar.Sigma);
Ll=favar.L;
favar_X=favar.X;
% load priors
L0=favar.L0*eye(n);
a0=favar.a0;
b0=favar.b0;
% sigmahat=(1/T)*(EPS'*EPS);

% preallocation
Ll_gibbs=zeros(size(Ll(:),1),It-Bu);
R2_gibbs=zeros(size(favarX,2),It-Bu);

if onestep==0 %static factors in this case
    FY=data_endo;
    pbstring='two-step'; %string for the progress bar
    % elseif onestep==1
    %     pbstring='one-step'; %string for the progress bar
end

% preliminary elements for the algorithm
% compute alphabar
alphabar=T+alpha0;

% initiate the Gibbs sampler
% initiate the counting of iterations
count=1;
pickcount=1;
% initiate the record matrices and cells
beta_gibbs=[];
F_gibbs=[];
L_gibbs=[];
phi_gibbs=[];
sigma_gibbs=[];
lambda_t_gibbs={};
sigma_t_gibbs={};

% step 1: determine initial values for the algorithm

% initial value for beta
beta=betahat;
% initial value for f_2,...,f_n
% obtain the triangular factorisation of sigmahat
[Fhat,Lambdahat]=bear.triangf(sigmahat);
% obtain the inverse of Fhat
[invFhat]=bear.invltod(Fhat,n);
% create the cell storing the different vectors of invF
Finv=cell(n,1);
% store the vectors
for ii=2:n
    Finv{ii,1}=invFhat(ii,1:ii-1);
end
% initial values for L_1,...,L_n
L=zeros(T,n);
% initial values for gamma_1,...,gamma_n
gamma=0.85*ones(1,n);
% initial values for G_1,...,G_n
G=cell(n,1);
for ii=1:n
    G{ii,1}=speye(T)-sparse(diag(gamma(1,ii)*ones(T-1,1),-1));
end
% initial values for phi_1,...,phi_n
phi=ones(1,n);

% step 2: determine the sbar values and Lambda
sbar=diag(Lambdahat);
Lambda=sparse(diag(sbar));

% step 3: recover the series of initial values for lambda_1,...,lambda_T and sigma_1,...,sigma_T
lambda_t=repmat(diag(sbar),1,1,T);
sigma_t=repmat(sigmahat,1,1,T);

% create a progress bar
hbar = bear.parfor_progressbar(It,['Progress of the Gibbs sampler (',pbstring,').']);

%% run the Gibbs sampler
while count<=It

    % step 4: draw beta from its conditional posterior
    % first compute the summations required for omegabar and betabar
    summ1=zeros(q,q);
    summ2=zeros(q,1);
    % run the summation
    for jj=1:T
        prodt=Xbart{jj,1}'/sigma_t(:,:,jj);
        summ1=summ1+prodt*Xbart{jj,1};
        summ2=summ2+prodt*yt(:,:,jj);
    end
    % then obtain the inverse of omega0
    invomega0=diag(1./diag(omega0));
    % obtain the inverse of omegabar
    invomegabar=summ1+invomega0;
    % recover omegabar
    C=chol(bear.nspd(invomegabar),'Lower')';
    invC=C\speye(q);
    omegabar=invC*invC';
    % recover betabar
    betabar=omegabar*(summ2+invomega0*beta0);
    % finally, draw beta from its posterior
    beta=betabar+chol(bear.nspd(omegabar),'lower')*randn(q,1);

    % step 5: draw the series f_2,...,f_n from their conditional posteriors
    % recover first the residuals
    for jj=1:T
        epst(:,:,jj)=yt(:,:,jj)-Xbart{jj,1}*beta;
    end
    % then draw the vectors in turn
    for jj=2:n
        % first compute the summations required for upsilonbar and fbar
        summ1=zeros(jj-1,jj-1);
        summ2=zeros(jj-1,1);
        % run the summation
        for kk=1:T
            prodt=epst(1:jj-1,1,kk)*exp(-L(kk,jj));
            summ1=summ1+prodt*epst(1:jj-1,1,kk)';
            summ2=summ2+prodt*epst(jj,1,kk)';
        end
        summ1=(1/sbar(jj,1))*summ1;
        summ2=(-1/sbar(jj,1))*summ2;
        % then obtain the inverse of upsilon0
        invupsilon0=diag(1./diag(upsilon0{jj,1}));
        % obtain upsilonbar
        invupsilonbar=summ1+invupsilon0;
        C=chol(bear.nspd(invupsilonbar));
        invC=C\speye(jj-1);
        upsilonbar=full(invC*invC');
        % recover fbar
        fbar=upsilonbar*(summ2+invupsilon0*f0{jj,1});
        % finally draw f_i^(-1)
        Finv{jj,1}=fbar+chol(bear.nspd(upsilonbar),'lower')*randn(jj-1,1);
    end
    % recover the inverse of F
    invF=eye(n);
    for jj=2:n
        invF(jj,1:jj-1)=Finv{jj,1};
    end
    % eventually recover F
    F=bear.invltod(invF,n);
    % then update sigma
    sigma=F*Lambda*F';

    % step 6: draw the series gamma_1,...,gamma_n from their conditional posteriors
    % draw the parameters in turn
    for jj=1:n
        % estimate zetabar
        zetabar=1/((1/phi(1,jj))*L(1:T-1,jj)'*L(1:T-1,jj)+1/zeta0);
        % estimate zetabar
        gammabar=zetabar*((1/phi(1,jj))*L(2:T,jj)'*L(1:T-1,jj)+gamma0/zeta0);
        % draw the value gamma_i
        gamma(1,jj)=gammabar+zetabar^0.5*randn;
        % obtain G_i
        G{jj,1}=speye(T)-sparse(diag(gamma(1,jj)*ones(T-1,1),-1));
    end

    % step 7: draw the series phi_1,...,phi_n from their conditional posteriors
    % draw the parameters in turn
    for jj=1:n
        % estimate deltabar
        deltabar=L(:,jj)'*G{jj,1}'*I_o*G{jj,1}*L(:,jj)+delta0;
        % draw the value phi_i
        phi(1,jj)=bear.igrandn(alphabar/2,deltabar/2);
    end

    % step 8: draw the series lambda_i,t from their conditional posteriors, i=1,...,n and t=1,...,T
    % consider variables in turn
    for jj=1:n
        % consider periods in turn
        for kk=1:T
            % a candidate value will be drawn from N(lambdabar,phibar)
            % the definitions of lambdabar and phibar varies with the period, thus define them first
            % if the period is the first period
            if kk==1
                lambdabar=(gamma(1,jj)*L(2,jj))/(1/omega+gamma(1,jj)^2);
                phibar=phi(1,jj)/(1/omega+gamma(1,jj)^2);
                % if the period is the final period
            elseif kk==T
                lambdabar=gamma(1,jj)*L(T-1,jj);
                phibar=phi(1,jj);
                % if the period is any period in-between
            else
                lambdabar=(gamma(1,jj)/(1+gamma(1,jj)^2))*(L(kk-1,jj)+L(kk+1,jj));
                phibar=phi(1,jj)/(1+gamma(1,jj)^2);
            end
            % now draw the candidate
            cand=lambdabar+phibar^0.5*randn;
            % compute the acceptance probability
            prob=bear.mhprob2(jj,cand,L(kk,jj),sbar(jj,1),epst(:,1,kk),Finv{jj,1});
            % draw a uniform random number
            draw=rand;
            % keep the candidate if the draw value is lower than the prob
            if draw<=prob
                L(kk,jj)=cand;
                % if not, just keep the former value
            end
        end
    end
    % then recover the series of matrices lambda_t and sigma_t
    for jj=1:T
        lambda_t(:,:,jj)=diag(sbar).*diag(exp(L(jj,:)));
        sigma_t(:,:,jj)=F*lambda_t(:,:,jj)*F';
    end

    %% Sample Sigma and Ll (static)
    [Sigma,Ll]=bear.favar_SigmaL(Sigma,Ll,nfactorvar,numpc,onestep,n,favar_X,FY,a0,b0,T,lags,L0);

    %% record phase
    % if the burn-in sample phase is not yet over
    if count<=Bu
        % simply add 1 to the iteration count
        count=count+1;
        % on the other hand, if the burn-in sample phase is over
    elseif count>Bu
        % adding one iteration to the count will depend on wether post-burn selection applies
        % if there is no post burn selection
        if pick==0
            % record the results
            beta_gibbs(:,count-Bu)=beta;
            F_gibbs(:,:,count-Bu)=F;
            gamma_gibbs(count-Bu,:)=gamma;
            L_gibbs(:,:,count-Bu)=L;
            phi_gibbs(count-Bu,:)=phi;
            sigma_gibbs(:,count-Bu)=sigma(:);
            % save the factors and loadings (keep the notation in the code consistent, although - except L - they don't change)
            Ll_gibbs(:,count-Bu)=Ll(:);

            % compute R2 (Coefficient of Determination) for plotX variables (keep the notation in the code consistent, although they don't change)
            R2=bear.favar_R2(favarX,FY);
            R2_gibbs(:,count-Bu)=R2(:);
            for jj=1:T
                lambda_t_gibbs{jj,1}(:,:,count-Bu)=lambda_t(:,:,jj);
                sigma_t_gibbs{jj,1}(:,:,count-Bu)=sigma_t(:,:,jj);
            end
            % then add one to the count
            count=count+1;
            % if there is post burn selection, only one draw over 'fpick' draws will be retained
        elseif pick==1
            % if the iteration does not correspond to fpick, don't record the results, don't increase the regular count, but do increase pickcount by 1, and do record the acceptance rate of the Metropolis-Hastings step
            if pickcount~=pickf
                pickcount=pickcount+1;
                % on the other hand, if the iteration does correspond to fpick
            elseif pickcount==pickf
                % do record the results
                beta_gibbs(:,count-Bu)=beta;
                F_gibbs(:,:,count-Bu)=F;
                gamma_gibbs(count-Bu,:)=gamma;
                L_gibbs(:,:,count-Bu)=L;
                phi_gibbs(count-Bu,:)=phi;
                sigma_gibbs(:,count-Bu)=sigma(:);
                % save the factors and loadings (keep the notation in the code consistent, although - except L - they don't change)
                Ll_gibbs(:,count-Bu)=Ll(:);

                % compute R2 (Coefficient of Determination) for plotX variables (keep the notation in the code consistent, although they don't change)
                R2=bear.favar_R2(favarX,FY);
                R2_gibbs(:,count-Bu)=R2(:);
                for jj=1:T
                    lambda_t_gibbs{jj,1}(:,:,count-Bu)=lambda_t(:,:,jj);
                    sigma_t_gibbs{jj,1}(:,:,count-Bu)=sigma_t(:,:,jj);
                end
                % then increase the regular count by 1 and re-initialise pickcount
                count=count+1;
                pickcount=1;
            end
        end
    end

    % update progress by one iteration
    hbar.iterate(1);

end

% in case we have thinning of the draws,
thin=abs(round(favar.thin)); % should be a positive integer
if thin~=1
    beta_gibbs=beta_gibbs(:,thin:thin:end);
    F_gibbs=F_gibbs(:,thin:thin:end);
    L_gibbs=L_gibbs(:,thin:thin:end);
    phi_gibbs=phi_gibbs(:,thin:thin:end);
    sigma_gibbs=sigma_gibbs(:,thin:thin:end);
    Ll_gibbs=Ll_gibbs(:,thin:thin:end);
    R2_gibbs=R2_gibbs(:,thin:thin:end);
    for jj=1:T
        lambda_t_gibbs=lambda_t_gibbs(:,:,thin:thin:end);
        sigma_t_gibbs=sigma_t_gibbs(:,:,thin:thin:end);
    end
    It=(1/thin)*It;
    Bu=(1/thin)*Bu;
end

% save in favar structure
favar.L_gibbs=Ll_gibbs;
favar.R2_gibbs=R2_gibbs;

close(hbar);   %close progress bar


function [K] = ku1v0(x, xp, hyp, ubarp, vbarp, dt, i)

logsigmau = hyp(1);
logthetau = hyp(2);
logsigmav = hyp(3);
logthetav = hyp(4);

a1 = hyp(5);
a2 = hyp(6);

n_x = size(x,1);
n_xp = size(xp,1);

x = repmat(x,1,n_xp);
xp = repmat(xp',n_x,1);

ubarp = repmat(ubarp',n_x,1);
vbarp = repmat(vbarp',n_x,1);

switch i

case 0

K=(-1).*dt.*exp(1).^(logsigmau+(-2).*logthetau+(-1/2).*exp(1).^((-1).* ...
  logthetau).*(x+(-1).*xp).^2).*(a2.*exp(1).^(2.*logthetau).*(ubarp.^2+ ...
  vbarp.^2)+a1.*((-1).*exp(1).^logthetau+(x+(-1).*xp).^2));

case 1 % logsigmau

K=(-1).*dt.*exp(1).^(logsigmau+(-2).*logthetau+(-1/2).*exp(1).^((-1).* ...
  logthetau).*(x+(-1).*xp).^2).*(a2.*exp(1).^(2.*logthetau).*(ubarp.^2+ ...
  vbarp.^2)+a1.*((-1).*exp(1).^logthetau+(x+(-1).*xp).^2));

case 2 % logthetau

K=(-1/2).*dt.*exp(1).^(logsigmau+(-3).*logthetau+(-1/2).*exp(1).^((-1).* ...
  logthetau).*(x+(-1).*xp).^2).*(a1.*(2.*exp(1).^(2.*logthetau)+(-5).*exp( ...
  1).^logthetau.*(x+(-1).*xp).^2+(x+(-1).*xp).^4)+a2.*exp(1).^(2.* ...
  logthetau).*(ubarp.^2+vbarp.^2).*(x+(-1).*xp).^2);

case 3 % logsigmav

K=0;

case 4 % logthetav

K=0;

case 5 % a1

K=(-1).*dt.*exp(1).^(logsigmau+(-2).*logthetau+(-1/2).*exp(1).^((-1).* ...
  logthetau).*(x+(-1).*xp).^2).*((-1).*exp(1).^logthetau+(x+(-1).*xp).^2); ...

case 6 % a2

K=(-1).*dt.*exp(1).^(logsigmau+(-1/2).*exp(1).^((-1).*logthetau).*(x+(-1) ...
  .*xp).^2).*(ubarp.^2+vbarp.^2);

otherwise

        K = zeros(n_x, n_xp);
end

if K == 0

    K = zeros(n_x, n_xp);

end

end


function plot_mix_gaussian( u,sig,prob,X )
%
% plot_mix_gaussian - plot the samples and the estimation.
%                     for 1D distribution, plot the normalized histogram and the 1D distribution function
%                     for 2D distribution, plot the samples and the contour of FWHM
%                     for mD distribution (m>2) - do not plot nothing.
%
% format:   plot_mix_gaussian( u,sig,prob,X )
%
% input:    u       - mean of each gaussian in the distribution. 1xM vector or 2xM matrix.
%                     each gaussian mean is stored in a separate column.
%           sig     - for 1D distribution -> standard deviation of each gaussian in the distribution
%                     each gaussian mean is stored in a separate column -> a 1xM vector
%                     for 2D distribution -> covariance matrix for each gaussian in the distribution
%                     2x2xM matrix, the 3rd dimension is the gaussians index,
%                     the 1st and 2nd dimensions are the covariance matrix
%           prob    - probability of each gaussian in the distribution to create the current sample.
%                     this is a 1xM vector
%           X       - the samples, 1xN vector or 2xN matrix, depends on the dimension of the
%                     distribution (i.e. 1D or 2D)
%
% output:   to the graphic current axis.
%
%
%

% check input
if (nargin<3)
    error( 'plot_mix_gaussian - insufficient input parameters' );
end
if ~exist( 'X' )
    X = [];
end

% constants
nbins = 200;

% check the size of the input to determin if it's 1D or 2D distribution
if (size(u,1)==2) & (size(u,2)==size(prob,2))
    plot_mix_gaussian_2d( u,sig,prob,X );
else
    plot_mix_gaussian_1d( u,sig,prob,X,nbins );
end
drawnow;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%                              Inner function implementation
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

function plot_mix_gaussian_1d( u,sig,prob,X,nbins )
% plot normalized histogram and normalized distribution on top of it

% constant
points = 1000;

if ~isempty( X )
    [n,x]   = hist( X,nbins );              % calc the histogram
    dx      = x(2)-x(1);                    % calc a single bin width
    n       = n / sum( n*dx );              % normalize histogram to have area of 1
    bar( x,n,'hist' );                      % plot normalized histogram
    xlim( [x(1)-dx/2,x(end)+dx/2] );        % make sure that the axis is squeezed to it's limits
    g       = gca;
    c       = [1 0 0];                      % choose the red color
    x_c     = linspace( x(1)-dx/2,x(end)+dx/2,points );
else
    g       = gca;
    X       = xlim( g );                    % get the axis limits
    c       = [0 1 0];                      % choose the green color
    x_c     = linspace( X(1),X(2),points );
end

% plot the distribution
for m = 1:length(prob)
    y   = prob(m) / sqrt( 2*pi*sig(m)^2 ) * exp( -((x_c-u(m)).^2)/(2*sig(m)^2) );
    line( x_c,y,'color',c,'parent',g,'linewidth',2 );
end
shg;
drawnow;

% ----------------------------------------------------------------------------------------

function plot_mix_gaussian_2d( u,covar,prob,X )
% plot 2D samples and distribution data on top of it

if ~isempty( X )
    if size(X,2)<size(X,1),
        X = X.';
    end
    plot( X(1,:),X(2,:),'.k' );             % plot samples
    xlim( [min(X(1,:)) max(X(1,:))] );      % squeeze axis limits
    ylim( [min(X(2,:)) max(X(2,:))] );       % squeeze axis limits
    g       = gca;
    c       = [1 0 0];                      % choose the red color
else
    g       = gca;
    c       = [0 1 0];                      % choose the green color
end

% plot each gaussian's FWHM and mean (center)
a           = linspace(0,2*pi,361); % degree vector
unit_circle = [cos(a);sin(a)];      % a unit circle for the case of sig_x=sig_y=1
for m = 1:length(prob)
    U       = u(:,m);               % the mean of the mth gaussian
    [V,D]   = eig(covar(:,:,m));    % eigen value and vectors for the covariance of the mth gaussian
    A       = V*sqrt(D);            % factorization: covar = A*A' = positive matrix
    outline = A * unit_circle * sqrt(2*log(2)) + U*ones(1,length(unit_circle)); % the contour
    line( U(1),U(2),'color',c,'parent',g,'marker','o' );
    line( outline(1,:),outline(2,:),'color',c,'parent',g,'linewidth',2 );
end


function material_cell = mean_material_node(grid3d, gt, material_node)

chkarg(istypesizeof(grid3d, 'Grid3d'), '"grid3d" should be instance of Grid.');
chkarg(istypesizeof(gt, 'GT'), '"gt" should be instance of GT.');
chkarg(istypesizeof(material_node, 'complexcell', [1 Axis.count], grid3d.N), ...
	'"material_node" should be length-%d cell array, whose each element is %d-by-%d-by-%d array with complex elements.', ...
	Axis.count, grid3d.Ncell{:});

for w = Axis.elems
	material_node{w} = expand_node_array(grid3d, material_node{w});  % (Nx+2) x (Ny+2) x (Nz+2)
end

if gt == GT.prim
	% material parameters for fields on primary grid
	material_cell = arithmetic_mean_material_node(material_node);
else  % gt == GT.dual
	% material parameters for fields on dual grid
	material_cell = harmonic_mean_material_node(material_node);
end

function material_edge_cell = arithmetic_mean_material_node(material_node)
material_edge_cell = cell(1, Axis.count);

material_edge_cell{Axis.x} = (...
	material_node{Axis.x}(2:end-1, 2:end-1, 2:end-1) ...
	+ material_node{Axis.x}(2:end-1, 1:end-2, 2:end-1) ...
	+ material_node{Axis.x}(2:end-1, 2:end-1, 1:end-2) ...
	+ material_node{Axis.x}(2:end-1, 1:end-2, 1:end-2)...
) / 4;

material_edge_cell{Axis.y} = (...
	material_node{Axis.y}(2:end-1, 2:end-1, 2:end-1) ...
	+ material_node{Axis.y}(2:end-1, 2:end-1, 1:end-2) ...
	+ material_node{Axis.y}(1:end-2, 2:end-1, 2:end-1) ...
	+ material_node{Axis.y}(1:end-2, 2:end-1, 1:end-2)...
) / 4;

material_edge_cell{Axis.z} = (...
	material_node{Axis.z}(2:end-1, 2:end-1, 2:end-1) ...
	+ material_node{Axis.z}(1:end-2, 2:end-1, 2:end-1) ...
	+ material_node{Axis.z}(2:end-1, 1:end-2, 2:end-1) ...
	+ material_node{Axis.z}(1:end-2, 1:end-2, 2:end-1)...
) / 4;

function material_face_cell = harmonic_mean_material_node(material_node)
material_face_cell = cell(1, Axis.count);
material_face_cell{Axis.x} = 2./(1./material_node{Axis.x}(1:end-2, 2:end-1, 2:end-1) + 1./material_node{Axis.x}(2:end-1, 2:end-1, 2:end-1));
material_face_cell{Axis.y} = 2./(1./material_node{Axis.y}(2:end-1, 1:end-2, 2:end-1) + 1./material_node{Axis.y}(2:end-1, 2:end-1, 2:end-1));
material_face_cell{Axis.z} = 2./(1./material_node{Axis.z}(2:end-1, 2:end-1, 1:end-2) + 1./material_node{Axis.z}(2:end-1, 2:end-1, 2:end-1));


% Specification of Riemann problems

%  Shocktube problem of G.A. Sod, JCP 27:1, 1978
pleft = 1.0;  pright = 0.1; rholeft = 1.0;  rhoright = 0.125;
uleft = 0;  uright = 0; tend = 0.151; lambda = 0.45;	% lambda = dt/dx

% Lax test case: M. Arora and P.L. Roe: JCP 132:3-11,  1997
%pleft = 3.528;  pright = 0.571; rholeft = 0.445;  rhoright = 0.5;
%uleft = 0.698;  uright = 0; tend = 0.15; lambda = 0.3;	% lambda = dt/dx

% Mach = 3 test case: M. Arora and P.L. Roe: JCP 132:3-11,  1997
%pleft = 10.333;  pright = 1; rholeft = 3.857;  rhoright = 1;
%uleft = 0.92;  uright = 3.55; tend = 0.09; lambda = 0.3; % lambda = dt/dx

% Shocktube problem with supersonic zone
%pleft = 1;  pright = 0.02; rholeft = 1;  rhoright = 0.02;
%uleft = 0;  uright = 0; tend = 0.162; lambda = 0.4;	% lambda = dt/dx

% Contact discontinuity
%pleft = 0.5;  pright = 0.5; rholeft = 1.0;  rhoright = 0.6;
%uleft = 0;  uright = 0; tend = 1; lambda = 0.4; 	% lambda = dt/dx

% Stationary shock
%pleft = 1.0;  pright = 0.1; rholeft = 1.0;  rhoright = 0.125;
%uleft = -2;  uright = -2; tend = 0.1; lambda = 0.2; 	% lambda = dt/dx


function [X,Y,Out] = TMac(data,known,Nway,coreNway,opts)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% tensor completion by parallel matrix factorization
% ==============================================================================
% solve
%  min_{X,Y} sum_{n=1}^N 0.5*alpha(n)*||Proj_{known}(Xn*Yn-Unfold_n(M))||_F^2
% ===============================================================================
%
% Input:
%       data: observed entries of the underlying tensor
%       known: indices of observed entries
%       Nway: the dimension of the underlying tensor
%       coreNway: estimated ranks of all mode matricizations
%       opts.
%           maxit: maximum number of iterations (default: 500)
%           tol: stopping tolerance (default: 1e-4)
%           maxT: maximum running time (sec) (default: 1e6)
%           alpha: weights in the model (default: alpha(n) = 1/N, any n)
%           alpha_adj: determine whether dynamically update alpha
%                       (default: 1 (yes))
%           rank_adj: determine rank-adjusting strategy
%                       (1: increase; -1: decrease; 0: fix)
%           rank_inc: rank increment if rank-increasing strategy is used
%           rank_min: minimum rank estimation
%           rank_max: maximum rank estimation
%
% Output:
%       X,Y: cell structs
%       Out.
%           iter: number of iterations
%           relerr1: relative change array of total fitting
%           relerr2: array of total fitting
%           alpha: final weights alpha (may be different from input)

N = length(Nway); coNway = zeros(1,N);
for n = 1:N
    coNway(n) = prod(Nway)/Nway(n);
end
nrmb = norm(data);
%% Parameters and defaults
if isfield(opts,'maxit')      maxit = opts.maxit;     else maxit = 500;             end
if isfield(opts,'tol')        tol = opts.tol;         else tol = 1e-4;              end
if isfield(opts,'maxT')       maxT = opts.maxT;       else maxT = 1e6;              end
if isfield(opts,'alpha')      alpha = opts.alpha;     else alpha = ones(1,N)/N;     end
if isfield(opts,'alpha_adj')
    alpha_adj = opts.alpha_adj;
else
    alpha_adj = 1;
end

if isfield(opts,'rank_adj') rank_adj = opts.rank_adj; else rank_adj = zeros(1,N);   end
if isfield(opts,'rank_inc') rank_inc = opts.rank_inc; else rank_inc = ones(1,N);    end
if isfield(opts,'rank_min') rank_min = opts.rank_min; else rank_min = ones(1,N);    end
if isfield(opts,'rank_max') rank_max = opts.rank_max; else rank_max = 50*ones(1,N); end

%% Data preprocessing and initialization
if isfield(opts,'X0')
    X = opts.X0;
else
    X = cell(1,N);
    for n = 1:N
        X{n} = randn(Nway(n),coreNway(n));
    end
end

if isfield(opts,'Y0')
    Y = opts.Y0;
else
    Y = cell(1,N);
    for n = 1:N
        Y{n} = randn(coreNway(n),coNway(n));
    end
end

% rescale the initial point based on number of elements
estMnrm = sqrt(nrmb^2*(prod(Nway)/length(known)));

for n = 1:N
    X{n} = X{n}/norm(X{n},'fro')*estMnrm^(Nway(n)/(Nway(n)+coNway(n)));
    Y{n} = Y{n}/norm(Y{n},'fro')*estMnrm^(coNway(n)/(Nway(n)+coNway(n)));
end

X0 = X; Y0 = Y;

[known,id] = sort(known); data = data(id);

M = zeros(Nway); M(known) = data;

sx = cell(1,N);
reschg = ones(1,N);
reschg_tol = max(1e-2,10*tol);
rank_inc_num = sum(rank_adj==1);

res0 = zeros(1,N); TotalRes = 0;
res = res0;
for n = 1:N
    Mn = Fold(X{n}*Y{n},Nway,n);
    res0(n) = norm(Mn(known)-data);
    TotalRes = TotalRes+res0(n);
end
solX = ones(1,N);
Xsq = cell(1,N); Yt = cell(1,N); spI = cell(1,N);
for n = 1:N
    Yt{n} = Y{n}';
end

Out.rank = coreNway;

start_time = tic;

alpha = alpha/sum(alpha);

fprintf('Iteration:     ');

for k = 1:maxit
    fprintf('\b\b\b\b\b%5i',k);

    % update (X,Y)
    for n = 1:N
        if alpha(n) > 0
            Mn = Unfold(M,Nway,n);
            if solX(n)
                X{n} = Mn*Yt{n};
            end
            solX(n) = 1;

            Xsq{n} = X{n}'*X{n};
            Y{n} = pinv(Xsq{n})*X{n}'*Mn;
            Yt{n} = Y{n}';

            if rank_adj(n) == -1
                %rank_dec_adaptive();
                rank_dec_adaptive(Xsq,n,coreNway,rank_min,rank_adj,X,X0,Y,Y0);
            end
        end
    end

    % update M
    Mn = Fold(X{1}*Y{1},Nway,1);
    res(1) = norm(Mn(known)-data);
    M = alpha(1)*Mn;
    for n = 2:N
        if alpha(n) > 0
        Mn = Fold(X{n}*Y{n},Nway,n);
        res(n) = norm(Mn(known)-data);
        M = M+alpha(n)*Mn;
        end
    end

    % pass the true tensor M for evaluation
    if isfield(opts,'Mtr')
        Out.truerel(k) = norm(M(:)-opts.Mtr(:))/norm(opts.Mtr(:));
    end

    M(known) = data;

    TotalRes0 = TotalRes;
    TotalRes = 0;
    for n = 1:N
        if alpha(n) > 0
            TotalRes = TotalRes+res(n)^2;
        end
    end
    ratio = res./res0;   reschg = abs(1-ratio);

    if rank_inc_num > 0
        for n = 1:N
            if alpha(n) > 0
            if coreNway(n) < rank_max(n) && reschg(n) < reschg_tol
                %rank_inc_adaptive();
                rank_inc_adaptive(M,Y,n,Yt,Y0,coreNway,rank_max,rank_inc,rank_inc_num,nstall,X0,solX,Nway,coNway);
            end
            end
        end
    end

    % adaptively update weight

    if alpha_adj ~= 0
        alpha = 1./(res.^2); alpha = alpha/sum(alpha);
    end

    % record how the rank estimates are updated
    Out.rank = [Out.rank; coreNway];

    % --- diagnostics, reporting, stopping checks ---
    relerr1 = abs(TotalRes-TotalRes0)/(TotalRes0+1);
    relerr2 = sum(alpha.*res)/nrmb;

    % reporting
    Out.hist_rel(1,k) = relerr1;
    Out.hist_rel(2,k) = relerr2;

    % check stopping criterion
    crit = relerr1<tol;
    if crit; nstall = nstall+1; else nstall = 0; end
    if nstall>=3 || relerr2<tol break; end
    if toc(start_time)>maxT; break; end;

    X0 = X; Y0 = Y; M0 = M;
    res0 = res;
end % main
fprintf('\n'); Out.iter = k;
Out.alpha = alpha;

end


function Y = vanherk(X,N,TYPE,varargin)
%  VANHERK    Fast max/min 1D filter
%
%    Y = VANHERK(X,N,TYPE) performs the 1D max/min filtering of the row
%    vector X using a N-length filter.
%    The filtering type is defined by TYPE = 'max' or 'min'. This function
%    uses the van Herk algorithm for min/max filters that demands only 3
%    min/max calculations per element, independently of the filter size.
%
%    If X is a 2D matrix, each row will be filtered separately.
%
%    Y = VANHERK(...,'col') performs the filtering on the columns of X.
%
%    Y = VANHERK(...,'shape') returns the subset of the filtering specified
%    by 'shape' :
%        'full'  - Returns the full filtering result,
%        'same'  - (default) Returns the central filter area that is the
%                   same size as X,
%        'valid' - Returns only the area where no filter elements are outside
%                  the image.
%
%    X can be uint8 or double. If X is uint8 the processing is quite faster, so
%    dont't use X as double, unless it is really necessary.
%

% Initialization
[direc, shape] = parse_inputs(varargin{:});
if strcmp(direc,'col')
   X = X';
end
if strcmp(TYPE,'max')
   maxfilt = 1;
elseif strcmp(TYPE,'min')
   maxfilt = 0;
else
   error([ 'TYPE must be ' char(39) 'max' char(39) ' or ' char(39) 'min' char(39) '.'])
end

% Correcting X size
fixsize = 0;
addel = 0;
if mod(size(X,2),N) ~= 0
   fixsize = 1;
   addel = N-mod(size(X,2),N);
   if maxfilt
      f = [ X zeros(size(X,1), addel) ];
   else
      f = [X repmat(X(:,end),1,addel)];
   end
else
   f = X;
end
lf = size(f,2);
lx = size(X,2);
clear X

% Declaring aux. mat.
g = f;
h = g;

% Filling g & h (aux. mat.)
ig = 1:N:size(f,2);
ih = ig + N - 1;

g(:,ig) = f(:,ig);
h(:,ih) = f(:,ih);

if maxfilt
   for i = 2 : N
      igold = ig;
      ihold = ih;

      ig = ig + 1;
      ih = ih - 1;

      g(:,ig) = max(f(:,ig),g(:,igold));
      h(:,ih) = max(f(:,ih),h(:,ihold));
   end
else
   for i = 2 : N
      igold = ig;
      ihold = ih;

      ig = ig + 1;
      ih = ih - 1;

      g(:,ig) = min(f(:,ig),g(:,igold));
      h(:,ih) = min(f(:,ih),h(:,ihold));
   end
end
clear f

% Comparing g & h
if strcmp(shape,'full')
   ig = [ N : 1 : lf ];
   ih = [ 1 : 1 : lf-N+1 ];
   if fixsize
      if maxfilt
         Y = [ g(:,1:N-1)  max(g(:,ig), h(:,ih))  h(:,end-N+2:end-addel) ];
      else
         Y = [ g(:,1:N-1)  min(g(:,ig), h(:,ih))  h(:,end-N+2:end-addel) ];
      end
   else
      if maxfilt
         Y = [ g(:,1:N-1)  max(g(:,ig), h(:,ih))  h(:,end-N+2:end) ];
      else
         Y = [ g(:,1:N-1)  min(g(:,ig), h(:,ih))  h(:,end-N+2:end) ];
      end
   end

elseif strcmp(shape,'same')
   if fixsize
      if addel > (N-1)/2
         %disp('hoi')
         ig = [ N : 1 : lf - addel + floor((N-1)/2) ];
         ih = [ 1 : 1 : lf-N+1 - addel + floor((N-1)/2)];
         if maxfilt
            Y = [ g(:,1+ceil((N-1)/2):N-1)  max(g(:,ig), h(:,ih)) ];
         else
            Y = [ g(:,1+ceil((N-1)/2):N-1)  min(g(:,ig), h(:,ih)) ];
         end
      else
         ig = [ N : 1 : lf ];
         ih = [ 1 : 1 : lf-N+1 ];
         if maxfilt
            Y = [ g(:,1+ceil((N-1)/2):N-1)  max(g(:,ig), h(:,ih))  h(:,lf-N+2:lf-N+1+floor((N-1)/2)-addel) ];
         else
            Y = [ g(:,1+ceil((N-1)/2):N-1)  min(g(:,ig), h(:,ih))  h(:,lf-N+2:lf-N+1+floor((N-1)/2)-addel) ];
         end
      end
   else % not fixsize (addel=0, lf=lx)
      ig = [ N : 1 : lx ];
      ih = [ 1 : 1 : lx-N+1 ];
      if maxfilt
         Y = [  g(:,N-ceil((N-1)/2):N-1) max( g(:,ig), h(:,ih) )  h(:,lx-N+2:lx-N+1+floor((N-1)/2)) ];
      else
         Y = [  g(:,N-ceil((N-1)/2):N-1) min( g(:,ig), h(:,ih) )  h(:,lx-N+2:lx-N+1+floor((N-1)/2)) ];
      end
   end

elseif strcmp(shape,'valid')
   ig = [ N : 1 : lx];
   ih = [ 1 : 1: lx-N+1];
   if maxfilt
      Y = [ max( g(:,ig), h(:,ih) ) ];
   else
      Y = [ min( g(:,ig), h(:,ih) ) ];
   end
end

if strcmp(direc,'col')
   Y = Y';
end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
function [direc, shape] = parse_inputs(varargin)
direc = 'lin';
shape = 'same';
flag = [0 0]; % [dir shape]

for i = 1 : nargin
   t = varargin{i};
   if strcmp(t,'col') & flag(1) == 0
      direc = 'col';
      flag(1) = 1;
   elseif strcmp(t,'full') & flag(2) == 0
      shape = 'full';
      flag(2) = 1;
   elseif strcmp(t,'same') & flag(2) == 0
      shape = 'same';
      flag(2) = 1;
   elseif strcmp(t,'valid') & flag(2) == 0
      shape = 'valid';
      flag(2) = 1;
   else
      error(['Too many / Unkown parameter : ' t ])
   end
end


function C = curvature(DEM,ctype,varargin)

%CURVATURE 8-connected neighborhood curvature of a digital elevation model
%
% Syntax
%
%     C = curvature(DEM)
%     C = curvature(DEM,type)
%     C = curvature(DEM,type,pn,pv,...)
%
% Description
%
%     curvature returns the second numerical derivative (curvature) of a
%     digital elevation model. By default, curvature returns the profile
%     curvature (profc).
%
% Input arguments
%
%     DEM    digital elevation model (GRIDobj)
%     type   'profc' (default) : profile curvature [m^(-1)]
%            'planc' : planform curvature or contour curvature [m^(-1)]
%            'tangc' : tangential curvature [m^(-1)]
%            'meanc' : mean curvature [m^(-1)]
%            'total' : total curvature [m^(-2)]
%
%     Parameter name value/pairs
%
%     'useblockproc'    true or {false}: use block processing
%                       (see function blockproc)
%     'useparallel'     true or {false}: use parallel computing toolbox
%     'blocksize'       blocksize for blockproc (default: 5000)
%
% Output arguments
%
%     C      curvature (GRIDobj)
%
% Remarks
%
%     Please note that curvature is not defined for cells with zero
%     gradient. Here, curvature is set to zero.
%
%     All formulas are according to Schmidt et al. (2003) on page 800.
%
% Example
%
%     DEM = GRIDobj('srtm_bigtujunga30m_utm11.tif');
%     DEM = filter(DEM);
%     C = curvature(DEM,'planc');
%     imageschs(DEM,C,'percentclip',0.1)
%
% Reference
%
%     Schmidt, J., Evans, I.S., Brinkmann, J., 2003. Comparison of
%     polynomial models for land surface curvature calculation.
%     International Journal of Geographical Information Science 17,
%     797-814. doi:10.1080/13658810310001596058
%
% See also: GRIDobj/gradient8
%
% Author:  Wolfgang Schwanghart (w.schwanghart[at]geo.uni-potsdam.de)
% Date: 17. August, 2017

% check input arguments
narginchk(1,inf);
if nargin == 1
    ctype = 'profc';
else
    ctype = validatestring(ctype,{'profc','planc','tangc','meanc','total'});
end

p = inputParser;
p.FunctionName = 'GRIDobj/curvature';
addParamValue(p,'useblockproc',false,@(x) isscalar(x));
addParamValue(p,'blocksize',5000,@(x) isscalar(x));
addParamValue(p,'useparallel',false,@(x) isscalar(x));
parse(p,varargin{:});

% create a copy of the DEM instance
C = DEM;
c = class(DEM.Z);
switch c
    case 'double'
        C.Z = double.empty(0,0);
    otherwise
        C.Z = single.empty(0,0);
end

% Large matrix support. Break calculations in chunks using blockproc
% Parallisation for large grids using blockproc does in my experience with
% four cores hardly increase the speed.
if p.Results.useblockproc
    blksiz = bestblk(size(DEM.Z),p.Results.blocksize);
    cs  = C.cellsize;
    fun = @(x) curvaturesub(x,cs,ctype);
    C.Z = blockproc(DEM.Z,blksiz,fun,...
           'BorderSize',[1 1],...
           'Padmethod','symmetric',...
           'UseParallel',p.Results.useparallel);
else
    C.Z = curvaturesub(DEM.Z,C.cellsize,ctype);
end

C.name = ctype;

end
% subfunction

function curv = curvaturesub(dem,cs,ctype)

if isstruct(dem);
    dem = dem.data;
    % DEM has already been padded
    correctedges = false;
    shape = 'same';
else
    correctedges = true;
    shape = 'valid';
end

% First-order partial derivatives:
[fx,fy] = gradient(dem,cs);

if correctedges
    dem = padarray(dem,[1 1],'symmetric');
end
% Second order derivatives according to Evans method (see Olaya 2009)
%
% z1 z2 z3
% z4 z5 z6
% z7 z8 z9

% kernel for d2z/dx2
kernel = [1 -2 1; 1 -2 1; 1 -2 1]./(3*cs.^2);
fxx = conv2(dem,kernel,shape);
% kernel for d2z/dy2
kernel = kernel';
fyy = conv2(dem,kernel,shape);
% kernel for d2z/dxy
kernel = [-1 0 1; 0 0 0; 1 0 -1]./(4*cs.^2);
fxy = conv2(dem,kernel,shape);

%% Other options to calculate Second-order partial derivatives:
% r = gradient(p,cs);
% t = gradient(q',cs)';
% % Second-order mixed partial derivative:
% s = gradient(p',cs)';

switch ctype
    case 'profc'
        curv = - (fx.^2 .* fxx + 2*fx.*fy.*fxy + fy.^2.*fyy)./((fx.^2 + fy.^2).*(1 + fx.^2 + fy.^2).^(3/2));
    case 'tangc'
        curv = - (fy.^2 .* fxx + 2*fx.*fy.*fxy + fx.^2.*fyy)./((fx.^2 + fy.^2).*(1 + fx.^2 + fy.^2).^(1/2));
    case 'planc'
        curv = - (fy.^2 .* fxx + 2*fx.*fy.*fxy + fx.^2.*fyy)./((fx.^2 + fy.^2).^(3/2));
    case 'meanc'
        curv = - ((1+fy.^2).*fxx - 2.*fxy.*fx.*fy + (1+fx.^2).*fyy)./ ...
            (2.* (fx.^2+fy.^2+1).^(3/2));
%         curv = (fx.^2 .* fxx + 2*fx.*fy.*fxy + fy.^2.*fyy)./((fx.^2 + fy.^2).*(1 + fx.^2 + fy.^2)) ...
%             - ((1+fy).^2 .* fxx + 2*fx.*fy.*fxy + (1+fx).^2.*fyy)./(2.*(1 + fx.^2 + fy.^2).^(3/2));
    case 'total'
        curv = fxx.^2 + 2*fxy.^2+fyy.^2;
end

if correctedges
    dem = dem(2:end-1,2:end-1);
end
curv(isinf(curv) | isnan(curv)) = 0;
curv(isnan(dem)) = nan;
curv = reshape(curv,size(dem));

end


function [ x, y ] = srot ( n, x, incx, y, incy, c, s )

%*****************************************************************************80
%
%% SROT applies a plane rotation.
%
%  Licensing:
%
%    This code is distributed under the GNU LGPL license.
%
%  Modified:
%
%    09 November 2006
%
%  Author:
%
%    MATLAB version by John Burkardt.
%
%  Reference:
%
%    Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart,
%    LINPACK User's Guide,
%    SIAM, 1979.
%
%    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
%    Basic Linear Algebra Subprograms for Fortran Usage,
%    Algorithm 539,
%    ACM Transactions on Mathematical Software,
%    Volume 5, Number 3, September 1979, pages 308-323.
%
%  Parameters:
%
%    Input, integer N, the number of entries in the vectors.
%
%    Input, real X(*), one of the vectors to be rotated.
%
%    Input, integer INCX, the increment between successive entries of X.
%
%    Input, real Y(*), one of the vectors to be rotated.
%
%    Input, integer INCY, the increment between successive elements of Y.
%
%    Input, real C, S, parameters (presumably the cosine and
%    sine of some angle) that define a plane rotation.
%
%    Output, real X(*), the rotated vector.
%
%    Output, real Y(*), the rotated vector.
%
  if ( n <= 0 )

    x = [];
    y = [];

  elseif ( incx == 1 & incy == 1 )

    for i = 1 : n
      stemp = c * x(i) + s * y(i);
      y(i) =  c * y(i) - s * x(i);
      x(i) = stemp;
    end

  else

    if ( 0 <= incx )
      ix = 1;
    else
      ix = ( - n + 1 ) * incx + 1;
    end

    if ( 0 <= incy )
      iy = 1;
    else
      iy = ( - n + 1 ) * incy + 1;
    end

    for i = 1 : n
      stemp = c * x(ix) + s * y(iy);
      y(iy) = c * y(iy) - s * x(ix);
      x(ix) = stemp;
      ix = ix + incx;
      iy = iy + incy;
    end

  end

  return
end


function F = airy(K, F, scale, pref)
%AIRY   Airy function of a CHEBFUN.
%   AIRY(F) returns the Airy function Ai(F) of a CHEBFUN F.
%
%   AIRY(K, F) returns various Airy functions specified by K:
%     0 - (default) is the same as airy(Z)
%     1 - returns the derivative, Ai'(Z)
%     2 - returns the Airy function of the second kind, Bi(Z)
%     3 - returns the derivative, Bi'(Z)
%
%   AIRY(K, F, SCALE) returns a scaled AIRY(K, F) specified by SCALE:
%     0 - (default) is that same as AIRY(K, Z)
%     1 - returns airy(K, F) scaled by EXP(2/3*F.^(3/2)) for K = 0, 1,
%         and scaled by EXP(-ABS(2/3.*REAL(F.^(3/2)))) for K = 2, 3.
%
% See also BESSELJ.

% Copyright 2017 by The University of Oxford and The Chebfun Developers.
% See http://www.chebfun.org/ for Chebfun information.

% Parse the inputs as described in help text:
if ( nargin == 1 )
    F = K;
    K = 0;
    pref = chebfunpref();
end
if ( nargin < 3 )
    scale = 0;
    pref = chebfunpref();
end
if ( nargin == 3 )
    if ( isa(scale, 'chebfunpref') )
        pref = scale;
        scale = 0;
    else
        pref = chebfunpref;
    end
end

for k = 1:numel(F)
    F(k) = columnAiry(K, F(k), scale, pref);
end

end

function g = columnAiry(K, f, scale, pref)

% The standard Airy function:
g = compose(f, @(x) airy(K, x), [], pref);

if ( scale == 0 )
    % Standard case (no scaling).

elseif ( (scale == 1) && ((K == 0) || (K == 1)) )
    % Scaled with k = 1, 2:
    scl = exp(2/3*f.^(3/2));
    g = scl.*g;

elseif ( (scale == 1) && ((K == 2) || (K == 3)) )
    % Scaled with k = 2, 3:
    scl = exp(-abs(2/3*real(f.^(3/2))));
    g = scl.*g;

else
    % Invalid parameter sequence:
    error('CHEBFUN:CHEBFUN:airy:params', 'Invalid paramter selection.');

end

end


function [y] = spm_fx_lz(x,u,P)
% flow for Lorenz attractor
% FORMAT [y] = spm_fx_lz(x,u,P)
% x - state
% u - input
% P - parameters
%__________________________________________________________________________
% Copyright (C) 2008 Wellcome Trust Centre for Neuroimaging

% Karl Friston
% $Id: spm_fx_lz.m 1961 2008-07-26 09:38:46Z karl $

% flow for Lorenz attractor
%--------------------------------------------------------------------------
try
    P(3) = P(3)*(1 + u);
end
J    = [-P(1) P(1) 0; (P(3) - x(3)) -1 -x(1); x(2) x(1) P(2)];
y    = J*x;


function [ttm] = tt_Fd_mtx2(tt_a, bound1, bound2, eps)
%TT-representation of the diffusion matrix
%   [TTM] = TT_FD_MTX2(TT_A, BOUND1, BOUND2, EPS) Computes TT
%   representation of a simplest discretization of the diffusion operator
%   with operator given in the QTT-format (TT_A).
%
%
% TT-Toolbox 2.2, 2009-2012
%
%This is TT Toolbox, written by Ivan Oseledets et al.
%Institute of Numerical Mathematics, Moscow, Russia
%webpage: http://spring.inm.ras.ru/osel
%
%For all questions, bugs and suggestions please mail
%ivan.oseledets@gmail.com
%---------------------------

d = size(tt_a, 1);
n = zeros(1,d);
for q=1:d
    n(q)=size(tt_a{q}, 1);
end;

if (max(size(bound1))==1) bound1 = bound1*ones(1,d); end;
if (max(size(bound2))==1) bound2 = bound2*ones(1,d); end;

ranks_a = tt_ranks(tt_a);

for q=1:d
    cur_tt = cell(d,1);

    cur_tt{1}=zeros(n(1),n(1),ranks_a(1));
    for k=1:ranks_a(1)
            lp1 = diag(-1*ones(n(1)-1,1), [-1])+diag(2*ones(n(1), 1), [0])+diag(-1*ones(n(1)-1,1), [1]);
            Mp1 = diag((1/6)*ones(n(1)-1,1), [-1])+diag((4/6)*ones(n(1), 1), [0])+diag((1/6)*ones(n(1)-1,1), [1]);
            if (bound1(1)==1) lp1(1,1)=1; end;
            if (bound2(1)==1) lp1(n(1),n(1))=1; end;
            h = 1/(n(1)+1);
            if ((bound1(1)==1)||(bound2(1)==1)) h = 1/n(1); end;
            if ((bound1(1)==1)&&(bound2(1)==1)) h = 1/(n(1)-1); end;
            Mlp1 = diag(tt_a{1}(2:n(1),k), [-1])+diag(tt_a{1}(2:n(1),k), [1]);
            Mlp1 = Mlp1 + diag(tt_a{1}(1:n(1),k)+[tt_a{1}(2:n(1),k)' tt_a{1}(n(1),k)]', [0])*0.5;
        if (q==1)
            cur_tt{1}(:,:,k) = Mlp1.*(lp1/h^2);
        else
            cur_tt{1}(:,:,k) = Mlp1.*Mp1;
%             cur_tt{1}(:,:,k) = diag(tt_a{1}(1:n(1),k)+[tt_a{1}(2:n(1),k)' tt_a{1}(n(1),k)]', [0])*0.5;
        end;
    end;

    for p=2:d-1
        cur_tt{p}=zeros(n(p),n(p),ranks_a(p-1),ranks_a(p));
        for k1=1:ranks_a(p-1)
            for k2=1:ranks_a(p)
                    lp1 = diag(-1*ones(n(p)-1,1), [-1])+diag(2*ones(n(p), 1), [0])+diag(-1*ones(n(p)-1,1), [1]);
                    Mp1 = diag((1/6)*ones(n(1)-1,1), [-1])+diag((4/6)*ones(n(1), 1), [0])+diag((1/6)*ones(n(1)-1,1), [1]);
                    if (bound1(p)==1) lp1(1,1)=1; end;
                    if (bound2(p)==1) lp1(n(p),n(p))=1; end;
                    h = 1/(n(p)+1);
                    if ((bound1(p)==1)||(bound2(p)==1)) h = 1/n(p); end;
                    if ((bound1(p)==1)&&(bound2(p)==1)) h = 1/(n(p)-1); end;
                    Mlp1 = diag(tt_a{p}(2:n(p),k1,k2), [-1])+diag(tt_a{p}(2:n(p),k1,k2), [1]);
                    Mlp1 = Mlp1 + diag(tt_a{p}(1:n(p),k1,k2)+[tt_a{p}(2:n(p),k1,k2)' tt_a{p}(n(p),k1,k2)]', [0])*0.5;
                if (p==q)
                    cur_tt{p}(:,:,k1,k2) = Mlp1.*(lp1/h^2);
                else
                    cur_tt{p}(:,:,k1,k2) = Mlp1.*Mp1;
%                     cur_tt{p}(:,:,k1,k2) = diag(tt_a{p}(1:n(p),k1,k2)+[tt_a{p}(2:n(p),k1,k2)' tt_a{p}(n(p),k1,k2)]', [0])*0.5;
                end;
            end;
        end;
    end;

    cur_tt{d}=zeros(n(d),n(d),ranks_a(d-1));
    for k=1:ranks_a(d-1)
            lp1 = diag(-1*ones(n(d)-1,1), [-1])+diag(2*ones(n(d), 1), [0])+diag(-1*ones(n(d)-1,1), [1]);
            Mp1 = diag((1/6)*ones(n(1)-1,1), [-1])+diag((4/6)*ones(n(1), 1), [0])+diag((1/6)*ones(n(1)-1,1), [1]);
            if (bound1(d)==1) lp1(1,1)=1; end;
            if (bound2(d)==1) lp1(n(d),n(d))=1; end;
            h = 1/(n(d)+1);
            if ((bound1(d)==1)||(bound2(d)==1)) h = 1/n(d); end;
            if ((bound1(d)==1)&&(bound2(d)==1)) h = 1/(n(d)-1); end;
            Mlp1 = diag(tt_a{d}(2:n(d),k), [-1])+diag(tt_a{d}(2:n(d),k), [1]);
            Mlp1 = Mlp1 + diag(tt_a{d}(1:n(d),k)+[tt_a{d}(2:n(d),k)' tt_a{d}(n(d),k)]', [0])*0.5;
        if (q==d)
            cur_tt{d}(:,:,k) = Mlp1.*(lp1/h^2);
        else
            cur_tt{d}(:,:,k) = Mlp1.*Mp1;
%             cur_tt{d}(:,:,k) = diag(tt_a{d}(1:n(d),k)+[tt_a{d}(2:n(d),k)' tt_a{d}(n(d),k)]', [0])*0.5;
        end;
    end;

    if (q==1)
        ttm = cur_tt;
    else
        ttm = ttm_add(ttm, cur_tt);
        ttm = tt_mat_compr(ttm, eps);
    end;
end;

end


function [ x, tan, status ] = p00_limit ( problem, option, nvar, x1, tan1, ...
  x2, tan2, lim )

%*****************************************************************************80
%
%% P00_LIMIT seeks a limit point.
%
%  Discussion:
%
%    For a given index 1 <= LIM <= NVAR, a limit point X is a point which
%    satisfies F(X) = 0 and TAN(X)(LIM) = 0, that is, X is a point on the
%    solution curve, and the LIM-th component of the tangent vector at X
%    is zero.
%
%    This function may be called if a limit point has been bracketed,
%    that is, if X1 and X2 are points on the curve with the property that
%    there is a change in sign in the LIM-th component of the tangent
%    vector between X1 and X2.
%
%    The function carries out an iteration seeking a point X between
%    X1 and X2 for which the LIM-th tangent component is zero.
%
%  Licensing:
%
%    This code is distributed under the GNU LGPL license.
%
%  Modified:
%
%    15 October 2008
%
%  Author:
%
%    John Burkardt
%
%  Parameters:
%
%    Input, integer PROBLEM, the problem index.
%
%    Input, integer OPTION, the option index.
%
%    Input, integer NVAR, the number of variables.
%
%    Input, real X1(NVAR), TAN1(NVAR), a point on the curve,
%    and its tangent vector.
%
%    Input, real X2(NVAR), TAN2(NVAR), a second point on the curve,
%    and its tangent vector.
%
%    Input, integer LIM, the index of the entry of TAN which
%    we are seeking to zero.
%
%    Output, real X(NVAR), TAN(NVAR), the computed limit point
%    and its tangent vector.
%
%    Output, integer STATUS.
%    nonnegative, the limit point was computed in STATUS steps.
%    negative, the limit point could not be computed.
%
  VERBOSE = 0;
%
%  Use a fixed parameter index, but do NOT use LIM.
%
  x = x2 - x1;
  x(lim) = 0.0;
  par_index = r8vec_amax_index ( nvar, x );
%
%  Start the zero finding process.
%
  a = 0.0;
  b = 1.0;
  tol = sqrt ( eps );
  arg = 0.0;
  status_zero = 0;
  value = 0.0;

  status = 0;

  while ( 1 )

    [ arg, status_zero ] = zero_rc ( a, b, tol, value, status_zero );

    if ( status_zero < 0 )
      status = -1;
      fprintf ( 1, '\n' );
      fprintf ( 1, 'P00_LIMIT - Fatal error!\n' );
      fprintf ( 1, '  ZERO_RC returned an error flag.\n' );
      break
    end

    if ( arg == 0.0 )

      x = x1;
      tan = tan1;

    elseif ( arg == 1.0 )

      x = x2;
      tan = tan2;

    else

      x = ( 1.0 - arg ) * x1 ...
          +       arg   * x2;

      [ x, status_newton ] = p00_newton ( problem, option, nvar, x, par_index );

      if ( status_newton < 0 )
        status = -2;
        fprintf ( 1, '\n' );
        fprintf ( 1, 'P00_LIMIT - Fatal error!\n' );
        fprintf ( 1, '  ZERO_RC returned an error flag.\n' );
        break
      end

      tan = p00_tan ( problem, option, nvar, x );

    end

    value = tan(lim);

    if ( VERBOSE )
      fprintf ( 1, '  %8d  %14e  %14e\n', status_zero, arg, value );
    end

    status = status + 1;

    if ( status_zero == 0 )
      break
    end

  end

  return
end


% This is material illustrating the methods from the book
% Financial Modelling  - Theory, Implementation and Practice with Matlab
% source
% Wiley Finance Series
% ISBN 978-0-470-74489-5
%
% Date: 02.05.2012
%
% Authors:  Joerg Kienitz
%           Daniel Wetterau
%
% Please send comments, suggestions, bugs, code etc. to
% kienitzwetterau_FinModelling@gmx.de
%
% (C) Joerg Kienitz, Daniel Wetterau
%
% Since this piece of code is distributed via the mathworks file-exchange
% it is covered by the BSD license
%
% This code is being provided solely for information and general
% illustrative purposes. The authors will not be responsible for the
% consequences of reliance upon using the code or for numbers produced
% from using the code.

function [price, se, low, high] ...
    = LongstaffSchwartz_M2(S, M, Ns, g, df, f, B, Nr, NSim, level)
% Longstaff Schwartz method for pricing american options

v = g(:,end);   % start for backward induction

% backward induction and regression from t_{Nr-1} up to t_1
for i = Nr-1:-1:1
        index = find(g(:,i+1) > 0); % all ITM paths
        s = S(index,i+1);           % values of S at given time points
        m = M(index,i+1);           % values of M at given time points
        v = v * df(i+1);            % option value at t_i

        Acell = B(s,m);             % evaluate basis function in cell array B
        A = cell2mat(Acell{:,:});   % convert to matrix

        c = A*f(:,i);                   % continuation value
        exercise = g(index,i+1) >= c;    % early exercise
        v(index(exercise)) = g(index(exercise),i+1);
end

price = mean(v * df(1));    % final option value

% standard error and confidence interval
sv = sqrt(1/(NSim-1)*sum((v - price * ones(NSim,1)).^2));
se = sv/sqrt(NSim);
low =  price - norminv(level) * sv/sqrt(NSim);
high = price + norminv(level) * sv/sqrt(NSim);

end


function [h,Hf,Hh] = fromFrameHmg(f,hf)

% FROMFRAMEHMG  Fom-frame transformation for homogeneous coordinates
%   P = FROMFRAMEHMG(F,PF) transforms homogeneous point PF from frame F to
%   the global frame.
%
%   [p,Pf,Ppf] = ... returns the Jacobians wrt F and PF.

%   Copyright 2008-2009 Joan Sola @ LAAS-CNRS.

F = homogeneous(f)    ;
[t,q] = splitFrame(f) ;

h = F*hf;

if nargout > 1

    [a,b,c,d] = split(q);
    [hx,hy,hz,ht] = split(hf);

    Ht = [...
        [ ht,  0,  0]
        [  0, ht,  0]
        [  0,  0, ht]
        [  0,  0,  0]];
    Hq = [...
        [  2*a*hx-2*d*hy+2*c*hz,  2*b*hx+2*c*hy+2*d*hz, -2*c*hx+2*b*hy+2*a*hz, -2*d*hx-2*a*hy+2*b*hz]
        [  2*d*hx+2*a*hy-2*b*hz,  2*c*hx-2*b*hy-2*a*hz,  2*b*hx+2*c*hy+2*d*hz,  2*a*hx-2*d*hy+2*c*hz]
        [ -2*c*hx+2*b*hy+2*a*hz,  2*d*hx+2*a*hy-2*b*hz, -2*a*hx+2*d*hy-2*c*hz,  2*b*hx+2*c*hy+2*d*hz]
        [                     0,                     0,                     0,                     0]];

    Hf = [Ht Hq];
    Hh = F;

end

return

% ========== End of function - Start GPL license ==========

%   # START GPL LICENSE

%---------------------------------------------------------------------
%
%   This file is part of SLAMTB, a SLAM toolbox for Matlab.
%
%   SLAMTB 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.
%
%   SLAMTB 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 SLAMTB.  If not, see <http://www.gnu.org/licenses/>.
%
%---------------------------------------------------------------------

%   SLAMTB is Copyright:
%   Copyright (c) 2008-2010, Joan Sola @ LAAS-CNRS,
%   Copyright (c) 2010-2013, Joan Sola,
%   Copyright (c) 2014-2015, Joan Sola @ IRI-UPC-CSIC,
%   SLAMTB is Copyright 2009
%   by Joan Sola, Teresa Vidal-Calleja, David Marquez and Jean Marie Codol
%   @ LAAS-CNRS.
%   See on top of this file for its particular copyright.

%   # END GPL LICENSE


function [ point, seed ] = p08_sample ( m, n, seed )

%*****************************************************************************80
%
%% P08_SAMPLE samples points from the region in problem 08.
%
%  Discussion:
%
%    A rejection method is used.
%
%  Licensing:
%
%    This code is distributed under the GNU LGPL license.
%
%  Modified:
%
%    12 April 2009
%
%  Author:
%
%    John Burkardt
%
%  Parameters:
%
%    Input, integer M, the spatial dimension.
%
%    Input, integer N, the number of points.
%
%    Input/output, integer SEED, a seed for the random number generator.
%
%    Output, real POINT(M,N), the coordinates
%    of the points.
%
  batch = 1000;

  [ lo, hi ] = p08_box ( m );

  have = 0;
%
%  We are going to generate batches of sample points.
%
  sample_num = min ( batch, n );

  reject = 0;

  while ( 1 )
%
%  Generate a batch of points in the bounding box.
%
    sample(1:m,1:sample_num) = rand ( m, sample_num );
%
%  Remap the points to the box.
%
    sample(1,1:sample_num) = lo(1) + sample(1,1:sample_num) * ( hi(1) - lo(1) );
    sample(2,1:sample_num) = lo(2) + sample(2,1:sample_num) * ( hi(2) - lo(2) );

    inside(1:sample_num) = p08_inside ( m, sample_num, sample );
%
%  Accept those points which are inside the region.
%
    for j = 1 : sample_num

      if ( inside(j) )

        have = have + 1;
        point(1:m,have) = sample(1:m,j);

        if ( have == n )
          return
        end

      else

        reject = reject + 1;

      end

    end

    if ( 10 * n < reject )
      fprintf ( 1, '\n' );
      fprintf ( 1, 'P08_SAMPLE - Fatal error!\n' );
      fprintf ( 1, '  Too many points rejected!\n' );
      fprintf ( 1, '\n' );
      fprintf ( 1, '  Total number of accepted points = %d\n', have );
      fprintf ( 1, '\n' );
      fprintf ( 1, '  Number generated on this sweep =  %d\n', sample_num );
      fprintf ( 1, '  Number accepted =                 %d\n', ...
        sample_num - reject );
      fprintf ( 1, '  Number rejected =                 %d\n', reject );
      fprintf ( 1, '\n' );
      fprintf ( 1, '  Something appears to be wrong!\n' );
      error ( 'P08_SAMPLE - Fatal error!' );
    end

  end

  return
end


% This is material illustrating the methods from the book
% Financial Modelling  - Theory, Implementation and Practice with Matlab
% source
% Wiley Finance Series
% ISBN 978-0-470-74489-5
%
% Date: 02.05.2012
%
% Authors:  Joerg Kienitz
%           Daniel Wetterau
%
% Please send comments, suggestions, bugs, code etc. to
% kienitzwetterau_FinModelling@gmx.de
%
% (C) Joerg Kienitz, Daniel Wetterau
%
% Since this piece of code is distributed via the mathworks file-exchange
% it is covered by the BSD license
%
% This code is being provided solely for information and general
% illustrative purposes. The authors will not be responsible for the
% consequences of reliance upon using the code or for numbers produced
% from using the code.

function [price_pi, se, conflevel_low, conflevel_high] = ...
    PIter_E(S, g, K, r, T, sigma, Nr, NSim, NSSim, type, getpaths, payoff)
% policy iteration using European options

% S: Path set
% K: Strike for analytic pricing
% r: riskless rate for analytic pricing
% T: Laufzeit der Option in Jahren
% sigma: volatility for analytic pricing
% NSim: number of simulations
% NSSim: number of simulations for sub-simulation
% type: 0 -> put, 1 -> call

dt = T/Nr;              % equidistant spacing
tau = Nr*ones(NSim,1);  % exercise rule for each path
iVec = (1:NSim)';       % index vector
for i = 1:Nr-1
    i_nexercise = tau == Nr;        % only ex if not already done
    % paths (realisation) where the stopping rule needs improvement
    I_nexercise = iVec(i_nexercise);

    price = BlackScholesPrice(S(i_nexercise,i+1), K, r, (1:Nr-i)'*dt,...
        sigma, type);                      % analytic price
    exbound = max(price,[],2);             % ex decision
    isubsim = g(i_nexercise,i) >= exbound; % index set indicating subsim

    if sum(I_nexercise(isubsim)) ~= 0       % if necessary
        Indicator = subsimulation(S(I_nexercise(isubsim),i+1), K, r, sigma, ...
            dt, NSSim, Nr-i, type,getpaths, payoff); % subsim

        Ind = iVec(I_nexercise(isubsim)); % index: payoff >= current rule
        % exercised befor this time? Use Indicator
        ind2 = g(I_nexercise(isubsim),i) >= Indicator; % ind: at ind2 and q
        Ind2 = iVec(ind2);                              % ind set for ind2
        if sum(ind2) ~= 0
            tau(Ind(Ind2)) = i; % final exercise
        end
    end
end

f = zeros(NSim,1); % sum payoffs for exercise times
for j = 1:NSim
    f(j) = g(j,tau(j));
end
price_pi = mean(f .* exp(-r*dt*tau));

sv = sqrt(1/(NSim-1)*sum((f*100 - price_pi * ones(NSim,1)).^2));
se = sv/sqrt(NSim);
conflevel_low = price_pi - 1.96 * sv/sqrt(NSim);
conflevel_high = price_pi + 1.96 * sv/sqrt(NSim);

end

function [price_local] = subsimulation(S, K, r, sigma, dt, NSim, Nr, type, getpaths, payoff)
    lenS = length(S);           % length of the path set S
    iVec = (1:NSim)';           % index set
    S2 = getpaths(S,NSim,Nr);   % new path set
    g2 = payoff(S2(:,2:end,:)); % evaluate option on path set S2

    price_local = zeros(lenS, 1);

    for k = 1:lenS
        payoff = zeros(NSim, Nr);
        for i=1:1:Nr-1
            for z=i:1:Nr-1
                i_nexercise = payoff(:,i) == 0; % check if exercised
                I_nexercise = iVec(i_nexercise);

                price = BlackScholesPrice(S2(I_nexercise,z,k),K,r, ...
                    (1:Nr-z)'*dt,sigma,type);       % analytic price
                exbound=max(price,[],2);            % bound for exercise

                exercise = g2(i_nexercise,z,k) >= exbound; % exercise
                payoff(I_nexercise(exercise),i) = ...
                    g2(I_nexercise(exercise),z,k) * exp(-r*dt*z);

            end

            finalexercise = payoff(:,i) == 0;   % finally not exercised
            payoff(finalexercise,i) = g2(finalexercise,Nr,k) ...
                * exp(-r*dt*Nr);                % final exercise

        end
        payoff(:,Nr) = g2(:,Nr,k) * exp(-r*dt*Nr);
        price_local(k) = max(mean(payoff));
    end

end


 function [alpha, beta, ok] = nufft_best_alpha(J, L, K_N)
%function [alpha, beta, ok] = nufft_best_alpha(J, L, K_N)
%
%	return previously numerically optimized alpha and beta
%	use L=0 to return best available choice of any L
%
%	Copyright 2001-12-17	Jeff Fessler	The University of Michigan

if nargin < 1, help(mfilename), error(mfilename), end
if nargin < 2, L=2; end
if nargin < 3, K_N=2; end

Jlist1 = 6;		% list of which J's
alpha1 = [...		% last colum is best beta
	1 -0.46		0.19;	% J=6
];

Jlist2 = 2:10;		% list of which J's
alpha2 = [...		% last colum is best beta
	1 -0.200 -0.04	0.34;	% J=2
	1 -0.485 0.090	0.48;
	1 -0.470 0.085	0.56;	% J=4
	1 -0.4825 0.12	0.495;
	1 -0.57 0.14	0.43;	% J=6
	1 -0.465 0.07	0.65;
	1 -0.540 0.16	0.47;	% J=8
	1 -0.625 0.14	0.325;	% J=9
	1 -0.57 0.185	0.43;	% J=10 5.9707e-07
];

Jlist3 = [4 6];		% list of which J's
alpha3 = [...		% last colum is best beta
	1 -0.5319 0.1522 -0.0199	0.6339;	% J=4 2.5953e-04
	1 -0.6903 0.2138 -0.0191	0.2254;	% J=6 1.0097e-04
];

if K_N == 2

	if L==0
		if any(J == Jlist3)
			L = 3;
		else
			L = 2;
		end	% current best
	end

	if L==1
		alpha = alpha1;
		Jlist = Jlist1;

	elseif L==2
		alpha = alpha2;
		Jlist = Jlist2;

	elseif L==3
		alpha = alpha3;
		Jlist = Jlist3;

	else
		warning 'L not done'
		alpha = nan;
		beta = nan;
		ok = 0;
		return
	end

else
	warning 'K_N not done'
	alpha = 1;
	beta = 0.5;
	ok = logical(1);
	return
end

if any(J == Jlist)
	j = find(J == Jlist);
	beta = alpha(j,end);
	alpha = alpha(j,1:(end-1));
	ok = logical(1);
else
	ok = logical(0);
	alpha = nan;
	beta = nan;
end


function x = rotatearound(x0,theta,mu)

[n1,n2] = size(x0);
[m1,m2] = size(mu);
theta = -theta;
R = [cos(theta),  sin(theta),
     -sin(theta), cos(theta)];
didflip = false;
if n1 ~= 2 & n2 == 2,
  x0 = x0';
  n2 = n1;
  didflip = true;
end;
if m1 ~= 2 & m2 == 2,
  mu = mu';
  m2 = m1;
end;

if m2 ~= n2,
  mu = repmat(mu(:,1),[1,n2]);
end;

x = R * (x0 - mu) + mu;
if didflip,
  x = x';
end


function [parent] = multiNonUnifMutation(parent,bounds,Ops)
% Multi-Non uniform mutation changes all of the parameters of the parent
% based on a non-uniform probability distribution.  This Gaussian
% distribution starts wide, and narrows to a point distribution as the
% current generation approaches the maximum generation.
%
% function [newSol] = multiNonUnifMutate(parent,bounds,Ops)
% parent  - the first parent ( [solution string function value] )
% bounds  - the bounds matrix for the solution space
% Ops     - Options for multiNonUnifMutation
%          [gen #MultiNonUnifMutations maxGen b]

% Binary and Real-Valued Simulation Evolution for Matlab
% Copyright (C) 1996 C.R. Houck, J.A. Joines, M.G. Kay
%
% C.R. Houck, J.Joines, and M.Kay. A genetic algorithm for function
% optimization: A Matlab implementation. ACM Transactions on Mathmatical
% Software, Submitted 1996.
%
% This program 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 1, or (at your option)
% any later version.
%
% This program 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. A copy of the GNU
% General Public License can be obtained from the
% Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

cg=Ops(1); 				% Current Generation
mg=Ops(3); 				% Maximum Number of Generations
b=Ops(4);                               % Shape parameter
df = bounds(:,2) - bounds(:,1); 	% Range of the variables
numVar = size(parent,2)-1; 		% Get the number of variables
% Now mutate that point
md = round(rand(1,numVar));
for i = 1:numVar
  if md(i)
    parent(i)=parent(i)+delta(cg,mg,bounds(i,2)-parent(i),b);
  else
    parent(i)=parent(i)-delta(cg,mg,parent(i)-bounds(i,1),b);
  end
end


% Reflective multivariate slice sampling

function [func, fx] = mcmc_init_reflective(x_init, get_logpdf, get_dlogpdf, ...
                                           epsilon, L, varargin)

options = struct( ...
    'fx',    @func_x_default, ...
    'type',  'inside');
% $$$     'y',     @(x) x,  ...        % transform the variable
% $$$     'logdy', @(x) 0,  ...        % log-jacobi of the transformation
% $$$     'dy',    @(x) 1,  ...
% $$$     'ddy',   @(x) 0,  ...
% $$$     'f',     @(y, varargin) []); % function for making pre-evaluations for logpdf

% Parse arguments
[options, errmsg] = argparse( options, varargin{:} );
error(errmsg);

% Initialization
x_current = x_init;
[fx_current, dfx_current] = options.fx(x_current);
logpdf_current = get_logpdf(fx_current);

fx = fx_current;

x_proposal = x_current;

switch options.type

 case 'outside'
  func = @reflective_outside;

 case 'inside'
  func = @reflective_inside;

 case default
  error('Unknown type for slice sampling');

end

  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function [x, fx] = reflective_inside(varargin)
  x_trajectory = x_current;
  fx_trajectory = fx_current;
  dfx_trajectory = dfx_current;
  logpdf_trajectory = logpdf_current;
  lp_trajectory = logpdf_current(varargin{:});

  % Momentum stuff
  step = exprnd(epsilon); % step length
  p = randn(size(x_current));

  %traj = [];

  % Simulate N steps
  for n=1:L

    if mod(n-1,ceil(L/10)) == 0
      % Update the slice
      lp_slice = lp_trajectory + log(rand());
    end

    % Move a step forward
    x_proposed = x_trajectory + step*p;
    % Check whether the new point is inside the slice
    [fx_proposed, dfx_proposed] = options.fx(x_proposed);
    logpdf_proposed = get_logpdf(fx_proposed);
    lp_proposed = logpdf_proposed(varargin{:});
    if lp_proposed <= lp_slice
      % Reflect based on the gradient at the inside point

      % Get the gradient
      dlogpdf = get_dlogpdf(dfx_trajectory);
      g = dlogpdf(varargin{:});

      % New momentum
      g2 = g'*g;
      if g2 > 0
        p = p - (2*(p'*g)/g2)*g;
      else
        % Random or opposite direction?
        p = -p;%orth(randn(numel(p))) * p;
      end

      % Check the reflected point is inside the slice
      x_reflect = x_trajectory + step*p;
      [fx_reflect, dfx_reflect] = options.fx(x_reflect);
      logpdf_reflect = get_logpdf(fx_reflect);
      lp_reflect = logpdf_reflect(varargin{:});
      if lp_reflect <= lp_slice
        disp('Reject trajectory')
        % TODO: Should I keep the state or ignore
        x = x_current;
        fx = fx_current;
        %x = nan;
        %fx = nan;
        return
      end

      %
      % TODO: HOW TO REQUEST THE GRADIENT?!?!?!!!!
      %

      % Verify opposite direction
      x_verify = x_trajectory - step*p;
      fx_verify = options.fx(x_verify);
      logpdf_verify = get_logpdf(fx_verify);
      lp_verify = logpdf_verify(varargin{:});
      if lp_verify > lp_slice
        disp('Reject trajectory')
        % TODO: Should I keep the state or ignore
        x = x_current;
        fx = fx_current;
        %x = nan;
        %fx = nan;
        return
      end

      % Accept the reflected step
      %disp('Reflect')
      x_trajectory = x_reflect;
      fx_trajectory = fx_reflect;
      dfx_trajectory = dfx_reflect;
      lp_trajectory = lp_reflect;
      logpdf_trajectory = logpdf_reflect;

    else

      % Accept the forward step
      x_trajectory = x_proposed;
      fx_trajectory = fx_proposed;
      dfx_trajectory = dfx_proposed;
      lp_trajectory = lp_proposed;
      logpdf_trajectory = logpdf_proposed;

    end
%    traj = [traj, x_trajectory];
  end

% $$$   figure
% $$$   plot(traj(1,:),traj(2,:), 'kx-');
% $$$   % Plot contours
% $$$   v = axis();
% $$$   vx = linspace(v(1), v(2), 20);
% $$$   vy = linspace(v(3), v(4), 10);
% $$$   [VY,VX] = meshgrid(vy,vx);
% $$$   V = [VX(:), VY(:)]';
% $$$   F = zeros(size(VX));
% $$$   for n=1:numel(F)
% $$$     logpdf = get_logpdf(V(:,n));
% $$$     F(n) = logpdf();
% $$$   end
% $$$   hold on
% $$$   contour(VX,VY,reshape(F,size(VX)));
% $$$   error('jou')

  disp('Accept trajectory')
  x_current = x_trajectory;
  fx_current = fx_trajectory;
  dfx_current = dfx_trajectory;
  logpdf_current = logpdf_trajectory;

  x = x_current;
  fx = fx_current;
  end

  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  function [y, fy] = reflective_outside(varargin)
  disp('Check gradient')
  mycheckgrad(@helper, x_current, 1e-6)
  error('Stopped because wanted to check gradients')
    function [f, df] = helper(x)
    [fx, dfx] = options.fx(x);
    logpdf = get_logpdf(fx);
    dlogpdf = get_dlogpdf(dfx);
    f = logpdf(varargin{:});
    df = dlogpdf(varargin{:});
    end
  end

end

function [fx, dfx] = func_x_default(x)
fx = x;
dfx = x;
end


function [hd_record,hd_estimates]=panel6hd(Xi,theta_gibbs,D_record,strshocks_record,It,Bu,Ymat,N,n,m,p,k,T,d,HDband)

% preliminary tasks
% first create the hd_record and temp cells
hd_record=cell(n*N,n*N+1);
temp=cell(n*N,2);

% then initiate the Gibbs algorithm
for ii=1:It-Bu

% recover theta for the current iteration (one column for each period)
theta_iter=reshape(theta_gibbs(:,ii,:),d,T);

% recover D for the current iteration (one page for each period)
D_iter=[];
for jj=1:T
D_iter(:,:,jj)=reshape(D_record(:,ii,jj),N*n,N*n);
end

% recover the series of period-specific orthogonal IRFs
[IRFcell]=bear.panel6hdsim(theta_iter,D_iter,Xi,N,n,m,p,T,k);

% recover the structural disturbances
ETA=[];
for jj=1:N*n
ETA=[ETA;strshocks_record{jj,1}(ii,:)];
end
ETA=ETA';

% then compute the historical decomposition
   % loop over variables
   for jj=1:n*N
      % loop over shocks
      for kk=1:n*N
      % loop over shocks
      vshocks=ETA(:,kk);
         % loop over time periods
         for ll=1:T
         % initiate the vectors of IRFs and shocks
         virf=[];
            % then loop over IRF periods
            for mm=1:ll
            % create the vector of IRF coefficients
            virf=[virf IRFcell{mm,ll}(jj,kk)];
            end
         % compute then the contribution of shock kk for variable jj at period ll
         hd_record{jj,kk}(ii,ll)=virf*flipud(vshocks(1:ll,1));
         end
      end
   end

% then go for next Gibbs iteration
end

% compute the contributions of deterministic variables
% loop over rows of temp/hd_record
for ii=1:n*N
% fill the Ytot matrix in temp
% initial condition
temp{ii,1}=hd_record{ii,1};
   % sum over the remaining columns of hd_record
   for jj=2:n*N
   temp{ii,1}=temp{ii,1}+hd_record{ii,jj};
   end
% fill the Y matrix in temp
temp{ii,2}=repmat(Ymat(:,ii)',It-Bu,1);
% fill the Yd matrix in hd_record
hd_record{ii,N*n+1}=temp{ii,2}-temp{ii,1};
% go for next variable
end

% finally, obtain point esimates and credibility intervals
[hd_estimates]=bear.hdestimates(hd_record,N*n,T,HDband);


function XvalResult = ncrossdecomp(Method,X,FacMin,FacMax,Segments,Cent,Show);

%NCROSSDECOMP crossvalidation of PARAFAC/Tucker/PCA
%
% See also:
% 'ncrossreg'
%
% This file performs cross-validation of decomposition models
% PARAFAC, PCA, and Tucker. The cross-validation is performed
% such that part of the data are set to missing, the model is
% fitted to the remaining data, and the residuals between fitted
% and true left-out elements is calculated. This is performed
% 'Segments' times such that all elements are left out once.
% The segments are chosen by taking every 'Segments' element of
% X(:), i.e. from the vectorized array. If X is of size 5 x 7,
% and three segemnts are chosen ('Segments' = 3), then in the
% first of three models, the model is fitted to the matrix
%
% |x 0 0 x 0 0 x|
% |0 x 0 0 x 0 0|
% |0 0 x 0 0 x 0|
% |x 0 0 x 0 0 x|
% |0 x 0 0 x 0 0|
%
% where x's indicate missing elements. After fitting the residuals
% in the locations of missing values are calculated. After fitting
% all three models, all residuals have been calculated.
%
% Note that the number of segments must be chosen such that no columns
% or rows contain only missing elements (the algorithm will check this).
% Using 'Segments' = 7, 9, or 13 will usually achieve that.
%
% I/O
% XvalResult = ncrossdecomp(Method,X,FacMin,FacMax,Segments,Cent,Show);
%
% INPUT
% Method   : 'parafac', 'tucker', 'pca', or 'nipals'
%            For Tucker only Tucker3 models with equal
%            number of components is currently available.
%            For PCA the least squares model is calculated.
%            Thus, offsets and parameters are calculated in
%            a least squares sense unlike the method NIPALS,
%            which calculates the PCA model using an ad hoc
%            approach for handling missing data (as in
%            standard chemometric software).
% X        : Multi-way array of data
% FacMin   : Lowest number of factors to use
% FacMax   : Highest number of factors (note that for Tucker only models
%            with the same number of components in each mode are
%            calculated currently
% Segments : The number of segments to use. Try many!
% Cent     : If set of one, the data are centered across samples,
%            i.e. ordinary centering. Note, however, that the centering
%            is not performed in a least squares sense but as preprocessing.
%            This is not optimal because the data have missing data because
%            of the way the elements are left out. This can give
%            significantly lower fit than reasonable if you have few samples
%            or use few segments. Alternatively, you can center the data
%            beforehand and perform cross-validation on the centered data
% Show     : If set to 0, no plot is given
%
% OUTPUT
% Structure XvalResult holding:
%           Fit: The fitted percentage of variation explaind (as a
%                function of component number)
%          Xval: The cross-validated percentage of variation explaind
%                (as a function of component number)
%   FittedModel: The fitted model (as a function of component number)
%     XvalModel: The cross-validated model (as a function of component number)

% $ Version 1.0301 $ Date 28. June 1999 $ Not compiled $
% $ Version 2.00 $ May 2001 $ Changed to array notation $ RB $ Not compiled $

% Copyright (C) 1995-2006  Rasmus Bro & Claus Andersson
% Copenhagen University, DK-1958 Frederiksberg, Denmark, rb@life.ku.dk
%
% This program 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 2 of the License, or (at your option) any later version.
%
% This program 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
% this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
% Street, Fifth Floor, Boston, MA  02110-1301, USA.

% uses NANSUM,

%GT
Perm  = [1:ndims(X)];
DimX  = size(X);
ord   = ndims(X);
delta = zeros(1,ndims(X));
for i = 1:ndims(X)
    c(i)     = isempty(intersect(factor(DimX(i)),factor(Segments)));
    index{i} = 1:DimX(i);
end
delta = zeros(1,ndims(X));
for i = 1:ndims(X)
    c(i)     = isempty(intersect(factor(DimX(i)),factor(Segments)));
    index{i} = 1:DimX(i);
end
P = find(~c);
if sum(c) < length(DimX) - 1
    for i = 1:sum(~c)
        while ~c(P(i)) & delta(P(i)) < (abs(DimX(P(i))- Segments) - 1)
            if ~rem(DimX(P(i)),2) & ~rem(Segments,2) & delta(P(i)) > 0
                Off = 2;
            else
                Off = 1;
            end
            delta(P(i)) = delta(P(i)) + Off;
            c(P(i)) = isempty(intersect(factor(DimX(P(i)) + delta(P(i))),factor(Segments)));
        end
        if sum(c) == length(DimX) - 1
            return
        end
    end
    if sum(~c) > 1
        error('The chosen segmentation leads to tubes of only missing values')
    end
end
if sum(c) == length(DimX) - 1
    [c,Perm] = sort(~c);
end
[nil,PermI] = sort(Perm);
X           = reshape(X,DimX(1),prod(DimX(2:end)));
%GT end

[I,J] = size(X);

if exist('Show')~=1
   Show = 1;
end

if lower(Method(1:3)=='tuc')
   if length(FacMin)==1
      FacMin = ones(1,ord)*FacMin;
   elseif length(FacMin)~=ord
      error('Error in FacMin: When fitting Tucker models, the number of factors should be given for each mode')
   end
   if length(FacMax)==1
      FacMax = ones(1,ord)*FacMax;
   elseif length(FacMax)~=ord
      error('Error in FacMax: When fitting Tucker models, the number of factors should be given for each mode')
   end
end

%RB
% Check if the selected segmentation works (does not produce rows/columns of only missing)
%out = ones(I,J);
%out(1:Segments:end)=NaN;
%out(find(isnan(X))) = NaN;
%if any(sum(isnan(out))==I)
%   error(' The chosen segmentation leads to columns of only missing elements')
%elseif any(sum(isnan(out'))==J)
%   error(' The chosen segmentation leads to rows of only missing elements')
%end
%RB end

if lower(Method(1:3)~='tuc')

   XvalResult.Fit = zeros(FacMax,2)*NaN;
   XvalResult.Xval = zeros(FacMax,2)*NaN;
   for f = 1:FacMin-1
      XvalResult.XvalModel{f} =  'Not fitted';
      XvalResult.FittedModel{f} = 'Not fitted';
   end

   for f = FacMin:FacMax

      % Fitted model
      disp([' Total model - Comp. ',num2str(f),'/',num2str(FacMax)])
      [M,Mean,Param] = decomp(Method,X,DimX,f,1,Segments,Cent,I,J);
      Model = M + ones(I,1)*Mean';
      id    = find(~isnan(X));
      OffsetCorrectedData = X - ones(I,1)*Mean';
      XvalResult.Fit(f,:) = [100*(1 - sum( (X(id) - Model(id)).^2)/sum(OffsetCorrectedData(id).^2)) f];
      XvalResult.FittedModel{f} = Model;

      % Xvalidated Model of data
      ModelXval = zeros(I,J)*NaN;
      for s = 1:Segments
         disp([' Segment ',num2str(s),'/',num2str(Segments),' - Comp. ',num2str(f),'/',num2str(FacMax)])
         %GT
         Xnow    = permute(zeros(DimX),Perm);
         dimsadd = size(Xnow);
         for j = 1:length(DimX)
            dimsadd(j) = delta(Perm(j));
            Xnow       = cat(j,Xnow,zeros(dimsadd));
            index2{j}  = 1:DimX(Perm(j));
            dimsadd    = size(Xnow);
         end
         Xnow(s:Segments:end)     = NaN;
         Xnow                     = reshape(permute(Xnow(index2{:}),PermI),DimX(1),prod(DimX(2:end)));
         Pos                      = isnan(Xnow);
         [M,Mean]                 = decomp(Method,Xnow + X,DimX,f,s,Segments,Cent,I,J,Param);
         model                    = M + ones(I,1)*Mean';
         ModelXval(Pos)           = model(Pos);
         %GT end
      end

      XvalResult.Xval(f,:) = [100*(1 - sum( (X(id) - ModelXval(id)).^2)/sum(OffsetCorrectedData(id).^2)) f];
      XvalResult.XvalModel{f} =  ModelXval;
   end

else % Do Tucker model

   %GT
   if length(FacMin) ~= ord
      FacMin = ones(1,ord)*min(FacMin);
   end
   if length(FacMax) ~= ord
      FacMax = ones(1,ord)*min(FacMax);
   end
   for i=1:length(FacMin)
      ind{i} = [FacMin(i):FacMax(i)]';
      ind2{i} = ones(length(ind{i}),1);
   end
   NCombs = cellfun('length',ind);
   for i=1:length(FacMin)
      o = [1:i-1,i+1:length(FacMin)];
      t = ipermute(ind{i}(:,ind2{o}),[i,o]);
      possibleCombs(1:prod(NCombs),i) = t(:);
   end
   FeasCombs = sort(possibleCombs');
   f2        = prod(FeasCombs(1:size(FeasCombs,1)-1,:))<FeasCombs(end,:);
   possibleCombs(f2,:) = [];
   possibleCombs(:,end+1) = find(~f2(:));
   %GTend
   %RB
   % Find all
   %PossibleNumber = [min(FacMin):max(FacMax)]'*ones(1,ord);
   %possibleCombs = unique(nchoosek(PossibleNumber(:),ord),'rows');
   %remove useless
   %f2 = [];
   %for f1 = 1:size(possibleCombs,1)
   %   if (prod(possibleCombs(f1,:))/max(possibleCombs(f1,:)))<max(possibleCombs(f1,:)) % Check that the largest mode is larger than the product of the other
   %      f2 = [f2;f1];
   %   elseif any(possibleCombs(f1,:)>FacMax)  % Chk the model is desired,
   %      f2 = [f2;f1];
   %   end
   %end
   %possibleCombs(f2,:)=[];
   %[f1,f2]=sort(sum(possibleCombs'));
   %possibleCombs = [possibleCombs(f2,:) f1'];
   %RBend

   XvalResult.Fit = zeros(size(possibleCombs,1),ord+1)*NaN;
   XvalResult.Xval = zeros(size(possibleCombs,1),ord+1)*NaN;
   for f = 1:size(possibleCombs,1)
      XvalResult.XvalModel{f} =  'Not fitted';
      XvalResult.FittedModel{f} = 'Not fitted';
   end

   for f1 = 1:size(possibleCombs,1)

      % Fitted model
      %GT
      disp([' Total model - Comp. ',num2str(possibleCombs(f1,:)),'/',num2str(FacMax)])
      [M,Mean,Param] = decomp(Method,X,DimX,possibleCombs(f1,:),1,Segments,Cent,I,J);
      %GTend
      %RB
      %disp([' Total model - Comp. ',num2str(possibleCombs(f1,1:end-1)),'/',num2str(FacMax)])
      %[M,Mean,Param] = decomp(Method,X,DimX,possibleCombs(f1,1:end-1),1,Segments,Cent,I,J);
      %RBend
      Model = M + ones(I,1)*Mean';
      id    = find(~isnan(X));
      OffsetCorrectedData = X - ones(I,1)*Mean';
      XvalResult.Fit(f1,:) = [100*(1 - sum( (X(id) - Model(id)).^2)/sum(OffsetCorrectedData(id).^2)) possibleCombs(f1,1:end-1)];
      XvalResult.FittedModel{f1} = Model;

      % Xvalidated Model of data
      ModelXval = zeros(I,J)*NaN;
      for s = 1:Segments
         disp([' Segment ',num2str(s),'/',num2str(Segments),' - Comp. ',num2str(possibleCombs(f1,1:end-1)),'/',num2str(FacMax)])
         %GT
         Xnow    = permute(zeros(DimX),Perm);
         dimsadd = DimX;
         for j = 1:length(DimX)
             dimsadd(j) = delta(j);
             Xnow       = cat(j,Xnow,zeros(dimsadd));
             index2{j}  = 1:DimX(j);
             dimsadd(j) = dimsadd(j) + DimX(j);
         end
         Xnow(s:Segments:end)     = NaN;
         Xnow                     = reshape(permute(Xnow(index2{:}),PermI),DimX(1),prod(DimX(2:end)));
         Pos                      = isnan(Xnow);
         [M,Mean]                 = decomp(Method,Xnow + X,DimX,possibleCombs(f1,1:end-1),s,Segments,Cent,I,J,Param);
         model                    = M + ones(I,1)*Mean';
         ModelXval(Pos)           = model(Pos);
         %GT end
      end

      XvalResult.Xval(f1,:) = [100*(1 - sum( (X(id) - ModelXval(id)).^2)/sum(OffsetCorrectedData(id).^2)) possibleCombs(f1,1:end-1)];
      XvalResult.XvalModel{f1} =  ModelXval;
   end

end

if Show&FacMin-FacMax~=0
   if Method(1:3) == 'pca'
      Nam = 'PCA';
   elseif Method(1:3) == 'tuc'
      Nam = 'Tucker';
   elseif Method(1:3) == 'par'
      Nam = 'PARAFAC';
   elseif Method(1:3) == 'nip'
      Nam = 'NIPALS';
   end

   figure
   save jjj
   if lower(Method(1:3))~='tuc'
      bar(FacMin:FacMax,[XvalResult.Fit(FacMin:FacMax,1) XvalResult.Xval(FacMin:FacMax,1)],.76,'grouped')
   else
      % extract the ones with lowest Xval fit (for each # total comp) for plotting
      fx = [];
      f5 =[];
      for f1 = 1:max(possibleCombs(:,end))
         f2 = find(possibleCombs(:,end)==f1);
         if length(f2)
            [f3,f4] = max(XvalResult.Xval(f2));
            f5 = [f5,f2(f4)];
         end
      end
      fx = [possibleCombs(f5,end) XvalResult.Fit(f5,1) XvalResult.Xval(f5,1)];
      bar(fx(:,1),fx(:,2:3),.76,'grouped')
      for f1 = 1:size(fx,1)
         f6=text(fx(f1,1),95,['[',num2str(possibleCombs(f5(f1),1:end-1)),']']);
         set(f6,'Rotation',270)
      end
   end

   g=get(gca,'YLim');
   set(gca,'YLim',[max(-20,g(1)) 100])
   legend('Fitted','Xvalidated',0)
   titl = ['Xvalidation results (',Nam,')'];
   if Cent
      titl = [titl ,' - centering'];
   else
      titl = [titl ,' - no centering'];
   end
   title(titl,'FontWeight','Bold')
   xlabel('Total number of components')
   ylabel('Percent variance explained')
end

function [M,Mean,parameters] = decomp(Method,X,DimX,f,s,Segments,Cent,I,J,parameters);

Conv = 0;
it = 0;
maxit = 500;
% Initialize
if Cent
   Mean = nanmean(X)';
else
   Mean = zeros(J,1);
end

if lower(Method(1:3)) == 'par'
   Xc = reshape(X- ones(I,1)*Mean',DimX);
   if exist('parameters')==1
      fact = parafac(Xc,f,[1e-5 10 0 0 NaN maxit],[],parameters.fact);
   else
      fact = parafac(Xc,f,[1e-5 10 0 0 NaN maxit]);
   end
   M = reshape(nmodel(fact),DimX(1),prod(DimX(2:end)));
   parameters.fact=fact;
elseif lower(Method(1:3)) == 'tuc'
   Xc = reshape(X- ones(I,1)*Mean',DimX);
   if exist('parameters')==1
      [fact,G] = tucker(Xc,f,[1e-2 0 0 0 NaN maxit],[],[],parameters.fact,parameters.G);
   else
      [fact,G] = tucker(Xc,f,[1e-2 0 0 0 NaN maxit]);
   end
   parameters.fact=fact;
   parameters.G=G;
   M = reshape(nmodel(fact,G),DimX(1),prod(DimX(2:end)))      ;
elseif lower(Method) == 'pca'|lower(Method) == 'nip'
   Xc = reshape(X- ones(I,1)*Mean',DimX(1),prod(DimX(2:end)));
   [t,p] = pcanipals(X- ones(I,1)*Mean',f,0);
   parameters.t=t;
   parameters.p=p;
   M = t*p';
else
   error(' Name of method not recognized')
end
Fit = X - M - ones(I,1)*Mean';
Fit = sum(Fit(find(~isnan(X))).^2);

% Iterate
while ~Conv
   it     = it+1;
   FitOld = Fit;

   % Fit multilinear part
   Xcent = X - ones(I,1)*Mean';

   if Method(1:3) == 'par'
      fact = parafac(reshape(Xcent,DimX),f,[1e-2 0 0 0 NaN maxit],[],fact);
      M = reshape(nmodel(fact),DimX(1),prod(DimX(2:end)));
   elseif Method(1:3) == 'tuc'
      [fact,G] = tucker(reshape(Xcent,DimX),f,[1e-2 0 0 0 NaN maxit],[0 0 0],zeros(size(G)),fact,G);
      M = reshape(nmodel(fact,G),DimX(1),prod(DimX(2:end)));
   elseif Method == 'pca'
      [t,p] = pcals(Xcent,f,0,t,p,0);
      M = t*p';
   elseif Method == 'nip'
      [t,p] = pcanipals(Xcent,f,0);
      M = t*p';
   end

   % Find offsets
   if Cent
      x = X;
      mm=M+ones(I,1)*Mean';
      x(find(isnan(X)))=mm(find(isnan(X)));
      Mean = mean(x)';
   end

   %Find fit
   Fit = X - M - ones(I,1)*Mean';
   Fit = sum(Fit(find(~isnan(X))).^2);
   if abs(Fit-FitOld)/FitOld<1e-8 | it > 1500
      Conv = 1;
   end

end
disp([' Fit ',num2str(Fit),' using ',num2str(it),' it.'])

function [t,p] = pcals(X,F,cent,t,p,show);

%  LEAST SQUARES PCA WITH MISSING ELEMENTS
%  20-6-1999
%
%  Calculates a least squares PCA model. Missing elements
%  are denoted NaN. The solution is NOT nested, so one has
%  to calculate a new model for each number of components.

ShowMeFitEvery = 20;
MaxIterations  = 5;
[I,J]=size(X);
Xorig      = X;
Miss       = find(isnan(X));
NotMiss    = find(~isnan(X));
m          = t*p';
X(Miss)    = m(Miss);
ssX    = sum(X(NotMiss).^2);

Fit    = 3;
OldFit = 6;
it     = 0;

while abs(Fit-OldFit)/OldFit>1e-3 & it < MaxIterations;
   it      = it +1;
   OldFit  = Fit;

   [t,s,p] = svds(X,F);
   t       = t*s;

   Model   = t*p';
   X(Miss) = Model(Miss);
   Fit     = sum(sum( (Xorig(NotMiss) - Model(NotMiss)).^2));

   if ~rem(it,ShowMeFitEvery)&show
      disp(['    Fit after ',num2str(it),' it. :',num2str(RelFit),'%'])
   end

end

function [t,p,Mean] = pcanipals(X,F,cent);

% NIPALS-PCA WITH MISSING ELEMENTS
% cent: One if centering is to be included, else zero

[I,J]=size(X);
rand('state',sum(100*clock))

Xorig      = X;
Miss       = isnan(X);
NotMiss    = ~isnan(X);
ssX    = sum(X(find(NotMiss)).^2);
Mean   = zeros(1,J);
if cent
   Mean    = nanmean(X);
end
X      = X - ones(I,1)*Mean;

t=[];
p=[];

for f=1:F
   Fit    = 3;
   OldFit = 6;
   it     = 0;
   T      = rand(I,1);
   P      = rand(J,1);
   Fit    = 2;
   FitOld = 3;

   while abs(Fit-FitOld)/FitOld>1e-7 & it < 100;
      FitOld  = Fit;
      it      = it +1;

      for j = 1:J
         id=find(NotMiss(:,j));
         if length(id)==0
            id,end
         P(j) = T(id)'*X(id,j)/(T(id)'*T(id));
      end
      P = P/norm(P);

      for i = 1:I
         id=find(NotMiss(i,:));
         T(i) = P(id)'*X(i,id)'/(P(id)'*P(id));
      end

      Fit = X-T*P';
      Fit = sum(Fit(find(NotMiss)).^2);
   end
   t = [t T];
   p = [p P];
   X = X - T*P';

end

function Xc = nanmean(X)

if isempty(X)
   Xc = NaN;
   return
end

i = isnan(X);
j = find(i);
i = sum(i);
X(j) = 0;
Num = size(X,1)-i;
Xc = sum(X);
i = find(Num);
Xc(i) = Xc(i)./Num(i);
Xc(find(~Num))=NaN;