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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
|
C Last change: BCM 28 Sep 99 2:46 pm
SUBROUTINE getreg(Begsrs,Nobs,Havsrs,Havesp,Userx,Nrusrx,Bgusrx,
& Itdtst,Leastr,Eastst,Luser,Elong,Adjtd,Adjao,
& Adjls,Adjtc,Adjso,Adjhol,Adjsea,Adjcyc,Adjusr,
& Nusrrg,Havtca,Rgaicd,Lam,Fcntyp,Havhol,Lomtst,
& Ch2tst,Chi2cv,Tlimit,Pvaic,Lceaic,Inptok)
IMPLICIT NONE
c-----------------------------------------------------------------------
c getreg.f, Release 1, Subroutine Version 1.6, Modified 03 Feb 1995.
c-----------------------------------------------------------------------
c Specify the regression and time series parts of the model
c-----------------------------------------------------------------------
c Code added to incorporate automatic TD selection
c BCM - January 1994
c-----------------------------------------------------------------------
INCLUDE 'stdio.i'
INCLUDE 'lex.i'
INCLUDE 'notset.prm'
INCLUDE 'srslen.prm'
INCLUDE 'model.prm'
INCLUDE 'model.cmn'
INCLUDE 'mdldat.cmn'
INCLUDE 'picktd.cmn'
INCLUDE 'tbllog.i'
INCLUDE 'svllog.i'
INCLUDE 'usrreg.cmn'
INCLUDE 'units.cmn'
INCLUDE 'error.cmn'
c ------------------------------------------------------------------
DOUBLE PRECISION ONE,ZERO
LOGICAL F,T
PARAMETER(ONE=1D0,ZERO=0D0,F=.false.,T=.true.)
c ------------------------------------------------------------------
CHARACTER effttl*(PCOLCR),rgfile*(PFILCR),rgfmt*(PFILCR)
LOGICAL argok,Havesp,havfmt,Havsrs,haveux,hvfile,hvstrt,hvuttl,
& Inptok,Elong,havtd,Havhol,havln,havlp,Luser,Havtca,
& lumean,luseas,fixvec,havcyc,herror,Ch2tst,Leastr,Lceaic
INTEGER Bgusrx,Begsrs,i,j,k,idisp,itmpvc,nchr,nelt,nflchr,nfmtch,
& neltux,Nobs,Nrusrx,peltux,Itdtst,ivec,igrp,i2,n2,k2,ispn,
& Adjtd,Adjao,Adjls,Adjtc,Adjso,Adjhol,Adjsea,Adjcyc,Adjusr,
& Nusrrg,nbvec,icol,ic1,Fcntyp,begcol,endcol,Lomtst,iuhl,
& Eastst,ielt,rtype
DOUBLE PRECISION Userx,dvec,Rgaicd,urmean,urnum,bvec,Lam,Chi2cv,
& daicdf,Tlimit,Pvaic
DIMENSION Bgusrx(2),Begsrs(2),itmpvc(0:1),Userx(*),ivec(1),
& dvec(1),urmean(PB),urnum(PB),ispn(2),fixvec(PB),
& bvec(PB),iuhl(PUHLGP),Rgaicd(PAICT),daicdf(PAICT)
c-----------------------------------------------------------------------
INTEGER strinx
LOGICAL chkcvr,gtarg,dpeq,istrue
EXTERNAL strinx,chkcvr,gtarg,dpeq,istrue
c-----------------------------------------------------------------------
c The spec dictionary was made with this command
c ../../dictionary/strary < ../../dictionary/regression.dic
c-----------------------------------------------------------------------
CHARACTER ARGDIC*151
INTEGER argidx,argptr,PARG,arglog
PARAMETER(PARG=22)
DIMENSION argptr(0:PARG),arglog(2,PARG)
PARAMETER(ARGDIC='variablesuserdatastartfileformatbprintsaveaictes
&teastermeansnoapplyusertypetcrateaicdiffsavelogcenteruserchi2testc
&hi2testcvtlimitpvaictesttestalleaster')
c-----------------------------------------------------------------------
CHARACTER YSNDIC*5
INTEGER ysnptr,PYSN
PARAMETER(PYSN=2)
DIMENSION ysnptr(0:PYSN)
PARAMETER(YSNDIC='yesno')
c ------------------------------------------------------------------
CHARACTER AICDIC*82
INTEGER aicidx,aicptr,PAIC
PARAMETER(PAIC=12)
DIMENSION aicptr(0:PAIC),aicidx(4)
PARAMETER(AICDIC='tdtdnolpyeartdstocktd1coeftd1nolpyeartdstock1coe
&feastereasterstockuserlomloqlpyear')
c-----------------------------------------------------------------------
CHARACTER URGDIC*89
INTEGER urgidx,urgptr,PURG
PARAMETER(PURG=16)
DIMENSION urgptr(0:PURG),urgidx(PURG)
PARAMETER(URGDIC='constantseasonaltdlomloqlpyearholidayholiday2hol
&iday3holiday4holiday5aolssotransitoryuser')
c ------------------------------------------------------------------
CHARACTER MDLDIC*33
INTEGER mdlind,mdlptr,PMODEL
PARAMETER(PMODEL=8)
DIMENSION mdlptr(0:PMODEL),mdlind(PMODEL)
PARAMETER(MDLDIC='tdaolsholidayuserseasonalusertcso')
c ------------------------------------------------------------------
CHARACTER URRDIC*12
INTEGER urrptr,PURR
PARAMETER(PURR=2)
DIMENSION urrptr(0:PURR)
PARAMETER(URRDIC='meanseasonal')
c ------------------------------------------------------------------
DATA argptr/1,10,14,18,23,27,33,34,39,43,50,61,68,76,82,89,96,106,
& 114,124,130,139,152/
DATA ysnptr/1,4,6/
DATA aicptr/1,3,13,20,27,38,50,56,67,71,74,77,83/
DATA urgptr/1,9,17,19,22,25,31,38,46,54,62,70,72,74,76,86,90/
DATA mdlptr/1,3,5,7,14,26,30,32,34/
DATA urrptr/1,5,13/
c-----------------------------------------------------------------------
c Assume the input is OK and we don't have any of the arguments
c-----------------------------------------------------------------------
peltux=PLEN*PUREG
haveux=F
hvuttl=F
hvfile=F
havfmt=F
hvstrt=F
nfmtch=1
havtd=F
Havhol=F
havln=F
havlp=F
havcyc=F
lumean=F
luseas=F
nbvec=NOTSET
CALL setlg(F,PB,fixvec)
c-----------------------------------------------------------------------
CALL setint(NOTSET,2*PARG,arglog)
CALL setint(NOTSET,2,ispn)
CALL setint(0,PUHLGP,iuhl)
c-----------------------------------------------------------------------
c Initialize the format and file
c-----------------------------------------------------------------------
CALL setchr(' ',PFILCR,rgfile)
CALL setchr(' ',PFILCR,rgfmt)
c-----------------------------------------------------------------------
c Argument get loop
c-----------------------------------------------------------------------
DO WHILE (T)
IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,Inptok))THEN
IF(Lfatal)RETURN
GO TO(10,20,30,40,50,60,70,80,90,100,110,120,130,150,160,170,
& 140,180,190,191,192,193)argidx
c-----------------------------------------------------------------------
c variables argument
c-----------------------------------------------------------------------
10 CALL gtpdrg(Begsrs,Nobs,Havsrs,Havesp,F,havtd,Havhol,havln,
& havlp,argok,Inptok)
c IF(.not.Lfatal.and.(Picktd.and.(Fcntyp.ne.4.and.
c & (.not.dpeq(Lam,1D0)))))
c & CALL rmlnvr(Priadj,Nobs)
IF(Lfatal)RETURN
GO TO 200
c-----------------------------------------------------------------------
c Names and number of columns for the user regression variables
c-----------------------------------------------------------------------
20 CALL gtnmvc(LPAREN,T,PUREG,Usrttl,Usrptr,Ncusrx,PCOLCR,argok,
& Inptok)
IF(Lfatal)RETURN
hvuttl=argok.and.Ncusrx.gt.0
GO TO 200
c-----------------------------------------------------------------------
c Data argument
c-----------------------------------------------------------------------
30 IF(hvfile)CALL inpter(PERROR,Errpos,'Getting data from a file')
c ------------------------------------------------------------------
CALL gtdpvc(LPAREN,T,peltux,Userx,neltux,argok,Inptok)
IF(Lfatal)RETURN
haveux=argok.and.neltux.gt.0
GO TO 200
c-----------------------------------------------------------------------
c Start argument
c-----------------------------------------------------------------------
40 CALL gtdtvc(Havesp,Sp,LPAREN,F,1,Bgusrx,nelt,argok,Inptok)
IF(Lfatal)RETURN
hvstrt=argok.and.nelt.gt.0
GO TO 200
c-----------------------------------------------------------------------
c File argument
c-----------------------------------------------------------------------
50 IF(haveux)CALL inpter(PERROR,Errpos,
& 'Already have user regression')
CALL gtnmvc(LPAREN,T,1,rgfile,itmpvc,neltux,PFILCR,argok,Inptok)
IF(Lfatal)RETURN
c ------------------------------------------------------------------
IF(argok.and.neltux.gt.0)THEN
CALL eltlen(1,itmpvc,neltux,nflchr)
IF(Lfatal)RETURN
hvfile=T
END IF
GO TO 200
c-----------------------------------------------------------------------
c Format argument
c-----------------------------------------------------------------------
60 CALL gtnmvc(LPAREN,T,1,rgfmt,itmpvc,nelt,PFILCR,argok,Inptok)
IF(Lfatal)RETURN
IF(argok)THEN
nfmtch=itmpvc(1)-1
havfmt=T
END IF
GO TO 200
c-----------------------------------------------------------------------
c Initial values for the regression. May want to change this
c later so that the betas only need take some initial values instead
c of all or none.
c-----------------------------------------------------------------------
70 CALL gtrgvl(nbvec,fixvec,bvec,Inptok)
IF(Lfatal)RETURN
GO TO 200
c-----------------------------------------------------------------------
c Print argument
c-----------------------------------------------------------------------
80 CALL getprt(LSPREG,NSPREG,Inptok)
GO TO 200
c-----------------------------------------------------------------------
c Save argument
c-----------------------------------------------------------------------
90 CALL getsav(LSPREG,NSPREG,Inptok)
GO TO 200
c-----------------------------------------------------------------------
c aictest argument
c-----------------------------------------------------------------------
100 CALL gtdcvc(LPAREN,F,4,AICDIC,aicptr,PAIC,'Choices for aictest a
&re td, tdnolpyear, tdstock, td1coef, td1nolpyear,',
& aicidx,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(.not.argok)THEN
CALL writln(' tdstock, tdstock1coef, lom, loq, lpyear, e
&aster, easterstock,',STDERR,Mt2,F)
CALL writln(' and user.',STDERR,Mt2,F)
END IF
IF(argok)THEN
DO i=1,nelt
IF(aicidx(i).eq.7.or.aicidx(i).eq.8)THEN
Leastr=T
IF(Eastst.eq.0)THEN
Eastst=aicidx(i)-6
ELSE
CALL inpter(PERROR,Errpos,
& 'Can only specify one of easter and easterstock in aictest.')
Inptok=F
END IF
* Havhol=T
ELSE IF(aicidx(i).eq.9)THEN
Luser=T
c-----------------------------------------------------------------------
c input for Lomtst (BCM March 2008)
c-----------------------------------------------------------------------
ELSE IF(aicidx(i).gt.9)THEN
IF(Lomtst.eq.0)THEN
Lomtst=aicidx(i)-9
ELSE
CALL inpter(PERROR,Errpos,
& 'Can only specify one of lom, loq, or lpyear in aictest.')
Inptok=F
END IF
ELSE
IF(Itdtst.eq.0)THEN
Itdtst=aicidx(i)
* havtd=T
ELSE
CALL inpter(PERROR,Errpos,
& 'Can only specify one type of trading day in aictest.')
Inptok=F
END IF
END IF
END DO
IF(Inptok)Iregfx=0
END IF
GO TO 200
c-----------------------------------------------------------------------
c eastermeans argument
c-----------------------------------------------------------------------
110 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN,
& 'Choices for eastermeans are yes and no.',
& ivec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(argok.and.nelt.gt.0)Elong=ivec(1).eq.1
GO TO 200
c-----------------------------------------------------------------------
c noapply argument
c-----------------------------------------------------------------------
120 CALL gtdcvc(LPAREN,T,PMODEL,MDLDIC,mdlptr,PMODEL,'Choices for th
&e noapply argument are td, ao, ls, holiday, or user.',
& mdlind,nelt,argok,Inptok)
IF(Lfatal)RETURN
c ------------------------------------------------------------------
IF(argok.and.nelt.gt.0)THEN
DO i=1,nelt
IF(mdlind(i).eq.1)THEN
Adjtd=-1
ELSE IF(mdlind(i).eq.2)THEN
Adjao=-1
ELSE IF(mdlind(i).eq.3)THEN
Adjls=-1
ELSE IF(mdlind(i).eq.4)THEN
Adjhol=-1
ELSE IF(mdlind(i).eq.5)THEN
Adjsea=-1
ELSE IF(mdlind(i).eq.6)THEN
Adjusr=-1
ELSE IF(mdlind(i).eq.7)THEN
Adjtc=-1
ELSE IF(mdlind(i).eq.8)THEN
Adjso=-1
END IF
END DO
END IF
GO TO 200
c-----------------------------------------------------------------------
c usertype argument
c-----------------------------------------------------------------------
130 CALL gtdcvc(LPAREN,F,PUREG,URGDIC,urgptr,PURG,
& 'Improper entry for usertype. See '//SPCSEC//
& ' of '//DOCNAM//'.',urgidx,Nusrrg,argok,Inptok)
IF(Lfatal)RETURN
c ------------------------------------------------------------------
IF(argok.and.Nusrrg.gt.0)THEN
DO i=1,Nusrrg
IF(urgidx(i).eq.1)THEN
Usrtyp(i)=PRGUCN
ELSE IF(urgidx(i).eq.2)THEN
Usrtyp(i)=PRGTUS
ELSE IF(urgidx(i).eq.3)THEN
Usrtyp(i)=PRGUTD
IF(.not.havtd)havtd=T
ELSE IF(urgidx(i).eq.4)THEN
Usrtyp(i)=PRGULM
IF(.not.havln)havln=T
ELSE IF(urgidx(i).eq.5)THEN
Usrtyp(i)=PRGULQ
IF(.not.havln)havln=T
ELSE IF(urgidx(i).eq.6)THEN
Usrtyp(i)=PRGULY
IF(.not.havlp)havlp=T
ELSE IF(urgidx(i).ge.7.and.urgidx(i).le.11)THEN
IF(.not.Havhol)Havhol=T
IF(iuhl(urgidx(i)-6).eq.0)iuhl(urgidx(i)-6)=1
IF(urgidx(i).eq.7)THEN
Usrtyp(i)=PRGTUH
ELSE IF(urgidx(i).eq.8)THEN
Usrtyp(i)=PRGUH2
ELSE IF(urgidx(i).eq.9)THEN
Usrtyp(i)=PRGUH3
ELSE IF(urgidx(i).eq.10)THEN
Usrtyp(i)=PRGUH4
ELSE IF(urgidx(i).eq.11)THEN
Usrtyp(i)=PRGUH5
END IF
ELSE IF(urgidx(i).eq.12)THEN
Usrtyp(i)=PRGUAO
ELSE IF(urgidx(i).eq.13)THEN
Usrtyp(i)=PRGULS
ELSE IF(urgidx(i).eq.14)THEN
Usrtyp(i)=PRGUSO
ELSE IF(urgidx(i).eq.15)THEN
Usrtyp(i)=PRGUCY
IF(.not.havcyc)havcyc=T
ELSE IF(urgidx(i).eq.16.or.urgidx(i).eq.NOTSET)THEN
Usrtyp(i)=PRGTUD
END IF
END DO
END IF
GO TO 200
c-----------------------------------------------------------------------
c centeruser argument
c-----------------------------------------------------------------------
140 CALL gtdcvc(LPAREN,F,1,URRDIC,urrptr,PURR,
& 'Choices for centeruser are mean and seasonal.',
& ivec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(argok.and.nelt.gt.0)THEN
lumean=ivec(1).eq.1
luseas=ivec(1).eq.2
END IF
GO TO 200
c-----------------------------------------------------------------------
c tcrate - alpha value for all TC outliers
c-----------------------------------------------------------------------
150 IF(Havtca)THEN
CALL inpter(PERROR,Errpos,'Cannot specify tcrate in both the re
&gression and outlier specs')
Inptok=F
ELSE
CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(argok.and.nelt.gt.0)THEN
IF(dvec(1).le.ZERO.or.dvec(1).ge.ONE)THEN
CALL inpter(PERROR,Errpos,
& 'Value of tcrate must be between 0 and 1.')
Inptok=F
ELSE
Tcalfa=dvec(1)
Havtca=T
END IF
END IF
END IF
GO TO 200
c-----------------------------------------------------------------------
c AIC test difference for the regression-based AIC test
c-----------------------------------------------------------------------
160 CALL gtdpvc(LPAREN,F,PAICT,daicdf,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(argok)THEN
IF(nelt.eq.1)THEN
DO ielt=1,PAICT
Rgaicd(ielt)=daicdf(1)
END DO
ELSE IF(nelt.gt.0)THEN
DO ielt=1,PAICT
IF(.not.dpeq(daicdf(ielt),DNOTST))Rgaicd(ielt)=daicdf(ielt)
END DO
END IF
END IF
GO TO 200
c-----------------------------------------------------------------------
c savelog argument
c-----------------------------------------------------------------------
170 CALL getsvl(LSLREG,NSLREG,Inptok)
GO TO 200
c-----------------------------------------------------------------------
c chi2test argument
c-----------------------------------------------------------------------
180 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN,
& 'Choices for chi2test are yes and no.',
& ivec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(argok.and.nelt.gt.0)Ch2tst=ivec(1).eq.1
GO TO 200
c-----------------------------------------------------------------------
c chi2testcv argument
c-----------------------------------------------------------------------
190 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(nelt.gt.0.and.argok)THEN
IF(dvec(1).le.ZERO.or.dvec(1).ge.ONE)THEN
CALL inpter(PERROR,Errpos,
& 'Value of chi2testcv must be between 0 and 1.')
Inptok=F
ELSE
Chi2cv=dvec(1)
END IF
END IF
GO TO 200
c-----------------------------------------------------------------------
c tlimit argument
c-----------------------------------------------------------------------
191 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(nelt.gt.0.and.argok)THEN
IF(dvec(1).le.ZERO)THEN
CALL inpter(PERROR,Errpos,
& 'Value of tlimit must be greater than 0.')
Inptok=F
ELSE
Tlimit=dvec(1)
END IF
END IF
GO TO 200
c-----------------------------------------------------------------------
c pvaictest argument
c-----------------------------------------------------------------------
192 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(nelt.gt.0.and.argok)THEN
IF(dvec(1).le.ZERO)THEN
CALL inpter(PERROR,Errpos,
& 'Value of pvaictest must be greater than 0.')
Inptok=F
ELSE IF(dvec(1).ge.ONE)THEN
CALL inpter(PERROR,Errpos,
& 'Value of pvaictest must be less than 1.')
Inptok=F
ELSE
Pvaic=ONE-dvec(1)
END IF
END IF
GO TO 200
c-----------------------------------------------------------------------
c testalleaster argument
c-----------------------------------------------------------------------
193 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN,
& 'Choices for testalleaster are yes and no.',
& ivec,nelt,argok,Inptok)
IF(Lfatal)RETURN
IF(argok.and.nelt.gt.0)Lceaic=ivec(1).eq.1
GO TO 200
END IF
c-----------------------------------------------------------------------
IF(nbvec.ne.NOTSET)THEN
c-----------------------------------------------------------------------
c Insert value for Leap Year regressor that will be removed
c-----------------------------------------------------------------------
IF(Picktd.and.(Fcntyp.ne.4.and.(.not.dpeq(Lam,1D0))))THEN
ic1=1
icol=strinx(T,Colttl,Colptr,ic1,Nb,'Leap Year')
DO WHILE (icol.gt.0)
IF(icol.le.nbvec)THEN
DO i=nbvec,icol,-1
bvec(i+1)=bvec(i)
fixvec(i+1)=fixvec(i)
END DO
END IF
Bvec(icol)=ONE
nbvec=nbvec+1
IF(icol.eq.Nb)THEN
icol=0
ELSE
ic1=icol+1
icol=strinx(T,Colttl,Colptr,ic1,Nb,'Leap Year')
END IF
END DO
END IF
IF(nbvec.gt.0.and.nbvec.NE.(Nb+Ncusrx))THEN
WRITE(STDERR,1000)
WRITE(Mt2,1000)
1000 FORMAT(' ERROR: Number of initial values is not the same as ',
& 'the number of regression',/,' variables.')
ELSE
DO i=1,Nb+Ncusrx
Regfx(i)=fixvec(i)
B(i)=bvec(i)
END DO
END IF
END IF
c ------------------------------------------------------------------
c If the data are from the file get the data
c-----------------------------------------------------------------------
IF(Inptok.and.hvfile.and..not.haveux)THEN
IF(Ncusrx.gt.0)THEN
CALL gtfldt(peltux,rgfile,nflchr,havfmt,rgfmt(1:nfmtch),2,
& Userx,neltux,Havesp,Sp,F,' ',0,F,' ',0,0,hvstrt,
& Bgusrx,Ncusrx,ispn,ispn,T,haveux,Inptok)
ELSE
WRITE(STDERR,1010)
WRITE(Mt2,1010)
END IF
END IF
c-----------------------------------------------------------------------
c Check for the required arguments
c-----------------------------------------------------------------------
IF(Inptok.and.(hvuttl.or.haveux))THEN
c-----------------------------------------------------------------------
c check user-defined regression type selection. First, check to
c see if user-defined regression variables are defined.
c-----------------------------------------------------------------------
IF(Nusrrg.gt.0)THEN
c-----------------------------------------------------------------------
c If only one type given, use it for all user-defined regression
c variables.
c-----------------------------------------------------------------------
IF(Nusrrg.eq.1)THEN
DO i=2,Ncusrx
Usrtyp(i)=Usrtyp(1)
END DO
END IF
c-----------------------------------------------------------------------
c Check to see if User-defined holiday groups are defined
c-----------------------------------------------------------------------
CALL chkuhg(iuhl,Nguhl,herror)
IF(herror)THEN
WRITE(STDERR,1040)
WRITE(Mt2,1040)
1040 FORMAT(' ERROR: Cannot specify holiday group types for ',
& 'user-defined regression',/,
& ' variables out of sequence.')
Inptok=F
END IF
END IF
IF(.not.(hvuttl.eqv.haveux))THEN
WRITE(STDERR,1010)
WRITE(Mt2,1010)
1010 FORMAT(/,' ERROR: Need to specify both user-defined ',
& 'regression variables (with user',/,
& ' argument) and X matrix (with file or data ',
& 'argument).')
Inptok=F
c ------------------------------------------------------------------
ELSE IF(mod(neltux,Ncusrx).ne.0)THEN
WRITE(STDERR,1020)neltux,Ncusrx
WRITE(Mt2,1020)neltux,Ncusrx
1020 FORMAT(/,' ERROR: Number of user-defined X elements=',i4,
& /,' not equal to a multiple of the number of ',
& 'columns=',i3,'.',/)
Inptok=F
c ------------------------------------------------------------------
ELSE
IF(.not.hvstrt)CALL cpyint(Begsrs,2,1,Bgusrx)
Nrusrx=neltux/Ncusrx
IF(.not.chkcvr(Bgusrx,Nrusrx,Begspn,Nspobs,Sp))THEN
CALL cvrerr('user-defined regression variables',Bgusrx,Nrusrx,
& 'span of the data',Begspn,Nspobs,Sp)
IF(Lfatal)RETURN
Inptok=F
c ------------------------------------------------------------------
ELSE
idisp=Grp(Ngrp)-1
DO i=1,Ncusrx
idisp=idisp+1
CALL getstr(Usrttl,Usrptr,Ncusrx,i,effttl,nchr)
IF(.not.Lfatal)THEN
IF(Usrtyp(i).eq.PRGTUH)THEN
CALL adrgef(B(idisp),effttl(1:nchr),'User-defined Holiday',
& PRGTUH,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUH2)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Holiday Group 2',PRGUH2,
& Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUH3)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Holiday Group 3',PRGUH3,
& Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUH4)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Holiday Group 4',PRGUH4,
& Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUH5)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Holiday Group 5',PRGUH5,
& Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGTUS)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Seasonal',PRGTUS,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUCN)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Constant',PRGUCN,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUTD)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Trading Day',PRGUTD,
& Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGULM)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined LOM',PRGULM,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGULQ)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined LOQ',PRGULQ,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGULY)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Leap Year',PRGULY,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUAO)THEN
CALL adrgef(B(idisp),effttl(1:nchr),'User-defined AO',
& PRGUAO,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGULS)THEN
CALL adrgef(B(idisp),effttl(1:nchr),'User-defined LS',
& PRGULS,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUSO)THEN
CALL adrgef(B(idisp),effttl(1:nchr),'User-defined SO',
& PRGUSO,Regfx(idisp),T)
ELSE IF(Usrtyp(i).eq.PRGUCY)THEN
CALL adrgef(B(idisp),effttl(1:nchr),
& 'User-defined Transitory',PRGUCY,
& Regfx(idisp),T)
ELSE
CALL adrgef(B(idisp),effttl(1:nchr),'User-defined',PRGTUD,
& Regfx(idisp),T)
END IF
END IF
IF(Lfatal)RETURN
END DO
c ------------------------------------------------------------------
c estimate and Remove either regressor mean or seasonal mean
c ------------------------------------------------------------------
IF(lumean)THEN
CALL setdp(ZERO,PB,urmean)
DO i=1,neltux
i2=MOD(i,Ncusrx)
IF(i2.eq.0)i2=Ncusrx
urmean(i2)=urmean(i2)+Userx(i)
END DO
DO i=1,Ncusrx
urmean(i)=urmean(i)/DBLE(Nrusrx)
END DO
DO i=1,neltux
i2=MOD(i,Ncusrx)
IF(i2.eq.0)i2=Ncusrx
Userx(i)=Userx(i)-urmean(i2)
END DO
ELSE IF(luseas)THEN
n2=Sp*Ncusrx
DO i=1,Sp
CALL setdp(ZERO,PB,urmean)
CALL setdp(ZERO,PB,urnum)
i2=(i-1)*Ncusrx+1
DO j=i2,neltux,n2
DO k=j,Ncusrx+j-1
k2=MOD(k,Ncusrx)
IF(k2.eq.0)k2=Ncusrx
urmean(k2)=urmean(k2)+Userx(k)
urnum(k2)=urnum(k2)+ONE
END DO
END DO
DO j=1,Ncusrx
urmean(j)=urmean(j) / urnum(j)
END DO
DO j=i2,neltux,n2
DO k=j,Ncusrx+j-1
k2=MOD(k,Ncusrx)
IF(k2.eq.0)k2=Ncusrx
Userx(k)=Userx(k)-urmean(k2)
END DO
END DO
END DO
END IF
c ------------------------------------------------------------------
END IF
END IF
END IF
IF(Lfatal)RETURN
IF(Nb.gt.0)THEN
c-----------------------------------------------------------------------
c Check if the regression model parameters are fixed. Sets iregfx.
c-----------------------------------------------------------------------
CALL regfix()
c ------------------------------------------------------------------
c set indicator variable for fixed User-defined regressors.
c ------------------------------------------------------------------
Userfx=F
IF(Ncusrx.gt.0.and.Iregfx.ge.2)THEN
IF(Iregfx.eq.3)THEN
Userfx=T
ELSE
DO igrp=1,Ngrp
begcol=Grp(igrp-1)
endcol=Grp(igrp)-1
rtype=Rgvrtp(begcol)
IF(rtype.eq.PRGTUD.or.rtype.eq.PRGTUS.or.rtype.eq.PRGTUH.or.
& rtype.eq.PRGUH2.or.rtype.eq.PRGUH3.or.rtype.eq.PRGUH4.or.
& rtype.eq.PRGUH5.or.rtype.eq.PRGUAO.or.rtype.eq.PRGULS.or.
& rtype.eq.PRGUSO.or.rtype.eq.PRGUCN.or.rtype.eq.PRGUCY.or.
& rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or.
& rtype.eq.PRGULY)THEN
DO i=begcol,endcol
Userfx=Userfx.or.Regfx(i)
END DO
END IF
END DO
END IF
END IF
c-----------------------------------------------------------------------
c sort outlier regressors specified by the user, if any.
c-----------------------------------------------------------------------
CALL otsort()
c-----------------------------------------------------------------------
IF(Nusrrg.gt.0.and.Ncusrx.eq.0)THEN
WRITE(STDERR,1030)
WRITE(Mt2,1030)
1030 FORMAT(' ERROR: Cannot specify group types for ',
& 'user-defined regression',/,
& ' variables if user-defined regression ',
& 'variables are not',/,
& ' defined in the regression spec.')
Inptok=F
END IF
END IF
c-----------------------------------------------------------------------
c Check to see if lom, loq, or lpyear regressors can be generated
c for this series. (BCM March 2008)
c-----------------------------------------------------------------------
IF(Lomtst.eq.1.and.Sp.ne.12)THEN
CALL writln('WARNING: The program will only perform an AIC test
&on the length of month',STDERR,Mt2,T)
CALL writln(' regressor for monthly time series.',
& STDERR,Mt2,F)
Lomtst=0
ELSE IF(Lomtst.eq.2.and.Sp.ne.4)THEN
CALL writln('WARNING: The program will only perform an AIC test
&on the length of quarter',STDERR,Mt2,T)
CALL writln(' regressor for quarterly time series.',
& STDERR,Mt2,F)
Lomtst=0
ELSE IF(Lomtst.eq.3.and.(.not.(Sp.eq.4.or.Sp.eq.12)))THEN
CALL writln('WARNING: The program will only perform an AIC test
&on the leap year',STDERR,Mt2,T)
CALL writln(' regressor for monthly or quarterly time se
&ries.',STDERR,Mt2,F)
Lomtst=0
END IF
c-----------------------------------------------------------------------
c Check to see if trading day model selected is compatable with
c choice of Lomtst (BCM March 2008)
c-----------------------------------------------------------------------
IF((Lomtst.eq.1.or.Lomtst.eq.2).and.Picktd)THEN
IF(Lomtst.eq.1)
& CALL writln('ERROR: AIC test for the length of month regresso
&r cannot be specified when',Mt2,STDERR,T)
IF(Lomtst.eq.2)
& CALL writln('ERROR: AIC test for the length of quarter regres
&sor cannot be specified when',Mt2,STDERR,T)
CALL writln(' the td or td1coef option is given in the var
&iables argument.',Mt2,STDERR,F)
Lomtst=0
Inptok=F
ELSE IF(Lomtst.eq.3.and.(Picktd.and.(.not.dpeq(Lam,ONE))))THEN
CALL writln('ERROR: AIC test for the leap year regressor cannot
&be specified when the',Mt2,STDERR,T)
CALL writln(' td or td1coef option is given in the variabl
&es argument and a',Mt2,STDERR,F)
CALL writln(' power transformation is performed.',Mt2,
& STDERR,F)
Lomtst=0
Inptok=F
END IF
c-----------------------------------------------------------------------
IF(Itdtst.eq.3.and.Itdtst.eq.6)THEN
IF(Lomtst.eq.1)THEN
CALL writln('ERROR: AIC test for the length of month regressor
&cannot be specified when',Mt2,STDERR,T)
ELSE IF(Lomtst.eq.2)THEN
CALL writln('ERROR: AIC test for the length of quarter regresso
&r cannot be specified when',Mt2,STDERR,T)
ELSE
CALL writln('ERROR: AIC test for the leap year regressor cannot
& be specified when',Mt2,STDERR,T)
END IF
CALL writln(' the tdstock or tdstock1coef option is given
&in the aictest argument.',Mt2,STDERR,F)
Lomtst=0
Inptok=F
END IF
c-----------------------------------------------------------------------
IF(Itdtst.gt.0.and.(.not.havtd))havtd=T
IF(Leastr.and.(.not.Havhol))Havhol=T
IF((Lomtst.eq.1.or.Lomtst.eq.2).and.(.not.havln))havln=T
IF(Lomtst.eq.3.and.(.not.havln))havlp=T
IF(Adjtd.eq.1.and.(.NOT.(havtd.or.havln.or.havlp)))Adjtd=0
IF(Adjhol.eq.1.and.(.not.Havhol))Adjhol=0
IF(Adjcyc.eq.1.and.(.not.havcyc))Adjcyc=0
IF(Nguhl.eq.0.and.Ch2tst)Ch2tst=F
c-----------------------------------------------------------------------
RETURN
200 CONTINUE
END DO
c -----------------------------------------------------------------
END
|
