1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
C Last change: BCM 14 May 1998 9:17 am
SUBROUTINE fcnar(Na,Testpm,Estprm,A,Lauto,Gudrun,Err,Lckinv)
IMPLICIT NONE
c-----------------------------------------------------------------------
c fcnar.f, Release 1, Subroutine Version 1.10, Modified 14 Feb 1995.
c-----------------------------------------------------------------------
c This routine works in the nonlinear routine on the
c regression residuals. Calculates the G'G matrix since
c the parameters have changed.
c-----------------------------------------------------------------------
c Subroutine to calculate exact MA ARIMA filter residuals.
c Setmdl differences the X:y matrix and changes the model to remove
c the differencing. The the remaining ARMA model is estimated.
c Model information is in ARIMA.cmn common so the variables are saved
c between calls of the routines fcnar, and arflt. Setmdl also
c constructs a vector of parameters to be estimated in the nonlinear
c routine. Fcnar calculates ARIMA filter residuals given new estimated
c parameters, estprm, from the nonlinear routine, regression residuals,
c tsrs, from rgcpnt, and the model information that was constructed
c in setmdl. ARflt filters an extended [X:y] matrix from rgcpnt
c using parameter estimates saved during the last fcnar call.
c-----------------------------------------------------------------------
c Name Type Description
c-----------------------------------------------------------------------
c a d Output na long vector of the deviances.
c err i Output error warning to have the nonlinear routine
c terminate the program (not used).
c estprm d Input nestpm long vector of estimated parameters from the
c nonlinear routine. Nestpm is found in model.cmn
c estptr i Local pointer in either estprm or arimap for the first operator
c to be expanded.
c i i Local do loop parameter
c iflt i Local index for the current filter type, DIFF, AR, or MA.
c ilag i Local index for the current lag, pointer to the current
c element in lag,arimap, and arimaf.
c iopr i Local index for the current operator, it is the pointer to the
c current row in the operator specfication matrix, opr.
c lagptr i Local pointer to the current coefficient and lag in arimap
c and arimal
c na i Input number of a's or the number of residuals expected by
c the nonlinear routine, nefobs+order of the MA operator
c nlag i Local number of lags in the current operator of a filter
c nopr i Local for the number of operators in a DIFF, AR, or MA filter.
c one d Local PARAMETER for a double precision 1
c Testpm i Input dummy number which should be the same as nestpm, the
c of parmeters in estprm
c zero d Local PARAMETER for double precision 0
c-----------------------------------------------------------------------
INCLUDE 'stdio.i'
INCLUDE 'notset.prm'
INCLUDE 'srslen.prm'
INCLUDE 'model.prm'
INCLUDE 'series.cmn'
INCLUDE 'units.cmn'
INCLUDE 'model.cmn'
INCLUDE 'mdldat.cmn'
INCLUDE 'error.cmn'
c ------------------------------------------------------------------
INTEGER PA
DOUBLE PRECISION TWO
PARAMETER(TWO=2D0,PA=PLEN+2*PORDER)
c ------------------------------------------------------------------
CHARACTER cdot*(1),tmpttl*(POPRCR)
LOGICAL Gudrun,Lckinv,Lauto
INTEGER Err,info,Na,ntmpcr,Testpm,fh2
DOUBLE PRECISION A,Estprm,fac
DIMENSION A(PA),Estprm(Nestpm)
c-----------------------------------------------------------------------
cdot='.'
IF(Lauto)cdot=' '
fh2=0
IF(.not.Lauto)THEN
fh2=Mt1
IF(.not.Gudrun)fh2=0
END IF
c-----------------------------------------------------------------------
c Insert the estimated parameters in the model into the ARIMA
c filtering data structures.
c-----------------------------------------------------------------------
CALL upespm(Estprm)
c-----------------------------------------------------------------------
c Call the ARIMA filter
c-----------------------------------------------------------------------
CALL copy(Tsrs,Nspobs,1,A)
CALL armafl(Nspobs,1,.true.,Lckinv,A,Na,PA,info)
c-----------------------------------------------------------------------
c Print the warning messages here because
c-----------------------------------------------------------------------
IF(info.ne.0)THEN
IF(Lprier)THEN
IF(info.eq.PINVER)THEN
CALL getstr(Oprttl,Oprptr,Noprtl,Prbfac,tmpttl,ntmpcr)
IF(Lfatal)RETURN
IF(fh2.gt.0)WRITE(fh2,1010)tmpttl(1:ntmpcr),cdot
CALL errhdr
WRITE(Mt2,1010)tmpttl(1:ntmpcr),cdot
c ------------------------------------------------------------------
ELSE IF(info.eq.PGPGER)THEN
IF(fh2.gt.0)WRITE(fh2,1020)PRGNAM,cdot
CALL errhdr
WRITE(Mt2,1020)PRGNAM,cdot
c ------------------------------------------------------------------
ELSE IF(info.eq.PACFER)THEN
IF(fh2.gt.0)WRITE(fh2,1030)cdot
CALL errhdr
WRITE(Mt2,1030)cdot
c ------------------------------------------------------------------
ELSE IF(info.eq.PVWPER)THEN
IF(fh2.gt.0)WRITE(fh2,1040)cdot
CALL errhdr
WRITE(Mt2,1040)cdot
END IF
c ------------------------------------------------------------------
IF(Lckinv)THEN
CALL errhdr
IF(Lauto)THEN
WRITE(Mt2,1049)Mdldsn(1:Nmddcr)
ELSE
IF(fh2.gt.0)THEN
WRITE(fh2,1050)
CALL prtitr(A,Na,Estprm,Nestpm,' ',NOTSET,NOTSET)
END IF
WRITE(Mt2,1050)
END IF
c ------------------------------------------------------------------
ELSE
CALL errhdr
IF(fh2.gt.0)WRITE(fh2,1060)
WRITE(Mt2,1060)
END IF
END IF
c-----------------------------------------------------------------------
c Make the residuals so big a bad jump will be brought back inbounds
c-----------------------------------------------------------------------
c CALL dcopy(Na,Lrgrsd,0,A,1)
CALL setdp(Lrgrsd,Na,A)
info=0
Err=-info
c ------------------------------------------------------------------
ELSE IF(Lextma)THEN
fac=exp(Lndtcv/TWO/Dnefob)
CALL scrmlt(fac,Na,A)
c ------------------------------------------------------------------
END IF
RETURN
c ------------------------------------------------------------------
1010 FORMAT(/,' WARNING: ',a,' roots inside the unit circle',a)
1020 FORMAT(/,' WARNING: Problem with MA parameter estimation. ',a,
& ' can''t',
& /,' invert the G''G matrix. Try a simpler ARIMA ',
& 'model without',
& /,' parameter constraints. Please send us the ',
& 'data and spec file',
& /,' that produced this message ',
& '(x12@census.gov)',a)
1030 FORMAT(/,' WARNING: Problem calculating the theoretical ARMA ACF',
& a)
1040 FORMAT(/,' WARNING: Problem calculating var(w_p|z)',a)
1049 FORMAT(' for model ',a,'. Will',/,
& ' attempt to fix the problem, and continue.')
1050 FORMAT(' Will print out the parameters,',/,
& ' attempt to fix the problem, and continue.')
1060 FORMAT(/)
END
|
