diff --git a/ReadMatLabDesign.for b/ReadMatLabDesign.for
index fdc0ac6182734b4c380ea04cf747701d419727af..82f49d5e1098d0fd7a4fac2628513a7ddf0a6a26 100644
--- a/ReadMatLabDesign.for
+++ b/ReadMatLabDesign.for
@@ -1,12 +1,12 @@
-C --------------------------------------------------------------------
-C This file crates matlabdll.dll whih is ment to read the .m file
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C This file crates matlabdll.dll whih is ment to read the .m file
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -17,205 +17,205 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ---------------------------------------------------------------------
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-!DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'design_' :: DESIGN
-
-C INPUT
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
-C OUTPUT
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- & G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- & R(nx,nu,ns(6))
-C
-C COMMON
-C
- INTEGER ep
- COMMON /X/ ep
- DATA ep/0/
- CHARACTER*200 mfile,pathmfile
- COMMON /M/ mfile,pathmfile
- CHARACTER*1024 buffer,buffer1
- COMMON /ERRBUFFER/ buffer
-C
-C LOCALS TO INTERFACE MatLab
-C
- INTEGER engOpen, engGetVariable, mxCreateDoubleMatrix
- INTEGER mxGetPr
- INTEGER engPutVariable, engEvalString, engClose
- INTEGER i, temp, status
- DOUBLE PRECISION nsd(6)
- INTEGER ny_ptr,nz_ptr,nx_ptr,nu_ptr,ns_ptr,nt_ptr,theta_ptr
- INTEGER C_ptr, H_ptr, G_ptr, A_ptr, F_ptr, R_ptr
-
-
-C Try to open MatLab (just the first time)
- IF (ep .eq.0 ) THEN
- ep = engOpen('matlab ')
- IF (ep .eq. 0) THEN
- ny = 0 ! ' Can''t start MatLab engine'
- RETURN
- ENDIF
- IF (engEvalString(ep,'cd ' // pathmfile).ne. 0) then
- ny = -7 ! ' Can''t find or open the MatLab funtion'
- RETURN
- ENDIF
- ENDIF
-
-C
-C Check MatLab INPUT
-C
- ny_ptr = mxCreateDoubleScalar(ny*1.0d0)
- status = engPutVariable(ep, 'ny'C, ny_ptr)
- IF (status .ne. 0) THEN
- ny = -1 ! ' Can''t read ny in the MatLab file'
- RETURN
- ENDIF
-
- nz_ptr = mxCreateDoubleScalar(nz*1.0d0)
- status = engPutVariable(ep, 'nz'C, nz_ptr)
- IF (status .ne. 0) THEN
- ny = -2 ! ' Can''t read nz in the MatLab file'
- RETURN
- ENDIF
-
- nx_ptr = mxCreateDoubleScalar(nx*1.0d0)
- status = engPutVariable(ep, 'nx'C, nx_ptr)
- IF (status .ne. 0) THEN
- ny = -3 ! ' Can''t read nx in the MatLab file'
- RETURN
- ENDIF
-
- nu_ptr = mxCreateDoubleScalar(nu*1.0d0)
- status = engPutVariable(ep, 'nu'C, nu_ptr)
- IF (status .ne. 0) THEN
- ny = -4 ! ' Can''t read nu in the MatLab file'
- RETURN
- ENDIF
-
- ns_ptr = mxCreateDoubleMatrix(1, 6, 0)
- DO i=1,6
- nsd(i)=ns(i)*1.d0
- ENDDO
- CALL mxCopyReal8ToPtr(nsd, mxGetPr(ns_ptr), 6)
- status = engPutVariable(ep, 'ns'C, ns_ptr)
- IF (status .ne. 0) THEN
- ny = -5 ! ' Can''t read ns in the MatLab file'
- RETURN
- ENDIF
-
- theta_ptr = mxCreateDoubleMatrix(1, nt, 0)
- CALL mxCopyReal8ToPtr(theta, mxGetPr(theta_ptr), nt)
- status = engPutVariable(ep, 'theta'C, theta_ptr)
- IF (status .ne. 0) THEN
- ny = -6 ! ' Can''t read theta in the MatLab file'
- RETURN
- ENDIF
-
-C
-C Evaluate the MatLab DESIGN Funtion with the input data from FORTRAN
-C
- buffer = ''
- status = engOutputBuffer(ep, buffer1)
- IF (engEvalString(ep, 'clear success;'//
- & '[C,H,G,A,F,R]='//TRIM(mfile)//'( ny,nz,nx,'//
- & 'nu,ns,theta);'//'success=1;') .ne. 0) then
- ny = -8 ! engEvalString failed
- RETURN
- ENDIF
- C_ptr = engGetVariable(ep, 'success'C)
- IF (C_ptr .eq. 0) then
- buffer=buffer1
- ny=-8 ! engEvalString failed
- RETURN
- ENDIF
-
-C
-C Get the MatLab DESIGN created matrics back to FORTRAN
-C
- C_ptr = engGetVariable(ep, 'C'C)
- IF(C_ptr.NE.0) THEN
- CALL mxCopyPtrToReal8(mxGetPr(C_ptr), c, ny*max(1,nz)*ns(1))
- ELSE
- ny = -101
- ENDIF
-
- H_ptr = engGetVariable(ep, 'H'C)
- IF(H_ptr.NE.0) THEN
- CALL mxCopyPtrToReal8(mxGetPr(H_ptr), H, ny*nx*ns(2))
- ELSE
- ny = -102
- ENDIF
-
- G_ptr = engGetVariable(ep, 'G'C)
- IF(G_ptr.NE.0) THEN
- CALL mxCopyPtrToReal8(mxGetPr(G_ptr), G, ny*nu*ns(3))
- ELSE
- ny = -103
- ENDIF
-
- A_ptr = engGetVariable(ep, 'A'C)
- IF(A_ptr.NE.0) THEN
- CALL mxCopyPtrToReal8(mxGetPr(A_ptr), a, nx*ns(4))
- ELSE
- ny = -104
- ENDIF
-
- F_ptr = engGetVariable(ep, 'F'C)
- IF(F_ptr.NE.0) THEN
- CALL mxCopyPtrToReal8(mxGetPr(F_ptr), F, nx*nx*ns(5))
- ELSE
- ny = -105
- ENDIF
-
- R_ptr = engGetVariable(ep, 'R'C)
- IF(R_ptr.NE.0) THEN
- CALL mxCopyPtrToReal8(mxGetPr(R_ptr), R, nx*nu*ns(6))
- ELSE
- ny = -106
- ENDIF
-
-C
-C Free dynamic memory allocated by MXCREATE function
-C
- CALL mxDestroyArray(nz_ptr)
- CALL mxDestroyArray(nx_ptr)
- CALL mxDestroyArray(nu_ptr)
- CALL mxDestroyArray(ns_ptr)
- CALL mxDestroyArray(theta_ptr)
- CALL mxDestroyArray(C_ptr)
- CALL mxDestroyArray(H_ptr)
- CALL mxDestroyArray(G_ptr)
- CALL mxDestroyArray(A_ptr)
- CALL mxDestroyArray(F_ptr)
- CALL mxDestroyArray(R_ptr)
- CALL mxDestroyArray(ny_ptr)
-
- RETURN
- END
-
-C -----------------------------------------
-C To make dynamic the name of the .m file
-C -----------------------------------------
- SUBROUTINE SETFILEM(string1,string2)
-!DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'setfilem_' :: SETFILEM
- CHARACTER*200 string1,string2,mfile,pathmfile
- COMMON /M/ mfile, pathmfile
- mfile = string1
- pathmfile = string2
- RETURN
- END
-
-C --------------------
-C To get MatLab errors
-C --------------------
- SUBROUTINE GETERRSTR(matlaberror)
-!DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'geterrstr_' :: GETERRSTR
- CHARACTER*1024 matlaberror
- CHARACTER*1024 buffer
- COMMON /ERRBUFFER/ buffer
- matlaberror = buffer
- RETURN
- END
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ---------------------------------------------------------------------
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+!DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'design_' :: DESIGN
+
+C INPUT
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+C OUTPUT
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ & G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ & R(nx,nu,ns(6))
+C
+C COMMON
+C
+ INTEGER ep
+ COMMON /X/ ep
+ DATA ep/0/
+ CHARACTER*200 mfile,pathmfile
+ COMMON /M/ mfile,pathmfile
+ CHARACTER*1024 buffer,buffer1
+ COMMON /ERRBUFFER/ buffer
+C
+C LOCALS TO INTERFACE MatLab
+C
+ INTEGER engOpen, engGetVariable, mxCreateDoubleMatrix
+ INTEGER mxGetPr
+ INTEGER engPutVariable, engEvalString, engClose
+ INTEGER i, temp, status
+ DOUBLE PRECISION nsd(6)
+ INTEGER ny_ptr,nz_ptr,nx_ptr,nu_ptr,ns_ptr,nt_ptr,theta_ptr
+ INTEGER C_ptr, H_ptr, G_ptr, A_ptr, F_ptr, R_ptr
+
+
+C Try to open MatLab (just the first time)
+ IF (ep .eq.0 ) THEN
+ ep = engOpen('matlab ')
+ IF (ep .eq. 0) THEN
+ ny = 0 ! ' Can''t start MatLab engine'
+ RETURN
+ ENDIF
+ IF (engEvalString(ep,'cd ' // pathmfile).ne. 0) then
+ ny = -7 ! ' Can''t find or open the MatLab funtion'
+ RETURN
+ ENDIF
+ ENDIF
+
+C
+C Check MatLab INPUT
+C
+ ny_ptr = mxCreateDoubleScalar(ny*1.0d0)
+ status = engPutVariable(ep, 'ny'C, ny_ptr)
+ IF (status .ne. 0) THEN
+ ny = -1 ! ' Can''t read ny in the MatLab file'
+ RETURN
+ ENDIF
+
+ nz_ptr = mxCreateDoubleScalar(nz*1.0d0)
+ status = engPutVariable(ep, 'nz'C, nz_ptr)
+ IF (status .ne. 0) THEN
+ ny = -2 ! ' Can''t read nz in the MatLab file'
+ RETURN
+ ENDIF
+
+ nx_ptr = mxCreateDoubleScalar(nx*1.0d0)
+ status = engPutVariable(ep, 'nx'C, nx_ptr)
+ IF (status .ne. 0) THEN
+ ny = -3 ! ' Can''t read nx in the MatLab file'
+ RETURN
+ ENDIF
+
+ nu_ptr = mxCreateDoubleScalar(nu*1.0d0)
+ status = engPutVariable(ep, 'nu'C, nu_ptr)
+ IF (status .ne. 0) THEN
+ ny = -4 ! ' Can''t read nu in the MatLab file'
+ RETURN
+ ENDIF
+
+ ns_ptr = mxCreateDoubleMatrix(1, 6, 0)
+ DO i=1,6
+ nsd(i)=ns(i)*1.d0
+ ENDDO
+ CALL mxCopyReal8ToPtr(nsd, mxGetPr(ns_ptr), 6)
+ status = engPutVariable(ep, 'ns'C, ns_ptr)
+ IF (status .ne. 0) THEN
+ ny = -5 ! ' Can''t read ns in the MatLab file'
+ RETURN
+ ENDIF
+
+ theta_ptr = mxCreateDoubleMatrix(1, nt, 0)
+ CALL mxCopyReal8ToPtr(theta, mxGetPr(theta_ptr), nt)
+ status = engPutVariable(ep, 'theta'C, theta_ptr)
+ IF (status .ne. 0) THEN
+ ny = -6 ! ' Can''t read theta in the MatLab file'
+ RETURN
+ ENDIF
+
+C
+C Evaluate the MatLab DESIGN Funtion with the input data from FORTRAN
+C
+ buffer = ''
+ status = engOutputBuffer(ep, buffer1)
+ IF (engEvalString(ep, 'clear success;'//
+ & '[C,H,G,A,F,R]='//TRIM(mfile)//'( ny,nz,nx,'//
+ & 'nu,ns,theta);'//'success=1;') .ne. 0) then
+ ny = -8 ! engEvalString failed
+ RETURN
+ ENDIF
+ C_ptr = engGetVariable(ep, 'success'C)
+ IF (C_ptr .eq. 0) then
+ buffer=buffer1
+ ny=-8 ! engEvalString failed
+ RETURN
+ ENDIF
+
+C
+C Get the MatLab DESIGN created matrics back to FORTRAN
+C
+ C_ptr = engGetVariable(ep, 'C'C)
+ IF(C_ptr.NE.0) THEN
+ CALL mxCopyPtrToReal8(mxGetPr(C_ptr), c, ny*max(1,nz)*ns(1))
+ ELSE
+ ny = -101
+ ENDIF
+
+ H_ptr = engGetVariable(ep, 'H'C)
+ IF(H_ptr.NE.0) THEN
+ CALL mxCopyPtrToReal8(mxGetPr(H_ptr), H, ny*nx*ns(2))
+ ELSE
+ ny = -102
+ ENDIF
+
+ G_ptr = engGetVariable(ep, 'G'C)
+ IF(G_ptr.NE.0) THEN
+ CALL mxCopyPtrToReal8(mxGetPr(G_ptr), G, ny*nu*ns(3))
+ ELSE
+ ny = -103
+ ENDIF
+
+ A_ptr = engGetVariable(ep, 'A'C)
+ IF(A_ptr.NE.0) THEN
+ CALL mxCopyPtrToReal8(mxGetPr(A_ptr), a, nx*ns(4))
+ ELSE
+ ny = -104
+ ENDIF
+
+ F_ptr = engGetVariable(ep, 'F'C)
+ IF(F_ptr.NE.0) THEN
+ CALL mxCopyPtrToReal8(mxGetPr(F_ptr), F, nx*nx*ns(5))
+ ELSE
+ ny = -105
+ ENDIF
+
+ R_ptr = engGetVariable(ep, 'R'C)
+ IF(R_ptr.NE.0) THEN
+ CALL mxCopyPtrToReal8(mxGetPr(R_ptr), R, nx*nu*ns(6))
+ ELSE
+ ny = -106
+ ENDIF
+
+C
+C Free dynamic memory allocated by MXCREATE function
+C
+ CALL mxDestroyArray(nz_ptr)
+ CALL mxDestroyArray(nx_ptr)
+ CALL mxDestroyArray(nu_ptr)
+ CALL mxDestroyArray(ns_ptr)
+ CALL mxDestroyArray(theta_ptr)
+ CALL mxDestroyArray(C_ptr)
+ CALL mxDestroyArray(H_ptr)
+ CALL mxDestroyArray(G_ptr)
+ CALL mxDestroyArray(A_ptr)
+ CALL mxDestroyArray(F_ptr)
+ CALL mxDestroyArray(R_ptr)
+ CALL mxDestroyArray(ny_ptr)
+
+ RETURN
+ END
+
+C -----------------------------------------
+C To make dynamic the name of the .m file
+C -----------------------------------------
+ SUBROUTINE SETFILEM(string1,string2)
+!DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'setfilem_' :: SETFILEM
+ CHARACTER*200 string1,string2,mfile,pathmfile
+ COMMON /M/ mfile, pathmfile
+ mfile = string1
+ pathmfile = string2
+ RETURN
+ END
+
+C --------------------
+C To get MatLab errors
+C --------------------
+ SUBROUTINE GETERRSTR(matlaberror)
+!DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'geterrstr_' :: GETERRSTR
+ CHARACTER*1024 matlaberror
+ CHARACTER*1024 buffer
+ COMMON /ERRBUFFER/ buffer
+ matlaberror = buffer
+ RETURN
+ END
diff --git a/amh.for b/amh.for
index 9877f6fad6b8681d2c16de2173b6e45f4d2d85f7..28583ec960d898611b8ddc2e316a7d3c61ea8eff 100644
--- a/amh.for
+++ b/amh.for
@@ -1,50 +1,50 @@
-C -------------------------------------------------------------
-C AMH DRAWS THE DISCRETE LATENT VARIABLE IN BLOCKS
-C (see Fiorentini, Planas and Rossi, Statistics and Computing, 2014, 24, 77-89)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
-C x Pr[Z(t)|Z(\t)]
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C FURTHER INPUT
-C nobs: # of observatios
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C nv: # of discrete latent variables (S1,S2,...)
-C ns: ns1,ns2,...
-C nstot: total # of states (states of S1 x S2 x ...x Snv)
-C nt: dimension of theta
-C np: dimension of psi
-C PMAT: (nstot x nstot) one-step transition probabilities
-C PE: ergodic distribution of S1 x S2 x ...x Snv
-C INFOS: (9 x 6) set latent variables
-C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
-C PTR: transition porbabilities
-C PM: marginal probabilities
-C
-C OUTPUT
-C Z:(nobs x 1) takes values {1,2,...,nstot}
-C ACCRATE: CUMULATES ACCEPTANS 1 IF DRAW IS ACCEPTED 0 Otherwise
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C AMH DRAWS THE DISCRETE LATENT VARIABLE IN BLOCKS
+C (see Fiorentini, Planas and Rossi, Statistics and Computing, 2014, 24, 77-89)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
+C x Pr[Z(t)|Z(\t)]
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C FURTHER INPUT
+C nobs: # of observatios
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C nv: # of discrete latent variables (S1,S2,...)
+C ns: ns1,ns2,...
+C nstot: total # of states (states of S1 x S2 x ...x Snv)
+C nt: dimension of theta
+C np: dimension of psi
+C PMAT: (nstot x nstot) one-step transition probabilities
+C PE: ergodic distribution of S1 x S2 x ...x Snv
+C INFOS: (9 x 6) set latent variables
+C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
+C PTR: transition porbabilities
+C PM: marginal probabilities
+C
+C OUTPUT
+C Z:(nobs x 1) takes values {1,2,...,nstot}
+C ACCRATE: CUMULATES ACCEPTANS 1 IF DRAW IS ACCEPTED 0 Otherwise
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -55,503 +55,503 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE AMH(HFIX,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 yk,IYK,theta,psi,PTR,PM,INFOS,pdll,Z,S,ACCRATE)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia)
- POINTER (pdesign,DESIGN)
-
-C INPUT
- INTEGER HFIX,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,
- 1 IYK(nobs,ny+1),INFOS(9,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
- 1 PTR(nobs,nstot,nstot),PM(nobs,nstot)
-
-C INPUT/OUTPUT
- INTEGER Z(nobs),S(nobs,6),ACCRATE(nobs)
-
-C LOCALS
- INTEGER IT,I,II,J,JJ,K,IFAIL,ISEQ,iny,HFIXL,I0,I1,IACC,IC,IR,id1
- INTEGER Z0(nobs),IS(6),IND(HFIX+2,6),SEQ(nv),dn(2)
- DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot),
- 4 PALL(nstot,nstot,HFIX+1)
- DOUBLE PRECISION Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx)
- DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
- DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
- 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
- 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
- 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
- 4 VVHF(ny,nx),WORK(3*nx),LAM(nx),PR(nstot),
- 5 QN,QO,PA,PN,PO,GN,GO,AUX,delta,v,vd,PS0,PS1,AUX1,AUX0
- DOUBLE PRECISION, ALLOCATABLE:: DLL(:),XT(:,:),PT(:,:,:),
- 1 XT0(:,:),PT0(:,:,:),PTR2(:,:,:)
- DOUBLE PRECISION EPS,ONE,ZERO
- DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
- DOUBLE PRECISION LEMMA4,MARKOVP,genunf
-
- dn(1) = 0
- dn(2) = d(2)
- id1 = max(1,d(1))
- Z0 = Z
- delta = 1.D-3
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
-C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-C KOLMOGOROV EQNS
- PALL(:,:,1) = PMAT
- DO J = 2,HFIX+1 ! Kolmogorov eqns
- DO jj = 1,nstot
- DO ii = 1,nstot-1
- PALL(ii,jj,J) = SUM(PALL(ii,:,1)*PALL(:,jj,J-1))
- ENDDO
- PALL(nstot,jj,J) = 1.D0-SUM(PALL(1:nstot-1,jj,J))
- ENDDO
- ENDDO
-
-C OMEGA and MU RECURSIONS
- OM(:,:,:)= ZERO
- MU(:,:) = ZERO
- DO 250 IT = nobs-1,1,-1
-C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
- CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
- iny = IYK(IT+1,ny+1)
-
- DO 10 I=1,iny
- Ha(I) = SUM(H(IYK(IT+1,I),:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
- DO 10 J=1,nu
-10 HRG(I,J) = SUM(H(IYK(IT+1,I),:,IS(2))*R(:,J,IS(6)))
- + + G(IYK(IT+1,I),J,IS(3)) ! HR+G (ny x nu)
-
- DO 20 I=1,iny
- DO 20 J=1,iny
-20 VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
-
- DO 30 I=1,iny
- DO 30 J=1,nx
-30 HF(I,J)=SUM(H(IYK(IT+1,I),:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
-
- COM(1:iny,1:iny) = VV(1:iny,1:iny)
- IFAIL = -1
-C CALL F01ADF(iny,COM(1:iny+1,1:iny), iny+1, IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
- DO 40 I=1,iny
- DO 40 J=1,I
- VV(I,J) = COM(I,J)
-40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
-
-C B = R*(H*R+G)'*VV (nx x ny)
- DO 50 I=1,nu
- DO 50 J=1,iny
-50 HRGV(I,J) = SUM(HRG(1:iny,I)*VV(1:iny,J)) ! (H*R+G)'*VV (nu x ny)
-
- DO 60 I=1,nx
- DO 60 J=1,iny
-60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
-
- DO 70 I=1,nx
- DO 70 J=1,nx
- RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
-70 BH(I,J) = SUM(B(I,1:iny)*H(IYK(IT+1,1:iny),J,IS(2))) ! BH (nx x nx)
-
-C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
- DO 80 I=1,nx
- DO 80 J=1,nu
-80 BHRG(I,J) = SUM(B(I,1:iny)*HRG(1:iny,J))
-
- DO 90 I=1,nx
- DO 90 J=1,I
-90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
-
- IFAIL=-1
-C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- DO 100 I=1,nx
- IF (LAM(I).LE.EPS) LAM(I)= ZERO
-100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
-
-C AA = F - B*HF (nx x nx)
- DO 110 I=1,nx
- DO 110 J=1,nx
-110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:iny)*HF(1:iny,J))
-
-C OMC = OM(+1)*CS (nx x nx)
- DO 120 I=1,nx
- DO 120 J=1,nx
-120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
-
-C DD = I + CS'*OM(+1)*CS (nx x nx)
- DD(:,:) = ZERO
- DO 130 I=1,nx
- DD(I,I) = ONE
- DO 130 J=1,I
- DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
-130 DD(J,I) = DD(I,J)
-
-C DI = inv(DD) (nx x nx)
- COM1(1:nx,:) = DD(:,:)
- IFAIL = -1
-C CALL F01ADF(nx,COM1,nx+1,IFAIL)
- CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
- CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
- DO 135 I=1,nx
- DO 135 J=1,I
- DI(I,J) = COM1(I,J)
-135 DI(J,I) = DI(I,J)
-
-C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
- DO 140 I=1,nx
- DO 140 J=1,nx
-140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
-
- OMCDIC(:,:) = ZERO
- DO 145 I=1,nx
- OMCDIC(I,I) = ONE
- DO 145 J=1,nx
-145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
-
-C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
- DO 150 I=1,nx
- DO 150 J=1,nx
-150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
-
-C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
- DO 160 I=1,nx
- DO 160 J=1,nx
-160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
-
-C VV*H*F (ny x nx)
- DO 170 I=1,iny
- DO 170 J=1,nx
-170 VVHF(I,J) = SUM(VV(I,1:iny)*HF(1:iny,J))
-
-C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
-C + F'*H'*VV*H*F
- DO 180 I=1,nx
- DO 180 J=1,nx
-180 OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
- + + SUM(HF(1:iny,I)*VVHF(1:iny,J))
-
-C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
-C - AA'*(I - OM C DINV C')*OM(+1)*LAM
-C + F'*H'*VV*(y(+1) - H*a - c*z)
-C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
- COM(1:iny,1) = 0.D0
- DO 185 I=1,iny
-185 COM(I,1) = SUM(c(IYK(IT+1,I),1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
-
- DO 190 I=1,nx
-190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
- + + SUM(B(I,1:iny)*(yk(IT+1,IYK(IT+1,1:iny))
- + - COM(1:iny,1)))
- DO 200 I=1,nx
-200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
- + - SUM(AOMCDICOM(I,:)*LAM(:))
- + + SUM(VVHF(1:iny,I)*(yk(IT+1,IYK(IT+1,1:iny))
- # - Ha(1:iny)-COM(1:iny,1)))
-
-250 CONTINUE
-
- ALLOCATE (XT(0:HFIX,nx),PT(0:HFIX,nx,nx),XT0(0:HFIX,nx),
- 1 PT0(0:HFIX,nx,nx),PTR2(HFIX+1,nstot,nstot),DLL(HFIX))
-
-C First block
- I0 = 1
- I1 = HFIX
- GN = 1.D0
- GO = 1.D0
- QN = 1.D0
- QO = 1.D0
-C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
- vd = genunf(0.D0,1.D0) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
- DO 300 IT = I1,I0,-1
- PR(:) = PTR(IT+1,Z(IT+1),:)*PM(IT,:)/PM(IT+1,Z(IT+1)) ! P[Z(j)|Z(j+1)]
- IF (vd.GT.delta) THEN ! sample from gn(x)
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PR(1)
- ISEQ = 1
- DO 290 WHILE (AUX.LT.v)
- ISEQ = ISEQ + 1
-290 AUX = AUX + PR(ISEQ)
- ELSE
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PM(IT,1)
- ISEQ = 1
- DO 291 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-291 AUX = AUX + PM(IT,ISEQ)
- ENDIF
- Z(IT) = ISEQ
- GN = GN*PM(IT,ISEQ)
- GO = GO*PM(IT,Z0(IT))
- QN = QN*PR(ISEQ)
-300 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PM(IT,Z0(IT))/PM(IT+1,Z0(IT+1)) ! P[Z0(j)|Z0(j+1)]
-
- QN = delta*GN + (1.D0-delta)*QN
- QO = delta*GO + (1.D0-delta)*QO
-
- IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
- IND(1,1) = 0
- IND(2:HFIX+2,1) = Z0(1:HFIX+1)
- PS0 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
- IND(2:HFIX+2,1) = Z(1:HFIX+1)
- PS1 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
-
- DO 305 I = 1,max(d(1),HFIX)
-305 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
-
- CALL IKF(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
- 1 IYK(1:id1,:),c,H,G,a,F,R,Xdd,Pdd,DLL(1:d(1)))
- XT(d(1),1:nx) = Xdd(id1,1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
- CALL KF(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
- 1 IYK(1:HFIX,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- AUX1=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT(HFIX,:),PT(HFIX,:,:),nx)
- PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
-
- DO 306 I = 1,max(d(1),HFIX)
-306 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I,:))
-
- CALL IKF(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
- 1 IYK(1:id1,:),c,H,G,a,F,R,Xdd,Pdd,DLL(1:d(1)))
- XT0(d(1),1:nx) = Xdd(id1,1:nx)
- PT0(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
- CALL KF(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
- 1 IYK(1:HFIX,:),c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
- AUX0=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
- PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
-
-c PA = DEXP(PN-PO)*QO/QN
- PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
- PA = DEXP(PA)
- ELSE
- DO 307 I = 1,max(d(1),HFIX)
-307 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
-
- CALL IKF(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
- 1 IYK(1:id1,:),c,H,G,a,F,R,Xdd,Pdd,DLL(1:d(1)))
- XT(d(1),1:nx) = Xdd(id1,1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
- CALL KF(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
- 1 IYK(1:HFIX,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- XT0(HFIX,:) = XT(HFIX,:)
- PT0(HFIX,:,:)= PT(HFIX,:,:)
- PA = 1.D0
- ENDIF
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- IF (v.GT.PA) THEN
- IACC = 0
- Z(1:HFIX) = Z0(1:HFIX)
- ACCRATE(1:HFIX) = ACCRATE(1:HFIX) + 1
- ELSE
- Z0(1:HFIX) = Z(1:HFIX)
- IACC = 1
- ENDIF
-
-C Inner blocks
- DO 400 WHILE (I1.LT.(nobs-HFIX))
- I1 = I1 + HFIX
- I0 = I1 - HFIX + 1
- GN = 1.D0
- GO = 1.D0
- QN = 1.D0
- QO = 1.D0
-C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
- vd = genunf(0.D0,1.D0)
- PTR2(1,:,:) = PTR(I0,:,:) ! q[Z(t+1)|Z(t)]
- DO 310 J = 2,HFIX+1 ! q[Z(t+j)|Z(t)] j = 2,...,HFIX+1
- DO 310 IC = 1,nstot
- DO 310 IR = 1,nstot
-310 PTR2(J,IR,IC) = SUM(PTR(I0+J-1,IR,:)*PTR2(J-1,:,IC))
- DO 350 IT = I1,I0,-1 ! t+h,t+h-1,...,t+j,...,t+1
- K = IT - I0 + 1 ! h,h-1,...,1
- PR(:) = PTR(IT+1,Z(IT+1),:)*PTR2(K,:,Z(I0-1))
- # / PTR2(K+1,Z(IT+1),Z(I0-1))
- IF (vd.GT.delta) THEN ! sample from gn(x)
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PR(1)
- ISEQ = 1
- DO 320 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-320 AUX = AUX + PR(ISEQ)
- ELSE
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PM(IT,1)
- ISEQ = 1
- DO 322 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-322 AUX = AUX + PM(IT,ISEQ)
- ENDIF
- Z(IT) = ISEQ
- GN = GN*PM(IT,ISEQ)
- GO = GO*PM(IT,Z0(IT))
- QN = QN*PR(ISEQ)
-350 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PTR2(K,Z0(IT),Z0(I0-1))
- # / PTR2(K+1,Z0(IT+1),Z0(I0-1)) ! P[Z0(j)|Z0(j+1)]
-
- QN = delta*GN + (1.D0-delta)*QN
- QO = delta*GO + (1.D0-delta)*QO
-
- IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
- IND(1:HFIX+2,1) = Z0(I0-1:I1+1)
- PS0 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
- IND(1:HFIX+2,1) = Z(I0-1:I1+1)
- PS1 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
-
- XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
- PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
- XT0(0,:) = XT(0,:)
- PT0(0,:,:)= PT(0,:,:)
-
- DO 360 I = I0,I1
-360 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
- CALL KF(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
- 1 IYK(I0:I1,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- AUX1=LEMMA4(OM(I1,:,:),MU(I1,:),XT(HFIX,:),PT(HFIX,:,:),nx)
- PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
-
- DO 361 I = I0,I1
-361 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
- 1 IYK(I0:I1,:),c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
- AUX0=LEMMA4(OM(I1,:,:),MU(I1,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
- PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
-C PA = DEXP(PN-PO)*QO/QN
- PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
- PA = DEXP(PA)
- ELSE
- XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
- PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
-
- DO 362 I = I0,I1
-362 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
- 1 IYK(I0:I1,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- XT0(HFIX,:) = XT(HFIX,:)
- PT0(HFIX,:,:)= PT(HFIX,:,:)
- PA = 1.D0
- ENDIF
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- IF (v.GT.PA) THEN
- Z(I0:I1) = Z0(I0:I1)
- ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
- IACC = 0
- ELSE
- Z0(I0:I1) = Z(I0:I1)
- IACC = 1
- ENDIF
-400 CONTINUE
-
-C Last block
- I0 = I1+1
- I1 = nobs
- HFIXL = I1 - I0 + 1
- QN = 1.D0
- QO = 1.D0
-C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
- vd = genunf(0.D0,1.D0)
- DO 500 IT = HFIXL,1,-1
- IF (vd.GT.delta) THEN ! sample from gn(x)
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PTR(nobs-IT+1,1,Z(nobs-IT)) !nobs-9: nobs
- ISEQ = 1
- DO 450 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-450 AUX = AUX + PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
- ELSE
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PM(nobs-IT+1,1)
- ISEQ = 1
- DO 451 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-451 AUX = AUX + PM(nobs-IT+1,ISEQ)
- ENDIF
- Z(nobs-IT+1) = ISEQ
- GN = GN*PM(nobs-IT+1,ISEQ)
- GO = GO*PM(nobs-IT+1,Z0(nobs-IT+1))
- QN = QN*PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
-500 QO = QO*PTR(nobs-IT+1,Z0(nobs-IT+1),Z0(nobs-IT))
-
- QN = delta*GN + (1.D0-delta)*QN
- QO = delta*GO + (1.D0-delta)*QO
-
- IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
- IND(HFIXL+2,1) = 0
- IND(1:HFIXL+1,1) = Z0(I0-1:nobs)
- PS0 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
- IND(1:HFIXL+1,1) = Z(I0-1:nobs)
- PS1 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
-
- XT(0,:) = IACC*XT(HFIXL,:) + (1-IACC)*XT0(HFIXL,:) ! Xt|t
- PT(0,:,:) = IACC*PT(HFIXL,:,:)+ (1-IACC)*PT0(HFIXL,:,:) ! Pt|t
- XT0(0,:) = XT(0,:)
- PT0(0,:,:)= PT(0,:,:)
-
- DO 510 I = I0,I1
-510 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
- 1 IYK(I0:I1,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIXL))
-
- PN = SUM(DLL(1:HFIXL)) + PS1 ! prior x likelihood
-
- DO 520 I = I0,I1
-520 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
- 1 IYK(I0:I1,:),c,H,G,a,F,R,XT0,PT0,DLL(1:HFIXL))
-
- PO = SUM(DLL(1:HFIXL)) + PS0 ! prior x likelihood
-C PA = DEXP(PN-PO)*QO/QN
- PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
- PA = DEXP(PA)
- ELSE
- PA = 1.D0
- ENDIF
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- IF (v.GT.PA) THEN
- Z(I0:I1) = Z0(I0:I1)
- ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
- ELSE
- Z0(I0:I1) = Z(I0:I1)
- ENDIF
-
- DO I=1,nobs
- CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
- ENDDO
-
- DEALLOCATE (XT,PT,XT0,PT0,PTR2,DLL)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE AMH(HFIX,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 yk,IYK,theta,psi,PTR,PM,INFOS,pdll,Z,S,ACCRATE)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia)
+ POINTER (pdesign,DESIGN)
+
+C INPUT
+ INTEGER HFIX,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,
+ 1 IYK(nobs,ny+1),INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
+ 1 PTR(nobs,nstot,nstot),PM(nobs,nstot)
+
+C INPUT/OUTPUT
+ INTEGER Z(nobs),S(nobs,6),ACCRATE(nobs)
+
+C LOCALS
+ INTEGER IT,I,II,J,JJ,K,IFAIL,ISEQ,iny,HFIXL,I0,I1,IACC,IC,IR,id1
+ INTEGER Z0(nobs),IS(6),IND(HFIX+2,6),SEQ(nv),dn(2)
+ DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot),
+ 4 PALL(nstot,nstot,HFIX+1)
+ DOUBLE PRECISION Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx)
+ DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
+ DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
+ 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
+ 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
+ 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
+ 4 VVHF(ny,nx),WORK(3*nx),LAM(nx),PR(nstot),
+ 5 QN,QO,PA,PN,PO,GN,GO,AUX,delta,v,vd,PS0,PS1,AUX1,AUX0
+ DOUBLE PRECISION, ALLOCATABLE:: DLL(:),XT(:,:),PT(:,:,:),
+ 1 XT0(:,:),PT0(:,:,:),PTR2(:,:,:)
+ DOUBLE PRECISION EPS,ONE,ZERO
+ DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
+ DOUBLE PRECISION LEMMA4,MARKOVP,genunf
+
+ dn(1) = 0
+ dn(2) = d(2)
+ id1 = max(1,d(1))
+ Z0 = Z
+ delta = 1.D-3
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
+C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+C KOLMOGOROV EQNS
+ PALL(:,:,1) = PMAT
+ DO J = 2,HFIX+1 ! Kolmogorov eqns
+ DO jj = 1,nstot
+ DO ii = 1,nstot-1
+ PALL(ii,jj,J) = SUM(PALL(ii,:,1)*PALL(:,jj,J-1))
+ ENDDO
+ PALL(nstot,jj,J) = 1.D0-SUM(PALL(1:nstot-1,jj,J))
+ ENDDO
+ ENDDO
+
+C OMEGA and MU RECURSIONS
+ OM(:,:,:)= ZERO
+ MU(:,:) = ZERO
+ DO 250 IT = nobs-1,1,-1
+C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
+ CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
+ iny = IYK(IT+1,ny+1)
+
+ DO 10 I=1,iny
+ Ha(I) = SUM(H(IYK(IT+1,I),:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
+ DO 10 J=1,nu
+10 HRG(I,J) = SUM(H(IYK(IT+1,I),:,IS(2))*R(:,J,IS(6)))
+ + + G(IYK(IT+1,I),J,IS(3)) ! HR+G (ny x nu)
+
+ DO 20 I=1,iny
+ DO 20 J=1,iny
+20 VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
+
+ DO 30 I=1,iny
+ DO 30 J=1,nx
+30 HF(I,J)=SUM(H(IYK(IT+1,I),:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
+
+ COM(1:iny,1:iny) = VV(1:iny,1:iny)
+ IFAIL = -1
+C CALL F01ADF(iny,COM(1:iny+1,1:iny), iny+1, IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
+ DO 40 I=1,iny
+ DO 40 J=1,I
+ VV(I,J) = COM(I,J)
+40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
+
+C B = R*(H*R+G)'*VV (nx x ny)
+ DO 50 I=1,nu
+ DO 50 J=1,iny
+50 HRGV(I,J) = SUM(HRG(1:iny,I)*VV(1:iny,J)) ! (H*R+G)'*VV (nu x ny)
+
+ DO 60 I=1,nx
+ DO 60 J=1,iny
+60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
+
+ DO 70 I=1,nx
+ DO 70 J=1,nx
+ RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
+70 BH(I,J) = SUM(B(I,1:iny)*H(IYK(IT+1,1:iny),J,IS(2))) ! BH (nx x nx)
+
+C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
+ DO 80 I=1,nx
+ DO 80 J=1,nu
+80 BHRG(I,J) = SUM(B(I,1:iny)*HRG(1:iny,J))
+
+ DO 90 I=1,nx
+ DO 90 J=1,I
+90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
+
+ IFAIL=-1
+C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ DO 100 I=1,nx
+ IF (LAM(I).LE.EPS) LAM(I)= ZERO
+100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
+
+C AA = F - B*HF (nx x nx)
+ DO 110 I=1,nx
+ DO 110 J=1,nx
+110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:iny)*HF(1:iny,J))
+
+C OMC = OM(+1)*CS (nx x nx)
+ DO 120 I=1,nx
+ DO 120 J=1,nx
+120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
+
+C DD = I + CS'*OM(+1)*CS (nx x nx)
+ DD(:,:) = ZERO
+ DO 130 I=1,nx
+ DD(I,I) = ONE
+ DO 130 J=1,I
+ DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
+130 DD(J,I) = DD(I,J)
+
+C DI = inv(DD) (nx x nx)
+ COM1(1:nx,:) = DD(:,:)
+ IFAIL = -1
+C CALL F01ADF(nx,COM1,nx+1,IFAIL)
+ CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
+ CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
+ DO 135 I=1,nx
+ DO 135 J=1,I
+ DI(I,J) = COM1(I,J)
+135 DI(J,I) = DI(I,J)
+
+C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
+ DO 140 I=1,nx
+ DO 140 J=1,nx
+140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
+
+ OMCDIC(:,:) = ZERO
+ DO 145 I=1,nx
+ OMCDIC(I,I) = ONE
+ DO 145 J=1,nx
+145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
+
+C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
+ DO 150 I=1,nx
+ DO 150 J=1,nx
+150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
+
+C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
+ DO 160 I=1,nx
+ DO 160 J=1,nx
+160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
+
+C VV*H*F (ny x nx)
+ DO 170 I=1,iny
+ DO 170 J=1,nx
+170 VVHF(I,J) = SUM(VV(I,1:iny)*HF(1:iny,J))
+
+C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
+C + F'*H'*VV*H*F
+ DO 180 I=1,nx
+ DO 180 J=1,nx
+180 OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
+ + + SUM(HF(1:iny,I)*VVHF(1:iny,J))
+
+C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
+C - AA'*(I - OM C DINV C')*OM(+1)*LAM
+C + F'*H'*VV*(y(+1) - H*a - c*z)
+C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
+ COM(1:iny,1) = 0.D0
+ DO 185 I=1,iny
+185 COM(I,1) = SUM(c(IYK(IT+1,I),1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
+
+ DO 190 I=1,nx
+190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
+ + + SUM(B(I,1:iny)*(yk(IT+1,IYK(IT+1,1:iny))
+ + - COM(1:iny,1)))
+ DO 200 I=1,nx
+200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
+ + - SUM(AOMCDICOM(I,:)*LAM(:))
+ + + SUM(VVHF(1:iny,I)*(yk(IT+1,IYK(IT+1,1:iny))
+ # - Ha(1:iny)-COM(1:iny,1)))
+
+250 CONTINUE
+
+ ALLOCATE (XT(0:HFIX,nx),PT(0:HFIX,nx,nx),XT0(0:HFIX,nx),
+ 1 PT0(0:HFIX,nx,nx),PTR2(HFIX+1,nstot,nstot),DLL(HFIX))
+
+C First block
+ I0 = 1
+ I1 = HFIX
+ GN = 1.D0
+ GO = 1.D0
+ QN = 1.D0
+ QO = 1.D0
+C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
+ vd = genunf(0.D0,1.D0) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
+ DO 300 IT = I1,I0,-1
+ PR(:) = PTR(IT+1,Z(IT+1),:)*PM(IT,:)/PM(IT+1,Z(IT+1)) ! P[Z(j)|Z(j+1)]
+ IF (vd.GT.delta) THEN ! sample from gn(x)
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PR(1)
+ ISEQ = 1
+ DO 290 WHILE (AUX.LT.v)
+ ISEQ = ISEQ + 1
+290 AUX = AUX + PR(ISEQ)
+ ELSE
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PM(IT,1)
+ ISEQ = 1
+ DO 291 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+291 AUX = AUX + PM(IT,ISEQ)
+ ENDIF
+ Z(IT) = ISEQ
+ GN = GN*PM(IT,ISEQ)
+ GO = GO*PM(IT,Z0(IT))
+ QN = QN*PR(ISEQ)
+300 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PM(IT,Z0(IT))/PM(IT+1,Z0(IT+1)) ! P[Z0(j)|Z0(j+1)]
+
+ QN = delta*GN + (1.D0-delta)*QN
+ QO = delta*GO + (1.D0-delta)*QO
+
+ IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
+ IND(1,1) = 0
+ IND(2:HFIX+2,1) = Z0(1:HFIX+1)
+ PS0 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
+ IND(2:HFIX+2,1) = Z(1:HFIX+1)
+ PS1 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
+
+ DO 305 I = 1,max(d(1),HFIX)
+305 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
+
+ CALL IKF(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
+ 1 IYK(1:id1,:),c,H,G,a,F,R,Xdd,Pdd,DLL(1:d(1)))
+ XT(d(1),1:nx) = Xdd(id1,1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
+ CALL KF(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
+ 1 IYK(1:HFIX,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ AUX1=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT(HFIX,:),PT(HFIX,:,:),nx)
+ PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
+
+ DO 306 I = 1,max(d(1),HFIX)
+306 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I,:))
+
+ CALL IKF(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
+ 1 IYK(1:id1,:),c,H,G,a,F,R,Xdd,Pdd,DLL(1:d(1)))
+ XT0(d(1),1:nx) = Xdd(id1,1:nx)
+ PT0(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
+ CALL KF(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
+ 1 IYK(1:HFIX,:),c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
+ AUX0=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
+ PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
+
+c PA = DEXP(PN-PO)*QO/QN
+ PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
+ PA = DEXP(PA)
+ ELSE
+ DO 307 I = 1,max(d(1),HFIX)
+307 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
+
+ CALL IKF(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
+ 1 IYK(1:id1,:),c,H,G,a,F,R,Xdd,Pdd,DLL(1:d(1)))
+ XT(d(1),1:nx) = Xdd(id1,1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
+ CALL KF(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
+ 1 IYK(1:HFIX,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ XT0(HFIX,:) = XT(HFIX,:)
+ PT0(HFIX,:,:)= PT(HFIX,:,:)
+ PA = 1.D0
+ ENDIF
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ IF (v.GT.PA) THEN
+ IACC = 0
+ Z(1:HFIX) = Z0(1:HFIX)
+ ACCRATE(1:HFIX) = ACCRATE(1:HFIX) + 1
+ ELSE
+ Z0(1:HFIX) = Z(1:HFIX)
+ IACC = 1
+ ENDIF
+
+C Inner blocks
+ DO 400 WHILE (I1.LT.(nobs-HFIX))
+ I1 = I1 + HFIX
+ I0 = I1 - HFIX + 1
+ GN = 1.D0
+ GO = 1.D0
+ QN = 1.D0
+ QO = 1.D0
+C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
+ vd = genunf(0.D0,1.D0)
+ PTR2(1,:,:) = PTR(I0,:,:) ! q[Z(t+1)|Z(t)]
+ DO 310 J = 2,HFIX+1 ! q[Z(t+j)|Z(t)] j = 2,...,HFIX+1
+ DO 310 IC = 1,nstot
+ DO 310 IR = 1,nstot
+310 PTR2(J,IR,IC) = SUM(PTR(I0+J-1,IR,:)*PTR2(J-1,:,IC))
+ DO 350 IT = I1,I0,-1 ! t+h,t+h-1,...,t+j,...,t+1
+ K = IT - I0 + 1 ! h,h-1,...,1
+ PR(:) = PTR(IT+1,Z(IT+1),:)*PTR2(K,:,Z(I0-1))
+ # / PTR2(K+1,Z(IT+1),Z(I0-1))
+ IF (vd.GT.delta) THEN ! sample from gn(x)
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PR(1)
+ ISEQ = 1
+ DO 320 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+320 AUX = AUX + PR(ISEQ)
+ ELSE
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PM(IT,1)
+ ISEQ = 1
+ DO 322 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+322 AUX = AUX + PM(IT,ISEQ)
+ ENDIF
+ Z(IT) = ISEQ
+ GN = GN*PM(IT,ISEQ)
+ GO = GO*PM(IT,Z0(IT))
+ QN = QN*PR(ISEQ)
+350 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PTR2(K,Z0(IT),Z0(I0-1))
+ # / PTR2(K+1,Z0(IT+1),Z0(I0-1)) ! P[Z0(j)|Z0(j+1)]
+
+ QN = delta*GN + (1.D0-delta)*QN
+ QO = delta*GO + (1.D0-delta)*QO
+
+ IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
+ IND(1:HFIX+2,1) = Z0(I0-1:I1+1)
+ PS0 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
+ IND(1:HFIX+2,1) = Z(I0-1:I1+1)
+ PS1 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
+
+ XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
+ PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
+ XT0(0,:) = XT(0,:)
+ PT0(0,:,:)= PT(0,:,:)
+
+ DO 360 I = I0,I1
+360 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+ CALL KF(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
+ 1 IYK(I0:I1,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ AUX1=LEMMA4(OM(I1,:,:),MU(I1,:),XT(HFIX,:),PT(HFIX,:,:),nx)
+ PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
+
+ DO 361 I = I0,I1
+361 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
+ 1 IYK(I0:I1,:),c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
+ AUX0=LEMMA4(OM(I1,:,:),MU(I1,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
+ PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
+C PA = DEXP(PN-PO)*QO/QN
+ PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
+ PA = DEXP(PA)
+ ELSE
+ XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
+ PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
+
+ DO 362 I = I0,I1
+362 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
+ 1 IYK(I0:I1,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ XT0(HFIX,:) = XT(HFIX,:)
+ PT0(HFIX,:,:)= PT(HFIX,:,:)
+ PA = 1.D0
+ ENDIF
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ IF (v.GT.PA) THEN
+ Z(I0:I1) = Z0(I0:I1)
+ ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
+ IACC = 0
+ ELSE
+ Z0(I0:I1) = Z(I0:I1)
+ IACC = 1
+ ENDIF
+400 CONTINUE
+
+C Last block
+ I0 = I1+1
+ I1 = nobs
+ HFIXL = I1 - I0 + 1
+ QN = 1.D0
+ QO = 1.D0
+C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
+ vd = genunf(0.D0,1.D0)
+ DO 500 IT = HFIXL,1,-1
+ IF (vd.GT.delta) THEN ! sample from gn(x)
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PTR(nobs-IT+1,1,Z(nobs-IT)) !nobs-9: nobs
+ ISEQ = 1
+ DO 450 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+450 AUX = AUX + PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
+ ELSE
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PM(nobs-IT+1,1)
+ ISEQ = 1
+ DO 451 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+451 AUX = AUX + PM(nobs-IT+1,ISEQ)
+ ENDIF
+ Z(nobs-IT+1) = ISEQ
+ GN = GN*PM(nobs-IT+1,ISEQ)
+ GO = GO*PM(nobs-IT+1,Z0(nobs-IT+1))
+ QN = QN*PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
+500 QO = QO*PTR(nobs-IT+1,Z0(nobs-IT+1),Z0(nobs-IT))
+
+ QN = delta*GN + (1.D0-delta)*QN
+ QO = delta*GO + (1.D0-delta)*QO
+
+ IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
+ IND(HFIXL+2,1) = 0
+ IND(1:HFIXL+1,1) = Z0(I0-1:nobs)
+ PS0 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
+ IND(1:HFIXL+1,1) = Z(I0-1:nobs)
+ PS1 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
+
+ XT(0,:) = IACC*XT(HFIXL,:) + (1-IACC)*XT0(HFIXL,:) ! Xt|t
+ PT(0,:,:) = IACC*PT(HFIXL,:,:)+ (1-IACC)*PT0(HFIXL,:,:) ! Pt|t
+ XT0(0,:) = XT(0,:)
+ PT0(0,:,:)= PT(0,:,:)
+
+ DO 510 I = I0,I1
+510 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
+ 1 IYK(I0:I1,:),c,H,G,a,F,R,XT,PT,DLL(1:HFIXL))
+
+ PN = SUM(DLL(1:HFIXL)) + PS1 ! prior x likelihood
+
+ DO 520 I = I0,I1
+520 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
+ 1 IYK(I0:I1,:),c,H,G,a,F,R,XT0,PT0,DLL(1:HFIXL))
+
+ PO = SUM(DLL(1:HFIXL)) + PS0 ! prior x likelihood
+C PA = DEXP(PN-PO)*QO/QN
+ PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
+ PA = DEXP(PA)
+ ELSE
+ PA = 1.D0
+ ENDIF
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ IF (v.GT.PA) THEN
+ Z(I0:I1) = Z0(I0:I1)
+ ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
+ ELSE
+ Z0(I0:I1) = Z(I0:I1)
+ ENDIF
+
+ DO I=1,nobs
+ CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
+ ENDDO
+
+ DEALLOCATE (XT,PT,XT0,PT0,PTR2,DLL)
+
+ RETURN
END
diff --git a/amh2.for b/amh2.for
index 09d2fa174f379f7a9c5214e551b7edd184584ab7..1779a0cc704f766be46bbfaa10d25b9d548aefed 100644
--- a/amh2.for
+++ b/amh2.for
@@ -1,50 +1,50 @@
-C -------------------------------------------------------------
-C AMH2 DRAWS THE DISCRETE LATENT VARIABLE IN BLOCKS (no missing values)
-C (see Fiorentini, Planas and Rossi, Statistics and Computing, 2014, 24, 77-89)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
-C x Pr[Z(t)|Z(\t)]
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C FURTHER INPUT
-C nobs: # of observatios
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C nv: # of discrete latent variables (S1,S2,...)
-C ns: ns1,ns2,...
-C nstot: total # of states (states of S1 x S2 x ...x Snv)
-C nt: dimension of theta
-C np: dimension of psi
-C PMAT: (nstot x nstot) one-step transition probabilities
-C PE: ergodic distribution of S1 x S2 x ...x Snv
-C INFOS: (9 x 6) set latent variables
-C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
-C PTR: transition porbabilities
-C PM: marginal probabilities
-C
-C OUTPUT
-C Z:(nobs x 1) takes values {1,2,...,nstot}
-C ACCRATE: CUMULATES ACCEPTANS 1 IF DRAW IS ACCEPTED 0 Otherwise
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C AMH2 DRAWS THE DISCRETE LATENT VARIABLE IN BLOCKS (no missing values)
+C (see Fiorentini, Planas and Rossi, Statistics and Computing, 2014, 24, 77-89)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
+C x Pr[Z(t)|Z(\t)]
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C FURTHER INPUT
+C nobs: # of observatios
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C nv: # of discrete latent variables (S1,S2,...)
+C ns: ns1,ns2,...
+C nstot: total # of states (states of S1 x S2 x ...x Snv)
+C nt: dimension of theta
+C np: dimension of psi
+C PMAT: (nstot x nstot) one-step transition probabilities
+C PE: ergodic distribution of S1 x S2 x ...x Snv
+C INFOS: (9 x 6) set latent variables
+C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
+C PTR: transition porbabilities
+C PM: marginal probabilities
+C
+C OUTPUT
+C Z:(nobs x 1) takes values {1,2,...,nstot}
+C ACCRATE: CUMULATES ACCEPTANS 1 IF DRAW IS ACCEPTED 0 Otherwise
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -55,512 +55,512 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE AMH2(HFIX,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,yk,
- 1 theta,psi,PTR,PM,INFOS,pdll,Z,S,ACCRATE)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER HFIX,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,
- 1 INFOS(9,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
- 1 PTR(nobs,nstot,nstot),PM(nobs,nstot)
-
-C INPUT/OUTPUT
- INTEGER Z(nobs),S(nobs,6),ACCRATE(nobs)
-
-C LOCALS
- INTEGER IT,I,II,J,JJ,K,IFAIL,ISEQ,HFIXL,I0,I1,IACC,IC,IR,id1
- INTEGER Z0(nobs),IS(6),IND(HFIX+2,6),SEQ(nv),dn(2)
- DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot),
- 4 PALL(nstot,nstot,HFIX+1)
- DOUBLE PRECISION Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx)
- DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
- DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
- 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
- 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
- 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
- 4 VVHF(ny,nx),WORK(3*nx),LAM(nx),PR(nstot),
- 5 QN,QO,PA,PN,PO,GN,GO,AUX,delta,v,vd,PS0,PS1,AUX1,AUX0
- DOUBLE PRECISION, ALLOCATABLE:: DLL(:),XT(:,:),PT(:,:,:),
- 1 XT0(:,:),PT0(:,:,:),PTR2(:,:,:)
- DOUBLE PRECISION EPS,ONE,ZERO
- DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
- DOUBLE PRECISION LEMMA4,MARKOVP,genunf
-
- dn(1) = 0
- dn(2) = d(2)
- id1 = max(d(1),1)
- Z0 = Z
- delta = 1.D-3
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
-C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-
-C KOLMOGOROV EQNS
- PALL(:,:,1) = PMAT
- DO J = 2,HFIX+1 ! Kolmogorov eqns
- DO jj = 1,nstot
- DO ii = 1,nstot-1
- PALL(ii,jj,J) = SUM(PALL(ii,:,1)*PALL(:,jj,J-1))
- ENDDO
- PALL(nstot,jj,J) = 1.D0-SUM(PALL(1:nstot-1,jj,J))
- ENDDO
- ENDDO
-
-C OMEGA and MU RECURSIONS
- OM(:,:,:)= ZERO
- MU(:,:) = ZERO
- DO 250 IT = nobs-1,1,-1
-C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
- CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
-
- DO 10 I=1,ny
- Ha(I) = SUM(H(I,:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
- DO 10 J=1,nu
-10 HRG(I,J) = SUM(H(I,:,IS(2))*R(:,J,IS(6)))
- + + G(I,J,IS(3)) ! HR+G (ny x nu)
-
- DO 20 I=1,ny
- VV(I,I) = SUM(HRG(I,1:nu)*HRG(I,1:nu))
- DO 20 J=1,I-1
- VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
-20 VV(J,I) = VV(I,J)
-
- DO 30 I=1,ny
- DO 30 J=1,nx
-30 HF(I,J)=SUM(H(I,:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
-
- COM(1:ny,1:ny) = VV(1:ny,1:ny)
- IFAIL = -1
-C CALL F01ADF(ny,COM(1:ny+1,1:ny), ny+1, IFAIL)
- CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
- DO 40 I=1,ny
- DO 40 J=1,I
- VV(I,J) = COM(I,J)
-40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
-
-C B = R*(H*R+G)'*VV (nx x ny)
- DO 50 I=1,nu
- DO 50 J=1,ny
-50 HRGV(I,J) = SUM(HRG(1:ny,I)*VV(1:ny,J)) ! (H*R+G)'*VV (nu x ny)
-
- DO 60 I=1,nx
- DO 60 J=1,ny
-60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
-
- DO 70 I=1,nx
- DO 70 J=1,nx
-70 BH(I,J) = SUM(B(I,1:ny)*H(1:ny,J,IS(2))) ! BH (nx x nx)
-
- DO 75 I=1,nx
- RR(I,I) = SUM(R(I,:,IS(6))*R(I,:,IS(6)))
- DO 75 J=1,I-1
- RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
-75 RR(J,I) = RR(I,J)
-
-C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
- DO 80 I=1,nx
- DO 80 J=1,nu
-80 BHRG(I,J) = SUM(B(I,1:ny)*HRG(1:ny,J))
-
- DO 90 I=1,nx
- DO 90 J=1,I
-90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
-
- IFAIL=-1
-C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- DO 100 I=1,nx
- IF (LAM(I).LE.EPS) LAM(I)= ZERO
-100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
-
-C AA = F - B*HF (nx x nx)
- DO 110 I=1,nx
- DO 110 J=1,nx
-110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:ny)*HF(1:ny,J))
-
-C OMC = OM(+1)*CS (nx x nx)
- DO 120 I=1,nx
- DO 120 J=1,nx
-120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
-
-C DD = I + CS'*OM(+1)*CS (nx x nx)
- DD(:,:) = ZERO
- DO 130 I=1,nx
- DD(I,I) = ONE
- DO 130 J=1,I
- DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
-130 DD(J,I) = DD(I,J)
-
-C DI = inv(DD) (nx x nx)
- COM1(1:nx,:) = DD(:,:)
- IFAIL = -1
-C CALL F01ADF(nx,COM1,nx+1,IFAIL)
- CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
- CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
- DO 135 I=1,nx
- DO 135 J=1,I
- DI(I,J) = COM1(I,j)
-135 DI(J,I) = DI(I,J)
-
-C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
- DO 140 I=1,nx
- DO 140 J=1,nx
-140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
-
- OMCDIC(:,:) = ZERO
- DO 145 I=1,nx
- OMCDIC(I,I) = ONE
- DO 145 J=1,nx
-145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
-
-C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
- DO 150 I=1,nx
- DO 150 J=1,nx
-150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
-
-C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
- DO 160 I=1,nx
- DO 160 J=1,nx
-160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
-
-C VV*H*F (ny x nx)
- DO 170 I=1,ny
- DO 170 J=1,nx
-170 VVHF(I,J) = SUM(VV(I,1:ny)*HF(1:ny,J))
-
-C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
-C + F'*H'*VV*H*F
- DO 180 I=1,nx
- OM(IT,I,I) = SUM(AOMCDICOM(I,:)*AA(:,I))
- + + SUM(HF(1:ny,I)*VVHF(1:ny,I))
- DO 180 J=1,I-1
- OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
- + + SUM(HF(1:ny,I)*VVHF(1:ny,J))
-180 OM(IT,J,I) = OM(IT,I,J)
-
-C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
-C - AA'*(I - OM C DINV C')*OM(+1)*LAM
-C + F'*H'*VV*(y(+1) - H*a - c*z)
-C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
- COM(1:ny,1) = 0.D0
- DO 185 I=1,ny
-185 COM(I,1) = SUM(c(I,1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
-
- DO 190 I=1,nx
-190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
- + + SUM(B(I,1:ny)*(yk(IT+1,1:ny)
- + - COM(1:ny,1)))
- DO 200 I=1,nx
-200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
- + - SUM(AOMCDICOM(I,:)*LAM(:))
- + + SUM(VVHF(1:ny,I)*(yk(IT+1,1:ny)
- # - Ha(1:ny)-COM(1:ny,1)))
-250 CONTINUE
-
- ALLOCATE (XT(0:HFIX,nx),PT(0:HFIX,nx,nx),XT0(0:HFIX,nx),
- 1 PT0(0:HFIX,nx,nx),PTR2(HFIX+1,nstot,nstot),DLL(HFIX))
-
-C First block
- I0 = 1
- I1 = HFIX
- GN = 1.D0
- GO = 1.D0
- QN = 1.D0
- QO = 1.D0
-C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
- vd = genunf(0.D0,1.D0)
- DO 300 IT = I1,I0,-1
- PR(:) = PTR(IT+1,Z(IT+1),:)*PM(IT,:)/PM(IT+1,Z(IT+1)) ! P[Z(j)|Z(j+1)]
- IF (vd.GT.delta) THEN ! sample from gn(x)
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PR(1)
- ISEQ = 1
- DO 290 WHILE (AUX.LT.v)
- ISEQ = ISEQ + 1
-290 AUX = AUX + PR(ISEQ)
- ELSE
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PM(IT,1)
- ISEQ = 1
- DO 291 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-291 AUX = AUX + PM(IT,ISEQ)
- ENDIF
- Z(IT) = ISEQ
- GN = GN*PM(IT,ISEQ)
- GO = GO*PM(IT,Z0(IT))
- QN = QN*PR(ISEQ)
-300 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PM(IT,Z0(IT))/PM(IT+1,Z0(IT+1)) ! P[Z0(j)|Z0(j+1)]
-
- QN = delta*GN + (1.D0-delta)*QN
- QO = delta*GO + (1.D0-delta)*QO
-
- IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
- IND(1,1) = 0
- IND(2:HFIX+2,1) = Z0(1:HFIX+1)
- PS0 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
- IND(2:HFIX+2,1) = Z(1:HFIX+1)
- PS1 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
-
- DO 305 I = 1,max(d(1),HFIX)
-305 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
-
- CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
- 1 c,H,G,a,F,R,Xdd,Pdd,DLL(1:id1))
- XT(d(1),1:nx) = Xdd(id1,1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
- CALL KF2(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
- 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- AUX1=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT(HFIX,:),PT(HFIX,:,:),nx)
- PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
-
- DO 306 I = 1,max(d(1),HFIX)
-306 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I,:))
-
- CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
- 1 c,H,G,a,F,R,Xdd,Pdd,DLL(1:id1))
- XT0(d(1),1:nx) = Xdd(id1,1:nx)
- PT0(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
- CALL KF2(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
- 1 c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
- AUX0=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
- PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
-
-c PA = DEXP(PN-PO)*QO/QN
- PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
- PA = DEXP(PA)
- ELSE
- DO 307 I = 1,max(d(1),HFIX)
-307 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
-
- CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
- 1 c,H,G,a,F,R,Xdd,Pdd,DLL(1:id1))
- XT(d(1),1:nx) = Xdd(id1,1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
- CALL KF2(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
- 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- XT0(HFIX,:) = XT(HFIX,:)
- PT0(HFIX,:,:)= PT(HFIX,:,:)
- PA = 1.D0
- ENDIF
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- IF (v.GT.PA) THEN
- IACC = 0
- Z(1:HFIX) = Z0(1:HFIX)
- ACCRATE(1:HFIX) = ACCRATE(1:HFIX) + 1
- ELSE
- Z0(1:HFIX) = Z(1:HFIX)
- IACC = 1
- ENDIF
-
-C Inner blocks
- DO 400 WHILE (I1.LT.(nobs-HFIX))
- I1 = I1 + HFIX
- I0 = I1 - HFIX + 1
- GN = 1.D0
- GO = 1.D0
- QN = 1.D0
- QO = 1.D0
-C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
- vd = genunf(0.D0,1.D0)
- PTR2(1,:,:) = PTR(I0,:,:) ! q[Z(t+1)|Z(t)]
- DO 310 J = 2,HFIX+1 ! q[Z(t+j)|Z(t)] j = 2,...,HFIX+1
- DO 310 IC = 1,nstot
- DO 310 IR = 1,nstot
-310 PTR2(J,IR,IC) = SUM(PTR(I0+J-1,IR,:)*PTR2(J-1,:,IC))
- DO 350 IT = I1,I0,-1 ! t+h,t+h-1,...,t+j,...,t+1
- K = IT - I0 + 1 ! h,h-1,...,1
- PR(:) = PTR(IT+1,Z(IT+1),:)*PTR2(K,:,Z(I0-1))
- # / PTR2(K+1,Z(IT+1),Z(I0-1))
- IF (vd.GT.delta) THEN ! sample from gn(x)
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PR(1)
- ISEQ = 1
- DO 320 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-320 AUX = AUX + PR(ISEQ)
- ELSE
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PM(IT,1)
- ISEQ = 1
- DO 322 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-322 AUX = AUX + PM(IT,ISEQ)
- ENDIF
- Z(IT) = ISEQ
- GN = GN*PM(IT,ISEQ)
- GO = GO*PM(IT,Z0(IT))
- QN = QN*PR(ISEQ)
-350 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PTR2(K,Z0(IT),Z0(I0-1))
- # / PTR2(K+1,Z0(IT+1),Z0(I0-1)) ! P[Z0(j)|Z0(j+1)]
-
- QN = delta*GN + (1.D0-delta)*QN
- QO = delta*GO + (1.D0-delta)*QO
-
- IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
- IND(1:HFIX+2,1) = Z0(I0-1:I1+1)
- PS0 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
- IND(1:HFIX+2,1) = Z(I0-1:I1+1)
- PS1 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
-
- XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
- PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
- XT0(0,:) = XT(0,:)
- PT0(0,:,:)= PT(0,:,:)
-
- DO 360 I = I0,I1
-360 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
- CALL KF2(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
- 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- AUX1=LEMMA4(OM(I1,:,:),MU(I1,:),XT(HFIX,:),PT(HFIX,:,:),nx)
- PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
-
- DO 361 I = I0,I1
-361 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF2(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
- 1 c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
- AUX0=LEMMA4(OM(I1,:,:),MU(I1,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
- PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
-C PA = DEXP(PN-PO)*QO/QN
- PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
- PA = DEXP(PA)
- ELSE
- XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
- PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
-
- DO 362 I = I0,I1
-362 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF2(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
- 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
- XT0(HFIX,:) = XT(HFIX,:)
- PT0(HFIX,:,:)= PT(HFIX,:,:)
- PA = 1.D0
- ENDIF
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- IF (v.GT.PA) THEN
- Z(I0:I1) = Z0(I0:I1)
- ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
- IACC = 0
- ELSE
- Z0(I0:I1) = Z(I0:I1)
- IACC = 1
- ENDIF
-400 CONTINUE
-
-C Last block
- I0 = I1+1
- I1 = nobs
- HFIXL = I1 - I0 + 1
- QN = 1.D0
- QO = 1.D0
-C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
- vd = genunf(0.D0,1.D0)
- DO 500 IT = HFIXL,1,-1
- IF (vd.GT.delta) THEN ! sample from gn(x)
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PTR(nobs-IT+1,1,Z(nobs-IT)) !nobs-9: nobs
- ISEQ = 1
- DO 450 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-450 AUX = AUX + PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
- ELSE
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- AUX = PM(nobs-IT+1,1)
- ISEQ = 1
- DO 451 WHILE (AUX.LT.v)
- ISEQ = ISEQ+1
-451 AUX = AUX + PM(nobs-IT+1,ISEQ)
- ENDIF
- Z(nobs-IT+1) = ISEQ
- GN = GN*PM(nobs-IT+1,ISEQ)
- GO = GO*PM(nobs-IT+1,Z0(nobs-IT+1))
- QN = QN*PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
-500 QO = QO*PTR(nobs-IT+1,Z0(nobs-IT+1),Z0(nobs-IT))
-
- QN = delta*GN + (1.D0-delta)*QN
- QO = delta*GO + (1.D0-delta)*QO
-
- IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
- IND(HFIXL+2,1) = 0
- IND(1:HFIXL+1,1) = Z0(I0-1:nobs)
- PS0 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
- IND(1:HFIXL+1,1) = Z(I0-1:nobs)
- PS1 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
-
- XT(0,:) = IACC*XT(HFIXL,:) + (1-IACC)*XT0(HFIXL,:) ! Xt|t
- PT(0,:,:) = IACC*PT(HFIXL,:,:)+ (1-IACC)*PT0(HFIXL,:,:) ! Pt|t
- XT0(0,:) = XT(0,:)
- PT0(0,:,:)= PT(0,:,:)
-
- DO 510 I = I0,I1
-510 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF2(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
- 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIXL))
-
- PN = SUM(DLL(1:HFIXL)) + PS1 ! prior x likelihood
-
- DO 520 I = I0,I1
-520 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
-
- CALL KF2(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
- 1 c,H,G,a,F,R,XT0,PT0,DLL(1:HFIXL))
-
- PO = SUM(DLL(1:HFIXL)) + PS0 ! prior x likelihood
-C PA = DEXP(PN-PO)*QO/QN
- PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
- PA = DEXP(PA)
- ELSE
- PA = 1.D0
- ENDIF
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0)
- IF (v.GT.PA) THEN
- Z(I0:I1) = Z0(I0:I1)
- ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
- ELSE
- Z0(I0:I1) = Z(I0:I1)
- ENDIF
-
- DO I=1,nobs
- CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
- ENDDO
-
- DEALLOCATE (XT,PT,XT0,PT0,PTR2,DLL)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE AMH2(HFIX,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,yk,
+ 1 theta,psi,PTR,PM,INFOS,pdll,Z,S,ACCRATE)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER HFIX,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,
+ 1 INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
+ 1 PTR(nobs,nstot,nstot),PM(nobs,nstot)
+
+C INPUT/OUTPUT
+ INTEGER Z(nobs),S(nobs,6),ACCRATE(nobs)
+
+C LOCALS
+ INTEGER IT,I,II,J,JJ,K,IFAIL,ISEQ,HFIXL,I0,I1,IACC,IC,IR,id1
+ INTEGER Z0(nobs),IS(6),IND(HFIX+2,6),SEQ(nv),dn(2)
+ DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot),
+ 4 PALL(nstot,nstot,HFIX+1)
+ DOUBLE PRECISION Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx)
+ DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
+ DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
+ 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
+ 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
+ 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
+ 4 VVHF(ny,nx),WORK(3*nx),LAM(nx),PR(nstot),
+ 5 QN,QO,PA,PN,PO,GN,GO,AUX,delta,v,vd,PS0,PS1,AUX1,AUX0
+ DOUBLE PRECISION, ALLOCATABLE:: DLL(:),XT(:,:),PT(:,:,:),
+ 1 XT0(:,:),PT0(:,:,:),PTR2(:,:,:)
+ DOUBLE PRECISION EPS,ONE,ZERO
+ DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
+ DOUBLE PRECISION LEMMA4,MARKOVP,genunf
+
+ dn(1) = 0
+ dn(2) = d(2)
+ id1 = max(d(1),1)
+ Z0 = Z
+ delta = 1.D-3
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
+C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+
+C KOLMOGOROV EQNS
+ PALL(:,:,1) = PMAT
+ DO J = 2,HFIX+1 ! Kolmogorov eqns
+ DO jj = 1,nstot
+ DO ii = 1,nstot-1
+ PALL(ii,jj,J) = SUM(PALL(ii,:,1)*PALL(:,jj,J-1))
+ ENDDO
+ PALL(nstot,jj,J) = 1.D0-SUM(PALL(1:nstot-1,jj,J))
+ ENDDO
+ ENDDO
+
+C OMEGA and MU RECURSIONS
+ OM(:,:,:)= ZERO
+ MU(:,:) = ZERO
+ DO 250 IT = nobs-1,1,-1
+C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
+ CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
+
+ DO 10 I=1,ny
+ Ha(I) = SUM(H(I,:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
+ DO 10 J=1,nu
+10 HRG(I,J) = SUM(H(I,:,IS(2))*R(:,J,IS(6)))
+ + + G(I,J,IS(3)) ! HR+G (ny x nu)
+
+ DO 20 I=1,ny
+ VV(I,I) = SUM(HRG(I,1:nu)*HRG(I,1:nu))
+ DO 20 J=1,I-1
+ VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
+20 VV(J,I) = VV(I,J)
+
+ DO 30 I=1,ny
+ DO 30 J=1,nx
+30 HF(I,J)=SUM(H(I,:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
+
+ COM(1:ny,1:ny) = VV(1:ny,1:ny)
+ IFAIL = -1
+C CALL F01ADF(ny,COM(1:ny+1,1:ny), ny+1, IFAIL)
+ CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
+ DO 40 I=1,ny
+ DO 40 J=1,I
+ VV(I,J) = COM(I,J)
+40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
+
+C B = R*(H*R+G)'*VV (nx x ny)
+ DO 50 I=1,nu
+ DO 50 J=1,ny
+50 HRGV(I,J) = SUM(HRG(1:ny,I)*VV(1:ny,J)) ! (H*R+G)'*VV (nu x ny)
+
+ DO 60 I=1,nx
+ DO 60 J=1,ny
+60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
+
+ DO 70 I=1,nx
+ DO 70 J=1,nx
+70 BH(I,J) = SUM(B(I,1:ny)*H(1:ny,J,IS(2))) ! BH (nx x nx)
+
+ DO 75 I=1,nx
+ RR(I,I) = SUM(R(I,:,IS(6))*R(I,:,IS(6)))
+ DO 75 J=1,I-1
+ RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
+75 RR(J,I) = RR(I,J)
+
+C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
+ DO 80 I=1,nx
+ DO 80 J=1,nu
+80 BHRG(I,J) = SUM(B(I,1:ny)*HRG(1:ny,J))
+
+ DO 90 I=1,nx
+ DO 90 J=1,I
+90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
+
+ IFAIL=-1
+C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ DO 100 I=1,nx
+ IF (LAM(I).LE.EPS) LAM(I)= ZERO
+100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
+
+C AA = F - B*HF (nx x nx)
+ DO 110 I=1,nx
+ DO 110 J=1,nx
+110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:ny)*HF(1:ny,J))
+
+C OMC = OM(+1)*CS (nx x nx)
+ DO 120 I=1,nx
+ DO 120 J=1,nx
+120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
+
+C DD = I + CS'*OM(+1)*CS (nx x nx)
+ DD(:,:) = ZERO
+ DO 130 I=1,nx
+ DD(I,I) = ONE
+ DO 130 J=1,I
+ DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
+130 DD(J,I) = DD(I,J)
+
+C DI = inv(DD) (nx x nx)
+ COM1(1:nx,:) = DD(:,:)
+ IFAIL = -1
+C CALL F01ADF(nx,COM1,nx+1,IFAIL)
+ CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
+ CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
+ DO 135 I=1,nx
+ DO 135 J=1,I
+ DI(I,J) = COM1(I,j)
+135 DI(J,I) = DI(I,J)
+
+C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
+ DO 140 I=1,nx
+ DO 140 J=1,nx
+140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
+
+ OMCDIC(:,:) = ZERO
+ DO 145 I=1,nx
+ OMCDIC(I,I) = ONE
+ DO 145 J=1,nx
+145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
+
+C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
+ DO 150 I=1,nx
+ DO 150 J=1,nx
+150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
+
+C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
+ DO 160 I=1,nx
+ DO 160 J=1,nx
+160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
+
+C VV*H*F (ny x nx)
+ DO 170 I=1,ny
+ DO 170 J=1,nx
+170 VVHF(I,J) = SUM(VV(I,1:ny)*HF(1:ny,J))
+
+C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
+C + F'*H'*VV*H*F
+ DO 180 I=1,nx
+ OM(IT,I,I) = SUM(AOMCDICOM(I,:)*AA(:,I))
+ + + SUM(HF(1:ny,I)*VVHF(1:ny,I))
+ DO 180 J=1,I-1
+ OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
+ + + SUM(HF(1:ny,I)*VVHF(1:ny,J))
+180 OM(IT,J,I) = OM(IT,I,J)
+
+C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
+C - AA'*(I - OM C DINV C')*OM(+1)*LAM
+C + F'*H'*VV*(y(+1) - H*a - c*z)
+C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
+ COM(1:ny,1) = 0.D0
+ DO 185 I=1,ny
+185 COM(I,1) = SUM(c(I,1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
+
+ DO 190 I=1,nx
+190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
+ + + SUM(B(I,1:ny)*(yk(IT+1,1:ny)
+ + - COM(1:ny,1)))
+ DO 200 I=1,nx
+200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
+ + - SUM(AOMCDICOM(I,:)*LAM(:))
+ + + SUM(VVHF(1:ny,I)*(yk(IT+1,1:ny)
+ # - Ha(1:ny)-COM(1:ny,1)))
+250 CONTINUE
+
+ ALLOCATE (XT(0:HFIX,nx),PT(0:HFIX,nx,nx),XT0(0:HFIX,nx),
+ 1 PT0(0:HFIX,nx,nx),PTR2(HFIX+1,nstot,nstot),DLL(HFIX))
+
+C First block
+ I0 = 1
+ I1 = HFIX
+ GN = 1.D0
+ GO = 1.D0
+ QN = 1.D0
+ QO = 1.D0
+C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
+ vd = genunf(0.D0,1.D0)
+ DO 300 IT = I1,I0,-1
+ PR(:) = PTR(IT+1,Z(IT+1),:)*PM(IT,:)/PM(IT+1,Z(IT+1)) ! P[Z(j)|Z(j+1)]
+ IF (vd.GT.delta) THEN ! sample from gn(x)
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PR(1)
+ ISEQ = 1
+ DO 290 WHILE (AUX.LT.v)
+ ISEQ = ISEQ + 1
+290 AUX = AUX + PR(ISEQ)
+ ELSE
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PM(IT,1)
+ ISEQ = 1
+ DO 291 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+291 AUX = AUX + PM(IT,ISEQ)
+ ENDIF
+ Z(IT) = ISEQ
+ GN = GN*PM(IT,ISEQ)
+ GO = GO*PM(IT,Z0(IT))
+ QN = QN*PR(ISEQ)
+300 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PM(IT,Z0(IT))/PM(IT+1,Z0(IT+1)) ! P[Z0(j)|Z0(j+1)]
+
+ QN = delta*GN + (1.D0-delta)*QN
+ QO = delta*GO + (1.D0-delta)*QO
+
+ IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
+ IND(1,1) = 0
+ IND(2:HFIX+2,1) = Z0(1:HFIX+1)
+ PS0 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
+ IND(2:HFIX+2,1) = Z(1:HFIX+1)
+ PS1 = MARKOVP(PALL,PE,nstot,HFIX,1,nobs,IND(1:HFIX+2,1))
+
+ DO 305 I = 1,max(d(1),HFIX)
+305 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
+
+ CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
+ 1 c,H,G,a,F,R,Xdd,Pdd,DLL(1:id1))
+ XT(d(1),1:nx) = Xdd(id1,1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
+ CALL KF2(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
+ 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ AUX1=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT(HFIX,:),PT(HFIX,:,:),nx)
+ PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
+
+ DO 306 I = 1,max(d(1),HFIX)
+306 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I,:))
+
+ CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
+ 1 c,H,G,a,F,R,Xdd,Pdd,DLL(1:id1))
+ XT0(d(1),1:nx) = Xdd(id1,1:nx)
+ PT0(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
+ CALL KF2(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
+ 1 c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
+ AUX0=LEMMA4(OM(HFIX,:,:),MU(HFIX,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
+ PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
+
+c PA = DEXP(PN-PO)*QO/QN
+ PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
+ PA = DEXP(PA)
+ ELSE
+ DO 307 I = 1,max(d(1),HFIX)
+307 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
+
+ CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:id1,:),yk(1:id1,:),
+ 1 c,H,G,a,F,R,Xdd,Pdd,DLL(1:id1))
+ XT(d(1),1:nx) = Xdd(id1,1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(id1,1:nx,1:nx)
+ CALL KF2(HFIX,d,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(1:HFIX,:),
+ 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ XT0(HFIX,:) = XT(HFIX,:)
+ PT0(HFIX,:,:)= PT(HFIX,:,:)
+ PA = 1.D0
+ ENDIF
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ IF (v.GT.PA) THEN
+ IACC = 0
+ Z(1:HFIX) = Z0(1:HFIX)
+ ACCRATE(1:HFIX) = ACCRATE(1:HFIX) + 1
+ ELSE
+ Z0(1:HFIX) = Z(1:HFIX)
+ IACC = 1
+ ENDIF
+
+C Inner blocks
+ DO 400 WHILE (I1.LT.(nobs-HFIX))
+ I1 = I1 + HFIX
+ I0 = I1 - HFIX + 1
+ GN = 1.D0
+ GO = 1.D0
+ QN = 1.D0
+ QO = 1.D0
+C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
+ vd = genunf(0.D0,1.D0)
+ PTR2(1,:,:) = PTR(I0,:,:) ! q[Z(t+1)|Z(t)]
+ DO 310 J = 2,HFIX+1 ! q[Z(t+j)|Z(t)] j = 2,...,HFIX+1
+ DO 310 IC = 1,nstot
+ DO 310 IR = 1,nstot
+310 PTR2(J,IR,IC) = SUM(PTR(I0+J-1,IR,:)*PTR2(J-1,:,IC))
+ DO 350 IT = I1,I0,-1 ! t+h,t+h-1,...,t+j,...,t+1
+ K = IT - I0 + 1 ! h,h-1,...,1
+ PR(:) = PTR(IT+1,Z(IT+1),:)*PTR2(K,:,Z(I0-1))
+ # / PTR2(K+1,Z(IT+1),Z(I0-1))
+ IF (vd.GT.delta) THEN ! sample from gn(x)
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PR(1)
+ ISEQ = 1
+ DO 320 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+320 AUX = AUX + PR(ISEQ)
+ ELSE
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PM(IT,1)
+ ISEQ = 1
+ DO 322 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+322 AUX = AUX + PM(IT,ISEQ)
+ ENDIF
+ Z(IT) = ISEQ
+ GN = GN*PM(IT,ISEQ)
+ GO = GO*PM(IT,Z0(IT))
+ QN = QN*PR(ISEQ)
+350 QO = QO*PTR(IT+1,Z0(IT+1),Z0(IT))*PTR2(K,Z0(IT),Z0(I0-1))
+ # / PTR2(K+1,Z0(IT+1),Z0(I0-1)) ! P[Z0(j)|Z0(j+1)]
+
+ QN = delta*GN + (1.D0-delta)*QN
+ QO = delta*GO + (1.D0-delta)*QO
+
+ IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
+ IND(1:HFIX+2,1) = Z0(I0-1:I1+1)
+ PS0 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
+ IND(1:HFIX+2,1) = Z(I0-1:I1+1)
+ PS1 = MARKOVP(PALL,PE,nstot,HFIX,2,nobs,IND(1:HFIX+2,1))
+
+ XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
+ PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
+ XT0(0,:) = XT(0,:)
+ PT0(0,:,:)= PT(0,:,:)
+
+ DO 360 I = I0,I1
+360 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+ CALL KF2(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
+ 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ AUX1=LEMMA4(OM(I1,:,:),MU(I1,:),XT(HFIX,:),PT(HFIX,:,:),nx)
+ PN = AUX1 + SUM(DLL(1:HFIX)) + PS1 ! prior x likelihood
+
+ DO 361 I = I0,I1
+361 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF2(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
+ 1 c,H,G,a,F,R,XT0,PT0,DLL(1:HFIX))
+ AUX0=LEMMA4(OM(I1,:,:),MU(I1,:),XT0(HFIX,:),PT0(HFIX,:,:),nx)
+ PO = AUX0 + SUM(DLL(1:HFIX)) + PS0 ! prior x likelihood
+C PA = DEXP(PN-PO)*QO/QN
+ PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
+ PA = DEXP(PA)
+ ELSE
+ XT(0,:) = IACC*XT(HFIX,:) + (1-IACC)*XT0(HFIX,:) ! Xt|t
+ PT(0,:,:) = IACC*PT(HFIX,:,:)+ (1-IACC)*PT0(HFIX,:,:) ! Pt|t
+
+ DO 362 I = I0,I1
+362 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF2(HFIX,dn,ny,nz,nx,nu,ns,IND(1:HFIX,:),yk(I0:I1,:),
+ 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIX))
+ XT0(HFIX,:) = XT(HFIX,:)
+ PT0(HFIX,:,:)= PT(HFIX,:,:)
+ PA = 1.D0
+ ENDIF
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ IF (v.GT.PA) THEN
+ Z(I0:I1) = Z0(I0:I1)
+ ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
+ IACC = 0
+ ELSE
+ Z0(I0:I1) = Z(I0:I1)
+ IACC = 1
+ ENDIF
+400 CONTINUE
+
+C Last block
+ I0 = I1+1
+ I1 = nobs
+ HFIXL = I1 - I0 + 1
+ QN = 1.D0
+ QO = 1.D0
+C vd = G05CAF(vd) ! For qn(z) = delta*g0(z) + (1-delta)*gn(z)
+ vd = genunf(0.D0,1.D0)
+ DO 500 IT = HFIXL,1,-1
+ IF (vd.GT.delta) THEN ! sample from gn(x)
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PTR(nobs-IT+1,1,Z(nobs-IT)) !nobs-9: nobs
+ ISEQ = 1
+ DO 450 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+450 AUX = AUX + PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
+ ELSE
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ AUX = PM(nobs-IT+1,1)
+ ISEQ = 1
+ DO 451 WHILE (AUX.LT.v)
+ ISEQ = ISEQ+1
+451 AUX = AUX + PM(nobs-IT+1,ISEQ)
+ ENDIF
+ Z(nobs-IT+1) = ISEQ
+ GN = GN*PM(nobs-IT+1,ISEQ)
+ GO = GO*PM(nobs-IT+1,Z0(nobs-IT+1))
+ QN = QN*PTR(nobs-IT+1,ISEQ,Z(nobs-IT))
+500 QO = QO*PTR(nobs-IT+1,Z0(nobs-IT+1),Z0(nobs-IT))
+
+ QN = delta*GN + (1.D0-delta)*QN
+ QO = delta*GO + (1.D0-delta)*QO
+
+ IF (SUM(ABS(Z(I0:I1)-Z0(I0:I1))).NE.0) THEN
+ IND(HFIXL+2,1) = 0
+ IND(1:HFIXL+1,1) = Z0(I0-1:nobs)
+ PS0 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
+ IND(1:HFIXL+1,1) = Z(I0-1:nobs)
+ PS1 = MARKOVP(PALL,PE,nstot,HFIXL,nobs,nobs,IND(1:HFIXL+2,1))
+
+ XT(0,:) = IACC*XT(HFIXL,:) + (1-IACC)*XT0(HFIXL,:) ! Xt|t
+ PT(0,:,:) = IACC*PT(HFIXL,:,:)+ (1-IACC)*PT0(HFIXL,:,:) ! Pt|t
+ XT0(0,:) = XT(0,:)
+ PT0(0,:,:)= PT(0,:,:)
+
+ DO 510 I = I0,I1
+510 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF2(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
+ 1 c,H,G,a,F,R,XT,PT,DLL(1:HFIXL))
+
+ PN = SUM(DLL(1:HFIXL)) + PS1 ! prior x likelihood
+
+ DO 520 I = I0,I1
+520 CALL INT2SEQ(Z0(I),nv,INFOS,SEQ,IND(I-I0+1,:))
+
+ CALL KF2(HFIXL,dn,ny,nz,nx,nu,ns,IND(1:HFIXL,:),yk(I0:I1,:),
+ 1 c,H,G,a,F,R,XT0,PT0,DLL(1:HFIXL))
+
+ PO = SUM(DLL(1:HFIXL)) + PS0 ! prior x likelihood
+C PA = DEXP(PN-PO)*QO/QN
+ PA = MAX(MIN(PN-PO+DLOG(QO)-DLOG(QN),0.D0),-300.D0)
+ PA = DEXP(PA)
+ ELSE
+ PA = 1.D0
+ ENDIF
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0)
+ IF (v.GT.PA) THEN
+ Z(I0:I1) = Z0(I0:I1)
+ ACCRATE(I0:I1) = ACCRATE(I0:I1) + 1
+ ELSE
+ Z0(I0:I1) = Z(I0:I1)
+ ENDIF
+
+ DO I=1,nobs
+ CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
+ ENDDO
+
+ DEALLOCATE (XT,PT,XT0,PT0,PTR2,DLL)
+
+ RETURN
END
diff --git a/checkdesign.for b/checkdesign.for
index d4297d439362c5d4cd4fe003863e51c9dcf04b4a..68474ff3595c2afa4f5dc85157b37d3d6315272b 100644
--- a/checkdesign.for
+++ b/checkdesign.for
@@ -1,27 +1,27 @@
-C -------------------------------------------------------------
-C CHECKDESIGN cheks design.dll or design.m
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C CHECKDESIGN cheks design.dll or design.m
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -32,237 +32,237 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE CHECKDESIGN(ny,nz,nx,nu,ns,nt,d,theta,pdll,PATH,NMLNAME)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN)
-
-C INPUT
- INTEGER ny,nz,nx,nu,ns(6),nt,d(2)
- DOUBLE PRECISION theta(nt)
- CHARACTER*200 NMLNAME,PATH,FILEOUT
-
-C LOCALS
- INTEGER I,J,maxnz,IFAIL,ESTABLE
- DOUBLE PRECISION WORK(4*nx),WR(nx),WI(nx),VR(1),
- 1 VI(1),W(nx) !WRY(ny),WORK1(64*ny)
- DOUBLE PRECISION,ALLOCATABLE::c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:),R(:,:,:) !,HRG(:,:),HRGRH(:,:)
- CHARACTER*3 CJ
-C EXTERNAL SUBROUTINES
- EXTERNAL DGEEV
-
- ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))) !,HRG(ny,nu),HRGRH(ny,ny))
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-
- maxnz = max(1,nz)
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.CHK'
- OPEN(11,FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
-C write ny,nx,etc
- WRITE(11,1000) nt,ny,nx,nu,nz
-1000 FORMAT(' nt = ',I3,'; ny = ',I3,'; nx = ',I3,'; nu = ',I3,
- # '; nz = ',I3,';')
-
-C write theta
- WRITE(11,*) 'theta(1:nt) = ['
- WRITE(11,*) ' '
- WRITE(11,'(<nt>(F20.10))') theta(1:nt)
- WRITE(11,*) ']'
-
-C write c(ny,max(1,nz),ns(1))
- DO J = 1,ns(1)
- WRITE(11,*) ' '
- IF (J.LE.9) THEN
- WRITE(CJ,'(I1)') J
- ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
- WRITE(CJ,'(I2)') J
- ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
- WRITE(CJ,'(I3)') J
- ENDIF
- WRITE(11,*) 'c(1:ny,1:nz,'//TRIM(CJ)// ') = ['
- WRITE(11,*) ' '
- WRITE(11,'(<maxnz>(F20.10))') (c(I,1:maxnz,J),I=1,ny)
- WRITE(11,*) ']'
- ENDDO
-
-C write H(ny,nx,ns(2))
- DO J = 1,ns(2)
- WRITE(11,*) ' '
- IF (J.LE.9) THEN
- WRITE(CJ,'(I1)') J
- ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
- WRITE(CJ,'(I2)') J
- ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
- WRITE(CJ,'(I3)') J
- ENDIF
- WRITE(11,*) 'H(1:ny,1:nx,'//TRIM(CJ)// ') = ['
- WRITE(11,*) ' '
- WRITE(11,'(<nx>(F20.10))') (H(I,1:nx,J),I=1,ny)
- WRITE(11,*) ']'
- ENDDO
-
-C write G(ny,nu,ns(3))
- DO J = 1,ns(3)
- WRITE(11,*) ' '
- IF (J.LE.9) THEN
- WRITE(CJ,'(I1)') J
- ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
- WRITE(CJ,'(I2)') J
- ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
- WRITE(CJ,'(I3)') J
- ENDIF
- WRITE(11,*) 'G(1:ny,1:nu,'//TRIM(CJ)// ') = ['
- WRITE(11,*) ' '
- WRITE(11,'(<nu>(F20.10))') (G(I,1:nu,J),I=1,ny)
- WRITE(11,*) ']'
- ENDDO
-
-C write a(nx,ns(4))
- DO J = 1,ns(4)
- WRITE(11,*) ' '
- IF (J.LE.9) THEN
- WRITE(CJ,'(I1)') J
- ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
- WRITE(CJ,'(I2)') J
- ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
- WRITE(CJ,'(I3)') J
- ENDIF
- WRITE(11,*) 'a(1:nx,'//TRIM(CJ)// ') = ['
- WRITE(11,*) ' '
- WRITE(11,'(<1>(F20.10))') (a(I,J),I=1,nx)
- WRITE(11,*) ']'
- ENDDO
-
-C write F(nx,nx,ns(5))
- DO J = 1,ns(5)
- WRITE(11,*) ' '
- IF (J.LE.9) THEN
- WRITE(CJ,'(I1)') J
- ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
- WRITE(CJ,'(I2)') J
- ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
- WRITE(CJ,'(I3)') J
- ENDIF
- WRITE(11,*) 'F(1:nx,1:nx,'//TRIM(CJ)// ') = ['
- WRITE(11,*) ' '
- WRITE(11,'(<nx>(F20.10))') (F(I,1:nx,J),I=1,nx)
- WRITE(11,*) ']'
- ENDDO
-
-C write R(nx,nu,ns(6))
- DO J = 1,ns(6)
- WRITE(11,*) ' '
- IF (J.LE.9) THEN
- WRITE(CJ,'(I1)') J
- ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
- WRITE(CJ,'(I2)') J
- ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
- WRITE(CJ,'(I3)') J
- ENDIF
- WRITE(11,*) 'R(1:nx,1:nu,'//TRIM(CJ)// ') = ['
- WRITE(11,*) ' '
- WRITE(11,'(<nu>(F20.10))') (R(I,1:nu,J),I=1,nx)
- WRITE(11,*) ']'
- ENDDO
-
-C Check unstable eigenvalues of F
- DO J = 1,ns(5)
- IF (d(2).GT.0) THEN
- IFAIL=-1
-C CALL F02EBF('N',d(2),F(1:d(2),1:d(2),J),d(2),
-C 1 WR(1:d(2)),WI(1:d(2)),VR,1,VI,1,WORK,4*nx,IFAIL)
- CALL DGEEV('N','N',d(2),F(1:d(2),1:d(2),J),d(2),
- 1 WR(1:d(2)),WI(1:d(2)),VR,1,VI,1,WORK,4*nx,IFAIL)
-
- ESTABLE = 0
- DO I = 1,d(2)
- W(I) = WR(I)**2+WI(I)**2
- ESTABLE = ESTABLE + ABS(W(I).GE.1.D0)
- ENDDO
- IF (ESTABLE.NE.d(2)) THEN
- WRITE(11,*) ' '
- WRITE(11,*) 'WARNING: the number of unstable eigenvalues for '
- WRITE(11,*) 'F(1:nx,1:nx,'//TRIM(CJ)// 'is not equal to d(2) '
- WRITE(11,*) 'or non-stationary states are not placed in the'
- WRITE(11,*) 'first d(2) positions.'
- ENDIF
- ENDIF
-
-C Check stable eigenvalues of F
- IF (nx-d(2).GT.0) THEN
- IFAIL=-1
-c CALL F02EBF('N',nx-d(2),F(d(2)+1:nx,d(2)+1:nx,J),
-c 1 nx-d(2),WR,WI,VR,1,VI,1,WORK,4*nx,IFAIL)
- CALL DGEEV('N','N',nx-d(2),F(d(2)+1:nx,d(2)+1:nx,J),
- # nx-d(2),WR,WI,VR,1,VI,1,WORK,4*nx,IFAIL)
-
- ESTABLE = 0
- DO I = 1,nx-d(2)
- W(I) = WR(I)**2+WI(I)**2
- ESTABLE = ESTABLE + ABS(W(I).LT.1.D0)
- ENDDO
- IF (ESTABLE.NE.(nx-d(2))) THEN
- WRITE(11,*) ' '
- WRITE(11,*) 'WARNING: the number of stable eigenvalues for '
- WRITE(11,*) 'F(1:nx,1:nx,'//TRIM(CJ)//'is not equal to nx-d(2)'
- WRITE(11,*) 'or non-stationary states are not placed in the '
- WRITE(11,*) 'first d(2) positions.'
- ENDIF
- ENDIF
- ENDDO
-
- CLOSE(11)
- DEALLOCATE(c,H,G,a,F,R)
-
- RETURN
- PAUSE
- END
-
-C Check rank{(HR+G)*(HR+G)'} this check is wrong!!!
-c DO J = 1,ns(2) !H
-c DO JJ = 1,ns(3) !G
-c DO JJJ = 1,ns(6) !R
-
-c DO I =1,ny
-c DO K =1,nu
-c HRG(I,K) = SUM(H(I,1:nx,J)*R(1:nx,K,JJJ))+G(I,K,JJ)
-c ENDDO
-c ENDDO
-
-c DO I =1,ny
-c DO K =1,ny
-c HRGRH(I,K) = SUM(HRG(I,1:nu)*HRG(K,1:nu))
-c ENDDO
-c ENDDO
-
-c IFAIL = -1
-c CALL F02FAF('N','U',ny,HRGRH,ny,WRY(1:ny),WORK1,64*ny,IFAIL)
-c SRANK = 0
-c DO 10 I=1,ny
-c10 IF (WRY(I).GT.1.D-12) SRANK=SRANK+1
-
-c IF (SRANK.LT.ny) THEN
-c WRITE(11,*) ' '
-c WRITE(11,*) 'WARNING: the rank of the system computed looking '
-c WRITE(11,*) 'at rank{(HR+G)*transpose(HR+G)} is less than ny '
-c ENDIF
-
-c ENDDO
-c ENDDO
-c ENDDO
-
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE CHECKDESIGN(ny,nz,nx,nu,ns,nt,d,theta,pdll,PATH,NMLNAME)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN)
+
+C INPUT
+ INTEGER ny,nz,nx,nu,ns(6),nt,d(2)
+ DOUBLE PRECISION theta(nt)
+ CHARACTER*200 NMLNAME,PATH,FILEOUT
+
+C LOCALS
+ INTEGER I,J,maxnz,IFAIL,ESTABLE
+ DOUBLE PRECISION WORK(4*nx),WR(nx),WI(nx),VR(1),
+ 1 VI(1),W(nx) !WRY(ny),WORK1(64*ny)
+ DOUBLE PRECISION,ALLOCATABLE::c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:),R(:,:,:) !,HRG(:,:),HRGRH(:,:)
+ CHARACTER*3 CJ
+C EXTERNAL SUBROUTINES
+ EXTERNAL DGEEV
+
+ ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))) !,HRG(ny,nu),HRGRH(ny,ny))
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+
+ maxnz = max(1,nz)
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.CHK'
+ OPEN(11,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+C write ny,nx,etc
+ WRITE(11,1000) nt,ny,nx,nu,nz
+1000 FORMAT(' nt = ',I3,'; ny = ',I3,'; nx = ',I3,'; nu = ',I3,
+ # '; nz = ',I3,';')
+
+C write theta
+ WRITE(11,*) 'theta(1:nt) = ['
+ WRITE(11,*) ' '
+ WRITE(11,'(<nt>(F20.10))') theta(1:nt)
+ WRITE(11,*) ']'
+
+C write c(ny,max(1,nz),ns(1))
+ DO J = 1,ns(1)
+ WRITE(11,*) ' '
+ IF (J.LE.9) THEN
+ WRITE(CJ,'(I1)') J
+ ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
+ WRITE(CJ,'(I2)') J
+ ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
+ WRITE(CJ,'(I3)') J
+ ENDIF
+ WRITE(11,*) 'c(1:ny,1:nz,'//TRIM(CJ)// ') = ['
+ WRITE(11,*) ' '
+ WRITE(11,'(<maxnz>(F20.10))') (c(I,1:maxnz,J),I=1,ny)
+ WRITE(11,*) ']'
+ ENDDO
+
+C write H(ny,nx,ns(2))
+ DO J = 1,ns(2)
+ WRITE(11,*) ' '
+ IF (J.LE.9) THEN
+ WRITE(CJ,'(I1)') J
+ ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
+ WRITE(CJ,'(I2)') J
+ ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
+ WRITE(CJ,'(I3)') J
+ ENDIF
+ WRITE(11,*) 'H(1:ny,1:nx,'//TRIM(CJ)// ') = ['
+ WRITE(11,*) ' '
+ WRITE(11,'(<nx>(F20.10))') (H(I,1:nx,J),I=1,ny)
+ WRITE(11,*) ']'
+ ENDDO
+
+C write G(ny,nu,ns(3))
+ DO J = 1,ns(3)
+ WRITE(11,*) ' '
+ IF (J.LE.9) THEN
+ WRITE(CJ,'(I1)') J
+ ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
+ WRITE(CJ,'(I2)') J
+ ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
+ WRITE(CJ,'(I3)') J
+ ENDIF
+ WRITE(11,*) 'G(1:ny,1:nu,'//TRIM(CJ)// ') = ['
+ WRITE(11,*) ' '
+ WRITE(11,'(<nu>(F20.10))') (G(I,1:nu,J),I=1,ny)
+ WRITE(11,*) ']'
+ ENDDO
+
+C write a(nx,ns(4))
+ DO J = 1,ns(4)
+ WRITE(11,*) ' '
+ IF (J.LE.9) THEN
+ WRITE(CJ,'(I1)') J
+ ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
+ WRITE(CJ,'(I2)') J
+ ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
+ WRITE(CJ,'(I3)') J
+ ENDIF
+ WRITE(11,*) 'a(1:nx,'//TRIM(CJ)// ') = ['
+ WRITE(11,*) ' '
+ WRITE(11,'(<1>(F20.10))') (a(I,J),I=1,nx)
+ WRITE(11,*) ']'
+ ENDDO
+
+C write F(nx,nx,ns(5))
+ DO J = 1,ns(5)
+ WRITE(11,*) ' '
+ IF (J.LE.9) THEN
+ WRITE(CJ,'(I1)') J
+ ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
+ WRITE(CJ,'(I2)') J
+ ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
+ WRITE(CJ,'(I3)') J
+ ENDIF
+ WRITE(11,*) 'F(1:nx,1:nx,'//TRIM(CJ)// ') = ['
+ WRITE(11,*) ' '
+ WRITE(11,'(<nx>(F20.10))') (F(I,1:nx,J),I=1,nx)
+ WRITE(11,*) ']'
+ ENDDO
+
+C write R(nx,nu,ns(6))
+ DO J = 1,ns(6)
+ WRITE(11,*) ' '
+ IF (J.LE.9) THEN
+ WRITE(CJ,'(I1)') J
+ ELSEIF ((J.GE.10).AND.(J.LE.99)) THEN
+ WRITE(CJ,'(I2)') J
+ ELSEIF ((J.GE.100).AND.(J.LE.999)) THEN
+ WRITE(CJ,'(I3)') J
+ ENDIF
+ WRITE(11,*) 'R(1:nx,1:nu,'//TRIM(CJ)// ') = ['
+ WRITE(11,*) ' '
+ WRITE(11,'(<nu>(F20.10))') (R(I,1:nu,J),I=1,nx)
+ WRITE(11,*) ']'
+ ENDDO
+
+C Check unstable eigenvalues of F
+ DO J = 1,ns(5)
+ IF (d(2).GT.0) THEN
+ IFAIL=-1
+C CALL F02EBF('N',d(2),F(1:d(2),1:d(2),J),d(2),
+C 1 WR(1:d(2)),WI(1:d(2)),VR,1,VI,1,WORK,4*nx,IFAIL)
+ CALL DGEEV('N','N',d(2),F(1:d(2),1:d(2),J),d(2),
+ 1 WR(1:d(2)),WI(1:d(2)),VR,1,VI,1,WORK,4*nx,IFAIL)
+
+ ESTABLE = 0
+ DO I = 1,d(2)
+ W(I) = WR(I)**2+WI(I)**2
+ ESTABLE = ESTABLE + ABS(W(I).GE.1.D0)
+ ENDDO
+ IF (ESTABLE.NE.d(2)) THEN
+ WRITE(11,*) ' '
+ WRITE(11,*) 'WARNING: the number of unstable eigenvalues for '
+ WRITE(11,*) 'F(1:nx,1:nx,'//TRIM(CJ)// 'is not equal to d(2) '
+ WRITE(11,*) 'or non-stationary states are not placed in the'
+ WRITE(11,*) 'first d(2) positions.'
+ ENDIF
+ ENDIF
+
+C Check stable eigenvalues of F
+ IF (nx-d(2).GT.0) THEN
+ IFAIL=-1
+c CALL F02EBF('N',nx-d(2),F(d(2)+1:nx,d(2)+1:nx,J),
+c 1 nx-d(2),WR,WI,VR,1,VI,1,WORK,4*nx,IFAIL)
+ CALL DGEEV('N','N',nx-d(2),F(d(2)+1:nx,d(2)+1:nx,J),
+ # nx-d(2),WR,WI,VR,1,VI,1,WORK,4*nx,IFAIL)
+
+ ESTABLE = 0
+ DO I = 1,nx-d(2)
+ W(I) = WR(I)**2+WI(I)**2
+ ESTABLE = ESTABLE + ABS(W(I).LT.1.D0)
+ ENDDO
+ IF (ESTABLE.NE.(nx-d(2))) THEN
+ WRITE(11,*) ' '
+ WRITE(11,*) 'WARNING: the number of stable eigenvalues for '
+ WRITE(11,*) 'F(1:nx,1:nx,'//TRIM(CJ)//'is not equal to nx-d(2)'
+ WRITE(11,*) 'or non-stationary states are not placed in the '
+ WRITE(11,*) 'first d(2) positions.'
+ ENDIF
+ ENDIF
+ ENDDO
+
+ CLOSE(11)
+ DEALLOCATE(c,H,G,a,F,R)
+
+ RETURN
+ PAUSE
+ END
+
+C Check rank{(HR+G)*(HR+G)'} this check is wrong!!!
+c DO J = 1,ns(2) !H
+c DO JJ = 1,ns(3) !G
+c DO JJJ = 1,ns(6) !R
+
+c DO I =1,ny
+c DO K =1,nu
+c HRG(I,K) = SUM(H(I,1:nx,J)*R(1:nx,K,JJJ))+G(I,K,JJ)
+c ENDDO
+c ENDDO
+
+c DO I =1,ny
+c DO K =1,ny
+c HRGRH(I,K) = SUM(HRG(I,1:nu)*HRG(K,1:nu))
+c ENDDO
+c ENDDO
+
+c IFAIL = -1
+c CALL F02FAF('N','U',ny,HRGRH,ny,WRY(1:ny),WORK1,64*ny,IFAIL)
+c SRANK = 0
+c DO 10 I=1,ny
+c10 IF (WRY(I).GT.1.D-12) SRANK=SRANK+1
+
+c IF (SRANK.LT.ny) THEN
+c WRITE(11,*) ' '
+c WRITE(11,*) 'WARNING: the rank of the system computed looking '
+c WRITE(11,*) 'at rank{(HR+G)*transpose(HR+G)} is less than ny '
+c ENDIF
+
+c ENDDO
+c ENDDO
+c ENDDO
+
diff --git a/chi2inv.for b/chi2inv.for
index 6f911f1b8a9671b6cd08e8842805f4c19c875d32..842c48701a98aa4ad97b6958eb2d5ce9a4675ac3 100644
--- a/chi2inv.for
+++ b/chi2inv.for
@@ -435,9 +435,9 @@ C LOCALS
WRITE(*,*) 'CHI2INV: Too many degrees of freedom'
PAUSE
RETURN
- ENDIF
+ ENDIF
CHI2INV = T(V,P)
- RETURN
+ RETURN
END
diff --git a/confun.for b/confun.for
index f9d5a8157f1ac2d0f4e5c2f5e6cefa2e9fc2006c..a4c09d6fbe0c10b29853f4daadf799d92e02eaa3 100644
--- a/confun.for
+++ b/confun.for
@@ -1,13 +1,13 @@
-C --------------------------------------------------------------------
-C CONFUN computes non linear constrains for E04UCF
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C CONFUN computes non linear constrains for E04UCF
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,19 +18,19 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE CONFUN(MODE,NCNLNS,NPAR,LDCJ,NEEDC,CHI,CC,CJAC,
- , NNN,IU,U)
-C Input
- INTEGER MODE,NPAR,NCNLNS,LDCJ,NEEDC(NCNLNS),NNN
- INTEGER*8 IU(72)
- DOUBLE PRECISION U(IU(1)*(2*IU(4)+IU(5)+7)+3*IU(8)+2),CHI(NPAR)
-C Output
- DOUBLE PRECISION CC(LDCJ),CJAC(LDCJ,NPAR)
-
- CC(:) = 0.D0
- CJAC(:,:) = 0.D0
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE CONFUN(MODE,NCNLNS,NPAR,LDCJ,NEEDC,CHI,CC,CJAC,
+ , NNN,IU,U)
+C Input
+ INTEGER MODE,NPAR,NCNLNS,LDCJ,NEEDC(NCNLNS),NNN
+ INTEGER*8 IU(72)
+ DOUBLE PRECISION U(IU(1)*(2*IU(4)+IU(5)+7)+3*IU(8)+2),CHI(NPAR)
+C Output
+ DOUBLE PRECISION CC(LDCJ),CJAC(LDCJ,NPAR)
+
+ CC(:) = 0.D0
+ CJAC(:,:) = 0.D0
+
+ RETURN
END
diff --git a/cumnorm.for b/cumnorm.for
index 94ca63fd90756df4159832dfc2b0995563f8714c..4645f476b9dd3ae7cb9cf580231386765ca877b8 100644
--- a/cumnorm.for
+++ b/cumnorm.for
@@ -1,14 +1,14 @@
-C ------------------------------------------------------------------------
-C CUMNORM returns the value of the cumulative (standard)
-C Normal distribution function between -inf and X using erfc
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------------------
+C CUMNORM returns the value of the cumulative (standard)
+C Normal distribution function between -inf and X using erfc
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -19,15 +19,15 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION cumnorm(X)
-C INPUT
- DOUBLE PRECISION X
-
- cumnorm = .5D0*erfc(-X/dsqrt(2.D0))
-
- RETURN
- END
-
-
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION cumnorm(X)
+C INPUT
+ DOUBLE PRECISION X
+
+ cumnorm = .5D0*erfc(-X/dsqrt(2.D0))
+
+ RETURN
+ END
+
+
diff --git a/designz.for b/designz.for
index 60a9bfbe4d8ef2844209170513d320efba327169..5d29e5d4ccf66b8fb9afb562c317275c70f1ee61 100644
--- a/designz.for
+++ b/designz.for
@@ -1,24 +1,24 @@
-C --------------------------------------------------------------------
-C DESIGNZ sets transition probs for latent variables using INFOS
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C by cols: S1,S2,...,Snv; with nv <=6
-C by row: the 1st contains the # of matrices affected by Si
-C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
-C the 8-th row contains the # of states
-C the 9-th row spec the dynamics for Sj
-C
-C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
-C
-C OUTPUT: P1,P2,...,P6 where
-C Pk(i,j) = Pr[Sk(t+1)=i|Sk(t)=j], k = 1,2,...,min(6,nv)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C DESIGNZ sets transition probs for latent variables using INFOS
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C by cols: S1,S2,...,Snv; with nv <=6
+C by row: the 1st contains the # of matrices affected by Si
+C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
+C the 8-th row contains the # of states
+C the 9-th row spec the dynamics for Sj
+C
+C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
+C
+C OUTPUT: P1,P2,...,P6 where
+C Pk(i,j) = Pr[Sk(t+1)=i|Sk(t)=j], k = 1,2,...,min(6,nv)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -29,377 +29,377 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ---------------------------------------------------------------------
- SUBROUTINE DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
-C INPUT
- INTEGER nv,np,INFOS(9,6)
- DOUBLE PRECISION psi(np)
-C OUTPUT
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6))
-
-C LOCALS
- INTEGER I,J,K
-
-C Transition probability matrix
- K = 0
- IF (nv.EQ.1) THEN
-
- IF (INFOS(9,1).EQ.1) THEN ! S~IID
- DO I = 1,INFOS(8,1)-1
- P1(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ELSEIF (INFOS(9,1).EQ.2) THEN ! S~Markov
- DO J = 1,INFOS(8,1)
- DO I = 1,INFOS(8,1)-1
- P1(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,1)
- P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
- ENDDO
-
- ELSEIF (nv.EQ.2) THEN
-
- IF (INFOS(9,1).EQ.1) THEN
- DO I = 1,INFOS(8,1)-1
- P1(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ELSEIF (INFOS(9,1).EQ.2) THEN
- DO J = 1,INFOS(8,1)
- DO I = 1,INFOS(8,1)-1
- P1(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,1)
- P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
- ENDDO
- IF (INFOS(9,2).EQ.1) THEN
- DO I = 1,INFOS(8,2)-1
- P2(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ELSEIF (INFOS(9,2).EQ.2) THEN
- DO J = 1,INFOS(8,2)
- DO I = 1,INFOS(8,2)-1
- P2(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,2)
- P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
- ENDDO
-
- ELSEIF (nv.EQ.3) THEN
-
- IF (INFOS(9,1).EQ.1) THEN
- DO I = 1,INFOS(8,1)-1
- P1(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ELSEIF (INFOS(9,1).EQ.2) THEN
- DO J = 1,INFOS(8,1)
- DO I = 1,INFOS(8,1)-1
- P1(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,1)
- P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
- ENDDO
- IF (INFOS(9,2).EQ.1) THEN
- DO I = 1,INFOS(8,2)-1
- P2(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ELSEIF (INFOS(9,2).EQ.2) THEN
- DO J = 1,INFOS(8,2)
- DO I = 1,INFOS(8,2)-1
- P2(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,2)
- P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
- ENDDO
- IF (INFOS(9,3).EQ.1) THEN
- DO I = 1,INFOS(8,3)-1
- P3(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ELSEIF (INFOS(9,3).EQ.2) THEN
- DO J = 1,INFOS(8,3)
- DO I = 1,INFOS(8,3)-1
- P3(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,3)
- P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
- ENDDO
-
- ELSEIF (nv.EQ.4) THEN
-
- IF (INFOS(9,1).EQ.1) THEN
- DO I = 1,INFOS(8,1)-1
- P1(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ELSEIF (INFOS(9,1).EQ.2) THEN
- DO J = 1,INFOS(8,1)
- DO I = 1,INFOS(8,1)-1
- P1(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,1)
- P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
- ENDDO
- IF (INFOS(9,2).EQ.1) THEN
- DO I = 1,INFOS(8,2)-1
- P2(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ELSEIF (INFOS(9,2).EQ.2) THEN
- DO J = 1,INFOS(8,2)
- DO I = 1,INFOS(8,2)-1
- P2(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,2)
- P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
- ENDDO
- IF (INFOS(9,3).EQ.1) THEN
- DO I = 1,INFOS(8,3)-1
- P3(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ELSEIF (INFOS(9,3).EQ.2) THEN
- DO J = 1,INFOS(8,3)
- DO I = 1,INFOS(8,3)-1
- P3(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,3)
- P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
- ENDDO
- IF (INFOS(9,4).EQ.1) THEN
- DO I = 1,INFOS(8,4)-1
- P4(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,4)-1
- ELSEIF (INFOS(9,4).EQ.2) THEN
- DO J = 1,INFOS(8,4)
- DO I = 1,INFOS(8,4)-1
- P4(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,4)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,4)
- P4(INFOS(8,4),J) = 1.D0-SUM(P4(1:INFOS(8,4)-1,J))
- ENDDO
-
- ELSEIF (nv.EQ.5) THEN
-
- IF (INFOS(9,1).EQ.1) THEN
- DO I = 1,INFOS(8,1)-1
- P1(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ELSEIF (INFOS(9,1).EQ.2) THEN
- DO J = 1,INFOS(8,1)
- DO I = 1,INFOS(8,1)-1
- P1(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,1)
- P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
- ENDDO
- IF (INFOS(9,2).EQ.1) THEN
- DO I = 1,INFOS(8,2)-1
- P2(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ELSEIF (INFOS(9,2).EQ.2) THEN
- DO J = 1,INFOS(8,2)
- DO I = 1,INFOS(8,2)-1
- P2(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,2)
- P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
- ENDDO
- IF (INFOS(9,3).EQ.1) THEN
- DO I = 1,INFOS(8,3)-1
- P3(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ELSEIF (INFOS(9,3).EQ.2) THEN
- DO J = 1,INFOS(8,3)
- DO I = 1,INFOS(8,3)-1
- P3(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,3)
- P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
- ENDDO
- IF (INFOS(9,4).EQ.1) THEN
- DO I = 1,INFOS(8,4)-1
- P4(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,4)-1
- ELSEIF (INFOS(9,4).EQ.2) THEN
- DO J = 1,INFOS(8,4)
- DO I = 1,INFOS(8,4)-1
- P4(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,4)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,4)
- P4(INFOS(8,4),J) = 1.D0-SUM(P4(1:INFOS(8,4)-1,J))
- ENDDO
- IF (INFOS(9,5).EQ.1) THEN
- DO I = 1,INFOS(8,5)-1
- P5(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,5)-1
- ELSEIF (INFOS(9,5).EQ.2) THEN
- DO J = 1,INFOS(8,5)
- DO I = 1,INFOS(8,5)-1
- P5(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,5)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,5)
- P5(INFOS(8,5),J) = 1.D0-SUM(P5(1:INFOS(8,5)-1,J))
- ENDDO
-
- ELSEIF (nv.EQ.6) THEN
-
- IF (INFOS(9,1).EQ.1) THEN
- DO I = 1,INFOS(8,1)-1
- P1(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ELSEIF (INFOS(9,1).EQ.2) THEN
- DO J = 1,INFOS(8,1)
- DO I = 1,INFOS(8,1)-1
- P1(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,1)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,1)
- P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
- ENDDO
- IF (INFOS(9,2).EQ.1) THEN
- DO I = 1,INFOS(8,2)-1
- P2(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ELSEIF (INFOS(9,2).EQ.2) THEN
- DO J = 1,INFOS(8,2)
- DO I = 1,INFOS(8,2)-1
- P2(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,2)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,2)
- P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
- ENDDO
- IF (INFOS(9,3).EQ.1) THEN
- DO I = 1,INFOS(8,3)-1
- P3(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ELSEIF (INFOS(9,3).EQ.2) THEN
- DO J = 1,INFOS(8,3)
- DO I = 1,INFOS(8,3)-1
- P3(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,3)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,3)
- P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
- ENDDO
- IF (INFOS(9,4).EQ.1) THEN
- DO I = 1,INFOS(8,4)-1
- P4(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,4)-1
- ELSEIF (INFOS(9,4).EQ.2) THEN
- DO J = 1,INFOS(8,4)
- DO I = 1,INFOS(8,4)-1
- P4(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,4)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,4)
- P4(INFOS(8,4),J) = 1.D0-SUM(P4(1:INFOS(8,4)-1,J))
- ENDDO
- IF (INFOS(9,5).EQ.1) THEN
- DO I = 1,INFOS(8,5)-1
- P5(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,5)-1
- ELSEIF (INFOS(9,5).EQ.2) THEN
- DO J = 1,INFOS(8,5)
- DO I = 1,INFOS(8,5)-1
- P5(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,5)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,5)
- P5(INFOS(8,5),J) = 1.D0-SUM(P5(1:INFOS(8,5)-1,J))
- ENDDO
- IF (INFOS(9,6).EQ.1) THEN
- DO I = 1,INFOS(8,6)-1
- P6(I,:) = psi(K+I)
- ENDDO
- K = K + INFOS(8,6)-1
- ELSEIF (INFOS(9,6).EQ.2) THEN
- DO J = 1,INFOS(8,6)
- DO I = 1,INFOS(8,6)-1
- P6(I,J) = psi(K+I)
- ENDDO
- K = K + INFOS(8,6)-1
- ENDDO
- ENDIF
- DO J = 1,INFOS(8,6)
- P6(INFOS(8,6),J) = 1.D0-SUM(P6(1:INFOS(8,6)-1,J))
- ENDDO
- ENDIF
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ---------------------------------------------------------------------
+ SUBROUTINE DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
+C INPUT
+ INTEGER nv,np,INFOS(9,6)
+ DOUBLE PRECISION psi(np)
+C OUTPUT
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6))
+
+C LOCALS
+ INTEGER I,J,K
+
+C Transition probability matrix
+ K = 0
+ IF (nv.EQ.1) THEN
+
+ IF (INFOS(9,1).EQ.1) THEN ! S~IID
+ DO I = 1,INFOS(8,1)-1
+ P1(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ELSEIF (INFOS(9,1).EQ.2) THEN ! S~Markov
+ DO J = 1,INFOS(8,1)
+ DO I = 1,INFOS(8,1)-1
+ P1(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,1)
+ P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
+ ENDDO
+
+ ELSEIF (nv.EQ.2) THEN
+
+ IF (INFOS(9,1).EQ.1) THEN
+ DO I = 1,INFOS(8,1)-1
+ P1(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ELSEIF (INFOS(9,1).EQ.2) THEN
+ DO J = 1,INFOS(8,1)
+ DO I = 1,INFOS(8,1)-1
+ P1(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,1)
+ P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
+ ENDDO
+ IF (INFOS(9,2).EQ.1) THEN
+ DO I = 1,INFOS(8,2)-1
+ P2(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ELSEIF (INFOS(9,2).EQ.2) THEN
+ DO J = 1,INFOS(8,2)
+ DO I = 1,INFOS(8,2)-1
+ P2(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,2)
+ P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
+ ENDDO
+
+ ELSEIF (nv.EQ.3) THEN
+
+ IF (INFOS(9,1).EQ.1) THEN
+ DO I = 1,INFOS(8,1)-1
+ P1(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ELSEIF (INFOS(9,1).EQ.2) THEN
+ DO J = 1,INFOS(8,1)
+ DO I = 1,INFOS(8,1)-1
+ P1(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,1)
+ P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
+ ENDDO
+ IF (INFOS(9,2).EQ.1) THEN
+ DO I = 1,INFOS(8,2)-1
+ P2(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ELSEIF (INFOS(9,2).EQ.2) THEN
+ DO J = 1,INFOS(8,2)
+ DO I = 1,INFOS(8,2)-1
+ P2(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,2)
+ P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
+ ENDDO
+ IF (INFOS(9,3).EQ.1) THEN
+ DO I = 1,INFOS(8,3)-1
+ P3(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ELSEIF (INFOS(9,3).EQ.2) THEN
+ DO J = 1,INFOS(8,3)
+ DO I = 1,INFOS(8,3)-1
+ P3(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,3)
+ P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
+ ENDDO
+
+ ELSEIF (nv.EQ.4) THEN
+
+ IF (INFOS(9,1).EQ.1) THEN
+ DO I = 1,INFOS(8,1)-1
+ P1(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ELSEIF (INFOS(9,1).EQ.2) THEN
+ DO J = 1,INFOS(8,1)
+ DO I = 1,INFOS(8,1)-1
+ P1(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,1)
+ P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
+ ENDDO
+ IF (INFOS(9,2).EQ.1) THEN
+ DO I = 1,INFOS(8,2)-1
+ P2(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ELSEIF (INFOS(9,2).EQ.2) THEN
+ DO J = 1,INFOS(8,2)
+ DO I = 1,INFOS(8,2)-1
+ P2(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,2)
+ P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
+ ENDDO
+ IF (INFOS(9,3).EQ.1) THEN
+ DO I = 1,INFOS(8,3)-1
+ P3(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ELSEIF (INFOS(9,3).EQ.2) THEN
+ DO J = 1,INFOS(8,3)
+ DO I = 1,INFOS(8,3)-1
+ P3(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,3)
+ P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
+ ENDDO
+ IF (INFOS(9,4).EQ.1) THEN
+ DO I = 1,INFOS(8,4)-1
+ P4(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,4)-1
+ ELSEIF (INFOS(9,4).EQ.2) THEN
+ DO J = 1,INFOS(8,4)
+ DO I = 1,INFOS(8,4)-1
+ P4(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,4)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,4)
+ P4(INFOS(8,4),J) = 1.D0-SUM(P4(1:INFOS(8,4)-1,J))
+ ENDDO
+
+ ELSEIF (nv.EQ.5) THEN
+
+ IF (INFOS(9,1).EQ.1) THEN
+ DO I = 1,INFOS(8,1)-1
+ P1(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ELSEIF (INFOS(9,1).EQ.2) THEN
+ DO J = 1,INFOS(8,1)
+ DO I = 1,INFOS(8,1)-1
+ P1(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,1)
+ P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
+ ENDDO
+ IF (INFOS(9,2).EQ.1) THEN
+ DO I = 1,INFOS(8,2)-1
+ P2(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ELSEIF (INFOS(9,2).EQ.2) THEN
+ DO J = 1,INFOS(8,2)
+ DO I = 1,INFOS(8,2)-1
+ P2(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,2)
+ P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
+ ENDDO
+ IF (INFOS(9,3).EQ.1) THEN
+ DO I = 1,INFOS(8,3)-1
+ P3(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ELSEIF (INFOS(9,3).EQ.2) THEN
+ DO J = 1,INFOS(8,3)
+ DO I = 1,INFOS(8,3)-1
+ P3(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,3)
+ P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
+ ENDDO
+ IF (INFOS(9,4).EQ.1) THEN
+ DO I = 1,INFOS(8,4)-1
+ P4(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,4)-1
+ ELSEIF (INFOS(9,4).EQ.2) THEN
+ DO J = 1,INFOS(8,4)
+ DO I = 1,INFOS(8,4)-1
+ P4(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,4)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,4)
+ P4(INFOS(8,4),J) = 1.D0-SUM(P4(1:INFOS(8,4)-1,J))
+ ENDDO
+ IF (INFOS(9,5).EQ.1) THEN
+ DO I = 1,INFOS(8,5)-1
+ P5(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,5)-1
+ ELSEIF (INFOS(9,5).EQ.2) THEN
+ DO J = 1,INFOS(8,5)
+ DO I = 1,INFOS(8,5)-1
+ P5(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,5)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,5)
+ P5(INFOS(8,5),J) = 1.D0-SUM(P5(1:INFOS(8,5)-1,J))
+ ENDDO
+
+ ELSEIF (nv.EQ.6) THEN
+
+ IF (INFOS(9,1).EQ.1) THEN
+ DO I = 1,INFOS(8,1)-1
+ P1(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ELSEIF (INFOS(9,1).EQ.2) THEN
+ DO J = 1,INFOS(8,1)
+ DO I = 1,INFOS(8,1)-1
+ P1(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,1)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,1)
+ P1(INFOS(8,1),J) = 1.D0-SUM(P1(1:INFOS(8,1)-1,J))
+ ENDDO
+ IF (INFOS(9,2).EQ.1) THEN
+ DO I = 1,INFOS(8,2)-1
+ P2(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ELSEIF (INFOS(9,2).EQ.2) THEN
+ DO J = 1,INFOS(8,2)
+ DO I = 1,INFOS(8,2)-1
+ P2(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,2)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,2)
+ P2(INFOS(8,2),J) = 1.D0-SUM(P2(1:INFOS(8,2)-1,J))
+ ENDDO
+ IF (INFOS(9,3).EQ.1) THEN
+ DO I = 1,INFOS(8,3)-1
+ P3(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ELSEIF (INFOS(9,3).EQ.2) THEN
+ DO J = 1,INFOS(8,3)
+ DO I = 1,INFOS(8,3)-1
+ P3(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,3)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,3)
+ P3(INFOS(8,3),J) = 1.D0-SUM(P3(1:INFOS(8,3)-1,J))
+ ENDDO
+ IF (INFOS(9,4).EQ.1) THEN
+ DO I = 1,INFOS(8,4)-1
+ P4(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,4)-1
+ ELSEIF (INFOS(9,4).EQ.2) THEN
+ DO J = 1,INFOS(8,4)
+ DO I = 1,INFOS(8,4)-1
+ P4(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,4)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,4)
+ P4(INFOS(8,4),J) = 1.D0-SUM(P4(1:INFOS(8,4)-1,J))
+ ENDDO
+ IF (INFOS(9,5).EQ.1) THEN
+ DO I = 1,INFOS(8,5)-1
+ P5(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,5)-1
+ ELSEIF (INFOS(9,5).EQ.2) THEN
+ DO J = 1,INFOS(8,5)
+ DO I = 1,INFOS(8,5)-1
+ P5(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,5)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,5)
+ P5(INFOS(8,5),J) = 1.D0-SUM(P5(1:INFOS(8,5)-1,J))
+ ENDDO
+ IF (INFOS(9,6).EQ.1) THEN
+ DO I = 1,INFOS(8,6)-1
+ P6(I,:) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,6)-1
+ ELSEIF (INFOS(9,6).EQ.2) THEN
+ DO J = 1,INFOS(8,6)
+ DO I = 1,INFOS(8,6)-1
+ P6(I,J) = psi(K+I)
+ ENDDO
+ K = K + INFOS(8,6)-1
+ ENDDO
+ ENDIF
+ DO J = 1,INFOS(8,6)
+ P6(INFOS(8,6),J) = 1.D0-SUM(P6(1:INFOS(8,6)-1,J))
+ ENDDO
+ ENDIF
+
+ RETURN
END
diff --git a/drawpsi.for b/drawpsi.for
index b54d50e49a7bd628a9e73fd0befb2440a02fcc86..a95d9029b6c52463a3b09574d98137c06d30dcd1 100644
--- a/drawpsi.for
+++ b/drawpsi.for
@@ -1,47 +1,47 @@
-C ----------------------------------------------------------------------
-C DRAWS parameters PSI conditionally on S
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C p(theta,psi|Y,S,z) propto p(theta|Y,S,z) x p(psi|S)
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C FURTHER INPUT:
-C
-C nobs: # of observations
-C d: order of integration of the system
-C nv: # of discrete latent variables (S1,S2,...)
-C nt: dimension of parameter theta
-C Z: discrete latent var
-C theta0: previous value of theta
-C INFOS (9 x 6):
-C by cols: S1,S2,...,Snv; with nv <=6
-C by row: the 1st contains the # of matrices affected by Si
-C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
-C the 8-th row contains the # of states
-C the 9-th row spec. the dynamic of S
-C
-C OUTPUT:
-C PSI (np(1) x 1)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C DRAWS parameters PSI conditionally on S
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C p(theta,psi|Y,S,z) propto p(theta|Y,S,z) x p(psi|S)
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C FURTHER INPUT:
+C
+C nobs: # of observations
+C d: order of integration of the system
+C nv: # of discrete latent variables (S1,S2,...)
+C nt: dimension of parameter theta
+C Z: discrete latent var
+C theta0: previous value of theta
+C INFOS (9 x 6):
+C by cols: S1,S2,...,Snv; with nv <=6
+C by row: the 1st contains the # of matrices affected by Si
+C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
+C the 8-th row contains the # of states
+C the 9-th row spec. the dynamic of S
+C
+C OUTPUT:
+C PSI (np(1) x 1)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -52,105 +52,105 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- SUBROUTINE DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
-
-C INPUT
- INTEGER nobs,nv,np(3),Z(nobs),INFOS(9,6)
- DOUBLE PRECISION psiprior(np(2),np(3)),psi0(np(1))
-C OUTPUT
- DOUBLE PRECISION psi(np(1))
-C LOCALS
- INTEGER I,K,ii,jj,NN,NSI,IFAIL,SEQ(nobs,nv)
- INTEGER,ALLOCATABLE:: NIJ(:,:)
- INTEGER S(nobs,6)
- DOUBLE PRECISION, ALLOCATABLE:: P1(:,:),P2(:,:),P3(:,:),P4(:,:),
- 1 P5(:,:),P6(:,:),PENEW(:),PEOLD(:),GAM(:)
- DOUBLE PRECISION uv,v,AG
- DOUBLE PRECISION genunf,gengam
-C DOUBLE PRECISION G05CAF
-
- ALLOCATE(P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6)))
-
- DO 1 I = 1,nobs
-1 CALL INT2SEQ(Z(I),nv,INFOS,SEQ(I,1:nv),S(I,1:6))
-
- psi(:) = 0.D0
- NN = 0
- K = 0
- DO 100 I = 1,nv
- NSI = INFOS(8,I) ! # of states for SI
- ALLOCATE(GAM(NSI))
- IF (INFOS(9,I).EQ.1) THEN ! S~IID
-C SAMPLING FROM DIRICHLET
- DO 5 ii = 1,NSI
- AG = SUM(ABS((SEQ(1:nobs,I).EQ.ii)))+psiprior(K+1,ii)
- IFAIL = -1
-C 5 CALL G05FFF(AG,1.D0,1,GAM(ii),IFAIL)
-5 GAM(ii) = gengam(1.D0,AG)
- psi(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
- psi0(NN+1:NN+NSI-1) = psi(NN+1:NN+NSI-1)
- K = K + 1
- NN = NN + NSI-1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- ALLOCATE(NIJ(NSI,NSI),PENEW(NSI),PEOLD(NSI))
- DO 50 jj = 1,NSI
- DO 10 ii = 1,NSI
-10 NIJ(ii,jj) = SUM(ABS((SEQ(2:nobs,I).EQ.ii).AND.
- # (SEQ(1:nobs-1,I).EQ.jj)))
-C SAMPLING FROM DIRICHLET
- DO 20 ii = 1,NSI
- AG = NIJ(ii,jj) + psiprior(K+1,ii)
- IFAIL = -1
-C20 CALL G05FFF(AG,1.D0,1,GAM(ii),IFAIL)
-20 GAM(ii) = gengam(1.D0,AG)
- psi(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
- K = K + 1
-50 NN = NN + NSI-1
-C METROPOLIS TO ADJUST INITIAL CONDITION P(S(1)=0|p11,p12,...)
- CALL DESIGNZ(nv,np(1),psi,INFOS,P1,P2,P3,P4,P5,P6) !new
- IF (I.EQ.1) THEN
- CALL ERGODIC(NSI,P1,PENEW(1:NSI))
- ELSEIF (I.EQ.2) THEN
- CALL ERGODIC(NSI,P2,PENEW(1:NSI))
- ELSEIF (I.EQ.3) THEN
- CALL ERGODIC(NSI,P3,PENEW(1:NSI))
- ELSEIF (I.EQ.4) THEN
- CALL ERGODIC(NSI,P4,PENEW(1:NSI))
- ELSEIF (I.EQ.5) THEN
- CALL ERGODIC(NSI,P5,PENEW(1:NSI))
- ELSE
- CALL ERGODIC(NSI,P6,PENEW(1:NSI))
- ENDIF
- CALL DESIGNZ(nv,np(1),psi0,INFOS,P1,P2,P3,P4,P5,P6) !old
- IF (I.EQ.1) THEN
- CALL ERGODIC(NSI,P1,PEOLD(1:NSI))
- ELSEIF (I.EQ.2) THEN
- CALL ERGODIC(NSI,P2,PEOLD(1:NSI))
- ELSEIF (I.EQ.3) THEN
- CALL ERGODIC(NSI,P3,PEOLD(1:NSI))
- ELSEIF (I.EQ.4) THEN
- CALL ERGODIC(NSI,P4,PEOLD(1:NSI))
- ELSEIF (I.EQ.5) THEN
- CALL ERGODIC(NSI,P5,PEOLD(1:NSI))
- ELSE
- CALL ERGODIC(NSI,P6,PEOLD(1:NSI))
- ENDIF
- uv = min(1.D0,PENEW(SEQ(1,I))/PEOLD(SEQ(1,I)))
-C v = G05CAF(v)
- v = genunf(0.D0,1.D0) ! U(0,1)
- IF (v.GT.uv) THEN
- psi(NN-NSI*(NSI-1)+1:NN) = psi0(NN-NSI*(NSI-1)+1:NN)
- ENDIF
- psi0(NN-NSI*(NSI-1)+1:NN) = psi(NN-NSI*(NSI-1)+1:NN)
- DEALLOCATE(NIJ,PENEW,PEOLD)
- ENDIF
-100 DEALLOCATE(GAM)
- DEALLOCATE(P1,P2,P3,P4,P5,P6)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ SUBROUTINE DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
+
+C INPUT
+ INTEGER nobs,nv,np(3),Z(nobs),INFOS(9,6)
+ DOUBLE PRECISION psiprior(np(2),np(3)),psi0(np(1))
+C OUTPUT
+ DOUBLE PRECISION psi(np(1))
+C LOCALS
+ INTEGER I,K,ii,jj,NN,NSI,IFAIL,SEQ(nobs,nv)
+ INTEGER,ALLOCATABLE:: NIJ(:,:)
+ INTEGER S(nobs,6)
+ DOUBLE PRECISION, ALLOCATABLE:: P1(:,:),P2(:,:),P3(:,:),P4(:,:),
+ 1 P5(:,:),P6(:,:),PENEW(:),PEOLD(:),GAM(:)
+ DOUBLE PRECISION uv,v,AG
+ DOUBLE PRECISION genunf,gengam
+C DOUBLE PRECISION G05CAF
+
+ ALLOCATE(P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6)))
+
+ DO 1 I = 1,nobs
+1 CALL INT2SEQ(Z(I),nv,INFOS,SEQ(I,1:nv),S(I,1:6))
+
+ psi(:) = 0.D0
+ NN = 0
+ K = 0
+ DO 100 I = 1,nv
+ NSI = INFOS(8,I) ! # of states for SI
+ ALLOCATE(GAM(NSI))
+ IF (INFOS(9,I).EQ.1) THEN ! S~IID
+C SAMPLING FROM DIRICHLET
+ DO 5 ii = 1,NSI
+ AG = SUM(ABS((SEQ(1:nobs,I).EQ.ii)))+psiprior(K+1,ii)
+ IFAIL = -1
+C 5 CALL G05FFF(AG,1.D0,1,GAM(ii),IFAIL)
+5 GAM(ii) = gengam(1.D0,AG)
+ psi(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
+ psi0(NN+1:NN+NSI-1) = psi(NN+1:NN+NSI-1)
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ ALLOCATE(NIJ(NSI,NSI),PENEW(NSI),PEOLD(NSI))
+ DO 50 jj = 1,NSI
+ DO 10 ii = 1,NSI
+10 NIJ(ii,jj) = SUM(ABS((SEQ(2:nobs,I).EQ.ii).AND.
+ # (SEQ(1:nobs-1,I).EQ.jj)))
+C SAMPLING FROM DIRICHLET
+ DO 20 ii = 1,NSI
+ AG = NIJ(ii,jj) + psiprior(K+1,ii)
+ IFAIL = -1
+C20 CALL G05FFF(AG,1.D0,1,GAM(ii),IFAIL)
+20 GAM(ii) = gengam(1.D0,AG)
+ psi(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
+ K = K + 1
+50 NN = NN + NSI-1
+C METROPOLIS TO ADJUST INITIAL CONDITION P(S(1)=0|p11,p12,...)
+ CALL DESIGNZ(nv,np(1),psi,INFOS,P1,P2,P3,P4,P5,P6) !new
+ IF (I.EQ.1) THEN
+ CALL ERGODIC(NSI,P1,PENEW(1:NSI))
+ ELSEIF (I.EQ.2) THEN
+ CALL ERGODIC(NSI,P2,PENEW(1:NSI))
+ ELSEIF (I.EQ.3) THEN
+ CALL ERGODIC(NSI,P3,PENEW(1:NSI))
+ ELSEIF (I.EQ.4) THEN
+ CALL ERGODIC(NSI,P4,PENEW(1:NSI))
+ ELSEIF (I.EQ.5) THEN
+ CALL ERGODIC(NSI,P5,PENEW(1:NSI))
+ ELSE
+ CALL ERGODIC(NSI,P6,PENEW(1:NSI))
+ ENDIF
+ CALL DESIGNZ(nv,np(1),psi0,INFOS,P1,P2,P3,P4,P5,P6) !old
+ IF (I.EQ.1) THEN
+ CALL ERGODIC(NSI,P1,PEOLD(1:NSI))
+ ELSEIF (I.EQ.2) THEN
+ CALL ERGODIC(NSI,P2,PEOLD(1:NSI))
+ ELSEIF (I.EQ.3) THEN
+ CALL ERGODIC(NSI,P3,PEOLD(1:NSI))
+ ELSEIF (I.EQ.4) THEN
+ CALL ERGODIC(NSI,P4,PEOLD(1:NSI))
+ ELSEIF (I.EQ.5) THEN
+ CALL ERGODIC(NSI,P5,PEOLD(1:NSI))
+ ELSE
+ CALL ERGODIC(NSI,P6,PEOLD(1:NSI))
+ ENDIF
+ uv = min(1.D0,PENEW(SEQ(1,I))/PEOLD(SEQ(1,I)))
+C v = G05CAF(v)
+ v = genunf(0.D0,1.D0) ! U(0,1)
+ IF (v.GT.uv) THEN
+ psi(NN-NSI*(NSI-1)+1:NN) = psi0(NN-NSI*(NSI-1)+1:NN)
+ ENDIF
+ psi0(NN-NSI*(NSI-1)+1:NN) = psi(NN-NSI*(NSI-1)+1:NN)
+ DEALLOCATE(NIJ,PENEW,PEOLD)
+ ENDIF
+100 DEALLOCATE(GAM)
+ DEALLOCATE(P1,P2,P3,P4,P5,P6)
+
+ RETURN
END
diff --git a/drawtheta.for b/drawtheta.for
index 7848c0226a5fcaea32c5a8e0b3d4a5d2cfde7bc6..91470035c50841d24a444b14964a50422e125e92 100644
--- a/drawtheta.for
+++ b/drawtheta.for
@@ -1,32 +1,32 @@
-C ----------------------------------------------------------------------
-C DRAWTHETA draws model parameters theta
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C p(theta|Y,S,z) propto p(theta|Y,S,z)
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C OUTPUT:
-C theta (nt x 1)
-C NEVAL # of runs of the Kalman Filter (KF) / MH acceptance prob
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C DRAWTHETA draws model parameters theta
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C p(theta|Y,S,z) propto p(theta|Y,S,z)
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C OUTPUT:
+C theta (nt x 1)
+C NEVAL # of runs of the Kalman Filter (KF) / MH acceptance prob
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -37,133 +37,133 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- SUBROUTINE DRAWTHETA(nobs,d,ny,nz,nx,nu,nv,ns,nt,INFOS,INDT,
- 1 MEDT,SIGT,yk,IYK,Z,thetaprior,tipo,pdll,
- 2 theta0,theta,NEVAL)
-C INPUT
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia)
- INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nt,Z(nobs),
- 1 IYK(nobs,ny+1),INFOS(9,6),INDT(nt+2)
- DOUBLE PRECISION yk(nobs,ny+nz),thetaprior(nt,4),theta0(nt)
- DOUBLE PRECISION MEDT(max(1,INDT(nt+1))),
- 1 SIGT(max(1,INDT(nt+1)),max(1,INDT(nt+1)))
-
- CHARACTER*2 tipo(nt)
-C OUTPUT
- INTEGER NEVAL(nt)
- DOUBLE PRECISION theta(nt)
-C LOCALS
- INTEGER I,J,jj,NN,IFAIL,SEQ(nv)
- INTEGER it,S(nobs,6)
- DOUBLE PRECISION PN,PO,QN,QO,PA,v,AG,WORK((nt+2)*(nt+1)/2),
- 1 SEGA(nt),WORK2(nt)
- DOUBLE PRECISION genunf,ptheta,prior,mvnpdf
-C DOUBLE PRECISION G05CAF
- IF (nv.GT.0) THEN
- DO 1 I = 1,nobs
-1 CALL INT2SEQ(Z(I),nv,INFOS,SEQ(1:nv),S(I,1:6))
- ELSE
- S(1:nobs,:) = 1
- ENDIF
-
-C --------------------------------------------
-C DRAW theta1 from p(theta1|Y,S)
-C p(theta1|Y,S) prop p(Y|theta1,S) x p(theta1)
-C --------------------------------------------
- NN = 0
- JJ = INDT(nt+1)
- IF (JJ.GT.1) THEN ! Draw a set of theta via AMH
-C MH proposal:
-C theta ~ (1-beta)*N(MEDT,2.38^2*SIGT/JJ) + beta*N(MEDT,.1^2*I/JJ)
-C7777 v = G05CAF(v) ! Sampling U(0,1)
-7777 v = genunf(0.D0,1.D0) ! Sampling U(0,1)
- IF (v.LE..95) THEN
- IFAIL = -1
-c CALL G05EAF(MEDT,JJ,2.38**2*SIGT/DFLOAT(JJ),JJ,1.D-14,
-c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
-c CALL G05EZF(SEGA(1:JJ),JJ,WORK,(nt+2)*(nt+1)/2,IFAIL)
- CALL setgmn(MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ,JJ,
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ SUBROUTINE DRAWTHETA(nobs,d,ny,nz,nx,nu,nv,ns,nt,INFOS,INDT,
+ 1 MEDT,SIGT,yk,IYK,Z,thetaprior,tipo,pdll,
+ 2 theta0,theta,NEVAL)
+C INPUT
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia)
+ INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nt,Z(nobs),
+ 1 IYK(nobs,ny+1),INFOS(9,6),INDT(nt+2)
+ DOUBLE PRECISION yk(nobs,ny+nz),thetaprior(nt,4),theta0(nt)
+ DOUBLE PRECISION MEDT(max(1,INDT(nt+1))),
+ 1 SIGT(max(1,INDT(nt+1)),max(1,INDT(nt+1)))
+
+ CHARACTER*2 tipo(nt)
+C OUTPUT
+ INTEGER NEVAL(nt)
+ DOUBLE PRECISION theta(nt)
+C LOCALS
+ INTEGER I,J,jj,NN,IFAIL,SEQ(nv)
+ INTEGER it,S(nobs,6)
+ DOUBLE PRECISION PN,PO,QN,QO,PA,v,AG,WORK((nt+2)*(nt+1)/2),
+ 1 SEGA(nt),WORK2(nt)
+ DOUBLE PRECISION genunf,ptheta,prior,mvnpdf
+C DOUBLE PRECISION G05CAF
+ IF (nv.GT.0) THEN
+ DO 1 I = 1,nobs
+1 CALL INT2SEQ(Z(I),nv,INFOS,SEQ(1:nv),S(I,1:6))
+ ELSE
+ S(1:nobs,:) = 1
+ ENDIF
+
+C --------------------------------------------
+C DRAW theta1 from p(theta1|Y,S)
+C p(theta1|Y,S) prop p(Y|theta1,S) x p(theta1)
+C --------------------------------------------
+ NN = 0
+ JJ = INDT(nt+1)
+ IF (JJ.GT.1) THEN ! Draw a set of theta via AMH
+C MH proposal:
+C theta ~ (1-beta)*N(MEDT,2.38^2*SIGT/JJ) + beta*N(MEDT,.1^2*I/JJ)
+C7777 v = G05CAF(v) ! Sampling U(0,1)
+7777 v = genunf(0.D0,1.D0) ! Sampling U(0,1)
+ IF (v.LE..95) THEN
+ IFAIL = -1
+c CALL G05EAF(MEDT,JJ,2.38**2*SIGT/DFLOAT(JJ),JJ,1.D-14,
+c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
+c CALL G05EZF(SEGA(1:JJ),JJ,WORK,(nt+2)*(nt+1)/2,IFAIL)
+ CALL setgmn(MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ,JJ,
# WORK(1:(JJ+2)*(JJ+1)/2))
- CALL genmn(WORK(1:(JJ+2)*(JJ+1)/2),SEGA(1:JJ),WORK2(1:JJ))
- ELSE
- DO I = 1,JJ
-c CALL G05EAF(MEDT(I),1,1D-2/DFLOAT(JJ),1,1.D-14,
-c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
-c CALL G05EZF(SEGA(I),1,WORK,(nt+2)*(nt+1)/2,IFAIL)
+ CALL genmn(WORK(1:(JJ+2)*(JJ+1)/2),SEGA(1:JJ),WORK2(1:JJ))
+ ELSE
+ DO I = 1,JJ
+c CALL G05EAF(MEDT(I),1,1D-2/DFLOAT(JJ),1,1.D-14,
+c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
+c CALL G05EZF(SEGA(I),1,WORK,(nt+2)*(nt+1)/2,IFAIL)
CALL setgmn(MEDT(I),1D-2/DFLOAT(JJ),1,1,WORK(1:3))
- CALL genmn(WORK(1:3),SEGA(I),WORK2(1))
- ENDDO
- ENDIF
- NN = NN + 1
-C CHEK theta
- DO I = 1,JJ
- IF ((SEGA(I).LT.thetaprior(INDT(I),3)).OR.
- # (SEGA(I).GT.thetaprior(INDT(I),4))) THEN
- IF (NN.LE.1000) THEN
- GOTO 7777
- ELSE
- type *, ' '
- type *, 'Reduce skcriterium or use Slice sampling'
- type *, 'Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDIF
- END DO
-C f(theta1(new)|theta2,S,y)
- theta(INDT(1:JJ)) = SEGA(1:JJ)
- PN = PTHETA(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta,
- 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
- DO I =2,JJ
- PN = PN + PRIOR(theta(INDT(I)),thetaprior(INDT(I),:),
- # tipo(INDT(I)))
- ENDDO
-C q(theta1(new))
- AG = 1.D0
- DO I = 1,JJ
- AG = AG*mvnpdf(SEGA(I),MEDT(I),1D-2/DFLOAT(JJ),1)
- END DO
- QN = .95D0*mvnpdf(SEGA(1:JJ),MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ)
- + + .05D0*AG
-
-C f(theta1(old)|theta2,S,y)
- PO = PTHETA(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta0,
- 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
- DO I =2,JJ
- PO = PO + PRIOR(theta0(INDT(I)),thetaprior(INDT(I),:),
- # tipo(INDT(I)))
- ENDDO
-C q(theta1(old))
- AG = 1.D0
- DO I = 1,JJ
- AG = AG*mvnpdf(theta0(INDT(1:JJ)),MEDT(I),1D-2/DFLOAT(JJ),1)
- END DO
- QO = .95D0*mvnpdf(theta0(INDT(1:JJ)),MEDT,2.38**2*SIGT/DFLOAT(JJ)
- # ,JJ) + .05D0*AG
-
-C v = G05CAF(v) ! Sampling from U(0,1)
- v = genunf(0.D0,1.D0) ! Sampling U(0,1)
-
- PA = DEXP(PN-PO)*QO/QN
- IF (v.GT.MIN(1.D0,PA)) THEN
- theta(INDT(1:JJ)) = theta0(INDT(1:JJ))
- NEVAL(INDT(1)) = 0
- ELSE
- theta0(INDT(1:JJ)) = theta(INDT(1:JJ))
- NEVAL(INDT(1)) = 1
- ENDIF
- ENDIF
-
-C The rest of theta by SLICE
- DO J = 1,INDT(nt+2)-JJ
- it = INDT(JJ+J)
- CALL SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta0,
- 1 thetaprior(it,:),tipo(it),pdll,NEVAL(it),theta(it))
- theta0(it) = theta(it)
- END DO
-
- RETURN
+ CALL genmn(WORK(1:3),SEGA(I),WORK2(1))
+ ENDDO
+ ENDIF
+ NN = NN + 1
+C CHEK theta
+ DO I = 1,JJ
+ IF ((SEGA(I).LT.thetaprior(INDT(I),3)).OR.
+ # (SEGA(I).GT.thetaprior(INDT(I),4))) THEN
+ IF (NN.LE.1000) THEN
+ GOTO 7777
+ ELSE
+ type *, ' '
+ type *, 'Reduce skcriterium or use Slice sampling'
+ type *, 'Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDIF
+ END DO
+C f(theta1(new)|theta2,S,y)
+ theta(INDT(1:JJ)) = SEGA(1:JJ)
+ PN = PTHETA(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta,
+ 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
+ DO I =2,JJ
+ PN = PN + PRIOR(theta(INDT(I)),thetaprior(INDT(I),:),
+ # tipo(INDT(I)))
+ ENDDO
+C q(theta1(new))
+ AG = 1.D0
+ DO I = 1,JJ
+ AG = AG*mvnpdf(SEGA(I),MEDT(I),1D-2/DFLOAT(JJ),1)
+ END DO
+ QN = .95D0*mvnpdf(SEGA(1:JJ),MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ)
+ + + .05D0*AG
+
+C f(theta1(old)|theta2,S,y)
+ PO = PTHETA(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta0,
+ 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
+ DO I =2,JJ
+ PO = PO + PRIOR(theta0(INDT(I)),thetaprior(INDT(I),:),
+ # tipo(INDT(I)))
+ ENDDO
+C q(theta1(old))
+ AG = 1.D0
+ DO I = 1,JJ
+ AG = AG*mvnpdf(theta0(INDT(1:JJ)),MEDT(I),1D-2/DFLOAT(JJ),1)
+ END DO
+ QO = .95D0*mvnpdf(theta0(INDT(1:JJ)),MEDT,2.38**2*SIGT/DFLOAT(JJ)
+ # ,JJ) + .05D0*AG
+
+C v = G05CAF(v) ! Sampling from U(0,1)
+ v = genunf(0.D0,1.D0) ! Sampling U(0,1)
+
+ PA = DEXP(PN-PO)*QO/QN
+ IF (v.GT.MIN(1.D0,PA)) THEN
+ theta(INDT(1:JJ)) = theta0(INDT(1:JJ))
+ NEVAL(INDT(1)) = 0
+ ELSE
+ theta0(INDT(1:JJ)) = theta(INDT(1:JJ))
+ NEVAL(INDT(1)) = 1
+ ENDIF
+ ENDIF
+
+C The rest of theta by SLICE
+ DO J = 1,INDT(nt+2)-JJ
+ it = INDT(JJ+J)
+ CALL SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta0,
+ 1 thetaprior(it,:),tipo(it),pdll,NEVAL(it),theta(it))
+ theta0(it) = theta(it)
+ END DO
+
+ RETURN
END
diff --git a/drawtheta2.for b/drawtheta2.for
index 88520062fc5af9a6db4b1e5c1d1021bc93b69adc..19eb7f88fcd67fce8d79aa41df41f7c76c7e2424 100644
--- a/drawtheta2.for
+++ b/drawtheta2.for
@@ -1,32 +1,32 @@
-C ----------------------------------------------------------------------
-C DRAWTHETA2 draws model parameters theta (no missing values)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C p(theta|Y,S,z) propto p(theta|Y,S,z)
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C OUTPUT:
-C theta (nt x 1)
-C NEVAL # of runs of the Kalman Filter (KF) / MH acceptance prob
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C DRAWTHETA2 draws model parameters theta (no missing values)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C p(theta|Y,S,z) propto p(theta|Y,S,z)
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C OUTPUT:
+C theta (nt x 1)
+C NEVAL # of runs of the Kalman Filter (KF) / MH acceptance prob
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -34,135 +34,135 @@ C
C DMM is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-C GNU General Public License for more details.
-C
+C GNU General Public License for more details.
+C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- SUBROUTINE DRAWTHETA2(nobs,d,ny,nz,nx,nu,nv,ns,nt,INFOS,INDT,
- 1 MEDT,SIGT,yk,Z,thetaprior,tipo,pdll,
- 2 theta0,theta,NEVAL)
-C INPUT
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia)
- INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nt,Z(nobs),
- 1 INFOS(9,6),INDT(nt+2)
- DOUBLE PRECISION yk(nobs,ny+nz),thetaprior(nt,4),theta0(nt)
- DOUBLE PRECISION MEDT(max(1,INDT(nt+1))),
- 1 SIGT(max(1,INDT(nt+1)),max(1,INDT(nt+1)))
- CHARACTER*2 tipo(nt)
-C OUTPUT
- INTEGER NEVAL(nt)
- DOUBLE PRECISION theta(nt)
-C LOCALS
- INTEGER I,J,JJ,NN,IFAIL,SEQ(nv)
- INTEGER it,S(nobs,6)
- DOUBLE PRECISION PN,PO,QN,QO,PA,v,AG,WORK((nt+2)*(nt+1)/2),
- 1 SEGA(nt),WORK2(nt)
- DOUBLE PRECISION genunf,ptheta2,prior,mvnpdf
-C DOUBLE PRECISION G05CAF
-
- IF (nv.GT.0) THEN
- DO 1 I = 1,nobs
-1 CALL INT2SEQ(Z(I),nv,INFOS,SEQ(1:nv),S(I,1:6))
- ELSE
- S(1:nobs,:) = 1
- ENDIF
-
-C --------------------------------------------
-C DRAW theta1 from p(theta1|Y,S)
-C p(theta1|Y,S) prop p(Y|theta1,S) x p(theta1)
-C --------------------------------------------
- NN = 0
- JJ = INDT(nt+1)
- IF (JJ.GT.1) THEN ! Draw a set of theta via AMH
-C MH proposal:
-C theta ~ (1-beta)*N(MEDT,2.38^2*SIGT/JJ) + beta*N(MEDT,.1^2*I/JJ)
-C7777 v = G05CAF(v) ! Sampling U(0,1)
-7777 v = genunf(0.D0,1.D0) ! Sampling U(0,1)
- IF (v.LE..95) THEN
- IFAIL = -1
-c CALL G05EAF(MEDT,JJ,2.38**2*SIGT/DFLOAT(JJ),JJ,1.D-14,
-c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
-c CALL G05EZF(SEGA(1:JJ),JJ,WORK,(nt+2)*(nt+1)/2,IFAIL)
- CALL setgmn(MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ,JJ,
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ SUBROUTINE DRAWTHETA2(nobs,d,ny,nz,nx,nu,nv,ns,nt,INFOS,INDT,
+ 1 MEDT,SIGT,yk,Z,thetaprior,tipo,pdll,
+ 2 theta0,theta,NEVAL)
+C INPUT
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia)
+ INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nt,Z(nobs),
+ 1 INFOS(9,6),INDT(nt+2)
+ DOUBLE PRECISION yk(nobs,ny+nz),thetaprior(nt,4),theta0(nt)
+ DOUBLE PRECISION MEDT(max(1,INDT(nt+1))),
+ 1 SIGT(max(1,INDT(nt+1)),max(1,INDT(nt+1)))
+ CHARACTER*2 tipo(nt)
+C OUTPUT
+ INTEGER NEVAL(nt)
+ DOUBLE PRECISION theta(nt)
+C LOCALS
+ INTEGER I,J,JJ,NN,IFAIL,SEQ(nv)
+ INTEGER it,S(nobs,6)
+ DOUBLE PRECISION PN,PO,QN,QO,PA,v,AG,WORK((nt+2)*(nt+1)/2),
+ 1 SEGA(nt),WORK2(nt)
+ DOUBLE PRECISION genunf,ptheta2,prior,mvnpdf
+C DOUBLE PRECISION G05CAF
+
+ IF (nv.GT.0) THEN
+ DO 1 I = 1,nobs
+1 CALL INT2SEQ(Z(I),nv,INFOS,SEQ(1:nv),S(I,1:6))
+ ELSE
+ S(1:nobs,:) = 1
+ ENDIF
+
+C --------------------------------------------
+C DRAW theta1 from p(theta1|Y,S)
+C p(theta1|Y,S) prop p(Y|theta1,S) x p(theta1)
+C --------------------------------------------
+ NN = 0
+ JJ = INDT(nt+1)
+ IF (JJ.GT.1) THEN ! Draw a set of theta via AMH
+C MH proposal:
+C theta ~ (1-beta)*N(MEDT,2.38^2*SIGT/JJ) + beta*N(MEDT,.1^2*I/JJ)
+C7777 v = G05CAF(v) ! Sampling U(0,1)
+7777 v = genunf(0.D0,1.D0) ! Sampling U(0,1)
+ IF (v.LE..95) THEN
+ IFAIL = -1
+c CALL G05EAF(MEDT,JJ,2.38**2*SIGT/DFLOAT(JJ),JJ,1.D-14,
+c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
+c CALL G05EZF(SEGA(1:JJ),JJ,WORK,(nt+2)*(nt+1)/2,IFAIL)
+ CALL setgmn(MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ,JJ,
# WORK(1:(JJ+2)*(JJ+1)/2))
- CALL genmn(WORK(1:(JJ+2)*(JJ+1)/2),SEGA(1:JJ),WORK2(1:JJ))
- ELSE
- DO I = 1,JJ
-c CALL G05EAF(MEDT(I),1,1D-2/DFLOAT(JJ),1,1.D-14,
-c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
-c CALL G05EZF(SEGA(I),1,WORK,(nt+2)*(nt+1)/2,IFAIL)
+ CALL genmn(WORK(1:(JJ+2)*(JJ+1)/2),SEGA(1:JJ),WORK2(1:JJ))
+ ELSE
+ DO I = 1,JJ
+c CALL G05EAF(MEDT(I),1,1D-2/DFLOAT(JJ),1,1.D-14,
+c 1 WORK,(nt+2)*(nt+1)/2,IFAIL)
+c CALL G05EZF(SEGA(I),1,WORK,(nt+2)*(nt+1)/2,IFAIL)
CALL setgmn(MEDT(I),1D-2/DFLOAT(JJ),1,1,WORK(1:3))
- CALL genmn(WORK(1:3),SEGA(I),WORK2(1))
- ENDDO
- ENDIF
- NN = NN + 1
-C CHEK theta
- DO I = 1,JJ
- IF ((SEGA(I).LT.thetaprior(INDT(I),3)).OR.
- # (SEGA(I).GT.thetaprior(INDT(I),4))) THEN
- IF (NN.LE.1000) THEN
- GOTO 7777
- ELSE
- type *, ' '
- type *, 'Reduce skcriterium or use Slice sampling'
- type *, 'Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDIF
- END DO
-C f(theta1(new)|theta2,S,y)
- theta(INDT(1:JJ)) = SEGA(1:JJ)
- PN = PTHETA2(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,theta,
- 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
- DO I =2,JJ
- PN = PN + PRIOR(theta(INDT(I)),thetaprior(INDT(I),:),
- # tipo(INDT(I)))
- ENDDO
-C q(theta1(new))
- AG = 1.D0
- DO I = 1,JJ
- AG = AG*mvnpdf(SEGA(I),MEDT(I),1D-2/DFLOAT(JJ),1)
- END DO
- QN = .95D0*mvnpdf(SEGA(1:JJ),MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ)
- + + .05D0*AG
-
-C f(theta1(old)|theta2,S,y)
- PO = PTHETA2(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,theta0,
- 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
- DO I =2,JJ
- PO = PO + PRIOR(theta0(INDT(I)),thetaprior(INDT(I),:),
- # tipo(INDT(I)))
- ENDDO
-C q(theta1(old))
- AG = 1.D0
- DO I = 1,JJ
- AG = AG*mvnpdf(theta0(INDT(1:JJ)),MEDT(I),1D-2/DFLOAT(JJ),1)
- END DO
- QO = .95D0*mvnpdf(theta0(INDT(1:JJ)),MEDT,2.38**2*SIGT/DFLOAT(JJ)
- # ,JJ) + .05D0*AG
-
-c v = G05CAF(v) ! Sampling from U(0,1)
- v = genunf(0.D0,1.D0) ! Sampling U(0,1)
- PA = DEXP(PN-PO)*QO/QN
- IF (v.GT.MIN(1.D0,PA)) THEN
- theta(INDT(1:JJ)) = theta0(INDT(1:JJ))
- NEVAL(INDT(1)) = 0
- ELSE
- theta0(INDT(1:JJ)) = theta(INDT(1:JJ))
- NEVAL(INDT(1)) = 1
- ENDIF
- ENDIF
-
-C The rest of theta by SLICE
- DO J = 1,INDT(nt+2)-JJ
- it = INDT(JJ+J)
- CALL SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,theta0,
- 1 thetaprior(it,:),tipo(it),pdll,NEVAL(it),theta(it))
- theta0(it) = theta(it)
- END DO
-
- RETURN
+ CALL genmn(WORK(1:3),SEGA(I),WORK2(1))
+ ENDDO
+ ENDIF
+ NN = NN + 1
+C CHEK theta
+ DO I = 1,JJ
+ IF ((SEGA(I).LT.thetaprior(INDT(I),3)).OR.
+ # (SEGA(I).GT.thetaprior(INDT(I),4))) THEN
+ IF (NN.LE.1000) THEN
+ GOTO 7777
+ ELSE
+ type *, ' '
+ type *, 'Reduce skcriterium or use Slice sampling'
+ type *, 'Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDIF
+ END DO
+C f(theta1(new)|theta2,S,y)
+ theta(INDT(1:JJ)) = SEGA(1:JJ)
+ PN = PTHETA2(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,theta,
+ 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
+ DO I =2,JJ
+ PN = PN + PRIOR(theta(INDT(I)),thetaprior(INDT(I),:),
+ # tipo(INDT(I)))
+ ENDDO
+C q(theta1(new))
+ AG = 1.D0
+ DO I = 1,JJ
+ AG = AG*mvnpdf(SEGA(I),MEDT(I),1D-2/DFLOAT(JJ),1)
+ END DO
+ QN = .95D0*mvnpdf(SEGA(1:JJ),MEDT,2.38**2*SIGT/DFLOAT(JJ),JJ)
+ + + .05D0*AG
+
+C f(theta1(old)|theta2,S,y)
+ PO = PTHETA2(INDT(1),nobs,d,ny,nz,nx,nu,ns,nt,S,yk,theta0,
+ 1 thetaprior(INDT(1),:),tipo(INDT(1)),pdll)
+ DO I =2,JJ
+ PO = PO + PRIOR(theta0(INDT(I)),thetaprior(INDT(I),:),
+ # tipo(INDT(I)))
+ ENDDO
+C q(theta1(old))
+ AG = 1.D0
+ DO I = 1,JJ
+ AG = AG*mvnpdf(theta0(INDT(1:JJ)),MEDT(I),1D-2/DFLOAT(JJ),1)
+ END DO
+ QO = .95D0*mvnpdf(theta0(INDT(1:JJ)),MEDT,2.38**2*SIGT/DFLOAT(JJ)
+ # ,JJ) + .05D0*AG
+
+c v = G05CAF(v) ! Sampling from U(0,1)
+ v = genunf(0.D0,1.D0) ! Sampling U(0,1)
+ PA = DEXP(PN-PO)*QO/QN
+ IF (v.GT.MIN(1.D0,PA)) THEN
+ theta(INDT(1:JJ)) = theta0(INDT(1:JJ))
+ NEVAL(INDT(1)) = 0
+ ELSE
+ theta0(INDT(1:JJ)) = theta(INDT(1:JJ))
+ NEVAL(INDT(1)) = 1
+ ENDIF
+ ENDIF
+
+C The rest of theta by SLICE
+ DO J = 1,INDT(nt+2)-JJ
+ it = INDT(JJ+J)
+ CALL SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,theta0,
+ 1 thetaprior(it,:),tipo(it),pdll,NEVAL(it),theta(it))
+ theta0(it) = theta(it)
+ END DO
+
+ RETURN
END
diff --git a/ergodic.for b/ergodic.for
index 778e25900be37867b61a639a8f1a35b9404092fa..d735b07fd1e25f452c89177d4f032892315b7616 100644
--- a/ergodic.for
+++ b/ergodic.for
@@ -1,18 +1,18 @@
-C ---------------------------------------------------------------------
-C ERGODIC solves the linear system: PE*(I-P') = 0
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C PE=(PE1,PE2); PE1=PE(1),...,PE(n-1) and PE2=1-sum(PE(1:n-1))
-C A = I-P' = [a b
-C n x n c d]
-C where a = A(1:n-1,1:n-1); c = A(n,1:n-1) (1 x n-1)
-C => PE1 = -c*(a-1*c)**(-1), 1 = (1,1,...1)' (n-1 x 1)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ---------------------------------------------------------------------
+C ERGODIC solves the linear system: PE*(I-P') = 0
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C PE=(PE1,PE2); PE1=PE(1),...,PE(n-1) and PE2=1-sum(PE(1:n-1))
+C A = I-P' = [a b
+C n x n c d]
+C where a = A(1:n-1,1:n-1); c = A(n,1:n-1) (1 x n-1)
+C => PE1 = -c*(a-1*c)**(-1), 1 = (1,1,...1)' (n-1 x 1)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -23,43 +23,43 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ---------------------------------------------------------------------
- SUBROUTINE ERGODIC(n,P,PE)
-C INPUT
- INTEGER n
- DOUBLE PRECISION P(n,n)
-C OUTPUT
- DOUBLE PRECISION PE(n)
-C LOCALS
- INTEGER I,IFAIL,LWORK,IPIV(n-1)
- DOUBLE PRECISION A(n,n),AC(n-1,n-1)
- DOUBLE PRECISION, ALLOCATABLE:: WORK(:)
-
- LWORK = 64*(n-1)
- ALLOCATE(WORK(LWORK))
-
-C A = I - P'
- DO 10 I = 1,n
- A(I,:) = -P(:,I)
-10 A(I,I) = A(I,I) + 1.D0
-
-C AC = a - 1*c
- DO 20 I =1,n-1
-20 AC(I,1:n-1) = A(I,1:n-1) - A(n,1:n-1)
-
-C inv of AC
-C CALL F07ADF(n-1,n-1,AC,n-1,IPIV,IFAIL)
-C CALL F07AJF(n-1,AC,n-1,IPIV,WORK,LWORK,IFAIL)
- CALL DGETRF(n-1,n-1,AC,n-1,IPIV,IFAIL)
- CALL DGETRI(n-1,AC,n-1,IPIV,WORK,LWORK,IFAIL)
-
-C PE = -c*(A-1*c)**(-1)
- DO 30 I=1,n-1
-30 PE(I) = -SUM(A(n,1:n-1)*AC(:,I))
- PE(n) = 1.D0-SUM(PE(1:n-1))
-
- DEALLOCATE(WORK)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ---------------------------------------------------------------------
+ SUBROUTINE ERGODIC(n,P,PE)
+C INPUT
+ INTEGER n
+ DOUBLE PRECISION P(n,n)
+C OUTPUT
+ DOUBLE PRECISION PE(n)
+C LOCALS
+ INTEGER I,IFAIL,LWORK,IPIV(n-1)
+ DOUBLE PRECISION A(n,n),AC(n-1,n-1)
+ DOUBLE PRECISION, ALLOCATABLE:: WORK(:)
+
+ LWORK = 64*(n-1)
+ ALLOCATE(WORK(LWORK))
+
+C A = I - P'
+ DO 10 I = 1,n
+ A(I,:) = -P(:,I)
+10 A(I,I) = A(I,I) + 1.D0
+
+C AC = a - 1*c
+ DO 20 I =1,n-1
+20 AC(I,1:n-1) = A(I,1:n-1) - A(n,1:n-1)
+
+C inv of AC
+C CALL F07ADF(n-1,n-1,AC,n-1,IPIV,IFAIL)
+C CALL F07AJF(n-1,AC,n-1,IPIV,WORK,LWORK,IFAIL)
+ CALL DGETRF(n-1,n-1,AC,n-1,IPIV,IFAIL)
+ CALL DGETRI(n-1,AC,n-1,IPIV,WORK,LWORK,IFAIL)
+
+C PE = -c*(A-1*c)**(-1)
+ DO 30 I=1,n-1
+30 PE(I) = -SUM(A(n,1:n-1)*AC(:,I))
+ PE(n) = 1.D0-SUM(PE(1:n-1))
+
+ DEALLOCATE(WORK)
+
+ RETURN
END
diff --git a/findinput.for b/findinput.for
index 4546896b195c6499648b91dc256b2c20fb63fa10..fc950061c9888838ec7301e07f41dc326cd8a8dc 100644
--- a/findinput.for
+++ b/findinput.for
@@ -1,20 +1,20 @@
-C -------------------------------------------------------------
-C FINFINPUT finds input values in the inputfile
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C INPUT:
-C STR1
-C STR2
-C
-C OPUTPUT:
-C NUM the value to be recovered
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C FINFINPUT finds input values in the inputfile
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C INPUT:
+C STR1
+C STR2
+C
+C OPUTPUT:
+C NUM the value to be recovered
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -25,47 +25,47 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE FINDINPUT(STR1,N1,STR2,N2,NUM)
-C INPUT
- INTEGER N1,N2
- CHARACTER STR1*N1,STR2*N2
-C OUTPUT
- DOUBLE PRECISION NUM
-C LOCALS
- INTEGER IPOS,IPOS2
- CHARACTER*1 :: OSTR
- CHARACTER*300 ERRMSG
-
- NUM = 0.D0
- OSTR = ' '
- ERRMSG = 'INPUT ERROR: '// STR2 //' is not set'
- IPOS = INDEX(TRIM(STR1),STR2)
- IF (IPOS.EQ.0) THEN
- WRITE(*,*) ERRMSG
- PAUSE
- STOP
- ELSE
- IPOS = IPOS+2
- DO WHILE ((OSTR.NE.'=').AND.(OSTR.NE.'$'))
- READ(STR1(IPOS:IPOS),*) OSTR
- IPOS = IPOS+1
- END DO
- IPOS2 = IPOS
- DO WHILE ((OSTR.NE.';').AND.(OSTR.NE.'$'))
- READ(STR1(IPOS2:IPOS2),*) OSTR
- IPOS2 = IPOS2 + 1
- END DO
- IF (IPOS2-1.GT.IPOS) THEN
- READ(STR1(IPOS:IPOS2-2),'(F20.10)') NUM
- READ(STR1(IPOS:IPOS2-2),*) NUM
- ELSE
- WRITE(*,*) ERRMSG
- PAUSE
- STOP
- ENDIF
- ENDIF
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE FINDINPUT(STR1,N1,STR2,N2,NUM)
+C INPUT
+ INTEGER N1,N2
+ CHARACTER STR1*N1,STR2*N2
+C OUTPUT
+ DOUBLE PRECISION NUM
+C LOCALS
+ INTEGER IPOS,IPOS2
+ CHARACTER*1 :: OSTR
+ CHARACTER*300 ERRMSG
+
+ NUM = 0.D0
+ OSTR = ' '
+ ERRMSG = 'INPUT ERROR: '// STR2 //' is not set'
+ IPOS = INDEX(TRIM(STR1),STR2)
+ IF (IPOS.EQ.0) THEN
+ WRITE(*,*) ERRMSG
+ PAUSE
+ STOP
+ ELSE
+ IPOS = IPOS+2
+ DO WHILE ((OSTR.NE.'=').AND.(OSTR.NE.'$'))
+ READ(STR1(IPOS:IPOS),*) OSTR
+ IPOS = IPOS+1
+ END DO
+ IPOS2 = IPOS
+ DO WHILE ((OSTR.NE.';').AND.(OSTR.NE.'$'))
+ READ(STR1(IPOS2:IPOS2),*) OSTR
+ IPOS2 = IPOS2 + 1
+ END DO
+ IF (IPOS2-1.GT.IPOS) THEN
+ READ(STR1(IPOS:IPOS2-2),'(F20.10)') NUM
+ READ(STR1(IPOS:IPOS2-2),*) NUM
+ ELSE
+ WRITE(*,*) ERRMSG
+ PAUSE
+ STOP
+ ENDIF
+ ENDIF
+
+ RETURN
END
diff --git a/forecast.for b/forecast.for
index 5e921c9eef557a055c83aeb28af56226d3dfe452..dd85e2960e605e2f25edc37912404c4cc5a1c0b7 100644
--- a/forecast.for
+++ b/forecast.for
@@ -1,31 +1,31 @@
-C ----------------------------------------------------------------------------
-C FORECAST simulates y(T+1),...,y(T+nf),x(T+1),...,x(T+nf),S(T+1),...,S(T+nf)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C OUTPUT:
-C
-C (nf x (ny+nx+1)) FORE: y(T+k),x(T+k),S(T+k)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------------
+C FORECAST simulates y(T+1),...,y(T+nf),x(T+1),...,x(T+nf),S(T+1),...,S(T+nf)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C OUTPUT:
+C
+C (nf x (ny+nx+1)) FORE: y(T+k),x(T+k),S(T+k)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -34,128 +34,128 @@ C DMM is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
-C ----------------------------------------------------------------------------
- SUBROUTINE FORECAST(zk,nf,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 theta,psi,INFOS,Z,STATE,pdll,FORE)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN)
-
-C INPUT
- INTEGER nf,ny,nz,nx,nu,nv,nt,np(3),ns(6),nstot,Z,INFOS(9,6)
- DOUBLE PRECISION zk(nf,nz),theta(nt),psi(np(1)),STATE(nx)
-
-C OUTPUT
- DOUBLE PRECISION FORE(nf,ny+nx+1)
-C LOCALS
- INTEGER ISEQ,SEQ(nv),inf,I,IFAIL
- INTEGER S(6)
- DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:)
- DOUBLE PRECISION,ALLOCATABLE:: P1(:,:),P2(:,:),P3(:,:),P4(:,:),
- 1 P5(:,:),P6(:,:),PMAT(:,:),PE(:)
- DOUBLE PRECISION U,AUX
- DOUBLE PRECISION MED(nu)
-C DOUBLE PRECISION WORKU((nu+2)*(nu+1)/2)
-
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION genunf,gennor
-C EXTERNAL SUBROUTINES
- EXTERNAL DESIGNZ,PPROD,ERGODIC,INT2SEQ
-
-
- ALLOCATE(R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)))
-
-C Call DESIGN
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-
- IF (nv.GT.0) THEN
- ALLOCATE (P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot))
-
- CALL DESIGNZ(nv,np(1),psi,INFOS,P1,P2,P3,P4,P5,P6)
-C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
- ENDIF
-
-C DRAW Z(T+1) ~ Pr[Z(T+1)|Z(T)]
- S(1:6) = 1
- IF (nv.GT.0) THEN
-C U = G05CAF(U) ! Sampling U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PMAT(ISEQ,Z)
- DO 10 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-10 AUX = AUX + PMAT(ISEQ,Z)
- FORE(1,nx+ny+1) = ISEQ
- CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,S)
- ENDIF
-
-C DRAW x(T+1) ~ f(x(T+1)|x(T),Z(T+1))
- IFAIL = -1
- DO I = 1,nu
- MED(I) = gennor(0.D0,1.D0)
- END DO
- DO 20 I=1,nx
-20 FORE(1,ny+I) = a(I,S(4)) + SUM(F(I,1:nx,S(5))*STATE(1:nx))
- + + SUM(R(I,1:nu,S(6))*MED(1:nu))
-
-C DRAW yk(T+1) ~ f(yk(T+1)|x(T+1),Z(T+1),zk(T+1))
- DO 30 I=1,ny
-30 FORE(1,I) = SUM(H(I,1:nx,S(2))*FORE(1,ny+1:ny+nx))
- + + SUM(c(I,1:nz,S(1))*zk(1,1:nz))
- + + SUM(G(I,1:nu,S(3))*MED(1:nu))
-
- DO 100 inf = 2,nf
-C DRAW Z(T+inf) ~ Pr[Z(T+inf)|Z(T+inf-1)]
- IF (nv.GT.0) THEN
-C U = G05CAF(U) ! Sampling U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PMAT(ISEQ,FORE(inf-1,nx+ny+1))
- DO 40 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-40 AUX = AUX + PMAT(ISEQ,FORE(inf-1,nx+ny+1))
- FORE(inf,nx+ny+1) = ISEQ
- CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,S)
- ENDIF
-
-C DRAW x(T+inf) ~ f(x(T+inf)|x(T+inf-1),Z(T+inf))
- DO I = 1,nu
- MED(I) = gennor(0.D0,1.D0)
- END DO
- DO 50 I=1,nx
-50 FORE(inf,ny+I) = a(I,S(4))
- + + SUM(F(I,1:nx,S(5))*FORE(inf-1,ny+1:ny+nx))
- + + SUM(R(I,1:nu,S(6))*MED(1:nu))
-
-C DRAW y(T+inf) ~ f(y(T+1)|x(T+inf),Z(T+inf),zk(T+inf))
- DO 60 I=1,ny
-60 FORE(inf,I) = SUM(H(I,1:nx,S(2))*FORE(inf,ny+1:ny+nx))
- + + SUM(c(I,1:nz,S(1))*zk(inf,1:nz))
- + + SUM(G(I,1:nu,S(3))*MED(1:nu))
-
-100 CONTINUE
-
- DEALLOCATE (R,c,H,G,a,F)
- IF(nv.GT.0) DEALLOCATE(P1,P2,P3,P4,P5,P6,PMAT,PE)
-
- RETURN
+C ----------------------------------------------------------------------------
+ SUBROUTINE FORECAST(zk,nf,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 theta,psi,INFOS,Z,STATE,pdll,FORE)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN)
+
+C INPUT
+ INTEGER nf,ny,nz,nx,nu,nv,nt,np(3),ns(6),nstot,Z,INFOS(9,6)
+ DOUBLE PRECISION zk(nf,nz),theta(nt),psi(np(1)),STATE(nx)
+
+C OUTPUT
+ DOUBLE PRECISION FORE(nf,ny+nx+1)
+C LOCALS
+ INTEGER ISEQ,SEQ(nv),inf,I,IFAIL
+ INTEGER S(6)
+ DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:)
+ DOUBLE PRECISION,ALLOCATABLE:: P1(:,:),P2(:,:),P3(:,:),P4(:,:),
+ 1 P5(:,:),P6(:,:),PMAT(:,:),PE(:)
+ DOUBLE PRECISION U,AUX
+ DOUBLE PRECISION MED(nu)
+C DOUBLE PRECISION WORKU((nu+2)*(nu+1)/2)
+
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION genunf,gennor
+C EXTERNAL SUBROUTINES
+ EXTERNAL DESIGNZ,PPROD,ERGODIC,INT2SEQ
+
+
+ ALLOCATE(R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)))
+
+C Call DESIGN
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+
+ IF (nv.GT.0) THEN
+ ALLOCATE (P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot))
+
+ CALL DESIGNZ(nv,np(1),psi,INFOS,P1,P2,P3,P4,P5,P6)
+C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+ ENDIF
+
+C DRAW Z(T+1) ~ Pr[Z(T+1)|Z(T)]
+ S(1:6) = 1
+ IF (nv.GT.0) THEN
+C U = G05CAF(U) ! Sampling U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PMAT(ISEQ,Z)
+ DO 10 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+10 AUX = AUX + PMAT(ISEQ,Z)
+ FORE(1,nx+ny+1) = ISEQ
+ CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,S)
+ ENDIF
+
+C DRAW x(T+1) ~ f(x(T+1)|x(T),Z(T+1))
+ IFAIL = -1
+ DO I = 1,nu
+ MED(I) = gennor(0.D0,1.D0)
+ END DO
+ DO 20 I=1,nx
+20 FORE(1,ny+I) = a(I,S(4)) + SUM(F(I,1:nx,S(5))*STATE(1:nx))
+ + + SUM(R(I,1:nu,S(6))*MED(1:nu))
+
+C DRAW yk(T+1) ~ f(yk(T+1)|x(T+1),Z(T+1),zk(T+1))
+ DO 30 I=1,ny
+30 FORE(1,I) = SUM(H(I,1:nx,S(2))*FORE(1,ny+1:ny+nx))
+ + + SUM(c(I,1:nz,S(1))*zk(1,1:nz))
+ + + SUM(G(I,1:nu,S(3))*MED(1:nu))
+
+ DO 100 inf = 2,nf
+C DRAW Z(T+inf) ~ Pr[Z(T+inf)|Z(T+inf-1)]
+ IF (nv.GT.0) THEN
+C U = G05CAF(U) ! Sampling U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PMAT(ISEQ,FORE(inf-1,nx+ny+1))
+ DO 40 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+40 AUX = AUX + PMAT(ISEQ,FORE(inf-1,nx+ny+1))
+ FORE(inf,nx+ny+1) = ISEQ
+ CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,S)
+ ENDIF
+
+C DRAW x(T+inf) ~ f(x(T+inf)|x(T+inf-1),Z(T+inf))
+ DO I = 1,nu
+ MED(I) = gennor(0.D0,1.D0)
+ END DO
+ DO 50 I=1,nx
+50 FORE(inf,ny+I) = a(I,S(4))
+ + + SUM(F(I,1:nx,S(5))*FORE(inf-1,ny+1:ny+nx))
+ + + SUM(R(I,1:nu,S(6))*MED(1:nu))
+
+C DRAW y(T+inf) ~ f(y(T+1)|x(T+inf),Z(T+inf),zk(T+inf))
+ DO 60 I=1,ny
+60 FORE(inf,I) = SUM(H(I,1:nx,S(2))*FORE(inf,ny+1:ny+nx))
+ + + SUM(c(I,1:nz,S(1))*zk(inf,1:nz))
+ + + SUM(G(I,1:nu,S(3))*MED(1:nu))
+
+100 CONTINUE
+
+ DEALLOCATE (R,c,H,G,a,F)
+ IF(nv.GT.0) DEALLOCATE(P1,P2,P3,P4,P5,P6,PMAT,PE)
+
+ RETURN
END
diff --git a/funct1.for b/funct1.for
index 6a4bcd0caed9e50d61c79673ce924774b307c1a0..35b7bf0cdce99eae6ddc17c436293c12f392cf90 100644
--- a/funct1.for
+++ b/funct1.for
@@ -1,13 +1,13 @@
-C -------------------------------------------------------------------------
-C FUNCT1 computes -loglikelihood and the numerical derivatives for E04UCF
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------------------
+C FUNCT1 computes -loglikelihood and the numerical derivatives for E04UCF
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,132 +18,132 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------
- SUBROUTINE FUNCT1(MODE,NPAR,CHI,DLL,OBJGRD,NNN,IU,U)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- INTEGER POINTER pdll
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN)
-
-C INPUT
- INTEGER MODE,NPAR,NNN
- INTEGER*8 IU(72)
- DOUBLE PRECISION U(IU(1)*(2*IU(4)+IU(5)+7)+3*IU(8)+2),
- 1 CHI(NPAR),OBJGRD(NPAR)
-
-C OUTPUT
- DOUBLE PRECISION DLL
-
-C LOCALS
- INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nt,np,nmis,I,J,nstot,
- 1 INFOS(9,6),IMSVAR
- INTEGER, ALLOCATABLE:: INDT(:),IYK(:,:),S(:,:)
- DOUBLE PRECISION, ALLOCATABLE:: theta(:),thetaprior(:,:),psi(:),
- 1 yk(:,:)
- DOUBLE PRECISION, ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),
- 2 a(:,:),F(:,:,:),R(:,:,:)
- DOUBLE PRECISION, ALLOCATABLE:: LIKE(:),XT(:,:),PT(:,:,:),
- 1 Xdd(:,:),Pdd(:,:,:)
- DOUBLE PRECISION, ALLOCATABLE:: XSMOOTH(:,:),XSSE(:,:),
- 1 SSMOOTH(:,:),INN(:,:)
-
-C Retrive metainformation
- nobs = IU(1)
- d(1:2) = IU(2:3)
- ny = IU(4)
- nz = IU(5)
- nx = IU(6)
- nu = IU(7)
- nt = IU(8)
- ns(1:6)= IU(9:14)
- pdll = IU(15)
- nv = IU(16)
- np = IU(71)
- IMSVAR = IU(72)
-
- ALLOCATE(INDT(nt+2),IYK(nobs,ny+1),S(nobs,6))
- ALLOCATE(theta(nt),thetaprior(nt,4),psi(max(1,np)),yk(nobs,ny+nz))
- ALLOCATE(LIKE(nobs),XT(0:nobs,nx),PT(0:nobs,nx,nx),
- 1 Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx))
-
- DO J=1,6
- INFOS(1:9,J) = IU(17+9*(J-1):16+J*9)
- ENDDO
- DO J=1,ny+nz
- yk(:,J) = U(1+nobs*(J-1):J*nobs)
- ENDDO
- thetaprior(1:nt,3) = U(nobs*(ny+nz)+1:nobs*(ny+nz)+nt)
- thetaprior(1:nt,4) = U(nobs*(ny+nz)+nt+1:nobs*(ny+nz)+2*nt)
- I = nobs*(ny+nz)+2*nt+1
- INDT(1:nt+2) = U(I:I+nt+1)
- I = I+nt+2
- DO J=1,ny+1
- IYK(1:nobs,J) = U(I+nobs*(J-1):I+nobs*J-1)
- ENDDO
- I = I+nobs*(ny+1)
- DO J = 1,6
- S(1:nobs,J) = U(I+(J-1)*nobs:I-1+J*nobs)
- ENDDO
-
-C Expand theta and psi
- theta(1:nt) = thetaprior(1:nt,3)
- theta(INDT(1:NPAR-np)) = CHI(1:NPAR-np)
- IF (np.GT.0) psi(1:np) = CHI(NPAR-np+1:NPAR)
-
-C Evaluate the likelihood
- ALLOCATE(c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- nmis = ny*nobs-SUM(IYK(1:nobs,ny+1))
- IF (nv.EQ.0) THEN
- IF (nmis.GT.0) THEN
- CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
- 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
- XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
- CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,LIKE)
- ELSE
- CALL IKF2(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),
- 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
- XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
- CALL KF2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,XT,PT,LIKE)
- ENDIF
- ELSE
- nstot = PRODUCT(INFOS(8,1:nv))
- IF (IMSVAR.EQ.1) THEN ! Hamilton (Ecoca 1989) filter
- ALLOCATE(SSMOOTH(nobs,nstot),INN(nobs,ny))
- CALL HF(nobs,nx,nstot,nz,nu,ns,nv,np,psi,0,yk,IYK,INFOS,
- 1 c,a,F,R,SSMOOTH,INN,LIKE)
- DEALLOCATE(SSMOOTH,INN)
- ELSE ! KIM (JoE 1994) algorithm
- ALLOCATE(XSMOOTH(nobs,nx),XSSE(nobs,nx),SSMOOTH(nobs,nstot),
- 1 INN(nobs,ny))
- CALL KIM(nobs,d,ny,nz,nx,nu,ns,nstot,nv,np,INFOS,yk,IYK,
- 1 c,H,G,a,F,R,psi,0,XSMOOTH,XSSE,SSMOOTH,INN,LIKE)
- DEALLOCATE(XSMOOTH,XSSE,SSMOOTH,INN)
- ENDIF
-
- ENDIF
-
- DLL = -SUM(LIKE(d(1)+1:nobs))
-
- DEALLOCATE(LIKE)
- DEALLOCATE(c,H,G,a,F,R)
- DEALLOCATE(INDT,IYK,S,theta,thetaprior,psi,yk,XT,PT,Xdd,Pdd)
-
- RETURN
- END
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------
+ SUBROUTINE FUNCT1(MODE,NPAR,CHI,DLL,OBJGRD,NNN,IU,U)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ INTEGER POINTER pdll
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN)
+
+C INPUT
+ INTEGER MODE,NPAR,NNN
+ INTEGER*8 IU(72)
+ DOUBLE PRECISION U(IU(1)*(2*IU(4)+IU(5)+7)+3*IU(8)+2),
+ 1 CHI(NPAR),OBJGRD(NPAR)
+
+C OUTPUT
+ DOUBLE PRECISION DLL
+
+C LOCALS
+ INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nt,np,nmis,I,J,nstot,
+ 1 INFOS(9,6),IMSVAR
+ INTEGER, ALLOCATABLE:: INDT(:),IYK(:,:),S(:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: theta(:),thetaprior(:,:),psi(:),
+ 1 yk(:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),
+ 2 a(:,:),F(:,:,:),R(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: LIKE(:),XT(:,:),PT(:,:,:),
+ 1 Xdd(:,:),Pdd(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: XSMOOTH(:,:),XSSE(:,:),
+ 1 SSMOOTH(:,:),INN(:,:)
+
+C Retrive metainformation
+ nobs = IU(1)
+ d(1:2) = IU(2:3)
+ ny = IU(4)
+ nz = IU(5)
+ nx = IU(6)
+ nu = IU(7)
+ nt = IU(8)
+ ns(1:6)= IU(9:14)
+ pdll = IU(15)
+ nv = IU(16)
+ np = IU(71)
+ IMSVAR = IU(72)
+
+ ALLOCATE(INDT(nt+2),IYK(nobs,ny+1),S(nobs,6))
+ ALLOCATE(theta(nt),thetaprior(nt,4),psi(max(1,np)),yk(nobs,ny+nz))
+ ALLOCATE(LIKE(nobs),XT(0:nobs,nx),PT(0:nobs,nx,nx),
+ 1 Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx))
+
+ DO J=1,6
+ INFOS(1:9,J) = IU(17+9*(J-1):16+J*9)
+ ENDDO
+ DO J=1,ny+nz
+ yk(:,J) = U(1+nobs*(J-1):J*nobs)
+ ENDDO
+ thetaprior(1:nt,3) = U(nobs*(ny+nz)+1:nobs*(ny+nz)+nt)
+ thetaprior(1:nt,4) = U(nobs*(ny+nz)+nt+1:nobs*(ny+nz)+2*nt)
+ I = nobs*(ny+nz)+2*nt+1
+ INDT(1:nt+2) = U(I:I+nt+1)
+ I = I+nt+2
+ DO J=1,ny+1
+ IYK(1:nobs,J) = U(I+nobs*(J-1):I+nobs*J-1)
+ ENDDO
+ I = I+nobs*(ny+1)
+ DO J = 1,6
+ S(1:nobs,J) = U(I+(J-1)*nobs:I-1+J*nobs)
+ ENDDO
+
+C Expand theta and psi
+ theta(1:nt) = thetaprior(1:nt,3)
+ theta(INDT(1:NPAR-np)) = CHI(1:NPAR-np)
+ IF (np.GT.0) psi(1:np) = CHI(NPAR-np+1:NPAR)
+
+C Evaluate the likelihood
+ ALLOCATE(c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ nmis = ny*nobs-SUM(IYK(1:nobs,ny+1))
+ IF (nv.EQ.0) THEN
+ IF (nmis.GT.0) THEN
+ CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
+ 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
+ XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+ CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,LIKE)
+ ELSE
+ CALL IKF2(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),
+ 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
+ XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+ CALL KF2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,XT,PT,LIKE)
+ ENDIF
+ ELSE
+ nstot = PRODUCT(INFOS(8,1:nv))
+ IF (IMSVAR.EQ.1) THEN ! Hamilton (Ecoca 1989) filter
+ ALLOCATE(SSMOOTH(nobs,nstot),INN(nobs,ny))
+ CALL HF(nobs,nx,nstot,nz,nu,ns,nv,np,psi,0,yk,IYK,INFOS,
+ 1 c,a,F,R,SSMOOTH,INN,LIKE)
+ DEALLOCATE(SSMOOTH,INN)
+ ELSE ! KIM (JoE 1994) algorithm
+ ALLOCATE(XSMOOTH(nobs,nx),XSSE(nobs,nx),SSMOOTH(nobs,nstot),
+ 1 INN(nobs,ny))
+ CALL KIM(nobs,d,ny,nz,nx,nu,ns,nstot,nv,np,INFOS,yk,IYK,
+ 1 c,H,G,a,F,R,psi,0,XSMOOTH,XSSE,SSMOOTH,INN,LIKE)
+ DEALLOCATE(XSMOOTH,XSSE,SSMOOTH,INN)
+ ENDIF
+
+ ENDIF
+
+ DLL = -SUM(LIKE(d(1)+1:nobs))
+
+ DEALLOCATE(LIKE)
+ DEALLOCATE(c,H,G,a,F,R)
+ DEALLOCATE(INDT,IYK,S,theta,thetaprior,psi,yk,XT,PT,Xdd,Pdd)
+
+ RETURN
+ END
diff --git a/gammln.for b/gammln.for
index e9a2c4718804752acf1480cfa00148a59e216720..7f335d28327a52ccb5c6a57b2ca3da92cd69c91c 100644
--- a/gammln.for
+++ b/gammln.for
@@ -1,11 +1,11 @@
-C ------------------------------------------------------------------------
-C GAMMLN returns the value for the natural logarithm of the Gamma function
-C Numerical Recipes - Chapter 6
-C
+C ------------------------------------------------------------------------
+C GAMMLN returns the value for the natural logarithm of the Gamma function
+C Numerical Recipes - Chapter 6
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -16,29 +16,29 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION gammln(xx)
-C INPUT
- DOUBLE PRECISION xx
- INTEGER j
- DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
- SAVE cof,stp
- DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
- * 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
- * -.5395239384953d-5,2.5066282746310005d0/
- x=xx
- y=x
- tmp=x+5.5d0
- tmp=(x+0.5d0)*dlog(tmp)-tmp
- ser=1.000000000190015d0
- do 11 j=1,6
- y=y+1.d0
- ser=ser+cof(j)/y
-11 continue
- gammln=tmp+log(stp*ser/x)
- return
- END
-
-
-
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION gammln(xx)
+C INPUT
+ DOUBLE PRECISION xx
+ INTEGER j
+ DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
+ SAVE cof,stp
+ DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
+ * 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
+ * -.5395239384953d-5,2.5066282746310005d0/
+ x=xx
+ y=x
+ tmp=x+5.5d0
+ tmp=(x+0.5d0)*dlog(tmp)-tmp
+ ser=1.000000000190015d0
+ do 11 j=1,6
+ y=y+1.d0
+ ser=ser+cof(j)/y
+11 continue
+ gammln=tmp+log(stp*ser/x)
+ return
+ END
+
+
+
diff --git a/gck.for b/gck.for
index ba5cc9c5d094f17b19e1d381982155bd6f93ddca..a5a66130f12b24540fb9f3d5395729f54cb09af0 100644
--- a/gck.for
+++ b/gck.for
@@ -1,51 +1,51 @@
-C ----------------------------------------------------------------------
-C GCK Implements the SINGLE-MOVE Sampler of
-C Gerlach, Carter and Kohn (2000): Efficient Bayesian Inference
-C for Dynamic Mixture Models, JASA, 95,451, pp.819-28
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
-C x Pr[Z(t)|Z(\t)]
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C FURTHER INPUT:
-C
-C nobs: # of observatios
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C nv: # of discrete latent variables (S1,S2,...)
-C ns: ns1,ns2,...
-C nstot: total # of states (states of S1 x S2 x ...x Snv)
-C nt: dimension of theta
-C np: dimension of psi
-C PMAT: (nstot x nstot) one-step transition probabilities
-C PE: ergodic distribution of S1 x S2 x ...x Snv
-C INFOS: (9 x 6) set latent variables
-C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
-C
-C OUTPUT:
-C
-C Z:(nobs x 1) takes values {1,2,...,nstot}
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C GCK Implements the SINGLE-MOVE Sampler of
+C Gerlach, Carter and Kohn (2000): Efficient Bayesian Inference
+C for Dynamic Mixture Models, JASA, 95,451, pp.819-28
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
+C x Pr[Z(t)|Z(\t)]
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C FURTHER INPUT:
+C
+C nobs: # of observatios
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C nv: # of discrete latent variables (S1,S2,...)
+C ns: ns1,ns2,...
+C nstot: total # of states (states of S1 x S2 x ...x Snv)
+C nt: dimension of theta
+C np: dimension of psi
+C PMAT: (nstot x nstot) one-step transition probabilities
+C PE: ergodic distribution of S1 x S2 x ...x Snv
+C INFOS: (9 x 6) set latent variables
+C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
+C
+C OUTPUT:
+C
+C Z:(nobs x 1) takes values {1,2,...,nstot}
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -56,341 +56,341 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- SUBROUTINE GCK(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,yk,IYK,
- 1 theta,psi,INFOS,pdll,Z,S)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,IYK(nobs,ny+1),
- 1 INFOS(9,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np)
-
-C INPUT/OUTPUT
- INTEGER Z(nobs),S(nobs,6)
-
-C LOCALS
- INTEGER IT,I,J,K,IFAIL,ISEQ,IMAX(1),iny,NIFS,KKK
- INTEGER IS(6),SH(3),IND(max(1,d(1)),6),SEQ(nv),IFS(nstot),dc(2)
- DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- DOUBLE PRECISION PMAT(nstot,nstot),PE(nstot),
- 1 P1(MAX(1,INFOS(8,1)*MIN(INFOS(9,1),1)),
- 1 MAX(1,INFOS(8,1)*MIN(INFOS(9,1),1))),
- 1 P2(MAX(1,INFOS(8,2)*MIN(INFOS(9,2),1)),
- 1 MAX(1,INFOS(8,2)*MIN(INFOS(9,2),1))),
- 1 P3(MAX(1,INFOS(8,3)*MIN(INFOS(9,3),1)),
- 1 MAX(1,INFOS(8,3)*MIN(INFOS(9,3),1))),
- 1 P4(MAX(1,INFOS(8,4)*MIN(INFOS(9,4),1)),
- 1 MAX(1,INFOS(8,4)*MIN(INFOS(9,4),1))),
- 1 P5(MAX(1,INFOS(8,5)*MIN(INFOS(9,5),1)),
- 1 MAX(1,INFOS(8,5)*MIN(INFOS(9,5),1))),
- 1 P6(MAX(1,INFOS(8,6)*MIN(INFOS(9,6),1)),
- 1 MAX(1,INFOS(8,6)*MIN(INFOS(9,6),1)))
- DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
- DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
- 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
- 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
- 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
- 4 VVHF(ny,nx),Xdd(0:max(1,d(1)),nx),Pdd(0:max(1,d(1)),nx,nx),
- 5 WORK(3*nx),LAM(nx),AUX,U
- INTEGER, ALLOCATABLE:: IRANK(:)
- DOUBLE PRECISION, ALLOCATABLE:: DLL(:),PROB(:),PROBL(:),
- 1 XT(:,:),PT(:,:,:),PMUL(:,:,:)
- DOUBLE PRECISION EPS,ONE,ZERO
- DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
- DOUBLE PRECISION genunf,LEMMA4,MARKOVP
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
-C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-
-C OMEGA and MU RECURSIONS
- OM(:,:,:)= ZERO
- MU(:,:) = ZERO
- DO 250 IT = nobs-1,1,-1
-C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
- CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
- iny = IYK(IT+1,ny+1)
-
- DO 10 I=1,iny
- Ha(I) = SUM(H(IYK(IT+1,I),:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
- DO 10 J=1,nu
-10 HRG(I,J) = SUM(H(IYK(IT+1,I),:,IS(2))*R(:,J,IS(6)))
- + + G(IYK(IT+1,I),J,IS(3)) ! HR+G (ny x nu)
-
- DO 20 I=1,iny
- DO 20 J=1,iny
-20 VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
-
- DO 30 I=1,iny
- DO 30 J=1,nx
-30 HF(I,J)=SUM(H(IYK(IT+1,I),:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
-
- COM(1:iny,1:iny) = VV(1:iny,1:iny)
- IFAIL = -1
-C CALL F01ADF(iny,COM(1:iny+1,1:iny), iny+1, IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
- DO 40 I=1,iny
- DO 40 J=1,I
- VV(I,J) = COM(I,J)
-40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
-
-C B = R*(H*R+G)'*VV (nx x ny)
- DO 50 I=1,nu
- DO 50 J=1,iny
-50 HRGV(I,J) = SUM(HRG(1:iny,I)*VV(1:iny,J)) ! (H*R+G)'*VV (nu x ny)
-
- DO 60 I=1,nx
- DO 60 J=1,iny
-60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
-
- DO 70 I=1,nx
- DO 70 J=1,nx
- RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
-70 BH(I,J) = SUM(B(I,1:iny)*H(IYK(IT+1,1:iny),J,IS(2))) ! BH (nx x nx)
-
-C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
- DO 80 I=1,nx
- DO 80 J=1,nu
-80 BHRG(I,J) = SUM(B(I,1:iny)*HRG(1:iny,J))
-
- DO 90 I=1,nx
- DO 90 J=1,I
-90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
-
- IFAIL=-1
-C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- DO 100 I=1,nx
- IF (LAM(I).LE.EPS) LAM(I)= ZERO
-100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
-
-C AA = F - B*HF (nx x nx)
- DO 110 I=1,nx
- DO 110 J=1,nx
-110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:iny)*HF(1:iny,J))
-
-C OMC = OM(+1)*CS (nx x nx)
- DO 120 I=1,nx
- DO 120 J=1,nx
-120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
-
-C DD = I + CS'*OM(+1)*CS (nx x nx)
- DD(:,:) = ZERO
- DO 130 I=1,nx
- DD(I,I) = ONE
- DO 130 J=1,I
- DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
-130 DD(J,I) = DD(I,J)
-
-C DI = inv(DD) (nx x nx)
- COM1(1:nx,1:nx) = DD(1:nx,1:nx)
- IFAIL = -1
-C CALL F01ADF(nx,COM1,nx+1,IFAIL)
- CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
- CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
-
- DO 135 I=1,nx
- DO 135 J=1,I
- DI(I,J) = COM1(I,j)
-135 DI(J,I) = DI(I,J)
-
-C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
- DO 140 I=1,nx
- DO 140 J=1,nx
-140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
-
- OMCDIC(:,:) = ZERO
- DO 145 I=1,nx
- OMCDIC(I,I) = ONE
- DO 145 J=1,nx
-145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
-
-C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
- DO 150 I=1,nx
- DO 150 J=1,nx
-150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
-
-C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
- DO 160 I=1,nx
- DO 160 J=1,nx
-160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
-
-C VV*H*F (ny x nx)
- DO 170 I=1,iny
- DO 170 J=1,nx
-170 VVHF(I,J) = SUM(VV(I,1:iny)*HF(1:iny,J))
-
-C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
-C + F'*H'*VV*H*F
- DO 180 I=1,nx
- DO 180 J=1,nx
-180 OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
- + + SUM(HF(1:iny,I)*VVHF(1:iny,J))
-
-C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
-C - AA'*(I - OM C DINV C')*OM(+1)*LAM
-C + F'*H'*VV*(y(+1) - H*a - c*z)
-C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
- COM(1:iny,1) = 0.D0
- DO 185 I=1,iny
-185 COM(I,1) = SUM(c(IYK(IT+1,I),1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
-
- DO 190 I=1,nx
-190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
- + + SUM(B(I,1:iny)*(yk(IT+1,IYK(IT+1,1:iny))
- + - COM(1:iny,1)))
- DO 200 I=1,nx
-200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
- + - SUM(AOMCDICOM(I,:)*LAM(:))
- + + SUM(VVHF(1:iny,I)*(yk(IT+1,IYK(IT+1,1:iny))
- # - Ha(1:iny)-COM(1:iny,1)))
-
-250 CONTINUE
-
-C ---------------
-C START SAMPLING
-C ---------------
- ALLOCATE(DLL(nstot),PROB(nstot),PROBL(nstot),XT(0:nstot,nx),
- 1 PT(0:nstot,nx,nx),IRANK(nstot),PMUL(nstot,nstot,2))
- PMUL(:,:,1) = PMAT(:,:) ! one-step ahead
- PMUL(:,:,2) = 0.D0 ! two-step ahead
- DO 260 I = 1,nstot
- DO 260 J = 1,nstot
- DO 260 K = 1,nstot
-260 PMUL(I,J,2) = PMUL(I,J,2) + PMAT(I,K)*PMAT(K,J)
-
-C FEASIBLE Z-STATES
- NIFS = 0
- IFS(:) = 0
- DO 265 K =1,nstot
- IF (PE(K).GT.0.D0) THEN
- NIFS = NIFS + 1
- IFS(NIFS) = K
-265 ENDIF
- dc(1:2) = 0
- DO 2000 IT = 1,nobs
- DO 1000 KKK = 1,NIFS
- K = IFS(KKK)
- CALL INT2SEQ(K,nv,INFOS,SEQ,IS(:))
- IF ((IT.LE.d(1)).AND.(d(1).GT.0)) THEN
- DO 300 I = 1,d(1)
-300 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
- IND(IT,:)= IS(:)
- CALL IKF(d,ny,nz,nx,nu,ns,IND(1:d(1),:),yk(1:d(1),:),
- 1 IYK(1:d(1),:),c,H,G,a,F,R,Xdd(1:d(1),:),
- 2 Pdd(1:d(1),:,:),DLL(1:max(1,d(1))))
- XT(K,:) = Xdd(IT,:) ! xi(t|t)
- PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
- DLL(:) = ZERO ! log likelihood
- ELSEIF ((IT.GT.d(1)).AND.(d(1).GT.0)) THEN
-C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
- Xdd(0,:) = XT(0,:)
- Pdd(0,:,:) = PT(0,:,:)
- CALL KF(1,dc,ny,nz,nx,nu,ns,IS,yk(IT,:),IYK(IT,:),c,H,G,a,F,R,
- 1 Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
- XT(K,:) = Xdd(1,:)
- PT(K,:,:) = Pdd(1,:,:)
- ELSEIF ((IT.EQ.1).AND.(d(1).EQ.0)) THEN
- CALL IKF(d,ny,nz,nx,nu,ns,IS(:),yk(1,:),IYK(1,:),c,H,G,a,F,R,
- 1 Xdd(0,:),Pdd(0,:,:),DLL(K))
- CALL KF(1,dc,ny,nz,nx,nu,ns,IS(:),yk(1,:),IYK(1,:),c,H,G,a,
- 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K)) ! log likelihood
- XT(K,:) = Xdd(IT,:) ! xi(t|t)
- PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
- ELSEIF ((IT.GT.1).AND.(d(1).EQ.0)) THEN
-C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
- Xdd(0,:) = XT(0,:)
- Pdd(0,:,:) = PT(0,:,:)
- CALL KF(1,dc,ny,nz,nx,nu,ns,IS(:),yk(IT,:),IYK(IT,:),c,H,G,a,
- 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
- XT(K,:) = Xdd(1,:)
- PT(K,:,:) = Pdd(1,:,:)
- ENDIF
-
- SH(1) = Z(max(1,IT-1))
- SH(2) = K
- SH(3) = Z(min(nobs,IT+1))
- PROBL(K) = DLL(K)
- + + LEMMA4(OM(IT,:,:),MU(IT,:),XT(K,:),PT(K,:,:),nx)
- + + MARKOVP(PMUL,PE,nstot,1,IT,nobs,SH)
-
-1000 CONTINUE
-
-C ---------------------------------------------
-C SAMPLING Z(t:t+h-1) using PROB
-C ISEQ is the sampled sequence - out of nstot
-C ---------------------------------------------
-C To prevent exp overflow
- PROB(:) = 0.D0
- IMAX = MAXLOC(PROBL(IFS(1:NIFS)))
- KKK = IFS(IMAX(1))
- PROBL(IFS(1:NIFS)) = PROBL(IFS(1:NIFS))-PROBL(KKK)
- PROB(IFS(1:NIFS)) = DEXP(PROBL(IFS(1:NIFS)))
- # / SUM(DEXP(PROBL(IFS(1:NIFS))))
-
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PROB(1)
- DO 310 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-310 AUX = AUX + PROB(ISEQ)
-
- Z(IT) = ISEQ
-
- XT(0,:) = XT(ISEQ,:)
- PT(0,:,:) = PT(ISEQ,:,:)
-
-2000 CONTINUE
-
- DO I=1,nobs
- CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
- ENDDO
-
- DEALLOCATE(DLL,PROB,PROBL,XT,PT,IRANK,PMUL)
- RETURN
- END
-
-C **** da butta ******************
-c DO IT = 1,nobs-1
-c CALL INT2SEQ(Z(IT),nv,INFOS,SEQ,SS(IT,:))
-c ENDDO
-
-c SS(nobs,:) = 1
-c CALL IKF(d,ny,nz,nx,nu,ns,SS(1:max(d(1),1),1:6),
-c 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
-c 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
-c XX(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
-c PP(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
-c CALL KF(nobs,d,ny,nz,nx,nu,ns,SS,yk,IYK,c,H,G,a,F,R,XX,PP,LIKE)
-
-c R1 = DEXP(SUM(LIKE))*P1(SS(nobs,4),SS(nobs-1,4))
-
-c SS(nobs,4) = 2
-c CALL IKF(d,ny,nz,nx,nu,ns,SS(1:max(d(1),1),1:6),
-c 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
-c 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
-c XX(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
-c PP(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
-c CALL KF(nobs,d,ny,nz,nx,nu,ns,SS,yk,IYK,c,H,G,a,F,R,XX,PP,LIKE)
-c R2 = DEXP(SUM(LIKE))*P1(SS(nobs,4),SS(nobs-1,4))
-c R1 = R1/(R1+R2)
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ SUBROUTINE GCK(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,yk,IYK,
+ 1 theta,psi,INFOS,pdll,Z,S)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,IYK(nobs,ny+1),
+ 1 INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np)
+
+C INPUT/OUTPUT
+ INTEGER Z(nobs),S(nobs,6)
+
+C LOCALS
+ INTEGER IT,I,J,K,IFAIL,ISEQ,IMAX(1),iny,NIFS,KKK
+ INTEGER IS(6),SH(3),IND(max(1,d(1)),6),SEQ(nv),IFS(nstot),dc(2)
+ DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ DOUBLE PRECISION PMAT(nstot,nstot),PE(nstot),
+ 1 P1(MAX(1,INFOS(8,1)*MIN(INFOS(9,1),1)),
+ 1 MAX(1,INFOS(8,1)*MIN(INFOS(9,1),1))),
+ 1 P2(MAX(1,INFOS(8,2)*MIN(INFOS(9,2),1)),
+ 1 MAX(1,INFOS(8,2)*MIN(INFOS(9,2),1))),
+ 1 P3(MAX(1,INFOS(8,3)*MIN(INFOS(9,3),1)),
+ 1 MAX(1,INFOS(8,3)*MIN(INFOS(9,3),1))),
+ 1 P4(MAX(1,INFOS(8,4)*MIN(INFOS(9,4),1)),
+ 1 MAX(1,INFOS(8,4)*MIN(INFOS(9,4),1))),
+ 1 P5(MAX(1,INFOS(8,5)*MIN(INFOS(9,5),1)),
+ 1 MAX(1,INFOS(8,5)*MIN(INFOS(9,5),1))),
+ 1 P6(MAX(1,INFOS(8,6)*MIN(INFOS(9,6),1)),
+ 1 MAX(1,INFOS(8,6)*MIN(INFOS(9,6),1)))
+ DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
+ DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
+ 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
+ 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
+ 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
+ 4 VVHF(ny,nx),Xdd(0:max(1,d(1)),nx),Pdd(0:max(1,d(1)),nx,nx),
+ 5 WORK(3*nx),LAM(nx),AUX,U
+ INTEGER, ALLOCATABLE:: IRANK(:)
+ DOUBLE PRECISION, ALLOCATABLE:: DLL(:),PROB(:),PROBL(:),
+ 1 XT(:,:),PT(:,:,:),PMUL(:,:,:)
+ DOUBLE PRECISION EPS,ONE,ZERO
+ DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
+ DOUBLE PRECISION genunf,LEMMA4,MARKOVP
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
+C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+
+C OMEGA and MU RECURSIONS
+ OM(:,:,:)= ZERO
+ MU(:,:) = ZERO
+ DO 250 IT = nobs-1,1,-1
+C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
+ CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
+ iny = IYK(IT+1,ny+1)
+
+ DO 10 I=1,iny
+ Ha(I) = SUM(H(IYK(IT+1,I),:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
+ DO 10 J=1,nu
+10 HRG(I,J) = SUM(H(IYK(IT+1,I),:,IS(2))*R(:,J,IS(6)))
+ + + G(IYK(IT+1,I),J,IS(3)) ! HR+G (ny x nu)
+
+ DO 20 I=1,iny
+ DO 20 J=1,iny
+20 VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
+
+ DO 30 I=1,iny
+ DO 30 J=1,nx
+30 HF(I,J)=SUM(H(IYK(IT+1,I),:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
+
+ COM(1:iny,1:iny) = VV(1:iny,1:iny)
+ IFAIL = -1
+C CALL F01ADF(iny,COM(1:iny+1,1:iny), iny+1, IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
+ DO 40 I=1,iny
+ DO 40 J=1,I
+ VV(I,J) = COM(I,J)
+40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
+
+C B = R*(H*R+G)'*VV (nx x ny)
+ DO 50 I=1,nu
+ DO 50 J=1,iny
+50 HRGV(I,J) = SUM(HRG(1:iny,I)*VV(1:iny,J)) ! (H*R+G)'*VV (nu x ny)
+
+ DO 60 I=1,nx
+ DO 60 J=1,iny
+60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
+
+ DO 70 I=1,nx
+ DO 70 J=1,nx
+ RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
+70 BH(I,J) = SUM(B(I,1:iny)*H(IYK(IT+1,1:iny),J,IS(2))) ! BH (nx x nx)
+
+C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
+ DO 80 I=1,nx
+ DO 80 J=1,nu
+80 BHRG(I,J) = SUM(B(I,1:iny)*HRG(1:iny,J))
+
+ DO 90 I=1,nx
+ DO 90 J=1,I
+90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
+
+ IFAIL=-1
+C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ DO 100 I=1,nx
+ IF (LAM(I).LE.EPS) LAM(I)= ZERO
+100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
+
+C AA = F - B*HF (nx x nx)
+ DO 110 I=1,nx
+ DO 110 J=1,nx
+110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:iny)*HF(1:iny,J))
+
+C OMC = OM(+1)*CS (nx x nx)
+ DO 120 I=1,nx
+ DO 120 J=1,nx
+120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
+
+C DD = I + CS'*OM(+1)*CS (nx x nx)
+ DD(:,:) = ZERO
+ DO 130 I=1,nx
+ DD(I,I) = ONE
+ DO 130 J=1,I
+ DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
+130 DD(J,I) = DD(I,J)
+
+C DI = inv(DD) (nx x nx)
+ COM1(1:nx,1:nx) = DD(1:nx,1:nx)
+ IFAIL = -1
+C CALL F01ADF(nx,COM1,nx+1,IFAIL)
+ CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
+ CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
+
+ DO 135 I=1,nx
+ DO 135 J=1,I
+ DI(I,J) = COM1(I,j)
+135 DI(J,I) = DI(I,J)
+
+C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
+ DO 140 I=1,nx
+ DO 140 J=1,nx
+140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
+
+ OMCDIC(:,:) = ZERO
+ DO 145 I=1,nx
+ OMCDIC(I,I) = ONE
+ DO 145 J=1,nx
+145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
+
+C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
+ DO 150 I=1,nx
+ DO 150 J=1,nx
+150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
+
+C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
+ DO 160 I=1,nx
+ DO 160 J=1,nx
+160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
+
+C VV*H*F (ny x nx)
+ DO 170 I=1,iny
+ DO 170 J=1,nx
+170 VVHF(I,J) = SUM(VV(I,1:iny)*HF(1:iny,J))
+
+C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
+C + F'*H'*VV*H*F
+ DO 180 I=1,nx
+ DO 180 J=1,nx
+180 OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
+ + + SUM(HF(1:iny,I)*VVHF(1:iny,J))
+
+C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
+C - AA'*(I - OM C DINV C')*OM(+1)*LAM
+C + F'*H'*VV*(y(+1) - H*a - c*z)
+C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
+ COM(1:iny,1) = 0.D0
+ DO 185 I=1,iny
+185 COM(I,1) = SUM(c(IYK(IT+1,I),1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
+
+ DO 190 I=1,nx
+190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
+ + + SUM(B(I,1:iny)*(yk(IT+1,IYK(IT+1,1:iny))
+ + - COM(1:iny,1)))
+ DO 200 I=1,nx
+200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
+ + - SUM(AOMCDICOM(I,:)*LAM(:))
+ + + SUM(VVHF(1:iny,I)*(yk(IT+1,IYK(IT+1,1:iny))
+ # - Ha(1:iny)-COM(1:iny,1)))
+
+250 CONTINUE
+
+C ---------------
+C START SAMPLING
+C ---------------
+ ALLOCATE(DLL(nstot),PROB(nstot),PROBL(nstot),XT(0:nstot,nx),
+ 1 PT(0:nstot,nx,nx),IRANK(nstot),PMUL(nstot,nstot,2))
+ PMUL(:,:,1) = PMAT(:,:) ! one-step ahead
+ PMUL(:,:,2) = 0.D0 ! two-step ahead
+ DO 260 I = 1,nstot
+ DO 260 J = 1,nstot
+ DO 260 K = 1,nstot
+260 PMUL(I,J,2) = PMUL(I,J,2) + PMAT(I,K)*PMAT(K,J)
+
+C FEASIBLE Z-STATES
+ NIFS = 0
+ IFS(:) = 0
+ DO 265 K =1,nstot
+ IF (PE(K).GT.0.D0) THEN
+ NIFS = NIFS + 1
+ IFS(NIFS) = K
+265 ENDIF
+ dc(1:2) = 0
+ DO 2000 IT = 1,nobs
+ DO 1000 KKK = 1,NIFS
+ K = IFS(KKK)
+ CALL INT2SEQ(K,nv,INFOS,SEQ,IS(:))
+ IF ((IT.LE.d(1)).AND.(d(1).GT.0)) THEN
+ DO 300 I = 1,d(1)
+300 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
+ IND(IT,:)= IS(:)
+ CALL IKF(d,ny,nz,nx,nu,ns,IND(1:d(1),:),yk(1:d(1),:),
+ 1 IYK(1:d(1),:),c,H,G,a,F,R,Xdd(1:d(1),:),
+ 2 Pdd(1:d(1),:,:),DLL(1:max(1,d(1))))
+ XT(K,:) = Xdd(IT,:) ! xi(t|t)
+ PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
+ DLL(:) = ZERO ! log likelihood
+ ELSEIF ((IT.GT.d(1)).AND.(d(1).GT.0)) THEN
+C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
+ Xdd(0,:) = XT(0,:)
+ Pdd(0,:,:) = PT(0,:,:)
+ CALL KF(1,dc,ny,nz,nx,nu,ns,IS,yk(IT,:),IYK(IT,:),c,H,G,a,F,R,
+ 1 Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
+ XT(K,:) = Xdd(1,:)
+ PT(K,:,:) = Pdd(1,:,:)
+ ELSEIF ((IT.EQ.1).AND.(d(1).EQ.0)) THEN
+ CALL IKF(d,ny,nz,nx,nu,ns,IS(:),yk(1,:),IYK(1,:),c,H,G,a,F,R,
+ 1 Xdd(0,:),Pdd(0,:,:),DLL(K))
+ CALL KF(1,dc,ny,nz,nx,nu,ns,IS(:),yk(1,:),IYK(1,:),c,H,G,a,
+ 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K)) ! log likelihood
+ XT(K,:) = Xdd(IT,:) ! xi(t|t)
+ PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
+ ELSEIF ((IT.GT.1).AND.(d(1).EQ.0)) THEN
+C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
+ Xdd(0,:) = XT(0,:)
+ Pdd(0,:,:) = PT(0,:,:)
+ CALL KF(1,dc,ny,nz,nx,nu,ns,IS(:),yk(IT,:),IYK(IT,:),c,H,G,a,
+ 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
+ XT(K,:) = Xdd(1,:)
+ PT(K,:,:) = Pdd(1,:,:)
+ ENDIF
+
+ SH(1) = Z(max(1,IT-1))
+ SH(2) = K
+ SH(3) = Z(min(nobs,IT+1))
+ PROBL(K) = DLL(K)
+ + + LEMMA4(OM(IT,:,:),MU(IT,:),XT(K,:),PT(K,:,:),nx)
+ + + MARKOVP(PMUL,PE,nstot,1,IT,nobs,SH)
+
+1000 CONTINUE
+
+C ---------------------------------------------
+C SAMPLING Z(t:t+h-1) using PROB
+C ISEQ is the sampled sequence - out of nstot
+C ---------------------------------------------
+C To prevent exp overflow
+ PROB(:) = 0.D0
+ IMAX = MAXLOC(PROBL(IFS(1:NIFS)))
+ KKK = IFS(IMAX(1))
+ PROBL(IFS(1:NIFS)) = PROBL(IFS(1:NIFS))-PROBL(KKK)
+ PROB(IFS(1:NIFS)) = DEXP(PROBL(IFS(1:NIFS)))
+ # / SUM(DEXP(PROBL(IFS(1:NIFS))))
+
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PROB(1)
+ DO 310 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+310 AUX = AUX + PROB(ISEQ)
+
+ Z(IT) = ISEQ
+
+ XT(0,:) = XT(ISEQ,:)
+ PT(0,:,:) = PT(ISEQ,:,:)
+
+2000 CONTINUE
+
+ DO I=1,nobs
+ CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
+ ENDDO
+
+ DEALLOCATE(DLL,PROB,PROBL,XT,PT,IRANK,PMUL)
+ RETURN
+ END
+
+C **** da butta ******************
+c DO IT = 1,nobs-1
+c CALL INT2SEQ(Z(IT),nv,INFOS,SEQ,SS(IT,:))
+c ENDDO
+
+c SS(nobs,:) = 1
+c CALL IKF(d,ny,nz,nx,nu,ns,SS(1:max(d(1),1),1:6),
+c 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
+c 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
+c XX(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+c PP(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+c CALL KF(nobs,d,ny,nz,nx,nu,ns,SS,yk,IYK,c,H,G,a,F,R,XX,PP,LIKE)
+
+c R1 = DEXP(SUM(LIKE))*P1(SS(nobs,4),SS(nobs-1,4))
+
+c SS(nobs,4) = 2
+c CALL IKF(d,ny,nz,nx,nu,ns,SS(1:max(d(1),1),1:6),
+c 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
+c 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
+c XX(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+c PP(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+c CALL KF(nobs,d,ny,nz,nx,nu,ns,SS,yk,IYK,c,H,G,a,F,R,XX,PP,LIKE)
+c R2 = DEXP(SUM(LIKE))*P1(SS(nobs,4),SS(nobs-1,4))
+c R1 = R1/(R1+R2)
diff --git a/gck2.for b/gck2.for
index 36d54cc3c6e2c31ceb8ba7366e42e3eb24a29a6f..c6c1370f912b0829b27d55fe2606da3b29a2eb36 100644
--- a/gck2.for
+++ b/gck2.for
@@ -1,51 +1,51 @@
-C ----------------------------------------------------------------------
-C GCK2 (no missing values) implements the SINGLE-MOVE Sampler of
-C Gerlach, Carter and Kohn (2000): Efficient Bayesian Inference
-C for Dynamic Mixture Models, JASA, 95,451, pp.819-28
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
-C x Pr[Z(t)|Z(\t)]
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C FURTHER INPUT:
-C
-C nobs: # of observatios
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C nv: # of discrete latent variables (S1,S2,...)
-C ns: ns1,ns2,...
-C nstot: total # of states (states of S1 x S2 x ...x Snv)
-C nt: dimension of theta
-C np: dimension of psi
-C PMAT: (nstot x nstot) one-step transition probabilities
-C PE: ergodic distribution of S1 x S2 x ...x Snv
-C INFOS: (9 x 6) set latent variables
-C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
-C
-C OUTPUT:
-C
-C Z:(nobs x 1) takes values {1,2,...,nstot}
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C GCK2 (no missing values) implements the SINGLE-MOVE Sampler of
+C Gerlach, Carter and Kohn (2000): Efficient Bayesian Inference
+C for Dynamic Mixture Models, JASA, 95,451, pp.819-28
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Pr[Z(t)|Z(\t),Y] pto Pr[Y^(t+1,T)|Y^t,Z] x Pr[Y(t)|Y^(t-1),Z^t]
+C x Pr[Z(t)|Z(\t)]
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C FURTHER INPUT:
+C
+C nobs: # of observatios
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C nv: # of discrete latent variables (S1,S2,...)
+C ns: ns1,ns2,...
+C nstot: total # of states (states of S1 x S2 x ...x Snv)
+C nt: dimension of theta
+C np: dimension of psi
+C PMAT: (nstot x nstot) one-step transition probabilities
+C PE: ergodic distribution of S1 x S2 x ...x Snv
+C INFOS: (9 x 6) set latent variables
+C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
+C
+C OUTPUT:
+C
+C Z:(nobs x 1) takes values {1,2,...,nstot}
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -56,317 +56,317 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- SUBROUTINE GCK2(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,yk,
- 1 theta,psi,INFOS,pdll,Z,S)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,
- 1 INFOS(9,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np)
-
-C INPUT/OUTPUT
- INTEGER Z(nobs),S(nobs,6)
-
-C LOCALS
- INTEGER IT,I,J,K,IFAIL,ISEQ,IMAX(1),NIFS,KKK
- INTEGER IS(6),SH(3),IND(max(1,d(1)),6),SEQ(nv),IFS(nstot),dc(2)
- DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot)
- DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
- DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
- 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
- 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
- 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
- 4 VVHF(ny,nx),Xdd(0:max(1,d(1)),nx),Pdd(0:max(1,d(1)),nx,nx),
- 5 WORK(3*nx),LAM(nx),AUX,U
- INTEGER, ALLOCATABLE:: IRANK(:)
- DOUBLE PRECISION, ALLOCATABLE:: DLL(:),PROB(:),PROBL(:),
- 1 XT(:,:),PT(:,:,:),PMUL(:,:,:)
- DOUBLE PRECISION EPS,ONE,ZERO
- DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
- DOUBLE PRECISION genunf,LEMMA4,MARKOVP
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
-C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-
-C OMEGA and MU RECURSIONS
- OM(:,:,:)= ZERO
- MU(:,:) = ZERO
- DO 250 IT = nobs-1,1,-1
-C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
- CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
-
- DO 10 I=1,ny
- Ha(I) = SUM(H(I,:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
- DO 10 J=1,nu
-10 HRG(I,J) = SUM(H(I,:,IS(2))*R(:,J,IS(6)))
- + + G(I,J,IS(3)) ! HR+G (ny x nu)
-
- DO 20 I=1,ny
- VV(I,I) = SUM(HRG(I,1:nu)*HRG(I,1:nu))
- DO 20 J=1,I-1
- VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
-20 VV(J,I) = VV(I,J)
-
- DO 30 I=1,ny
- DO 30 J=1,nx
-30 HF(I,J)=SUM(H(I,:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
-
- COM(1:ny,1:ny) = VV(1:ny,1:ny)
- IFAIL = -1
-C CALL F01ADF(ny,COM(1:ny+1,1:ny), ny+1, IFAIL)
- CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
-
- DO 40 I=1,ny
- DO 40 J=1,I
- VV(I,J) = COM(I,J)
-40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
-
-C B = R*(H*R+G)'*VV (nx x ny)
- DO 50 I=1,nu
- DO 50 J=1,ny
-50 HRGV(I,J) = SUM(HRG(1:ny,I)*VV(1:ny,J)) ! (H*R+G)'*VV (nu x ny)
-
- DO 60 I=1,nx
- DO 60 J=1,ny
-60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
-
- DO 70 I=1,nx
- DO 70 J=1,nx
-70 BH(I,J) = SUM(B(I,1:ny)*H(1:ny,J,IS(2))) ! BH (nx x nx)
-
- DO 75 I=1,nx
- RR(I,I) = SUM(R(I,:,IS(6))*R(I,:,IS(6)))
- DO 75 J=1,I-1
- RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
-75 RR(J,I) = RR(I,J)
-
-C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
- DO 80 I=1,nx
- DO 80 J=1,nu
-80 BHRG(I,J) = SUM(B(I,1:ny)*HRG(1:ny,J))
-
- DO 90 I=1,nx
- DO 90 J=1,I
-90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
-
- IFAIL=-1
-C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
- DO 100 I=1,nx
- IF (LAM(I).LE.EPS) LAM(I)= ZERO
-100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
-
-C AA = F - B*HF (nx x nx)
- DO 110 I=1,nx
- DO 110 J=1,nx
-110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:ny)*HF(1:ny,J))
-
-C OMC = OM(+1)*CS (nx x nx)
- DO 120 I=1,nx
- DO 120 J=1,nx
-120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
-
-C DD = I + CS'*OM(+1)*CS (nx x nx)
- DD(:,:) = ZERO
- DO 130 I=1,nx
- DD(I,I) = ONE
- DO 130 J=1,I
- DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
-130 DD(J,I) = DD(I,J)
-
-C DI = inv(DD) (nx x nx)
- COM1(1:nx,1:nx) = DD(1:nx,1:nx)
- IFAIL = -1
-C CALL F01ADF(nx,COM1,nx+1,IFAIL)
- CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
- CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
-
- DO 135 I=1,nx
- DO 135 J=1,I
- DI(I,J) = COM1(I,j)
-135 DI(J,I) = DI(I,J)
-
-C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
- DO 140 I=1,nx
- DO 140 J=1,nx
-140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
-
- OMCDIC(:,:) = ZERO
- DO 145 I=1,nx
- OMCDIC(I,I) = ONE
- DO 145 J=1,nx
-145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
-
-C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
- DO 150 I=1,nx
- DO 150 J=1,nx
-150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
-
-C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
- DO 160 I=1,nx
- DO 160 J=1,nx
-160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
-
-C VV*H*F (ny x nx)
- DO 170 I=1,ny
- DO 170 J=1,nx
-170 VVHF(I,J) = SUM(VV(I,1:ny)*HF(1:ny,J))
-
-C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
-C + F'*H'*VV*H*F
- DO 180 I=1,nx
- OM(IT,I,I) = SUM(AOMCDICOM(I,:)*AA(:,I))
- + + SUM(HF(1:ny,I)*VVHF(1:ny,I))
- DO 180 J=1,I-1
- OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
- + + SUM(HF(1:ny,I)*VVHF(1:ny,J))
-180 OM(IT,J,I) = OM(IT,I,J)
-
-C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
-C - AA'*(I - OM C DINV C')*OM(+1)*LAM
-C + F'*H'*VV*(y(+1) - H*a - c*z)
-C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
- COM(1:ny,1) = 0.D0
- DO 185 I=1,ny
-185 COM(I,1) = SUM(c(I,1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
-
- DO 190 I=1,nx
-190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
- + + SUM(B(I,1:ny)*(yk(IT+1,1:ny)
- + - COM(1:ny,1)))
- DO 200 I=1,nx
-200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
- + - SUM(AOMCDICOM(I,:)*LAM(:))
- + + SUM(VVHF(1:ny,I)*(yk(IT+1,1:ny)
- # - Ha(1:ny)-COM(1:ny,1)))
-
-250 CONTINUE
-
-C ---------------
-C START SAMPLING
-C ---------------
- ALLOCATE(DLL(nstot),PROB(nstot),PROBL(nstot),XT(0:nstot,nx),
- 1 PT(0:nstot,nx,nx),IRANK(nstot),PMUL(nstot,nstot,2))
- PMUL(:,:,1) = PMAT(:,:) ! one-step ahead
- PMUL(:,:,2) = 0.D0 ! two-step ahead
- DO 260 I = 1,nstot
- DO 260 J = 1,nstot
- DO 260 K = 1,nstot
-260 PMUL(I,J,2) = PMUL(I,J,2) + PMAT(I,K)*PMAT(K,J)
-
-C FEASIBLE Z-STATES
- NIFS = 0
- IFS(:) = 0
- DO 265 K =1,nstot
- IF (PE(K).GT.0.D0) THEN
- NIFS = NIFS + 1
- IFS(NIFS) = K
-265 ENDIF
- dc(1:2) = 0
- DO 2000 IT = 1,nobs
- DO 1000 KKK = 1,NIFS
- K = IFS(KKK)
- CALL INT2SEQ(K,nv,INFOS,SEQ,IS(:))
- IF ((IT.LE.d(1)).AND.(d(1).GT.0)) THEN
- DO 300 I = 1,d(1)
-300 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
- IND(IT,:)= IS(:)
- CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:d(1),:),yk(1:d(1),:),
- 1 c,H,G,a,F,R,Xdd(1:d(1),:),
- 2 Pdd(1:d(1),:,:),DLL(1:max(1,d(1))))
- XT(K,:) = Xdd(IT,:) ! xi(t|t)
- PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
- DLL(:) = ZERO ! log likelihood
- ELSEIF ((IT.GT.d(1)).AND.(d(1).GT.0)) THEN
-C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
- Xdd(0,:) = XT(0,:)
- Pdd(0,:,:) = PT(0,:,:)
- CALL KF2(1,dc,ny,nz,nx,nu,ns,IS,yk(IT,:),c,H,G,a,F,R,
- 1 Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
- XT(K,:) = Xdd(1,:)
- PT(K,:,:) = Pdd(1,:,:)
- ELSEIF ((IT.EQ.1).AND.(d(1).EQ.0)) THEN
- CALL IKF2(d,ny,nz,nx,nu,ns,IS(:),yk(1,:),c,H,G,a,F,R,
- 1 Xdd(0,:),Pdd(0,:,:),DLL(K))
- CALL KF2(1,dc,ny,nz,nx,nu,ns,IS(:),yk(1,:),c,H,G,a,
- 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K)) ! log likelihood
- XT(K,:) = Xdd(IT,:) ! xi(t|t)
- PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
- ELSEIF ((IT.GT.1).AND.(d(1).EQ.0)) THEN
-C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
- Xdd(0,:) = XT(0,:)
- Pdd(0,:,:) = PT(0,:,:)
- CALL KF2(1,dc,ny,nz,nx,nu,ns,IS(:),yk(IT,:),c,H,G,a,
- 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
- XT(K,:) = Xdd(1,:)
- PT(K,:,:) = Pdd(1,:,:)
- ENDIF
-
- SH(1) = Z(max(1,IT-1))
- SH(2) = K
- SH(3) = Z(min(nobs,IT+1))
- PROBL(K) = DLL(K)
- + + LEMMA4(OM(IT,:,:),MU(IT,:),XT(K,:),PT(K,:,:),nx)
- + + MARKOVP(PMUL,PE,nstot,1,IT,nobs,SH)
-
-1000 CONTINUE
-
-C ---------------------------------------------
-C SAMPLING Z(t:t+h-1) using PROB
-C ISEQ is the sampled sequence - out of nstot
-C ---------------------------------------------
-C To prevent exp overflow
- PROB(:) = 0.D0
- IMAX = MAXLOC(PROBL(IFS(1:NIFS)))
- KKK = IFS(IMAX(1))
- PROBL(IFS(1:NIFS)) = PROBL(IFS(1:NIFS))-PROBL(KKK)
- PROB(IFS(1:NIFS)) = DEXP(PROBL(IFS(1:NIFS)))
- # / SUM(DEXP(PROBL(IFS(1:NIFS))))
-
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PROB(1)
- DO 310 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-310 AUX = AUX + PROB(ISEQ)
-
- Z(IT) = ISEQ
-
- XT(0,:) = XT(ISEQ,:)
- PT(0,:,:) = PT(ISEQ,:,:)
-
-2000 CONTINUE
-
- DO I=1,nobs
- CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
- ENDDO
-
- DEALLOCATE(DLL,PROB,PROBL,XT,PT,IRANK,PMUL)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ SUBROUTINE GCK2(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,yk,
+ 1 theta,psi,INFOS,pdll,Z,S)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np,
+ 1 INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np)
+
+C INPUT/OUTPUT
+ INTEGER Z(nobs),S(nobs,6)
+
+C LOCALS
+ INTEGER IT,I,J,K,IFAIL,ISEQ,IMAX(1),NIFS,KKK
+ INTEGER IS(6),SH(3),IND(max(1,d(1)),6),SEQ(nv),IFS(nstot),dc(2)
+ DOUBLE PRECISION c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot)
+ DOUBLE PRECISION OM(nobs,nx,nx),MU(nobs,nx)
+ DOUBLE PRECISION HRG(ny,nu),VV(ny,ny),HF(ny,nx),COM(ny+1,ny),
+ 1 HRGV(nu,ny),B(nx,ny),RR(nx,nx),BH(nx,nx),BHRG(nx,nu),DD(nx,nx),
+ 2 CS(nx,nx),CC(nx,nx),AA(nx,nx),DI(nx,nx),COM1(nx+1,nx),Ha(ny),
+ 3 OMC(nx,nx),OMCDIC(nx,nx),AOMCDIC(nx,nx),AOMCDICOM(nx,nx),
+ 4 VVHF(ny,nx),Xdd(0:max(1,d(1)),nx),Pdd(0:max(1,d(1)),nx,nx),
+ 5 WORK(3*nx),LAM(nx),AUX,U
+ INTEGER, ALLOCATABLE:: IRANK(:)
+ DOUBLE PRECISION, ALLOCATABLE:: DLL(:),PROB(:),PROBL(:),
+ 1 XT(:,:),PT(:,:,:),PMUL(:,:,:)
+ DOUBLE PRECISION EPS,ONE,ZERO
+ DATA EPS/1.D-14/,ONE/1.0D0/,ZERO/0.0D0/
+ DOUBLE PRECISION genunf,LEMMA4,MARKOVP
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL DESIGNZ(nv,np,psi,INFOS,P1,P2,P3,P4,P5,P6)
+C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+
+C OMEGA and MU RECURSIONS
+ OM(:,:,:)= ZERO
+ MU(:,:) = ZERO
+ DO 250 IT = nobs-1,1,-1
+C INT2SEQ map from Z(IT+1) to IS = (k1 k2 k3 k4 k5 k6)
+ CALL INT2SEQ(Z(IT+1),nv,INFOS,SEQ,IS)
+
+ DO 10 I=1,ny
+ Ha(I) = SUM(H(I,:,IS(2))*a(:,IS(4))) ! H*a (ny x 1)
+ DO 10 J=1,nu
+10 HRG(I,J) = SUM(H(I,:,IS(2))*R(:,J,IS(6)))
+ + + G(I,J,IS(3)) ! HR+G (ny x nu)
+
+ DO 20 I=1,ny
+ VV(I,I) = SUM(HRG(I,1:nu)*HRG(I,1:nu))
+ DO 20 J=1,I-1
+ VV(I,J) = SUM(HRG(I,1:nu)*HRG(J,1:nu)) ! (HR+G)*(HR+G)' (ny x ny)
+20 VV(J,I) = VV(I,J)
+
+ DO 30 I=1,ny
+ DO 30 J=1,nx
+30 HF(I,J)=SUM(H(I,:,IS(2))*F(:,J,IS(5))) ! HF(ny x nx)
+
+ COM(1:ny,1:ny) = VV(1:ny,1:ny)
+ IFAIL = -1
+C CALL F01ADF(ny,COM(1:ny+1,1:ny), ny+1, IFAIL)
+ CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
+
+ DO 40 I=1,ny
+ DO 40 J=1,I
+ VV(I,J) = COM(I,J)
+40 VV(J,I) = VV(I,J) ! inv[(HR+G)*(HR+G)'] (ny x ny)
+
+C B = R*(H*R+G)'*VV (nx x ny)
+ DO 50 I=1,nu
+ DO 50 J=1,ny
+50 HRGV(I,J) = SUM(HRG(1:ny,I)*VV(1:ny,J)) ! (H*R+G)'*VV (nu x ny)
+
+ DO 60 I=1,nx
+ DO 60 J=1,ny
+60 B(I,J) = SUM(R(I,1:nu,IS(6))*HRGV(1:nu,J)) ! B (nx x ny)
+
+ DO 70 I=1,nx
+ DO 70 J=1,nx
+70 BH(I,J) = SUM(B(I,1:ny)*H(1:ny,J,IS(2))) ! BH (nx x nx)
+
+ DO 75 I=1,nx
+ RR(I,I) = SUM(R(I,:,IS(6))*R(I,:,IS(6)))
+ DO 75 J=1,I-1
+ RR(I,J) = SUM(R(I,:,IS(6))*R(J,:,IS(6))) ! RR' (nx x nx)
+75 RR(J,I) = RR(I,J)
+
+C FIND CS such that CS*CS' = RR'-B*HRG*R' (nx x nx)
+ DO 80 I=1,nx
+ DO 80 J=1,nu
+80 BHRG(I,J) = SUM(B(I,1:ny)*HRG(1:ny,J))
+
+ DO 90 I=1,nx
+ DO 90 J=1,I
+90 CC(I,J) = RR(I,J) - SUM(BHRG(I,1:nu)*R(J,1:nu,IS(6)))
+
+ IFAIL=-1
+C CALL F02FAF('V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ CALL DSYEV( 'V','L',nx,CC,nx,LAM,WORK,3*nx,IFAIL)
+ DO 100 I=1,nx
+ IF (LAM(I).LE.EPS) LAM(I)= ZERO
+100 CS(:,I) = CC(1:nx,I)*DSQRT(LAM(I))
+
+C AA = F - B*HF (nx x nx)
+ DO 110 I=1,nx
+ DO 110 J=1,nx
+110 AA(I,J) = F(I,J,IS(5)) - SUM(B(I,1:ny)*HF(1:ny,J))
+
+C OMC = OM(+1)*CS (nx x nx)
+ DO 120 I=1,nx
+ DO 120 J=1,nx
+120 OMC(I,J) = SUM(OM(IT+1,I,:)*CS(:,J))
+
+C DD = I + CS'*OM(+1)*CS (nx x nx)
+ DD(:,:) = ZERO
+ DO 130 I=1,nx
+ DD(I,I) = ONE
+ DO 130 J=1,I
+ DD(I,J) = DD(I,J) + SUM(CS(:,I)*OMC(:,J))
+130 DD(J,I) = DD(I,J)
+
+C DI = inv(DD) (nx x nx)
+ COM1(1:nx,1:nx) = DD(1:nx,1:nx)
+ IFAIL = -1
+C CALL F01ADF(nx,COM1,nx+1,IFAIL)
+ CALL DPOTRF('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = L*L'
+ CALL DPOTRI('L',nx,COM1(1:nx,1:nx),nx,IFAIL) ! COM1 = DD^-1
+
+ DO 135 I=1,nx
+ DO 135 J=1,I
+ DI(I,J) = COM1(I,j)
+135 DI(J,I) = DI(I,J)
+
+C OMCDIC = I - OM(+1)*CS*DI*CS' (nx x nx)
+ DO 140 I=1,nx
+ DO 140 J=1,nx
+140 COM1(I,J) = SUM(OMC(I,:)*DI(:,J)) ! OM(+1)*CS*DI (nx x nx)
+
+ OMCDIC(:,:) = ZERO
+ DO 145 I=1,nx
+ OMCDIC(I,I) = ONE
+ DO 145 J=1,nx
+145 OMCDIC(I,J) = OMCDIC(I,J)-SUM(COM1(I,:)*CS(J,:))
+
+C AOMCDIC = AA'*(I - OM(+1)*CS*DINV CS') (nx x nx)
+ DO 150 I=1,nx
+ DO 150 J=1,nx
+150 AOMCDIC(I,J) = SUM(AA(:,I)*OMCDIC(:,J))
+
+C AOMCDICOM = AA'*(I - OM(+1)*CS*DINV*CS')*OM(+1) (nx x nx)
+ DO 160 I=1,nx
+ DO 160 J=1,nx
+160 AOMCDICOM(I,J) = SUM(AOMCDIC(I,:)*OM(IT+1,:,J))
+
+C VV*H*F (ny x nx)
+ DO 170 I=1,ny
+ DO 170 J=1,nx
+170 VVHF(I,J) = SUM(VV(I,1:ny)*HF(1:ny,J))
+
+C OM = AA*(I - OM(+1)*C*DI*C')*OM(+1)*AA' +
+C + F'*H'*VV*H*F
+ DO 180 I=1,nx
+ OM(IT,I,I) = SUM(AOMCDICOM(I,:)*AA(:,I))
+ + + SUM(HF(1:ny,I)*VVHF(1:ny,I))
+ DO 180 J=1,I-1
+ OM(IT,I,J) = SUM(AOMCDICOM(I,:)*AA(:,J))
+ + + SUM(HF(1:ny,I)*VVHF(1:ny,J))
+180 OM(IT,J,I) = OM(IT,I,J)
+
+C MU = AA'*(I - OM(+1)*C*DI* C')*MU(+1) +
+C - AA'*(I - OM C DINV C')*OM(+1)*LAM
+C + F'*H'*VV*(y(+1) - H*a - c*z)
+C LAM = a - B*H*a + B*[y(+1)-c*z] (nx x 1)
+ COM(1:ny,1) = 0.D0
+ DO 185 I=1,ny
+185 COM(I,1) = SUM(c(I,1:nz,IS(1))*yk(IT+1,ny+1:ny+nz))
+
+ DO 190 I=1,nx
+190 LAM(I) = a(I,IS(4)) - SUM(BH(I,1:nx)*a(1:nx,IS(4)))
+ + + SUM(B(I,1:ny)*(yk(IT+1,1:ny)
+ + - COM(1:ny,1)))
+ DO 200 I=1,nx
+200 MU(IT,I) = SUM(AOMCDIC(I,:)*MU(IT+1,:))
+ + - SUM(AOMCDICOM(I,:)*LAM(:))
+ + + SUM(VVHF(1:ny,I)*(yk(IT+1,1:ny)
+ # - Ha(1:ny)-COM(1:ny,1)))
+
+250 CONTINUE
+
+C ---------------
+C START SAMPLING
+C ---------------
+ ALLOCATE(DLL(nstot),PROB(nstot),PROBL(nstot),XT(0:nstot,nx),
+ 1 PT(0:nstot,nx,nx),IRANK(nstot),PMUL(nstot,nstot,2))
+ PMUL(:,:,1) = PMAT(:,:) ! one-step ahead
+ PMUL(:,:,2) = 0.D0 ! two-step ahead
+ DO 260 I = 1,nstot
+ DO 260 J = 1,nstot
+ DO 260 K = 1,nstot
+260 PMUL(I,J,2) = PMUL(I,J,2) + PMAT(I,K)*PMAT(K,J)
+
+C FEASIBLE Z-STATES
+ NIFS = 0
+ IFS(:) = 0
+ DO 265 K =1,nstot
+ IF (PE(K).GT.0.D0) THEN
+ NIFS = NIFS + 1
+ IFS(NIFS) = K
+265 ENDIF
+ dc(1:2) = 0
+ DO 2000 IT = 1,nobs
+ DO 1000 KKK = 1,NIFS
+ K = IFS(KKK)
+ CALL INT2SEQ(K,nv,INFOS,SEQ,IS(:))
+ IF ((IT.LE.d(1)).AND.(d(1).GT.0)) THEN
+ DO 300 I = 1,d(1)
+300 CALL INT2SEQ(Z(I),nv,INFOS,SEQ,IND(I,:))
+ IND(IT,:)= IS(:)
+ CALL IKF2(d,ny,nz,nx,nu,ns,IND(1:d(1),:),yk(1:d(1),:),
+ 1 c,H,G,a,F,R,Xdd(1:d(1),:),
+ 2 Pdd(1:d(1),:,:),DLL(1:max(1,d(1))))
+ XT(K,:) = Xdd(IT,:) ! xi(t|t)
+ PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
+ DLL(:) = ZERO ! log likelihood
+ ELSEIF ((IT.GT.d(1)).AND.(d(1).GT.0)) THEN
+C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
+ Xdd(0,:) = XT(0,:)
+ Pdd(0,:,:) = PT(0,:,:)
+ CALL KF2(1,dc,ny,nz,nx,nu,ns,IS,yk(IT,:),c,H,G,a,F,R,
+ 1 Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
+ XT(K,:) = Xdd(1,:)
+ PT(K,:,:) = Pdd(1,:,:)
+ ELSEIF ((IT.EQ.1).AND.(d(1).EQ.0)) THEN
+ CALL IKF2(d,ny,nz,nx,nu,ns,IS(:),yk(1,:),c,H,G,a,F,R,
+ 1 Xdd(0,:),Pdd(0,:,:),DLL(K))
+ CALL KF2(1,dc,ny,nz,nx,nu,ns,IS(:),yk(1,:),c,H,G,a,
+ 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K)) ! log likelihood
+ XT(K,:) = Xdd(IT,:) ! xi(t|t)
+ PT(K,:,:) = Pdd(IT,:,:) ! P(t|t)
+ ELSEIF ((IT.GT.1).AND.(d(1).EQ.0)) THEN
+C Input XT(0) PT(0), Output XT(K),PT(K),DLL(K)
+ Xdd(0,:) = XT(0,:)
+ Pdd(0,:,:) = PT(0,:,:)
+ CALL KF2(1,dc,ny,nz,nx,nu,ns,IS(:),yk(IT,:),c,H,G,a,
+ 1 F,R,Xdd(0:1,:),Pdd(0:1,:,:),DLL(K))
+ XT(K,:) = Xdd(1,:)
+ PT(K,:,:) = Pdd(1,:,:)
+ ENDIF
+
+ SH(1) = Z(max(1,IT-1))
+ SH(2) = K
+ SH(3) = Z(min(nobs,IT+1))
+ PROBL(K) = DLL(K)
+ + + LEMMA4(OM(IT,:,:),MU(IT,:),XT(K,:),PT(K,:,:),nx)
+ + + MARKOVP(PMUL,PE,nstot,1,IT,nobs,SH)
+
+1000 CONTINUE
+
+C ---------------------------------------------
+C SAMPLING Z(t:t+h-1) using PROB
+C ISEQ is the sampled sequence - out of nstot
+C ---------------------------------------------
+C To prevent exp overflow
+ PROB(:) = 0.D0
+ IMAX = MAXLOC(PROBL(IFS(1:NIFS)))
+ KKK = IFS(IMAX(1))
+ PROBL(IFS(1:NIFS)) = PROBL(IFS(1:NIFS))-PROBL(KKK)
+ PROB(IFS(1:NIFS)) = DEXP(PROBL(IFS(1:NIFS)))
+ # / SUM(DEXP(PROBL(IFS(1:NIFS))))
+
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PROB(1)
+ DO 310 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+310 AUX = AUX + PROB(ISEQ)
+
+ Z(IT) = ISEQ
+
+ XT(0,:) = XT(ISEQ,:)
+ PT(0,:,:) = PT(ISEQ,:,:)
+
+2000 CONTINUE
+
+ DO I=1,nobs
+ CALL INT2SEQ(Z(I),nv,INFOS,SEQ,S(I,:))
+ ENDDO
+
+ DEALLOCATE(DLL,PROB,PROBL,XT,PT,IRANK,PMUL)
+ RETURN
END
diff --git a/harmonic.for b/harmonic.for
index ce1c270051a84bc7d7cad540d3d7d3c8753dc126..43d27417ca33452cf59e62466764140cf74eabf9 100644
--- a/harmonic.for
+++ b/harmonic.for
@@ -1,18 +1,18 @@
-C --------------------------------------------------------------------------
-C HARMONIC computes the harmonic mean estimates of the Marginal Lilkelihood
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C 1 Modified HME (Geweke, 1999)
-C 2 Modified and stabilized HME (Geweke, 1999)
-C 1/ML = sum[f(S)f(THETA)/p(Y|THETA,S)P(S|THETA)p(THETA)],
-C {S,THETA}~p(S,THETA|Y)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------------
+C HARMONIC computes the harmonic mean estimates of the Marginal Lilkelihood
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C 1 Modified HME (Geweke, 1999)
+C 2 Modified and stabilized HME (Geweke, 1999)
+C 1/ML = sum[f(S)f(THETA)/p(Y|THETA,S)P(S|THETA)p(THETA)],
+C {S,THETA}~p(S,THETA|Y)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -23,241 +23,241 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------
- SUBROUTINE HARMONIC(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk,IYK,gibpar,gibZ,thetaprior,
- 2 psiprior,tipo,pdll,MLH)
-
-C INPUT
- INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
- 1 INFOS(9,6),gibZ(G,nobs),IYK(nobs,ny+1)
- DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
- 1 thetaprior(nt,4),psiprior(np(2),np(3))
- CHARACTER*2 tipo(nt)
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
-
-C OUTPUT
- DOUBLE PRECISION MLH(11,2)
-
-C LOCALS
- INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,SEQ(nv),IS(nobs,6),
- 1 NPVAL,IND1(1),NPARTH,NN,NSI,II,JJ
- DOUBLE PRECISION, ALLOCATABLE:: DEN2(:),ub(:)
- INTEGER,ALLOCATABLE::IND(:,:),NIND(:)
- DOUBLE PRECISION parm(nt),SIGM(nt,nt),pval(11),
- 1 COM(nt+1,nt),ISIGM(nt,nt),DET,CON(11)
- DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),
- 1 ALPHA(:,:),MOM(:,:)
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6))
- dOUBLE PRECISION Ppar(nt+np(1)),Fpar,QTHETA,QPSI,PS,QS,QF,A0,SS(1,1)
- DOUBLE PRECISION ZERO,ONE,PI
- DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION PTHETA,PRIOR,PRIORDIR,CHI2INV !PPCHI2 or G01FCF
-C EXTERNAL SUBROUTINES
- EXTERNAL NEWEYWESTCOV2,DPOTRF,DPOTRI,DESIGNZ,PPROD,ERGODIC,INT2SEQ
-
- NPARTH = 0
- DO I = 1,nt
- IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
- NPARTH = NPARTH + 1
- NPOS(NPARTH) = I
- ENDIF
- ENDDO
- DO I = 1,np(1)
- NPOS(NPARTH+I) = nt+I
- ENDDO
- NPAR = NPARTH + np(1)
- parm(:) = ZERO
- DO I = 1,NPARTH
- parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
- ENDDO
-
- NQ = 0
- CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
- 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
-
- COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
- IFAIL = -1
-C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
- CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
- DET = 1.D0 ! det(SIGM)
- DO I=1,NPARTH
- DET = DET*COM(I,I)**2
- ENDDO
- CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
-
- DO 30 I=1,NPARTH
- ISIGM(I,I) = COM(I,I)
- DO 30 J=1,I-1
- ISIGM(I,J) = COM(I,J)
-30 ISIGM(J,I) = ISIGM(I,J)
-
-C COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
-C IFAIL = -1
-C CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
-C 1 WORK(1:NPARTH),IFAIL) ! det(SIGM)
-
-C p = .05, .55, ...,1
- NPVAL = 11
- ALLOCATE (DEN2(G),IND(G,NPVAL),NIND(NPVAL),ub(NPVAL))
- pval(NPVAL) = 1.D0
- DO 40 I = 1,NPVAL-1
- pval(I) = .05D0 + DFLOAT(I-1)*.1D0
-40 ub(I) = CHI2INV(I,NPARTH) ! only tabulated values
-C40 ub(I) = PPCHI2(pval(I),DFLOAT(NPARTH),IFAIL) !G01FCF(pval(I),DFLOAT(NPARTH),IFAIL)
- CON(:) = (2.D0*PI)**(-NPARTH/2.D0)*DET**(-.5D0)/pval(:)
-
- IF (nv.GT.0) THEN
- ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
-C Transition prob for QS
- DO 55 I = 1,nstot-1
-55 PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
- PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
-
- DO 57 K = 2,nobs
- DO 57 I = 1,nstot-1
- DO 57 J = 1,nstot
- COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
- IF (COM(1,1).GT.ZERO) THEN
- PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.(gibZ(1:G,K-1).EQ.J
- # )))/COM(1,1)
- ELSE
- PTR(K,I,J) = ONE/DFLOAT(nstot)
- ENDIF
-57 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
-
-C Mean and VAR for PSI
- ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
- DO I=1,np(1)
- MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
- MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
- MOM(I,2) = MOM(I,2)-MOM(I,1)**2
- ENDDO
- NN = 0
- K = 0
- DO I = 1,nv
- NSI = INFOS(8,I) ! # of states for S
- IF (INFOS(9,I).EQ.1) THEN ! S~IID
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- DO jj = 1,NSI
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-
- NIND(:) = 0
- QS = ZERO
- PS = ZERO
- IS(:,:) = 1
- Ppar(:) = 0.D0
- DO 110 IG = 1,G
- IF (nv.GT.0) THEN
- CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
- 1 P1,P2,P3,P4,P5,P6)
-C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
- PS = DLOG(PE(gibZ(IG,1))) ! log P(S1)
- QS = DLOG(PTR(1,gibZ(IG,1),1)) ! log Q(S1)
- CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
- DO 60 K = 2,nobs
- CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
- PS = PS + DLOG(PMAT(gibZ(IG,K),gibZ(IG,K-1)))
-60 QS = QS + DLOG(PTR(K,gibZ(IG,K),gibZ(IG,K-1)))
- ENDIF
-
-C Q(THETA)~Gaussian
- QF = ZERO
- DO 70 I = 1,NPARTH
- DO 70 J = 1,NPARTH
-70 QF = QF + (gibpar(IG,NPOS(I))-parm(I))
- # * (gibpar(IG,NPOS(J))-parm(J))*ISIGM(I,J)
- QTHETA = -.5D0*QF
-
-C PRIOR for THETA
- DO 80 I = 1,NPARTH
-80 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
- # tipo(NPOS(I)))
-
-C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
-C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
- QPSI = ZERO
- NN = NPARTH
- K = 0
- DO 100 J = 1,nv
- NSI = INFOS(8,J)
- IF(INFOS(9,J).EQ.1) THEN ! S~IID
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
- NN = NN + NSI-1
- ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
- DO 90 I = 1,NSI
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
-90 NN = NN + NSI-1
- ENDIF
-100 CONTINUE
-
- Fpar = PTHETA(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,IYK,
- 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
- 2 tipo(NPOS(1)),pdll)
- Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log[f(y|par,S)f(par)]
-
- DEN2(IG) = QTHETA+QPSI+QS-Fpar-PS
-
- DO 105 I=1,NPVAL-1
- IF (QF.GT.ub(I)) THEN
- NIND(I) = NIND(I) + 1 ! count where to put 0s
- IND(NIND(I),I) = IG ! those to discard
-105 ENDIF
-110 CONTINUE
-
- IND1 = MINLOC(DEN2)
- DET = DEN2(IND1(1))
- DEN2(1:G) = DEXP(DEN2(1:G)-DET)
-
- MLH(NPVAL,1) = SUM(DEN2(1:G))/DFLOAT(G)
- CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(NPVAL,1),SS)
- MLH(NPVAL,2) = SS(1,1)/(DFLOAT(G)*MLH(NPVAL,1)**2)
- MLH(NPVAL,1) = MLH(NPVAL,1)*CON(NPVAL)
- DO 120 I=NPVAL-1,1,-1
- DEN2(IND(1:NIND(I),I)) = 0.D0
- MLH(I,1) = SUM(DEN2(1:G))/DFLOAT(G)
- CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(I,1),SS)
- MLH(I,2) = SS(1,1)/(DFLOAT(G)*MLH(I,1)**2)
-120 MLH(I,1) = MLH(I,1)*CON(I)
-
- DO 130 I =1,NPVAL
-130 IF (MLH(I,1).GT.ZERO) MLH(I,1) = -DLOG(MLH(I,1))-DET
-
- DEALLOCATE(DEN2,IND,NIND,ub)
- IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------
+ SUBROUTINE HARMONIC(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk,IYK,gibpar,gibZ,thetaprior,
+ 2 psiprior,tipo,pdll,MLH)
+
+C INPUT
+ INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
+ 1 INFOS(9,6),gibZ(G,nobs),IYK(nobs,ny+1)
+ DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
+ 1 thetaprior(nt,4),psiprior(np(2),np(3))
+ CHARACTER*2 tipo(nt)
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+
+C OUTPUT
+ DOUBLE PRECISION MLH(11,2)
+
+C LOCALS
+ INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,SEQ(nv),IS(nobs,6),
+ 1 NPVAL,IND1(1),NPARTH,NN,NSI,II,JJ
+ DOUBLE PRECISION, ALLOCATABLE:: DEN2(:),ub(:)
+ INTEGER,ALLOCATABLE::IND(:,:),NIND(:)
+ DOUBLE PRECISION parm(nt),SIGM(nt,nt),pval(11),
+ 1 COM(nt+1,nt),ISIGM(nt,nt),DET,CON(11)
+ DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),
+ 1 ALPHA(:,:),MOM(:,:)
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6))
+ dOUBLE PRECISION Ppar(nt+np(1)),Fpar,QTHETA,QPSI,PS,QS,QF,A0,SS(1,1)
+ DOUBLE PRECISION ZERO,ONE,PI
+ DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION PTHETA,PRIOR,PRIORDIR,CHI2INV !PPCHI2 or G01FCF
+C EXTERNAL SUBROUTINES
+ EXTERNAL NEWEYWESTCOV2,DPOTRF,DPOTRI,DESIGNZ,PPROD,ERGODIC,INT2SEQ
+
+ NPARTH = 0
+ DO I = 1,nt
+ IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
+ NPARTH = NPARTH + 1
+ NPOS(NPARTH) = I
+ ENDIF
+ ENDDO
+ DO I = 1,np(1)
+ NPOS(NPARTH+I) = nt+I
+ ENDDO
+ NPAR = NPARTH + np(1)
+ parm(:) = ZERO
+ DO I = 1,NPARTH
+ parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
+ ENDDO
+
+ NQ = 0
+ CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
+ 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
+
+ COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+ IFAIL = -1
+C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
+ CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
+ DET = 1.D0 ! det(SIGM)
+ DO I=1,NPARTH
+ DET = DET*COM(I,I)**2
+ ENDDO
+ CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
+
+ DO 30 I=1,NPARTH
+ ISIGM(I,I) = COM(I,I)
+ DO 30 J=1,I-1
+ ISIGM(I,J) = COM(I,J)
+30 ISIGM(J,I) = ISIGM(I,J)
+
+C COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+C IFAIL = -1
+C CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
+C 1 WORK(1:NPARTH),IFAIL) ! det(SIGM)
+
+C p = .05, .55, ...,1
+ NPVAL = 11
+ ALLOCATE (DEN2(G),IND(G,NPVAL),NIND(NPVAL),ub(NPVAL))
+ pval(NPVAL) = 1.D0
+ DO 40 I = 1,NPVAL-1
+ pval(I) = .05D0 + DFLOAT(I-1)*.1D0
+40 ub(I) = CHI2INV(I,NPARTH) ! only tabulated values
+C40 ub(I) = PPCHI2(pval(I),DFLOAT(NPARTH),IFAIL) !G01FCF(pval(I),DFLOAT(NPARTH),IFAIL)
+ CON(:) = (2.D0*PI)**(-NPARTH/2.D0)*DET**(-.5D0)/pval(:)
+
+ IF (nv.GT.0) THEN
+ ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
+C Transition prob for QS
+ DO 55 I = 1,nstot-1
+55 PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
+ PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
+
+ DO 57 K = 2,nobs
+ DO 57 I = 1,nstot-1
+ DO 57 J = 1,nstot
+ COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
+ IF (COM(1,1).GT.ZERO) THEN
+ PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.(gibZ(1:G,K-1).EQ.J
+ # )))/COM(1,1)
+ ELSE
+ PTR(K,I,J) = ONE/DFLOAT(nstot)
+ ENDIF
+57 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
+
+C Mean and VAR for PSI
+ ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
+ DO I=1,np(1)
+ MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
+ MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
+ MOM(I,2) = MOM(I,2)-MOM(I,1)**2
+ ENDDO
+ NN = 0
+ K = 0
+ DO I = 1,nv
+ NSI = INFOS(8,I) ! # of states for S
+ IF (INFOS(9,I).EQ.1) THEN ! S~IID
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ DO jj = 1,NSI
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+
+ NIND(:) = 0
+ QS = ZERO
+ PS = ZERO
+ IS(:,:) = 1
+ Ppar(:) = 0.D0
+ DO 110 IG = 1,G
+ IF (nv.GT.0) THEN
+ CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
+ 1 P1,P2,P3,P4,P5,P6)
+C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+ PS = DLOG(PE(gibZ(IG,1))) ! log P(S1)
+ QS = DLOG(PTR(1,gibZ(IG,1),1)) ! log Q(S1)
+ CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
+ DO 60 K = 2,nobs
+ CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
+ PS = PS + DLOG(PMAT(gibZ(IG,K),gibZ(IG,K-1)))
+60 QS = QS + DLOG(PTR(K,gibZ(IG,K),gibZ(IG,K-1)))
+ ENDIF
+
+C Q(THETA)~Gaussian
+ QF = ZERO
+ DO 70 I = 1,NPARTH
+ DO 70 J = 1,NPARTH
+70 QF = QF + (gibpar(IG,NPOS(I))-parm(I))
+ # * (gibpar(IG,NPOS(J))-parm(J))*ISIGM(I,J)
+ QTHETA = -.5D0*QF
+
+C PRIOR for THETA
+ DO 80 I = 1,NPARTH
+80 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
+ # tipo(NPOS(I)))
+
+C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
+C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
+ QPSI = ZERO
+ NN = NPARTH
+ K = 0
+ DO 100 J = 1,nv
+ NSI = INFOS(8,J)
+ IF(INFOS(9,J).EQ.1) THEN ! S~IID
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
+ DO 90 I = 1,NSI
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+90 NN = NN + NSI-1
+ ENDIF
+100 CONTINUE
+
+ Fpar = PTHETA(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,IYK,
+ 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
+ 2 tipo(NPOS(1)),pdll)
+ Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log[f(y|par,S)f(par)]
+
+ DEN2(IG) = QTHETA+QPSI+QS-Fpar-PS
+
+ DO 105 I=1,NPVAL-1
+ IF (QF.GT.ub(I)) THEN
+ NIND(I) = NIND(I) + 1 ! count where to put 0s
+ IND(NIND(I),I) = IG ! those to discard
+105 ENDIF
+110 CONTINUE
+
+ IND1 = MINLOC(DEN2)
+ DET = DEN2(IND1(1))
+ DEN2(1:G) = DEXP(DEN2(1:G)-DET)
+
+ MLH(NPVAL,1) = SUM(DEN2(1:G))/DFLOAT(G)
+ CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(NPVAL,1),SS)
+ MLH(NPVAL,2) = SS(1,1)/(DFLOAT(G)*MLH(NPVAL,1)**2)
+ MLH(NPVAL,1) = MLH(NPVAL,1)*CON(NPVAL)
+ DO 120 I=NPVAL-1,1,-1
+ DEN2(IND(1:NIND(I),I)) = 0.D0
+ MLH(I,1) = SUM(DEN2(1:G))/DFLOAT(G)
+ CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(I,1),SS)
+ MLH(I,2) = SS(1,1)/(DFLOAT(G)*MLH(I,1)**2)
+120 MLH(I,1) = MLH(I,1)*CON(I)
+
+ DO 130 I =1,NPVAL
+130 IF (MLH(I,1).GT.ZERO) MLH(I,1) = -DLOG(MLH(I,1))-DET
+
+ DEALLOCATE(DEN2,IND,NIND,ub)
+ IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
+
+ RETURN
END
diff --git a/harmonic2.for b/harmonic2.for
index a027710e89c9791847e80a934c7f2416adf0bb60..502f0bc9fc0bd0a4baaca034dcc3804596e5549c 100644
--- a/harmonic2.for
+++ b/harmonic2.for
@@ -1,19 +1,19 @@
-C --------------------------------------------------------------------------
-C HARMONIC2 (no missing values) computes the harmonic mean estimates of
-C the Marginal Lilkelihood
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C 1 Modified HME (Geweke, 1999)
-C 2 Modified and stabilized HME (Geweke, 1999)
-C 1/ML = sum[f(S)f(THETA)/p(Y|THETA,S)P(S|THETA)p(THETA)],
-C {S,THETA}~p(S,THETA|Y)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------------
+C HARMONIC2 (no missing values) computes the harmonic mean estimates of
+C the Marginal Lilkelihood
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C 1 Modified HME (Geweke, 1999)
+C 2 Modified and stabilized HME (Geweke, 1999)
+C 1/ML = sum[f(S)f(THETA)/p(Y|THETA,S)P(S|THETA)p(THETA)],
+C {S,THETA}~p(S,THETA|Y)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -24,241 +24,241 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------
- SUBROUTINE HARMONIC2(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk,gibpar,gibZ,thetaprior,psiprior,
- 2 tipo,pdll,MLH)
-
-C INPUT
- INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
- 1 INFOS(9,6),gibZ(G,nobs)
- DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
- 1 thetaprior(nt,4),psiprior(np(2),np(3))
- CHARACTER*2 tipo(nt)
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
-
-C OUTPUT
- DOUBLE PRECISION MLH(11,2)
-
-C LOCALS
- INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,SEQ(nv),IS(nobs,6),
- 1 NPVAL,IND1(1),NPARTH,NN,NSI,II,JJ
- DOUBLE PRECISION, ALLOCATABLE:: DEN2(:),ub(:)
- INTEGER,ALLOCATABLE::IND(:,:),NIND(:)
- DOUBLE PRECISION parm(nt),SIGM(nt,nt),pval(11),
- 1 COM(nt+1,nt),ISIGM(nt,nt),DET,CON(11)
- DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),
- 1 ALPHA(:,:),MOM(:,:)
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6))
- DOUBLE PRECISION Ppar(nt+np(1)),Fpar,QTHETA,QPSI,PS,QS,QF,A0,SS(1,1)
- DOUBLE PRECISION ZERO,ONE,PI
- DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION PTHETA2,PRIOR,PRIORDIR,CHI2INV !PPCHI2,G01FCF
-C EXTERNAL SUBROUTINES
- EXTERNAL NEWEYWESTCOV2,DPOTRF,DPOTRI,DESIGNZ,PPROD,ERGODIC,INT2SEQ
-
- NPARTH = 0
- DO I = 1,nt
- IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
- NPARTH = NPARTH + 1
- NPOS(NPARTH) = I
- ENDIF
- ENDDO
- DO I = 1,np(1)
- NPOS(NPARTH+I) = nt+I
- ENDDO
- NPAR = NPARTH + np(1)
- parm(:) = ZERO
- DO I = 1,NPARTH
- parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
- ENDDO
-
- NQ = 0
- CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
- 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
-
- COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
- IFAIL = -1
-C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
- CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
- DET = 1.D0 ! det(SIGM)
- DO I=1,NPARTH
- DET = DET*COM(I,I)**2
- ENDDO
- CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
-
- DO 30 I=1,NPARTH
- ISIGM(I,I) = COM(I,I)
- DO 30 J=1,I-1
- ISIGM(I,J) = COM(I,J)
-30 ISIGM(J,I) = ISIGM(I,J)
-
-c COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
-c IFAIL = -1
-c CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
-c 1 WORK(1:NPARTH),IFAIL) ! det(SIGM)
-
-C p = .05, .55, ...,1
- NPVAL = 11
- ALLOCATE (DEN2(G),IND(G,NPVAL),NIND(NPVAL),ub(NPVAL))
- pval(NPVAL) = 1.D0
- DO 40 I = 1,NPVAL-1
- pval(I) = 0.05D0 + DFLOAT(I-1)*.1D0
-40 ub(I) = CHI2INV(I,NPARTH) ! only tabulated values
-C40 ub(I) = PPCHI2(pval(I),DFLOAT(NPARTH),IFAIL) ! G01FCF(pval(I),DFLOAT(NPARTH),IFAIL)
- CON(:) = (2.D0*PI)**(-NPARTH/2.D0)*DET**(-.5D0)/pval(:)
-
- IF (nv.GT.0) THEN
- ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
-C Transition prob for QS
- DO 55 I = 1,nstot-1
-55 PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
- PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
-
- DO 57 K = 2,nobs
- DO 57 I = 1,nstot-1
- DO 57 J = 1,nstot
- COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
- IF (COM(1,1).GT.ZERO) THEN
- PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.(gibZ(1:G,K-1).EQ.J
- # )))/COM(1,1)
- ELSE
- PTR(K,I,J) = ONE/DFLOAT(nstot)
- ENDIF
-57 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
-
-C Mean and VAR for PSI
- ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
- DO I=1,np(1)
- MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
- MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
- MOM(I,2) = MOM(I,2)-MOM(I,1)**2
- ENDDO
- NN = 0
- K = 0
- DO I = 1,nv
- NSI = INFOS(8,I) ! # of states for S
- IF (INFOS(9,I).EQ.1) THEN ! S~IID
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- DO jj = 1,NSI
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-
- NIND(:) = 0
- QS = ZERO
- PS = ZERO
- IS(:,:) = 1
- Ppar(:) = 0.D0
- DO 110 IG = 1,G
- IF (nv.GT.0) THEN
- CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
- 1 P1,P2,P3,P4,P5,P6)
-C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
- PS = DLOG(PE(gibZ(IG,1))) ! log P(S1)
- QS = DLOG(PTR(1,gibZ(IG,1),1)) ! log Q(S1)
- CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
- DO 60 K = 2,nobs
- CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
- PS = PS + DLOG(PMAT(gibZ(IG,K),gibZ(IG,K-1)))
-60 QS = QS + DLOG(PTR(K,gibZ(IG,K),gibZ(IG,K-1)))
- ENDIF
-
-C Q(THETA)~Gaussian
- QF = ZERO
- DO 70 I = 1,NPARTH
- DO 70 J = 1,NPARTH
-70 QF = QF + (gibpar(IG,NPOS(I))-parm(I))
- # * (gibpar(IG,NPOS(J))-parm(J))*ISIGM(I,J)
- QTHETA = -.5D0*QF
-
-C PRIOR for THETA
- DO 80 I = 1,NPARTH
-80 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
- # tipo(NPOS(I)))
-
-C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
-C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
- QPSI = ZERO
- NN = NPARTH
- K = 0
- DO 100 J = 1,nv
- NSI = INFOS(8,J)
- IF(INFOS(9,J).EQ.1) THEN ! S~IID
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
- NN = NN + NSI-1
- ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
- DO 90 I = 1,NSI
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
-90 NN = NN + NSI-1
- ENDIF
-100 CONTINUE
-
- Fpar = PTHETA2(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,
- 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
- 2 tipo(NPOS(1)),pdll)
- Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log[f(y|par,S)f(par)]
-
- DEN2(IG) = QTHETA+QPSI+QS-Fpar-PS
-
- DO 105 I=1,NPVAL-1
- IF (QF.GT.ub(I)) THEN
- NIND(I) = NIND(I) + 1 ! count where to put 0s
- IND(NIND(I),I) = IG ! those to discard
-105 ENDIF
-110 CONTINUE
-
- IND1 = MINLOC(DEN2)
- DET = DEN2(IND1(1))
- DEN2(1:G) = DEXP(DEN2(1:G)-DET)
-
- MLH(NPVAL,1) = SUM(DEN2(1:G))/DFLOAT(G)
- CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(NPVAL,1),SS)
- MLH(NPVAL,2) = SS(1,1)/(DFLOAT(G)*MLH(NPVAL,1)**2)
- MLH(NPVAL,1) = MLH(NPVAL,1)*CON(NPVAL)
- DO 120 I=NPVAL-1,1,-1
- DEN2(IND(1:NIND(I),I)) = 0.D0
- MLH(I,1) = SUM(DEN2(1:G))/DFLOAT(G)
- CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(I,1),SS)
- MLH(I,2) = SS(1,1)/(DFLOAT(G)*MLH(I,1)**2)
-120 MLH(I,1) = MLH(I,1)*CON(I)
-
- DO 130 I =1,NPVAL
-130 IF (MLH(I,1).GT.ZERO) MLH(I,1) = -DLOG(MLH(I,1))-DET
-
- DEALLOCATE(DEN2,IND,NIND,ub)
- IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------
+ SUBROUTINE HARMONIC2(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk,gibpar,gibZ,thetaprior,psiprior,
+ 2 tipo,pdll,MLH)
+
+C INPUT
+ INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
+ 1 INFOS(9,6),gibZ(G,nobs)
+ DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
+ 1 thetaprior(nt,4),psiprior(np(2),np(3))
+ CHARACTER*2 tipo(nt)
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+
+C OUTPUT
+ DOUBLE PRECISION MLH(11,2)
+
+C LOCALS
+ INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,SEQ(nv),IS(nobs,6),
+ 1 NPVAL,IND1(1),NPARTH,NN,NSI,II,JJ
+ DOUBLE PRECISION, ALLOCATABLE:: DEN2(:),ub(:)
+ INTEGER,ALLOCATABLE::IND(:,:),NIND(:)
+ DOUBLE PRECISION parm(nt),SIGM(nt,nt),pval(11),
+ 1 COM(nt+1,nt),ISIGM(nt,nt),DET,CON(11)
+ DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),
+ 1 ALPHA(:,:),MOM(:,:)
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6))
+ DOUBLE PRECISION Ppar(nt+np(1)),Fpar,QTHETA,QPSI,PS,QS,QF,A0,SS(1,1)
+ DOUBLE PRECISION ZERO,ONE,PI
+ DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION PTHETA2,PRIOR,PRIORDIR,CHI2INV !PPCHI2,G01FCF
+C EXTERNAL SUBROUTINES
+ EXTERNAL NEWEYWESTCOV2,DPOTRF,DPOTRI,DESIGNZ,PPROD,ERGODIC,INT2SEQ
+
+ NPARTH = 0
+ DO I = 1,nt
+ IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
+ NPARTH = NPARTH + 1
+ NPOS(NPARTH) = I
+ ENDIF
+ ENDDO
+ DO I = 1,np(1)
+ NPOS(NPARTH+I) = nt+I
+ ENDDO
+ NPAR = NPARTH + np(1)
+ parm(:) = ZERO
+ DO I = 1,NPARTH
+ parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
+ ENDDO
+
+ NQ = 0
+ CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
+ 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
+
+ COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+ IFAIL = -1
+C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
+ CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
+ DET = 1.D0 ! det(SIGM)
+ DO I=1,NPARTH
+ DET = DET*COM(I,I)**2
+ ENDDO
+ CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
+
+ DO 30 I=1,NPARTH
+ ISIGM(I,I) = COM(I,I)
+ DO 30 J=1,I-1
+ ISIGM(I,J) = COM(I,J)
+30 ISIGM(J,I) = ISIGM(I,J)
+
+c COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+c IFAIL = -1
+c CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
+c 1 WORK(1:NPARTH),IFAIL) ! det(SIGM)
+
+C p = .05, .55, ...,1
+ NPVAL = 11
+ ALLOCATE (DEN2(G),IND(G,NPVAL),NIND(NPVAL),ub(NPVAL))
+ pval(NPVAL) = 1.D0
+ DO 40 I = 1,NPVAL-1
+ pval(I) = 0.05D0 + DFLOAT(I-1)*.1D0
+40 ub(I) = CHI2INV(I,NPARTH) ! only tabulated values
+C40 ub(I) = PPCHI2(pval(I),DFLOAT(NPARTH),IFAIL) ! G01FCF(pval(I),DFLOAT(NPARTH),IFAIL)
+ CON(:) = (2.D0*PI)**(-NPARTH/2.D0)*DET**(-.5D0)/pval(:)
+
+ IF (nv.GT.0) THEN
+ ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
+C Transition prob for QS
+ DO 55 I = 1,nstot-1
+55 PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
+ PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
+
+ DO 57 K = 2,nobs
+ DO 57 I = 1,nstot-1
+ DO 57 J = 1,nstot
+ COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
+ IF (COM(1,1).GT.ZERO) THEN
+ PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.(gibZ(1:G,K-1).EQ.J
+ # )))/COM(1,1)
+ ELSE
+ PTR(K,I,J) = ONE/DFLOAT(nstot)
+ ENDIF
+57 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
+
+C Mean and VAR for PSI
+ ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
+ DO I=1,np(1)
+ MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
+ MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
+ MOM(I,2) = MOM(I,2)-MOM(I,1)**2
+ ENDDO
+ NN = 0
+ K = 0
+ DO I = 1,nv
+ NSI = INFOS(8,I) ! # of states for S
+ IF (INFOS(9,I).EQ.1) THEN ! S~IID
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ DO jj = 1,NSI
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+
+ NIND(:) = 0
+ QS = ZERO
+ PS = ZERO
+ IS(:,:) = 1
+ Ppar(:) = 0.D0
+ DO 110 IG = 1,G
+ IF (nv.GT.0) THEN
+ CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
+ 1 P1,P2,P3,P4,P5,P6)
+C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+ PS = DLOG(PE(gibZ(IG,1))) ! log P(S1)
+ QS = DLOG(PTR(1,gibZ(IG,1),1)) ! log Q(S1)
+ CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
+ DO 60 K = 2,nobs
+ CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
+ PS = PS + DLOG(PMAT(gibZ(IG,K),gibZ(IG,K-1)))
+60 QS = QS + DLOG(PTR(K,gibZ(IG,K),gibZ(IG,K-1)))
+ ENDIF
+
+C Q(THETA)~Gaussian
+ QF = ZERO
+ DO 70 I = 1,NPARTH
+ DO 70 J = 1,NPARTH
+70 QF = QF + (gibpar(IG,NPOS(I))-parm(I))
+ # * (gibpar(IG,NPOS(J))-parm(J))*ISIGM(I,J)
+ QTHETA = -.5D0*QF
+
+C PRIOR for THETA
+ DO 80 I = 1,NPARTH
+80 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
+ # tipo(NPOS(I)))
+
+C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
+C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
+ QPSI = ZERO
+ NN = NPARTH
+ K = 0
+ DO 100 J = 1,nv
+ NSI = INFOS(8,J)
+ IF(INFOS(9,J).EQ.1) THEN ! S~IID
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
+ DO 90 I = 1,NSI
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+90 NN = NN + NSI-1
+ ENDIF
+100 CONTINUE
+
+ Fpar = PTHETA2(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,
+ 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
+ 2 tipo(NPOS(1)),pdll)
+ Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log[f(y|par,S)f(par)]
+
+ DEN2(IG) = QTHETA+QPSI+QS-Fpar-PS
+
+ DO 105 I=1,NPVAL-1
+ IF (QF.GT.ub(I)) THEN
+ NIND(I) = NIND(I) + 1 ! count where to put 0s
+ IND(NIND(I),I) = IG ! those to discard
+105 ENDIF
+110 CONTINUE
+
+ IND1 = MINLOC(DEN2)
+ DET = DEN2(IND1(1))
+ DEN2(1:G) = DEXP(DEN2(1:G)-DET)
+
+ MLH(NPVAL,1) = SUM(DEN2(1:G))/DFLOAT(G)
+ CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(NPVAL,1),SS)
+ MLH(NPVAL,2) = SS(1,1)/(DFLOAT(G)*MLH(NPVAL,1)**2)
+ MLH(NPVAL,1) = MLH(NPVAL,1)*CON(NPVAL)
+ DO 120 I=NPVAL-1,1,-1
+ DEN2(IND(1:NIND(I),I)) = 0.D0
+ MLH(I,1) = SUM(DEN2(1:G))/DFLOAT(G)
+ CALL NEWEYWESTCOV2(G,1,1,DEN2(1:G),MLH(I,1),SS)
+ MLH(I,2) = SS(1,1)/(DFLOAT(G)*MLH(I,1)**2)
+120 MLH(I,1) = MLH(I,1)*CON(I)
+
+ DO 130 I =1,NPVAL
+130 IF (MLH(I,1).GT.ZERO) MLH(I,1) = -DLOG(MLH(I,1))-DET
+
+ DEALLOCATE(DEN2,IND,NIND,ub)
+ IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
+
+ RETURN
END
diff --git a/hf.for b/hf.for
index f558538f674558d4a572099b97f83bf67a0920c8..ec21a2ca52ddd10d2add250d73759ec1a2c76356 100644
--- a/hf.for
+++ b/hf.for
@@ -1,18 +1,18 @@
-C ----------------------------------------------------------------------
-C HF computes the loglikelihood, the innovations, and the Hamilton (1989)
-C Smoother for a Markov Switching VAR(1)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT: LLILIKE: log-likelihood
-C INN: innovations
-C SSMOOTH: P(s(t)|y^T), t=1,2,...,T
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C HF computes the loglikelihood, the innovations, and the Hamilton (1989)
+C Smoother for a Markov Switching VAR(1)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT: LLILIKE: log-likelihood
+C INN: innovations
+C SSMOOTH: P(s(t)|y^T), t=1,2,...,T
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -23,146 +23,146 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- SUBROUTINE HF(nobs,nx,nk,nz,nu,ns,nv,np,psi,ismoo,yk,IYK,INFOS,
- 1 c,a,F,R,SSMOOTH,INN,LLIKE)
-
-C INPUT
- INTEGER nobs,nx,nk,nz,nu,nv,np,ns(6),ismoo,IYK(nobs,nx+1),INFOS(9,6)
- DOUBLE PRECISION yk(nobs,nx+nz),c(nx,max(1,nz),ns(1)),
- 1 a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),psi(max(1,np))
-
-C OUTPUT
- DOUBLE PRECISION SSMOOTH(nobs,nk),INN(nobs,nx),LLIKE(nobs)
-
-C LOCALS
- INTEGER inobs,inx,I,J,K,IMAX(1),IS(6),SEQ(1)
- DOUBLE PRECISION,ALLOCATABLE:: ZZ(:),gam(:),mu(:),SIG(:,:),FILT(:,:),
- 1 P(:,:),PE(:),PP1(:,:),PP2(:,:),PP3(:,:),PP4(:,:),PP5(:,:),
- 1 PP6(:,:)
-
- DOUBLE PRECISION logmvnpdf,mvnpdf,norm,Lmax
- ALLOCATE(PP1(INFOS(8,1),INFOS(8,1)),PP2(INFOS(8,2),INFOS(8,2)),
- 1 PP3(INFOS(8,3),INFOS(8,3)),PP4(INFOS(8,4),INFOS(8,4)),
- 1 PP5(INFOS(8,5),INFOS(8,5)),PP6(INFOS(8,6),INFOS(8,6)))
- ALLOCATE(ZZ(nk),gam(nk),mu(nx),SIG(nx,nx),FILT(nobs,nk),
- 1 P(nk,nk),PE(nk))
-
- FILT(:,:) = 0.D0
- LLIKE(:) = 0.D0
- CALL designz(nv,np,psi,INFOS,PP1,PP2,PP3,PP4,PP5,PP6)
- CALL pprod(nv,nk,INFOS,PP1,PP2,PP3,PP4,PP5,PP6,P)
-C Initial condition (stationary MS-VAR(1))
- CALL ergodic(nk,P,PE)
- inx = IYK(1,nx+1)
- DO J = 1,inx
- mu(J) = a(IYK(1,J),IS(4))+
- # + SUM(F(IYK(1,J),IYK(1,1:inx),IS(5))
- # * yk(1,IYK(1,1:inx)))
- # + SUM(c(IYK(1,J),1:nz,IS(1))*yk(1,nx+1:nx+nz))
- ENDDO
-C SIG = R*R'
- DO K=1,inx
- SIG(K,K) = SUM(R(IYK(1,K),1:nu,IS(6))
- # * R(IYK(1,K),1:nu,IS(6)))
- DO J=1,K-1
- SIG(K,J) = SUM(R(IYK(1,K),1:nu,IS(6))
- # * R(IYK(1,J),1:nu,IS(6)))
- SIG(J,K) = SIG(K,J)
- ENDDO
- ENDDO
- DO I = 1,nk
- gam(I) = PE(I)*mvnpdf(yk(1,IYK(1,1:inx)),mu(1:inx),
- # SIG(1:inx,1:inx),inx)
- ENDDO
- LLIKE(1) = dlog(sum(gam(1:nk)))
- FILT(1,1:nk-1) = gam(1:nk-1)/sum(gam(1:nk))
- FILT(1,nk) = 1.D0-sum(FILT(1,1:nk-1))
-
-C ----------------------------------------------------------
-C Filtering Z(t|t)=P*Z(t-1|t-1) (.*) F(j) / SUM of numerator
-C ----------------------------------------------------------
- DO 100 inobs = 2,nobs
- inx = IYK(inobs,nx+1)
- DO I =1,nk
- CALL int2seq(I,nv,INFOS,SEQ,IS)
- ZZ(I) = SUM(P(I,1:nk)*FILT(inobs-1,1:nk))
-c y(t) = c(t)z(t) + x(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
- DO J = 1,inx
- mu(J) = a(IYK(inobs,J),IS(4))+
- # + SUM(F(IYK(inobs,J),IYK(inobs,1:inx),IS(5))
- # * yk(inobs-1,IYK(inobs-1,1:inx)))
- # + SUM(c(IYK(inobs,J),1:nz,IS(1))*yk(inobs,nx+1:nx+nz))
- ENDDO
-C SIG = R*R'
- DO K=1,inx
- SIG(K,K) = SUM(R(IYK(inobs,K),1:nu,IS(6))
- # * R(IYK(inobs,K),1:nu,IS(6)))
- DO J=1,K-1
- SIG(K,J) = SUM(R(IYK(inobs,K),1:nu,IS(6))
- # * R(IYK(inobs,J),1:nu,IS(6)))
- SIG(J,K) = SIG(K,J)
- ENDDO
- ENDDO
- gam(I) = logmvnpdf(yk(inobs,IYK(inobs,1:inx)),mu(1:inx),
- # SIG(1:inx,1:inx),inx) ! log
- ENDDO
-C ---------------------------------------------------
-C Compute the log-likelihood and Normalise the filter
-C ---------------------------------------------------
- IMAX = MAXLOC(gam(1:nk))
- Lmax = gam(IMAX(1))
- gam(:) = dexp(gam(:)-Lmax)
- FILT(inobs,1:nk) = ZZ(1:nk)*gam(1:nk)
- norm = SUM(FILT(inobs,:))
- FILT(inobs,:) = FILT(inobs,:)/norm
- LLIKE(inobs) = DLOG(norm) + Lmax
-100 CONTINUE
-
-C ------------------------------------------------------------------------------------
-C Hamilton smoother for a MS-VAR(1)
-C Z(t|T): Hamilton (94), pp 694
-C Innovations:
-C INN(t) = y(y)-SUM(S(t),S(t-1)) P(S(t)|S(t-1)*P(S(t-1)|x^(t-1))*E(x(t)|S(t),x^(t-1))
-C ------------------------------------------------------------------------------------
- IF (ismoo.EQ.1) THEN
- SSMOOTH(nobs,:) = FILT(nobs,:)
- DO inobs = nobs-1,1,-1
- DO J=1,nk
- gam(J) = SUM(P(J,1:nk)*FILT(inobs,1:nk))
- ENDDO
- DO J=1,nk
- ZZ(J) = 1.D0
- IF (gam(J).GT.1.D-13) ZZ(J) = SSMOOTH(inobs+1,J)/gam(J)
- ENDDO
- DO J=1,nk
- gam(J) = SUM(P(1:nk,J)*ZZ(1:nk))
- ENDDO
- SSMOOTH(inobs,1:nk) = FILT(inobs,1:nk)*gam(1:nk)
- ENDDO
- INN(:,:) = 0.D0
- DO inobs = 2,nobs
- inx = IYK(inobs,nx+1)
- DO I=1,nk
- CALL int2seq(I,nv,INFOS,SEQ,IS)
- DO K = 1,inx
- mu(K) = a(IYK(inobs,K),IS(4))+
- # + SUM(F(IYK(inobs,K),IYK(inobs,1:inx),IS(5))
- # * yk(inobs-1,IYK(inobs-1,1:inx)))
- # + SUM(c(IYK(inobs,K),1:nz,IS(1))*yk(inobs,nx+1:nx+nz))
- ENDDO
- DO J=1,nk
- INN(inobs,IYK(inobs,1:inx)) = INN(inobs,IYK(inobs,1:inx))
- 1 + mu(1:inx)*P(I,J)*FILT(inobs-1,J)
- ENDDO
- ENDDO
- INN(inobs,IYK(inobs,1:inx)) = yk(inobs,IYK(inobs,1:inx))
- 1 - INN(inobs,IYK(inobs,1:inx))
- ENDDO
- ENDIF
-
- DEALLOCATE(gam,mu,SIG)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ SUBROUTINE HF(nobs,nx,nk,nz,nu,ns,nv,np,psi,ismoo,yk,IYK,INFOS,
+ 1 c,a,F,R,SSMOOTH,INN,LLIKE)
+
+C INPUT
+ INTEGER nobs,nx,nk,nz,nu,nv,np,ns(6),ismoo,IYK(nobs,nx+1),INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,nx+nz),c(nx,max(1,nz),ns(1)),
+ 1 a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),psi(max(1,np))
+
+C OUTPUT
+ DOUBLE PRECISION SSMOOTH(nobs,nk),INN(nobs,nx),LLIKE(nobs)
+
+C LOCALS
+ INTEGER inobs,inx,I,J,K,IMAX(1),IS(6),SEQ(1)
+ DOUBLE PRECISION,ALLOCATABLE:: ZZ(:),gam(:),mu(:),SIG(:,:),FILT(:,:),
+ 1 P(:,:),PE(:),PP1(:,:),PP2(:,:),PP3(:,:),PP4(:,:),PP5(:,:),
+ 1 PP6(:,:)
+
+ DOUBLE PRECISION logmvnpdf,mvnpdf,norm,Lmax
+ ALLOCATE(PP1(INFOS(8,1),INFOS(8,1)),PP2(INFOS(8,2),INFOS(8,2)),
+ 1 PP3(INFOS(8,3),INFOS(8,3)),PP4(INFOS(8,4),INFOS(8,4)),
+ 1 PP5(INFOS(8,5),INFOS(8,5)),PP6(INFOS(8,6),INFOS(8,6)))
+ ALLOCATE(ZZ(nk),gam(nk),mu(nx),SIG(nx,nx),FILT(nobs,nk),
+ 1 P(nk,nk),PE(nk))
+
+ FILT(:,:) = 0.D0
+ LLIKE(:) = 0.D0
+ CALL designz(nv,np,psi,INFOS,PP1,PP2,PP3,PP4,PP5,PP6)
+ CALL pprod(nv,nk,INFOS,PP1,PP2,PP3,PP4,PP5,PP6,P)
+C Initial condition (stationary MS-VAR(1))
+ CALL ergodic(nk,P,PE)
+ inx = IYK(1,nx+1)
+ DO J = 1,inx
+ mu(J) = a(IYK(1,J),IS(4))+
+ # + SUM(F(IYK(1,J),IYK(1,1:inx),IS(5))
+ # * yk(1,IYK(1,1:inx)))
+ # + SUM(c(IYK(1,J),1:nz,IS(1))*yk(1,nx+1:nx+nz))
+ ENDDO
+C SIG = R*R'
+ DO K=1,inx
+ SIG(K,K) = SUM(R(IYK(1,K),1:nu,IS(6))
+ # * R(IYK(1,K),1:nu,IS(6)))
+ DO J=1,K-1
+ SIG(K,J) = SUM(R(IYK(1,K),1:nu,IS(6))
+ # * R(IYK(1,J),1:nu,IS(6)))
+ SIG(J,K) = SIG(K,J)
+ ENDDO
+ ENDDO
+ DO I = 1,nk
+ gam(I) = PE(I)*mvnpdf(yk(1,IYK(1,1:inx)),mu(1:inx),
+ # SIG(1:inx,1:inx),inx)
+ ENDDO
+ LLIKE(1) = dlog(sum(gam(1:nk)))
+ FILT(1,1:nk-1) = gam(1:nk-1)/sum(gam(1:nk))
+ FILT(1,nk) = 1.D0-sum(FILT(1,1:nk-1))
+
+C ----------------------------------------------------------
+C Filtering Z(t|t)=P*Z(t-1|t-1) (.*) F(j) / SUM of numerator
+C ----------------------------------------------------------
+ DO 100 inobs = 2,nobs
+ inx = IYK(inobs,nx+1)
+ DO I =1,nk
+ CALL int2seq(I,nv,INFOS,SEQ,IS)
+ ZZ(I) = SUM(P(I,1:nk)*FILT(inobs-1,1:nk))
+c y(t) = c(t)z(t) + x(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+ DO J = 1,inx
+ mu(J) = a(IYK(inobs,J),IS(4))+
+ # + SUM(F(IYK(inobs,J),IYK(inobs,1:inx),IS(5))
+ # * yk(inobs-1,IYK(inobs-1,1:inx)))
+ # + SUM(c(IYK(inobs,J),1:nz,IS(1))*yk(inobs,nx+1:nx+nz))
+ ENDDO
+C SIG = R*R'
+ DO K=1,inx
+ SIG(K,K) = SUM(R(IYK(inobs,K),1:nu,IS(6))
+ # * R(IYK(inobs,K),1:nu,IS(6)))
+ DO J=1,K-1
+ SIG(K,J) = SUM(R(IYK(inobs,K),1:nu,IS(6))
+ # * R(IYK(inobs,J),1:nu,IS(6)))
+ SIG(J,K) = SIG(K,J)
+ ENDDO
+ ENDDO
+ gam(I) = logmvnpdf(yk(inobs,IYK(inobs,1:inx)),mu(1:inx),
+ # SIG(1:inx,1:inx),inx) ! log
+ ENDDO
+C ---------------------------------------------------
+C Compute the log-likelihood and Normalise the filter
+C ---------------------------------------------------
+ IMAX = MAXLOC(gam(1:nk))
+ Lmax = gam(IMAX(1))
+ gam(:) = dexp(gam(:)-Lmax)
+ FILT(inobs,1:nk) = ZZ(1:nk)*gam(1:nk)
+ norm = SUM(FILT(inobs,:))
+ FILT(inobs,:) = FILT(inobs,:)/norm
+ LLIKE(inobs) = DLOG(norm) + Lmax
+100 CONTINUE
+
+C ------------------------------------------------------------------------------------
+C Hamilton smoother for a MS-VAR(1)
+C Z(t|T): Hamilton (94), pp 694
+C Innovations:
+C INN(t) = y(y)-SUM(S(t),S(t-1)) P(S(t)|S(t-1)*P(S(t-1)|x^(t-1))*E(x(t)|S(t),x^(t-1))
+C ------------------------------------------------------------------------------------
+ IF (ismoo.EQ.1) THEN
+ SSMOOTH(nobs,:) = FILT(nobs,:)
+ DO inobs = nobs-1,1,-1
+ DO J=1,nk
+ gam(J) = SUM(P(J,1:nk)*FILT(inobs,1:nk))
+ ENDDO
+ DO J=1,nk
+ ZZ(J) = 1.D0
+ IF (gam(J).GT.1.D-13) ZZ(J) = SSMOOTH(inobs+1,J)/gam(J)
+ ENDDO
+ DO J=1,nk
+ gam(J) = SUM(P(1:nk,J)*ZZ(1:nk))
+ ENDDO
+ SSMOOTH(inobs,1:nk) = FILT(inobs,1:nk)*gam(1:nk)
+ ENDDO
+ INN(:,:) = 0.D0
+ DO inobs = 2,nobs
+ inx = IYK(inobs,nx+1)
+ DO I=1,nk
+ CALL int2seq(I,nv,INFOS,SEQ,IS)
+ DO K = 1,inx
+ mu(K) = a(IYK(inobs,K),IS(4))+
+ # + SUM(F(IYK(inobs,K),IYK(inobs,1:inx),IS(5))
+ # * yk(inobs-1,IYK(inobs-1,1:inx)))
+ # + SUM(c(IYK(inobs,K),1:nz,IS(1))*yk(inobs,nx+1:nx+nz))
+ ENDDO
+ DO J=1,nk
+ INN(inobs,IYK(inobs,1:inx)) = INN(inobs,IYK(inobs,1:inx))
+ 1 + mu(1:inx)*P(I,J)*FILT(inobs-1,J)
+ ENDDO
+ ENDDO
+ INN(inobs,IYK(inobs,1:inx)) = yk(inobs,IYK(inobs,1:inx))
+ 1 - INN(inobs,IYK(inobs,1:inx))
+ ENDDO
+ ENDIF
+
+ DEALLOCATE(gam,mu,SIG)
+ RETURN
END
diff --git a/ikf.for b/ikf.for
index b5af0a3307f9b96a664024ec950f1a9af751be21..36b1f3e02aa362a919ab9c1599727e8d092f7b19 100644
--- a/ikf.for
+++ b/ikf.for
@@ -1,39 +1,39 @@
-C --------------------------------------------------------------------
-C IKF COMPUTES INITIAL VALUES FOR THE KALMAN RECURSIONS FOR STATIONARY
-C AND NON-STATIONARY TIME SERIES MODELS.
-C Stationary: Unconditional mean and variance of x1 as in
-C A.C.Harvey 1989,"Forecasting strucural time series
-C models and the Kalman filter", p.121
-C
-C Non-stationary: Filtered state estimates and covaiance matrices
-C as in S.J.Koopman (1997), "Exact initial Kalman
-C Filtering and Smoothing for non-statonary Time
-C Series models", JASA, 92, pp.1630-38
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C IKF COMPUTES INITIAL VALUES FOR THE KALMAN RECURSIONS FOR STATIONARY
+C AND NON-STATIONARY TIME SERIES MODELS.
+C Stationary: Unconditional mean and variance of x1 as in
+C A.C.Harvey 1989,"Forecasting strucural time series
+C models and the Kalman filter", p.121
+C
+C Non-stationary: Filtered state estimates and covaiance matrices
+C as in S.J.Koopman (1997), "Exact initial Kalman
+C Filtering and Smoothing for non-statonary Time
+C Series models", JASA, 92, pp.1630-38
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -44,291 +44,291 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE IKF(d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,
- 1 Xdd,Pdd,LIKE)
-C INPUT
- INTEGER d(2),ny,nz,nx,nu,ns(6),S(MAX(d(1),1),6),
- 1 IYK(max(d(1),1),ny+1)
- DOUBLE PRECISION yk(MAX(d(1),1),ny+nz),c(ny,max(1,nz),ns(1)),
- 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 R(nx,nu,ns(6))
-C OUTPUT
- DOUBLE PRECISION Pdd(MAX(d(1),1),nx,nx),Xdd(MAX(d(1),1),nx),
- 1 LIKE(MAX(d(1),1))
-C LOCALS
- INTEGER I,J,IFAIL,imain,iny,FiRANK
- INTEGER IPIV(nx)
- DOUBLE PRECISION aa(nx),Ps(nx,nx),Pi(nx,nx)
- DOUBLE PRECISION HPs(ny,nx),HPi(ny,nx),
- 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
- 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ci(nx,nx)
- DOUBLE PRECISION W1(ny),WORK(64*nx),WORK1(64*ny),
- 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny)
- DOUBLE PRECISION ONE,ZERO,DETV,RSS,SUMW1
- DATA ONE/1.0D0/,ZERO/0.0D0/
-
-C Unconditional mean and variance
- LIKE(:) = ZERO
- IF (d(1).EQ.0) THEN ! stationary models
- IF(SUM(ABS(a(:,S(1,4)))).EQ.ZERO) THEN
- Xdd(1,:) = ZERO
- ELSE
- APPO = -F(:,:,S(1,5))
- DO 1 I = 1,nx
-1 APPO(I,I) = 1.D0+APPO(I,I)
- IFAIL = -1
-C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
-C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
- CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
- CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
- DO 3 I =1,nx
-3 Xdd(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
- ENDIF
-
-C Pdd - F*Pdd*F' = R*R'
- CALL LYAP(nx,nu,1.D-3,F(:,:,S(1,5)),R(:,:,S(1,6)),Pdd)
- ELSE
-C -----------------------------------------------------------
-C Non-stationary models
-C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
-C eta~N(0,I), delta~N(0,k*I) k -> +inf
-C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
-C -----------------------------------------------------------
- aa(1:nx) = ZERO
- Ps(1:nx,1:nx) = ZERO
- IF (d(2).LT.nx) THEN
- IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
- APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
- DO 5 I = d(2)+1,nx
-5 APPO(I,I) = 1.D0+APPO(I,I)
-C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),IFAIL)
-C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
- CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),IFAIL)
- CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
- DO 6 I = d(2)+1,nx
-6 aa(I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
- ENDIF
-
-C Lyapunov eqn
- CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
- 1 R(d(2)+1:nx,1:nu,S(1,6)),Ps(d(2)+1:nx,d(2)+1:nx))
-
- ENDIF
-
- Pi(1:nx,1:nx) = ZERO
- DO 10 I = 1,d(2)
-10 Pi(I,I) = ONE
-
- Xdd(:,:) = ZERO
- Pdd(:,:,:) = ZERO
- DO 1000 imain = 1,d(1)
- iny = IYK(imain,ny+1)
- DO 30 I=1,iny
- DO 30 J=1,nx
-30 HPs(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*Ps(:,J))
-
- DO 40 I=1,iny
- Fs(I,I) = SUM(HPs(I,:)*H(IYK(imain,I),:,S(imain,2)))+
- + SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,I),:,S(imain,3)))
- DO 40 J=1,I-1
- Fs(I,J) = SUM(HPs(I,:)*H(IYK(imain,J),:,S(imain,2)))+
- + SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,J),:,S(imain,3)))
-40 Fs(J,I) = Fs(I,J)
-
- DO 50 I=1,iny
- DO 50 J=1,nx
-50 HPi(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*Pi(:,J))
-
- DO 60 I=1,iny
- Fi(I,I) = SUM(HPi(I,:)*H(IYK(imain,I),:,S(imain,2)))
- DO 60 J=1,I-1
- Fi(I,J) = SUM(HPi(I,:)*H(IYK(imain,J),:,S(imain,2)))
-60 Fi(J,I) = Fi(I,J)
-
-C --------------------------------------------------------------------------
-C Computes inverse of the innovation variance matrix
-C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
-C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
-C --------------------------------------------------------------------------
- IF (iny.EQ.1) THEN
- Fsm = ZERO
- Fim = 1.D0/Fi
- FFF = Fim*Fs*Fim
- ELSE
-
- IFAIL = -1
- COM(1:iny,1:iny) = Fi(1:iny,1:iny)
-C CALL F02FAF('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),
-C 1 WORK1,64*ny,IFAIL)
- CALL DSYEV('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),WORK1,
- 1 64*ny,IFAIL)
- FiRANK = 0
- SUMW1 = SUM(ABS(W1(1:iny)))
- DO 70 I=1,iny
- W1(I) = W1(I)/SUMW1
-70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
- FiRANK = min(FiRANK,d(2))
-
- IF(FiRANK.EQ.iny) THEN
- Fsm = ZERO
- COM(1:iny,1:iny) = Fi(1:iny,1:iny)
- IFAIL = -1
-C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
-
- DO 80 I=1,iny
- Fim(I,I) = COM(I,I)
- DO 80 J=1,I-1
- Fim(I,J) = COM(I,J)
-80 Fim(J,I) = Fim(I,J)
-
- DO 81 I=1,iny
- DO 81 J=1,iny
-81 COM(I,J) = SUM(Fim(I,1:iny)*Fs(1:iny,J)) ! Fim x Fs
-
- DO 82 I=1,iny
- FFF(I,I) = SUM(COM(I,1:iny)*Fim(1:iny,I))
- DO 82 J=1,I-1
- FFF(I,J) = SUM(COM(I,1:iny)*Fim(1:iny,J)) ! Fim x Fs x Fim
-82 FFF(J,I) = FFF(I,J)
-
- ELSE
- SUMW1=0.D0
- DO I=Firank+1,iny
- SUMW1 = SUMW1 + Fi(I,I)
- ENDDO
- IF (SUMW1.GT.0.D0) THEN
- CALL INVFBIS(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
- 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
- ELSE
- CALL INVF(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
- 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
- ENDIF
- ENDIF
- ENDIF
-C ------------------------------------------------------------------
-C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
-C ------------------------------------------------------------------
- DO 85 I = 1,nx
- DO 85 J = 1,iny
- RG(I,J) =
- # SUM(R(I,1:nu,S(imain,6))*G(IYK(imain,J),1:nu,S(imain,3)))
-85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
-
- DO 90 I = 1,nx
- DO 90 J = 1,iny
- PHFs(I,J) = SUM(HPs(1:iny,I)*Fsm(1:iny,J))
-90 PHFi(I,J) = SUM(HPi(1:iny,I)*Fim(1:iny,J))
-
-C Innovations
- DO 100 I=1,iny
-100 COM(I,1) = yk(imain,IYK(imain,I))
- + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*aa(1:nx))
- + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
- DO 110 I=1,nx
-110 Xdd(imain,I) = aa(I)
- + + SUM((PHFs(I,1:iny)+PHFi(I,1:iny))*COM(1:iny,1))
-
-C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
-C - Ps*H'*Fsm*H*Ps
- DO 120 I = 1,nx
- APPO(I,I) = -SUM(PHFs(I,1:iny)*HPs(1:iny,I))
- DO 120 J = 1,I-1
- APPO(I,J) = -SUM(PHFs(I,1:iny)*HPs(1:iny,J))
-120 APPO(J,I) = APPO(I,J)
-
-C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
- DO 130 I = 1,nx
- APPO(I,I) = APPO(I,I) - SUM(HPs(1:iny,I)*PHFi(I,1:iny))
- + - SUM(PHFi(I,1:iny)*HPs(1:iny,I))
- DO 130 J = 1,I-1
- APPO(I,J) = APPO(I,J) - SUM(HPs(1:iny,I)*PHFi(J,1:iny))
- + - SUM(PHFi(I,1:iny)*HPs(1:iny,J))
-130 APPO(J,I) = APPO(I,J)
-
-C Pi*H'*Fim*Fs*Fim*H*Pi
- DO 140 I = 1,nx
- DO 140 J = 1,iny
-140 APPO1(I,J) = SUM(HPi(1:iny,I)*FFF(1:iny,J))
-
- DO 150 I = 1,nx
- PFP(I,I) = SUM(APPO1(I,1:iny)*HPi(1:iny,I))
- DO 150 J = 1,I-1
- PFP(I,J) = SUM(APPO1(I,1:iny)*HPi(1:iny,J))
-150 PFP(J,I) = PFP(I,J)
-
- Pdd(imain,:,:) = Ps(:,:) + PFP(:,:) + APPO(:,:)
-
-C ----------------------------------------------
-C CONTRIBUTE TO THE LIKELIHOOD 1ST d INNOVATIONS
-C ----------------------------------------------
- IFAIL = -1
-C CALL F03ABF(Fsm(1:iny,1:iny)+Fim(1:iny,1:iny),iny,iny,
-C 1 DETV,WORK1(1:iny),IFAIL)
- FFF(1:iny,1:iny) = Fsm(1:iny,1:iny)+Fim(1:iny,1:iny)
- CALL DPOTRF('L',iny,FFF(1:iny,1:iny),iny,IFAIL) ! FFF = L*L'
- DETV = 1.D0
- RSS = ZERO
- DO 155 I=1,iny
- DETV = DETV*FFF(I,I)
- DO 155 J=1,iny
-155 RSS = RSS + COM(I,1)*Fsm(I,J)*COM(J,1)
-
- LIKE(imain) = -.5D0*(RSS - 2.D0*DLOG(DETV))
- IF (LIKE(imain).NE.0.D0) THEN
- LIKE(imain)=LIKE(imain)-iny/2.D0*DLOG(2.*3.141592653589793D0)
- ENDIF
-C ----------------------------------
-C Predictions X(d+1|d) and P(d+1|d)
-C ----------------------------------
- IF (imain.LT.d(1)) THEN
-C aa = a + F*Xdd
- DO 160 I=1,nx
-160 aa(I) = a(I,S(imain+1,4))+SUM(F(I,:,S(imain+1,5))*Xdd(imain,:))
-
-C Pi = F*Pi*F'-Ci
-C Ps = F*PddF'+R*R'
- DO 170 I = 1,nx
- DO 170 J = 1,nx
- PFP(I,J) = SUM(F(I,:,S(imain+1,5))*Pi(:,J)) ! F*Pi
-170 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*Pdd(imain,:,J)) ! F*Pdd
-
-C Mi = F*Pi*H' ! H to be checked
- DO 172 I = 1,nx
- DO 172 J = 1,iny
-172 Mi(I,J) = SUM(PFP(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))!S(+1,..) before
-
-C Ci = Mi*Fim*Mi'
- DO 174 I = 1,nx
- DO 174 J = 1,iny
-174 RG(I,J) = SUM(Mi(I,1:iny)*Fim(1:iny,J)) ! Mi*Fim
-
- DO 176 I = 1,nx
- Ci(I,I) = SUM(RG(I,1:iny)*Mi(I,1:iny))
- DO 176 J = 1,I-1
-176 Ci(I,J) = SUM(RG(I,1:iny)*Mi(J,1:iny))
-
- DO 180 I = 1,nx
- Pi(I,I) = SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
- Ps(I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
- DO 180 J = 1,I-1
- Pi(I,J) = SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
- Ps(I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
- Pi(J,I) = Pi(I,J)
-180 Ps(J,I) = Ps(I,J)
-
- ENDIF
-1000 CONTINUE
- ENDIF
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE IKF(d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,
+ 1 Xdd,Pdd,LIKE)
+C INPUT
+ INTEGER d(2),ny,nz,nx,nu,ns(6),S(MAX(d(1),1),6),
+ 1 IYK(max(d(1),1),ny+1)
+ DOUBLE PRECISION yk(MAX(d(1),1),ny+nz),c(ny,max(1,nz),ns(1)),
+ 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 R(nx,nu,ns(6))
+C OUTPUT
+ DOUBLE PRECISION Pdd(MAX(d(1),1),nx,nx),Xdd(MAX(d(1),1),nx),
+ 1 LIKE(MAX(d(1),1))
+C LOCALS
+ INTEGER I,J,IFAIL,imain,iny,FiRANK
+ INTEGER IPIV(nx)
+ DOUBLE PRECISION aa(nx),Ps(nx,nx),Pi(nx,nx)
+ DOUBLE PRECISION HPs(ny,nx),HPi(ny,nx),
+ 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
+ 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ci(nx,nx)
+ DOUBLE PRECISION W1(ny),WORK(64*nx),WORK1(64*ny),
+ 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny)
+ DOUBLE PRECISION ONE,ZERO,DETV,RSS,SUMW1
+ DATA ONE/1.0D0/,ZERO/0.0D0/
+
+C Unconditional mean and variance
+ LIKE(:) = ZERO
+ IF (d(1).EQ.0) THEN ! stationary models
+ IF(SUM(ABS(a(:,S(1,4)))).EQ.ZERO) THEN
+ Xdd(1,:) = ZERO
+ ELSE
+ APPO = -F(:,:,S(1,5))
+ DO 1 I = 1,nx
+1 APPO(I,I) = 1.D0+APPO(I,I)
+ IFAIL = -1
+C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
+C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+ CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
+ CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+ DO 3 I =1,nx
+3 Xdd(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
+ ENDIF
+
+C Pdd - F*Pdd*F' = R*R'
+ CALL LYAP(nx,nu,1.D-3,F(:,:,S(1,5)),R(:,:,S(1,6)),Pdd)
+ ELSE
+C -----------------------------------------------------------
+C Non-stationary models
+C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
+C eta~N(0,I), delta~N(0,k*I) k -> +inf
+C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
+C -----------------------------------------------------------
+ aa(1:nx) = ZERO
+ Ps(1:nx,1:nx) = ZERO
+ IF (d(2).LT.nx) THEN
+ IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
+ APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
+ DO 5 I = d(2)+1,nx
+5 APPO(I,I) = 1.D0+APPO(I,I)
+C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),IFAIL)
+C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+ CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),IFAIL)
+ CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+ DO 6 I = d(2)+1,nx
+6 aa(I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
+ ENDIF
+
+C Lyapunov eqn
+ CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
+ 1 R(d(2)+1:nx,1:nu,S(1,6)),Ps(d(2)+1:nx,d(2)+1:nx))
+
+ ENDIF
+
+ Pi(1:nx,1:nx) = ZERO
+ DO 10 I = 1,d(2)
+10 Pi(I,I) = ONE
+
+ Xdd(:,:) = ZERO
+ Pdd(:,:,:) = ZERO
+ DO 1000 imain = 1,d(1)
+ iny = IYK(imain,ny+1)
+ DO 30 I=1,iny
+ DO 30 J=1,nx
+30 HPs(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*Ps(:,J))
+
+ DO 40 I=1,iny
+ Fs(I,I) = SUM(HPs(I,:)*H(IYK(imain,I),:,S(imain,2)))+
+ + SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,I),:,S(imain,3)))
+ DO 40 J=1,I-1
+ Fs(I,J) = SUM(HPs(I,:)*H(IYK(imain,J),:,S(imain,2)))+
+ + SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,J),:,S(imain,3)))
+40 Fs(J,I) = Fs(I,J)
+
+ DO 50 I=1,iny
+ DO 50 J=1,nx
+50 HPi(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*Pi(:,J))
+
+ DO 60 I=1,iny
+ Fi(I,I) = SUM(HPi(I,:)*H(IYK(imain,I),:,S(imain,2)))
+ DO 60 J=1,I-1
+ Fi(I,J) = SUM(HPi(I,:)*H(IYK(imain,J),:,S(imain,2)))
+60 Fi(J,I) = Fi(I,J)
+
+C --------------------------------------------------------------------------
+C Computes inverse of the innovation variance matrix
+C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
+C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
+C --------------------------------------------------------------------------
+ IF (iny.EQ.1) THEN
+ Fsm = ZERO
+ Fim = 1.D0/Fi
+ FFF = Fim*Fs*Fim
+ ELSE
+
+ IFAIL = -1
+ COM(1:iny,1:iny) = Fi(1:iny,1:iny)
+C CALL F02FAF('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),
+C 1 WORK1,64*ny,IFAIL)
+ CALL DSYEV('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),WORK1,
+ 1 64*ny,IFAIL)
+ FiRANK = 0
+ SUMW1 = SUM(ABS(W1(1:iny)))
+ DO 70 I=1,iny
+ W1(I) = W1(I)/SUMW1
+70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
+ FiRANK = min(FiRANK,d(2))
+
+ IF(FiRANK.EQ.iny) THEN
+ Fsm = ZERO
+ COM(1:iny,1:iny) = Fi(1:iny,1:iny)
+ IFAIL = -1
+C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
+
+ DO 80 I=1,iny
+ Fim(I,I) = COM(I,I)
+ DO 80 J=1,I-1
+ Fim(I,J) = COM(I,J)
+80 Fim(J,I) = Fim(I,J)
+
+ DO 81 I=1,iny
+ DO 81 J=1,iny
+81 COM(I,J) = SUM(Fim(I,1:iny)*Fs(1:iny,J)) ! Fim x Fs
+
+ DO 82 I=1,iny
+ FFF(I,I) = SUM(COM(I,1:iny)*Fim(1:iny,I))
+ DO 82 J=1,I-1
+ FFF(I,J) = SUM(COM(I,1:iny)*Fim(1:iny,J)) ! Fim x Fs x Fim
+82 FFF(J,I) = FFF(I,J)
+
+ ELSE
+ SUMW1=0.D0
+ DO I=Firank+1,iny
+ SUMW1 = SUMW1 + Fi(I,I)
+ ENDDO
+ IF (SUMW1.GT.0.D0) THEN
+ CALL INVFBIS(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
+ 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
+ ELSE
+ CALL INVF(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
+ 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
+ ENDIF
+ ENDIF
+ ENDIF
+C ------------------------------------------------------------------
+C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
+C ------------------------------------------------------------------
+ DO 85 I = 1,nx
+ DO 85 J = 1,iny
+ RG(I,J) =
+ # SUM(R(I,1:nu,S(imain,6))*G(IYK(imain,J),1:nu,S(imain,3)))
+85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
+
+ DO 90 I = 1,nx
+ DO 90 J = 1,iny
+ PHFs(I,J) = SUM(HPs(1:iny,I)*Fsm(1:iny,J))
+90 PHFi(I,J) = SUM(HPi(1:iny,I)*Fim(1:iny,J))
+
+C Innovations
+ DO 100 I=1,iny
+100 COM(I,1) = yk(imain,IYK(imain,I))
+ + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*aa(1:nx))
+ + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+ DO 110 I=1,nx
+110 Xdd(imain,I) = aa(I)
+ + + SUM((PHFs(I,1:iny)+PHFi(I,1:iny))*COM(1:iny,1))
+
+C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+C - Ps*H'*Fsm*H*Ps
+ DO 120 I = 1,nx
+ APPO(I,I) = -SUM(PHFs(I,1:iny)*HPs(1:iny,I))
+ DO 120 J = 1,I-1
+ APPO(I,J) = -SUM(PHFs(I,1:iny)*HPs(1:iny,J))
+120 APPO(J,I) = APPO(I,J)
+
+C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+ DO 130 I = 1,nx
+ APPO(I,I) = APPO(I,I) - SUM(HPs(1:iny,I)*PHFi(I,1:iny))
+ + - SUM(PHFi(I,1:iny)*HPs(1:iny,I))
+ DO 130 J = 1,I-1
+ APPO(I,J) = APPO(I,J) - SUM(HPs(1:iny,I)*PHFi(J,1:iny))
+ + - SUM(PHFi(I,1:iny)*HPs(1:iny,J))
+130 APPO(J,I) = APPO(I,J)
+
+C Pi*H'*Fim*Fs*Fim*H*Pi
+ DO 140 I = 1,nx
+ DO 140 J = 1,iny
+140 APPO1(I,J) = SUM(HPi(1:iny,I)*FFF(1:iny,J))
+
+ DO 150 I = 1,nx
+ PFP(I,I) = SUM(APPO1(I,1:iny)*HPi(1:iny,I))
+ DO 150 J = 1,I-1
+ PFP(I,J) = SUM(APPO1(I,1:iny)*HPi(1:iny,J))
+150 PFP(J,I) = PFP(I,J)
+
+ Pdd(imain,:,:) = Ps(:,:) + PFP(:,:) + APPO(:,:)
+
+C ----------------------------------------------
+C CONTRIBUTE TO THE LIKELIHOOD 1ST d INNOVATIONS
+C ----------------------------------------------
+ IFAIL = -1
+C CALL F03ABF(Fsm(1:iny,1:iny)+Fim(1:iny,1:iny),iny,iny,
+C 1 DETV,WORK1(1:iny),IFAIL)
+ FFF(1:iny,1:iny) = Fsm(1:iny,1:iny)+Fim(1:iny,1:iny)
+ CALL DPOTRF('L',iny,FFF(1:iny,1:iny),iny,IFAIL) ! FFF = L*L'
+ DETV = 1.D0
+ RSS = ZERO
+ DO 155 I=1,iny
+ DETV = DETV*FFF(I,I)
+ DO 155 J=1,iny
+155 RSS = RSS + COM(I,1)*Fsm(I,J)*COM(J,1)
+
+ LIKE(imain) = -.5D0*(RSS - 2.D0*DLOG(DETV))
+ IF (LIKE(imain).NE.0.D0) THEN
+ LIKE(imain)=LIKE(imain)-iny/2.D0*DLOG(2.*3.141592653589793D0)
+ ENDIF
+C ----------------------------------
+C Predictions X(d+1|d) and P(d+1|d)
+C ----------------------------------
+ IF (imain.LT.d(1)) THEN
+C aa = a + F*Xdd
+ DO 160 I=1,nx
+160 aa(I) = a(I,S(imain+1,4))+SUM(F(I,:,S(imain+1,5))*Xdd(imain,:))
+
+C Pi = F*Pi*F'-Ci
+C Ps = F*PddF'+R*R'
+ DO 170 I = 1,nx
+ DO 170 J = 1,nx
+ PFP(I,J) = SUM(F(I,:,S(imain+1,5))*Pi(:,J)) ! F*Pi
+170 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*Pdd(imain,:,J)) ! F*Pdd
+
+C Mi = F*Pi*H' ! H to be checked
+ DO 172 I = 1,nx
+ DO 172 J = 1,iny
+172 Mi(I,J) = SUM(PFP(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))!S(+1,..) before
+
+C Ci = Mi*Fim*Mi'
+ DO 174 I = 1,nx
+ DO 174 J = 1,iny
+174 RG(I,J) = SUM(Mi(I,1:iny)*Fim(1:iny,J)) ! Mi*Fim
+
+ DO 176 I = 1,nx
+ Ci(I,I) = SUM(RG(I,1:iny)*Mi(I,1:iny))
+ DO 176 J = 1,I-1
+176 Ci(I,J) = SUM(RG(I,1:iny)*Mi(J,1:iny))
+
+ DO 180 I = 1,nx
+ Pi(I,I) = SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
+ Ps(I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
+ DO 180 J = 1,I-1
+ Pi(I,J) = SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
+ Ps(I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
+ Pi(J,I) = Pi(I,J)
+180 Ps(J,I) = Ps(I,J)
+
+ ENDIF
+1000 CONTINUE
+ ENDIF
+ RETURN
END
diff --git a/ikf2.for b/ikf2.for
index 30cda8c965e238fcb9e5bd561e2c257d7c87e15a..0d6e83607df4d3b2c63799e025b0870e172d532e 100644
--- a/ikf2.for
+++ b/ikf2.for
@@ -1,39 +1,39 @@
-C -----------------C --------------------------------------------------------------------
-C IKF2 (no missing values) COMPUTES INITIAL VALUES FOR THE KALMAN RECURSIONS FOR STATIONARY
-C AND NON-STATIONARY TIME SERIES MODELS.
-C Stationary: Unconditional mean and variance of x1 as in
-C A.C.Harvey 1989,"Forecasting strucural time series
-C models and the Kalman filter", p.121
-C
-C Non-stationary: Filtered state estimates and covaiance matrices
-C as in S.J.Koopman (1997), "Exact initial Kalman
-C Filtering and Smoothing for non-statonary Time
-C Series models", JASA, 92, pp.1630-38
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -----------------C --------------------------------------------------------------------
+C IKF2 (no missing values) COMPUTES INITIAL VALUES FOR THE KALMAN RECURSIONS FOR STATIONARY
+C AND NON-STATIONARY TIME SERIES MODELS.
+C Stationary: Unconditional mean and variance of x1 as in
+C A.C.Harvey 1989,"Forecasting strucural time series
+C models and the Kalman filter", p.121
+C
+C Non-stationary: Filtered state estimates and covaiance matrices
+C as in S.J.Koopman (1997), "Exact initial Kalman
+C Filtering and Smoothing for non-statonary Time
+C Series models", JASA, 92, pp.1630-38
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -44,291 +44,291 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE IKF2(d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,
- 1 Xdd,Pdd,LIKE)
-C INPUT
- INTEGER d(2),ny,nz,nx,nu,ns(6),S(MAX(d(1),1),6)
- DOUBLE PRECISION yk(MAX(d(1),1),ny+nz),c(ny,max(1,nz),ns(1)),
- 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 R(nx,nu,ns(6))
-C OUTPUT
- DOUBLE PRECISION Pdd(MAX(d(1),1),nx,nx),Xdd(MAX(d(1),1),nx),
- 1 LIKE(MAX(d(1),1))
-C LOCALS
- INTEGER I,J,IFAIL,imain,FiRANK
- INTEGER IPIV(nx)
- DOUBLE PRECISION aa(nx),Ps(nx,nx),Pi(nx,nx)
- DOUBLE PRECISION HPs(ny,nx),HPi(ny,nx),
- 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
- 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ci(nx,nx)
- DOUBLE PRECISION W1(ny),WORK(64*nx),WORK1(64*ny),
- 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny)
- DOUBLE PRECISION ONE,ZERO,DETV,RSS,SUMW1
- DATA ONE/1.0D0/,ZERO/0.0D0/
-
-C Unconditional mean and variance
- LIKE(:) = ZERO
- IF (d(1).EQ.0) THEN ! stationary models
- IF(SUM(ABS(a(:,S(1,4)))).EQ.ZERO) THEN
- Xdd(1,:) = ZERO
- ELSE
- APPO = -F(:,:,S(1,5))
- DO 1 I = 1,nx
-1 APPO(I,I) = 1.D0+APPO(I,I)
- IFAIL = -1
-C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
-C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
- CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
- CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
- DO 3 I =1,nx
-3 Xdd(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
- ENDIF
-
-C Pdd - F*Pdd*F' = R*R'
- CALL LYAP(nx,nu,1.D-3,F(:,:,S(1,5)),R(:,:,S(1,6)),Pdd)
- ELSE
-C -----------------------------------------------------------
-C Non-stationary models
-C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
-C eta~N(0,I), delta~N(0,k*I) k -> +inf
-C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
-C -----------------------------------------------------------
- aa(1:nx) = ZERO
- Ps(1:nx,1:nx) = ZERO
- IF (d(2).LT.nx) THEN
- IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
- APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
- DO 5 I = d(2)+1,nx
-5 APPO(I,I) = 1.D0+APPO(I,I)
-C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),IFAIL)
-C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
- CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),IFAIL)
- CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
- DO 6 I = d(2)+1,nx
-6 aa(I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
- ENDIF
-
-C Lyapunov eqn
- CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
- 1 R(d(2)+1:nx,1:nu,S(1,6)),Ps(d(2)+1:nx,d(2)+1:nx))
-
- ENDIF
-
- Pi(1:nx,1:nx) = ZERO
- DO 10 I = 1,d(2)
-10 Pi(I,I) = ONE
-
- Xdd(:,:) = ZERO
- Pdd(:,:,:) = ZERO
- DO 1000 imain = 1,d(1)
- DO 30 I=1,ny
- DO 30 J=1,nx
-30 HPs(I,J) = SUM(H(I,:,S(imain,2))*Ps(:,J))
-
- DO 40 I=1,ny
- Fs(I,I) = SUM(HPs(I,:)*H(I,:,S(imain,2)))
- + +SUM(G(I,:,S(imain,3))*G(I,:,S(imain,3)))
- DO 40 J=1,I-1
- Fs(I,J) = SUM(HPs(I,:)*H(J,:,S(imain,2)))
- + +SUM(G(I,:,S(imain,3))*G(J,:,S(imain,3)))
-40 Fs(J,I) = Fs(I,J)
-
- DO 50 I=1,ny
- DO 50 J=1,nx
-50 HPi(I,J) = SUM(H(I,:,S(imain,2))*Pi(:,J))
-
- DO 60 I=1,ny
- Fi(I,I) = SUM(HPi(I,:)*H(I,:,S(imain,2)))
- DO 60 J=1,I-1
- Fi(I,J) = SUM(HPi(I,:)*H(J,:,S(imain,2)))
-60 Fi(J,I) = Fi(I,J)
-
-C --------------------------------------------------------------------------
-C Computes inverse of the innovation variance matrix
-C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
-C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
-C --------------------------------------------------------------------------
- IF (ny.EQ.1) THEN
- Fsm = ZERO
- Fim = 1.D0/Fi
- FFF = Fim*Fs*Fim
- ELSE
-
- IFAIL = -1
- COM(1:ny,1:ny) = Fi(1:ny,1:ny)
-C CALL F02FAF('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),WORK1,64*ny,IFAIL)
- CALL DSYEV('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),WORK1,
- 1 64*ny,IFAIL)
- FiRANK = 0
- SUMW1 = SUM(ABS(W1(1:ny)))
- DO 70 I=1,ny
- W1(I) = W1(I)/SUMW1
-70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
- FiRANK = min(FiRANK,d(2))
-
- IF(FiRANK.EQ.ny) THEN
- Fsm = ZERO
- COM(1:ny,1:ny) = Fi(1:ny,1:ny)
- IFAIL = -1
-C CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
- CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
-
- DO 80 I=1,ny
- Fim(I,I) = COM(I,I)
- DO 80 J=1,I-1
- Fim(I,J) = COM(I,J)
-80 Fim(J,I) = Fim(I,J)
-
- DO 81 I=1,ny
- DO 81 J=1,ny
-81 COM(I,J) = SUM(Fim(I,1:ny)*Fs(1:ny,J)) ! Fim x Fs
-
- DO 82 I=1,ny
- FFF(I,I) = SUM(COM(I,1:ny)*Fim(1:ny,I))
- DO 82 J=1,I-1
- FFF(I,J) = SUM(COM(I,1:ny)*Fim(1:ny,J)) ! Fim x Fs x Fim
-82 FFF(J,I) = FFF(I,J)
-
- ELSE
- SUMW1=0.D0
- DO I=Firank+1,ny
- SUMW1 = SUMW1 + Fi(I,I)
- ENDDO
- IF (SUMW1.GT.0.D0) THEN
- CALL INVFBIS(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
- 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
- ELSE
- CALL INVF(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
- 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
- ENDIF
- ENDIF
- ENDIF
-C ------------------------------------------------------------------
-C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
-C ------------------------------------------------------------------
- DO 85 I = 1,nx
- DO 85 J = 1,ny
- RG(I,J) =
- # SUM(R(I,1:nu,S(imain,6))*G(J,1:nu,S(imain,3)))
-85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
-
- DO 90 I = 1,nx
- DO 90 J = 1,ny
- PHFs(I,J) = SUM(HPs(1:ny,I)*Fsm(1:ny,J))
-90 PHFi(I,J) = SUM(HPi(1:ny,I)*Fim(1:ny,J))
-
-C Innovations
- DO 100 I=1,ny
-100 COM(I,1) = yk(imain,I)
- + - SUM(H(I,1:nx,S(imain,2))*aa(1:nx))
- + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
- DO 110 I=1,nx
-110 Xdd(imain,I) = aa(I)
- + + SUM((PHFs(I,1:ny)+PHFi(I,1:ny))*COM(1:ny,1))
-
-C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps
-C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
-
-C- Ps*H'*Fsm*H*Ps
- DO 120 I = 1,nx
- APPO(I,I) = -SUM(PHFs(I,1:ny)*HPs(1:ny,I))
- DO 120 J = 1,I-1
- APPO(I,J) = -SUM(PHFs(I,1:ny)*HPs(1:ny,J))
-120 APPO(J,I) = APPO(I,J)
-
-C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
- DO 130 I = 1,nx
- APPO(I,I) = APPO(I,I) - SUM(HPs(1:ny,I)*PHFi(I,1:ny))
- + - SUM(PHFi(I,1:ny)*HPs(1:ny,I))
- DO 130 J = 1,I-1
- APPO(I,J) = APPO(I,J) - SUM(HPs(1:ny,I)*PHFi(J,1:ny))
- + - SUM(PHFi(I,1:ny)*HPs(1:ny,J))
-130 APPO(J,I) = APPO(I,J)
-
-C Pi*H'*Fim*Fs*Fim*H*Pi
- DO 140 I = 1,nx
- DO 140 J = 1,ny
-140 APPO1(I,J) = SUM(HPi(1:ny,I)*FFF(1:ny,J))
-
- DO 150 I = 1,nx
- PFP(I,I) = SUM(APPO1(I,1:ny)*HPi(1:ny,I))
- DO 150 J = 1,I-1
- PFP(I,J) = SUM(APPO1(I,1:ny)*HPi(1:ny,J))
-150 PFP(J,I) = PFP(I,J)
-
- Pdd(imain,:,:) = Ps(:,:) + PFP(:,:) + APPO(:,:)
-
-C ----------------------------------------------
-C CONTRIBUTE TO THE LIKELIHOOD 1ST d INNOVATIONS
-C ----------------------------------------------
- IFAIL = -1
-C CALL F03ABF(Fsm(1:ny,1:ny)+Fim(1:ny,1:ny),ny,ny,
-C 1 DETV,WORK1(1:ny),IFAIL)
- FFF(1:ny,1:ny) = Fsm(1:ny,1:ny)+Fim(1:ny,1:ny)
- CALL DPOTRF('L',ny,FFF(1:ny,1:ny),ny,IFAIL) ! FFF = L*L'
- DETV = 1.D0
- RSS = ZERO
- DO 155 I=1,ny
- DETV = DETV*FFF(I,I)
- DO 155 J=1,ny
-155 RSS = RSS + COM(I,1)*Fsm(I,J)*COM(J,1)
-
- LIKE(imain) = -.5D0*(RSS - 2.D0*DLOG(DETV))
- IF (LIKE(imain).NE.0.D0) THEN
- LIKE(imain)=LIKE(imain)-ny/2.D0*DLOG(2.*3.141592653589793D0)
- ENDIF
-C ----------------------------------
-C Predictions X(d+1|d) and P(d+1|d)
-C ----------------------------------
- IF (imain.LT.d(1)) THEN
-C aa = a + F*Xdd
- DO 160 I=1,nx
-160 aa(I) = a(I,S(imain+1,4))+SUM(F(I,:,S(imain+1,5))*Xdd(imain,:))
-
-C Pi = F*Pi*F'-Ci
-C Ps = F*PddF'+R*R'
- DO 170 I = 1,nx
- DO 170 J = 1,nx
- PFP(I,J) = SUM(F(I,:,S(imain+1,5))*Pi(:,J)) ! F*Pi
-170 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*Pdd(imain,:,J)) ! F*Pdd
-
-C Mi = F*Pi*H' ! H to be checked
- DO 172 I = 1,nx
- DO 172 J = 1,ny
-172 Mi(I,J) = SUM(PFP(I,1:nx)*H(J,1:nx,S(imain,2)))!S(+1,..) before
-
-C Ci = Mi*Fim*Mi'
- DO 174 I = 1,nx
- DO 174 J = 1,ny
-174 RG(I,J) = SUM(Mi(I,1:ny)*Fim(1:ny,J)) ! Mi*Fim
-
- DO 176 I = 1,nx
- Ci(I,I) = SUM(RG(I,1:ny)*Mi(I,1:ny))
- DO 176 J = 1,I-1
-176 Ci(I,J) = SUM(RG(I,1:ny)*Mi(J,1:ny))
-
- DO 180 I = 1,nx
- Pi(I,I) = SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
- Ps(I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
- DO 180 J = 1,I-1
- Pi(I,J) = SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
- Ps(I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
- Pi(J,I) = Pi(I,J)
-180 Ps(J,I) = Ps(I,J)
-
- ENDIF
-1000 CONTINUE
- ENDIF
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE IKF2(d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,
+ 1 Xdd,Pdd,LIKE)
+C INPUT
+ INTEGER d(2),ny,nz,nx,nu,ns(6),S(MAX(d(1),1),6)
+ DOUBLE PRECISION yk(MAX(d(1),1),ny+nz),c(ny,max(1,nz),ns(1)),
+ 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 R(nx,nu,ns(6))
+C OUTPUT
+ DOUBLE PRECISION Pdd(MAX(d(1),1),nx,nx),Xdd(MAX(d(1),1),nx),
+ 1 LIKE(MAX(d(1),1))
+C LOCALS
+ INTEGER I,J,IFAIL,imain,FiRANK
+ INTEGER IPIV(nx)
+ DOUBLE PRECISION aa(nx),Ps(nx,nx),Pi(nx,nx)
+ DOUBLE PRECISION HPs(ny,nx),HPi(ny,nx),
+ 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
+ 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ci(nx,nx)
+ DOUBLE PRECISION W1(ny),WORK(64*nx),WORK1(64*ny),
+ 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny)
+ DOUBLE PRECISION ONE,ZERO,DETV,RSS,SUMW1
+ DATA ONE/1.0D0/,ZERO/0.0D0/
+
+C Unconditional mean and variance
+ LIKE(:) = ZERO
+ IF (d(1).EQ.0) THEN ! stationary models
+ IF(SUM(ABS(a(:,S(1,4)))).EQ.ZERO) THEN
+ Xdd(1,:) = ZERO
+ ELSE
+ APPO = -F(:,:,S(1,5))
+ DO 1 I = 1,nx
+1 APPO(I,I) = 1.D0+APPO(I,I)
+ IFAIL = -1
+C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
+C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+ CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
+ CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+ DO 3 I =1,nx
+3 Xdd(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
+ ENDIF
+
+C Pdd - F*Pdd*F' = R*R'
+ CALL LYAP(nx,nu,1.D-3,F(:,:,S(1,5)),R(:,:,S(1,6)),Pdd)
+ ELSE
+C -----------------------------------------------------------
+C Non-stationary models
+C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
+C eta~N(0,I), delta~N(0,k*I) k -> +inf
+C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
+C -----------------------------------------------------------
+ aa(1:nx) = ZERO
+ Ps(1:nx,1:nx) = ZERO
+ IF (d(2).LT.nx) THEN
+ IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
+ APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
+ DO 5 I = d(2)+1,nx
+5 APPO(I,I) = 1.D0+APPO(I,I)
+C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),IFAIL)
+C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+ CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),IFAIL)
+ CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+ DO 6 I = d(2)+1,nx
+6 aa(I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
+ ENDIF
+
+C Lyapunov eqn
+ CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
+ 1 R(d(2)+1:nx,1:nu,S(1,6)),Ps(d(2)+1:nx,d(2)+1:nx))
+
+ ENDIF
+
+ Pi(1:nx,1:nx) = ZERO
+ DO 10 I = 1,d(2)
+10 Pi(I,I) = ONE
+
+ Xdd(:,:) = ZERO
+ Pdd(:,:,:) = ZERO
+ DO 1000 imain = 1,d(1)
+ DO 30 I=1,ny
+ DO 30 J=1,nx
+30 HPs(I,J) = SUM(H(I,:,S(imain,2))*Ps(:,J))
+
+ DO 40 I=1,ny
+ Fs(I,I) = SUM(HPs(I,:)*H(I,:,S(imain,2)))
+ + +SUM(G(I,:,S(imain,3))*G(I,:,S(imain,3)))
+ DO 40 J=1,I-1
+ Fs(I,J) = SUM(HPs(I,:)*H(J,:,S(imain,2)))
+ + +SUM(G(I,:,S(imain,3))*G(J,:,S(imain,3)))
+40 Fs(J,I) = Fs(I,J)
+
+ DO 50 I=1,ny
+ DO 50 J=1,nx
+50 HPi(I,J) = SUM(H(I,:,S(imain,2))*Pi(:,J))
+
+ DO 60 I=1,ny
+ Fi(I,I) = SUM(HPi(I,:)*H(I,:,S(imain,2)))
+ DO 60 J=1,I-1
+ Fi(I,J) = SUM(HPi(I,:)*H(J,:,S(imain,2)))
+60 Fi(J,I) = Fi(I,J)
+
+C --------------------------------------------------------------------------
+C Computes inverse of the innovation variance matrix
+C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
+C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
+C --------------------------------------------------------------------------
+ IF (ny.EQ.1) THEN
+ Fsm = ZERO
+ Fim = 1.D0/Fi
+ FFF = Fim*Fs*Fim
+ ELSE
+
+ IFAIL = -1
+ COM(1:ny,1:ny) = Fi(1:ny,1:ny)
+C CALL F02FAF('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),WORK1,64*ny,IFAIL)
+ CALL DSYEV('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),WORK1,
+ 1 64*ny,IFAIL)
+ FiRANK = 0
+ SUMW1 = SUM(ABS(W1(1:ny)))
+ DO 70 I=1,ny
+ W1(I) = W1(I)/SUMW1
+70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
+ FiRANK = min(FiRANK,d(2))
+
+ IF(FiRANK.EQ.ny) THEN
+ Fsm = ZERO
+ COM(1:ny,1:ny) = Fi(1:ny,1:ny)
+ IFAIL = -1
+C CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
+ CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
+
+ DO 80 I=1,ny
+ Fim(I,I) = COM(I,I)
+ DO 80 J=1,I-1
+ Fim(I,J) = COM(I,J)
+80 Fim(J,I) = Fim(I,J)
+
+ DO 81 I=1,ny
+ DO 81 J=1,ny
+81 COM(I,J) = SUM(Fim(I,1:ny)*Fs(1:ny,J)) ! Fim x Fs
+
+ DO 82 I=1,ny
+ FFF(I,I) = SUM(COM(I,1:ny)*Fim(1:ny,I))
+ DO 82 J=1,I-1
+ FFF(I,J) = SUM(COM(I,1:ny)*Fim(1:ny,J)) ! Fim x Fs x Fim
+82 FFF(J,I) = FFF(I,J)
+
+ ELSE
+ SUMW1=0.D0
+ DO I=Firank+1,ny
+ SUMW1 = SUMW1 + Fi(I,I)
+ ENDDO
+ IF (SUMW1.GT.0.D0) THEN
+ CALL INVFBIS(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
+ 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
+ ELSE
+ CALL INVF(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
+ 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
+ ENDIF
+ ENDIF
+ ENDIF
+C ------------------------------------------------------------------
+C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
+C ------------------------------------------------------------------
+ DO 85 I = 1,nx
+ DO 85 J = 1,ny
+ RG(I,J) =
+ # SUM(R(I,1:nu,S(imain,6))*G(J,1:nu,S(imain,3)))
+85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
+
+ DO 90 I = 1,nx
+ DO 90 J = 1,ny
+ PHFs(I,J) = SUM(HPs(1:ny,I)*Fsm(1:ny,J))
+90 PHFi(I,J) = SUM(HPi(1:ny,I)*Fim(1:ny,J))
+
+C Innovations
+ DO 100 I=1,ny
+100 COM(I,1) = yk(imain,I)
+ + - SUM(H(I,1:nx,S(imain,2))*aa(1:nx))
+ + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+ DO 110 I=1,nx
+110 Xdd(imain,I) = aa(I)
+ + + SUM((PHFs(I,1:ny)+PHFi(I,1:ny))*COM(1:ny,1))
+
+C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps
+C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+
+C- Ps*H'*Fsm*H*Ps
+ DO 120 I = 1,nx
+ APPO(I,I) = -SUM(PHFs(I,1:ny)*HPs(1:ny,I))
+ DO 120 J = 1,I-1
+ APPO(I,J) = -SUM(PHFs(I,1:ny)*HPs(1:ny,J))
+120 APPO(J,I) = APPO(I,J)
+
+C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+ DO 130 I = 1,nx
+ APPO(I,I) = APPO(I,I) - SUM(HPs(1:ny,I)*PHFi(I,1:ny))
+ + - SUM(PHFi(I,1:ny)*HPs(1:ny,I))
+ DO 130 J = 1,I-1
+ APPO(I,J) = APPO(I,J) - SUM(HPs(1:ny,I)*PHFi(J,1:ny))
+ + - SUM(PHFi(I,1:ny)*HPs(1:ny,J))
+130 APPO(J,I) = APPO(I,J)
+
+C Pi*H'*Fim*Fs*Fim*H*Pi
+ DO 140 I = 1,nx
+ DO 140 J = 1,ny
+140 APPO1(I,J) = SUM(HPi(1:ny,I)*FFF(1:ny,J))
+
+ DO 150 I = 1,nx
+ PFP(I,I) = SUM(APPO1(I,1:ny)*HPi(1:ny,I))
+ DO 150 J = 1,I-1
+ PFP(I,J) = SUM(APPO1(I,1:ny)*HPi(1:ny,J))
+150 PFP(J,I) = PFP(I,J)
+
+ Pdd(imain,:,:) = Ps(:,:) + PFP(:,:) + APPO(:,:)
+
+C ----------------------------------------------
+C CONTRIBUTE TO THE LIKELIHOOD 1ST d INNOVATIONS
+C ----------------------------------------------
+ IFAIL = -1
+C CALL F03ABF(Fsm(1:ny,1:ny)+Fim(1:ny,1:ny),ny,ny,
+C 1 DETV,WORK1(1:ny),IFAIL)
+ FFF(1:ny,1:ny) = Fsm(1:ny,1:ny)+Fim(1:ny,1:ny)
+ CALL DPOTRF('L',ny,FFF(1:ny,1:ny),ny,IFAIL) ! FFF = L*L'
+ DETV = 1.D0
+ RSS = ZERO
+ DO 155 I=1,ny
+ DETV = DETV*FFF(I,I)
+ DO 155 J=1,ny
+155 RSS = RSS + COM(I,1)*Fsm(I,J)*COM(J,1)
+
+ LIKE(imain) = -.5D0*(RSS - 2.D0*DLOG(DETV))
+ IF (LIKE(imain).NE.0.D0) THEN
+ LIKE(imain)=LIKE(imain)-ny/2.D0*DLOG(2.*3.141592653589793D0)
+ ENDIF
+C ----------------------------------
+C Predictions X(d+1|d) and P(d+1|d)
+C ----------------------------------
+ IF (imain.LT.d(1)) THEN
+C aa = a + F*Xdd
+ DO 160 I=1,nx
+160 aa(I) = a(I,S(imain+1,4))+SUM(F(I,:,S(imain+1,5))*Xdd(imain,:))
+
+C Pi = F*Pi*F'-Ci
+C Ps = F*PddF'+R*R'
+ DO 170 I = 1,nx
+ DO 170 J = 1,nx
+ PFP(I,J) = SUM(F(I,:,S(imain+1,5))*Pi(:,J)) ! F*Pi
+170 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*Pdd(imain,:,J)) ! F*Pdd
+
+C Mi = F*Pi*H' ! H to be checked
+ DO 172 I = 1,nx
+ DO 172 J = 1,ny
+172 Mi(I,J) = SUM(PFP(I,1:nx)*H(J,1:nx,S(imain,2)))!S(+1,..) before
+
+C Ci = Mi*Fim*Mi'
+ DO 174 I = 1,nx
+ DO 174 J = 1,ny
+174 RG(I,J) = SUM(Mi(I,1:ny)*Fim(1:ny,J)) ! Mi*Fim
+
+ DO 176 I = 1,nx
+ Ci(I,I) = SUM(RG(I,1:ny)*Mi(I,1:ny))
+ DO 176 J = 1,I-1
+176 Ci(I,J) = SUM(RG(I,1:ny)*Mi(J,1:ny))
+
+ DO 180 I = 1,nx
+ Pi(I,I) = SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
+ Ps(I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
+ DO 180 J = 1,I-1
+ Pi(I,J) = SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
+ Ps(I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
+ Pi(J,I) = Pi(I,J)
+180 Ps(J,I) = Ps(I,J)
+
+ ENDIF
+1000 CONTINUE
+ ENDIF
+
+ RETURN
END
diff --git a/initrand.for b/initrand.for
index d94b585258e0562dbf0ff4496091be664b6d2a68..5381d35375488353f0e6bc02af6457d2ad19b127 100644
--- a/initrand.for
+++ b/initrand.for
@@ -1,14 +1,14 @@
-C ------------------------------------------------------------
-C INITRAND initializes the random number generator:
-C INITIAL = 0 FIXED SEED, otherwise SEED set according to clock
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------
+C INITRAND initializes the random number generator:
+C INITIAL = 0 FIXED SEED, otherwise SEED set according to clock
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -17,15 +17,15 @@ C DMM is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
-C ------------------------------------------------------------
- SUBROUTINE INITRAND(INITIAL,DATE_ITIME)
-C Input
- INTEGER INITIAL,DATE_ITIME(8)
-
- IF(INITIAL.NE.0) THEN
- CALL setall(DATE_ITIME(7),DATE_ITIME(8))
- ELSE
- CALL setall(12345,54321)
- ENDIF
- RETURN
+C ------------------------------------------------------------
+ SUBROUTINE INITRAND(INITIAL,DATE_ITIME)
+C Input
+ INTEGER INITIAL,DATE_ITIME(8)
+
+ IF(INITIAL.NE.0) THEN
+ CALL setall(DATE_ITIME(7),DATE_ITIME(8))
+ ELSE
+ CALL setall(12345,54321)
+ ENDIF
+ RETURN
END
diff --git a/innov.for b/innov.for
index 9c295399f2d9ad737fb9f3896846ab04561587a1..a8879cc351f67d9949065f0d471671a125579c8a 100644
--- a/innov.for
+++ b/innov.for
@@ -1,30 +1,30 @@
-C --------------------------------------------------------------------
-C INNOV RETURNS MODEL INNOVATIONS
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C INNOV RETURNS MODEL INNOVATIONS
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -35,161 +35,161 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE INNOV(nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,pdll,INN)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN)
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,nt
- INTEGER ns(6),IYK(nobs,ny+1),S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
-
-C OUTPUT
- DOUBLE PRECISION INN(nobs,ny)
-
-C LOCALS
- INTEGER imain,iny,I,J,IFAIL
- DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:)
- DOUBLE PRECISION,ALLOCATABLE:: X1(:),P1(:,:),FP(:,:),HP1(:,:),
- 1 V(:,:),Vinv(:,:),COM(:,:),RG(:,:),HPV(:,:),Xdd(:,:),Pdd(:,:,:),
- 1 LIKE(:),XT(:),PT(:,:),INN0(:)
-
- ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
- ALLOCATE(X1(nx),P1(nx,nx),FP(nx,nx),HP1(ny,nx),V(ny,ny),
- 1 Vinv(ny,ny),COM(ny+1,ny),RG(nx,ny),HPV(nx,ny),
- 1 Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx),LIKE(max(d(1),1)),
- 1 XT(nx),PT(nx,nx),INN0(ny))
-
- pdesign = getprocaddress(pdll, "design_"C)
- INN(:,:) = 0.D0
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),c,H,G,a,F,R,
- 2 Xdd,Pdd,LIKE(1:max(d(1),1)))
- XT(1:nx) = Xdd(max(d(1),1),1:nx)
- PT(1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
-
- DO 1000 imain = d(1)+1,nobs
- iny = IYK(imain,ny+1)
-
-C ------------------------------------
-C Prediction x1 = c+F*x0
-C Prediction var. P1 = F*p0*F'+ R*R'
-C ------------------------------------
- DO 10 I=1,nx
-10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(:))
-
- DO 20 I=1,nx
- DO 20 J=1,nx
-20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(:,J))
-
- DO 30 I=1,nx
- P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
- DO 30 J=1,I-1
- P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
-30 P1(J,I) = P1(I,J)
-
-C -------------------------------
-C Innovations: INN = yk-H*X1-c*z
-C -------------------------------
- DO 40 I=1,iny
-40 INN(imain,I) = yk(imain,IYK(imain,I))
- + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*X1(1:nx))
- + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
-
-C ----------------------------------------------------------
-C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
-C ----------------------------------------------------------
- DO 50 I=1,iny
- DO 50 J=1,nx
-50 HP1(I,J) = SUM(H(IYK(imain,I),1:nx,S(imain,2))*P1(1:nx,J))
-
- DO 55 I=1,nx
- DO 55 J=1,iny
-55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
- # * G(IYK(imain,J),1:nu,S(imain,3))) ! R*G'
-
- DO 56 I=1,iny
- DO 56 J=1,iny
-56 COM(I,J)=SUM(H(IYK(imain,I),1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
-
- DO 60 I=1,iny
- V(I,I) = SUM(HP1(I,1:nx)*H(IYK(imain,I),1:nx,S(imain,2))) +
- # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
- # G(IYK(imain,I),1:nu,S(imain,3)))+2.*COM(I,I)
- DO 60 J=1,I-1
- V(I,J) = SUM(HP1(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))+
- # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
- # G(IYK(imain,J),1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
-60 V(J,I) = V(I,J)
-
-C -------------------------------------------------------------------
-C Updating equations:
-C x0 = x1 + (P1*H'+R*G')*Vinv*INN
-C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
-C -------------------------------------------------------------------
- IF (iny.GT.0) THEN
- COM(1:iny,1:iny) = V(1:iny,1:iny)
- IFAIL = -1
-c CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
-
- DO 70 I=1,iny
- Vinv(I,I) = COM(I,I)
- DO 70 J=1,I-1
- Vinv(I,J) = COM(I,J)
-70 Vinv(J,I) = Vinv(I,J)
-
- DO 90 I=1,nx
- DO 90 J=1,iny
-90 HPV(I,J) = SUM((HP1(1:iny,I)+RG(I,1:iny))*Vinv(1:iny,J))
-
- DO 100 I=1,nx
-100 XT(I) = X1(I)+SUM(HPV(I,1:iny)*INN(imain,1:iny))
-
- DO 110 I=1,nx
- PT(I,I) = P1(I,I)
- + - SUM(HPV(I,1:iny)*(HP1(1:iny,I)+RG(I,1:iny)))
- DO 110 J=1,I-1
- PT(I,J) = P1(I,J)
- + - SUM(HPV(I,1:iny)*(HP1(1:iny,J)+RG(J,1:iny)))
-110 PT(J,I) = PT(I,J)
-
- ELSE
-
- XT(1:nx) = X1(1:nx)
- PT(1:nx,1:nx) = P1(1:nx,1:nx)
-
-1000 ENDIF
-
-C Put Innovations in the rigth place
- DO I = 1,nobs
- iny = IYK(I,ny+1)
- INN0(1:ny) = 0.D0
- INN0(IYK(I,1:iny)) = INN(I,1:iny)
- INN(I,1:ny) = INN0(1:ny)
- ENDDO
-
- DEALLOCATE(R,c,H,G,a,F,X1,P1,FP,HP1,V,Vinv,COM,RG,HPV,Xdd,Pdd,
- 1 LIKE,XT,PT,INN0)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE INNOV(nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,pdll,INN)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN)
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,nt
+ INTEGER ns(6),IYK(nobs,ny+1),S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
+
+C OUTPUT
+ DOUBLE PRECISION INN(nobs,ny)
+
+C LOCALS
+ INTEGER imain,iny,I,J,IFAIL
+ DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:)
+ DOUBLE PRECISION,ALLOCATABLE:: X1(:),P1(:,:),FP(:,:),HP1(:,:),
+ 1 V(:,:),Vinv(:,:),COM(:,:),RG(:,:),HPV(:,:),Xdd(:,:),Pdd(:,:,:),
+ 1 LIKE(:),XT(:),PT(:,:),INN0(:)
+
+ ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
+ ALLOCATE(X1(nx),P1(nx,nx),FP(nx,nx),HP1(ny,nx),V(ny,ny),
+ 1 Vinv(ny,ny),COM(ny+1,ny),RG(nx,ny),HPV(nx,ny),
+ 1 Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx),LIKE(max(d(1),1)),
+ 1 XT(nx),PT(nx,nx),INN0(ny))
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ INN(:,:) = 0.D0
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),c,H,G,a,F,R,
+ 2 Xdd,Pdd,LIKE(1:max(d(1),1)))
+ XT(1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+
+ DO 1000 imain = d(1)+1,nobs
+ iny = IYK(imain,ny+1)
+
+C ------------------------------------
+C Prediction x1 = c+F*x0
+C Prediction var. P1 = F*p0*F'+ R*R'
+C ------------------------------------
+ DO 10 I=1,nx
+10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(:))
+
+ DO 20 I=1,nx
+ DO 20 J=1,nx
+20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(:,J))
+
+ DO 30 I=1,nx
+ P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
+ DO 30 J=1,I-1
+ P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
+30 P1(J,I) = P1(I,J)
+
+C -------------------------------
+C Innovations: INN = yk-H*X1-c*z
+C -------------------------------
+ DO 40 I=1,iny
+40 INN(imain,I) = yk(imain,IYK(imain,I))
+ + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*X1(1:nx))
+ + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+
+C ----------------------------------------------------------
+C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
+C ----------------------------------------------------------
+ DO 50 I=1,iny
+ DO 50 J=1,nx
+50 HP1(I,J) = SUM(H(IYK(imain,I),1:nx,S(imain,2))*P1(1:nx,J))
+
+ DO 55 I=1,nx
+ DO 55 J=1,iny
+55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
+ # * G(IYK(imain,J),1:nu,S(imain,3))) ! R*G'
+
+ DO 56 I=1,iny
+ DO 56 J=1,iny
+56 COM(I,J)=SUM(H(IYK(imain,I),1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
+
+ DO 60 I=1,iny
+ V(I,I) = SUM(HP1(I,1:nx)*H(IYK(imain,I),1:nx,S(imain,2))) +
+ # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
+ # G(IYK(imain,I),1:nu,S(imain,3)))+2.*COM(I,I)
+ DO 60 J=1,I-1
+ V(I,J) = SUM(HP1(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))+
+ # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
+ # G(IYK(imain,J),1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
+60 V(J,I) = V(I,J)
+
+C -------------------------------------------------------------------
+C Updating equations:
+C x0 = x1 + (P1*H'+R*G')*Vinv*INN
+C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
+C -------------------------------------------------------------------
+ IF (iny.GT.0) THEN
+ COM(1:iny,1:iny) = V(1:iny,1:iny)
+ IFAIL = -1
+c CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
+
+ DO 70 I=1,iny
+ Vinv(I,I) = COM(I,I)
+ DO 70 J=1,I-1
+ Vinv(I,J) = COM(I,J)
+70 Vinv(J,I) = Vinv(I,J)
+
+ DO 90 I=1,nx
+ DO 90 J=1,iny
+90 HPV(I,J) = SUM((HP1(1:iny,I)+RG(I,1:iny))*Vinv(1:iny,J))
+
+ DO 100 I=1,nx
+100 XT(I) = X1(I)+SUM(HPV(I,1:iny)*INN(imain,1:iny))
+
+ DO 110 I=1,nx
+ PT(I,I) = P1(I,I)
+ + - SUM(HPV(I,1:iny)*(HP1(1:iny,I)+RG(I,1:iny)))
+ DO 110 J=1,I-1
+ PT(I,J) = P1(I,J)
+ + - SUM(HPV(I,1:iny)*(HP1(1:iny,J)+RG(J,1:iny)))
+110 PT(J,I) = PT(I,J)
+
+ ELSE
+
+ XT(1:nx) = X1(1:nx)
+ PT(1:nx,1:nx) = P1(1:nx,1:nx)
+
+1000 ENDIF
+
+C Put Innovations in the rigth place
+ DO I = 1,nobs
+ iny = IYK(I,ny+1)
+ INN0(1:ny) = 0.D0
+ INN0(IYK(I,1:iny)) = INN(I,1:iny)
+ INN(I,1:ny) = INN0(1:ny)
+ ENDDO
+
+ DEALLOCATE(R,c,H,G,a,F,X1,P1,FP,HP1,V,Vinv,COM,RG,HPV,Xdd,Pdd,
+ 1 LIKE,XT,PT,INN0)
+ RETURN
END
diff --git a/innov2.for b/innov2.for
index a45117aea94de4f522452aa195b5264be48fa8b3..dc5582e796ca4ca52ff55d06727464672fd843bf 100644
--- a/innov2.for
+++ b/innov2.for
@@ -1,30 +1,30 @@
-C --------------------------------------------------------------------
-C INNOV2 (no mising values) RETURNS MODEL INNOVATIONS
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C INNOV2 (no mising values) RETURNS MODEL INNOVATIONS
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -35,150 +35,150 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE INNOV2(nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,pdll,INN)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
-
-C OUTPUT
- DOUBLE PRECISION INN(nobs,ny)
-
-C LOCALS
- INTEGER imain,I,J,IFAIL
- DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:)
- DOUBLE PRECISION,ALLOCATABLE:: X1(:),P1(:,:),FP(:,:),HP1(:,:),
- 1 V(:,:),Vinv(:,:),COM(:,:),RG(:,:),HPV(:,:),Xdd(:,:),Pdd(:,:,:),
- 1 LIKE(:),XT(:),PT(:,:)
-
- ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
- ALLOCATE(X1(nx),P1(nx,nx),FP(nx,nx),HP1(ny,nx),V(ny,ny),
- 1 Vinv(ny,ny),COM(ny+1,ny),RG(nx,ny),HPV(nx,ny),
- 1 Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx),LIKE(max(d(1),1)),
- 1 XT(nx),PT(nx,nx))
-
- pdesign = getprocaddress(pdll, "design_"C)
- INN(:,:) = 0.D0
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL IKF2(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),c,H,G,a,F,R,
- 2 Xdd,Pdd,LIKE(1:max(d(1),1)))
- XT(1:nx) = Xdd(max(d(1),1),1:nx)
- PT(1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
-
- DO 1000 imain = d(1)+1,nobs
-
-C ------------------------------------
-C Prediction x1 = c+F*x0
-C Prediction var. P1 = F*p0*F'+ R*R'
-C ------------------------------------
- DO 10 I=1,nx
-10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(:))
-
- DO 20 I=1,nx
- DO 20 J=1,nx
-20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(:,J))
-
- DO 30 I=1,nx
- P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
- DO 30 J=1,I-1
- P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
-30 P1(J,I) = P1(I,J)
-
-C -------------------------------
-C Innovations: INN = yk-H*X1-c*z
-C -------------------------------
- DO 40 I=1,ny
-40 INN(imain,I) = yk(imain,I)
- + - SUM(H(I,1:nx,S(imain,2))*X1(1:nx))
- + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
-C ----------------------------------------------------------
-C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
-C ----------------------------------------------------------
- DO 50 I=1,ny
- DO 50 J=1,nx
-50 HP1(I,J) = SUM(H(I,1:nx,S(imain,2))*P1(1:nx,J))
-
- DO 55 I=1,nx
- DO 55 J=1,ny
-55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
- # * G(J,1:nu,S(imain,3))) ! R*G'
-
- DO 56 I=1,ny
- DO 56 J=1,ny
-56 COM(I,J)=SUM(H(I,1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
-
- DO 60 I=1,ny
- V(I,I) = SUM(HP1(I,1:nx)*H(I,1:nx,S(imain,2))) +
- # SUM(G(I,1:nu,S(imain,3))*
- # G(I,1:nu,S(imain,3)))+2.*COM(I,I)
- DO 60 J=1,I-1
- V(I,J) = SUM(HP1(I,1:nx)*H(J,1:nx,S(imain,2)))+
- # SUM(G(I,1:nu,S(imain,3))*
- # G(J,1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
-60 V(J,I) = V(I,J)
-
-C -------------------------------------------------------------------
-C Updating equations:
-C x0 = x1 + (P1*H'+R*G')*Vinv*INN
-C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
-C -------------------------------------------------------------------
- IF (ny.GT.0) THEN
- COM(1:ny,1:ny) = V(1:ny,1:ny)
- IFAIL = -1
-c CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
- CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
-
- DO 70 I=1,ny
- Vinv(I,I) = COM(I,I)
- DO 70 J=1,I-1
- Vinv(I,J) = COM(I,J)
-70 Vinv(J,I) = Vinv(I,J)
-
- DO 90 I=1,nx
- DO 90 J=1,ny
-90 HPV(I,J) = SUM((HP1(1:ny,I)+RG(I,1:ny))*Vinv(1:ny,J))
-
- DO 100 I=1,nx
-100 XT(I) = X1(I)+SUM(HPV(I,1:ny)*INN(imain,1:ny))
-
- DO 110 I=1,nx
- PT(I,I) = P1(I,I)
- + - SUM(HPV(I,1:ny)*(HP1(1:ny,I)+RG(I,1:ny)))
- DO 110 J=1,I-1
- PT(I,J) = P1(I,J)
- + - SUM(HPV(I,1:ny)*(HP1(1:ny,J)+RG(J,1:ny)))
-110 PT(J,I) = PT(I,J)
-
- ELSE
-
- XT(1:nx) = X1(1:nx)
- PT(1:nx,1:nx) = P1(1:nx,1:nx)
-
-1000 ENDIF
-
- DEALLOCATE(R,c,H,G,a,F,X1,P1,FP,HP1,V,Vinv,COM,RG,HPV,Xdd,Pdd,
- 1 LIKE,XT,PT)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE INNOV2(nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,pdll,INN)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
+
+C OUTPUT
+ DOUBLE PRECISION INN(nobs,ny)
+
+C LOCALS
+ INTEGER imain,I,J,IFAIL
+ DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:)
+ DOUBLE PRECISION,ALLOCATABLE:: X1(:),P1(:,:),FP(:,:),HP1(:,:),
+ 1 V(:,:),Vinv(:,:),COM(:,:),RG(:,:),HPV(:,:),Xdd(:,:),Pdd(:,:,:),
+ 1 LIKE(:),XT(:),PT(:,:)
+
+ ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
+ ALLOCATE(X1(nx),P1(nx,nx),FP(nx,nx),HP1(ny,nx),V(ny,ny),
+ 1 Vinv(ny,ny),COM(ny+1,ny),RG(nx,ny),HPV(nx,ny),
+ 1 Xdd(max(d(1),1),nx),Pdd(max(d(1),1),nx,nx),LIKE(max(d(1),1)),
+ 1 XT(nx),PT(nx,nx))
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ INN(:,:) = 0.D0
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL IKF2(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),c,H,G,a,F,R,
+ 2 Xdd,Pdd,LIKE(1:max(d(1),1)))
+ XT(1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+
+ DO 1000 imain = d(1)+1,nobs
+
+C ------------------------------------
+C Prediction x1 = c+F*x0
+C Prediction var. P1 = F*p0*F'+ R*R'
+C ------------------------------------
+ DO 10 I=1,nx
+10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(:))
+
+ DO 20 I=1,nx
+ DO 20 J=1,nx
+20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(:,J))
+
+ DO 30 I=1,nx
+ P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
+ DO 30 J=1,I-1
+ P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
+30 P1(J,I) = P1(I,J)
+
+C -------------------------------
+C Innovations: INN = yk-H*X1-c*z
+C -------------------------------
+ DO 40 I=1,ny
+40 INN(imain,I) = yk(imain,I)
+ + - SUM(H(I,1:nx,S(imain,2))*X1(1:nx))
+ + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+C ----------------------------------------------------------
+C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
+C ----------------------------------------------------------
+ DO 50 I=1,ny
+ DO 50 J=1,nx
+50 HP1(I,J) = SUM(H(I,1:nx,S(imain,2))*P1(1:nx,J))
+
+ DO 55 I=1,nx
+ DO 55 J=1,ny
+55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
+ # * G(J,1:nu,S(imain,3))) ! R*G'
+
+ DO 56 I=1,ny
+ DO 56 J=1,ny
+56 COM(I,J)=SUM(H(I,1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
+
+ DO 60 I=1,ny
+ V(I,I) = SUM(HP1(I,1:nx)*H(I,1:nx,S(imain,2))) +
+ # SUM(G(I,1:nu,S(imain,3))*
+ # G(I,1:nu,S(imain,3)))+2.*COM(I,I)
+ DO 60 J=1,I-1
+ V(I,J) = SUM(HP1(I,1:nx)*H(J,1:nx,S(imain,2)))+
+ # SUM(G(I,1:nu,S(imain,3))*
+ # G(J,1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
+60 V(J,I) = V(I,J)
+
+C -------------------------------------------------------------------
+C Updating equations:
+C x0 = x1 + (P1*H'+R*G')*Vinv*INN
+C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
+C -------------------------------------------------------------------
+ IF (ny.GT.0) THEN
+ COM(1:ny,1:ny) = V(1:ny,1:ny)
+ IFAIL = -1
+c CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
+ CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
+
+ DO 70 I=1,ny
+ Vinv(I,I) = COM(I,I)
+ DO 70 J=1,I-1
+ Vinv(I,J) = COM(I,J)
+70 Vinv(J,I) = Vinv(I,J)
+
+ DO 90 I=1,nx
+ DO 90 J=1,ny
+90 HPV(I,J) = SUM((HP1(1:ny,I)+RG(I,1:ny))*Vinv(1:ny,J))
+
+ DO 100 I=1,nx
+100 XT(I) = X1(I)+SUM(HPV(I,1:ny)*INN(imain,1:ny))
+
+ DO 110 I=1,nx
+ PT(I,I) = P1(I,I)
+ + - SUM(HPV(I,1:ny)*(HP1(1:ny,I)+RG(I,1:ny)))
+ DO 110 J=1,I-1
+ PT(I,J) = P1(I,J)
+ + - SUM(HPV(I,1:ny)*(HP1(1:ny,J)+RG(J,1:ny)))
+110 PT(J,I) = PT(I,J)
+
+ ELSE
+
+ XT(1:nx) = X1(1:nx)
+ PT(1:nx,1:nx) = P1(1:nx,1:nx)
+
+1000 ENDIF
+
+ DEALLOCATE(R,c,H,G,a,F,X1,P1,FP,HP1,V,Vinv,COM,RG,HPV,Xdd,Pdd,
+ 1 LIKE,XT,PT)
+ RETURN
END
diff --git a/input.for b/input.for
index 3f5f8baa0390d1ccc0165eace909899696a63f69..34dac5768da1e45363b6ce0fc36f094c7c8f30d5 100644
--- a/input.for
+++ b/input.for
@@ -1,13 +1,13 @@
-C -----------------------------------------------------------------------
-C INPUT reads the input file *.nml
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -----------------------------------------------------------------------
+C INPUT reads the input file *.nml
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,1014 +18,1014 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -----------------------------------------------------------------------
- SUBROUTINE input(FILEIN,NMLNAME,PATH,ny,nz,nx,nu,d,nv,ns,
- 1 nstot,np,nf,INFOS,seed,thin,burnin,simulrec,sampler,
- 2 datasim,dllname,check,estimation,nt,pdftheta,hyptheta,
- 3 hypS,T,obs,Ssampler,hbl,MargLik)
-
-C INCLUDE 'iosdef.for'
- INTEGER IERR
-C INPUT
- CHARACTER*200 FILEIN
-C OUTPUT
- NAMELIST /ssm/ nx,nu,d,nv,dllname,check,estimation
- INTEGER nx,nu,d(2),nv
- CHARACTER*200 dllname
- CHARACTER*1 check
- CHARACTER*2 estimation
-
- NAMELIST /S1/ dynS1,matS1,ns1,hypS1
- NAMELIST /S2/ dynS2,matS2,ns2,hypS2
- NAMELIST /S3/ dynS3,matS3,ns3,hypS3
- NAMELIST /S4/ dynS4,matS4,ns4,hypS4
- NAMELIST /S5/ dynS5,matS5,ns5,hypS5
- NAMELIST /S6/ dynS6,matS6,ns6,hypS6
- CHARACTER*1 dynS1,dynS2,dynS3,dynS4,dynS5,dynS6,
- 1 matS1(6),matS2(6),matS3(6),matS4(6),matS5(6),matS6(6)
- INTEGER ns1,ns2,ns3,ns4,ns5,ns6
- DOUBLE PRECISION hypS1(50,50),hypS2(50,50),hypS3(50,50),
- 1 hypS4(50,50),hypS5(50,50),hypS6(50,50),hypS(50,50,6)
-
- NAMELIST /mcmc/ seed,thin,burnin,simulrec,sampler,
- 1 Ssampler,hbl,marglik
- INTEGER seed,thin,burnin,simulrec,hbl
- CHARACTER*1 MargLik
- CHARACTER*2 sampler
- CHARACTER*3 Ssampler
-
- NAMELIST /prior/ nt,pdftheta,hyptheta
- INTEGER nt
- DOUBLE PRECISION hyptheta(4,200)
- CHARACTER*2 pdftheta(200)
-
- NAMELIST /dataset/ T,ny,nz,nf,datasim,obs
- INTEGER T,ny,nz,nf
- DOUBLE PRECISION obs(30000)
- CHARACTER*1 datasim
-
-C OUTPUT not in the namelist
- INTEGER ns(6),INFOS(9,6),IMAX(1),np(3),nstot,IND
- CHARACTER*200 NMLNAME,PATH
-
-C LOCALS
- CHARACTER*3 IC
- CHARACTER*200 STR
- INTEGER I,J,K,IFAIL
- INTEGER, ALLOCATABLE:: nstateS(:)
- CHARACTER*1, ALLOCATABLE:: matS(:,:),dynS(:)
-
-C IDENTIFY the PATH and NAME of the .NML INPUT FILE
- I = SCAN(FILEIN,'\', BACK = .TRUE.)
- IF((I.LE.0).OR.(I.GE.200)) THEN
- NMLNAME = FILEIN
- PATH = ''
- ELSE
- NMLNAME = FILEIN(I+1:200)
- PATH = FILEIN(1:I)
- ENDIF
- I = SCAN(NMLNAME,'.', BACK = .TRUE.)
- NMLNAME = NMLNAME(1:I-1)
-
-C FIND namelist ssm
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL',
- 1 STATUS='OLD',IOSTAT=IERR, ERR=5000)
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&ssm').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namelist ssm not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-
-C READ namelist ssm
- ns1=0
- ns2=0
- ns3=0
- ns4=0
- ns5=0
- ns6=0
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- nx = -1
- nu = -1
- d(:) = -1
- nv = 0
- dllname = ''
- check = 'N'
- estimation = 'BA'
- READ(1,NML=ssm,END=5001,ERR=5001)
- IF (nx.LE.0) THEN
- TYPE *, ' Check nx in namelist ssm'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF(nu.LE.0) THEN
- TYPE *, ' Check nu in namelist ssm'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF((d(1).LT.0).OR.(d(2).LT.0).OR.(d(2).GT.nx)) THEN
- TYPE *, ' Check d in namelist ssm'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF((nv.LT.0).OR.(nv.GT.6)) THEN
- TYPE *, ' Check nv in namelist ssm'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF(dllname.EQ.'') THEN
- TYPE *, ' Check dllname in namelist ssm'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- CLOSE(1)
- IF ((estimation.NE.'ML').AND.(estimation.NE.'ml').AND.
- & (estimation.NE.'Ml').AND.(estimation.NE.'mL').AND.
- & (estimation.NE.'BA').AND.(estimation.NE.'ba').AND.
- & (estimation.NE.'Ba').AND.(estimation.NE.'bA')) THEN
- estimation = 'BA'
- ENDIF
-
- IF (nv.GT.0) THEN
-C FIND namelist S1
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&S1').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namelist S1 not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-
-C READ namelist S1
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- dynS1 = '-'
- ns1 = -1
- hypS1(:,:) = 1
- matS1(:) = '-'
- READ(1,NML=S1,END=5002,ERR=5002)
-
- IF ((dynS1.NE.'I').AND.(dynS1.NE.'M'))THEN
- TYPE *, ' Check dynS1 in namelist S1'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (ns1.LT.2) THEN
- TYPE *, ' Check ns1 in namelist S1'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (dynS1.EQ.'I') THEN
- DO J = 1,ns1
- IF (hypS1(J,1).LE.0) THEN
- TYPE *, ' Check hypS1 in namelist S1'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ELSEIF (dynS1.EQ.'M') THEN
- DO J = 1,ns1
- DO K = 1,ns1
- IF (hypS1(J,K).LE.0) THEN
- TYPE *, ' Check hypS1 in namelist S1'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-
- IF ((matS1(1).EQ.'-').OR.((matS1(1).NE.'a')
- # .AND.(matS1(1).NE.'H').AND.(matS1(1).NE.'G')
- # .AND.(matS1(1).NE.'c').AND.(matS1(1).NE.'F')
- # .AND.(matS1(1).NE.'R'))) THEN
- TYPE *, ' Check matS1 in namelist S1'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- DO I = 2,6
- IF ((matS1(I).NE.'-').AND.(matS1(I).NE.'a')
- # .AND.(matS1(I).NE.'H').AND.(matS1(I).NE.'G')
- # .AND.(matS1(I).NE.'c').AND.(matS1(I).NE.'F')
- # .AND.(matS1(I).NE.'R')) THEN
- TYPE *, ' Check matS1 in namelist S1'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDIF
- CLOSE(1)
-
- IF (nv.GT.1) THEN
-C FIND namelist S2
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&S2').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namelist S2 not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-C READ namelist S2
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- dynS2 = '-'
- ns2 = -1
- hypS2(:,:) = 1 ! Uniform
- matS2(:) = '-'
- READ(1,NML=S2,END=5003,ERR=5003)
-
- IF ((dynS2.NE.'I').AND.(dynS2.NE.'M'))THEN
- TYPE *, ' Check dynS2 in namelist S2'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (ns2.LT.2) THEN
- TYPE *, ' Check ns2 in namelist S2'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (dynS2.EQ.'I') THEN
- DO J = 1,ns2
- IF (hypS2(J,1).LE.0) THEN
- TYPE *, ' Check hypS2 in namelist S2'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ELSEIF (dynS2.EQ.'M') THEN
- DO J = 1,ns2
- DO K = 1,ns2
- IF (hypS2(J,K).LE.0) THEN
- TYPE *, ' Check hypS2 in namelist S2'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDDO
- ENDIF
- I = 1
- IF ((matS2(I).EQ.'-').OR.((matS2(I).NE.'a')
- # .AND.(matS2(I).NE.'H').AND.(matS2(I).NE.'G')
- # .AND.(matS2(I).NE.'c').AND.(matS2(I).NE.'F')
- # .AND.(matS2(I).NE.'R'))) THEN
- TYPE *, ' Check matS2 in namelist S2'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- DO I = 2,6
- IF ((matS2(I).NE.'-').AND.(matS2(I).NE.'a')
- # .AND.(matS2(I).NE.'H').AND.(matS2(I).NE.'G')
- # .AND.(matS2(I).NE.'c').AND.(matS2(I).NE.'F')
- # .AND.(matS2(I).NE.'R')) THEN
- PAUSE
- TYPE *, ' Check matS2 in namelist S2'
- TYPE *, ' Program aborting'
- STOP
- ENDIF
- ENDDO
- ENDIF
- CLOSE(1)
-
- IF (nv.GT.2) THEN
-C FIND namelist S3
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&S3').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namelist S3 not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-
-C READ namelist S3
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- dynS3 = '-'
- ns3 = -1
- hypS3(:,:) = 1
- matS3(:) = '-'
- READ(1,NML=S3,END=5004,ERR=5004)
-
- IF ((dynS3.NE.'I').AND.(dynS3.NE.'M'))THEN
- TYPE *, ' Check dynS3 in namelist S3'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (ns3.LT.2) THEN
- TYPE *, ' Check ns3 in namelist S3'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (dynS3.EQ.'I') THEN
- DO J = 1,ns3
- IF (hypS3(J,1).LE.0) THEN
- TYPE *, ' Check hypS3 in namelist S3'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ELSEIF (dynS3.EQ.'M') THEN
- DO J = 1,ns3
- DO K = 1,ns3
- IF (hypS3(J,K).LE.0) THEN
- TYPE *, ' Check hypS3 in namelist S3'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-
- IF ((matS3(1).EQ.'-').OR.((matS3(1).NE.'a')
- # .AND.(matS3(1).NE.'H').AND.(matS3(1).NE.'G')
- # .AND.(matS3(1).NE.'c').AND.(matS3(1).NE.'F')
- # .AND.(matS3(1).NE.'R'))) THEN
- TYPE *, ' Check matS3 in namelist S3'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- DO I = 2,6
- IF ((matS3(I).NE.'-').AND.(matS3(I).NE.'a')
- # .AND.(matS3(I).NE.'H').AND.(matS3(I).NE.'G')
- # .AND.(matS3(I).NE.'c').AND.(matS3(I).NE.'F')
- # .AND.(matS3(I).NE.'R')) THEN
- TYPE *, ' Check matS3 in namelist S3'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDIF
- CLOSE(1)
-
- IF (nv.GT.3) THEN
-C FIND namelist S4
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&S4').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namlist S4 not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-
-C READ namelist S4
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- dynS4 = '-'
- ns4 = -1
- hypS4(:,:) = 1
- matS4(:) = '-'
- READ(1,NML=S4,END=5005,ERR=5005)
-
- IF ((dynS4.NE.'I').AND.(dynS4.NE.'M'))THEN
- TYPE *, ' Check dynS4 in namelist S4'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (ns4.LT.2) THEN
- TYPE *, ' Check ns4 in namelist S4'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (dynS4.EQ.'I') THEN
- DO J = 1,ns4
- IF (hypS4(J,1).LE.0) THEN
- TYPE *, ' Check hypS4 in namelist S4'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ELSEIF (dynS4.EQ.'M') THEN
- DO J = 1,ns4
- DO K = 1,ns4
- IF (hypS4(J,K).LE.0) THEN
- TYPE *, ' Check hypS4 in namelist S4'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-
- IF ((matS4(1).EQ.'-').OR.((matS4(1).NE.'a')
- # .AND.(matS4(1).NE.'H').AND.(matS4(1).NE.'G')
- # .AND.(matS4(1).NE.'c').AND.(matS4(1).NE.'F')
- # .AND.(matS4(1).NE.'R'))) THEN
- TYPE *, ' Check matS4 in namelist S4'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- DO I = 2,6
- IF ((matS4(I).NE.'-').AND.(matS4(I).NE.'a')
- # .AND.(matS4(I).NE.'H').AND.(matS4(I).NE.'G')
- # .AND.(matS4(I).NE.'c').AND.(matS4(I).NE.'F')
- # .AND.(matS4(I).NE.'R')) THEN
- TYPE *, ' Check matS4 in namelist S4'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDIF
- CLOSE(1)
-
- IF (nv.GT.4) THEN
-C FIND namelist S5
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&S5').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namlist S5 not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-
-C READ namelist S5
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- dynS5 = '-'
- ns5 = -1
- hypS5(:,:) = 1
- matS5(:) = '-'
- READ(1,NML=S5,END=5006,ERR=5006)
-
- IF ((dynS5.NE.'I').AND.(dynS5.NE.'M'))THEN
- TYPE *, ' Check dynS5 in namelist S5'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (ns5.LT.2) THEN
- TYPE *, ' Check ns5 in namelist S5'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (dynS5.EQ.'I') THEN
- DO J = 1,ns5
- IF (hypS5(J,1).LE.0) THEN
- TYPE *, ' Check hypS5 in namelist S5'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ELSEIF (dynS5.EQ.'M') THEN
- DO J = 1,ns5
- DO K = 1,ns5
- IF (hypS5(J,K).LE.0) THEN
- TYPE *, ' Check hypS5 in namelist S5'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-
- IF ((matS5(1).EQ.'-').OR.((matS5(1).NE.'a')
- # .AND.(matS5(1).NE.'H').AND.(matS5(1).NE.'G')
- # .AND.(matS5(1).NE.'c').AND.(matS5(1).NE.'F')
- # .AND.(matS5(1).NE.'R'))) THEN
- TYPE *, ' Check matS5 in namelist S5'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- DO I = 2,6
- IF ((matS5(I).NE.'-').AND.(matS5(I).NE.'a')
- # .AND.(matS5(I).NE.'H').AND.(matS5(I).NE.'G')
- # .AND.(matS5(I).NE.'c').AND.(matS5(I).NE.'F')
- # .AND.(matS5(I).NE.'R')) THEN
- TYPE *, ' Check matS5 in namelist S5'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDIF
- CLOSE(1)
-
- IF (nv.GT.5) THEN
-C FIND namelist S6
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&S6').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namlist S6 not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-
-C READ namelist S6
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- dynS6 = '-'
- ns6 = -1
- hypS6(:,:) = 1
- matS6(:) = '-'
- READ(1,NML=S6,END=5007,ERR=5007)
-
- IF ((dynS6.NE.'I').AND.(dynS6.NE.'M'))THEN
- TYPE *, ' Check dynS6 in namelist S6'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (ns6.LT.2) THEN
- TYPE *, ' Check ns6 in namelist S6'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
- IF (dynS6.EQ.'I') THEN
- DO J = 1,ns6
- IF (hypS6(J,1).LE.0) THEN
- TYPE *, ' Check hypS6 in namelist S6'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ELSEIF (dynS6.EQ.'M') THEN
- DO J = 1,ns6
- DO K = 1,ns6
- IF (hypS6(J,K).LE.0) THEN
- TYPE *, ' Check hypS6 in namelist S6'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-
- IF ((matS6(1).EQ.'-').OR.((matS6(1).NE.'a')
- # .AND.(matS6(1).NE.'H').AND.(matS6(1).NE.'G')
- # .AND.(matS6(1).NE.'c').AND.(matS6(1).NE.'F')
- # .AND.(matS6(1).NE.'R'))) THEN
- TYPE *, ' Check matS6 in namelist S6'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- DO I = 2,6
- IF ((matS6(I).NE.'-').AND.(matS6(I).NE.'a')
- # .AND.(matS6(I).NE.'H').AND.(matS6(I).NE.'G')
- # .AND.(matS6(I).NE.'c').AND.(matS6(I).NE.'F')
- # .AND.(matS6(I).NE.'R')) THEN
- TYPE *, ' Check matS6 in namelist S6'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDIF
- CLOSE(1)
-
-C FIND namelist prior
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&prior').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namelist prior not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-C READ namelist prior
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- nt = 0
- pdftheta(:) = ' '
- hyptheta(:,:) = -1
- READ(1,NML = prior,END=5008,ERR=5008)
- IF (nt.LE.0) THEN
- TYPE *, ' Check nt in namelist prior'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (nt.GT.200) THEN
- TYPE *, ' nt is too large '
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (estimation.EQ.'BA') THEN
- DO I = 1,nt
- WRITE(IC,'(I3)') I
- IF ((pdftheta(I).NE.'BE').AND.(pdftheta(I).NE.'NT').AND.
- # (pdftheta(I).NE.'IG')) THEN
- TYPE *, ' Check pdftheta('//IC//') in namelist prior'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (hyptheta(3,I).GT.hyptheta(4,I)) THEN
- TYPE *, ' Check hyptheta('//IC//') in namelist prior'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (pdftheta(I).EQ.'BE') THEN
- IF (hyptheta(3,I).LT.hyptheta(4,I)) THEN
- IF ((hyptheta(1,I).LE.0.).OR.(hyptheta(2,I).LE.0.).OR.
- # (hyptheta(3,I).GT.hyptheta(4,I))) THEN
- TYPE *, ' Check hyptheta('//IC//') in namelist prior'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDIF
- ELSEIF (pdftheta(I).EQ.'NT') THEN
- IF (hyptheta(3,I).LT.hyptheta(4,I)) THEN
- IF ((hyptheta(2,I).LE.0.).OR.(hyptheta(3,I).GT.hyptheta(4,I)))
- # THEN
- TYPE *, ' Check hyptheta('//IC//') in namelist prior'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDIF
- ELSEIF (pdftheta(I).EQ.'IG') THEN
- IF (hyptheta(3,I).LT.hyptheta(4,I)) THEN
- IF ((hyptheta(1,I).LE.0.).OR.(hyptheta(2,I).LE.0.).OR.
- # (hyptheta(3,I).GT.hyptheta(4,I)).OR.(hyptheta(3,I).LT.0.))THEN
- TYPE *, ' Check hyptheta('//IC//') in namelist prior'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDIF
- ENDIF
- ENDDO
- ELSE
- DO I = 1,nt ! ML check
- WRITE(IC,'(I3)') I
- IF (hyptheta(3,I).GT.hyptheta(4,I)) THEN
- TYPE *, ' Check hyptheta('//IC//') in namelist prior'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
- ENDIF
- CLOSE(1)
-
-C FIND namelist mcmc
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&mcmc').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namelist mcmc not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-
-C READ namelist mcmc
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- seed = 0
- thin = 1
- burnin = 1000
- simulrec = 5000
- sampler = 'SL'
- Ssampler = 'GCK'
- hbl = 1
- MargLik = 'N'
- READ(1,NML=mcmc,END=5009,ERR=5009)
- IF ((seed.LT.0).OR.(seed.GT.999)) THEN
- TYPE *, ' Check seed in namelist mcmc'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (thin.LT.1) THEN
- TYPE *, ' Check thin in namelist mcmc'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (burnin.LE.0) THEN
- TYPE *, ' Check burnin in namelist mcmc'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (simulrec.LE.1) THEN
- TYPE *, ' Check simulrec in namelist mcmc'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF ((sampler.NE.'SL').AND.(sampler.NE.'MH')) THEN
- TYPE *, ' Check sampler in namelist mcmc'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
-c IF ((Ssampler.NE.'GCK').AND.(Ssampler.NE.'AMH')
-c # .AND.(Ssampler.NE.'MH ')) THEN
-c TYPE *, ' Check Ssampler in namelist mcmc'
-c TYPE *, ' Program aborting'
-c PAUSE
-c STOP
-c ENDIF
-c IF ((hbl.GT.1).AND.(Ssampler.EQ.'GCK')) THEN
-c TYPE *, ' Check hbl in namelist mcmc'
-c TYPE *, ' Program aborting'
-c PAUSE
-c STOP
-c ENDIF
-
- CLOSE(1)
-
-C FIND namelist dataset
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- IFAIL = -1
- DO WHILE (.NOT.EOF(1))
- READ(1,'(A)') STR
- IF (INDEX(STR,'&dataset').GT.0) IFAIL = 0
- ENDDO
- CLOSE(1)
- IF (IFAIL.EQ.-1) THEN
- TYPE *, ' Namelist dataset not found'
- TYPE *, ' Program aborting'
- PAUSE
- RETURN
- ENDIF
-C READ namelist dataset
- OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
- ny = -1
- nz = -1
- nf = 0
- datasim = 'N'
- READ(1,NML=dataset,END=5010,ERR=5010)
- IF ((T.LE.0).OR.(T.GT.3000)) THEN
- TYPE *, ' Check T in namelist dataset (T<=3000)'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (ny.LE.0) THEN
- TYPE *, ' Check ny in namelist dataset'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (nz.LT.0) THEN
- TYPE *, ' Check nz in namelist dataset'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (nf.LT.0) THEN
- TYPE *, ' Check nf in namelist dataset'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF (T.LT.hbl) THEN
- TYPE *, ' Check hbl in namelist mcmc (hbl > T)'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- IF ((datasim.NE.'N').AND.(datasim.NE.'n').AND.
- & (datasim.NE.'y').AND.(datasim.NE.'Y')) THEN
- datasim = 'N'
- ENDIF
-
- CLOSE(1)
-
-C -----------------------------------------------------------------------
-C ASSIGN discrete latent variables: INFOS (9 x nv)
-C by cols: S1,S2,...,SNV; with nv <=6
-C by row: the 1st contains the # of matrices affected by Si
-C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
-C the 8-th row contains the # of states
-C the 9-th row spec. the dynamic of Sj (0-deterministic,1=Indep,2=Markov)
-C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
-C np(1): total # of psi parameters
-C np(2): total # of idependent PSI-Dirichlet vectors
-C np(3): max # of hyperparameters for psi
-C -----------------------------------------------------------------------
- INFOS(:,:) = 0
- INFOS(8,:) = 1 ! number of states
- ns(:) = 1
- np(:) = 0
- IF (nv.GT.0) THEN
- ALLOCATE(matS(6,6),dynS(6),nstateS(6))
- matS(:,1) = matS1(:)
- matS(:,2) = matS2(:)
- matS(:,3) = matS3(:)
- matS(:,4) = matS4(:)
- matS(:,5) = matS5(:)
- matS(:,6) = matS6(:)
- hypS(:,:,1) = hypS1(:,:)
- hypS(:,:,2) = hypS2(:,:)
- hypS(:,:,3) = hypS3(:,:)
- hypS(:,:,4) = hypS4(:,:)
- hypS(:,:,5) = hypS5(:,:)
- hypS(:,:,6) = hypS6(:,:)
- dynS(1) = dynS1
- dynS(2) = dynS2
- dynS(3) = dynS3
- dynS(4) = dynS4
- dynS(5) = dynS5
- dynS(6) = dynS6
- nstateS(1) = ns1
- nstateS(2) = ns2
- nstateS(3) = ns3
- nstateS(4) = ns4
- nstateS(5) = ns5
- nstateS(6) = ns6
- IMAX = MAXLOC(nstateS(1:nv))
- np(2) = 0
- np(3) = nstateS(IMAX(1))
- DO 50 J = 1,nv
- K = 0
- DO 40 I = 1,6
- IF(matS(I,J).EQ.'c') THEN
- K = K + 1
- IND = 1
- INFOS(K+1,J) = IND ! Matrices affected by SJ
- ENDIF
- IF(matS(I,J).EQ.'H') THEN
- K = K + 1
- IND = 2
- INFOS(K+1,J) = IND
- ENDIF
- IF(matS(I,J).EQ.'G') THEN
- K = K + 1
- IND = 3
- INFOS(K+1,J) = IND
- ENDIF
- IF(matS(I,J).EQ.'a') THEN
- K = K + 1
- IND = 4
- INFOS(K+1,J) = IND
- ENDIF
- IF(matS(I,J).EQ.'F') THEN
- K = K + 1
- IND = 5
- INFOS(K+1,J) = IND
- ENDIF
- IF(matS(I,J).EQ.'R') THEN
- K = K + 1
- IND = 6
- INFOS(K+1,J) = IND
- ENDIF
-40 CONTINUE
- INFOS(1,J) = K ! # of matrix affected by SJ
- INFOS(8,J) = nstateS(J) ! # of states for SJ
- IF (dynS(J).EQ.'I') THEN
- INFOS(9,J) = 1 ! dynamics for Sj
- np(2) = np(2) + 1
- np(1) = np(1) + nstateS(J)-1
- ELSEIF (dynS(J).EQ.'M') THEN
- INFOS(9,J) = 2
- np(2) = np(2) + nstateS(J)
- np(1) = np(1) + (nstateS(J)-1)*nstateS(J)
- ENDIF
-50 CONTINUE
-
- DO 60 I = 1,nv
- DO 60 J = 1,INFOS(1,I)
-60 ns(INFOS(J+1,I)) = INFOS(8,I)
- nstot = PRODUCT(INFOS(8,1:nv)) ! total # of states
-
- DEALLOCATE(matS,dynS,nstateS)
- ENDIF
-
- GO TO 7777
-
-5000 TYPE *,'Input file not found'
- TYPE *,'Program aborting'
- PAUSE
- STOP
-
-5001 TYPE *,'Input error in namelist ssm'
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5002 TYPE *,'Input error in namelist S1 '
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5003 TYPE *,'Input error in namelist S2 '
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5004 TYPE *,'Input error in namelist S3 '
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5005 TYPE *,'Input error in namelist S4 '
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5006 TYPE *,'Input error in namelist S5 '
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5007 TYPE *,'Input error in namelist S6 '
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5008 TYPE *,'Input error in namelist prior'
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5009 TYPE *,'Input error in namelist mcmc'
- TYPE *,'Program aborting'
- PAUSE
- STOP
-5010 TYPE *,'Input error in namelist dataset'
- TYPE *,'Program aborting'
- PAUSE
- STOP
-
-7777 RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -----------------------------------------------------------------------
+ SUBROUTINE input(FILEIN,NMLNAME,PATH,ny,nz,nx,nu,d,nv,ns,
+ 1 nstot,np,nf,INFOS,seed,thin,burnin,simulrec,sampler,
+ 2 datasim,dllname,check,estimation,nt,pdftheta,hyptheta,
+ 3 hypS,T,obs,Ssampler,hbl,MargLik)
+
+C INCLUDE 'iosdef.for'
+ INTEGER IERR
+C INPUT
+ CHARACTER*200 FILEIN
+C OUTPUT
+ NAMELIST /ssm/ nx,nu,d,nv,dllname,check,estimation
+ INTEGER nx,nu,d(2),nv
+ CHARACTER*200 dllname
+ CHARACTER*1 check
+ CHARACTER*2 estimation
+
+ NAMELIST /S1/ dynS1,matS1,ns1,hypS1
+ NAMELIST /S2/ dynS2,matS2,ns2,hypS2
+ NAMELIST /S3/ dynS3,matS3,ns3,hypS3
+ NAMELIST /S4/ dynS4,matS4,ns4,hypS4
+ NAMELIST /S5/ dynS5,matS5,ns5,hypS5
+ NAMELIST /S6/ dynS6,matS6,ns6,hypS6
+ CHARACTER*1 dynS1,dynS2,dynS3,dynS4,dynS5,dynS6,
+ 1 matS1(6),matS2(6),matS3(6),matS4(6),matS5(6),matS6(6)
+ INTEGER ns1,ns2,ns3,ns4,ns5,ns6
+ DOUBLE PRECISION hypS1(50,50),hypS2(50,50),hypS3(50,50),
+ 1 hypS4(50,50),hypS5(50,50),hypS6(50,50),hypS(50,50,6)
+
+ NAMELIST /mcmc/ seed,thin,burnin,simulrec,sampler,
+ 1 Ssampler,hbl,marglik
+ INTEGER seed,thin,burnin,simulrec,hbl
+ CHARACTER*1 MargLik
+ CHARACTER*2 sampler
+ CHARACTER*3 Ssampler
+
+ NAMELIST /prior/ nt,pdftheta,hyptheta
+ INTEGER nt
+ DOUBLE PRECISION hyptheta(4,200)
+ CHARACTER*2 pdftheta(200)
+
+ NAMELIST /dataset/ T,ny,nz,nf,datasim,obs
+ INTEGER T,ny,nz,nf
+ DOUBLE PRECISION obs(30000)
+ CHARACTER*1 datasim
+
+C OUTPUT not in the namelist
+ INTEGER ns(6),INFOS(9,6),IMAX(1),np(3),nstot,IND
+ CHARACTER*200 NMLNAME,PATH
+
+C LOCALS
+ CHARACTER*3 IC
+ CHARACTER*200 STR
+ INTEGER I,J,K,IFAIL
+ INTEGER, ALLOCATABLE:: nstateS(:)
+ CHARACTER*1, ALLOCATABLE:: matS(:,:),dynS(:)
+
+C IDENTIFY the PATH and NAME of the .NML INPUT FILE
+ I = SCAN(FILEIN,'\', BACK = .TRUE.)
+ IF((I.LE.0).OR.(I.GE.200)) THEN
+ NMLNAME = FILEIN
+ PATH = ''
+ ELSE
+ NMLNAME = FILEIN(I+1:200)
+ PATH = FILEIN(1:I)
+ ENDIF
+ I = SCAN(NMLNAME,'.', BACK = .TRUE.)
+ NMLNAME = NMLNAME(1:I-1)
+
+C FIND namelist ssm
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL',
+ 1 STATUS='OLD',IOSTAT=IERR, ERR=5000)
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&ssm').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namelist ssm not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+
+C READ namelist ssm
+ ns1=0
+ ns2=0
+ ns3=0
+ ns4=0
+ ns5=0
+ ns6=0
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ nx = -1
+ nu = -1
+ d(:) = -1
+ nv = 0
+ dllname = ''
+ check = 'N'
+ estimation = 'BA'
+ READ(1,NML=ssm,END=5001,ERR=5001)
+ IF (nx.LE.0) THEN
+ TYPE *, ' Check nx in namelist ssm'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF(nu.LE.0) THEN
+ TYPE *, ' Check nu in namelist ssm'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF((d(1).LT.0).OR.(d(2).LT.0).OR.(d(2).GT.nx)) THEN
+ TYPE *, ' Check d in namelist ssm'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF((nv.LT.0).OR.(nv.GT.6)) THEN
+ TYPE *, ' Check nv in namelist ssm'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF(dllname.EQ.'') THEN
+ TYPE *, ' Check dllname in namelist ssm'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ CLOSE(1)
+ IF ((estimation.NE.'ML').AND.(estimation.NE.'ml').AND.
+ & (estimation.NE.'Ml').AND.(estimation.NE.'mL').AND.
+ & (estimation.NE.'BA').AND.(estimation.NE.'ba').AND.
+ & (estimation.NE.'Ba').AND.(estimation.NE.'bA')) THEN
+ estimation = 'BA'
+ ENDIF
+
+ IF (nv.GT.0) THEN
+C FIND namelist S1
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&S1').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namelist S1 not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+
+C READ namelist S1
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ dynS1 = '-'
+ ns1 = -1
+ hypS1(:,:) = 1
+ matS1(:) = '-'
+ READ(1,NML=S1,END=5002,ERR=5002)
+
+ IF ((dynS1.NE.'I').AND.(dynS1.NE.'M'))THEN
+ TYPE *, ' Check dynS1 in namelist S1'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (ns1.LT.2) THEN
+ TYPE *, ' Check ns1 in namelist S1'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (dynS1.EQ.'I') THEN
+ DO J = 1,ns1
+ IF (hypS1(J,1).LE.0) THEN
+ TYPE *, ' Check hypS1 in namelist S1'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ELSEIF (dynS1.EQ.'M') THEN
+ DO J = 1,ns1
+ DO K = 1,ns1
+ IF (hypS1(J,K).LE.0) THEN
+ TYPE *, ' Check hypS1 in namelist S1'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF ((matS1(1).EQ.'-').OR.((matS1(1).NE.'a')
+ # .AND.(matS1(1).NE.'H').AND.(matS1(1).NE.'G')
+ # .AND.(matS1(1).NE.'c').AND.(matS1(1).NE.'F')
+ # .AND.(matS1(1).NE.'R'))) THEN
+ TYPE *, ' Check matS1 in namelist S1'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ DO I = 2,6
+ IF ((matS1(I).NE.'-').AND.(matS1(I).NE.'a')
+ # .AND.(matS1(I).NE.'H').AND.(matS1(I).NE.'G')
+ # .AND.(matS1(I).NE.'c').AND.(matS1(I).NE.'F')
+ # .AND.(matS1(I).NE.'R')) THEN
+ TYPE *, ' Check matS1 in namelist S1'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(1)
+
+ IF (nv.GT.1) THEN
+C FIND namelist S2
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&S2').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namelist S2 not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+C READ namelist S2
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ dynS2 = '-'
+ ns2 = -1
+ hypS2(:,:) = 1 ! Uniform
+ matS2(:) = '-'
+ READ(1,NML=S2,END=5003,ERR=5003)
+
+ IF ((dynS2.NE.'I').AND.(dynS2.NE.'M'))THEN
+ TYPE *, ' Check dynS2 in namelist S2'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (ns2.LT.2) THEN
+ TYPE *, ' Check ns2 in namelist S2'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (dynS2.EQ.'I') THEN
+ DO J = 1,ns2
+ IF (hypS2(J,1).LE.0) THEN
+ TYPE *, ' Check hypS2 in namelist S2'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ELSEIF (dynS2.EQ.'M') THEN
+ DO J = 1,ns2
+ DO K = 1,ns2
+ IF (hypS2(J,K).LE.0) THEN
+ TYPE *, ' Check hypS2 in namelist S2'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ I = 1
+ IF ((matS2(I).EQ.'-').OR.((matS2(I).NE.'a')
+ # .AND.(matS2(I).NE.'H').AND.(matS2(I).NE.'G')
+ # .AND.(matS2(I).NE.'c').AND.(matS2(I).NE.'F')
+ # .AND.(matS2(I).NE.'R'))) THEN
+ TYPE *, ' Check matS2 in namelist S2'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ DO I = 2,6
+ IF ((matS2(I).NE.'-').AND.(matS2(I).NE.'a')
+ # .AND.(matS2(I).NE.'H').AND.(matS2(I).NE.'G')
+ # .AND.(matS2(I).NE.'c').AND.(matS2(I).NE.'F')
+ # .AND.(matS2(I).NE.'R')) THEN
+ PAUSE
+ TYPE *, ' Check matS2 in namelist S2'
+ TYPE *, ' Program aborting'
+ STOP
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(1)
+
+ IF (nv.GT.2) THEN
+C FIND namelist S3
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&S3').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namelist S3 not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+
+C READ namelist S3
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ dynS3 = '-'
+ ns3 = -1
+ hypS3(:,:) = 1
+ matS3(:) = '-'
+ READ(1,NML=S3,END=5004,ERR=5004)
+
+ IF ((dynS3.NE.'I').AND.(dynS3.NE.'M'))THEN
+ TYPE *, ' Check dynS3 in namelist S3'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (ns3.LT.2) THEN
+ TYPE *, ' Check ns3 in namelist S3'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (dynS3.EQ.'I') THEN
+ DO J = 1,ns3
+ IF (hypS3(J,1).LE.0) THEN
+ TYPE *, ' Check hypS3 in namelist S3'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ELSEIF (dynS3.EQ.'M') THEN
+ DO J = 1,ns3
+ DO K = 1,ns3
+ IF (hypS3(J,K).LE.0) THEN
+ TYPE *, ' Check hypS3 in namelist S3'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF ((matS3(1).EQ.'-').OR.((matS3(1).NE.'a')
+ # .AND.(matS3(1).NE.'H').AND.(matS3(1).NE.'G')
+ # .AND.(matS3(1).NE.'c').AND.(matS3(1).NE.'F')
+ # .AND.(matS3(1).NE.'R'))) THEN
+ TYPE *, ' Check matS3 in namelist S3'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ DO I = 2,6
+ IF ((matS3(I).NE.'-').AND.(matS3(I).NE.'a')
+ # .AND.(matS3(I).NE.'H').AND.(matS3(I).NE.'G')
+ # .AND.(matS3(I).NE.'c').AND.(matS3(I).NE.'F')
+ # .AND.(matS3(I).NE.'R')) THEN
+ TYPE *, ' Check matS3 in namelist S3'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(1)
+
+ IF (nv.GT.3) THEN
+C FIND namelist S4
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&S4').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namlist S4 not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+
+C READ namelist S4
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ dynS4 = '-'
+ ns4 = -1
+ hypS4(:,:) = 1
+ matS4(:) = '-'
+ READ(1,NML=S4,END=5005,ERR=5005)
+
+ IF ((dynS4.NE.'I').AND.(dynS4.NE.'M'))THEN
+ TYPE *, ' Check dynS4 in namelist S4'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (ns4.LT.2) THEN
+ TYPE *, ' Check ns4 in namelist S4'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (dynS4.EQ.'I') THEN
+ DO J = 1,ns4
+ IF (hypS4(J,1).LE.0) THEN
+ TYPE *, ' Check hypS4 in namelist S4'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ELSEIF (dynS4.EQ.'M') THEN
+ DO J = 1,ns4
+ DO K = 1,ns4
+ IF (hypS4(J,K).LE.0) THEN
+ TYPE *, ' Check hypS4 in namelist S4'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF ((matS4(1).EQ.'-').OR.((matS4(1).NE.'a')
+ # .AND.(matS4(1).NE.'H').AND.(matS4(1).NE.'G')
+ # .AND.(matS4(1).NE.'c').AND.(matS4(1).NE.'F')
+ # .AND.(matS4(1).NE.'R'))) THEN
+ TYPE *, ' Check matS4 in namelist S4'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ DO I = 2,6
+ IF ((matS4(I).NE.'-').AND.(matS4(I).NE.'a')
+ # .AND.(matS4(I).NE.'H').AND.(matS4(I).NE.'G')
+ # .AND.(matS4(I).NE.'c').AND.(matS4(I).NE.'F')
+ # .AND.(matS4(I).NE.'R')) THEN
+ TYPE *, ' Check matS4 in namelist S4'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(1)
+
+ IF (nv.GT.4) THEN
+C FIND namelist S5
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&S5').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namlist S5 not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+
+C READ namelist S5
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ dynS5 = '-'
+ ns5 = -1
+ hypS5(:,:) = 1
+ matS5(:) = '-'
+ READ(1,NML=S5,END=5006,ERR=5006)
+
+ IF ((dynS5.NE.'I').AND.(dynS5.NE.'M'))THEN
+ TYPE *, ' Check dynS5 in namelist S5'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (ns5.LT.2) THEN
+ TYPE *, ' Check ns5 in namelist S5'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (dynS5.EQ.'I') THEN
+ DO J = 1,ns5
+ IF (hypS5(J,1).LE.0) THEN
+ TYPE *, ' Check hypS5 in namelist S5'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ELSEIF (dynS5.EQ.'M') THEN
+ DO J = 1,ns5
+ DO K = 1,ns5
+ IF (hypS5(J,K).LE.0) THEN
+ TYPE *, ' Check hypS5 in namelist S5'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF ((matS5(1).EQ.'-').OR.((matS5(1).NE.'a')
+ # .AND.(matS5(1).NE.'H').AND.(matS5(1).NE.'G')
+ # .AND.(matS5(1).NE.'c').AND.(matS5(1).NE.'F')
+ # .AND.(matS5(1).NE.'R'))) THEN
+ TYPE *, ' Check matS5 in namelist S5'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ DO I = 2,6
+ IF ((matS5(I).NE.'-').AND.(matS5(I).NE.'a')
+ # .AND.(matS5(I).NE.'H').AND.(matS5(I).NE.'G')
+ # .AND.(matS5(I).NE.'c').AND.(matS5(I).NE.'F')
+ # .AND.(matS5(I).NE.'R')) THEN
+ TYPE *, ' Check matS5 in namelist S5'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(1)
+
+ IF (nv.GT.5) THEN
+C FIND namelist S6
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&S6').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namlist S6 not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+
+C READ namelist S6
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ dynS6 = '-'
+ ns6 = -1
+ hypS6(:,:) = 1
+ matS6(:) = '-'
+ READ(1,NML=S6,END=5007,ERR=5007)
+
+ IF ((dynS6.NE.'I').AND.(dynS6.NE.'M'))THEN
+ TYPE *, ' Check dynS6 in namelist S6'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (ns6.LT.2) THEN
+ TYPE *, ' Check ns6 in namelist S6'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+ IF (dynS6.EQ.'I') THEN
+ DO J = 1,ns6
+ IF (hypS6(J,1).LE.0) THEN
+ TYPE *, ' Check hypS6 in namelist S6'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ELSEIF (dynS6.EQ.'M') THEN
+ DO J = 1,ns6
+ DO K = 1,ns6
+ IF (hypS6(J,K).LE.0) THEN
+ TYPE *, ' Check hypS6 in namelist S6'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF ((matS6(1).EQ.'-').OR.((matS6(1).NE.'a')
+ # .AND.(matS6(1).NE.'H').AND.(matS6(1).NE.'G')
+ # .AND.(matS6(1).NE.'c').AND.(matS6(1).NE.'F')
+ # .AND.(matS6(1).NE.'R'))) THEN
+ TYPE *, ' Check matS6 in namelist S6'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ DO I = 2,6
+ IF ((matS6(I).NE.'-').AND.(matS6(I).NE.'a')
+ # .AND.(matS6(I).NE.'H').AND.(matS6(I).NE.'G')
+ # .AND.(matS6(I).NE.'c').AND.(matS6(I).NE.'F')
+ # .AND.(matS6(I).NE.'R')) THEN
+ TYPE *, ' Check matS6 in namelist S6'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(1)
+
+C FIND namelist prior
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&prior').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namelist prior not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+C READ namelist prior
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ nt = 0
+ pdftheta(:) = ' '
+ hyptheta(:,:) = -1
+ READ(1,NML = prior,END=5008,ERR=5008)
+ IF (nt.LE.0) THEN
+ TYPE *, ' Check nt in namelist prior'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (nt.GT.200) THEN
+ TYPE *, ' nt is too large '
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (estimation.EQ.'BA') THEN
+ DO I = 1,nt
+ WRITE(IC,'(I3)') I
+ IF ((pdftheta(I).NE.'BE').AND.(pdftheta(I).NE.'NT').AND.
+ # (pdftheta(I).NE.'IG')) THEN
+ TYPE *, ' Check pdftheta('//IC//') in namelist prior'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (hyptheta(3,I).GT.hyptheta(4,I)) THEN
+ TYPE *, ' Check hyptheta('//IC//') in namelist prior'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (pdftheta(I).EQ.'BE') THEN
+ IF (hyptheta(3,I).LT.hyptheta(4,I)) THEN
+ IF ((hyptheta(1,I).LE.0.).OR.(hyptheta(2,I).LE.0.).OR.
+ # (hyptheta(3,I).GT.hyptheta(4,I))) THEN
+ TYPE *, ' Check hyptheta('//IC//') in namelist prior'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDIF
+ ELSEIF (pdftheta(I).EQ.'NT') THEN
+ IF (hyptheta(3,I).LT.hyptheta(4,I)) THEN
+ IF ((hyptheta(2,I).LE.0.).OR.(hyptheta(3,I).GT.hyptheta(4,I)))
+ # THEN
+ TYPE *, ' Check hyptheta('//IC//') in namelist prior'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDIF
+ ELSEIF (pdftheta(I).EQ.'IG') THEN
+ IF (hyptheta(3,I).LT.hyptheta(4,I)) THEN
+ IF ((hyptheta(1,I).LE.0.).OR.(hyptheta(2,I).LE.0.).OR.
+ # (hyptheta(3,I).GT.hyptheta(4,I)).OR.(hyptheta(3,I).LT.0.))THEN
+ TYPE *, ' Check hyptheta('//IC//') in namelist prior'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSE
+ DO I = 1,nt ! ML check
+ WRITE(IC,'(I3)') I
+ IF (hyptheta(3,I).GT.hyptheta(4,I)) THEN
+ TYPE *, ' Check hyptheta('//IC//') in namelist prior'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(1)
+
+C FIND namelist mcmc
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&mcmc').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namelist mcmc not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+
+C READ namelist mcmc
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ seed = 0
+ thin = 1
+ burnin = 1000
+ simulrec = 5000
+ sampler = 'SL'
+ Ssampler = 'GCK'
+ hbl = 1
+ MargLik = 'N'
+ READ(1,NML=mcmc,END=5009,ERR=5009)
+ IF ((seed.LT.0).OR.(seed.GT.999)) THEN
+ TYPE *, ' Check seed in namelist mcmc'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (thin.LT.1) THEN
+ TYPE *, ' Check thin in namelist mcmc'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (burnin.LE.0) THEN
+ TYPE *, ' Check burnin in namelist mcmc'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (simulrec.LE.1) THEN
+ TYPE *, ' Check simulrec in namelist mcmc'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF ((sampler.NE.'SL').AND.(sampler.NE.'MH')) THEN
+ TYPE *, ' Check sampler in namelist mcmc'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+c IF ((Ssampler.NE.'GCK').AND.(Ssampler.NE.'AMH')
+c # .AND.(Ssampler.NE.'MH ')) THEN
+c TYPE *, ' Check Ssampler in namelist mcmc'
+c TYPE *, ' Program aborting'
+c PAUSE
+c STOP
+c ENDIF
+c IF ((hbl.GT.1).AND.(Ssampler.EQ.'GCK')) THEN
+c TYPE *, ' Check hbl in namelist mcmc'
+c TYPE *, ' Program aborting'
+c PAUSE
+c STOP
+c ENDIF
+
+ CLOSE(1)
+
+C FIND namelist dataset
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ IFAIL = -1
+ DO WHILE (.NOT.EOF(1))
+ READ(1,'(A)') STR
+ IF (INDEX(STR,'&dataset').GT.0) IFAIL = 0
+ ENDDO
+ CLOSE(1)
+ IF (IFAIL.EQ.-1) THEN
+ TYPE *, ' Namelist dataset not found'
+ TYPE *, ' Program aborting'
+ PAUSE
+ RETURN
+ ENDIF
+C READ namelist dataset
+ OPEN(1,File=TRIM(FILEIN), ACCESS='SEQUENTIAL')
+ ny = -1
+ nz = -1
+ nf = 0
+ datasim = 'N'
+ READ(1,NML=dataset,END=5010,ERR=5010)
+ IF ((T.LE.0).OR.(T.GT.3000)) THEN
+ TYPE *, ' Check T in namelist dataset (T<=3000)'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (ny.LE.0) THEN
+ TYPE *, ' Check ny in namelist dataset'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (nz.LT.0) THEN
+ TYPE *, ' Check nz in namelist dataset'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (nf.LT.0) THEN
+ TYPE *, ' Check nf in namelist dataset'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF (T.LT.hbl) THEN
+ TYPE *, ' Check hbl in namelist mcmc (hbl > T)'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ IF ((datasim.NE.'N').AND.(datasim.NE.'n').AND.
+ & (datasim.NE.'y').AND.(datasim.NE.'Y')) THEN
+ datasim = 'N'
+ ENDIF
+
+ CLOSE(1)
+
+C -----------------------------------------------------------------------
+C ASSIGN discrete latent variables: INFOS (9 x nv)
+C by cols: S1,S2,...,SNV; with nv <=6
+C by row: the 1st contains the # of matrices affected by Si
+C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
+C the 8-th row contains the # of states
+C the 9-th row spec. the dynamic of Sj (0-deterministic,1=Indep,2=Markov)
+C nstot: total # of states i.e. ns1 x ns2 x ...x nsv
+C np(1): total # of psi parameters
+C np(2): total # of idependent PSI-Dirichlet vectors
+C np(3): max # of hyperparameters for psi
+C -----------------------------------------------------------------------
+ INFOS(:,:) = 0
+ INFOS(8,:) = 1 ! number of states
+ ns(:) = 1
+ np(:) = 0
+ IF (nv.GT.0) THEN
+ ALLOCATE(matS(6,6),dynS(6),nstateS(6))
+ matS(:,1) = matS1(:)
+ matS(:,2) = matS2(:)
+ matS(:,3) = matS3(:)
+ matS(:,4) = matS4(:)
+ matS(:,5) = matS5(:)
+ matS(:,6) = matS6(:)
+ hypS(:,:,1) = hypS1(:,:)
+ hypS(:,:,2) = hypS2(:,:)
+ hypS(:,:,3) = hypS3(:,:)
+ hypS(:,:,4) = hypS4(:,:)
+ hypS(:,:,5) = hypS5(:,:)
+ hypS(:,:,6) = hypS6(:,:)
+ dynS(1) = dynS1
+ dynS(2) = dynS2
+ dynS(3) = dynS3
+ dynS(4) = dynS4
+ dynS(5) = dynS5
+ dynS(6) = dynS6
+ nstateS(1) = ns1
+ nstateS(2) = ns2
+ nstateS(3) = ns3
+ nstateS(4) = ns4
+ nstateS(5) = ns5
+ nstateS(6) = ns6
+ IMAX = MAXLOC(nstateS(1:nv))
+ np(2) = 0
+ np(3) = nstateS(IMAX(1))
+ DO 50 J = 1,nv
+ K = 0
+ DO 40 I = 1,6
+ IF(matS(I,J).EQ.'c') THEN
+ K = K + 1
+ IND = 1
+ INFOS(K+1,J) = IND ! Matrices affected by SJ
+ ENDIF
+ IF(matS(I,J).EQ.'H') THEN
+ K = K + 1
+ IND = 2
+ INFOS(K+1,J) = IND
+ ENDIF
+ IF(matS(I,J).EQ.'G') THEN
+ K = K + 1
+ IND = 3
+ INFOS(K+1,J) = IND
+ ENDIF
+ IF(matS(I,J).EQ.'a') THEN
+ K = K + 1
+ IND = 4
+ INFOS(K+1,J) = IND
+ ENDIF
+ IF(matS(I,J).EQ.'F') THEN
+ K = K + 1
+ IND = 5
+ INFOS(K+1,J) = IND
+ ENDIF
+ IF(matS(I,J).EQ.'R') THEN
+ K = K + 1
+ IND = 6
+ INFOS(K+1,J) = IND
+ ENDIF
+40 CONTINUE
+ INFOS(1,J) = K ! # of matrix affected by SJ
+ INFOS(8,J) = nstateS(J) ! # of states for SJ
+ IF (dynS(J).EQ.'I') THEN
+ INFOS(9,J) = 1 ! dynamics for Sj
+ np(2) = np(2) + 1
+ np(1) = np(1) + nstateS(J)-1
+ ELSEIF (dynS(J).EQ.'M') THEN
+ INFOS(9,J) = 2
+ np(2) = np(2) + nstateS(J)
+ np(1) = np(1) + (nstateS(J)-1)*nstateS(J)
+ ENDIF
+50 CONTINUE
+
+ DO 60 I = 1,nv
+ DO 60 J = 1,INFOS(1,I)
+60 ns(INFOS(J+1,I)) = INFOS(8,I)
+ nstot = PRODUCT(INFOS(8,1:nv)) ! total # of states
+
+ DEALLOCATE(matS,dynS,nstateS)
+ ENDIF
+
+ GO TO 7777
+
+5000 TYPE *,'Input file not found'
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+
+5001 TYPE *,'Input error in namelist ssm'
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5002 TYPE *,'Input error in namelist S1 '
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5003 TYPE *,'Input error in namelist S2 '
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5004 TYPE *,'Input error in namelist S3 '
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5005 TYPE *,'Input error in namelist S4 '
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5006 TYPE *,'Input error in namelist S5 '
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5007 TYPE *,'Input error in namelist S6 '
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5008 TYPE *,'Input error in namelist prior'
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5009 TYPE *,'Input error in namelist mcmc'
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+5010 TYPE *,'Input error in namelist dataset'
+ TYPE *,'Program aborting'
+ PAUSE
+ STOP
+
+7777 RETURN
END
diff --git a/int2seq.for b/int2seq.for
index d7038bf139398ef9b6f58ab9b5f658ab091cb268..a1df49a636bc7a9ade5e22f23f7530c28d549513 100644
--- a/int2seq.for
+++ b/int2seq.for
@@ -1,18 +1,18 @@
-C ------------------------------------------------------------
-C INT2SEQ converts integers into the S-sequence
-C int = integer to be converted
-C nv = # of S variables
-C INFOS = info for S-var
-C SEQ = S-sequence
-C IS = map to c, H, G, etc
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------
+C INT2SEQ converts integers into the S-sequence
+C int = integer to be converted
+C nv = # of S variables
+C INFOS = info for S-var
+C SEQ = S-sequence
+C IS = map to c, H, G, etc
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -23,35 +23,35 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -----------------------------------------------------------------------
- SUBROUTINE INT2SEQ(int,nv,INFOS,SEQ,IS)
-C INPUT
- INTEGER int,nv,INFOS(9,6)
-C OUTPUT
- INTEGER SEQ(nv),IS(6)
-C LOCALS
- INTEGER M,i,j,k,ns(nv)
-
- IS(:) = 1
- SEQ(:) = 1
- ns(1:nv) = INFOS(8,1:nv)
- j = int
- i = nv
- DO WHILE (i.GT.1)
- M = PRODUCT(ns(nv-i+2:nv))
- DO 10 k = 1,ns(nv-i+1)
- IF (j.LE.k*M) THEN
- SEQ(nv-i+1) = k
- GOTO 11
- ENDIF
-10 CONTINUE
-11 j = j-(k-1)*M
- i = i - 1
- ENDDO
- SEQ(nv) = j
- DO 20 i = 1,nv
- DO 20 j = 1,INFOS(1,i)
-20 IS(INFOS(j+1,i)) = SEQ(i)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -----------------------------------------------------------------------
+ SUBROUTINE INT2SEQ(int,nv,INFOS,SEQ,IS)
+C INPUT
+ INTEGER int,nv,INFOS(9,6)
+C OUTPUT
+ INTEGER SEQ(nv),IS(6)
+C LOCALS
+ INTEGER M,i,j,k,ns(nv)
+
+ IS(:) = 1
+ SEQ(:) = 1
+ ns(1:nv) = INFOS(8,1:nv)
+ j = int
+ i = nv
+ DO WHILE (i.GT.1)
+ M = PRODUCT(ns(nv-i+2:nv))
+ DO 10 k = 1,ns(nv-i+1)
+ IF (j.LE.k*M) THEN
+ SEQ(nv-i+1) = k
+ GOTO 11
+ ENDIF
+10 CONTINUE
+11 j = j-(k-1)*M
+ i = i - 1
+ ENDDO
+ SEQ(nv) = j
+ DO 20 i = 1,nv
+ DO 20 j = 1,INFOS(1,i)
+20 IS(INFOS(j+1,i)) = SEQ(i)
+ RETURN
END
diff --git a/int2seq2.for b/int2seq2.for
index f7c68fc0032531f585fc1b44289836963c8bc9ad..7be780e87869d9b7404429f496f9789a2a1dfbef 100644
--- a/int2seq2.for
+++ b/int2seq2.for
@@ -1,17 +1,17 @@
-C ------------------------------------------------------------
-C INT2SEQ2 converts integers into the S-sequence
-C int = integer to be converted
-C nv = # of S variables
-C INFOS = info for S-var
-C SEQ = S-sequence
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------
+C INT2SEQ2 converts integers into the S-sequence
+C int = integer to be converted
+C nv = # of S variables
+C INFOS = info for S-var
+C SEQ = S-sequence
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -22,24 +22,24 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -----------------------------------------------------------------------
- SUBROUTINE int2seq2(int,nv,ns,SEQ)
-C INPUT
- INTEGER nv,ns
- INTEGER(KIND=8) int
-C OUTPUT
- INTEGER SEQ(nv)
-C LOCALS
- INTEGER I
- INTEGER(KIND=8) ik
-
- SEQ(:) = 1
- ik = int-1
- DO i = 1,nv
- SEQ(i) = mod(ik,ns)+1
- ik = ik/ns
- ENDDO
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -----------------------------------------------------------------------
+ SUBROUTINE int2seq2(int,nv,ns,SEQ)
+C INPUT
+ INTEGER nv,ns
+ INTEGER(KIND=8) int
+C OUTPUT
+ INTEGER SEQ(nv)
+C LOCALS
+ INTEGER I
+ INTEGER(KIND=8) ik
+
+ SEQ(:) = 1
+ ik = int-1
+ DO i = 1,nv
+ SEQ(i) = mod(ik,ns)+1
+ ik = ik/ns
+ ENDDO
+
+ RETURN
END
diff --git a/invf.for b/invf.for
index 7429c9f1433384e53fbd5961b1e8fb9324cb08d3..e7fa291261cf07f2a45a989af8c9801a8e49227a 100644
--- a/invf.for
+++ b/invf.for
@@ -1,23 +1,23 @@
-C ----------------------------------------------------------------------
-C INVF computes the inverse of the np x np matrix (A + k*B) when k->inf.
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C CARE!! A and B must have the following structure:
-C A = [a11 a12
-C a12' a22], where a22 is (np-nq) x (np-nq) of full rank
-C
-C B = [b1 0
-C 0 0], where b1 is nq x nq of full rank
-C
-C OUTPUT: Am, Bm: inv(A+kB) = Am+(1/k)Bm-(1/k^2)Bm*A*Bm+O(1/k^3)
-C FFF: Bm*A*Bm
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C INVF computes the inverse of the np x np matrix (A + k*B) when k->inf.
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C CARE!! A and B must have the following structure:
+C A = [a11 a12
+C a12' a22], where a22 is (np-nq) x (np-nq) of full rank
+C
+C B = [b1 0
+C 0 0], where b1 is nq x nq of full rank
+C
+C OUTPUT: Am, Bm: inv(A+kB) = Am+(1/k)Bm-(1/k^2)Bm*A*Bm+O(1/k^3)
+C FFF: Bm*A*Bm
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -28,101 +28,101 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -----------------------------------------------------------------------
- SUBROUTINE INVF(A,B,np,nq,Am,Bm,FFF)
-C INPUT
- INTEGER np,nq
- DOUBLE PRECISION A(np,np),B(np,np)
-C OUTPUT
- DOUBLE PRECISION Am(np,np),Bm(np,np),FFF(np,np)
-C LOCALS
- INTEGER IFAIL,IPIV(np),I,J
- DOUBLE PRECISION Q1(np,nq),Q2(np,np-nq),V(np-nq,np-nq),
- 1 VV(nq,nq),M(nq,np-nq),Q1A(nq,np-nq),Q2Ainv(np-nq,np-nq),
- 3 AQ2inv(np-nq,np-nq),AQ2(np-nq,np-nq),BmA(np,np)
- DOUBLE PRECISION W(np),WORK(64*np)
- DOUBLE PRECISION ZERO
- DATA ZERO/0.0D0/
- EXTERNAL DSYEV,DGETRF,DGETRI
-
- Q1(:,:) = ZERO
- Q2(:,:) = ZERO
- V(:,:) = A(nq+1:np,nq+1:np) ! V = A22
-
-C [V,W] = eig(A(nq+1:np,nq+1:np))
- IFAIL = 0
-c CALL F02FAF('V','U',np-nq,V,np-nq,W(1:np-nq),WORK,64*np,IFAIL)
- CALL DSYEV('V','U',np-nq,V,np-nq,W(1:np-nq),WORK,64*np,IFAIL)
-
-C Q2(nq+1:np,:) = V*W^-.5
- DO 10 J = 1,np-nq
-10 Q2(nq+1:np,J) = V(:,J)/dsqrt(W(J))
-
-c [VV,W]=eig(B(1:nq,1:nq));
- VV(:,:) = B(1:nq,1:nq)
- IFAIL = 0
-c CALL F02FAF('V','U',nq,VV,nq,W(1:nq),WORK,64*np,IFAIL)
- CALL DSYEV('V','U',nq,VV,nq,W(1:nq),WORK,64*np,IFAIL)
-
-C Q1(1:nq,1:nq) = VV*W^-.5;
- DO 20 I = 1,nq
-20 Q1(1:nq,I) = VV(1:nq,I)/dsqrt(W(I))
-
-c M =-Q1(1:nq,:)'*A(1:nq,nq+1:np)*Q2(nq+1:np,:)*inv(A(nq+1:np,nq+1:np)*Q2(nq+1:np,:))
- DO 30 I = 1, np-nq
- DO 30 J = 1, np-nq
-30 AQ2(I,J) = SUM(A(I+nq,1+nq:np)*Q2(1+nq:np,J))
-
- IFAIL = 0
-C CALL F07ADF(np-nq,np-nq,AQ2,np-nq,IPIV(1:np-nq),IFAIL)
-C CALL F07AJF(np-nq,AQ2,np-nq,IPIV(1:np-nq),WORK,64*np,IFAIL)
- CALL DGETRF(np-nq,np-nq,AQ2,np-nq,IPIV(1:np-nq),IFAIL)
- CALL DGETRI(np-nq,AQ2,np-nq,IPIV(1:np-nq),WORK,64*np,IFAIL)
-
- AQ2inv(:,:) = AQ2(:,:)
-
- DO 40 I=1,nq
- DO 40 J=1,np-nq
-40 Q1A(I,J) = SUM(Q1(:,I)*A(1:nq,J+nq))
-
-C Q2(nq+1:np,:)*inv(A(nq+1:np,nq+1:np)*Q2(nq+1:np,:))
- DO 50 I=1,np-nq
- DO 50 J=1,np-nq
-50 Q2Ainv(I,J) = SUM(Q2(I+nq,1:np-nq)*AQ2inv(1:np-nq,J))
-
- DO 60 I=1,nq
- DO 60 J=1,np-nq
-60 M(I,J) = -SUM(Q1A(I,1:np-nq)*Q2Ainv(1:np-nq,J))
-
-c Q1(nq+1:np,:) = M'
- DO 70 I = 1,nq
- DO 70 J = 1,np-nq
-70 Q1(nq+J,I) = M(I,J)
-
-C Am = Q2*Q2'
- Am(:,:) = ZERO
- DO 80 I=nq+1,np
- Am(I,I) = SUM(Q2(I,1:np-nq)*Q2(I,1:np-nq))
- DO 80 J=nq+1,I-1
- Am(I,J) = SUM(Q2(I,1:np-nq)*Q2(J,1:np-nq))
-80 Am(J,I) = Am(I,J)
-
-C Bm = Q1*Q1'
- DO 90 I=1,np
- DO 90 J=1,I
- Bm(I,J) = SUM(Q1(I,1:nq)*Q1(J,1:nq))
-90 Bm(J,I) = Bm(I,J)
-
-C FFF = Bm*A*Bm
- DO 100 I=1,np
- DO 100 J=1,np
-100 BmA(I,J) = SUM(Bm(I,1:np)*A(1:np,J))
-
- DO 110 I=1,np
- DO 110 J=1,I
- FFF(I,J) = SUM(BmA(I,1:np)*Bm(1:np,J))
-110 FFF(J,I) = FFF(I,J)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -----------------------------------------------------------------------
+ SUBROUTINE INVF(A,B,np,nq,Am,Bm,FFF)
+C INPUT
+ INTEGER np,nq
+ DOUBLE PRECISION A(np,np),B(np,np)
+C OUTPUT
+ DOUBLE PRECISION Am(np,np),Bm(np,np),FFF(np,np)
+C LOCALS
+ INTEGER IFAIL,IPIV(np),I,J
+ DOUBLE PRECISION Q1(np,nq),Q2(np,np-nq),V(np-nq,np-nq),
+ 1 VV(nq,nq),M(nq,np-nq),Q1A(nq,np-nq),Q2Ainv(np-nq,np-nq),
+ 3 AQ2inv(np-nq,np-nq),AQ2(np-nq,np-nq),BmA(np,np)
+ DOUBLE PRECISION W(np),WORK(64*np)
+ DOUBLE PRECISION ZERO
+ DATA ZERO/0.0D0/
+ EXTERNAL DSYEV,DGETRF,DGETRI
+
+ Q1(:,:) = ZERO
+ Q2(:,:) = ZERO
+ V(:,:) = A(nq+1:np,nq+1:np) ! V = A22
+
+C [V,W] = eig(A(nq+1:np,nq+1:np))
+ IFAIL = 0
+c CALL F02FAF('V','U',np-nq,V,np-nq,W(1:np-nq),WORK,64*np,IFAIL)
+ CALL DSYEV('V','U',np-nq,V,np-nq,W(1:np-nq),WORK,64*np,IFAIL)
+
+C Q2(nq+1:np,:) = V*W^-.5
+ DO 10 J = 1,np-nq
+10 Q2(nq+1:np,J) = V(:,J)/dsqrt(W(J))
+
+c [VV,W]=eig(B(1:nq,1:nq));
+ VV(:,:) = B(1:nq,1:nq)
+ IFAIL = 0
+c CALL F02FAF('V','U',nq,VV,nq,W(1:nq),WORK,64*np,IFAIL)
+ CALL DSYEV('V','U',nq,VV,nq,W(1:nq),WORK,64*np,IFAIL)
+
+C Q1(1:nq,1:nq) = VV*W^-.5;
+ DO 20 I = 1,nq
+20 Q1(1:nq,I) = VV(1:nq,I)/dsqrt(W(I))
+
+c M =-Q1(1:nq,:)'*A(1:nq,nq+1:np)*Q2(nq+1:np,:)*inv(A(nq+1:np,nq+1:np)*Q2(nq+1:np,:))
+ DO 30 I = 1, np-nq
+ DO 30 J = 1, np-nq
+30 AQ2(I,J) = SUM(A(I+nq,1+nq:np)*Q2(1+nq:np,J))
+
+ IFAIL = 0
+C CALL F07ADF(np-nq,np-nq,AQ2,np-nq,IPIV(1:np-nq),IFAIL)
+C CALL F07AJF(np-nq,AQ2,np-nq,IPIV(1:np-nq),WORK,64*np,IFAIL)
+ CALL DGETRF(np-nq,np-nq,AQ2,np-nq,IPIV(1:np-nq),IFAIL)
+ CALL DGETRI(np-nq,AQ2,np-nq,IPIV(1:np-nq),WORK,64*np,IFAIL)
+
+ AQ2inv(:,:) = AQ2(:,:)
+
+ DO 40 I=1,nq
+ DO 40 J=1,np-nq
+40 Q1A(I,J) = SUM(Q1(:,I)*A(1:nq,J+nq))
+
+C Q2(nq+1:np,:)*inv(A(nq+1:np,nq+1:np)*Q2(nq+1:np,:))
+ DO 50 I=1,np-nq
+ DO 50 J=1,np-nq
+50 Q2Ainv(I,J) = SUM(Q2(I+nq,1:np-nq)*AQ2inv(1:np-nq,J))
+
+ DO 60 I=1,nq
+ DO 60 J=1,np-nq
+60 M(I,J) = -SUM(Q1A(I,1:np-nq)*Q2Ainv(1:np-nq,J))
+
+c Q1(nq+1:np,:) = M'
+ DO 70 I = 1,nq
+ DO 70 J = 1,np-nq
+70 Q1(nq+J,I) = M(I,J)
+
+C Am = Q2*Q2'
+ Am(:,:) = ZERO
+ DO 80 I=nq+1,np
+ Am(I,I) = SUM(Q2(I,1:np-nq)*Q2(I,1:np-nq))
+ DO 80 J=nq+1,I-1
+ Am(I,J) = SUM(Q2(I,1:np-nq)*Q2(J,1:np-nq))
+80 Am(J,I) = Am(I,J)
+
+C Bm = Q1*Q1'
+ DO 90 I=1,np
+ DO 90 J=1,I
+ Bm(I,J) = SUM(Q1(I,1:nq)*Q1(J,1:nq))
+90 Bm(J,I) = Bm(I,J)
+
+C FFF = Bm*A*Bm
+ DO 100 I=1,np
+ DO 100 J=1,np
+100 BmA(I,J) = SUM(Bm(I,1:np)*A(1:np,J))
+
+ DO 110 I=1,np
+ DO 110 J=1,I
+ FFF(I,J) = SUM(BmA(I,1:np)*Bm(1:np,J))
+110 FFF(J,I) = FFF(I,J)
+
+ RETURN
END
diff --git a/invfbis.for b/invfbis.for
index 353c32f61690361dac19f366eb7129a7cd593299..dedc621888ba6bba53e2e59efd029452fb47ab5b 100644
--- a/invfbis.for
+++ b/invfbis.for
@@ -1,23 +1,23 @@
-C ----------------------------------------------------------------------
-C INVFBIS computes the inverse of the np x np matrix (A + k*B) when k->inf.
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C CARE!! A and B must have the following form
-C A = [a11 a12
-C a12' a22], where a22 is a (np-nq)x(np-nq) matrix of full rank
-C
-C B psd with rank(B) = nq <= np
-C
-C
-C OUTPUT: Am, Bm: inv(A+kB) = Am + (1/k)Bm - (1/k^2)Bm*A*Bm + O(1/k^3)
-C FFF: Bm*A*Bm
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C INVFBIS computes the inverse of the np x np matrix (A + k*B) when k->inf.
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C CARE!! A and B must have the following form
+C A = [a11 a12
+C a12' a22], where a22 is a (np-nq)x(np-nq) matrix of full rank
+C
+C B psd with rank(B) = nq <= np
+C
+C
+C OUTPUT: Am, Bm: inv(A+kB) = Am + (1/k)Bm - (1/k^2)Bm*A*Bm + O(1/k^3)
+C FFF: Bm*A*Bm
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -28,87 +28,87 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -----------------------------------------------------------------------
- SUBROUTINE INVFBIS(A,B,np,nq,Am,Bm,FFF)
-C INPUT
- INTEGER NP,NQ
- DOUBLE PRECISION A(np,np),B(np,np)
-C OUTPUT
- DOUBLE PRECISION Am(np,np),Bm(np,np),FFF(np,np)
-C LOCALS
- INTEGER IFAIL,i,j
- DOUBLE PRECISION ZERO
-
- DOUBLE PRECISION Q(np,np)
- DOUBLE PRECISION DM(np),PM(np,np),PMA(np,np),COM(np,np),
- 1 WORK(3*np),W(np)
-
- EXTERNAL DSYEV
- DATA ZERO/0.0D0/
-
-C Inverse of A + k*M, A, M NxN, A psd, M pd
-C Write M = PM*DM*PM'
-C MA = (PM*DM^-.5)'*A*(PM*DM^-.5)
-C and MA = PMA * DMA * PMA'
-C then Q = PM*DM^-.5*PMA verifies:
-C Q'*M*Q = I and Q'*A*Q = DMA
-C implying: A + k*M = inv(Q)'*DMA*inv(Q) + k inv(Q)'*inv(Q)
-C = inv(Q)'*(DMA + k I) inv(Q)
-C so inv(A + k*M) = Q * inv(DMA + k I) * Q'
-C
-C CARE!!!! inv (k*A + (1-k)*M) = (1/k) * Q *inv(DMA + (1-k)/k)) Q'
-C ---------------------------------------------
-C [COM DM] = eig(M)
- IFAIL = -1
- PM(:,:) = A(:,:)
-C CALL F02FAF('V','U',np,PM,np,DM,WORK,3*np,IFAIL) ! COM = P
- CALL DSYEV('V','U',np,PM,np,DM,WORK,3*np,IFAIL) ! COM = P
-
-C PM = PM * DM^-.5
- DO 10 J = 1,np
-10 PM(:,J) = PM(:,J)/dsqrt(DM(J))
-
-C COM = (PM*DM^-.5)'*FI
- COM(:,:) = ZERO
- DO 20 I = 1,np
- DO 20 J = 1,np
-20 COM(I,J) = SUM(PM(1:np,I)*B(1:np,J))
-
-C Q = (PM*DM^-.5)'*FI*(PM*DM^-.5)
- PMA(:,:) = ZERO
- DO 30 I = 1,np
- PMA(I,I) = SUM(COM(I,1:np)*PM(1:np,I))
- DO 30 J = 1,I-1
- PMA(I,J) = SUM(COM(I,1:np)*PM(1:np,J))
-30 PMA(J,I)=PMA(I,J)
-
-C [PMA,W] = eig(A2)
- IFAIL = -1
-C CALL F02FAF('V','U',np,PMA,np,W,WORK,3*np,IFAIL)
- CALL DSYEV('V','U',np,PMA,np,W,WORK,3*np,IFAIL)
-C Q = PM*DM^-.5*PMA
- Q(:,:)=ZERO
- DO 40 I = 1,np
- DO 40 J = 1,np
-40 Q(I,J) = SUM(PM(I,1:np)*PMA(1:np,J))
-
-C Am = Q1*Q1' Q1 p x p-q
- DO 110 I=1,np
- Am(I,I) = SUM(Q(I,1:np-nq)*Q(I,1:np-nq))
- DO 110 J=1,I-1
- Am(I,J) = SUM(Q(I,1:np-nq)*Q(J,1:np-nq))
-110 Am(J,I) = Am(I,J)
-
-C Bm = Q2*Q2'/W(np-nq+1:np) Q2 p x q
- DO 120 I=1,np
- DO 120 J=1,np
-120 Bm(I,J) = SUM(Q(I,np-nq+1:np)*Q(J,np-nq+1:np)/W(np-nq+1:np))
-
-C FFF is Q2 * Q2 / W^2
- DO 130 I=1,np
- DO 130 J=1,np
-130 FFF(I,J) =SUM(Q(I,np-nq+1:np)*Q(J,np-nq+1:np)/W(np-nq+1:np)**2.D0)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -----------------------------------------------------------------------
+ SUBROUTINE INVFBIS(A,B,np,nq,Am,Bm,FFF)
+C INPUT
+ INTEGER NP,NQ
+ DOUBLE PRECISION A(np,np),B(np,np)
+C OUTPUT
+ DOUBLE PRECISION Am(np,np),Bm(np,np),FFF(np,np)
+C LOCALS
+ INTEGER IFAIL,i,j
+ DOUBLE PRECISION ZERO
+
+ DOUBLE PRECISION Q(np,np)
+ DOUBLE PRECISION DM(np),PM(np,np),PMA(np,np),COM(np,np),
+ 1 WORK(3*np),W(np)
+
+ EXTERNAL DSYEV
+ DATA ZERO/0.0D0/
+
+C Inverse of A + k*M, A, M NxN, A psd, M pd
+C Write M = PM*DM*PM'
+C MA = (PM*DM^-.5)'*A*(PM*DM^-.5)
+C and MA = PMA * DMA * PMA'
+C then Q = PM*DM^-.5*PMA verifies:
+C Q'*M*Q = I and Q'*A*Q = DMA
+C implying: A + k*M = inv(Q)'*DMA*inv(Q) + k inv(Q)'*inv(Q)
+C = inv(Q)'*(DMA + k I) inv(Q)
+C so inv(A + k*M) = Q * inv(DMA + k I) * Q'
+C
+C CARE!!!! inv (k*A + (1-k)*M) = (1/k) * Q *inv(DMA + (1-k)/k)) Q'
+C ---------------------------------------------
+C [COM DM] = eig(M)
+ IFAIL = -1
+ PM(:,:) = A(:,:)
+C CALL F02FAF('V','U',np,PM,np,DM,WORK,3*np,IFAIL) ! COM = P
+ CALL DSYEV('V','U',np,PM,np,DM,WORK,3*np,IFAIL) ! COM = P
+
+C PM = PM * DM^-.5
+ DO 10 J = 1,np
+10 PM(:,J) = PM(:,J)/dsqrt(DM(J))
+
+C COM = (PM*DM^-.5)'*FI
+ COM(:,:) = ZERO
+ DO 20 I = 1,np
+ DO 20 J = 1,np
+20 COM(I,J) = SUM(PM(1:np,I)*B(1:np,J))
+
+C Q = (PM*DM^-.5)'*FI*(PM*DM^-.5)
+ PMA(:,:) = ZERO
+ DO 30 I = 1,np
+ PMA(I,I) = SUM(COM(I,1:np)*PM(1:np,I))
+ DO 30 J = 1,I-1
+ PMA(I,J) = SUM(COM(I,1:np)*PM(1:np,J))
+30 PMA(J,I)=PMA(I,J)
+
+C [PMA,W] = eig(A2)
+ IFAIL = -1
+C CALL F02FAF('V','U',np,PMA,np,W,WORK,3*np,IFAIL)
+ CALL DSYEV('V','U',np,PMA,np,W,WORK,3*np,IFAIL)
+C Q = PM*DM^-.5*PMA
+ Q(:,:)=ZERO
+ DO 40 I = 1,np
+ DO 40 J = 1,np
+40 Q(I,J) = SUM(PM(I,1:np)*PMA(1:np,J))
+
+C Am = Q1*Q1' Q1 p x p-q
+ DO 110 I=1,np
+ Am(I,I) = SUM(Q(I,1:np-nq)*Q(I,1:np-nq))
+ DO 110 J=1,I-1
+ Am(I,J) = SUM(Q(I,1:np-nq)*Q(J,1:np-nq))
+110 Am(J,I) = Am(I,J)
+
+C Bm = Q2*Q2'/W(np-nq+1:np) Q2 p x q
+ DO 120 I=1,np
+ DO 120 J=1,np
+120 Bm(I,J) = SUM(Q(I,np-nq+1:np)*Q(J,np-nq+1:np)/W(np-nq+1:np))
+
+C FFF is Q2 * Q2 / W^2
+ DO 130 I=1,np
+ DO 130 J=1,np
+130 FFF(I,J) =SUM(Q(I,np-nq+1:np)*Q(J,np-nq+1:np)/W(np-nq+1:np)**2.D0)
+
+ RETURN
END
diff --git a/invnormcdf.for b/invnormcdf.for
index 7b9e4cd9173dfbba95d6f2ff36676909b5534ee2..b11cb4af247ef0897b6560837ce2daccf42927af 100644
--- a/invnormcdf.for
+++ b/invnormcdf.for
@@ -1,18 +1,18 @@
-C --------------------------------------------------------------------------------
-C INVNORMCDF Computes the inverse of the N(0,1) cdf according to
-C the algorithm shown in Wichura, M.J. (1988).
-C Algorithm AS 241: The Percentage Points of the Normal Distribution.
-C Applied Statistics, 37, 477-484.
-C
-C Copyright (C) 2002 Przemyslaw Sliwa and Jason H. Stover.
-C
-C Recoded in Fortran by A. Rossi
+C --------------------------------------------------------------------------------
+C INVNORMCDF Computes the inverse of the N(0,1) cdf according to
+C the algorithm shown in Wichura, M.J. (1988).
+C Algorithm AS 241: The Percentage Points of the Normal Distribution.
+C Applied Statistics, 37, 477-484.
+C
+C Copyright (C) 2002 Przemyslaw Sliwa and Jason H. Stover.
+C
+C Recoded in Fortran by A. Rossi
C Copyright (C) 2014 European Commission
-C
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -23,126 +23,126 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION INVNORMCDF(P)
-C INPUT
- DOUBLE PRECISION P
-C LOCALS
- DOUBLE PRECISION r,x,pp,dP
-C EXTERNAL FUNCIONS
- DOUBLE PRECISION small,intermediate,tail
-
- IF (P.GE.1.D0) THEN
- INVNORMCDF = 1.D100
- RETURN
- ENDIF
-
- IF (P.LE.0.D0) THEN
- INVNORMCDF = -1.D100
- RETURN
- ENDIF
-
- dP = P - 0.5D0
- IF (DABS(dP).LE.0.425D0) THEN
- INVNORMCDF = small(dP)
- RETURN
- ENDIF
-
- IF (P.LT.0.5D0) THEN
- pp = P
- ELSE
- pp = 1.D0-P
- ENDIF
-
- r = dsqrt(-dlog(pp))
- IF (r.LE.5.D0) THEN
- x = intermediate(r)
- ELSE
- x = tail(r)
- ENDIF
-
- IF (P.LT.0.5D0) THEN
- INVNORMCDF = -x
- ELSE
- INVNORMCDF = x
- ENDIF
-
- RETURN
- END
-
-C *************************************************************
- double precision function small(q)
- double precision q,r,a(8),b(8)
- double precision rat_eval
- data a/3.387132872796366608,133.14166789178437745,
- * 1971.5909503065514427, 13731.693765509461125,
- * 45921.953931549871457, 67265.770927008700853,
- * 33430.575583588128105, 2509.0809287301226727/
- data b/ 1.D0,42.313330701600911252,
- * 687.1870074920579083, 5394.1960214247511077,
- * 21213.794301586595867, 39307.89580009271061,
- * 28729.085735721942674, 5226.495278852854561/
-
- r = .180625D0 - q * q
- small = q * rat_eval(a, 8, b, 8, r)
-
- return
- end
-C *************************************************************
- double precision function intermediate(r)
- double precision r,a(8),b(8)
- double precision rat_eval
- data a/1.42343711074968357734, 4.6303378461565452959,
- * 5.7694972214606914055, 3.64784832476320460504,
- * 1.27045825245236838258, 0.24178072517745061177,
- * 0.0227238449892691845833, 7.7454501427834140764d-4/
- data b/ 1.D0, 2.05319162663775882187,
- * 1.6763848301838038494, 0.68976733498510000455,
- * 0.14810397642748007459, 0.0151986665636164571966,
- * 5.475938084995344946d-4, 1.05075007164441684324d-9/
-
- intermediate = rat_eval(a, 8, b, 8, r-1.6D0)
-
- return
- end
-C *************************************************************
- double precision function tail(r)
- double precision r,a(8),b(8)
- double precision rat_eval
- data a/6.6579046435011037772, 5.4637849111641143699,
- * 1.7848265399172913358, 0.29656057182850489123,
- * 0.026532189526576123093, 0.0012426609473880784386,
- * 2.71155556874348757815d-5, 2.01033439929228813265d-7/
- data b/ 1.D0, 0.59983220655588793769,
- * 0.13692988092273580531, 0.0148753612908506148525,
- * 7.868691311456132591d-4, 1.8463183175100546818d-5,
- * 1.4215117583164458887d-7, 2.04426310338993978564d-15/
-
- tail = rat_eval(a, 8, b, 8, (r - 5.D0))
-
- return
- end
-C *************************************************************
- double precision function rat_eval(a,na,b,nb,x)
- integer na,nb,i
- double precision a(na),b(nb),x,u,v
-
- u = a(na)
- do i=na,2,-1
- u = x*u+a(i-1)
- enddo
-
- v = b(nb)
- do i=nb,2,-1
- v = x*v+b(i-1)
- enddo
- rat_eval = u/v
-
- return
- end
-C *************************************************************
-
-
-
-
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION INVNORMCDF(P)
+C INPUT
+ DOUBLE PRECISION P
+C LOCALS
+ DOUBLE PRECISION r,x,pp,dP
+C EXTERNAL FUNCIONS
+ DOUBLE PRECISION small,intermediate,tail
+
+ IF (P.GE.1.D0) THEN
+ INVNORMCDF = 1.D100
+ RETURN
+ ENDIF
+
+ IF (P.LE.0.D0) THEN
+ INVNORMCDF = -1.D100
+ RETURN
+ ENDIF
+
+ dP = P - 0.5D0
+ IF (DABS(dP).LE.0.425D0) THEN
+ INVNORMCDF = small(dP)
+ RETURN
+ ENDIF
+
+ IF (P.LT.0.5D0) THEN
+ pp = P
+ ELSE
+ pp = 1.D0-P
+ ENDIF
+
+ r = dsqrt(-dlog(pp))
+ IF (r.LE.5.D0) THEN
+ x = intermediate(r)
+ ELSE
+ x = tail(r)
+ ENDIF
+
+ IF (P.LT.0.5D0) THEN
+ INVNORMCDF = -x
+ ELSE
+ INVNORMCDF = x
+ ENDIF
+
+ RETURN
+ END
+
+C *************************************************************
+ double precision function small(q)
+ double precision q,r,a(8),b(8)
+ double precision rat_eval
+ data a/3.387132872796366608,133.14166789178437745,
+ * 1971.5909503065514427, 13731.693765509461125,
+ * 45921.953931549871457, 67265.770927008700853,
+ * 33430.575583588128105, 2509.0809287301226727/
+ data b/ 1.D0,42.313330701600911252,
+ * 687.1870074920579083, 5394.1960214247511077,
+ * 21213.794301586595867, 39307.89580009271061,
+ * 28729.085735721942674, 5226.495278852854561/
+
+ r = .180625D0 - q * q
+ small = q * rat_eval(a, 8, b, 8, r)
+
+ return
+ end
+C *************************************************************
+ double precision function intermediate(r)
+ double precision r,a(8),b(8)
+ double precision rat_eval
+ data a/1.42343711074968357734, 4.6303378461565452959,
+ * 5.7694972214606914055, 3.64784832476320460504,
+ * 1.27045825245236838258, 0.24178072517745061177,
+ * 0.0227238449892691845833, 7.7454501427834140764d-4/
+ data b/ 1.D0, 2.05319162663775882187,
+ * 1.6763848301838038494, 0.68976733498510000455,
+ * 0.14810397642748007459, 0.0151986665636164571966,
+ * 5.475938084995344946d-4, 1.05075007164441684324d-9/
+
+ intermediate = rat_eval(a, 8, b, 8, r-1.6D0)
+
+ return
+ end
+C *************************************************************
+ double precision function tail(r)
+ double precision r,a(8),b(8)
+ double precision rat_eval
+ data a/6.6579046435011037772, 5.4637849111641143699,
+ * 1.7848265399172913358, 0.29656057182850489123,
+ * 0.026532189526576123093, 0.0012426609473880784386,
+ * 2.71155556874348757815d-5, 2.01033439929228813265d-7/
+ data b/ 1.D0, 0.59983220655588793769,
+ * 0.13692988092273580531, 0.0148753612908506148525,
+ * 7.868691311456132591d-4, 1.8463183175100546818d-5,
+ * 1.4215117583164458887d-7, 2.04426310338993978564d-15/
+
+ tail = rat_eval(a, 8, b, 8, (r - 5.D0))
+
+ return
+ end
+C *************************************************************
+ double precision function rat_eval(a,na,b,nb,x)
+ integer na,nb,i
+ double precision a(na),b(nb),x,u,v
+
+ u = a(na)
+ do i=na,2,-1
+ u = x*u+a(i-1)
+ enddo
+
+ v = b(nb)
+ do i=nb,2,-1
+ v = x*v+b(i-1)
+ enddo
+ rat_eval = u/v
+
+ return
+ end
+C *************************************************************
+
+
+
+
diff --git a/kf.for b/kf.for
index 889766e044d8e7d803306b4e7152634125cdaff1..971e2a834ae9642c039ca08a54930e11c69e7b71 100644
--- a/kf.for
+++ b/kf.for
@@ -1,32 +1,32 @@
-C --------------------------------------------------------------------
-C KF implements the Kalman filter recursions and returns
-C XT = E[x(t)|t], PT = V[x(t)|t]
-C LIKE(t) = log-likelihood(t), t = 1,...,nobs
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C KF implements the Kalman filter recursions and returns
+C XT = E[x(t)|t], PT = V[x(t)|t]
+C LIKE(t) = log-likelihood(t), t = 1,...,nobs
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -37,141 +37,141 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,
- 1 XT,PT,LIKE)
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6),IYK(nobs,ny+1)
- DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
- 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 R(nx,nu,ns(6))
-
-C OUTPUT
- DOUBLE PRECISION LIKE(nobs)
- DOUBLE PRECISION XT(0:nobs,nx),PT(0:nobs,nx,nx)
-
-C LOCALS
- INTEGER imain,iny,I,J,IFAIL
- DOUBLE PRECISION RSS,DETV,X1(nx),P1(nx,nx),FP(nx,nx),
- 1 INN(ny),HP1(ny,nx),V(ny,ny),Vinv(ny,ny),COM(ny+1,ny),
- 2 RG(nx,ny),HPV(nx,ny)
-
- LIKE(d(1)+1:nobs) = 0.D0
- DO 1000 imain = d(1)+1,nobs
- iny = IYK(imain,ny+1)
-
-C ------------------------------------
-C Prediction x1 = c+F*x0
-C Prediction var. P1 = F*p0*F'+ R*R'
-C ------------------------------------
- DO 10 I=1,nx
-10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(imain-1,:))
-
- DO 20 I=1,nx
- DO 20 J=1,nx
-20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain-1,:,J))
-
- DO 30 I=1,nx
- P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
- DO 30 J=1,I-1
- P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
-30 P1(J,I) = P1(I,J)
-
-C -------------------------------
-C Innovations: INN = yk-H*X1-c*z
-C -------------------------------
- DO 40 I=1,iny
-40 INN(I)= yk(imain,IYK(imain,I))
- + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*X1(1:nx))
- + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
-C ---------------------------------------------------------
-C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
-C ---------------------------------------------------------
- DO 50 I=1,iny
- DO 50 J=1,nx
-50 HP1(I,J) = SUM(H(IYK(imain,I),1:nx,S(imain,2))*P1(1:nx,J))
-
- DO 55 I=1,nx
- DO 55 J=1,iny
-55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
- # * G(IYK(imain,J),1:nu,S(imain,3))) ! R*G'
-
- DO 56 I=1,iny
- DO 56 J=1,iny
-56 COM(I,J)=SUM(H(IYK(imain,I),1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
-
- DO 60 I=1,iny
- V(I,I) = SUM(HP1(I,1:nx)*H(IYK(imain,I),1:nx,S(imain,2))) +
- # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
- # G(IYK(imain,I),1:nu,S(imain,3))) + 2.*COM(I,I)
-
- DO 60 J=1,I-1
- V(I,J) = SUM(HP1(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))+
- # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
- # G(IYK(imain,J),1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
-60 V(J,I) = V(I,J)
-
-C -------------------------------------------------------------------
-C Updating equations:
-C x0 = x1 + (P1*H'+R*G')*Vinv*INN
-C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
-C -------------------------------------------------------------------
- IF (iny.GT.0) THEN
- COM(1:iny,1:iny) = V(1:iny,1:iny)
- IFAIL = -1
-C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- DETV = 1.D0 ! det(L)
- DO I=1,iny
- DETV = DETV*COM(I,I)
- ENDDO
- CALL DPOTRI('L',iny,COM(1:iny,1:ny),iny,IFAIL) ! COM = VV^-1
-
- DO 70 I=1,iny
- Vinv(I,I) = COM(I,I)
- DO 70 J=1,I-1
- Vinv(I,J) = COM(I,J)
-70 Vinv(J,I) = Vinv(I,J)
-
- DO 90 I=1,nx
- DO 90 J=1,iny
-90 HPV(I,J) = SUM((HP1(1:iny,I)+RG(I,1:iny))*Vinv(1:iny,J))
-
- DO 100 I=1,nx
-100 XT(imain,I) = X1(I)+SUM(HPV(I,1:iny)*INN(1:iny))
-
- DO 110 I=1,nx
- PT(imain,I,I) = P1(I,I)
- + - SUM(HPV(I,1:iny)*(HP1(1:iny,I)+RG(I,1:iny)))
- DO 110 J=1,I-1
- PT(imain,I,J) = P1(I,J)
- + - SUM(HPV(I,1:iny)*(HP1(1:iny,J)+RG(J,1:iny)))
-110 PT(imain,J,I) = PT(imain,I,J)
-
-C ---------------------------------------------
-C Log-Likelihood = -(RSS + ln(det(V))/2
-C RSS = INN'*Vinv*INN
-C ---------------------------------------------
-c IFAIL=-1
-c CALL F03ABF(V(1:iny,1:iny),iny,iny,DETV,COM(1:iny,1),IFAIL)
-
- RSS = 0.D0
- DO 120 I=1,iny
- DO 120 J=1,iny
-120 RSS = RSS + INN(I)*Vinv(I,J)*INN(J)
-
- LIKE(imain) = -.5D0*(RSS + 2.D0*DLOG(DETV))
- # - iny/2.D0*DLOG(2.*3.141592653589793D0)
- ELSE
-
- XT(imain,1:nx) = X1(1:nx)
- PT(imain,1:nx,1:nx) = P1(1:nx,1:nx)
-
-1000 ENDIF
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,
+ 1 XT,PT,LIKE)
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6),IYK(nobs,ny+1)
+ DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
+ 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 R(nx,nu,ns(6))
+
+C OUTPUT
+ DOUBLE PRECISION LIKE(nobs)
+ DOUBLE PRECISION XT(0:nobs,nx),PT(0:nobs,nx,nx)
+
+C LOCALS
+ INTEGER imain,iny,I,J,IFAIL
+ DOUBLE PRECISION RSS,DETV,X1(nx),P1(nx,nx),FP(nx,nx),
+ 1 INN(ny),HP1(ny,nx),V(ny,ny),Vinv(ny,ny),COM(ny+1,ny),
+ 2 RG(nx,ny),HPV(nx,ny)
+
+ LIKE(d(1)+1:nobs) = 0.D0
+ DO 1000 imain = d(1)+1,nobs
+ iny = IYK(imain,ny+1)
+
+C ------------------------------------
+C Prediction x1 = c+F*x0
+C Prediction var. P1 = F*p0*F'+ R*R'
+C ------------------------------------
+ DO 10 I=1,nx
+10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(imain-1,:))
+
+ DO 20 I=1,nx
+ DO 20 J=1,nx
+20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain-1,:,J))
+
+ DO 30 I=1,nx
+ P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
+ DO 30 J=1,I-1
+ P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
+30 P1(J,I) = P1(I,J)
+
+C -------------------------------
+C Innovations: INN = yk-H*X1-c*z
+C -------------------------------
+ DO 40 I=1,iny
+40 INN(I)= yk(imain,IYK(imain,I))
+ + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*X1(1:nx))
+ + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+C ---------------------------------------------------------
+C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
+C ---------------------------------------------------------
+ DO 50 I=1,iny
+ DO 50 J=1,nx
+50 HP1(I,J) = SUM(H(IYK(imain,I),1:nx,S(imain,2))*P1(1:nx,J))
+
+ DO 55 I=1,nx
+ DO 55 J=1,iny
+55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
+ # * G(IYK(imain,J),1:nu,S(imain,3))) ! R*G'
+
+ DO 56 I=1,iny
+ DO 56 J=1,iny
+56 COM(I,J)=SUM(H(IYK(imain,I),1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
+
+ DO 60 I=1,iny
+ V(I,I) = SUM(HP1(I,1:nx)*H(IYK(imain,I),1:nx,S(imain,2))) +
+ # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
+ # G(IYK(imain,I),1:nu,S(imain,3))) + 2.*COM(I,I)
+
+ DO 60 J=1,I-1
+ V(I,J) = SUM(HP1(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))+
+ # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
+ # G(IYK(imain,J),1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
+60 V(J,I) = V(I,J)
+
+C -------------------------------------------------------------------
+C Updating equations:
+C x0 = x1 + (P1*H'+R*G')*Vinv*INN
+C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
+C -------------------------------------------------------------------
+ IF (iny.GT.0) THEN
+ COM(1:iny,1:iny) = V(1:iny,1:iny)
+ IFAIL = -1
+C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ DETV = 1.D0 ! det(L)
+ DO I=1,iny
+ DETV = DETV*COM(I,I)
+ ENDDO
+ CALL DPOTRI('L',iny,COM(1:iny,1:ny),iny,IFAIL) ! COM = VV^-1
+
+ DO 70 I=1,iny
+ Vinv(I,I) = COM(I,I)
+ DO 70 J=1,I-1
+ Vinv(I,J) = COM(I,J)
+70 Vinv(J,I) = Vinv(I,J)
+
+ DO 90 I=1,nx
+ DO 90 J=1,iny
+90 HPV(I,J) = SUM((HP1(1:iny,I)+RG(I,1:iny))*Vinv(1:iny,J))
+
+ DO 100 I=1,nx
+100 XT(imain,I) = X1(I)+SUM(HPV(I,1:iny)*INN(1:iny))
+
+ DO 110 I=1,nx
+ PT(imain,I,I) = P1(I,I)
+ + - SUM(HPV(I,1:iny)*(HP1(1:iny,I)+RG(I,1:iny)))
+ DO 110 J=1,I-1
+ PT(imain,I,J) = P1(I,J)
+ + - SUM(HPV(I,1:iny)*(HP1(1:iny,J)+RG(J,1:iny)))
+110 PT(imain,J,I) = PT(imain,I,J)
+
+C ---------------------------------------------
+C Log-Likelihood = -(RSS + ln(det(V))/2
+C RSS = INN'*Vinv*INN
+C ---------------------------------------------
+c IFAIL=-1
+c CALL F03ABF(V(1:iny,1:iny),iny,iny,DETV,COM(1:iny,1),IFAIL)
+
+ RSS = 0.D0
+ DO 120 I=1,iny
+ DO 120 J=1,iny
+120 RSS = RSS + INN(I)*Vinv(I,J)*INN(J)
+
+ LIKE(imain) = -.5D0*(RSS + 2.D0*DLOG(DETV))
+ # - iny/2.D0*DLOG(2.*3.141592653589793D0)
+ ELSE
+
+ XT(imain,1:nx) = X1(1:nx)
+ PT(imain,1:nx,1:nx) = P1(1:nx,1:nx)
+
+1000 ENDIF
+
+ RETURN
END
diff --git a/kf2.for b/kf2.for
index 2f81f7677468031777cc84958deab8c742fb4695..84a018986972223c703b1e9c5a62de119dc60e48 100644
--- a/kf2.for
+++ b/kf2.for
@@ -1,32 +1,32 @@
-C --------------------------------------------------------------------
-C KF2 (no missing values) implements the Kalman filter recursions and returns
-C XT = E[x(t)|t], PT = V[x(t)|t]
-C LIKE(t) = log-likelihood(t), t = 1,...,nobs
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C KF2 (no missing values) implements the Kalman filter recursions and returns
+C XT = E[x(t)|t], PT = V[x(t)|t]
+C LIKE(t) = log-likelihood(t), t = 1,...,nobs
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -37,136 +37,136 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE KF2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,
- 1 XT,PT,LIKE)
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
- 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 R(nx,nu,ns(6))
-
-C OUTPUT
- DOUBLE PRECISION LIKE(nobs)
- DOUBLE PRECISION XT(0:nobs,nx),PT(0:nobs,nx,nx)
-
-C LOCALS
- INTEGER imain,I,J,IFAIL
- DOUBLE PRECISION RSS,DETV,X1(nx),P1(nx,nx),FP(nx,nx),
- 1 INN(ny),HP1(ny,nx),V(ny,ny),Vinv(ny,ny),COM(ny+1,ny),
- 2 RG(nx,ny),HPV(nx,ny)
-
- LIKE(d(1)+1:nobs) = 0.D0
- DO 1000 imain = d(1)+1,nobs
-
-C ------------------------------------
-C Prediction x1 = a+F*x0
-C Prediction var. P1 = F*p0*F'+ R*R'
-C ------------------------------------
- DO 10 I=1,nx
-10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(imain-1,:))
-
- DO 20 I=1,nx
- DO 20 J=1,nx
-20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain-1,:,J))
-
- DO 30 I=1,nx
- P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
- DO 30 J=1,I-1
- P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
- + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
-30 P1(J,I) = P1(I,J)
-
-C -------------------------------
-C Innovations: INN = yk-H*X1-c*z
-C -------------------------------
- DO 40 I=1,ny
-40 INN(I) = yk(imain,I)
- + - SUM(H(I,1:nx,S(imain,2))*X1(1:nx))
- + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
-C ---------------------------------------------------------
-C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
-C ---------------------------------------------------------
- DO 50 I=1,ny
- DO 50 J=1,nx
-50 HP1(I,J) = SUM(H(I,1:nx,S(imain,2))*P1(1:nx,J))
-
- DO 55 I=1,nx
- DO 55 J=1,ny
-55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
- # * G(J,1:nu,S(imain,3))) ! R*G'
-
- DO 56 I=1,ny
- DO 56 J=1,ny
-56 COM(I,J)=SUM(H(I,1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
-
- DO 60 I=1,ny
- V(I,I) = SUM(HP1(I,1:nx)*H(I,1:nx,S(imain,2))) +
- # SUM(G(I,1:nu,S(imain,3))*
- # G(I,1:nu,S(imain,3))) + 2.*COM(I,I)
-
- DO 60 J=1,I-1
- V(I,J) = SUM(HP1(I,1:nx)*H(J,1:nx,S(imain,2)))+
- # SUM(G(I,1:nu,S(imain,3))*
- # G(J,1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
-60 V(J,I) = V(I,J)
-
-C -------------------------------------------------------------------
-C Updating equations:
-C x0 = x1 + (P1*H'+R*G')*Vinv*INN
-C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
-C -------------------------------------------------------------------
- COM(1:ny,1:ny) = V(1:ny,1:ny)
- IFAIL = -1
-c CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
- CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
- DETV = 1.D0 ! det(L)
- DO I=1,ny
- DETV = DETV*COM(I,I)
- ENDDO
- CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
-
- DO 70 I=1,ny
- Vinv(I,I) = COM(I,I)
- DO 70 J=1,I-1
- Vinv(I,J) = COM(I,J)
-70 Vinv(J,I) = Vinv(I,J)
-
- DO 90 I=1,nx
- DO 90 J=1,ny
-90 HPV(I,J) = SUM((HP1(1:ny,I)+RG(I,1:ny))*Vinv(1:ny,J))
-
- DO 100 I=1,nx
-100 XT(imain,I) = X1(I)+SUM(HPV(I,1:ny)*INN(1:ny))
-
- DO 110 I=1,nx
- PT(imain,I,I) = P1(I,I)
- + - SUM(HPV(I,1:ny)*(HP1(1:ny,I)+RG(I,1:ny)))
- DO 110 J=1,I-1
- PT(imain,I,J) = P1(I,J)
- + - SUM(HPV(I,1:ny)*(HP1(1:ny,J)+RG(J,1:ny)))
-110 PT(imain,J,I) = PT(imain,I,J)
-
-C ---------------------------------------------
-C Log-Likelihood = -(RSS + ln(det(V))/2
-C RSS = INN'*Vinv*INN
-C ---------------------------------------------
-C IFAIL=-1
-C CALL F03ABF(V(1:ny,1:ny),ny,ny,DETV,COM(1:ny,1),IFAIL)
-
- RSS = 0.D0
- DO 120 I=1,ny
- DO 120 J=1,ny
-120 RSS = RSS + INN(I)*Vinv(I,J)*INN(J)
-
- LIKE(imain) = -.5D0*(RSS + 2.D0*DLOG(DETV))
- # - ny/2.D0*DLOG(2.*3.141592653589793D0)
-
-
-1000 CONTINUE
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE KF2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,
+ 1 XT,PT,LIKE)
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
+ 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 R(nx,nu,ns(6))
+
+C OUTPUT
+ DOUBLE PRECISION LIKE(nobs)
+ DOUBLE PRECISION XT(0:nobs,nx),PT(0:nobs,nx,nx)
+
+C LOCALS
+ INTEGER imain,I,J,IFAIL
+ DOUBLE PRECISION RSS,DETV,X1(nx),P1(nx,nx),FP(nx,nx),
+ 1 INN(ny),HP1(ny,nx),V(ny,ny),Vinv(ny,ny),COM(ny+1,ny),
+ 2 RG(nx,ny),HPV(nx,ny)
+
+ LIKE(d(1)+1:nobs) = 0.D0
+ DO 1000 imain = d(1)+1,nobs
+
+C ------------------------------------
+C Prediction x1 = a+F*x0
+C Prediction var. P1 = F*p0*F'+ R*R'
+C ------------------------------------
+ DO 10 I=1,nx
+10 X1(I) = a(I,S(imain,4))+SUM(F(I,:,S(imain,5))*XT(imain-1,:))
+
+ DO 20 I=1,nx
+ DO 20 J=1,nx
+20 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain-1,:,J))
+
+ DO 30 I=1,nx
+ P1(I,I) = SUM(FP(I,:)*F(I,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(I,1:nu,S(imain,6)))
+ DO 30 J=1,I-1
+ P1(I,J) = SUM(FP(I,:)*F(J,:,S(imain,5)))
+ + + SUM(R(I,1:nu,S(imain,6))*R(J,1:nu,S(imain,6)))
+30 P1(J,I) = P1(I,J)
+
+C -------------------------------
+C Innovations: INN = yk-H*X1-c*z
+C -------------------------------
+ DO 40 I=1,ny
+40 INN(I) = yk(imain,I)
+ + - SUM(H(I,1:nx,S(imain,2))*X1(1:nx))
+ + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+C ---------------------------------------------------------
+C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
+C ---------------------------------------------------------
+ DO 50 I=1,ny
+ DO 50 J=1,nx
+50 HP1(I,J) = SUM(H(I,1:nx,S(imain,2))*P1(1:nx,J))
+
+ DO 55 I=1,nx
+ DO 55 J=1,ny
+55 RG(I,J) = SUM(R(I,1:nu,S(imain,6))
+ # * G(J,1:nu,S(imain,3))) ! R*G'
+
+ DO 56 I=1,ny
+ DO 56 J=1,ny
+56 COM(I,J)=SUM(H(I,1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
+
+ DO 60 I=1,ny
+ V(I,I) = SUM(HP1(I,1:nx)*H(I,1:nx,S(imain,2))) +
+ # SUM(G(I,1:nu,S(imain,3))*
+ # G(I,1:nu,S(imain,3))) + 2.*COM(I,I)
+
+ DO 60 J=1,I-1
+ V(I,J) = SUM(HP1(I,1:nx)*H(J,1:nx,S(imain,2)))+
+ # SUM(G(I,1:nu,S(imain,3))*
+ # G(J,1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
+60 V(J,I) = V(I,J)
+
+C -------------------------------------------------------------------
+C Updating equations:
+C x0 = x1 + (P1*H'+R*G')*Vinv*INN
+C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
+C -------------------------------------------------------------------
+ COM(1:ny,1:ny) = V(1:ny,1:ny)
+ IFAIL = -1
+c CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
+ CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
+ DETV = 1.D0 ! det(L)
+ DO I=1,ny
+ DETV = DETV*COM(I,I)
+ ENDDO
+ CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
+
+ DO 70 I=1,ny
+ Vinv(I,I) = COM(I,I)
+ DO 70 J=1,I-1
+ Vinv(I,J) = COM(I,J)
+70 Vinv(J,I) = Vinv(I,J)
+
+ DO 90 I=1,nx
+ DO 90 J=1,ny
+90 HPV(I,J) = SUM((HP1(1:ny,I)+RG(I,1:ny))*Vinv(1:ny,J))
+
+ DO 100 I=1,nx
+100 XT(imain,I) = X1(I)+SUM(HPV(I,1:ny)*INN(1:ny))
+
+ DO 110 I=1,nx
+ PT(imain,I,I) = P1(I,I)
+ + - SUM(HPV(I,1:ny)*(HP1(1:ny,I)+RG(I,1:ny)))
+ DO 110 J=1,I-1
+ PT(imain,I,J) = P1(I,J)
+ + - SUM(HPV(I,1:ny)*(HP1(1:ny,J)+RG(J,1:ny)))
+110 PT(imain,J,I) = PT(imain,I,J)
+
+C ---------------------------------------------
+C Log-Likelihood = -(RSS + ln(det(V))/2
+C RSS = INN'*Vinv*INN
+C ---------------------------------------------
+C IFAIL=-1
+C CALL F03ABF(V(1:ny,1:ny),ny,ny,DETV,COM(1:ny,1),IFAIL)
+
+ RSS = 0.D0
+ DO 120 I=1,ny
+ DO 120 J=1,ny
+120 RSS = RSS + INN(I)*Vinv(I,J)*INN(J)
+
+ LIKE(imain) = -.5D0*(RSS + 2.D0*DLOG(DETV))
+ # - ny/2.D0*DLOG(2.*3.141592653589793D0)
+
+
+1000 CONTINUE
+
+ RETURN
END
diff --git a/kim.for b/kim.for
index 9add4071d7a8f25a2a9410c7515643f1d96ced26..24c0d420c11fb26b0b098b28b41eac9525d8b694 100644
--- a/kim.for
+++ b/kim.for
@@ -1,50 +1,50 @@
-C -------------------------------------------------------------
-C KIM implements the filtering and smoothing algorithm of
-C Kim, Journal of Econometrics, 1994
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-
-C OUTPUT:
-C SFILT = Pr(S(t)|y^t), (nobs x nk)
-C SSMOOTH = Pr(S(t)|y^T), (nobs x nk)
-C XFILT = E(x(t)|y^t), (nobs x nx)
-C XSMOOTH = E(x(t)|y^T), (nobs x nx)
-C INN = E(y(t)|y^t-1),(nobs x ny
-C
-C INTERMEDIATE:
-C SP1 = Pr(S(t-1)=i,S(t)=j|y^t) nk x nk
-C SP0 = Pr(S(t)=i,S(t+1)=j|y^(t+1)) nk x nk
-C X1 = x(t|t-1,i,j) nobs x nx x nk x nk
-C P1 = E[(x(t)-X1)^2|y^(t-1)] nobs x nx x nx x nk x nk
-C X0 = x(t|t,i,j) nx x nk x nk
-C P0 = E[(x(t)-X0)^2|y^t] nx x nx x nk x nk
-C XI = x(t|t,i) nobs x nx x nk
-C PI = E[(x(t)-XI)^2|y^t] nobs x nx x nx x nk
-C V = Var(INN) ny x ny x nk x nk
-C
-C SPT1 = Pr(S(t)=j,S(t+1)=k|y^T) nk x nk
-C XS = E(x(t)|S(t)=j,S(t+1)=k,y^T) nx x nk x nk
-C PS = E[(x(t)-XS)^2|S(t)=j,S(t+1)=k,y^T] nx x nx x nk x nk
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C KIM implements the filtering and smoothing algorithm of
+C Kim, Journal of Econometrics, 1994
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+
+C OUTPUT:
+C SFILT = Pr(S(t)|y^t), (nobs x nk)
+C SSMOOTH = Pr(S(t)|y^T), (nobs x nk)
+C XFILT = E(x(t)|y^t), (nobs x nx)
+C XSMOOTH = E(x(t)|y^T), (nobs x nx)
+C INN = E(y(t)|y^t-1),(nobs x ny
+C
+C INTERMEDIATE:
+C SP1 = Pr(S(t-1)=i,S(t)=j|y^t) nk x nk
+C SP0 = Pr(S(t)=i,S(t+1)=j|y^(t+1)) nk x nk
+C X1 = x(t|t-1,i,j) nobs x nx x nk x nk
+C P1 = E[(x(t)-X1)^2|y^(t-1)] nobs x nx x nx x nk x nk
+C X0 = x(t|t,i,j) nx x nk x nk
+C P0 = E[(x(t)-X0)^2|y^t] nx x nx x nk x nk
+C XI = x(t|t,i) nobs x nx x nk
+C PI = E[(x(t)-XI)^2|y^t] nobs x nx x nx x nk
+C V = Var(INN) ny x ny x nk x nk
+C
+C SPT1 = Pr(S(t)=j,S(t+1)=k|y^T) nk x nk
+C XS = E(x(t)|S(t)=j,S(t+1)=k,y^T) nx x nk x nk
+C PS = E[(x(t)-XS)^2|S(t)=j,S(t+1)=k,y^T] nx x nx x nk x nk
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -55,372 +55,372 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------------------
- SUBROUTINE KIM(nobs,d,ny,nz,nx,nu,ns,nk,nv,np,INFOS,yk,IYK,
- 1 c,H,G,a,F,R,psi,ismoother,XSMOOTH,XSSE,SSMOOTH,INN,LIKE)
-C INPUT
- INTEGER nobs,ny,nz,nx,nu,ns(6),nk,nv,np,ismoother,
- 1 d(2),IYK(nobs,ny+1),INFOS(9,6)
- DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
- 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 R(nx,nu,ns(6)),psi(max(1,np))
-C OUTPUT
- DOUBLE PRECISION XSMOOTH(nobs,nx),XSSE(nobs,nx),SSMOOTH(nobs,nk),
- 1 LIKE(nobs),INN(nobs,ny)
-
-C LOCALS
- INTEGER imain,iny,I,J,K,L,IFAIL
- INTEGER IPIV(nx),IMAX(1),IS(max(1,d(1)),6),SEQ(1)
- DOUBLE PRECISION DETV,RSS,lfy,maxfyss,fsum
- DOUBLE PRECISION, ALLOCATABLE:: SP1(:,:),SP0(:,:),X0(:,:,:),
- 1 P0(:,:,:,:),X1(:,:,:,:),P1(:,:,:,:,:),fyss(:,:),
- 1 XI(:,:,:),PI(:,:,:,:),Pdd(:,:,:),Xdd(:,:),INNIJ(:),
- 1 V(:,:),AUX(:,:),AUX1(:,:,:,:),XFILT(:,:),SFILT(:,:),
- 1 SPT1(:,:),XS(:,:,:),PS(:,:,:,:),XSC(:,:),PSC(:,:,:),PTIL(:,:),
- 1 FP(:,:),HP1(:,:),RG(:,:),COM(:,:),VINV(:,:),HPV(:,:),W(:),
- 1 PP1(:,:),PP2(:,:),PP3(:,:),PP4(:,:),PP5(:,:),PP6(:,:),P(:,:)
-
-C EXTERNAL SUBROUTINES
- EXTERNAL DESIGNZ,PPROD,ERGODIC,INT2SEQ,IKF2,KF2,DPOTRF,DPOTRI,
- 1 DGETRF,DGETRS
-
- LIKE(:) = 0.D0
- INN(:,:) = 0.D0
- ALLOCATE(PP1(INFOS(8,1),INFOS(8,1)),PP2(INFOS(8,2),INFOS(8,2)),
- 1 PP3(INFOS(8,3),INFOS(8,3)),PP4(INFOS(8,4),INFOS(8,4)),
- 1 PP5(INFOS(8,5),INFOS(8,5)),PP6(INFOS(8,6),INFOS(8,6)),
- 1 P(nk,nk))
- CALL DESIGNZ(nv,np,psi,INFOS,PP1,PP2,PP3,PP4,PP5,PP6)
- CALL PPROD(nv,nk,INFOS,PP1,PP2,PP3,PP4,PP5,PP6,P)
- DEALLOCATE(PP1,PP2,PP3,PP4,PP5,PP6)
-
-C S-filter initialization Pr[S(d-1),S(d)|y^d]
-C X-filter initialization
- ALLOCATE(SP1(nk,nk),SP0(nk,nk),X0(nx,nk,nk),P0(nx,nx,nk,nk),
- 1 X1(nobs,nx,nk,nk),P1(nobs,nx,nx,nk,nk),INNIJ(ny),
- 1 XI(nobs,nx,nk),PI(nobs,nx,nx,nk),fyss(nk,nk),V(ny,ny),
- 1 AUX(nx,nx),AUX1(nx,nx,nk,nk),XFILT(nobs,nx),SFILT(nobs,nk),
- 1 Pdd(MAX(d(1),1),nx,nx),Xdd(MAX(d(1),1),nx),FP(nx,nx),HP1(ny,nx),
- 1 RG(nx,ny),COM(ny+1,ny),VINV(ny,ny),HPV(nx,ny))
-
- CALL ERGODIC(nk,P,fyss(1:nk,1))
- IF (d(1).LE.1) THEN
- RSS = 0.D0
- DO J = 1,nk ! S(d)
- DO I = 1,nk ! S(d-1)
- CALL INT2SEQ(J,nv,INFOS,SEQ,IS(max(1,d(1)),:))
- CALL IKF2(d,ny,nz,nx,nu,ns,IS(1,:),yk(1,:),
- 1 c,H,G,a,F,R,Xdd(1,:),Pdd(1,:,:),LIKE(1))
-
- IF (d(1).EQ.0) THEN
- X1(1,:,1,1) = Xdd(1,:) ! 0|0
- P1(1,:,:,1,1) = Pdd(1,:,:)
- CALL KF2(1,d,ny,nz,nx,nu,ns,IS,yk(1,:),c,H,G,a,F,R,
- 1 X1(1:2,:,1,1),P1(1:2,:,:,1,1),LIKE(1))
- SP0(I,J) = P(J,I)*fyss(I,1)*LIKE(1)
-
- X0(:,I,J) = X1(2,:,1,1)
- P0(:,:,I,J) = P1(2,:,:,1,1)
- XI(1,:,J) = X1(2,:,1,1)
- PI(1,:,:,J) = P1(2,:,:,1,1)
- ELSE
- SP0(I,J) = P(J,I)*fyss(I,1)
- X0(:,I,J) = Xdd(1,:) ! 1|1
- P0(:,:,I,J) = Pdd(1,:,:)
- XI(1,:,J) = Xdd(1,:)
- PI(1,:,:,J) = Pdd(1,:,:)
- ENDIF
- RSS = RSS+SP0(I,J)
- ENDDO
-
- ENDDO
- ELSE
- WRITE(*,*) 'WARNING: d(1)=2 not implemeted yet'
- PAUSE
- STOP
- ENDIF
- SP0(:,:) = SP0(:,:)/RSS
- DO I =1,nk
- SFILT(max(1,d(1)),I) = SUM(SP0(:,I))
- ENDDO
- DEALLOCATE(Xdd,Pdd)
-
-C ---------
-C Filtering
-C ---------
- XFILT(:,:) = 0.D0
- DO 1000 imain=max(2,d(1)+1),nobs
- iny = IYK(imain,ny+1)
- DO I = 1,nk
- DO J = 1,nk
- CALL INT2SEQ(J,nv,INFOS,SEQ,IS(1,:))
-C ------------------------------------
-C Prediction x1 = a+F*x0
-C Prediction var. P1 = F*p0*F'+ R*R'
-C ------------------------------------
- DO 10 K=1,nx
-10 X1(imain,K,I,J)=a(K,IS(1,4))+SUM(F(K,:,IS(1,5))*XI(imain-1,:,I))
-
- DO 20 K=1,nx
- DO 20 L=1,nx
-20 FP(K,L) = SUM(F(K,:,IS(1,5))*PI(imain-1,:,L,I))
-
- DO 30 K=1,nx
- P1(imain,K,K,I,J) = SUM(FP(K,:)*F(K,:,IS(1,5)))
- + + SUM(R(K,1:nu,IS(1,6))*R(K,1:nu,IS(1,6)))
- DO 30 L=1,K-1
- P1(imain,K,L,I,J) = SUM(FP(K,:)*F(L,:,IS(1,5)))
- + + SUM(R(K,1:nu,IS(1,6))*R(L,1:nu,IS(1,6)))
-30 P1(imain,L,K,I,J) = P1(imain,K,L,I,J)
-
-C -------------------------------
-C Innovations: INN = yk-H*X1-c*z
-C -------------------------------
- DO 40 K=1,iny
-40 INNIJ(K) = yk(imain,IYK(imain,K))
- + - SUM(H(IYK(imain,K),1:nx,IS(1,2))*X1(imain,:,I,J))
- + - SUM(c(IYK(imain,K),1:nz,IS(1,1))*yk(imain,ny+1:ny+nz))
- INN(imain,1:ny) = INN(imain,1:ny)
- + + INNIJ(1:ny)*P(J,I)*SFILT(imain-1,I)
-
-C ---------------------------------------------------------
-C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
-C ---------------------------------------------------------
- DO 50 K=1,iny
- DO 50 L=1,nx
-50 HP1(K,L)=SUM(H(IYK(imain,K),1:nx,IS(1,2))*P1(imain,1:nx,L,I,J))
-
- DO 55 K=1,nx
- DO 55 L=1,iny
-55 RG(K,L) = SUM(R(K,1:nu,IS(1,6))*G(IYK(imain,L),1:nu,IS(1,3))) ! R*G'
-
- DO 56 K=1,iny
- DO 56 L=1,iny
-56 COM(K,L)=SUM(H(IYK(imain,K),1:nx,IS(1,2))*RG(1:nx,L)) ! H*R*G'
-
- DO 60 K=1,iny
- V(K,K) = SUM(HP1(K,1:nx)*H(IYK(imain,K),1:nx,IS(1,2)))
- # + SUM(G(IYK(imain,K),1:nu,IS(1,3))
- # * G(IYK(imain,K),1:nu,IS(1,3)))+2.*COM(K,K)
-
- DO 60 L=1,K-1
- V(K,L) = SUM(HP1(K,1:nx)*H(IYK(imain,L),1:nx,IS(1,2)))
- # + SUM(G(IYK(imain,K),1:nu,IS(1,3))
- # * G(IYK(imain,L),1:nu,IS(1,3)))+COM(K,L)+COM(L,K)
-60 V(L,K) = V(K,L)
-
-C -------------------------------------------------------------------
-C Updating equations:
-C x0 = x1 + (P1*H'+R*G')*Vinv*INN
-C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
-C -------------------------------------------------------------------
- IF (iny.GT.0) THEN
- COM(1:iny,1:iny) = V(1:iny,1:iny)
- IFAIL = -1
-C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- DETV = 1.D0 ! det(L)
- DO K=1,iny
- DETV = DETV*COM(K,K)
- ENDDO
- CALL DPOTRI('L',iny,COM(1:iny,1:ny),iny,IFAIL) ! COM = VV^-1
-
- DO 70 K=1,iny
- VINV(K,K) = COM(K,K)
- DO 70 L=1,K-1
- VINV(K,L) = COM(K,L)
-70 VINV(L,K) = VINV(K,L)
-
- DO 90 K=1,nx
- DO 90 L=1,iny
-90 HPV(K,L) = SUM((HP1(1:iny,K)+RG(K,1:iny))*VINV(1:iny,L))
-
- DO 100 K=1,nx
-100 X0(K,I,J)=X1(imain,K,I,J)+SUM(HPV(K,1:iny)*INNIJ(1:iny))
-
- DO 110 K=1,nx
- P0(K,K,I,J) = P1(imain,K,K,I,J)
- + - SUM(HPV(K,1:iny)*(HP1(1:iny,K)+RG(K,1:iny)))
- DO 110 L=1,K-1
- P0(K,L,I,J) = P1(imain,K,L,I,J)
- + - SUM(HPV(K,1:iny)*(HP1(1:iny,L)+RG(L,1:iny)))
-110 P0(L,K,I,J) = P0(K,L,I,J)
-
-C ---------------------------------------------
-C log f(y(t)|S(t-1)=i,S(t)=j,y^(t-1))
-C Log-Likelihood = -(RSS + ln(det(V))/2
-C RSS = INN'*VINV*INN
-C ---------------------------------------------
-C IFAIL=-1
-C CALL F03ABF(V(1:iny,1:iny),iny,iny,DETV,COM(1:iny,1),IFAIL)
- RSS = 0.D0
- DO 120 K=1,iny
- DO 120 L=1,iny
-120 RSS = RSS + INNIJ(K)*VINV(K,L)*INNIJ(L)
-
- lfy=-.5D0*(RSS+2.*DLOG(DETV)+iny*DLOG(2.*3.141592653589793D0))
- fyss(I,J) = lfy + DLOG(P(J,I)) + DLOG(SUM(SP0(:,I)))
-
- ELSE
-
- X0(:,I,J) = X1(imain,:,I,J)
- P0(:,:,I,J) = P1(imain,:,:,I,J)
-
- ENDIF
-
- ENDDO
- ENDDO
-
-C log f(y(t)|y^(t-1))
- IF (iny.GT.0) THEN
- IMAX = MAXLOC(fyss(:,1))
- maxfyss = fyss(IMAX(1),1)
- DO 130 K = 2,nk
- IMAX = MAXLOC(fyss(:,K))
-130 maxfyss = MAX(fyss(IMAX(1),K),maxfyss)
-
- fyss(:,:) = fyss(:,:) - maxfyss
-
- fsum = 0.D0
- DO 140 I=1,nk
- DO 140 J=1,nk
-140 fsum = fsum + dexp(fyss(I,J))
-
- LIKE(imain) = maxfyss+DLOG(fsum)
-
-C Compute SP1 = Pr(S(t-1)=i,S(t)=j|y^t)
- SP1(:,:) = DEXP(fyss(:,:)-DLOG(fsum))
-
- ELSE
-
-C Compute SP1 = Pr(S(t-1)=i,S(t)=j|y^t-1)=Pr(S(t)=j|S(t-1)=i)*Pr(S(t-1)=i|y^t-1)
- DO I = 1,nk
- DO J = 1,nk
- SP1(I,J) = P(J,I)*SFILT(imain-1,I)
- ENDDO
- ENDDO
- ENDIF
-
-C Compute Pr(S(t)=j|y^t)
- DO 145 J = 1,nk
-145 SFILT(imain,J) = SUM(SP1(:,J))
-
-C Shrinking XJ
- DO 150 J = 1,nk
- DO 150 K = 1,nx
-150 XI(imain,K,J) = SUM(SP1(:,J)*X0(K,:,J))/SFILT(imain,J)
-
-C Shrinking PJ
- DO 160 I=1,nk
- DO 160 J=1,nk
- DO 160 K=1,nx
- DO 160 L=1,nx
-160 AUX1(K,L,I,J) = P0(K,L,I,J)
- # + (XI(imain,K,J)-X0(K,I,J))*(XI(imain,L,J)-X0(L,I,J))
-
- DO 170 J=1,nk
- DO 170 K=1,nx
- DO 170 L=1,nx
-170 PI(imain,K,L,J) = SUM(SP1(:,J)*AUX1(K,L,:,J))/SFILT(imain,J)
-
-C Computing E(x(t)|y^t)
- DO 175 J=1,nk
-175 XFILT(imain,:)=XFILT(imain,:)+XI(imain,:,J)*SFILT(imain,J)
-
-1000 SP0(:,:) = SP1(:,:)
-
- DEALLOCATE(SP1,SP0,X0,P0,AUX1,fyss,VINV,INNIJ)
-
-C Smoothing S and X
- IF (ismoother.EQ.1) THEN
- ALLOCATE(SPT1(nk,nk),XS(nx,nk,nk),PS(nx,nx,nk,nk),XSC(nx,nk),
- 1 PSC(nx,nx,nk),PTIL(nx,nx),W(nk))
-
- SSMOOTH(nobs,:) = SFILT(nobs,:)
- XSMOOTH(nobs,:) = XFILT(nobs,:)
- DO I=1,nx
- XSSE(nobs,I) = dsqrt(SUM(SFILT(nobs,1:nk)*PI(nobs,I,I,1:nk)))
- ENDDO
- XSC(:,:) = XI(nobs,:,:)
- PSC(:,:,:) = PI(nobs,:,:,:)
- DO 2000 imain = nobs-1,1,-1
-C SPT1:= Pr(S(t)=j,S(t+1)=k|y^T)=Pr(S(t+1)=k|y^T)*Pr(S(t)=j|y^t)*Pr(S(t+1)=k|S(t)=j)/Pr(S(t+1)=k|y^t) - (2.20')
-C Pr(S(t+1)=k|y^t) = sum_i Pr(S(t+1)=k|S(t)=i)*Pr(S(t)=i|y^t)
-C XS:= E(x(t)|S(t)=j,S(t+1)=k,y^T) nx x nk x nk (2.24)
-C PS:= E[(x(t)-XS)^2|S(t)=j,S(t+1)=k,y^T] nx x nx x nk x nk (2.25)
- DO J=1,nk
- DO K=1,nk
- CALL INT2SEQ(K,nv,INFOS,SEQ,IS(1,:))
- SPT1(J,K) = SSMOOTH(imain+1,K)*SFILT(imain,J)*P(K,J)
- # / SUM(P(K,1:nk)*SFILT(imain,1:nk))
-C PTIL=(PI(imain,:,:,J)*PHI((K-1)*nx+1:K*nx,(K-1)*nx+1:K*nx)')/P1(imain+1,:,:,J,K)
-C the traspose is stored
- DO 180 I=1,nx
- DO 180 L=1,nx
-180 PTIL(L,I) = SUM(PI(imain,I,:,J)*F(L,:,IS(1,5)))
-
-C P1(imain+1,:,:,J,K) * PTIL' = PHI((K-1)*nx+1:K*nx,(K-1)*nx+1:K*nx)*PI(imain,:,:,J)'
-C nx,nx nx,nx nx,nx
- AUX(:,:) = P1(imain+1,:,:,J,K)
-C CALL F07ADF(nx,nx,AUX,nx,IPIV(1:nx),IFAIL)
-C CALL F07AEF('N',nx,nx,AUX,nx,IPIV(1:nx),PTIL,nx,IFAIL) ! this gives PTIL'
- CALL DGETRF(nx,nx,AUX,nx,IPIV(1:nx),IFAIL)
- CALL DGETRS('N',nx,nx,AUX,nx,IPIV(1:nx),PTIL,nx,IFAIL) ! this gives PTIL'
-
-C XS(:,J,K) = XI(imain,:,J) + PTIL*(XSC(:,K)-X1(imain+1,:,J,K)')
- DO 190 I=1,nx
-190 XS(I,J,K) = XI(imain,I,J)
- # + SUM(PTIL(:,I)*(XSC(:,K)-X1(imain+1,:,J,K)))
-
-C PS(:,:,J,K) = PI(imain,:,:,J) + PTIL*(PSC(:,:,K)-P1(imain+1,:,:,J,K))*PTIL';
- DO 200 I=1,nx
- DO 200 L=1,nx
-200 AUX(I,L) = SUM(PTIL(:,I)*(PSC(:,L,K)-P1(imain+1,:,L,J,K)))
-
- DO 210 I=1,nx
- PS(I,I,J,K) = PI(imain,I,I,J)+SUM(AUX(I,:)*PTIL(:,I))
- DO 210 L=1,I-1
- PS(I,L,J,K) = PI(imain,I,L,J)+SUM(AUX(I,:)*PTIL(:,L))
-210 PS(L,I,J,K) = PS(I,L,J,K)
- ENDDO
-
-C SSMOOTH Kim eqn (2.21)
- SSMOOTH(imain,J) = SUM(SPT1(J,:))
-
- IF (SSMOOTH(imain,J).GT.10.D-12) THEN
- DO I=1,nk
- W(I)=SPT1(J,I)/SSMOOTH(imain,J)
- ENDDO
- ELSE
- W(1:nk)=1.D0/DFLOAT(nk)
- ENDIF
-
-C XSC(:,J) = XS(:,J,1:nk)*SPT1(J,1:nk)'/SSMOOTH(imain,J) Kim eqn (2.26)
- DO 220 I=1,nx
-220 XSC(I,J) = SUM(XS(I,J,1:nk)*W(1:nk))
-
-C PSC(:,:,J) = PSC(:,:,J)+SPT1(J,K)*(PS(:,:,J,K)+AUX)/SSMOOTH(imain,J) Kim eqn (2.27)
-C AUX = (XSC(:,J)-X1(imain,:,J,K))*(XSC(:,J)-X1(imain,:,J,K))'
- PSC(:,:,J) = 0.D0
- DO 235 K = 1,nk
- HPV(1:nx,1) = XSC(1:nx,J)-X1(imain,1:nx,J,K)
- DO 230 I=1,nx
- AUX(I,I) = HPV(I,1)*HPV(I,1)
- DO 230 L=1,I-1
- AUX(I,L) = HPV(I,1)*HPV(L,1)
-230 AUX(L,I) = AUX(I,L)
-235 PSC(:,:,J) = PSC(:,:,J) + W(K)*(PS(:,:,J,K) + AUX(:,:))
- ENDDO
-
-C Kim eqn (2.28)
- DO 240 I=1,nx
- XSMOOTH(imain,I) = SUM(SSMOOTH(imain,1:nk)*XSC(I,1:nk))
-240 XSSE(imain,I) = dsqrt(SUM(SSMOOTH(imain,1:nk)*PSC(I,I,1:nk)))
-
-2000 CONTINUE
- DEALLOCATE(X1,P1,XI,PI,AUX,SPT1,XS,PS,XSC,PSC,PTIL,XFILT,SFILT,P,W)
-
- ENDIF
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------------------
+ SUBROUTINE KIM(nobs,d,ny,nz,nx,nu,ns,nk,nv,np,INFOS,yk,IYK,
+ 1 c,H,G,a,F,R,psi,ismoother,XSMOOTH,XSSE,SSMOOTH,INN,LIKE)
+C INPUT
+ INTEGER nobs,ny,nz,nx,nu,ns(6),nk,nv,np,ismoother,
+ 1 d(2),IYK(nobs,ny+1),INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
+ 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 R(nx,nu,ns(6)),psi(max(1,np))
+C OUTPUT
+ DOUBLE PRECISION XSMOOTH(nobs,nx),XSSE(nobs,nx),SSMOOTH(nobs,nk),
+ 1 LIKE(nobs),INN(nobs,ny)
+
+C LOCALS
+ INTEGER imain,iny,I,J,K,L,IFAIL
+ INTEGER IPIV(nx),IMAX(1),IS(max(1,d(1)),6),SEQ(1)
+ DOUBLE PRECISION DETV,RSS,lfy,maxfyss,fsum
+ DOUBLE PRECISION, ALLOCATABLE:: SP1(:,:),SP0(:,:),X0(:,:,:),
+ 1 P0(:,:,:,:),X1(:,:,:,:),P1(:,:,:,:,:),fyss(:,:),
+ 1 XI(:,:,:),PI(:,:,:,:),Pdd(:,:,:),Xdd(:,:),INNIJ(:),
+ 1 V(:,:),AUX(:,:),AUX1(:,:,:,:),XFILT(:,:),SFILT(:,:),
+ 1 SPT1(:,:),XS(:,:,:),PS(:,:,:,:),XSC(:,:),PSC(:,:,:),PTIL(:,:),
+ 1 FP(:,:),HP1(:,:),RG(:,:),COM(:,:),VINV(:,:),HPV(:,:),W(:),
+ 1 PP1(:,:),PP2(:,:),PP3(:,:),PP4(:,:),PP5(:,:),PP6(:,:),P(:,:)
+
+C EXTERNAL SUBROUTINES
+ EXTERNAL DESIGNZ,PPROD,ERGODIC,INT2SEQ,IKF2,KF2,DPOTRF,DPOTRI,
+ 1 DGETRF,DGETRS
+
+ LIKE(:) = 0.D0
+ INN(:,:) = 0.D0
+ ALLOCATE(PP1(INFOS(8,1),INFOS(8,1)),PP2(INFOS(8,2),INFOS(8,2)),
+ 1 PP3(INFOS(8,3),INFOS(8,3)),PP4(INFOS(8,4),INFOS(8,4)),
+ 1 PP5(INFOS(8,5),INFOS(8,5)),PP6(INFOS(8,6),INFOS(8,6)),
+ 1 P(nk,nk))
+ CALL DESIGNZ(nv,np,psi,INFOS,PP1,PP2,PP3,PP4,PP5,PP6)
+ CALL PPROD(nv,nk,INFOS,PP1,PP2,PP3,PP4,PP5,PP6,P)
+ DEALLOCATE(PP1,PP2,PP3,PP4,PP5,PP6)
+
+C S-filter initialization Pr[S(d-1),S(d)|y^d]
+C X-filter initialization
+ ALLOCATE(SP1(nk,nk),SP0(nk,nk),X0(nx,nk,nk),P0(nx,nx,nk,nk),
+ 1 X1(nobs,nx,nk,nk),P1(nobs,nx,nx,nk,nk),INNIJ(ny),
+ 1 XI(nobs,nx,nk),PI(nobs,nx,nx,nk),fyss(nk,nk),V(ny,ny),
+ 1 AUX(nx,nx),AUX1(nx,nx,nk,nk),XFILT(nobs,nx),SFILT(nobs,nk),
+ 1 Pdd(MAX(d(1),1),nx,nx),Xdd(MAX(d(1),1),nx),FP(nx,nx),HP1(ny,nx),
+ 1 RG(nx,ny),COM(ny+1,ny),VINV(ny,ny),HPV(nx,ny))
+
+ CALL ERGODIC(nk,P,fyss(1:nk,1))
+ IF (d(1).LE.1) THEN
+ RSS = 0.D0
+ DO J = 1,nk ! S(d)
+ DO I = 1,nk ! S(d-1)
+ CALL INT2SEQ(J,nv,INFOS,SEQ,IS(max(1,d(1)),:))
+ CALL IKF2(d,ny,nz,nx,nu,ns,IS(1,:),yk(1,:),
+ 1 c,H,G,a,F,R,Xdd(1,:),Pdd(1,:,:),LIKE(1))
+
+ IF (d(1).EQ.0) THEN
+ X1(1,:,1,1) = Xdd(1,:) ! 0|0
+ P1(1,:,:,1,1) = Pdd(1,:,:)
+ CALL KF2(1,d,ny,nz,nx,nu,ns,IS,yk(1,:),c,H,G,a,F,R,
+ 1 X1(1:2,:,1,1),P1(1:2,:,:,1,1),LIKE(1))
+ SP0(I,J) = P(J,I)*fyss(I,1)*LIKE(1)
+
+ X0(:,I,J) = X1(2,:,1,1)
+ P0(:,:,I,J) = P1(2,:,:,1,1)
+ XI(1,:,J) = X1(2,:,1,1)
+ PI(1,:,:,J) = P1(2,:,:,1,1)
+ ELSE
+ SP0(I,J) = P(J,I)*fyss(I,1)
+ X0(:,I,J) = Xdd(1,:) ! 1|1
+ P0(:,:,I,J) = Pdd(1,:,:)
+ XI(1,:,J) = Xdd(1,:)
+ PI(1,:,:,J) = Pdd(1,:,:)
+ ENDIF
+ RSS = RSS+SP0(I,J)
+ ENDDO
+
+ ENDDO
+ ELSE
+ WRITE(*,*) 'WARNING: d(1)=2 not implemeted yet'
+ PAUSE
+ STOP
+ ENDIF
+ SP0(:,:) = SP0(:,:)/RSS
+ DO I =1,nk
+ SFILT(max(1,d(1)),I) = SUM(SP0(:,I))
+ ENDDO
+ DEALLOCATE(Xdd,Pdd)
+
+C ---------
+C Filtering
+C ---------
+ XFILT(:,:) = 0.D0
+ DO 1000 imain=max(2,d(1)+1),nobs
+ iny = IYK(imain,ny+1)
+ DO I = 1,nk
+ DO J = 1,nk
+ CALL INT2SEQ(J,nv,INFOS,SEQ,IS(1,:))
+C ------------------------------------
+C Prediction x1 = a+F*x0
+C Prediction var. P1 = F*p0*F'+ R*R'
+C ------------------------------------
+ DO 10 K=1,nx
+10 X1(imain,K,I,J)=a(K,IS(1,4))+SUM(F(K,:,IS(1,5))*XI(imain-1,:,I))
+
+ DO 20 K=1,nx
+ DO 20 L=1,nx
+20 FP(K,L) = SUM(F(K,:,IS(1,5))*PI(imain-1,:,L,I))
+
+ DO 30 K=1,nx
+ P1(imain,K,K,I,J) = SUM(FP(K,:)*F(K,:,IS(1,5)))
+ + + SUM(R(K,1:nu,IS(1,6))*R(K,1:nu,IS(1,6)))
+ DO 30 L=1,K-1
+ P1(imain,K,L,I,J) = SUM(FP(K,:)*F(L,:,IS(1,5)))
+ + + SUM(R(K,1:nu,IS(1,6))*R(L,1:nu,IS(1,6)))
+30 P1(imain,L,K,I,J) = P1(imain,K,L,I,J)
+
+C -------------------------------
+C Innovations: INN = yk-H*X1-c*z
+C -------------------------------
+ DO 40 K=1,iny
+40 INNIJ(K) = yk(imain,IYK(imain,K))
+ + - SUM(H(IYK(imain,K),1:nx,IS(1,2))*X1(imain,:,I,J))
+ + - SUM(c(IYK(imain,K),1:nz,IS(1,1))*yk(imain,ny+1:ny+nz))
+ INN(imain,1:ny) = INN(imain,1:ny)
+ + + INNIJ(1:ny)*P(J,I)*SFILT(imain-1,I)
+
+C ---------------------------------------------------------
+C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
+C ---------------------------------------------------------
+ DO 50 K=1,iny
+ DO 50 L=1,nx
+50 HP1(K,L)=SUM(H(IYK(imain,K),1:nx,IS(1,2))*P1(imain,1:nx,L,I,J))
+
+ DO 55 K=1,nx
+ DO 55 L=1,iny
+55 RG(K,L) = SUM(R(K,1:nu,IS(1,6))*G(IYK(imain,L),1:nu,IS(1,3))) ! R*G'
+
+ DO 56 K=1,iny
+ DO 56 L=1,iny
+56 COM(K,L)=SUM(H(IYK(imain,K),1:nx,IS(1,2))*RG(1:nx,L)) ! H*R*G'
+
+ DO 60 K=1,iny
+ V(K,K) = SUM(HP1(K,1:nx)*H(IYK(imain,K),1:nx,IS(1,2)))
+ # + SUM(G(IYK(imain,K),1:nu,IS(1,3))
+ # * G(IYK(imain,K),1:nu,IS(1,3)))+2.*COM(K,K)
+
+ DO 60 L=1,K-1
+ V(K,L) = SUM(HP1(K,1:nx)*H(IYK(imain,L),1:nx,IS(1,2)))
+ # + SUM(G(IYK(imain,K),1:nu,IS(1,3))
+ # * G(IYK(imain,L),1:nu,IS(1,3)))+COM(K,L)+COM(L,K)
+60 V(L,K) = V(K,L)
+
+C -------------------------------------------------------------------
+C Updating equations:
+C x0 = x1 + (P1*H'+R*G')*Vinv*INN
+C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
+C -------------------------------------------------------------------
+ IF (iny.GT.0) THEN
+ COM(1:iny,1:iny) = V(1:iny,1:iny)
+ IFAIL = -1
+C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ DETV = 1.D0 ! det(L)
+ DO K=1,iny
+ DETV = DETV*COM(K,K)
+ ENDDO
+ CALL DPOTRI('L',iny,COM(1:iny,1:ny),iny,IFAIL) ! COM = VV^-1
+
+ DO 70 K=1,iny
+ VINV(K,K) = COM(K,K)
+ DO 70 L=1,K-1
+ VINV(K,L) = COM(K,L)
+70 VINV(L,K) = VINV(K,L)
+
+ DO 90 K=1,nx
+ DO 90 L=1,iny
+90 HPV(K,L) = SUM((HP1(1:iny,K)+RG(K,1:iny))*VINV(1:iny,L))
+
+ DO 100 K=1,nx
+100 X0(K,I,J)=X1(imain,K,I,J)+SUM(HPV(K,1:iny)*INNIJ(1:iny))
+
+ DO 110 K=1,nx
+ P0(K,K,I,J) = P1(imain,K,K,I,J)
+ + - SUM(HPV(K,1:iny)*(HP1(1:iny,K)+RG(K,1:iny)))
+ DO 110 L=1,K-1
+ P0(K,L,I,J) = P1(imain,K,L,I,J)
+ + - SUM(HPV(K,1:iny)*(HP1(1:iny,L)+RG(L,1:iny)))
+110 P0(L,K,I,J) = P0(K,L,I,J)
+
+C ---------------------------------------------
+C log f(y(t)|S(t-1)=i,S(t)=j,y^(t-1))
+C Log-Likelihood = -(RSS + ln(det(V))/2
+C RSS = INN'*VINV*INN
+C ---------------------------------------------
+C IFAIL=-1
+C CALL F03ABF(V(1:iny,1:iny),iny,iny,DETV,COM(1:iny,1),IFAIL)
+ RSS = 0.D0
+ DO 120 K=1,iny
+ DO 120 L=1,iny
+120 RSS = RSS + INNIJ(K)*VINV(K,L)*INNIJ(L)
+
+ lfy=-.5D0*(RSS+2.*DLOG(DETV)+iny*DLOG(2.*3.141592653589793D0))
+ fyss(I,J) = lfy + DLOG(P(J,I)) + DLOG(SUM(SP0(:,I)))
+
+ ELSE
+
+ X0(:,I,J) = X1(imain,:,I,J)
+ P0(:,:,I,J) = P1(imain,:,:,I,J)
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+C log f(y(t)|y^(t-1))
+ IF (iny.GT.0) THEN
+ IMAX = MAXLOC(fyss(:,1))
+ maxfyss = fyss(IMAX(1),1)
+ DO 130 K = 2,nk
+ IMAX = MAXLOC(fyss(:,K))
+130 maxfyss = MAX(fyss(IMAX(1),K),maxfyss)
+
+ fyss(:,:) = fyss(:,:) - maxfyss
+
+ fsum = 0.D0
+ DO 140 I=1,nk
+ DO 140 J=1,nk
+140 fsum = fsum + dexp(fyss(I,J))
+
+ LIKE(imain) = maxfyss+DLOG(fsum)
+
+C Compute SP1 = Pr(S(t-1)=i,S(t)=j|y^t)
+ SP1(:,:) = DEXP(fyss(:,:)-DLOG(fsum))
+
+ ELSE
+
+C Compute SP1 = Pr(S(t-1)=i,S(t)=j|y^t-1)=Pr(S(t)=j|S(t-1)=i)*Pr(S(t-1)=i|y^t-1)
+ DO I = 1,nk
+ DO J = 1,nk
+ SP1(I,J) = P(J,I)*SFILT(imain-1,I)
+ ENDDO
+ ENDDO
+ ENDIF
+
+C Compute Pr(S(t)=j|y^t)
+ DO 145 J = 1,nk
+145 SFILT(imain,J) = SUM(SP1(:,J))
+
+C Shrinking XJ
+ DO 150 J = 1,nk
+ DO 150 K = 1,nx
+150 XI(imain,K,J) = SUM(SP1(:,J)*X0(K,:,J))/SFILT(imain,J)
+
+C Shrinking PJ
+ DO 160 I=1,nk
+ DO 160 J=1,nk
+ DO 160 K=1,nx
+ DO 160 L=1,nx
+160 AUX1(K,L,I,J) = P0(K,L,I,J)
+ # + (XI(imain,K,J)-X0(K,I,J))*(XI(imain,L,J)-X0(L,I,J))
+
+ DO 170 J=1,nk
+ DO 170 K=1,nx
+ DO 170 L=1,nx
+170 PI(imain,K,L,J) = SUM(SP1(:,J)*AUX1(K,L,:,J))/SFILT(imain,J)
+
+C Computing E(x(t)|y^t)
+ DO 175 J=1,nk
+175 XFILT(imain,:)=XFILT(imain,:)+XI(imain,:,J)*SFILT(imain,J)
+
+1000 SP0(:,:) = SP1(:,:)
+
+ DEALLOCATE(SP1,SP0,X0,P0,AUX1,fyss,VINV,INNIJ)
+
+C Smoothing S and X
+ IF (ismoother.EQ.1) THEN
+ ALLOCATE(SPT1(nk,nk),XS(nx,nk,nk),PS(nx,nx,nk,nk),XSC(nx,nk),
+ 1 PSC(nx,nx,nk),PTIL(nx,nx),W(nk))
+
+ SSMOOTH(nobs,:) = SFILT(nobs,:)
+ XSMOOTH(nobs,:) = XFILT(nobs,:)
+ DO I=1,nx
+ XSSE(nobs,I) = dsqrt(SUM(SFILT(nobs,1:nk)*PI(nobs,I,I,1:nk)))
+ ENDDO
+ XSC(:,:) = XI(nobs,:,:)
+ PSC(:,:,:) = PI(nobs,:,:,:)
+ DO 2000 imain = nobs-1,1,-1
+C SPT1:= Pr(S(t)=j,S(t+1)=k|y^T)=Pr(S(t+1)=k|y^T)*Pr(S(t)=j|y^t)*Pr(S(t+1)=k|S(t)=j)/Pr(S(t+1)=k|y^t) - (2.20')
+C Pr(S(t+1)=k|y^t) = sum_i Pr(S(t+1)=k|S(t)=i)*Pr(S(t)=i|y^t)
+C XS:= E(x(t)|S(t)=j,S(t+1)=k,y^T) nx x nk x nk (2.24)
+C PS:= E[(x(t)-XS)^2|S(t)=j,S(t+1)=k,y^T] nx x nx x nk x nk (2.25)
+ DO J=1,nk
+ DO K=1,nk
+ CALL INT2SEQ(K,nv,INFOS,SEQ,IS(1,:))
+ SPT1(J,K) = SSMOOTH(imain+1,K)*SFILT(imain,J)*P(K,J)
+ # / SUM(P(K,1:nk)*SFILT(imain,1:nk))
+C PTIL=(PI(imain,:,:,J)*PHI((K-1)*nx+1:K*nx,(K-1)*nx+1:K*nx)')/P1(imain+1,:,:,J,K)
+C the traspose is stored
+ DO 180 I=1,nx
+ DO 180 L=1,nx
+180 PTIL(L,I) = SUM(PI(imain,I,:,J)*F(L,:,IS(1,5)))
+
+C P1(imain+1,:,:,J,K) * PTIL' = PHI((K-1)*nx+1:K*nx,(K-1)*nx+1:K*nx)*PI(imain,:,:,J)'
+C nx,nx nx,nx nx,nx
+ AUX(:,:) = P1(imain+1,:,:,J,K)
+C CALL F07ADF(nx,nx,AUX,nx,IPIV(1:nx),IFAIL)
+C CALL F07AEF('N',nx,nx,AUX,nx,IPIV(1:nx),PTIL,nx,IFAIL) ! this gives PTIL'
+ CALL DGETRF(nx,nx,AUX,nx,IPIV(1:nx),IFAIL)
+ CALL DGETRS('N',nx,nx,AUX,nx,IPIV(1:nx),PTIL,nx,IFAIL) ! this gives PTIL'
+
+C XS(:,J,K) = XI(imain,:,J) + PTIL*(XSC(:,K)-X1(imain+1,:,J,K)')
+ DO 190 I=1,nx
+190 XS(I,J,K) = XI(imain,I,J)
+ # + SUM(PTIL(:,I)*(XSC(:,K)-X1(imain+1,:,J,K)))
+
+C PS(:,:,J,K) = PI(imain,:,:,J) + PTIL*(PSC(:,:,K)-P1(imain+1,:,:,J,K))*PTIL';
+ DO 200 I=1,nx
+ DO 200 L=1,nx
+200 AUX(I,L) = SUM(PTIL(:,I)*(PSC(:,L,K)-P1(imain+1,:,L,J,K)))
+
+ DO 210 I=1,nx
+ PS(I,I,J,K) = PI(imain,I,I,J)+SUM(AUX(I,:)*PTIL(:,I))
+ DO 210 L=1,I-1
+ PS(I,L,J,K) = PI(imain,I,L,J)+SUM(AUX(I,:)*PTIL(:,L))
+210 PS(L,I,J,K) = PS(I,L,J,K)
+ ENDDO
+
+C SSMOOTH Kim eqn (2.21)
+ SSMOOTH(imain,J) = SUM(SPT1(J,:))
+
+ IF (SSMOOTH(imain,J).GT.10.D-12) THEN
+ DO I=1,nk
+ W(I)=SPT1(J,I)/SSMOOTH(imain,J)
+ ENDDO
+ ELSE
+ W(1:nk)=1.D0/DFLOAT(nk)
+ ENDIF
+
+C XSC(:,J) = XS(:,J,1:nk)*SPT1(J,1:nk)'/SSMOOTH(imain,J) Kim eqn (2.26)
+ DO 220 I=1,nx
+220 XSC(I,J) = SUM(XS(I,J,1:nk)*W(1:nk))
+
+C PSC(:,:,J) = PSC(:,:,J)+SPT1(J,K)*(PS(:,:,J,K)+AUX)/SSMOOTH(imain,J) Kim eqn (2.27)
+C AUX = (XSC(:,J)-X1(imain,:,J,K))*(XSC(:,J)-X1(imain,:,J,K))'
+ PSC(:,:,J) = 0.D0
+ DO 235 K = 1,nk
+ HPV(1:nx,1) = XSC(1:nx,J)-X1(imain,1:nx,J,K)
+ DO 230 I=1,nx
+ AUX(I,I) = HPV(I,1)*HPV(I,1)
+ DO 230 L=1,I-1
+ AUX(I,L) = HPV(I,1)*HPV(L,1)
+230 AUX(L,I) = AUX(I,L)
+235 PSC(:,:,J) = PSC(:,:,J) + W(K)*(PS(:,:,J,K) + AUX(:,:))
+ ENDDO
+
+C Kim eqn (2.28)
+ DO 240 I=1,nx
+ XSMOOTH(imain,I) = SUM(SSMOOTH(imain,1:nk)*XSC(I,1:nk))
+240 XSSE(imain,I) = dsqrt(SUM(SSMOOTH(imain,1:nk)*PSC(I,I,1:nk)))
+
+2000 CONTINUE
+ DEALLOCATE(X1,P1,XI,PI,AUX,SPT1,XS,PS,XSC,PSC,PTIL,XFILT,SFILT,P,W)
+
+ ENDIF
+ RETURN
END
diff --git a/ks.for b/ks.for
index 89353488b4f8769bddabbdd7b0677041f7931a8f..8a1343c78ea1c89f1c9702f9d2afb9b5b8e4a48d 100644
--- a/ks.for
+++ b/ks.for
@@ -1,34 +1,34 @@
-C --------------------------------------------------------------------
-C KS IMPLEMENTS THE KALMAN SMMOOTHER RECURSIONS in
-C Koopman (1997), JASA, 92, 440, 1630-38
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C XS = E[x(t)|y(1),...,y(nobs)]
-C PS = V[x(t)|y(1),...,y(nobs)], t = 1,2,...,nobs
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C KS IMPLEMENTS THE KALMAN SMMOOTHER RECURSIONS in
+C Koopman (1997), JASA, 92, 440, 1630-38
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C XS = E[x(t)|y(1),...,y(nobs)]
+C PS = V[x(t)|y(1),...,y(nobs)], t = 1,2,...,nobs
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -39,560 +39,560 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE KS(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XS,PS)
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6),IYK(nobs,ny+1)
- DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
- 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 R(nx,nu,ns(6))
-
-C OUTPUT
- DOUBLE PRECISION XS(nobs,nx),PS(nobs,nx,nx)
-
-C LOCALS
- INTEGER imain,iny,I,J,IFAIL,FiRANK,ITIME
- INTEGER IPIV(nx)
- DOUBLE PRECISION TOL,SUMW1
- DOUBLE PRECISION,ALLOCATABLE:: Pi(:,:,:),HPs(:,:),HPi(:,:),
- 1 Fi(:,:),Fs(:,:),Fim(:,:),Fsm(:,:),PHFs(:,:),PHFi(:,:),FFF(:,:),
- 2 Mi(:,:),Ms(:,:),Ci(:,:),Kst(:,:,:),Kit(:,:,:),W1(:),WORK(:),
- 3 WORK1(:),PFP(:,:),APPO(:,:),APPO1(:,:),COM(:,:),RG(:,:),
- 4 FP(:,:),HP1(:,:),V(:,:),CC(:,:),HPV(:,:),X0(:),P0(:,:),
- 5 RECR(:),RECRI(:),RECN(:,:),XT(:,:),PT(:,:,:),INN(:,:),
- 1 Vinv(:,:,:),Vis(:,:,:),Vii(:,:,:)
-
-C EXTERNAL SUBROUTINES
- EXTERNAL INVF,INVFBIS,LYAP,DSYEV,DPOTRF,DPOTRI,DGETRF,DGETRI
-
- ALLOCATE(Pi(d(1),nx,nx),HPs(ny,nx),HPi(ny,nx),
- 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
- 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ms(nx,ny),Ci(nx,nx),
- 3 Kst(d(1),nx,ny),Kit(d(1),nx,ny))
-
- ALLOCATE(W1(ny),WORK(64*nx),WORK1(64*ny),
- 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny))
-
- ALLOCATE(FP(nx,nx),HP1(ny,nx),V(ny,ny),CC(nx,nx),
- 1 HPV(nx,ny),X0(nx),P0(nx,nx),RECR(nx),RECRI(nx),RECN(nx,nx))
-
- ALLOCATE(XT(nobs,nx),PT(nobs,nx,nx),INN(nobs,ny),
- 1 Vinv(nobs,ny,ny),Vis(d(1),ny,ny),Vii(d(1),ny,ny))
-
- TOL = 1.D-3
-C Unconditional mean and variance
- IF (d(1).EQ.0) THEN ! stationary models
- IF(SUM(ABS(a(:,S(1,4)))).EQ.0.D0) THEN
- XT(1,:) = 0.D0 ! X(1|0)
- ELSE
- APPO = -F(:,:,S(1,5))
- DO 1 I = 1,nx
-1 APPO(I,I) = 1.D0+APPO(I,I)
-C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
-C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
- CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
- CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
-
- DO 2 I =1,nx
-2 XT(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
- ENDIF
-
-C P(1|0) - F*P(1|0)*F' = R*R'
- CALL LYAP(nx,nu,TOL,F(:,:,S(1,5)),R(:,:,S(1,6)),PT(1,:,:))
- ELSE
-C -----------------------------------------------------------
-C Non-stationary models
-C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
-C eta~N(0,I), delta~N(0,k*I) k -> +inf
-C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
-C CARE!! aa (uncond. mean),Ps, and Pi to be filled by users
-C -----------------------------------------------------------
- XT(1,1:nx) = 0.D0 ! X(1|0)
- PT(1,1:nx,1:nx) = 0.D0 ! P(1|0)
- IF (d(2).LT.nx) THEN
- IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
- APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
- DO 3 I = d(2)+1,nx
-3 APPO(I,I) = 1.D0+APPO(I,I)
-C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),IFAIL)
-C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
- CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),IFAIL)
- CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
-
- DO 4 I = d(2)+1,nx
-4 XT(1,I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
- ENDIF
-
-C Lyapunov eqn
- CALL LYAP(nx-d(2),nu,TOL,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
- 1 R(d(2)+1:nx,1:nu,S(1,6)),PT(1,d(2)+1:nx,d(2)+1:nx))
- ENDIF
-
- Pi(:,:,:) = 0.D0
- DO 5 I = 1,d(2)
-5 Pi(1,I,I) = 1.D0
-
- DO 200 imain = 1,d(1)
- iny = IYK(imain,ny+1)
- DO 30 I=1,iny
- DO 30 J=1,nx
-30 HPs(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*PT(imain,:,J))
-
- DO 40 I=1,iny
- Fs(I,I) = SUM(HPs(I,:)*H(IYK(imain,I),:,S(imain,2)))
- + +SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,I),:,S(imain,3)))
- DO 40 J=1,I-1
- Fs(I,J) = SUM(HPs(I,:)*H(IYK(imain,J),:,S(imain,2)))
- + +SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,J),:,S(imain,3)))
-40 Fs(J,I) = Fs(I,J)
-
- DO 50 I=1,iny
- DO 50 J=1,nx
-50 HPi(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*Pi(imain,:,J))
-
- DO 60 I=1,iny
- Fi(I,I) = SUM(HPi(I,:)*H(IYK(imain,I),:,S(imain,2)))
- DO 60 J=1,I-1
- Fi(I,J) = SUM(HPi(I,:)*H(IYK(imain,J),:,S(imain,2)))
-60 Fi(J,I) = Fi(I,J)
-
-C --------------------------------------------------------------------------
-C Computes inverse of the innovation variance matrix
-C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
-C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
-C --------------------------------------------------------------------------
- IF (iny.EQ.1) THEN
- Fsm = 0.D0
- Fim = 1.D0/Fi
- FFF = Fim*Fs*Fim
- ELSE
-
- IFAIL = -1
- COM(1:iny,1:iny) = Fi(1:iny,1:iny)
-C CALL F02FAF('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),
-C 1 WORK1,64*iny,IFAIL)
- CALL DSYEV('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),
- 1 WORK1,64*iny,IFAIL)
-
- FiRANK = 0
- SUMW1 = SUM(ABS(W1(1:iny)))
- DO 70 I=1,iny
- W1(I) = W1(I)/SUMW1
-70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
- FiRANK = min(FiRANK,d(2))
-
- IF(FiRANK.EQ.iny) THEN
- Fsm = 0.D0
- COM(1:iny,1:iny) = Fi(1:iny,1:iny)
- IFAIL = -1
-C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
-
- DO 80 I=1,iny
- Fim(I,I) = COM(I,I)
- DO 80 J=1,I-1
- Fim(I,J) = COM(I,J)
-80 Fim(J,I) = Fim(I,J)
-
- DO 81 I=1,iny
- DO 81 J=1,iny
-81 COM(I,J) = SUM(Fim(I,1:iny)*Fs(1:iny,J)) ! Fim x Fs
-
- DO 82 I=1,iny
- FFF(I,I) = SUM(COM(I,1:iny)*Fim(1:iny,I))
- DO 82 J=1,I-1
- FFF(I,J) = SUM(COM(I,1:iny)*Fim(1:iny,J)) ! Fim x Fs x Fim
-82 FFF(J,I) = FFF(I,J)
- ELSE
- SUMW1=0.D0
- DO I=Firank+1,iny
- SUMW1 = SUMW1 + Fi(I,I)
- ENDDO
- IF (SUMW1.GT.0.D0) THEN
- CALL INVFBIS(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
- 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
- ELSE
- CALL INVF(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
- 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
- ENDIF
- ENDIF
- ENDIF
- Vis(imain,1:iny,1:iny) = Fsm(1:iny,1:iny)
- Vii(imain,1:iny,1:iny) = Fim(1:iny,1:iny)
-
-C ------------------------------------------------------------------
-C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
-C ------------------------------------------------------------------
- DO 85 I = 1,nx
- DO 85 J = 1,iny
- RG(I,J) =
- # SUM(R(I,1:nu,S(imain,6))*G(IYK(imain,J),1:nu,S(imain,3)))
-85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
-
- DO 90 I = 1,nx
- DO 90 J = 1,iny
- PHFs(I,J) = SUM(HPs(1:iny,I)*Fsm(1:iny,J))
-90 PHFi(I,J) = SUM(HPi(1:iny,I)*Fim(1:iny,J))
-
-C Innovations
- DO 100 I=1,iny
-100 INN(imain,I) = yk(imain,IYK(imain,I))
- + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*XT(imain,1:nx))
- + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
- DO 110 I=1,nx
-110 X0(I) = XT(imain,I)
- + + SUM((PHFs(I,1:iny)+PHFi(I,1:iny))*INN(imain,1:iny))
-
-C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
-C - Ps*H'*Fsm*H*Ps
- DO 120 I = 1,nx
- APPO(I,I) = -SUM(PHFs(I,1:iny)*HPs(1:iny,I))
- DO 120 J = 1,I-1
- APPO(I,J) = -SUM(PHFs(I,1:iny)*HPs(1:iny,J))
-120 APPO(J,I) = APPO(I,J)
-
-C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
- DO 130 I = 1,nx
- APPO(I,I) = APPO(I,I) - SUM(HPs(1:iny,I)*PHFi(I,1:iny))
- + - SUM(PHFi(I,1:iny)*HPs(1:iny,I))
- DO 130 J = 1,I-1
- APPO(I,J) = APPO(I,J) - SUM(HPs(1:iny,I)*PHFi(J,1:iny))
- + - SUM(PHFi(I,1:iny)*HPs(1:iny,J))
-130 APPO(J,I) = APPO(I,J)
-
-C Pi*H'*Fim*Fs*Fim*H*Pi
- DO 140 I = 1,nx
- DO 140 J = 1,iny
-140 APPO1(I,J) = SUM(HPi(1:iny,I)*FFF(1:iny,J))
-
- DO 150 I = 1,nx
- PFP(I,I) = SUM(APPO1(I,1:iny)*HPi(1:iny,I))
- DO 150 J = 1,I-1
- PFP(I,J) = SUM(APPO1(I,1:iny)*HPi(1:iny,J))
-150 PFP(J,I) = PFP(I,J)
-
- P0(:,:) = PT(imain,:,:) + PFP(:,:) + APPO(:,:)
-
-C Mi = F*Pi*H'
- DO 151 I = 1,nx
- DO 151 J = 1,nx
-151 PFP(I,J) = SUM(F(I,1:nx,S(imain,5))*Pi(imain,1:nx,J)) ! F*Pi
-
- DO 152 I = 1,nx
- DO 152 J = 1,iny
-152 Mi(I,J) = SUM(PFP(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))
-
-C Ms = F*Ps*H' + R*G'
- DO 153 I = 1,nx
- DO 153 J = 1,nx
-153 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain,:,J)) ! F*Ps
-
- DO 154 I = 1,nx
- DO 154 J = 1,iny
-154 Ms(I,J)=RG(I,J)+SUM(FP(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))
-
-C Kit = Ms*Fim - Mi*FFF
-C Kst = Ms*Fsm + Mi*Fim
- DO 155 I = 1,nx
- DO 155 J = 1,iny
- Kit(imain,I,J) = SUM(Ms(I,1:iny)*Fim(1:iny,J))
- + - SUM(Mi(I,1:iny)*FFF(1:iny,J))
-155 Kst(imain,I,J) = SUM(Ms(I,1:iny)*Fsm(1:iny,J))
- + + SUM(Mi(I,1:iny)*Fim(1:iny,J))
-
-C ----------------------------------
-C Predictions X(t+1|t) and P(t+1|t)
-C ----------------------------------
- IF (imain.LT.d(1)) THEN
-C Pi+1 = F*Pi*F'-Ci
-
-C Ci = Mi*Fim*Mi'
- DO 164 I = 1,nx
- DO 164 J = 1,iny
-164 RG(I,J) = SUM(Mi(I,1:iny)*Fim(1:iny,J)) ! Mi*Fim
-
- DO 166 I = 1,nx
- Ci(I,I) = SUM(RG(I,1:iny)*Mi(I,1:iny))
- DO 166 J = 1,I-1
-166 Ci(I,J) = SUM(RG(I,1:iny)*Mi(J,1:iny))
-
- DO 168 I = 1,nx
- Pi(imain+1,I,I)=SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
- DO 168 J = 1,I-1
- Pi(imain+1,I,J)=SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
-168 Pi(imain+1,J,I) = Pi(imain+1,I,J)
-
- ENDIF
-
-C X(t+1|t) = a + F*X(t|t)
- DO 170 I=1,nx
-170 XT(imain+1,I) = a(I,S(imain+1,4))
- + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
-
-C P(t+1|t) = F*PddF' + R*R'
- DO 172 I = 1,nx
- DO 172 J = 1,nx
-172 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*P0(:,J)) ! F*Pdd
-
- DO 180 I = 1,nx
- PT(imain+1,I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
- DO 180 J = 1,I-1
- PT(imain+1,I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
-180 PT(imain+1,J,I) = PT(imain+1,I,J)
-
-200 CONTINUE
- ENDIF
-
- DO 400 imain = d(1)+1,nobs
- iny = IYK(imain,ny+1)
-C -------------------------------
-C Innovations: INN = yk-H*X1-c*z
-C -------------------------------
- DO 210 I=1,iny
-210 INN(imain,I) = yk(imain,IYK(imain,I))
- + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*XT(imain,:))
- + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
-C ----------------------------------------------------------
-C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
-C ----------------------------------------------------------
- DO 220 I=1,iny
- DO 220 J=1,nx
-220 HP1(I,J) = SUM(H(IYK(imain,I),1:nx,S(imain,2))*PT(imain,1:nx,J))
-
- DO 221 I=1,nx
- DO 221 J=1,iny
-221 RG(I,J)=SUM(R(I,1:nu,S(imain,6))*G(IYK(imain,J),1:nu,S(imain,3)))
-
- DO 222 I=1,iny
- DO 222 J=1,iny
-222 COM(I,J)=SUM(H(IYK(imain,I),1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
-
- DO 230 I=1,iny
- V(I,I) = SUM(HP1(I,1:nx)*H(IYK(imain,I),1:nx,S(imain,2)))
- # + SUM(G(IYK(imain,I),1:nu,S(imain,3))*
- # G(IYK(imain,I),1:nu,S(imain,3))) + 2.*COM(I,I)
- DO 230 J=1,I-1
- V(I,J) = SUM(HP1(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))+
- # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
- # G(IYK(imain,J),1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
-230 V(J,I) = V(I,J)
-
-C -------------------------------------------------------------------
-C Updating equations:
-C x0 = x1 + (P1*H'+R*G')*Vinv*INN
-C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
-C -------------------------------------------------------------------
- IF (iny.GT.0) THEN
- COM(1:iny,1:iny) = V(1:iny,1:iny)
- IFAIL = -1
-C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
- CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
-
- DO 240 I=1,iny
- Vinv(imain,I,I) = COM(I,I)
- DO 240 J=1,I-1
- Vinv(imain,I,J) = COM(I,J)
-240 Vinv(imain,J,I) = Vinv(imain,I,J)
-
- DO 260 I=1,nx
- DO 260 J=1,iny
-260 HPV(I,J) = SUM((HP1(1:iny,I)+RG(I,1:iny))*Vinv(imain,1:iny,J))
-
- DO 270 I=1,nx
-270 X0(I) = XT(imain,I)+SUM(HPV(I,1:iny)*INN(imain,1:iny))
-
- DO 280 I=1,nx
- P0(I,I) = PT(imain,I,I)
- + - SUM(HPV(I,1:iny)*(HP1(1:iny,I)+RG(I,1:iny)))
- DO 280 J=1,I-1
- P0(I,J) = PT(imain,I,J)
- + - SUM(HPV(I,1:iny)*(HP1(1:iny,J)+RG(J,1:iny)))
-280 P0(J,I) = P0(I,J)
-
- ELSE
-
- X0(1:nx) = XT(imain,1:nx)
- P0(1:nx,1:nx) = PT(imain,1:nx,1:nx)
-
- ENDIF
-
-C ------------------------------------
-C Prediction x1 = c+F*x0
-C Prediction var. P1 = F*p0*F'+ R*R'
-C ------------------------------------
- IF (imain.LT.nobs) THEN
- DO 290 I=1,nx
-290 XT(imain+1,I) = a(I,S(imain+1,4))
- + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
-
- DO 300 I=1,nx
- DO 300 J=1,nx
-300 FP(I,J) = SUM(F(I,1:nx,S(imain+1,5))*P0(1:nx,J))
-
- DO 310 I=1,nx
- PT(imain+1,I,I) = SUM(FP(I,:)*F(I,:,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
- DO 310 J=1,I-1
- PT(imain+1,I,J) = SUM(FP(I,:)*F(J,:,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
-310 PT(imain+1,J,I) = PT(imain+1,I,J)
- ENDIF
-400 CONTINUE
-
-C **** SMOOTHING BAKWARD RECURSIONS ****
- RECR(1:nx) = 0.D0
- RECN(1:nx,1:nx) = 0.D0
- DO 600 ITIME = nobs,d(1)+1,-1
- iny = IYK(ITIME,ny+1)
-
-C R*G' and H'*Vinv
- DO 420 J=1,iny
- DO 420 I=1,nx
- RG(I,J)=SUM(R(I,1:nu,S(ITIME,6))*G(IYK(ITIME,J),1:nu,S(ITIME,3)))
-420 PHFs(I,J) =
- # SUM(H(IYK(ITIME,1:iny),I,S(ITIME,2))*Vinv(ITIME,1:iny,J))
-
-C F(t+1)*P(t|t-1)
- DO 430 I=1,nx
- DO 430 J=1,nx
-430 FP(I,J) = SUM(F(I,1:nx,S(min(nobs,ITIME+1),5))*PT(ITIME,1:nx,J))
-
-C H'*Vinv*H
- DO 440 I=1,nx
- APPO(I,I) = SUM(PHFs(I,1:iny)*H(IYK(ITIME,1:iny),I,S(ITIME,2)))
- DO 440 J=1,I-1
- APPO(I,J) = SUM(PHFs(I,1:iny)*H(IYK(ITIME,1:iny),J,S(ITIME,2)))
-440 APPO(J,I) = APPO(I,J)
-
-C L(t) = F(t+1)-(F(t+1)*P(t|t-1)*H(t)'+R(t)*G(t)')*Vinv(t)*H(t)
- DO 450 I=1,nx
- DO 450 J=1,nx
-450 PFP(I,J) = F(I,J,S(min(nobs,ITIME+1),5))
- + - SUM(FP(I,1:nx)*APPO(1:nx,J))
- + - SUM(RG(I,1:iny)*PHFs(J,1:iny))
-
-C r(t-1) = H(t)'*Vinv(t)*INN(t)+L(t)'*r(t)
- DO 460 I=1,nx
-460 WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx))
-
- DO 470 I=1,nx
-470 RECR(I) = WORK(I) + SUM(PHFs(I,1:iny)*INN(ITIME,1:iny))
-
-C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
- DO 480 I=1,nx
- DO 480 J=1,nx
-480 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
-
- DO 490 I=1,nx
- RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
- DO 490 J=1,I-1
- RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
-490 RECN(J,I) = RECN(I,J)
-
-C X(t|T) = X(t|t-1) + P(t|t-1)*r(t-1)
- DO 500 I = 1,nx
-500 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
-
-C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
- DO 510 I=1,nx
- DO 510 J=1,nx
-510 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
-
- DO 520 I=1,nx
- PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
- DO 520 J=1,I-1
- PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
-520 PS(ITIME,J,I) = PS(ITIME,I,J)
-
-600 CONTINUE
-
-C INITIAL KALMAN SAMOOTING
- RECRI(1:nx) = 0.D0
- DO 800 ITIME = d(1),1,-1
- iny = IYK(ITIME,ny+1)
-C L(t) = F(t)-Kst(t)*H(t)
- DO 610 I=1,nx
- DO 610 J=1,nx
-610 PFP(I,J) = F(I,J,S(ITIME,5))
- + - SUM(Kst(ITIME,I,1:iny)*H(IYK(ITIME,1:iny),J,S(ITIME,2)))
-
-C r(t-1) = H(t)'*Fsm*INN(t) + L(t)'*r(t)
-C ri(t-1) = H(t)'*Fim*INN(t) + L(t)'*ri(t) + Li(t)'*r(t)
- DO 620 I=1,nx
- WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx)) ! L(t)'*r(t)
-620 WORK(nx+I) = SUM(PFP(1:nx,I)*RECRI(1:nx)) ! L(t)'*ri(t)
-
-C Li(t) = -Kit(t)*H(t)
- DO 621 I=1,nx
- DO 621 J=1,nx
-621 PFP(I,J) =
- # - SUM(Kit(ITIME,I,1:iny)*H(IYK(ITIME,1:iny),J,S(ITIME,2)))
-
-C L(t)'*ri(t) + Li(t)'*r(t)
- DO 622 I=1,nx
-622 WORK(nx+I) = WORK(nx+I)+SUM(PFP(1:nx,I)*RECR(1:nx))
-
-C H'*Fsm
- DO 625 I=1,nx
- DO 625 J=1,iny
-625 PHFs(I,J) =
- # SUM(H(IYK(ITIME,1:iny),I,S(ITIME,2))*Vis(ITIME,1:iny,J))
-
- DO 630 I=1,nx
-630 RECR(I) = WORK(I) + SUM(PHFs(I,1:iny)*INN(ITIME,1:iny))
-
-C H'*Fim
- DO 631 I=1,nx
- DO 631 J=1,iny
-631 PHFs(I,J) =
- # SUM(H(IYK(ITIME,1:iny),I,S(ITIME,2))*Vii(ITIME,1:iny,J))
-
- DO 632 I=1,nx
-632 RECRI(I) = WORK(nx+I) + SUM(PHFs(I,1:iny)*INN(ITIME,1:iny))
-
-C X(d|T) = X(d|d-1) + Psd*r(t-1) + Pid*ri(t-1)
- DO 660 I = 1,nx
-660 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
- + + SUM(Pi(ITIME,I,1:nx)*RECRI(1:nx))
-
-800 CONTINUE
-
- DEALLOCATE(Pi,HPs,HPi,Fi,Fs,Fim,Fsm,PHFs,PHFi,FFF,Mi,Ms,Ci,
- 1 Kst,Kit,W1,WORK,WORK1,PFP,APPO,APPO1,COM,RG,FP,HP1,V,CC,HPV,
- 2 X0,P0,RECR,RECRI,RECN,XT,PT,INN,Vinv,Vis,Vii)
-
- RETURN
- END
-
-C This is the variance and must be completed!!
-C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
-c DO 640 I=1,nx
-c DO 640 J=1,nx
-c640 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
-c DO 650 I=1,nx
-c RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
-c DO 650 J=1,I-1
-c RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
-c650 RECN(J,I) = RECN(I,J)
-C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
-c DO 670 I=1,nx
-c DO 670 J=1,nx
-c670 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
-c
-c DO 680 I=1,nx
-c PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
-c DO 680 J=1,I-1
-c PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
-c680 PS(ITIME,J,I) = PS(ITIME,I,J)
-
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE KS(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XS,PS)
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6),IYK(nobs,ny+1)
+ DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
+ 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 R(nx,nu,ns(6))
+
+C OUTPUT
+ DOUBLE PRECISION XS(nobs,nx),PS(nobs,nx,nx)
+
+C LOCALS
+ INTEGER imain,iny,I,J,IFAIL,FiRANK,ITIME
+ INTEGER IPIV(nx)
+ DOUBLE PRECISION TOL,SUMW1
+ DOUBLE PRECISION,ALLOCATABLE:: Pi(:,:,:),HPs(:,:),HPi(:,:),
+ 1 Fi(:,:),Fs(:,:),Fim(:,:),Fsm(:,:),PHFs(:,:),PHFi(:,:),FFF(:,:),
+ 2 Mi(:,:),Ms(:,:),Ci(:,:),Kst(:,:,:),Kit(:,:,:),W1(:),WORK(:),
+ 3 WORK1(:),PFP(:,:),APPO(:,:),APPO1(:,:),COM(:,:),RG(:,:),
+ 4 FP(:,:),HP1(:,:),V(:,:),CC(:,:),HPV(:,:),X0(:),P0(:,:),
+ 5 RECR(:),RECRI(:),RECN(:,:),XT(:,:),PT(:,:,:),INN(:,:),
+ 1 Vinv(:,:,:),Vis(:,:,:),Vii(:,:,:)
+
+C EXTERNAL SUBROUTINES
+ EXTERNAL INVF,INVFBIS,LYAP,DSYEV,DPOTRF,DPOTRI,DGETRF,DGETRI
+
+ ALLOCATE(Pi(d(1),nx,nx),HPs(ny,nx),HPi(ny,nx),
+ 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
+ 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ms(nx,ny),Ci(nx,nx),
+ 3 Kst(d(1),nx,ny),Kit(d(1),nx,ny))
+
+ ALLOCATE(W1(ny),WORK(64*nx),WORK1(64*ny),
+ 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny))
+
+ ALLOCATE(FP(nx,nx),HP1(ny,nx),V(ny,ny),CC(nx,nx),
+ 1 HPV(nx,ny),X0(nx),P0(nx,nx),RECR(nx),RECRI(nx),RECN(nx,nx))
+
+ ALLOCATE(XT(nobs,nx),PT(nobs,nx,nx),INN(nobs,ny),
+ 1 Vinv(nobs,ny,ny),Vis(d(1),ny,ny),Vii(d(1),ny,ny))
+
+ TOL = 1.D-3
+C Unconditional mean and variance
+ IF (d(1).EQ.0) THEN ! stationary models
+ IF(SUM(ABS(a(:,S(1,4)))).EQ.0.D0) THEN
+ XT(1,:) = 0.D0 ! X(1|0)
+ ELSE
+ APPO = -F(:,:,S(1,5))
+ DO 1 I = 1,nx
+1 APPO(I,I) = 1.D0+APPO(I,I)
+C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
+C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+ CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
+ CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+
+ DO 2 I =1,nx
+2 XT(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
+ ENDIF
+
+C P(1|0) - F*P(1|0)*F' = R*R'
+ CALL LYAP(nx,nu,TOL,F(:,:,S(1,5)),R(:,:,S(1,6)),PT(1,:,:))
+ ELSE
+C -----------------------------------------------------------
+C Non-stationary models
+C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
+C eta~N(0,I), delta~N(0,k*I) k -> +inf
+C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
+C CARE!! aa (uncond. mean),Ps, and Pi to be filled by users
+C -----------------------------------------------------------
+ XT(1,1:nx) = 0.D0 ! X(1|0)
+ PT(1,1:nx,1:nx) = 0.D0 ! P(1|0)
+ IF (d(2).LT.nx) THEN
+ IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
+ APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
+ DO 3 I = d(2)+1,nx
+3 APPO(I,I) = 1.D0+APPO(I,I)
+C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),IFAIL)
+C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+ CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),IFAIL)
+ CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+
+ DO 4 I = d(2)+1,nx
+4 XT(1,I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
+ ENDIF
+
+C Lyapunov eqn
+ CALL LYAP(nx-d(2),nu,TOL,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
+ 1 R(d(2)+1:nx,1:nu,S(1,6)),PT(1,d(2)+1:nx,d(2)+1:nx))
+ ENDIF
+
+ Pi(:,:,:) = 0.D0
+ DO 5 I = 1,d(2)
+5 Pi(1,I,I) = 1.D0
+
+ DO 200 imain = 1,d(1)
+ iny = IYK(imain,ny+1)
+ DO 30 I=1,iny
+ DO 30 J=1,nx
+30 HPs(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*PT(imain,:,J))
+
+ DO 40 I=1,iny
+ Fs(I,I) = SUM(HPs(I,:)*H(IYK(imain,I),:,S(imain,2)))
+ + +SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,I),:,S(imain,3)))
+ DO 40 J=1,I-1
+ Fs(I,J) = SUM(HPs(I,:)*H(IYK(imain,J),:,S(imain,2)))
+ + +SUM(G(IYK(imain,I),:,S(imain,3))*G(IYK(imain,J),:,S(imain,3)))
+40 Fs(J,I) = Fs(I,J)
+
+ DO 50 I=1,iny
+ DO 50 J=1,nx
+50 HPi(I,J) = SUM(H(IYK(imain,I),:,S(imain,2))*Pi(imain,:,J))
+
+ DO 60 I=1,iny
+ Fi(I,I) = SUM(HPi(I,:)*H(IYK(imain,I),:,S(imain,2)))
+ DO 60 J=1,I-1
+ Fi(I,J) = SUM(HPi(I,:)*H(IYK(imain,J),:,S(imain,2)))
+60 Fi(J,I) = Fi(I,J)
+
+C --------------------------------------------------------------------------
+C Computes inverse of the innovation variance matrix
+C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
+C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
+C --------------------------------------------------------------------------
+ IF (iny.EQ.1) THEN
+ Fsm = 0.D0
+ Fim = 1.D0/Fi
+ FFF = Fim*Fs*Fim
+ ELSE
+
+ IFAIL = -1
+ COM(1:iny,1:iny) = Fi(1:iny,1:iny)
+C CALL F02FAF('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),
+C 1 WORK1,64*iny,IFAIL)
+ CALL DSYEV('N','U',iny,COM(1:iny,1:iny),iny,W1(1:iny),
+ 1 WORK1,64*iny,IFAIL)
+
+ FiRANK = 0
+ SUMW1 = SUM(ABS(W1(1:iny)))
+ DO 70 I=1,iny
+ W1(I) = W1(I)/SUMW1
+70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
+ FiRANK = min(FiRANK,d(2))
+
+ IF(FiRANK.EQ.iny) THEN
+ Fsm = 0.D0
+ COM(1:iny,1:iny) = Fi(1:iny,1:iny)
+ IFAIL = -1
+C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
+
+ DO 80 I=1,iny
+ Fim(I,I) = COM(I,I)
+ DO 80 J=1,I-1
+ Fim(I,J) = COM(I,J)
+80 Fim(J,I) = Fim(I,J)
+
+ DO 81 I=1,iny
+ DO 81 J=1,iny
+81 COM(I,J) = SUM(Fim(I,1:iny)*Fs(1:iny,J)) ! Fim x Fs
+
+ DO 82 I=1,iny
+ FFF(I,I) = SUM(COM(I,1:iny)*Fim(1:iny,I))
+ DO 82 J=1,I-1
+ FFF(I,J) = SUM(COM(I,1:iny)*Fim(1:iny,J)) ! Fim x Fs x Fim
+82 FFF(J,I) = FFF(I,J)
+ ELSE
+ SUMW1=0.D0
+ DO I=Firank+1,iny
+ SUMW1 = SUMW1 + Fi(I,I)
+ ENDDO
+ IF (SUMW1.GT.0.D0) THEN
+ CALL INVFBIS(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
+ 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
+ ELSE
+ CALL INVF(Fs(1:iny,1:iny),Fi(1:iny,1:iny),iny,FiRANK,
+ 1 Fsm(1:iny,1:iny),Fim(1:iny,1:iny),FFF(1:iny,1:iny))
+ ENDIF
+ ENDIF
+ ENDIF
+ Vis(imain,1:iny,1:iny) = Fsm(1:iny,1:iny)
+ Vii(imain,1:iny,1:iny) = Fim(1:iny,1:iny)
+
+C ------------------------------------------------------------------
+C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
+C ------------------------------------------------------------------
+ DO 85 I = 1,nx
+ DO 85 J = 1,iny
+ RG(I,J) =
+ # SUM(R(I,1:nu,S(imain,6))*G(IYK(imain,J),1:nu,S(imain,3)))
+85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
+
+ DO 90 I = 1,nx
+ DO 90 J = 1,iny
+ PHFs(I,J) = SUM(HPs(1:iny,I)*Fsm(1:iny,J))
+90 PHFi(I,J) = SUM(HPi(1:iny,I)*Fim(1:iny,J))
+
+C Innovations
+ DO 100 I=1,iny
+100 INN(imain,I) = yk(imain,IYK(imain,I))
+ + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*XT(imain,1:nx))
+ + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+ DO 110 I=1,nx
+110 X0(I) = XT(imain,I)
+ + + SUM((PHFs(I,1:iny)+PHFi(I,1:iny))*INN(imain,1:iny))
+
+C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+C - Ps*H'*Fsm*H*Ps
+ DO 120 I = 1,nx
+ APPO(I,I) = -SUM(PHFs(I,1:iny)*HPs(1:iny,I))
+ DO 120 J = 1,I-1
+ APPO(I,J) = -SUM(PHFs(I,1:iny)*HPs(1:iny,J))
+120 APPO(J,I) = APPO(I,J)
+
+C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+ DO 130 I = 1,nx
+ APPO(I,I) = APPO(I,I) - SUM(HPs(1:iny,I)*PHFi(I,1:iny))
+ + - SUM(PHFi(I,1:iny)*HPs(1:iny,I))
+ DO 130 J = 1,I-1
+ APPO(I,J) = APPO(I,J) - SUM(HPs(1:iny,I)*PHFi(J,1:iny))
+ + - SUM(PHFi(I,1:iny)*HPs(1:iny,J))
+130 APPO(J,I) = APPO(I,J)
+
+C Pi*H'*Fim*Fs*Fim*H*Pi
+ DO 140 I = 1,nx
+ DO 140 J = 1,iny
+140 APPO1(I,J) = SUM(HPi(1:iny,I)*FFF(1:iny,J))
+
+ DO 150 I = 1,nx
+ PFP(I,I) = SUM(APPO1(I,1:iny)*HPi(1:iny,I))
+ DO 150 J = 1,I-1
+ PFP(I,J) = SUM(APPO1(I,1:iny)*HPi(1:iny,J))
+150 PFP(J,I) = PFP(I,J)
+
+ P0(:,:) = PT(imain,:,:) + PFP(:,:) + APPO(:,:)
+
+C Mi = F*Pi*H'
+ DO 151 I = 1,nx
+ DO 151 J = 1,nx
+151 PFP(I,J) = SUM(F(I,1:nx,S(imain,5))*Pi(imain,1:nx,J)) ! F*Pi
+
+ DO 152 I = 1,nx
+ DO 152 J = 1,iny
+152 Mi(I,J) = SUM(PFP(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))
+
+C Ms = F*Ps*H' + R*G'
+ DO 153 I = 1,nx
+ DO 153 J = 1,nx
+153 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain,:,J)) ! F*Ps
+
+ DO 154 I = 1,nx
+ DO 154 J = 1,iny
+154 Ms(I,J)=RG(I,J)+SUM(FP(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))
+
+C Kit = Ms*Fim - Mi*FFF
+C Kst = Ms*Fsm + Mi*Fim
+ DO 155 I = 1,nx
+ DO 155 J = 1,iny
+ Kit(imain,I,J) = SUM(Ms(I,1:iny)*Fim(1:iny,J))
+ + - SUM(Mi(I,1:iny)*FFF(1:iny,J))
+155 Kst(imain,I,J) = SUM(Ms(I,1:iny)*Fsm(1:iny,J))
+ + + SUM(Mi(I,1:iny)*Fim(1:iny,J))
+
+C ----------------------------------
+C Predictions X(t+1|t) and P(t+1|t)
+C ----------------------------------
+ IF (imain.LT.d(1)) THEN
+C Pi+1 = F*Pi*F'-Ci
+
+C Ci = Mi*Fim*Mi'
+ DO 164 I = 1,nx
+ DO 164 J = 1,iny
+164 RG(I,J) = SUM(Mi(I,1:iny)*Fim(1:iny,J)) ! Mi*Fim
+
+ DO 166 I = 1,nx
+ Ci(I,I) = SUM(RG(I,1:iny)*Mi(I,1:iny))
+ DO 166 J = 1,I-1
+166 Ci(I,J) = SUM(RG(I,1:iny)*Mi(J,1:iny))
+
+ DO 168 I = 1,nx
+ Pi(imain+1,I,I)=SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
+ DO 168 J = 1,I-1
+ Pi(imain+1,I,J)=SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
+168 Pi(imain+1,J,I) = Pi(imain+1,I,J)
+
+ ENDIF
+
+C X(t+1|t) = a + F*X(t|t)
+ DO 170 I=1,nx
+170 XT(imain+1,I) = a(I,S(imain+1,4))
+ + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
+
+C P(t+1|t) = F*PddF' + R*R'
+ DO 172 I = 1,nx
+ DO 172 J = 1,nx
+172 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*P0(:,J)) ! F*Pdd
+
+ DO 180 I = 1,nx
+ PT(imain+1,I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
+ DO 180 J = 1,I-1
+ PT(imain+1,I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
+180 PT(imain+1,J,I) = PT(imain+1,I,J)
+
+200 CONTINUE
+ ENDIF
+
+ DO 400 imain = d(1)+1,nobs
+ iny = IYK(imain,ny+1)
+C -------------------------------
+C Innovations: INN = yk-H*X1-c*z
+C -------------------------------
+ DO 210 I=1,iny
+210 INN(imain,I) = yk(imain,IYK(imain,I))
+ + - SUM(H(IYK(imain,I),1:nx,S(imain,2))*XT(imain,:))
+ + - SUM(c(IYK(imain,I),1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+C ----------------------------------------------------------
+C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
+C ----------------------------------------------------------
+ DO 220 I=1,iny
+ DO 220 J=1,nx
+220 HP1(I,J) = SUM(H(IYK(imain,I),1:nx,S(imain,2))*PT(imain,1:nx,J))
+
+ DO 221 I=1,nx
+ DO 221 J=1,iny
+221 RG(I,J)=SUM(R(I,1:nu,S(imain,6))*G(IYK(imain,J),1:nu,S(imain,3)))
+
+ DO 222 I=1,iny
+ DO 222 J=1,iny
+222 COM(I,J)=SUM(H(IYK(imain,I),1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
+
+ DO 230 I=1,iny
+ V(I,I) = SUM(HP1(I,1:nx)*H(IYK(imain,I),1:nx,S(imain,2)))
+ # + SUM(G(IYK(imain,I),1:nu,S(imain,3))*
+ # G(IYK(imain,I),1:nu,S(imain,3))) + 2.*COM(I,I)
+ DO 230 J=1,I-1
+ V(I,J) = SUM(HP1(I,1:nx)*H(IYK(imain,J),1:nx,S(imain,2)))+
+ # SUM(G(IYK(imain,I),1:nu,S(imain,3))*
+ # G(IYK(imain,J),1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
+230 V(J,I) = V(I,J)
+
+C -------------------------------------------------------------------
+C Updating equations:
+C x0 = x1 + (P1*H'+R*G')*Vinv*INN
+C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
+C -------------------------------------------------------------------
+ IF (iny.GT.0) THEN
+ COM(1:iny,1:iny) = V(1:iny,1:iny)
+ IFAIL = -1
+C CALL F01ADF(iny,COM(1:iny+1,1:iny),iny+1,IFAIL)
+ CALL DPOTRF('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',iny,COM(1:iny,1:iny),iny,IFAIL) ! COM = VV^-1
+
+ DO 240 I=1,iny
+ Vinv(imain,I,I) = COM(I,I)
+ DO 240 J=1,I-1
+ Vinv(imain,I,J) = COM(I,J)
+240 Vinv(imain,J,I) = Vinv(imain,I,J)
+
+ DO 260 I=1,nx
+ DO 260 J=1,iny
+260 HPV(I,J) = SUM((HP1(1:iny,I)+RG(I,1:iny))*Vinv(imain,1:iny,J))
+
+ DO 270 I=1,nx
+270 X0(I) = XT(imain,I)+SUM(HPV(I,1:iny)*INN(imain,1:iny))
+
+ DO 280 I=1,nx
+ P0(I,I) = PT(imain,I,I)
+ + - SUM(HPV(I,1:iny)*(HP1(1:iny,I)+RG(I,1:iny)))
+ DO 280 J=1,I-1
+ P0(I,J) = PT(imain,I,J)
+ + - SUM(HPV(I,1:iny)*(HP1(1:iny,J)+RG(J,1:iny)))
+280 P0(J,I) = P0(I,J)
+
+ ELSE
+
+ X0(1:nx) = XT(imain,1:nx)
+ P0(1:nx,1:nx) = PT(imain,1:nx,1:nx)
+
+ ENDIF
+
+C ------------------------------------
+C Prediction x1 = c+F*x0
+C Prediction var. P1 = F*p0*F'+ R*R'
+C ------------------------------------
+ IF (imain.LT.nobs) THEN
+ DO 290 I=1,nx
+290 XT(imain+1,I) = a(I,S(imain+1,4))
+ + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
+
+ DO 300 I=1,nx
+ DO 300 J=1,nx
+300 FP(I,J) = SUM(F(I,1:nx,S(imain+1,5))*P0(1:nx,J))
+
+ DO 310 I=1,nx
+ PT(imain+1,I,I) = SUM(FP(I,:)*F(I,:,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
+ DO 310 J=1,I-1
+ PT(imain+1,I,J) = SUM(FP(I,:)*F(J,:,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
+310 PT(imain+1,J,I) = PT(imain+1,I,J)
+ ENDIF
+400 CONTINUE
+
+C **** SMOOTHING BAKWARD RECURSIONS ****
+ RECR(1:nx) = 0.D0
+ RECN(1:nx,1:nx) = 0.D0
+ DO 600 ITIME = nobs,d(1)+1,-1
+ iny = IYK(ITIME,ny+1)
+
+C R*G' and H'*Vinv
+ DO 420 J=1,iny
+ DO 420 I=1,nx
+ RG(I,J)=SUM(R(I,1:nu,S(ITIME,6))*G(IYK(ITIME,J),1:nu,S(ITIME,3)))
+420 PHFs(I,J) =
+ # SUM(H(IYK(ITIME,1:iny),I,S(ITIME,2))*Vinv(ITIME,1:iny,J))
+
+C F(t+1)*P(t|t-1)
+ DO 430 I=1,nx
+ DO 430 J=1,nx
+430 FP(I,J) = SUM(F(I,1:nx,S(min(nobs,ITIME+1),5))*PT(ITIME,1:nx,J))
+
+C H'*Vinv*H
+ DO 440 I=1,nx
+ APPO(I,I) = SUM(PHFs(I,1:iny)*H(IYK(ITIME,1:iny),I,S(ITIME,2)))
+ DO 440 J=1,I-1
+ APPO(I,J) = SUM(PHFs(I,1:iny)*H(IYK(ITIME,1:iny),J,S(ITIME,2)))
+440 APPO(J,I) = APPO(I,J)
+
+C L(t) = F(t+1)-(F(t+1)*P(t|t-1)*H(t)'+R(t)*G(t)')*Vinv(t)*H(t)
+ DO 450 I=1,nx
+ DO 450 J=1,nx
+450 PFP(I,J) = F(I,J,S(min(nobs,ITIME+1),5))
+ + - SUM(FP(I,1:nx)*APPO(1:nx,J))
+ + - SUM(RG(I,1:iny)*PHFs(J,1:iny))
+
+C r(t-1) = H(t)'*Vinv(t)*INN(t)+L(t)'*r(t)
+ DO 460 I=1,nx
+460 WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx))
+
+ DO 470 I=1,nx
+470 RECR(I) = WORK(I) + SUM(PHFs(I,1:iny)*INN(ITIME,1:iny))
+
+C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
+ DO 480 I=1,nx
+ DO 480 J=1,nx
+480 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
+
+ DO 490 I=1,nx
+ RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
+ DO 490 J=1,I-1
+ RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
+490 RECN(J,I) = RECN(I,J)
+
+C X(t|T) = X(t|t-1) + P(t|t-1)*r(t-1)
+ DO 500 I = 1,nx
+500 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
+
+C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
+ DO 510 I=1,nx
+ DO 510 J=1,nx
+510 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
+
+ DO 520 I=1,nx
+ PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
+ DO 520 J=1,I-1
+ PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
+520 PS(ITIME,J,I) = PS(ITIME,I,J)
+
+600 CONTINUE
+
+C INITIAL KALMAN SAMOOTING
+ RECRI(1:nx) = 0.D0
+ DO 800 ITIME = d(1),1,-1
+ iny = IYK(ITIME,ny+1)
+C L(t) = F(t)-Kst(t)*H(t)
+ DO 610 I=1,nx
+ DO 610 J=1,nx
+610 PFP(I,J) = F(I,J,S(ITIME,5))
+ + - SUM(Kst(ITIME,I,1:iny)*H(IYK(ITIME,1:iny),J,S(ITIME,2)))
+
+C r(t-1) = H(t)'*Fsm*INN(t) + L(t)'*r(t)
+C ri(t-1) = H(t)'*Fim*INN(t) + L(t)'*ri(t) + Li(t)'*r(t)
+ DO 620 I=1,nx
+ WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx)) ! L(t)'*r(t)
+620 WORK(nx+I) = SUM(PFP(1:nx,I)*RECRI(1:nx)) ! L(t)'*ri(t)
+
+C Li(t) = -Kit(t)*H(t)
+ DO 621 I=1,nx
+ DO 621 J=1,nx
+621 PFP(I,J) =
+ # - SUM(Kit(ITIME,I,1:iny)*H(IYK(ITIME,1:iny),J,S(ITIME,2)))
+
+C L(t)'*ri(t) + Li(t)'*r(t)
+ DO 622 I=1,nx
+622 WORK(nx+I) = WORK(nx+I)+SUM(PFP(1:nx,I)*RECR(1:nx))
+
+C H'*Fsm
+ DO 625 I=1,nx
+ DO 625 J=1,iny
+625 PHFs(I,J) =
+ # SUM(H(IYK(ITIME,1:iny),I,S(ITIME,2))*Vis(ITIME,1:iny,J))
+
+ DO 630 I=1,nx
+630 RECR(I) = WORK(I) + SUM(PHFs(I,1:iny)*INN(ITIME,1:iny))
+
+C H'*Fim
+ DO 631 I=1,nx
+ DO 631 J=1,iny
+631 PHFs(I,J) =
+ # SUM(H(IYK(ITIME,1:iny),I,S(ITIME,2))*Vii(ITIME,1:iny,J))
+
+ DO 632 I=1,nx
+632 RECRI(I) = WORK(nx+I) + SUM(PHFs(I,1:iny)*INN(ITIME,1:iny))
+
+C X(d|T) = X(d|d-1) + Psd*r(t-1) + Pid*ri(t-1)
+ DO 660 I = 1,nx
+660 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
+ + + SUM(Pi(ITIME,I,1:nx)*RECRI(1:nx))
+
+800 CONTINUE
+
+ DEALLOCATE(Pi,HPs,HPi,Fi,Fs,Fim,Fsm,PHFs,PHFi,FFF,Mi,Ms,Ci,
+ 1 Kst,Kit,W1,WORK,WORK1,PFP,APPO,APPO1,COM,RG,FP,HP1,V,CC,HPV,
+ 2 X0,P0,RECR,RECRI,RECN,XT,PT,INN,Vinv,Vis,Vii)
+
+ RETURN
+ END
+
+C This is the variance and must be completed!!
+C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
+c DO 640 I=1,nx
+c DO 640 J=1,nx
+c640 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
+c DO 650 I=1,nx
+c RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
+c DO 650 J=1,I-1
+c RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
+c650 RECN(J,I) = RECN(I,J)
+C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
+c DO 670 I=1,nx
+c DO 670 J=1,nx
+c670 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
+c
+c DO 680 I=1,nx
+c PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
+c DO 680 J=1,I-1
+c PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
+c680 PS(ITIME,J,I) = PS(ITIME,I,J)
+
diff --git a/ks2.for b/ks2.for
index e279dbbbb4d67a6263fb90b952ec30b6f5dadc5f..33850caaf56e28ff3fa1e772a64e2d647fb75626 100644
--- a/ks2.for
+++ b/ks2.for
@@ -1,34 +1,34 @@
-C --------------------------------------------------------------------
-C KS2 (no missing values) IMPLEMENTS THE KALMAN SMMOOTHER RECURSIONS in
-C Koopman (1997), JASA, 92, 440, 1630-38
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C XS = E[x(t)|y(1),...,y(nobs)]
-C PS = V[x(t)|y(1),...,y(nobs)], t = 1,2,...,nobs
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C d(1): order of integration of the system
-C d(2): number of non-stationary elements
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C KS2 (no missing values) IMPLEMENTS THE KALMAN SMMOOTHER RECURSIONS in
+C Koopman (1997), JASA, 92, 440, 1630-38
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C XS = E[x(t)|y(1),...,y(nobs)]
+C PS = V[x(t)|y(1),...,y(nobs)], t = 1,2,...,nobs
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C d(1): order of integration of the system
+C d(2): number of non-stationary elements
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -39,559 +39,559 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE KS2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,XS)
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
- 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 R(nx,nu,ns(6))
-
-C OUTPUT
- DOUBLE PRECISION XS(nobs,nx)
-
-C LOCALS
- INTEGER imain,I,J,IFAIL,FiRANK,ITIME
- INTEGER IPIV(nx)
- DOUBLE PRECISION TOL,SUMW1
- DOUBLE PRECISION,ALLOCATABLE:: Pi(:,:,:),HPs(:,:),HPi(:,:),
- 1 Fi(:,:),Fs(:,:),Fim(:,:),Fsm(:,:),PHFs(:,:),PHFi(:,:),FFF(:,:),
- 2 Mi(:,:),Ms(:,:),Ci(:,:),Kst(:,:,:),Kit(:,:,:),W1(:),WORK(:),
- 3 WORK1(:),PFP(:,:),APPO(:,:),APPO1(:,:),COM(:,:),RG(:,:),
- 4 FP(:,:),HP1(:,:),V(:,:),CC(:,:),HPV(:,:),X0(:),P0(:,:),
- 5 RECR(:),RECRI(:),RECN(:,:),XT(:,:),PT(:,:,:),INN(:,:),
- 1 Vinv(:,:,:),Vis(:,:,:),Vii(:,:,:)
-
-C EXTERNAL SUBROUTINES
- EXTERNAL INVF,INVFBIS,LYAP,DSYEV,DPOTRF,DPOTRI,DGETRF,DGETRI
-
- ALLOCATE(Pi(d(1),nx,nx),HPs(ny,nx),HPi(ny,nx),
- 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
- 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ms(nx,ny),Ci(nx,nx),
- 3 Kst(d(1),nx,ny),Kit(d(1),nx,ny))
-
- ALLOCATE(W1(ny),WORK(64*nx),WORK1(64*ny),
- 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny))
-
- ALLOCATE(FP(nx,nx),HP1(ny,nx),V(ny,ny),CC(nx,nx),
- 1 HPV(nx,ny),X0(nx),P0(nx,nx),RECR(nx),RECRI(nx),RECN(nx,nx))
-
- ALLOCATE(XT(nobs,nx),PT(nobs,nx,nx),INN(nobs,ny),
- 1 Vinv(nobs,ny,ny),Vis(d(1),ny,ny),Vii(d(1),ny,ny))
-
-
- TOL = 1.D-3
-C Unconditional mean and variance
- IF (d(1).EQ.0) THEN ! stationary models
- IF(SUM(ABS(a(:,S(1,4)))).EQ.0.D0) THEN
- XT(1,:) = 0.D0 ! X(1|0)
- ELSE
- APPO = -F(:,:,S(1,5))
- DO 1 I = 1,nx
-1 APPO(I,I) = 1.D0+APPO(I,I)
-C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
-C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
- CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
- CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
- DO 2 I =1,nx
-2 XT(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
- ENDIF
-
-C P(1|0) - F*P(1|0)*F' = R*R'
- CALL LYAP(nx,nu,TOL,F(:,:,S(1,5)),R(:,:,S(1,6)),PT(1,:,:))
- ELSE
-C -----------------------------------------------------------
-C Non-stationary models
-C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
-C eta~N(0,I), delta~N(0,k*I) k -> +inf
-C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
-C CARE!! aa (uncond. mean),Ps, and Pi to be filled by users
-C -----------------------------------------------------------
- XT(1,1:nx) = 0.D0 ! X(1|0)
- PT(1,1:nx,1:nx) = 0.D0 ! P(1|0)
- IF (d(2).LT.nx) THEN
- IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
- APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
- DO 3 I = d(2)+1,nx
-3 APPO(I,I) = 1.D0+APPO(I,I)
-C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),IFAIL)
-C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
- CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),IFAIL)
- CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
-
- DO 4 I = d(2)+1,nx
-4 XT(1,I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
- ENDIF
-C Lyapunov eqn
- CALL LYAP(nx-d(2),nu,TOL,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
- 1 R(d(2)+1:nx,1:nu,S(1,6)),PT(1,d(2)+1:nx,d(2)+1:nx))
- ENDIF
-
- Pi(:,:,:) = 0.D0
- DO 5 I = 1,d(2)
-5 Pi(1,I,I) = 1.D0
-
- DO 200 imain = 1,d(1)
- DO 30 I=1,ny
- DO 30 J=1,nx
-30 HPs(I,J) = SUM(H(I,:,S(imain,2))*PT(imain,:,J))
-
- DO 40 I=1,ny
- Fs(I,I) = SUM(HPs(I,:)*H(I,:,S(imain,2)))
- + + SUM(G(I,:,S(imain,3))*G(I,:,S(imain,3)))
- DO 40 J=1,I-1
- Fs(I,J) = SUM(HPs(I,:)*H(J,:,S(imain,2)))
- + + SUM(G(I,:,S(imain,3))*G(J,:,S(imain,3)))
-40 Fs(J,I) = Fs(I,J)
-
- DO 50 I=1,ny
- DO 50 J=1,nx
-50 HPi(I,J) = SUM(H(I,:,S(imain,2))*Pi(imain,:,J))
-
- DO 60 I=1,ny
- Fi(I,I) = SUM(HPi(I,:)*H(I,:,S(imain,2)))
- DO 60 J=1,I-1
- Fi(I,J) = SUM(HPi(I,:)*H(J,:,S(imain,2)))
-60 Fi(J,I) = Fi(I,J)
-
-C --------------------------------------------------------------------------
-C Computes inverse of the innovation variance matrix
-C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
-C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
-C --------------------------------------------------------------------------
- IF (ny.EQ.1) THEN
- Fsm = 0.D0
- Fim = 1.D0/Fi
- FFF = Fim*Fs*Fim
- ELSE
-
- IFAIL = -1
- COM(1:ny,1:ny) = Fi(1:ny,1:ny)
-C CALL F02FAF('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),
-C 1 WORK1,64*ny,IFAIL)
- CALL DSYEV('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),
- 1 WORK1,64*ny,IFAIL)
-
- FiRANK = 0
- SUMW1 = SUM(ABS(W1(1:ny)))
- DO 70 I=1,ny
- W1(I) = W1(I)/SUMW1
-70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
- FiRANK = min(FiRANK,d(2))
-
-c CALL SCHOLLU(Fi(1:ny,1:ny),FFF,ny,NULLITY,EPS,IFAIL)
-c FiRANK = ny-NULLITY
-
- IF(FiRANK.EQ.ny) THEN
- Fsm = 0.D0
- COM(1:ny,1:ny) = Fi(1:ny,1:ny)
- IFAIL = -1
-c CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
- CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
-
- DO 80 I=1,ny
- Fim(I,I) = COM(I,I)
- DO 80 J=1,I-1
- Fim(I,J) = COM(I,J)
-80 Fim(J,I) = Fim(I,J)
-
- DO 81 I=1,ny
- DO 81 J=1,ny
-81 COM(I,J) = SUM(Fim(I,1:ny)*Fs(1:ny,J)) ! Fim x Fs
-
- DO 82 I=1,ny
- FFF(I,I) = SUM(COM(I,1:ny)*Fim(1:ny,I))
- DO 82 J=1,I-1
- FFF(I,J) = SUM(COM(I,1:ny)*Fim(1:ny,J)) ! Fim x Fs x Fim
-82 FFF(J,I) = FFF(I,J)
-
- ELSE
-
- SUMW1=0.D0
- DO I=Firank+1,ny
- SUMW1 = SUMW1 + Fi(I,I)
- ENDDO
- IF (SUMW1.GT.0.D0) THEN
- CALL INVFBIS(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
- 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
- ELSE
- CALL INVF(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
- 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
- ENDIF
-
- ENDIF
- ENDIF
- Vis(imain,1:ny,1:ny) = Fsm(1:ny,1:ny)
- Vii(imain,1:ny,1:ny) = Fim(1:ny,1:ny)
-
-C ------------------------------------------------------------------
-C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
-C ------------------------------------------------------------------
- DO 85 I = 1,nx
- DO 85 J = 1,ny
- RG(I,J) =
- # SUM(R(I,1:nu,S(imain,6))*G(J,1:nu,S(imain,3)))
-85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
-
- DO 90 I = 1,nx
- DO 90 J = 1,ny
- PHFs(I,J) = SUM(HPs(1:ny,I)*Fsm(1:ny,J))
-90 PHFi(I,J) = SUM(HPi(1:ny,I)*Fim(1:ny,J))
-
-C Innovations
- DO 100 I=1,ny
-100 INN(imain,I) = yk(imain,I)
- + - SUM(H(I,1:nx,S(imain,2))*XT(imain,1:nx))
- + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
- DO 110 I=1,nx
-110 X0(I) = XT(imain,I)
- + + SUM((PHFs(I,1:ny)+PHFi(I,1:ny))*INN(imain,1:ny))
-
-C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
-C - Ps*H'*Fsm*H*Ps
- DO 120 I = 1,nx
- APPO(I,I) = -SUM(PHFs(I,1:ny)*HPs(1:ny,I))
- DO 120 J = 1,I-1
- APPO(I,J) = -SUM(PHFs(I,1:ny)*HPs(1:ny,J))
-120 APPO(J,I) = APPO(I,J)
-
-C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
- DO 130 I = 1,nx
- APPO(I,I) = APPO(I,I) - SUM(HPs(1:ny,I)*PHFi(I,1:ny))
- + - SUM(PHFi(I,1:ny)*HPs(1:ny,I))
- DO 130 J = 1,I-1
- APPO(I,J) = APPO(I,J) - SUM(HPs(1:ny,I)*PHFi(J,1:ny))
- + - SUM(PHFi(I,1:ny)*HPs(1:ny,J))
-130 APPO(J,I) = APPO(I,J)
-
-C Pi*H'*Fim*Fs*Fim*H*Pi
- DO 140 I = 1,nx
- DO 140 J = 1,ny
-140 APPO1(I,J) = SUM(HPi(1:ny,I)*FFF(1:ny,J))
-
- DO 150 I = 1,nx
- PFP(I,I) = SUM(APPO1(I,1:ny)*HPi(1:ny,I))
- DO 150 J = 1,I-1
- PFP(I,J) = SUM(APPO1(I,1:ny)*HPi(1:ny,J))
-150 PFP(J,I) = PFP(I,J)
-
- P0(:,:) = PT(imain,:,:) + PFP(:,:) + APPO(:,:)
-
-C Mi = F*Pi*H'
- DO 151 I = 1,nx
- DO 151 J = 1,nx
-151 PFP(I,J) = SUM(F(I,1:nx,S(imain,5))*Pi(imain,1:nx,J)) ! F*Pi
-
- DO 152 I = 1,nx
- DO 152 J = 1,ny
-152 Mi(I,J) = SUM(PFP(I,1:nx)*H(J,1:nx,S(imain,2)))
-
-C Ms = F*Ps*H' + R*G'
- DO 153 I = 1,nx
- DO 153 J = 1,nx
-153 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain,:,J)) ! F*Ps
-
- DO 154 I = 1,nx
- DO 154 J = 1,ny
-154 Ms(I,J)=RG(I,J)+SUM(FP(I,1:nx)*H(J,1:nx,S(imain,2)))
-
-C Kit = Ms*Fim - Mi*FFF
-C Kst = Ms*Fsm + Mi*Fim
- DO 155 I = 1,nx
- DO 155 J = 1,ny
- Kit(imain,I,J) = SUM(Ms(I,1:ny)*Fim(1:ny,J))
- + - SUM(Mi(I,1:ny)*FFF(1:ny,J))
-155 Kst(imain,I,J) = SUM(Ms(I,1:ny)*Fsm(1:ny,J))
- + + SUM(Mi(I,1:ny)*Fim(1:ny,J))
-
-C ----------------------------------
-C Predictions X(t+1|t) and P(t+1|t)
-C ----------------------------------
- IF (imain.LT.d(1)) THEN
-C Pi+1 = F*Pi*F'-Ci
-
-C Ci = Mi*Fim*Mi'
- DO 164 I = 1,nx
- DO 164 J = 1,ny
-164 RG(I,J) = SUM(Mi(I,1:ny)*Fim(1:ny,J)) ! Mi*Fim
-
- DO 166 I = 1,nx
- Ci(I,I) = SUM(RG(I,1:ny)*Mi(I,1:ny))
- DO 166 J = 1,I-1
-166 Ci(I,J) = SUM(RG(I,1:ny)*Mi(J,1:ny))
-
- DO 168 I = 1,nx
- Pi(imain+1,I,I)=SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
- DO 168 J = 1,I-1
- Pi(imain+1,I,J)=SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
-168 Pi(imain+1,J,I) = Pi(imain+1,I,J)
-
- ENDIF
-
-C X(t+1|t) = a + F*X(t|t)
- DO 170 I=1,nx
-170 XT(imain+1,I) = a(I,S(imain+1,4))
- + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
-
-C P(t+1|t) = F*PddF' + R*R'
- DO 172 I = 1,nx
- DO 172 J = 1,nx
-172 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*P0(:,J)) ! F*Pdd
-
- DO 180 I = 1,nx
- PT(imain+1,I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
- DO 180 J = 1,I-1
- PT(imain+1,I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
-180 PT(imain+1,J,I) = PT(imain+1,I,J)
-
-200 CONTINUE
- ENDIF
-
- DO 400 imain = d(1)+1,nobs
-C -------------------------------
-C Innovations: INN = yk-H*X1-c*z
-C -------------------------------
- DO 210 I=1,ny
-210 INN(imain,I) = yk(imain,I)
- + - SUM(H(I,1:nx,S(imain,2))*XT(imain,:))
- + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
-
-C ----------------------------------------------------------
-C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
-C ----------------------------------------------------------
- DO 220 I=1,ny
- DO 220 J=1,nx
-220 HP1(I,J) = SUM(H(I,1:nx,S(imain,2))*PT(imain,1:nx,J))
-
- DO 221 I=1,nx
- DO 221 J=1,ny
-221 RG(I,J)=SUM(R(I,1:nu,S(imain,6))*G(J,1:nu,S(imain,3)))
-
- DO 222 I=1,ny
- DO 222 J=1,ny
-222 COM(I,J)=SUM(H(I,1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
-
- DO 230 I=1,ny
- V(I,I) = SUM(HP1(I,1:nx)*H(I,1:nx,S(imain,2)))
- # + SUM(G(I,1:nu,S(imain,3))*
- # G(I,1:nu,S(imain,3))) + 2.*COM(I,I)
- DO 230 J=1,I-1
- V(I,J) = SUM(HP1(I,1:nx)*H(J,1:nx,S(imain,2)))+
- # SUM(G(I,1:nu,S(imain,3))*
- # G(J,1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
-230 V(J,I) = V(I,J)
-
-C -------------------------------------------------------------------
-C Updating equations:
-C x0 = x1 + (P1*H'+R*G')*Vinv*INN
-C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
-C -------------------------------------------------------------------
- IF (ny.GT.0) THEN
- COM(1:ny,1:ny) = V(1:ny,1:ny)
- IFAIL = -1
-C CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
- CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
- CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
-
- DO 240 I=1,ny
- Vinv(imain,I,I) = COM(I,I)
- DO 240 J=1,I-1
- Vinv(imain,I,J) = COM(I,J)
-240 Vinv(imain,J,I) = Vinv(imain,I,J)
-
- DO 260 I=1,nx
- DO 260 J=1,ny
-260 HPV(I,J) = SUM((HP1(1:ny,I)+RG(I,1:ny))*Vinv(imain,1:ny,J))
-
- DO 270 I=1,nx
-270 X0(I) = XT(imain,I)+SUM(HPV(I,1:ny)*INN(imain,1:ny))
-
- DO 280 I=1,nx
- P0(I,I) = PT(imain,I,I)
- + - SUM(HPV(I,1:ny)*(HP1(1:ny,I)+RG(I,1:ny)))
- DO 280 J=1,I-1
- P0(I,J) = PT(imain,I,J)
- + - SUM(HPV(I,1:ny)*(HP1(1:ny,J)+RG(J,1:ny)))
-280 P0(J,I) = P0(I,J)
- ELSE
-
- X0(1:nx) = XT(imain,1:nx)
- P0(1:nx,1:nx) = PT(imain,1:nx,1:nx)
-
- ENDIF
-
-C ------------------------------------
-C Prediction x1 = c+F*x0
-C Prediction var. P1 = F*p0*F'+ R*R'
-C ------------------------------------
- IF (imain.LT.nobs) THEN
- DO 290 I=1,nx
-290 XT(imain+1,I) = a(I,S(imain+1,4))
- + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
-
- DO 300 I=1,nx
- DO 300 J=1,nx
-300 FP(I,J) = SUM(F(I,1:nx,S(imain+1,5))*P0(1:nx,J))
-
- DO 310 I=1,nx
- PT(imain+1,I,I) = SUM(FP(I,:)*F(I,:,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
- DO 310 J=1,I-1
- PT(imain+1,I,J) = SUM(FP(I,:)*F(J,:,S(imain+1,5)))
- + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
-310 PT(imain+1,J,I) = PT(imain+1,I,J)
- ENDIF
-400 CONTINUE
-
-C **** SMOOTHING BAKWARD RECURSIONS ****
- RECR(1:nx) = 0.D0
- RECN(1:nx,1:nx) = 0.D0
- DO 600 ITIME = nobs,d(1)+1,-1
-C R*G' and H'*Vinv
- DO 420 J=1,ny
- DO 420 I=1,nx
- RG(I,J)=SUM(R(I,1:nu,S(ITIME,6))*G(J,1:nu,S(ITIME,3)))
-420 PHFs(I,J) =
- # SUM(H(1:ny,I,S(ITIME,2))*Vinv(ITIME,1:ny,J))
-
-C F(t+1)*P(t|t-1)
- DO 430 I=1,nx
- DO 430 J=1,nx
-430 FP(I,J) = SUM(F(I,1:nx,S(min(nobs,ITIME+1),5))*PT(ITIME,1:nx,J))
-
-C H'*Vinv*H
- DO 440 I=1,nx
- APPO(I,I) = SUM(PHFs(I,1:ny)*H(1:ny,I,S(ITIME,2)))
- DO 440 J=1,I-1
- APPO(I,J) = SUM(PHFs(I,1:ny)*H(1:ny,J,S(ITIME,2)))
-440 APPO(J,I) = APPO(I,J)
-
-C L(t) = F(t+1)-(F(t+1)*P(t|t-1)*H(t)'+R(t)*G(t)')*Vinv(t)*H(t)
- DO 450 I=1,nx
- DO 450 J=1,nx
-450 PFP(I,J) = F(I,J,S(min(nobs,ITIME+1),5))
- + - SUM(FP(I,1:nx)*APPO(1:nx,J))
- + - SUM(RG(I,1:ny)*PHFs(J,1:ny))
-
-C r(t-1) = H(t)'*Vinv(t)*INN(t)+L(t)'*r(t)
- DO 460 I=1,nx
-460 WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx))
-
- DO 470 I=1,nx
-470 RECR(I) = WORK(I) + SUM(PHFs(I,1:ny)*INN(ITIME,1:ny))
-
-C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
- DO 480 I=1,nx
- DO 480 J=1,nx
-480 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
-
- DO 490 I=1,nx
- RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
- DO 490 J=1,I-1
- RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
-490 RECN(J,I) = RECN(I,J)
-
-C X(t|T) = X(t|t-1) + P(t|t-1)*r(t-1)
- DO 500 I = 1,nx
-500 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
-
-C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
- DO 510 I=1,nx
- DO 510 J=1,nx
-510 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
-
-c DO 520 I=1,nx
-c PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
-c DO 520 J=1,I-1
-c PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
-c520 PS(ITIME,J,I) = PS(ITIME,I,J)
-
-600 CONTINUE
-
-C INITIAL KALMAN SAMOOTING
- RECRI(1:nx) = 0.D0
- DO 800 ITIME = d(1),1,-1
-C L(t) = F(t)-Kst(t)*H(t)
- DO 610 I=1,nx
- DO 610 J=1,nx
-610 PFP(I,J) = F(I,J,S(ITIME,5))
- + - SUM(Kst(ITIME,I,1:ny)*H(1:ny,J,S(ITIME,2)))
-
-C r(t-1) = H(t)'*Fsm*INN(t) + L(t)'*r(t)
-C ri(t-1) = H(t)'*Fim*INN(t) + L(t)'*ri(t) + Li(t)'*r(t)
- DO 620 I=1,nx
- WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx)) ! L(t)'*r(t)
-620 WORK(nx+I) = SUM(PFP(1:nx,I)*RECRI(1:nx)) ! L(t)'*ri(t)
-
-C Li(t) = -Kit(t)*H(t)
- DO 621 I=1,nx
- DO 621 J=1,nx
-621 PFP(I,J) =
- # - SUM(Kit(ITIME,I,1:ny)*H(1:ny,J,S(ITIME,2)))
-
-C L(t)'*ri(t) + Li(t)'*r(t)
- DO 622 I=1,nx
-622 WORK(nx+I) = WORK(nx+I)+SUM(PFP(1:nx,I)*RECR(1:nx))
-
-C H'*Fsm
- DO 625 I=1,nx
- DO 625 J=1,ny
-625 PHFs(I,J) =
- # SUM(H(1:ny,I,S(ITIME,2))*Vis(ITIME,1:ny,J))
-
- DO 630 I=1,nx
-630 RECR(I) = WORK(I) + SUM(PHFs(I,1:ny)*INN(ITIME,1:ny))
-
-C H'*Fim
- DO 631 I=1,nx
- DO 631 J=1,ny
-631 PHFs(I,J) =
- # SUM(H(1:ny,I,S(ITIME,2))*Vii(ITIME,1:ny,J))
-
- DO 632 I=1,nx
-632 RECRI(I) = WORK(nx+I) + SUM(PHFs(I,1:ny)*INN(ITIME,1:ny))
-
-C X(d|T) = X(d|d-1) + Psd*r(t-1) + Pid*ri(t-1)
- DO 660 I = 1,nx
-660 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
- + + SUM(Pi(ITIME,I,1:nx)*RECRI(1:nx))
-
-800 CONTINUE
-
- DEALLOCATE(Pi,HPs,HPi,Fi,Fs,Fim,Fsm,PHFs,PHFi,FFF,Mi,Ms,Ci,
- 1 Kst,Kit,W1,WORK,WORK1,PFP,APPO,APPO1,COM,RG,FP,HP1,V,CC,HPV,
- 2 X0,P0,RECR,RECRI,RECN,XT,PT,INN,Vinv,Vis,Vii)
-
- RETURN
- END
-
-C This is the variance and must be completed!!
-C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
-c DO 640 I=1,nx
-c DO 640 J=1,nx
-c640 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
-c DO 650 I=1,nx
-c RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
-c DO 650 J=1,I-1
-c RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
-c650 RECN(J,I) = RECN(I,J)
-C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
-c DO 670 I=1,nx
-c DO 670 J=1,nx
-c670 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
-c
-c DO 680 I=1,nx
-c PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
-c DO 680 J=1,I-1
-c PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
-c680 PS(ITIME,J,I) = PS(ITIME,I,J)
-
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE KS2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,XS)
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),c(ny,max(nz,1),ns(1)),
+ 1 H(ny,nx,ns(2)),G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 R(nx,nu,ns(6))
+
+C OUTPUT
+ DOUBLE PRECISION XS(nobs,nx)
+
+C LOCALS
+ INTEGER imain,I,J,IFAIL,FiRANK,ITIME
+ INTEGER IPIV(nx)
+ DOUBLE PRECISION TOL,SUMW1
+ DOUBLE PRECISION,ALLOCATABLE:: Pi(:,:,:),HPs(:,:),HPi(:,:),
+ 1 Fi(:,:),Fs(:,:),Fim(:,:),Fsm(:,:),PHFs(:,:),PHFi(:,:),FFF(:,:),
+ 2 Mi(:,:),Ms(:,:),Ci(:,:),Kst(:,:,:),Kit(:,:,:),W1(:),WORK(:),
+ 3 WORK1(:),PFP(:,:),APPO(:,:),APPO1(:,:),COM(:,:),RG(:,:),
+ 4 FP(:,:),HP1(:,:),V(:,:),CC(:,:),HPV(:,:),X0(:),P0(:,:),
+ 5 RECR(:),RECRI(:),RECN(:,:),XT(:,:),PT(:,:,:),INN(:,:),
+ 1 Vinv(:,:,:),Vis(:,:,:),Vii(:,:,:)
+
+C EXTERNAL SUBROUTINES
+ EXTERNAL INVF,INVFBIS,LYAP,DSYEV,DPOTRF,DPOTRI,DGETRF,DGETRI
+
+ ALLOCATE(Pi(d(1),nx,nx),HPs(ny,nx),HPi(ny,nx),
+ 1 Fi(ny,ny),Fs(ny,ny),Fim(ny,ny),Fsm(ny,ny),
+ 2 PHFs(nx,ny),PHFi(nx,ny),FFF(ny,ny),Mi(nx,ny),Ms(nx,ny),Ci(nx,nx),
+ 3 Kst(d(1),nx,ny),Kit(d(1),nx,ny))
+
+ ALLOCATE(W1(ny),WORK(64*nx),WORK1(64*ny),
+ 1 PFP(nx,nx),APPO(nx,nx),APPO1(nx,ny),COM(ny+1,ny),RG(nx,ny))
+
+ ALLOCATE(FP(nx,nx),HP1(ny,nx),V(ny,ny),CC(nx,nx),
+ 1 HPV(nx,ny),X0(nx),P0(nx,nx),RECR(nx),RECRI(nx),RECN(nx,nx))
+
+ ALLOCATE(XT(nobs,nx),PT(nobs,nx,nx),INN(nobs,ny),
+ 1 Vinv(nobs,ny,ny),Vis(d(1),ny,ny),Vii(d(1),ny,ny))
+
+
+ TOL = 1.D-3
+C Unconditional mean and variance
+ IF (d(1).EQ.0) THEN ! stationary models
+ IF(SUM(ABS(a(:,S(1,4)))).EQ.0.D0) THEN
+ XT(1,:) = 0.D0 ! X(1|0)
+ ELSE
+ APPO = -F(:,:,S(1,5))
+ DO 1 I = 1,nx
+1 APPO(I,I) = 1.D0+APPO(I,I)
+C CALL F07ADF(nx,nx,APPO,nx,IPIV,IFAIL)
+C CALL F07AJF(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+ CALL DGETRF(nx,nx,APPO,nx,IPIV,IFAIL)
+ CALL DGETRI(nx,APPO,nx,IPIV,WORK,64*nx,IFAIL)
+ DO 2 I =1,nx
+2 XT(1,I) = SUM(APPO(I,:)*a(:,S(1,4))) ! inv(I-F)*a
+ ENDIF
+
+C P(1|0) - F*P(1|0)*F' = R*R'
+ CALL LYAP(nx,nu,TOL,F(:,:,S(1,5)),R(:,:,S(1,6)),PT(1,:,:))
+ ELSE
+C -----------------------------------------------------------
+C Non-stationary models
+C Define X(1) = aa + A*eta + B*delta (A*B' = 0)
+C eta~N(0,I), delta~N(0,k*I) k -> +inf
+C X(1)~N(aa,P), P=Ps+k*Pi, Ps=AA', Pi=BB'.
+C CARE!! aa (uncond. mean),Ps, and Pi to be filled by users
+C -----------------------------------------------------------
+ XT(1,1:nx) = 0.D0 ! X(1|0)
+ PT(1,1:nx,1:nx) = 0.D0 ! P(1|0)
+ IF (d(2).LT.nx) THEN
+ IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
+ APPO(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
+ DO 3 I = d(2)+1,nx
+3 APPO(I,I) = 1.D0+APPO(I,I)
+C CALL F07ADF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),IFAIL)
+C CALL F07AJF(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+ CALL DGETRF(nx-d(2),nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),IFAIL)
+ CALL DGETRI(nx-d(2),APPO(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),WORK,64*nx,IFAIL)
+
+ DO 4 I = d(2)+1,nx
+4 XT(1,I) = SUM(APPO(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
+ ENDIF
+C Lyapunov eqn
+ CALL LYAP(nx-d(2),nu,TOL,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
+ 1 R(d(2)+1:nx,1:nu,S(1,6)),PT(1,d(2)+1:nx,d(2)+1:nx))
+ ENDIF
+
+ Pi(:,:,:) = 0.D0
+ DO 5 I = 1,d(2)
+5 Pi(1,I,I) = 1.D0
+
+ DO 200 imain = 1,d(1)
+ DO 30 I=1,ny
+ DO 30 J=1,nx
+30 HPs(I,J) = SUM(H(I,:,S(imain,2))*PT(imain,:,J))
+
+ DO 40 I=1,ny
+ Fs(I,I) = SUM(HPs(I,:)*H(I,:,S(imain,2)))
+ + + SUM(G(I,:,S(imain,3))*G(I,:,S(imain,3)))
+ DO 40 J=1,I-1
+ Fs(I,J) = SUM(HPs(I,:)*H(J,:,S(imain,2)))
+ + + SUM(G(I,:,S(imain,3))*G(J,:,S(imain,3)))
+40 Fs(J,I) = Fs(I,J)
+
+ DO 50 I=1,ny
+ DO 50 J=1,nx
+50 HPi(I,J) = SUM(H(I,:,S(imain,2))*Pi(imain,:,J))
+
+ DO 60 I=1,ny
+ Fi(I,I) = SUM(HPi(I,:)*H(I,:,S(imain,2)))
+ DO 60 J=1,I-1
+ Fi(I,J) = SUM(HPi(I,:)*H(J,:,S(imain,2)))
+60 Fi(J,I) = Fi(I,J)
+
+C --------------------------------------------------------------------------
+C Computes inverse of the innovation variance matrix
+C Cases: ny = 1, Fi is scalar >0 (or 0 not considered)
+C ny > 1, Fi is full rank or singular (or 0 matrix not considered)
+C --------------------------------------------------------------------------
+ IF (ny.EQ.1) THEN
+ Fsm = 0.D0
+ Fim = 1.D0/Fi
+ FFF = Fim*Fs*Fim
+ ELSE
+
+ IFAIL = -1
+ COM(1:ny,1:ny) = Fi(1:ny,1:ny)
+C CALL F02FAF('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),
+C 1 WORK1,64*ny,IFAIL)
+ CALL DSYEV('N','U',ny,COM(1:ny,1:ny),ny,W1(1:ny),
+ 1 WORK1,64*ny,IFAIL)
+
+ FiRANK = 0
+ SUMW1 = SUM(ABS(W1(1:ny)))
+ DO 70 I=1,ny
+ W1(I) = W1(I)/SUMW1
+70 IF (W1(I).GT.1.D-10) FiRANK=FiRANK+1
+ FiRANK = min(FiRANK,d(2))
+
+c CALL SCHOLLU(Fi(1:ny,1:ny),FFF,ny,NULLITY,EPS,IFAIL)
+c FiRANK = ny-NULLITY
+
+ IF(FiRANK.EQ.ny) THEN
+ Fsm = 0.D0
+ COM(1:ny,1:ny) = Fi(1:ny,1:ny)
+ IFAIL = -1
+c CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
+ CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
+
+ DO 80 I=1,ny
+ Fim(I,I) = COM(I,I)
+ DO 80 J=1,I-1
+ Fim(I,J) = COM(I,J)
+80 Fim(J,I) = Fim(I,J)
+
+ DO 81 I=1,ny
+ DO 81 J=1,ny
+81 COM(I,J) = SUM(Fim(I,1:ny)*Fs(1:ny,J)) ! Fim x Fs
+
+ DO 82 I=1,ny
+ FFF(I,I) = SUM(COM(I,1:ny)*Fim(1:ny,I))
+ DO 82 J=1,I-1
+ FFF(I,J) = SUM(COM(I,1:ny)*Fim(1:ny,J)) ! Fim x Fs x Fim
+82 FFF(J,I) = FFF(I,J)
+
+ ELSE
+
+ SUMW1=0.D0
+ DO I=Firank+1,ny
+ SUMW1 = SUMW1 + Fi(I,I)
+ ENDDO
+ IF (SUMW1.GT.0.D0) THEN
+ CALL INVFBIS(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
+ 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
+ ELSE
+ CALL INVF(Fs(1:ny,1:ny),Fi(1:ny,1:ny),ny,FiRANK,
+ 1 Fsm(1:ny,1:ny),Fim(1:ny,1:ny),FFF(1:ny,1:ny))
+ ENDIF
+
+ ENDIF
+ ENDIF
+ Vis(imain,1:ny,1:ny) = Fsm(1:ny,1:ny)
+ Vii(imain,1:ny,1:ny) = Fim(1:ny,1:ny)
+
+C ------------------------------------------------------------------
+C X(d|d) = X(d|d-1)+((Ps*H'+R*G')*Fsm+Pi*H'*Fim)*(Y(d)-H*X(d|d-1)-c)
+C ------------------------------------------------------------------
+ DO 85 I = 1,nx
+ DO 85 J = 1,ny
+ RG(I,J) =
+ # SUM(R(I,1:nu,S(imain,6))*G(J,1:nu,S(imain,3)))
+85 HPs(J,I) = HPs(J,I) + RG(I,J) ! HPs = (Ps*H'+R*G')'
+
+ DO 90 I = 1,nx
+ DO 90 J = 1,ny
+ PHFs(I,J) = SUM(HPs(1:ny,I)*Fsm(1:ny,J))
+90 PHFi(I,J) = SUM(HPi(1:ny,I)*Fim(1:ny,J))
+
+C Innovations
+ DO 100 I=1,ny
+100 INN(imain,I) = yk(imain,I)
+ + - SUM(H(I,1:nx,S(imain,2))*XT(imain,1:nx))
+ + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+ DO 110 I=1,nx
+110 X0(I) = XT(imain,I)
+ + + SUM((PHFs(I,1:ny)+PHFi(I,1:ny))*INN(imain,1:ny))
+
+C P(d|d) = P(d|d-1) + Pi*H'*Fim*Fs*Fim*H*Pi - Ps*H'*Fsm*H*Ps - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+C - Ps*H'*Fsm*H*Ps
+ DO 120 I = 1,nx
+ APPO(I,I) = -SUM(PHFs(I,1:ny)*HPs(1:ny,I))
+ DO 120 J = 1,I-1
+ APPO(I,J) = -SUM(PHFs(I,1:ny)*HPs(1:ny,J))
+120 APPO(J,I) = APPO(I,J)
+
+C - Ps*H'*Fim*H*Pi - (Ps*H'*Fim*H*Pi)'
+ DO 130 I = 1,nx
+ APPO(I,I) = APPO(I,I) - SUM(HPs(1:ny,I)*PHFi(I,1:ny))
+ + - SUM(PHFi(I,1:ny)*HPs(1:ny,I))
+ DO 130 J = 1,I-1
+ APPO(I,J) = APPO(I,J) - SUM(HPs(1:ny,I)*PHFi(J,1:ny))
+ + - SUM(PHFi(I,1:ny)*HPs(1:ny,J))
+130 APPO(J,I) = APPO(I,J)
+
+C Pi*H'*Fim*Fs*Fim*H*Pi
+ DO 140 I = 1,nx
+ DO 140 J = 1,ny
+140 APPO1(I,J) = SUM(HPi(1:ny,I)*FFF(1:ny,J))
+
+ DO 150 I = 1,nx
+ PFP(I,I) = SUM(APPO1(I,1:ny)*HPi(1:ny,I))
+ DO 150 J = 1,I-1
+ PFP(I,J) = SUM(APPO1(I,1:ny)*HPi(1:ny,J))
+150 PFP(J,I) = PFP(I,J)
+
+ P0(:,:) = PT(imain,:,:) + PFP(:,:) + APPO(:,:)
+
+C Mi = F*Pi*H'
+ DO 151 I = 1,nx
+ DO 151 J = 1,nx
+151 PFP(I,J) = SUM(F(I,1:nx,S(imain,5))*Pi(imain,1:nx,J)) ! F*Pi
+
+ DO 152 I = 1,nx
+ DO 152 J = 1,ny
+152 Mi(I,J) = SUM(PFP(I,1:nx)*H(J,1:nx,S(imain,2)))
+
+C Ms = F*Ps*H' + R*G'
+ DO 153 I = 1,nx
+ DO 153 J = 1,nx
+153 FP(I,J) = SUM(F(I,:,S(imain,5))*PT(imain,:,J)) ! F*Ps
+
+ DO 154 I = 1,nx
+ DO 154 J = 1,ny
+154 Ms(I,J)=RG(I,J)+SUM(FP(I,1:nx)*H(J,1:nx,S(imain,2)))
+
+C Kit = Ms*Fim - Mi*FFF
+C Kst = Ms*Fsm + Mi*Fim
+ DO 155 I = 1,nx
+ DO 155 J = 1,ny
+ Kit(imain,I,J) = SUM(Ms(I,1:ny)*Fim(1:ny,J))
+ + - SUM(Mi(I,1:ny)*FFF(1:ny,J))
+155 Kst(imain,I,J) = SUM(Ms(I,1:ny)*Fsm(1:ny,J))
+ + + SUM(Mi(I,1:ny)*Fim(1:ny,J))
+
+C ----------------------------------
+C Predictions X(t+1|t) and P(t+1|t)
+C ----------------------------------
+ IF (imain.LT.d(1)) THEN
+C Pi+1 = F*Pi*F'-Ci
+
+C Ci = Mi*Fim*Mi'
+ DO 164 I = 1,nx
+ DO 164 J = 1,ny
+164 RG(I,J) = SUM(Mi(I,1:ny)*Fim(1:ny,J)) ! Mi*Fim
+
+ DO 166 I = 1,nx
+ Ci(I,I) = SUM(RG(I,1:ny)*Mi(I,1:ny))
+ DO 166 J = 1,I-1
+166 Ci(I,J) = SUM(RG(I,1:ny)*Mi(J,1:ny))
+
+ DO 168 I = 1,nx
+ Pi(imain+1,I,I)=SUM(PFP(I,1:nx)*F(I,1:nx,S(imain+1,5)))-Ci(I,I)
+ DO 168 J = 1,I-1
+ Pi(imain+1,I,J)=SUM(PFP(I,1:nx)*F(J,1:nx,S(imain+1,5)))-Ci(I,J)
+168 Pi(imain+1,J,I) = Pi(imain+1,I,J)
+
+ ENDIF
+
+C X(t+1|t) = a + F*X(t|t)
+ DO 170 I=1,nx
+170 XT(imain+1,I) = a(I,S(imain+1,4))
+ + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
+
+C P(t+1|t) = F*PddF' + R*R'
+ DO 172 I = 1,nx
+ DO 172 J = 1,nx
+172 APPO(I,J) = SUM(F(I,:,S(imain+1,5))*P0(:,J)) ! F*Pdd
+
+ DO 180 I = 1,nx
+ PT(imain+1,I,I) = SUM(APPO(I,1:nx)*F(I,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
+ DO 180 J = 1,I-1
+ PT(imain+1,I,J) = SUM(APPO(I,1:nx)*F(J,1:nx,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
+180 PT(imain+1,J,I) = PT(imain+1,I,J)
+
+200 CONTINUE
+ ENDIF
+
+ DO 400 imain = d(1)+1,nobs
+C -------------------------------
+C Innovations: INN = yk-H*X1-c*z
+C -------------------------------
+ DO 210 I=1,ny
+210 INN(imain,I) = yk(imain,I)
+ + - SUM(H(I,1:nx,S(imain,2))*XT(imain,:))
+ + - SUM(c(I,1:nz,S(imain,1))*yk(imain,ny+1:ny+nz))
+
+C ----------------------------------------------------------
+C Innovation variance V = H*P1*H' + G*G' + H*R*G' + G*R'*H'
+C ----------------------------------------------------------
+ DO 220 I=1,ny
+ DO 220 J=1,nx
+220 HP1(I,J) = SUM(H(I,1:nx,S(imain,2))*PT(imain,1:nx,J))
+
+ DO 221 I=1,nx
+ DO 221 J=1,ny
+221 RG(I,J)=SUM(R(I,1:nu,S(imain,6))*G(J,1:nu,S(imain,3)))
+
+ DO 222 I=1,ny
+ DO 222 J=1,ny
+222 COM(I,J)=SUM(H(I,1:nx,S(imain,2))*RG(1:nx,J)) ! H*R*G'
+
+ DO 230 I=1,ny
+ V(I,I) = SUM(HP1(I,1:nx)*H(I,1:nx,S(imain,2)))
+ # + SUM(G(I,1:nu,S(imain,3))*
+ # G(I,1:nu,S(imain,3))) + 2.*COM(I,I)
+ DO 230 J=1,I-1
+ V(I,J) = SUM(HP1(I,1:nx)*H(J,1:nx,S(imain,2)))+
+ # SUM(G(I,1:nu,S(imain,3))*
+ # G(J,1:nu,S(imain,3)))+COM(I,J)+COM(J,I)
+230 V(J,I) = V(I,J)
+
+C -------------------------------------------------------------------
+C Updating equations:
+C x0 = x1 + (P1*H'+R*G')*Vinv*INN
+C p0 = p1 - (P1*H'+R*G')*Vinv*(P1*H'+R*G')'
+C -------------------------------------------------------------------
+ IF (ny.GT.0) THEN
+ COM(1:ny,1:ny) = V(1:ny,1:ny)
+ IFAIL = -1
+C CALL F01ADF(ny,COM(1:ny+1,1:ny),ny+1,IFAIL)
+ CALL DPOTRF('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = L*L'
+ CALL DPOTRI('L',ny,COM(1:ny,1:ny),ny,IFAIL) ! COM = VV^-1
+
+ DO 240 I=1,ny
+ Vinv(imain,I,I) = COM(I,I)
+ DO 240 J=1,I-1
+ Vinv(imain,I,J) = COM(I,J)
+240 Vinv(imain,J,I) = Vinv(imain,I,J)
+
+ DO 260 I=1,nx
+ DO 260 J=1,ny
+260 HPV(I,J) = SUM((HP1(1:ny,I)+RG(I,1:ny))*Vinv(imain,1:ny,J))
+
+ DO 270 I=1,nx
+270 X0(I) = XT(imain,I)+SUM(HPV(I,1:ny)*INN(imain,1:ny))
+
+ DO 280 I=1,nx
+ P0(I,I) = PT(imain,I,I)
+ + - SUM(HPV(I,1:ny)*(HP1(1:ny,I)+RG(I,1:ny)))
+ DO 280 J=1,I-1
+ P0(I,J) = PT(imain,I,J)
+ + - SUM(HPV(I,1:ny)*(HP1(1:ny,J)+RG(J,1:ny)))
+280 P0(J,I) = P0(I,J)
+ ELSE
+
+ X0(1:nx) = XT(imain,1:nx)
+ P0(1:nx,1:nx) = PT(imain,1:nx,1:nx)
+
+ ENDIF
+
+C ------------------------------------
+C Prediction x1 = c+F*x0
+C Prediction var. P1 = F*p0*F'+ R*R'
+C ------------------------------------
+ IF (imain.LT.nobs) THEN
+ DO 290 I=1,nx
+290 XT(imain+1,I) = a(I,S(imain+1,4))
+ + + SUM(F(I,1:nx,S(imain+1,5))*X0(1:nx))
+
+ DO 300 I=1,nx
+ DO 300 J=1,nx
+300 FP(I,J) = SUM(F(I,1:nx,S(imain+1,5))*P0(1:nx,J))
+
+ DO 310 I=1,nx
+ PT(imain+1,I,I) = SUM(FP(I,:)*F(I,:,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(I,1:nu,S(imain+1,6)))
+ DO 310 J=1,I-1
+ PT(imain+1,I,J) = SUM(FP(I,:)*F(J,:,S(imain+1,5)))
+ + + SUM(R(I,1:nu,S(imain+1,6))*R(J,1:nu,S(imain+1,6)))
+310 PT(imain+1,J,I) = PT(imain+1,I,J)
+ ENDIF
+400 CONTINUE
+
+C **** SMOOTHING BAKWARD RECURSIONS ****
+ RECR(1:nx) = 0.D0
+ RECN(1:nx,1:nx) = 0.D0
+ DO 600 ITIME = nobs,d(1)+1,-1
+C R*G' and H'*Vinv
+ DO 420 J=1,ny
+ DO 420 I=1,nx
+ RG(I,J)=SUM(R(I,1:nu,S(ITIME,6))*G(J,1:nu,S(ITIME,3)))
+420 PHFs(I,J) =
+ # SUM(H(1:ny,I,S(ITIME,2))*Vinv(ITIME,1:ny,J))
+
+C F(t+1)*P(t|t-1)
+ DO 430 I=1,nx
+ DO 430 J=1,nx
+430 FP(I,J) = SUM(F(I,1:nx,S(min(nobs,ITIME+1),5))*PT(ITIME,1:nx,J))
+
+C H'*Vinv*H
+ DO 440 I=1,nx
+ APPO(I,I) = SUM(PHFs(I,1:ny)*H(1:ny,I,S(ITIME,2)))
+ DO 440 J=1,I-1
+ APPO(I,J) = SUM(PHFs(I,1:ny)*H(1:ny,J,S(ITIME,2)))
+440 APPO(J,I) = APPO(I,J)
+
+C L(t) = F(t+1)-(F(t+1)*P(t|t-1)*H(t)'+R(t)*G(t)')*Vinv(t)*H(t)
+ DO 450 I=1,nx
+ DO 450 J=1,nx
+450 PFP(I,J) = F(I,J,S(min(nobs,ITIME+1),5))
+ + - SUM(FP(I,1:nx)*APPO(1:nx,J))
+ + - SUM(RG(I,1:ny)*PHFs(J,1:ny))
+
+C r(t-1) = H(t)'*Vinv(t)*INN(t)+L(t)'*r(t)
+ DO 460 I=1,nx
+460 WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx))
+
+ DO 470 I=1,nx
+470 RECR(I) = WORK(I) + SUM(PHFs(I,1:ny)*INN(ITIME,1:ny))
+
+C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
+ DO 480 I=1,nx
+ DO 480 J=1,nx
+480 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
+
+ DO 490 I=1,nx
+ RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
+ DO 490 J=1,I-1
+ RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
+490 RECN(J,I) = RECN(I,J)
+
+C X(t|T) = X(t|t-1) + P(t|t-1)*r(t-1)
+ DO 500 I = 1,nx
+500 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
+
+C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
+ DO 510 I=1,nx
+ DO 510 J=1,nx
+510 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
+
+c DO 520 I=1,nx
+c PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
+c DO 520 J=1,I-1
+c PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
+c520 PS(ITIME,J,I) = PS(ITIME,I,J)
+
+600 CONTINUE
+
+C INITIAL KALMAN SAMOOTING
+ RECRI(1:nx) = 0.D0
+ DO 800 ITIME = d(1),1,-1
+C L(t) = F(t)-Kst(t)*H(t)
+ DO 610 I=1,nx
+ DO 610 J=1,nx
+610 PFP(I,J) = F(I,J,S(ITIME,5))
+ + - SUM(Kst(ITIME,I,1:ny)*H(1:ny,J,S(ITIME,2)))
+
+C r(t-1) = H(t)'*Fsm*INN(t) + L(t)'*r(t)
+C ri(t-1) = H(t)'*Fim*INN(t) + L(t)'*ri(t) + Li(t)'*r(t)
+ DO 620 I=1,nx
+ WORK(I) = SUM(PFP(1:nx,I)*RECR(1:nx)) ! L(t)'*r(t)
+620 WORK(nx+I) = SUM(PFP(1:nx,I)*RECRI(1:nx)) ! L(t)'*ri(t)
+
+C Li(t) = -Kit(t)*H(t)
+ DO 621 I=1,nx
+ DO 621 J=1,nx
+621 PFP(I,J) =
+ # - SUM(Kit(ITIME,I,1:ny)*H(1:ny,J,S(ITIME,2)))
+
+C L(t)'*ri(t) + Li(t)'*r(t)
+ DO 622 I=1,nx
+622 WORK(nx+I) = WORK(nx+I)+SUM(PFP(1:nx,I)*RECR(1:nx))
+
+C H'*Fsm
+ DO 625 I=1,nx
+ DO 625 J=1,ny
+625 PHFs(I,J) =
+ # SUM(H(1:ny,I,S(ITIME,2))*Vis(ITIME,1:ny,J))
+
+ DO 630 I=1,nx
+630 RECR(I) = WORK(I) + SUM(PHFs(I,1:ny)*INN(ITIME,1:ny))
+
+C H'*Fim
+ DO 631 I=1,nx
+ DO 631 J=1,ny
+631 PHFs(I,J) =
+ # SUM(H(1:ny,I,S(ITIME,2))*Vii(ITIME,1:ny,J))
+
+ DO 632 I=1,nx
+632 RECRI(I) = WORK(nx+I) + SUM(PHFs(I,1:ny)*INN(ITIME,1:ny))
+
+C X(d|T) = X(d|d-1) + Psd*r(t-1) + Pid*ri(t-1)
+ DO 660 I = 1,nx
+660 XS(ITIME,I) = XT(ITIME,I) + SUM(PT(ITIME,I,1:nx)*RECR(1:nx))
+ + + SUM(Pi(ITIME,I,1:nx)*RECRI(1:nx))
+
+800 CONTINUE
+
+ DEALLOCATE(Pi,HPs,HPi,Fi,Fs,Fim,Fsm,PHFs,PHFi,FFF,Mi,Ms,Ci,
+ 1 Kst,Kit,W1,WORK,WORK1,PFP,APPO,APPO1,COM,RG,FP,HP1,V,CC,HPV,
+ 2 X0,P0,RECR,RECRI,RECN,XT,PT,INN,Vinv,Vis,Vii)
+
+ RETURN
+ END
+
+C This is the variance and must be completed!!
+C N(t-1) = H(t)'*Vinv(t)*H(t)+L(t)'*N(t)*L(t)
+c DO 640 I=1,nx
+c DO 640 J=1,nx
+c640 CC(I,J) = SUM(PFP(1:nx,I)*RECN(1:nx,J)) ! L(t)'*N(t)
+c DO 650 I=1,nx
+c RECN(I,I) = APPO(I,I) + SUM(CC(I,1:nx)*PFP(1:nx,I))
+c DO 650 J=1,I-1
+c RECN(I,J) = APPO(I,J) + SUM(CC(I,1:nx)*PFP(1:nx,J))
+c650 RECN(J,I) = RECN(I,J)
+C P(t|T) = P(t|t-1) - P(t|t-1)*N(t-1)*P(t|t-1)
+c DO 670 I=1,nx
+c DO 670 J=1,nx
+c670 CC(I,J) = SUM(PT(ITIME,I,1:nx)*RECN(1:nx,J)) ! P(t|t-1)*N(t-1)
+c
+c DO 680 I=1,nx
+c PS(ITIME,I,I) = PT(ITIME,I,I) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,I))
+c DO 680 J=1,I-1
+c PS(ITIME,I,J) = PT(ITIME,I,J) - SUM(CC(I,1:nx)*PT(ITIME,1:nx,J))
+c680 PS(ITIME,J,I) = PS(ITIME,I,J)
+
diff --git a/lemma4.for b/lemma4.for
index a847f2cc4fd32a0dcbac7d325fc7b92572d2d839..e1b6d700852d605824269d593110ce57b4f6639d 100644
--- a/lemma4.for
+++ b/lemma4.for
@@ -1,14 +1,14 @@
-C ------------------------------------------------------------
-C LEMMA4 returns log(f(y(t+1),...,y(T)|y(1),...,y(t),theta,S))
-C For details see lemma 4 in Gerlach et al. JASA, 2000
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------
+C LEMMA4 returns log(f(y(t+1),...,y(T)|y(1),...,y(t),theta,S))
+C For details see lemma 4 in Gerlach et al. JASA, 2000
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -19,75 +19,75 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------------------
- DOUBLE PRECISION FUNCTION LEMMA4(OM,MU,X0,P0,nx)
-
-! INPUT
- INTEGER nx
- DOUBLE PRECISION OM(nx,nx),MU(nx),X0(nx),P0(nx,nx)
-
-! LOCALS
- INTEGER I,J,NULLITY,IFAIL
- DOUBLE PRECISION COM(nx+1,nx),OMC(nx,nx),C(nx,nx),T(nx,nx),
- 1 DETV,AUX,EPS ! W(nx),LAM(nx),WORK(3*nx)
-
-! EXTERNAL SUBROUTINES
- EXTERNAL SCHOLLU,DPOTRF,DPOTRI
-
- EPS = 1.D-14
- T(:,:) = 0.D0
- CALL SCHOLLU(P0,T,nx,NULLITY,EPS,IFAIL)
-
-C OMC = T' OM T + I
- DO 20 I=1,nx
- DO 20 J=1,nx
-20 COM(I,J) = SUM(T(:,I)*OM(:,J))
-
- OMC(:,:) = 0.D0
- DO 30 I=1,nx
- OMC(I,I) = 1.D0
- DO 30 J=1,I
- OMC(I,J) = SUM(COM(I,:)*T(:,J)) + OMC(I,J)
-30 OMC(J,I) = OMC(I,J)
-
-C OMC = inv(T' OM T + I )
- COM(1:nx,:) = OMC(:,:)
- IFAIL = -1
-C CALL F01ADF(nx, COM, nx+1, IFAIL)
- CALL DPOTRF('L',nx,COM(1:nx,1:nx),nx,IFAIL) ! COM = L*L'
- DETV = 1.D0 ! det(L)
- DO I =1,nx
- DETV = DETV*COM(I,I)
- ENDDO
- CALL DPOTRI('L',nx,COM(1:nx,1:nx),nx,IFAIL) ! COM = VV^-1
-
- DO 40 I=1,nx
- OMC(I,I) = COM(I,I)
- DO 40 J=1,I-1
- OMC(I,J) = COM(I,J)
-40 OMC(J,I) = OMC(I,J)
-
-C COM(1:nx,:) = OMC(:,:) ! CARE OMC IS INVERTED
-C IFAIL=-1
-C CALL F03ABF(COM(1:nx,1:nx),nx,nx,DETV,W,IFAIL)
-
-C AUX = -.5*m' OM m + MU'*m +.5*(mu-om*m)'*T(T'omT+I)^-1*T'*(mu-om*m)
- AUX = SUM(MU(:)*X0(:)) ! MU'*m
- DO 50 I=1,nx
-50 C(I,1) = SUM(X0(:)*OM(:,I)) ! OM*m
- AUX = AUX - .5D0*SUM(C(:,1)*X0(:)) ! -.5*m' OM m
-
- DO 60 I=1,nx
-60 COM(I,1) = SUM((MU(:)-C(:,1))*T(:,I)) !(mu-om*m)'*T
-
-C .5*(mu-om*m)'*T(T'omT+I)^-1*T'*(mu-om*m)
- DO 70 I=1,nx
- DO 70 J=1,nx
-70 AUX = AUX + .5D0*COM(I,1)*COM(J,1)*OMC(I,J)
-
-c LEMMA4 = .5D0*DLOG(DETV) + AUX
- LEMMA4 = -1.D0*DLOG(DETV) + AUX
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION LEMMA4(OM,MU,X0,P0,nx)
+
+! INPUT
+ INTEGER nx
+ DOUBLE PRECISION OM(nx,nx),MU(nx),X0(nx),P0(nx,nx)
+
+! LOCALS
+ INTEGER I,J,NULLITY,IFAIL
+ DOUBLE PRECISION COM(nx+1,nx),OMC(nx,nx),C(nx,nx),T(nx,nx),
+ 1 DETV,AUX,EPS ! W(nx),LAM(nx),WORK(3*nx)
+
+! EXTERNAL SUBROUTINES
+ EXTERNAL SCHOLLU,DPOTRF,DPOTRI
+
+ EPS = 1.D-14
+ T(:,:) = 0.D0
+ CALL SCHOLLU(P0,T,nx,NULLITY,EPS,IFAIL)
+
+C OMC = T' OM T + I
+ DO 20 I=1,nx
+ DO 20 J=1,nx
+20 COM(I,J) = SUM(T(:,I)*OM(:,J))
+
+ OMC(:,:) = 0.D0
+ DO 30 I=1,nx
+ OMC(I,I) = 1.D0
+ DO 30 J=1,I
+ OMC(I,J) = SUM(COM(I,:)*T(:,J)) + OMC(I,J)
+30 OMC(J,I) = OMC(I,J)
+
+C OMC = inv(T' OM T + I )
+ COM(1:nx,:) = OMC(:,:)
+ IFAIL = -1
+C CALL F01ADF(nx, COM, nx+1, IFAIL)
+ CALL DPOTRF('L',nx,COM(1:nx,1:nx),nx,IFAIL) ! COM = L*L'
+ DETV = 1.D0 ! det(L)
+ DO I =1,nx
+ DETV = DETV*COM(I,I)
+ ENDDO
+ CALL DPOTRI('L',nx,COM(1:nx,1:nx),nx,IFAIL) ! COM = VV^-1
+
+ DO 40 I=1,nx
+ OMC(I,I) = COM(I,I)
+ DO 40 J=1,I-1
+ OMC(I,J) = COM(I,J)
+40 OMC(J,I) = OMC(I,J)
+
+C COM(1:nx,:) = OMC(:,:) ! CARE OMC IS INVERTED
+C IFAIL=-1
+C CALL F03ABF(COM(1:nx,1:nx),nx,nx,DETV,W,IFAIL)
+
+C AUX = -.5*m' OM m + MU'*m +.5*(mu-om*m)'*T(T'omT+I)^-1*T'*(mu-om*m)
+ AUX = SUM(MU(:)*X0(:)) ! MU'*m
+ DO 50 I=1,nx
+50 C(I,1) = SUM(X0(:)*OM(:,I)) ! OM*m
+ AUX = AUX - .5D0*SUM(C(:,1)*X0(:)) ! -.5*m' OM m
+
+ DO 60 I=1,nx
+60 COM(I,1) = SUM((MU(:)-C(:,1))*T(:,I)) !(mu-om*m)'*T
+
+C .5*(mu-om*m)'*T(T'omT+I)^-1*T'*(mu-om*m)
+ DO 70 I=1,nx
+ DO 70 J=1,nx
+70 AUX = AUX + .5D0*COM(I,1)*COM(J,1)*OMC(I,J)
+
+c LEMMA4 = .5D0*DLOG(DETV) + AUX
+ LEMMA4 = -1.D0*DLOG(DETV) + AUX
+
+ RETURN
END
diff --git a/logmvnpdf.for b/logmvnpdf.for
index 80b8816a3382e9aa8a52ca65505e0406e9d473a9..e1a55feb02ff6cc4ac10754413a0c6162363719c 100644
--- a/logmvnpdf.for
+++ b/logmvnpdf.for
@@ -1,17 +1,17 @@
-C ------------------------------------------------------------------------
-C LOGMVNPDF returns the Multivariate Normal pdf with parameters mu, SIG,
-C evaluated at x.
-C mu (px1),SIG (pxp), x (px1)
-C Bauwens et al. (1999): "Bayesian Inference in Dynamic Econometric
-C models", Oxford University Press, page 298
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------------------
+C LOGMVNPDF returns the Multivariate Normal pdf with parameters mu, SIG,
+C evaluated at x.
+C mu (px1),SIG (pxp), x (px1)
+C Bauwens et al. (1999): "Bayesian Inference in Dynamic Econometric
+C models", Oxford University Press, page 298
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -22,54 +22,54 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION logmvnpdf(X,mu,SIG,p)
-
-C INPUT
- INTEGER p
- DOUBLE PRECISION X(p),mu(p),SIG(p,p)
-C LOCALS
- INTEGER I,J,IFAIL
- DOUBLE PRECISION,ALLOCATABLE:: ISIG(:,:),COM(:,:)
- DOUBLE PRECISION PI,H,DET,KER
- DATA PI/3.141592653589793D0/,H/-.5D0/
-C EXTERNAL SUBROUTINES
- EXTERNAL DPOTRF,DPOTRI
-
- ALLOCATE(ISIG(p,p),COM(p+1,p))
-
-C INVERT SIG
- COM(1:p,1:p) = SIG(1:p,1:p)
- IFAIL = -1
-C CALL F01ADF(p,COM(1:p+1,1:p),p+1,IFAIL)
- CALL DPOTRF('L',p,COM(1:p,1:p),p,IFAIL) ! COM = L*L'
- DET = 1.D0 ! det(L)
- DO I =1,p
- DET = DET*COM(I,I)
- ENDDO
- CALL DPOTRI('L',p,COM(1:p,1:p),p,IFAIL) ! COM = VV^-1
-
- DO 10 I=1,p
- ISIG(I,I) = COM(I,I)
- DO 10 J=1,I-1
- ISIG(I,J) = COM(I,J)
-10 ISIG(J,I) = ISIG(I,J)
-
-C DETERMINANT of SIG
-c COM(1:p,1:p) = SIG(1:p,1:p)
-c IFAIL = -1
-c CALL F03ABF(COM(1:p,1:p),p,p,DET,WKSPCE,IFAIL)
-
-C QUADRATIC FORM (log)
- KER = 0.D0
- DO 20 I=1,p
- DO 20 J=1,p
-20 KER = KER + (X(I)-mu(I))*ISIG(I,J)*(X(J)-mu(J))
-
-C LOG PDF
- logmvnpdf = H*p*dlog(2.*PI)-1.D0*dlog(DET)+H*KER
-
- DEALLOCATE(ISIG,COM)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION logmvnpdf(X,mu,SIG,p)
+
+C INPUT
+ INTEGER p
+ DOUBLE PRECISION X(p),mu(p),SIG(p,p)
+C LOCALS
+ INTEGER I,J,IFAIL
+ DOUBLE PRECISION,ALLOCATABLE:: ISIG(:,:),COM(:,:)
+ DOUBLE PRECISION PI,H,DET,KER
+ DATA PI/3.141592653589793D0/,H/-.5D0/
+C EXTERNAL SUBROUTINES
+ EXTERNAL DPOTRF,DPOTRI
+
+ ALLOCATE(ISIG(p,p),COM(p+1,p))
+
+C INVERT SIG
+ COM(1:p,1:p) = SIG(1:p,1:p)
+ IFAIL = -1
+C CALL F01ADF(p,COM(1:p+1,1:p),p+1,IFAIL)
+ CALL DPOTRF('L',p,COM(1:p,1:p),p,IFAIL) ! COM = L*L'
+ DET = 1.D0 ! det(L)
+ DO I =1,p
+ DET = DET*COM(I,I)
+ ENDDO
+ CALL DPOTRI('L',p,COM(1:p,1:p),p,IFAIL) ! COM = VV^-1
+
+ DO 10 I=1,p
+ ISIG(I,I) = COM(I,I)
+ DO 10 J=1,I-1
+ ISIG(I,J) = COM(I,J)
+10 ISIG(J,I) = ISIG(I,J)
+
+C DETERMINANT of SIG
+c COM(1:p,1:p) = SIG(1:p,1:p)
+c IFAIL = -1
+c CALL F03ABF(COM(1:p,1:p),p,p,DET,WKSPCE,IFAIL)
+
+C QUADRATIC FORM (log)
+ KER = 0.D0
+ DO 20 I=1,p
+ DO 20 J=1,p
+20 KER = KER + (X(I)-mu(I))*ISIG(I,J)*(X(J)-mu(J))
+
+C LOG PDF
+ logmvnpdf = H*p*dlog(2.*PI)-1.D0*dlog(DET)+H*KER
+
+ DEALLOCATE(ISIG,COM)
+ RETURN
END
diff --git a/lyapunov.for b/lyapunov.for
index 66964fd7451408845a2288edac15de0627a2d5e2..d0c292b9bb87c54c1b611124614820b1b96d854d 100644
--- a/lyapunov.for
+++ b/lyapunov.for
@@ -1,16 +1,16 @@
-C -------------------------------------------------------------
-C LYAP solves the Lyapunov equation Ps-F*Ps*F'=RR
-C where RR and Ps are symmetric matrices.
-C Developed by DYNARE team
-C Recoded in Fortran by A.Rossi, C.Planas and G.Fiorentini
-C
+C -------------------------------------------------------------
+C LYAP solves the Lyapunov equation Ps-F*Ps*F'=RR
+C where RR and Ps are symmetric matrices.
+C Developed by DYNARE team
+C Recoded in Fortran by A.Rossi, C.Planas and G.Fiorentini
+C
C Copyright (C) 2006-2012 Dynare Team
-C Copyright (C) 2010-2014 European Commission
-C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -21,190 +21,190 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE LYAP(nx,nu,compt,F,R,Ps)
-C INPUT
- INTEGER nx,nu
- DOUBLE PRECISION compt,F(nx,nx),R(nx,nu)
-C OUTPUT
- DOUBLE PRECISION Ps(nx,nx)
-C LOCALS
- INTEGER I,J,IFAIL,LWORK,IPIV(nx**2)
- LOGICAL BWORK(nx),SELECT
- DOUBLE PRECISION, ALLOCATABLE:: WORK(:),RR(:,:),WR(:),WI(:),
- 1 Z(:,:),T(:,:),ZR(:,:),ZRZ(:,:),Q(:,:),WR1(:),Z1(:)
-C EXTERNAL SUBROUTINES
- EXTERNAL DGETRF,DGETRI,DGEES,SELECT
-
-C RR = R*R'
- ALLOCATE(RR(nx,nx))
- DO 10 I = 1,nx
- RR(I,I) = SUM(R(I,:)*R(I,:))
- DO 10 J = 1,I-1
- RR(I,J) = SUM(R(I,:)*R(J,:))
-10 RR(J,I) = RR(I,J)
-
- IF (nx.EQ.1) THEN
- Ps(1,1) = RR(1,1)/(1.D0-F(1,1)**2)
- DEALLOCATE(RR)
- GOTO 7777
- ENDIF
-
- LWORK = 3*nx
- ALLOCATE(T(nx,nx),WORK(LWORK),WR(nx),WI(nx),Z(nx,nx),ZRZ(nx,nx),
- 1 ZR(nx,nx),Q(2*nx,2*nx),WR1(nx),Z1(2*nx))
-
- T(1:nx,1:nx) = F(1:nx,1:nx)
- IFAIL = -1
-C CALL F02EAF('V',nx,T,nx,WR,WI,Z,nx,WORK,LWORK,IFAIL) ! F = ZTZ'
- I = 0
- CALL DGEES('V','N',SELECT,nx,T,nx,I,WR,WI,Z,nx,WORK,LWORK,
- # BWORK,IFAIL)
- DO I = 1,nx
- IF (WI(I)**2+WR(I)**2.GE.1.D0) THEN
- TYPE *, ' '
- TYPE *, ' LYAPUNOV SUBROUTINE: Some parameters out of '
- TYPE *, ' stationary region. Check hyptheta in namelist prior.'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDDO
-
-C ZRZ = Z'*RR*Z (B in Matlab)
- DO 20 I = 1,nx
- DO 20 J = 1,nx
-20 ZR(I,J) = SUM(Z(:,I)*RR(:,J)) ! Z'*RR
-
- DO 30 I = 1,nx
- DO 30 J = 1,nx
-30 ZRZ(I,J) = SUM(ZR(I,:)*Z(:,J))
-
- I = nx
- WR(:) = 0.D0 !(c in Matalab)
- WR1(:) = 0.D0 !(c1 in Matalab)
- Ps(:,:) = 0.D0 !(x in Matalab)
- DO WHILE (I.GE.2)
- IF (DABS(T(I,I-1)).LT.compt) THEN
- IF (I.LT.nx) THEN
-c c = T(1:i,:)*(x(:,i+1:end)*T(i,i+1:end)') + ...
-c T(i,i)*T(1:i,i+1:end)*x(i+1:end,i);
- DO 40 J = 1,nx
-40 WI(J) = SUM(Ps(J,I+1:nx)*T(I,I+1:nx))
- DO 50 J = 1,I
-50 WR(J) = SUM(T(J,1:nx)*WI(1:nx))
- + + T(I,I)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I))
-
- ENDIF
-c q = eye(i)-T(1:i,1:i)*T(i,i);
-c x(1:i,i) = q\(B(1:i,i)+c); x = inv(q)*(B(1:i,i)+c)
-c x(i,1:i-1) = x(1:i-1,i)';
-c i = i - 1;
- Q(1:I,1:I) = -T(I,I)*T(1:I,1:I)
- DO 60 J = 1,I
-60 Q(J,J) = Q(J,J) + 1.D0
-
- IFAIL = -1
- ZR(1:I,1:I) = Q(1:I,1:I)
-c CALL F07ADF(I,I,ZR(1:I,1:I),I,IPIV(1:I),IFAIL)
-c CALL F07AJF(I,ZR(1:I,1:I),I,IPIV(1:I),WORK(1:64*I),64*I,IFAIL)
- CALL DGETRF(I,I,ZR(1:I,1:I),I,IPIV(1:I),IFAIL)
- CALL DGETRI(I,ZR(1:I,1:I),I,IPIV(1:I),WORK(1:64*I),64*I,IFAIL)
- DO 70 J = 1,I
-70 Ps(J,I) = SUM(ZR(J,1:I)*(ZRZ(1:I,I)+WR(1:I)))
- Ps(I,1:I-1) = Ps(1:I-1,I)
- I = I - 1
- ELSE
- IF (I.LT.nx) THEN
-c c = T(1:i,:)*(x(:,i+1:end)*T(i,i+1:end)') + ...
-c T(i,i)*T(1:i,i+1:end)*x(i+1:end,i) + ...
-c T(i,i-1)*T(1:i,i+1:end)*x(i+1:end,i-1);
- DO 90 J = 1,nx
-90 WI(J) = SUM(Ps(J,I+1:nx)*T(I,I+1:nx))
- DO 100 J = 1,I
-100 WR(J) = SUM(T(J,1:nx)*WI(1:nx))
- + + T(I,I)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I))
- + + T(I,I-1)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I-1))
-c c1 = T(1:i,:)*(x(:,i+1:end)*T(i-1,i+1:end)') + ...
-c T(i-1,i-1)*T(1:i,i+1:end)*x(i+1:end,i-1) + ...
-c T(i-1,i)*T(1:i,i+1:end)*x(i+1:end,i);
- DO 110 J = 1,nx
-110 WI(J) = SUM(Ps(J,I+1:nx)*T(I-1,I+1:nx))
-
- DO 120 J = 1,I
-120 WR1(J) = SUM(T(J,1:nx)*WI(1:nx))
- + + T(I-1,I-1)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I-1))
- + + T(I-1,I)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I))
- ENDIF
-c q = [ eye(i)-T(1:i,1:i)*T(i,i) , -T(1:i,1:i)*T(i,i-1) ; ...
-c -T(1:i,1:i)*T(i-1,i) , eye(i)-T(1:i,1:i)*T(i-1,i-1) ];
- Q(1:I,1:I) = -T(I,I)*T(1:I,1:I)
- Q(I+1:2*I,I+1:2*I) = -T(I-1,I-1)*T(1:I,1:I)
- Q(1:I,I+1:2*I) = -T(I,I-1)*T(1:I,1:I)
- Q(I+1:2*I,1:I) = -T(I-1,I)*T(1:I,1:I)
- DO 130 J = 1,2*I
-130 Q(J,J) = Q(J,J) + 1.D0
-c z = q\[ B(1:i,i)+c ; B(1:i,i-1) + c1 ];
- IFAIL = -1
-C CALL F07ADF(2*I,2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),IFAIL)
-C CALL F07AJF(2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),WORK(1:64*2*I),
-C # 64*2*I,IFAIL)
- CALL DGETRF(2*I,2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),IFAIL)
- CALL DGETRI(2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),WORK(1:64*2*I),
- # 64*2*I,IFAIL)
-
- DO 140 J = 1,2*I
-140 Z1(J) = SUM(Q(J,1:I)*(ZRZ(1:I,I) + WR(1:I)))
- + + SUM(Q(J,I+1:2*I)*(ZRZ(1:I,I-1) + WR1(1:I)))
-c x(1:i,i) = z(1:i);
-c x(1:i,i-1) = z(i+1:end);
-c x(i,1:i-1) = x(1:i-1,i)';
-c x(i-1,1:i-2) = x(1:i-2,i-1)';
- Ps(1:I,I) = Z1(1:i)
- Ps(1:I,I-1) = Z1(I+1:2*I)
- Ps(I,1:I-1) = Ps(1:I-1,I)
- Ps(I-1,1:I-2) = Ps(1:I-2,I-1)
- I = I - 2
- ENDIF
- END DO
-c if i == 1
-c c = T(1,:)*(x(:,2:end)*T(1,2:end)') + T(1,1)*T(1,2:end)*x(2:end,1);
-c x(1,1) = (B(1,1)+c)/(1-T(1,1)*T(1,1));
-c end
- IF (I.EQ.1) THEN
- DO 150 J =1,nx
- WI(J) = SUM(Ps(J,2:nx)*T(1,2:nx))
-150 WR(1) = SUM(T(1,1:nx)*WI(1:nx))
- + + T(1,1)*SUM(T(1,2:nx)*Ps(2:nx,1))
- Ps(1,1) = (ZRZ(1,1)+WR(1))/(1.D0-T(1,1)**2)
- ENDIF
-c x = U(:,:)*x*U(:,:)';
- DO 160 I = 1,nx
- DO 160 J = 1,nx
-160 ZR(I,J) = SUM(Z(I,1:nx)*Ps(1:nx,J))
-
- DO 170 I = 1,nx
- Ps(I,I) = SUM(ZR(I,1:nx)*Z(I,1:nx))
- DO 170 J = 1,I-1
- Ps(I,J) = SUM(ZR(I,1:nx)*Z(J,1:nx))
-170 Ps(J,I) = Ps(I,J)
-
- DEALLOCATE(WORK,RR,WR,WI,Z,T,ZRZ,ZR,Q,WR1,Z1)
-
-7777 RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE LYAP(nx,nu,compt,F,R,Ps)
+C INPUT
+ INTEGER nx,nu
+ DOUBLE PRECISION compt,F(nx,nx),R(nx,nu)
+C OUTPUT
+ DOUBLE PRECISION Ps(nx,nx)
+C LOCALS
+ INTEGER I,J,IFAIL,LWORK,IPIV(nx**2)
+ LOGICAL BWORK(nx),SELECT
+ DOUBLE PRECISION, ALLOCATABLE:: WORK(:),RR(:,:),WR(:),WI(:),
+ 1 Z(:,:),T(:,:),ZR(:,:),ZRZ(:,:),Q(:,:),WR1(:),Z1(:)
+C EXTERNAL SUBROUTINES
+ EXTERNAL DGETRF,DGETRI,DGEES,SELECT
+
+C RR = R*R'
+ ALLOCATE(RR(nx,nx))
+ DO 10 I = 1,nx
+ RR(I,I) = SUM(R(I,:)*R(I,:))
+ DO 10 J = 1,I-1
+ RR(I,J) = SUM(R(I,:)*R(J,:))
+10 RR(J,I) = RR(I,J)
+
+ IF (nx.EQ.1) THEN
+ Ps(1,1) = RR(1,1)/(1.D0-F(1,1)**2)
+ DEALLOCATE(RR)
+ GOTO 7777
+ ENDIF
+
+ LWORK = 3*nx
+ ALLOCATE(T(nx,nx),WORK(LWORK),WR(nx),WI(nx),Z(nx,nx),ZRZ(nx,nx),
+ 1 ZR(nx,nx),Q(2*nx,2*nx),WR1(nx),Z1(2*nx))
+
+ T(1:nx,1:nx) = F(1:nx,1:nx)
+ IFAIL = -1
+C CALL F02EAF('V',nx,T,nx,WR,WI,Z,nx,WORK,LWORK,IFAIL) ! F = ZTZ'
+ I = 0
+ CALL DGEES('V','N',SELECT,nx,T,nx,I,WR,WI,Z,nx,WORK,LWORK,
+ # BWORK,IFAIL)
+ DO I = 1,nx
+ IF (WI(I)**2+WR(I)**2.GE.1.D0) THEN
+ TYPE *, ' '
+ TYPE *, ' LYAPUNOV SUBROUTINE: Some parameters out of '
+ TYPE *, ' stationary region. Check hyptheta in namelist prior.'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDDO
+
+C ZRZ = Z'*RR*Z (B in Matlab)
+ DO 20 I = 1,nx
+ DO 20 J = 1,nx
+20 ZR(I,J) = SUM(Z(:,I)*RR(:,J)) ! Z'*RR
+
+ DO 30 I = 1,nx
+ DO 30 J = 1,nx
+30 ZRZ(I,J) = SUM(ZR(I,:)*Z(:,J))
+
+ I = nx
+ WR(:) = 0.D0 !(c in Matalab)
+ WR1(:) = 0.D0 !(c1 in Matalab)
+ Ps(:,:) = 0.D0 !(x in Matalab)
+ DO WHILE (I.GE.2)
+ IF (DABS(T(I,I-1)).LT.compt) THEN
+ IF (I.LT.nx) THEN
+c c = T(1:i,:)*(x(:,i+1:end)*T(i,i+1:end)') + ...
+c T(i,i)*T(1:i,i+1:end)*x(i+1:end,i);
+ DO 40 J = 1,nx
+40 WI(J) = SUM(Ps(J,I+1:nx)*T(I,I+1:nx))
+ DO 50 J = 1,I
+50 WR(J) = SUM(T(J,1:nx)*WI(1:nx))
+ + + T(I,I)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I))
+
+ ENDIF
+c q = eye(i)-T(1:i,1:i)*T(i,i);
+c x(1:i,i) = q\(B(1:i,i)+c); x = inv(q)*(B(1:i,i)+c)
+c x(i,1:i-1) = x(1:i-1,i)';
+c i = i - 1;
+ Q(1:I,1:I) = -T(I,I)*T(1:I,1:I)
+ DO 60 J = 1,I
+60 Q(J,J) = Q(J,J) + 1.D0
+
+ IFAIL = -1
+ ZR(1:I,1:I) = Q(1:I,1:I)
+c CALL F07ADF(I,I,ZR(1:I,1:I),I,IPIV(1:I),IFAIL)
+c CALL F07AJF(I,ZR(1:I,1:I),I,IPIV(1:I),WORK(1:64*I),64*I,IFAIL)
+ CALL DGETRF(I,I,ZR(1:I,1:I),I,IPIV(1:I),IFAIL)
+ CALL DGETRI(I,ZR(1:I,1:I),I,IPIV(1:I),WORK(1:64*I),64*I,IFAIL)
+ DO 70 J = 1,I
+70 Ps(J,I) = SUM(ZR(J,1:I)*(ZRZ(1:I,I)+WR(1:I)))
+ Ps(I,1:I-1) = Ps(1:I-1,I)
+ I = I - 1
+ ELSE
+ IF (I.LT.nx) THEN
+c c = T(1:i,:)*(x(:,i+1:end)*T(i,i+1:end)') + ...
+c T(i,i)*T(1:i,i+1:end)*x(i+1:end,i) + ...
+c T(i,i-1)*T(1:i,i+1:end)*x(i+1:end,i-1);
+ DO 90 J = 1,nx
+90 WI(J) = SUM(Ps(J,I+1:nx)*T(I,I+1:nx))
+ DO 100 J = 1,I
+100 WR(J) = SUM(T(J,1:nx)*WI(1:nx))
+ + + T(I,I)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I))
+ + + T(I,I-1)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I-1))
+c c1 = T(1:i,:)*(x(:,i+1:end)*T(i-1,i+1:end)') + ...
+c T(i-1,i-1)*T(1:i,i+1:end)*x(i+1:end,i-1) + ...
+c T(i-1,i)*T(1:i,i+1:end)*x(i+1:end,i);
+ DO 110 J = 1,nx
+110 WI(J) = SUM(Ps(J,I+1:nx)*T(I-1,I+1:nx))
+
+ DO 120 J = 1,I
+120 WR1(J) = SUM(T(J,1:nx)*WI(1:nx))
+ + + T(I-1,I-1)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I-1))
+ + + T(I-1,I)*SUM(T(J,I+1:nx)*Ps(I+1:nx,I))
+ ENDIF
+c q = [ eye(i)-T(1:i,1:i)*T(i,i) , -T(1:i,1:i)*T(i,i-1) ; ...
+c -T(1:i,1:i)*T(i-1,i) , eye(i)-T(1:i,1:i)*T(i-1,i-1) ];
+ Q(1:I,1:I) = -T(I,I)*T(1:I,1:I)
+ Q(I+1:2*I,I+1:2*I) = -T(I-1,I-1)*T(1:I,1:I)
+ Q(1:I,I+1:2*I) = -T(I,I-1)*T(1:I,1:I)
+ Q(I+1:2*I,1:I) = -T(I-1,I)*T(1:I,1:I)
+ DO 130 J = 1,2*I
+130 Q(J,J) = Q(J,J) + 1.D0
+c z = q\[ B(1:i,i)+c ; B(1:i,i-1) + c1 ];
+ IFAIL = -1
+C CALL F07ADF(2*I,2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),IFAIL)
+C CALL F07AJF(2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),WORK(1:64*2*I),
+C # 64*2*I,IFAIL)
+ CALL DGETRF(2*I,2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),IFAIL)
+ CALL DGETRI(2*I,Q(1:2*I,1:2*I),2*I,IPIV(1:2*I),WORK(1:64*2*I),
+ # 64*2*I,IFAIL)
+
+ DO 140 J = 1,2*I
+140 Z1(J) = SUM(Q(J,1:I)*(ZRZ(1:I,I) + WR(1:I)))
+ + + SUM(Q(J,I+1:2*I)*(ZRZ(1:I,I-1) + WR1(1:I)))
+c x(1:i,i) = z(1:i);
+c x(1:i,i-1) = z(i+1:end);
+c x(i,1:i-1) = x(1:i-1,i)';
+c x(i-1,1:i-2) = x(1:i-2,i-1)';
+ Ps(1:I,I) = Z1(1:i)
+ Ps(1:I,I-1) = Z1(I+1:2*I)
+ Ps(I,1:I-1) = Ps(1:I-1,I)
+ Ps(I-1,1:I-2) = Ps(1:I-2,I-1)
+ I = I - 2
+ ENDIF
+ END DO
+c if i == 1
+c c = T(1,:)*(x(:,2:end)*T(1,2:end)') + T(1,1)*T(1,2:end)*x(2:end,1);
+c x(1,1) = (B(1,1)+c)/(1-T(1,1)*T(1,1));
+c end
+ IF (I.EQ.1) THEN
+ DO 150 J =1,nx
+ WI(J) = SUM(Ps(J,2:nx)*T(1,2:nx))
+150 WR(1) = SUM(T(1,1:nx)*WI(1:nx))
+ + + T(1,1)*SUM(T(1,2:nx)*Ps(2:nx,1))
+ Ps(1,1) = (ZRZ(1,1)+WR(1))/(1.D0-T(1,1)**2)
+ ENDIF
+c x = U(:,:)*x*U(:,:)';
+ DO 160 I = 1,nx
+ DO 160 J = 1,nx
+160 ZR(I,J) = SUM(Z(I,1:nx)*Ps(1:nx,J))
+
+ DO 170 I = 1,nx
+ Ps(I,I) = SUM(ZR(I,1:nx)*Z(I,1:nx))
+ DO 170 J = 1,I-1
+ Ps(I,J) = SUM(ZR(I,1:nx)*Z(J,1:nx))
+170 Ps(J,I) = Ps(I,J)
+
+ DEALLOCATE(WORK,RR,WR,WI,Z,T,ZRZ,ZR,Q,WR1,Z1)
+
+7777 RETURN
+ END
+
+C For DEEGS - not used
+ LOGICAL FUNCTION SELECT(A,B)
+ DOUBLE PRECISION A,B
+ RETURN
END
-
-C For DEEGS - not used
- LOGICAL FUNCTION SELECT(A,B)
- DOUBLE PRECISION A,B
- RETURN
- END
-
-
-c SUBROUTINE PROVA(A)
-c DOUBLE PRECISION A
-c DIMENSION A( * )
-c A(4) = 1.D0
-c RETURN
+
+
+c SUBROUTINE PROVA(A)
+c DOUBLE PRECISION A
+c DIMENSION A( * )
+c A(4) = 1.D0
+c RETURN
c END
diff --git a/main.for b/main.for
index 2e2b58f571683edde4abf1467916da1eaaba8dd4..4ea6121d9ec01f614b90938e902ff54f52a54393 100644
--- a/main.for
+++ b/main.for
@@ -1,27 +1,27 @@
-C --------------------------------------------------------------------------------------
-C Program DMM: Bayesian and Classical Inference of Dynamic Mixture Models
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
-C a(t) (nx x ns4) ns4 = # of states for a(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------------------------
+C Program DMM: Bayesian and Classical Inference of Dynamic Mixture Models
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for H(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for G(t)
+C a(t) (nx x ns4) ns4 = # of states for a(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for F(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for R(t)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -32,795 +32,795 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------------------
- PROGRAM DMM
- USE dfwin
-C DECLARE an "interface block" to the .DLL that contains DESIGN
-
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN)
-C DECLARE an "interface block" to the .DLL that contains SETFILEM
- INTERFACE
- SUBROUTINE SETFILEM(mfile,pathmfile)
- CHARACTER*200 mfile,pathmfile
- END SUBROUTINE
- END INTERFACE
- POINTER (psetfilem,SETFILEM)
-C DECLARE an "interface block" to the .DLL that contains GETERRSTR
- INTERFACE
- SUBROUTINE GETERRSTR(matlaberror)
- CHARACTER*1024 matlaberror
- END SUBROUTINE
- END INTERFACE
- POINTER (pgeterrstr,GETERRSTR)
-
- LOGICAL status
- CHARACTER*200 DLLNAME ! name of the DLL (defined by the user)
-
-C NAMELIST DECLARATIONS
- INTEGER ny,nz,nx,nu,d(2),nv,nt,nf,nobs
- INTEGER seed,thin,burnin,GGG,HBL
- CHARACTER*1 MargLik,datasim,check
- CHARACTER*2 thetasampler,estimation
- CHARACTER*3 Ssampler
- DOUBLE PRECISION, ALLOCATABLE:: hypS(:,:,:),hyptheta(:,:),
- 1 obs(:)
- CHARACTER(2), ALLOCATABLE:: pdftheta(:)
-C LOCALS
- INTEGER, ALLOCATABLE:: Z(:),ZW(:),S(:,:),NEVAL(:),
- 1 CUMN(:),IYK(:,:),INDT(:),ACCRATE(:),gibZ(:,:),
- 1 IT1(:),IT2(:),DATE_ITIME(:),np(:),ns(:),INFOS(:,:)
- DOUBLE PRECISION, ALLOCATABLE:: yk(:,:),STATE(:,:),theta(:),
- 1 theta0(:),thetaprior(:,:),psi(:),psi0(:),psiprior(:,:),
- 2 INN(:,:),FORE(:,:),ykmis(:),PTR(:,:,:),PM(:,:),
- 3 gibtheta(:,:),MLHM(:,:),MLMW(:,:),thetase(:),AKMSE(:,:),HESS(:),
- 4 psise(:),SSMOOTH(:,:)
- DOUBLE PRECISION,ALLOCATABLE::c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:),R(:,:,:)
- CHARACTER(12), ALLOCATABLE:: REAL_CLOCK(:)
- INTEGER ntf,nstot,nmis,indmis,IT,I,J,K,L1,jjj,IND,IFAIL,IMAX(1),
- 1 IMIN(1),IMSVAR
- DOUBLE PRECISION AUX,lastl,lasth
- CHARACTER*1 DEB
- CHARACTER*3 DLLEXT
- CHARACTER*200 mfile,pathmfile
- CHARACTER*200 FILEIN,NMLNAME,PATH,FILEOUT,DMMTITLE,CURDIR
- CHARACTER*1024 matlaberror
-
-C EXTERNAL SUBROUTINES
- EXTERNAL GETARG
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION genbet
-
-C TIME
- ALLOCATE(np(3),ns(6),INFOS(9,6),IT1(7),IT2(7),DATE_ITIME(8),
- 1 REAL_CLOCK(3))
- CALL DATE_AND_TIME(REAL_CLOCK(1),REAL_CLOCK(2),REAL_CLOCK(3),
- 1 DATE_ITIME)
- IT1(1:3) = DATE_ITIME(1:3)
- IT1(4:7) = DATE_ITIME(5:8)
-
-C GET the namelist specified by FILEIN
- DEB = 'D'
- IF (DEB.EQ.'R') THEN
- CALL GETARG(1,FILEIN) ! load name of input file
- ELSE
- FILEIN = 'H:\AROSSI\DMM\NILE\nile.nml'
-C FILEIN = 'H:\arossi\dmm\tfpf\tfpf_es.nml'
- ENDIF
-
-C CHECK FILEIN
- IF (TRIM(FILEIN).EQ.'') THEN
- TYPE *, ' '
- TYPE *, ' No input file provided'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
-C LOAD input from FILEIN
- ALLOCATE(obs(30000),hyptheta(4,200),hypS(50,50,6),pdftheta(200))
- CALL input(FILEIN,NMLNAME,PATH,
- 1 ny,nz,nx,nu,d,nv,ns,nstot,np,nf,INFOS,
- 2 seed,thin,burnin,GGG,thetasampler,datasim,DLLNAME,check,
- 3 estimation,nt,pdftheta,hyptheta,hypS,nobs,obs,
- 4 Ssampler,HBL,MargLik)
-
-C CHECK DLL NAME AND FIND FILE EXTENSION (.dll or .m)
- J = SCAN(DLLNAME,'\', BACK = .TRUE.)
- I = SCAN(DLLNAME,'.', BACK = .TRUE.)
- DLLEXT = DLLNAME(I+1:I+3)
- IF ((DLLEXT.EQ.'M ').OR.(DLLEXT.EQ.'m ')) THEN
- mfile = DLLNAME(J+1:I-1)
- pathmfile = DLLNAME(1:J-1)
- DLLNAME = 'H:\arossi\dmm64\matlabdll\debug\matlabdll.dll' ! provvisorio
- IND = GETCWD(CURDIR) ! current directory
-C DLLNAME = TRIM(CURDIR) // '\matlabdll.dll' ! definitivo
- ENDIF
-
-C FIND the DLL and LOAD it into the memory
- pdll = loadlibrary(DLLNAME)
- IF (pdll.EQ.0) THEN
- TYPE *, ' '
- TYPE *, TRIM(DLLNAME) // ' cannot be found or opened'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
-C SET UP the pointer to the DLL function
- pdesign = getprocaddress(pdll, "design_"C)
- IF (pdesign.EQ.0) THEN
- TYPE *, ' '
- TYPE *, ' Sub DESIGN cannot be found into '// DLLNAME
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
-C CHECK the MatLab file if needed
- IF ((DLLEXT.EQ.'M ').OR.(DLLEXT.EQ.'m ')) THEN
-C SET UP the pointer to the DLL function
- psetfilem = getprocaddress(pdll, "setfilem_"C)
- IF (psetfilem.EQ.0) THEN
- TYPE *, ' '
- TYPE *, ' Sub SETFILEM cannot be found into '// DLLNAME
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
-C SET UP the pointer to the DLL function
- pgeterrstr = getprocaddress(pdll, "geterrstr_"C)
- IF (pgeterrstr.EQ.0) THEN
- TYPE *, ' '
- TYPE *, ' Sub GETERRSTR cannot be found into '// DLLNAME
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
-
-C Assign the name of the matlab file
- ALLOCATE( c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),
- 1 theta(nt))
- CALL SETFILEM(mfile,pathmfile) ! ONLY THE FIRST TIME
- theta(:) = 1.D0
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- DEALLOCATE(c,H,G,a,F,R,theta)
- IF (ny.EQ.0) THEN
- TYPE *, ' '
- TYPE *, ' Can''t start MATLAB engine'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-1) THEN
- TYPE *, ' '
- TYPE *, ' Can''t read ny in the MATLAB file'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-2) THEN
- TYPE *, ' '
- TYPE *, ' Can''t read nz in the MATLAB file'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-3) THEN
- TYPE *, ' '
- TYPE *, ' Can''t read nx in the MATLAB file'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-4) THEN
- TYPE *, ' '
- TYPE *, ' Can''t read nu in the MATLAB file'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-5) THEN
- TYPE *, ' '
- TYPE *, ' Can''t read ns in the MATLAB file'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-6) THEN
- TYPE *, ' '
- TYPE *, ' Can''t read nt in the MATLAB file'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-7) THEN
- TYPE *, ' '
- TYPE *, ' Can''t find or open the MatLab function'
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.EQ.-8) THEN
- CALL GETERRSTR(matlaberror)
- TYPE *, ' '
- TYPE *, ' the MATLAB funtion can not be executed:'
- TYPE *, trim(matlaberror)
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ELSEIF (ny.LT.-100) THEN
- TYPE *, ' '
- TYPE *, ' One of the output canot be assigned during the call '
- TYPE *, ' ' // trim(DLLNAME)
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- ENDIF
- ENDIF
-
-C SET SHELL title
- DMMTITLE = 'title DMM input:' // TRIM(PATH) // TRIM(NMLNAME)
- # // '.nml' // ' - ' // TRIM(DLLNAME)
- CALL system(DMMTITLE)
-
-C INITIALISE THE RANDOM NUMBER GENERATOR
- CALL INITRAND(SEED,DATE_ITIME)
-
-C ASSIGN DATA and MISSING VALUES
- ALLOCATE(yk(nobs+nf,ny+nz),IYK(nobs,ny+1))
- K = 0
- DO 10 I = 1,nobs+nf
- DO 10 J = 1,ny+nz
- K = K+1
-10 yk(I,J) = obs(K)
-
- IYK(:,:) = 0
- INDMIS = 1
- DO 11 I = 1,nobs
- K = 0
- DO 11 J = 1,ny
- IF(yk(I,J).NE.-99999.D0) THEN
- K = K+1
- IYK(I,K) = J
- ELSE
- DO JJJ=1,nz
- IF (yk(I,ny+JJJ).EQ.-99999.D0)indmis=0
- END DO
- ENDIF
-11 IYK(I,ny+1) = K
- nmis = ny*nobs-SUM(IYK(1:nobs,ny+1))
- DEALLOCATE(obs)
-
-C Allocate and Assign S
- ALLOCATE(S(nobs,6),Z(nobs))
- S(1:nobs,1:6) = 1
-
-C ASSIGN THETA-PRIORS
- ALLOCATE(thetaprior(nt,4))
- DO 30 I = 1,nt
-30 thetaprior(I,1:4) = hyptheta(1:4,I)
- DEALLOCATE(hyptheta)
-
-C ASSIGN PSI hyperparameters (# ind. Dirichelet x max # hyp)
- IF (nv.GT.0) THEN
- ALLOCATE(psiprior(np(2),np(3)))
- K = 0
- DO I = 1,nv
- IF (INFOS(9,I).EQ.1) THEN ! S~iid
- psiprior(K+1,1:INFOS(8,I)) = hypS(1:INFOS(8,I),1,I)
- K = K+1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- DO J = 1,INFOS(8,I)
- psiprior(K+J,1:INFOS(8,I)) = hypS(1:INFOS(8,I),J,I)
- ENDDO
- K = K+INFOS(8,I)
- ENDIF
- END DO
- ENDIF
- DEALLOCATE(hypS)
-
-C THETA STARTING VALUES & TRACK FREE PARAMETERS
- ALLOCATE(theta0(nt),theta(nt),INDT(nt+2))
- CALL SIMPRIOR(estimation,nt,thetaprior,pdftheta(1:nt),ntf,INDT,
- 1 theta0)
- theta(1:nt) = theta0(1:nt)
-
-C PSI STARTING VALUES
- IF (nv.GT.0) THEN
- ALLOCATE(psi0(np(1)),psi(np(1)),ZW(2*nobs))
- ENDIF
- K = 0
- DO 80 J=1,nv
- IF (INFOS(9,J).EQ.1) THEN ! S-IID
- DO jjj = 1,INFOS(8,J)-1
- psi0(K+jjj) = genbet(1.D0,1.D0)
- ENDDO
- AUX = genbet(1.D0,1.D0)
-c CALL G05FEF(1.D0,1.D0,INFOS(8,J)-1,psi0(K+1:K+INFOS(8,J)-1),
-c 1 IFAIL) ! beta
-c CALL G05FEF(1.D0,1.D0,1,AUX,IFAIL)
-
- psi0(K+1:K+INFOS(8,J)-1) = psi0(K+1:K+INFOS(8,J)-1)/
- # (SUM(psi0(K+1:K+INFOS(8,J)-1))+AUX)
- K = K + INFOS(8,J)-1
- ELSE IF (INFOS(9,J).EQ.2) THEN ! S-MARKOV
- DO I = 1,INFOS(8,J)
-c CALL G05FEF(1.D0,1.D0,INFOS(8,J)-1,psi0(K+1:K+INFOS(8,J)-1),
-c 1 IFAIL)
-c CALL G05FEF(1.D0,1.D0,1,AUX,IFAIL)
- DO jjj = 1,INFOS(8,J)-1
- psi0(K+jjj) = genbet(1.D0,1.D0)
- ENDDO
- AUX = genbet(1.D0,1.D0)
- psi0(K+1:K+INFOS(8,J)-1) = psi0(K+1:K+INFOS(8,J)-1)/
- # (SUM(psi0(K+1:K+INFOS(8,J)-1))+AUX)
- K = K + INFOS(8,J)-1
- ENDDO
-80 ENDIF
-
-C WRITE HYPERPARAMTERS for THETA and PSI plus DATA
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.PRI'
- OPEN(10,FILE = FILEOUT, ACCESS='SEQUENTIAL')
- WRITE(10,'(<11+nv>(I6))') nt,np(1:3),nf,nz,seed,nx,ny,nobs,
- 1 nv,INFOS(8,1:nv)
- WRITE(10,'(A2)') estimation
- DO I =1,nt
- WRITE(10,1111) thetaprior(I,1:4),pdftheta(I)
- END DO
- K = 0
- DO I = 1,nv
- IF (INFOS(9,I).EQ.1) THEN
- WRITE(10,1112) INFOS(8,I),psiprior(K+1,:),INFOS(9,I)
- K = K+1
- ELSEIF (INFOS(9,I).EQ.2) THEN
- DO J = 1,INFOS(8,I)
- WRITE(10,1112) INFOS(8,I),psiprior(K+1,:),INFOS(9,I)
- K = K + 1
- END DO
- ENDIF
- END DO
- DO I =1,nobs+nf
- WRITE(10,'(<ny+nz>(F20.10))') yk(I,1:ny+nz)
- END DO
- CLOSE(10)
-
- ALLOCATE(STATE(nobs,nx),NEVAL(nt),CUMN(nt))
-
-C CHECK DESIGN.dll
- IF ((check.EQ.'Y').OR.(check.EQ.'y')) THEN
- CALL CHECKDESIGN(ny,nz,nx,nu,ns,nt,d,theta0,pdll,PATH,NMLNAME)
- GOTO 7777
- ENDIF
-
-C SIMULATION of DATA and UNOBSERVABLES
- IF ((datasim.EQ.'Y').OR.(datasim.EQ.'y')) THEN
- CALL OPENFILES(ESTIMATION,SEED,NV,0,0,datasim,MARGLIK,
- 1 PATH,NMLNAME)
- CALL SIMDATA(nobs,d,ny,nz,nx,nu,ns,nstot,nt,nv,np,INFOS,pdll,
- 2 theta0,psi0,Z,STATE,yk)
- IF (nv.EQ.0) THEN
- WRITE(9,'((F25.15))') theta0(1:nt)
- ELSE
- WRITE(9,'((F25.15))') theta0(1:nt),psi0(1:np(1))
- WRITE(11,'(<1>(I3))') Z(:)
- ENDIF
- WRITE(10,'(<nx>(F20.10))') (STATE(I,1:nx),I=1,nobs)
- WRITE(15,'(<ny>(F20.10))') (yk(I,1:ny),I=1,nobs)
- CLOSE(9)
- CLOSE(10)
- CLOSE(11)
- CLOSE(15)
- GOTO 7777
- ENDIF
-
-C MAXIMUM LIKELIHOOD ESTIMATION
- IF ((estimation.EQ.'ML').OR.(estimation.EQ.'ml').OR.
- & (estimation.EQ.'Ml').OR.(estimation.EQ.'mL')) THEN
- TYPE *, ' '
- TYPE *, ' Maximum Likelihood inference not allowed '
- TYPE *, ' Program aborting'
- PAUSE
- STOP
- CALL OPENFILES(estimation,seed,nv,nf,0,datasim,marglik,
- 1 path,nmlname)
- ALLOCATE(HESS((nt+np(1))*(nt+np(1)+1)/2))
-c CALL ML(nobs,d,ny,nz,nx,nu,nt,nv,ns,np(1),INFOS,pdll,INDT,yk,IYK,S,
-c 1 thetaprior,theta0,psi0,IMSVAR,HESS,AUX)
- ALLOCATE(THETASE(nt),AKMSE(nobs,nx),INN(nobs,ny))
- IF (nv.EQ.0) THEN
- CALL OPG(nobs,d,ny,nz,nx,nu,nt,ns,pdll,yk,IYK,S,
- 1 theta0,thetaprior,HESS,thetase,STATE,AKMSE,INN,IFAIL)
- WRITE(9,'(<2>(F25.15))') (theta0(I),thetase(I),I=1,nt)
- WRITE(9,'(<2>(F25.15))') AUX,IFAIL
- WRITE(10,'(<nx>(F20.10))') (STATE(I,1:nx),I=1,nobs)
- WRITE(10,'(<nx>(F20.10))') (AKMSE(I,1:nx),I=1,nobs)
- WRITE(12,'(<ny>(F20.10))') (INN(I,1:ny),I=1,nobs)
- ELSE
- ALLOCATE(psise(np(1)),SSMOOTH(nobs,nstot))
- IF(IMSVAR.EQ.1)THEN
- CALL OPGH(nobs,ny,nz,nx,nu,nt,nv,ns,nstot,np(1),pdll,yk,IYK,
- 1 INFOS,theta0,psi0,thetaprior,HESS,thetase,psise,
- 1 SSMOOTH,INN,IFAIL)
- ELSE
- CALL OPGKIM(nobs,d,ny,nz,nx,nu,nt,nv,ns,nstot,np(1),pdll,
- 1 yk,IYK,INFOS,theta0,psi0,thetaprior,HESS,
- 1 thetase,psise,STATE,AKMSE,SSMOOTH,INN,IFAIL)
- WRITE(10,'(<nx>(F20.10))') (STATE(I,1:nx),I=1,nobs)
- WRITE(10,'(<nx>(F20.10))') (AKMSE(I,1:nx),I=1,nobs)
- ENDIF
- WRITE(9,'(<2>(F25.15))') (theta0(I),thetase(I),I=1,nt)
- WRITE(9,'(<2>(F25.15))') (psi0(I),psise(I),I=1,np(1))
- WRITE(9,'(<2>(F25.15))') AUX,IFAIL
- WRITE(11,'(<nstot>(F20.10))') (SSMOOTH(I,1:nstot),I=1,nobs)
- WRITE(12,'(<ny>(F20.10))') (INN(I,1:ny),I=1,nobs)
- CLOSE(11)
- DEALLOCATE(PSISE,SSMOOTH,HESS)
- ENDIF
- CLOSE(9)
- CLOSE(10)
- CLOSE(12)
- DEALLOCATE(THETASE,AKMSE,INN)
- GOTO 7777
- ENDIF
-
-C MCMC BURN-IN
- IF ((nv.GT.0).AND.(HBL.GT.1)) THEN
- ALLOCATE(PTR(nobs,nstot,nstot),PM(nobs,nstot),ACCRATE(nobs))
- PM(:,:) = 1.D0/DFLOAT(nstot)
- PTR(:,:,:) = 1.D0/DFLOAT(nstot)
- ACCRATE(:) = 0
- ENDIF
- CUMN(1:nt) = 0
- NEVAL(1:nt)= 0
- IND = 100
- Z(:) = 1
- ZW(:) = 1
- L1 = 0
- IF (nmis.GT.0) THEN ! MISSINGS
- DO jjj = 1,burnin
- IF (nv.GT.0) THEN
- CALL GCK(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
- 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,psi0,
- 2 INFOS,pdll,Z,S)
- IF (HBL.GT.1) THEN
- CALL RECPR(jjj,nstot,nobs,Z,ZW,PM,PTR)
- ENDIF
- CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
- ENDIF
- DO it = 1,nt
- IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
- CALL SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,
- 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,
- 2 thetaprior(it,:),pdftheta(it),pdll,
- 3 NEVAL(it),theta(it))
- theta0(it) = theta(it)
- ENDIF
- END DO
- CUMN = CUMN + NEVAL
- IF (jjj/IND*IND.EQ.jjj) THEN
- IMIN = MINLOC(CUMN(INDT(1:ntf)))
- IMIN(1) = CUMN(INDT(IMIN(1))) !CUMN(IMIN(1))
- IMAX = MAXLOC(CUMN(INDT(1:ntf)))
- IMAX(1) = CUMN(INDT(IMAX(1))) !CUMN(IMAX(1))
- CALL system('cls')
- WRITE(6,1113) jjj,ntf,IMIN(1)/dfloat(jjj),
- # IMAX(1)/dfloat(jjj)
- ENDIF
- ENDDO
- ELSE ! NO MISSING
- DO jjj = 1,burnin
- IF (nv.GT.0) THEN
- CALL GCK2(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
- 1 yk(1:nobs,:),theta0,psi0,INFOS,pdll,Z,S)
- IF (HBL.GT.1) THEN
- CALL RECPR(jjj,nstot,nobs,Z,ZW,PM,PTR)
- ENDIF
- CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
- ENDIF
- DO it = 1,nt
- IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
- CALL SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk(1:nobs,:),
- 1 theta0,thetaprior(it,:),pdftheta(it),pdll,
- 2 NEVAL(it),theta(it))
- theta0(it) = theta(it)
- ENDIF
- END DO
- CUMN = CUMN + NEVAL
- IF (jjj/IND*IND.EQ.jjj) THEN
- IMIN = MINLOC(CUMN(INDT(1:ntf)))
- IMIN(1) = CUMN(INDT(IMIN(1))) !CUMN(IMIN(1))
- IMAX = MAXLOC(CUMN(INDT(1:ntf)))
- IMAX(1) = CUMN(INDT(IMAX(1))) !CUMN(IMAX(1))
- CALL system('cls')
- WRITE(6,1113) jjj,ntf,IMIN(1)/dfloat(jjj),
- # IMAX(1)/dfloat(jjj)
- ENDIF
- ENDDO
- ENDIF
- lastl = IMIN(1)/DFLOAT(burnin)
- lasth = IMAX(1)/DFLOAT(burnin)
- CUMN(1:nt) = 0
- NEVAL(:) = 0
-
-C OPEN OUTPUT FILES
-C 9 '.PAR', 10 '.UNB', 11 '.DIS', 12 '.INN', 13 '.FST', 14 '.MIS', 15 '.ML' o '.DAT'
- CALL OPENFILES(estimation,seed,nv,nf,nmis*INDMIS,datasim,Marglik,
- 1 PATH,NMLNAME)
-
-C MCMC RECORDING phase
- ALLOCATE(INN(nobs,ny))
- IF (nf.GT.0) THEN
- ALLOCATE(FORE(nf,ny+nx+1))
- ENDIF
- IF (indmis*NMIS.GE.1) THEN
- ALLOCATE(ykmis(nmis))
- ENDIF
- IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
- ALLOCATE(gibtheta(GGG,nt+np(1)),gibZ(GGG,nobs),MLHM(11,2),
- 1 MLMW(2,2))
- ENDIF
- IF (nmis.GT.0) THEN ! MISSINGS
- DO jjj = 1,GGG*thin
- IF (nv.GT.0) THEN
- IF (HBL.EQ.1) THEN
- CALL GCK(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
- 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,psi0,
- 2 INFOS,pdll,Z,S)
- ELSE
- CALL AMH(HBL,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
- 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,psi0,
- 2 PTR,PM,INFOS,pdll,Z,S,ACCRATE)
- CALL RECPR(jjj+burnin,nstot,nobs,Z,ZW,PM,PTR)
- ENDIF
- CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
- ENDIF
- DO it = 1,nt
- IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
- CALL SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk(1:nobs,:),
- 1 IYK(1:nobs,:),theta0,thetaprior(it,:),
- 2 pdftheta(it),pdll,NEVAL(it),theta(it))
- theta0(it) = theta(it)
- ENDIF
- END DO
- CUMN = CUMN+NEVAL
- CALL SIMSTATE(nobs,d,ny,nz,nx,nu,ns,nt,yk(1:nobs,:),
- 1 IYK(1:nobs,:),theta,S,pdll,STATE)
- CALL INNOV(nobs,d,ny,nz,nx,nu,ns,nt,S,
- 1 yk(1:nobs,:),IYK(1:nobs,:),theta,pdll,INN)
- IF (nf.GT.0) THEN
- CALL FORECAST(yk(nobs+1:nobs+nf,ny+1:ny+nz),nf,ny,nz,nx,nu,nv,
- 1 ns,nstot,nt,np,theta,psi,INFOS,Z(nobs),
- 2 STATE(nobs,:),pdll,FORE)
- ENDIF
- IF (INDMIS*nmis.GE.1) THEN
- J = 1
- DO I = 1,nobs
- IF (IYK(I,ny+1).LT.ny) THEN
- K = ny-IYK(I,ny+1)
- CALL MISSING(yk(I,:),ny,nz,nx,nu,ns,nt,K,theta,
- 1 S(I,1:6),STATE(I,:),pdll,ykmis(J:J+K-1))
- J = J+K
- ENDIF
- ENDDO
- ENDIF
- IF (jjj/IND*IND.EQ.jjj) THEN
- IMIN = MINLOC(CUMN(INDT(L1+1:ntf)))
- IMIN(1) = CUMN(INDT(L1+IMIN(1)))
- IMAX = MAXLOC(CUMN(INDT(L1+1:ntf)))
- IMAX(1) = CUMN(INDT(L1+IMAX(1)))
- CALL system('cls')
- WRITE(6,1113) BURNIN,ntf,lastl,lasth
- IF ((HBL.EQ.1).OR.(nv.EQ.0)) THEN
- WRITE(6,1114) jjj,ntf,IMIN(1)/dfloat(jjj),
- # IMAX(1)/dfloat(jjj)
- ELSEIF ((HBL.GT.1).AND.(nv.GT.0)) THEN
- WRITE(6,1115) jjj,ntf,IMIN(1)/dfloat(jjj),
- # IMAX(1)/dfloat(jjj),
- # SUM(1.D0-ACCRATE(1:nobs)/DFLOAT(jjj))/DFLOAT(nobs)
- ENDIF
- ENDIF
- IF (jjj/thin*thin.EQ.jjj) THEN
- WRITE(12,'(<nobs*ny>(F20.10))') (INN(1:nobs,I),I=1,ny)
- WRITE(10,'(<nobs*nx>(F20.10))') (STATE(1:nobs,I),I=1,nx)
- IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
- gibtheta(jjj/thin,1:nt) = theta(1:nt)
- ENDIF
- IF (nv.EQ.0) THEN
- WRITE(9,'(<nt>(F25.15))') theta(1:nt)
- ELSE
- IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
- gibtheta(jjj/thin,nt+1:nt+np(1)) = psi(1:np(1))
- gibZ(jjj/thin,1:nobs) = Z(1:nobs)
- ENDIF
- WRITE(9,'(<nt+np(1)>(F25.15))') theta(1:nt),psi(1:np(1))
- WRITE(11,'(<nobs>(I3))') Z(:)
- ENDIF
- IF (nf.GT.0) THEN
- J = min(nv,1)
- WRITE(13,'(<nf*(nx+ny+J)>(F20.10))') (FORE(1:nf,I),I=1,nx+ny+J)
- ENDIF
- IF (INDMIS*nmis.GE.1) WRITE(14,'(<nmis>(F20.10))') ykmis(1:nmis)
- ENDIF
- ENDDO
- ELSE ! NO MISSINGS
- DO jjj = 1,GGG*thin
- IF (nv.GT.0) THEN
- IF (HBL.EQ.1) THEN
- CALL GCK2(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
- 1 yk(1:nobs,:),theta0,psi0,INFOS,pdll,Z,S)
- ELSE
- CALL AMH2(hbl,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
- 1 yk(1:nobs,:),theta0,psi0,
- 2 PTR,PM,INFOS,pdll,Z,S,ACCRATE)
- CALL RECPR(jjj+burnin,nstot,nobs,Z,ZW,PM,PTR)
- ENDIF
- CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
- ENDIF
- DO it = 1,nt
- IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
- CALL SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk(1:nobs,:),
- 1 theta0,thetaprior(it,:),pdftheta(it),pdll,
- 2 NEVAL(it),theta(it))
- theta0(it) = theta(it)
- ENDIF
- END DO
- CUMN = CUMN+NEVAL
- CALL SIMSTATE2(nobs,d,ny,nz,nx,nu,ns,nt,yk(1:nobs,:),
- 1 theta,S,pdll,STATE)
- CALL INNOV2(nobs,d,ny,nz,nx,nu,ns,nt,S,
- 1 yk(1:nobs,:),theta,pdll,INN)
- IF (nf.GT.0) THEN
- CALL FORECAST(yk(nobs+1:nobs+nf,ny+1:ny+nz),nf,ny,nz,nx,nu,nv,
- 1 ns,nstot,nt,np,theta,psi,INFOS,Z(nobs),
- 2 STATE(nobs,:),pdll,FORE)
- ENDIF
- IF (jjj/IND*IND.EQ.jjj) THEN
- IMIN = MINLOC(CUMN(INDT(L1+1:ntf)))
- IMIN(1) = CUMN(INDT(L1+IMIN(1)))
- IMAX = MAXLOC(CUMN(INDT(L1+1:ntf)))
- IMAX(1) = CUMN(INDT(L1+IMAX(1)))
- CALL system('cls')
- WRITE(6,1113) BURNIN,ntf,lastl,lasth
- IF ((HBL.EQ.1).OR.(nv.EQ.0)) THEN
- WRITE(6,1114) jjj,ntf,IMIN(1)/dfloat(jjj),
- # IMAX(1)/dfloat(jjj)
- ELSEIF ((HBL.GT.1).AND.(nv.GT.0)) THEN
- WRITE(6,1115) jjj,ntf,IMIN(1)/dfloat(jjj),
- # IMAX(1)/dfloat(jjj),
- # SUM(1.D0-ACCRATE(1:nobs)/DFLOAT(jjj))/DFLOAT(nobs)
- ENDIF
- ENDIF
- IF (jjj/thin*thin.EQ.jjj) THEN
- IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
- gibtheta(jjj/thin,1:nt) = theta(1:nt)
- ENDIF
- WRITE(12,'(<nobs*ny>(F20.10))') (INN(1:nobs,I),I=1,ny)
- WRITE(10,'(<nobs*nx>(F20.10))') (STATE(1:nobs,I),I=1,nx)
- IF (nv.EQ.0) THEN
- WRITE(9,'(<nt>(F25.15))') theta(1:nt)
- ELSE
- IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
- gibtheta(jjj/thin,nt+1:nt+np(1)) = psi(1:np(1))
- gibZ(jjj/thin,1:nobs) = Z(1:nobs)
- ENDIF
- WRITE(9,'(<nt+np(1)>(F25.15))') theta(1:nt),psi(1:np(1))
- WRITE(11,'(<nobs>(I3))') Z(:)
- ENDIF
- IF (nf.GT.0) THEN
- J = min(nv,1)
- WRITE(13,'(<nf*(nx+ny+J)>(F20.10))') (FORE(1:nf,I),I=1,nx+ny+J)
- ENDIF
- ENDIF
- ENDDO
- ENDIF
- CLOSE(9)
- CLOSE(10)
- IF (nv.GT.0) CLOSE(11)
- CLOSE(12)
- IF (nf.GT.0) CLOSE(13)
- IF (indmis*nmis.GE.1) THEN
- CLOSE(14)
- DEALLOCATE(ykmis)
- ENDIF
- DEALLOCATE(INN)
- IF ((nv.GT.0).AND.(HBL.GT.1)) THEN
- DEALLOCATE(PTR,PM,ACCRATE)
- ENDIF
-
-C MARGINAL LIKELIHOOD
- IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
- WRITE(*,*) ' '
- WRITE(*,*) 'Computing the marginal likelihood. Please wait ...'
- IF (nmis.GT.0) THEN
- CALL HARMONIC(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk(1:nobs,:),IYK(1:nobs,:),gibtheta,gibZ,
- 2 thetaprior,psiprior,pdftheta,pdll,MLHM)
- WRITE(*,*) 'Modified harmonic mean: done!'
- CALL MENGWONG(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk(1:nobs,:),IYK(1:nobs,:),gibtheta,gibZ,
- 2 thetaprior,psiprior,pdftheta,pdll,MLHM(5,1),MLMW)
- WRITE(*,*) 'Bridge sampling: done!'
- WRITE(*,*) ' '
- ELSE
- CALL HARMONIC2(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk(1:nobs,:),gibtheta,gibZ,thetaprior,
- 2 psiprior,pdftheta,pdll,MLHM)
- WRITE(*,*) 'Modified harmonic mean: done!'
- CALL MENGWONG2(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk(1:nobs,:),gibtheta,gibZ,thetaprior,
- 2 psiprior,pdftheta,pdll,MLHM(5,1),MLMW)
- WRITE(*,*) 'Bridge sampling: done!'
- WRITE(*,*) ' '
- ENDIF
- WRITE(15,*) 'Modified Harmonic mean (ML and Var)'
- WRITE(15,'(<2>(F20.10))') (MLHM(I,:),I=1,11)
- WRITE(15,*) 'Bridge Sampling'
- WRITE(15,'(<2>(F20.10))') (MLMW(I,:),I=1,2)
- CLOSE(15)
- DEALLOCATE(gibtheta,gibZ,MLHM,MLMW)
- ENDIF
-
-7777 DEALLOCATE(yk,STATE,Z,S,theta0,theta,thetaprior,pdftheta,NEVAL,
- 1 CUMN,IYK,INDT)
- IF (nv.GT.0) THEN
- DEALLOCATE(psi0,psi,psiprior,ZW)
- ENDIF
-
- STATUS = freelibrary(pdll) !libero la DLL dalla memoria alla fine del programma
- IF (TRIM(PATH).EQ.'') THEN
- STATUS = getcwd(PATH) ! get current directory
- ENDIF
-
- CALL DATE_AND_TIME(REAL_CLOCK(1),REAL_CLOCK(2),REAL_CLOCK(3),
- 1 DATE_ITIME)
- IT2(1:3) = DATE_ITIME(1:3)
- IT2(4:7) = DATE_ITIME(5:8)
- IT=(IT2(4)-IT1(4))*3600+(IT2(5)-IT1(5))*60+(IT2(6)-IT1(6))
- IF ((check.EQ.'Y').OR.(check.EQ.'y')) THEN
- WRITE(6,1117) TRIM(PATH)
- ELSE
- IF ((datasim.EQ.'Y').OR.(datasim.EQ.'y')) THEN
- WRITE(6,1118) TRIM(PATH)
- ELSE
- IF ((estimation.EQ.'ML').OR.(estimation.EQ.'ml').OR.
- & (estimation.EQ.'Ml').OR.(estimation.EQ.'mL')) THEN
- WRITE(6,1119) IT,TRIM(PATH)
- ELSE
- WRITE(6,1116) IT,TRIM(PATH)
- ENDIF
- ENDIF
- ENDIF
- DEALLOCATE(np,ns,INFOS,IT1,IT2,DATE_ITIME,REAL_CLOCK)
-
-1111 FORMAT((<4>(F25.12)), ' ',A2)
-1112 FORMAT(I10,(<np(3)>(F25.12)), ' ',I2)
-1113 FORMAT(/,' Burn-in draws = ',I8,
- # /,' Parameters sampled by SLICE ',I5,
- # /,' SLICE likelihood eval. Min/Max = ',F6.2, ' / ',F6.2)
-1114 FORMAT(/,' Recording draws = ',I8,
- # /,' Parameters sampled by SLICE ',I5,
- # /,' SLICE likelihood eval. Min/Max = ',F6.2, ' / ',F6.2)
-1115 FORMAT(/,' Recording draws = ',I8,
- # /,' Parameters sampled by SLICE ',I5,
- # /,' SLICE likelihood eval. Min/Max = ',F6.2, ' / ',F6.2,
- # /,' Adaptive MH accettance rate = ',F6.2)
-1116 FORMAT(/,' MCMC completed',
- # /,' CPU-time (sec)=', I10,
- # /,' Output printed in ',A)
-1117 FORMAT(/,' Check completed',
- # /,' Output printed in ',A)
-1118 FORMAT(/,' Data simulation completed',
- # /,' Output printed in 'A)
-1119 FORMAT(/,' Maximum Likelihood completed',
- # /,' CPU-time (sec)=', I10,
- # /,' Output printed in ',A)
-
- PAUSE
- STOP
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------------------
+ PROGRAM DMM
+ USE dfwin
+C DECLARE an "interface block" to the .DLL that contains DESIGN
+
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN)
+C DECLARE an "interface block" to the .DLL that contains SETFILEM
+ INTERFACE
+ SUBROUTINE SETFILEM(mfile,pathmfile)
+ CHARACTER*200 mfile,pathmfile
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (psetfilem,SETFILEM)
+C DECLARE an "interface block" to the .DLL that contains GETERRSTR
+ INTERFACE
+ SUBROUTINE GETERRSTR(matlaberror)
+ CHARACTER*1024 matlaberror
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pgeterrstr,GETERRSTR)
+
+ LOGICAL status
+ CHARACTER*200 DLLNAME ! name of the DLL (defined by the user)
+
+C NAMELIST DECLARATIONS
+ INTEGER ny,nz,nx,nu,d(2),nv,nt,nf,nobs
+ INTEGER seed,thin,burnin,GGG,HBL
+ CHARACTER*1 MargLik,datasim,check
+ CHARACTER*2 thetasampler,estimation
+ CHARACTER*3 Ssampler
+ DOUBLE PRECISION, ALLOCATABLE:: hypS(:,:,:),hyptheta(:,:),
+ 1 obs(:)
+ CHARACTER(2), ALLOCATABLE:: pdftheta(:)
+C LOCALS
+ INTEGER, ALLOCATABLE:: Z(:),ZW(:),S(:,:),NEVAL(:),
+ 1 CUMN(:),IYK(:,:),INDT(:),ACCRATE(:),gibZ(:,:),
+ 1 IT1(:),IT2(:),DATE_ITIME(:),np(:),ns(:),INFOS(:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: yk(:,:),STATE(:,:),theta(:),
+ 1 theta0(:),thetaprior(:,:),psi(:),psi0(:),psiprior(:,:),
+ 2 INN(:,:),FORE(:,:),ykmis(:),PTR(:,:,:),PM(:,:),
+ 3 gibtheta(:,:),MLHM(:,:),MLMW(:,:),thetase(:),AKMSE(:,:),HESS(:),
+ 4 psise(:),SSMOOTH(:,:)
+ DOUBLE PRECISION,ALLOCATABLE::c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:),R(:,:,:)
+ CHARACTER(12), ALLOCATABLE:: REAL_CLOCK(:)
+ INTEGER ntf,nstot,nmis,indmis,IT,I,J,K,L1,jjj,IND,IFAIL,IMAX(1),
+ 1 IMIN(1),IMSVAR
+ DOUBLE PRECISION AUX,lastl,lasth
+ CHARACTER*1 DEB
+ CHARACTER*3 DLLEXT
+ CHARACTER*200 mfile,pathmfile
+ CHARACTER*200 FILEIN,NMLNAME,PATH,FILEOUT,DMMTITLE,CURDIR
+ CHARACTER*1024 matlaberror
+
+C EXTERNAL SUBROUTINES
+ EXTERNAL GETARG
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION genbet
+
+C TIME
+ ALLOCATE(np(3),ns(6),INFOS(9,6),IT1(7),IT2(7),DATE_ITIME(8),
+ 1 REAL_CLOCK(3))
+ CALL DATE_AND_TIME(REAL_CLOCK(1),REAL_CLOCK(2),REAL_CLOCK(3),
+ 1 DATE_ITIME)
+ IT1(1:3) = DATE_ITIME(1:3)
+ IT1(4:7) = DATE_ITIME(5:8)
+
+C GET the namelist specified by FILEIN
+ DEB = 'D'
+ IF (DEB.EQ.'R') THEN
+ CALL GETARG(1,FILEIN) ! load name of input file
+ ELSE
+ FILEIN = 'H:\AROSSI\DMM\NILE\nile.nml'
+C FILEIN = 'H:\arossi\dmm\tfpf\tfpf_es.nml'
+ ENDIF
+
+C CHECK FILEIN
+ IF (TRIM(FILEIN).EQ.'') THEN
+ TYPE *, ' '
+ TYPE *, ' No input file provided'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+C LOAD input from FILEIN
+ ALLOCATE(obs(30000),hyptheta(4,200),hypS(50,50,6),pdftheta(200))
+ CALL input(FILEIN,NMLNAME,PATH,
+ 1 ny,nz,nx,nu,d,nv,ns,nstot,np,nf,INFOS,
+ 2 seed,thin,burnin,GGG,thetasampler,datasim,DLLNAME,check,
+ 3 estimation,nt,pdftheta,hyptheta,hypS,nobs,obs,
+ 4 Ssampler,HBL,MargLik)
+
+C CHECK DLL NAME AND FIND FILE EXTENSION (.dll or .m)
+ J = SCAN(DLLNAME,'\', BACK = .TRUE.)
+ I = SCAN(DLLNAME,'.', BACK = .TRUE.)
+ DLLEXT = DLLNAME(I+1:I+3)
+ IF ((DLLEXT.EQ.'M ').OR.(DLLEXT.EQ.'m ')) THEN
+ mfile = DLLNAME(J+1:I-1)
+ pathmfile = DLLNAME(1:J-1)
+ DLLNAME = 'H:\arossi\dmm64\matlabdll\debug\matlabdll.dll' ! provvisorio
+ IND = GETCWD(CURDIR) ! current directory
+C DLLNAME = TRIM(CURDIR) // '\matlabdll.dll' ! definitivo
+ ENDIF
+
+C FIND the DLL and LOAD it into the memory
+ pdll = loadlibrary(DLLNAME)
+ IF (pdll.EQ.0) THEN
+ TYPE *, ' '
+ TYPE *, TRIM(DLLNAME) // ' cannot be found or opened'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+C SET UP the pointer to the DLL function
+ pdesign = getprocaddress(pdll, "design_"C)
+ IF (pdesign.EQ.0) THEN
+ TYPE *, ' '
+ TYPE *, ' Sub DESIGN cannot be found into '// DLLNAME
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+C CHECK the MatLab file if needed
+ IF ((DLLEXT.EQ.'M ').OR.(DLLEXT.EQ.'m ')) THEN
+C SET UP the pointer to the DLL function
+ psetfilem = getprocaddress(pdll, "setfilem_"C)
+ IF (psetfilem.EQ.0) THEN
+ TYPE *, ' '
+ TYPE *, ' Sub SETFILEM cannot be found into '// DLLNAME
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+C SET UP the pointer to the DLL function
+ pgeterrstr = getprocaddress(pdll, "geterrstr_"C)
+ IF (pgeterrstr.EQ.0) THEN
+ TYPE *, ' '
+ TYPE *, ' Sub GETERRSTR cannot be found into '// DLLNAME
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+
+C Assign the name of the matlab file
+ ALLOCATE( c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),
+ 1 theta(nt))
+ CALL SETFILEM(mfile,pathmfile) ! ONLY THE FIRST TIME
+ theta(:) = 1.D0
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ DEALLOCATE(c,H,G,a,F,R,theta)
+ IF (ny.EQ.0) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t start MATLAB engine'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-1) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t read ny in the MATLAB file'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-2) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t read nz in the MATLAB file'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-3) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t read nx in the MATLAB file'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-4) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t read nu in the MATLAB file'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-5) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t read ns in the MATLAB file'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-6) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t read nt in the MATLAB file'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-7) THEN
+ TYPE *, ' '
+ TYPE *, ' Can''t find or open the MatLab function'
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.EQ.-8) THEN
+ CALL GETERRSTR(matlaberror)
+ TYPE *, ' '
+ TYPE *, ' the MATLAB funtion can not be executed:'
+ TYPE *, trim(matlaberror)
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ELSEIF (ny.LT.-100) THEN
+ TYPE *, ' '
+ TYPE *, ' One of the output canot be assigned during the call '
+ TYPE *, ' ' // trim(DLLNAME)
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ ENDIF
+ ENDIF
+
+C SET SHELL title
+ DMMTITLE = 'title DMM input:' // TRIM(PATH) // TRIM(NMLNAME)
+ # // '.nml' // ' - ' // TRIM(DLLNAME)
+ CALL system(DMMTITLE)
+
+C INITIALISE THE RANDOM NUMBER GENERATOR
+ CALL INITRAND(SEED,DATE_ITIME)
+
+C ASSIGN DATA and MISSING VALUES
+ ALLOCATE(yk(nobs+nf,ny+nz),IYK(nobs,ny+1))
+ K = 0
+ DO 10 I = 1,nobs+nf
+ DO 10 J = 1,ny+nz
+ K = K+1
+10 yk(I,J) = obs(K)
+
+ IYK(:,:) = 0
+ INDMIS = 1
+ DO 11 I = 1,nobs
+ K = 0
+ DO 11 J = 1,ny
+ IF(yk(I,J).NE.-99999.D0) THEN
+ K = K+1
+ IYK(I,K) = J
+ ELSE
+ DO JJJ=1,nz
+ IF (yk(I,ny+JJJ).EQ.-99999.D0)indmis=0
+ END DO
+ ENDIF
+11 IYK(I,ny+1) = K
+ nmis = ny*nobs-SUM(IYK(1:nobs,ny+1))
+ DEALLOCATE(obs)
+
+C Allocate and Assign S
+ ALLOCATE(S(nobs,6),Z(nobs))
+ S(1:nobs,1:6) = 1
+
+C ASSIGN THETA-PRIORS
+ ALLOCATE(thetaprior(nt,4))
+ DO 30 I = 1,nt
+30 thetaprior(I,1:4) = hyptheta(1:4,I)
+ DEALLOCATE(hyptheta)
+
+C ASSIGN PSI hyperparameters (# ind. Dirichelet x max # hyp)
+ IF (nv.GT.0) THEN
+ ALLOCATE(psiprior(np(2),np(3)))
+ K = 0
+ DO I = 1,nv
+ IF (INFOS(9,I).EQ.1) THEN ! S~iid
+ psiprior(K+1,1:INFOS(8,I)) = hypS(1:INFOS(8,I),1,I)
+ K = K+1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ DO J = 1,INFOS(8,I)
+ psiprior(K+J,1:INFOS(8,I)) = hypS(1:INFOS(8,I),J,I)
+ ENDDO
+ K = K+INFOS(8,I)
+ ENDIF
+ END DO
+ ENDIF
+ DEALLOCATE(hypS)
+
+C THETA STARTING VALUES & TRACK FREE PARAMETERS
+ ALLOCATE(theta0(nt),theta(nt),INDT(nt+2))
+ CALL SIMPRIOR(estimation,nt,thetaprior,pdftheta(1:nt),ntf,INDT,
+ 1 theta0)
+ theta(1:nt) = theta0(1:nt)
+
+C PSI STARTING VALUES
+ IF (nv.GT.0) THEN
+ ALLOCATE(psi0(np(1)),psi(np(1)),ZW(2*nobs))
+ ENDIF
+ K = 0
+ DO 80 J=1,nv
+ IF (INFOS(9,J).EQ.1) THEN ! S-IID
+ DO jjj = 1,INFOS(8,J)-1
+ psi0(K+jjj) = genbet(1.D0,1.D0)
+ ENDDO
+ AUX = genbet(1.D0,1.D0)
+c CALL G05FEF(1.D0,1.D0,INFOS(8,J)-1,psi0(K+1:K+INFOS(8,J)-1),
+c 1 IFAIL) ! beta
+c CALL G05FEF(1.D0,1.D0,1,AUX,IFAIL)
+
+ psi0(K+1:K+INFOS(8,J)-1) = psi0(K+1:K+INFOS(8,J)-1)/
+ # (SUM(psi0(K+1:K+INFOS(8,J)-1))+AUX)
+ K = K + INFOS(8,J)-1
+ ELSE IF (INFOS(9,J).EQ.2) THEN ! S-MARKOV
+ DO I = 1,INFOS(8,J)
+c CALL G05FEF(1.D0,1.D0,INFOS(8,J)-1,psi0(K+1:K+INFOS(8,J)-1),
+c 1 IFAIL)
+c CALL G05FEF(1.D0,1.D0,1,AUX,IFAIL)
+ DO jjj = 1,INFOS(8,J)-1
+ psi0(K+jjj) = genbet(1.D0,1.D0)
+ ENDDO
+ AUX = genbet(1.D0,1.D0)
+ psi0(K+1:K+INFOS(8,J)-1) = psi0(K+1:K+INFOS(8,J)-1)/
+ # (SUM(psi0(K+1:K+INFOS(8,J)-1))+AUX)
+ K = K + INFOS(8,J)-1
+ ENDDO
+80 ENDIF
+
+C WRITE HYPERPARAMTERS for THETA and PSI plus DATA
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.PRI'
+ OPEN(10,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+ WRITE(10,'(<11+nv>(I6))') nt,np(1:3),nf,nz,seed,nx,ny,nobs,
+ 1 nv,INFOS(8,1:nv)
+ WRITE(10,'(A2)') estimation
+ DO I =1,nt
+ WRITE(10,1111) thetaprior(I,1:4),pdftheta(I)
+ END DO
+ K = 0
+ DO I = 1,nv
+ IF (INFOS(9,I).EQ.1) THEN
+ WRITE(10,1112) INFOS(8,I),psiprior(K+1,:),INFOS(9,I)
+ K = K+1
+ ELSEIF (INFOS(9,I).EQ.2) THEN
+ DO J = 1,INFOS(8,I)
+ WRITE(10,1112) INFOS(8,I),psiprior(K+1,:),INFOS(9,I)
+ K = K + 1
+ END DO
+ ENDIF
+ END DO
+ DO I =1,nobs+nf
+ WRITE(10,'(<ny+nz>(F20.10))') yk(I,1:ny+nz)
+ END DO
+ CLOSE(10)
+
+ ALLOCATE(STATE(nobs,nx),NEVAL(nt),CUMN(nt))
+
+C CHECK DESIGN.dll
+ IF ((check.EQ.'Y').OR.(check.EQ.'y')) THEN
+ CALL CHECKDESIGN(ny,nz,nx,nu,ns,nt,d,theta0,pdll,PATH,NMLNAME)
+ GOTO 7777
+ ENDIF
+
+C SIMULATION of DATA and UNOBSERVABLES
+ IF ((datasim.EQ.'Y').OR.(datasim.EQ.'y')) THEN
+ CALL OPENFILES(ESTIMATION,SEED,NV,0,0,datasim,MARGLIK,
+ 1 PATH,NMLNAME)
+ CALL SIMDATA(nobs,d,ny,nz,nx,nu,ns,nstot,nt,nv,np,INFOS,pdll,
+ 2 theta0,psi0,Z,STATE,yk)
+ IF (nv.EQ.0) THEN
+ WRITE(9,'((F25.15))') theta0(1:nt)
+ ELSE
+ WRITE(9,'((F25.15))') theta0(1:nt),psi0(1:np(1))
+ WRITE(11,'(<1>(I3))') Z(:)
+ ENDIF
+ WRITE(10,'(<nx>(F20.10))') (STATE(I,1:nx),I=1,nobs)
+ WRITE(15,'(<ny>(F20.10))') (yk(I,1:ny),I=1,nobs)
+ CLOSE(9)
+ CLOSE(10)
+ CLOSE(11)
+ CLOSE(15)
+ GOTO 7777
+ ENDIF
+
+C MAXIMUM LIKELIHOOD ESTIMATION
+ IF ((estimation.EQ.'ML').OR.(estimation.EQ.'ml').OR.
+ & (estimation.EQ.'Ml').OR.(estimation.EQ.'mL')) THEN
+ TYPE *, ' '
+ TYPE *, ' Maximum Likelihood inference not allowed '
+ TYPE *, ' Program aborting'
+ PAUSE
+ STOP
+ CALL OPENFILES(estimation,seed,nv,nf,0,datasim,marglik,
+ 1 path,nmlname)
+ ALLOCATE(HESS((nt+np(1))*(nt+np(1)+1)/2))
+c CALL ML(nobs,d,ny,nz,nx,nu,nt,nv,ns,np(1),INFOS,pdll,INDT,yk,IYK,S,
+c 1 thetaprior,theta0,psi0,IMSVAR,HESS,AUX)
+ ALLOCATE(THETASE(nt),AKMSE(nobs,nx),INN(nobs,ny))
+ IF (nv.EQ.0) THEN
+ CALL OPG(nobs,d,ny,nz,nx,nu,nt,ns,pdll,yk,IYK,S,
+ 1 theta0,thetaprior,HESS,thetase,STATE,AKMSE,INN,IFAIL)
+ WRITE(9,'(<2>(F25.15))') (theta0(I),thetase(I),I=1,nt)
+ WRITE(9,'(<2>(F25.15))') AUX,IFAIL
+ WRITE(10,'(<nx>(F20.10))') (STATE(I,1:nx),I=1,nobs)
+ WRITE(10,'(<nx>(F20.10))') (AKMSE(I,1:nx),I=1,nobs)
+ WRITE(12,'(<ny>(F20.10))') (INN(I,1:ny),I=1,nobs)
+ ELSE
+ ALLOCATE(psise(np(1)),SSMOOTH(nobs,nstot))
+ IF(IMSVAR.EQ.1)THEN
+ CALL OPGH(nobs,ny,nz,nx,nu,nt,nv,ns,nstot,np(1),pdll,yk,IYK,
+ 1 INFOS,theta0,psi0,thetaprior,HESS,thetase,psise,
+ 1 SSMOOTH,INN,IFAIL)
+ ELSE
+ CALL OPGKIM(nobs,d,ny,nz,nx,nu,nt,nv,ns,nstot,np(1),pdll,
+ 1 yk,IYK,INFOS,theta0,psi0,thetaprior,HESS,
+ 1 thetase,psise,STATE,AKMSE,SSMOOTH,INN,IFAIL)
+ WRITE(10,'(<nx>(F20.10))') (STATE(I,1:nx),I=1,nobs)
+ WRITE(10,'(<nx>(F20.10))') (AKMSE(I,1:nx),I=1,nobs)
+ ENDIF
+ WRITE(9,'(<2>(F25.15))') (theta0(I),thetase(I),I=1,nt)
+ WRITE(9,'(<2>(F25.15))') (psi0(I),psise(I),I=1,np(1))
+ WRITE(9,'(<2>(F25.15))') AUX,IFAIL
+ WRITE(11,'(<nstot>(F20.10))') (SSMOOTH(I,1:nstot),I=1,nobs)
+ WRITE(12,'(<ny>(F20.10))') (INN(I,1:ny),I=1,nobs)
+ CLOSE(11)
+ DEALLOCATE(PSISE,SSMOOTH,HESS)
+ ENDIF
+ CLOSE(9)
+ CLOSE(10)
+ CLOSE(12)
+ DEALLOCATE(THETASE,AKMSE,INN)
+ GOTO 7777
+ ENDIF
+
+C MCMC BURN-IN
+ IF ((nv.GT.0).AND.(HBL.GT.1)) THEN
+ ALLOCATE(PTR(nobs,nstot,nstot),PM(nobs,nstot),ACCRATE(nobs))
+ PM(:,:) = 1.D0/DFLOAT(nstot)
+ PTR(:,:,:) = 1.D0/DFLOAT(nstot)
+ ACCRATE(:) = 0
+ ENDIF
+ CUMN(1:nt) = 0
+ NEVAL(1:nt)= 0
+ IND = 100
+ Z(:) = 1
+ ZW(:) = 1
+ L1 = 0
+ IF (nmis.GT.0) THEN ! MISSINGS
+ DO jjj = 1,burnin
+ IF (nv.GT.0) THEN
+ CALL GCK(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
+ 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,psi0,
+ 2 INFOS,pdll,Z,S)
+ IF (HBL.GT.1) THEN
+ CALL RECPR(jjj,nstot,nobs,Z,ZW,PM,PTR)
+ ENDIF
+ CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
+ ENDIF
+ DO it = 1,nt
+ IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
+ CALL SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,
+ 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,
+ 2 thetaprior(it,:),pdftheta(it),pdll,
+ 3 NEVAL(it),theta(it))
+ theta0(it) = theta(it)
+ ENDIF
+ END DO
+ CUMN = CUMN + NEVAL
+ IF (jjj/IND*IND.EQ.jjj) THEN
+ IMIN = MINLOC(CUMN(INDT(1:ntf)))
+ IMIN(1) = CUMN(INDT(IMIN(1))) !CUMN(IMIN(1))
+ IMAX = MAXLOC(CUMN(INDT(1:ntf)))
+ IMAX(1) = CUMN(INDT(IMAX(1))) !CUMN(IMAX(1))
+ CALL system('cls')
+ WRITE(6,1113) jjj,ntf,IMIN(1)/dfloat(jjj),
+ # IMAX(1)/dfloat(jjj)
+ ENDIF
+ ENDDO
+ ELSE ! NO MISSING
+ DO jjj = 1,burnin
+ IF (nv.GT.0) THEN
+ CALL GCK2(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
+ 1 yk(1:nobs,:),theta0,psi0,INFOS,pdll,Z,S)
+ IF (HBL.GT.1) THEN
+ CALL RECPR(jjj,nstot,nobs,Z,ZW,PM,PTR)
+ ENDIF
+ CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
+ ENDIF
+ DO it = 1,nt
+ IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
+ CALL SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk(1:nobs,:),
+ 1 theta0,thetaprior(it,:),pdftheta(it),pdll,
+ 2 NEVAL(it),theta(it))
+ theta0(it) = theta(it)
+ ENDIF
+ END DO
+ CUMN = CUMN + NEVAL
+ IF (jjj/IND*IND.EQ.jjj) THEN
+ IMIN = MINLOC(CUMN(INDT(1:ntf)))
+ IMIN(1) = CUMN(INDT(IMIN(1))) !CUMN(IMIN(1))
+ IMAX = MAXLOC(CUMN(INDT(1:ntf)))
+ IMAX(1) = CUMN(INDT(IMAX(1))) !CUMN(IMAX(1))
+ CALL system('cls')
+ WRITE(6,1113) jjj,ntf,IMIN(1)/dfloat(jjj),
+ # IMAX(1)/dfloat(jjj)
+ ENDIF
+ ENDDO
+ ENDIF
+ lastl = IMIN(1)/DFLOAT(burnin)
+ lasth = IMAX(1)/DFLOAT(burnin)
+ CUMN(1:nt) = 0
+ NEVAL(:) = 0
+
+C OPEN OUTPUT FILES
+C 9 '.PAR', 10 '.UNB', 11 '.DIS', 12 '.INN', 13 '.FST', 14 '.MIS', 15 '.ML' o '.DAT'
+ CALL OPENFILES(estimation,seed,nv,nf,nmis*INDMIS,datasim,Marglik,
+ 1 PATH,NMLNAME)
+
+C MCMC RECORDING phase
+ ALLOCATE(INN(nobs,ny))
+ IF (nf.GT.0) THEN
+ ALLOCATE(FORE(nf,ny+nx+1))
+ ENDIF
+ IF (indmis*NMIS.GE.1) THEN
+ ALLOCATE(ykmis(nmis))
+ ENDIF
+ IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
+ ALLOCATE(gibtheta(GGG,nt+np(1)),gibZ(GGG,nobs),MLHM(11,2),
+ 1 MLMW(2,2))
+ ENDIF
+ IF (nmis.GT.0) THEN ! MISSINGS
+ DO jjj = 1,GGG*thin
+ IF (nv.GT.0) THEN
+ IF (HBL.EQ.1) THEN
+ CALL GCK(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
+ 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,psi0,
+ 2 INFOS,pdll,Z,S)
+ ELSE
+ CALL AMH(HBL,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
+ 1 yk(1:nobs,:),IYK(1:nobs,:),theta0,psi0,
+ 2 PTR,PM,INFOS,pdll,Z,S,ACCRATE)
+ CALL RECPR(jjj+burnin,nstot,nobs,Z,ZW,PM,PTR)
+ ENDIF
+ CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
+ ENDIF
+ DO it = 1,nt
+ IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
+ CALL SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk(1:nobs,:),
+ 1 IYK(1:nobs,:),theta0,thetaprior(it,:),
+ 2 pdftheta(it),pdll,NEVAL(it),theta(it))
+ theta0(it) = theta(it)
+ ENDIF
+ END DO
+ CUMN = CUMN+NEVAL
+ CALL SIMSTATE(nobs,d,ny,nz,nx,nu,ns,nt,yk(1:nobs,:),
+ 1 IYK(1:nobs,:),theta,S,pdll,STATE)
+ CALL INNOV(nobs,d,ny,nz,nx,nu,ns,nt,S,
+ 1 yk(1:nobs,:),IYK(1:nobs,:),theta,pdll,INN)
+ IF (nf.GT.0) THEN
+ CALL FORECAST(yk(nobs+1:nobs+nf,ny+1:ny+nz),nf,ny,nz,nx,nu,nv,
+ 1 ns,nstot,nt,np,theta,psi,INFOS,Z(nobs),
+ 2 STATE(nobs,:),pdll,FORE)
+ ENDIF
+ IF (INDMIS*nmis.GE.1) THEN
+ J = 1
+ DO I = 1,nobs
+ IF (IYK(I,ny+1).LT.ny) THEN
+ K = ny-IYK(I,ny+1)
+ CALL MISSING(yk(I,:),ny,nz,nx,nu,ns,nt,K,theta,
+ 1 S(I,1:6),STATE(I,:),pdll,ykmis(J:J+K-1))
+ J = J+K
+ ENDIF
+ ENDDO
+ ENDIF
+ IF (jjj/IND*IND.EQ.jjj) THEN
+ IMIN = MINLOC(CUMN(INDT(L1+1:ntf)))
+ IMIN(1) = CUMN(INDT(L1+IMIN(1)))
+ IMAX = MAXLOC(CUMN(INDT(L1+1:ntf)))
+ IMAX(1) = CUMN(INDT(L1+IMAX(1)))
+ CALL system('cls')
+ WRITE(6,1113) BURNIN,ntf,lastl,lasth
+ IF ((HBL.EQ.1).OR.(nv.EQ.0)) THEN
+ WRITE(6,1114) jjj,ntf,IMIN(1)/dfloat(jjj),
+ # IMAX(1)/dfloat(jjj)
+ ELSEIF ((HBL.GT.1).AND.(nv.GT.0)) THEN
+ WRITE(6,1115) jjj,ntf,IMIN(1)/dfloat(jjj),
+ # IMAX(1)/dfloat(jjj),
+ # SUM(1.D0-ACCRATE(1:nobs)/DFLOAT(jjj))/DFLOAT(nobs)
+ ENDIF
+ ENDIF
+ IF (jjj/thin*thin.EQ.jjj) THEN
+ WRITE(12,'(<nobs*ny>(F20.10))') (INN(1:nobs,I),I=1,ny)
+ WRITE(10,'(<nobs*nx>(F20.10))') (STATE(1:nobs,I),I=1,nx)
+ IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
+ gibtheta(jjj/thin,1:nt) = theta(1:nt)
+ ENDIF
+ IF (nv.EQ.0) THEN
+ WRITE(9,'(<nt>(F25.15))') theta(1:nt)
+ ELSE
+ IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
+ gibtheta(jjj/thin,nt+1:nt+np(1)) = psi(1:np(1))
+ gibZ(jjj/thin,1:nobs) = Z(1:nobs)
+ ENDIF
+ WRITE(9,'(<nt+np(1)>(F25.15))') theta(1:nt),psi(1:np(1))
+ WRITE(11,'(<nobs>(I3))') Z(:)
+ ENDIF
+ IF (nf.GT.0) THEN
+ J = min(nv,1)
+ WRITE(13,'(<nf*(nx+ny+J)>(F20.10))') (FORE(1:nf,I),I=1,nx+ny+J)
+ ENDIF
+ IF (INDMIS*nmis.GE.1) WRITE(14,'(<nmis>(F20.10))') ykmis(1:nmis)
+ ENDIF
+ ENDDO
+ ELSE ! NO MISSINGS
+ DO jjj = 1,GGG*thin
+ IF (nv.GT.0) THEN
+ IF (HBL.EQ.1) THEN
+ CALL GCK2(nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
+ 1 yk(1:nobs,:),theta0,psi0,INFOS,pdll,Z,S)
+ ELSE
+ CALL AMH2(hbl,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np(1),
+ 1 yk(1:nobs,:),theta0,psi0,
+ 2 PTR,PM,INFOS,pdll,Z,S,ACCRATE)
+ CALL RECPR(jjj+burnin,nstot,nobs,Z,ZW,PM,PTR)
+ ENDIF
+ CALL DRAWPSI(nobs,nv,np,INFOS,Z,psiprior,psi0,psi)
+ ENDIF
+ DO it = 1,nt
+ IF (thetaprior(it,3).LT.thetaprior(it,4)) THEN
+ CALL SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk(1:nobs,:),
+ 1 theta0,thetaprior(it,:),pdftheta(it),pdll,
+ 2 NEVAL(it),theta(it))
+ theta0(it) = theta(it)
+ ENDIF
+ END DO
+ CUMN = CUMN+NEVAL
+ CALL SIMSTATE2(nobs,d,ny,nz,nx,nu,ns,nt,yk(1:nobs,:),
+ 1 theta,S,pdll,STATE)
+ CALL INNOV2(nobs,d,ny,nz,nx,nu,ns,nt,S,
+ 1 yk(1:nobs,:),theta,pdll,INN)
+ IF (nf.GT.0) THEN
+ CALL FORECAST(yk(nobs+1:nobs+nf,ny+1:ny+nz),nf,ny,nz,nx,nu,nv,
+ 1 ns,nstot,nt,np,theta,psi,INFOS,Z(nobs),
+ 2 STATE(nobs,:),pdll,FORE)
+ ENDIF
+ IF (jjj/IND*IND.EQ.jjj) THEN
+ IMIN = MINLOC(CUMN(INDT(L1+1:ntf)))
+ IMIN(1) = CUMN(INDT(L1+IMIN(1)))
+ IMAX = MAXLOC(CUMN(INDT(L1+1:ntf)))
+ IMAX(1) = CUMN(INDT(L1+IMAX(1)))
+ CALL system('cls')
+ WRITE(6,1113) BURNIN,ntf,lastl,lasth
+ IF ((HBL.EQ.1).OR.(nv.EQ.0)) THEN
+ WRITE(6,1114) jjj,ntf,IMIN(1)/dfloat(jjj),
+ # IMAX(1)/dfloat(jjj)
+ ELSEIF ((HBL.GT.1).AND.(nv.GT.0)) THEN
+ WRITE(6,1115) jjj,ntf,IMIN(1)/dfloat(jjj),
+ # IMAX(1)/dfloat(jjj),
+ # SUM(1.D0-ACCRATE(1:nobs)/DFLOAT(jjj))/DFLOAT(nobs)
+ ENDIF
+ ENDIF
+ IF (jjj/thin*thin.EQ.jjj) THEN
+ IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
+ gibtheta(jjj/thin,1:nt) = theta(1:nt)
+ ENDIF
+ WRITE(12,'(<nobs*ny>(F20.10))') (INN(1:nobs,I),I=1,ny)
+ WRITE(10,'(<nobs*nx>(F20.10))') (STATE(1:nobs,I),I=1,nx)
+ IF (nv.EQ.0) THEN
+ WRITE(9,'(<nt>(F25.15))') theta(1:nt)
+ ELSE
+ IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
+ gibtheta(jjj/thin,nt+1:nt+np(1)) = psi(1:np(1))
+ gibZ(jjj/thin,1:nobs) = Z(1:nobs)
+ ENDIF
+ WRITE(9,'(<nt+np(1)>(F25.15))') theta(1:nt),psi(1:np(1))
+ WRITE(11,'(<nobs>(I3))') Z(:)
+ ENDIF
+ IF (nf.GT.0) THEN
+ J = min(nv,1)
+ WRITE(13,'(<nf*(nx+ny+J)>(F20.10))') (FORE(1:nf,I),I=1,nx+ny+J)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ CLOSE(9)
+ CLOSE(10)
+ IF (nv.GT.0) CLOSE(11)
+ CLOSE(12)
+ IF (nf.GT.0) CLOSE(13)
+ IF (indmis*nmis.GE.1) THEN
+ CLOSE(14)
+ DEALLOCATE(ykmis)
+ ENDIF
+ DEALLOCATE(INN)
+ IF ((nv.GT.0).AND.(HBL.GT.1)) THEN
+ DEALLOCATE(PTR,PM,ACCRATE)
+ ENDIF
+
+C MARGINAL LIKELIHOOD
+ IF ((MargLik.EQ.'Y').OR.(MargLik.EQ.'y')) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Computing the marginal likelihood. Please wait ...'
+ IF (nmis.GT.0) THEN
+ CALL HARMONIC(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk(1:nobs,:),IYK(1:nobs,:),gibtheta,gibZ,
+ 2 thetaprior,psiprior,pdftheta,pdll,MLHM)
+ WRITE(*,*) 'Modified harmonic mean: done!'
+ CALL MENGWONG(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk(1:nobs,:),IYK(1:nobs,:),gibtheta,gibZ,
+ 2 thetaprior,psiprior,pdftheta,pdll,MLHM(5,1),MLMW)
+ WRITE(*,*) 'Bridge sampling: done!'
+ WRITE(*,*) ' '
+ ELSE
+ CALL HARMONIC2(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk(1:nobs,:),gibtheta,gibZ,thetaprior,
+ 2 psiprior,pdftheta,pdll,MLHM)
+ WRITE(*,*) 'Modified harmonic mean: done!'
+ CALL MENGWONG2(GGG,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk(1:nobs,:),gibtheta,gibZ,thetaprior,
+ 2 psiprior,pdftheta,pdll,MLHM(5,1),MLMW)
+ WRITE(*,*) 'Bridge sampling: done!'
+ WRITE(*,*) ' '
+ ENDIF
+ WRITE(15,*) 'Modified Harmonic mean (ML and Var)'
+ WRITE(15,'(<2>(F20.10))') (MLHM(I,:),I=1,11)
+ WRITE(15,*) 'Bridge Sampling'
+ WRITE(15,'(<2>(F20.10))') (MLMW(I,:),I=1,2)
+ CLOSE(15)
+ DEALLOCATE(gibtheta,gibZ,MLHM,MLMW)
+ ENDIF
+
+7777 DEALLOCATE(yk,STATE,Z,S,theta0,theta,thetaprior,pdftheta,NEVAL,
+ 1 CUMN,IYK,INDT)
+ IF (nv.GT.0) THEN
+ DEALLOCATE(psi0,psi,psiprior,ZW)
+ ENDIF
+
+ STATUS = freelibrary(pdll) !libero la DLL dalla memoria alla fine del programma
+ IF (TRIM(PATH).EQ.'') THEN
+ STATUS = getcwd(PATH) ! get current directory
+ ENDIF
+
+ CALL DATE_AND_TIME(REAL_CLOCK(1),REAL_CLOCK(2),REAL_CLOCK(3),
+ 1 DATE_ITIME)
+ IT2(1:3) = DATE_ITIME(1:3)
+ IT2(4:7) = DATE_ITIME(5:8)
+ IT=(IT2(4)-IT1(4))*3600+(IT2(5)-IT1(5))*60+(IT2(6)-IT1(6))
+ IF ((check.EQ.'Y').OR.(check.EQ.'y')) THEN
+ WRITE(6,1117) TRIM(PATH)
+ ELSE
+ IF ((datasim.EQ.'Y').OR.(datasim.EQ.'y')) THEN
+ WRITE(6,1118) TRIM(PATH)
+ ELSE
+ IF ((estimation.EQ.'ML').OR.(estimation.EQ.'ml').OR.
+ & (estimation.EQ.'Ml').OR.(estimation.EQ.'mL')) THEN
+ WRITE(6,1119) IT,TRIM(PATH)
+ ELSE
+ WRITE(6,1116) IT,TRIM(PATH)
+ ENDIF
+ ENDIF
+ ENDIF
+ DEALLOCATE(np,ns,INFOS,IT1,IT2,DATE_ITIME,REAL_CLOCK)
+
+1111 FORMAT((<4>(F25.12)), ' ',A2)
+1112 FORMAT(I10,(<np(3)>(F25.12)), ' ',I2)
+1113 FORMAT(/,' Burn-in draws = ',I8,
+ # /,' Parameters sampled by SLICE ',I5,
+ # /,' SLICE likelihood eval. Min/Max = ',F6.2, ' / ',F6.2)
+1114 FORMAT(/,' Recording draws = ',I8,
+ # /,' Parameters sampled by SLICE ',I5,
+ # /,' SLICE likelihood eval. Min/Max = ',F6.2, ' / ',F6.2)
+1115 FORMAT(/,' Recording draws = ',I8,
+ # /,' Parameters sampled by SLICE ',I5,
+ # /,' SLICE likelihood eval. Min/Max = ',F6.2, ' / ',F6.2,
+ # /,' Adaptive MH accettance rate = ',F6.2)
+1116 FORMAT(/,' MCMC completed',
+ # /,' CPU-time (sec)=', I10,
+ # /,' Output printed in ',A)
+1117 FORMAT(/,' Check completed',
+ # /,' Output printed in ',A)
+1118 FORMAT(/,' Data simulation completed',
+ # /,' Output printed in 'A)
+1119 FORMAT(/,' Maximum Likelihood completed',
+ # /,' CPU-time (sec)=', I10,
+ # /,' Output printed in ',A)
+
+ PAUSE
+ STOP
END
diff --git a/markovp.for b/markovp.for
index 76e2c56ba8873a75c1cdaac3f14fe9c6077cf076..a480fcc0d8adf6e00f78bd46a374095dc8e83061 100644
--- a/markovp.for
+++ b/markovp.for
@@ -1,20 +1,20 @@
-C ---------------------------------------------------------------------------
-C MARKOVP computes the conditional Log-Probability of a Block of S variables:
-C log{P[S(t+1),...,S(t+h)|S(1),...,S(t),S(t+h+1),...,S(T)]}
-C HFIX = block length
-C NH = 1 first block;
-C NH > 1 and NH < nobs/HFIX middle block
-C NH = nob/HFIX last block
-C S = {S(t),S(t+1),...,S(t+h),S(t+h+1)}
-C S(t) takes values in {1,2,...,N}
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ---------------------------------------------------------------------------
+C MARKOVP computes the conditional Log-Probability of a Block of S variables:
+C log{P[S(t+1),...,S(t+h)|S(1),...,S(t),S(t+h+1),...,S(T)]}
+C HFIX = block length
+C NH = 1 first block;
+C NH > 1 and NH < nobs/HFIX middle block
+C NH = nob/HFIX last block
+C S = {S(t),S(t+1),...,S(t+h),S(t+h+1)}
+C S(t) takes values in {1,2,...,N}
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -25,40 +25,40 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ---------------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION MARKOVP(PMAT,PE,N,HFIX,NH,nobs,S)
-
-C INPUT
- INTEGER N,HFIX,NH,S(HFIX+2),nobs
- DOUBLE PRECISION PMAT(N,N,HFIX+1),PE(N)
-
-C LOCALS
- INTEGER IT
-
- IF (NH.EQ.1) THEN
-
- MARKOVP = DLOG(PMAT(S(HFIX+2),S(2),HFIX))+DLOG(PE(S(2)))
- + - DLOG(PE(S(HFIX+2)))
- DO 10 IT=2,HFIX
-10 MARKOVP = MARKOVP + DLOG(PMAT(S(IT+1),S(IT),1))
- + + DLOG(PMAT(S(HFIX+2),S(IT+1),HFIX+1-IT))
- + - DLOG(PMAT(S(HFIX+2),S(IT),HFIX+2-IT))
-
- ELSEIF ((NH.GT.1).AND.(NH.LT.nobs/HFIX)) THEN
-
- MARKOVP = 0.D0
- DO 20 IT=1,HFIX
-20 MARKOVP = MARKOVP + DLOG(PMAT(S(IT+1),S(IT),1))
- + + DLOG(PMAT(S(HFIX+2),S(IT+1),HFIX+1-IT))
- + - DLOG(PMAT(S(HFIX+2),S(IT),HFIX+2-IT))
-
- ELSE
-
- MARKOVP = 0.D0
- DO 30 IT=1,HFIX
-30 MARKOVP = MARKOVP + DLOG(PMAT(S(IT+1),S(IT),1))
-
- ENDIF
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ---------------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION MARKOVP(PMAT,PE,N,HFIX,NH,nobs,S)
+
+C INPUT
+ INTEGER N,HFIX,NH,S(HFIX+2),nobs
+ DOUBLE PRECISION PMAT(N,N,HFIX+1),PE(N)
+
+C LOCALS
+ INTEGER IT
+
+ IF (NH.EQ.1) THEN
+
+ MARKOVP = DLOG(PMAT(S(HFIX+2),S(2),HFIX))+DLOG(PE(S(2)))
+ + - DLOG(PE(S(HFIX+2)))
+ DO 10 IT=2,HFIX
+10 MARKOVP = MARKOVP + DLOG(PMAT(S(IT+1),S(IT),1))
+ + + DLOG(PMAT(S(HFIX+2),S(IT+1),HFIX+1-IT))
+ + - DLOG(PMAT(S(HFIX+2),S(IT),HFIX+2-IT))
+
+ ELSEIF ((NH.GT.1).AND.(NH.LT.nobs/HFIX)) THEN
+
+ MARKOVP = 0.D0
+ DO 20 IT=1,HFIX
+20 MARKOVP = MARKOVP + DLOG(PMAT(S(IT+1),S(IT),1))
+ + + DLOG(PMAT(S(HFIX+2),S(IT+1),HFIX+1-IT))
+ + - DLOG(PMAT(S(HFIX+2),S(IT),HFIX+2-IT))
+
+ ELSE
+
+ MARKOVP = 0.D0
+ DO 30 IT=1,HFIX
+30 MARKOVP = MARKOVP + DLOG(PMAT(S(IT+1),S(IT),1))
+
+ ENDIF
+ RETURN
END
diff --git a/mengwong.for b/mengwong.for
index 6ca47fd01bbab30548cb9975dbffd34ee7113afc..3af811483caff8fcc050757e14b1fec80c5f7375 100644
--- a/mengwong.for
+++ b/mengwong.for
@@ -1,25 +1,25 @@
-C -------------------------------------------------------------------
-C MENGWONG computes the Marginal Lilkelihood estimates as deteiled
-C by Meng and Wong, Statistica Sinica, 1996
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT:
-C MLMW(:,1) all parameters,
-C MLMW(:,2) non-var params
-C MLMW(1,:) no iteration,
-C MLMW(2,:) SD,
-C MLMW(3,:) 10 iterations
-C
-C Remarks:
-C NPAR is total # of params,
-C NPARD = NPAR - #Variances
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------------
+C MENGWONG computes the Marginal Lilkelihood estimates as deteiled
+C by Meng and Wong, Statistica Sinica, 1996
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT:
+C MLMW(:,1) all parameters,
+C MLMW(:,2) non-var params
+C MLMW(1,:) no iteration,
+C MLMW(2,:) SD,
+C MLMW(3,:) 10 iterations
+C
+C Remarks:
+C NPAR is total # of params,
+C NPARD = NPAR - #Variances
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -30,393 +30,393 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------------
- SUBROUTINE MENGWONG(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk,IYK,gibpar,gibZ,thetaprior,psiprior,
- 2 tipo,pdll,MLSTART,MLMW)
-
-C INPUT
- INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
- 1 INFOS(9,6),gibZ(G,nobs),IYK(nobs,ny+1)
- DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
- 1 thetaprior(nt,4),psiprior(np(2),np(3)),MLSTART
- CHARACTER*2 tipo(nt)
- POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
-
-C OUTPUT
- DOUBLE PRECISION MLMW(2,2)
-
-C LOCALS
- INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,ISEQ,ISEQ0,SEQ(nv),
- 1 IS(nobs,6),NIM,NI,IND(1),NPARTH,NN,NSI,II,JJ
- DOUBLE PRECISION,ALLOCATABLE::MAT(:,:),VQN(:,:),VQD(:,:),
- 1 VHN(:,:),VHD(:,:)
- DOUBLE PRECISION parm(nt),SIGM(nt,nt),
- 1 COM(nt+1,nt),ISIGM(nt,nt),par(nt+np(1)),SEGA(nt+np(1)),
- 2 ub(nt),lb(nt),R3((nt+1)*(nt+2)/2),WORK(nt)
- DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),GAM(:),
- 1 ALPHA(:,:),MOM(:,:)
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6))
- DOUBLE PRECISION Ppar(nt+np(1)),Fpar,PS,QS,QPSI,C,DET,TRC,A0
- DOUBLE PRECISION ERRM,ERR,U,AUX,INDC(1),MUC,SS(2,2),MWNUM,MWDEN
- DOUBLE PRECISION ZERO,ONE,PI
- DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
-
-C EXTERNAL SUBROUTINES
- EXTERNAL NEWEYWESTCOV,NEWEYWESTCOV2,mvncdf,DPOTRF,DPOTRI,setgmn,
- 1 genmn,gengam,DESIGNZ,PPROD,ERGODIC,INT2SEQ
-
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION PTHETA,PRIOR,PRIORDIR,genunf,gengam
-
-
- PAR(:) = GIBPAR(1,:) ! set constant values
- NPARTH = 0
- DO I = 1,nt
- IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
- NPARTH = NPARTH + 1
- NPOS(NPARTH) = I
- ENDIF
- ENDDO
- DO I = 1,np(1)
- NPOS(NPARTH+I) = nt+I
- ENDDO
- NPAR=NPARTH+np(1)
- Ppar(:) = 0.D0
- parm(:) = ZERO
- DO I = 1,NPARTH
- parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
- ENDDO
-
- NQ = 0
- CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
- 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
-
- IF (nv.GT.0) THEN
- ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
-
-C Transition prob for QS
- DO I = 1,nstot-1
- PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
- ENDDO
- PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
-
- DO 50 K = 2,nobs
- DO 50 I = 1,nstot-1
- DO 50 J = 1,nstot
- COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
- IF (COM(1,1).GT.ZERO) THEN
- PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.
- # (gibZ(1:G,K-1).EQ.J)))/COM(1,1)
- ELSE
- PTR(K,I,J) = ONE/DFLOAT(nstot)
- ENDIF
-50 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
-
-C Mean and Var of PSI
- ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
- DO I=1,np(1)
- MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
- MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
- MOM(I,2) = MOM(I,2)-MOM(I,1)**2
- ENDDO
-C Hyperparameters of Dirichelt for Q(PSI)
-C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
- NN = 0
- K = 0
- DO I = 1,nv
- NSI = INFOS(8,I) ! # of states for S
- IF (INFOS(9,I).EQ.1) THEN ! S~IID
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- DO jj = 1,NSI
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-C Importance sampling
-C Sample THIS from N(THHAT,SIGHAT) with boundaries
-C Evaluate p(THIS) ~ N(THHAT,SIGHAT)
- NIM = 1000000
- ERRM = 1.D-8
-
-C Normalization constants TRC and TRCD
- lb(1:NPARTH) = thetaprior(NPOS(1:NPARTH),3)
- ub(1:NPARTH) = thetaprior(NPOS(1:NPARTH),4)
- CALL mvncdf(lb(1:NPARTH),ub(1:NPARTH),parm(1:NPARTH),
- 1 SIGM(1:NPARTH,1:NPARTH),NPARTH,ERRM,NIM,TRC,ERR,NI)
-
-C Inverse SIGM & det for NPARTH
- COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
- IFAIL = -1
-C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
- CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
- DET = 1.D0 ! det(SIGM)
- DO I=1,NPARTH
- DET = DET*COM(I,I)**2
- ENDDO
- CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
-
- DO 60 I=1,NPARTH
- ISIGM(I,I) = COM(I,I)
- DO 60 J=1,I-1
- ISIGM(I,J) = COM(I,J)
-60 ISIGM(J,I) = ISIGM(I,J)
-
-c COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
-c IFAIL = -1
-c CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
-c 1 WORK(1:NPARTH),IFAIL)
-
- C = (2.D0*PI)**(-.5D0*NPARTH)/DSQRT(DET) ! constant
-
- ALLOCATE (MAT(G,2),VHN(G,2),VHD(G,2),VQN(G,2),VQD(G,2))
- QS = ONE
- PS = ONE
- IS(:,:) = 1
- DO 200 IG = 1,G
-C SAMPLING THETA
- SEGA(:) = -1.D0
- IFAIL = -1
- IND(1) = 0
- INDC(1) = -1.D0
- DO WHILE (INDC(1).LT.ZERO)
- INDC(1) = ZERO
- IND(1) = IND(1) + 1
- IF (IND(1).GT.G) EXIT
-C CALL G05EAF(parm(1:NPARTH),NPARTH,SIGM(1:NPARTH,1:NPARTH),
-C 1 NPARTH,EPS,R3,(NPARTH+1)*(NPARTH+2)/2,IFAIL)
-C CALL G05EZF(SEGA(1:NPARTH),NPARTH,R3,(NPARTH+1)*(NPARTH+2)/2,
-C 1 IFAIL)
- COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
- CALL setgmn(parm(1:NPARTH),COM(1:NPARTH,1:NPARTH),NPARTH,
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------------
+ SUBROUTINE MENGWONG(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk,IYK,gibpar,gibZ,thetaprior,psiprior,
+ 2 tipo,pdll,MLSTART,MLMW)
+
+C INPUT
+ INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
+ 1 INFOS(9,6),gibZ(G,nobs),IYK(nobs,ny+1)
+ DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
+ 1 thetaprior(nt,4),psiprior(np(2),np(3)),MLSTART
+ CHARACTER*2 tipo(nt)
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer P alla DLL ad una varibile fittizia
+
+C OUTPUT
+ DOUBLE PRECISION MLMW(2,2)
+
+C LOCALS
+ INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,ISEQ,ISEQ0,SEQ(nv),
+ 1 IS(nobs,6),NIM,NI,IND(1),NPARTH,NN,NSI,II,JJ
+ DOUBLE PRECISION,ALLOCATABLE::MAT(:,:),VQN(:,:),VQD(:,:),
+ 1 VHN(:,:),VHD(:,:)
+ DOUBLE PRECISION parm(nt),SIGM(nt,nt),
+ 1 COM(nt+1,nt),ISIGM(nt,nt),par(nt+np(1)),SEGA(nt+np(1)),
+ 2 ub(nt),lb(nt),R3((nt+1)*(nt+2)/2),WORK(nt)
+ DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),GAM(:),
+ 1 ALPHA(:,:),MOM(:,:)
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6))
+ DOUBLE PRECISION Ppar(nt+np(1)),Fpar,PS,QS,QPSI,C,DET,TRC,A0
+ DOUBLE PRECISION ERRM,ERR,U,AUX,INDC(1),MUC,SS(2,2),MWNUM,MWDEN
+ DOUBLE PRECISION ZERO,ONE,PI
+ DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
+
+C EXTERNAL SUBROUTINES
+ EXTERNAL NEWEYWESTCOV,NEWEYWESTCOV2,mvncdf,DPOTRF,DPOTRI,setgmn,
+ 1 genmn,gengam,DESIGNZ,PPROD,ERGODIC,INT2SEQ
+
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION PTHETA,PRIOR,PRIORDIR,genunf,gengam
+
+
+ PAR(:) = GIBPAR(1,:) ! set constant values
+ NPARTH = 0
+ DO I = 1,nt
+ IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
+ NPARTH = NPARTH + 1
+ NPOS(NPARTH) = I
+ ENDIF
+ ENDDO
+ DO I = 1,np(1)
+ NPOS(NPARTH+I) = nt+I
+ ENDDO
+ NPAR=NPARTH+np(1)
+ Ppar(:) = 0.D0
+ parm(:) = ZERO
+ DO I = 1,NPARTH
+ parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
+ ENDDO
+
+ NQ = 0
+ CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
+ 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
+
+ IF (nv.GT.0) THEN
+ ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
+
+C Transition prob for QS
+ DO I = 1,nstot-1
+ PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
+ ENDDO
+ PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
+
+ DO 50 K = 2,nobs
+ DO 50 I = 1,nstot-1
+ DO 50 J = 1,nstot
+ COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
+ IF (COM(1,1).GT.ZERO) THEN
+ PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.
+ # (gibZ(1:G,K-1).EQ.J)))/COM(1,1)
+ ELSE
+ PTR(K,I,J) = ONE/DFLOAT(nstot)
+ ENDIF
+50 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
+
+C Mean and Var of PSI
+ ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
+ DO I=1,np(1)
+ MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
+ MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
+ MOM(I,2) = MOM(I,2)-MOM(I,1)**2
+ ENDDO
+C Hyperparameters of Dirichelt for Q(PSI)
+C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
+ NN = 0
+ K = 0
+ DO I = 1,nv
+ NSI = INFOS(8,I) ! # of states for S
+ IF (INFOS(9,I).EQ.1) THEN ! S~IID
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ DO jj = 1,NSI
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+C Importance sampling
+C Sample THIS from N(THHAT,SIGHAT) with boundaries
+C Evaluate p(THIS) ~ N(THHAT,SIGHAT)
+ NIM = 1000000
+ ERRM = 1.D-8
+
+C Normalization constants TRC and TRCD
+ lb(1:NPARTH) = thetaprior(NPOS(1:NPARTH),3)
+ ub(1:NPARTH) = thetaprior(NPOS(1:NPARTH),4)
+ CALL mvncdf(lb(1:NPARTH),ub(1:NPARTH),parm(1:NPARTH),
+ 1 SIGM(1:NPARTH,1:NPARTH),NPARTH,ERRM,NIM,TRC,ERR,NI)
+
+C Inverse SIGM & det for NPARTH
+ COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+ IFAIL = -1
+C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
+ CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
+ DET = 1.D0 ! det(SIGM)
+ DO I=1,NPARTH
+ DET = DET*COM(I,I)**2
+ ENDDO
+ CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
+
+ DO 60 I=1,NPARTH
+ ISIGM(I,I) = COM(I,I)
+ DO 60 J=1,I-1
+ ISIGM(I,J) = COM(I,J)
+60 ISIGM(J,I) = ISIGM(I,J)
+
+c COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+c IFAIL = -1
+c CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
+c 1 WORK(1:NPARTH),IFAIL)
+
+ C = (2.D0*PI)**(-.5D0*NPARTH)/DSQRT(DET) ! constant
+
+ ALLOCATE (MAT(G,2),VHN(G,2),VHD(G,2),VQN(G,2),VQD(G,2))
+ QS = ONE
+ PS = ONE
+ IS(:,:) = 1
+ DO 200 IG = 1,G
+C SAMPLING THETA
+ SEGA(:) = -1.D0
+ IFAIL = -1
+ IND(1) = 0
+ INDC(1) = -1.D0
+ DO WHILE (INDC(1).LT.ZERO)
+ INDC(1) = ZERO
+ IND(1) = IND(1) + 1
+ IF (IND(1).GT.G) EXIT
+C CALL G05EAF(parm(1:NPARTH),NPARTH,SIGM(1:NPARTH,1:NPARTH),
+C 1 NPARTH,EPS,R3,(NPARTH+1)*(NPARTH+2)/2,IFAIL)
+C CALL G05EZF(SEGA(1:NPARTH),NPARTH,R3,(NPARTH+1)*(NPARTH+2)/2,
+C 1 IFAIL)
+ COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+ CALL setgmn(parm(1:NPARTH),COM(1:NPARTH,1:NPARTH),NPARTH,
1 NPARTH,R3(1:(NPARTH+2)*(NPARTH+1)/2))
- CALL genmn(R3(1:(NPARTH+2)*(NPARTH+1)/2),SEGA(1:NPARTH),
- 1 WORK(1:NPARTH))
- DO I=1,NPARTH
- IF (SEGA(I).LT.thetaprior(NPOS(I),3)) INDC(1)=-1
- IF (SEGA(I).GT.thetaprior(NPOS(I),4)) INDC(1)=-2
- ENDDO
- END DO
-C SAMPLING PSI from Dirichlet(ALPHA)
- NN = NPARTH
- K = 0
- DO 70 I = 1,nv
- NSI = INFOS(8,I) ! # of states for SI
- ALLOCATE(GAM(NSI))
- IF (INFOS(9,I).EQ.1) THEN ! S~IID
- DO ii = 1,NSI
- IFAIL = -1
-C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
- GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
- ENDDO
- SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
- K = K + 1
- NN = NN + NSI-1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- DO jj = 1,NSI
- DO ii = 1,NSI
- IFAIL = -1
-C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
- GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
- ENDDO
- SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
- K = K + 1
- NN = NN + NSI-1
- ENDDO
- ENDIF
-70 DEALLOCATE(GAM)
-
-C SAMPLING S
- IF (nv.GT.0) THEN
- CALL DESIGNZ(nv,np(1),SEGA(NPARTH+1:NPAR),INFOS,
- 1 P1,P2,P3,P4,P5,P6)
-C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-C S(1)
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PTR(1,ISEQ,1)
- DO 80 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-80 AUX = AUX + PTR(1,ISEQ,1)
- CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(1,:))
- QS = PTR(1,ISEQ,1)
- PS = PE(ISEQ) ! P(S1)
- ISEQ0 = ISEQ
-C S(2),...,S(nobs)
- DO 90 K = 2,nobs
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PTR(K,ISEQ,ISEQ0)
- DO 85 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-85 AUX = AUX + PTR(K,ISEQ,ISEQ0)
- CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(K,:))
- QS = QS*PTR(K,ISEQ,ISEQ0)
- PS = PS*PMAT(ISEQ,ISEQ0)
-90 ISEQ0 = ISEQ
- ENDIF
-
-C QUADRATIC FORM FOR for THETA
- DO 91 I = 1,NPARTH
-91 COM(I,1) = SUM((SEGA(1:NPARTH)-parm(1:NPARTH))*ISIGM(1:NPARTH,I))
- MUC = SUM(COM(1:NPARTH,1)*(SEGA(1:NPARTH)-parm(1:NPARTH)))
-
-C VQN(IG,1) = QS*C*DEXP(-.5D0*MUC)/TRC
-
- par(NPOS(1:NPARTH+np(1))) = SEGA(1:NPARTH+np(1)) ! (THETA,PSI)
-
-C PRIOR for THETA
- DO 92 I = 2,NPARTH
-92 Ppar(I) = PRIOR(par(NPOS(I)),thetaprior(NPOS(I),:),tipo(NPOS(I)))
-
-C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
- QPSI = 0.D0
- NN = NPARTH
- K = 0
- DO 100 J = 1,nv
- NSI = INFOS(8,J)
- IF(INFOS(9,J).EQ.1) THEN ! S~IID
- Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
- NN = NN + NSI-1
- ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
- DO 99 I = 1,NSI
- Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
-99 NN = NN + NSI-1
- ENDIF
-100 CONTINUE
-
- Fpar = PTHETA(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,IYK,
- 1 par(1:nt),thetaprior(NPOS(1),:),
- 2 tipo(NPOS(1)),pdll)
- Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
-
- VQN(IG,1) = DEXP(QPSI)*QS*C*DEXP(-.5D0*MUC)/TRC
-
-200 VHN(IG,1) = Fpar + DLOG(PS)
-
-C ---------------------
-C Meng-Wong denominator
-C ---------------------
- QS = ONE
- PS = ONE
- DO 400 IG = 1,G
- IF (nv.GT.0) THEN
- CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
- 1 P1,P2,P3,P4,P5,P6)
-C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-
- QS = PTR(1,gibZ(IG,1),1)
- PS = PE(gibZ(IG,1))
- CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
- DO 210 K = 2,nobs
- QS = QS*PTR(K,gibZ(IG,K),gibZ(IG,K-1))
- PS = PS*PMAT(gibZ(IG,K),gibZ(IG,K-1))
-210 CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
- ENDIF
-
-C PRIOR for THETA
- DO 310 I = 2,NPARTH
-310 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
- 1 tipo(NPOS(I)))
-
-C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
- QPSI = 0.D0
- NN = NPARTH
- K = 0
- DO 305 J = 1,nv
- NSI = INFOS(8,J)
- IF(INFOS(9,J).EQ.1) THEN ! S~IID
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
- NN = NN + NSI-1
- ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
- DO 304 I = 1,NSI
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
-304 NN = NN + NSI-1
- ENDIF
-305 CONTINUE
-
- Fpar = PTHETA(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,IYK,
- 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
- 2 tipo(NPOS(1)),pdll)
- Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
-
- VHD(IG,1) = Fpar + DLOG(PS)
-
- COM(:,1) = ZERO
- DO 320 I = 1,NPARTH
-320 COM(I,1) = SUM((gibpar(IG,NPOS(1:NPARTH))-parm(1:NPARTH))
- # * ISIGM(1:NPARTH,I))
- MUC = SUM(COM(1:NPARTH,1)*(gibpar(IG,NPOS(1:NPARTH))
- # - parm(1:NPARTH)))
-
- VQD(IG,1) = DEXP(QPSI)*QS*DEXP(-.5D0*MUC)*C/TRC
-400 CONTINUE
-
- IND = MAXLOC(VHN(:,1))
- DET = VHN(IND(1),1)
-
- MAT(:,1) = DEXP(VHN(:,1)-DET)/(DEXP(VHN(:,1)-MLSTART)+VQN(:,1))
- MAT(:,2) = VQD(:,1)/(DEXP(VHD(:,1)-MLSTART)+VQD(:,1))
-
- CALL NEWEYWESTCOV(G,2,1,MAT(:,1:2),SS)
- MLMW(2,1) = SUM(MAT(:,1))/SUM(MAT(:,2))
- MLMW(1,1) = DLOG(MLMW(2,1)) + DET
- MLMW(1:2,2) = SS(1,1)*G/SUM(MAT(:,1))**2 +
- + SS(2,2)*G/SUM(MAT(:,2))**2 +
- + - 2.D0*SS(1,2)*G/(SUM(MAT(:,1))*SUM(MAT(:,2)))
-
- MLMW(2,1) = MLMW(1,1) ! log scale
- DO 500 I=1,10
- MWNUM = SUM(DEXP(VHN(:,1)-DET)
- 1 / (DEXP(VHN(:,1)-MLMW(2,1))+VQN(:,1)))
- MWDEN = SUM(VQD(:,1)/(DEXP(VHD(:,1)-MLMW(2,1))+VQD(:,1)))
- MLMW(2,1) = DLOG(MWNUM/MWDEN) + DET ! log-scale
-500 CONTINUE
-
- DEALLOCATE (MAT,VHN,VHD,VQN,VQD)
- IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
-
- RETURN
+ CALL genmn(R3(1:(NPARTH+2)*(NPARTH+1)/2),SEGA(1:NPARTH),
+ 1 WORK(1:NPARTH))
+ DO I=1,NPARTH
+ IF (SEGA(I).LT.thetaprior(NPOS(I),3)) INDC(1)=-1
+ IF (SEGA(I).GT.thetaprior(NPOS(I),4)) INDC(1)=-2
+ ENDDO
+ END DO
+C SAMPLING PSI from Dirichlet(ALPHA)
+ NN = NPARTH
+ K = 0
+ DO 70 I = 1,nv
+ NSI = INFOS(8,I) ! # of states for SI
+ ALLOCATE(GAM(NSI))
+ IF (INFOS(9,I).EQ.1) THEN ! S~IID
+ DO ii = 1,NSI
+ IFAIL = -1
+C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
+ GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
+ ENDDO
+ SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ DO jj = 1,NSI
+ DO ii = 1,NSI
+ IFAIL = -1
+C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
+ GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
+ ENDDO
+ SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
+ K = K + 1
+ NN = NN + NSI-1
+ ENDDO
+ ENDIF
+70 DEALLOCATE(GAM)
+
+C SAMPLING S
+ IF (nv.GT.0) THEN
+ CALL DESIGNZ(nv,np(1),SEGA(NPARTH+1:NPAR),INFOS,
+ 1 P1,P2,P3,P4,P5,P6)
+C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+C S(1)
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PTR(1,ISEQ,1)
+ DO 80 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+80 AUX = AUX + PTR(1,ISEQ,1)
+ CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(1,:))
+ QS = PTR(1,ISEQ,1)
+ PS = PE(ISEQ) ! P(S1)
+ ISEQ0 = ISEQ
+C S(2),...,S(nobs)
+ DO 90 K = 2,nobs
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PTR(K,ISEQ,ISEQ0)
+ DO 85 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+85 AUX = AUX + PTR(K,ISEQ,ISEQ0)
+ CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(K,:))
+ QS = QS*PTR(K,ISEQ,ISEQ0)
+ PS = PS*PMAT(ISEQ,ISEQ0)
+90 ISEQ0 = ISEQ
+ ENDIF
+
+C QUADRATIC FORM FOR for THETA
+ DO 91 I = 1,NPARTH
+91 COM(I,1) = SUM((SEGA(1:NPARTH)-parm(1:NPARTH))*ISIGM(1:NPARTH,I))
+ MUC = SUM(COM(1:NPARTH,1)*(SEGA(1:NPARTH)-parm(1:NPARTH)))
+
+C VQN(IG,1) = QS*C*DEXP(-.5D0*MUC)/TRC
+
+ par(NPOS(1:NPARTH+np(1))) = SEGA(1:NPARTH+np(1)) ! (THETA,PSI)
+
+C PRIOR for THETA
+ DO 92 I = 2,NPARTH
+92 Ppar(I) = PRIOR(par(NPOS(I)),thetaprior(NPOS(I),:),tipo(NPOS(I)))
+
+C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
+ QPSI = 0.D0
+ NN = NPARTH
+ K = 0
+ DO 100 J = 1,nv
+ NSI = INFOS(8,J)
+ IF(INFOS(9,J).EQ.1) THEN ! S~IID
+ Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
+ DO 99 I = 1,NSI
+ Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+99 NN = NN + NSI-1
+ ENDIF
+100 CONTINUE
+
+ Fpar = PTHETA(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,IYK,
+ 1 par(1:nt),thetaprior(NPOS(1),:),
+ 2 tipo(NPOS(1)),pdll)
+ Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
+
+ VQN(IG,1) = DEXP(QPSI)*QS*C*DEXP(-.5D0*MUC)/TRC
+
+200 VHN(IG,1) = Fpar + DLOG(PS)
+
+C ---------------------
+C Meng-Wong denominator
+C ---------------------
+ QS = ONE
+ PS = ONE
+ DO 400 IG = 1,G
+ IF (nv.GT.0) THEN
+ CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
+ 1 P1,P2,P3,P4,P5,P6)
+C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+
+ QS = PTR(1,gibZ(IG,1),1)
+ PS = PE(gibZ(IG,1))
+ CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
+ DO 210 K = 2,nobs
+ QS = QS*PTR(K,gibZ(IG,K),gibZ(IG,K-1))
+ PS = PS*PMAT(gibZ(IG,K),gibZ(IG,K-1))
+210 CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
+ ENDIF
+
+C PRIOR for THETA
+ DO 310 I = 2,NPARTH
+310 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
+ 1 tipo(NPOS(I)))
+
+C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
+ QPSI = 0.D0
+ NN = NPARTH
+ K = 0
+ DO 305 J = 1,nv
+ NSI = INFOS(8,J)
+ IF(INFOS(9,J).EQ.1) THEN ! S~IID
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
+ DO 304 I = 1,NSI
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+304 NN = NN + NSI-1
+ ENDIF
+305 CONTINUE
+
+ Fpar = PTHETA(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,IYK,
+ 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
+ 2 tipo(NPOS(1)),pdll)
+ Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
+
+ VHD(IG,1) = Fpar + DLOG(PS)
+
+ COM(:,1) = ZERO
+ DO 320 I = 1,NPARTH
+320 COM(I,1) = SUM((gibpar(IG,NPOS(1:NPARTH))-parm(1:NPARTH))
+ # * ISIGM(1:NPARTH,I))
+ MUC = SUM(COM(1:NPARTH,1)*(gibpar(IG,NPOS(1:NPARTH))
+ # - parm(1:NPARTH)))
+
+ VQD(IG,1) = DEXP(QPSI)*QS*DEXP(-.5D0*MUC)*C/TRC
+400 CONTINUE
+
+ IND = MAXLOC(VHN(:,1))
+ DET = VHN(IND(1),1)
+
+ MAT(:,1) = DEXP(VHN(:,1)-DET)/(DEXP(VHN(:,1)-MLSTART)+VQN(:,1))
+ MAT(:,2) = VQD(:,1)/(DEXP(VHD(:,1)-MLSTART)+VQD(:,1))
+
+ CALL NEWEYWESTCOV(G,2,1,MAT(:,1:2),SS)
+ MLMW(2,1) = SUM(MAT(:,1))/SUM(MAT(:,2))
+ MLMW(1,1) = DLOG(MLMW(2,1)) + DET
+ MLMW(1:2,2) = SS(1,1)*G/SUM(MAT(:,1))**2 +
+ + SS(2,2)*G/SUM(MAT(:,2))**2 +
+ + - 2.D0*SS(1,2)*G/(SUM(MAT(:,1))*SUM(MAT(:,2)))
+
+ MLMW(2,1) = MLMW(1,1) ! log scale
+ DO 500 I=1,10
+ MWNUM = SUM(DEXP(VHN(:,1)-DET)
+ 1 / (DEXP(VHN(:,1)-MLMW(2,1))+VQN(:,1)))
+ MWDEN = SUM(VQD(:,1)/(DEXP(VHD(:,1)-MLMW(2,1))+VQD(:,1)))
+ MLMW(2,1) = DLOG(MWNUM/MWDEN) + DET ! log-scale
+500 CONTINUE
+
+ DEALLOCATE (MAT,VHN,VHD,VQN,VQD)
+ IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
+
+ RETURN
END
diff --git a/mengwong2.for b/mengwong2.for
index fcd95fc95a52c46d2fb56c84b896968c6567651c..1735d84d6ed5f21b5d302b080f29d0c95210f70d 100644
--- a/mengwong2.for
+++ b/mengwong2.for
@@ -1,25 +1,25 @@
-C -------------------------------------------------------------------
-C MENGWONG2 (no missing values) computes the Marginal Lilkelihood estimates as deteiled
-C by Meng and Wong, Statistica Sinica, 1996
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT:
-C MLMW(:,1) all parameters,
-C MLMW(:,2) non-var params
-C MLMW(1,:) no iteration,
-C MLMW(2,:) SD,
-C MLMW(3,:) 10 iterations
-C
-C Remarks:
-C NPAR is total # of params,
-C NPARD = NPAR - #Variances
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------------
+C MENGWONG2 (no missing values) computes the Marginal Lilkelihood estimates as deteiled
+C by Meng and Wong, Statistica Sinica, 1996
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT:
+C MLMW(:,1) all parameters,
+C MLMW(:,2) non-var params
+C MLMW(1,:) no iteration,
+C MLMW(2,:) SD,
+C MLMW(3,:) 10 iterations
+C
+C Remarks:
+C NPAR is total # of params,
+C NPARD = NPAR - #Variances
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -30,392 +30,392 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------------
- SUBROUTINE MENGWONG2(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
- 1 INFOS,yk,gibpar,gibZ,thetaprior,psiprior,
- 2 tipo,pdll,MLSTART,MLMW)
-
-C INPUT
- INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
- 1 INFOS(9,6),gibZ(G,nobs)
- DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
- 1 thetaprior(nt,4),psiprior(np(2),np(3)),MLSTART
- CHARACTER*2 tipo(nt)
- POINTER (pdll,fittizia)
-
-C OUTPUT
- DOUBLE PRECISION MLMW(2,2)
-
-C LOCALS
- INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,ISEQ,ISEQ0,SEQ(nv),
- 1 IS(nobs,6),NIM,NI,IND(1),NPARTH,NN,NSI,II,JJ
- DOUBLE PRECISION,ALLOCATABLE::MAT(:,:),VQN(:,:),VQD(:,:),
- 1 VHN(:,:),VHD(:,:)
- DOUBLE PRECISION parm(nt),SIGM(nt,nt),
- 1 COM(nt+1,nt),ISIGM(nt,nt),par(nt+np(1)),SEGA(nt+np(1)),
- 2 ub(nt),lb(nt),R3((nt+1)*(nt+2)/2),WORK(nt)
- DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),GAM(:),
- 1 ALPHA(:,:),MOM(:,:)
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6))
- DOUBLE PRECISION Ppar(nt+np(1)),Fpar,PS,QS,QPSI,C,DET,TRC,A0
- DOUBLE PRECISION ERRM,ERR,U,AUX,INDC(1),MUC,SS(2,2),MWNUM,MWDEN
- DOUBLE PRECISION ZERO,ONE,PI
- DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
-
-C EXTERNAL SUBROUTINES
- EXTERNAL NEWEYWESTCOV,NEWEYWESTCOV2,mvncdf,DPOTRF,DPOTRI,setgmn,
- 1 genmn,gengam,DESIGNZ,PPROD,ERGODIC,INT2SEQ
-
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION PTHETA2,PRIOR,PRIORDIR,genunf,gengam
-
- PAR(:) = GIBPAR(1,:) ! set constant values
- NPARTH = 0
- DO I = 1,nt
- IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
- NPARTH = NPARTH + 1
- NPOS(NPARTH) = I
- ENDIF
- ENDDO
- DO I = 1,np(1)
- NPOS(NPARTH+I) = nt+I
- ENDDO
- NPAR=NPARTH+np(1)
- Ppar(:) = 0.D0
- parm(:) = ZERO
- DO I = 1,NPARTH
- parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
- ENDDO
-
- NQ = 0
- CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
- 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
-
- IF (nv.GT.0) THEN
- ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
-
-C Transition prob for QS
- DO I = 1,nstot-1
- PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
- ENDDO
- PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
-
- DO 50 K = 2,nobs
- DO 50 I = 1,nstot-1
- DO 50 J = 1,nstot
- COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
- IF (COM(1,1).GT.ZERO) THEN
- PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.
- # (gibZ(1:G,K-1).EQ.J)))/COM(1,1)
- ELSE
- PTR(K,I,J) = ONE/DFLOAT(nstot)
- ENDIF
-50 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
-
-C Mean and Var of PSI
- ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
- DO I=1,np(1)
- MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
- MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
- MOM(I,2) = MOM(I,2)-MOM(I,1)**2
- ENDDO
-C Hyperparameters of Dirichelt for Q(PSI)
-C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
- NN = 0
- K = 0
- DO I = 1,nv
- NSI = INFOS(8,I) ! # of states for S
- IF (INFOS(9,I).EQ.1) THEN ! S~IID
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- DO jj = 1,NSI
- A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
- DO ii = 1,NSI-1
- ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
- ENDDO
- ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
- K = K + 1
- NN = NN + NSI-1
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-C Importance sampling
-C Sample THIS from N(THHAT,SIGHAT) with boundaries
-C Evaluate p(THIS) ~ N(THHAT,SIGHAT)
- NIM = 1000000
- ERRM = 1.D-8
-
-C Normalization constants TRC and TRCD
- lb(1:NPARTH) = thetaprior(NPOS(1:NPARTH),3)
- ub(1:NPARTH) = thetaprior(NPOS(1:NPARTH),4)
- CALL mvncdf(lb(1:NPARTH),ub(1:NPARTH),parm(1:NPARTH),
- 1 SIGM(1:NPARTH,1:NPARTH),NPARTH,ERRM,NIM,TRC,ERR,NI)
-
-C Inverse SIGM & det for NPARTH
- COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
- IFAIL = -1
-C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
- CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
- DET = 1.D0 ! det(SIGM)
- DO I=1,NPARTH
- DET = DET*COM(I,I)**2
- ENDDO
- CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
-
- DO 60 I=1,NPARTH
- ISIGM(I,I) = COM(I,I)
- DO 60 J=1,I-1
- ISIGM(I,J) = COM(I,J)
-60 ISIGM(J,I) = ISIGM(I,J)
-
-c COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
-c IFAIL = -1
-c CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
-c 1 WORK(1:NPARTH),IFAIL)
-
- C = (2.D0*PI)**(-.5D0*NPARTH)/DSQRT(DET) ! constant
-
- ALLOCATE (MAT(G,2),VHN(G,2),VHD(G,2),VQN(G,2),VQD(G,2))
- QS = ONE
- PS = ONE
- IS(:,:) = 1
- DO 200 IG = 1,G
-C SAMPLING THETA
- SEGA(:) = -1.D0
- IFAIL = -1
- IND(1) = 0
- INDC(1) = -1.D0
- DO WHILE (INDC(1).LT.ZERO)
- INDC(1) = ZERO
- IND(1) = IND(1) + 1
- IF (IND(1).GT.G) EXIT
-c CALL G05EAF(parm(1:NPARTH),NPARTH,SIGM(1:NPARTH,1:NPARTH),
-c 1 NPARTH,EPS,R3,(NPARTH+1)*(NPARTH+2)/2,IFAIL)
-c CALL G05EZF(SEGA(1:NPARTH),NPARTH,R3,(NPARTH+1)*(NPARTH+2)/2,
-c 1 IFAIL)
- COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
- CALL setgmn(parm(1:NPARTH),COM(1:NPARTH,1:NPARTH),NPARTH,
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------------
+ SUBROUTINE MENGWONG2(G,nobs,d,ny,nz,nx,nu,nv,ns,nstot,nt,np,
+ 1 INFOS,yk,gibpar,gibZ,thetaprior,psiprior,
+ 2 tipo,pdll,MLSTART,MLMW)
+
+C INPUT
+ INTEGER G,nobs,d(2),ny,nz,nx,nu,nv,ns(6),nstot,nt,np(3),
+ 1 INFOS(9,6),gibZ(G,nobs)
+ DOUBLE PRECISION yk(nobs,ny+nz),gibpar(G,nt+np(1)),
+ 1 thetaprior(nt,4),psiprior(np(2),np(3)),MLSTART
+ CHARACTER*2 tipo(nt)
+ POINTER (pdll,fittizia)
+
+C OUTPUT
+ DOUBLE PRECISION MLMW(2,2)
+
+C LOCALS
+ INTEGER NPAR,I,J,K,IG,NPOS(nt+np(1)),IFAIL,NQ,ISEQ,ISEQ0,SEQ(nv),
+ 1 IS(nobs,6),NIM,NI,IND(1),NPARTH,NN,NSI,II,JJ
+ DOUBLE PRECISION,ALLOCATABLE::MAT(:,:),VQN(:,:),VQD(:,:),
+ 1 VHN(:,:),VHD(:,:)
+ DOUBLE PRECISION parm(nt),SIGM(nt,nt),
+ 1 COM(nt+1,nt),ISIGM(nt,nt),par(nt+np(1)),SEGA(nt+np(1)),
+ 2 ub(nt),lb(nt),R3((nt+1)*(nt+2)/2),WORK(nt)
+ DOUBLE PRECISION,ALLOCATABLE:: PTR(:,:,:),PMAT(:,:),PE(:),GAM(:),
+ 1 ALPHA(:,:),MOM(:,:)
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6))
+ DOUBLE PRECISION Ppar(nt+np(1)),Fpar,PS,QS,QPSI,C,DET,TRC,A0
+ DOUBLE PRECISION ERRM,ERR,U,AUX,INDC(1),MUC,SS(2,2),MWNUM,MWDEN
+ DOUBLE PRECISION ZERO,ONE,PI
+ DATA ZERO/0.0D0/,ONE/1.0D0/,PI/3.141592653589793D0/
+
+C EXTERNAL SUBROUTINES
+ EXTERNAL NEWEYWESTCOV,NEWEYWESTCOV2,mvncdf,DPOTRF,DPOTRI,setgmn,
+ 1 genmn,gengam,DESIGNZ,PPROD,ERGODIC,INT2SEQ
+
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION PTHETA2,PRIOR,PRIORDIR,genunf,gengam
+
+ PAR(:) = GIBPAR(1,:) ! set constant values
+ NPARTH = 0
+ DO I = 1,nt
+ IF (GIBPAR(1,I).NE.GIBPAR(2,I)) THEN
+ NPARTH = NPARTH + 1
+ NPOS(NPARTH) = I
+ ENDIF
+ ENDDO
+ DO I = 1,np(1)
+ NPOS(NPARTH+I) = nt+I
+ ENDDO
+ NPAR=NPARTH+np(1)
+ Ppar(:) = 0.D0
+ parm(:) = ZERO
+ DO I = 1,NPARTH
+ parm(I) = SUM(gibpar(:,NPOS(I)))/DFLOAT(G)
+ ENDDO
+
+ NQ = 0
+ CALL NEWEYWESTCOV2(G,NPARTH,NQ,gibpar(:,NPOS(1:NPARTH)),
+ 1 parm(1:NPARTH),SIGM(1:NPARTH,1:NPARTH)) ! THETA Var-covar
+
+ IF (nv.GT.0) THEN
+ ALLOCATE(PTR(nobs,nstot,nstot),PMAT(nstot,nstot),PE(nstot))
+
+C Transition prob for QS
+ DO I = 1,nstot-1
+ PTR(1,I,1) = SUM(ABS(gibZ(1:G,1).EQ.I))/DFLOAT(G)
+ ENDDO
+ PTR(1,nstot,1) = ONE-SUM(PTR(1,1:nstot-1,1))
+
+ DO 50 K = 2,nobs
+ DO 50 I = 1,nstot-1
+ DO 50 J = 1,nstot
+ COM(1,1) = SUM(ABS(gibZ(1:G,K-1).EQ.J))
+ IF (COM(1,1).GT.ZERO) THEN
+ PTR(K,I,J) = SUM(ABS((gibZ(1:G,K).EQ.I).AND.
+ # (gibZ(1:G,K-1).EQ.J)))/COM(1,1)
+ ELSE
+ PTR(K,I,J) = ONE/DFLOAT(nstot)
+ ENDIF
+50 PTR(K,nstot,J) = ONE-SUM(PTR(K,1:nstot-1,J))
+
+C Mean and Var of PSI
+ ALLOCATE (ALPHA(np(2),np(3)),MOM(np(1),2))
+ DO I=1,np(1)
+ MOM(I,1) = SUM(gibpar(:,nt+I))/DFLOAT(G)
+ MOM(I,2) = SUM(gibpar(:,nt+I)**2)/DFLOAT(G)
+ MOM(I,2) = MOM(I,2)-MOM(I,1)**2
+ ENDDO
+C Hyperparameters of Dirichelt for Q(PSI)
+C Mothod of Moments: a0 = m1(1-m1)/V1+1, ai = mi*a0, i=1,2,..,N
+ NN = 0
+ K = 0
+ DO I = 1,nv
+ NSI = INFOS(8,I) ! # of states for S
+ IF (INFOS(9,I).EQ.1) THEN ! S~IID
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ DO jj = 1,NSI
+ A0 = MOM(NN+1,1)*(1.D0-MOM(NN+1,1))/MOM(NN+1,2)+1.D0 !alpha0
+ DO ii = 1,NSI-1
+ ALPHA(K+1,ii) = MOM(NN+ii,1)*A0
+ ENDDO
+ ALPHA(K+1,NSI) = A0-SUM(ALPHA(K+1,1:NSI-1))
+ K = K + 1
+ NN = NN + NSI-1
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+C Importance sampling
+C Sample THIS from N(THHAT,SIGHAT) with boundaries
+C Evaluate p(THIS) ~ N(THHAT,SIGHAT)
+ NIM = 1000000
+ ERRM = 1.D-8
+
+C Normalization constants TRC and TRCD
+ lb(1:NPARTH) = thetaprior(NPOS(1:NPARTH),3)
+ ub(1:NPARTH) = thetaprior(NPOS(1:NPARTH),4)
+ CALL mvncdf(lb(1:NPARTH),ub(1:NPARTH),parm(1:NPARTH),
+ 1 SIGM(1:NPARTH,1:NPARTH),NPARTH,ERRM,NIM,TRC,ERR,NI)
+
+C Inverse SIGM & det for NPARTH
+ COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+ IFAIL = -1
+C CALL F01ADF(NPARTH,COM(1:NPARTH+1,1:NPARTH),NPARTH+1,IFAIL) ! Inverse var-covar
+ CALL DPOTRF('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = L*L'
+ DET = 1.D0 ! det(SIGM)
+ DO I=1,NPARTH
+ DET = DET*COM(I,I)**2
+ ENDDO
+ CALL DPOTRI('L',NPARTH,COM(1:NPARTH,1:NPARTH),NPARTH,IFAIL) ! COM = VV^-1
+
+ DO 60 I=1,NPARTH
+ ISIGM(I,I) = COM(I,I)
+ DO 60 J=1,I-1
+ ISIGM(I,J) = COM(I,J)
+60 ISIGM(J,I) = ISIGM(I,J)
+
+c COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+c IFAIL = -1
+c CALL F03ABF(COM(1:NPARTH,1:NPARTH),NPARTH,NPARTH,DET,
+c 1 WORK(1:NPARTH),IFAIL)
+
+ C = (2.D0*PI)**(-.5D0*NPARTH)/DSQRT(DET) ! constant
+
+ ALLOCATE (MAT(G,2),VHN(G,2),VHD(G,2),VQN(G,2),VQD(G,2))
+ QS = ONE
+ PS = ONE
+ IS(:,:) = 1
+ DO 200 IG = 1,G
+C SAMPLING THETA
+ SEGA(:) = -1.D0
+ IFAIL = -1
+ IND(1) = 0
+ INDC(1) = -1.D0
+ DO WHILE (INDC(1).LT.ZERO)
+ INDC(1) = ZERO
+ IND(1) = IND(1) + 1
+ IF (IND(1).GT.G) EXIT
+c CALL G05EAF(parm(1:NPARTH),NPARTH,SIGM(1:NPARTH,1:NPARTH),
+c 1 NPARTH,EPS,R3,(NPARTH+1)*(NPARTH+2)/2,IFAIL)
+c CALL G05EZF(SEGA(1:NPARTH),NPARTH,R3,(NPARTH+1)*(NPARTH+2)/2,
+c 1 IFAIL)
+ COM(1:NPARTH,1:NPARTH) = SIGM(1:NPARTH,1:NPARTH)
+ CALL setgmn(parm(1:NPARTH),COM(1:NPARTH,1:NPARTH),NPARTH,
1 NPARTH,R3(1:(NPARTH+2)*(NPARTH+1)/2))
- CALL genmn(R3(1:(NPARTH+2)*(NPARTH+1)/2),SEGA(1:NPARTH),
- 1 WORK(1:NPARTH))
- DO I=1,NPARTH
- IF (SEGA(I).LT.thetaprior(NPOS(I),3)) INDC(1)=-1
- IF (SEGA(I).GT.thetaprior(NPOS(I),4)) INDC(1)=-2
- ENDDO
- END DO
-C SAMPLING PSI from Dirichlet(ALPHA)
- NN = NPARTH
- K = 0
- DO 70 I = 1,nv
- NSI = INFOS(8,I) ! # of states for SI
- ALLOCATE(GAM(NSI))
- IF (INFOS(9,I).EQ.1) THEN ! S~IID
- DO ii = 1,NSI
- IFAIL = -1
-C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
- GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
- ENDDO
- SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
- K = K + 1
- NN = NN + NSI-1
- ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
- DO jj = 1,NSI
- DO ii = 1,NSI
- IFAIL = -1
-C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
- GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
- ENDDO
- SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
- K = K + 1
- NN = NN + NSI-1
- ENDDO
- ENDIF
-70 DEALLOCATE(GAM)
-
-C SAMPLING S
- IF (nv.GT.0) THEN
- CALL DESIGNZ(nv,np(1),SEGA(NPARTH+1:NPAR),INFOS,
- 1 P1,P2,P3,P4,P5,P6)
-C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-C S(1)
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PTR(1,ISEQ,1)
- DO 80 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-80 AUX = AUX + PTR(1,ISEQ,1)
- CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(1,:))
- QS = PTR(1,ISEQ,1)
- PS = PE(ISEQ) ! P(S1)
- ISEQ0 = ISEQ
-C S(2),...,S(nobs)
- DO 90 K = 2,nobs
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0)
- ISEQ = 1
- AUX = PTR(K,ISEQ,ISEQ0)
- DO 85 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-85 AUX = AUX + PTR(K,ISEQ,ISEQ0)
- CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(K,:))
- QS = QS*PTR(K,ISEQ,ISEQ0)
- PS = PS*PMAT(ISEQ,ISEQ0)
-90 ISEQ0 = ISEQ
- ENDIF
-
-C QUADRATIC FORM FOR for THETA
- DO 91 I = 1,NPARTH
-91 COM(I,1) = SUM((SEGA(1:NPARTH)-parm(1:NPARTH))*ISIGM(1:NPARTH,I))
- MUC = SUM(COM(1:NPARTH,1)*(SEGA(1:NPARTH)-parm(1:NPARTH)))
-
-C VQN(IG,1) = QS*C*DEXP(-.5D0*MUC)/TRC
-
- par(NPOS(1:NPARTH+np(1))) = SEGA(1:NPARTH+np(1)) ! (THETA,PSI)
-
-C PRIOR for THETA
- DO 92 I = 2,NPARTH
-92 Ppar(I) = PRIOR(par(NPOS(I)),thetaprior(NPOS(I),:),tipo(NPOS(I)))
-
-C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
- QPSI = 0.D0
- NN = NPARTH
- K = 0
- DO 100 J = 1,nv
- NSI = INFOS(8,J)
- IF(INFOS(9,J).EQ.1) THEN ! S~IID
- Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
- NN = NN + NSI-1
- ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
- DO 99 I = 1,NSI
- Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
-99 NN = NN + NSI-1
- ENDIF
-100 CONTINUE
-
- Fpar = PTHETA2(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,
- 1 par(1:nt),thetaprior(NPOS(1),:),
- 2 tipo(NPOS(1)),pdll)
- Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
-
- VQN(IG,1) = DEXP(QPSI)*QS*C*DEXP(-.5D0*MUC)/TRC
-
-200 VHN(IG,1) = Fpar + DLOG(PS)
-
-C ---------------------
-C Meng-Wong denominator
-C ---------------------
- QS = ONE
- PS = ONE
- DO 400 IG = 1,G
- IF (nv.GT.0) THEN
- CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
- 1 P1,P2,P3,P4,P5,P6)
-C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-
- QS = PTR(1,gibZ(IG,1),1)
- PS = PE(gibZ(IG,1))
- CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
- DO 210 K = 2,nobs
- QS = QS*PTR(K,gibZ(IG,K),gibZ(IG,K-1))
- PS = PS*PMAT(gibZ(IG,K),gibZ(IG,K-1))
-210 CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
- ENDIF
-
-C PRIOR for THETA
- DO 310 I = 2,NPARTH
-310 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
- 1 tipo(NPOS(I)))
-
-C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
- QPSI = 0.D0
- NN = NPARTH
- K = 0
- DO 305 J = 1,nv
- NSI = INFOS(8,J)
- IF(INFOS(9,J).EQ.1) THEN ! S~IID
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
- NN = NN + NSI-1
- ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
- DO 304 I = 1,NSI
- Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 psiprior(K+1,1:NSI),NSI)
- QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
- 1 ALPHA(K+1,1:NSI),NSI)
- K = K + 1
-304 NN = NN + NSI-1
- ENDIF
-305 CONTINUE
-
- Fpar = PTHETA2(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,
- 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
- 2 tipo(NPOS(1)),pdll)
- Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
-
- VHD(IG,1) = Fpar + DLOG(PS)
-
- COM(:,1) = ZERO
- DO 320 I = 1,NPARTH
-320 COM(I,1) = SUM((gibpar(IG,NPOS(1:NPARTH))-parm(1:NPARTH))
- # * ISIGM(1:NPARTH,I))
- MUC = SUM(COM(1:NPARTH,1)*(gibpar(IG,NPOS(1:NPARTH))
- # - parm(1:NPARTH)))
-
- VQD(IG,1) = DEXP(QPSI)*QS*DEXP(-.5D0*MUC)*C/TRC
-400 CONTINUE
-
- IND = MAXLOC(VHN(:,1))
- DET = VHN(IND(1),1)
-
- MAT(:,1) = DEXP(VHN(:,1)-DET)/(DEXP(VHN(:,1)-MLSTART)+VQN(:,1))
- MAT(:,2) = VQD(:,1)/(DEXP(VHD(:,1)-MLSTART)+VQD(:,1))
-
- CALL NEWEYWESTCOV(G,2,1,MAT(:,1:2),SS)
- MLMW(2,1) = SUM(MAT(:,1))/SUM(MAT(:,2))
- MLMW(1,1) = DLOG(MLMW(2,1)) + DET
- MLMW(1:2,2) = SS(1,1)*G/SUM(MAT(:,1))**2 +
- + SS(2,2)*G/SUM(MAT(:,2))**2 +
- + - 2.D0*SS(1,2)*G/(SUM(MAT(:,1))*SUM(MAT(:,2)))
-
- MLMW(2,1) = MLMW(1,1) ! log scale
- DO 500 I=1,10
- MWNUM = SUM(DEXP(VHN(:,1)-DET)
- 1 / (DEXP(VHN(:,1)-MLMW(2,1))+VQN(:,1)))
- MWDEN = SUM(VQD(:,1)/(DEXP(VHD(:,1)-MLMW(2,1))+VQD(:,1)))
- MLMW(2,1) = DLOG(MWNUM/MWDEN) + DET ! log-scale
-500 CONTINUE
-
- DEALLOCATE (MAT,VHN,VHD,VQN,VQD)
- IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
-
- RETURN
+ CALL genmn(R3(1:(NPARTH+2)*(NPARTH+1)/2),SEGA(1:NPARTH),
+ 1 WORK(1:NPARTH))
+ DO I=1,NPARTH
+ IF (SEGA(I).LT.thetaprior(NPOS(I),3)) INDC(1)=-1
+ IF (SEGA(I).GT.thetaprior(NPOS(I),4)) INDC(1)=-2
+ ENDDO
+ END DO
+C SAMPLING PSI from Dirichlet(ALPHA)
+ NN = NPARTH
+ K = 0
+ DO 70 I = 1,nv
+ NSI = INFOS(8,I) ! # of states for SI
+ ALLOCATE(GAM(NSI))
+ IF (INFOS(9,I).EQ.1) THEN ! S~IID
+ DO ii = 1,NSI
+ IFAIL = -1
+C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
+ GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
+ ENDDO
+ SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF (INFOS(9,I).EQ.2) THEN ! S~Markov
+ DO jj = 1,NSI
+ DO ii = 1,NSI
+ IFAIL = -1
+C CALL G05FFF(ALPHA(K+1,ii),1.D0,1,GAM(ii),IFAIL)
+ GAM(ii) = gengam(1.D0,ALPHA(K+1,ii))
+ ENDDO
+ SEGA(NN+1:NN+NSI-1) = GAM(1:NSI-1)/SUM(GAM(1:NSI))
+ K = K + 1
+ NN = NN + NSI-1
+ ENDDO
+ ENDIF
+70 DEALLOCATE(GAM)
+
+C SAMPLING S
+ IF (nv.GT.0) THEN
+ CALL DESIGNZ(nv,np(1),SEGA(NPARTH+1:NPAR),INFOS,
+ 1 P1,P2,P3,P4,P5,P6)
+C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+C S(1)
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PTR(1,ISEQ,1)
+ DO 80 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+80 AUX = AUX + PTR(1,ISEQ,1)
+ CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(1,:))
+ QS = PTR(1,ISEQ,1)
+ PS = PE(ISEQ) ! P(S1)
+ ISEQ0 = ISEQ
+C S(2),...,S(nobs)
+ DO 90 K = 2,nobs
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0)
+ ISEQ = 1
+ AUX = PTR(K,ISEQ,ISEQ0)
+ DO 85 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+85 AUX = AUX + PTR(K,ISEQ,ISEQ0)
+ CALL INT2SEQ(ISEQ,nv,INFOS,SEQ,IS(K,:))
+ QS = QS*PTR(K,ISEQ,ISEQ0)
+ PS = PS*PMAT(ISEQ,ISEQ0)
+90 ISEQ0 = ISEQ
+ ENDIF
+
+C QUADRATIC FORM FOR for THETA
+ DO 91 I = 1,NPARTH
+91 COM(I,1) = SUM((SEGA(1:NPARTH)-parm(1:NPARTH))*ISIGM(1:NPARTH,I))
+ MUC = SUM(COM(1:NPARTH,1)*(SEGA(1:NPARTH)-parm(1:NPARTH)))
+
+C VQN(IG,1) = QS*C*DEXP(-.5D0*MUC)/TRC
+
+ par(NPOS(1:NPARTH+np(1))) = SEGA(1:NPARTH+np(1)) ! (THETA,PSI)
+
+C PRIOR for THETA
+ DO 92 I = 2,NPARTH
+92 Ppar(I) = PRIOR(par(NPOS(I)),thetaprior(NPOS(I),:),tipo(NPOS(I)))
+
+C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
+ QPSI = 0.D0
+ NN = NPARTH
+ K = 0
+ DO 100 J = 1,nv
+ NSI = INFOS(8,J)
+ IF(INFOS(9,J).EQ.1) THEN ! S~IID
+ Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
+ DO 99 I = 1,NSI
+ Ppar(NPARTH+K+1) = PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(par(NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+99 NN = NN + NSI-1
+ ENDIF
+100 CONTINUE
+
+ Fpar = PTHETA2(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,
+ 1 par(1:nt),thetaprior(NPOS(1),:),
+ 2 tipo(NPOS(1)),pdll)
+ Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
+
+ VQN(IG,1) = DEXP(QPSI)*QS*C*DEXP(-.5D0*MUC)/TRC
+
+200 VHN(IG,1) = Fpar + DLOG(PS)
+
+C ---------------------
+C Meng-Wong denominator
+C ---------------------
+ QS = ONE
+ PS = ONE
+ DO 400 IG = 1,G
+ IF (nv.GT.0) THEN
+ CALL DESIGNZ(nv,np(1),gibpar(IG,nt+1:nt+np(1)),INFOS,
+ 1 P1,P2,P3,P4,P5,P6)
+C PMAT(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+
+ QS = PTR(1,gibZ(IG,1),1)
+ PS = PE(gibZ(IG,1))
+ CALL INT2SEQ(gibZ(IG,1),nv,INFOS,SEQ,IS(1,:))
+ DO 210 K = 2,nobs
+ QS = QS*PTR(K,gibZ(IG,K),gibZ(IG,K-1))
+ PS = PS*PMAT(gibZ(IG,K),gibZ(IG,K-1))
+210 CALL INT2SEQ(gibZ(IG,K),nv,INFOS,SEQ,IS(K,:))
+ ENDIF
+
+C PRIOR for THETA
+ DO 310 I = 2,NPARTH
+310 Ppar(I) = PRIOR(gibpar(IG,NPOS(I)),thetaprior(NPOS(I),:),
+ 1 tipo(NPOS(I)))
+
+C PRIOR for PSI and Q(PSI)~Dirichlet(a1,a2,...,aN)
+ QPSI = 0.D0
+ NN = NPARTH
+ K = 0
+ DO 305 J = 1,nv
+ NSI = INFOS(8,J)
+ IF(INFOS(9,J).EQ.1) THEN ! S~IID
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+ NN = NN + NSI-1
+ ELSEIF(INFOS(9,J).EQ.2) THEN ! S~Markov
+ DO 304 I = 1,NSI
+ Ppar(NPARTH+K+1) = PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 psiprior(K+1,1:NSI),NSI)
+ QPSI = QPSI+PRIORDIR(gibpar(IG,NPOS(NN+1:NN+NSI-1)),
+ 1 ALPHA(K+1,1:NSI),NSI)
+ K = K + 1
+304 NN = NN + NSI-1
+ ENDIF
+305 CONTINUE
+
+ Fpar = PTHETA2(NPOS(1),nobs,d,ny,nz,nx,nu,ns,nt,IS,yk,
+ 1 gibpar(IG,1:nt),thetaprior(NPOS(1),:),
+ 2 tipo(NPOS(1)),pdll)
+ Fpar = Fpar + SUM(Ppar(2:NPARTH+K)) ! log f(y|par,S)f(par,S)
+
+ VHD(IG,1) = Fpar + DLOG(PS)
+
+ COM(:,1) = ZERO
+ DO 320 I = 1,NPARTH
+320 COM(I,1) = SUM((gibpar(IG,NPOS(1:NPARTH))-parm(1:NPARTH))
+ # * ISIGM(1:NPARTH,I))
+ MUC = SUM(COM(1:NPARTH,1)*(gibpar(IG,NPOS(1:NPARTH))
+ # - parm(1:NPARTH)))
+
+ VQD(IG,1) = DEXP(QPSI)*QS*DEXP(-.5D0*MUC)*C/TRC
+400 CONTINUE
+
+ IND = MAXLOC(VHN(:,1))
+ DET = VHN(IND(1),1)
+
+ MAT(:,1) = DEXP(VHN(:,1)-DET)/(DEXP(VHN(:,1)-MLSTART)+VQN(:,1))
+ MAT(:,2) = VQD(:,1)/(DEXP(VHD(:,1)-MLSTART)+VQD(:,1))
+
+ CALL NEWEYWESTCOV(G,2,1,MAT(:,1:2),SS)
+ MLMW(2,1) = SUM(MAT(:,1))/SUM(MAT(:,2))
+ MLMW(1,1) = DLOG(MLMW(2,1)) + DET
+ MLMW(1:2,2) = SS(1,1)*G/SUM(MAT(:,1))**2 +
+ + SS(2,2)*G/SUM(MAT(:,2))**2 +
+ + - 2.D0*SS(1,2)*G/(SUM(MAT(:,1))*SUM(MAT(:,2)))
+
+ MLMW(2,1) = MLMW(1,1) ! log scale
+ DO 500 I=1,10
+ MWNUM = SUM(DEXP(VHN(:,1)-DET)
+ 1 / (DEXP(VHN(:,1)-MLMW(2,1))+VQN(:,1)))
+ MWDEN = SUM(VQD(:,1)/(DEXP(VHD(:,1)-MLMW(2,1))+VQD(:,1)))
+ MLMW(2,1) = DLOG(MWNUM/MWDEN) + DET ! log-scale
+500 CONTINUE
+
+ DEALLOCATE (MAT,VHN,VHD,VQN,VQD)
+ IF (nv.GT.0) DEALLOCATE (PTR,PMAT,PE,ALPHA,MOM)
+
+ RETURN
END
diff --git a/missing.for b/missing.for
index 60aa72dabc6c03696ae740e3bf0c5dee005bf5eb..e7dfacdd23af6a2b51637b50a7c0e7502c9fe81a 100644
--- a/missing.for
+++ b/missing.for
@@ -1,13 +1,13 @@
-C --------------------------------------------------------------------
-C MISSING Simulates missing observations
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C MISSING Simulates missing observations
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,65 +18,65 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE MISSING(yk,ny,nz,nx,nu,ns,nt,nmis,theta,S,STATE,pdll,ykmis)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia)
- POINTER (pdesign,DESIGN)
-
-C INPUT
- INTEGER ny,nz,nx,nu,nt,ns(6),nmis
- DOUBLE PRECISION yk(ny+nz),theta(nt),STATE(nx)
-
-C OUTPUT
- DOUBLE PRECISION ykmis(nmis)
-C LOCALS
- INTEGER S(6),I,J,K,IFAIL,NIYK(ny)
- DOUBLE PRECISION U(nu)
- DOUBLE PRECISION gennor
- DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:)
-
- ALLOCATE(R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)))
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-
-C NIYK = not(IYK)
- K = 0
- DO 10 J = 1,ny
- IF(yk(J).EQ.-99999.D0) THEN
- K = K+1
- NIYK(K) = J
-10 ENDIF
-
-C SAMPLING U
- IFAIL = -1
- U(1:nu) = 0.D0
- DO 20 I = 1,nu
-c CALL G05EAF(U(I),1,1.D0,1,1.D-14,WORKU,3,IFAIL)
-c20 CALL G05EZF(U(I),1,WORKU,3,IFAIL)
-20 U(I) = gennor(0.D0,1.D0)
-
-
-C DRAW yk ~ f(yk|x,S,zk,theta)
- DO 30 I = 1,nmis
-30 ykmis(I) = SUM(c(NIYK(I),1:nz,S(1))*yk(ny+1:ny+nz))
- + + SUM(H(NIYK(I),1:nx,S(2))*STATE(1:nx))
- + + SUM(G(NIYK(I),1:nu,S(3))*U(1:nu))
-
- DEALLOCATE (R,c,H,G,a,F)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE MISSING(yk,ny,nz,nx,nu,ns,nt,nmis,theta,S,STATE,pdll,ykmis)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia)
+ POINTER (pdesign,DESIGN)
+
+C INPUT
+ INTEGER ny,nz,nx,nu,nt,ns(6),nmis
+ DOUBLE PRECISION yk(ny+nz),theta(nt),STATE(nx)
+
+C OUTPUT
+ DOUBLE PRECISION ykmis(nmis)
+C LOCALS
+ INTEGER S(6),I,J,K,IFAIL,NIYK(ny)
+ DOUBLE PRECISION U(nu)
+ DOUBLE PRECISION gennor
+ DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:)
+
+ ALLOCATE(R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)))
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+
+C NIYK = not(IYK)
+ K = 0
+ DO 10 J = 1,ny
+ IF(yk(J).EQ.-99999.D0) THEN
+ K = K+1
+ NIYK(K) = J
+10 ENDIF
+
+C SAMPLING U
+ IFAIL = -1
+ U(1:nu) = 0.D0
+ DO 20 I = 1,nu
+c CALL G05EAF(U(I),1,1.D0,1,1.D-14,WORKU,3,IFAIL)
+c20 CALL G05EZF(U(I),1,WORKU,3,IFAIL)
+20 U(I) = gennor(0.D0,1.D0)
+
+
+C DRAW yk ~ f(yk|x,S,zk,theta)
+ DO 30 I = 1,nmis
+30 ykmis(I) = SUM(c(NIYK(I),1:nz,S(1))*yk(ny+1:ny+nz))
+ + + SUM(H(NIYK(I),1:nx,S(2))*STATE(1:nx))
+ + + SUM(G(NIYK(I),1:nu,S(3))*U(1:nu))
+
+ DEALLOCATE (R,c,H,G,a,F)
+
+ RETURN
END
diff --git a/ml.for b/ml.for
index c3c9afbbbcecef0a13c60dd56ccd0e6346e34016..b419f460c65c0356b44934a92aa3782de6175094 100644
--- a/ml.for
+++ b/ml.for
@@ -1,27 +1,27 @@
-C --------------------------------------------------------------------
-C ML estimates model parameters theta by maximum likelihood
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C ML estimates model parameters theta by maximum likelihood
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -32,236 +32,236 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE ML(nobs,d,ny,nz,nx,nu,nt,nv,ns,np,INFOS,pdll,INDT,yk,IYK,
- 1 S,thetaprior,theta,psi,IMSVAR,HESS,FOPT)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
-C INTEGER POINTER pdll
- POINTER (pdll,fittizia)
- POINTER (pdesign,DESIGN)
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,nt,nv,ns(6),np,INFOS(9,6),
- 1 INDT(nt+2),IYK(nobs,ny+1),S(nobs,6)
- DOUBLE PRECISION thetaprior(nt,4),yk(nobs,ny+nz)
-
-C OUTPUT
- INTEGER IMSVAR
- DOUBLE PRECISION FOPT,theta(nt),psi(max(1,np)),
- 1 HESS((nt+np)*(nt+np+1)/2)
-
-C LOCALS
- INTEGER NPAR,NTHETA,I,J,K,IFAIL,IFAILNEW,IOPT,NCLIN,NCNLN,LDA,ITER,
- 1 LDCJ,LWORK,LIWORK
- DOUBLE PRECISION FOPTNEW
- INTEGER, ALLOCATABLE:: ISTATE(:),IWORK(:)
- INTEGER*8, ALLOCATABLE:: IU(:)
- DOUBLE PRECISION, ALLOCATABLE:: CHINEW(:),CHI(:),LBV(:),UBV(:),
- 1 CLAMDA(:),OBJGRD(:),WORK(:),CC(:),U(:),CJAC(:,:),RR(:,:),AA(:,:)
- DOUBLE PRECISION, ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),
- 2 a(:,:),F(:,:,:),R(:,:,:)
- EXTERNAL FUNCT1,E04UCF,E04UEF,CONFUN
-
- NTHETA = INDT(nt+2)! # of free parameters theta
- NPAR = NTHETA+np ! # of parameters (total)
-
-C Check if the model is an MS-VAR(1):
-C d(1)=d(2)=0, H=I(nx), G=0
- IMSVAR=0
- ALLOCATE(c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-C Check H (ny x nx x ns(2)) and G (ny x nu x ns(3))
- IF ((nx.EQ.ny).AND.(SUM(d).EQ.0)) THEN
- IMSVAR = 1
- DO I = 1,ny
- IF (H(I,I,1).NE.1.D0) THEN
- IMSVAR = 0
- GO TO 123
- ENDIF
- DO J = 1,I-1
- IF (H(I,J,1).NE.0.D0) THEN
- IMSVAR = 0
- GO TO 123
- ENDIF
- ENDDO
- DO J = I+1,ny
- IF (H(I,J,1).NE.0.D0) THEN
- IMSVAR = 0
- GO TO 123
- ENDIF
- ENDDO
- IF (SUM(DABS(G(I,1:nu,1))).NE.0.D0) THEN
- IMSVAR = 0
- GO TO 123
- ENDIF
- ENDDO
- ENDIF
-
-123 DEALLOCATE(c,H,G,a,F,R)
-C Shrink theta, LB and UB
- ALLOCATE(CHINEW(NPAR),CHI(NPAR))
-
-C Starting values - set via the 1st entry of th prior when possible
- DO I = 1,NTHETA
- IF ((thetaprior(INDT(I),1).LT.thetaprior(INDT(I),3)).OR.
- # (thetaprior(INDT(I),1).GT.thetaprior(INDT(I),4))) THEN
- CHINEW(I) = theta(INDT(I))
- ELSE
- CHINEW(I) = thetaprior(INDT(I),1)
- ENDIF
- ENDDO
-C Starting values for PSI
- CHINEW(NTHETA+1:NPAR) = psi(1:np)
-
-C Linear constraints for transition probabilities
-C LBV <= AA*theta <= UBV
- NCLIN = 0
- DO I = 1,nv
- IF(INFOS(9,I).EQ.1) THEN ! Independent
- NCLIN = NCLIN+1
- ELSEIF(INFOS(9,I).EQ.2) THEN ! Markov
- NCLIN = NCLIN+INFOS(8,I)
- ENDIF
- ENDDO
-
-C Lower and upper bounds
- ALLOCATE(LBV(NPAR+NCLIN),UBV(NPAR+NCLIN),AA(NCLIN,NPAR))
- LBV(1:NTHETA) = thetaprior(INDT(1:NTHETA),3)
- UBV(1:NTHETA) = thetaprior(INDT(1:NTHETA),4)
- LBV(NTHETA+1:NPAR) = 1.D-3
- LBV(NPAR+1:NPAR+NCLIN) = 1.D-6
- UBV(NTHETA+1:NPAR) = 1.D0-1.D-3
- UBV(NPAR+1:NPAR+NCLIN) = 1.D0-1.D-6
- K = NTHETA
- J = 1
- AA(:,:) = 0.D0
- DO I = 1,nv
- IF(INFOS(9,I).EQ.1) THEN ! Independent
- AA(J,K+1:K+INFOS(8,I)-1) = 1.D0
- K = K+INFOS(8,I)-1
- J = J+1
- ELSEIF(INFOS(9,I).EQ.2) THEN ! Markov
- DO ITER = 1,INFOS(8,I)
- AA(J,K+1:K+INFOS(8,I)-1) = 1.D0
- K = K+INFOS(8,I)-1
- J = J+1
- ENDDO
- ENDIF
- ENDDO
-
-C --------------------------------------------------------
-C Set E04UCF parameters: IU all integers, U data + bounds
-C --------------------------------------------------------
- ALLOCATE (IU(72),U(nobs*(2*ny+nz+7)+3*nt+2))
- IU(1) = nobs
- IU(2:3) = d(1:2)
- IU(4) = ny
- IU(5) = nz
- IU(6) = nx
- IU(7) = nu
- IU(8) = nt
- IU(9:14)= ns(1:6)
- IU(15) = pdll
- IU(16) = nv
- DO J=1,6
- IU(17+9*(J-1):16+J*9) = INFOS(1:9,J)
- ENDDO
- IU(71) = np
- IU(72) = IMSVAR
-
- DO J=1,ny+nz
- U(1+nobs*(J-1):J*nobs) = yk(:,J)
- ENDDO
- U(nobs*(ny+nz)+1:nobs*(ny+nz)+nt) = thetaprior(1:nt,3)
- U(nobs*(ny+nz)+nt+1:nobs*(ny+nz)+2*nt) = thetaprior(1:nt,4)
- I = nobs*(ny+nz)+2*nt+1
- U(I:I+nt+1) = INDT(1:nt+2)
- I = I+nt+2
- DO J=1,ny+1
- U(I+nobs*(J-1):I-1+nobs*J) = IYK(1:nobs,J)
- ENDDO
- I = I+nobs*(ny+1)
- DO J = 1,6
- U(I+(J-1)*nobs:I-1+J*nobs) = S(1:nobs,J)
- ENDDO
-
-C -----------------------------------------------
-C Likelihood Maximization via E04UCF (NAG mk.17)
-C -----------------------------------------------
- CALL E04UEF('Derivative level = 0')
- CALL E04UEF('Hessian = Yes')
- CALL E04UEF('Major iteration limit = 400')
- CALL E04UEF('Minor iteration limit = 300')
- CALL E04UEF('Cold start')
- CALL E04UEF('Major print level = 1')
- IOPT = 0
- FOPT = 1D100
- NCNLN = 0
- LDA = max(1,NCLIN)
- LDCJ = max(1,NCNLN)
- LWORK = 2*NPAR**2+20*NPAR+11*NCLIN
- LIWORK=3*NPAR+2*NCNLN+NCLIN
- ALLOCATE(ISTATE(NPAR+NCNLN+NCLIN),IWORK(LIWORK),
- 1 CLAMDA(NPAR+NCNLN+NCLIN),OBJGRD(NPAR),WORK(LWORK),CC(LDCJ),
- 1 CJAC(LDCJ,NPAR),RR(NPAR,NPAR))
-
-1234 IFAILNEW = -1
- CALL E04UCF(NPAR,NCLIN,NCNLN,LDA,LDCJ,NPAR,AA,LBV,UBV,CONFUN,
- 1 FUNCT1,ITER,ISTATE,CC,CJAC,CLAMDA,FOPTNEW,OBJGRD,RR,CHINEW,
- 2 IWORK,LIWORK,WORK,LWORK,IU,U,IFAILNEW)
-
-C Hessian matrix for theta and psi
- IF (IOPT.EQ.0) THEN
- HESS(:) = 0.D0
- DO 50 I=1,NTHETA
- DO 50 J=1,I
- K = INDT(I)*(INDT(I)+1)/2-INDT(I)+INDT(J)
-50 HESS(K) = SUM(RR(:,I)*RR(:,J))
-
- DO 55 I=NTHETA+1,NTHETA+np
- DO 55 J=1,NTHETA
- K = (I+nt-NTHETA)*(I+nt-NTHETA+1)/2 - (I+nt-NTHETA) + INDT(J)
-55 HESS(K) = SUM(RR(:,I)*RR(:,J))
-
- DO 60 I=NTHETA+1,NTHETA+np
- DO 60 J=NTHETA+1,I
- K = (I+nt-NTHETA)*(I+nt-NTHETA+1)/2 - I + J
-60 HESS(K) = SUM(RR(:,I)*RR(:,J))
- ENDIF
-
- IF (FOPTNEW.LT.FOPT) THEN
- CHI(:) = CHINEW(:)
- FOPT = FOPTNEW
- IFAIL = IFAILNEW
- ENDIF
-
- IF (((IFAILNEW.EQ.1).OR.(IFAILNEW.EQ.4).OR.(IFAILNEW.EQ.6))
- * .AND.(IOPT.LT.2)) THEN
-
- IOPT = IOPT + 1
- CALL E04UEF('Warm start')
- RR(:,:) = 0.D0
- DO 30 I=1,NPAR
-30 RR(I,I)=1.D0
- GO TO 1234
- ENDIF
- theta(1:nt) = thetaprior(1:nt,3)
- theta(INDT(1:NTHETA)) = CHI(1:NTHETA)
- IF (NPAR.GT.NTHETA) psi(1:np) = CHI(NTHETA+1:NPAR)
-
- DEALLOCATE (ISTATE,IWORK,CLAMDA,OBJGRD,WORK,CC,CJAC,RR,AA)
- DEALLOCATE (CHINEW,CHI,LBV,UBV,IU,U)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE ML(nobs,d,ny,nz,nx,nu,nt,nv,ns,np,INFOS,pdll,INDT,yk,IYK,
+ 1 S,thetaprior,theta,psi,IMSVAR,HESS,FOPT)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+C INTEGER POINTER pdll
+ POINTER (pdll,fittizia)
+ POINTER (pdesign,DESIGN)
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,nt,nv,ns(6),np,INFOS(9,6),
+ 1 INDT(nt+2),IYK(nobs,ny+1),S(nobs,6)
+ DOUBLE PRECISION thetaprior(nt,4),yk(nobs,ny+nz)
+
+C OUTPUT
+ INTEGER IMSVAR
+ DOUBLE PRECISION FOPT,theta(nt),psi(max(1,np)),
+ 1 HESS((nt+np)*(nt+np+1)/2)
+
+C LOCALS
+ INTEGER NPAR,NTHETA,I,J,K,IFAIL,IFAILNEW,IOPT,NCLIN,NCNLN,LDA,ITER,
+ 1 LDCJ,LWORK,LIWORK
+ DOUBLE PRECISION FOPTNEW
+ INTEGER, ALLOCATABLE:: ISTATE(:),IWORK(:)
+ INTEGER*8, ALLOCATABLE:: IU(:)
+ DOUBLE PRECISION, ALLOCATABLE:: CHINEW(:),CHI(:),LBV(:),UBV(:),
+ 1 CLAMDA(:),OBJGRD(:),WORK(:),CC(:),U(:),CJAC(:,:),RR(:,:),AA(:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),
+ 2 a(:,:),F(:,:,:),R(:,:,:)
+ EXTERNAL FUNCT1,E04UCF,E04UEF,CONFUN
+
+ NTHETA = INDT(nt+2)! # of free parameters theta
+ NPAR = NTHETA+np ! # of parameters (total)
+
+C Check if the model is an MS-VAR(1):
+C d(1)=d(2)=0, H=I(nx), G=0
+ IMSVAR=0
+ ALLOCATE(c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+C Check H (ny x nx x ns(2)) and G (ny x nu x ns(3))
+ IF ((nx.EQ.ny).AND.(SUM(d).EQ.0)) THEN
+ IMSVAR = 1
+ DO I = 1,ny
+ IF (H(I,I,1).NE.1.D0) THEN
+ IMSVAR = 0
+ GO TO 123
+ ENDIF
+ DO J = 1,I-1
+ IF (H(I,J,1).NE.0.D0) THEN
+ IMSVAR = 0
+ GO TO 123
+ ENDIF
+ ENDDO
+ DO J = I+1,ny
+ IF (H(I,J,1).NE.0.D0) THEN
+ IMSVAR = 0
+ GO TO 123
+ ENDIF
+ ENDDO
+ IF (SUM(DABS(G(I,1:nu,1))).NE.0.D0) THEN
+ IMSVAR = 0
+ GO TO 123
+ ENDIF
+ ENDDO
+ ENDIF
+
+123 DEALLOCATE(c,H,G,a,F,R)
+C Shrink theta, LB and UB
+ ALLOCATE(CHINEW(NPAR),CHI(NPAR))
+
+C Starting values - set via the 1st entry of th prior when possible
+ DO I = 1,NTHETA
+ IF ((thetaprior(INDT(I),1).LT.thetaprior(INDT(I),3)).OR.
+ # (thetaprior(INDT(I),1).GT.thetaprior(INDT(I),4))) THEN
+ CHINEW(I) = theta(INDT(I))
+ ELSE
+ CHINEW(I) = thetaprior(INDT(I),1)
+ ENDIF
+ ENDDO
+C Starting values for PSI
+ CHINEW(NTHETA+1:NPAR) = psi(1:np)
+
+C Linear constraints for transition probabilities
+C LBV <= AA*theta <= UBV
+ NCLIN = 0
+ DO I = 1,nv
+ IF(INFOS(9,I).EQ.1) THEN ! Independent
+ NCLIN = NCLIN+1
+ ELSEIF(INFOS(9,I).EQ.2) THEN ! Markov
+ NCLIN = NCLIN+INFOS(8,I)
+ ENDIF
+ ENDDO
+
+C Lower and upper bounds
+ ALLOCATE(LBV(NPAR+NCLIN),UBV(NPAR+NCLIN),AA(NCLIN,NPAR))
+ LBV(1:NTHETA) = thetaprior(INDT(1:NTHETA),3)
+ UBV(1:NTHETA) = thetaprior(INDT(1:NTHETA),4)
+ LBV(NTHETA+1:NPAR) = 1.D-3
+ LBV(NPAR+1:NPAR+NCLIN) = 1.D-6
+ UBV(NTHETA+1:NPAR) = 1.D0-1.D-3
+ UBV(NPAR+1:NPAR+NCLIN) = 1.D0-1.D-6
+ K = NTHETA
+ J = 1
+ AA(:,:) = 0.D0
+ DO I = 1,nv
+ IF(INFOS(9,I).EQ.1) THEN ! Independent
+ AA(J,K+1:K+INFOS(8,I)-1) = 1.D0
+ K = K+INFOS(8,I)-1
+ J = J+1
+ ELSEIF(INFOS(9,I).EQ.2) THEN ! Markov
+ DO ITER = 1,INFOS(8,I)
+ AA(J,K+1:K+INFOS(8,I)-1) = 1.D0
+ K = K+INFOS(8,I)-1
+ J = J+1
+ ENDDO
+ ENDIF
+ ENDDO
+
+C --------------------------------------------------------
+C Set E04UCF parameters: IU all integers, U data + bounds
+C --------------------------------------------------------
+ ALLOCATE (IU(72),U(nobs*(2*ny+nz+7)+3*nt+2))
+ IU(1) = nobs
+ IU(2:3) = d(1:2)
+ IU(4) = ny
+ IU(5) = nz
+ IU(6) = nx
+ IU(7) = nu
+ IU(8) = nt
+ IU(9:14)= ns(1:6)
+ IU(15) = pdll
+ IU(16) = nv
+ DO J=1,6
+ IU(17+9*(J-1):16+J*9) = INFOS(1:9,J)
+ ENDDO
+ IU(71) = np
+ IU(72) = IMSVAR
+
+ DO J=1,ny+nz
+ U(1+nobs*(J-1):J*nobs) = yk(:,J)
+ ENDDO
+ U(nobs*(ny+nz)+1:nobs*(ny+nz)+nt) = thetaprior(1:nt,3)
+ U(nobs*(ny+nz)+nt+1:nobs*(ny+nz)+2*nt) = thetaprior(1:nt,4)
+ I = nobs*(ny+nz)+2*nt+1
+ U(I:I+nt+1) = INDT(1:nt+2)
+ I = I+nt+2
+ DO J=1,ny+1
+ U(I+nobs*(J-1):I-1+nobs*J) = IYK(1:nobs,J)
+ ENDDO
+ I = I+nobs*(ny+1)
+ DO J = 1,6
+ U(I+(J-1)*nobs:I-1+J*nobs) = S(1:nobs,J)
+ ENDDO
+
+C -----------------------------------------------
+C Likelihood Maximization via E04UCF (NAG mk.17)
+C -----------------------------------------------
+ CALL E04UEF('Derivative level = 0')
+ CALL E04UEF('Hessian = Yes')
+ CALL E04UEF('Major iteration limit = 400')
+ CALL E04UEF('Minor iteration limit = 300')
+ CALL E04UEF('Cold start')
+ CALL E04UEF('Major print level = 1')
+ IOPT = 0
+ FOPT = 1D100
+ NCNLN = 0
+ LDA = max(1,NCLIN)
+ LDCJ = max(1,NCNLN)
+ LWORK = 2*NPAR**2+20*NPAR+11*NCLIN
+ LIWORK=3*NPAR+2*NCNLN+NCLIN
+ ALLOCATE(ISTATE(NPAR+NCNLN+NCLIN),IWORK(LIWORK),
+ 1 CLAMDA(NPAR+NCNLN+NCLIN),OBJGRD(NPAR),WORK(LWORK),CC(LDCJ),
+ 1 CJAC(LDCJ,NPAR),RR(NPAR,NPAR))
+
+1234 IFAILNEW = -1
+ CALL E04UCF(NPAR,NCLIN,NCNLN,LDA,LDCJ,NPAR,AA,LBV,UBV,CONFUN,
+ 1 FUNCT1,ITER,ISTATE,CC,CJAC,CLAMDA,FOPTNEW,OBJGRD,RR,CHINEW,
+ 2 IWORK,LIWORK,WORK,LWORK,IU,U,IFAILNEW)
+
+C Hessian matrix for theta and psi
+ IF (IOPT.EQ.0) THEN
+ HESS(:) = 0.D0
+ DO 50 I=1,NTHETA
+ DO 50 J=1,I
+ K = INDT(I)*(INDT(I)+1)/2-INDT(I)+INDT(J)
+50 HESS(K) = SUM(RR(:,I)*RR(:,J))
+
+ DO 55 I=NTHETA+1,NTHETA+np
+ DO 55 J=1,NTHETA
+ K = (I+nt-NTHETA)*(I+nt-NTHETA+1)/2 - (I+nt-NTHETA) + INDT(J)
+55 HESS(K) = SUM(RR(:,I)*RR(:,J))
+
+ DO 60 I=NTHETA+1,NTHETA+np
+ DO 60 J=NTHETA+1,I
+ K = (I+nt-NTHETA)*(I+nt-NTHETA+1)/2 - I + J
+60 HESS(K) = SUM(RR(:,I)*RR(:,J))
+ ENDIF
+
+ IF (FOPTNEW.LT.FOPT) THEN
+ CHI(:) = CHINEW(:)
+ FOPT = FOPTNEW
+ IFAIL = IFAILNEW
+ ENDIF
+
+ IF (((IFAILNEW.EQ.1).OR.(IFAILNEW.EQ.4).OR.(IFAILNEW.EQ.6))
+ * .AND.(IOPT.LT.2)) THEN
+
+ IOPT = IOPT + 1
+ CALL E04UEF('Warm start')
+ RR(:,:) = 0.D0
+ DO 30 I=1,NPAR
+30 RR(I,I)=1.D0
+ GO TO 1234
+ ENDIF
+ theta(1:nt) = thetaprior(1:nt,3)
+ theta(INDT(1:NTHETA)) = CHI(1:NTHETA)
+ IF (NPAR.GT.NTHETA) psi(1:np) = CHI(NTHETA+1:NPAR)
+
+ DEALLOCATE (ISTATE,IWORK,CLAMDA,OBJGRD,WORK,CC,CJAC,RR,AA)
+ DEALLOCATE (CHINEW,CHI,LBV,UBV,IU,U)
+ RETURN
END
diff --git a/mvncdf.for b/mvncdf.for
index 5f2bd1ed70b4741393bfe8e56340d33fad10a420..982f0fb9c26cc297f4fda9be55fb5fac67f8f34f 100644
--- a/mvncdf.for
+++ b/mvncdf.for
@@ -1,17 +1,17 @@
-C ----------------------------------------------------------------------
-C MVNCDF Multivariate normal cumulative distribution function
-C computes the multivariate Normal cumulative distribution
-C function with mean vector MU, variance matrix SIGMA inside
-C LB and UB. Algorithm due to Alan Genz (1992):
-C "Numerical Computation of Multivariate Normal Probabilities",
-C Journal of Computational and Graphical Statistics, pp. 141-149.
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C MVNCDF Multivariate normal cumulative distribution function
+C computes the multivariate Normal cumulative distribution
+C function with mean vector MU, variance matrix SIGMA inside
+C LB and UB. Algorithm due to Alan Genz (1992):
+C "Numerical Computation of Multivariate Normal Probabilities",
+C Journal of Computational and Graphical Statistics, pp. 141-149.
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -22,74 +22,74 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- SUBROUTINE MVNCDF(LB,UB,MU,SIGMA,K,EPS,NMAX,INTSUM,ERROR,N)
-
-! INPUT
- INTEGER K,NMAX
- DOUBLE PRECISION LB(K),UB(K),MU(K),SIGMA(K,K),EPS
-
-! OUTPUT
- INTEGER N
- DOUBLE PRECISION INTSUM,ERROR
-
-! LOCALS
- INTEGER IFAIL,I,J
- DOUBLE PRECISION LBC(K),UBC(K),C(K,K),F(K),E(K),D(K),Y(K)
- DOUBLE PRECISION ALPHA,VARSUM,W,DELTA,SUMCY
-
-! EXTERNAL SUBROUTINES
- EXTERNAL DPOTRF
-! EXTERNAL FUNCTIONS
- DOUBLE PRECISION CUMNORM,GENUNF,INVNORMCDF ! PPND16
-
-
- LBC(:) = LB(:) - MU(:)
- UBC(:) = UB(:) - MU(:)
- ALPHA = 2.326347874040841 ! 99-TH PERCENTILE FOR A N(0,1)
- C(1:K,1:K) = SIGMA(1:K,1:K)
- IFAIL = -1
- CALL DPOTRF('L',K,C,K,IFAIL) ! SIGMA = C*C'
-
-C INITIALIZATIONS
- F(:) = 0.D0
- D(:) = 0.D0
- E(:) = 0.D0
- Y(:) = 0.D0
- IFAIL = 0
- E(1) = CUMNORM(UBC(1)/C(1,1)) ! CDF
- IFAIL = 0
- D(1) = CUMNORM(LBC(1)/C(1,1)) ! CDF
- F(1) = E(1) - D(1)
- INTSUM = 0.D0
- N = 0
- VARSUM = 0.D0
- ERROR = EPS+1.D0
- DO WHILE ((ERROR.GT.EPS).AND.(N.LT.NMAX))
- DO 100 I = 2,K
- W = GENUNF(0.D0,1.D0)
- IF((D(I-1)+W*F(I-1)).LE.0.D0) THEN
- Y(I-1) = -10.D10
- ELSEIF ((D(I-1)+W*F(I-1)).GE.1.D0) THEN
- Y(I-1) = 10.D10
- ELSE
-C Y(I-1) = PPND16(D(I-1)+W*F(I-1),IFAIL)
- Y(I-1) = INVNORMCDF(D(I-1)+W*F(I-1))
- ENDIF
- SUMCY = 0.D0
- DO 50 J = 1, I-1
-50 SUMCY = SUMCY + C(I,J)*Y(J)
- E(I) = CUMNORM((UBC(I) - SUMCY) / C(I,I))
- IFAIL = 0
- D(I) = CUMNORM((LBC(I) - SUMCY) / C(I,I))
-100 F(I) = (E(I) - D(I))*F(I-1)
- N = N + 1
- DELTA = (F(K) - INTSUM)/DFLOAT(N)
- INTSUM = INTSUM + DELTA
- VARSUM = (N-2)*VARSUM/DFLOAT(N) + DELTA**2
- ERROR = ALPHA * DSQRT(VARSUM)
- END DO
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ SUBROUTINE MVNCDF(LB,UB,MU,SIGMA,K,EPS,NMAX,INTSUM,ERROR,N)
+
+! INPUT
+ INTEGER K,NMAX
+ DOUBLE PRECISION LB(K),UB(K),MU(K),SIGMA(K,K),EPS
+
+! OUTPUT
+ INTEGER N
+ DOUBLE PRECISION INTSUM,ERROR
+
+! LOCALS
+ INTEGER IFAIL,I,J
+ DOUBLE PRECISION LBC(K),UBC(K),C(K,K),F(K),E(K),D(K),Y(K)
+ DOUBLE PRECISION ALPHA,VARSUM,W,DELTA,SUMCY
+
+! EXTERNAL SUBROUTINES
+ EXTERNAL DPOTRF
+! EXTERNAL FUNCTIONS
+ DOUBLE PRECISION CUMNORM,GENUNF,INVNORMCDF ! PPND16
+
+
+ LBC(:) = LB(:) - MU(:)
+ UBC(:) = UB(:) - MU(:)
+ ALPHA = 2.326347874040841 ! 99-TH PERCENTILE FOR A N(0,1)
+ C(1:K,1:K) = SIGMA(1:K,1:K)
+ IFAIL = -1
+ CALL DPOTRF('L',K,C,K,IFAIL) ! SIGMA = C*C'
+
+C INITIALIZATIONS
+ F(:) = 0.D0
+ D(:) = 0.D0
+ E(:) = 0.D0
+ Y(:) = 0.D0
+ IFAIL = 0
+ E(1) = CUMNORM(UBC(1)/C(1,1)) ! CDF
+ IFAIL = 0
+ D(1) = CUMNORM(LBC(1)/C(1,1)) ! CDF
+ F(1) = E(1) - D(1)
+ INTSUM = 0.D0
+ N = 0
+ VARSUM = 0.D0
+ ERROR = EPS+1.D0
+ DO WHILE ((ERROR.GT.EPS).AND.(N.LT.NMAX))
+ DO 100 I = 2,K
+ W = GENUNF(0.D0,1.D0)
+ IF((D(I-1)+W*F(I-1)).LE.0.D0) THEN
+ Y(I-1) = -10.D10
+ ELSEIF ((D(I-1)+W*F(I-1)).GE.1.D0) THEN
+ Y(I-1) = 10.D10
+ ELSE
+C Y(I-1) = PPND16(D(I-1)+W*F(I-1),IFAIL)
+ Y(I-1) = INVNORMCDF(D(I-1)+W*F(I-1))
+ ENDIF
+ SUMCY = 0.D0
+ DO 50 J = 1, I-1
+50 SUMCY = SUMCY + C(I,J)*Y(J)
+ E(I) = CUMNORM((UBC(I) - SUMCY) / C(I,I))
+ IFAIL = 0
+ D(I) = CUMNORM((LBC(I) - SUMCY) / C(I,I))
+100 F(I) = (E(I) - D(I))*F(I-1)
+ N = N + 1
+ DELTA = (F(K) - INTSUM)/DFLOAT(N)
+ INTSUM = INTSUM + DELTA
+ VARSUM = (N-2)*VARSUM/DFLOAT(N) + DELTA**2
+ ERROR = ALPHA * DSQRT(VARSUM)
+ END DO
+
+ RETURN
END
diff --git a/mvnpdf.for b/mvnpdf.for
index cdf0a7c1185a32d77db6b859e4b840b534370f06..b0fc8d0dd81534f3ffaa6aa64106d6277441ee7a 100644
--- a/mvnpdf.for
+++ b/mvnpdf.for
@@ -1,17 +1,17 @@
-C ------------------------------------------------------------------------
-C MVNPDF returns the multivariate Normal pdf with parameters mu, SIG,
-C evaluated at x.
-C mu (px1),SIG (pxp), x (px1)
-C Bauwens et al. (1999): "Bayesian Inference in Dynamic Econometric
-C models", Oxford University Press, page 298
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------------------
+C MVNPDF returns the multivariate Normal pdf with parameters mu, SIG,
+C evaluated at x.
+C mu (px1),SIG (pxp), x (px1)
+C Bauwens et al. (1999): "Bayesian Inference in Dynamic Econometric
+C models", Oxford University Press, page 298
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -20,51 +20,51 @@ C DMM is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
-C --------------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION mvnpdf(X,mu,SIG,p)
-
-C INPUT
- INTEGER p
- DOUBLE PRECISION X(p),mu(p),SIG(p,p)
-C LOCALS
- INTEGER I,J,IFAIL
- DOUBLE PRECISION,ALLOCATABLE:: ISIG(:,:),COM(:,:)
- DOUBLE PRECISION PI,H,DET,KER
- DATA PI/3.141592653589793D0/,H/-.5D0/
-C EXTERNAL SUBROUTINES
- EXTERNAL DPOTRF,DPOTRI
-
- ALLOCATE(ISIG(p,p),COM(p+1,p))
- COM(1:p,1:p) = SIG(1:p,1:p)
- IFAIL = -1
-C CALL F01ADF(p,COM(1:p+1,1:p),p+1,IFAIL)
- CALL DPOTRF('L',p,COM(1:p,1:p),p,IFAIL) ! COM = L*L'
- DET = 1.D0 ! det(L)
- DO I =1,p
- DET = DET*COM(I,I)
- ENDDO
- CALL DPOTRI('L',p,COM(1:p,1:p),p,IFAIL) ! COM = VV^-1
-
- DO 10 I=1,p
- ISIG(I,I) = COM(I,I)
- DO 10 J=1,I-1
- ISIG(I,J) = COM(I,J)
-10 ISIG(J,I) = ISIG(I,J)
-
-C DETERMINANT of SIG
-C COM(1:p,1:p) = SIG(1:p,1:p)
-C IFAIL = -1
-C CALL F03ABF(COM(1:p,1:p),p,p,DET,WKSPCE,IFAIL)
-
-C QUADRATIC FORM (log)
- KER = 0.D0
- DO 20 I=1,p
- DO 20 J=1,p
-20 KER = KER + (X(I)-mu(I))*ISIG(I,J)*(X(J)-mu(J))
-
-C PDF
- mvnpdf = (2.*PI)**(H*p)*DET**(-1.D0)*DEXP(H*KER)
-
- DEALLOCATE(ISIG,COM)
- RETURN
+C --------------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION mvnpdf(X,mu,SIG,p)
+
+C INPUT
+ INTEGER p
+ DOUBLE PRECISION X(p),mu(p),SIG(p,p)
+C LOCALS
+ INTEGER I,J,IFAIL
+ DOUBLE PRECISION,ALLOCATABLE:: ISIG(:,:),COM(:,:)
+ DOUBLE PRECISION PI,H,DET,KER
+ DATA PI/3.141592653589793D0/,H/-.5D0/
+C EXTERNAL SUBROUTINES
+ EXTERNAL DPOTRF,DPOTRI
+
+ ALLOCATE(ISIG(p,p),COM(p+1,p))
+ COM(1:p,1:p) = SIG(1:p,1:p)
+ IFAIL = -1
+C CALL F01ADF(p,COM(1:p+1,1:p),p+1,IFAIL)
+ CALL DPOTRF('L',p,COM(1:p,1:p),p,IFAIL) ! COM = L*L'
+ DET = 1.D0 ! det(L)
+ DO I =1,p
+ DET = DET*COM(I,I)
+ ENDDO
+ CALL DPOTRI('L',p,COM(1:p,1:p),p,IFAIL) ! COM = VV^-1
+
+ DO 10 I=1,p
+ ISIG(I,I) = COM(I,I)
+ DO 10 J=1,I-1
+ ISIG(I,J) = COM(I,J)
+10 ISIG(J,I) = ISIG(I,J)
+
+C DETERMINANT of SIG
+C COM(1:p,1:p) = SIG(1:p,1:p)
+C IFAIL = -1
+C CALL F03ABF(COM(1:p,1:p),p,p,DET,WKSPCE,IFAIL)
+
+C QUADRATIC FORM (log)
+ KER = 0.D0
+ DO 20 I=1,p
+ DO 20 J=1,p
+20 KER = KER + (X(I)-mu(I))*ISIG(I,J)*(X(J)-mu(J))
+
+C PDF
+ mvnpdf = (2.*PI)**(H*p)*DET**(-1.D0)*DEXP(H*KER)
+
+ DEALLOCATE(ISIG,COM)
+ RETURN
END
diff --git a/neweywestcov.for b/neweywestcov.for
index 063bb4839275415d5a3f353bf54d96b207eb87ab..3ca25ea2e881e3b8f70dc4e0081af54623b2b2d3 100644
--- a/neweywestcov.for
+++ b/neweywestcov.for
@@ -1,18 +1,18 @@
-C ------------------------------------------------------------------------
-C NEWEYWESTCOV implements Newey and West 1987, A simple positive semi-definite
-C hetheroscedasticity and autocorrelation consistent covariance matrix,
-C Econometrica, 55, 703-08.
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT:
-C OMEGA = OMEGA0 + SUM(is=1,nq) (1-is/(nq+1))*(Omegas+Omegas')
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------------------
+C NEWEYWESTCOV implements Newey and West 1987, A simple positive semi-definite
+C hetheroscedasticity and autocorrelation consistent covariance matrix,
+C Econometrica, 55, 703-08.
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT:
+C OMEGA = OMEGA0 + SUM(is=1,nq) (1-is/(nq+1))*(Omegas+Omegas')
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -23,47 +23,47 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------------------------------
- SUBROUTINE NEWEYWESTCOV(N,nvar,NQ,MAT,OMEGA)
-! INPUT
- INTEGER N,nvar,NQ
- DOUBLE PRECISION MAT(N,nvar)
-! OUTPUT
- DOUBLE PRECISION OMEGA(nvar,nvar)
-! LOCALS
- INTEGER I,J,K,is
- DOUBLE PRECISION MEAN(nvar),OMEGAS(nvar,nvar)
- DOUBLE PRECISION, ALLOCATABLE::MAT0(:,:)
- DOUBLE PRECISION ZERO,ONE
- DATA ZERO/0.0D0/, ONE/1.0D0/
-
- ALLOCATE (MAT0(N,nvar))
- DO 10 I = 1,nvar
- MEAN(I) = sum(MAT(:,I))/dfloat(N)
-10 MAT0(:,I) = MAT(:,I) - MEAN(I) ! Remove the mean
-
- OMEGA(:,:) = ZERO ! lag-0 covariance matrix
- DO 30 I =1,nvar
- DO 30 J =1,I
- OMEGA(I,J) = sum(MAT0(:,I)*MAT0(:,J))
-30 OMEGA(J,I) = OMEGA(I,J)
- OMEGA(:,:) = OMEGA(:,:)/dfloat(N)
-
- DO 100 is = 1, NQ
- OMEGAS(:,:) = ZERO ! lag-s covariance matrix
- DO 50 I =1,nvar
- DO 50 J =1,nvar
- DO 50 K =1,N-is
-50 OMEGAS(I,J) = OMEGAS(I,J)+MAT0(K+is,I)*MAT0(K,J)/dfloat(N-is)
-
- DO 60 I =1,nvar
- DO 60 J =1,I
- OMEGA(I,J) = OMEGA(I,J) +
- + (ONE-is/dfloat(NQ+1))*(OMEGAS(J,I)+OMEGAS(I,J))
-60 OMEGA(J,I) = OMEGA(I,J)
-
-100 CONTINUE
- DEALLOCATE (MAT0)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------------------------------
+ SUBROUTINE NEWEYWESTCOV(N,nvar,NQ,MAT,OMEGA)
+! INPUT
+ INTEGER N,nvar,NQ
+ DOUBLE PRECISION MAT(N,nvar)
+! OUTPUT
+ DOUBLE PRECISION OMEGA(nvar,nvar)
+! LOCALS
+ INTEGER I,J,K,is
+ DOUBLE PRECISION MEAN(nvar),OMEGAS(nvar,nvar)
+ DOUBLE PRECISION, ALLOCATABLE::MAT0(:,:)
+ DOUBLE PRECISION ZERO,ONE
+ DATA ZERO/0.0D0/, ONE/1.0D0/
+
+ ALLOCATE (MAT0(N,nvar))
+ DO 10 I = 1,nvar
+ MEAN(I) = sum(MAT(:,I))/dfloat(N)
+10 MAT0(:,I) = MAT(:,I) - MEAN(I) ! Remove the mean
+
+ OMEGA(:,:) = ZERO ! lag-0 covariance matrix
+ DO 30 I =1,nvar
+ DO 30 J =1,I
+ OMEGA(I,J) = sum(MAT0(:,I)*MAT0(:,J))
+30 OMEGA(J,I) = OMEGA(I,J)
+ OMEGA(:,:) = OMEGA(:,:)/dfloat(N)
+
+ DO 100 is = 1, NQ
+ OMEGAS(:,:) = ZERO ! lag-s covariance matrix
+ DO 50 I =1,nvar
+ DO 50 J =1,nvar
+ DO 50 K =1,N-is
+50 OMEGAS(I,J) = OMEGAS(I,J)+MAT0(K+is,I)*MAT0(K,J)/dfloat(N-is)
+
+ DO 60 I =1,nvar
+ DO 60 J =1,I
+ OMEGA(I,J) = OMEGA(I,J) +
+ + (ONE-is/dfloat(NQ+1))*(OMEGAS(J,I)+OMEGAS(I,J))
+60 OMEGA(J,I) = OMEGA(I,J)
+
+100 CONTINUE
+ DEALLOCATE (MAT0)
+ RETURN
END
diff --git a/neweywestcov2.for b/neweywestcov2.for
index b523059e23a325ed3a444d7ec628502ecb7d7007..f257810068be0aa880539f88d59bb973072ab895 100644
--- a/neweywestcov2.for
+++ b/neweywestcov2.for
@@ -1,18 +1,18 @@
-C ------------------------------------------------------------------------
-C NEWEYWESTCOV2 implements Newey and West 1987, A simple positive semi-definite
-C hetheroscedasticity and autocorrelation consistent covariance matrix,
-C Econometrica, 55, 703-08.
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT:
-C OMEGA = OMEGA0 + SUM(is=1,nq) (1-is/(nq+1))*(Omegas+Omegas')
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------------------
+C NEWEYWESTCOV2 implements Newey and West 1987, A simple positive semi-definite
+C hetheroscedasticity and autocorrelation consistent covariance matrix,
+C Econometrica, 55, 703-08.
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT:
+C OMEGA = OMEGA0 + SUM(is=1,nq) (1-is/(nq+1))*(Omegas+Omegas')
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -23,46 +23,46 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------------------------------
- SUBROUTINE NEWEYWESTCOV2(N,nvar,NQ,MAT,MEAN,OMEGA)
-! INPUT
- INTEGER N,nvar,NQ
- DOUBLE PRECISION MAT(N,nvar),MEAN(nvar)
-! OUTPUT
- DOUBLE PRECISION OMEGA(nvar,nvar)
-! LOCALS
- INTEGER I,J,K,is
- DOUBLE PRECISION OMEGAS(nvar,nvar)
- DOUBLE PRECISION, ALLOCATABLE::MAT0(:,:)
- DOUBLE PRECISION ZERO,ONE
- DATA ZERO/0.0D0/, ONE/1.0D0/
-
- ALLOCATE (MAT0(N,nvar))
- DO 10 I = 1,nvar
-10 MAT0(:,I) = MAT(:,I) - MEAN(I) ! Remove the mean
-
- OMEGA(:,:) = ZERO ! lag-0 covariance matrix
- DO 30 I =1,nvar
- DO 30 J =1,I
- OMEGA(I,J) = sum(MAT0(:,I)*MAT0(:,J))
-30 OMEGA(J,I) = OMEGA(I,J)
- OMEGA(:,:) = OMEGA(:,:)/dfloat(N)
-
- DO 100 is = 1, NQ
- OMEGAS(:,:) = ZERO ! lag-s covariance matrix
- DO 50 I =1,nvar
- DO 50 J =1,nvar
- DO 50 K =1,N-is
-50 OMEGAS(I,J) = OMEGAS(I,J)+MAT0(K+is,I)*MAT0(K,J)/dfloat(N-is)
-
- DO 60 I =1,nvar
- DO 60 J =1,I
- OMEGA(I,J) = OMEGA(I,J) +
- + (ONE-is/dfloat(NQ+1))*(OMEGAS(J,I)+OMEGAS(I,J))
-60 OMEGA(J,I) = OMEGA(I,J)
-
-100 CONTINUE
- DEALLOCATE (MAT0)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------------------------------
+ SUBROUTINE NEWEYWESTCOV2(N,nvar,NQ,MAT,MEAN,OMEGA)
+! INPUT
+ INTEGER N,nvar,NQ
+ DOUBLE PRECISION MAT(N,nvar),MEAN(nvar)
+! OUTPUT
+ DOUBLE PRECISION OMEGA(nvar,nvar)
+! LOCALS
+ INTEGER I,J,K,is
+ DOUBLE PRECISION OMEGAS(nvar,nvar)
+ DOUBLE PRECISION, ALLOCATABLE::MAT0(:,:)
+ DOUBLE PRECISION ZERO,ONE
+ DATA ZERO/0.0D0/, ONE/1.0D0/
+
+ ALLOCATE (MAT0(N,nvar))
+ DO 10 I = 1,nvar
+10 MAT0(:,I) = MAT(:,I) - MEAN(I) ! Remove the mean
+
+ OMEGA(:,:) = ZERO ! lag-0 covariance matrix
+ DO 30 I =1,nvar
+ DO 30 J =1,I
+ OMEGA(I,J) = sum(MAT0(:,I)*MAT0(:,J))
+30 OMEGA(J,I) = OMEGA(I,J)
+ OMEGA(:,:) = OMEGA(:,:)/dfloat(N)
+
+ DO 100 is = 1, NQ
+ OMEGAS(:,:) = ZERO ! lag-s covariance matrix
+ DO 50 I =1,nvar
+ DO 50 J =1,nvar
+ DO 50 K =1,N-is
+50 OMEGAS(I,J) = OMEGAS(I,J)+MAT0(K+is,I)*MAT0(K,J)/dfloat(N-is)
+
+ DO 60 I =1,nvar
+ DO 60 J =1,I
+ OMEGA(I,J) = OMEGA(I,J) +
+ + (ONE-is/dfloat(NQ+1))*(OMEGAS(J,I)+OMEGAS(I,J))
+60 OMEGA(J,I) = OMEGA(I,J)
+
+100 CONTINUE
+ DEALLOCATE (MAT0)
+ RETURN
END
diff --git a/ols.for b/ols.for
index a57aedebfe584ba2b2ff4ee7019dabcbb6e0b6e1..87a1e9c6c233ca8be5e07a117fefe5a140c7d7e9 100644
--- a/ols.for
+++ b/ols.for
@@ -1,29 +1,29 @@
-C --------------------------------------------------
-C OLS reurns the ordinary least square estimates of
-C a linear regression
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C INPUT: matrix of regressors X (N x K),
-C vector of observations Y (N x 1)
-C N number of observation
-C K number of regressors
-C
-C OUTPUT: BETA = model parameters
-C SEB = standard error of parameters
-C SIGMA = var covar matrix of parameters
-C RES = model residuals
-C VA = variance of residuals
-C IFAULT = OUTPUT, ERROR INDICATOR:
-C 1 IF N < 1
-C 2 IF X'X IS NOT +VE SEMI-DEFINITE
-C 0 OTHERWISE
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------
+C OLS reurns the ordinary least square estimates of
+C a linear regression
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C INPUT: matrix of regressors X (N x K),
+C vector of observations Y (N x 1)
+C N number of observation
+C K number of regressors
+C
+C OUTPUT: BETA = model parameters
+C SEB = standard error of parameters
+C SIGMA = var covar matrix of parameters
+C RES = model residuals
+C VA = variance of residuals
+C IFAULT = OUTPUT, ERROR INDICATOR:
+C 1 IF N < 1
+C 2 IF X'X IS NOT +VE SEMI-DEFINITE
+C 0 OTHERWISE
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -34,63 +34,63 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------
- SUBROUTINE OLS(Y,X,N,K,BETA,SEB,SIGMA,RES,VA,IFAULT)
- INTEGER N,K
- DOUBLE PRECISION Y(N),X(N,K),BETA(K),SEB(K),SIGMA(K,K)
- DOUBLE PRECISION RES(N),VA
- INTEGER I,J,IFAULT,NULLTY
- DOUBLE PRECISION XX(K,K),invXX(K,K),LTRXX(K*(K+1)/2),W(K),
- 1 pro(K,N),RMAX
-
-C Compute X'X
- DO I = 1,K
- XX(I,I) = SUM(X(1:N,I)*X(1:N,I))
- DO J = I+1,K
- XX(I,J) = SUM(X(1:N,I)*X(1:N,J))
- XX(J,I) = XX(I,J)
- ENDDO
- ENDDO
-
-C Compute inv(X'X)
- DO 10 i=1,K
- DO 10 j=1,i
-10 LTRXX(i*(i+1)/2-i+j)=XX(i,j)
-
- CALL SYMINV(LTRXX,K,LTRXX,W,NULLTY,IFAULT,RMAX)
- DO i = 1,K
- invXX(i,i) = LTRXX(i*(i+1)/2)
- DO j = 1,i-1
- invXX(i,j) = LTRXX(i*(i+1)/2-i+j)
- invXX(j,i) = invXX(i,j)
- ENDDO
- ENDDO
-
-C beta=inv(x'*x)*x'*y;
- DO I = 1,K
- DO J = 1,N
- pro(I,J) = SUM(invXX(I,:)*X(J,:))
- ENDDO
- ENDDO
- DO I = 1,K
- beta(I) = SUM(pro(I,:)*Y(:))
- ENDDO
-
-C Residuals: res=y-x*beta
- DO I = 1,N
- RES(I) = Y(I)-SUM(X(I,:)*beta(:))
- ENDDO
-
-C Variance of residuals: va=(res'res)/n
- VA = SUM(RES(:)*RES(:))/DFLOAT(N)
-
-C Var-Covar matri:x sigma=va*inv(x'*x);
- SIGMA = VA*invXX
-
-C Coefficient Standard errors
- DO 20 i=1,K
-20 SEB(i) = dsqrt(SIGMA(i,i))
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------
+ SUBROUTINE OLS(Y,X,N,K,BETA,SEB,SIGMA,RES,VA,IFAULT)
+ INTEGER N,K
+ DOUBLE PRECISION Y(N),X(N,K),BETA(K),SEB(K),SIGMA(K,K)
+ DOUBLE PRECISION RES(N),VA
+ INTEGER I,J,IFAULT,NULLTY
+ DOUBLE PRECISION XX(K,K),invXX(K,K),LTRXX(K*(K+1)/2),W(K),
+ 1 pro(K,N),RMAX
+
+C Compute X'X
+ DO I = 1,K
+ XX(I,I) = SUM(X(1:N,I)*X(1:N,I))
+ DO J = I+1,K
+ XX(I,J) = SUM(X(1:N,I)*X(1:N,J))
+ XX(J,I) = XX(I,J)
+ ENDDO
+ ENDDO
+
+C Compute inv(X'X)
+ DO 10 i=1,K
+ DO 10 j=1,i
+10 LTRXX(i*(i+1)/2-i+j)=XX(i,j)
+
+ CALL SYMINV(LTRXX,K,LTRXX,W,NULLTY,IFAULT,RMAX)
+ DO i = 1,K
+ invXX(i,i) = LTRXX(i*(i+1)/2)
+ DO j = 1,i-1
+ invXX(i,j) = LTRXX(i*(i+1)/2-i+j)
+ invXX(j,i) = invXX(i,j)
+ ENDDO
+ ENDDO
+
+C beta=inv(x'*x)*x'*y;
+ DO I = 1,K
+ DO J = 1,N
+ pro(I,J) = SUM(invXX(I,:)*X(J,:))
+ ENDDO
+ ENDDO
+ DO I = 1,K
+ beta(I) = SUM(pro(I,:)*Y(:))
+ ENDDO
+
+C Residuals: res=y-x*beta
+ DO I = 1,N
+ RES(I) = Y(I)-SUM(X(I,:)*beta(:))
+ ENDDO
+
+C Variance of residuals: va=(res'res)/n
+ VA = SUM(RES(:)*RES(:))/DFLOAT(N)
+
+C Var-Covar matri:x sigma=va*inv(x'*x);
+ SIGMA = VA*invXX
+
+C Coefficient Standard errors
+ DO 20 i=1,K
+20 SEB(i) = dsqrt(SIGMA(i,i))
+
+ RETURN
END
diff --git a/openfiles.for b/openfiles.for
index 36998bd52d198a587d04de8dee934aa7501405af..4517fa82cec8edebcfe16033fb643cf86de1244c 100644
--- a/openfiles.for
+++ b/openfiles.for
@@ -1,13 +1,13 @@
-C --------------------------------------------------------------------------
-C OPENFILES opens files for writing the DMM output
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------------
+C OPENFILES opens files for writing the DMM output
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,81 +18,81 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------------
- SUBROUTINE OPENFILES(ESTIMATION,SEED,NV,NF,NMIS,SIMULATION,
- 1 MARGLIK,PATH,NMLNAME)
- INTEGER SEED,nv,NF,NMIS
- CHARACTER*1 SIMULATION,MARGLIK
- CHARACTER*2 ESTIMATION
- CHARACTER*3 CSEED
- CHARACTER*200 NMLNAME,PATH,FILEOUT
-
- IF ((estimation.EQ.'ML').OR.(estimation.EQ.'ml').OR.
- & (estimation.EQ.'Ml').OR.(estimation.EQ.'mL')) THEN
-
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.PAR'
- OPEN(9, FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.UNB'
- OPEN(10,FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
- IF (nv.GT.0) THEN
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.DIS'
- OPEN(11,FILE = FILEOUT, ACCESS='SEQUENTIAL')
- ENDIF
-
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.INN'
- OPEN(12, FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
- ELSE
-
- IF (SEED.LE.9) THEN
- WRITE(CSEED,'(I1)') SEED
- ELSEIF ((SEED.GE.10).AND.(SEED.LE.99)) THEN
- WRITE(CSEED,'(I2)') SEED
- ELSEIF ((SEED.GE.100).AND.(SEED.LE.999)) THEN
- WRITE(CSEED,'(I3)') SEED
- ENDIF
-
- IF (nv.GT.0) THEN
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.DIS'
- OPEN(11,FILE = FILEOUT, ACCESS='SEQUENTIAL')
- ENDIF
-
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.PAR'
- OPEN(9, FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.UNB'
- OPEN(10,FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
- IF ((SIMULATION.EQ.'N').OR.(SIMULATION.EQ.'n')) THEN
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.INN'
- OPEN(12, FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
- IF (nf.GT.0) THEN
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.FST'
- OPEN(13,FILE = FILEOUT, ACCESS='SEQUENTIAL')
- ENDIF
-
- IF (nmis.GT.0) THEN
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.MIS'
- OPEN(14,FILE = FILEOUT, ACCESS='SEQUENTIAL')
- ENDIF
-
- IF ((MARGLIK.EQ.'Y').OR.(MARGLIK.EQ.'y')) THEN
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.ML'
- OPEN(15,FILE = FILEOUT, ACCESS='SEQUENTIAL')
- ENDIF
-
- ELSE
-
- FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.DAT'
- OPEN(15,FILE = FILEOUT, ACCESS='SEQUENTIAL')
-
- ENDIF
-
- ENDIF
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------------
+ SUBROUTINE OPENFILES(ESTIMATION,SEED,NV,NF,NMIS,SIMULATION,
+ 1 MARGLIK,PATH,NMLNAME)
+ INTEGER SEED,nv,NF,NMIS
+ CHARACTER*1 SIMULATION,MARGLIK
+ CHARACTER*2 ESTIMATION
+ CHARACTER*3 CSEED
+ CHARACTER*200 NMLNAME,PATH,FILEOUT
+
+ IF ((estimation.EQ.'ML').OR.(estimation.EQ.'ml').OR.
+ & (estimation.EQ.'Ml').OR.(estimation.EQ.'mL')) THEN
+
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.PAR'
+ OPEN(9, FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.UNB'
+ OPEN(10,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+ IF (nv.GT.0) THEN
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.DIS'
+ OPEN(11,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+ ENDIF
+
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//'.INN'
+ OPEN(12, FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+ ELSE
+
+ IF (SEED.LE.9) THEN
+ WRITE(CSEED,'(I1)') SEED
+ ELSEIF ((SEED.GE.10).AND.(SEED.LE.99)) THEN
+ WRITE(CSEED,'(I2)') SEED
+ ELSEIF ((SEED.GE.100).AND.(SEED.LE.999)) THEN
+ WRITE(CSEED,'(I3)') SEED
+ ENDIF
+
+ IF (nv.GT.0) THEN
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.DIS'
+ OPEN(11,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+ ENDIF
+
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.PAR'
+ OPEN(9, FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.UNB'
+ OPEN(10,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+ IF ((SIMULATION.EQ.'N').OR.(SIMULATION.EQ.'n')) THEN
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.INN'
+ OPEN(12, FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+ IF (nf.GT.0) THEN
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.FST'
+ OPEN(13,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+ ENDIF
+
+ IF (nmis.GT.0) THEN
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.MIS'
+ OPEN(14,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+ ENDIF
+
+ IF ((MARGLIK.EQ.'Y').OR.(MARGLIK.EQ.'y')) THEN
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.ML'
+ OPEN(15,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+ ENDIF
+
+ ELSE
+
+ FILEOUT = TRIM(PATH)//TRIM(NMLNAME)//TRIM(CSEED)//'.DAT'
+ OPEN(15,FILE = FILEOUT, ACCESS='SEQUENTIAL')
+
+ ENDIF
+
+ ENDIF
+
+ RETURN
END
diff --git a/opg.for b/opg.for
index 30fa98b2f850124c0ef29806665452841033f9a0..19b1da244ea195bf4a9f73b479c924d95aadb0de 100644
--- a/opg.for
+++ b/opg.for
@@ -1,20 +1,20 @@
-C ------------------------------------------------------------
-C OPG coumputes the Var-Covar matrix of Parameters inverting
-C the Observed Information matrix calcuted by outer product
-C of gradient estimator - e.g. Davidson MacKinnon pp 265-66
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT: SE = Standard deviations;
-C IFAIL = 0 Hessian
-C IFAIL = 1 OPG
-C IFAIL = -1 Failure
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------
+C OPG coumputes the Var-Covar matrix of Parameters inverting
+C the Observed Information matrix calcuted by outer product
+C of gradient estimator - e.g. Davidson MacKinnon pp 265-66
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT: SE = Standard deviations;
+C IFAIL = 0 Hessian
+C IFAIL = 1 OPG
+C IFAIL = -1 Failure
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -25,179 +25,179 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------------------
- SUBROUTINE OPG(nobs,d,ny,nz,nx,nu,nt,ns,pdll,yk,IYK,S,
- 1 theta,thetaprior,HESS,SE,XS,AKMSE,INN,IFAIL)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-! Input
- INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),pdll,IYK(nobs,ny+1),
- 1 S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(nt,4),
- 1 HESS(nt*(nt+1)/2)
-! Output
- INTEGER IFAIL,IFAILSY
- DOUBLE PRECISION SE(nt),XS(nobs,nx),AKMSE(nobs,nx),INN(nobs,ny)
-! Locals
- INTEGER I,J,K,IFREE(nt),NFREE
- DOUBLE PRECISION DRI,RMAX
- DOUBLE PRECISION, ALLOCATABLE:: THETAV(:),DLL(:),DLLM(:),XSM(:,:),
- 1 XT(:,:),PT(:,:,:),Xdd(:,:),Pdd(:,:,:)
- DOUBLE PRECISION, ALLOCATABLE:: c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:),R(:,:,:)
- DOUBLE PRECISION, ALLOCATABLE:: GRAD(:,:),P(:),LTR(:),
- 1 W(:),OP(:,:),MAT(:,:),VC(:,:),pro(:,:)
-
- SE(:) = 0.D0
- DRI = 1.D-3
- NFREE = 0
- DO 20 I = 1,nt
- IF ((theta(I).GT.thetaprior(I,3)).AND.
- 1 (theta(I).LT.thetaprior(I,4))) THEN
- NFREE = NFREE + 1
- IFREE(NFREE) = I
-20 ENDIF
-
-C Using Hessian from E04UCF
- ALLOCATE (LTR(NFREE*(NFREE+1)/2),W(NFREE))
- DO 25 I=1,NFREE
- DO 25 J=1,I
- K = IFREE(I)*(IFREE(I)+1)/2-IFREE(I)+IFREE(J)
-25 LTR(I*(I+1)/2-I+J) = HESS(K)
- IFAIL = 0
- CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
-
- ALLOCATE(GRAD(nobs,NFREE),P(NFREE),OP(NFREE,NFREE),MAT(nobs*nx,NFREE),
- 1 VC(NFREE,NFREE),pro(nobs*nx,NFREE))
- ALLOCATE(c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
- ALLOCATE(THETAV(nt),DLL(nobs),DLLM(nobs),XSM(nobs,nx),
- 1 XT(0:nobs,nx),PT(0:nobs,nx,nx),Xdd(max(d(1),1),nx),
- 1 Pdd(max(d(1),1),nx,nx))
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-
- CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
- 2 c,H,G,a,F,R,Xdd,Pdd,DLL(1:max(d(1),1)))
- XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
- CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,DLL)
- CALL KS(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XS,
- 1 PT(1:nobs,1:nx,1:nx))
- CALL INNOV(nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta,pdll,INN)
-
- AKMSE(1:d(1),:) = 0.D0
- DO I = d(1)+1,nobs
- DO J = 1,nx
- AKMSE(I,J) = PT(I,J,J)
- END DO
- END DO
-
- THETAV(1:NFREE) = theta(IFREE(1:NFREE))
- P(1:NFREE) = THETAV(1:NFREE)*DRI
- DO I=1,NFREE
- IF(DABS(P(I)).LT.1.D-13) P(I)=1.D-13
- IF (((theta(IFREE(I))+P(I)).GT.THETAPRIOR(IFREE(I),4)).OR.
- 1 ((theta(IFREE(I))+P(I)).LT.THETAPRIOR(IFREE(I),3))) THEN
- IF (theta(IFREE(I)).GT.0.D0) THEN
- P(I) = THETAPRIOR(IFREE(I),3) - theta(IFREE(I))
- ELSE
- P(I) = THETAPRIOR(IFREE(I),4) - theta(IFREE(I))
- ENDIF
- ENDIF
- END DO
-
- DO 1000 I=1,NFREE
- THETAV(I) = THETAV(I) + P(I)
- theta(IFREE(I)) = THETAV(I)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
- 2 c,H,G,a,F,R,Xdd,Pdd,DLLM(1:max(d(1),1)))
- XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
- CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,DLLM)
- CALL KS(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XSM,
- 1 PT(1:nobs,1:nx,1:nx))
- THETAV(I) = THETAV(I) - P(I)
- theta(IFREE(I)) = THETAV(I)
- GRAD(2:nobs,I) = (DLLM(2:nobs) - DLL(2:nobs))/P(I)
-
- DO J = 1,nx ! MAT (nobs x nx) x nfree
- MAT(1+(J-1)*nobs:J*nobs,I) = (XSM(:,J)-XS(:,J))/P(I)
- ENDDO
-1000 CONTINUE
-
-C Use OPG if Hessian is bad
- IF (IFAIL.GT.0) THEN
- DO 300 I=1,NFREE
- DO 300 J=1,I
-300 OP(I,J) = SUM(GRAD(2:nobs,I)*GRAD(2:nobs,J))
-
- DO 150 I=1,NFREE
- DO 150 J=1,I
-150 LTR(i*(i+1)/2-i+j)=OP(I,J)
- IFAIL = 1
- CALL SYMINV(LTR,NFREE,LTR,W,J,IFAILSY,RMAX)
- IF (IFAILSY.NE.0) THEN
- IFAIL = -1
- GOTO 1111
- ENDIF
- ENDIF
-
-C ------------------------------------------------------
-C Computes MAT(i,:)*VC*MAT(:,i) for each i=1,2,..,nobs
-C ------------------------------------------------------
- DO 170 i=1,NFREE
- VC(i,i)=LTR(i*(i+1)/2)
- SE(IFREE(i)) = DSQRT(LTR(i*(i+1)/2))
- DO 170 j=1,i-1
- VC(i,j)=LTR(i*(i+1)/2-i+j)
-170 VC(j,i)=VC(i,j)
-
- DO 301 I = 1,nobs*nx ! pro = MAT x VC
- DO 301 J = 1,Nfree ! (nobsxnx)xnt x nt x nt
-301 pro(i,j) = SUM(MAT(i,1:NFREE)*VC(1:NFREE,j))
-
-C AKMSE: first nobs = var of nobs estimate of first state element
- DO I = d(1)+1,nobs
- DO J = 1,nx
- AKMSE(I,J) = AKMSE(I,J) + SUM(pro(nobs*(J-1)+I,1:NFREE)*
- 1 MAT(nobs*(J-1)+I,1:NFREE))
- ENDDO
- ENDDO
-
-1111 DO I = 1,nobs
- DO J = 1,nx
- AKMSE(I,J) = DSQRT(AKMSE(I,J))
- ENDDO
- ENDDO
-
- DEALLOCATE(OP,W,LTR,P,GRAD,MAT,VC,pro)
- DEALLOCATE(c,H,G,a,F,R,THETAV,DLL,DLLM,XSM,XT,PT,Xdd,Pdd)
-
- RETURN
- END
-
-cELSE
-c CALL KIM2(nobs,d,ny,nz,nx,nu,ns,PRODUCT(ns),nv,np,INFOS,yk,
-c 1 c,H,G,a,F,R,psi,1,XS,AKMSE,SSMOOTH,DLL)
-c DO I=1,NFREE
-c SE(IFREE(I)) = DSQRT(LTR(I*(I+1)/2))
-c ENDDO
-c ENDIF
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------------------
+ SUBROUTINE OPG(nobs,d,ny,nz,nx,nu,nt,ns,pdll,yk,IYK,S,
+ 1 theta,thetaprior,HESS,SE,XS,AKMSE,INN,IFAIL)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+! Input
+ INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),pdll,IYK(nobs,ny+1),
+ 1 S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(nt,4),
+ 1 HESS(nt*(nt+1)/2)
+! Output
+ INTEGER IFAIL,IFAILSY
+ DOUBLE PRECISION SE(nt),XS(nobs,nx),AKMSE(nobs,nx),INN(nobs,ny)
+! Locals
+ INTEGER I,J,K,IFREE(nt),NFREE
+ DOUBLE PRECISION DRI,RMAX
+ DOUBLE PRECISION, ALLOCATABLE:: THETAV(:),DLL(:),DLLM(:),XSM(:,:),
+ 1 XT(:,:),PT(:,:,:),Xdd(:,:),Pdd(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:),R(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE:: GRAD(:,:),P(:),LTR(:),
+ 1 W(:),OP(:,:),MAT(:,:),VC(:,:),pro(:,:)
+
+ SE(:) = 0.D0
+ DRI = 1.D-3
+ NFREE = 0
+ DO 20 I = 1,nt
+ IF ((theta(I).GT.thetaprior(I,3)).AND.
+ 1 (theta(I).LT.thetaprior(I,4))) THEN
+ NFREE = NFREE + 1
+ IFREE(NFREE) = I
+20 ENDIF
+
+C Using Hessian from E04UCF
+ ALLOCATE (LTR(NFREE*(NFREE+1)/2),W(NFREE))
+ DO 25 I=1,NFREE
+ DO 25 J=1,I
+ K = IFREE(I)*(IFREE(I)+1)/2-IFREE(I)+IFREE(J)
+25 LTR(I*(I+1)/2-I+J) = HESS(K)
+ IFAIL = 0
+ CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
+
+ ALLOCATE(GRAD(nobs,NFREE),P(NFREE),OP(NFREE,NFREE),MAT(nobs*nx,NFREE),
+ 1 VC(NFREE,NFREE),pro(nobs*nx,NFREE))
+ ALLOCATE(c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)))
+ ALLOCATE(THETAV(nt),DLL(nobs),DLLM(nobs),XSM(nobs,nx),
+ 1 XT(0:nobs,nx),PT(0:nobs,nx,nx),Xdd(max(d(1),1),nx),
+ 1 Pdd(max(d(1),1),nx,nx))
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+
+ CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
+ 2 c,H,G,a,F,R,Xdd,Pdd,DLL(1:max(d(1),1)))
+ XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+ CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,DLL)
+ CALL KS(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XS,
+ 1 PT(1:nobs,1:nx,1:nx))
+ CALL INNOV(nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,theta,pdll,INN)
+
+ AKMSE(1:d(1),:) = 0.D0
+ DO I = d(1)+1,nobs
+ DO J = 1,nx
+ AKMSE(I,J) = PT(I,J,J)
+ END DO
+ END DO
+
+ THETAV(1:NFREE) = theta(IFREE(1:NFREE))
+ P(1:NFREE) = THETAV(1:NFREE)*DRI
+ DO I=1,NFREE
+ IF(DABS(P(I)).LT.1.D-13) P(I)=1.D-13
+ IF (((theta(IFREE(I))+P(I)).GT.THETAPRIOR(IFREE(I),4)).OR.
+ 1 ((theta(IFREE(I))+P(I)).LT.THETAPRIOR(IFREE(I),3))) THEN
+ IF (theta(IFREE(I)).GT.0.D0) THEN
+ P(I) = THETAPRIOR(IFREE(I),3) - theta(IFREE(I))
+ ELSE
+ P(I) = THETAPRIOR(IFREE(I),4) - theta(IFREE(I))
+ ENDIF
+ ENDIF
+ END DO
+
+ DO 1000 I=1,NFREE
+ THETAV(I) = THETAV(I) + P(I)
+ theta(IFREE(I)) = THETAV(I)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
+ 2 c,H,G,a,F,R,Xdd,Pdd,DLLM(1:max(d(1),1)))
+ XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+ CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,DLLM)
+ CALL KS(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XSM,
+ 1 PT(1:nobs,1:nx,1:nx))
+ THETAV(I) = THETAV(I) - P(I)
+ theta(IFREE(I)) = THETAV(I)
+ GRAD(2:nobs,I) = (DLLM(2:nobs) - DLL(2:nobs))/P(I)
+
+ DO J = 1,nx ! MAT (nobs x nx) x nfree
+ MAT(1+(J-1)*nobs:J*nobs,I) = (XSM(:,J)-XS(:,J))/P(I)
+ ENDDO
+1000 CONTINUE
+
+C Use OPG if Hessian is bad
+ IF (IFAIL.GT.0) THEN
+ DO 300 I=1,NFREE
+ DO 300 J=1,I
+300 OP(I,J) = SUM(GRAD(2:nobs,I)*GRAD(2:nobs,J))
+
+ DO 150 I=1,NFREE
+ DO 150 J=1,I
+150 LTR(i*(i+1)/2-i+j)=OP(I,J)
+ IFAIL = 1
+ CALL SYMINV(LTR,NFREE,LTR,W,J,IFAILSY,RMAX)
+ IF (IFAILSY.NE.0) THEN
+ IFAIL = -1
+ GOTO 1111
+ ENDIF
+ ENDIF
+
+C ------------------------------------------------------
+C Computes MAT(i,:)*VC*MAT(:,i) for each i=1,2,..,nobs
+C ------------------------------------------------------
+ DO 170 i=1,NFREE
+ VC(i,i)=LTR(i*(i+1)/2)
+ SE(IFREE(i)) = DSQRT(LTR(i*(i+1)/2))
+ DO 170 j=1,i-1
+ VC(i,j)=LTR(i*(i+1)/2-i+j)
+170 VC(j,i)=VC(i,j)
+
+ DO 301 I = 1,nobs*nx ! pro = MAT x VC
+ DO 301 J = 1,Nfree ! (nobsxnx)xnt x nt x nt
+301 pro(i,j) = SUM(MAT(i,1:NFREE)*VC(1:NFREE,j))
+
+C AKMSE: first nobs = var of nobs estimate of first state element
+ DO I = d(1)+1,nobs
+ DO J = 1,nx
+ AKMSE(I,J) = AKMSE(I,J) + SUM(pro(nobs*(J-1)+I,1:NFREE)*
+ 1 MAT(nobs*(J-1)+I,1:NFREE))
+ ENDDO
+ ENDDO
+
+1111 DO I = 1,nobs
+ DO J = 1,nx
+ AKMSE(I,J) = DSQRT(AKMSE(I,J))
+ ENDDO
+ ENDDO
+
+ DEALLOCATE(OP,W,LTR,P,GRAD,MAT,VC,pro)
+ DEALLOCATE(c,H,G,a,F,R,THETAV,DLL,DLLM,XSM,XT,PT,Xdd,Pdd)
+
+ RETURN
+ END
+
+cELSE
+c CALL KIM2(nobs,d,ny,nz,nx,nu,ns,PRODUCT(ns),nv,np,INFOS,yk,
+c 1 c,H,G,a,F,R,psi,1,XS,AKMSE,SSMOOTH,DLL)
+c DO I=1,NFREE
+c SE(IFREE(I)) = DSQRT(LTR(I*(I+1)/2))
+c ENDDO
+c ENDIF
diff --git a/opgh.for b/opgh.for
index 6d7f8b6e44b690644cd8c96ec61e9f2196fb560c..279a5d3e562821244f23ca67408ed9a308962e87 100644
--- a/opgh.for
+++ b/opgh.for
@@ -1,21 +1,21 @@
-C ------------------------------------------------------------
-C OPGH coumputes the Var-Covar matrix of Parameters inverting
-C the Observed Information matrix calcuted by outer product
-C of gradient estimator - e.g. Davidson MacKinnon pp 265-66
-C for MS-VAR(1) models
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT: SE = Standard deviations;
-C IFAIL = 0 Hessian
-C IFAIL = 1 OPG
-C IFAIL = -1 Failure
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------
+C OPGH coumputes the Var-Covar matrix of Parameters inverting
+C the Observed Information matrix calcuted by outer product
+C of gradient estimator - e.g. Davidson MacKinnon pp 265-66
+C for MS-VAR(1) models
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT: SE = Standard deviations;
+C IFAIL = 0 Hessian
+C IFAIL = 1 OPG
+C IFAIL = -1 Failure
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -26,147 +26,147 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------------------
- SUBROUTINE OPGH(nobs,ny,nz,nx,nu,nt,nv,ns,nstot,np,pdll,yk,IYK,
- 1 INFOS,theta,psi,thetaprior,HESS,thetase,psise,
- 1 SSMOOTH,INN,IFAIL)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-! Input
- INTEGER nobs,ny,nz,nx,nu,nt,nv,ns(6),nstot,np,pdll,IYK(nobs,ny+1),
- 1 INFOS(9,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
- 1 thetaprior(nt,4),HESS((nt+np)*(nt+np+1)/2)
-! Output
- INTEGER IFAIL
- DOUBLE PRECISION thetase(nt),psise(np),SSMOOTH(nobs,nstot),
- 1 INN(nobs,ny)
-! Locals
- INTEGER I,J,K,IFREE(nt+np),NFREE,NFT
- DOUBLE PRECISION DRI,PAR(nt+np),DLL(nobs),DLLM(nobs),RMAX
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- DOUBLE PRECISION, ALLOCATABLE:: GRAD(:,:),P(:),LTR(:),
- 1 W(:),OP(:,:),VC(:,:),pro(:,:)
-
- thetase(:) = 0.D0
- psise(:) = 0.D0
- IFAIL = 0
- DRI = 1.D-3
- NFREE = 0
- DO 20 I = 1,nt
- IF ((theta(I).GT.thetaprior(I,3)).AND.
- 1 (theta(I).LT.thetaprior(I,4))) THEN
- NFREE = NFREE + 1
- IFREE(NFREE) = I
- PAR(NFREE) = theta(I)
-20 ENDIF
- NFT = NFREE ! only theta free param
- DO 21 I = 1,np
- IF ((psi(I).GT..001D0).AND.(psi(I).LT..999D0)) THEN
- NFREE = NFREE + 1
- IFREE(NFREE) = I+nt
- PAR(NFREE) = psi(I)
-21 ENDIF
-
- ALLOCATE (LTR(NFREE*(NFREE+1)/2),W(NFREE))
- DO 25 I=1,NFREE
- DO 25 J=1,I
- K = IFREE(I)*(IFREE(I)+1)/2-IFREE(I)+IFREE(J)
-25 LTR(I*(I+1)/2-I+J) = HESS(K)
- IFAIL = 0
- CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL HF(nobs,nx,nstot,nz,nu,ns,nv,np,psi,1,yk,IYK,INFOS,
- 1 c,a,F,R,SSMOOTH,INN,DLL)
-
- IF (IFAIL.GT.0) THEN
- ALLOCATE (GRAD(Nobs,NFREE),P(NFREE),OP(NFREE,NFREE),
- 1 VC(NFREE,NFREE),pro(nobs*nx,NFREE))
-
- LTR(:) = 0.D0
- W(:) = 0.D0
- GRAD(:,:)= 0.D0
- P(:) = 0.D0
- OP(:,:) = 0.D0
- P(1:NFREE) = PAR(1:NFREE)*DRI ! delta
- DO I=1,NFT
- IF(DABS(P(I)).LT.1.D-13) P(I)=1.D-13
- IF (((theta(IFREE(I))+P(I)).GT.thetaprior(IFREE(I),4)).OR.
- 1 ((theta(IFREE(I))+P(I)).LT.thetaprior(IFREE(I),3))) THEN
- IF (theta(IFREE(I)).GT.0.D0) THEN
- P(I) = thetaprior(IFREE(I),3) - theta(IFREE(I))
- ELSE
- P(I) = thetaprior(IFREE(I),4) - theta(IFREE(I))
- ENDIF
- ENDIF
- END DO
-
- DO I=NFT+1,NFREE
- IF (DABS(P(I)).LT.1.D-13) P(I)=1.D-13
- IF (((psi(I-NFT)+P(I)).GT.999D0).OR.
- 1 ((psi(I-NFT)+P(I)).LT..001D0)) THEN
- P(I) = .001D0 - psi(I-NFT)
- ENDIF
- END DO
-
-C -----------
-C Main Cycle
-C -----------
- DO 1000 I=1,NFREE
- PAR(I) = PAR(I) + P(I)
- IF (I.LE.NFT) THEN
- theta(IFREE(I)) = PAR(I)
- ELSE
- psi(I-NFT) = PAR(I)
- ENDIF
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL HF(nobs,nx,nstot,nz,nu,ns,nv,np,psi,0,yk,IYK,INFOS,
- 1 c,a,F,R,SSMOOTH,INN,DLLM)
- PAR(I) = PAR(I) - P(I)
- IF (I.LE.NFT) THEN
- theta(IFREE(I)) = PAR(I)
- ELSE
- psi(I-NFT) = PAR(I)
- ENDIF
- GRAD(2:nobs,I) = (DLLM(2:nobs) - DLL(2:nobs))/P(I)
-1000 CONTINUE
-
-C Use OPG if Hessian is bad
- DO 300 I=1,NFREE
- DO 300 J=1,I
-300 OP(I,J) = SUM(GRAD(2:Nobs,I)*GRAD(2:Nobs,J))
-
- DO 150 I=1,NFREE
- DO 150 J=1,I
-150 LTR(i*(i+1)/2-i+j) = OP(I,J)
- CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
- IF (IFAIL.NE.0) GO TO 1111
- DEALLOCATE (OP,W,P,GRAD,VC,pro)
- ENDIF
-
- DO i=1,NFT
- thetase(IFREE(I))=dsqrt(LTR(i*(i+1)/2))
- ENDDO
- DO i=NFT+1,NFREE
- psise(I-NFT)=dsqrt(LTR(i*(i+1)/2))
- ENDDO
-
-1111 DEALLOCATE (LTR)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------------------
+ SUBROUTINE OPGH(nobs,ny,nz,nx,nu,nt,nv,ns,nstot,np,pdll,yk,IYK,
+ 1 INFOS,theta,psi,thetaprior,HESS,thetase,psise,
+ 1 SSMOOTH,INN,IFAIL)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+! Input
+ INTEGER nobs,ny,nz,nx,nu,nt,nv,ns(6),nstot,np,pdll,IYK(nobs,ny+1),
+ 1 INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
+ 1 thetaprior(nt,4),HESS((nt+np)*(nt+np+1)/2)
+! Output
+ INTEGER IFAIL
+ DOUBLE PRECISION thetase(nt),psise(np),SSMOOTH(nobs,nstot),
+ 1 INN(nobs,ny)
+! Locals
+ INTEGER I,J,K,IFREE(nt+np),NFREE,NFT
+ DOUBLE PRECISION DRI,PAR(nt+np),DLL(nobs),DLLM(nobs),RMAX
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ DOUBLE PRECISION, ALLOCATABLE:: GRAD(:,:),P(:),LTR(:),
+ 1 W(:),OP(:,:),VC(:,:),pro(:,:)
+
+ thetase(:) = 0.D0
+ psise(:) = 0.D0
+ IFAIL = 0
+ DRI = 1.D-3
+ NFREE = 0
+ DO 20 I = 1,nt
+ IF ((theta(I).GT.thetaprior(I,3)).AND.
+ 1 (theta(I).LT.thetaprior(I,4))) THEN
+ NFREE = NFREE + 1
+ IFREE(NFREE) = I
+ PAR(NFREE) = theta(I)
+20 ENDIF
+ NFT = NFREE ! only theta free param
+ DO 21 I = 1,np
+ IF ((psi(I).GT..001D0).AND.(psi(I).LT..999D0)) THEN
+ NFREE = NFREE + 1
+ IFREE(NFREE) = I+nt
+ PAR(NFREE) = psi(I)
+21 ENDIF
+
+ ALLOCATE (LTR(NFREE*(NFREE+1)/2),W(NFREE))
+ DO 25 I=1,NFREE
+ DO 25 J=1,I
+ K = IFREE(I)*(IFREE(I)+1)/2-IFREE(I)+IFREE(J)
+25 LTR(I*(I+1)/2-I+J) = HESS(K)
+ IFAIL = 0
+ CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL HF(nobs,nx,nstot,nz,nu,ns,nv,np,psi,1,yk,IYK,INFOS,
+ 1 c,a,F,R,SSMOOTH,INN,DLL)
+
+ IF (IFAIL.GT.0) THEN
+ ALLOCATE (GRAD(Nobs,NFREE),P(NFREE),OP(NFREE,NFREE),
+ 1 VC(NFREE,NFREE),pro(nobs*nx,NFREE))
+
+ LTR(:) = 0.D0
+ W(:) = 0.D0
+ GRAD(:,:)= 0.D0
+ P(:) = 0.D0
+ OP(:,:) = 0.D0
+ P(1:NFREE) = PAR(1:NFREE)*DRI ! delta
+ DO I=1,NFT
+ IF(DABS(P(I)).LT.1.D-13) P(I)=1.D-13
+ IF (((theta(IFREE(I))+P(I)).GT.thetaprior(IFREE(I),4)).OR.
+ 1 ((theta(IFREE(I))+P(I)).LT.thetaprior(IFREE(I),3))) THEN
+ IF (theta(IFREE(I)).GT.0.D0) THEN
+ P(I) = thetaprior(IFREE(I),3) - theta(IFREE(I))
+ ELSE
+ P(I) = thetaprior(IFREE(I),4) - theta(IFREE(I))
+ ENDIF
+ ENDIF
+ END DO
+
+ DO I=NFT+1,NFREE
+ IF (DABS(P(I)).LT.1.D-13) P(I)=1.D-13
+ IF (((psi(I-NFT)+P(I)).GT.999D0).OR.
+ 1 ((psi(I-NFT)+P(I)).LT..001D0)) THEN
+ P(I) = .001D0 - psi(I-NFT)
+ ENDIF
+ END DO
+
+C -----------
+C Main Cycle
+C -----------
+ DO 1000 I=1,NFREE
+ PAR(I) = PAR(I) + P(I)
+ IF (I.LE.NFT) THEN
+ theta(IFREE(I)) = PAR(I)
+ ELSE
+ psi(I-NFT) = PAR(I)
+ ENDIF
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL HF(nobs,nx,nstot,nz,nu,ns,nv,np,psi,0,yk,IYK,INFOS,
+ 1 c,a,F,R,SSMOOTH,INN,DLLM)
+ PAR(I) = PAR(I) - P(I)
+ IF (I.LE.NFT) THEN
+ theta(IFREE(I)) = PAR(I)
+ ELSE
+ psi(I-NFT) = PAR(I)
+ ENDIF
+ GRAD(2:nobs,I) = (DLLM(2:nobs) - DLL(2:nobs))/P(I)
+1000 CONTINUE
+
+C Use OPG if Hessian is bad
+ DO 300 I=1,NFREE
+ DO 300 J=1,I
+300 OP(I,J) = SUM(GRAD(2:Nobs,I)*GRAD(2:Nobs,J))
+
+ DO 150 I=1,NFREE
+ DO 150 J=1,I
+150 LTR(i*(i+1)/2-i+j) = OP(I,J)
+ CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
+ IF (IFAIL.NE.0) GO TO 1111
+ DEALLOCATE (OP,W,P,GRAD,VC,pro)
+ ENDIF
+
+ DO i=1,NFT
+ thetase(IFREE(I))=dsqrt(LTR(i*(i+1)/2))
+ ENDDO
+ DO i=NFT+1,NFREE
+ psise(I-NFT)=dsqrt(LTR(i*(i+1)/2))
+ ENDDO
+
+1111 DEALLOCATE (LTR)
+ RETURN
END
diff --git a/opgkim.for b/opgkim.for
index f409dffba1fc6cdbb78140a3f74d882eb5d1fac9..0022269dd155b77bb4eda8a5b93ee2f72a858a01 100644
--- a/opgkim.for
+++ b/opgkim.for
@@ -1,20 +1,20 @@
-C ------------------------------------------------------------
-C OPGKIM coumputes the Var-Covar matrix of Parameters inverting
-C the Observed Information matrix calcuted by outer product
-C of gradient estimator - e.g. Davidson MacKinnon pp 265-66
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C OUTPUT: SE = Standard deviations;
-C IFAIL = 0 Hessian
-C IFAIL = 1 OPG
-C IFAIL = -1 Failure
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------
+C OPGKIM coumputes the Var-Covar matrix of Parameters inverting
+C the Observed Information matrix calcuted by outer product
+C of gradient estimator - e.g. Davidson MacKinnon pp 265-66
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C OUTPUT: SE = Standard deviations;
+C IFAIL = 0 Hessian
+C IFAIL = 1 OPG
+C IFAIL = -1 Failure
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -25,150 +25,150 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------------------
- SUBROUTINE OPGKIM(nobs,d,ny,nz,nx,nu,nt,nv,ns,nstot,np,pdll,yk,
- 1 IYK,INFOS,theta,psi,thetaprior,HESS,thetase,
- 1 psise,XS,XSSE,SSMOOTH,INN,IFAIL)
-
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-! Input
- INTEGER nobs,d(2),ny,nz,nx,nu,nt,nv,ns(6),nstot,np,pdll,IYK(nobs,ny+1),
- 1 INFOS(9,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
- 1 thetaprior(nt,4),HESS((nt+np)*(nt+np+1)/2)
-! Output
- INTEGER IFAIL
- DOUBLE PRECISION thetase(nt),psise(np),XS(nobs,nx),XSSE(nobs,nx),
- 1 SSMOOTH(nobs,nstot),INN(nobs,ny)
-! Locals
- INTEGER I,J,K,IFREE(nt+np),NFREE,NFT
- DOUBLE PRECISION DRI,PAR(nt+np),DLL(nobs),DLLM(nobs),RMAX
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- DOUBLE PRECISION, ALLOCATABLE:: GRAD(:,:),P(:),LTR(:),
- 1 W(:),OP(:,:),VC(:,:),pro(:,:)
-
- thetase(:) = 0.D0
- psise(:) = 0.D0
- IFAIL = 0
- DRI = 1.D-3
- NFREE = 0
- DO 20 I = 1,nt
- IF ((theta(I).GT.thetaprior(I,3)).AND.
- 1 (theta(I).LT.thetaprior(I,4))) THEN
- NFREE = NFREE + 1
- IFREE(NFREE) = I
- PAR(NFREE) = theta(I)
-20 ENDIF
- NFT = NFREE ! only theta free param
- DO 21 I = 1,np
- IF ((psi(I).GT..001D0).AND.(psi(I).LT..999D0)) THEN
- NFREE = NFREE + 1
- IFREE(NFREE) = I+nt
- PAR(NFREE) = psi(I)
-21 ENDIF
-
- ALLOCATE (LTR(NFREE*(NFREE+1)/2),W(NFREE))
- DO 25 I=1,NFREE
- DO 25 J=1,I
- K = IFREE(I)*(IFREE(I)+1)/2-IFREE(I)+IFREE(J)
-25 LTR(I*(I+1)/2-I+J) = HESS(K)
- IFAIL = 0
- CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL KIM(nobs,d,ny,nz,nx,nu,ns,nstot,nv,np,INFOS,yk,IYK,
- 1 c,H,G,a,F,R,psi,1,XS,XSSE,SSMOOTH,INN,DLL)
-
-
- IF (IFAIL.GT.0) THEN
- ALLOCATE (GRAD(Nobs,NFREE),P(NFREE),OP(NFREE,NFREE),
- 1 VC(NFREE,NFREE),pro(nobs*nx,NFREE))
-
- LTR(:) = 0.D0
- W(:) = 0.D0
- GRAD(:,:)= 0.D0
- P(:) = 0.D0
- OP(:,:) = 0.D0
- P(1:NFREE) = PAR(1:NFREE)*DRI ! delta
- DO I=1,NFT
- IF(DABS(P(I)).LT.1.D-13) P(I)=1.D-13
- IF (((theta(IFREE(I))+P(I)).GT.thetaprior(IFREE(I),4)).OR.
- 1 ((theta(IFREE(I))+P(I)).LT.thetaprior(IFREE(I),3))) THEN
- IF (theta(IFREE(I)).GT.0.D0) THEN
- P(I) = thetaprior(IFREE(I),3) - theta(IFREE(I))
- ELSE
- P(I) = thetaprior(IFREE(I),4) - theta(IFREE(I))
- ENDIF
- ENDIF
- END DO
-
- DO I=NFT+1,NFREE
- IF (DABS(P(I)).LT.1.D-13) P(I)=1.D-13
- IF (((psi(I-NFT)+P(I)).GT.999D0).OR.
- 1 ((psi(I-NFT)+P(I)).LT..001D0)) THEN
- P(I) = .001D0 - psi(I-NFT)
- ENDIF
- END DO
-
-C -----------
-C Main Cycle
-C -----------
- DO 1000 I=1,NFREE
- PAR(I) = PAR(I) + P(I)
- IF (I.LE.NFT) THEN
- theta(IFREE(I)) = PAR(I)
- ELSE
- psi(I-NFT) = PAR(I)
- ENDIF
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL KIM(nobs,d,ny,nz,nx,nu,ns,nstot,nv,np,INFOS,yk,IYK,
- 1 c,H,G,a,F,R,psi,0,XS,XSSE,SSMOOTH,INN,DLLM)
-
- PAR(I) = PAR(I) - P(I)
- IF (I.LE.NFT) THEN
- theta(IFREE(I)) = PAR(I)
- ELSE
- psi(I-NFT) = PAR(I)
- ENDIF
- GRAD(2:nobs,I) = (DLLM(2:nobs) - DLL(2:nobs))/P(I)
-1000 CONTINUE
-
-C Use OPG if Hessian is bad
- DO 300 I=1,NFREE
- DO 300 J=1,I
-300 OP(I,J) = SUM(GRAD(2:Nobs,I)*GRAD(2:Nobs,J))
-
- DO 150 I=1,NFREE
- DO 150 J=1,I
-150 LTR(i*(i+1)/2-i+j) = OP(I,J)
- CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
- IF (IFAIL.NE.0) GO TO 1111
- DEALLOCATE (OP,W,P,GRAD,VC,pro)
- ENDIF
-
- DO i=1,NFT
- thetase(IFREE(I))=dsqrt(LTR(i*(i+1)/2))
- ENDDO
- DO i=NFT+1,NFREE
- psise(I-NFT)=dsqrt(LTR(i*(i+1)/2))
- ENDDO
-
-1111 DEALLOCATE (LTR)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------------------
+ SUBROUTINE OPGKIM(nobs,d,ny,nz,nx,nu,nt,nv,ns,nstot,np,pdll,yk,
+ 1 IYK,INFOS,theta,psi,thetaprior,HESS,thetase,
+ 1 psise,XS,XSSE,SSMOOTH,INN,IFAIL)
+
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+! Input
+ INTEGER nobs,d(2),ny,nz,nx,nu,nt,nv,ns(6),nstot,np,pdll,IYK(nobs,ny+1),
+ 1 INFOS(9,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),psi(np),
+ 1 thetaprior(nt,4),HESS((nt+np)*(nt+np+1)/2)
+! Output
+ INTEGER IFAIL
+ DOUBLE PRECISION thetase(nt),psise(np),XS(nobs,nx),XSSE(nobs,nx),
+ 1 SSMOOTH(nobs,nstot),INN(nobs,ny)
+! Locals
+ INTEGER I,J,K,IFREE(nt+np),NFREE,NFT
+ DOUBLE PRECISION DRI,PAR(nt+np),DLL(nobs),DLLM(nobs),RMAX
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ DOUBLE PRECISION, ALLOCATABLE:: GRAD(:,:),P(:),LTR(:),
+ 1 W(:),OP(:,:),VC(:,:),pro(:,:)
+
+ thetase(:) = 0.D0
+ psise(:) = 0.D0
+ IFAIL = 0
+ DRI = 1.D-3
+ NFREE = 0
+ DO 20 I = 1,nt
+ IF ((theta(I).GT.thetaprior(I,3)).AND.
+ 1 (theta(I).LT.thetaprior(I,4))) THEN
+ NFREE = NFREE + 1
+ IFREE(NFREE) = I
+ PAR(NFREE) = theta(I)
+20 ENDIF
+ NFT = NFREE ! only theta free param
+ DO 21 I = 1,np
+ IF ((psi(I).GT..001D0).AND.(psi(I).LT..999D0)) THEN
+ NFREE = NFREE + 1
+ IFREE(NFREE) = I+nt
+ PAR(NFREE) = psi(I)
+21 ENDIF
+
+ ALLOCATE (LTR(NFREE*(NFREE+1)/2),W(NFREE))
+ DO 25 I=1,NFREE
+ DO 25 J=1,I
+ K = IFREE(I)*(IFREE(I)+1)/2-IFREE(I)+IFREE(J)
+25 LTR(I*(I+1)/2-I+J) = HESS(K)
+ IFAIL = 0
+ CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL KIM(nobs,d,ny,nz,nx,nu,ns,nstot,nv,np,INFOS,yk,IYK,
+ 1 c,H,G,a,F,R,psi,1,XS,XSSE,SSMOOTH,INN,DLL)
+
+
+ IF (IFAIL.GT.0) THEN
+ ALLOCATE (GRAD(Nobs,NFREE),P(NFREE),OP(NFREE,NFREE),
+ 1 VC(NFREE,NFREE),pro(nobs*nx,NFREE))
+
+ LTR(:) = 0.D0
+ W(:) = 0.D0
+ GRAD(:,:)= 0.D0
+ P(:) = 0.D0
+ OP(:,:) = 0.D0
+ P(1:NFREE) = PAR(1:NFREE)*DRI ! delta
+ DO I=1,NFT
+ IF(DABS(P(I)).LT.1.D-13) P(I)=1.D-13
+ IF (((theta(IFREE(I))+P(I)).GT.thetaprior(IFREE(I),4)).OR.
+ 1 ((theta(IFREE(I))+P(I)).LT.thetaprior(IFREE(I),3))) THEN
+ IF (theta(IFREE(I)).GT.0.D0) THEN
+ P(I) = thetaprior(IFREE(I),3) - theta(IFREE(I))
+ ELSE
+ P(I) = thetaprior(IFREE(I),4) - theta(IFREE(I))
+ ENDIF
+ ENDIF
+ END DO
+
+ DO I=NFT+1,NFREE
+ IF (DABS(P(I)).LT.1.D-13) P(I)=1.D-13
+ IF (((psi(I-NFT)+P(I)).GT.999D0).OR.
+ 1 ((psi(I-NFT)+P(I)).LT..001D0)) THEN
+ P(I) = .001D0 - psi(I-NFT)
+ ENDIF
+ END DO
+
+C -----------
+C Main Cycle
+C -----------
+ DO 1000 I=1,NFREE
+ PAR(I) = PAR(I) + P(I)
+ IF (I.LE.NFT) THEN
+ theta(IFREE(I)) = PAR(I)
+ ELSE
+ psi(I-NFT) = PAR(I)
+ ENDIF
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL KIM(nobs,d,ny,nz,nx,nu,ns,nstot,nv,np,INFOS,yk,IYK,
+ 1 c,H,G,a,F,R,psi,0,XS,XSSE,SSMOOTH,INN,DLLM)
+
+ PAR(I) = PAR(I) - P(I)
+ IF (I.LE.NFT) THEN
+ theta(IFREE(I)) = PAR(I)
+ ELSE
+ psi(I-NFT) = PAR(I)
+ ENDIF
+ GRAD(2:nobs,I) = (DLLM(2:nobs) - DLL(2:nobs))/P(I)
+1000 CONTINUE
+
+C Use OPG if Hessian is bad
+ DO 300 I=1,NFREE
+ DO 300 J=1,I
+300 OP(I,J) = SUM(GRAD(2:Nobs,I)*GRAD(2:Nobs,J))
+
+ DO 150 I=1,NFREE
+ DO 150 J=1,I
+150 LTR(i*(i+1)/2-i+j) = OP(I,J)
+ CALL SYMINV(LTR,NFREE,LTR,W,J,IFAIL,RMAX)
+ IF (IFAIL.NE.0) GO TO 1111
+ DEALLOCATE (OP,W,P,GRAD,VC,pro)
+ ENDIF
+
+ DO i=1,NFT
+ thetase(IFREE(I))=dsqrt(LTR(i*(i+1)/2))
+ ENDDO
+ DO i=NFT+1,NFREE
+ psise(I-NFT)=dsqrt(LTR(i*(i+1)/2))
+ ENDDO
+
+1111 DEALLOCATE (LTR)
+ RETURN
END
diff --git a/pprod.for b/pprod.for
index 8950d5649b7844feabc067da482e65a8d64b98b5..8f45caa192ce0359491d838d6241a452d2abe2ac 100644
--- a/pprod.for
+++ b/pprod.for
@@ -1,15 +1,15 @@
-C -------------------------------------------------------------
-C PPROD computes PALL = P1 x P2 x ...x Pnv where
-C Pk(i,j)= Pr[Sk(t+1)=i|Sk(t)=j], k = 1,2,...,min(6,nv)
-C P(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C PPROD computes PALL = P1 x P2 x ...x Pnv where
+C Pk(i,j)= Pr[Sk(t+1)=i|Sk(t)=j], k = 1,2,...,min(6,nv)
+C P(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -20,55 +20,55 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,P)
-C INPUT
- INTEGER nv,nstot
- INTEGER INFOS(9,6)
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6))
-C OUTPUT
- DOUBLE PRECISION P(nstot,nstot)
-C LOCALS
- INTEGER n1,n2,n3,n4,n5,n6,I,J
- DOUBLE PRECISION PC(nstot,nstot)
-
- n1 = INFOS(8,1)
- IF (nv.EQ.1) THEN
- P(1:n1,1:n1) = P1(1:n1,1:n1)
- ELSEIF (nv.GT.1) THEN
- n2 = INFOS(8,2)
- DO 20 I =1,n1
- DO 20 J =1,n1
-20 P(n2*(I-1)+1:n2*I,n2*(J-1)+1:n2*J)=P1(I,J)*P2(1:n2,1:n2)
- ELSEIF (nv.GT.2) THEN
- PC(:,:) = P(:,:)
- n3 = INFOS(8,3)
- DO 30 I =1,n1*n2
- DO 30 J =1,n1*n2
-30 P(n3*(I-1)+1:n3*I,n3*(J-1)+1:n3*J)=PC(I,J)*P3(1:n3,1:n3)
- ELSEIF (nv.GT.3) THEN
- PC(:,:) = P(:,:)
- n4 = INFOS(8,4)
- DO 40 I =1,n1*n2*n3
- DO 40 J =1,n1*n2*n3
-40 P(n4*(I-1)+1:n4*I,n4*(J-1)+1:n4*J)=PC(I,J)*P4(1:n4,1:n4)
- ELSEIF (nv.GT.4) THEN
- PC(:,:) = P(:,:)
- n5 = INFOS(8,5)
- DO 50 I =1,n1*n2*n3*n4
- DO 50 J =1,n1*n2*n3*n4
-50 P(n5*(I-1)+1:n5*I,n5*(J-1)+1:n5*J)=PC(I,J)*P5(1:n5,1:n5)
- ELSEIF (nv.GT.5) THEN
- PC(:,:) = P(:,:)
- n6 = INFOS(8,6)
- DO 60 I =1,n1*n2*n3*n4*n5
- DO 60 J =1,n1*n2*n3*n4*n5
-60 P(n6*(I-1)+1:n6*I,n6*(J-1)+1:n6*J)=PC(I,J)*P6(1:n6,1:n6)
- ENDIF
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,P)
+C INPUT
+ INTEGER nv,nstot
+ INTEGER INFOS(9,6)
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6))
+C OUTPUT
+ DOUBLE PRECISION P(nstot,nstot)
+C LOCALS
+ INTEGER n1,n2,n3,n4,n5,n6,I,J
+ DOUBLE PRECISION PC(nstot,nstot)
+
+ n1 = INFOS(8,1)
+ IF (nv.EQ.1) THEN
+ P(1:n1,1:n1) = P1(1:n1,1:n1)
+ ELSEIF (nv.GT.1) THEN
+ n2 = INFOS(8,2)
+ DO 20 I =1,n1
+ DO 20 J =1,n1
+20 P(n2*(I-1)+1:n2*I,n2*(J-1)+1:n2*J)=P1(I,J)*P2(1:n2,1:n2)
+ ELSEIF (nv.GT.2) THEN
+ PC(:,:) = P(:,:)
+ n3 = INFOS(8,3)
+ DO 30 I =1,n1*n2
+ DO 30 J =1,n1*n2
+30 P(n3*(I-1)+1:n3*I,n3*(J-1)+1:n3*J)=PC(I,J)*P3(1:n3,1:n3)
+ ELSEIF (nv.GT.3) THEN
+ PC(:,:) = P(:,:)
+ n4 = INFOS(8,4)
+ DO 40 I =1,n1*n2*n3
+ DO 40 J =1,n1*n2*n3
+40 P(n4*(I-1)+1:n4*I,n4*(J-1)+1:n4*J)=PC(I,J)*P4(1:n4,1:n4)
+ ELSEIF (nv.GT.4) THEN
+ PC(:,:) = P(:,:)
+ n5 = INFOS(8,5)
+ DO 50 I =1,n1*n2*n3*n4
+ DO 50 J =1,n1*n2*n3*n4
+50 P(n5*(I-1)+1:n5*I,n5*(J-1)+1:n5*J)=PC(I,J)*P5(1:n5,1:n5)
+ ELSEIF (nv.GT.5) THEN
+ PC(:,:) = P(:,:)
+ n6 = INFOS(8,6)
+ DO 60 I =1,n1*n2*n3*n4*n5
+ DO 60 J =1,n1*n2*n3*n4*n5
+60 P(n6*(I-1)+1:n6*I,n6*(J-1)+1:n6*J)=PC(I,J)*P6(1:n6,1:n6)
+ ENDIF
+
+ RETURN
END
diff --git a/prior.for b/prior.for
index aac48b90d0ae092d2910fa465b7e192fbdf9f1ec..0650f7c19d9dd943d9a58c6d928a92a437694002 100644
--- a/prior.for
+++ b/prior.for
@@ -1,17 +1,17 @@
-C -------------------------------------------------------------------
-C PRIOR COMPUTES THE LOG-VALUE PRIOR pdf EVALUATED AT THETA
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C TIPO: 'BE' = Beta over (a,b)
-C 'IG' = Inverted Gamma, parameterization as in Bauwens et al.
-C 'NT' = Truncated Normal(mean,variance) over (a,b)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------------
+C PRIOR COMPUTES THE LOG-VALUE PRIOR pdf EVALUATED AT THETA
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C TIPO: 'BE' = Beta over (a,b)
+C 'IG' = Inverted Gamma, parameterization as in Bauwens et al.
+C 'NT' = Truncated Normal(mean,variance) over (a,b)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -22,42 +22,42 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION PRIOR(theta,thetaprior,tipo)
-C INPUT
- DOUBLE PRECISION theta,thetaprior(4)
- CHARACTER*2 tipo
-
-C LOCALS
- DOUBLE PRECISION XMIN,XMAX,AUX,PI
- DATA PI/3.141592653589793D0/
-
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION gammln,cumnorm
-
- IF (tipo.EQ.'IG') THEN
- PRIOR = -gammln(.5D0*thetaprior(2))
- + - .5D0*thetaprior(2)*DLOG(2.D0/thetaprior(1))
- + - (.5D0*thetaprior(2)+1.D0)*DLOG(theta)
- + - .5D0*thetaprior(1)/theta
-C XMAX = thetaprior(1)/(2.D0*thetaprior(4))
-C CALL S14BAF(thetaprior(2)/2.D0,XMAX,EPS,P,Q,IFAIL)
-C PRIOR = PRIOR -DLOG(Q)
- ELSEIF (tipo.EQ.'NT') THEN
- XMIN = (thetaprior(3)-thetaprior(1))/DSQRT(thetaprior(2))
- XMAX = (thetaprior(4)-thetaprior(1))/DSQRT(thetaprior(2))
- AUX = cumnorm(XMAX)-cumnorm(XMIN)
- PRIOR = -.5D0*DLOG(thetaprior(2))
- + - .5D0*(theta-thetaprior(1))**2/thetaprior(2)
- + - DLOG(AUX) -.5D0*DLOG(2.D0*PI)
- ELSEIF (tipo.EQ.'BE') THEN
- AUX = gammln(thetaprior(1) + thetaprior(2))
- + - gammln(thetaprior(1))- gammln(thetaprior(2))
- XMIN = (theta-thetaprior(3))/(thetaprior(4)-thetaprior(3))
- PRIOR = AUX + (thetaprior(1)-1.D0)*DLOG(XMIN)
- + + (thetaprior(2)-1.D0)*DLOG(1.D0-XMIN)
- + - DLOG(thetaprior(4)-thetaprior(3))
- ENDIF
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION PRIOR(theta,thetaprior,tipo)
+C INPUT
+ DOUBLE PRECISION theta,thetaprior(4)
+ CHARACTER*2 tipo
+
+C LOCALS
+ DOUBLE PRECISION XMIN,XMAX,AUX,PI
+ DATA PI/3.141592653589793D0/
+
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION gammln,cumnorm
+
+ IF (tipo.EQ.'IG') THEN
+ PRIOR = -gammln(.5D0*thetaprior(2))
+ + - .5D0*thetaprior(2)*DLOG(2.D0/thetaprior(1))
+ + - (.5D0*thetaprior(2)+1.D0)*DLOG(theta)
+ + - .5D0*thetaprior(1)/theta
+C XMAX = thetaprior(1)/(2.D0*thetaprior(4))
+C CALL S14BAF(thetaprior(2)/2.D0,XMAX,EPS,P,Q,IFAIL)
+C PRIOR = PRIOR -DLOG(Q)
+ ELSEIF (tipo.EQ.'NT') THEN
+ XMIN = (thetaprior(3)-thetaprior(1))/DSQRT(thetaprior(2))
+ XMAX = (thetaprior(4)-thetaprior(1))/DSQRT(thetaprior(2))
+ AUX = cumnorm(XMAX)-cumnorm(XMIN)
+ PRIOR = -.5D0*DLOG(thetaprior(2))
+ + - .5D0*(theta-thetaprior(1))**2/thetaprior(2)
+ + - DLOG(AUX) -.5D0*DLOG(2.D0*PI)
+ ELSEIF (tipo.EQ.'BE') THEN
+ AUX = gammln(thetaprior(1) + thetaprior(2))
+ + - gammln(thetaprior(1))- gammln(thetaprior(2))
+ XMIN = (theta-thetaprior(3))/(thetaprior(4)-thetaprior(3))
+ PRIOR = AUX + (thetaprior(1)-1.D0)*DLOG(XMIN)
+ + + (thetaprior(2)-1.D0)*DLOG(1.D0-XMIN)
+ + - DLOG(thetaprior(4)-thetaprior(3))
+ ENDIF
+ RETURN
END
diff --git a/priordir.for b/priordir.for
index 1fa28d40b302bff5b04bac82dcbdaf65b559739b..f109152dd2511481c2d22ec777467ab17e7ec644 100644
--- a/priordir.for
+++ b/priordir.for
@@ -1,16 +1,16 @@
-C -------------------------------------------------------------
-C PRIORDIR COMPUTES THE LOG PRIOR DISTRIBUTION EVALUATED AT psi
-C FOR THE DIRICHLET pdf
-C f(psi(1),..,psi(N-1);a1,...,aN)=1/B(a)*prod_i=1^N psi(i)^(ai-1)
-C B(a) = prod_i=1^N G(ai)/G(a0), a0 = a1+...+aN
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C PRIORDIR COMPUTES THE LOG PRIOR DISTRIBUTION EVALUATED AT psi
+C FOR THE DIRICHLET pdf
+C f(psi(1),..,psi(N-1);a1,...,aN)=1/B(a)*prod_i=1^N psi(i)^(ai-1)
+C B(a) = prod_i=1^N G(ai)/G(a0), a0 = a1+...+aN
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -21,26 +21,26 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------
- DOUBLE PRECISION FUNCTION PRIORDIR(psi,psiprior,N)
-C INPUT
- INTEGER N
- DOUBLE PRECISION psi(N-1),psiprior(N)
-
-C LOCALS
- INTEGER I
-
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION GAMMLN
-
- PRIORDIR = gammln(SUM(psiprior(1:N)))
- DO I = 1,N-1
- PRIORDIR = PRIORDIR - gammln(psiprior(I))
- # + (psiprior(I)-1.D0)*DLOG(psi(I))
- ENDDO
- PRIORDIR = PRIORDIR - gammln(psiprior(N))
- # + (psiprior(N)-1.D0)*DLOG(1.D0-SUM(psi(1:N-1)))
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION PRIORDIR(psi,psiprior,N)
+C INPUT
+ INTEGER N
+ DOUBLE PRECISION psi(N-1),psiprior(N)
+
+C LOCALS
+ INTEGER I
+
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION GAMMLN
+
+ PRIORDIR = gammln(SUM(psiprior(1:N)))
+ DO I = 1,N-1
+ PRIORDIR = PRIORDIR - gammln(psiprior(I))
+ # + (psiprior(I)-1.D0)*DLOG(psi(I))
+ ENDDO
+ PRIORDIR = PRIORDIR - gammln(psiprior(N))
+ # + (psiprior(N)-1.D0)*DLOG(1.D0-SUM(psi(1:N-1)))
+
+ RETURN
END
diff --git a/ptheta.for b/ptheta.for
index 0712b6353e2c80c8c6eed153a8463c517e0d6ab2..7b084a28b3eb6dee8439b2a1bf3a9d783fd719aa 100644
--- a/ptheta.for
+++ b/ptheta.for
@@ -1,13 +1,13 @@
-C ----------------------------------------------------------------
-C PTHETA COMPUTES THE LOG POSTERIOR
-C P(theta1(it)|theta1(~it),S,Y)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------
+C PTHETA COMPUTES THE LOG POSTERIOR
+C P(theta1(it)|theta1(~it),S,Y)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,51 +18,51 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------
- DOUBLE PRECISION FUNCTION PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,
- 1 S,yk,IYK,theta,thetaprior,tipo,pdll)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6),
- 1 IYK(nobs,ny+1)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
- CHARACTER*2 tipo
-
-C LOCALS
- DOUBLE PRECISION,ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),a(:,:),
- 1 F(:,:,:),R(:,:,:),LIKE(:),XT(:,:),PT(:,:,:),Xdd(:,:),Pdd(:,:,:)
- DOUBLE PRECISION PRIOR
-
- ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),G(ny,nu,ns(3)),
- 1 a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),LIKE(nobs),
- 2 XT(0:nobs,nx),PT(0:nobs,nx,nx),Xdd(max(d(1),1),nx),
- 3 Pdd(max(d(1),1),nx,nx))
-
-C computes the log-posterior
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
- 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
- XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
- CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,LIKE)
- PTHETA = SUM(LIKE) + PRIOR(theta(it),thetaprior,tipo)
-
- DEALLOCATE(c,H,G,a,F,R,LIKE,XT,PT,Xdd,Pdd)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,
+ 1 S,yk,IYK,theta,thetaprior,tipo,pdll)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6),
+ 1 IYK(nobs,ny+1)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
+ CHARACTER*2 tipo
+
+C LOCALS
+ DOUBLE PRECISION,ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),a(:,:),
+ 1 F(:,:,:),R(:,:,:),LIKE(:),XT(:,:),PT(:,:,:),Xdd(:,:),Pdd(:,:,:)
+ DOUBLE PRECISION PRIOR
+
+ ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),G(ny,nu,ns(3)),
+ 1 a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),LIKE(nobs),
+ 2 XT(0:nobs,nx),PT(0:nobs,nx,nx),Xdd(max(d(1),1),nx),
+ 3 Pdd(max(d(1),1),nx,nx))
+
+C computes the log-posterior
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL IKF(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),IYK(1:max(d(1),1),1:ny+1),
+ 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
+ XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+ CALL KF(nobs,d,ny,nz,nx,nu,ns,S,yk,IYK,c,H,G,a,F,R,XT,PT,LIKE)
+ PTHETA = SUM(LIKE) + PRIOR(theta(it),thetaprior,tipo)
+
+ DEALLOCATE(c,H,G,a,F,R,LIKE,XT,PT,Xdd,Pdd)
+ RETURN
END
diff --git a/ptheta2.for b/ptheta2.for
index ed42a9cefff38397b6ac8f7bc8c0f2bac7df4b84..6673de55ba30b66dd9b230235c3e7ae28b1fb7ad 100644
--- a/ptheta2.for
+++ b/ptheta2.for
@@ -1,13 +1,13 @@
-C ----------------------------------------------------------------
-C PTHETA2 (no missing values) COMPUTES THE LOG POSTERIOR
-C P(theta1(it)|theta1(~it),S,Y)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------
+C PTHETA2 (no missing values) COMPUTES THE LOG POSTERIOR
+C P(theta1(it)|theta1(~it),S,Y)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,51 +18,51 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------
- DOUBLE PRECISION FUNCTION PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,
- 1 S,yk,theta,thetaprior,tipo,pdll)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
- CHARACTER*2 tipo
-
-C LOCALS
- DOUBLE PRECISION,ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),a(:,:),
- 1 F(:,:,:),R(:,:,:),LIKE(:),XT(:,:),PT(:,:,:),Xdd(:,:),Pdd(:,:,:)
- DOUBLE PRECISION PRIOR
-
- ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),G(ny,nu,ns(3)),
- 1 a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),LIKE(nobs),
- 2 XT(0:nobs,nx),PT(0:nobs,nx,nx),Xdd(max(d(1),1),nx),
- 3 Pdd(max(d(1),1),nx,nx))
-
-
-C computes the log-posterior
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- CALL IKF2(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
- 1 yk(1:max(d(1),1),1:ny+nz),
- 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
- XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
- PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
- CALL KF2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,XT,PT,LIKE)
- PTHETA2 = SUM(LIKE) + PRIOR(theta(it),thetaprior,tipo)
-
- DEALLOCATE(c,H,G,a,F,R,LIKE,XT,PT,Xdd,Pdd)
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,
+ 1 S,yk,theta,thetaprior,tipo,pdll)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
+ CHARACTER*2 tipo
+
+C LOCALS
+ DOUBLE PRECISION,ALLOCATABLE:: c(:,:,:),H(:,:,:),G(:,:,:),a(:,:),
+ 1 F(:,:,:),R(:,:,:),LIKE(:),XT(:,:),PT(:,:,:),Xdd(:,:),Pdd(:,:,:)
+ DOUBLE PRECISION PRIOR
+
+ ALLOCATE(c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),G(ny,nu,ns(3)),
+ 1 a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6)),LIKE(nobs),
+ 2 XT(0:nobs,nx),PT(0:nobs,nx,nx),Xdd(max(d(1),1),nx),
+ 3 Pdd(max(d(1),1),nx,nx))
+
+
+C computes the log-posterior
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ CALL IKF2(d,ny,nz,nx,nu,ns,S(1:max(d(1),1),1:6),
+ 1 yk(1:max(d(1),1),1:ny+nz),
+ 2 c,H,G,a,F,R,Xdd,Pdd,LIKE(1:max(d(1),1)))
+ XT(d(1),1:nx) = Xdd(max(d(1),1),1:nx)
+ PT(d(1),1:nx,1:nx) = Pdd(max(d(1),1),1:nx,1:nx)
+ CALL KF2(nobs,d,ny,nz,nx,nu,ns,S,yk,c,H,G,a,F,R,XT,PT,LIKE)
+ PTHETA2 = SUM(LIKE) + PRIOR(theta(it),thetaprior,tipo)
+
+ DEALLOCATE(c,H,G,a,F,R,LIKE,XT,PT,Xdd,Pdd)
+ RETURN
END
diff --git a/recest.for b/recest.for
index 61550576640671be2aec4add45d431828cb760c3..a073f89cc3bebc05fa1d00772b1d5abd677476b8 100644
--- a/recest.for
+++ b/recest.for
@@ -1,14 +1,14 @@
-C -----------------------------------------------
-C RECEST performs recursive estimation of the
-C MEAN, SD, and COVARIANCE MATRIX
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -----------------------------------------------
+C RECEST performs recursive estimation of the
+C MEAN, SD, and COVARIANCE MATRIX
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -19,33 +19,33 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -----------------------------------------------
- SUBROUTINE RECEST(NX,N,X,MED0,SIG0,SK0,MED,SIG,SK)
-C INPUT
- INTEGER NX,N
- DOUBLE PRECISION X(NX),MED0(NX),SK0(NX),SIG0(NX,NX)
-C OUTPUT
- DOUBLE PRECISION MED(NX),SK(NX),SIG(NX,NX)
-C LOCALS
- INTEGER I,J
- DOUBLE PRECISION SSX,SSXY,S3X
-
-C MEAN
- MED = (N*MED0+X)/DFLOAT(N+1)
-C VAR and SKEW
- DO I = 1,NX
- SSX = SIG0(I,I) + MED0(I)**2
- S3X = SK0(I)*SIG0(I,I)**1.5D0+3.D0*MED0(I)*SSX-2.D0*MED0(I)**3
- SSX = (N*SSX+X(I)**2)/DFLOAT(N+1)
- SIG(I,I) = SSX-MED(I)**2
- S3X = (S3X*N+X(I)**3)/DFLOAT(N+1)
- DO J = 1,I-1
- SSXY = SIG0(I,J) + MED0(I)*MED0(J)
- SIG(I,J) = (N*SSXY+X(I)*X(J))/DFLOAT(N+1)-MED(I)*MED(J)
- SIG(J,I) = SIG(I,J)
- ENDDO
- SK(I) = SIG(I,I)**(-1.5D0)*(S3X-3.D0*MED(I)*SSX+2.D0*MED(I)**3)
- ENDDO
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -----------------------------------------------
+ SUBROUTINE RECEST(NX,N,X,MED0,SIG0,SK0,MED,SIG,SK)
+C INPUT
+ INTEGER NX,N
+ DOUBLE PRECISION X(NX),MED0(NX),SK0(NX),SIG0(NX,NX)
+C OUTPUT
+ DOUBLE PRECISION MED(NX),SK(NX),SIG(NX,NX)
+C LOCALS
+ INTEGER I,J
+ DOUBLE PRECISION SSX,SSXY,S3X
+
+C MEAN
+ MED = (N*MED0+X)/DFLOAT(N+1)
+C VAR and SKEW
+ DO I = 1,NX
+ SSX = SIG0(I,I) + MED0(I)**2
+ S3X = SK0(I)*SIG0(I,I)**1.5D0+3.D0*MED0(I)*SSX-2.D0*MED0(I)**3
+ SSX = (N*SSX+X(I)**2)/DFLOAT(N+1)
+ SIG(I,I) = SSX-MED(I)**2
+ S3X = (S3X*N+X(I)**3)/DFLOAT(N+1)
+ DO J = 1,I-1
+ SSXY = SIG0(I,J) + MED0(I)*MED0(J)
+ SIG(I,J) = (N*SSXY+X(I)*X(J))/DFLOAT(N+1)-MED(I)*MED(J)
+ SIG(J,I) = SIG(I,J)
+ ENDDO
+ SK(I) = SIG(I,I)**(-1.5D0)*(S3X-3.D0*MED(I)*SSX+2.D0*MED(I)**3)
+ ENDDO
+ RETURN
END
diff --git a/recpr.for b/recpr.for
index de2d35fb63161f284c962348022fed5e0c4b0115..888f4ca3c67e740b8784d2058c16c5aca9041190 100644
--- a/recpr.for
+++ b/recpr.for
@@ -1,15 +1,15 @@
-C ------------------------------------------------------------------------
-C RECPR compute transition and marginal probabilities for
-C the adaptive MH block-sampler (see Fiorentini,Planas
-C and Rossi, Statistics and Computing 2014)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ------------------------------------------------------------------------
+C RECPR compute transition and marginal probabilities for
+C the adaptive MH block-sampler (see Fiorentini,Planas
+C and Rossi, Statistics and Computing 2014)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -20,35 +20,35 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ------------------------------------------------------------------------
- SUBROUTINE RECPR(N,NS,nobs,S,SW,PM,PTR)
-! INPUT
- INTEGER N,NS,nobs
- INTEGER S(nobs),SW(2*nobs)
-! INPUT/OUTPUT
- DOUBLE PRECISION PM(nobs,NS),PTR(nobs,NS,NS)
-! LOCALS
- INTEGER I,J,IT
-
-C Use previous run
- SW(1:nobs) = SW(nobs+1:2*nobs)
- SW(nobs+1:2*nobs) = S(1:nobs)
-
-C Transition probs Pr[S(t)|S(t-1),Y]
- DO 10 IT = 2,nobs
- DO 10 J = 1,NS
- DO 9 I = 1,NS-1
-9 PTR(IT,I,J) = (N*PTR(IT,I,J)*PM(IT-1,J)
- # + (SW(IT).EQ.I)*(SW(IT-1).EQ.J))
- # / (N*PM(IT-1,J)+ABS(SW(IT-1).EQ.J))
-10 PTR(IT,NS,J) = 1.D0-SUM(PTR(IT,1:NS-1,J))
-
- DO 30 IT = 1,nobs
- DO 20 I = 1,NS-1
-20 PM(IT,I) = (N*PM(IT,I)
- # + ABS(SW(IT).EQ.I))/DFLOAT(N+1)
-30 PM(IT,NS) = 1.D0 - SUM(PM(IT,1:NS-1))
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ------------------------------------------------------------------------
+ SUBROUTINE RECPR(N,NS,nobs,S,SW,PM,PTR)
+! INPUT
+ INTEGER N,NS,nobs
+ INTEGER S(nobs),SW(2*nobs)
+! INPUT/OUTPUT
+ DOUBLE PRECISION PM(nobs,NS),PTR(nobs,NS,NS)
+! LOCALS
+ INTEGER I,J,IT
+
+C Use previous run
+ SW(1:nobs) = SW(nobs+1:2*nobs)
+ SW(nobs+1:2*nobs) = S(1:nobs)
+
+C Transition probs Pr[S(t)|S(t-1),Y]
+ DO 10 IT = 2,nobs
+ DO 10 J = 1,NS
+ DO 9 I = 1,NS-1
+9 PTR(IT,I,J) = (N*PTR(IT,I,J)*PM(IT-1,J)
+ # + (SW(IT).EQ.I)*(SW(IT-1).EQ.J))
+ # / (N*PM(IT-1,J)+ABS(SW(IT-1).EQ.J))
+10 PTR(IT,NS,J) = 1.D0-SUM(PTR(IT,1:NS-1,J))
+
+ DO 30 IT = 1,nobs
+ DO 20 I = 1,NS-1
+20 PM(IT,I) = (N*PM(IT,I)
+ # + ABS(SW(IT).EQ.I))/DFLOAT(N+1)
+30 PM(IT,NS) = 1.D0 - SUM(PM(IT,1:NS-1))
+
+ RETURN
END
diff --git a/schollu.for b/schollu.for
index e1c1b2aad6f7b7f0b82b140baa841d4fde71c73c..fd787b7a9ea72c6bc77f83b32621e80c17c2494f 100644
--- a/schollu.for
+++ b/schollu.for
@@ -1,28 +1,28 @@
-C ---------------------------------------------------------------
-C The Cholesky decomposition of the MxM real symmetric positive
-C semi-definite matrix A=LU
-C U is the transpose of L, is performed and stored in the lower
-C triangle of the array L.
-C A is retained so that the solution obtained can be subsequently
-C improved. The procedure will fail if A, modified by the rounding
-C errors, is not positive semi-definite.
-C
-C A input matrix
-C L lower triangular matrix of the Cholesky decomposition
-C M actual dimension of A
-C NULL nullity of A, i.e. # of "zeros" diagonal elements of L
-C TINY used as tolerance
-C IFAIL 1 if A not positive semi-definite, 0 otherwise
-C Modified from Wilkinson & Reinsch (1971) p.21 and Healy AS6
-C
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ---------------------------------------------------------------
+C The Cholesky decomposition of the MxM real symmetric positive
+C semi-definite matrix A=LU
+C U is the transpose of L, is performed and stored in the lower
+C triangle of the array L.
+C A is retained so that the solution obtained can be subsequently
+C improved. The procedure will fail if A, modified by the rounding
+C errors, is not positive semi-definite.
+C
+C A input matrix
+C L lower triangular matrix of the Cholesky decomposition
+C M actual dimension of A
+C NULL nullity of A, i.e. # of "zeros" diagonal elements of L
+C TINY used as tolerance
+C IFAIL 1 if A not positive semi-definite, 0 otherwise
+C Modified from Wilkinson & Reinsch (1971) p.21 and Healy AS6
+C
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -33,41 +33,41 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ---------------------------------------------------------------
- SUBROUTINE SCHOLLU(A,L,M,NULL,TINY,IFAIL)
-C INPUT
- INTEGER M,NULL
- DOUBLE PRECISION A(M,M),TINY,X
-C OUTPUT
- DOUBLE PRECISION L(M,M)
- INTEGER IFAIL
-C LOCALS
- INTEGER I,J,K
-
- NULL=0
- DO 10 I=1,M
- X=A(I,I)
- DO 20 K=I-1,1,-1
- 20 X=X-L(I,K)*L(I,K)
- IF (X.GE.TINY) THEN
- L(I,I)=DSQRT(X)
- DO 21 J=I+1,M
- X=A(I,J)
- DO 22 K=I-1,1,-1
- 22 X=X-L(J,K)*L(I,K)
- 21 L(J,I)=X/L(I,I)
- ELSE IF (X.GE.0.D0) THEN
- NULL=NULL+1
- L(I,I)=0.D0
- DO 23 J=I+1,M
- 23 L(J,I)=0.D0
- ELSE
- IFAIL=1
- RETURN
- ENDIF
- 10 CONTINUE
-
- IFAIL=0
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ---------------------------------------------------------------
+ SUBROUTINE SCHOLLU(A,L,M,NULL,TINY,IFAIL)
+C INPUT
+ INTEGER M,NULL
+ DOUBLE PRECISION A(M,M),TINY,X
+C OUTPUT
+ DOUBLE PRECISION L(M,M)
+ INTEGER IFAIL
+C LOCALS
+ INTEGER I,J,K
+
+ NULL=0
+ DO 10 I=1,M
+ X=A(I,I)
+ DO 20 K=I-1,1,-1
+ 20 X=X-L(I,K)*L(I,K)
+ IF (X.GE.TINY) THEN
+ L(I,I)=DSQRT(X)
+ DO 21 J=I+1,M
+ X=A(I,J)
+ DO 22 K=I-1,1,-1
+ 22 X=X-L(J,K)*L(I,K)
+ 21 L(J,I)=X/L(I,I)
+ ELSE IF (X.GE.0.D0) THEN
+ NULL=NULL+1
+ L(I,I)=0.D0
+ DO 23 J=I+1,M
+ 23 L(J,I)=0.D0
+ ELSE
+ IFAIL=1
+ RETURN
+ ENDIF
+ 10 CONTINUE
+
+ IFAIL=0
+ RETURN
END
diff --git a/simdata.for b/simdata.for
index c66e6c6bd482c982aef6bccf6327059be2dedb86..0ecef50a241dcd197a7386d309d18e804eafec17 100644
--- a/simdata.for
+++ b/simdata.for
@@ -1,40 +1,40 @@
-C --------------------------------------------------------------------
-C SIMDATA simulates (S, x, yk) given (theta,psi)
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C Set latent variables: INFOS (9 x nv)
-C by cols: S1,S2,...,Snv; with nv <=6
-C by row: the 1st contains the # of matrices affected by Si
-C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
-C the 8-th row contains the # of states
-C the 9-th row spec the dynamics for Sj
-
-C OUTPUT:
-C
-C S ~ p(S|psi)
-C STATE ~ p(x|S,theta)
-C yk ~ p(y|S,x,theta)
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C SIMDATA simulates (S, x, yk) given (theta,psi)
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C Set latent variables: INFOS (9 x nv)
+C by cols: S1,S2,...,Snv; with nv <=6
+C by row: the 1st contains the # of matrices affected by Si
+C the 2nd-3rd etc point to c (1),H (2),G (3),a (4),F (5),R (6)
+C the 8-th row contains the # of states
+C the 9-th row spec the dynamics for Sj
+
+C OUTPUT:
+C
+C S ~ p(S|psi)
+C STATE ~ p(x|S,theta)
+C yk ~ p(y|S,x,theta)
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -45,162 +45,162 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE SIMDATA(nobs,d,ny,nz,nx,nu,ns,nstot,nt,nv,np,INFOS,
- 1 pdll,theta,psi,Z,STATE,yk)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),nstot,nt,nv,np(3),INFOS(9,6)
- DOUBLE PRECISION theta(nt),psi(np(1))
-C OUTPUT
- INTEGER Z(nobs)
- DOUBLE PRECISION STATE(nobs,nx),yk(nobs,ny+nz)
-
-C LOCALS
- INTEGER ISEQ,I,J,K,it,IFAIL,IPIV(nx)
- INTEGER S(nobs,6),SEQ(nv)
- DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
- 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
- 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
- 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot)
-
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION genunf,gennor
-C EXTERNAL SUBROUTINES
- EXTERNAL DGETRF,DGETRI,DESIGNZ,PPROD,ERGODIC,INT2SEQ,LYAP,SETGMN,
- 1 GENMN
-
- DOUBLE PRECISION U,AUX
- DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:)
- DOUBLE PRECISION,ALLOCATABLE:: Xdd(:,:),Pdd(:,:,:),WORK(:),
- 1 FP(:,:),WORK1(:),UP(:)
-
-
- ALLOCATE (R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 3 Xdd(MAX(d(1),1),nx),Pdd(MAX(d(1),1),nx,nx),
- 3 WORK((nx+2)*(nx+1)/2),FP(nx,nx),WORK1(64*nx),UP(nu) )
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-
-C DRAW Z ~ Pr(S1 x ... x Snv|psi)
- S(:,:) = 1
- IF (nv.GT.0) THEN
- CALL DESIGNZ(nv,np(1),psi,INFOS,P1,P2,P3,P4,P5,P6)
-C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
- CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
-C ERGODIC solves PE: PE*(I-P') = 0
- CALL ERGODIC(nstot,PMAT,PE)
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0) ! Sampling from U(0,1)
- ISEQ = 1
- AUX = PE(1)
- DO 5 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-5 AUX = AUX + PE(ISEQ)
- Z(1) = ISEQ
- CALL INT2SEQ(Z(1),nv,INFOS,SEQ,S(1,:))
- DO it=2,nobs
-C U = G05CAF(U) ! Sampling from U(0,1)
- U = genunf(0.D0,1.D0) ! Sampling from U(0,1)
- ISEQ = 1
- AUX = PMAT(1,Z(it-1))
- DO 10 WHILE (AUX.LT.U)
- ISEQ = ISEQ + 1
-10 AUX = AUX + PMAT(ISEQ,Z(it-1))
- Z(it) = ISEQ
- CALL INT2SEQ(Z(it),nv,INFOS,SEQ,S(it,:))
- ENDDO
- ELSE
- S(:,:) = 1
- Z(:) = 1
- ENDIF
-
- yk(1:nobs,1:ny) = 0.D0
-C DRAW x(1) ~ N[x(1|0),P(1|0)]
- STATE(1,1:nx) = 0.D0
- IF (d(2).LT.nx) THEN
- Xdd(1,1:nx) = 0.D0
- Pdd(1,1:nx,1:nx) = 0.D0
- IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
- FP(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
- DO 25 I = d(2)+1,nx
-25 FP(I,I) = 1.D0+FP(I,I)
- IFAIL = -1
-C CALL F07ADF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),IFAIL)
-C CALL F07AJF(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
- CALL DGETRF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),IFAIL)
- CALL DGETRI(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
-
- DO 30 I = d(2)+1,nx
-30 Xdd(1,I) = SUM(FP(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
- ENDIF
- CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
- 1 R(d(2)+1:nx,1:nu,S(1,6)),Pdd(1,d(2)+1:nx,d(2)+1:nx))
- IFAIL = -1
-C CALL G05EAF(Xdd(1,d(2)+1:nx),nx-d(2),Pdd(1,d(2)+1:nx,d(2)+1:nx),
-C 1 nx-d(2),10.D-14,WORK,(nx+2)*(nx+1)/2,IFAIL)
-C CALL G05EZF(STATE(1,d(2)+1:nx),nx-d(2),WORK,(nx+2)*(nx+1)/2,
-C 1 IFAIL)
- CALL setgmn(Xdd(1,d(2)+1:nx),Pdd(1,d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE SIMDATA(nobs,d,ny,nz,nx,nu,ns,nstot,nt,nv,np,INFOS,
+ 1 pdll,theta,psi,Z,STATE,yk)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,ns(6),nstot,nt,nv,np(3),INFOS(9,6)
+ DOUBLE PRECISION theta(nt),psi(np(1))
+C OUTPUT
+ INTEGER Z(nobs)
+ DOUBLE PRECISION STATE(nobs,nx),yk(nobs,ny+nz)
+
+C LOCALS
+ INTEGER ISEQ,I,J,K,it,IFAIL,IPIV(nx)
+ INTEGER S(nobs,6),SEQ(nv)
+ DOUBLE PRECISION P1(INFOS(8,1),INFOS(8,1)),
+ 1 P2(INFOS(8,2),INFOS(8,2)),P3(INFOS(8,3),INFOS(8,3)),
+ 2 P4(INFOS(8,4),INFOS(8,4)),P5(INFOS(8,5),INFOS(8,5)),
+ 3 P6(INFOS(8,6),INFOS(8,6)),PMAT(nstot,nstot),PE(nstot)
+
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION genunf,gennor
+C EXTERNAL SUBROUTINES
+ EXTERNAL DGETRF,DGETRI,DESIGNZ,PPROD,ERGODIC,INT2SEQ,LYAP,SETGMN,
+ 1 GENMN
+
+ DOUBLE PRECISION U,AUX
+ DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:)
+ DOUBLE PRECISION,ALLOCATABLE:: Xdd(:,:),Pdd(:,:,:),WORK(:),
+ 1 FP(:,:),WORK1(:),UP(:)
+
+
+ ALLOCATE (R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 3 Xdd(MAX(d(1),1),nx),Pdd(MAX(d(1),1),nx,nx),
+ 3 WORK((nx+2)*(nx+1)/2),FP(nx,nx),WORK1(64*nx),UP(nu) )
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+
+C DRAW Z ~ Pr(S1 x ... x Snv|psi)
+ S(:,:) = 1
+ IF (nv.GT.0) THEN
+ CALL DESIGNZ(nv,np(1),psi,INFOS,P1,P2,P3,P4,P5,P6)
+C PALL(i,j) = Pr[Z(t+1)=i|Z(t)=j], Z = S1 x S2 x ... x Snv
+ CALL PPROD(nv,nstot,INFOS,P1,P2,P3,P4,P5,P6,PMAT)
+C ERGODIC solves PE: PE*(I-P') = 0
+ CALL ERGODIC(nstot,PMAT,PE)
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0) ! Sampling from U(0,1)
+ ISEQ = 1
+ AUX = PE(1)
+ DO 5 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+5 AUX = AUX + PE(ISEQ)
+ Z(1) = ISEQ
+ CALL INT2SEQ(Z(1),nv,INFOS,SEQ,S(1,:))
+ DO it=2,nobs
+C U = G05CAF(U) ! Sampling from U(0,1)
+ U = genunf(0.D0,1.D0) ! Sampling from U(0,1)
+ ISEQ = 1
+ AUX = PMAT(1,Z(it-1))
+ DO 10 WHILE (AUX.LT.U)
+ ISEQ = ISEQ + 1
+10 AUX = AUX + PMAT(ISEQ,Z(it-1))
+ Z(it) = ISEQ
+ CALL INT2SEQ(Z(it),nv,INFOS,SEQ,S(it,:))
+ ENDDO
+ ELSE
+ S(:,:) = 1
+ Z(:) = 1
+ ENDIF
+
+ yk(1:nobs,1:ny) = 0.D0
+C DRAW x(1) ~ N[x(1|0),P(1|0)]
+ STATE(1,1:nx) = 0.D0
+ IF (d(2).LT.nx) THEN
+ Xdd(1,1:nx) = 0.D0
+ Pdd(1,1:nx,1:nx) = 0.D0
+ IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
+ FP(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
+ DO 25 I = d(2)+1,nx
+25 FP(I,I) = 1.D0+FP(I,I)
+ IFAIL = -1
+C CALL F07ADF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),IFAIL)
+C CALL F07AJF(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
+ CALL DGETRF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),IFAIL)
+ CALL DGETRI(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
+
+ DO 30 I = d(2)+1,nx
+30 Xdd(1,I) = SUM(FP(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
+ ENDIF
+ CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
+ 1 R(d(2)+1:nx,1:nu,S(1,6)),Pdd(1,d(2)+1:nx,d(2)+1:nx))
+ IFAIL = -1
+C CALL G05EAF(Xdd(1,d(2)+1:nx),nx-d(2),Pdd(1,d(2)+1:nx,d(2)+1:nx),
+C 1 nx-d(2),10.D-14,WORK,(nx+2)*(nx+1)/2,IFAIL)
+C CALL G05EZF(STATE(1,d(2)+1:nx),nx-d(2),WORK,(nx+2)*(nx+1)/2,
+C 1 IFAIL)
+ CALL setgmn(Xdd(1,d(2)+1:nx),Pdd(1,d(2)+1:nx,d(2)+1:nx),nx-d(2),
# nx-d(2),WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2))
- CALL genmn(WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2),STATE(1,d(2)+1:nx),
- # WORK1(1:nx-d(2)))
-
- ENDIF
-
-C DRAW u(1)
- DO 35 J = 1,nu
-C35 UP(J) = G05DDF(0.0D0,1.D0)
-35 UP(J) = gennor(0.0D0,1.D0)
-
-
-C COMPUTE y(1)
- DO 36 K = 1,ny
-36 yk(1,K) = SUM(H(K,1:nx,S(1,2))*STATE(1,1:nx))
- # + SUM(G(K,1:nu,S(1,3))*UP(1:nu))
- # + SUM(c(K,1:nz,S(1,1))*yk(1,ny+1:ny+nz))
-
- DO 100 it = 2,nobs
-C DRAW u ~ N(0,I)
- DO 40 J = 1,nu
-C40 UP(J) = G05DDF(0.0D0,1.D0)
-40 UP(J) = gennor(0.0D0,1.D0)
-
-C COMPUTE x
- DO 50 K = 1,nx
-50 STATE(it,K) = a(K,S(it,4))
- # + SUM(F(K,1:nx,S(it,5))*STATE(it-1,1:nx))
- # + SUM(R(K,1:nu,S(it,6))*UP(1:nu))
-
-C COMPUTE yk
- DO 60 K = 1,ny
-60 yk(it,K) = SUM(H(K,1:nx,S(it,2))*STATE(it,1:nx))
- # + SUM(G(K,1:nu,S(it,3))*UP(1:nu))
- # + SUM(c(K,1:nz,S(it,1))*yk(it,ny+1:ny+nz))
-
-100 CONTINUE
-
- DEALLOCATE (R,c,H,G,a,F,Xdd,Pdd,WORK,FP,WORK1,UP)
-
- RETURN
+ CALL genmn(WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2),STATE(1,d(2)+1:nx),
+ # WORK1(1:nx-d(2)))
+
+ ENDIF
+
+C DRAW u(1)
+ DO 35 J = 1,nu
+C35 UP(J) = G05DDF(0.0D0,1.D0)
+35 UP(J) = gennor(0.0D0,1.D0)
+
+
+C COMPUTE y(1)
+ DO 36 K = 1,ny
+36 yk(1,K) = SUM(H(K,1:nx,S(1,2))*STATE(1,1:nx))
+ # + SUM(G(K,1:nu,S(1,3))*UP(1:nu))
+ # + SUM(c(K,1:nz,S(1,1))*yk(1,ny+1:ny+nz))
+
+ DO 100 it = 2,nobs
+C DRAW u ~ N(0,I)
+ DO 40 J = 1,nu
+C40 UP(J) = G05DDF(0.0D0,1.D0)
+40 UP(J) = gennor(0.0D0,1.D0)
+
+C COMPUTE x
+ DO 50 K = 1,nx
+50 STATE(it,K) = a(K,S(it,4))
+ # + SUM(F(K,1:nx,S(it,5))*STATE(it-1,1:nx))
+ # + SUM(R(K,1:nu,S(it,6))*UP(1:nu))
+
+C COMPUTE yk
+ DO 60 K = 1,ny
+60 yk(it,K) = SUM(H(K,1:nx,S(it,2))*STATE(it,1:nx))
+ # + SUM(G(K,1:nu,S(it,3))*UP(1:nu))
+ # + SUM(c(K,1:nz,S(it,1))*yk(it,ny+1:ny+nz))
+
+100 CONTINUE
+
+ DEALLOCATE (R,c,H,G,a,F,Xdd,Pdd,WORK,FP,WORK1,UP)
+
+ RETURN
END
diff --git a/simprior.for b/simprior.for
index e2983b84e1f5bb24e2de586749977d4bbaa92df4..a9503f40a4ff76848977194fc15122489a475c53 100644
--- a/simprior.for
+++ b/simprior.for
@@ -1,13 +1,13 @@
-C --------------------------------------------------------------------
-C SIMPRIOR SIMULATES theta from the PRIOR pdf
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C SIMPRIOR SIMULATES theta from the PRIOR pdf
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,62 +18,62 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE SIMPRIOR(estimation,nt,thetaprior,tipo,ntf,INDT,theta)
-C INPUT
- INTEGER nt
- DOUBLE PRECISION thetaprior(nt,4)
- CHARACTER*2 tipo(nt),estimation
-C OUTPUT
- INTEGER ntf,INDT(nt+2)
- DOUBLE PRECISION theta(nt)
-C LOCALS
- INTEGER I,IFAIL
- DOUBLE PRECISION LB,UB,PLB,PUB
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION cumnorm,TNORMI,gengam,genbet
-
- INDT(:) = 0
- ntf = 0
- DO I = 1,nt
- IF (thetaprior(I,3).LT.thetaprior(I,4)) THEN
- ntf = ntf + 1
- INDT(ntf) = I
- IF (estimation.EQ.'BA') THEN
- IF (tipo(I).EQ.'IG') THEN
- IFAIL = -1
-C CALL G05FFF(thetaprior(I,2)/2.D0,2.D0/thetaprior(I,1),1,
-C 1 theta(I),IFAIL)
- theta(I) = 1.D0
- # / gengam(thetaprior(I,1)/2.D0,thetaprior(I,2)/2.D0)
- IF( (theta(I).LT.thetaprior(I,3)).OR.
- # (theta(I).GT.thetaprior(I,4)) ) THEN
- theta(I) = (thetaprior(I,4)+thetaprior(I,3))/2.D0
- ENDIF
- ELSEIF (tipo(I).EQ.'NT') THEN
- LB = (thetaprior(I,3)-thetaprior(I,1))/DSQRT(thetaprior(I,2))
- UB = (thetaprior(I,4)-thetaprior(I,1))/DSQRT(thetaprior(I,2))
-c PLB = S15ABF(LB,IFAIL)
-c PUB = S15ABF(UB,IFAIL)
- PLB = cumnorm(LB)
- PUB = cumnorm(UB)
- theta(I) = TNORMI(PLB,PUB)
- theta(I) = thetaprior(I,1)+theta(I)*DSQRT(thetaprior(I,2))
- ELSEIF (tipo(I).EQ.'BE') THEN
- IFAIL = -1
-C CALL G05FEF(thetaprior(I,1),thetaprior(I,2),1,theta(I),IFAIL)
- theta(I) = genbet(thetaprior(I,1),thetaprior(I,2))
- theta(I) = theta(I)*(thetaprior(I,4)-thetaprior(I,3))
- + + thetaprior(I,3)
- ENDIF
- ELSE
- theta(I) = thetaprior(I,1)
- ENDIF
- ELSE
- theta(I) = thetaprior(I,3)
- ENDIF
- ENDDO
- INDT(nt+2) = ntf ! # OF FREE PARS
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE SIMPRIOR(estimation,nt,thetaprior,tipo,ntf,INDT,theta)
+C INPUT
+ INTEGER nt
+ DOUBLE PRECISION thetaprior(nt,4)
+ CHARACTER*2 tipo(nt),estimation
+C OUTPUT
+ INTEGER ntf,INDT(nt+2)
+ DOUBLE PRECISION theta(nt)
+C LOCALS
+ INTEGER I,IFAIL
+ DOUBLE PRECISION LB,UB,PLB,PUB
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION cumnorm,TNORMI,gengam,genbet
+
+ INDT(:) = 0
+ ntf = 0
+ DO I = 1,nt
+ IF (thetaprior(I,3).LT.thetaprior(I,4)) THEN
+ ntf = ntf + 1
+ INDT(ntf) = I
+ IF (estimation.EQ.'BA') THEN
+ IF (tipo(I).EQ.'IG') THEN
+ IFAIL = -1
+C CALL G05FFF(thetaprior(I,2)/2.D0,2.D0/thetaprior(I,1),1,
+C 1 theta(I),IFAIL)
+ theta(I) = 1.D0
+ # / gengam(thetaprior(I,1)/2.D0,thetaprior(I,2)/2.D0)
+ IF( (theta(I).LT.thetaprior(I,3)).OR.
+ # (theta(I).GT.thetaprior(I,4)) ) THEN
+ theta(I) = (thetaprior(I,4)+thetaprior(I,3))/2.D0
+ ENDIF
+ ELSEIF (tipo(I).EQ.'NT') THEN
+ LB = (thetaprior(I,3)-thetaprior(I,1))/DSQRT(thetaprior(I,2))
+ UB = (thetaprior(I,4)-thetaprior(I,1))/DSQRT(thetaprior(I,2))
+c PLB = S15ABF(LB,IFAIL)
+c PUB = S15ABF(UB,IFAIL)
+ PLB = cumnorm(LB)
+ PUB = cumnorm(UB)
+ theta(I) = TNORMI(PLB,PUB)
+ theta(I) = thetaprior(I,1)+theta(I)*DSQRT(thetaprior(I,2))
+ ELSEIF (tipo(I).EQ.'BE') THEN
+ IFAIL = -1
+C CALL G05FEF(thetaprior(I,1),thetaprior(I,2),1,theta(I),IFAIL)
+ theta(I) = genbet(thetaprior(I,1),thetaprior(I,2))
+ theta(I) = theta(I)*(thetaprior(I,4)-thetaprior(I,3))
+ + + thetaprior(I,3)
+ ENDIF
+ ELSE
+ theta(I) = thetaprior(I,1)
+ ENDIF
+ ELSE
+ theta(I) = thetaprior(I,3)
+ ENDIF
+ ENDDO
+ INDT(nt+2) = ntf ! # OF FREE PARS
+ RETURN
END
diff --git a/simstate.for b/simstate.for
index 698ff995e4c1e11a723c2000fa5ae2a5bc53d7cd..2094b57c227023dc9bfef09b9d6c58d4cf667254 100644
--- a/simstate.for
+++ b/simstate.for
@@ -1,34 +1,34 @@
-C --------------------------------------------------------------------
-C SIMSTATE IMPLEMENTS THE SIMULATION SMOOTHER in Durbin and
-C Koopman (2002), "A simple and efficient simulation smoother
-C for state space time series analysis". Biometrika, 89, 3, 603-15
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C OUTPUT:
-C
-C STATE ~ p(x|y,theta,Z) (nobs x nx)
-C
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C SIMSTATE IMPLEMENTS THE SIMULATION SMOOTHER in Durbin and
+C Koopman (2002), "A simple and efficient simulation smoother
+C for state space time series analysis". Biometrika, 89, 3, 603-15
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C OUTPUT:
+C
+C STATE ~ p(x|y,theta,Z) (nobs x nx)
+C
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -39,125 +39,125 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE SIMSTATE(nobs,d,ny,nz,nx,nu,ns,nt,yk,IYK,
- 1 theta,S,pdll,STATE)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),S(nobs,6),
- 1 IYK(nobs,ny+1)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
-C OUTPUT
- DOUBLE PRECISION STATE(nobs,nx)
-C LOCALS
- INTEGER I,J,K,it,IFAIL,IPIV(nx)
- DOUBLE PRECISION,ALLOCATABLE:: ykP(:,:),XP(:,:),XS(:,:),PS(:,:,:)
- DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:)
- DOUBLE PRECISION,ALLOCATABLE:: Xdd(:,:),Pdd(:,:,:),WORK(:),
- 1 FP(:,:),WORK1(:),UP(:)
-C EXTERNAL SUBROUTINES
- EXTERNAL DGETRF,DGETRI,SETGMN,GENMN,LYAP,KS
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION GENNOR
-
- ALLOCATE (R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 ykP(nobs,ny+nz),XP(nobs,nx),XS(nobs,nx),PS(nobs,nx,nx),
- 3 Xdd(MAX(d(1),1),nx),Pdd(MAX(d(1),1),nx,nx),
- 3 WORK((nx+2)*(nx+1)/2),FP(nx,nx),WORK1(64*nx),UP(nu) )
-
-C pdesign = getprocaddress(pdll, "DESIGN"C)
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-
- ykP(:,:) = 0.D0
-C DRAW x(1)+ FROM N[x(1|0),P(1|0)]
- XP(1,1:nx) = 0.D0
- IF (d(2).LT.nx) THEN
- Xdd(1,1:nx) = 0.D0
- Pdd(1,1:nx,1:nx) = 0.D0
- IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
- FP(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
- DO 20 I = d(2)+1,nx
-20 FP(I,I) = 1.D0+FP(I,I)
- IFAIL = -1
-C CALL F07ADF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),IFAIL)
-C CALL F07AJF(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
- CALL DGETRF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),IFAIL)
- CALL DGETRI(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
- DO 30 I = d(2)+1,nx
-30 Xdd(1,I) = SUM(FP(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
- ENDIF
- CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
- 1 R(d(2)+1:nx,1:nu,S(1,6)),Pdd(1,d(2)+1:nx,d(2)+1:nx))
- IFAIL = -1
-c CALL G05EAF(Xdd(1,d(2)+1:nx),nx-d(2),Pdd(1,d(2)+1:nx,d(2)+1:nx),
-c 1 nx-d(2),10.D-14,WORK,(nx+2)*(nx+1)/2,IFAIL)
-c CALL G05EZF(XP(1,d(2)+1:nx),nx-d(2),WORK,(nx+2)*(nx+1)/2,IFAIL)
- CALL setgmn(Xdd(1,d(2)+1:nx),Pdd(1,d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE SIMSTATE(nobs,d,ny,nz,nx,nu,ns,nt,yk,IYK,
+ 1 theta,S,pdll,STATE)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),S(nobs,6),
+ 1 IYK(nobs,ny+1)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
+C OUTPUT
+ DOUBLE PRECISION STATE(nobs,nx)
+C LOCALS
+ INTEGER I,J,K,it,IFAIL,IPIV(nx)
+ DOUBLE PRECISION,ALLOCATABLE:: ykP(:,:),XP(:,:),XS(:,:),PS(:,:,:)
+ DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:)
+ DOUBLE PRECISION,ALLOCATABLE:: Xdd(:,:),Pdd(:,:,:),WORK(:),
+ 1 FP(:,:),WORK1(:),UP(:)
+C EXTERNAL SUBROUTINES
+ EXTERNAL DGETRF,DGETRI,SETGMN,GENMN,LYAP,KS
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION GENNOR
+
+ ALLOCATE (R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 ykP(nobs,ny+nz),XP(nobs,nx),XS(nobs,nx),PS(nobs,nx,nx),
+ 3 Xdd(MAX(d(1),1),nx),Pdd(MAX(d(1),1),nx,nx),
+ 3 WORK((nx+2)*(nx+1)/2),FP(nx,nx),WORK1(64*nx),UP(nu) )
+
+C pdesign = getprocaddress(pdll, "DESIGN"C)
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+
+ ykP(:,:) = 0.D0
+C DRAW x(1)+ FROM N[x(1|0),P(1|0)]
+ XP(1,1:nx) = 0.D0
+ IF (d(2).LT.nx) THEN
+ Xdd(1,1:nx) = 0.D0
+ Pdd(1,1:nx,1:nx) = 0.D0
+ IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
+ FP(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
+ DO 20 I = d(2)+1,nx
+20 FP(I,I) = 1.D0+FP(I,I)
+ IFAIL = -1
+C CALL F07ADF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),IFAIL)
+C CALL F07AJF(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
+ CALL DGETRF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),IFAIL)
+ CALL DGETRI(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
+ DO 30 I = d(2)+1,nx
+30 Xdd(1,I) = SUM(FP(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
+ ENDIF
+ CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
+ 1 R(d(2)+1:nx,1:nu,S(1,6)),Pdd(1,d(2)+1:nx,d(2)+1:nx))
+ IFAIL = -1
+c CALL G05EAF(Xdd(1,d(2)+1:nx),nx-d(2),Pdd(1,d(2)+1:nx,d(2)+1:nx),
+c 1 nx-d(2),10.D-14,WORK,(nx+2)*(nx+1)/2,IFAIL)
+c CALL G05EZF(XP(1,d(2)+1:nx),nx-d(2),WORK,(nx+2)*(nx+1)/2,IFAIL)
+ CALL setgmn(Xdd(1,d(2)+1:nx),Pdd(1,d(2)+1:nx,d(2)+1:nx),nx-d(2),
# nx-d(2),WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2))
- CALL genmn(WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2),STATE(1,d(2)+1:nx),
- # WORK1(1:nx-d(2)))
-
- ENDIF
-
-C DRAW u(1)+
- DO 35 J = 1,nu
-C35 UP(J) = G05DDF(0.0D0,1.D0)
-35 UP(J) = gennor(0.0D0,1.D0)
-
-C COMPUTE y(1)+
- DO 36 K = 1,ny
-36 ykP(1,K) = SUM(H(K,1:nx,S(1,2))*XP(1,1:nx))
- # + SUM(G(K,1:nu,S(1,3))*UP(1:nu))
- # + SUM(c(K,1:nz,S(1,1))*yk(1,ny+1:ny+nz))
-
- DO 100 it = 2,nobs
-C DRAW u+ ~ N(0,I)
- DO 40 J = 1,nu
-C40 UP(J) = G05DDF(0.0D0,1.D0)
-40 UP(J) = gennor(0.0D0,1.D0)
-
-C COMPUTE x+
- DO 50 K = 1,nx
-50 XP(it,K) = a(K,S(it,4))+SUM(F(K,1:nx,S(it,5))*XP(it-1,1:nx))
- # + SUM(R(K,1:nu,S(it,6))*UP(1:nu))
-
-C COMPUTE yk+
- DO 60 K = 1,ny
-60 ykP(it,K) = SUM(H(K,1:nx,S(it,2))*XP(it,1:nx))
- # + SUM(G(K,1:nu,S(it,3))*UP(1:nu))
- # + SUM(c(K,1:nz,S(it,1))*yk(it,ny+1:ny+nz))
-
-100 CONTINUE
-
-C KALMAN SMOOTHING RECURSIONS
- a(:,:) = 0.D0
- c(:,:,:) = 0.D0
- CALL KS(nobs,d,ny,nz,nx,nu,ns,S,yk-ykP,IYK,c,H,G,a,F,R,XS,PS)
-
-C SETTING THE STATE
- STATE(1:nobs,:) = XP(1:nobs,:) + XS(1:nobs,:)
-
- DEALLOCATE(R,c,H,G,a,F,ykP,XP,XS,PS,Xdd,Pdd,WORK,FP,WORK1,UP)
-
- RETURN
+ CALL genmn(WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2),STATE(1,d(2)+1:nx),
+ # WORK1(1:nx-d(2)))
+
+ ENDIF
+
+C DRAW u(1)+
+ DO 35 J = 1,nu
+C35 UP(J) = G05DDF(0.0D0,1.D0)
+35 UP(J) = gennor(0.0D0,1.D0)
+
+C COMPUTE y(1)+
+ DO 36 K = 1,ny
+36 ykP(1,K) = SUM(H(K,1:nx,S(1,2))*XP(1,1:nx))
+ # + SUM(G(K,1:nu,S(1,3))*UP(1:nu))
+ # + SUM(c(K,1:nz,S(1,1))*yk(1,ny+1:ny+nz))
+
+ DO 100 it = 2,nobs
+C DRAW u+ ~ N(0,I)
+ DO 40 J = 1,nu
+C40 UP(J) = G05DDF(0.0D0,1.D0)
+40 UP(J) = gennor(0.0D0,1.D0)
+
+C COMPUTE x+
+ DO 50 K = 1,nx
+50 XP(it,K) = a(K,S(it,4))+SUM(F(K,1:nx,S(it,5))*XP(it-1,1:nx))
+ # + SUM(R(K,1:nu,S(it,6))*UP(1:nu))
+
+C COMPUTE yk+
+ DO 60 K = 1,ny
+60 ykP(it,K) = SUM(H(K,1:nx,S(it,2))*XP(it,1:nx))
+ # + SUM(G(K,1:nu,S(it,3))*UP(1:nu))
+ # + SUM(c(K,1:nz,S(it,1))*yk(it,ny+1:ny+nz))
+
+100 CONTINUE
+
+C KALMAN SMOOTHING RECURSIONS
+ a(:,:) = 0.D0
+ c(:,:,:) = 0.D0
+ CALL KS(nobs,d,ny,nz,nx,nu,ns,S,yk-ykP,IYK,c,H,G,a,F,R,XS,PS)
+
+C SETTING THE STATE
+ STATE(1:nobs,:) = XP(1:nobs,:) + XS(1:nobs,:)
+
+ DEALLOCATE(R,c,H,G,a,F,ykP,XP,XS,PS,Xdd,Pdd,WORK,FP,WORK1,UP)
+
+ RETURN
END
diff --git a/simstate2.for b/simstate2.for
index 63644b9cb5eaf5782fd90a132cc8bbd92ffe6197..5b1d3d1d457990a5e8902b169f2c05d91e269b73 100644
--- a/simstate2.for
+++ b/simstate2.for
@@ -1,34 +1,34 @@
-C --------------------------------------------------------------------
-C SIMSTATE2 (no missing values) IMPLEMENTS THE SIMULATION SMOOTHER
-C in Durbin and Koopman (2002), "A simple and efficient simulation smoother
-C for state space time series analysis". Biometrika, 89, 3, 603-15
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
-C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
-C
-C y(t) (ny x 1) ny = # of endogenous series
-C z(t) (nz x 1) nz = # of exogenous series
-C x(t) (nx x 1) nx = # of continous states
-C u(t) (nu x 1) nu = # of shocks
-C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
-C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
-C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
-C a(t) (nx x ns4) ns4 = # of states for S4(t)
-C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
-C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
-C
-C OUTPUT:
-C
-C STATE ~ p(x|y,theta,Z) (nobs x nx)
-C
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------------------------------------
+C SIMSTATE2 (no missing values) IMPLEMENTS THE SIMULATION SMOOTHER
+C in Durbin and Koopman (2002), "A simple and efficient simulation smoother
+C for state space time series analysis". Biometrika, 89, 3, 603-15
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C State-space format: y(t) = c(t)z(t) + H(t)x(t) + G(t)u(t)
+C x(t) = a(t) + F(t)x(t-1) + R(t)u(t)
+C
+C y(t) (ny x 1) ny = # of endogenous series
+C z(t) (nz x 1) nz = # of exogenous series
+C x(t) (nx x 1) nx = # of continous states
+C u(t) (nu x 1) nu = # of shocks
+C c(t) (ny x nz x ns1) ns1 = # of states for c(t)
+C H(t) (ny x nx x ns2) ns2 = # of states for S2(t)
+C G(t) (ny x nu x ns3) ns3 = # of states for S3(t)
+C a(t) (nx x ns4) ns4 = # of states for S4(t)
+C F(t) (nx x nx x ns5) ns5 = # of states for S5(t)
+C R(t) (nx x nu x ns6) ns6 = # of states for S6(t)
+C
+C OUTPUT:
+C
+C STATE ~ p(x|y,theta,Z) (nobs x nx)
+C
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -39,123 +39,123 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------------------------------------
- SUBROUTINE SIMSTATE2(nobs,d,ny,nz,nx,nu,ns,nt,yk,
- 1 theta,S,pdll,STATE)
-
- USE dfwin
- INTERFACE
- SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
- INTEGER ny,nz,nx,nu,ns(6),nt
- DOUBLE PRECISION theta(nt)
- DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
- END SUBROUTINE
- END INTERFACE
- POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
- POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
-
-C INPUT
- INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
-C OUTPUT
- DOUBLE PRECISION STATE(nobs,nx)
-C LOCALS
- INTEGER I,J,K,it,IFAIL,IPIV(nx)
- DOUBLE PRECISION,ALLOCATABLE:: ykP(:,:),XP(:,:),XS(:,:)
- DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
- 1 G(:,:,:),a(:,:),F(:,:,:)
- DOUBLE PRECISION,ALLOCATABLE:: Xdd(:,:),Pdd(:,:,:),WORK(:),
- 1 FP(:,:),WORK1(:),UP(:)
-C EXTERNAL SUBROUTINES
- EXTERNAL DGETRF,DGETRI,SETGMN,GENMN,LYAP,KS2
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION GENNOR
-
- ALLOCATE (R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
- 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
- 2 ykP(nobs,ny+nz),XP(nobs,nx),XS(nobs,nx),
- 3 Xdd(MAX(d(1),1),nx),Pdd(MAX(d(1),1),nx,nx),
- 3 WORK((nx+2)*(nx+1)/2),FP(nx,nx),WORK1(64*nx),UP(nu) )
-
- pdesign = getprocaddress(pdll, "design_"C)
- CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
-
- ykP(:,:) = 0.D0
-C DRAW x(1)+ FROM N[x(1|0),P(1|0)]
- XP(1,1:nx) = 0.D0
- IF (d(2).LT.nx) THEN
- Xdd(1,1:nx) = 0.D0
- Pdd(1,1:nx,1:nx) = 0.D0
- IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
- FP(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
- DO 20 I = d(2)+1,nx
-20 FP(I,I) = 1.D0+FP(I,I)
- IFAIL = -1
-C CALL F07ADF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),IFAIL)
-C CALL F07AJF(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
-C 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
- CALL DGETRF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),IFAIL)
- CALL DGETRI(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
- 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
- DO 30 I = d(2)+1,nx
-30 Xdd(1,I) = SUM(FP(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
- ENDIF
- CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
- 1 R(d(2)+1:nx,1:nu,S(1,6)),Pdd(1,d(2)+1:nx,d(2)+1:nx))
- IFAIL = -1
-C CALL G05EAF(Xdd(1,d(2)+1:nx),nx-d(2),Pdd(1,d(2)+1:nx,d(2)+1:nx),
-C 1 nx-d(2),10.D-14,WORK,(nx+2)*(nx+1)/2,IFAIL)
-C CALL G05EZF(XP(1,d(2)+1:nx),nx-d(2),WORK,(nx+2)*(nx+1)/2,IFAIL)
- CALL setgmn(Xdd(1,d(2)+1:nx),Pdd(1,d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------------------------------------
+ SUBROUTINE SIMSTATE2(nobs,d,ny,nz,nx,nu,ns,nt,yk,
+ 1 theta,S,pdll,STATE)
+
+ USE dfwin
+ INTERFACE
+ SUBROUTINE DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+ INTEGER ny,nz,nx,nu,ns(6),nt
+ DOUBLE PRECISION theta(nt)
+ DOUBLE PRECISION c(ny,max(1,nz),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),R(nx,nu,ns(6))
+ END SUBROUTINE
+ END INTERFACE
+ POINTER (pdll,fittizia) ! ASSOCIATE pointer pdll alla DLL ad una varibile fittizia
+ POINTER (pdesign,DESIGN) ! IMPORTANT associo il puntatore pdesign alla Interface definita
+
+C INPUT
+ INTEGER nobs,d(2),ny,nz,nx,nu,nt,ns(6),S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt)
+C OUTPUT
+ DOUBLE PRECISION STATE(nobs,nx)
+C LOCALS
+ INTEGER I,J,K,it,IFAIL,IPIV(nx)
+ DOUBLE PRECISION,ALLOCATABLE:: ykP(:,:),XP(:,:),XS(:,:)
+ DOUBLE PRECISION,ALLOCATABLE::R(:,:,:),c(:,:,:),H(:,:,:),
+ 1 G(:,:,:),a(:,:),F(:,:,:)
+ DOUBLE PRECISION,ALLOCATABLE:: Xdd(:,:),Pdd(:,:,:),WORK(:),
+ 1 FP(:,:),WORK1(:),UP(:)
+C EXTERNAL SUBROUTINES
+ EXTERNAL DGETRF,DGETRI,SETGMN,GENMN,LYAP,KS2
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION GENNOR
+
+ ALLOCATE (R(nx,nu,ns(6)),c(ny,max(nz,1),ns(1)),H(ny,nx,ns(2)),
+ 1 G(ny,nu,ns(3)),a(nx,ns(4)),F(nx,nx,ns(5)),
+ 2 ykP(nobs,ny+nz),XP(nobs,nx),XS(nobs,nx),
+ 3 Xdd(MAX(d(1),1),nx),Pdd(MAX(d(1),1),nx,nx),
+ 3 WORK((nx+2)*(nx+1)/2),FP(nx,nx),WORK1(64*nx),UP(nu) )
+
+ pdesign = getprocaddress(pdll, "design_"C)
+ CALL DESIGN(ny,nz,nx,nu,ns,nt,theta,c,H,G,a,F,R)
+
+ ykP(:,:) = 0.D0
+C DRAW x(1)+ FROM N[x(1|0),P(1|0)]
+ XP(1,1:nx) = 0.D0
+ IF (d(2).LT.nx) THEN
+ Xdd(1,1:nx) = 0.D0
+ Pdd(1,1:nx,1:nx) = 0.D0
+ IF(SUM(ABS(a(d(2)+1:nx,S(1,4)))).NE.0.D0) THEN
+ FP(d(2)+1:nx,d(2)+1:nx) = -F(d(2)+1:nx,d(2)+1:nx,S(1,5))
+ DO 20 I = d(2)+1,nx
+20 FP(I,I) = 1.D0+FP(I,I)
+ IFAIL = -1
+C CALL F07ADF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),IFAIL)
+C CALL F07AJF(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+C 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
+ CALL DGETRF(nx-d(2),nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),IFAIL)
+ CALL DGETRI(nx-d(2),FP(d(2)+1:nx,d(2)+1:nx),nx-d(2),
+ 1 IPIV(d(2)+1:nx),WORK1,64*nx,IFAIL)
+ DO 30 I = d(2)+1,nx
+30 Xdd(1,I) = SUM(FP(I,d(2)+1:nx)*a(d(2)+1:nx,S(1,4))) ! inv(I-F)*a
+ ENDIF
+ CALL LYAP(nx-d(2),nu,1.D-3,F(d(2)+1:nx,d(2)+1:nx,S(1,5)),
+ 1 R(d(2)+1:nx,1:nu,S(1,6)),Pdd(1,d(2)+1:nx,d(2)+1:nx))
+ IFAIL = -1
+C CALL G05EAF(Xdd(1,d(2)+1:nx),nx-d(2),Pdd(1,d(2)+1:nx,d(2)+1:nx),
+C 1 nx-d(2),10.D-14,WORK,(nx+2)*(nx+1)/2,IFAIL)
+C CALL G05EZF(XP(1,d(2)+1:nx),nx-d(2),WORK,(nx+2)*(nx+1)/2,IFAIL)
+ CALL setgmn(Xdd(1,d(2)+1:nx),Pdd(1,d(2)+1:nx,d(2)+1:nx),nx-d(2),
# nx-d(2),WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2))
- CALL genmn(WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2),STATE(1,d(2)+1:nx),
- # WORK1(1:nx-d(2)))
- ENDIF
-
-C DRAW u(1)+
- DO 35 J = 1,nu
-C35 UP(J) = G05DDF(0.0D0,1.D0)
-35 UP(J) = gennor(0.0D0,1.D0)
-
-
-C COMPUTE y(1)+
- DO 36 K = 1,ny
-36 ykP(1,K) = SUM(H(K,1:nx,S(1,2))*XP(1,1:nx))
- # + SUM(G(K,1:nu,S(1,3))*UP(1:nu))
- # + SUM(c(K,1:nz,S(1,1))*yk(1,ny+1:ny+nz))
-
- DO 100 it = 2,nobs
-C DRAW u+ ~ N(0,I)
- DO 40 J = 1,nu
-C40 UP(J) = G05DDF(0.0D0,1.D0)
-40 UP(J) = gennor(0.0D0,1.D0)
-
-C COMPUTE x+
- DO 50 K = 1,nx
-50 XP(it,K) = a(K,S(it,4))+SUM(F(K,1:nx,S(it,5))*XP(it-1,1:nx))
- # + SUM(R(K,1:nu,S(it,6))*UP(1:nu))
-
-C COMPUTE yk+
- DO 60 K = 1,ny
-60 ykP(it,K) = SUM(H(K,1:nx,S(it,2))*XP(it,1:nx))
- # + SUM(G(K,1:nu,S(it,3))*UP(1:nu))
- # + SUM(c(K,1:nz,S(it,1))*yk(it,ny+1:ny+nz))
-
-100 CONTINUE
-
-C KALMAN SMOOTHING RECURSIONS
- a(:,:) = 0.D0
- c(:,:,:) = 0.D0
- CALL KS2(nobs,d,ny,nz,nx,nu,ns,S,yk-ykP,c,H,G,a,F,R,XS)
-
-C SETTING THE STATE
- STATE(1:nobs,:) = XP(1:nobs,:) + XS(1:nobs,:)
-
- DEALLOCATE (R,c,H,G,a,F,ykP,XP,XS,Xdd,Pdd,WORK,FP,WORK1,UP)
-
- RETURN
+ CALL genmn(WORK(1:(nx-d(2)+2)*(nx-d(2)+1)/2),STATE(1,d(2)+1:nx),
+ # WORK1(1:nx-d(2)))
+ ENDIF
+
+C DRAW u(1)+
+ DO 35 J = 1,nu
+C35 UP(J) = G05DDF(0.0D0,1.D0)
+35 UP(J) = gennor(0.0D0,1.D0)
+
+
+C COMPUTE y(1)+
+ DO 36 K = 1,ny
+36 ykP(1,K) = SUM(H(K,1:nx,S(1,2))*XP(1,1:nx))
+ # + SUM(G(K,1:nu,S(1,3))*UP(1:nu))
+ # + SUM(c(K,1:nz,S(1,1))*yk(1,ny+1:ny+nz))
+
+ DO 100 it = 2,nobs
+C DRAW u+ ~ N(0,I)
+ DO 40 J = 1,nu
+C40 UP(J) = G05DDF(0.0D0,1.D0)
+40 UP(J) = gennor(0.0D0,1.D0)
+
+C COMPUTE x+
+ DO 50 K = 1,nx
+50 XP(it,K) = a(K,S(it,4))+SUM(F(K,1:nx,S(it,5))*XP(it-1,1:nx))
+ # + SUM(R(K,1:nu,S(it,6))*UP(1:nu))
+
+C COMPUTE yk+
+ DO 60 K = 1,ny
+60 ykP(it,K) = SUM(H(K,1:nx,S(it,2))*XP(it,1:nx))
+ # + SUM(G(K,1:nu,S(it,3))*UP(1:nu))
+ # + SUM(c(K,1:nz,S(it,1))*yk(it,ny+1:ny+nz))
+
+100 CONTINUE
+
+C KALMAN SMOOTHING RECURSIONS
+ a(:,:) = 0.D0
+ c(:,:,:) = 0.D0
+ CALL KS2(nobs,d,ny,nz,nx,nu,ns,S,yk-ykP,c,H,G,a,F,R,XS)
+
+C SETTING THE STATE
+ STATE(1:nobs,:) = XP(1:nobs,:) + XS(1:nobs,:)
+
+ DEALLOCATE (R,c,H,G,a,F,ykP,XP,XS,Xdd,Pdd,WORK,FP,WORK1,UP)
+
+ RETURN
END
diff --git a/slice.for b/slice.for
index 12bab96000d60b8a72e7405b19a9dd2625544599..616a43354369cd445f9612e3351e8fd682a8c9d4 100644
--- a/slice.for
+++ b/slice.for
@@ -1,14 +1,14 @@
-C -------------------------------------------------------------
-C SLICE implements the SINGLE-VARIABLE SLICE SAMPLING in Neal (2003),
-C Slice Sampling, Annals of Statistics 31, 705-67
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C SLICE implements the SINGLE-VARIABLE SLICE SAMPLING in Neal (2003),
+C Slice Sampling, Annals of Statistics 31, 705-67
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -19,121 +19,121 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,thetaprior,tipo,pdll,NEVAL,XSIM)
-C INPUT
- INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6),
- 1 IYK(nobs,ny+1)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
- CHARACTER*2 tipo
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia)
-
-C OUTPUT
- INTEGER NEVAL
- DOUBLE PRECISION XSIM
-C LOCALS
- INTEGER M,J,K,OK
- DOUBLE PRECISION XOLD,XLB,XUB
- DOUBLE PRECISION FXOLD,U,Z,L,R,W,FXL,FXR,FXSIM
- DOUBLE PRECISION genunf,PTHETA
-
- NEVAL = 0
- XOLD = theta(it)
- XLB = thetaprior(3)
- XUB = thetaprior(4)
-
-C -------------------------------------------------------
-C 1. DRAW Z = ln[f(X0)] - EXP(1) where EXP(1)=-ln(U(0,1))
-C THIS DEFINES THE SLICE S={x: z < ln(f(x))}
-C -------------------------------------------------------
- theta(it) = XOLD
- FXOLD=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- U = genunf(0.D0,1.D0)
- Z = FXOLD + DLOG(U)
-
-C -------------------------------------------------------------
-C 2. FIND I=(L,R) AROUND X0 THAT CONTAINS S AS MUCH AS POSSIBLE
-C STEPPING-OUT PROCEDURE
-C W = an estimate of the scale of SC
-C M = Limit on steps (-1 = +INF)
-C -------------------------------------------------------------
- M = -1
- W = max((XUB-XLB)/10.0,1.D0)
-C U = G05CAF(U)
- U = genunf(0.D0,1.D0)
- L = XOLD - W*U
- R = XOLD + W - W*U ! L + W
- IF (M.EQ.-1) THEN
- DO 100 WHILE(L.GT.XLB)
- theta(it) = L
- FXL=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXL.LE.Z) GOTO 110
-100 L = L - W
-110 DO 200 WHILE(R.LT.XUB)
- theta(it) = R
- FXR=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXR.LE.Z) GOTO 210
-200 R = R + W
-210 CONTINUE
- ELSE
-C U = G05CAF(U)
- U = genunf(0.D0,1.D0)
- J = M*U
- K = M-1-J
- DO 300 WHILE (J.GT.0)
- IF (L.LE.XLB) GOTO 310
- theta(it) = L
- FXL=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXL.LE.Z) GOTO 310
- L = L - W
-300 J = J - 1
-310 CONTINUE
- DO 400 WHILE (K.GT.0)
- IF (R.GE.XLB) GOTO 410
- theta(it) = R
- FXR=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXR.LE.Z) GOTO 410
- R = R + W
-400 K = K - 1
-410 CONTINUE
- ENDIF
- IF (L.LT.XLB) L = XLB
- IF (R.GT.XUB) R = XUB
-
-C ------------------------------------------------------
-C 3. SAMPLING FROM THE SET A = (I INTERSECT S) = (LA,RA)
-C ------------------------------------------------------
- OK = 0
- DO 500 WHILE (OK.EQ.0)
-C U = G05CAF(U)
- U = genunf(0.D0,1.D0)
- XSIM = L + U*(R - L)
- theta(it) = XSIM
- FXSIM=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXSIM.GE.Z) OK = 1
- IF(XSIM.GT.XOLD) THEN
- R = XSIM
- ELSE
- L = XSIM
- ENDIF
-500 CONTINUE
-
- theta(it) = XOLD
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE SLICE(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,thetaprior,tipo,pdll,NEVAL,XSIM)
+C INPUT
+ INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6),
+ 1 IYK(nobs,ny+1)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
+ CHARACTER*2 tipo
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia)
+
+C OUTPUT
+ INTEGER NEVAL
+ DOUBLE PRECISION XSIM
+C LOCALS
+ INTEGER M,J,K,OK
+ DOUBLE PRECISION XOLD,XLB,XUB
+ DOUBLE PRECISION FXOLD,U,Z,L,R,W,FXL,FXR,FXSIM
+ DOUBLE PRECISION genunf,PTHETA
+
+ NEVAL = 0
+ XOLD = theta(it)
+ XLB = thetaprior(3)
+ XUB = thetaprior(4)
+
+C -------------------------------------------------------
+C 1. DRAW Z = ln[f(X0)] - EXP(1) where EXP(1)=-ln(U(0,1))
+C THIS DEFINES THE SLICE S={x: z < ln(f(x))}
+C -------------------------------------------------------
+ theta(it) = XOLD
+ FXOLD=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ U = genunf(0.D0,1.D0)
+ Z = FXOLD + DLOG(U)
+
+C -------------------------------------------------------------
+C 2. FIND I=(L,R) AROUND X0 THAT CONTAINS S AS MUCH AS POSSIBLE
+C STEPPING-OUT PROCEDURE
+C W = an estimate of the scale of SC
+C M = Limit on steps (-1 = +INF)
+C -------------------------------------------------------------
+ M = -1
+ W = max((XUB-XLB)/10.0,1.D0)
+C U = G05CAF(U)
+ U = genunf(0.D0,1.D0)
+ L = XOLD - W*U
+ R = XOLD + W - W*U ! L + W
+ IF (M.EQ.-1) THEN
+ DO 100 WHILE(L.GT.XLB)
+ theta(it) = L
+ FXL=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXL.LE.Z) GOTO 110
+100 L = L - W
+110 DO 200 WHILE(R.LT.XUB)
+ theta(it) = R
+ FXR=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXR.LE.Z) GOTO 210
+200 R = R + W
+210 CONTINUE
+ ELSE
+C U = G05CAF(U)
+ U = genunf(0.D0,1.D0)
+ J = M*U
+ K = M-1-J
+ DO 300 WHILE (J.GT.0)
+ IF (L.LE.XLB) GOTO 310
+ theta(it) = L
+ FXL=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXL.LE.Z) GOTO 310
+ L = L - W
+300 J = J - 1
+310 CONTINUE
+ DO 400 WHILE (K.GT.0)
+ IF (R.GE.XLB) GOTO 410
+ theta(it) = R
+ FXR=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXR.LE.Z) GOTO 410
+ R = R + W
+400 K = K - 1
+410 CONTINUE
+ ENDIF
+ IF (L.LT.XLB) L = XLB
+ IF (R.GT.XUB) R = XUB
+
+C ------------------------------------------------------
+C 3. SAMPLING FROM THE SET A = (I INTERSECT S) = (LA,RA)
+C ------------------------------------------------------
+ OK = 0
+ DO 500 WHILE (OK.EQ.0)
+C U = G05CAF(U)
+ U = genunf(0.D0,1.D0)
+ XSIM = L + U*(R - L)
+ theta(it) = XSIM
+ FXSIM=PTHETA(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,IYK,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXSIM.GE.Z) OK = 1
+ IF(XSIM.GT.XOLD) THEN
+ R = XSIM
+ ELSE
+ L = XSIM
+ ENDIF
+500 CONTINUE
+
+ theta(it) = XOLD
+
+ RETURN
END
diff --git a/slice2.for b/slice2.for
index 9968287c54031a1e45af5c2a81fc432a6c48a521..6810e700ab2387ff42e66865c4d1bc03d0d0f304 100644
--- a/slice2.for
+++ b/slice2.for
@@ -1,14 +1,14 @@
-C -------------------------------------------------------------
-C SLICE2 (no missing values) implements the SINGLE-VARIABLE SLICE SAMPLING
-C in Neal (2003), Slice Sampling, Annals of Statistics 31, 705-67
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C -------------------------------------------------------------
+C SLICE2 (no missing values) implements the SINGLE-VARIABLE SLICE SAMPLING
+C in Neal (2003), Slice Sampling, Annals of Statistics 31, 705-67
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -19,120 +19,120 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C -------------------------------------------------------------
- SUBROUTINE SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,thetaprior,tipo,pdll,NEVAL,XSIM)
-C INPUT
- INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6)
- DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
- CHARACTER*2 tipo
- CHARACTER*1 fittizia
- POINTER (pdll,fittizia)
-
-C OUTPUT
- INTEGER NEVAL
- DOUBLE PRECISION XSIM
-C LOCALS
- INTEGER M,J,K,OK
- DOUBLE PRECISION XOLD,XLB,XUB
- DOUBLE PRECISION FXOLD,U,Z,L,R,W,FXL,FXR,FXSIM
- DOUBLE PRECISION genunf,PTHETA2
-
- NEVAL = 0
- XOLD = theta(it)
- XLB = thetaprior(3)
- XUB = thetaprior(4)
-
-C -------------------------------------------------------
-C 1. DRAW Z = ln[f(X0)] - EXP(1) where EXP(1)=-ln(U(0,1))
-C THIS DEFINES THE SLICE S={x: z < ln(f(x))}
-C -------------------------------------------------------
- theta(it) = XOLD
- FXOLD=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- U = genunf(0.D0,1.D0)
- Z = FXOLD + DLOG(U)
-
-C -------------------------------------------------------------
-C 2. FIND I=(L,R) AROUND X0 THAT CONTAINS S AS MUCH AS POSSIBLE
-C STEPPING-OUT PROCEDURE
-C W = an estimate of the scale of SC
-C M = Limit on steps (-1 = +INF)
-C -------------------------------------------------------------
- M = -1
- W = max((XUB-XLB)/10.0,1.D0)
-C U = G05CAF(U)
- U = genunf(0.D0,1.D0)
- L = XOLD - W*U
- R = XOLD + W - W*U ! L + W
- IF (M.EQ.-1) THEN
- DO 100 WHILE(L.GT.XLB)
- theta(it) = L
- FXL=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXL.LE.Z) GOTO 110
-100 L = L - W
-110 DO 200 WHILE(R.LT.XUB)
- theta(it) = R
- FXR=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXR.LE.Z) GOTO 210
-200 R = R + W
-210 CONTINUE
- ELSE
-C U = G05CAF(U)
- U = genunf(0.D0,1.D0)
- J = M*U
- K = M-1-J
- DO 300 WHILE (J.GT.0)
- IF (L.LE.XLB) GOTO 310
- theta(it) = L
- FXL=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXL.LE.Z) GOTO 310
- L = L - W
-300 J = J - 1
-310 CONTINUE
- DO 400 WHILE (K.GT.0)
- IF (R.GE.XLB) GOTO 410
- theta(it) = R
- FXR=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXR.LE.Z) GOTO 410
- R = R + W
-400 K = K - 1
-410 CONTINUE
- ENDIF
- IF (L.LT.XLB) L = XLB
- IF (R.GT.XUB) R = XUB
-
-C ------------------------------------------------------
-C 3. SAMPLING FROM THE SET A = (I INTERSECT S) = (LA,RA)
-C ------------------------------------------------------
- OK = 0
- DO 500 WHILE (OK.EQ.0)
-C U = G05CAF(U)
- U = genunf(0.D0,1.D0)
- XSIM = L + U*(R - L)
- theta(it) = XSIM
- FXSIM=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
- 1 theta,thetaprior,tipo,pdll)
- NEVAL = NEVAL + 1
- IF (FXSIM.GE.Z) OK = 1
- IF(XSIM.GT.XOLD) THEN
- R = XSIM
- ELSE
- L = XSIM
- ENDIF
-500 CONTINUE
-
- theta(it) = XOLD
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C -------------------------------------------------------------
+ SUBROUTINE SLICE2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,thetaprior,tipo,pdll,NEVAL,XSIM)
+C INPUT
+ INTEGER it,nobs,d(2),ny,nz,nx,nu,ns(6),nt,S(nobs,6)
+ DOUBLE PRECISION yk(nobs,ny+nz),theta(nt),thetaprior(4)
+ CHARACTER*2 tipo
+ CHARACTER*1 fittizia
+ POINTER (pdll,fittizia)
+
+C OUTPUT
+ INTEGER NEVAL
+ DOUBLE PRECISION XSIM
+C LOCALS
+ INTEGER M,J,K,OK
+ DOUBLE PRECISION XOLD,XLB,XUB
+ DOUBLE PRECISION FXOLD,U,Z,L,R,W,FXL,FXR,FXSIM
+ DOUBLE PRECISION genunf,PTHETA2
+
+ NEVAL = 0
+ XOLD = theta(it)
+ XLB = thetaprior(3)
+ XUB = thetaprior(4)
+
+C -------------------------------------------------------
+C 1. DRAW Z = ln[f(X0)] - EXP(1) where EXP(1)=-ln(U(0,1))
+C THIS DEFINES THE SLICE S={x: z < ln(f(x))}
+C -------------------------------------------------------
+ theta(it) = XOLD
+ FXOLD=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ U = genunf(0.D0,1.D0)
+ Z = FXOLD + DLOG(U)
+
+C -------------------------------------------------------------
+C 2. FIND I=(L,R) AROUND X0 THAT CONTAINS S AS MUCH AS POSSIBLE
+C STEPPING-OUT PROCEDURE
+C W = an estimate of the scale of SC
+C M = Limit on steps (-1 = +INF)
+C -------------------------------------------------------------
+ M = -1
+ W = max((XUB-XLB)/10.0,1.D0)
+C U = G05CAF(U)
+ U = genunf(0.D0,1.D0)
+ L = XOLD - W*U
+ R = XOLD + W - W*U ! L + W
+ IF (M.EQ.-1) THEN
+ DO 100 WHILE(L.GT.XLB)
+ theta(it) = L
+ FXL=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXL.LE.Z) GOTO 110
+100 L = L - W
+110 DO 200 WHILE(R.LT.XUB)
+ theta(it) = R
+ FXR=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXR.LE.Z) GOTO 210
+200 R = R + W
+210 CONTINUE
+ ELSE
+C U = G05CAF(U)
+ U = genunf(0.D0,1.D0)
+ J = M*U
+ K = M-1-J
+ DO 300 WHILE (J.GT.0)
+ IF (L.LE.XLB) GOTO 310
+ theta(it) = L
+ FXL=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXL.LE.Z) GOTO 310
+ L = L - W
+300 J = J - 1
+310 CONTINUE
+ DO 400 WHILE (K.GT.0)
+ IF (R.GE.XLB) GOTO 410
+ theta(it) = R
+ FXR=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXR.LE.Z) GOTO 410
+ R = R + W
+400 K = K - 1
+410 CONTINUE
+ ENDIF
+ IF (L.LT.XLB) L = XLB
+ IF (R.GT.XUB) R = XUB
+
+C ------------------------------------------------------
+C 3. SAMPLING FROM THE SET A = (I INTERSECT S) = (LA,RA)
+C ------------------------------------------------------
+ OK = 0
+ DO 500 WHILE (OK.EQ.0)
+C U = G05CAF(U)
+ U = genunf(0.D0,1.D0)
+ XSIM = L + U*(R - L)
+ theta(it) = XSIM
+ FXSIM=PTHETA2(it,nobs,d,ny,nz,nx,nu,ns,nt,S,yk,
+ 1 theta,thetaprior,tipo,pdll)
+ NEVAL = NEVAL + 1
+ IF (FXSIM.GE.Z) OK = 1
+ IF(XSIM.GT.XOLD) THEN
+ R = XSIM
+ ELSE
+ L = XSIM
+ ENDIF
+500 CONTINUE
+
+ theta(it) = XOLD
+
+ RETURN
END
diff --git a/syminv.for b/syminv.for
index cbca448c448ae8b4698677f54986dcbe9c6102c0..5bae68f4013bf5f88e749f7b8e0b7b4420ad654d 100644
--- a/syminv.for
+++ b/syminv.for
@@ -85,7 +85,7 @@ c
IF(IROW.NE.0) GO TO 10
100 RETURN
END
-
+
SUBROUTINE CHOLA(A, N, U, NULLTY, IFAULT, RMAX, R)
C
C ALGORITHM AS6, APPLIED STATISTICS, VOL.17, 1968, WITH
diff --git a/tnormi.for b/tnormi.for
index 1986b67c5f4bcc80e03d59dde673065eba0a9405..0694719c4ddaa07b742b3f281e8876faca8e1047 100644
--- a/tnormi.for
+++ b/tnormi.for
@@ -1,14 +1,14 @@
-C ----------------------------------------------------------------------
-C TNORMI generates a truncated normal random number
-C through the inversion method
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C ----------------------------------------------------------------------
+C TNORMI generates a truncated normal random number
+C through the inversion method
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -19,18 +19,18 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C ----------------------------------------------------------------------
- DOUBLE PRECISION FUNCTION TNORMI(PHIL,PHIP)
-C INPUT
- DOUBLE PRECISION PHIL,PHIP,T
-C EXTERNAL FUNCTIONS
- DOUBLE PRECISION genunf,INVNORMCDF !PPND16
-
- T = PHIL+genunf(0.d0,1.d0)*(PHIP-PHIL) ! Rescaling U(PHIL,PHIP)
-C TNORMI = G01FAF('L',T,IFAIL) ! INVERSE of N(0,1)
-C TNORMI = PPND16(T,IFAIL)
- TNORMI = INVNORMCDF(T)
-
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C ----------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION TNORMI(PHIL,PHIP)
+C INPUT
+ DOUBLE PRECISION PHIL,PHIP,T
+C EXTERNAL FUNCTIONS
+ DOUBLE PRECISION genunf,INVNORMCDF !PPND16
+
+ T = PHIL+genunf(0.d0,1.d0)*(PHIP-PHIL) ! Rescaling U(PHIL,PHIP)
+C TNORMI = G01FAF('L',T,IFAIL) ! INVERSE of N(0,1)
+C TNORMI = PPND16(T,IFAIL)
+ TNORMI = INVNORMCDF(T)
+
+ RETURN
END
diff --git a/var.for b/var.for
index cd9c76695fb2e7dd9f74524d4d0df07a8a93b206..69a651b1707df1400788b51c83cb6fbd535ab984 100644
--- a/var.for
+++ b/var.for
@@ -1,13 +1,13 @@
-C --------------------------------------
-C VAR computes the variance of an array
-C Developed by A.Rossi, C.Planas and G.Fiorentini
-C
-C Copyright (C) 2010-2014 European Commission
-C
+C --------------------------------------
+C VAR computes the variance of an array
+C Developed by A.Rossi, C.Planas and G.Fiorentini
+C
+C Copyright (C) 2010-2014 European Commission
+C
C This file is part of Program DMM
C
-C DMM is free software developed at the Joint Research Centre of the
-C European Commission: you can redistribute it and/or modify it under
+C DMM is free software developed at the Joint Research Centre of the
+C European Commission: you can redistribute it and/or modify it under
C the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
@@ -18,11 +18,11 @@ C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
-C along with DMM. If not, see <http://www.gnu.org/licenses/>.
-C --------------------------------------
- DOUBLE PRECISION FUNCTION VAR(X,N)
- INTEGER N
- DOUBLE PRECISION X(N)
- VAR=SUM(X(1:N)**2)/DFLOAT(N)-(SUM(X(1:N))/DFLOAT(N))**2
- RETURN
+C along with DMM. If not, see <http://www.gnu.org/licenses/>.
+C --------------------------------------
+ DOUBLE PRECISION FUNCTION VAR(X,N)
+ INTEGER N
+ DOUBLE PRECISION X(N)
+ VAR=SUM(X(1:N)**2)/DFLOAT(N)-(SUM(X(1:N))/DFLOAT(N))**2
+ RETURN
END