aaamain.f0000664006604000003110000002615114521201400011721 0ustar sun00315stepsC Last change: Nov, 2021, add a logical variable to test if this is C the first .spc which has composite spec, program only processes C to this file. The .spcs after this file will be ignored. C previous change: BCM 15 Oct 1998 12:21 pm **==aa0001.f processed by SPAG 4.03F at 10:52 on 28 Sep 1994 BLOCK DATA INX12 IMPLICIT NONE C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'chrt.cmn' INCLUDE 'ssap.cmn' C----------------------------------------------------------------------- INTEGER j,ii C----------------------------------------------------------------------- DATA Ialpha/'j','f','m','a','m','j','j','a','s','o','n','d'/ DATA Ialphq/'1','2','3','4'/ DATA I1,I4,I7/'*','I','.'/ DATA Imid/2,6,10,14,18,22,26,30,34,38,42,46,50,54/ DATA F1/'(1x,i2,a1,i4,2x, (f9.2,2x),3x,f9.2,2x,a10)'/ DATA F2/'(11x, (1x,i2,a1,i4,1x,a1,1x),4x,a7,3x,a8)'/ DATA F3/'(1x,i2,a1,i4,2x, (e10.4,1x),3x,f9.2,2x,a10)'/ DATA(Cut(1,ii),ii=1,4)/3D0,4D0,5D0,6D0/ DATA(Cut(2,ii),ii=1,4)/2D0,3D0,4D0,5D0/ DATA(Cut(3,ii),ii=1,4)/3D0,4D0,5D0,6D0/ DATA(Cut(4,ii),ii=1,4)/3D0,5D0,7D0,10D0/ DATA(Cut(5,ii),ii=1,4)/3D0,4D0,5D0,6D0/ DATA(Ch(j),j=1,NEST)/'%','+','#','$','@'/ C----------------------------------------------------------------------- END **==x12a.f processed by SPAG 4.03F at 10:53 on 28 Sep 1994 PROGRAM x12a IMPLICIT NONE C----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'cchars.i' INCLUDE 'build.prm' INCLUDE 'notset.prm' INCLUDE 'seatop.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' INCLUDE 'nsums.i' C----------------------------------------------------------------------- LOGICAL lmeta,lchkin,rok,lcomp,ldata,lgraf,lexgrf,gmtok,x11agr, & fok,l1stcomp CHARACTER insrs*(PFILCR),outsrs*(PFILCR),mtafil*(PFILCR), & datsrs*(PFILCR),logfil*(PFILCR),dtafil*(PFILCR), & grfdir*(PFILCR),xb*(PFILCR),tfmt*(10),dattim*(24) INTEGER i,failed,nfail,unopnd,nopen,nlgfil,n1,n2,xfail, & nmtfil,n4,i1,i2,ilghdr DIMENSION outsrs(PSRS),insrs(PSRS),datsrs(PSRS),failed(PSRS), & unopnd(PSRS) C----------------------------------------------------------------------- CHARACTER*24 cvdttm INTEGER nblank,lstpth EXTERNAL nblank,lstpth,cvdttm C----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) C----------------------------------------------------------------------- c Initialize variables C----------------------------------------------------------------------- Mt2=0 Ng=8 STDERR=6 nfail=0 xfail=0 nopen=0 Lfatal=F x11agr=T l1stcomp=F CALL setchr(' ',PFILCR,Infile) CALL setchr(' ',PFILCR,Cursrs) CALL setchr(' ',PFILCR,Curgrf) CALL setchr(' ',PFILCR,grfdir) CALL setchr(' ',PFILCR,dtafil) CALL setchr(' ',PFILCR,xb) TABCHR=CHAR(9) Ierhdr=NOTSET Crvend=CNOTST CALL fdate(dattim) dattim=cvdttm(dattim) cunix CHREOF=char(4) NEWLIN=char(10) C ------------------------------------------------------------------ cdos cdos CHREOF=char(26) cdos NEWLIN=char(13) C----------------------------------------------------------------------- C Print out introductory header giving version number of program. C----------------------------------------------------------------------- WRITE(STDOUT,1000)PRGNAM,VERNUM,BUILD,dattim 1000 FORMAT(/,1x,a,' Seasonal Adjustment Program',/, & ' Version Number ',a,' Build ',a,/,' Execution began ',a) C----------------------------------------------------------------------- c Get options specified on the command line. C----------------------------------------------------------------------- CALL getxop(lmeta,lchkin,lcomp,Lsumm,Lmdsum,Lnoprt,Lwdprt,Lpage, & ldata,dtafil,lgraf,grfdir,Lcmpaq,Ltimer) IF(Lfatal)STOP C----------------------------------------------------------------------- IF(Lwdprt)THEN Ttlfmt='(A1,8X,A,T92,''PAGE'',I4,'', SERIES '',A)' ELSE Ttlfmt='(A1,8X,A,12X,''PAGE'',I4,'', SERIES '',A)' END IF C----------------------------------------------------------------------- c If input is from metafile, get list of series names C----------------------------------------------------------------------- IF(lmeta)THEN CALL gtmtfl(insrs,outsrs,datsrs,mtafil,ldata,dtafil) IF(Lfatal)STOP nmtfil=nblank(mtafil) logfil=mtafil(1:(nmtfil-4)) ELSE C----------------------------------------------------------------------- c Else, set up variables for using a single file. C----------------------------------------------------------------------- Imeta=1 insrs(1)=Infile outsrs(1)=Cursrs logfil=outsrs(1) mtafil=' ' nmtfil=1 END IF C----------------------------------------------------------------------- c initialize variables for Lmdsum C----------------------------------------------------------------------- nSeatsSer=0 noTratadas=0 call inicSumS() C----------------------------------------------------------------------- c open log file for all X-13A-S runs. First, get path information C----------------------------------------------------------------------- nlgfil=nblank(logfil) logfil(nlgfil+1:nlgfil+4)='.log' nlgfil=nlgfil+4 OPEN(Ng,FILE=logfil(1:nlgfil),STATUS='UNKNOWN',ERR=20) WRITE(Ng,1010) 1010 FORMAT('1') IF(.not.lchkin)THEN ilghdr=67+nblank(VERNUM)+nblank(BUILD) IF(Lwdprt)THEN i1=(LINLEN-ilghdr)/2 ELSE i1=(80-ilghdr)/2 END IF WRITE(Ng,1020)xb(1:i1),PRGNAM,VERNUM,BUILD,dattim 1020 FORMAT(A,'Log for ',a,' program (Version ',a,' Build ',a,') ',a) i2=ilghdr/2 WRITE(tfmt,1021)i2 1021 FORMAT('(a,',i2,'a2,a)') WRITE(Ng,tfmt)xb(1:i1),('*-',i=1,i2),'*' WRITE(Ng,1022) 1022 FORMAT(///, & ' Type of Series',6x,'Additional',19x,'Series title',/, & ' Adjust. Ident.',6x,'Identifiers',/) END IF C----------------------------------------------------------------------- c Process all the series. C----------------------------------------------------------------------- DO i=1,Imeta rok=T dtafil=' ' IF (l1stcomp) THEN WRITE(STDERR,1090) WRITE(Ng,1090) Imeta = i-1 exit END IF 1090 FORMAT(/, & ' WARNING: X-13 will not process any series in a metafile ',/, & ' following a spec for a composite adjustment.',/) IF(lmeta)THEN Infile=insrs(i) Cursrs=outsrs(i) IF(ldata)dtafil=datsrs(i) END IF n1=nblank(Infile) n2=nblank(Cursrs) C----------------------------------------------------------------------- c Set up graphics variables C----------------------------------------------------------------------- gmtok=T fok=T IF(lgraf)THEN Ngrfcr=nblank(grfdir) Curgrf(1:Ngrfcr)=grfdir(1:Ngrfcr) n4=lstpth(grfdir,Ngrfcr) IF(n4.lt.Ngrfcr)THEN Ngrfcr=Ngrfcr+1 cdos backslash for directory cdos Curgrf(Ngrfcr:Ngrfcr)='\' cunix forward slash for directory Curgrf(Ngrfcr:Ngrfcr)='/' END IF n4=lstpth(Cursrs,n2) Curgrf((Ngrfcr+1):(Ngrfcr+(n2-n4)))=Cursrs((n4+1):n2) Ngrfcr=Ngrfcr+n2-n4 INQUIRE(FILE=Curgrf(1:Ngrfcr)//'.gmt',EXIST=lexgrf) CALL fopen(Curgrf(1:Ngrfcr)//'.gmt','graphical meta file', & 'UNKNOWN',Grfout,gmtok) IF(.not.gmtok)CALL abend END IF C----------------------------------------------------------------------- c write(*,*) 'enter profiler' c call profiler(0,'Profiler.txt') IF(gmtok)THEN CALL x12run(i,unopnd,nopen,lchkin,lcomp,rok,fok,n1,nfail,ldata, & dtafil,mtafil,nmtfil,dattim,x11agr,lgraf,lexgrf, & l1stcomp) ELSE fok=F END IF C----------------------------------------------------------------------- c print error message if there was an input error. C----------------------------------------------------------------------- IF(Lfatal)THEN IF(rok)THEN WRITE(STDOUT,*)' Program error(s) halt execution for ', & Infile(1:n1),'.spc' xfail=xfail+1 END IF IF(gmtok.and.fok) & WRITE(STDOUT,1025)' Check error file '//Cursrs(1:n2)//'.err' nfail=nfail+1 failed(nfail)=i C----------------------------------------------------------------------- ELSE IF(.not.lchkin)THEN CALL fdate(dattim) dattim=cvdttm(dattim) WRITE(STDOUT,1025)' Execution complete for '//Infile(1:n1)// & '.spc at '//dattim END IF C----------------------------------------------------------------------- c Close all files C----------------------------------------------------------------------- CALL fclose(-1) END DO C----------------------------------------------------------------------- IF((.not.Lquiet).and.nfail.gt.xfail)WRITE(STDERR,1030) 1030 FORMAT(/, & ' NOTE: Correct input errors in the order they are detected',/, & ' since the first one or two may be responsible for',/, & ' the others (especially if there are errors in the',/, & ' SERIES or COMPOSITE spec).',/) C----------------------------------------------------------------------- IF(Imeta.gt.1)THEN IF(nopen.gt.0.or.nfail.gt.0)THEN CALL prtlog(Ng,insrs,outsrs,nopen,unopnd,nfail,failed, & mtafil(1:nmtfil),logfil(1:nlgfil)) END IF if (Lmdsum.and.nSeatsSer.gt.25) then * write(*,*)' Lmdsum=T nSeatsSer = ',nSeatsSer call writeSumS(mtafil,nmtfil-4,nSeatsSer,noTratadas,wSposBphi, $ wSstochTD,wSstatseas,wSrmod,wSxl) * else * write(*,*)' Lmdsum=F nSeatsSer = ',nSeatsSer end if END IF C----------------------------------------------------------------------- IF(lgraf.and.Lsumm.gt.0)THEN WRITE(Ng,1040) 1040 FORMAT(/,' NOTE: The diagnostic files produced by the -s ', & 'option are stored in the',/, & ' directory specified by the graphics (-g) option.') END IF c CALL fclose(Ng) C----------------------------------------------------------------------- STOP C----------------------------------------------------------------------- 20 WRITE(STDERR,1025)' Unable to open '//logfil(1:nlgfil) CALL abend 1025 FORMAT(/,a) STOP END abend.f0000664006604000003110000000523014521201400011376 0ustar sun00315steps**==abend.f processed by SPAG 4.03F at 09:46 on 1 Mar 1994 SUBROUTINE abend IMPLICIT NONE c----------------------------------------------------------------------- c abend - abnormal termination of program, Lahey pc version c Does a trace of the line number and routines the programs stopped in, c then the program stops. c----------------------------------------------------------------------- c Author - Larry Bobbitt c Statistical Research Division c U.S. Census Bureau c Room 3000-4 c Washington, D.C. 20233 c (301) 763-3957 c----------------------------------------------------------------------- c Revised by Brian C. Monsell for X-12, X-13A-S c----------------------------------------------------------------------- c INCLUDE 'stdio.i' c----------------------------------------------------------------------- c call fclose(ALL) c call abort() c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'dgnsvl.i' c----------------------------------------------------------------------- LOGICAL istrue EXTERNAL istrue c----------------------------------------------------------------------- c if running a sliding spans or revisions history analysis, c generate diagnostic or savelog output indicating the analysis c has failed (BCM - March 2005) c----------------------------------------------------------------------- IF(Issap.eq.2.and.(Lsumm.gt.0.or.Svltab(LSLPCT)))THEN IF(Lsumm.gt.0)WRITE(Nform,1025)'failed' IF(Svltab(LSLPCT))WRITE(Ng,1035) ELSE IF(Irev.eq.4.and.(istrue(Svltab,LSLASA,LSLASP).or. & Lsumm.gt.0))THEN IF(Lsumm.gt.0)THEN WRITE(Nform,1015)'failed' IF(Irevsa.gt.0)WRITE(Nform,1005)'failed' END IF IF(istrue(Svltab,LSLASA,LSLASP))WRITE(Ng,1045) END IF IF(Lsumm.gt.0.and.Opnudg)WRITE(Nform,1055) c----------------------------------------------------------------------- CALL fstop() Lfatal=.true. c----------------------------------------------------------------------- 1005 FORMAT('historysa: ',a) 1015 FORMAT('history: ',a) 1025 FORMAT('sspans: ',a) 1035 FORMAT(/,' Sliding spans analysis failed : check error file.') 1045 FORMAT(/,' History analysis failed : check error file.') 1055 FORMAT('errorstop: yes') RETURN c----------------------------------------------------------------------- END ac02ae.i0000664006604000003110000000022614521201401011364 0ustar sun00315stepsC C... Variables in Common Block /ac02ae/ ... logical SAT double precision X,Y0,R,RX,J,JX common /ac02ae/ X,Y0,R,RX,J,JX,SAT acfar.f0000664006604000003110000000372214521201401011406 0ustar sun00315steps SUBROUTINE acfar(M,R,Res,Ndat,Ip,Iq) IMPLICIT NONE c----------------------------------------------------------------------- C Construct autocovariances for AR-filtered transformed series. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- INTEGER PR PARAMETER(PR=PLEN/4) c----------------------------------------------------------------------- INCLUDE 'autoq.cmn' c----------------------------------------------------------------------- C Dummy arguments c----------------------------------------------------------------------- REAL*8 R,Res INTEGER Ip,Iq,M,Ndat DIMENSION R(*),Res(*) c----------------------------------------------------------------------- C Local variables c----------------------------------------------------------------------- INTEGER i,is,k,m1,n,n35 c----------------------------------------------------------------------- C THE AUTOCOVARIANCES ARE STORED IN THE R VECTOR. c----------------------------------------------------------------------- n=Ndat C m1=MAX0(M,Ip+Iq+1) n35=INT(DLOG(DBLE(n))**2) M=MAX0(m1,n35) IF (M.GE.n) THEN M=MIN0(m1,n-n/4) c IF (Out.EQ.1) WRITE (7,*) 'M HAS BEEN MODIFIED TO ',M END IF C C0=0.0D0 DO i=1,n C0=C0+Res(i)**2 END DO c IF (M.GE.n) THEN c M=n-2 c IF (M.LE.0) THEN c WRITE (7,'(4X,''TOO FEW DEGREES OF FREEDOM'')') c RETURN c END IF c Ilb=M c IF (Out.EQ.1) WRITE (7,*) 'M HAS BEEN MODIFIED TO ',M c END IF C0=C0/DBLE(n) DO k=1,M R(k)=0.0D0 is=k+1 DO i=is,n R(k)=R(k)+Res(i)*Res(i-k) END DO R(k)=R(k)/(DBLE(n)*C0) END DO c----------------------------------------------------------------------- RETURN END acfast.i0000664006604000003110000000467114521201401011602 0ustar sun00315stepsC C Created by REG on 12 Aug 2005 C C... Variables in Common Block /acfast/ C Full statistics ... real*8 FACFPER(0:12),FACFPEM(0:12),FACFAER(0:12),FACFAEM(0:12), $ FACFSER(0:12),FACFSEM(0:12),FACFIER(0:12),FACFIEM(0:12) C Noend statistics ... real*8 NACFPER(0:12),NACFPEM(0:12),NACFAER(0:12),NACFAEM(0:12), $ NACFSER(0:12),NACFSEM(0:12),NACFIER(0:12),NACFIEM(0:12) C Weighted statistics ... real*8 WACFPER(0:12),WACFPEM(0:12),WACFAER(0:12),WACFAEM(0:12), $ WACFSER(0:12),WACFSEM(0:12),WACFIER(0:12),WACFIEM(0:12) C Full Diagnostics real*8 FACFPDG(0:12),FACFADG(0:12),FACFSDG(0:12),FACFIDG(0:12) C Noend Diagnostics real*8 NACFPDG(0:12),NACFADG(0:12),NACFSDG(0:12),NACFIDG(0:12) C Weighted Diagnostics real*8 WACFPDG(0:12),WACFADG(0:12),WACFSDG(0:12),WACFIDG(0:12) C Full Diagnostic Pvalues real*8 FACFPDP(0:12),FACFADP(0:12),FACFSDP(0:12),FACFIDP(0:12) C Noend Diagnostic Pvalues real*8 NACFPDP(0:12),NACFADP(0:12),NACFSDP(0:12),NACFIDP(0:12) C Weighted Diagnostic Pvalues real*8 WACFPDP(0:12),WACFADP(0:12),WACFSDP(0:12),WACFIDP(0:12) C Full Diagnostic Classes: 'ok', '+ ', '- ', '++', '--' character*2 FACFPDC(0:12),FACFADC(0:12),FACFSDC(0:12), $ FACFIDC(0:12) C Noend Diagnostic Classes: 'ok', '+ ', '- ', '++', '--' character*2 NACFPDC(0:12),NACFADC(0:12),NACFSDC(0:12), $ NACFIDC(0:12) C Weighted Diagnostic Classes: 'ok', '+ ', '- ', '++', '--' character*2 WACFPDC(0:12),WACFADC(0:12),WACFSDC(0:12), $ WACFIDC(0:12) common /acfast/ FACFPER,FACFPEM,FACFAER,FACFAEM, $ FACFSER,FACFSEM,FACFIER,FACFIEM, $ NACFPER,NACFPEM,NACFAER,NACFAEM, $ NACFSER,NACFSEM,NACFIER,NACFIEM, $ FACFPDG,FACFADG,FACFSDG,FACFIDG, $ NACFPDG,NACFADG,NACFSDG,NACFIDG, $ FACFPDP,FACFADP,FACFSDP,FACFIDP, $ NACFPDP,NACFADP,NACFSDP,NACFIDP, $ FACFPDC,FACFADC,FACFSDC,FACFIDC, $ NACFPDC,NACFADC,NACFSDC,NACFIDC, $ WACFPER,WACFPEM,WACFAER,WACFAEM, $ WACFSER,WACFSEM,WACFIER,WACFIEM, $ WACFPDG,WACFADG,WACFSDG,WACFIDG, $ WACFPDP,WACFADP,WACFSDP,WACFIDP, $ WACFPDC,WACFADC,WACFSDC,WACFIDC acfdgn.f0000664006604000003110000002204514521201401011553 0ustar sun00315stepsC Last change: BCM 29 Aug 2005 10:02 am **==savacf.f processed by SPAG 4.03F at 10:31 on 29 Jul 1994 SUBROUTINE acfdgn(Nefobs,A,Na,Mxlag,Nlagbl,Ldiag) IMPLICIT NONE c----------------------------------------------------------------------- c acfdgn() saves diagnostics related to the residual autocorrelation c function to the log file and to the unified diagnostics file. c Written by BCM July 2007 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'mdlsvl.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL F,T INTEGER PR PARAMETER(F=.FALSE.,T=.true.,PR=PLEN/4) c----------------------------------------------------------------------- CHARACTER outstr*(PR*3) DOUBLE PRECISION A(PLEN),smpac,seacf,tacflg INTEGER Nlagbl,i1,i2,i3,ilag,i,np,endlag,Nefobs,Na,Mxlag,ipos LOGICAL Ldiag DIMENSION smpac(PR),seacf(PR) c----------------------------------------------------------------------- INCLUDE 'autoq.cmn' c----------------------------------------------------------------------- c Compute residual ACF c----------------------------------------------------------------------- IF(Mxlag.eq.0)THEN IF(Sp.eq.1)THEN Mxlag=10 ELSE Mxlag=2*Sp END IF Mxlag=min(Mxlag,Nefobs/4) ELSE c ------------------------------------------------------------------ Mxlag=min(Mxlag,Nefobs-1) END IF c ------------------------------------------------------------------ np=0 endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))np=np+1 END DO c ------------------------------------------------------------------ CALL acf(A(Na-Nefobs+1),Nefobs,Nefobs,smpac,seacf,Mxlag,np,Sp, & 0,T,F) c ------------------------------------------------------------------ i1=0 i2=0 IF(Ldiag.or.Svltab(LSLLBQ))THEN DO i=1,Nlagbl IF(Dgf(i).gt.0.and.Qpv(i).lt.Qcheck)i1=i1+1 IF(dabs(smpac(i)/seacf(i)).gt.Acflim)i2=i2+1 END DO END IF c ------------------------------------------------------------------ c Print ACF seasonal lag info to log file c ------------------------------------------------------------------ IF(Svltab(LSLSAC).and.(Sp.eq.4.or.Sp.eq.12))THEN WRITE(Ng,1000)'Summary of Seasonal ACF Lags' WRITE(Ng,1001) i=1 ilag=Sp*1 DO WHILE (ilag.le.Mxlag) tacflg=smpac(ilag)/seacf(ilag) WRITE(Ng,1002)ilag,smpac(ilag),seacf(ilag),tacflg,Qs(ilag), & Dgf(ilag),Qpv(ilag) i=i+1 ilag=Sp*i END DO WRITE(Ng,*)' -------' WRITE(Ng,*)' ' END IF c ------------------------------------------------------------------ c Print ACF seasonal lag info to udg file c ------------------------------------------------------------------ IF(Ldiag.and.(Sp.eq.4.or.Sp.eq.12))THEN i=i+1 ilag=Sp*i DO WHILE (ilag.le.Mxlag) tacflg=smpac(ilag)/seacf(ilag) WRITE(Nform,1200)'acf',ilag,smpac(ilag),seacf(ilag),tacflg, & Qs(ilag),Dgf(ilag),Qpv(ilag) i=i+1 ilag=Sp*i END DO END IF c ------------------------------------------------------------------ c Print LB-Q information in log file c ------------------------------------------------------------------ IF(Svltab(LSLLBQ))THEN IF(i1.eq.0)THEN WRITE(Ng,1140)'Ljung-Box' ELSE WRITE(Ng,1120)'Ljung-Box' DO i=1,Nlagbl IF(Dgf(i).gt.0.and.Qpv(i).lt.Qcheck) & WRITE(Ng,1130)i,Qs(i),Dgf(i),Qpv(i) END DO WRITE(Ng,'()') END IF END IF c ------------------------------------------------------------------ c Print LB-Q information in udg file c ------------------------------------------------------------------ IF(Ldiag)THEN WRITE(Nform,1110)'qlimit',Qcheck WRITE(Nform,1160)'lb',i1 outstr=' ' ipos=1 IF(i1.gt.0)THEN DO i=1,Nlagbl IF(Dgf(i).gt.0.and.Qpv(i).lt.Qcheck)THEN WRITE(Nform,1150)'lb',i,Qs(i),Dgf(i),Qpv(i) call itoc(i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=' ' ipos=ipos+1 END IF END DO write(Nform,1190)'lb',outstr(1:(ipos-1)) ELSE write(Nform,1190)'lb','0' END IF END IF c ------------------------------------------------------------------ c Now produce BP-Q information c ------------------------------------------------------------------ i3=0 IF(Ldiag.or.Svltab(LSLLBQ+1))THEN CALL acf(A(Na-Nefobs+1),Nefobs,Nefobs,smpac,seacf,Mxlag,np,Sp, + 1,T,F) c ------------------------------------------------------------------ DO i=1,Nlagbl IF(Dgf(i).gt.0.and.Qpv(i).lt.Qcheck)i3=i3+1 END DO END IF c ------------------------------------------------------------------ c Print BP-Q information in log file c ------------------------------------------------------------------ IF(Svltab(LSLLBQ+1))THEN * IF(Laccss)CALL insmrk(Ng,LSLLBQ,T,T) IF(i3.eq.0)THEN WRITE(Ng,1140)'Box-Pierce' ELSE WRITE(Ng,1120)'Box-Pierce' DO i=1,Nlagbl IF(Dgf(i).gt.0.and.Qpv(i).lt.Qcheck) & WRITE(Ng,1130)i,Qs(i),Dgf(i),Qpv(i) END DO WRITE(Ng,'()') END IF * IF(Laccss)CALL insmrk(Ng,LSLLBQ,F,T) END IF c ------------------------------------------------------------------ c Print BP-Q information in udg file c ------------------------------------------------------------------ IF(Ldiag)THEN WRITE(Nform,1160)'bp',i3 outstr=' ' ipos=1 IF(i3.gt.0)THEN DO i=1,Nlagbl IF(Dgf(i).gt.0.and.Qpv(i).lt.Qcheck)THEN WRITE(Nform,1150)'bp',i,Qs(i),Dgf(i),Qpv(i) call itoc(i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=' ' ipos=ipos+1 END IF END DO write(Nform,1190)'bp',outstr(1:(ipos-1)) ELSE write(Nform,1190)'bp','0' END IF c ------------------------------------------------------------------ c Print significant ACF lags in udg file c ------------------------------------------------------------------ WRITE(Nform,1110)'acflimit',Acflim WRITE(Nform,1170)'acf',i2 outstr=' ' ipos=1 IF(i2.gt.0)THEN DO i=1,Nlagbl tacflg=smpac(i)/seacf(i) IF(dabs(tacflg).gt.Acflim)THEN WRITE(Nform,1180)'acf',i,smpac(i),seacf(i),tacflg call itoc(i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=' ' ipos=ipos+1 END IF END DO write(Nform,1190)'sigacf',outstr(1:(ipos-1)) ELSE write(Nform,1190)'sigacf','0' END IF END IF c ------------------------------------------------------------------ c Print significant PACF lags in udg file c ------------------------------------------------------------------ IF(Ldiag)THEN CALL pacf(Nefobs,Sp,smpac,seacf,Mxlag,F) i2=0 DO i=1,Nlagbl IF(dabs(smpac(i)/seacf(i)).gt.Acflim)i2=i2+1 END DO WRITE(Nform,1170)'pacf',i2 outstr=' ' ipos=1 IF(i2.gt.0)THEN DO i=1,Nlagbl tacflg=smpac(i)/seacf(i) IF(dabs(tacflg).gt.Acflim)THEN WRITE(Nform,1180)'pacf',i,smpac(i),seacf(i),tacflg call itoc(i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=' ' ipos=ipos+1 END IF END DO write(Nform,1190)'sigpacf',outstr(1:(ipos-1)) ELSE write(Nform,1190)'sigpacf','0' END IF END IF c ------------------------------------------------------------------ 1000 FORMAT(18x,a) 1001 FORMAT(16x,'ACF',8x,'SE',5x,'T-STAT',6x,'Q',6x,'df',2x,'P-VALUE') 1002 FORMAT(4x,'Lag',i3,4f10.3,i5,f8.3) 1110 FORMAT(a,': ',f7.4) 1120 FORMAT(5x,'Summary of Significant ',a,' Q:',/, & 5x,'Lag',5x,' Q ',5x,' DF',5x,' P',/, & 5x,'---',5x,'-------',5x,'---',5x,'-----') 1130 FORMAT(5x,i3,5x,f7.3,5x,i3,5x,f6.3) 1140 FORMAT(5x,'No significant ',a,' Qs',/) 1150 FORMAT(a,'q$',i2.2,': ',f7.3,5x,i3,5x,f6.3) 1160 FORMAT('n',a,'q: ',i3) 1170 FORMAT('nsig',a,': ',i3) 1180 FORMAT('sig',a,'$',i2.2,': ',f7.4,5x,f7.4,3x,f7.4) 1190 FORMAT(a,'lags: ',a) 1200 FORMAT(a,'$',i2.2,': ',f7.4,5x,f7.4,3x,f7.4,3x,f7.3,5x,i3,5x,f6.3) c----------------------------------------------------------------------- RETURN END acf.f0000664006604000003110000001262314521201401011063 0ustar sun00315stepsC Last change: BCM 5 Mar 1999 11:04 am **==acf.f processed by SPAG 4.03F at 14:08 on 8 Sep 1994 SUBROUTINE acf(Z,Nz,Nefobs,R,Se,Nr,Np,Sp,Iqtype,Lmu,Lprt) IMPLICIT NONE c----------------------------------------------------------------------- c ACF computes the sample autocorrelation function of vector z c----------------------------------------------------------------------- c Name type description c----------------------------------------------------------------------- c lprt l Input logical to print out the table c ncol i Local number of column of autocorrelations to print c nlag i Local number of lags c np i Local number of parameters in the ARIMA model c nr i Output length of vector r, sample autocorrelations c nefobs i Input number of effective observations c nz i Input number of observations in the data vector c nmaopr i Local number of lag operators in the all the components c of the structural model c one d Local PARAMETER for 1.0d0 c r d Ouput vector of sample autocorrelations c se d Local vector of standard errors c sp i Input length of the seasonal period c z d Input vector of data c zero d Local PARAMETER for 0.0d0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'stdio.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER PR DOUBLE PRECISION ONE,ZERO PARAMETER(PR=PLEN/4,ONE=1D0,ZERO=0D0) c ------------------------------------------------------------------ INCLUDE 'autoq.cmn' c ------------------------------------------------------------------ INTEGER i,ip1,isp,j,jsp,k,mp1,ncol,Nefobs,Nz,Np,Nr,nrm1,Iqtype,Sp DOUBLE PRECISION c,mu,R,Se,sr,sq,Z DIMENSION c(PR),R(PR),Se(PR),Z(Nz) LOGICAL Lprt,Lmu c ------------------------------------------------------------------ DOUBLE PRECISION chisq EXTERNAL chisq c ------------------------------------------------------------------ IF(Nr.le.0)Nr=min(3*Sp,int(Nz/4.0+.99)) mu=ZERO C0=ZERO c ------------------------------------------------------------------ IF(Lmu)THEN DO k=1,Nz mu=mu+Z(k) END DO END IF c ------------------------------------------------------------------ mu=mu/Nz DO k=1,Nz C0=C0+(Z(k)-mu)**2 END DO c ------------------------------------------------------------------ IF(C0.le.ZERO)THEN IF(.not.Lquiet)WRITE(STDERR,1010) CALL errhdr WRITE(Mt2,1010) 1010 FORMAT(/,' NOTE: Can''t calculate an ACF for a ', & 'model with no variance') CALL setdp(DNOTST,PR,Qpv) c ------------------------------------------------------------------ ELSE C0=C0/Nz sq=ZERO c---------------------------------------------------------------------- c formula for computing autocovariances c c0=mle var c n c ck=1/n* sum (z j-mu)(z j-i-mu) c j=i+1 c rk=ck/c0 c---------------------------------------------------------------------- DO i=1,Nr c(i)=ZERO ip1=i+1 c ------------------------------------------------------------------ DO j=ip1,Nz c(i)=c(i)+(Z(j)-mu)*(Z(j-i)-mu) END DO c ------------------------------------------------------------------ c(i)=c(i)/Nz R(i)=c(i)/C0 IF(Iqtype.eq.0)THEN sq=sq+R(i)**2/(Nefobs-i) Qs(i)=sq*Nefobs*(Nefobs+2) ELSE sq=sq+R(i)**2 Qs(i)=sq*Nefobs END IF Dgf(i)=max(0,i-Np) IF(Dgf(i).gt.0)THEN Qpv(i)=chisq(Qs(i),Dgf(i)) ELSE Qpv(i)=ZERO END IF END DO c---------------------------------------------------------------------- c Use Bartlett's formula for computing standard errors of acf c se(rq) =~ 1/sqrt(n)*(1+2(r1**2+r2**2+...+rq**2)) c---------------------------------------------------------------------- Se(1)=ONE/sqrt(dble(Nz)) sr=ZERO nrm1=Nr-1 c ------------------------------------------------------------------ DO i=1,nrm1 sr=sr+R(i)*R(i) Se(i+1)=sqrt((ONE+2.0D0*sr)/dble(Nz)) END DO c ------------------------------------------------------------------ IF(Lprt)THEN ncol=Sp IF(Sp.eq.1)ncol=10 IF(Sp.gt.12)ncol=12 c ------------------------------------------------------------------ mp1=(Nr-1)/ncol+1 DO i=1,mp1 isp=(i-1)*ncol+1 jsp=min(isp+ncol-1,Nr) WRITE(Mt1,1020)(j,j=isp,jsp) 1020 FORMAT(/,' Lag ',12I6) WRITE(Mt1,1030)(R(j),j=isp,jsp) 1030 FORMAT(' ACF ',12F6.2) WRITE(Mt1,1040)(Se(j),j=isp,jsp) 1040 FORMAT(' SE ',12F6.2) WRITE(Mt1,1050)(Qs(j),j=isp,jsp) 1050 FORMAT(' Q ',12F6.2) WRITE(Mt1,1060)(Dgf(j),j=isp,jsp) 1060 FORMAT(' DF ',12I6) WRITE(Mt1,1070)(Qpv(j),j=isp,jsp) 1070 FORMAT(' P ',12F6.3) END DO c ------------------------------------------------------------------ END IF END IF c ------------------------------------------------------------------ RETURN END acfhdr.f0000664006604000003110000000720614521201401011562 0ustar sun00315steps SUBROUTINE acfhdr(Mt1,Ndf,Nsdf,Iflag) IMPLICIT NONE c----------------------------------------------------------------------- c print title to acf and pacf tables and plots c iflag i indicator for PACF and ACF, i = 1 PACF, i = 2,4 ACF, c i=3,5 ACF of squared residuals c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' c----------------------------------------------------------------------- CHARACTER ctargt*(50) DOUBLE PRECISION Lam INTEGER Fcntyp,Mt1,Ndf,Nsdf,Iflag,ntargt c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- COMMON /armalm/ Lam,Fcntyp c----------------------------------------------------------------------- IF(Ndf.eq.NOTSET)THEN IF(Iflag.eq.3.or.Iflag.eq.5)THEN ctargt(1:17)='Squared Residuals' ntargt=17 ELSE ctargt(1:9)='Residuals' ntargt=9 END IF ELSE IF(Nb.gt.0)THEN ctargt(1:20)='Regression Residuals' ntargt=20 ELSE ctargt(1:6)='Series' ntargt=6 IF(dpeq(Lam,0D0).or.Kfmt.gt.0)THEN ctargt(7:8)=' (' ntargt=ntargt+2 IF(dpeq(Lam,0D0))THEN ctargt(9:19)='Transformed' ntargt=ntargt+11 IF(Kfmt.gt.0)THEN ctargt(20:21)=', ' ntargt=ntargt+2 END IF END IF IF(Kfmt.gt.0)THEN ctargt(ntargt+1:ntargt+11)='Preadjusted' ntargt=ntargt+11 END IF ctargt(ntargt+1:ntargt+1)=')' ntargt=ntargt+1 END IF END IF END IF c----------------------------------------------------------------------- c Write out header for the plot c----------------------------------------------------------------------- IF(Iflag.eq.1)THEN WRITE(Mt1,1010)ctargt(1:ntargt) ELSE IF(Iflag.le.3)THEN IF(Iqtype.eq.0)THEN WRITE(Mt1,1021)ctargt(1:ntargt),'Ljung-Box' ELSE WRITE(Mt1,1021)ctargt(1:ntargt),'Box-Pierce' END IF ELSE WRITE(Mt1,1020)ctargt(1:ntargt) END IF END IF c----------------------------------------------------------------------- IF(Ndf.ne.NOTSET)THEN IF(Ndf.eq.0)THEN IF(Nsdf.eq.0)THEN WRITE(Mt1,1030) c ------------------------------------------------------------------ ELSE WRITE(Mt1,1040)Nsdf END IF c ------------------------------------------------------------------ ELSE IF(Nsdf.eq.0)THEN WRITE(Mt1,1050)Ndf c ------------------------------------------------------------------ ELSE WRITE(Mt1,1060)Ndf,Nsdf END IF END IF c ------------------------------------------------------------------ 1010 FORMAT(' Sample Partial Autocorrelations of the ',a) 1020 FORMAT(' Sample Autocorrelations of the ',a) 1021 FORMAT(' Sample Autocorrelations of the ',a,' with the ',a, & ' diagnostic.') 1030 FORMAT(' Differencing: none') 1040 FORMAT(' Differencing: Seasonal Order=',i1) 1050 FORMAT(' Differencing: Nonseasonal Order=',i1) 1060 FORMAT(' Differencing: Nonseasonal Order=',i1, & ', Seasonal Order=',i1) c ------------------------------------------------------------------ RETURN END acfptr.prm0000664006604000003110000000066014521201401012160 0ustar sun00315stepsc----------------------------------------------------------------------- c LACF,LACP,LPCF, and LPCP are displacements from the c spec pointers so that prtacf can print the right combination c of acf's and plots whether they are for the identify or the check. c----------------------------------------------------------------------- INTEGER LACF, LACP, LPCF, LPCP PARAMETER (LACF=1, LACP=2, LPCF=3, LPCP=4) acfst.i0000664006604000003110000000073414521201401011435 0ustar sun00315stepsC C... Variables in Common Block /acfst/ ... real*8 ACFPTH(0:24),ACFPER(0:mc),ACFPEM(0:24),ACFATH(0:24), $ ACFAER(0:mc),ACFAEM(0:24),ACFSTH(0:24),ACFSER(0:mc), $ ACFSEM(0:24),ACFCTH(0:24),ACFCER(0:mc),ACFCEM(0:24), $ ACFITH(0:24),ACFIER(0:mc),ACFIEM(0:24) common /acfst/ ACFPTH,ACFPER,ACFPEM,ACFATH,ACFAER,ACFAEM,ACFSTH, $ ACFSER,ACFSEM,ACFCTH,ACFCER,ACFCEM,ACFITH,ACFIER, $ ACFIEM across.i0000664006604000003110000000163214521201401011625 0ustar sun00315stepsC C Created by REG on 12 Aug 2005 C C... Variables in Common Block /altcrosscov/ ... C Cross Covariance Estimates real*8 seaIrrEst, seaTreEst, treIrrEst C Cross Covariance Estimators real*8 seaIrrEso, seaTreEso, treIrrEso C Cross Covariance Variances real*8 seaIrrVar, seaTreVar, treIrrVar C Cross Covariance Diagnostics real*8 seaIrrDia, seaTreDia, treIrrDia C Cross Covariance Pvalues real*8 seaIrrDgP, seaTreDgP, treIrrDgP C Cross Covariance Classes: 'ok', '+ ', '- ', '++', '--' character*2 seaIrrDgC, seaTreDgC, treIrrDgC C The Cross Covariance common block common /altcrosscov/ & seaIrrEst, seaTreEst, treIrrEst, & seaIrrEso, seaTreEso, treIrrEso, & seaIrrVar, seaTreVar, treIrrVar, & seaIrrDia, seaTreDia, treIrrDia, & seaIrrDgP, seaTreDgP, treIrrDgP, & seaIrrDgC, seaTreDgC, treIrrDgC addadj.f0000664006604000003110000000763114521201401011544 0ustar sun00315stepsC Last change: BCM 20 Jan 98 11:44 am SUBROUTINE addadj(Nspobs,Begspn,Sp,Begadj,Bgusra,Nusrad,Frstad, & Usradj,Adj,Nadj,Base,Adjtyp,Percnt,Ok) IMPLICIT NONE c----------------------------------------------------------------------- c Add a user-defined prior adjustment series to the main prior c adjustment file Adj. c----------------------------------------------------------------------- DOUBLE PRECISION ONEHND,ZERO LOGICAL F,T PARAMETER(F=.false.,T=.true.,ONEHND=100D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER Adjtyp*(9) INTEGER Nspobs,Begspn,Sp,Bgusra,Nusrad,Frstad,iprd,Begadj,Percnt, & Nadj,iprd2 LOGICAL Ok DOUBLE PRECISION Usradj,Adj,Base DIMENSION Adj(*),Usradj(*),Begspn(2),Bgusra(2),Begadj(2) c----------------------------------------------------------------------- LOGICAL chkcvr EXTERNAL chkcvr c----------------------------------------------------------------------- c Check to see if the span of the adjustments is large enough to c----------------------------------------------------------------------- IF(.not.chkcvr(Bgusra,Nusrad,Begspn,Nspobs,Sp))THEN CALL cvrerr(Adjtyp//' adjustments',Bgusra,Nusrad,'span',Begspn, & Nspobs,Sp) IF(Lfatal)RETURN Ok=F RETURN END IF c----------------------------------------------------------------------- c Get the difference between the user start date and the total c adjustment start date . If this difference is negative, assume this is c due to backcasts and append 1.0 (or zero) to the user-defined c backcasts. c----------------------------------------------------------------------- CALL dfdate(Begadj,Bgusra,Sp,Frstad) IF(Frstad.lt.0)THEN DO iprd=Nusrad,1,-1 iprd2=iprd-Frstad Usradj(iprd2)=Usradj(iprd) IF(Percnt.eq.0)Usradj(iprd2)=Usradj(iprd2)/ONEHND IF(iprd.le.abs(Frstad))Usradj(iprd)=Base END DO Nusrad=Nusrad-Frstad Frstad=0 CALL cpyint(Begadj,2,1,Bgusra) ELSE IF(Percnt.eq.0)THEN DO iprd=Nusrad,1,-1 Usradj(iprd)=Usradj(iprd)/ONEHND END DO END IF c ------------------------------------------------------------------ c Now combine the adjustments. c ------------------------------------------------------------------ DO iprd=1,Nadj iprd2=iprd+Frstad IF(iprd2.le.Nusrad)THEN IF(Percnt.lt.2)THEN IF(Usradj(iprd2).le.ZERO)THEN IF(Percnt.eq.0)THEN CALL writln('ERROR: Prior adjustment factors expressed as per ¢ages cannot have values',STDERR,Mt2,T) ELSE CALL writln('ERROR: Prior adjustment factors expressed as rat &ios cannot have values',STDERR,Mt2,T) END IF CALL writln(' less than or equal to zero.',STDERR,Mt2,F) CALL writln(' Check the '//Adjtyp// & ' prior adjustment factors given in your spec file.', & STDERR,Mt2,T) CALL abend RETURN END IF Adj(iprd)=Adj(iprd)*Usradj(iprd2) ELSE Adj(iprd)=Adj(iprd)+Usradj(iprd2) END IF ELSE Usradj(iprd2)=Base END IF END DO c----------------------------------------------------------------------- c Make Frstad the time point the adjustments begin on in the user c defined adjustment series, not a displacement. c----------------------------------------------------------------------- Frstad=Frstad+1 c----------------------------------------------------------------------- RETURN END addate.f0000664006604000003110000000326514521201402011557 0ustar sun00315stepsC Last change: BCM 6 Oct 97 11:15 am **==addate.f processed by SPAG 4.03F at 09:46 on 1 Mar 1994 SUBROUTINE addate(Indate,Sp,B10,Outdat) c----------------------------------------------------------------------- IMPLICIT NONE INTEGER Indate(2),Sp,B10,iadd,Outdat(2) c----------------------------------------------------------------------- c If the seasonal period is one, indate(2) and outdat(2) have c no meaning. c----------------------------------------------------------------------- IF(Sp.eq.1)THEN Outdat(1)=Indate(1)+B10 Outdat(2)=0 ELSE c----------------------------------------------------------------------- c Else treat as dates. First, convert to base 10. c----------------------------------------------------------------------- iadd=Indate(1)*Sp+Indate(2)+B10 c----------------------------------------------------------------------- c Convert the result back to the date form. Note this will handle c negative dates. c----------------------------------------------------------------------- Outdat(1)=iadd/Sp Outdat(2)=mod(iadd,Sp) c----------------------------------------------------------------------- IF(Outdat(2).lt.0)THEN Outdat(1)=Outdat(1)-1 Outdat(2)=Sp+Outdat(2) c----------------------------------------------------------------------- ELSE IF(Outdat(2).eq.0.and.Outdat(1).eq.0)THEN Outdat(1)=-1 Outdat(2)=Sp ELSE IF(Outdat(2).eq.0)THEN Outdat(1)=Outdat(1)-1 Outdat(2)=Sp END IF END IF c----------------------------------------------------------------------- RETURN END addeas.f0000664006604000003110000000317114521201402011552 0ustar sun00315stepsC Last change: BCM 22 Sep 1998 10:59 am SUBROUTINE addeas(Keastr,Easidx,Eastst) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine adds trading day or holiday regressors for the c automatic AIC test. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.FALSE.) c----------------------------------------------------------------------- CHARACTER tgrptl*(PGRPCR) INTEGER ipos,Keastr,nchr,Easidx,Eastst,etype c----------------------------------------------------------------------- c Add Easter regressor to the regression matrix c----------------------------------------------------------------------- IF(Easidx.eq.0)THEN IF(Eastst.eq.1)THEN tgrptl='Easter[' ipos=8 etype=PRGTEA ELSE tgrptl='StockEaster[' ipos=13 etype=PRGTES END IF CALL itoc(Keastr,tgrptl,ipos) ELSE tgrptl='StatCanEaster[' ipos=15 CALL itoc(Keastr-Easidx,tgrptl,ipos) etype=PRGTEC END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- tgrptl(ipos:ipos)=']' nchr=ipos CALL adrgef(DNOTST,tgrptl(1:nchr),tgrptl(1:nchr),etype,F,F) c----------------------------------------------------------------------- RETURN END addfix.f0000664006604000003110000000733014521201402011571 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 1:46 pm SUBROUTINE addfix(Trnsrs,Nbcst,Rind,Fxindx) IMPLICIT NONE c----------------------------------------------------------------------- c Adds fixed regressors back into the regression matrix, as well as c the effects of the fixed regressors to the adjusted transformed c series. This routine also used to add back regressors after the c ARIMA model orders are identified. c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'fxreg.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER str*(PCOLCR),strgrp*(PGRPCR) INTEGER i,icol,Nbcst,nchr,nchgrp,igrp,begcol,endcol,Rind,Fxindx, & nu DOUBLE PRECISION Trnsrs(PLEN) c----------------------------------------------------------------------- IF(Ngrpfx.eq.0)RETURN c----------------------------------------------------------------------- c Step through each group of the fixed regressors, and add them back c into the regression matrix. c----------------------------------------------------------------------- nu=0 DO igrp=Ngrpfx,1,-1 begcol=Grpfix(igrp-1) endcol=Grpfix(igrp)-1 c----------------------------------------------------------------------- IF((Fxtype(begcol).ge.PRGTUH.and.Fxtype(begcol).le.PRGUH5).or. & Fxtype(begcol).eq.PRGTUS.or.Fxtype(begcol).eq.PRGUTD.or. & Fxtype(begcol).eq.PRGTUD.or.Fxtype(begcol).eq.PRGULM.or. & Fxtype(begcol).eq.PRGULQ.or.Fxtype(begcol).eq.PRGULY.or. & Fxtype(begcol).eq.PRGUAO.or.Fxtype(begcol).eq.PRGULS.or. & Fxtype(begcol).eq.PRGUSO.or.Fxtype(begcol).eq.PRGUCN.or. & Fxtype(begcol).eq.PRGUCY)THEN nu=nu+1 c----------------------------------------------------------------------- c delete regressor(s) from set (BCM Jul 2007) c----------------------------------------------------------------------- DO icol=endcol,begcol,-1 IF(Fixind(icol).eq.Fxindx)THEN CALL delstr(icol,Cfxttl,Cfxptr,Nfxttl,PB) IF(Lfatal)RETURN END IF END DO ELSE CALL getstr(Gfxttl,Gfxptr,Ngfxtl,igrp,strgrp,nchgrp) IF(Lfatal)RETURN DO icol=endcol,begcol,-1 IF(Fixind(icol).eq.Fxindx)THEN CALL getstr(Cfxttl,Cfxptr,Nfxttl,icol,str,nchr) IF(.not.Lfatal) & CALL adrgef(Bfx(icol),str(1:nchr),strgrp(1:nchgrp), & Fxtype(icol),Fxindx.eq.1,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c delete regressor from set c----------------------------------------------------------------------- CALL delstr(icol,Cfxttl,Cfxptr,Nfxttl,PB) IF(Lfatal)RETURN END IF END DO END IF END DO c----------------------------------------------------------------------- IF(Userfx.or.(Fxindx.eq.2.and.nu.gt.0))THEN CALL addusr(Rind,Fxindx) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Fxindx.eq.2)THEN DO i=1,Nspobs Trnsrs(i)=Trnsrs(i)+Fixfc2(i+Nbcst) END DO ELSE DO i=1,Nspobs Trnsrs(i)=Trnsrs(i)+Fixfac(i+Nbcst) END DO END IF c----------------------------------------------------------------------- RETURN END addlom.f0000664006604000003110000000571214521201402011574 0ustar sun00315stepsC Last change: BCM 22 Sep 1998 10:59 am SUBROUTINE addlom(Aicrgm,Aicln0,Sp,Lnindx) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine adds trading day or holiday regressors for the c automatic AIC test. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.FALSE.) c----------------------------------------------------------------------- CHARACTER tgrptl*(PGRPCR),datstr*(10) INTEGER Aicstk,Aicrgm,ipos,Sp,nchdat,nchr,Aicln0,Lnindx,ipos2, & varln,varln1,varln2 DIMENSION Aicrgm(2) c----------------------------------------------------------------------- IF(Aicrgm(1).ne.NOTSET)THEN CALL wrtdat(Aicrgm,Sp,datstr,nchdat) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Lnindx.eq.0)RETURN c----------------------------------------------------------------------- c Add lom/loq/lpyear regressors. c----------------------------------------------------------------------- IF(Lnindx.eq.1)THEN tgrptl='Length-of-Month' ipos=15 varln= PRGTLM varln1=PRRTLM varln2=PRATLM ELSE IF(Lnindx.eq.2)THEN tgrptl='Length-of-Quarter' ipos=17 varln= PRGTLQ varln1=PRRTLQ varln2=PRATLQ ELSE tgrptl='Leap Year' ipos=9 varln= PRGTLY varln1=PRRTLY varln2=PRATLY END IF IF(Aicln0.eq.0)THEN ipos2=ipos IF(Aicrgm(1).ne.NOTSET)THEN ipos2=ipos+nchdat+9 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (after '//datstr(1:nchdat)// & ')' END IF CALL adrgef(DNOTST,tgrptl(1:ipos),tgrptl(1:ipos2),varln,F,F) IF(Lfatal)RETURN END IF IF(Aicrgm(1).ne.NOTSET)THEN IF(Aicln0.ge.0)THEN IF(Aicln0.eq.0)THEN ipos2=ipos+nchdat+22 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (change for before '// & datstr(1:nchdat)//')' ELSE ipos2=ipos+nchdat+10 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (before '// & datstr(1:nchdat)//')' END IF CALL adrgef(DNOTST,tgrptl(1:ipos)//' I',tgrptl(1:ipos2),varln1, & F,F) IF(Lfatal)RETURN ELSE ipos2=ipos+nchdat+12 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (starting '// & datstr(1:nchdat)//')' CALL adrgef(DNOTST,tgrptl(1:ipos)//' II',tgrptl(1:ipos2),varln2, & F,F) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- RETURN END addmat.f0000664006604000003110000000611514521201402011564 0ustar sun00315steps SUBROUTINE addMat( mA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c addMat.f, Release 1, Subroutine Version 1.0, Created 11 Apr 2005. c----------------------------------------------------------------------- c This subroutine calculates the matrix addition of mC = mA + mB c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to be added c mB d second input matrix to be added c mC d matrix output result of mA+mB c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nB(1), nB(2) ), & mC( nA(1), nB(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j c----------------------------------------------------------------------- c Check for valid matrix addition. c----------------------------------------------------------------------- IF (( nA(1) .eq. nB(1) ) .and. ( nA(2) .eq. nB(2) )) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(1) nC(2) = nB(2) c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA + mB. c----------------------------------------------------------------------- DO i = 1, nC(1) c ------------------------------------------------------------------ c Compute vector addition of mA row i plus mB row i. c ------------------------------------------------------------------ DO j = 1, nC(2) mC(i,j) = mA(i,j) + mB(i,j) END DO END DO c----------------------------------------------------------------------- c Invalid matrix addition. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END addmul.f0000664006604000003110000000107714521201402011602 0ustar sun00315steps SUBROUTINE addmul(Z,X,Y,Ib,Ie) IMPLICIT NONE C*** Start of declarations inserted by SPAG INCLUDE 'srslen.prm' INCLUDE 'x11opt.cmn' INTEGER i,Ib,Ie DOUBLE PRECISION X,Y,Z C*** End of declarations inserted by SPAG C --- THIS SUBROUTINE MULTIPLIES (ADDS) SERIES X TO Y AND STORES THE C --- RESULT IN Z. DIMENSION X(Ie),Y(Ie),Z(Ie) IF(Muladd.ne.0)THEN DO i=Ib,Ie Z(i)=X(i)+Y(i) END DO RETURN END IF DO i=Ib,Ie Z(i)=X(i)*Y(i) END DO RETURN END addotl.f0000664006604000003110000003625514521201402011611 0ustar sun00315stepsC Last change: BCM 16 Jul 2003 5:07 pm SUBROUTINE addotl(Bgdtxy,Nrxy,Iymx,Begcol,Endcol) IMPLICIT NONE c----------------------------------------------------------------------- c Add outlier effect variables from begcol:endcol outliers in an c nrxy by ncxy Xy matrix. Outliers are defined by date (yr,mo) and c type, AO or LS in the notlr rows of otlr. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begcol i Local begining column of the x matrix that holds the c outlier effects c begotl i Local index for t0 of an AO or LS outlier, c or the begining of the ramp. c bgdtXy i Input date array of the starting date of the observations c in the extended Xy matrix (yr,mo) c drmp d Local number of point on the ramp, the inverse c is the increment the ramp must climb c each time point c endcol i Local index for last column of x used for outlier effects c endotl i Local end of the ramp. c icol i Local index for the current Xy matrix column c irow i Local index for the current Xy matrix row c iymx i Input difference in the number of time points between c the start dates of the series, y, and the regression c variables, x. c j i Local do loop index c mone d Local PARAMETER double precision -1. Used to set c the LS effects c notlr i Local number of outliers, also is the number of columns c used for outlier effects and the number of rows of otlr c one d Local PARAMETER double precision 1 c otldat i Local date (yr,mo) that the outlier occured on or the dates c (begyr,begmo,endyr,endmo) the ramp occured on. c otltyp c Local 2 character outlier type specifier, AO, LS, or RP c predat i Local date one period before the start of X. Used as a c displacement c zero d Local PARAMETER for a double precision 0d0 c----------------------------------------------------------------------- c Date types and initialization c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO,ONE,MONE PARAMETER(ZERO=0.0D0,ONE=1.0D0,MONE=-1.0D0) c ------------------------------------------------------------------ CHARACTER str*(19) LOGICAL locok INTEGER Bgdtxy,begotl,endotl,icol,irow,nchr,Nrxy,otltyp,Begcol, & Endcol,Iymx,imod DOUBLE PRECISION drmp,drow DIMENSION Bgdtxy(2) c----------------------------------------------------------------------- c Check that the begining and ending columns are between 1 and nb. c----------------------------------------------------------------------- IF(Begcol.lt.1.or.Endcol.gt.Ncxy-1.or.Endcol.lt.Begcol)THEN IF(.not.Lhiddn)WRITE(STDERR,1010)Begcol,Endcol,Ncxy-1 CALL errhdr WRITE(Mt2,1010)Begcol,Endcol,Ncxy-1 1010 FORMAT(/,' ERROR: Column, 1<=begcol<=endcol<= nb', & /,25x,3I8,'.') CALL abend RETURN END IF c----------------------------------------------------------------------- c Check and add the outliers c----------------------------------------------------------------------- icol=Begcol DO WHILE (icol.le.Endcol) CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(.not.Lfatal)THEN CALL rdotlr(str(1:nchr),Bgdtxy,Sp,otltyp,begotl,endotl,locok) IF(.not.locok)CALL abend END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c AO outlier c----------------------------------------------------------------------- IF(otltyp.eq.AO.or.otltyp.eq.MV)THEN IF(begotl.gt.Iymx+Nspobs.or.begotl.lt.Iymx+1)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) 1020 FORMAT(/,' NOTE: Removing ',a, & ' from the regression because it is not within',/, & ' the span of the data.',/) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE DO irow=1,Nrxy Xy(Ncxy*(irow-1)+icol)=ZERO END DO Xy(Ncxy*(begotl-1)+icol)=ONE icol=icol+1 END IF c----------------------------------------------------------------------- c LS outlier c----------------------------------------------------------------------- ELSE IF(otltyp.eq.LS)THEN IF(begotl.gt.Iymx+Nspobs.or.begotl.lt.Iymx+2)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(begotl.eq.Iymx+Nspobs+1)THEN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1030)str(1:nchr) CALL errhdr WRITE(Mt2,1030)str(1:nchr) 1030 FORMAT(/,' NOTE: Removing ',a, & ' from the regression because it occurs at the',/, & ' last data point of the span of the data.',/) ELSE IF(begotl.eq.Iymx+1)THEN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1040)str(1:nchr) CALL errhdr WRITE(Mt2,1040)str(1:nchr) 1040 FORMAT(/,' NOTE: Removing ',a, & ' from the regression because it occurs at the',/, & ' first data point of the span of the data.',/) ELSE IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) END IF CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE DO irow=1,begotl-1 Xy(Ncxy*(irow-1)+icol)=MONE END DO c ------------------------------------------------------------------ DO irow=begotl,Nrxy Xy(Ncxy*(irow-1)+icol)=ZERO END DO icol=icol+1 END IF c----------------------------------------------------------------------- c Ramp outlier, If both end points are outside the span, drop c the ramp because either a constant or a slope will be the variable. c----------------------------------------------------------------------- ELSE IF(otltyp.eq.RP)THEN IF((endotl.le.begotl).or.(begotl.ge.Iymx+Nspobs).or. & (endotl.le.Iymx+1).or. & (begotl.le.Iymx+1.and.endotl.ge.Iymx+Nspobs))THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE drmp=dble(endotl-begotl) DO irow=1,begotl Xy(Ncxy*(irow-1)+icol)=-drmp c Xy(Ncxy*(irow-1)+icol)=MONE END DO c ------------------------------------------------------------------ DO irow=max(1,begotl+1),min(endotl-1,Nrxy) Xy(Ncxy*(irow-1)+icol)=(irow-max(1,begotl+1)+1)-drmp c Xy(Ncxy*(irow-1)+icol)=dble(irow-endotl)/drmp END DO c ------------------------------------------------------------------ DO irow=endotl,Nrxy Xy(Ncxy*(irow-1)+icol)=ZERO END DO icol=icol+1 END IF c----------------------------------------------------------------------- c temporary level shift outlier, c If both end points are outside the span, drop the temporary LS c because a constant will be the variable. c----------------------------------------------------------------------- ELSE IF(otltyp.eq.TLS)THEN IF((endotl.le.begotl).or.(begotl.ge.Iymx+Nspobs).or. & (endotl.le.Iymx+1).or. & (begotl.le.Iymx+1.and.endotl.ge.Iymx+Nspobs))THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE IF((begotl-1).gt.1)THEN DO irow=1,begotl-1 Xy(Ncxy*(irow-1)+icol)=ZERO c Xy(Ncxy*(irow-1)+icol)=MONE END DO END IF c ------------------------------------------------------------------ DO irow=max(1,begotl),min(endotl,Nrxy) Xy(Ncxy*(irow-1)+icol)=ONE c Xy(Ncxy*(irow-1)+icol)=dble(irow-endotl)/drmp END DO c ------------------------------------------------------------------ IF((endotl+1).lt.Nrxy)THEN DO irow=endotl+1,Nrxy Xy(Ncxy*(irow-1)+icol)=ZERO END DO END IF icol=icol+1 END IF c----------------------------------------------------------------------- c TC outlier c----------------------------------------------------------------------- ELSE IF(otltyp.eq.TC)THEN IF(begotl.gt.Iymx+Nspobs.or.begotl.lt.Iymx+1)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE DO irow=1,begotl-1 Xy(Ncxy*(irow-1)+icol)=ZERO END DO c ------------------------------------------------------------------ Xy(Ncxy*(begotl-1)+icol)=ONE DO irow=begotl+1,Nrxy Xy(Ncxy*(irow-1)+icol)=Xy(Ncxy*(irow-2)+icol)*Tcalfa END DO icol=icol+1 END IF c----------------------------------------------------------------------- c SO outlier c----------------------------------------------------------------------- ELSE IF(otltyp.eq.SO)THEN IF(begotl.gt.Iymx+Nspobs.or.begotl.lt.Iymx+1)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE DO irow=begotl,Nrxy Xy(Ncxy*(irow-1)+icol)=ZERO END DO c ------------------------------------------------------------------ imod=mod(begotl,Sp) drmp=ONE/DBLE(Sp-1) DO irow=begotl-1,1,-1 IF(mod(irow,Sp).eq.imod)THEN Xy(Ncxy*(irow-1)+icol)=MONE ELSE Xy(Ncxy*(irow-1)+icol)=drmp END IF END DO icol=icol+1 END IF c----------------------------------------------------------------------- c Quadratic Ramp outlier, increasing rate of change c If both end points are outside the span, drop c the ramp because either a constant or a slope will be the variable. c----------------------------------------------------------------------- ELSE IF(otltyp.eq.QI)THEN IF((endotl.le.begotl).or.(begotl.ge.Iymx+Nspobs).or. & (endotl.le.Iymx+1).or. & (begotl.le.Iymx+1.and.endotl.ge.Iymx+Nspobs))THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE drmp=dble(endotl-begotl) DO irow=1,begotl Xy(Ncxy*(irow-1)+icol)=-(drmp*drmp) c Xy(Ncxy*(irow-1)+icol)=MONE END DO c ------------------------------------------------------------------ DO irow=max(1,begotl+1),min(endotl-1,Nrxy) drow=dble(irow-max(1,begotl+1)+1) Xy(Ncxy*(irow-1)+icol)=(drow*drow)-(drmp*drmp) c Xy(Ncxy*(irow-1)+icol)=dble(irow-endotl)/drmp END DO c ------------------------------------------------------------------ DO irow=endotl,Nrxy Xy(Ncxy*(irow-1)+icol)=ZERO END DO icol=icol+1 END IF c----------------------------------------------------------------------- c Quadratic Ramp outlier, decreasing rate of change c If both end points are outside the span, drop c the ramp because either a constant or a slope will be the variable. c----------------------------------------------------------------------- ELSE IF(otltyp.eq.QD)THEN IF((endotl.le.begotl).or.(begotl.ge.Iymx+Nspobs).or. & (endotl.le.Iymx+1).or. & (begotl.le.Iymx+1.and.endotl.ge.Iymx+Nspobs))THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(.not.(Lquiet.or.Lhiddn))WRITE(STDERR,1020)str(1:nchr) CALL errhdr WRITE(Mt2,1020)str(1:nchr) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN Endcol=Endcol-1 c ------------------------------------------------------------------ ELSE drmp=dble(endotl-begotl) DO irow=1,begotl Xy(Ncxy*(irow-1)+icol)=-(drmp*drmp) c Xy(Ncxy*(irow-1)+icol)=MONE END DO c ------------------------------------------------------------------ DO irow=max(1,begotl+1),min(endotl-1,Nrxy) drow=dble(irow-max(1,begotl+1)+1) Xy(Ncxy*(irow-1)+icol)=-((drmp-drow)*(drmp-drow)) c Xy(Ncxy*(irow-1)+icol)=dble(irow-endotl)/drmp END DO c ------------------------------------------------------------------ DO irow=endotl,Nrxy Xy(Ncxy*(irow-1)+icol)=ZERO END DO icol=icol+1 END IF ELSE c----------------------------------------------------------------------- c Not an outlier c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN WRITE(STDERR,1050)str(1:nchr) CALL errhdr WRITE(Mt2,1050)str(1:nchr) 1050 FORMAT(/,' ERROR: ',a, & ' not an AO, LS, TC, TL, SO, QD, QI or ramp outlier.') CALL abend RETURN END IF END DO c ------------------------------------------------------------------ RETURN END addsef.f0000664006604000003110000001116214521201402011556 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 2:49 pm SUBROUTINE addsef(Begdat,Numrxy,Numcxy,Begcol,Endcol,Xy,Begrgm) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to add seasonal effect variables to an nrxy by ncxy xy c matrix in columns begcol to begcol+sp-2. seasonal effect submatrix c is nrxy by sp-1 and the ith seasonal effect has a 1 in month i, -1 in c the spth month, and zero otherwise. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c imo i Local current month c j i Local do loop index c zero i Local PARAMETER for 0.0d0 c----------------------------------------------------------------------- c Variable typing and initialization c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F DOUBLE PRECISION ZERO,MONE,ONE PARAMETER(ZERO=0.0D0,MONE=-1.0D0,ONE=1.0D0,F=.false.) c----------------------------------------------------------------------- CHARACTER str*(PCOLCR) LOGICAL Begrgm INTEGER Begdat,predat,i,j,imo,premo,Numrxy,Numcxy,Begcol,ipos, & Endcol,ncol,precol,sp2,tcol,icol,iper,nchr DOUBLE PRECISION Xy DIMENSION Begdat(2),Begrgm(PLEN),predat(2),Xy(Numcxy,Numrxy), & tcol(PSP) c----------------------------------------------------------------------- INTEGER strinx,ctoi EXTERNAL strinx,ctoi c----------------------------------------------------------------------- CHARACTER MONDIC*33 INTEGER monptr,PMON PARAMETER(PMON=11) DIMENSION monptr(0:PMON) PARAMETER(MONDIC='janfebmaraprmayjunjulaugsepoctnov') DATA monptr/1,4,7,10,13,16,19,22,25,28,31,34/ c----------------------------------------------------------------------- c Set the begining and ending columns and the seasonal period c----------------------------------------------------------------------- ncol=Endcol-Begcol+1 sp2=ncol+1 c----------------------------------------------------------------------- c Check that the begining and ending columns are between 1 c and ncxy. c----------------------------------------------------------------------- IF(Begcol.lt.1.or.Endcol.gt.Numcxy-1.or.Endcol.lt.Begcol)THEN WRITE(STDERR,1010)Begcol,Endcol,Numcxy-1 CALL errhdr WRITE(Mt2,1010)Begcol,Endcol,Numcxy-1 1010 FORMAT(/,' Column error, 1<=begcol<=endcol<= nb',/,26x,3I8) CALL abend() RETURN END IF c----------------------------------------------------------------------- IF(sp2.lt.Sp)THEN ipos=1 CALL setint(NOTSET,Sp-1,tcol) DO icol=Begcol,Endcol CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(Sp.eq.12)THEN iper=strinx(F,MONDIC,monptr,1,PMON,str(1:3)) ELSE iper=ctoi(str(1:nchr),ipos) END IF tcol(iper)=icol-Begcol+1 END DO END IF c----------------------------------------------------------------------- c Add the SM variables row by row. Imo is the current month. If c imo is the spth month though imo will be 0 then that row will be -1's. c otherwise a 1 will be placed in the imo'th column of the seasonal c effect submatrix or the begcol-1+imo column of the xy matrix. c----------------------------------------------------------------------- CALL addate(Begdat,Sp,-1,predat) premo=predat(2) precol=Begcol-1 c----------------------------------------------------------------------- DO i=1,Numrxy imo=mod(premo+i,Sp) c----------------------------------------------------------------------- DO j=Begcol,Endcol Xy(j,i)=ZERO END DO IF(Begrgm(i))THEN IF(imo.eq.0)THEN DO j=Begcol,Endcol Xy(j,i)=MONE END DO c ------------------------------------------------------------------ ELSE IF(Sp.eq.sp2)THEN Xy(precol+imo,i)=ONE ELSE IF(tcol(imo).ne.NOTSET)THEN Xy(precol+tcol(imo),i)=ONE END IF END IF END IF END DO c----------------------------------------------------------------------- RETURN END addsub.f0000664006604000003110000000125114521201402011570 0ustar sun00315steps**==addsub.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 SUBROUTINE ADD_SUB(A,B,C,N,M,Id,Ind) IMPLICIT NONE **--ADDSUB6 C C*** Start of declarations rewritten by SPAG C C Dummy arguments C INTEGER Id,Ind,M,N REAL*8 A(Id,*),B(Id,*),C(Id,*) C C Local variables C INTEGER i,j C C*** End of declarations rewritten by SPAG C c **** Start of Executable Program C INTEGER*4 N,M,ID,IND DO i=1,N DO j=1,M IF (Ind.GT.0) THEN C(i,j)=A(i,j)+B(i,j) ELSE C(i,j)=A(i,j)-B(i,j) END IF END DO END DO END addtd.f0000664006604000003110000001025314521201402011410 0ustar sun00315stepsC Last change: BCM 22 Sep 1998 10:59 am SUBROUTINE addtd(Aicstk,Aicrgm,Aictd0,Sp,Tdindx) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine adds trading day regressors for the c automatic AIC test. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.FALSE.) c----------------------------------------------------------------------- CHARACTER day*(3),tgrptl*(PGRPCR),datstr*(10) INTEGER Aicstk,Aicrgm,ipos,i,Sp,nchdat,nchr,Aictd0,Tdindx,ipos2, & vartd,vartd1,vartd2,nvar DIMENSION Aicrgm(2),day(6) c----------------------------------------------------------------------- DATA day/'Mon','Tue','Wed','Thu','Fri','Sat'/ c----------------------------------------------------------------------- IF(Tdindx.eq.0)RETURN c----------------------------------------------------------------------- IF(Aicrgm(1).ne.NOTSET)THEN CALL wrtdat(Aicrgm,Sp,datstr,nchdat) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Add stock trading day variables. c----------------------------------------------------------------------- IF(Tdindx.eq.3.or.Tdindx.eq.6)THEN tgrptl='Stock Trading Day[' ipos=19 CALL itoc(Aicstk,tgrptl,ipos) IF(Lfatal)RETURN tgrptl(ipos:ipos)=']' IF(Tdindx.eq.6)THEN vartd= PRG1ST vartd1=PRR1ST vartd2=PRA1ST nvar=1 ELSE vartd= PRGTST vartd1=PRRTST vartd2=PRATST nvar=6 END IF c----------------------------------------------------------------------- c Add 1 parameter trading day variables. c----------------------------------------------------------------------- ELSE tgrptl='Trading Day' ipos=11 IF(Tdindx.eq.4.or.Tdindx.eq.5)THEN vartd= PRG1TD vartd1=PRR1TD vartd2=PRA1TD nvar=1 ELSE vartd= PRGTTD vartd1=PRRTTD vartd2=PRATTD nvar=6 END IF END IF IF(Aictd0.eq.0)THEN ipos2=ipos IF(Aicrgm(1).ne.NOTSET)THEN ipos2=ipos+nchdat+9 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (after '//datstr(1:nchdat)// & ')' END IF DO i=1,nvar IF(nvar.eq.1)THEN CALL adrgef(DNOTST,'Weekday','1-Coefficient '//tgrptl(1:ipos2), & vartd,F,F) ELSE CALL adrgef(DNOTST,day(i),tgrptl(1:ipos2),vartd,F,F) END IF IF(Lfatal)RETURN END DO END IF IF(Aicrgm(1).ne.NOTSET)THEN IF(Aictd0.ge.0)THEN IF(Aictd0.eq.0)THEN ipos2=ipos+nchdat+22 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (change for before '// & datstr(1:nchdat)//')' ELSE ipos2=ipos+nchdat+10 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (before '// & datstr(1:nchdat)//')' END IF IF(nvar.eq.1)THEN CALL adrgef(DNOTST,'Weekday I', & '1-Coefficient '//tgrptl(1:ipos2),vartd1,F,F) IF(Lfatal)RETURN ELSE DO i=1,nvar CALL adrgef(DNOTST,day(i)//' I',tgrptl(1:ipos2),vartd1,F,F) IF(Lfatal)RETURN END DO END IF ELSE ipos2=ipos+nchdat+12 tgrptl(1:ipos2)=tgrptl(1:ipos)//' (starting '// & datstr(1:nchdat)//')' IF(nvar.eq.1)THEN CALL adrgef(DNOTST,'Weekday II', & '1-Coefficient '//tgrptl(1:ipos2),vartd2,F,F) IF(Lfatal)RETURN ELSE DO i=1,nvar CALL adrgef(DNOTST,day(i)//' II',tgrptl(1:ipos2),vartd2,F,F) IF(Lfatal)RETURN END DO END IF END IF END IF c----------------------------------------------------------------------- RETURN END addusr.f0000664006604000003110000001342714521201403011621 0ustar sun00315stepsC Last change: BCM 7 May 1998 2:14 pm SUBROUTINE addusr(Rind,Fxindx) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'urgbak.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.FALSE.) c----------------------------------------------------------------------- CHARACTER effttl*(PCOLCR),thisu*(PCOLCR) INTEGER begcol,disp,ncol,igrp,i,nchr,Rind,icol,nusr,ucol,Fxindx, & rtype c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- c If there are user defined regressors left in the model, delete c them before adding all the user-defined regressors back in c----------------------------------------------------------------------- IF(Ncusrx.gt.0)THEN igrp=Ngrp DO WHILE (igrp.ge.1) begcol=Grp(igrp-1) ncol=Grp(igrp)-begcol rtype=Rgvrtp(begcol) IF((rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or.rtype.eq.PRGTUS.or. & rtype.eq.PRGUTD.or.rtype.eq.PRGTUD.or.rtype.eq.PRGULM.or. & rtype.eq.PRGULQ.or.rtype.eq.PRGULY.or.rtype.eq.PRGUAO.or. & rtype.eq.PRGULS.or.rtype.eq.PRGUSO.or.rtype.eq.PRGUCN.or. & rtype.eq.PRGUCY)THEN DO icol=begcol,begcol+ncol-1 CALL getstr(Colttl,Colptr,Nb,icol,thisu,nusr) IF(Lfatal)RETURN ucol=strinx(F,Usrtt2(Rind),Usrpt2,1,Ncusx2(Rind), & thisu(1:nusr)) Buser(ucol)=B(icol) END DO CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN END IF igrp=igrp-1 END DO END IF c----------------------------------------------------------------------- c Restore values of the user defined regression variables c----------------------------------------------------------------------- disp=PUSERX*Rind+1 CALL copy(Userx2(disp),PUSERX,1,Userx) disp=(PUREG+1)*Rind+1 CALL cpyint(Usrpt2(disp),PUREG+1,1,Usrptr(0)) disp=PUREG*Rind+1 CALL cpyint(Usrty2(disp),PUREG,1,Usrtyp) Ncusrx=Ncusx2(Rind) Usrttl=Usrtt2(Rind) c----------------------------------------------------------------------- c Restore user-defined regressors to the regression matrix c----------------------------------------------------------------------- disp=PUREG*Rind DO i=1,Ncusrx c IF(.not.(Fxuser(disp+i).and.Fxindx.eq.2))THEN CALL getstr(Usrttl,Usrptr,Ncusrx,i,effttl,nchr) IF(Lfatal)RETURN IF(Usrtyp(i).eq.PRGTUS)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Seasonal',Usrtyp(i),Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGTUH)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Holiday',Usrtyp(i),Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUH2)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Holiday Group 2',Usrtyp(i), & Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUH3)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Holiday Group 3',Usrtyp(i), & Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUH4)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Holiday Group 4',Usrtyp(i), & Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUH5)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Holiday Group 5',Usrtyp(i), & Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUTD)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Trading Day',Usrtyp(i), & Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGULY)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Leap Year',Usrtyp(i), & Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGULM)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined LOM',Usrtyp(i),Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGULQ)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr),'User-defined LOQ', & Usrtyp(i),Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUAO)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr),'User-defined AO', & Usrtyp(i),Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGULS)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr),'User-defined LS', & Usrtyp(i),Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUSO)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr),'User-defined SO', & Usrtyp(i),Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUCN)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Constant',Usrtyp(i), & Fxuser(disp+i),F) ELSE IF(Usrtyp(i).eq.PRGUCY)THEN CALL adrgef(Buser(disp+i),effttl(1:nchr), & 'User-defined Cycle',Usrtyp(i), & Fxuser(disp+i),F) ELSE CALL adrgef(Buser(disp+i),effttl(1:nchr),'User-defined', & PRGTUD,Fxuser(disp+i),F) END IF c END IF END DO c----------------------------------------------------------------------- RETURN END adestr.f0000664006604000003110000002175614521201403011625 0ustar sun00315stepsC Last change: BCM 29 Jun 1998 1:02 pm SUBROUTINE adestr(Begdat,Nrxy,Ncxy,Isp,Icol,Ndays,Easidx,Xy, & Xmeans,Emean,Estock) IMPLICIT NONE c----------------------------------------------------------------------- c adestr.f, Release 1, Subroutine Version 1.1, Modified 20 Oct 1994. c----------------------------------------------------------------------- c BCM April, 2016 - generate easter(0) regressor c----------------------------------------------------------------------- c Subroutine takes input for a year and month where the year is in c the 20th century, and the subroutine returns Bell's holiday variables c for easter (see Bell 1983). c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c idate i Input of length 2 array for the current date (yr,mo) c kdate i Local array of the dates of easter, labor day and thanks c giving. c Dates range from March 23 - April 25 for Easter c kdate(i) = offset to be added to March 22 in order to get c the correct dates for year i where the year ranges from c 1901 to 2100. c cmlmo i cumulative sum of lengths of months c lpyr i Local to indicate leap year and is also the offset for the c fdomo and lnomo arrays. leapyear = 12 and otherwise 0. c Ndays i Local number of days prior to Easter in holiday effect c (not including Easter itself). Ndays = 0 specifies only c Easter day will be used in the regressor. c ZERO d Local PARAMETER for 0.0d0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO,MONE PARAMETER(ZERO=0.0D0,MONE=-1.0D0) c ------------------------------------------------------------------ LOGICAL Xmeans,Estock INTEGER Begdat,Ncxy,Nrxy,predat,cmlnmo,cmlnqt,idate,Icol,Isp, & julbeg,juleas,julend,kdate,lpyr,Ndays,ibeg,iend,period, & year,i,Easidx,itmp DOUBLE PRECISION tmp,Xy,Emean DIMENSION Begdat(2),predat(2),cmlnmo(13,2),cmlnqt(5,2),idate(2), & kdate(1901:2100),Xy(Ncxy,Nrxy),Emean(PSP) c----------------------------------------------------------------------- DOUBLE PRECISION sceast EXTERNAL sceast c----------------------------------------------------------------------- c The date of Easter = March 22 + kdate(year) c for year = 1901 to 2100, inclusive c----------------------------------------------------------------------- DATA kdate/ & 16, 8,21,12,32,24, 9,28,20, 5,25,16, 1,21,13,32,17, 9,29,13, & 5,25,10,29,21,13,26,17, 9,29,14, 5,25,10,30,21, 6,26,18, 2, & 22,14,34,18,10,30,15, 6,26,18, 3,22,14,27,19,10,30,15, 7,26, & 11,31,23, 7,27,19, 4,23,15, 7,20,11,31,23, 8,27,19, 4,24,15, & 28,20,12,31,16, 8,28,12, 4,24, 9,28,20,12,25,16, 8,21,13,32, & 24, 9,29,20, 5,25,17, 1,21,13,33,17, 9,29,14, 5,25,10,30,21, & 13,26,18, 9,29,14, 6,25,10,30,22, 6,26,18, 3,22,14,34,19,10, & 30,15, 7,26,18, 3,23,14,27,19,11,30,15, 7,27,11,31,23, 8,27, & 19, 4,24,15, 7,20,12,31,23, 8,28,19, 4,24,16,28,20,12,32,16, & 8,28,13, 4,24, 9,29,20,12,25,17, 8,21,13,33,24, 9,29,21, 6/ c----------------------------------------------------------------------- c Cumulative sums of lengths of months c----------------------------------------------------------------------- DATA cmlnmo/0,31,59,90,120,151,181,212,243,273,304,334,365,0,31, & 60,91,121,152,182,214,244,274,305,335,366/ DATA cmlnqt/0,90,181,273,365,0,91,182,274,366/ c----------------------------------------------------------------------- c Add the holiday effects row by row, row i and columns begcol to c endcol c----------------------------------------------------------------------- CALL addate(Begdat,Isp,-1,predat) c ------------------------------------------------------------------ DO i=1,Nrxy CALL addate(predat,Isp,i,idate) year=idate(YR) period=idate(MO) c ------------------------------------------------------------------ IF((mod(year,100).ne.0.and.mod(year,4).eq.0).or.mod(year,400) & .eq.0)THEN lpyr=2 c ------------------------------------------------------------------ ELSE lpyr=1 END IF c----------------------------------------------------------------------- c Quarterly Easter effect. c----------------------------------------------------------------------- IF(Isp.ne.12)THEN julbeg=cmlnqt(period,lpyr)+1 julend=cmlnqt(period+1,lpyr) c----------------------------------------------------------------------- c Calculating Julian date of holidays and proportion of days in c quarter which fall within the holiday window. Easter first. c Computing beginning and ending dates of current month c which overlap with holiday effect window c----------------------------------------------------------------------- juleas=cmlnqt(2,lpyr)-9+kdate(year) IF(Ndays.gt.0)THEN ibeg=max(julbeg,juleas-Ndays+Easidx) iend=min(julend,juleas-1+Easidx) ELSE ibeg=max(julbeg,juleas-Easidx) iend=min(julend,juleas-Easidx) END IF c----------------------------------------------------------------------- c Dividing days in current month which fall within window c by length of window to computed proportion of days c----------------------------------------------------------------------- IF(ibeg.le.iend)THEN itmp=iend-ibeg+1 IF(Easidx.eq.0)THEN tmp=dble(itmp) IF(Ndays.gt.0)tmp=tmp/dble(Ndays) ELSE tmp=sceast(Ndays,itmp,period.eq.1,julend.ge.juleas) END IF c ------------------------------------------------------------------ ELSE IF(Easidx.eq.1.and.period.eq.2)THEN tmp=MONE ELSE tmp=ZERO END IF END IF c----------------------------------------------------------------------- c Monthly Easter effect. Calculating Julian date of beginning and c ending of present month c----------------------------------------------------------------------- ELSE julbeg=cmlnmo(period,lpyr)+1 julend=cmlnmo(period+1,lpyr) c----------------------------------------------------------------------- c Calculating Julian date of holidays and proportion of days in c month which fall within the holiday window. Easter first. c Computing beginning and ending dates of current month c which overlap with holiday effect window c----------------------------------------------------------------------- juleas=cmlnmo(3,lpyr)+22+kdate(year) IF(Ndays.gt.0)THEN ibeg=max(julbeg,juleas-Ndays+Easidx) iend=min(julend,juleas-1+Easidx) ELSE ibeg=max(julbeg,juleas-Easidx) iend=min(julend,juleas-Easidx) END IF c----------------------------------------------------------------------- c Dividing days in current month which fall within window c by length of window to computed proportion of days c----------------------------------------------------------------------- IF(ibeg.le.iend)THEN itmp=iend-ibeg+1 IF(Easidx.eq.0)THEN tmp=dble(itmp) IF(Ndays.gt.0)tmp=tmp/dble(Ndays) ELSE tmp=sceast(Ndays,itmp,period.eq.3,julend.ge.juleas) END IF ELSE IF(Easidx.eq.1.and.period.eq.4)THEN tmp=MONE ELSE tmp=ZERO END IF END IF END IF c----------------------------------------------------------------------- c Subtracting off long term means of holiday effects in order c to make holiday effects orthogonal to the trend c----------------------------------------------------------------------- IF(Xmeans.and.Easidx.eq.0)tmp=tmp-Emean(period) c----------------------------------------------------------------------- c if stock end-of-month easter, change easter regressor based on c current period c----------------------------------------------------------------------- IF(Estock)THEN IF(Isp.eq.4)THEN IF(period.eq.2)tmp=ZERO ELSE IF(period.eq.3)THEN tmp=tmp+Xy(Icol,i-1) ELSE IF(period.eq.4)THEN tmp=ZERO END IF END IF END IF c----------------------------------------------------------------------- c Put the effect in the regression matrix. c----------------------------------------------------------------------- Xy(Icol,i)=tmp END DO c ------------------------------------------------------------------ RETURN END adj.cmn0000664006604000003110000000174414521201403011424 0ustar sun00315stepsc----------------------------------------------------------------------- c Adj : Prior adjustment factors c Adj1st : Position in the Adj vector that corresponds to the c beginning of the span c Adjmod : Mode of the prior adjustment factors in Adj c (0=differences converted to facter by exponentiation, c 1=factors,2=differences) c Nadj : Number user-defined prior adjustment factors c Begadj : Starting date for user-defined prior adjustment factors c Setpri : gives pointer for first observation in Sprior c----------------------------------------------------------------------- INTEGER Adj1st,Adjmod,Nadj,Begadj,Setpri DOUBLE PRECISION Adj,Cnstnt DIMENSION Adj(PLEN),Begadj(2) c----------------------------------------------------------------------- COMMON / adjcmn / Adj,Cnstnt,Adj1st,Nadj,Begadj,Setpri,Adjmod c-----------------------------------------------------------------------adjreg.f0000664006604000003110000001530514521201403011570 0ustar sun00315stepsC Last change: BCM 25 Nov 1998 12:41 pm SUBROUTINE adjreg(Orix,Orixmv,Orixot,Ftd,Fao,Fls,Ftc,Fso,Fsea, & Fcyc,Fusr,Fmv,Fhol,Fcntyp,Lam,Nrxy,N) IMPLICIT NONE c----------------------------------------------------------------------- c Computes adjustment factors for trading day, holiday, outlier, c AO outlier, and user defined regression effects. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11log.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'inpt.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO,ONE PARAMETER(ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INTEGER i,Nrxy,N,Fcntyp DOUBLE PRECISION Orix,Orixmv,Orixot,orixa,orixcl,Lam,Ftd,Fao,Fusr, & Fmv,Fhol,Fls,Ftc,Fso,Fsea,Fcyc,temp DIMENSION Orix(PLEN),Orixmv(PLEN),Orixot(PLEN),orixa(PLEN), & orixcl(PLEN),Ftd(PLEN),Fao(PLEN),Fusr(PLEN),Fmv(PLEN), & Fhol(PLEN),Fls(PLEN),Ftc(PLEN),Fso(PLEN),Fsea(PLEN), & Fcyc(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c Adjust original series (extended by forecasts and backcasts) c using regression effects. c----------------------------------------------------------------------- c call fopen('debug.x12','unknown',IDB,fok) c----------------------------------------------------------------------- c Initialize regression adjusted forecast and backcast extended c original series. c----------------------------------------------------------------------- CALL setdp(0D0,PLEN,orixa) CALL setdp(0D0,PLEN,Orixmv) CALL setdp(0D0,PLEN,Orixot) CALL setdp(0D0,PLEN,orixcl) c----------------------------------------------------------------------- DO i=1,Nrxy orixa(i+Pos1bk-1)=Orix(i+Pos1bk-1)-Ftd(i)-Fls(i)-Fhol(i)-Fao(i)- & Ftc(i)-Fusr(i)-Fmv(i)-Fsea(i)-Fso(i)-Fcyc(i) Orixmv(i+Pos1bk-1)=Orix(i+Pos1bk-1)-Fmv(i) Orixot(i+Pos1bk-1)=Orixmv(i+Pos1bk-1)-Fao(i)-Fls(i)-Ftc(i)-Fso(i) orixcl(i+Pos1bk-1)=Orixmv(i+Pos1bk-1)-Ftd(i)-Fhol(i) END DO * write(Mtprof,*) ' Orix(Pos1bk) = ',Orix(Pos1bk) c----------------------------------------------------------------------- c call fclose(IDB) c----------------------------------------------------------------------- c Transform series back to original scale c----------------------------------------------------------------------- CALL invfcn(orix(Pos1bk),Nrxy,Fcntyp,Lam,orix(Pos1bk)) CALL invfcn(orixa(Pos1bk),Nrxy,Fcntyp,Lam,orixa(Pos1bk)) CALL invfcn(Orixmv(Pos1bk),Nrxy,Fcntyp,Lam,Orixmv(Pos1bk)) CALL invfcn(Orixot(Pos1bk),Nrxy,Fcntyp,Lam,Orixot(Pos1bk)) CALL invfcn(orixcl(Pos1bk),Nrxy,Fcntyp,Lam,orixcl(Pos1bk)) c----------------------------------------------------------------------- IF(Posfob.eq.Posffc)THEN N=Nrxy+Sp ELSE N=Nrxy END IF IF(dpeq(Lam,0D0).or.dpeq(Lam,1D0))THEN CALL invfcn(Ftd,N,Fcntyp,Lam,Ftd) CALL invfcn(Fhol,N,Fcntyp,Lam,Fhol) CALL invfcn(Fls,N,Fcntyp,Lam,Fls) CALL invfcn(Ftc,N,Fcntyp,Lam,Ftc) CALL invfcn(Fao,N,Fcntyp,Lam,Fao) CALL invfcn(Fso,N,Fcntyp,Lam,Fso) CALL invfcn(Fsea,N,Fcntyp,Lam,Fsea) CALL invfcn(Fusr,N,Fcntyp,Lam,Fusr) CALL invfcn(Fcyc,N,Fcntyp,Lam,Fcyc) END IF c ------------------------------------------------------------------ c copy adjusted series, adjustment factors into variables c properly indexed for X-11 seasonal adjustment routines c----------------------------------------------------------------------- CALL copy(orixa(Pos1bk),Nrxy,1,Stcsi(Pos1bk)) * write(Mtprof,*) ' stcsi(Pos1bk) = ',stcsi(Pos1bk) IF(Nbcst.gt.0)THEN CALL copy(Orix(Pos1bk),Nbcst,1,Series(Pos1bk)) IF(Kfmt.gt.0) & CALL addmul(Series,Series,Sprior,Pos1bk,Pos1bk+Nbcst-1) END IF IF(Nfcst.gt.0)THEN CALL copy(Orix(Posfob+1),Nfcst,1,Series(Posfob+1)) IF(Kfmt.gt.0)CALL addmul(Series,Series,Sprior,Posfob+1,Posffc) END IF IF(dpeq(Lam,0D0).or.dpeq(Lam,1D0))THEN IF(.not.Axrgtd.and.Adjtd.eq.1)CALL copy(Ftd,N,1,Factd(Pos1bk)) IF(Adjhol.eq.1)CALL copy(Fhol,N,1,Fachol(Pos1bk)) IF(Adjao.eq.1)CALL copy(Fao,N,1,Facao(Pos1bk)) IF(Adjls.eq.1)CALL copy(Fls,N,1,Facls(Pos1bk)) IF(Adjtc.eq.1)CALL copy(Ftc,N,1,Factc(Pos1bk)) IF(Adjso.eq.1)CALL copy(Fso,N,1,Facso(Pos1bk)) IF(Adjsea.eq.1)CALL copy(Fsea,N,1,Facsea(Pos1bk)) IF(Adjusr.eq.1)CALL copy(Fusr,N,1,Facusr(Pos1bk)) IF(Adjcyc.eq.1)CALL copy(Fcyc,N,1,Faccyc(Pos1bk)) END IF c----------------------------------------------------------------------- c Set 'extra' backcasts in series, factors to zero c----------------------------------------------------------------------- IF(Nbcst2.gt.Nbcst)THEN temp=ZERO IF(Fcntyp.eq.1)temp=ONE DO i=1,Pos1bk-1 IF((.not.Axrgtd).and.Adjtd.eq.1)Factd(i)=temp IF((.not.Axrghl).and.Adjhol.eq.1)Fachol(i)=temp IF(Adjao.eq.1)Facao(i)=temp IF(Adjls.eq.1)Facls(i)=temp IF(Adjtc.eq.1)Factc(i)=temp IF(Adjso.eq.1)Facso(i)=temp IF(Adjsea.eq.1)Facsea(i)=temp IF(Adjusr.eq.1)Facusr(i)=temp IF(Adjcyc.eq.1)Faccyc(i)=temp END DO END IF c----------------------------------------------------------------------- c put outlier adjusted and missing value adjusted series back on c original scale BCM May 2004 c----------------------------------------------------------------------- IF(Kfmt.gt.0)THEN CALL addmul(Orixmv,Orixmv,Sprior,Pos1bk,Posffc) CALL addmul(Orixot,Orixot,Sprior,Pos1bk,Posffc) CALL addmul(orixcl,Orixcl,Sprior,Pos1bk,Posffc) END IF c----------------------------------------------------------------------- c copy calendar adjusted series with forecasts into Stocal c BCM May 2006 c----------------------------------------------------------------------- CALL copy(orixcl(Pos1bk),Nrxy,1,Stocal(Pos1bk)) c----------------------------------------------------------------------- RETURN END adjsrs.f0000664006604000003110000001105614521201403011621 0ustar sun00315stepsC Last change: BCM 19 Oct 1998 11:51 am SUBROUTINE adjsrs(Nspobs,Sp,Begspn,Fctdrp,Nfcst,Nbcst,Ok) IMPLICIT NONE c----------------------------------------------------------------------- c adjsrs.f, Release 1, Subroutine Version 1.4, Modified 02 Nov 1994. c----------------------------------------------------------------------- c Get the time series of prior adjustment factors, y, including the c number of observations, nadj and start date, start. c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- LOGICAL T,F INTEGER PLOM,PLOQ PARAMETER(PLOM=2,PLOQ=3,T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'adj.cmn' INCLUDE 'picktd.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER sname*3 DOUBLE PRECISION base LOGICAL Ok,lom,begrgm INTEGER Begspn,Fctdrp,i,Nbcst,Nfcst,Nspobs,Sp DIMENSION Begspn(2),begrgm(PLEN) c ------------------------------------------------------------------ LOGICAL chkcvr EXTERNAL chkcvr c ------------------------------------------------------------------ IF(Adjmod.eq.2)THEN base=0D0 ELSE base=1D0 END IF CALL addate(Begspn,Sp,-Nbcst,Begadj) Nadj=Nspobs+Nbcst+max(Sp,Nfcst-Fctdrp) c----------------------------------------------------------------------- c Generate length of period factors. Note lom and loq are the c same the factor is determined by the seasonal period. c----------------------------------------------------------------------- IF(Priadj.gt.1)THEN IF(Priadj.eq.PLOM.or.Priadj.eq.PLOQ)THEN lom=T ELSE lom=F END IF c----------------------------------------------------------------------- c The 7th trading day factors c----------------------------------------------------------------------- IF(Lrgmtd.and.Picktd.and.(MOD(Tdzero,2).ne.0).and. & (.not.Fulltd))THEN CALL gtrgpt(Begadj,Tddate,Tdzero,begrgm,Nadj) ELSE CALL setlg(T,PLEN,begrgm) END IF CALL td7var(Begadj,Sp,Nadj,1,1,lom,F,T,Adj,begrgm) c----------------------------------------------------------------------- Kfmt=1 IF(lom)THEN sname='LOM' IF(Sp.eq.4)sname='LOQ' ELSE sname='LPY' END IF IF(Nuspad.eq.0.or.Npser.eq.0)THEN Prmser(1:3)=sname Npser=3 ELSE IF(Npser.lt.61)THEN Prmser(1:Npser+4)=Prmser(1:Npser)//'+'//sname Npser=Npser+4 END IF c----------------------------------------------------------------------- c Default is no adjustment c----------------------------------------------------------------------- ELSE CALL setdp(base,Nadj,Adj) END IF c----------------------------------------------------------------------- c May want to change so this will only need to cover the span and c not the series and the forecasts then the other user defined c adjustments will default to 1d0. Note, if there are adjustments c for part of the forecasts but not all and they are not 1 already c this should be an error because the proper unadjusted forecasts c will not be printed. c----------------------------------------------------------------------- IF(Nprtyp.gt.0)THEN DO i=1,Nprtyp IF(Prtype(i).eq.1)THEN CALL addadj(Nspobs,Begspn,Sp,Begadj,Bgutad,Nustad,Frstat, & Usrtad,Adj,Nadj,base,'temporary',Percnt(i),Ok) ELSE IF(Prtype(i).eq.2)THEN CALL addadj(Nspobs,Begspn,Sp,Begadj,Bgupad,Nuspad,Frstap, & Usrpad,Adj,Nadj,base,'permanent',Percnt(i),Ok) END IF IF(Lfatal)RETURN IF(Ok)THEN IF(Kfmt.eq.0)Kfmt=1 ELSE IF(Kfmt.gt.0)Kfmt=0 END IF END DO END IF c----------------------------------------------------------------------- CALL dfdate(Begspn,Begadj,Sp,Adj1st) Adj1st=Adj1st+1 IF(Frstap.eq.0.and.Priadj.gt.1)Frstap=1 c ----------------------------------------------------------------- RETURN c ----------------------------------------------------------------- END adlabr.f0000664006604000003110000001477014521201403011566 0ustar sun00315stepsC Last change: BCM 25 Nov 97 10:19 am SUBROUTINE adlabr(Begdat,Nrxy,Ncxy,Icol,Ndays,Xy,Xmeans) c----------------------------------------------------------------------- c adlabr.f, Release 1, Subroutine Version 1.2, Modified 18 Oct 1994. c----------------------------------------------------------------------- c Subroutine takes input for a year and month where the year is in c the 20th century, and the subroutine returns Bell's holiday variables c labor day (see Bell 1983). c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c idate i Input of length 2 array for the current date (yr,mo) c kdate i Local array of the dates of easter, labor day and thanks c giving. c Dates range from March 23 - April 25 for Easter c from September 1 - September 7 for Labor Day c from November 22 - November 28 c kdate(i,j) = offset to be added to March 22, Aug 31, and c Nov 21 in order to get the correct dates for year i c where the year ranges from 1901 to 2100. c cmlnmo i cumulative sum of lengths of months c lpyr i Local to indicate leap year and is also the offset for the c fdomo and lnomo arrays. leapyear = 12 and otherwise 0. c means d Local vector of long term means of holiday effects c Ndays i Local number of days prior to Labor Day in holiday effect c (not including Labor Day itself) c ZERO d Local PARAMETER for 0.0d0 c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO PARAMETER(ZERO=0.0D0) c ------------------------------------------------------------------ LOGICAL Xmeans INTEGER Begdat,Ncxy,Nrxy,predat,cmlnmo,Icol,idate,i,julbeg,julend, & jullab,kdate,lpyr,ibeg,iend,mnindx,period,Ndays,year DOUBLE PRECISION means,tmp,Xy DIMENSION Begdat(2),predat(2),cmlnmo(13,2),idate(2), & kdate(1901:2100),means(25,8:9),Xy(Ncxy,Nrxy) c----------------------------------------------------------------------- c The date of Labor Day = August 31 + kdate(year) c for year = 1901 to 2100, inclusive c----------------------------------------------------------------------- DATA kdate/2,1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5, & 3,2,1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2, & 1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7, & 5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4, & 3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2, & 7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2,7,6, & 5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5/ c----------------------------------------------------------------------- c Cumulative sums of lengths of months c----------------------------------------------------------------------- DATA cmlnmo/0,31,59,90,120,151,181,212,243,273,304,334,365,0,31, & 60,91,121,152,182,214,244,274,305,335,366/ c----------------------------------------------------------------------- c Long term means of holiday effects: c means(tau,8) - August Labor Day effect c means(tau,9) - September Labor Day effect c----------------------------------------------------------------------- DATA(means(i,8),i=1,25)/ & .8800D0,.8750D0,.8696D0,.8636D0,.8571D0,.8500D0,.8421D0,.8333D0, & .8235D0,.8125D0,.8000D0,.7857D0,.7692D0,.7500D0,.7273D0,.7000D0, & .6667D0,.6250D0,.5714D0,.5000D0,.4286D0,.3571D0,.2857D0,.2143D0, & .1429D0/ DATA(means(i,9),i=1,25)/ & .1200D0,.1250D0,.1304D0,.1364D0,.1429D0,.1500D0,.1579D0,.1667D0, & .1765D0,.1875D0,.2000D0,.2143D0,.2308D0,.2500D0,.2727D0,.3000D0, & .3333D0,.3750D0,.4286D0,.5000D0,.5714D0,.6429D0,.7143D0,.7857D0, & .8571D0/ c----------------------------------------------------------------------- c Add the holiday effects row by row, row i and columns begcol to c endcol c----------------------------------------------------------------------- mnindx=25-Ndays+1 CALL addate(Begdat,12,-1,predat) c ------------------------------------------------------------------ DO i=1,Nrxy CALL addate(predat,12,i,idate) year=idate(YR) period=idate(MO) c ------------------------------------------------------------------ IF((mod(year,100).ne.0.and.mod(year,4).eq.0).or.mod(year,400) & .eq.0)THEN lpyr=2 c ------------------------------------------------------------------ ELSE lpyr=1 END IF c----------------------------------------------------------------------- c Calculating Julian date of beginning and ending of present month c----------------------------------------------------------------------- julbeg=cmlnmo(period,lpyr)+1 julend=cmlnmo(period+1,lpyr) c----------------------------------------------------------------------- c Calculating Julian date of holiday and proportion of days in c month which fall within the holiday window. Computing beginning and c ending dates of current month which overlap with holiday effect c window. c----------------------------------------------------------------------- jullab=cmlnmo(9,lpyr)+kdate(year) ibeg=max(julbeg,jullab-Ndays) iend=min(julend,jullab-1) c----------------------------------------------------------------------- c Dividing days in current month which fall within window c by length of window to computed proportion of days. Then subtract c off long term means of holiday effects in order to make holiday c effects orthogonal to the trend. c----------------------------------------------------------------------- IF(ibeg.le.iend)THEN tmp=dble(iend-ibeg+1)/dble(Ndays) ELSE tmp=ZERO END IF c ------------------------------------------------------------------ IF(Xmeans.and.(period.eq.8.or.period.eq.9)) & tmp=tmp-means(mnindx,period) c ------------------------------------------------------------------ Xy(Icol,i)=tmp END DO c ------------------------------------------------------------------ RETURN END adotss.f0000664006604000003110000001033114521201403011623 0ustar sun00315stepsC Last change: BCM 7 Oct 2003 3:53 pm SUBROUTINE adotss(Botr,Otrptr,Notrtl,Fixotr,Otrttl,Lastsy,Otlfix) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER Otrttl*(PCOLCR*PB),str*(PCOLCR) LOGICAL Fixotr,locok,Otlfix,fx,lastLS DOUBLE PRECISION Botr INTEGER Otrptr,Notrtl,icol,nch,endcol,otltyp,begotl,endotl,rtype, & Lastsy,otypvc,otlind,nlast,ltype,ilast,lcol,opref DIMENSION Otrptr(0:PB),Botr(PB),Fixotr(PB),otypvc(9),opref(7) c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- DATA otypvc/PRGTAO,PRGTLS,PRGTTC,PRGTRP,PRGTAO,PRGTTL,PRGTSO, & PRGTQI,PRGTQD/ DATA opref/1,4,2,0,0,0,3/ c----------------------------------------------------------------------- endcol=Notrtl icol=1 nlast=0 lastLS=F DO WHILE(icol.le.endcol) CALL getstr(Otrttl,Otrptr,Notrtl,icol,str,nch) IF(Lfatal)RETURN otlind=strinx(T,Grpttl,Grpptr,1,Ngrptl,str(1:nch)) IF(otlind.eq.0)THEN CALL rdotlr(str(1:nch),Begsrs,Sp,otltyp,begotl,endotl,locok) c----------------------------------------------------------------------- c Check to see if outlier is defined. If so, then add outlier c to regression. c----------------------------------------------------------------------- IF(((otltyp.eq.RP.or.otltyp.eq.TLS.or.otltyp.eq.QI.or. & otltyp.eq.QD).and.(begotl.ge.Frstsy.and. & endotl.le.Lastsy)).or. & ((otltyp.eq.SO.or.otltyp.eq.LS).and. & (begotl.gt.Frstsy.and.begotl.le.Lastsy)).or. & ((otltyp.eq.AO.or.otltyp.eq.TC).and. & (begotl.ge.Frstsy.and.begotl.le.Lastsy))) & THEN fx=Fixotr(icol).or.Otlfix CALL adrgef(Botr(icol),str(1:nch),str(1:nch),otypvc(otltyp), & fx,F) IF(Iregfx.eq.3.and.(.not.fx))Iregfx=2 IF((otltyp.ne.RP.and.otltyp.ne.TLS.or.otltyp.ne.QI.or. & otltyp.ne.QD).and.(begotl.eq.Lastsy))THEN nlast=nlast+1 IF(.not.lastLS)lastLS=otltyp.eq.LS END IF END IF IF(Lfatal)RETURN END IF icol=icol+1 END DO c----------------------------------------------------------------------- c if more than one outlier appears on the final observation, delete c outliers that will cause singularities in the regression matrix. c----------------------------------------------------------------------- IF(nlast.gt.1)THEN icol=Nb ltype=0 ilast=0 lcol=0 DO WHILE(icol.ge.1) rtype=Rgvrtp(icol) IF(rtype.eq.PRGTAO.or.rtype.eq.PRGTAA.or.rtype.eq.PRGTLS.or. * & rtype.eq.PRGTAL.or.rtype.eq.PRGTTC.or.rtype.eq.PRGTAT.or. * & rtype.eq.PRGTSO.or.rtype.eq.PRGTAS)THEN & rtype.eq.PRGTAL.or.rtype.eq.PRGTTC.or.rtype.eq.PRGTAT.or. & rtype.eq.PRGTSO)THEN CALL getstr(Colttl,Colptr,Nb,icol,str,nch) IF(Lfatal)RETURN CALL rdotlr(str(1:nch),Begsrs,Sp,otltyp,begotl,endotl,locok) IF((otltyp.ne.RP.and.otltyp.ne.TLS.or.otltyp.ne.QI.or. & otltyp.ne.QD).and.begotl.eq.Lastsy)THEN ilast=ilast+1 IF(ilast.eq.1)THEN ltype=otltyp lcol=icol ELSE IF(opref(ltype).lt.opref(otltyp))THEN CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN ELSE CALL dlrgef(lcol,Nrxy,1) IF(Lfatal)RETURN ltype=otltyp lcol=icol END IF END IF END IF END IF icol=icol-1 END DO END IF c----------------------------------------------------------------------- RETURN END adpdrg.f0000664006604000003110000013123414521201403011575 0ustar sun00315stepsc Last Change: allow AOSdate-0.0 or LSSdate-0.0 format.change error C message for AOS and LSS, pass Endmdl variable to rdotlr.f, Mar-21 C Last change: BCM 23 Jul 1998 12:19 pm SUBROUTINE adpdrg(Begsrs,Endmdl,Nobs,Havsrs,Havesp,Rgname,Nrgchr, & X11reg,Havtd,Havhol,Havln,Havlp,Locok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c BCM April, 2016 - generate easter(0) regressor c----------------------------------------------------------------------- c adpdrg.f, Release 1, Subroutine Version 1.11, Modified 16 Feb 1995. c----------------------------------------------------------------------- c Get the predefined regression variables c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'picktd.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER day*3,effttl*(PCOLCR),cmonth*3,ordend*2,Rgname*(LINLEN), & tgrptl*(PGRPCR) LOGICAL argok,Havsrs,Havesp,Inptok,Locok,X11reg,Havhol,Havtd, & Havln,Havlp INTEGER Begsrs,Endmdl,begdat,enddat,i,ipos,isncos,nchr,neastr, & nelt,nlabor,Nobs,Nrgchr,nsncos,nthank,spm1,tdspdy,tmpdat, & vartyp,ivec,zeroz,igrp,ewlim DIMENSION Begsrs(2),Endmdl(2),day(7),isncos(PSP/2),cmonth(12), & ordend(0:9),tmpdat(2),ivec(1),ewlim(0:1) c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- c The argument dictionary was created with the following command: c ../../dictionary/strary < ../../dictionary/variables.dic c----------------------------------------------------------------------- CHARACTER REGDIC*123 INTEGER regidx,regptr,PREG PARAMETER(PREG=18) DIMENSION regptr(0:PREG) PARAMETER(REGDIC='constseasonalsincostdtdnolpyearlomloqlpyeartdsto &cklomstockeastersceasterlaborthanktd1coeftd1nolpyeartdstock1coefea &sterstock') c----------------------------------------------------------------------- c The ao,ls, ramp type dictionary was created c with the following command: c ../../dictionary/strary typ < ../../dictionary/outlier.type.dic c----------------------------------------------------------------------- CHARACTER TYPDIC*24 INTEGER typidx,typptr,POTYPE PARAMETER(POTYPE=11) DIMENSION typptr(0:POTYPE) PARAMETER(TYPDIC='aolsrpmvtcsotlqiqdaoslss') c ------------------------------------------------------------------ DATA regptr/1,6,14,20,22,32,35,38,44,51,59,65,73,78,83,90,101,113, & 124/ DATA typptr/1,3,5,7,9,11,13,15,17,19,22,25/ DATA (ewlim(i),i=0,1)/25,24/ c ------------------------------------------------------------------ DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA day/'Mon','Tue','Wed','Thu','Fri','Sat','Sun'/ DATA ordend/'th','st','nd','rd','th','th','th','th','th','th'/ c ------------------------------------------------------------------ Locok=T CALL setchr(' ',PCOLCR,effttl) zeroz=0 c----------------------------------------------------------------------- c Change by BCM Feb 1996: c read arguments for X11-irregular regression as well as regARIMA c----------------------------------------------------------------------- regidx=strinx(F,REGDIC,regptr,1,PREG,Rgname(1:Nrgchr)) IF(X11reg.and.(regidx.le.3.or.(regidx.gt.4.and.regidx.lt.9).or. & regidx.eq.10.or.regidx.eq.16))regidx=0 GO TO(10,20,30,40,40,40,40,40,50,40,60,60,70,80,40,40,50,60)regidx c----------------------------------------------------------------------- c AO, LS, Ramp, or error c----------------------------------------------------------------------- typidx=strinx(F,TYPDIC,typptr,1,POTYPE,Rgname(1:3)) if(typidx.eq.0)typidx=strinx(F,TYPDIC,typptr,1,POTYPE,Rgname(1:2)) c----------------------------------------------------------------------- c Change by BCM Feb 1996: c only AOs allowed in X11-irregular regression c----------------------------------------------------------------------- IF(X11reg.and.typidx.gt.1)typidx=0 c----------------------------------------------------------------------- GO TO(90,100,110,90,120,130,140,160,170,180,190),typidx c----------------------------------------------------------------------- c Not an ao, ls, or rp c----------------------------------------------------------------------- c Change by BCM Feb 1996: c Add error message for X-11 regression c----------------------------------------------------------------------- IF(X11reg)THEN CALL inpter(PERROR,Lstpos, & 'Irregular Component Regression variable name "'// & Rgname(1:Nrgchr)//'" not found') ELSE CALL inpter(PERROR,Lstpos,'Regression variable name "'// & Rgname(1:Nrgchr)//'" not found') END IF GO TO 200 c----------------------------------------------------------------------- c AO outlier c----------------------------------------------------------------------- 90 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for AO outliers') GO TO 200 ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN c ------------------------------------------------------------------ CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(begdat.gt.Nobs.or.begdat.lt.1)THEN CALL inpter(PERROR,Lstpos,'Not within series') GO TO 200 END IF END IF c ------------------------------------------------------------------ IF(typidx.eq.1)THEN Rgname(1:2)='AO' vartyp=PRGTAO ELSE Rgname(1:2)='MV' vartyp=PRGTMV END IF GO TO 210 c----------------------------------------------------------------------- c Level-shift variable c----------------------------------------------------------------------- 100 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for level-shift') GO TO 200 ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(begdat.gt.Nobs-1.or.begdat.lt.2)THEN CALL inpter(PERROR,Lstpos,'Not within series') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:2)='LS' vartyp=PRGTLS GO TO 210 c----------------------------------------------------------------------- c Ramp variable c----------------------------------------------------------------------- 110 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for ramp variable') GO TO 200 c ------------------------------------------------------------------ ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(enddat.gt.Nobs)THEN CALL inpter(PERROR,Lstpos,'End of ramp not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(begdat.lt.1)THEN CALL inpter(PERROR,Lstpos,'Beginning of ramp not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(enddat.le.begdat)THEN CALL inpter(PERROR,Lstpos,'Beginning and end of ramp reversed') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:2)='Rp' vartyp=PRGTRP GO TO 210 c----------------------------------------------------------------------- c TC outlier c----------------------------------------------------------------------- 120 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for TC outliers') GO TO 200 ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN c ------------------------------------------------------------------ CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(begdat.gt.Nobs.or.begdat.lt.1)THEN CALL inpter(PERROR,Lstpos,'Not within series') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:2)='TC' vartyp=PRGTTC GO TO 210 c----------------------------------------------------------------------- c SO outlier c----------------------------------------------------------------------- 130 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for seasonal outliers') GO TO 200 ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN c ------------------------------------------------------------------ CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(begdat.gt.Nobs.or.begdat.lt.1)THEN CALL inpter(PERROR,Lstpos,'Not within series') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:2)='SO' vartyp=PRGTSO GO TO 210 c----------------------------------------------------------------------- c TLS variable c----------------------------------------------------------------------- 140 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for temporary LS variable') GO TO 200 c ------------------------------------------------------------------ ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(enddat.gt.Nobs)THEN CALL inpter(PERROR,Lstpos, & 'End of temporary LS not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(begdat.lt.1)THEN CALL inpter(PERROR,Lstpos, & 'Beginning of temporary LS not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(enddat.le.begdat)THEN CALL inpter(PERROR,Lstpos, & 'Beginning and end of temporary LS reversed') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:2)='TL' vartyp=PRGTTL GO TO 210 c----------------------------------------------------------------------- c Quadratic Ramp variable, increasing rate c----------------------------------------------------------------------- 160 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for quadratic ramp (QI) variable') GO TO 200 c ------------------------------------------------------------------ ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(enddat.gt.Nobs)THEN CALL inpter(PERROR,Lstpos, & 'End of quadratic ramp (QI) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(begdat.lt.1)THEN CALL inpter(PERROR,Lstpos, & 'Beginning of quadratic ramp (QI) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(enddat.le.begdat)THEN CALL inpter(PERROR,Lstpos, & 'Beginning and end of quadratic ramp (QI) reversed') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:2)='QI' vartyp=PRGTQI GO TO 210 c----------------------------------------------------------------------- c Quadratic Ramp variable, decreasing rate c----------------------------------------------------------------------- 170 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for quadratic ramp (QD) variable') GO TO 200 c ------------------------------------------------------------------ ELSE CALL rdotlr(Rgname(1:Nrgchr),Begsrs,Sp,typidx,begdat,enddat, & argok) IF(.not.argok)THEN CALL inpter(PERROR,Lstpos, & 'See the above AO, LS, RP, SO, TL, TC, QI, or QD error.') GO TO 200 ELSE IF(enddat.gt.Nobs)THEN CALL inpter(PERROR,Lstpos, & 'End of quadratic ramp (QD) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(begdat.lt.1)THEN CALL inpter(PERROR,Lstpos, & 'Beginning of quadratic ramp (QD) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(enddat.le.begdat)THEN CALL inpter(PERROR,Lstpos, & 'Beginning and end of quadratic ramp (QD) reversed') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:2)='QD' vartyp=PRGTQD GO TO 210 c----------------------------------------------------------------------- c AO sequence variable c----------------------------------------------------------------------- 180 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for AO sequence (AOS) variable') GO TO 200 c ------------------------------------------------------------------ ELSE CALL rdotls(Rgname(1:Nrgchr),Begsrs,Endmdl,Sp,typidx,begdat, & enddat,argok) IF(.not.argok)THEN CALL inpter(PERROR,Lstpos,'See the above AOS or LSS error.') GO TO 200 ELSE IF(enddat.gt.Nobs)THEN CALL inpter(PERROR,Lstpos, & 'End of AO sequence (AOS) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(begdat.lt.1)THEN CALL inpter(PERROR,Lstpos, & 'Beginning of AO sequence (AOS) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(enddat.le.begdat)THEN CALL inpter(PERROR,Lstpos, & 'Beginning and end of AO sequence (AOS) reversed') GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:3)='AOS' vartyp=PRSQAO GO TO 220 c----------------------------------------------------------------------- c LS sequence variable c----------------------------------------------------------------------- 190 IF(.not.Havsrs)THEN CALL inpter(PERROR,Lstpos, & 'No time series specified for LS sequence (LSS) variable') GO TO 200 c ------------------------------------------------------------------ ELSE CALL rdotls(Rgname(1:Nrgchr),Begsrs,Endmdl,Sp,typidx,begdat, & enddat,argok) IF(.not.argok)THEN CALL inpter(PERROR,Lstpos,'See the above AOS or LSS error.') GO TO 200 ELSE IF(enddat.gt.Nobs)THEN CALL inpter(PERROR,Lstpos, & 'End of LS sequence (LSS) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(begdat.lt.1)THEN CALL inpter(PERROR,Lstpos, & 'Beginning of LS sequence (LSS) not within series') GO TO 200 c ------------------------------------------------------------------ ELSE IF(enddat.le.begdat)THEN CALL inpter(PERROR,Lstpos, & 'Beginning of LS sequence (LSS) occurs on or '// & 'after end of LS sequence (LSS)',T) GO TO 200 END IF END IF c ------------------------------------------------------------------ Rgname(1:3)='LSS' vartyp=PRSQLS GO TO 220 c ------------------------------------------------------------------ 200 Locok=F CALL lex() GO TO 230 c ------------------------------------------------------------------ 210 CALL adrgef(DNOTST,Rgname(1:Nrgchr),Rgname(1:Nrgchr),vartyp,F,T) IF(Lfatal)RETURN CALL lex() GO TO 230 c ------------------------------------------------------------------ 220 DO i=begdat,enddat CALL addate(Begsrs,Sp,i-1,tmpdat) CALL wrtdat(tmpdat,Sp,Rgname(3:),Nrgchr) IF(Lfatal)RETURN Nrgchr=Nrgchr+2 CALL adrgef(DNOTST,Rgname(1:Nrgchr),Rgname(1:Nrgchr),vartyp,F,T) IF(Lfatal)RETURN END DO CALL lex() GO TO 230 c----------------------------------------------------------------------- c Overall constant on the AR side c----------------------------------------------------------------------- 10 CALL adrgef(DNOTST,'Constant','Constant',PRGTCN,F,T) IF(Lfatal)RETURN CALL lex() GO TO 230 c----------------------------------------------------------------------- c Seasonal effects c----------------------------------------------------------------------- 20 CALL lex() IF(.not.Havesp)THEN CALL inpter(PERROR,Lstpos, & 'No seasonal period specified to determine seasonal effects.') Locok=F c ------------------------------------------------------------------ ELSE IF(Sp.eq.1)THEN CALL inpter(PERROR,Lstpos, & 'Seasonal effects with nonseasonal data.') Locok=F ELSE IF(Nxtktp.ne.SLASH.AND.(Lseff.or.Lseadf.or.Lidsdf))THEN IF(Lidsdf)THEN CALL inpter(PERROR,Lstpos, & 'Already have a seasonal difference in the identify spec.') ELSE CALL inpter(PERROR,Lstpos, & 'Already have seasonal effects or seasonal difference.') END IF Locok=F ELSE IF(Lrgmse.and.Nxtktp.eq.SLASH)THEN CALL inpter(PERROR,Lstpos, & 'Already have change of regime seasonal effects.') Locok=F c ------------------------------------------------------------------ ELSE IF(.not.Lseff)THEN spm1=Sp-1 c ------------------------------------------------------------------ IF(Sp.eq.12)THEN DO i=1,spm1 effttl=cmonth(i) nchr=3 CALL adrgef(DNOTST,effttl(1:nchr),'Seasonal',PRGTSE,F,T) IF(Lfatal)RETURN END DO c ------------------------------------------------------------------ ELSE DO i=1,spm1 ipos=1 CALL itoc(i,effttl,ipos) IF(Lfatal)RETURN IF(mod(i,100).ge.11.and.mod(i,100).le.13)THEN effttl(ipos:ipos+1)='th' ELSE effttl(ipos:ipos+1)=ordend(mod(i,10)) END IF nchr=ipos+1 CALL adrgef(DNOTST,effttl(1:nchr),'Seasonal',PRGTSE,F,T) IF(Lfatal)RETURN END DO END IF END IF IF(Nxtktp.eq.SLASH)THEN CALL adrgim(Begsrs,Nobs,Havesp,'Seasonal',PRRTSE,PRATSE,zeroz, & .not.Lseff,Lrgmse,Lseff,Locok) IF(zeroz.eq.0.AND.(Lseff.or.Lseadf.or.Lidsdf))THEN IF(Lidsdf)THEN CALL inpter(PERROR,Lstpos, & 'Already have a seasonal difference in the identify spec.') ELSE CALL inpter(PERROR,Lstpos, & 'Already have seasonal effects or seasonal difference.') END IF Locok=F END IF END IF END IF IF(Locok.and.zeroz.eq.0)Lseff=T IF(Lfatal)RETURN GO TO 230 c----------------------------------------------------------------------- c Seasonal sine-cosine c----------------------------------------------------------------------- 30 CALL lex() CALL getivc(LBRAKT,T,Sp/2,isncos,nsncos,Locok,Inptok) IF(Lfatal)RETURN IF(nsncos.le.0)THEN CALL inpter(PERROR,Lstpos, & 'Must specify the sine-cosine term explicitly.') Locok=F c ------------------------------------------------------------------ ELSE IF(.not.Havesp)THEN CALL inpter(PERROR,Lstpos, & 'No seasonal period specified to determine seasonal effects.') Locok=F c ------------------------------------------------------------------ ELSE IF(Sp.eq.1)THEN CALL inpter(PERROR,Lstpos, & 'Seasonal effects with nonseasonal data.') c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.SLASH.AND.(Lseff.or.Lseadf.or.Lidsdf))THEN IF(Lidsdf)THEN CALL inpter(PERROR,Lstpos, & 'Already have a seasonal difference in the identify spec') ELSE CALL inpter(PERROR,Lstpos, & 'Already have seasonal effects or seasonal difference') END IF Locok=F c ------------------------------------------------------------------ ELSE IF(Nxtktp.eq.SLASH.and.Lrgmse)THEN CALL inpter(PERROR,Lstpos, & 'Already have change of regime seasonal effects.') Locok=F ELSE IF(.not.Lseff)THEN IF(isncos(nsncos).eq.Sp/2)THEN nsncos=2*nsncos-1 c ------------------------------------------------------------------ ELSE nsncos=2*nsncos END IF c ------------------------------------------------------------------ DO i=2,nsncos+1,2 effttl='cos(2pi*' ipos=9 CALL itoc(isncos(i/2),effttl,ipos) IF(Lfatal)RETURN effttl(ipos:ipos+1)='t/' ipos=ipos+2 CALL itoc(Sp,effttl,ipos) IF(Lfatal)RETURN effttl(ipos:ipos)=')' CALL adrgef(DNOTST,effttl(1:ipos),'Trigonometric Seasonal', & PRGTTS,F,T) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(isncos(i/2).lt.Sp/2)THEN effttl='sin(2pi*' ipos=9 CALL itoc(isncos(i/2),effttl,ipos) IF(Lfatal)RETURN effttl(ipos:ipos+1)='t/' ipos=ipos+2 CALL itoc(Sp,effttl,ipos) IF(Lfatal)RETURN effttl(ipos:ipos)=')' CALL adrgef(DNOTST,effttl(1:ipos),'Trigonometric Seasonal', & PRGTTS,F,T) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(isncos(i/2).gt.Sp/2.or.isncos(i/2).lt.1)THEN WRITE(STDERR,1010)isncos(i/2) WRITE(Mt2,1010)isncos(i/2) 1010 FORMAT(/,' ERROR: Cannot have a sin-cos variable pair with,', & ' i=',i4,'.',/) Locok=F GO TO 230 END IF END DO END IF IF(Nxtktp.eq.SLASH)THEN CALL adrgim(Begsrs,Nobs,Havesp,'Trigonometric Seasonal', & PRRTTS,PRATTS,zeroz,.not.Lseff,Lrgmse,Lseff,Locok) END IF IF(Lfatal)RETURN END IF IF(Locok.and.zeroz.eq.0)Lseff=T GO TO 230 c----------------------------------------------------------------------- c First six trading day effects c----------------------------------------------------------------------- 40 CALL lex() IF(.not.Havesp)THEN CALL inpter(PERROR,Lstpos, & 'No seasonal period specified in series spec.') Locok=F ELSE IF(Sp.ne.12.and.Sp.ne.4)THEN CALL inpter(PERROR,Lstpos, & ' Need monthly or quarterly data for trading day') Locok=F ELSE IF(Begsrs(1).lt.1776)THEN CALL inpter(PERROR,Lstpos, &'No trading variables before 1776. Try including the century in') CALL writln(' the start date',Mt2,STDERR,F) Locok=F ELSE c ------------------------------------------------------------------ IF(regidx.eq.4.or.regidx.eq.5.or.regidx.eq.15.or. & regidx.eq.16)THEN IF(Isrflw.eq.2)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use flow trading day regressors for stock series.') Locok=F ELSE IF(Fulltd.AND.(.not.Nxtktp.eq.SLASH))THEN CALL inpter(PERROR,Lstpos,'Already have trading day effects.') Locok=F ELSE IF (Nxtktp.eq.SLASH.and.Lrgmtd) then CALL inpter(PERROR,Lstpos, & 'Already have change of regime trading day effects.') Locok=F ELSE c IF (.not.Havtd.OR.(Havtd.and.Tdzero.ne.0)) THEN IF(.not.Fulltd)THEN Picktd=regidx.eq.4.or.regidx.eq.15 IF(regidx.eq.15.or.regidx.eq.16)THEN CALL adrgef(DNOTST,'Weekday','1-Coefficient Trading Day', & PRG1TD,F,T) IF(Lfatal)RETURN ELSE DO i=1,6 CALL adrgef(DNOTST,day(i),'Trading Day',PRGTTD,F,T) IF(Lfatal)RETURN END DO END IF END IF IF(Nxtktp.eq.SLASH)THEN IF(regidx.eq.15.or.regidx.eq.16)THEN CALL adrgim(Begsrs,Nobs,Havesp,'1-Coefficient Trading Day', & PRR1TD,PRA1TD,zeroz,.not.Fulltd,Lrgmtd,Fulltd, & Locok) ELSE CALL adrgim(Begsrs,Nobs,Havesp,'Trading Day',PRRTTD,PRATTD, & zeroz,.not.Fulltd,Lrgmtd,Fulltd,Locok) END IF IF(Lfatal)RETURN Tdzero=zeroz IF(Picktd)Lnzero=zeroz IF(zeroz.eq.0)Fulltd=T ELSE Fulltd=T END IF END IF END IF c----------------------------------------------------------------------- c Seventh trading day variables, lom, lpyear, lomstock c----------------------------------------------------------------------- IF((regidx.eq.6.or.regidx.eq.7.or.regidx.eq.8).and.Picktd)THEN CALL inpter(PERROR,Lstpos, &'Can''t add a length of month, quarter, or leap year variable when & using') CALL writln(' the td or td1coef option.',Mt2,STDERR,F) Locok=F c----------------------------------------------------------------------- ELSE IF(regidx.eq.6.or.regidx.eq.7)THEN c----------------------------------------------------------------------- IF(Havlp)THEN IF(Sp.eq.12)THEN CALL inpter(PERROR,Lstpos,'Can''t add a length of month variab &le when using the leap year') ELSE CALL inpter(PERROR,Lstpos,'Can''t add a length of quarter vari &able when using the leap year') END IF CALL writln(' variable.',Mt2,STDERR,F) Locok=F c----------------------------------------------------------------------- ELSE IF(Isrflw.eq.2)THEN IF(regidx.eq.6)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use flow length of month regressor for stock series.') ELSE CALL inpter(PERROR,Lstpos, & 'Cannot use flow length of quarter regressor for stock series.') END IF Locok=F ELSE IF(Sp.eq.12)THEN IF(.not.Fullln)CALL adrgef(DNOTST,'Length-of-Month', & 'Length-of-Month',PRGTLM,F,T) IF(.not.Lfatal.and.Nxtktp.eq.SLASH)THEN CALL adrgim(Begsrs,Nobs,Havesp,'Length-of-Month',PRRTLM, & PRATLM,zeroz,.not.Fullln,Lrgmln,Fullln,Locok) Lnzero=zeroz END IF ELSE c----------------------------------------------------------------------- IF(.not.Fullln)CALL adrgef(DNOTST,'Length-of-Quarter', & 'Length-of-Quarter',PRGTLQ,F,T) IF(.not.Lfatal.and.Nxtktp.eq.SLASH)THEN CALL adrgim(Begsrs,Nobs,Havesp,'Length-of-Quarter',PRRTLQ, & PRATLQ,zeroz,.not.Fullln,Lrgmln,Fullln,Locok) Lnzero=zeroz END IF END IF IF(zeroz.eq.0)Fullln=T c----------------------------------------------------------------------- ELSE IF((.not.Havtd.AND.(regidx.eq.4.or.regidx.eq.15)).or. & regidx.eq.8)THEN IF(Havln)THEN IF(Sp.eq.12)THEN CALL inpter(PERROR,Lstpos,'Can''t add a leap year variable whe &n using the length of month') ELSE CALL inpter(PERROR,Lstpos,'Can''t add a leap year variable whe &n using the length of quarter') END IF CALL writln(' variable.',Mt2,STDERR,F) Locok=F c----------------------------------------------------------------------- ELSE IF(Isrflw.eq.2)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use flow leap year regressor for stock series.') Locok=F ELSE IF((.not.Fulllp).and.(.not.(Lrgmtd.and.Picktd))) & CALL adrgef(DNOTST,'Leap Year','Leap Year',PRGTLY,F,T) IF(Lfatal)RETURN IF(regidx.eq.8)THEN IF(Nxtktp.eq.SLASH)THEN CALL adrgim(Begsrs,Nobs,Havesp,'Leap Year',PRRTLY,PRATLY, & zeroz,.not.Fulllp,Lrgmln,Fulllp,Locok) Lnzero=zeroz END IF IF(zeroz.eq.0)Fulllp=T END IF END IF c ------------------------------------------------------------------ ELSE IF(regidx.eq.10)THEN IF(Isrflw.eq.1)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use stock length of month regressor for flow series.') Locok=F ELSE IF(Havlp)THEN CALL inpter(PERROR,Lstpos,'Can''t add a stock length of month v &ariable when using the') CALL writln(' leap year variable.',Mt2,STDERR,F) Locok=F c----------------------------------------------------------------------- ELSE IF(Sp.ne.12)THEN CALL inpter(PERROR,Lstpos, & 'Need monthly data for stock trading day') Locok=F CALL lex() c ------------------------------------------------------------------ ELSE IF(.not.Fullln)CALL adrgef(DNOTST,'Stock Length-of-Month', & 'Stock Length-of-Month',PRGTSL,F,T) IF(Lfatal)RETURN c CALL lex() IF(Nxtktp.eq.SLASH) & CALL adrgim(Begsrs,Nobs,Havesp,'Stock Length-of-Month', & PRRTSL,PRATSL,zeroz,.not.Fullln,Lrgmln,Fullln, & Locok) END IF IF(zeroz.eq.0)Fullln=T END IF IF(Lfatal)RETURN IF((regidx.eq.4.or.regidx.eq.5.or.regidx.eq.15.or.regidx.eq.16) & .and.Locok)Havtd=T IF((regidx.eq.6.or.regidx.eq.7.or.regidx.eq.10).and.Locok)Havln=T IF(regidx.eq.8.and.Locok)Havlp=T END IF c ------------------------------------------------------------------ GO TO 230 c----------------------------------------------------------------------- c First six stock trading day effects c----------------------------------------------------------------------- 50 CALL lex() IF(.not.Havesp)THEN CALL inpter(PERROR,Lstpos, & 'No seasonal period specified in series spec.') Locok=F c ------------------------------------------------------------------ ELSE IF(Sp.ne.12)THEN CALL inpter(PERROR,Lstpos, & 'Need monthly data for stock trading day') Locok=F c ------------------------------------------------------------------ ELSE IF(Begsrs(1).lt.1776)THEN CALL inpter(PERROR,Lstpos, &'No trading variables before 1776. Try including the century in') CALL writln(' the start date.',Mt2,STDERR,F) Locok=F ELSE IF(Isrflw.eq.1)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use stock trading day regressors for flow series.') Locok=F END IF c ------------------------------------------------------------------ CALL getivc(LBRAKT,T,1,ivec,nelt,argok,Locok) IF(Lfatal)RETURN tdspdy=ivec(1) c ------------------------------------------------------------------ IF(nelt.le.0)THEN CALL inpter(PERROR,Lstpos, & 'Must specify the Stock TD sample day explicitly') Locok=F c ------------------------------------------------------------------ ELSE IF(tdspdy.le.0.or.tdspdy.gt.31)THEN CALL inpter(PERROR,Lstpos,'Stock TD sample day must be (1:31)') * CALL inpter(PERROR,Lstpos,'Stock TD sample day must be (28:31)') Locok=F c ------------------------------------------------------------------ ELSE tgrptl='Stock Trading Day[' ipos=19 * IF(tdspdy.le.27.and.tdspdy.gt.0)THEN * CALL inpter(PWARN,Lstpos,'Stock TD sample day reset to 28') * tdspdy=28 * END IF CALL itoc(tdspdy,tgrptl,ipos) IF(Lfatal)RETURN tgrptl(ipos:ipos)=']' nchr=ipos c ------------------------------------------------------------------ IF(Fulltd.AND.(.not.Nxtktp.eq.SLASH))THEN CALL inpter(PERROR,Lstpos, & 'Already have stock trading day effects.') Locok=F ELSE IF (Nxtktp.eq.SLASH.and.Lrgmtd) then CALL inpter(PERROR,Lstpos, & 'Already have change of regime stock trading day effects.') Locok=F ELSE c IF (.not.Havtd.OR.(Havtd.and.Tdzero.ne.0)) THEN IF(.not.Fulltd)THEN IF(regidx.eq.17)THEN CALL adrgef(DNOTST,'Weekday','1-Coefficient '//tgrptl(1:nchr), & PRG1ST,F,T) ELSE DO i=1,6 CALL adrgef(DNOTST,day(i),tgrptl(1:nchr),PRGTST,F,T) IF(Lfatal)RETURN END DO END IF END IF c CALL lex() IF(Nxtktp.eq.SLASH)THEN IF(regidx.eq.17)THEN CALL adrgim(Begsrs,Nobs,Havesp,'1-Coefficient '// & tgrptl(1:nchr),PRR1ST,PRA1ST,zeroz,.not.Fulltd, & Lrgmtd,Fulltd,Locok) ELSE CALL adrgim(Begsrs,Nobs,Havesp,tgrptl(1:nchr),PRRTST,PRATST, & zeroz,.not.Fulltd,Lrgmtd,Fulltd,Locok) END IF Tdzero=zeroz ELSE Fulltd=T END IF Havtd=T IF(Lfatal)RETURN END IF END IF GO TO 230 c----------------------------------------------------------------------- c Easter effect c----------------------------------------------------------------------- 60 CALL lex() IF(regidx.eq.18)THEN Easidx=0 ELSE Easidx=regidx-11 END IF IF(.not.Havesp)THEN CALL inpter(PERROR,Lstpos, & 'No seasonal period specified in series spec.') Locok=F c ------------------------------------------------------------------ ELSE IF(Sp.ne.12.and.Sp.ne.4)THEN CALL inpter(PERROR,Lstpos, & ' Need monthly or quarterly data for an Easter effect' & ) Locok=F c ------------------------------------------------------------------ ELSE IF(Begsrs(1).lt.1901)THEN CALL inpter(PERROR,Lstpos, &'No Easter effect before 1901. Try including the century in the') CALL writln(' start date.',Mt2,STDERR,F) Locok=F ELSE IF(Isrflw.eq.2.and.regidx.lt.18)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use Easter regressor for stock series.') Locok=F ELSE IF(Isrflw.eq.1.and.regidx.eq.18)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use stock Easter regressor for flow series.') Locok=F END IF c ------------------------------------------------------------------ CALL addate(Begsrs,Sp,Nobs-1,tmpdat) IF(tmpdat(1).gt.2100)THEN CALL inpter(PERROR,Lstpos, & 'Cannot compute holiday effect after 2100') Locok=F END IF c ------------------------------------------------------------------ CALL getivc(LBRAKT,T,1,ivec,nelt,argok,Locok) IF(Lfatal)RETURN neastr=ivec(1) c ------------------------------------------------------------------ IF(nelt.le.0)THEN CALL inpter(PERROR,Errpos, & 'Must specify the Easter window length explicitly') Locok=F c ------------------------------------------------------------------ ELSE IF(neastr.lt.(0+Easidx).or.neastr.gt.ewlim(Easidx))THEN IF(Easidx.eq.0)THEN CALL inpter(PERROR,Errpos, & 'The Easter window must be from 0 to 25.') ELSE CALL inpter(PERROR,Errpos, & 'The Statistics Canada Easter window must be from 1 to 24.') END IF Locok=F c ------------------------------------------------------------------ ELSE IF(Easidx.eq.0)THEN IF(regidx.eq.18)THEN effttl='StockEaster[' ipos=13 ELSE effttl='Easter[' ipos=8 END IF ELSE IF(Easidx.eq.1)THEN effttl='StatCanEaster[' ipos=15 END IF CALL itoc(neastr,effttl,ipos) IF(Lfatal)RETURN effttl(ipos:ipos)=']' nchr=ipos IF(Easidx.eq.0)THEN IF(regidx.eq.18)THEN CALL adrgef(DNOTST,effttl(1:nchr),'StockEaster',PRGTES,F,T) ELSE CALL adrgef(DNOTST,effttl(1:nchr),'Easter',PRGTEA,F,T) END IF ELSE IF(Easidx.eq.1)THEN CALL adrgef(DNOTST,effttl(1:nchr),'StatCanEaster',PRGTEC,F,T) END IF IF(Lfatal)RETURN Havhol=T END IF GO TO 230 c----------------------------------------------------------------------- c Labor day effect c----------------------------------------------------------------------- 70 CALL lex() igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Labor') IF(.not.Havesp)THEN CALL inpter(PERROR,Lstpos, & 'No seasonal period specified in series spec.') Locok=F c ------------------------------------------------------------------ ELSE IF(Sp.ne.12)THEN CALL inpter(PERROR,Lstpos, & 'Need monthly data for a Labor Day effect') Locok=F c ------------------------------------------------------------------ ELSE IF(Begsrs(1).lt.1901)THEN CALL inpter(PERROR,Lstpos, &'No Labor Day effect before 1901. Try including the century in') CALL writln(' the start date',Mt2,STDERR,F) Locok=F c ------------------------------------------------------------------ ELSE IF(Isrflw.eq.2)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use Labor Day regressor for stock series.') Locok=F c ------------------------------------------------------------------ ELSE IF(igrp.gt.0)THEN CALL inpter(PERROR,Lstpos,'A Labor Day regressor is already inclu &ded in the regARIMA model.') Locok=F END IF c ------------------------------------------------------------------ CALL addate(Begsrs,Sp,Nobs-1,tmpdat) IF(tmpdat(1).gt.2100)THEN CALL inpter(PERROR,Lstpos, & 'Cannot compute holiday effect after 2100') Locok=F END IF c ------------------------------------------------------------------ CALL getivc(LBRAKT,T,1,ivec,nelt,argok,Locok) IF(Lfatal)RETURN nlabor=ivec(1) c ------------------------------------------------------------------ IF(nelt.le.0)THEN CALL inpter(PERROR,Errpos, & 'Must specify the Labor Day window length explicitly' & ) Locok=F c ------------------------------------------------------------------ ELSE IF(nlabor.le.0.or.nlabor.gt.25)THEN CALL inpter(PERROR,Errpos, & 'The Labor Day window must be from 1 to 25.') Locok=F c ------------------------------------------------------------------ ELSE effttl='Labor[' ipos=7 CALL itoc(nlabor,effttl,ipos) IF(Lfatal)RETURN effttl(ipos:ipos)=']' nchr=ipos CALL adrgef(DNOTST,effttl(1:nchr),effttl(1:nchr),PRGTLD,F,T) IF(Lfatal)RETURN Havhol=T END IF GO TO 230 c----------------------------------------------------------------------- c Thanksgiving-Christmas effect c----------------------------------------------------------------------- 80 CALL lex() igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Thanksgiving') c ------------------------------------------------------------------ IF(.not.Havesp)THEN CALL inpter(PERROR,Lstpos, & 'No seasonal period specified in series spec.') Locok=F c ------------------------------------------------------------------ ELSE IF(Sp.ne.12)THEN CALL inpter(PERROR,Lstpos, & 'Need monthly data for a Thanksgiving-Christmas day effect') Locok=F c ------------------------------------------------------------------ ELSE IF(Begsrs(1).lt.1939)THEN CALL inpter(PERROR,Lstpos, & 'Thanksgiving-Christmas day effect not defined before 1939.') IF(Begsrs(1).lt.100)CALL writln(' Try including the centur &y in the start date.',Mt2,STDERR,F) Locok=F c ------------------------------------------------------------------ ELSE IF(Isrflw.eq.2)THEN CALL inpter(PERROR,Lstpos, & 'Cannot use Thanksgiving-Christmas regressor for stock series.') Locok=F c ------------------------------------------------------------------ ELSE IF(igrp.gt.0)THEN CALL inpter(PERROR,Lstpos,'A Thanksgiving-Christmas regressor is &already included ') CALL writln(' in the regARIMA model.',Mt2,STDERR,F) Locok=F END IF c ------------------------------------------------------------------ CALL addate(Begsrs,Sp,Nobs-1,tmpdat) IF(tmpdat(1).gt.2100)THEN CALL inpter(PERROR,Lstpos, & 'Cannot compute holiday effect after 2100') Locok=F END IF c ------------------------------------------------------------------ CALL getivc(LBRAKT,T,1,ivec,nelt,argok,Locok) IF(Lfatal)RETURN nthank=ivec(1) c ------------------------------------------------------------------ IF(nelt.le.0)THEN CALL inpter(PERROR,Errpos, & 'Must specify the Thanksgiving day window length explicitly' & ) Locok=F c ------------------------------------------------------------------ ELSE IF(nthank.lt.-8.or.nthank.gt.17.or.nthank.eq.0)THEN CALL inpter(PERROR,Errpos,'The Thanksgiving day window must be fr &om -8 to 17 (excluding 0)') c ------------------------------------------------------------------ ELSE effttl='Thanksgiving[' ipos=14 CALL itoc(nthank,effttl,ipos) IF(Lfatal)RETURN effttl(ipos:ipos)=']' nchr=ipos CALL adrgef(DNOTST,effttl(1:nchr),effttl(1:nchr),PRGTTH,F,T) IF(Lfatal)RETURN Havhol=T END IF 230 Inptok=Inptok.and.Locok c ----------------------------------------------------------------- RETURN END adrgef.f0000664006604000003110000003766314521201403011577 0ustar sun00315stepsC Last change: BCM 21 Sep 1998 9:20 am SUBROUTINE adrgef(Initvl,Effttl,Igrptl,Vartyp,Varfix,Userin) IMPLICIT NONE c----------------------------------------------------------------------- c Add a column to the igrptl group and create the c regression group if it doesn't exist. Also, does the checking a c bookkeeping needed to add the effect. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begcol i Local begining column of the regression group the new c columns are to be placed c blkttl c Local pgrpcr characters of blanks c effttl c Input title of the effect c headings for this regression group c i i Local do loop index c icol i Local index for the current column in colttl or effttl c igrp i Local the current regression group c igrptl c Input character title of this regression group. c initvl d Input initial value. c nchr i Input number of characters in the group title c tmpttl c Local character to hold the group title padded with blanks c vartyp i Input type of regression variable (see model.prm). c----------------------------------------------------------------------- c Specify parameters c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- c Type and dimension variables c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- CHARACTER Effttl*(*),Igrptl*(*),tmpttl*(PGRPCR),numstr*(5) LOGICAL addcat,locok,havreg,Varfix,ltmp,Userin INTEGER begotl,bgotl2,endotl,icol,igrp,nchr,otlidx,otlid2,Vartyp, & jgrp,itype,dspzro,dsptyp,zeroz,zero2,rgmidx,rgmid2,begcol, & endcol,jcol,itmp,newreg,ireg,ipos DOUBLE PRECISION Initvl,dptmp DIMENSION dspzro(-1:1),dptmp(PB),itmp(PB),ltmp(PB) c----------------------------------------------------------------------- INTEGER ctoi,strinx EXTERNAL ctoi,strinx c----------------------------------------------------------------------- CHARACTER DAYDIC*18 INTEGER dayptr,PDAY PARAMETER(PDAY=6) DIMENSION dayptr(0:PDAY) PARAMETER(DAYDIC='montuewedthufrisat') c ------------------------------------------------------------------ CHARACTER MONDIC*33 INTEGER monptr,PMON PARAMETER(PMON=11) DIMENSION monptr(0:PMON) PARAMETER(MONDIC='janfebmaraprmayjunjulaugsepoctnov') c ------------------------------------------------------------------ DATA dspzro/PRATSE,PRGTSE,PRRTSE/ DATA dayptr/1,4,7,10,13,16,19/ DATA monptr/1,4,7,10,13,16,19,22,25,28,31,34/ c----------------------------------------------------------------------- c Find the group. If the group doesn't exist, create it c----------------------------------------------------------------------- igrp=strinx(F,Grpttl,Grpptr,1,Ngrp,Igrptl) c----------------------------------------------------------------------- IF(igrp.eq.0)THEN addcat=T igrp=1 IF(Ngrp.gt.0)THEN c ------------------------------------------------------------------ c IF this is an outlier supplied by user, sort by date c ------------------------------------------------------------------ IF((Vartyp.eq.PRGTAO.or.Vartyp.eq.PRGTLS.or.Vartyp.eq.PRGTRP.or. & Vartyp.eq.PRGTMV.or.Vartyp.eq.PRGTTC.or.Vartyp.eq.PRGTTL.or. & Vartyp.eq.PRGTSO.or.Vartyp.eq.PRGTQI.or.Vartyp.eq.PRGTQD.or. & Vartyp.eq.PRSQAO.or.Vartyp.eq.PRSQLS).and.(.not.Userin))THEN CALL rdotlr(Effttl,Begspn,Sp,otlidx,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF havreg=.false. DO jgrp=1,Ngrp icol=Grp(jgrp-1) itype=Rgvrtp(icol) IF(itype.eq.PRGTAO.or.itype.eq.PRGTLS.or.itype.eq.PRGTRP.or. & itype.eq.PRGTMV.or.itype.eq.PRGTTC.or.itype.eq.PRGTTL.or. & itype.eq.PRGTSO.or.itype.eq.PRGTQI.or.itype.eq.PRGTQD.or. & itype.eq.PRSQAO.or.itype.eq.PRSQLS)THEN CALL getstr(Colttl,Colptr,Nb,icol,tmpttl,nchr) IF(Lfatal)RETURN CALL rdotlr(tmpttl(1:nchr),Begspn,Sp,otlid2,bgotl2,endotl, & locok) IF(.not.locok)THEN CALL abend RETURN END IF havreg=.true. c ------------------------------------------------------------------ IF(begotl.eq.bgotl2)THEN IF(otlidx.eq.otlid2)THEN WRITE(STDERR,1030)Effttl CALL errhdr WRITE(Mt2,1030)Effttl CALL abend RETURN c ------------------------------------------------------------------ ELSE IF(otlidx.lt.otlid2)THEN GO TO 1 END IF c ------------------------------------------------------------------ ELSE IF(begotl.lt.bgotl2)THEN GO TO 1 END IF c ------------------------------------------------------------------ c If no more outliers, insert outlier group here c ------------------------------------------------------------------ ELSE IF(havreg)THEN GO TO 1 END IF END DO 1 igrp=jgrp c ------------------------------------------------------------------ c If this is an lom/loq/lpyear regressor, try to find a c corresponding set of trading day regressors - otherwise, add to c end of group c ------------------------------------------------------------------ ELSE IF(Vartyp.eq.PRGTLM.or.Vartyp.eq.PRGTLQ.or.Vartyp.eq.PRGTLY & .or.Vartyp.eq.PRRTLM.or.Vartyp.eq.PRRTLQ.or.Vartyp.eq.PRRTLY & .or.Vartyp.eq.PRATLM.or.Vartyp.eq.PRATLQ.or.Vartyp.eq.PRATLY & )THEN DO jgrp=1,Ngrp icol=Grp(jgrp-1) itype=Rgvrtp(icol) IF((itype.eq.PRGTTD.or.itype.eq.PRG1TD).and.(Vartyp.eq.PRGTLM & .or.Vartyp.eq.PRGTLQ.or.Vartyp.eq.PRGTLY))THEN igrp=jgrp+1 ELSE IF((itype.eq.PRRTTD.or.itype.eq.PRR1TD).and. & (Vartyp.eq.PRRTLM.or.Vartyp.eq.PRRTLQ.or. & Vartyp.eq.PRRTLY))THEN igrp=jgrp+1 ELSE IF((itype.eq.PRATTD.or.itype.eq.PRA1TD).and. & (Vartyp.eq.PRATLM.or.Vartyp.eq.PRATLQ.or. & Vartyp.eq.PRATLY))THEN igrp=jgrp+1 END IF END DO IF(igrp.eq.1)igrp=Ngrp+1 c ------------------------------------------------------------------ c IF this is not an outlier supplied by user, check to see if c it is a "change of regime" regressors (or a parent of a change c of regime regressor). If so, keep those groups together and c sort by type of regressor, date of regime change. c ------------------------------------------------------------------ ELSE IF(Vartyp.eq.PRGTSE.or.Vartyp.eq.PRGTTS.or.Vartyp.eq.PRGTTD & .or.Vartyp.eq.PRGTST.or.Vartyp.eq.PRGTSL.or.Vartyp.eq.PRRTSE & .or.Vartyp.eq.PRRTTS.or.Vartyp.eq.PRRTTD.or.Vartyp.eq.PRRTST & .or.Vartyp.eq.PRRTSL.or.Vartyp.eq.PRATSE.or.Vartyp.eq.PRATTS & .or.Vartyp.eq.PRATTD.or.Vartyp.eq.PRATST.or.Vartyp.eq.PRATSL & .or.Vartyp.eq.PRG1TD.or.Vartyp.eq.PRR1TD.or.Vartyp.eq.PRA1TD & .or.Vartyp.eq.PRG1ST.or.Vartyp.eq.PRR1ST.or.Vartyp.eq.PRA1ST & )THEN CALL rdregm(Igrptl,Begspn,Sp,zeroz,rgmidx,locok) IF(.not.locok)THEN CALL abend RETURN END IF havreg=.false. dsptyp=Vartyp-dspzro(zeroz) DO jgrp=1,Ngrp icol=Grp(jgrp-1) itype=Rgvrtp(icol) CALL getstr(Grpttl,Grpptr,Ngrp,jgrp,tmpttl,nchr) IF(Lfatal)RETURN CALL rdregm(tmpttl(1:nchr),Begspn,Sp,zero2,rgmid2,locok) IF(.not.locok)THEN CALL abend RETURN END IF IF(itype.eq.dsptyp+dspzro(zero2))THEN havreg=.true. c ------------------------------------------------------------------ c If they are the same type of regressor, print error message and c leave routine c ------------------------------------------------------------------ IF(zeroz.eq.zero2)THEN c IF(zeroz.eq.0)RETURN c IF(rgmidx.lt.rgmid2)GO TO 2 WRITE(STDERR,1020)Effttl CALL errhdr WRITE(Mt2,1020)Effttl CALL abend RETURN c ------------------------------------------------------------------ c Else, check to see if this regressor type should come before c the current regressor. c ------------------------------------------------------------------ ELSE IF(zeroz.eq.0.OR.(zeroz.EQ.1.and.zero2.eq.-1))THEN GO TO 2 END IF ELSE IF(havreg)THEN GO TO 2 END IF END DO 2 igrp=jgrp c ------------------------------------------------------------------ ELSE igrp=Ngrp+1 END IF END IF IF(igrp.eq.Ngrp+1)THEN CALL putstr(Igrptl,PGRP,Grpttl,Grpptr,Ngrptl) IF(Lfatal)RETURN ELSE CALL insstr(Igrptl,igrp,PGRP,Grpttl,Grpptr,Ngrptl) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ ELSE addcat=F END IF c ------------------------------------------------------------------ IF(Nb.ge.PB)THEN ipos=1 CALL itoc(PB,numstr,ipos) WRITE(STDERR,1010)Effttl,numstr(1:(ipos-1)),LIMSEC,PRGNAM,DOCNAM CALL errhdr WRITE(Mt2,1010)Effttl,numstr(1:(ipos-1)),LIMSEC,PRGNAM,DOCNAM 1010 FORMAT(/, & ' ERROR: Adding ',a,' exceeds the number of regression ', & 'effects allowed',/, & ' in the model (',a,').',//, & ' Check the regression model, change the ', & 'automatic outlier options,',/, & ' (e.g. method to ADDONE, raise the critical ', & 'value, or change types',/ & ' to identify AOs only), or change the program ', & 'limits (see ',a,/, & ' of the ',a,' ',a,').') CALL abend RETURN END IF c ------------------------------------------------------------------ CALL insptr(addcat,1,igrp,PGRP,PB,Grp,Ngrp) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Find out if the column titles already exist c----------------------------------------------------------------------- icol=strinx(F,Colttl,Colptr,1,Ncoltl,Effttl) c ------------------------------------------------------------------ IF(icol.gt.0)THEN WRITE(STDERR,1020)Effttl CALL errhdr WRITE(Mt2,1020)Effttl 1020 FORMAT(/,' ERROR: ',a,' is already in the regression.') CALL abend RETURN END IF c----------------------------------------------------------------------- c Sort the automatically identified outliers by date c----------------------------------------------------------------------- nchr=len(Igrptl) IF(Vartyp.eq.PRGTAA.or.Vartyp.eq.PRGTAL.or.Vartyp.eq.PRGTAT)THEN * & Vartyp.eq.PRGTAS)THEN CALL rdotlr(Effttl,Begspn,Sp,otlidx,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF c ------------------------------------------------------------------ c Note grp is updated for the new outlier so use -2 instead of -1 c ------------------------------------------------------------------ DO icol=Grp(igrp-1),Grp(igrp)-2 CALL getstr(Colttl,Colptr,Nb,icol,tmpttl,nchr) IF(Lfatal)RETURN CALL rdotlr(tmpttl(1:nchr),Begspn,Sp,otlid2,bgotl2,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF c ------------------------------------------------------------------ IF(begotl.eq.bgotl2)THEN IF(otlidx.eq.otlid2)THEN WRITE(STDERR,1030)Effttl CALL errhdr WRITE(Mt2,1030)Effttl 1030 FORMAT(/,' ERROR: ',a,' already exists.') CALL abend RETURN c ------------------------------------------------------------------ ELSE IF(otlidx.lt.otlid2)THEN GO TO 10 END IF c ------------------------------------------------------------------ ELSE IF(begotl.lt.bgotl2)THEN GO TO 10 END IF END DO icol=Grp(igrp)-1 c ------------------------------------------------------------------ c Need to handle trading day sometime c ------------------------------------------------------------------ ELSE IF(Vartyp.eq.PRGTTD.or.Vartyp.eq.PRGTST.or.Vartyp.eq.PRRTTD & .or.Vartyp.eq.PRRTST.or.Vartyp.eq.PRATTD.or.Vartyp.eq.PRATST) & THEN newreg=strinx(F,DAYDIC,dayptr,1,PDAY,Effttl(1:3)) DO icol=Grp(igrp-1),Grp(igrp)-2 CALL getstr(Colttl,Colptr,Nb,icol,tmpttl,nchr) IF(Lfatal)RETURN ireg=strinx(F,DAYDIC,dayptr,1,PDAY,tmpttl(1:3)) IF(newreg.eq.ireg)THEN WRITE(STDERR,1030)Effttl CALL errhdr WRITE(Mt2,1030)Effttl CALL abend RETURN ELSE IF(newreg.lt.ireg)THEN GO TO 10 END IF END DO icol=Grp(igrp)-1 c ------------------------------------------------------------------ c Need to handle seasonal c ------------------------------------------------------------------ ELSE IF(Vartyp.eq.PRGTSE.or.Vartyp.eq.PRRTSE.or.Vartyp.eq.PRATSE) & THEN ipos=1 IF(Sp.eq.12)THEN newreg=strinx(F,MONDIC,monptr,1,PMON,Effttl(1:3)) ELSE newreg=ctoi(Effttl,ipos) END IF DO icol=Grp(igrp-1),Grp(igrp)-2 ipos=1 CALL getstr(Colttl,Colptr,Nb,icol,tmpttl,nchr) IF(Lfatal)RETURN IF(Sp.eq.12)THEN ireg=strinx(F,MONDIC,monptr,1,PMON,tmpttl(1:3)) ELSE ireg=ctoi(tmpttl(1:nchr),ipos) END IF IF(newreg.eq.ireg)THEN WRITE(STDERR,1030)Effttl CALL errhdr WRITE(Mt2,1030)Effttl CALL abend RETURN ELSE IF(newreg.lt.ireg)THEN GO TO 10 END IF END DO icol=Grp(igrp)-1 c ------------------------------------------------------------------ ELSE icol=Grp(igrp)-1 END IF c ------------------------------------------------------------------ 10 CALL insstr(Effttl,icol,PB,Colttl,Colptr,Ncoltl) IF(Lfatal)RETURN Nb=Ncoltl Ncxy=Nb+1 IF(addcat)THEN begcol=Grp(igrp-1) endcol=Grp(igrp)-1 DO jcol=begcol,endcol dptmp(jcol-begcol+1)=Initvl itmp(jcol-begcol+1)=Vartyp ltmp(jcol-begcol+1)=Varfix END DO CALL insdbl(dptmp,igrp,Grp,Ngrp,B) IF(.not.Lfatal)CALL insint(itmp,igrp,Grp,Ngrp,Rgvrtp) IF(.not.Lfatal)CALL inslg(ltmp,igrp,Grp,Ngrp,Regfx) IF(Lfatal)RETURN ELSE IF(Nb.gt.icol)THEN CALL copy(B(icol),Nb-icol,-1,B(icol+1)) CALL cpyint(Rgvrtp(icol),Nb-icol,-1,Rgvrtp(icol+1)) CALL copylg(Regfx(icol),Nb-icol,-1,Regfx(icol+1)) END IF B(icol)=Initvl Rgvrtp(icol)=Vartyp Regfx(icol)=Varfix END IF c ------------------------------------------------------------------ RETURN END adrgim.f0000664006604000003110000002101114521201403011566 0ustar sun00315stepsC Last change: BCM 28 Sep 1998 8:55 am SUBROUTINE adrgim(Begsrs,Nobs,Havesp,Grptxt,Vartyp,Vrtyp2,Zeroz, & Delreg,Lregim,Fullef,Locok) IMPLICIT NONE c----------------------------------------------------------------------- c Add regression variables for a change in regime c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'picktd.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- CHARACTER Grptxt*(*),rdtstr*(10),colstr*(PCOLCR),igrptl*(PGRPCR), & rgmtxt*(PGRPCR) LOGICAL argok,Delreg,Havesp,Locok,Lregim,Fullef INTEGER Vartyp,Vrtyp2,strgim,igrp,begcol,endcol,icol,ncolcr,ngtxt, & Begsrs,Nobs,nchdat,dfrgim,Zeroz,varori,varor1,varor2,nchr, & nrgm DIMENSION Begsrs(2),strgim(2) c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- c Get the date of the change of regime. c----------------------------------------------------------------------- CALL gtrgdt(Havesp,Sp,strgim,Zeroz,argok,Locok) IF(.not.argok.or.Lfatal)THEN Locok=F RETURN END IF CALL wrtdat(strgim,Sp,rdtstr,nchdat) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Test date of change of regime to see if it is valid c----------------------------------------------------------------------- CALL dfdate(strgim,Begsrs,Sp,dfrgim) IF(dfrgim.le.0.or.dfrgim.ge.Nobs)THEN CALL inpter(PERROR,Lstpos, & 'Date given for change of regime not within the series.') Locok=F RETURN END IF c----------------------------------------------------------------------- c Add change of regime regression variables. First, determine which c group the full effect is stored in. c----------------------------------------------------------------------- igrp=strinx(F,Grpttl,Grpptr,1,Ngrp,Grptxt) begcol=Grp(igrp-1) endcol=Grp(igrp)-1 c----------------------------------------------------------------------- IF(Zeroz.eq.0.and.(Vartyp.eq.PRRTTD.or.Vartyp.eq.PRR1TD).and. & Picktd)THEN CALL adrgef(DNOTST,'Leap Year','Leap Year (after '// & rdtstr(1:nchdat)//')',PRGTLY,F,T) END IF c----------------------------------------------------------------------- c For each effect in the group, add a change of regime variable that c will be its analog. c----------------------------------------------------------------------- ngtxt=len(Grptxt) DO icol=endcol,begcol,-1 CALL getstr(Colttl,Colptr,Ncoltl,icol,colstr,ncolcr) IF(.not.Lfatal)THEN IF(Zeroz.eq.0.or.(Zeroz.eq.1.and.Fullef))THEN nrgm=ngtxt+nchdat+21 rgmtxt(1:nrgm)=Grptxt(1:ngtxt)//' (change for before '// & rdtstr(1:nchdat)//')' CALL adrgef(DNOTST,colstr(1:ncolcr)//' I',rgmtxt(1:nrgm), & Vartyp,F,T) ELSE IF(Zeroz.gt.0)THEN nrgm=ngtxt+nchdat+10 rgmtxt(1:nrgm)=Grptxt(1:ngtxt)//' (before '// & rdtstr(1:nchdat)//')' CALL adrgef(DNOTST,colstr(1:ncolcr)//' I',rgmtxt(1:nrgm), & Vartyp,F,T) IF(Zeroz.eq.2)THEN nrgm=ngtxt+nchdat+12 rgmtxt(1:nrgm)=Grptxt(1:ngtxt)//' (starting '// & rdtstr(1:nchdat)//')' CALL adrgef(DNOTST,colstr(1:ncolcr)//' II',rgmtxt(1:nrgm), & Vrtyp2,F,T) END IF ELSE IF(Fullef)THEN nrgm=ngtxt+nchdat+20 rgmtxt(1:nrgm)=Grptxt(1:ngtxt)//' (change for after '// & rdtstr(1:nchdat)//')' CALL adrgef(DNOTST,colstr(1:ncolcr)//' II',rgmtxt(1:nrgm), & Vrtyp2,F,T) ELSE nrgm=ngtxt+nchdat+12 rgmtxt(1:nrgm)=Grptxt(1:ngtxt)//' (starting '// & rdtstr(1:nchdat)//')' CALL adrgef(DNOTST,colstr(1:ncolcr)//' II',rgmtxt(1:nrgm), & Vrtyp2,F,T) END IF END IF IF(Lfatal)RETURN END DO c----------------------------------------------------------------------- c Delete regular regressors if regime regressors are to be fit by c themselves c----------------------------------------------------------------------- IF(Delreg.AND.(Zeroz.ne.0))THEN CALL dlrgef(begcol,Nobs,endcol-begcol+1) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Zeroz.eq.0.or.Fullef)THEN varor1=0 varor2=0 IF(Zeroz.eq.0)THEN varori=Rgvrtp(begcol) varor1=varori+1 varor2=varori+3 ELSE IF(Vartyp.eq.PRR1TD)THEN varori=PRG1TD varor1=varori+1 varor2=varori+3 ELSE IF(Vartyp.eq.PRG1ST)THEN varori=PRG1ST ELSE varori=Vartyp-17 varor1=varori+1 varor2=varori+3 END IF igrp=Ngrp DO WHILE (igrp.gt.0) icol=Grp(igrp-1) IF(Rgvrtp(icol).eq.varori)THEN CALL getstr(Grpttl,Grpptr,Ngrp,igrp,igrptl,nchr) IF(.not.Lfatal)CALL delstr(igrp,Grpttl,Grpptr,Ngrp,PGRP) IF(Lfatal)RETURN IF(Zeroz.ge.0)THEN CALL insstr(igrptl(1:nchr)//' (after '//rdtstr(1:nchdat)//')', & igrp,PGRP,Grpttl,Grpptr,Ngrp) ELSE CALL insstr(igrptl(1:nchr)//' (before '//rdtstr(1:nchdat)// & ')',igrp,PGRP,Grpttl,Grpptr,Ngrp) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(igrp.lt.Ngrp)THEN icol=Grp(igrp) IF(Rgvrtp(icol).ge.varor1.and.Rgvrtp(icol).le.varor2)THEN CALL getstr(Grpttl,Grpptr,Ngrp,igrp+1,igrptl,nchr) IF(Lfatal)RETURN CALL delstr(igrp+1,Grpttl,Grpptr,Ngrp,PGRP) IF(Zeroz.ge.0)THEN CALL insstr( & igrptl(1:nchr)//' (after '//rdtstr(1:nchdat)//')', & igrp+1,PGRP,Grpttl,Grpptr,Ngrp) ELSE CALL insstr( & igrptl(1:nchr)//' (before '//rdtstr(1:nchdat)//')', & igrp+1,PGRP,Grpttl,Grpptr,Ngrp) END IF END IF END IF c----------------------------------------------------------------------- igrp=0 ELSE igrp=igrp-1 END IF END DO END IF c----------------------------------------------------------------------- c If td option picked, also add lom or loq variable. c----------------------------------------------------------------------- IF((Vartyp.eq.PRRTTD.or.Vartyp.eq.PRR1TD).and.Picktd)THEN IF(Zeroz.eq.0)THEN CALL adrgef(DNOTST,'Leap Year I', & 'Leap Year (change for before '//rdtstr(1:nchdat)//')', & PRRTLY,F,T) ELSE IF(Zeroz.gt.0)THEN CALL adrgef(DNOTST,'Leap Year I', & 'Leap Year (before '//rdtstr(1:nchdat)//')',PRRTLY,F,T) IF(Zeroz.eq.2) & CALL adrgef(DNOTST,'Leap Year II','Leap Year (starting '// & rdtstr(1:nchdat)//')',PRATLY,F,T) ELSE IF(Fullef)THEN CALL adrgef(DNOTST,'Leap Year II','Leap Year (change for after ' & //rdtstr(1:nchdat)//')',PRATLY,F,T) ELSE CALL adrgef(DNOTST,'Leap Year II', & 'Leap Year (starting '//rdtstr(1:nchdat)//')',PRATLY,F,T) END IF END IF c----------------------------------------------------------------------- IF(.not.Lregim)Lregim=.true. IF(Vartyp.eq.PRRTTD.or.Vartyp.eq.PRRTST.or.Vartyp.eq.PRR1TD.or. & Vartyp.eq.PRR1ST)THEN CALL cpyint(strgim,2,1,Tddate) IF((Vartyp.eq.PRRTTD.or.Vartyp.eq.PRR1TD).and.Picktd) & CALL cpyint(strgim,2,1,Lndate) END IF IF(Vartyp.eq.PRRTLM.or.Vartyp.eq.PRRTLQ.or.Vartyp.eq.PRRTLY) & CALL cpyint(strgim,2,1,Lndate) c----------------------------------------------------------------------- RETURN END adsncs.f0000664006604000003110000001161414521201404011607 0ustar sun00315stepsC Last change: BCM 26 Jan 98 12:57 pm SUBROUTINE adsncs(Begdat,Sp,Nrxy,Ncxy,Colttl,Colptr,Begcol,Endcol, & Xy,Begrgm) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to add sine-cosine seasonal effect variables to c an nrXy by ncXy Xy matrix in columns begcol to begcol+sp-2. c The sine-cosine submatrix is nrXy by sp and the ith and i+1th c variable are, c sin(2*isncos(i)*pi*t/sp) c cos(2*isncos(i)*pi*t/sp) c where isncos(i) is between 1 and sp/2 and there are no more than c sp/2 sine-cosine pairs. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c fac d Local factor without the harmonic, 2*pi/sp c fcn c Local character string to determine weather the variable c is a sine or cosine function c harmc d Local psp long vector of factors that are multiples of c the harmonic, 2*pi*harmonic/sp c i i Local do loop index c iharmc i Local index for the ith harmonic c dmo d Local current month c j i Local do loop index c lsin l Local sp/2 vector of switches indicating that the c variable is a sine function otherwise it's a cosine c function c ncol i Local number of sine-cosine variables, ncol NZ. FH set to '',i2,''.'',/)')NZ-2 end if if (CkLen .lt.0) then write (nio,'(2x, $ ''WARNING : The value entered for NZ is smaller '', $ ''than the number of observations in the series.'')') write (nio,'(12x, $ ''The program will use '',i3,'' observations.'')')Nz write (nio,'(//)') else if (CkLen .gt.0) then write (nio,'(2x, $ ''WARNING : The value entered for NZ is greater '', $ ''than the number of observations in the series.'')') write (nio,'(12x, $ ''The program will use '',i3,'' observations.'')')Nz write (nio,'(//)') end if if (Ioneout .eq. 1) then opened = .true. end if C if ((Iter.ne.0) .and. (Ioneout.eq.1)) then CC LINES OF CODE ADDED FOR X-13A-S : 6 C if (noutdir.gt.0) then C filename = Outdir(1:ISTRLEN(Outdir)) // outf(1:ISTRLEN(outf)) C $ // '.CMP' C ELSE C filename = outf(1:ISTRLEN(outf))//'.cmp' C END IF CC END OF CODE BLOCK CC LINES OF CODE COMMENTED FOR X-13A-S : 6 Cccdos Cc filename = Outdir(1:ISTRLEN(Outdir)) // '\\' // Cc $ outf(1:ISTRLEN(outf)) // '.CMP' Cccunix Ccc filename = Outdir(1:ISTRLEN(Outdir)) // '/' // Ccc $ outf(1:ISTRLEN(outf)) // '.CMP' CC END OF CODE BLOCK C call OPENDEVICE(filename,22,0,ireturn) C end if if (Out .eq. 0) then 7002 format ( $ ' PART 1 : ARIMA ESTIMATION',/,' -------------------------',// $ ) write (Nio,7002) end if C if ((Iter.eq.2) .and. (.not.saved)) then * call profiler(2,'before NMCHECK') call NMCHECK (Type,Init,ilam,Imean,P,D,Q,Bp,Bd,Bq,Sqg,Mq,M, $ iqm,maxit,fh,noserie,Pg,Out,seas, $ Noadmiss,OutNA,StochTD, $ Iter,qmax,Har,Bias,Tramo,model,Noutr, $ Nouir,Nous,Npatd,Npareg,interp,Rsa,Fortr,Neast, $ epsiv,Epsphi,Xl,Rmod,thlim,bthlim,crmean,hplan,hpcycle, $ rogtable,centrregs,statseas,units, $ acfe,posbphi,nochmodel, $ tabtables,d_tabtables,psieinic,psiefin, $ StrFobs,StrLobs,HPper,brol,blamda, $ bserie,bmid,bcMark,Nzorig) C WHEN ITER=2 WE SAVE THE NAMELIST INPUT IN AN INTERNAL FILE C IN ORDER TO RE-READ IT. WHEN THE INTERNAL FILE IS CLOSED IT IS C AUTOMATICALLY DELETED C * call profiler(2,'before NMLSTS') call NMLSTS(Nochmodel,Type,Init,Ilam,Imean,P,D,Q,Bp,Bd,Bq, $ Sqg,Mq,M,iqm,maxit,fh,noserie,Pg,modelsumm, $ Out,seas,Noadmiss,OutNA,StochTD, $ Iter,qmax,Har,Bias,Tramo, $ model,Noutr,Nouir,Nous,Npatd,Npareg,interp,Rsa, $ Fortr,Neast,epsiv,Epsphi,ta,Xl,Rmod, $ blqt,tmu,Phi,Th,Bphi,Bth,thlim,bthlim,crmean,hplan, $ hpcycle,rogtable,centrregs, $ statseas,units,kunits,acfe,posbphi,printphtrf, $ tabtables,psieinic,psiefin, $ StrFobs,StrLobs,HPper,maxSpect,brol,blamda, $ bserie,bmid,bcMark,ODate,OLen,DetSeas, $ nds,Nz,nfixed,2,ifail) saved = .true. else * call profiler(2,'before NMCHECK') call NMCHECK (Type,Init,ilam,Imean,P,D,Q,Bp,Bd,Bq,Sqg,Mq,M, $ iqm,maxit,fh,noserie,Pg,Out,seas, $ Noadmiss,OutNA,StochTD, $ Iter,qmax,Har,Bias,Tramo,model,Noutr, $ Nouir,Nous,Npatd,Npareg,interp,Rsa,Fortr,Neast, $ epsiv,Epsphi,Xl,Rmod,thlim,bthlim,crmean,hplan,hpcycle, $ rogtable,centrregs,statseas,units, $ acfe,posbphi,nochmodel, $ tabtables,d_tabtables,psieinic,psiefin, $ StrFobs,StrLobs,HPper,brol,blamda, $ bserie,bmid,bcMark,Nzorig) end if * call profiler(2,'before PROUT1') call PROUT1(Mq,Ilam,Type,Ioneout,Nz,Titleg,Tramo,interp,Init,P, $ D,Q,Bd,Bp,Bq,Out,Nper,Nyer,npread) if (Type .eq. 0) then if (Out .eq. 0) then write (Nio,'('' METHOD: MAXIMUM LIKELIHOOD'')') end if else if (Type .eq. 1) then if (Out .eq. 0) then write (Nio,'('' METHOD: CONSTRAINED LEAST SQUARES'')') end if else * call profiler(2,'**GO TO 5025**, line 1452') goto 5025 end if if (Out.eq.0) then if (noserie.ne.1) then write (Nio,'(/'' NO OF OBSERVATIONS ='',I3,//)') Nz end if if (Firstobs .gt. 1) then write (Nio,'(4x,"Due to FirstObs parameter:")') write (Nio,'(8x,"First(",i3.3,") observations in the ", & "original series have been removed.",//)')Firstobs-1 end if if ((lastobs.ne.-1).and. $ (LastObs .gt. 0) .and.((Dlen-LastObs).gt.0)) then write (Nio,'(4x,"Due to LastObs parameter:")') write (Nio,'(8x,"Last(",i3.3,") observations in the ", & "original series have been removed.",//)') & Dlen-LastObs end if if ((Tramo .ne.0) .and. (Tramo .ne.999)) then lost = LostB() if (lost .gt.0) then write (Nio,'(4x,"Due to FirstObs parameter:")') write (nio,'(8x,"First(",i3.3,") observations in the ", & "original series have been removed.",//)')lost end if lost = LostE() if (lost .gt.0) then write (Nio,'(4x,"Due to LastObs parameter:")') write (nio,'(8x,"Last(",i3.3,") observations in the ", & "original series have been removed.",//)')lost end if end if c c if ((Tramo.eq.1) .and. (interp.eq.1)) then write (Nio, $ '(2x,''MISSING OBSERVATIONS IN ORIGINAL SERIES'',/,2x, $ ''HAVE BEEN INTERPOLATED'',/)') end if C LINES OF CODE COMMENTED FOR X-13A-S : 8 C if (Out .eq. 0) then C if (kunits .ne. 0) then C write (Nio, '(''

'',A,A,i2,A)') C $ 'TRAMO modified the original ', C $ 'series by multiplying them by 10**',3*kunits,'.' C write (Nio,'(A)') C $ '
SEATS will preserve this modification.

' Cc call Enote(nio) C end if C end if C END OF CODE BLOCK if ((Tramo.eq.1) .and. (noserie.eq.0)) then write (Nio, C LINES OF CODE COMMENTED FOR X-13A-S : 2 C $ '(//,'' ORIGINAL UNCORRECTED SERIES (from TRAMO)'')') C call TABLE(Tram,ndec1) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 $ '(//,'' ORIGINAL UNCORRECTED SERIES (from regARIMA)'')') * call profiler(2,'before TABLE2') call TABLE2(Tram) C END OF CODE BLOCK if (Ilam .eq. 0) then do i = 1,Nz bz(i) = (Tram(i)/oz(i)) * 100.0d0 end do write (Nio,'(/,'' PREADJUSTMENT FACTORS'',/, $'' Outliers and Other Deterministic Effects'',//, C LINES OF CODE COMMENTED FOR X-13A-S : 2 C $'' (from TRAMO)'')') c call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 $'' (from regARIMA)'')') * call profiler(2,'before TABLE2') call TABLE2(bz) C END OF CODE BLOCK else do i = 1,Nz bz(i) = Tram(i) - oz(i) end do write (Nio,'(/,'' PREADJUSTMENT COMPONENT'',/, $'' Outliers and Other Deterministic Effects'',//, C LINES OF CODE COMMENTED FOR X-13A-S : 2 C $'' (from TRAMO)'')') C call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 $'' (from regARIMA)'')') * call profiler(2,'before TABLE2') call TABLE2(bz) C END OF CODE BLOCK end if end if end if if ((Tramo .eq. 0 ) .and. (Units .eq. 1)) then sunits=0 * call profiler(2,'before UNITSCHECK') call UNITSCHECK(oz,nz,sunits) if ((sunits .gt.0). and. (Out .eq. 0)) then write (Nio,'(/,4x,A)') 'Units in input series '// $ 'are too small.' write (Nio,'(4x,A,A,i2,A)') & 'It is recommended that the series be', & ' multiplied by 10**',3*sunits,';' write (Nio,'(4x,A,/,4x,A)') & 'the program will do it automatically.', & '(If correction is not desired, set UNITS=0)' write (Nio,'(4x,A,A,i2,A)') & 'The output of the program refers to ', & 'series multiplied by 10**',3*sunits,'.' end if if ((sunits .lt.0) .and. (Out .eq. 0)) then write (Nio,'(/,4x,A)') 'Units in input series '// $ 'are too large.' write (Nio,'(/,4x,A,A,i2,A)') & 'It is recommended that the series be', & ' divided by 10**',-3*sunits,';' write (Nio,'(4x,A,/,4x,A)') & 'the program will do it automatically.', & '(If correction is not desired, set UNITS=0)' write (Nio,'(/,4x,A,A,i2,A)') & 'The output of the program refers to ', & 'series divided by 10**',-3*sunits,'.' end if end if if ((Out.eq.0) .and. (noserie.eq.0) .and. (Tramo.eq.0)) then 7003 format (//,' ORIGINAL SERIES') write (Nio,7003) end if if ((Out.eq.0) .and. (noserie.eq.0) .and. (Tramo.ne.0)) then 7004 format (//, C LINES OF CODE COMMENTED FOR X-13A-S : 1 C $ //,' ARIMA SERIES',/,' (Corrected by TRAMO)',/ C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 $ ' ARIMA SERIES',/,' (Corrected by regARIMA)',/ C END OF CODE BLOCK $ ' "Original Series" FOR SEATS') write (Nio,7004) end if C if ((noserie.eq.0) .and. (Out.eq.0)) then ncen = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(oz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 * call profiler(2,'before TABLE2') call TABLE2(oz) C END OF CODE BLOCK if ((Neff(2) .eq. 1).and.(centrregs.eq.1)) then write (Nio,'(/,4x,''DETERMINISTIC EFFECTS ASSIGNED '', $''TO THE SEASONAL COMPONENT'',/,4x,''HAVE BEEN CENTERED.'')') ncen = 1 end if if ((Neff(2) .eq. 1).and.(centrregs.eq.0)) then write (Nio,'(/,4x,''DETERMINISTIC EFFECTS ASSIGNED '', $''TO THE SEASONAL COMPONENT'',/,4x,''HAVE NOT BEEN CENTERED.'')') end if if ((Nouir.eq.1).or.(Neff(3).eq.1)) then write (Nio,'(/,4x,''DETERMINISTIC EFFECTS ASSIGNED '', $ ''TO THE IRREGULAR COMPONENT'',/,4x, $ ''HAVE NOT BEEN CENTERED.'')') end if if (Neff(5).eq.1) then write (Nio,'(/,4x,''DETERMINISTIC EFFECTS ASSIGNED '', $''TO THE TRANSITORY COMPONENT'',/,4x, $''HAVE NOT BEEN CENTERED.'')') end if end if C C PRINT OUT INPUT PARAMETERS C if (Bias .eq. 0) then Bias = 1 if (Out .eq. 0) then write (Nio,'(//,2X,''BIAS SET EQUAL TO 1'')') end if end if if (iqm .eq. 999) then if ((Mq.ne.12) .and. (Mq.ne.6) .and. (Mq.ne.4) .and. $ (Mq.ne.3) .and. (Mq.ne.2) .and. (Mq.ne.1) .and. $ (Mq.gt.12)) then iqm = 24 end if if ((Mq.eq.12) .or. (Mq.eq.6)) then iqm = 24 end if if (Mq .eq. 4) then iqm = 16 end if if (Mq .eq. 3) then iqm = 12 end if if ((Mq.eq.1) .or. (Mq.eq.2)) then iqm = 8 end if end if if ((Out .eq. 0) .or. (Noserie .eq. 1)) then write (Nio,'(/,2x,''INPUT PARAMETERS'',/2x, $ ''----------------'')') write (Nio,'(/2x,''LAM='',i2,8x,''IMEAN='',i2,8x, $ ''RSA='',i2,8x,''MQ='',i2)') Ilam, Imean, Rsa, Mq write (Nio,'(2x,''P='',i2,10x,''BP='',i2,11x,''Q='',i2,10x, $ ''BQ='',i2)')P, Bp, Q, Bq write (Nio,'(2x,''D='',i2,10x,''BD='',i2,11x, $ ''NOADMISS='',i2,3x,''RMOD='',f8.3)') $ D, Bd, Noadmiss, Rmod write (Nio,'(2x,''M='',i2,10x,''QMAX='',i2,9x, $ ''BIAS='',i2)') M, qmax, Bias write (Nio,'(2X,''THLIM='',F7.3,2X,''THLIM='',F7.3, $ 2x,''IQM='',i3,7x,''OUT='',i3)') thlim,bthlim, $ Iqm,Out write (Nio,'(2X,''EPSPHI='',F6.3,1X,''MAXIT='',i3,7x, $ ''XL='',f7.3,4x,''STOCHTD='',i2)') $ epsphi,Maxit,Xl,StochTD end if cc * if (out.eq.0 .and. pg.eq.0 .and. iter.eq.0) then *c calculamos el espectro del modelo de tramo y generamos el fichero spect.t3 ** call profiler(2,'before PLOTOrigSpectrum') * call PLOTOrigSpectrum(p,d,q,bp,bd,bq,mq,Th,Phi,BTh,BPhi) * end if c c if ((out.eq.0).and.(tramo.ne.0)) then c call ShowFirstModel(HTML,Nio,p,d,q,bp,bd,bq,th, c $ Bth,phi,Bphi,imean) c end if * ntry = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 6 c if ((Rsa.eq.1) .or. (Rsa.eq.2)) then c ntry = 1 C call OPENDEVSCRATCH(12) C Nio = 12 C Nidx = 12 c end if C END OF CODE BLOCK c Llamamos a rutina para cambiar modelos iniciale de tramo no apropiados * call profiler(2,'before changemodel (1)') * CALL outARMAParam() auxInt=changemodel(nio,init,nochmodel,statseas,posbphi, $ rmod,p,d,q,bp,bd,bq,th,bth,phi,bphi,imean, $ remMeanMCS,out,tramo,inputModel) * call profiler(2,'after changemodel (1)') * CALL outARMAParam() c c c4000 if ((Tramo.ne.0) .and. (Init.eq.2) .and. (Rsa.ne.1) .and. C $ (Rsa.ne.2) .and. (nochmodel.eq.0)) then C call OPENDEVSCRATCH(12) C Nio = 12 C Nidx = 12 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 4 C if ((Tramo.ne.0) .and. (Init.eq.2)) then C call OPENDEVSCRATCH(42) C Nio = 42 C Nidx = 42 C END OF CODE BLOCK C noretry = 0 C end if 4000 do i=1,n10 fixParam(i)=0 enddo do 10 while (.true.) C LINES OF CODE COMMENTED FOR X-13A-S : 3 C if ((Nio.eq.12) .and. (Noadmiss.eq.2)) then C Nio = ndevice C call CLOSEDEVICE(12) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 3 if ((Nio.eq.42) .and. (Noadmiss.eq.2)) then Nio = ndevice call CLOSEDEVICE(42) C END OF CODE BLOCK end if * if (ncrazy .eq. 1) then * write (NIO,'(//,2x,"A PURE (SEASONAL) MA IMPLIES A ", * $"SMALL AND SHORT-LIVED SEASONAL CORRELATION.",/2x, * $" SEASONALITY IS TOO WEAK AND UNSTABLE TO BE RELIABLY CAPTURED.", * $/2x,"SEASONAL COMPONENT MADE ZERO")') * ncrazy = 0 * end if C C TEST P AND Q AGAINST CONSTRAINTS C if (P .le. 3*n1) then if (Q .le. 3*n1) then C C NOW WE CHECK IF THE MODEL IS DEGENERATE (TILL 87) C if (Init.ne.0 .and. Q.ne.0 .and. P.eq.Q) then do i = 1,Q if (ABS(Th(i)-Phi(i)) .gt. ceps) THEN * call profiler(2,'**GO TO 5000**, line 1739') goto 5000 end if end do * call profiler(2,'**GO TO 5015**, line 1743') goto 5015 end if C C TEST BP,BQ AGAINST CONSTRAINTS C 5000 if (Bp .le. 2*n1) then if (Bq .le. 2*n1) then C C WE CHECK ALSO IF THE SEASONAL PART IS DEGENERATE (TILL 93) C if (Init.ne.0 .and. Bq.ne.0 .and. Bp.eq.Bq) then do i = 1,Bq if (ABS(Bth(i)-Bphi(i)) .gt. ceps)THEN * call profiler(2,'**GO TO 5001**, line 1757') goto 5001 END IF end do * call profiler(2,'**GO TO 5016**, line 1761') goto 5016 end if 5001 do i = 1,10 xmin(i) = -Xl xmax(i) = Xl end do C C TRANSFORM INPUT DEPENDING ON LAMDA C Pbp = P + Bp Pq = Pbp + Q mq2 = Mq * 2 Bpq = P + Q + Bp + Bq nx = Bpq Pstar = P + Bp*Mq Qstar = Q + Bq*Mq if (noserie .ne. 1) then if ((Mq.ne.12) .and. (Mq.ne.6) .and. (Mq.ne.4) .and. $ (Mq.ne.3) .and. (Mq.ne.2) .and. (Mq.ne.1) .and. $ (Mq.gt.12)) then write (*,'(//,8X,A,//)') $'FREQUENCY OF OBSERVATIONS NOT APPROPIATE FOR SEATS' Iq = 24 end if if (iqm .eq. 999) then if ((Mq.ne.12) .and. (Mq.ne.6) .and. (Mq.ne.4) $ .and.(Mq.ne.3) .and. (Mq.ne.2) .and. (Mq.ne.1) $ .and.(Mq.gt.12)) then write (Nio,'(//,8X,A,//)') $ 'FREQUENCY OF OBSERVATIONS NOT APPROPIATE FOR SEATS' iqm = 24 end if if ((Mq.eq.12) .or. (Mq.eq.6)) then iqm = 24 end if if (Mq .eq. 4) then iqm = 16 end if if (Mq .eq. 3) then iqm = 12 end if if ((Mq.eq.1) .or. (Mq.eq.2)) then iqm = 8 end if end if if (M .ge. Nz-(D+Bd*Mq)) then M = (Nz-(D+Bd*Mq)) if (iqm .ge. M) then iqm = M - 2 end if if (iqm .lt. P+Bp+Q+Bq+Imean) then iqm = M end if end if if ((M.lt.Mq) .or. (iqm.le.0) .or. $ (Nz-(D+Bd*Mq+P+Bp*Mq).le.0)) THEN * call profiler(2,'**GO TO 5017**, line 1818') goto 5017 END IF if (iqm .gt. M) then iqm = M end if Iq = iqm if (Ilam .eq. 0) then do i = 1,Nz if (oz(i) .le. 0) THEN * call profiler(2,'**GO TO 5002**, line 1828') goto 5002 END IF end do do i = 1,Nz z(i) = LOG(oz(i)) end do if (Out .eq. 0) then write (Nio,'(/'' TRANSFORMATION: Z -> LOG Z'')') end if * call profiler(2,'**GO TO 5003**, line 1838') goto 5003 5002 Ilam = 1 write (Nio, $'(/4X,''Ilam CHANGED TO 1 SERIES HAS NEGATIVE VALUES'',/) $ ') end if do i = 1,Nz z(i) = oz(i) end do ! if (Out .eq. 0) then ! write (Nio,'(/,'' TRANSFORMATION: Z -> Z'')') ! end if C C SET VARIOUS PARAMETERS C 5003 Pbp = P + Bp Pq = Pbp + Q mq2 = Mq * 2 Bpq = P + Q + Bp + Bq nx = Bpq Pstar = P + Bp*Mq Qstar = Q + Bq*Mq C C MEAN AND VARIANCE CALCULATED. DIFFERENCING OF THE Z SERIES C if (noserie .ne. 1) then Nw = Nz zm = 0.0d0 do i = 1,Nz zm = zm + z(i) Wd(i) = z(i) end do zm = zm / Nz Zvar = 0.0d0 do j = 1,Nz Zvar = Zvar + (z(j)-zm)**2 end do Zvar = Zvar / Nz ! if ((Ilam.eq.0) .and. (noserie.eq.0) .and. ! $ (Pg.eq.0) .and. (Out.ne.2)) then ! fname = 'RSERIE.T' ! if (Mq .eq. 12) then ! subtitle = 'SERIES MONTHLY RATE of GROWTH ( % )' ! end if ! if (Mq .eq. 4) then ! subtitle = 'SERIES QUARTERLY RATE of GROWTH ( % )' ! end if ! if ((Mq.ne.12) .and. (Mq.ne.4)) then ! subtitle = 'SERIES RATE of GROWTH in PERIOD ( % )' ! end if ! do i = 2,Nw ! bz(i-1) = 100.0d0 * (Wd(i)-Wd(i-1)) ! end do ! nyer2 = Nyer ! nper2 = Nper ! Nper=Nper+1 ! if (Nper .gt. Mq) then ! Nper = 1 ! Nyer = Nyer + 1 ! end if ! call PLOTSERIES(fname,subtitle,bz,Nw-1,1,0.0d0) ! Nyer = nyer2 ! Nper = nper2 ! end if if (Bd .ne. 0) then do i = 1,Bd Nw = Nw - Mq do j = 1,Nw Wd(j) = Wd(j+Mq) - Wd(j) end do end do end if if (D .ne. 0) then do i = 1,D Nw = Nw - 1 do j = 1,Nw Wd(j) = Wd(j+1) - Wd(j) end do end do end if Nwdif=Nw do i=1,Nw Wdif(i)=Wd(i) enddo C C MEAN CORRECT Wd SERIES IF IMEAN = 1 C wmDifXL = 0.0d0 if ((crmean.eq.0) .or. (MOD(Nw,Mq).eq.0)) then do j = 1,Nw wmDifXL = wmDifXL + Wd(j) end do wmDifXL = wmDifXL / Nw else nn = Nw - MOD(Nw,Mq) do j = 1,nn wmDifXL = wmDifXL + Wd(j) end do wmDifXL = wmDifXL / nn end if wm=wmDifXL if (Imean.ne.0 .or. D.ne.0) then if (Imean .ne. 0) then do j = 1,Nw Wd(j) = Wd(j) - wmDifXL end do do j = 1,Nw WDifCen(j) = Wd(j) end do end if end if ImeanOut=Imean C C CALCULATE VARIANCE OF NONDIFFERENCED SERIES AND DIFFERENCED SERIES C 5004 VdifXL = 0.0d0 do i = 1,Nw VdifXL = VdifXL + Wd(i)*Wd(i) end do VdifXL = VdifXL / Nw if (Nio .eq. ndevice) then dvec(1)=wmDifXL call USRENTRY(dvec,1,1,1,1,1024) end if if (M .gt. 48) then if (Out .eq. 0) then 7011 format ( $ /,' ONLY ALLOWS 48 AUTOCORRELATIONS-',i4, $ ' IS TOO MANY') write (Nio,7011) M end if M = 48 end if if (Imean .eq. 0) then wm = 0.0d0 end if * end if * call AUTO(Nw,Wd,M,r,0,Nw,Bpq,Nfreq,0,Qstat,df,se,Ierr, * $ Errext) * call profiler(2,'before AUTO') call AUTO(Nw,Wd,M,rXL,0,Nw,Bpq,Nfreq,0, $ QstatXL,df,seRxl,Ierr,Errext) IF(Ierr.eq.1)RETURN do i=1,m r(i)=rXL(i) enddo if (Nio .eq. ndevice) then call USRENTRY(r,1,m,1,5*n10,2163) end if iout = Out * call profiler(2,'before PART') call PART(Nw,M,rXL,iout,partAcf,SEpartAcf) end if end if C C INITIALIZE DETPRI C if (model .eq. 1) then call setTmcs('Y') end if Detpri = 1.0d0 Inoadmiss = 0 C C CALCULATE TRANSFORMED VALUES OF MODEL PARAMETERS AND OUTPUT INITIAL C VALUES OF MODEL PARAMETERS C if (Init .lt. 1) then C C THIS SUBROUTINE COMPUTES THE STARTING VALUES OF ESTIMATION C * call profiler(2,'before STAVAL') * CALL outARMAParam() call STAVAL(P,Q,Bp,Bq,Phi,Th,Bphi,Bth,r,Mq,mq2) * call profiler(2,'after STAVAL') * CALL outARMAParam() end if do 15 while (.true.) if ((noadmiss.eq.2).and.(init.eq.2)) then Pbp = P + Bp Pq = Pbp + Q mq2 = Mq * 2 Bpq = P + Q + Bp + Bq nx = Bpq Pstar = P + Bp*Mq Qstar = Q + Bq*Mq end if C LINES OF CODE COMMENTED FOR X-13A-S : 4 C if ((Nio.eq.12) .and. (Noadmiss.eq.2)) then C Nio = ndevice C Nidx = nidevice C call CLOSEDEVICE(12) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 3 if ((Nio.eq.42) .and. (Noadmiss.eq.2)) then Nio = ndevice * Nidx = nidevice call CLOSEDEVICE(42) C END OF CODE BLOCK end if * call profiler(2,'before TRANS1') * CALL outARMAParam() if (P .ne. 0) then C call CHECKI2(Phi,x,1,P,xl,ur) * call profiler(2,'before TRANS1') call TRANS1(Phi,P,xtmp,xmin,xmax,1,P,out) end if if (Bp .ne. 0) then C call CHECKI2(Bphi,x,P+1,Pbp,xl,ur) * call profiler(2,'before TRANS1') call TRANS1(Bphi,Bp,xtmp,xmin,xmax,P+1,Pbp,out) end if if (Q .ne. 0) then C call CHECKI2(Th,x,Pbp+1,Pq,xl,xl) * call profiler(2,'before TRANS1') call TRANS1(Th,Q,xtmp,xmin,xmax,Pbp+1,Pq,out) end if if (Bq .ne. 0) then C call CHECKI2(Bth,x,Pq+1,Bpq,xl,xl) * call profiler(2,'before TRANS1') call TRANS1(Bth,Bq,xtmp,xmin,xmax,Pq+1,Bpq,out) end if * call profiler(2,'after TRANS1') * CALL outARMAParam() do i=1,nx if (FixParam(i).eq.0) then x(i)=xtmp(i) end if enddo if (Qstar .ne. 0) then do i = 1,Qstar Thstar(i) = 0.0d0 end do end if if (Pstar .ne. 0) then do i = 1,Pstar Phist(i) = 0.0d0 end do end if C C OUTPUT INITIAL VALUES OF TRANSFORMED PARAMETERS AND BOUNDS C PARAMETERS ARE CONSTRAINED TO NOT QUITE REACH BOUNDARIES OF C STABILITY/INVERTIBILITY OF MODEL C cc c Spectral Analysis Linearized Series cc if ((noserie.ne.1).and.((mq.eq.4).or.(mq.eq.12))) then do i = 1,61 Szz(i) = 0.0d0 ow(i) = 0.0d0 end do cname='Linealized Series ' * call profiler(2,'before SpectrumComputation') * CALL outARMAParam() call SpectrumComputation(z,nz,mq,cname,'Xl',0,1, $ PicosXl,totalSeasXL) * call profiler(2,'after SpectrumComputation') * CALL outARMAParam() end if cc c cc if (Init .eq. 2) then C C RESIDUALS $ STANDARD ERROR IF PARAMETERS NOT ESTIMATED, INIT=2 C if (noserie .eq. 1) THEN * call profiler(2,'**GO TO 5008**, line 2096') goto 5008 END IF Jfac = 1 Na = Nw - Pstar + Qstar Dof = Nw - Pstar - nx - Imean * call profiler(2,'before CALCFX, line 2102') * CALL outARMAParam() call CALCFX(nx,x,s,Na,a,Ierr,Errext,out,*5007) * call profiler(2,'**CALCFX: DID NOT GO TO 5007**') * CALL outARMAParam() if (Ierr.ne.0) then Dstdres(ntrace) = -99999.99 TrTitle(ntrace) = titleg ntrace = ntrace + 1 handle=1 Ierr=0 Errext='' * call profiler(2,'**GO TO 5020**, line 2112') goto 5020 call closealls() return end if 5007 s = s / Detpri**2 f = s / Dof Sqf = SQRT(f) else C C SET PARAMETERS FOR SEARCH C E(I) INDICATES FIXED RANGES. CONV1(I) IS NOT USED. C TEST FOR MODELS WITH CONSTRAINED COEFFICIENTS C do i = 1,nx if (fixParam(i).eq.0) then e(i) = 0 else if (fixParam(i).eq.1) then e(i) = 1 end if conv1(i) = 0.0 end do if (P .gt. 1) then kkp = P - 1 do i = 1,kkp if (ABS(Phi(i)) .gt. ceps) THEN * call profiler(2,'**GO TO 5005**, line 2138') goto 5005 END IF end do do i = 1,kkp e(i) = 1 end do end if 5005 if (Q .gt. 1) then kq = Q - 1 do i = 1,kq if (ABS(Th(i)) .gt. ceps)THEN * call profiler(2,'**GO TO 5006**, line 2150') goto 5006 END IF end do do i = 1,kq e(Pbp+i) = 1 end do end if 5006 Na = Nw - Pstar + Qstar Ifac = 0 Jfac = 0 C C TST IS A FLAG TO TEST IF SOME PARAMETERS ARE FIXED C tst = 0 if ((Nreestimated.eq.0) .and. (Tramo.eq.1) .and. $ (Nio.eq.ndevice)) then Nreestimated = 1 end if * call profiler(2,'before SEARCH, line 2169') * CALL outARMAParam() call SEARCH(nx,x,xmin,xmax,epsiv,e,conv1,Na,a,s,maxit, $ maxf,iprint,se,c,tst,Pbp,p,ur,Out,ItnSearch, $ bd,d,Ierr,Errext,*5119) * call profiler(2,' **SEARCH: DID NOT GO TO 5119**') * CALL outARMAParam() if (Ierr.ne.0) then Dstdres(ntrace) = -99999.99 TrTitle(ntrace) = titleg ntrace = ntrace + 1 handle=1 Ierr=0 Errext='' * call profiler(2,'**GO TO 5020**, line 2181') goto 5020 call closealls() return else IfnSearch=Ifn FIsearch=S do i=1,nx xSearch(i)=x(i) Esearch(i)=E(i) enddo nxSearch=nx end if if (Nhtofix .eq. 1) then x(P+Bp+Q) = -Xl Nhtofix = 0 end if if (tst .gt. 0) then * call profiler(2,'before CHMODEL, line 2199') * CALL outARMAParam() call CHMODEL(x,se,nx,P,Q,Bp,Bq,D,Bd,Wd,Nw,wm,VdifXL, $ Mq,ur,Xl,Phi,tst,Imean,seas,Pbp,Pq,Bpq,Pstar, $ z,Nz,out,*10) * call profiler(2,'**CHMODEL: DID NOT GO TO 10**') * CALL outARMAParam() Pbp = P + Bp Pq = Pbp + Q Bpq = P + Q + Bp + Bq Pstar = P + Bp*Mq end if C C Chequeo por si APPROXIMATE o chmodel nos dan un modelo que no queremos (muy poco probable) C lo metemos por si acaso pero podríamos quitarlo * call profiler(2,'before changemodel (2)') * CALL outARMAParam() if (changemodel(nio,init,nochmodel,statseas, $ posbphi,rmod,p,d,q,bp,bd,bq,th,bth,phi,bphi, $ imean,remMeanMCS,out,tramo,inputModel).gt.0)then * call profiler(2,'**GO TO 10**, line 2216') goto 10 end if * call profiler(2,'after changemodel (2)') * CALL outARMAParam() c if (tst .le. 0) then seMEan = 0.0d0 * call profiler(2,'before CHECK (called from analts)') call CHECK(VdifXL,wm,Nw,Phi,P,Bphi,Bp,Th,Q,Bth,Bq,Mq, $ seMean) end if s = s / Detpri**2 Dof = Nw - Pstar - nx - Imean f = s / Dof Sqf = SQRT(f) dof1 = SQRT((Dof+Qstar)/Dof) do i = 1,nx se(i) = se(i) * dof1 / Detpri end do C C OUTPUT VALUES OF TRANSFORMED PARAMETERS AND THEIR STANDARD ERRORS C OUTPUT CORRELATION MATRIX OF TRANSFORMED PARAMETERS AND FORM C COVARIANCE MATRIX C C if (tst .gt. 0) then seMean=0.0d0 end if tstMean=tst dvec(1)=seMEan call USRENTRY(dvec,1,1,1,1,1025) do i=1,nx do j=1,i cMatrix(i,j)=c(i,j) enddo enddo do i = 1,nx do j = 1,i c(i,j) = c(i,j) * se(i) * se(j) end do end do end if C C CALCULATE DURBIN-WATSON STATISTIC C sfd = 0.0d0 do i = 2,Na sfd = sfd + (a(i)-a(i-1))**2 end do sfd = sfd / Detpri**2 dw = sfd / s C C MODEL PARAMETERS ,CALCULATE THEIR STANDARD ERRORS IN VAR C SUBROUTINE C 5008 if (Init .ne. 2) then * call profiler(2,'before VARMP') call VARMP(x,c,P,sePHI,1,P) call VARMP(x,c,Bp,seBPHI,P+1,Pbp) call VARMP(x,c,Q,seTH,Pbp+1,Pq) call VARMP(x,c,Bq,seBTH,Pq+1,Bpq) else do i = 1,P sePHI(i) = 0.0d0 end do seBPHI(1)=0.0d0 do i = 1,Q seTH(i) = 0.0d0 end do seBTH(1)=0.0d0 end if ! of p<>0 call USRENTRY(sePHI,1,P,1,n10,1110) call USRENTRY(seBPHI,1,Bp,1,n10,1112) call USRENTRY(seTH,1,Q,1,n10,1111) call USRENTRY(seBTH,1,Bq,1,n10,1113) c c if (Noadmiss .eq. 2) then c call OPENDEVSCRATCH(18) c niosave = Nio c Nio = 18 c Nidx = 18 c end if if (P .ne. 0) then do i = 1,P phis(i+1) = -Phi(i) end do end if phis(1) = 1.0d0 nphi = P + 1 if (Q .ne. 0) then do i = 1,Q ths(i+1) = -Th(i) end do end if ths(1) = 1.0d0 nth = Q + 1 if (noserie.ne.1 .and. Q.gt.1) then * call profiler(2,'before RPQ') call RPQ(ths,nth,MArez,MAimz,MAmodul,MAar,MApr,1,out) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK end if C C EVEN IF P=1 CALL RPQ BECAUSE SIGEX WANTS THE ROOT IN REZ,IMZ, C MODUL,AR,PR C if (noserie.eq.1) then if (p.gt.0) then * call profiler(2,'before RPQ') call RPQ(phis,nphi,rez,imz,modul,ar,pr,1,out) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK end if goto 5011 else call RPQ(phis,nphi,rez,imz,modul,ar,pr,1,out) C C CORRECT RESIDUALS FOR FACTOR OF DETPRI C do i = 1,Na a(i) = a(i) / Detpri aa(i) = a(i) end do C C COMPUTES THE STATISTCS OF RESIDUAL C if (Type .eq. 1) then rmean = 0.0d0 do i = Qstar+1,Na rmean = rmean + a(i) end do C C WITH CLS THE FIRST QSTAR RESIDUALS ARE ZERO SO TO COMPUTE THE MEAN C AND VARIANCE THE NUMBER OF RESIDUALS NA=NA-QSTAR C rmean = rmean / (Na-Qstar) rvar = 0.0d0 do i = Qstar+1,Na rvar = rvar + a(i)*a(i) end do rvar = rvar / (Na-Qstar) else rmean = DMEAN(Na,a) rvar = DVAR(Na,a) end if rstd = (rvar/Na)**0.5d0 rtval = rmean / rstd C C T-VALUE OF RESIDUALS IS GREATER THEN TA (INPUT PARAMETER) C THE RESIDUALS ARE MEAN CORRECTED C if ((Imean.eq.1) .and. (rtval.gt.ta)) then do i = 1,Na a(i) = a(i) - rmean end do phi1(1) = 1.0d0 do i = 1,P phi1(i+1) = -Phi(i) end do bphi1(1) = 1.0d0 do i = 1,Bp*Mq bphi1(i+1) = 0.0d0 end do if (Bp .gt. 0) then do i = 1,Bp bphi1(i*Mq) = -Bphi(i) end do end if * call profiler(2,'before CONV') call CONV(phi1,P+1,bphi1,1+Bp*Mq,bphi1,lll) th1(1) = 1.0d0 do i = 1,Q th1(i+1) = -Th(i) end do bth1(1) = 1.0d0 do i = 1,Bq*Mq bth1(i) = 0.0d0 end do if (Bq .gt. 0) then do i = 1,Bq bth1(i*Mq) = -Bth(i) end do end if * call profiler(2,'before CONV') call CONV(th1,Q+1,bth1,1+Q*Mq,bth1,lll1) first = 0.0d0 do i = 1,lll first = first + bphi1(i) end do second = 0.0d0 do i = 1,lll1 second = second + bth1(i) end do first = second / first wm = wm + first*rmean if (Out .eq. 0) then 7040 format (//,/,' CORRECTED MEAN OF DIFF. SERIES =', $ d12.4) write (Nio,7040) wm end if if (Type .eq. 1) then rmean = 0.0d0 do i = Qstar+1,Na rmean = rmean + a(i) end do rmean = rmean / (Na-Qstar) rvar = 0.0d0 do i = Qstar+1,Na rvar = rvar + a(i)*a(i) end do rvar = (rvar-rmean**2) / (Na-Qstar) else rmean = DMEAN(Na,a) rvar = DVAR(Na,a) end if rstd = (rvar/Na)**0.5d0 rtval = rmean / rstd end if skewne = 0.0d0 rkurt = 0.0d0 nna = Na if (Type .eq. 1) then nna = Na - Pstar end if do i = 1,Na skewne = skewne + ((a(i)-rmean)**3)/(rvar**1.50d0*nna) rkurt = rkurt + ((a(i)-rmean)**4)/(rvar**2.0d0*nna) end do rvar = rvar / Na test1 = SQRT(6.0d0/Na) test = SQRT(24.0d0/Na) wnormtes = (skewne**2)/(test1**2) + $ ((rkurt-3)**2)/(test**2) nyer2 = Nyer nper2 = Nper nyer1 = Nyer nper1 = Nper + Nz - Na do while (nper1 .gt. Nfreq) nper1 = nper1 - Nfreq nyer1 = nyer1 + 1 end do do while (nper1 .le. 0) nper1 = nper1 + Nfreq nyer1 = nyer1 - 1 end do nz1 = Nz do i=1,Na Resid(i)=a(i) enddo SumSres=s numEresid=na do i = 1,na eresid(i) = a(i) end do call USRENTRY(eresid,1,numEresid,1,MPKP,1100) Nz = nz1 cc c Here Introduce the fitted graph cc * if ((pg .eq. 0).and.(out.lt.2).and.(iter.eq.0)) then ** call profiler(2,'before PlotFitted') * if (tramo.gt.0) then * call PlotFitted(tram,eresid,nz,numEresid,ilam, * $ nyer2,nper2,mq) * else * call PlotFitted(oz,eresid,nz,numEresid,ilam, * $ nyer2,nper2,mq) * end if * end if Nper = nper2 Nyer = nyer2 C C COMPUTES THE STUDENTISED RESIDUAL C * if (Out .eq. 2) then * if (HTML .eq. 1) then * write (Nio,'(''
EXTENDED RESIDUAL'', * $ '' STANDARD ERROR : '',D12.4)') Sqf * write (Nio,'(''
DIAGNOSIS (*)'')') * else * write (Nio, * $'(6X,''EXTENDED RESIDUAL STANDARD ERROR :'',2X,D12.4)') Sqf * write (Nio, * $ '(2X,''DIAGNOSIS (*)'',/,2X,''-------------'')') * end if * nsr = 0 * end if flagTstu = 0 do i = 1,Na aa(i) = a(i) end do Ken = kendalls(a,Na,Nfreq) c 21/08/2009 c if ((Out.eq.0) .and. ((a(i).lt.-Sek).or.(a(i).gt.Sek))) c $ then c nsr = 1 + nsr c if (HTML .eq. 1) then c if (nsr .eq. 1) then c write (Nio,'('''')') c write (Nio,'('''')') Sek c write (Nio,'('''', c $ '''', c $ '''')') c 6042 format ('') c write (Nio,6042) iper, iyear, a(i) * else c write (Nio,6042) iper, iyear, a(i) c end if c write (Nio,'("
OUTLIERS IN EXTENDED '', c $ ''RESIDUALS ( > '',f5.2, c $ '') :
MONTHYEART-VALUE
',i2, c $ '',i4, c $ '',f5.2, c $ '
")') c else c if (nsr .eq. 1) then c write (Nio,'(6x,''OUTLIERS IN EXTENDED '', c $ ''RESIDUALS ( > '',f5.2,'') :'')') Sek c write (Nio, c $ '(42X,''MONTH'',4X,''YEAR'',4X,''T-VALUE'')') c 7042 format (44x,i2,5x,i4,5x,f5.2) c write (Nio,7042) iper, iyear, a(i) c else c write (Nio,7042) iper, iyear, a(i) c end if c end if c end if * if ((Pg.eq.0) .and. (Out.lt.2).and.(iter.eq.0)) then * fname = 'RESID.T' * subtitle = 'EXTENDED RESIDUALS' * Nyer = nyer1 * Nper = nper1 * call PLOTSERIES(fname,subtitle,eresid,numEresid, * $ 555,2.0d0*Sqf) * cname=subtitle * shortName='a ' * if (out.eq.0) then ** call profiler(2,'before SpectrumComputation') * call SpectrumComputation(a,Na,mq,cname,shortName, * $ 1,0,PicosRes,totalSeasRes) * end if * Nyer = nyer2 * Nper = nper2 * end if C C CALCULATE PSI COEFFICIENTS AFTER DIFFERENCING FOR COMPARISONS C OF MODELS C lp = MAX(L,Qstar+1) lp = MIN(lp,5*N12-N12/3) * call profiler(2,'before RATF') call RATF(Thstar,Qstar,Phist,Pstar,ps,lp,1) C C CALCULATE AUTOCORRELATIONS AND PARTIAL AUTOCORRELATIONS OF RESIDUALS C C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call AUTO(Na,a,M,r,Iq,Nw,Bpq,Nfreq,iauto, C $ Qstat,df,sea) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 3 iauto = 1 * call profiler(2,'before AUTO') * call AUTO(Na,a,M,r,Iq,Nw,Bpq,Nfreq,iauto,Qstat,df,sea, * & Ierr,Errext) call AUTO(Na,a,M,r,Iq,Na,Bpq,Nfreq,iauto,Qstat,df,sea, & Ierr,Errext) IF(Ierr.eq.1)RETURN C END OF CODE BLOCK dvec(1)=dble(Iq-Bpq-Imean) call USRENTRY(dvec,1,1,1,1,1000) dvec(1)=Bjstat1 call USRENTRY(dvec,1,1,1,1,1002) dvec(1)=Pstat1 call USRENTRY(dvec,1,1,1,1,1003) call USRENTRY(r,1,M,1,M,2161) * if ((ntry.gt.0) .and. ((Rsa.eq.1).or.(Rsa.eq.2))) then * call AMI(Bjstat1,Sqf,qmax,ntry,P,D,Q,Bp,Bd,Bq,Imean,Mq, * $ Init,Type,Th,Bth,Phi,Bphi,Rmod,Epsphi, * $ status,Noadmiss,prec,out,fixparam,varwnc,*10,*15) *C LINES OF CODE ADDED FOR X-13A-S : 1 * IF(Lfatal)RETURN *C END OF CODE BLOCK * end if if ((Tramo.ne.0) .and. (Init.eq.2) $ .and. (Rsa.eq.0) .and. (Noadmiss.ne.2) .and. $ (noretry.eq.0).and.(nochmodel.eq.0)) THEN * call profiler(2,'**GO TO 5013**, line 2613') goto 5013 END IF if (Out .eq. 0) then sbjstat1 = Bjstat1 sbjstat2 = Bjstat2 spstat1 = Pstat1 end if C call PART(Na,M,r,iout) if (Out .eq. 0) then C C COMPUTES THE RACES TESTS C xmed = DMED(a,Na) * call profiler(2,'before RACES') call RACES(a,Na,xmed,1,tvalRUNS,n_1,n0) dvec(1)=DBLE(Na) call USRENTRY(dvec,1,1,1,1,1008) dvec(1)=tvalRUNS call USRENTRY(dvec,1,1,1,1,1007) end if C C COMMENTED 01-11-1999 C C IF (OUT.NE.2) WRITE(NIO,188) C 188 FORMAT(/' APPROXIMATE TEST OF RUNS ON RESIDUALS ', C $ 'AUTOCORRELATION FUNCTION'/ C $ ' --------------------------------------', C $ '------------------------') C AMED=DMED(R,M) C IF (OUT.NE.2) THEN C CALL RACES(R,M,AMED,1,TVAL) C CALL USRENTRY(M*1.0D0,1,1,1,1,1009) C CALL USRENTRY(TVAL,1,1,1,1,1006) C end if C C C C C COMPUTES SQUARED RESIDUAL C cc c Spectral Analysis Residuals cc if ((mq.eq.4).or.(mq.eq.12)) then do i = 1,61 Szz(i) = 0.0d0 ow(i) = 0.0d0 end do cname='Extended Residuals ' * call profiler(2,'before SpectrumComputation') call SpectrumComputation(a,Na,mq,cname,'At',0,0, $ PicosRes,totalSeasRes) end if cc c cc do i = 1,Na ba(i) = a(i)**2 end do C C CALCULATE AUTOCORRELATIONS AND PART. AUTOCORR. OF SQUARED RESIDUALS C if (M.gt.48 .and. Out.ne.2) then write (Nio,7011) M end if M = MIN(M,48) iauto = 1 C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call AUTO(Na,ba,M,sr,Iq,Nw,0,Nfreq,iauto, C $ sQStat,sDF,sSE) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 3 * call profiler(2,'before AUTO') call AUTO(Na,ba,M,sr,Iq,Nw,0,Nfreq,iauto,sQStat,sDF,sSE, & Ierr,Errext) IF(Ierr.eq.1)RETURN C END OF CODE BLOCK dvec(1)=dble(Iq-Bpq-Imean) call USRENTRY(dvec,1,1,1,1,1001) dvec(1)=Bjstat1 call USRENTRY(dvec,1,1,1,1,1004) dvec(1)=Pstat1 call USRENTRY(dvec,1,1,1,1,1005) call USRENTRY(sr,1,M,1,5*n10,2162) if (P+D+Bp+Bd .le. 0) then * call profiler(2,'**GO TO 5013**, line 2701') goto 5018 END IF ilsave = -1 lsig = -1 if (lsig .ne. 0) then C C * if ((THLIM.lt.0.0d0) .or. (BTHLIM .lt. 0.0d0)) then * if (Noadmiss .eq. 2) then * smtr = 0 * if (out.eq.0) then * if (HTML .eq. 1) then * call Snote(Nio) * write (Nio,'(''WHEN THE MODEL IS '', * $ ''APPROXIMATED, SMOOTHING OF THE '', * $ ''TREND-CYCLE IS NOT ALLOWED.'')') * call Enote(Nio) * else * write (Nio,'(//,8x, * $ ''WHEN THE MODEL IS APPROXIMATED,'',/,8x, * $ ''SMOOTHING OF THE TREND-CYCLE IS NOT'',/,8x, * $ ''ALLOWED.'')') * end if * end if * else * call SMOOTHING(p,d,q,bp,bd,bq,mq,smtr,thlim,bthlim, * $ ths,th,bth,bths,thstar) * end if * end if C C qbqMQ=q+bq*mq fhi=max(fh,qbqMQ+max(qbqmq,p+bp*MQ)) if (NOADMISS.eq.-1) then fhi=max(fhi,2*(p+d+MQ*(bp+bd))) end if * call profiler(2,'before FCAST') call FCAST(Phist,Thstar,bphist,bpstar,z,Nz,wm,a,Na, $ lsig,f,ILam,D,Bd,Imean,zaf,fhi,Out,Bias, $ forbias,Noadmiss,alpha) end if if (bp .eq. 2) then * call profiler(2,'**GO TO 5119**, line 2744') goto 5119 end if printBack=.FALSE. if (lsig .ne. -2) then lsig = -2 C C REVERSE SERIES AND DIFFERENCED SERIES WITH PROPER SIGN C jdd = D + Bd kd = (-1)**jdd j = Nw do i = 1,Nw ws = Wd(i) * kd Wd(i) = Wd(Nw-i+1) * kd Wd(Nw-i+1) = ws j = j - 2 if (j .le. 0) THEN * call profiler(2,'**GO TO 5009**, line 2762') goto 5009 end if end do 5009 zab = zaf * kd do i = 1,Nz bz(Nz-i+1) = z(i) end do C C GENERATE BACKWARDS RESIDUALS AND REMOVE FACTOR DETPRI C Jfac = 1 * call profiler(2,'before CALCFX, line 2774') call CALCFX(Bpq,x,s,Na,a,Ierr,Errext,out,*5010) * call profiler(2,'**CALCFX: DID NOT GO TO 5010**') if (Ierr.ne.0) then Dstdres(ntrace) = -99999.99 TrTitle(ntrace) = titleg ntrace = ntrace + 1 handle=1 Ierr=0 Errext='' * call profiler(2,'**GO TO 5020**, line 2784') goto 5020 call closealls() return end if 5010 do i = 1,Na a(i) = a(i) / Detpri end do do i = 1,Na ba(Na-i+1) = a(i) Nz = Na end do printBack=.TRUE. Nz = nz1 qbqMQ=q+bq*mq fhi=max(fh,qbqMQ+max(qbqmq,p+bp*MQ)) if (NOADMISS.eq.-1) then fhi=max(fhi,2*(p+d+MQ*(bp+bd))) end if * call profiler(2,'before FCAST') call FCAST(Phist,Thstar,bphist,bpstar,bz,Nz,wm,a,Na, $ lsig,f,ILam,D,Bd,Imean,zab,fhi,Out,-300, $ forbias,Noadmiss,alpha) end if end if 5011 if (P .ne. 0) then do i = 1,P phis(i+1) = -Phi(i) end do end if phis(1) = 1.0d0 if (Q .ne. 0) then do i = 1,Q ths(i+1) = -Th(i) end do end if ths(1) = 1.0d0 if (Bp .ne. 0) then do j = 1,Bp bphis(Mq*j+1) = -Bphi(j) do i = (j-1)*Mq+2,j*Mq bphis(i) = 0.0d0 end do end do end if bphis(1) = 1.0d0 if (Bq .ne. 0) then do i = 1,Bq j = i*Mq + 1 bths(j) = -Bth(i) do k = 2,Mq jk = k + Mq*(i-1) bths(jk) = 0.0d0 end do end do end if bths(1) = 1.0d0 * if (Noadmiss .eq. 2) then C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call CLOSEDEVICE(18) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 * call CLOSEDEVICE(38) C END OF CODE BLOCK * Nio = niosave * Nidx = nidevice * end if if (Noadmiss .ne. 2) then if ((matopened) .and. (Iter .gt. 0)) then write(buffS,'(i4,x,A)') niter,mattitle(1:22) end if end if c Inicializamos nPeakSA * call profiler(2,'before PicosReset') call PicosReset(picosSA) call PicosReset(picosIr) call PicosReset(picosTr) c c call OutPart2(nio,nidx,HTML,z,nz,ILam,ImeanOut,noserie,Pg,Out, c $ iter,Itab,Iid,p,D,q,bp,BD,bq,Nper,Nyer,mq, c $ Wdif,WdifCen,nwDif,WmDifXL,Zvar,VdifXL, c $ QstatXL,df,rXL,seRxl,M,partACF,sePartACF,model, c $ PicosXL,init,tstmean,Wm,seMean,nx,Cmatrix, c $ PHI,TH,BPHI,BTH,sePHI,seTH,seBPHI,seBTH, c $ MArez,MAimz,MAmodul,MAar,MApr, c $ rez,imz,modul,ar,pr) c C Modified by REG on 30 Aug 2005 to add nfixed to SIGEX parameter list * call profiler(2,'before SIGEX') * write(Mtprof,*)' nio = ',nio * write(Mtprof,*)' out = ',out * write(Mtprof,*)' ItnSearch = ',ItnSearch * write(Mtprof,*)' IfnSearch = ',IfnSearch * write(Mtprof,*)' FIsearch = ',FIsearch * write(Mtprof,*)' nxSearch = ',nxSearch * do j=1,nxSearch * write(Mtprof,*)' xSearch(',j,'), Esearch(',j,') = ',xSearch(j), * * Esearch(j) * end do qstar_seats=qstar pstar_seats=pstar * call profiler(2,'before SIGEX, line 2908') * write(Mtprof,*) ' z(1) = ',z(1) call SIGEX(z,bz,oz,a,aa,forbias,Ilam,P,D,Q,Bp,Bd,Bq,Mq, $ phis,bphis,ths,bths,zaf,zab,imz,rez,modul,ar,fh,fhi, $ noserie,Init,Imean,phi,bphi,Th,Bth,status,hpcycle, $ rogtable,hplan,HPper,maxSpect, $ Type,alpha,acfe,posbphi,printphtrf,tabtables, $ IOUT,Ndevice,printBack,ba,sr,SQSTAT,SDF,SSE,m, $ n_1,n0,tvalRUNS,Qstat,DF,Pstat1,spstat1, $ wnormtes,wsk,skewne,test1,wkk,rkurt,test,r,SEa, $ Resid,flagTstu,it,iper,iyear, $ rmean,rstd,DW,KEN,RTVAL,SumSres,F,Nyer1,Nper1, $ Pstar_seats,Qstar_seats,InputModel, $ niter,mattitle,Lgraf,nfixed,IsCloseToTD,FixParam,x, $ ImeanOut,Wdif,WdifCen,nwDif,WmDifXL,VdifXL, $ QstatXL,rXL,seRxl,partACF,sePartACF,model, $ PicosXL,tstmean,Wm,seMean,nx,Cmatrix, $ sePHI,seTH,seBPHI,seBTH, $ MArez,MAimz,MAmodul,MAar,MApr,pr,outNA,stochTD, $ ItnSearch,IfnSearch,nxSearch,Esearch, $ FIsearch,xSearch,varwnc,numSer,remMeanMCS,*10,*15) * call profiler(2,'SIGEX: did not go to 10 or 15') * call profiler(2,'before addToSumS') * write(*,*) ' TRAMO,fh = ',Tramo,fh call addToSumS(mq,IsCloseToTD,crQs,crSNP,crPeaks,.false.) if (IsCloseToTD) then aux1=0.0d0 aux2=getSdc() else aux1=getSdc() aux2=0.0d0 end if if ((matopened) .and. (Iter .eq. 0)) then * call profiler(2,'before wrHeadTGenSumS') call wrHeadTGenSumS(65) write (65, 6507) $ getPat(),getTmcs(), $ getAna(),getNmmu(),getNmp(),getNmd(),getNmq(), $ getNmBp(),getNmBd(),getNmBq(),getSd(),Ken, $ getSf(),getCvar(),getCcc(),getCmtTc(),getCmtS(), $ getCmtIR(),getCmtTs(),getCmtSA() 6507 format(7x,A,6x,A,8x,A,4x,I1,4x,I1,4x,I1, $ 4x,I1,5x,I1,5x,I1,5x,I1,2x,g11.4,5x,g11.4,5x,A,7x,A, $ 7x,A,2x,A,1x,A,x,A,5x,A,2x,A) write (65,*) write (65,*) if (IsCloseToTD) then auxS='stocTD' else auxS='Trans ' end if write (65,*)' Decomposition : Standard Errors' write (65,*) write (65,6508) 6508 format(26x,'SD(innov)',28x,'SE Est.',16x,'SE Rev.') write (65,6509) 6509 format(63x,'(Conc.)',16x,'(Conc.)') write (65,6510)auxS 6510 format(8x,'TC',9x,'S',5x,A6,8x, $ 'U',8x,'SA',11x,'TC',8x,'SA',11x,'TC',8x, $ 'SA') write (65,6511)getSdt(),getSds(), $ getSdc(),getSdi(),getSdSa(), $ getSeCect(),getSeCecSa(), $ getRseCect(),getRseCecSa() 6511 format(5x,g11.4,1x,g11.4,1x,g11.4,1x,g11.4,1x, $ g11.4,4x,g11.4,x,g11.4,4x,g11.4,x,g11.4) write (65,*) write (65,*)' SE : Rates of Growth' write (65,6512) 6512 format( 9x,'SE T11',19x,'SE T1Mq') write (65,6513) 6513 format(6x,'(One Period)',11x,'(Annual Centered)') write (65,6514) 6514 format(8x,'TC',8x,'SA',9x,'X',8x,'TC',8x,'SA') write (65,6515)getT11t(),getT11Sa(),getT112x(), $ getT112t(),getT112Sa() 6515 format(1x,f9.2,1x,f9.2,1x,f9.2,1x,f9.2,1x,f9.2) write (65,*) write (65,*) c * call profiler(2,'before wrHeadTparIISumS') call wrHeadTparIISumS(65) write (65,6516)getCovt1(),getCovSa1(), $ getCovt5(),getCovSa5(), $ getSsh(),getSsp2(),getSsp2(), $ getDaat(),getDaaSa() 6516 format(5x,f9.1,1x, $ f9.1,1x,f9.1,1x,f9.1,11x,I2,8x,I2,8x,I2, $ 4x,f9.2,1x,f9.2) c if ((mq.eq.12) .or. (mq.eq.4)) then * call profiler(2,'before tablaPicos') call tablaPicos(65,picosSA,picosTr,picosIr,mq, $ totalSeasTR,totalSeasSA, $ totalSeasIR) call wrResidSeasTest(OST,crQs,crSNP,crPeaks,65) end if c escribimos los modelos de los componentes write(65,*) write(65,*) write(65,*) write(65,*)' Model for the components:' write(65,*) write(65,*) if (lu61.ne.' ') then write(65,6517) 'Trend-cycle:' write(65,6517) lu61(1:istrlen(lu61)) write(65,*) 6517 format(2x,A) end if if (lu62.ne.' ') then write(65,6517)'Seasonal:' write(65,6517) lu62(1:istrlen(lu62)) write(65,*) end if if (lu63.ne.' ') then write(65,6517)'SA series:' write(65,6517) lu63(1:istrlen(lu63)) write(65,*) end if if (lu64.ne.' ') then if (IsCloseToTD) then write (65,6517)'TD stoch.:' else write (65,6517)'Transitory:' end if write (65,6517) lu64(1:istrlen(lu64)) write(65,*) end if if (lu64I.ne.' ') then write (65,6517)'Irregular:' write (65,6517) lu64I end if else if ((matopened) .and. (Iter .gt. 0)) then write (65,6518) $ niter, mattitle(1:22), getPat(),getTmcs(), $ getAna(),getNmmu(),getNmp(),getNmd(),getNmq(), $ getNmBp(),getNmBd(),getNmBq(),getSd(),Ken, $ getSf(),getCvar(),getCcc(),getCmtTc(),getCmtS(), $ getCmtIR(),getCmtTs(),getCmtSA() 6518 format(i4,3x,a,3x,a,6x,a,8x,a,4x,i1,4x,i1,4x,i1, $ 3x,i1,5x,i1,5x,i1,5x,i1,4x,g11.4,5x,g11.4, $ 3x,a,7x,a,6x,a,3x,a,1x,a,1x,a,5x,a,2x,a) write (66, 6606)niter,mattitle(1:22), $ getSdt(),getSds(), $ aux1,aux2,getSdi(),getSdSa(), $ getSeCect(),getSeCecSa(), $ getRseCect(),getRseCecSa(), $ getT11t(),getT11Sa(), $ getT112x(),getT112t(),getT112Sa() 6606 format(i4,3x,a,6(x,g11.4),4x,g11.4,1x,g11.4,4x, $ g11.4,1x,g11.4,1x,f9.2,1x,f9.2,5x, $ g9.2,1x,g9.2,1x,g9.2) write (67,6706)niter,mattitle(1:22), $ getCovt1(),getCovSa1(), $ getCovt5(),getCovSa5(), $ getSsh(),getSsp2(),getSsp2(), $ getDaat(),getDaaSa() 6706 format(i4,3x,a,1x,f9.1,1x, $ f9.1,1x,f9.1,1x,f9.1,11x,I2,8x,I2,8x,I2, $ 4x,f9.2,1x,f9.2) if ((mq.eq.12) .or. (mq.eq.4)) then * call profiler(2,'before wrLnTabPeaks') call wrLnTabPeaks(69,niter,matTitle,picosSA,1) call wrLnTabPeaks(72,niter,matTitle,picosIr,1) call wrLnTabPeaks(73,niter,matTitle,picosTr,1) end if call Mtx1Reset() call Mtx2Reset() end if if (kunits .ne. 0) then if (out.eq.0) then write (Nio, '(//,4x,A,A,i2,A,//)') $ 'WARNING : to recover the units of the original ', $ 'input file, the series should be multiplied by 10**', $ -3*kunits,'.' end if end if if ((Tramo .eq. 0) .and. (UNITS.eq.1)) then if ((sunits.gt.0).and.(Out. eq. 0)) then write (Nio,'(/,4x,A,A)') $ 'WARNING : To recover the units of the ', $ ' original input file' write (Nio,'(4x,A,A,i2,A)') $ 'the series should be multiplied by ', $ '10**',3*sunits,'.' end if if ((sunits.lt.0) .and. (Out .eq. 0)) then write (Nio,'(/,4x,A,A)') $ 'WARNING : To recover the units of the ', $ ' original input file' write (Nio,'(4x,A,A,i2,A)') $ 'the series should be divided by ', $ '10**',-3*sunits,'.' end if end if * call profiler(2,'GO TO 5119, line 3072') goto 5119 15 continue c 6050 format ('WHEN BPHI > 0, THE SEASONAL COMPONENT', $ ' CANNOT BE PROPERLY DEFINED.
', $ 'MODEL IS MODIFIED ACCORDINGLY.') 7050 format ( $ /,2x,'***********************************************', $ /,2x,'WHEN BPHI > 0, THE SEASONAL COMPONENT CANNOT BE', $ /,2x,'PROPERLY DEFINED.',/,2x, $ 'MODEL IS MODIFIED ACCORDINGLY.',/,2x, $ '***********************************************') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C 5013 if ((Bjstat1.gt.1.5d0*blqt) .and. (Bjstat1.gt.qmax)) then C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 5013 if ((Bjstat1.gt.1.5d0*blqt) .and. & (Bjstat1.gt.dble(qmax))) then C END OF CODE BLOCK if ((Imean.eq.1) .and. (ABS(tmu).lt.1.90d0) .and. $ (nprova.eq.0)) then imeansave = Imean Imean = 0 nprova = 1 else Init = 0 if (nprova .eq. 1) then nprova = 0 Imean = imeansave end if noretry = 1 call CLOSEDEVICE(42) Nio = ndevice * Nidx = nidevice WRITE(NIO,623)BJSTAT1,QMAX 623 FORMAT(//,2x,'RESETTING INIT = 0 BECAUSE RESIDUAL', & ' LJUNG-BOX Q (',F12.3,') > QMAX (',I5,')') end if else noretry = 1 call CLOSEDEVICE(42) Nio = ndevice * Nidx = nidevice end if * call profiler(2,'GO TO 10, line 3117') goto 10 else write (Nio,'(/,2X,'' BQ GREATER THAN '',I1)') 2*n1 * call profiler(2,'GO TO 5119, line 3121') goto 5119 end if else write (Nio,'(/,2X,'' BP GREATER THAN '',I1)') 2*n1 * call profiler(2,'GO TO 5119, line 3126') goto 5119 end if else write (Nio,'(/,2X,'' Q GREATER THAN '',I2)') 3*n1 * call profiler(2,'GO TO 5119, line 3131') goto 5119 end if else write (Nio,'(/,2X,'' P GREATER THAN '',I2)') 3*n1 * call profiler(2,'GO TO 5119, line 3136') goto 5119 end if 10 continue 5015 if (Out .eq. 0) then 7051 format ( $ /,' THE INITIAL VALUES OF THETA AND PHI ARE EQUAL ;', $ ' THE MODEL IS DEGENERATE') write (Nio,7051) end if * call profiler(2,'GO TO 5119, line 3146') goto 5119 5016 continue 7052 format ( $ /,' THE INITIAL VALUES OF BTHETA AND BPHI ARE EQUAL ;', $ ' THE MODEL IS DEGENERATE') write (Nio,7052) * call profiler(2,'GO TO 5119, line 3153') goto 5119 5017 continue write (Nio,'(4X,''NOT ENOUGH OBSERVATIONS'')') write (*,'(4X,A)') 'WARNING : POSSIBLE ERROR IN SERIES LENGTH' write (*,'(14X,A,/,14X,A)') $ 'PLEASE CHECK SERIES LENGTH', 'FOR THE SERIES :' write (*,'(14X,A)') Titleg zerr=2.0d0 dvec(1)=zerr call usrentry(dvec,1,1,1,1,-3) if ((matopened) .and. (iter .gt. 0)) then noTratadas=noTratadas+1 call MTX1RESET call MTX2RESET call ErrorLog('NOT ENOUGH OBSERVATIONS',1) write (65,6519) $ niter, mattitle(1:22),'u','u', 'u', $ -1, -1, -1, -1, -1, -1, -1,DONE, DONE, 'u', 'u', 'u', 'u', $ 'u', 'u', 'u', 'u' 6519 format(i4,'$',2x,a,3x,a,6x,a,8x,a,3x,i2,3x,i2,3x,i2,3x,i2,4x, $ i2,4x,i2,4x,i2,2x,f9.0,2x,f9.0,5x,a,7x,a,7x,a,2x,a,1x,a, $ 1x,a,5x,a,2x,a) c call OutNoPar(74,niter,mattitle) NAiter=inputModel-1 call OutPara(74,niter,mattitle,NAiter,ImeanOut, $ p,d,q,bp,bd,bq,phi,bphi,1,th,bth,1, $ qstat,wm,0) write (66,6607) $ niter, mattitle(1:22), DONE, $ DONE, DONE, DONE, DONE, $ DONE, DONE,DONE,DONE, $ DONE, DONE, DONE, DONE, DONE 6607 format(i4,'$',2x,a,1x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0, $ 1x,f9.0,4x,f9.0, $ 1x,f9.0,4x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0,1x, $ f9.0,1x,f9.0) write (67,6707) $ niter, mattitle(1:22),DONE, $ DONE, DONE, $ DONE, $ -1, -1, -1, DONE, DONE 6707 format(i4,'$',2x,a,1x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0,11x,i2, $ 8x,i2,8x,i2,4x,f9.0,1x,f9.0) if ((mq.eq.12) .or. (mq.eq.4)) then call PicosReset(picosSA) call wrLnTabPeaks(69,niter,matTitle,picosSA,1) call PicosReset(picosIr) call wrLnTabPeaks(72,niter,matTitle,picosIr,1) call PicosReset(picosTr) call wrLnTabPeaks(73,niter,matTitle,picosTr,1) end if end if if (Iter .eq. 1) then * call profiler(2,'GO TO 20, line 3207') goto 20 else * call profiler(2,'GO TO 5021, line 3210') goto 5021 end if * 5018 call OutPart2(nio,nidx,z,nz,iLam,ImeanOut,noserie,Pg,Out, * $ iter,Itab,Iid,p,D,q,bp,BD,bq,Nper,Nyer,mq, 5018 call OutPart2(nio,z,nz,iLam,ImeanOut,noserie,Pg,Out, $ iter,p,D,q,bp,BD,bq,Nper,Nyer,mq, $ Wdif,WdifCen,nwDif,WmDifXL,Zvar,VdifXL, $ QstatXL,df,rXL,seRxl,M,partACF,sePartACF,model, $ PicosXL,init,tstmean,Wm,seMean,nx,Cmatrix, $ PHI,TH,BPHI,BTH,sePHI,seTH,seBPHI,seBTH, $ MArez,MAimz,MAmodul,MAar,MApr, $ rez,imz,modul,ar,pr,THstar,.false.) if (out.eq.0) then 7053 format ( $ //,4x,' NO STOCHASTIC DECOMPOSITION IS PERFORMED FOR A ', $ 'NOISE OR PURELY MOVING AVERAGE MODEL', $ /,8x,' P+D+BP+BD>0 IS REQUIRED ') write (Nio,7053) write (Nio,'(//,4x, $ ''STOCHASTIC SA SERIES = LINEARIZED SERIES'')') end if zerr=4.0d0 dvec(1)=zerr call usrentry(dvec,1,1,1,1,-3) c c calculamos componentes y escribimos tablas en tables para Pure MA if (tramo .gt. 0) then if (Ilam .eq. 1) then do i=1,nz+fh trStoch(i) = 0.0d0 seasStoch(i) = 0.0d0 temp(i) = 0.0d0+ PAREG(i,5) trtemp(i) = wm + PAOUTR(i) + PAREG(i,1)+PAREG(i,7) stemp(i) = Paeast(i) + Patd(i) + Pareg(i,2) + Paous(i) satemp(i) = tram(i) - stemp(i) caltemp(i) = PAEAST(i) + PATD(i) + PAREG(i,6) pretemp(i) = tram(i) - oz(i) irtemp(i) = tram(i) - stemp(i) - trtemp(i)-temp(i) end do do i=1,nz+fh irStoch(i)=oz(i)*1000.0d0**dble(-Kunits) enddo else do i=1,nz+fh trStoch(i) = 1000.0d0**dble(Kunits) seasStoch(i) = 1.0d0 temp(i) = 100.0d0* PAREG(i,5) trtemp(i) = Exp(wm) * PAOUTR(i) * PAREG(i,1) * PAREG(i,7) stemp(i) = Paeast(i) * Patd(i) * Pareg(i,2) * $ Paous(i) *100.0d0 satemp(i) = tram(i) / (stemp(i)/100.0d0) caltemp(i) = PAEAST(i) * PATD(i) * PAREG(i,6) irtemp(i) = tram(i) / (stemp(i)/100.0d0) / trtemp(i) end do do i=1,nz pretemp(i) = tram(i) / oz(i) end do do i=nz+1,nz+fh pretemp(i) = tram(i) end do do i=nz+1,nz+fh oz(i) = trStoch(i) end do do i=1,nz+fh irStoch(i)=oz(i)*1000.0d0**dble(-Kunits) enddo end if call USRENTRY(trtemp,1,nz+fh,1,MPKP,1310) call USRENTRY(stemp,1,nz+fh,1,MPKP,1311) call USRENTRY(temp,1,nz+fh,1,MPKP,1313) call USRENTRY(SAtemp,1,nz+fh,1,MPKP,1309) call USRENTRY(IRtemp,1,nz+fh,1,MPKP,1312) call USRENTRY(trStoch,1,nz+fh,1,MPKP,1200) call USRENTRY(seasStoch,1,nz+fh,1,MPKP,1201) call USRENTRY(oz,1,nz+fh,1,MPKP,1203) call USRENTRY(irStoch,1,nz+fh,1,MPKP,1204) if (ITABLE .eq. 1) then call OUTTABLE2(Titleg,tram,trtemp,satemp,stemp,irtemp,temp, $ pretemp,caltemp,eresid,numEresid,temp,temp,0, $ Ilam,1,NZ,mq,2,SUNITS,fh,trStoch,oz,oz, $ IsCloseToTD) end if else if (Ilam .eq. 0) then do i=1,nz+fh temp(i) = 100.0d0 trtemp(i) = Exp(wm) stemp(i) = 100.0d0 satemp(i) = oz(i) / (stemp(i)/100.0d0) caltemp(i) = 1.0d0 irtemp(i) = oz(i) / (stemp(i)/100.0d0) / trtemp(i) pretemp(i) = 100.0d0 end do else do i=1,nz+fh temp(i) = 0.0d0 trtemp(i) = wm stemp(i) = 0.0d0 satemp(i) = oz(i) - stemp(i) caltemp(i) = 0.0d0 pretemp(i) = 0.0d0 irtemp(i) = oz(i) - stemp(i) - trtemp(i) end do end if if (ITABLE .eq. 1) then call OUTTABLE2(Titleg,oz,trtemp,satemp,stemp,irtemp,temp, $ pretemp,caltemp,eresid,numEresid,temp,temp,0, $ ilam,1,NZ,mq,2,SUNITS,fh,trtemp,satemp,satemp, $ IsCloseToTD) end if end if c graficos para los PURE MA * if (pg.eq.0) then * call PlotPureMA(oz,satemp,trtemp,stemp,temp,irtemp,iter,out, * $ ioneout,Ttlset,ntltst) * end if c calculo de rates of growth para pure ma wrmqx1=-1.d0 wrmqa1=-1.d0 c if (((mq.eq.4) .or. (mq.eq.6) .or. (mq.eq.12)) c $ .and.(tramo .gt. 0)) then c if (ilam .eq. 0) then c wrmqx1 = (tram(nz+mq/2)/tram(nz-mq/2)-1.0d0) * 100.0d0 c wrmqa1 = (satemp(nz+mq/2)/satemp(nz-mq/2)-1.0d0) * 100.0d0 c else c wrmqx1 = tram(nz+mq/2) - tram(nz-mq/2) c wrmqa1 = satemp(nz+mq/2) - satemp(nz-mq/2) c end if c end if c escribimos una linea en los ficheros sgeneral, sparamii y sparami (Pure Ma) if (matopened) then if (iter .gt. 0) then c call MTX1RESET c call MTX2RESET call addToSumS(mq,IsCloseToTD,crQs,crSNP,crPeaks,.true.) write (65,6520) $ niter, mattitle(1:22),getPat(),getTmcs(), 'N', $ imean, p, d,q,bp,Bd,bq , $ sqf, ken, '-', '-', '-', '-', $ '-', '-', '-', '-' 6520 format(i4,'^',2x,a,3x,a,6x,a,8x,a,4x,i1,4x,i1,4x,i1, $ 4x,i1,5x,i1,5x,i1,5x, $ i1,4x,g11.4,5x,g11.4,3x,a,7x,a,6x,a,3x,a,1x,a,1x,a, $ 5x,a,2x,a) c call OutNoPar(74,niter,mattitle) write (66,6608) $ niter, mattitle(1:22), 0.000, $ 0.000, 0.000,0.000, sqf, sqf, 0.000, 0.000,0.000,0.000, $ 0, 0, '-','-','-' 6608 format(i4,'^',2x,a,1x,g11.4,1x,g11.4,1x,g11.4,1x,g11.4, $ 1x,g11.4,1x,g11.4,4x,g11.4, $ 1x,g11.4,4x,g11.4,x,g11.4,1x,g11.4,1x,f9.2,9x,a,9x, $ a,9x,a) c write (67,6708) $ niter, mattitle(1:22),0.0,100.0,0.0,100.0, $ 0, 0, 0, 0.00, 0.00 6708 format(i4,'^',2x,a,1x,f9.1,1x,f9.1,1x,f9.1,1x,f9.1,11x,i2, $ 8x,i2,8x,i2,4x,f9.2,1x,f9.2) if ((mq.eq.12) .or. (mq.eq.4)) then call PicosReset(picosSA) call wrLnTabPeaks(69,niter,matTitle,picosSA,1) call PicosReset(picosIr) call wrLnTabPeaks(72,niter,matTitle,picosIr,1) call PicosReset(picosTr) call wrLnTabPeaks(73,niter,matTitle,picosTr,1) c write (69,'(i4,''^'',2x,a,2x,2(8(''-'',6x),3x))') c $ niter,mattitle(1:22) end if call MTX1RESET call MTX2RESET else call wrHeadTGenSumS(65) write (65,6521) $ getPat(),getTmcs(), 'N',imean, p, d,q,bp,Bd,bq , $ sqf, ken, '-', '-', '-', '-','-', '-', '-', '-' 6521 format(7x,a,6x,a,8x,a,4x,i1,4x,i1,4x,i1,4x,i1,5x,i1,5x, $ i1,5x,i1,4x,g11.4,5x,g11.4,3x,a,7x,a,6x,a,3x,a,1x,a,1x,a, $ 5x,a,2x,a) write (65,*) write (65,*) write (65,6501)'Decomposition : Standard Errors' write (65,*) write (65,6522) 6522 format(26x,'SD(innov)',28x,'SE Est.',16x,'SE Rev.') write (65,6523) 6523 format(63x,'(Conc.)',16x,'(Conc.)') write (65,6524) 6524 format(8x,'TC',9x,'S',5x,'Trans',9x, $ 'U',8x,'SA',11x,'TC',8x,'SA',11x,'TC',8x,'SA') write (65,6525) $ 0.000,0.000, 0.000, sqf, sqf, 0.000, 0.000,0.000,0.000 6525 format(5x,g11.4,1x,g11.4,1x,g11.4,1x,g11.4,1x, $ g11.4,4x,g11.4,1x,g11.4,4x,g11.4,1x,g11.4) write (65,*) write (65,*)' SE : Rates of Growth' write (65,6526) 6526 format( 9x,'SE T11',19x,'SE T1Mq') write (65,6527) 6527 format(6x,'(One Period)',11x,'(Annual Centered)') write (65,6528) 6528 format(8x,'TC',8x,'SA',9x,'X',8x,'TC',8x,'SA') write (65,6529)0d0, 0d0, '-','-','-' 6529 format(1x,f9.2,1x,f9.2,9x,a,9x,a,9x,a) write (65,*) write (65,*) c call wrHeadTparIISumS(65) write (65,6530) $ 0.0,100.0,0.0,100.0,0, 0, 0, 0.00, 0.00 6530 format(2x,f8.1,1x,f9.1,1x,f9.1,1x,f9.1,11x,I2,8x,I2,8x,I2, $ 4x,f9.2,1x,f9.2) write (65,*) write (65,*) write (65,*) write (65,6501)'Model is a pure MA. Not decomposed by Seats.' end if end if * call profiler(2,'GO TO 5119, line 3427') goto 5119 5019 if (ilsave .eq. -1) then 7054 format (/,' BP=',i2,',TOO LARGE NO DECOMPOSITION', $ ' IS PERFORMED') write (Nio,7054) Bp end if ENTRY HANDLE_POINT () 5020 Nsfcast = 0 Nsfcast1= 0 if (Handle .eq. 1) then Handle = 0 Nio = Ndevice zerr=1.0d0 dvec(1)=zerr call usrentry(dvec,1,1,1,1,-3) c if (Iter .eq. 0) then c call closealls() c end if if ((matopened) .and. (iter .gt. 0)) then noTratadas=NoTratadas+1 call ErrorLog('SEATS RUN TIME ERROR',1) call NoTreat2(niter,mattitle) end if Outdir = soutdir Graphdir = sgraphdir Nover = inover Ioneout = iioneout outf=soutfile end if 5119 Nsfcast = 0 Nsfcast1=0 if ((Itable.eq.1) .and. (Iter.eq.0)) then call CLOSEDEVICE2(36) end if if (Iter .eq. 2) then * call profiler(2,'GO TO 5022, line 3463') goto 5022 else if (Iter .eq. 1) then niter = niter + 1 itnSearch = 0 if (Ioneout .eq. 0) then call CLOSEDEVICE2(ndevice) end if else * call profiler(2,'GO TO 5023, line 3472') goto 5023 end if * call profiler(2,'GO TO 20, line 3475') go to 20 C C Commented in order to permit the ENTRY Handle_Point C 20 continue 5021 if ((Iter.eq.2) .or. (Iter.eq.3)) then * call profiler(2,'GO TO 25, line 3481') goto 25 else * call profiler(2,'GO TO 5027, line 3484') goto 5027 end if C Modified by REG on 30 Aug 2005 to add nfixed to NMLSTS parameter list 5022 call NMLSTS(Nochmodel,Type,Init,Ilam,Imean,P,D,Q,Bp,Bd,Bq, $ Sqg,Mq,M,iqm,maxit,fh,noserie,Pg,modelsumm, $ Out,seas,Noadmiss,OutNA,StochTD, $ Iter,qmax,Har,Bias,Tramo, $ model,Noutr,Nouir,Nous,Npatd,Npareg,interp,Rsa, $ Fortr,Neast,epsiv,Epsphi,ta,Xl,Rmod, $ blqt,tmu,Phi,Th,Bphi,Bth,thlim,bthlim,crmean,hplan, $ hpcycle,rogtable,centrregs, $ statseas,units,kunits,acfe,posbphi,printphtrf, $ tabtables,psieinic,psiefin, $ StrFobs,StrLobs,HPper,maxSpect,brol,blamda, $ bserie,bmid,bcMark,ODate,OLen,DetSeas, $ nds,Nz,nfixed,4,ifail) IF(Lfatal)RETURN if ((tramo .eq.0) .or. (Tramo .eq. 999))then FirstObs=Date2Idx(StrFobs) if (FirstObs .eq. -1) then FirstObs=1 end if LastObs=Date2Idx(StrLobs) else FirstObs=1 LastObs=-1 end if if (OUT .eq. -1) then if ((ITER .ge. 2) .and. (NumSer .gt. 25)) Then OUT=2 else OUT=0 end if end if SeasCheck = 0 niter = niter + 1 itnSearch = 0 if (Ioneout .eq. 0) then call CLOSEDEVICE(ndevice) end if * call profiler(2,'GO TO 25, line 3525') goto 25 5023 if (Iter .eq. 3) then niter = niter + 1 itnSearch = 0 if (Ioneout .eq. 0) then call CLOSEDEVICE2(ndevice) end if else * call profiler(2,'GO TO 5027, line 3534') goto 5027 end if * call profiler(2,'GO TO 25, line 3537') go to 25 C C Commented in order to permit the ENTRY Handle_Point C 25 continue 7055 format (//,6x,'ERROR IN THE NAMELIST "INPUT" ') 5024 continue write (*,7055) 7056 format (6x,'FOR THE SERIES : ',a,//) write (*,7056) Titleg * call profiler(2,'GO TO 6000, line 3547') go to 6000 5025 continue write (Nio,'(2X,''TYPE SHOULD BE EITHER 0 OR 1 '')') C LINES OF CODE COMMENTED FOR X-13A-S : 4 C 7057 format ( C $ //////,' ',66('* '),/,/,' ',24('* '),'PROCESSING COMPLETED',25( C $ '* '),//,' ',66('* ')) C write (Nio,7057) C END OF CODE BLOCK * call profiler(2,'GO TO 5028, line 3557') goto 5028 5026 continue write (Nio,'(2x,''THE VARIABLE HAS TOO MANY OBSERVATIONS'',/,2x, $ '' ONLY'',i3,'' ARE ALLOWED'')') mp C LINES OF CODE COMMENTED FOR X-13A-S : 1 C write (Nio,7057) C END OF CODE BLOCK write (*,'(4X,A)') 'WARNING : POSSIBLE ERROR IN INPUT FILE' write (*,'(14X,A,/,14X,A)') $ 'PLEASE CHECK SERIES LENGTH', 'FOR THE SERIES :' write (*,'(14X,A)') Titleg C C Ifail .eq.0 C end if C 5027 if (saved) then C Modified by REG on 30 Aug 2005 to add nfixed to NMLSTS parameter list call NMLSTS(Nochmodel,Type,Init,Ilam,Imean,P,D,Q,Bp,Bd,Bq, $ Sqg,Mq,M,iqm,maxit,fh,noserie,Pg,modelsumm, $ Out,seas,Noadmiss,OutNA,StochTD, $ Iter,qmax,Har,Bias,Tramo, $ model,Noutr,Nouir,Nous,Npatd,Npareg,interp,Rsa, $ Fortr,Neast,epsiv,Epsphi,ta,Xl,Rmod, $ blqt,tmu,Phi,Th,Bphi,Bth,thlim,bthlim,crmean,hplan, $ hpcycle,rogtable,centrregs, $ statseas,units,kunits,acfe,posbphi,printphtrf, $ tabtables,psieinic,psiefin, $ StrFobs,StrLobs,HPper,maxSpect,brol,blamda, $ bserie,bmid,bcMark,ODate,OLen,DetSeas, $ nds,Nz,nfixed,3,ifail) IF(Lfatal)RETURN end if if ((tramo .eq.0) .or. (Tramo .eq. 999))then FirstObs=Date2Idx(StrFobs) if (FirstObs .eq. -1) then FirstObs=1 end if LastObs=Date2Idx(StrLobs) FirstObs=1 LastObs=-1 end if * if ((Iter.eq.0) .and. (Out.eq.0).and.html.ne.1) then * write (Nio,7057) * end if C LINES OF CODE COMMENTED FOR X-13A-S : 2 C time1 = X05BAF() C Time = time1 - Time C END OF CODE BLOCK if ((Itable.eq.1) .and. (Iter.ne.0)) then call CLOSEDEVICE(36) end if C LINES OF CODE COMMENTED FOR X-13A-S : 9 c if ((Iter.eq.0) .and. (Out.ne.2)) then c write (Nio,'(//,A,F7.4,A)') ' ELAPSED TIME : ', Time, ' "' c end if c if ((Iter.eq.0) .and. (Out.ne.2)) then c write (Nio,7057) c end if c 5028 call CLOSEINFILE c call CLOSEDEVICE(ndevice) c if ((matopened) .and. (Iter .gt. 0)) then C END OF CODE BLOCK 5028 continue if ((Itable.eq.1) .and. (Iter.ne.0)) then call CLOSEDEVICE2(36) end if if ((matopened) .and. (Iter .gt. 0)) then * if (modelsumm.eq.1) then * call writeSumS(numser,noTratadas,serSet,wSposBphi, * $ wSstochTD,wSstatseas,wSrmod,wSxl) * end if call closeCompMatrix() call closeOldMatrix() call closePeaksMatrix(69) call closePeaksMatrix(72) call closePeaksMatrix(73) else if (matopened) then call CLOSEDEVICE(65) end if if (Momopened) then call CLOSEDEVICE(80) call CLOSEDEVICE(81) call CLOSEDEVICE(82) end if if ((Iter.ne.0) .and. (Ioneout.eq.0)) then call CLOSEDEVICE(17) end if if ((Iter.ne.0) .and. (Ioneout.eq.0).and.(out.eq.0)) then call CLOSEDEVICE(47) end if if ((Iter.ne.0) .and. (Ioneout.eq.0)) then call CLOSEDEVICE(27) end if if ((Iter.ne.0) .and. (Ioneout.eq.1)) then call CLOSEDEVICE(22) end if if ((out.lt.3) .and.(rogtable.eq.1)) then call CLOSEDEVICE(54) end if C.. C This part is for test to be removed C * if (Itbl .eq. 1) then * call CLOSEDEVICE(87) * end if C.. C End part for test to be removed C 6000 if ((Iter .gt. 0) .and. (niter .ge. 25)) then cdos cdos filename=Outdir(1:ISTRLEN(Outdir)) // '\\Seats.log' cunix filename=Outdir(1:ISTRLEN(Outdir)) // '/Seats.log' call OPENDEVICE (filename,44,0,ifail) call SEATSLOG(SerSet,niter-1) call CLOSEDEVICE(44) end if * close(17) * close(27) * close(22) * close(12) * close(18) * close(44) * close(36) * close(37) * close(16) * close(8) * close(70) * close(71) call closealls() *UNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(1,'SEATS') !DEC$ end if CUNX#end if return end subroutine closealls() include 'stream.i' close(17) * close(27) close(47) close(22) * close(12) * close(18) close(44) close(36) close(37) * close(16) * close(8) close(70) close(71) close(61) close(62) close(63) close(64) close(65) close(69) close(72) close(73) close(56) return end subroutine PicosReset(picos) C C.. Implicits .. implicit none C C.. Formal Arguments .. character Picos(7)*2 C C.. Local Scalars .. integer i do i=1,7 Picos(i)='--' enddo return end c c c NoTreat2: write the matrix line corresponding to this series indicating that was not treated subroutine NoTreat2(niter,mattitle) implicit none c INPUT integer niter character mattitle*(*) c LOCAL real*8 DONE parameter (DONE=-1.0D0) character picos(7)*2 c ------------------------------- c peaks.m => unit=69 c peaksIr.m => unit=72 c peaksTr.m => unit=73 c trendmod.m=> unit=61 c SAmod.m => unit=63 c Seasmod.m => unit=62 c transmod.m=> unit=64 c call picosReset(picos) call wrLnTabPeaks(69,niter,mattitle,picos,1) call picosReset(picos) call wrLnTabPeaks(72,niter,mattitle,picos,1) call picosReset(picos) call wrLnTabPeaks(73,niter,mattitle,picos,1) call Mtx1Reset() call Mtx2Reset() write (61,'(i4,"*",a)') $ niter,mattitle(1:22) write (62,'(i4,"*",a)') $ niter,mattitle(1:22) write (63,'(i4,"*",a)') $ niter,mattitle(1:22) write (64,'(i4,"*",a)') $ niter,mattitle(1:22) write (65, $'(i4,''*'',2x,a,3x,a,6x,a,8x,a,3x,i2,3x,i2,3x,i2,3x,i2,4x,i2,4x, $ i2,4x,i2,2x,f9.0,2x,f9.0, 5x,a,7x,a,7x,a,2x,a,x,a,x,a, $ 5x,a,2x,a)') $ niter, mattitle(1:22),'u','u', 'u', $ -1, -1, -1, -1, -1, -1, -1, $ -1.0d0, -1.0d0, 'u', 'u', 'u', 'u', $ 'u', 'u', 'u', 'u' call OutNoPar(74,niter,mattitle) write (66,6609) $ niter, mattitle(1:22), -1.0d0, $ -1.0d0, -1.0d0, -1.0d0, -1.0d0, $ -1.0d0, -1.0d0, -1.0d0, -1.0d0, $ -1.0d0, -1.0d0, -1.0d0, -1.0d0, -1.0d0 6609 format(i4,'*',2x,a,1x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0, $ 4x,f9.0,1x,f9.0,4x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0,1x, $ f9.0,1x,f9.0,1x,f9.0) write (67,6709) $ niter, mattitle(1:22),-1.0d0, $ -1.0d0, -1.0d0, $ -1.0d0, $ -1, -1, -1, -1.0d0, -1.0d0 6709 format(i4,'*',2x,a,1x,f9.0,1x,f9.0,1x,f9.0,1x,f9.0,11x,i2, $ 8x,i2,8x,i2,4x,f9.0,1x,f9.0) end * subroutine outARMAParam() * IMPLICIT NONE *C----------------------------------------------------------------------- * integer n1,n12 * parameter (n12 = 12, n1 = 1) *C----------------------------------------------------------------------- * INCLUDE 'srslen.prm' * INCLUDE 'dimensions.i' * INCLUDE 'calc.i' * INCLUDE 'units.cmn' *C----------------------------------------------------------------------- * INTEGER i *C----------------------------------------------------------------------- * IF(P.gt.0)THEN * DO i = 1, P * WRITE(Mtprof,*) 'phi(',i,') = ',Phi(i) * END DO * END IF *C----------------------------------------------------------------------- * IF(BP.gt.0)THEN * DO i = 1, BP * WRITE(Mtprof,*) 'bphi(',i,') = ',BPhi(i) * END DO * END IF *C----------------------------------------------------------------------- * IF(Q.gt.0)THEN * DO i = 1, Q * WRITE(Mtprof,*) 'th(',i,') = ',Th(i) * END DO * END IF *C----------------------------------------------------------------------- * IF(BQ.gt.0)THEN * DO i = 1, BQ * WRITE(Mtprof,*) 'bth(',i,') = ',BTh(i) * END DO * END IF *C----------------------------------------------------------------------- * RETURN * END ansub10.f0000664006604000003110000057617614521201406011632 0ustar sun00315stepsC Last change: REG 29 Jun 2006, 26 May 2006 C Previous change: REG 21 Apr 2006, 28 Feb 2006, 30 Aug 2005 C Previous change: BCM 19 Jun 2002 5:38 pm subroutine HPPARAM(mq,hplan,hpPer,hpPar,hpth,km,kc,g,h) C IN mq C IN/OUT HPlan,HPper C OUT HPpar:(0:HPLan and HPper by default; 1 HPper set by user;2 HPlan set by user) C C.. Implicits .. implicit none include 'units.cmn' C C.. Formal Arguments .. integer mq,HPpar real*8 hplan,hpPer,hpth(3),km,kc,g(3),h(4,5) C C.. Local Scalars .. integer alen,blen,clen,i,j,nmat,nsys real*8 a,b,m1,m2,n1,n2,r,s,sum,vb,z,freq,pi complex*16 r1,r2 C C.. Local Arrays .. real*8 am(60,66),hmat(4,4),mat(3,4) complex*16 apol(2),bpol(2),c(3) C C.. External Functions .. complex*16 SELROOT external SELROOT C C.. External Calls .. external CONVC, MLTSOL C C.. Intrinsic Functions .. intrinsic DBLE, DCMPLX, SQRT,ACOS,COS C C.. Data Declarations .. data ((mat(i,j), j = 1,4), i = 1,3)/ $ 1.0d0,0.0d0,0.0d0,0.0d0,0.0d0,1.0d0,0.0d0,0.0d0,0.0d0,0.0d0, $ 2.0d0,1.0d0/ C data ((hmat(i,j), j = 1,4), i = 1,4)/ $ 1.0d0,-2.0d0,1.0d0,0.0d0,0.0d0,1.0d0,-2.0d0,1.0d0,1.0d0, $ 0.0d0,0.0d0,0.0d0,0.0d0,1.0d0,0.0d0,0.0d0/ C C ... Executable Statements ... C C pi=acos(-1.0d0) if (hpPer.ge.2.0d0) then HPpar=1 ! HPPER set by user freq=2*pi/hpPer hpLan=.25d0/((1-cos(freq))**2) else if (hplan.lt.0.0625) then HPpar=0 !HPper and HPlan by default hpPer=10*MQ ! We choose the period of 10 Years freq=2*pi/hpPer hpLan=.25d0/((1-cos(freq))**2) else HPpar=2 !HPLAN set by user freq=acos(1-0.5d0/sqrt(hplan)) hpPer=2*pi/freq end if a = 2.0d0 b = 1.0d0 / SQRT(hplan) s = 2 * a * b z = SQRT((1.0d0/(2.0d0*hplan))*(1.0d0+SQRT(1.0d0+16.0d0*hplan))) r = s / (2.0d0*z) m1 = (-a+r) / 2.0d0 n1 = (z-b) / 2.0d0 m2 = (-a-r) / 2.0d0 n2 = (-z-b) / 2.0d0 r1 = SELROOT(m1,n1,m2,n2) b = -b z = -z n1 = (z-b) / 2.0d0 n2 = (-z-b) / 2.0d0 r2 = SELROOT(m1,n1,m2,n2) apol(1) = DCMPLX(1.0d0,0.0d0) apol(2) = r1 bpol(1) = DCMPLX(1.0d0,0.0d0) bpol(2) = r2 alen = 2 blen = 2 clen = alen + blen - 1 call CONVC(apol,alen,bpol,blen,c,clen) sum = 0.0d0 do i = 1,clen hpth(i) = DBLE(c(i)) sum = sum + hpth(i)*hpth(i) end do vb = (1.0d0+6.0d0*hplan) / sum km = 1.0d0 / vb kc = hplan / vb mat(2,1) = hpth(2) mat(3,1) = hpth(3) + hpth(3) mat(3,2) = hpth(2) + hpth(2) mat(2,2) = 1.0d0 + hpth(3) mat(2,3) = hpth(2) mat(1,3) = hpth(3) nsys = 1 nmat = 3 do i = 1,nmat do j = 1,nmat+nsys am(i,j) = mat(i,j) end do end do * WRITE(Ng,*)' subroutine HPPARAM, call 1' call MLTSOL(am,nmat,nsys,60,66) do i = 1,nmat g(nmat-i+1) = am(i,4) end do hmat(3,2) = hpth(2) hmat(3,3) = hpth(3) hmat(4,3) = hpth(2) hmat(4,4) = hpth(3) do i = 1,4 do j = 1,4 h(i,j) = hmat(i,j) end do end do end C C complex*16 function SELROOT(m1,n1,m2,n2) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. real*8 m1 C.. In/Out Status: Read, Not Written .. real*8 n1 C.. In/Out Status: Read, Not Written .. real*8 m2 C.. In/Out Status: Read, Not Written .. real*8 n2 C C.. Local Scalars .. real*8 mod1,mod2 complex*16 res C C.. Intrinsic Functions .. intrinsic DCMPLX C C ... Executable Statements ... C mod1 = (m1*m1) + (n1*n1) mod2 = (m2*m2) + (n2*n2) if (mod1 .le. mod2) then res = DCMPLX(m1,n1) else res = DCMPLX(m2,n2) end if SELROOT = res end C C subroutine CONVC(a,alen,b,blen,c,clen) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer alen C.. In/Out Status: Read, Not Written .. integer blen C.. In/Out Status: Read, Overwritten .. integer clen C.. In/Out Status: Maybe Read, Not Written .. complex*16 a(alen) C.. In/Out Status: Maybe Read, Not Written .. complex*16 b(blen) C.. In/Out Status: Not Read, Maybe Written .. complex*16 c(clen) C C.. Local Scalars .. integer i,j,l,num C C.. Local Arrays .. complex*16 e(60) C C ... Executable Statements ... C l = alen + blen - 1 do i = 1,l e(i) = (0.0d0,0.d0) end do do i = 1,alen do j = 1,blen num = i + j - 1 e(num) = e(num) + a(i)*b(j) end do end do do i = 1,l c(i) = e(i) end do clen = l end C C subroutine HPTRCOMP(tr,nz,nf,hptrend,hpcycle,hpth,km,g,h) c Lamda: (no used) c TR: the component to apply business cycle with NF forecast C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' include 'units.cmn' C C.. Formal Arguments .. integer nz,nf real*8 tr(*),hptrend(mpkp),hpcycle(mpkp),hpth(3),km,g(3),h(4,5) C C.. Local Scalars .. integer i,j,lenx,nmat,nsys,lf,lenext real*8 wm C C.. Local Arrays .. real*8 am(60,66),exb(-3:mpkp),exf(-3:mpkp),y(mpkp),z(-1:mpkp) real*8 trend(-3:mpkp) c C C.. External Calls .. external MLTSOL C C.. Intrinsic Functions .. * intrinsic LOG C C ... Executable Statements ... C lenx = nz + nf lf=4 call extendHP(tr,lenx,hpTH,2,lf,wm,trend) c if (lamda .eq. 1) then c do i = 1,len c trend(i) = tr(i) c end do c else c do i = 1,len c trend(i) = LOG(tr(i)) c end do c end if c do i = 1,4 c trend(1-i) = 2.0d0*trend(2-i) - trend(3-i) c end do c do i = 1,4 c trend(len+i) = 2.0d0*trend(len+i-1) - trend(len+i-2) c end do c c lenext=lenx+2*lf-8 do i = 1,lenext+2 y(i) = km * (g(1)*trend(i) + g(2)*trend(i+1) + g(3)*trend(i+2)) end do h(1,5) = 0.0d0 h(2,5) = 0.0d0 h(3,5) = y(lenext+1) h(4,5) = y(lenext+2) nmat = 4 nsys = 1 do i = 1,nmat do j = 1,nmat+nsys am(i,j) = h(i,j) end do end do * WRITE(Ng,*)' subroutine HPTRCOMP, call 1' call MLTSOL(am,nmat,nsys,60,66) do i = 1,4 exf(lenext+i) = am(i,5) end do do i = 1,lenext j = lenext - i + 1 exf(j) = -hpth(2)*exf(j+1) - hpth(3)*exf(j+2) + y(j) end do do j = -1,lenext+4 z(j) =Km* (g(1)*trend(j) +g(2)*trend(j-1)+g(3)*trend(j-2)) end do h(1,5) = wm h(2,5) = wm h(3,5) = z(0) h(4,5) = z(-1) nmat = 4 nsys = 1 do i = 1,nmat do j = 1,nmat+nsys am(i,j) = h(i,j) end do end do * WRITE(Ng,*)' subroutine HPTRCOMP, call 2' call MLTSOL(am,nmat,nsys,60,66) exb(0) = am(1,5) exb(-1) = am(2,5) exb(-2) = am(3,5) exb(-3) = am(4,5) do i = 1,lenext+4 exb(i) = -hpth(2)*exb(i-1) - hpth(3)*exb(i-2) + z(i) end do do i = 1,lenx hptrend(i) =(exf(i)+exb(i)) hpcycle(i) = trend(i) - hptrend(i) end do end C C C c Subroutine ErrorBcf c This subroutine is a more faster and direct way to obtain the variance of final error of BC c See that in this case Var final error BC=Var final error M c BUT SUPPOSE Error of Trend uncorrelated with error of extracting Business Cycle c and Error of Trend is correlated with error of estractiion BC from Trend c DO NOT USE this subroutine because THE SUPPOSITION OF FINAL ERROR uncorrelated is not correct c OUTPUT c VfBc: Var of final error of BC and M(long Term Trend) c INPUT c HPth: parte AR del modelo del filtro HP c Km: Variance of Long Term Trend innovation in units of Vp c Kc: Variance of Business Cycle innovation in units of Vp c Vp: variance of trend innovations c THETbc(1:nTHETbc): MA of Business Cycle component c PHIbc(1:nPHIbc): AR of Business Cycle Component c Vfp: var of final error of Trend subroutine ErrorBcF(HPth,Km,Kc,Vp,THETbc,nTHETbc,PHIbc,nPHIbc, $ Vfp,VfBc) implicit none include 'component.i' include 'units.cmn' c INPUT PARAMETERS real*8 HPth(3),Km,Kc,Vp,THETbc(*),PHIbc(*),Vfp integer nTHETbc,nPHIbc c OUTPUT PARAMETERS real*8 Vfbc c LOCAL PARAMETERS real*8 Vfbcp,HP_PHIbc(MaxCompDim) integer nHP_PHIbc,i real*8 gam(0:1),rho(0:1),g(0:1) real*8 bHP_PHIbc(MaxCompDim),bTHETbc(MaxCompDim) c call CONV(HPth,3,PHIbc,nPHIbc,HP_PHIbc,nHP_PHIbc) DO i=1,nHP_PHIbc-1 bHP_PHIbc(i)=-HP_PHIbc(i+1) endDO DO i=1,nTHETbc-1 bTHETbc(i)=-THETbc(i+1) endDo * WRITE(Ng,*)' subroutine ErrorBcF, call 1' call BFAC(bHP_PHIbc,bTHETbc,nHP_PHIbc-1,nTHETbc-1,0, $ gam,rho,Vfbcp,Km*Kc*Vp,g,0) Vfbc=Vfbcp+Vfp end c c c c Subroutine RevErrorBc c Output:VrcM,VrcBc: the concurrent revision errors in units of Va c PSIEm(0:2pk+1): are the weights of the innovations for Long Term Trend Filter c where PSIEm(pk+i) is the weight of the innovation B^i c PSIEbc(0:2pk+1):are the weights of the innovations for Business Cycle c INPUT as global variables of 'model.i' c PSI(nPSI),THETs(nTHETs) AR and MA of Seas component(no used if HPcycle>=3) c Cyc(nCyc),THETc(nTHETc) AR and MA of Transitory (no used if HPcycle>=2) c THstar(qstar0): MA of original serie c INPUT parameters: c HPcycle:(1: business Cycle extracted of Trend, c 2: business Cycle extracted of SA, c 3: business Cycle extracted of original serie) c varwns: innovations variance of Seas in units of Va (no used if HPcycle>=3) c qt1: innovations variance of Irregular in units of Va (no used if HPcycle>=2) c varwnc: innovations variance of Transitory in units of Va(no used if HPcycle>=2) c d_bd: d+bd c pk: a constant to define the size of PSIEs c PHIm(nPHIm) AR of Long Term Trend c THETm(nTHETm) MA of Long Term Trend c Vm: variance innovations of Long Term Trend in units of Va c PHIbc(nPHIbc) AR of Business Cycle c THETbc(nTHETbc) MA of business Cycle c Vbc: variance innovations of Business Cycle in units of Va subroutine RevErrorBc(HpCycle,HPth,varwns,qt1,varwnc,d_bd, $ pk, $ PHIm,nPHIm,THETm,nTHETm,Vm, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ VrcM,VrcBc,PSIEm,PSIEbc) implicit none include 'component.i' include 'polynom.i' include 'stream.i' c INPUT include 'estb.i' include 'models.i' include 'units.cmn' integer HpCycle real*8 HPth(3) real*8 varwns,qt1,varwnc integer d_bd,pk real*8 PHIm(MaxCompDim),THETm(MaxCompDim),Vm, $ PHIbc(MaxCompDim),THETbc(MaxCompDim),Vbc integer nTHETm,nPHIm,nTHETbc,nPHIbc c OUTPUT real*8 VrcBc,VrcM,PSIEm(0:2*pk+1),PSIEbc(0:2*pk+1) c LOCAL VARIABLES c Components that added produce the complementary component c to component to which the HP filter is applied (nP) real*8 VSnP(MaxComp),ARnP(MaxComp,MaxCompDim),dvec(1), $ MAnP(MaxComp,MaxCompDim) integer ARnPDim(MaxComp),MAnPDim(MaxComp),nCompNp c model complementary to the component to which the HP filter is applied (nP) real*8 PHInP(MaxCompDim),THETnP(MaxCompDim),VnP integer nPHInP,nTHETnP cc Convolution(TH,HPth) and its Box-Jenkins representation (b*) real*8 TH_HPth(MaxCompDim),bTH_HPth(MaxCompDim-1) integer nTH_HPth cc Box-Jenkins representation of PHInp,PHIm,THETm real*8 bPHInP(MaxCompDim-1),bPHIm(MaxCompDim-1), $ bTHETm(MaxCompDim-1) cc Box-Jenkins representation of PHIbc,THETbc real*8 bPHIbc(MaxCompDim-1),bTHETbc(MaxCompDim-1) cc The concurrent revision error are Hm/(TH*HPth)arm arm~niid(0,VrM) for M real*8 Hm(MaxCompDim),VrM,Em(0:maxCompDim) integer lHm,lEm cc The concurrent revision error are Hbc/(TH*HPth)arbc arm~niid(0,VrBc) for Bc real*8 Hbc(MaxCompDim),VrBc,Ebc(0:maxCompDim) integer lHbc,lEbc c Local dummy variables to BFAC real*8 gam(0:1),rho(0:1),g(0:1) c Local dummy variables to DECFB real*8 Rce(0:12) c real*8 delta(2),tmp(MaxCompDim) integer i,j,min_2_dbd,nTmp cc To check the exactness in getting components real*8 toterrNP cc ccc For debugging purposes c character strNp*(MaxStrLength) c EXTERNAL ISTRLEN integer ISTRLEN c delta(1)=1.0d0 delta(2)=-1.0d0 nCompNp=0 c c Step 1: getting the component complementary to P (to the component used to apply the HP filter) c if (HPcycle.eq.1) then c call AddComp(CHI,nCHI,THETp,nTHETp,varwnp, !Añadiendo esto tenemos la serie original en lugar de nP c $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) call AddComp(PSI,nPSI,THETs,nTHETs,varwns, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) dvec(1)=1.0d0 call AddComp(dvec,1,dvec,1,qt1, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) call AddComp(Cyc,nCyc,THETc,nTHETc,varwnc, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) else if (HPCycle.eq.2) then call AddComp(PSI,nPSI,THETs,nTHETs,varwns, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) end if c c Step 2: getting the component complementary to M and the complementary to BC c call GetComp(ARnP,ARnPdim,MAnP,MAnPdim,VSnP,nCompNp, $ PHInP,nPHInP,THETnP,nTHETnP,VnP,toterrNp) cc For debugging purposes c write(nio,'(///,"Model nP computed with getComp")') c call ShowModel(PHInp,nPHInp,THETnP,nTHETnP,VnP,'nP',strnP) c write(nio,'(//,A)') strNP(1:ISTRLEN(StrNP)) c write(nio,'(//,"TOTAL SQUARED ERROR NP = ",G10.4)') toterrNP cc End debugging block c c Step 4: Obtaining the concurrent revision errors and innovation weights for M and BC c call Conv(THSTR0,qstar0,HPth,3,TH_HPth,nTH_HPth) do i=1,nTH_HPth-1 bTH_HPth(i)=-TH_HPth(i+1) endDo do i=1,nPHInP-1 bPHInP(i)=-PHInP(i+1) endDo do i=1,nPHIm-1 bPHIm(i)=-PHIm(i+1) enddo do i=1,nTHETm-1 bTHETm(i)=-THETm(i+1) enddo call DECFB(bPHIm,bTH_HPth,nPHIm-1,nTH_HPth-1, $ bTHETm,bPHInP,nTHETm-1,nPHInP-1,Vm, $ PSIEm,pk,Rce,Hm,lHm,Vrm,Em,lEm) * WRITE(Ng,*)' subroutine RevErrorBc, call 1' call BFAC(bTH_HPth,Hm,nTH_HPth-1,lHm, $ 1,gam,rho,VrcM,VrM,g,1) min_2_dbd=min(2,d_bd) DO i=1,min_2_dbd call CONV(PHInp,nPHInP,Delta,2,tmp,ntmp) DO j=1,ntmp PHInp(j)=tmp(j) enddo nPHInp=ntmp endDo DO i=1,nPHInP-1 bPHInP(i)=-PHInP(i+1) endDo DO i=1,nPHIbc-1 bPHIbc(i)=-PHIbc(i+1) endDo DO i=1,nTHETbc-1 bTHETbc(i)=-THETbc(i+1) endDo call DECFB(bPHIbc,bTH_HPth,nPHIbc-1,nTH_HPth-1, $ bTHETbc,bPHInP,nTHETbc-1,nPHInP-1,Vbc, $ PSIEbc,pk,Rce,Hbc,lHbc,Vrbc,Ebc,lEbc) * WRITE(Ng,*)' subroutine RevErrorBc, call 2' call BFAC(bTH_HPth,Hbc,nTH_HPth-1,lHbc, $ 1,gam,rho,VrcBc,VrBc,g,1) end c c c c Subroutine GetErrorBc c Output: c VfcBc: variance of final error of Business Cycle in units of Va (0 if WithoutVf) c VfcM: variance of final error of Long Term Trend in units of Va (0 if WithoutVf) c VrcBc: variance of Revision error of Business Cycle for concurrent in units of Va c VrcM: variance of Revision error of Long Term Trend for concurrent in units of Va c PSIEm(0:2pk+1): are the weights of the innovations for Long Term Trend Filter c where PSIEm(pk+i) is the weight of the innovation B^i c PSIEbc(0:2pk+1):are the weights of the innovations for Business Cycle c PHInp(1:nPHInp) the AR of the component complementary to P,SA or Series according to hpcycle c INPUT/OUTPUT c WithoutVf: 1 if variance of final error is infinite(d+bd>2 or ns>0, c or there are roots too close to 1) c INPUT as global variables of 'model.i' c PSI(nPSI),THETs(nTHETs) AR and MA of Seas component(no used if HPcycle>=3) c Cyc(nCyc),THETc(nTHETc) AR and MA of Transitory (no used if HPcycle>=2) c THstar(qstar): MA of original serie c INPUT parameters: c HPcycle:(1: business Cycle extracted of Trend, c 2: business Cycle extracted of SA, c 3: business Cycle extracted of original serie) c varwns: innovations variance of Seas in units of Va (no used if HPcycle>=3) c qt1: innovations variance of Irregular in units of Va (no used if HPcycle>=2) c varwnc: innovations variance of Transitory in units of Va(no used if HPcycle>=2) c d_bd: d+bd c pk: a constant to define the size of PSIEs c PHIm(nPHIm) AR of Long Term Trend c THETm(nTHETm) MA of Long Term Trend c Vm: variance innovations of Long Term Trend in units of Va c PHIbc(nPHIbc) AR of Business Cycle c THETbc(nTHETbc) MA of business Cycle c Vbc: variance innovations of Business Cycle in units of Va subroutine getErrorBc(HpCycle,HPth,varwns,qt1,varwnc,d_bd, $ pk, $ PHIm,nPHIm,THETm,nTHETm,Vm, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ VfcM,VfcBc,VrcM,VrcBc,PSIEm,PSIEbc, $ WithoutVf,PHInp,nPHInp) implicit none include 'component.i' include 'polynom.i' include 'stream.i' c INPUT include 'estb.i' include 'models.i' include 'units.cmn' integer HpCycle real*8 HPth(3) real*8 varwns,qt1,varwnc integer d_bd,pk real*8 PHIm(MaxCompDim),THETm(MaxCompDim),Vm, $ PHIbc(MaxCompDim),THETbc(MaxCompDim),Vbc integer nTHETm,nPHIm,nTHETbc,nPHIbc c OUTPUT real*8 VfcM,VfcBc,VrcBc,VrcM,PSIEm(0:2*pk+1),PSIEbc(0:2*pk+1) integer withoutVf real*8 PHInP(MaxCompDim) integer nPHInp c LOCAL VARIABLES c Components that added produce the complementary component c to component to which the HP filter is applied (nP) real*8 VSnP(MaxComp),ARnP(MaxComp,MaxCompDim), $ MAnP(MaxComp,MaxCompDim) integer ARnPDim(MaxComp),MAnPDim(MaxComp),nCompNp c Components that added produce the complementary to Business Cycle (nBc) real*8 VSnBc(MaxComp),ARnBc(MaxComp,MaxCompDim), $ MAnBc(MaxComp,MaxCompDim) integer ARnBcDim(MaxComp),MAnBcDim(MaxComp),nCompNbc c Components that added produce the complementary to Long Term Trend (nM) real*8 VSnM(MaxComp),ARnM(MaxComp,MaxCompDim), $ MAnM(MaxComp,MaxCompDim) integer ARnMdim(MaxComp),MAnMdim(MaxComp),nCompNm c model complementary to the component to which the HP filter is applied (nP) real*8 PHInpDelta(MaxCompDim),THETnP(MaxCompDim),VnP integer nPHInpDelta,nTHETnP c model complementary to Long Term Trend (nM) real*8 PHInM(MaxCompDim),THETnM(MaxCompDim),VnM integer nPHInM,nTHETnM c model complementary to Business Cycle (nBc) real*8 PHInBc(MaxCompDim),THETnBc(MaxCompDim),VnBc integer nPHInBc,nTHETnBc cc Convolution(THn,THnm) and its Box-Jenkins representation (b*) real*8 THmTHnm(2*MaxCompDim),bTHmTHnm(2*MaxCompDim-1) integer nTHmTHnm cc Convolution(TH,HPth) and its Box-Jenkins representation (b*) real*8 TH_HPth(MaxCompDim),bTH_HPth(MaxCompDim-1) integer nTH_HPth cc Convolution(TH,HPth,PHIbc) and its Box-Jenkins representation (b*) real*8 TH_HPth_PHIbc(2*MaxCompDim),bTH_HPth_PHIbc(2*MaxCompDim-1) integer nTH_HPth_PHIbc cc Box-Jenkins representation of PHInp,PHInpDelta,PHIm,THETm real*8 bPHInPDelta(MaxCompDim-1),bPHInP(MaxCompDim-1), $ bPHIm(MaxCompDim-1),bTHETm(MaxCompDim-1) cc Box-Jenkins representation of PHIbc,THETbc real*8 bPHIbc(MaxCompDim-1),bTHETbc(MaxCompDim-1) cc The concurrent revision error are Hm/(TH*HPth)arm arm~niid(0,VrM) for M real*8 Hm(MaxCompDim),VrM,Em(0:MaxCompDim) integer lHm,lEm cc The concurrent revision error are Hbc/(TH*HPth)arbc arm~niid(0,VrBc) for Bc real*8 Hbc(MaxCompDim),VrBc,Ebc(0:maxCompDim) integer lHbc,lEbc c Local dummy variables to BFAC real*8 gam(0:1),rho(0:1),g(0:1) c Local dummy variables to DECFB real*8 Rce(0:12) c real*8 delta(2),tmp(MaxCompDim),dvec(1) integer i,j,min_2_dbd,nTmp cc To check the exactness in getting components real*8 toterrNP,toterrNM,toterrNBC,toterrTest cc ccc For debugging purposes cccc Representation of nBc and nM c character strNp*(MaxStrLength),strNbc*(MaxStrLength), c $ strnM*(MaxStrLength) cccc Testing the complementary components c real*8 VStest(MaxComp),ARtest(MaxComp,MaxCompDim), c $ MAtest(MaxComp,MaxCompDim) c integer ARtestDim(MAxComp),MAtestDim(MaxComp),nTestComp c real*8 PHItest(MaxCompDim),THtest(MAxCompDim),Vtest c integer nPHItest,nTHtest c character StrTest*MaxStrLength ccc End declarations for debugging purposes c EXTERNAL ISTRLEN integer ISTRLEN c delta(1)=1.0d0 delta(2)=-1.0d0 nCompNbc=0 nCompNm=0 nCompNp=0 c c Step 1: getting the component complementary to P (to the component used to apply the HP filter) c if (HPcycle.eq.1) then c call AddComp(CHI,nCHI,THETp,nTHETp,varwnp, !Añadiendo esto tenemos la serie original en lugar de nP c $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) call AddComp(PSI,nPSI,THETs,nTHETs,varwns, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) dvec(1)=1.0d0 call AddComp(dvec,1,dvec,1,qt1, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) call AddComp(Cyc,nCyc,THETc,nTHETc,varwnc, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) else if (HPCycle.eq.2) then call AddComp(PSI,nPSI,THETs,nTHETs,varwns, $ ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNP) end if c c Step 2: getting the component complementary to M and the complementary to BC c call CopyAddComp(ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNp, $ ARnM,ARnMdim,MAnM,MAnMdim,VSnM,nCompNm) call CopyAddComp(ARnP,ARnPDim,MAnP,MAnPDim,VSnP,nCompNp, $ ARnBc,ARnBcDim,MAnBc,MAnBcDim,VSnBc,nCompNbc) call AddComp(PHIm,nPHIm,THETm,nTHETm,Vm, $ ARnBc,ARnBcDim,MAnBc,MAnBcDim,VSnBc,nCompNbc) call AddComp(PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ ARnM,ARnMdim,MAnM,MAnMdim,VSnM,nCompNm) call GetComp(ARnP,ARnPdim,MAnP,MAnPdim,VSnP,nCompNp, $ PHInP,nPHInP,THETnP,nTHETnP,VnP,toterrNp) call GetComp(ARnBc,ARnBcDim,MAnBc,MAnBcDim,VSnBc,nCompNbc, $ PHInBc,nPHInBc,THETnBc,nTHETnBc,VnBc,toterrNBC) call GetComp(ARnM,ARnMdim,MAnM,MAnMdim,VSnm,nCompnM, $ PHInM,nPHInM,THETnM,nTHETnM,VnM,toterrNM) cc For debugging purposes c write(nio,'(///,"Model nP computed with getComp")') c call ShowModel(PHInp,nPHInp,THETnP,nTHETnP,VnP,'nP',strnP) c write(nio,'(//,A)') strNP(1:ISTRLEN(StrNP)) c write(nio,'(//,"TOTAL SQUARED ERROR NP = ",G10.4)') toterrNP c write(nio,'(//,"Componentes complementarios al BC", c $ " y Long Term Trend para depuracion")') c call ShowModel(PHInm,nPHInm,THETnM,nTHETnM,VnM,'nM',strnM) c write(nio,'(//,A)') strNM(1:ISTRLEN(StrNM)) c write(nio,'(//,"TOTAL SQUARED ERROR NM = ",G10.4)') toterrNM c call ShowModel(PHInBc,nPHInBc,THETnBc,nTHETnBc,VnBc,'nBc',strnBc) c write(nio,'(//,A,///)') strNBc(1:ISTRLEN(StrNBc)) c write(nio,'(//,"TOTAL SQUARED ERROR NBc = ",G10.4)') toterrNBc cc Testing nM and nBc c nTestComp=0 c call AddComp(PHIm,nPHIm,THETm,nTHETm,Vm, c $ ARtest,ARtestDim,MAtest,MAtestDim,VStest,nTestComp) c call AddComp(PHInm,nPHInm,THETnm,nTHETnm,Vnm, c $ ARtest,ARtestDim,MAtest,MAtestDim,VStest,nTestComp) c call GetComp(ARtest,ARtestDim,MAtest,MAtestDim,VStest,nTestComp, c $ PHItest,nPHItest,THtest,nTHtest,Vtest,toterrTest) c call ShowModel(PHItest,nPHItest,THtest,nTHtest,Vtest, c $ 'M+nM',strTest) c write(nio,'(//,A)') strTest(1:ISTRLEN(StrTest)) c write(nio,'(//,"Should be 1 Vtest(M)=",G10.4)') Vtest c nTestComp=0 c call AddComp(PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, c $ ARtest,ARtestDim,MAtest,MAtestDim,VStest,nTestComp) c call AddComp(PHInbc,nPHInbc,THETnbc,nTHETnbc,Vnbc, c $ ARtest,ARtestDim,MAtest,MAtestDim,VStest,nTestComp) c call GetComp(ARtest,ARtestDim,MAtest,MAtestDim,VStest,nTestComp, c $ PHItest,nPHItest,THtest,nTHtest,Vtest,toterrTest) c call ShowModel(PHItest,nPHItest,THtest,nTHtest,Vtest, c $ 'Bc+nBc',strTest) c write(nio,'(//,A)') strTest(1:ISTRLEN(StrTest)) c write(nio,'(/,"Should be 1 Vtest(BC)=",G10.4,///)') Vtest cc End debugging Block c c Step 3: Obtaining the final error of M and BC c call Conv(THSTR0,qstar0,HPth,3,TH_HPth,nTH_HPth) if (withoutVf.eq.0) then call Conv(THETm,nTHETm,THETnM,nTHETnM,THmTHnm,nTHmTHnm) call Conv(TH_HPth,nTH_HPth,PHIbc,nPHIbc, $ TH_HPth_PHIbc,nTH_HPth_PHIbc) do i=1,nTH_HPth_PHIbc-1 bTH_HPth_PHIbc(i)=-TH_HPth_PHIbc(i+1) enddo do i=1,nTHmTHnm-1 bTHmTHnm(i)=-THmTHnm(i+1) enddo * WRITE(Ng,*)' subroutine getErrorBc, call 1' call BFAC(bTH_HPth_PHIbc,bTHmTHnm,nTH_HPth_PHIbc-1,nTHmTHnm-1, $ 0,gam,rho,VfcM,Vm*Vnm,g,0) call Conv(THETbc,nTHETbc,THETnBc,nTHETnBc,THmTHnm,nTHmTHnm) do i=1,nTHmTHnm-1 bTHmTHnm(i)=-THmTHnm(i+1) enddo * WRITE(Ng,*)' subroutine getErrorBc, call 2' call BFAC(bTH_HPth_PHIbc,bTHmTHnm,nTH_HPth_PHIbc-1,nTHmTHnm-1,0, $ gam,rho,VfcBc,Vbc*Vnbc,g,0) if ((VfcM.lt.0.0d0).or.(VfcBc.lt.0.0d0)) then withoutVf=2 end if end if if (withoutVf.ne.0) then VfcM=0.0d0 VfcBc=0.0d0 end if c c Step 4: Obtaining the concurrent revision errors and innovation weights for M and BC c do i=1,nTH_HPth-1 bTH_HPth(i)=-TH_HPth(i+1) endDo do i=1,nPHInP-1 bPHInP(i)=-PHInP(i+1) endDo do i=1,nPHIm-1 bPHIm(i)=-PHIm(i+1) enddo do i=1,nTHETm-1 bTHETm(i)=-THETm(i+1) enddo call DECFB(bPHIm,bTH_HPth,nPHIm-1,nTH_HPth-1, $ bTHETm,bPHInP,nTHETm-1,nPHInP-1,Vm, $ PSIEm,pk,Rce,Hm,lHm,Vrm,Em,lEm) * WRITE(Ng,*)' subroutine getErrorBc, call 3' call BFAC(bTH_HPth,Hm,nTH_HPth-1,lHm, $ 1,gam,rho,VrcM,VrM,g,1) min_2_dbd=min(2,d_bd) Do i=1,nPHInp PHInpDelta(i)=PHInp(i) enddo nPHInpDelta=nPHInp DO i=1,min_2_dbd call CONV(PHInpDelta,nPHInpDelta,Delta,2,tmp,ntmp) DO j=1,ntmp PHInpDelta(j)=tmp(j) enddo nPHInpDelta=ntmp endDo DO i=1,nPHInPDelta-1 bPHInpDelta(i)=-PHInPDelta(i+1) endDo DO i=1,nPHIbc-1 bPHIbc(i)=-PHIbc(i+1) endDo DO i=1,nTHETbc-1 bTHETbc(i)=-THETbc(i+1) endDo call DECFB(bPHIbc,bTH_HPth,nPHIbc-1,nTH_HPth-1, $ bTHETbc,bPHInpDelta,nTHETbc-1,nPHInpDelta-1,Vbc, $ PSIEbc,pk,Rce,Hbc,lHbc,Vrbc,Ebc,lEbc) * WRITE(Ng,*)' subroutine getErrorBc, call 4' call BFAC(bTH_HPth,Hbc,nTH_HPth-1,lHbc, $ 1,gam,rho,VrcBc,VrBc,g,1) end c c subroutine getBcycleComp(d_bd,mq,nS, $ PHIp,nPHIp,PHIps,nPHIps,THETp,nTHETp,Vp, $ HPth,Km,Kc, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ PHIm,nPHIm,THETm,nTHETm,Vm,WithoutVf) c Given THhp, and the model of the component (P) to which c we apply the HP filter (Km/ACF(HPth)) and (kc*ACF((1-B)^2)/ACF(HPth)) c we obtain the models of Long Term Trend (M) and Business Cycle (Bc) c Model of P: PHIps(B)*(S(mq)^ns)*(1-B)^(d_bd) P= THETp(B)Apt Apt~niid(0,Vp) c where S(mq)=ones(1,mq) c OTHER INPUT/OUTPUT c WithoutVf: 1 if variance of final error is infinite(d+bd>2 or ns>0, c or there are roots too close to 1) implicit none include 'component.i' c INPUT/OUTPUT integer withoutVf c INPUT integer d_bd,ns,mq real*8 PHIp(*),PHIps(*),THETp(*),Vp,HPth(3),Kc,Km integer nPHIp,nPHIps,nTHETp c OUTPUT real*8 PHIbc(MaxCompDim),THETbc(MaxCompDim),Vbc integer nPHIbc,nTHETbc real*8 PHIm(MaxCompDim),THETm(MaxCompDim),Vm integer nPHIm,nTHETm c LOCAL PARAMETERS real*8 Delta(2),S(12),tmp(MaxCompDim) integer i,j,ntmp c if ((d_bd.gt.2).or.(ns.ne.0))then withoutVf=1 else withoutVf=0 end if call CONV(PHIp,nPHIp,HPth,3,PHIm,nPHIm) DO i=1,nTHETp THETbc(i)=THETp(i) THETm(i)=THETp(i) endDo nTHETbc=nTHETp do while(THETbc(nTHETbc).eq.0.0d0) nTHETbc=nTHETbc-1 enddo nTHETm=nTHETbc call CONV(PHIps,nPHIps,HPth,3,PHIbc,nPHIbc) Delta(1)=1.0d0 Delta(2)=-1.0d0 if (d_bd.ge.2) then do i=1,(d_bd-2) call CONV(PHIbc,nPHIbc,Delta,2,tmp,ntmp) Do j=1,ntmp PHIbc(j)=tmp(j) EndDo nPHIbc=ntmp endDO else do i=1,(2-d_bd) call CONV(THETbc,nTHETbc,Delta,2,tmp,ntmp) DO j=1,ntmp THETbc(j)=tmp(j) endDo nTHETbc=ntmp endDo end if if (ns.ge.1) then Do i=1,mq S(i)=1.0d0 endDo Do i=1,ns call CONV(PHIbc,nPHIbc,S,mq,tmp,ntmp) Do j=1,ntmp PHIbc(j)=tmp(j) endDo nPHIbc=ntmp endDo end if Vbc=Kc*Vp Vm=Km*Vp end c subroutine HPOUTPUT(lamda,compHP,hptrend,hpcyc,hpregt,hpregc, $ totcyc,ireg,nfor,out,pg,HPper,HPlam,HPpar,HPcycle,km,HPth, $ varw,VfcBc,VfcM,VfBc,WithoutVf,seBc,seM,iter,MQ,DBD) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer pk parameter (pk = 550) C C.. Formal Arguments .. real*8 VfcBc,VfcM,VfBc,seBc(2*pk+2),seM(2*pk+2) integer WithoutVf,DBD integer lamda,ireg,nfor,out,pg,HPpar,HPcycle,iter,MQ real*8 compHP(mpkp),hptrend(mpkp),hpcyc(mpkp),hpregt(mpkp), $ hpregc(mpkp),totcyc(mpkp),HPper,HPlam,Km,HPth(1:3), $ varw C C.. Local Scalars .. integer i,j,nf character fname*30,subtitle*50,LongTermCad*21 real*8 kons,sum0,sum1 C C.. Local Arrays .. real*8 temp(mpkp),splot(2*kp+1,3) C C.. External Calls .. integer ISTRLEN external TABLE1, ISTRLEN C C.. Intrinsic Functions .. intrinsic EXP include 'sform.i' include 'stream.i' include 'models.i' include 'polynom.i' character ModelStrCt*(MaxStrLength),ModelStrMt*(maxStrLength) C C ... Executable Statements ... C C C If (HPcycle.eq.1) then LongTermCad='LONG TERM TREND' else if (HPcycle.eq.2) then LongTermCad='SA series without BC' else LongTermCad='Series without BC' end if call PresentaHP(HPth,HPcycle,Km,HPlam,varw, $ ModelStrCt,ModelStrMt) c nf = nfor / 2 nf = nfor if (lamda .eq. 0) then sum0 = 0.0d0 sum1 = 0.0d0 do i = 1,Nz+nf sum0 = sum0 + compHP(i) sum1 = sum1 + Exp(hptrend(i)) end do kons = sum0 / sum1 end if if (out.eq.0) then call OutHeadHP(ModelStrCt,ModelStrMt,HPth,Km,HPper,HPlam, $ HPpar,HPcycle,VfcBc,VfcM,VfBc,WithoutVf,MQ,DBD,varw) end if * if ((pg .eq. 0).and.(iter.eq.0).and.(out.lt.2)) then * if (lamda .eq. 1) then * if (ireg .eq. 1) then * fname = 'HPcBCs.T' * subtitle = 'STOCHASTIC BUSSINES CYCLE' * call PLOTSERIESCI(fname,subtitle,hpcyc,seBc,Nz,1,-666.0d0) *c * fname = 'HPcBCr.T' * subtitle = 'REGRESSION CYCLICAL COMPONENT' * call PLOTSERIES(fname,subtitle,hpregc,Nz,1,0.0d0) *c * fname = 'HPcBCt.T' * subtitle = 'TOTAL BUSSINES CYCLE' * do i = 1,Nz * temp(i) = hpcyc(i) + hpregc(i) * end do * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c * fname = 'HPcLTs.T' * subtitle = 'STOCHASTIC '//LongTermCad(1:istrlen(LongTermCad)) * call PLOTSERIESCI(fname,subtitle,hptrend,seM,Nz,1,-666.0d0) *c * fname='HPcLTr.T' * subtitle = 'REGRESSION '//LongTermCad(1:istrlen(LongTermCad)) * call PLOTSERIES(fname,subtitle,hpregt,Nz,1,0.0d0) *c * fname='HPcLTt.T' * subtitle = 'TOTAL '//LongTermCad(1:istrlen(LongTermCad)) * do i = 1,Nz * temp(i) = hptrend(i) + hpregt(i) * end do * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c LAM=1 IREG=0 * ELSE *c * fname = 'HPcBCt.T' * subtitle = 'BUSINESS CYCLE' * call PLOTSERIESCI(fname,subtitle,hpcyc,seBc,Nz,1,-666.0d0) *C * fname = 'HPcLTt.T' * subtitle = LongTermCad(1:istrlen(LongTermCad)) * call PLOTSERIESCI(fname,subtitle,hptrend,seM,Nz,1,-666.0d0) * end if *c LAM=0 IREG>0 * else if (ireg .eq. 1) then *c logs * fname='HPcBCs.T' * subtitle = 'STOCHASTIC CYCLICAL COMPONENT' * call PLOTLSERIES(fname,subtitle,hpcyc,Nz,1,0.0d0) *c * fname='HPcBCr.T' * subtitle = 'REGRESSION CYCLICAL COMPONENT' * call PLOTLSERIES(fname,subtitle,hpregc,Nz,1,0.0d0) *c * fname='HPcBCt.T' * subtitle = 'TOTAL CYCLICAL COMPONENT' * do i = 1,Nz * temp(i) = hpcyc(i) + hpregc(i) * end do * call PLOTLSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c * fname='HPcLTsLO.T' * subtitle = 'STOCHASTIC '//LongTermCad(1:istrlen(LongTermCad)) * call PLOTLSERIES(fname,subtitle,hptrend,Nz,1,0.0d0) *c * fname = 'HPcLTrLO.T' * subtitle = 'REGRESSION '//LongTermCad(1:istrlen(LongTermCad)) * call PLOTLSERIES(fname,subtitle,hpregt,Nz,1,0.0d0) *c * do i = 1,Nz * temp(i) = hptrend(i) + hpregt(i) * end do * fname = 'HPcLTtLO.T' * subtitle = 'TOTAL '//LongTermCad(1:istrlen(LongTermCad)) * call PLOTLSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c levels *c * fname = 'HPfBCs.T' * subtitle = 'STOCHASTIC BUSINESS CYCLE FACTORS' * do i=1,nz * temp(i)=100.0d0 * (compHP(i)/(kons*EXP(hptrend(i)))) * end do * call PLOTSERIESCI(fname,subtitle,temp,seBc,Nz,1,-666.0d0) *c * fname='HPfBCr.T' * subtitle = 'REGRESSION CYCLICAL FACTOR' * do i = 1,Nz * temp(i) = 100.0d0 * EXP(hpregc(i)) * end do * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c * fname='HPfBCt.T' * subtitle = 'TOTAL CYCLICAL FACTOR' * do i = 1,Nz * temp(i) = * $ 100.0d0 * (compHP(i)/(kons*EXP(hptrend(i)))) * exp(hpregc(i)) * end do * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c *c * fname = 'HPcLTsLE.T' * subtitle = 'STOCHASTIC '//LongTermCad(1:istrlen(LongTermCad)) * do i = 1,Nz * temp(i) = kons * EXP(hptrend(i)) * end do * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c * fname = 'HPcLTrLE.T' * subtitle = 'REGRESSION '//LongTermCad(1:istrlen(LongTermCad)) * do i = 1,Nz * temp(i) = EXP(hpregt(i)) * end do * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) * do i = 1,Nz * temp(i) = kons * EXP(hptrend(i)) * (hpregt(i)) * end do * fname = 'HPcLTtLE.T' * subtitle = 'TOTAL '//LongTermCad(1:istrlen(LongTermCad)) * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) *c *c LAM=0 IREG=0 * else *c *cc fname='HPcBCs.T' * fname='HPcBCt.T' * subtitle = 'BUSINESS CYCLE' * call PLOTLSERIES(fname,subtitle,hpcyc,Nz,1,0.0d0) *c *c fname = 'HPfBCs.T' * fname = 'HPfBCt.T' * subtitle = ' BUSINESS CYCLE FACTORS' * do i = 1,Nz * temp(i) = 100.0d0 * (compHP(i)/(kons*EXP(hptrend(i)))) * end do * call PLOTSERIESCI(fname,subtitle,temp,seBc,Nz,1,-666.0d0) *c *cc fname='HPcLTsLO.T' * fname='HPcLTtLO.T' * subtitle = LongTermCad(1:istrlen(LongTermCad))//' COMPONENT' * call PLOTLSERIES(fname,subtitle,hptrend,Nz,1,0.0d0) *c *c fname = 'HPcLTsLE.T' * fname = 'HPcLTtLE.T' * subtitle = LongTermCad(1:istrlen(LongTermCad)) * do i = 1,Nz * temp(i) = kons * EXP(hptrend(i)) * end do * call PLOTSERIES(fname,subtitle,temp,Nz,1,0.0d0) * end if *c *c FORECAST * do i = 1,2*kp+1 * do j = 1,3 * splot(i,j) = 0.0d0 * end do * end do * if (lamda.eq.0) then * do i = kp-nf,kp+nf * splot(i,3) = exp(hptrend(nz-kp+i))*kons *c splot(i,3) = exp(hptrend(nz-kp+i)) * end do * else * do i = kp-nf,kp+nf * splot(i,3) = hptrend(nz-kp+i) * end do * end if * do i = -nf,nf * splot(kp+i,1) = splot(kp+i,3) - 1.96*seM(Nz+i) * splot(kp+i,2) = splot(kp+i,3) + 1.96*seM(Nz+i) * end do * fname = 'LTTFCI.T5' * subtitle = LongTermCad(1:istrlen(LongTermCad))// * $ ' Forecast with Confidence Intervals' * call PLOTFCAST2(fname,subtitle,splot,nf,nz,1) * if (lamda.eq.0) then * do i = kp-nf,kp+nf *c splot(i,3) = 100*exp(hpcyc(nz-kp+i)) * splot(i,3)=100.0d0*(compHP(nz-kp+i) * $ /(kons*EXP(hptrend(nz-kp+i)))) * end do * subtitle= * $ 'BUSINESS CYCLE FACTORS Forecast with Confidence Intervals' * else * do i = kp-nf,kp+nf * splot(i,3) = hpcyc(nz-kp+i) * end do * subtitle = 'BUSINESS CYCLE Forecast with Confidence Intervals' * end if * do i = -nf,nf * splot(kp+i,1) = splot(kp+i,3) - 1.96*seBc(Nz+i) * splot(kp+i,2) = splot(kp+i,3) + 1.96*seBc(Nz+i) * end do * fname = 'BCFCI.T5' * call PLOTFCAST2(fname,subtitle,splot,nf,nz,1) *cc * end if C C OUTPUT FILE C if (out.eq.0) then if (lamda .eq. 1) then if (ireg .eq. 1) then C C CYCLE C do i = 1,Nz+nf temp(i) = hpcyc(i) + hpregc(i) totcyc(i) = hpcyc(i) + hpregc(i) end do write (Nio,'(/,2X,"STOCHASTIC CYCLICAL COMPONENT")') call TABLE1(hpcyc,nf) write (Nio,'(/,2X,"REGRESSION CYCLICAL COMPONENT")') call TABLE1(hpregc,nf) write (Nio,'(/,2X,"TOTAL CYCLICAL COMPONENT")') call TABLE1(temp,nf) call USRENTRY(temp,1,Nz+nf,1,mpkp,2501) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of CYCLICAL COMPONENT'')') else c write(Nio,'(/2X,''Total error of CYCLICAL COMPONENT'')') write(Nio,'(/2X,''Revision error of CYCLICAL COMPONENT'')') end if call Table1(seBc,nf) C C LONG TERM TREND C write (Nio,'(/,2x,''STOCHASTIC '',A)') $ longTermCad(1:istrlen(LongTermCad)) call TABLE1(hptrend,nf) write (Nio,'(/,2x,''REGRESSION '',A)') $ longTermCad(1:istrlen(LongTermCad)) call TABLE1(hpregt,nf) do i = 1,Nz+nf temp(i) = hptrend(i) + hpregt(i) end do write (Nio,'(/,2X,''TOTAL '',A)') $ longTermCad(1:istrlen(LongTermCad)) call TABLE1(temp,nf) call USRENTRY(temp,1,Nz+nf,1,mpkp,2502) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of '',A)') $ longTermCad(1:istrlen(LongTermCad)) else c write(Nio,'(/2X,''Total error of LONG TERM TREND'')') write(Nio,'(/2X,''Revision error of '',A)') $ longTermCad(1:istrlen(LongTermCad)) c Because we pass fee=0 to SErrorF end if call Table1(seM,nf) else C C CYCLE C do i = 1,Nz totcyc(i) = hpcyc(i) end do write (Nio,'(/,2X,"CYCLICAL COMPONENT")') call TABLE1(hpcyc,nf) call USRENTRY(hpcyc,1,Nz+nf,1,mpkp,2501) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of CYCLICAL COMPONENT'')') else c write(Nio,'(/2X,''Total error of CYCLICAL COMPONENT'')') write(Nio,'(/2X,''Revision error of CYCLICAL COMPONENT'')') end if call Table1(seBc,nf) C C LONG TERM TREND C write (Nio,'(/,2X,A)')longTermCad(1:istrlen(LongTermCad)) call TABLE1(hptrend,nf) call USRENTRY(hptrend,1,Nz+nf,1,mpkp,2502) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of '',A)') $ longTermCad(1:istrlen(LongTermCad)) else c write(Nio,'(/2X,''Total error of LONG TERM TREND'')') write(Nio,'(/2X,''Revision error of '',A)') $ longTermCad(1:istrlen(LongTermCad)) c Because we pass fee=0 to SErrorF end if call Table1(seM,nf) end if else if (ireg .eq. 1) then C C CYCLE C do i = 1,Nz+nf temp(i) = hpcyc(i) + hpregc(i) totcyc(i) = hpcyc(i) + hpregc(i) end do write (Nio,'(/,2X,"STOCHASTIC CYCLICAL COMPONENT")') call TABLE1(hpcyc,nf) write (Nio,'(/,2X,"REGRESSION CYCLICAL COMPONENT")') call TABLE1(hpregc,nf) write (Nio,'(/,2X,"TOTAL CYCLICAL COMPONENT")') call TABLE1(temp,nf) do i = 1,Nz+nf temp(i) = 100.0d0 * (compHP(i)/(kons*EXP(hptrend(i)))) end do write (Nio,'(/,2X,"STOCHASTIC CYCLICAL FACTOR")') call TABLE1(temp,nf) do i = 1,Nz+nf temp(i) = 100.0d0 * EXP(hpregc(i)) end do write (Nio,'(/,2X,"REGRESSION CYCLICAL FACTOR")') call TABLE1(temp,nf) do i = 1,Nz+nf temp(i) = $ 100.0d0 * (compHP(i)/(kons*EXP(hptrend(i))))*exp(hpregc(i)) totcyc(i) = $ 100.0d0 * (compHP(i)/(kons*EXP(hptrend(i))))*exp(hpregc(i)) end do write (Nio,'(/,2X,"TOTAL CYCLICAL FACTOR")') call TABLE1(temp,nf) call USRENTRY(temp,1,Nz+nf,1,mpkp,2501) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of CYCLICAL FACTOR'')') else c write(Nio,'(/2X,''Total error of CYCLICAL FACTOR'')') write(Nio,'(/2X,''Revision error of CYCLICAL FACTOR'')') end if call Table1(seBc,nf) C C LONG TERM TREND C write (Nio,'(/,2x,''STOCHASTIC '',A)') $ LongTermCad(1:istrlen(LongTermCad)) call TABLE1(hptrend,nf) write (Nio,'(/,2x,''REGRESSION '',A)') $ LongTermCad(1:istrlen(LongTermCad)) call TABLE1(hpregt,nf) do i = 1,Nz+nf temp(i) = hptrend(i) + hpregt(i) end do write (Nio,'(/,2x,''TOTAL '',A)') $ LongTermCad(1:istrlen(LongTermCad)) call TABLE1(temp,nf) do i = 1,Nz+nf temp(i) = kons * EXP(hptrend(i)) end do write (Nio,'(/,2X,''STOCHASTIC '',A)') $ LongTermCad(1:istrlen(LongTermCad)) call TABLE1(temp,nf) do i = 1,Nz+nf temp(i) = EXP(hpregt(i)) end do write (Nio,'(/,2X,''REGRESSION '',A)') $ LongTermCad(1:istrlen(LongTermCad)) call TABLE1(temp,nf) do i = 1,Nz+nf temp(i) = kons * EXP(hptrend(i)) * exp(hpregt(i)) end do write (Nio,'(/,2X,''TOTAL '',A)') $ LongTermCad(1:istrlen(LongTermCad)) call TABLE1(temp,nf) call USRENTRY(temp,1,Nz+nf,1,mpkp,2502) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of '',A)') $ LongTermCad(1:istrlen(LongTermCad)) else c write(Nio,'(/2X,''Total error of LONG TERM TREND'')') write(Nio,'(/2X,''Revision error of '',A)') $ LongTermCad(1:istrlen(LongTermCad)) end if call Table1(seM,nf) else C C CYCLE C do i = 1,Nz+nf temp(i) = 100.0d0 * (compHP(i)/(kons*EXP(hptrend(i)))) totcyc(i) = 100.0d0 * (compHP(i)/(kons*EXP(hptrend(i)))) end do write (Nio,'(/,2X,"CYCLICAL COMPONENT")') call TABLE1(hpcyc,nf) write (Nio,'(/,2X,"CYCLICAL FACTORS")') call TABLE1(temp,nf) call USRENTRY(temp,1,Nz+nf,1,mpkp,2501) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of CYCLICAL FACTOR'')') else c write(Nio,'(/2X,''Total error of CYCLICAL FACTOR'')') write(Nio,'(/2X,''Revision error of CYCLICAL FACTOR'')') end if call Table1(seBc,nf) C C LONG TERM TREND C write (Nio,'(/,2X,A," COMPONENT")') $ LongTermCad(1:istrlen(LongTermCad)) call TABLE1(hptrend,nf) do i = 1,Nz+nf temp(i) = kons * EXP(hptrend(i)) end do write (Nio,'(/,2X,A)')LongTermCad(1:istrlen(LongTermCad)) call TABLE1(temp,nf) call USRENTRY(temp,1,Nz+nf,1,mpkp,2502) if (withoutVf.ne.0) then write(Nio,'(/2X,''Revision error of '',A)') $ LongTermCad(1:istrlen(LongTermCad)) else c write(Nio,'(/2X,''Total error of LONG TERM TREND'')') write(Nio,'(/2X,''Revision error of '',A)') $ LongTermCad(1:istrlen(LongTermCad)) end if call Table1(seM,nf) end if end if end C C C subroutine TABLE1(datax,nfor) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 datax(*) C.. In/Out Status: Read, Overwritten .. C.. In/Out Status: Read, Not Written .. integer nfor C C.. Local Scalars .. integer i,i1,i2,ifact,j,jfact,kfreq,ndecp,nfreq1,nnper, $ nper1,nx,ny,nyr integer*4 yr,krest real*8 sum,zz integer*4 decp C C.. Local Arrays .. character fdecp1(7)*8,fn1(12)*8,fn2(12)*8,fnfreq(3)*8,mth(12)*4, $ srt(11)*4,srt0(4)*4,srt1(6)*4,wrt0(8)*8,wrt2(7)*8, $ wrt99(7)*8 C C.. Intrinsic Functions .. intrinsic ABS, INT, LOG10 include 'sform.i' include 'stream.i' C C.. Data Declarations .. data mth/ $ 'JAN ','FEB ','MAR ','APR ','MAY ','JUN','JUL','AUG ','SEP', $ 'OCT ','NOV ','DEC '/ data srt/ $ '1ST','2ND','3RD','4TH','5TH','6TH','7TH','8TH','9TH','10TH', $ '11TH'/ data srt0/'1ST','2ND','1ST','2ND'/ data srt1/'1ST','2ND','3RD','1ST','2ND','3RD'/ data wrt2/'(1H ,I4,','N2','X,','N1','(F10','.DECP','))'/ data wrt0/ $ '(1H ,I4,','"-", I4,','N2','X,','N1','(F10','.DECP','))'/ data wrt99/'(/,1X,','"YEAR"','2X,','N2','(6X,','A4','))'/ data fdecp1/'.0','.1','.2','.3','.4','.5','.6'/ data fn1/'1','2','3','4','5','6','7','8','9','10','11','12'/ data fn2/ $ '2','12','22','32','42','52','62','72','82','092','102','112' $ / data fnfreq/'4','12','6'/ C C ... Executable Statements ... C decp = 3 kfreq = Nfreq if (kfreq .lt. 4) then if (Nfreq .eq. 3) then kfreq = 6 else kfreq = 4 end if end if nnper = Nper if (Nper .gt. Nfreq) then Nper = Nfreq else if (Nper.eq.0) then Nper = 1 end if ndecp = decp if (decp .ge. 6) then decp = 6 end if c if (decp .ne. 0) then c mdecp = 10 - decp c a = 0.00999999 * 10**mdecp c do i = 1,Nz c if (datax(i) .ge. a) then c decp = decp - 1 c end if c end do c end if zz = LOG10(ABS(datax(1))+.0000000001d0) sum = ABS(zz) do i = 2,Nz+nfor if (zz .gt. 0.0d0) then sum = 0.0d0 goto 5000 else zz = LOG10(ABS(datax(i))+.0000000001d0) if ((ABS(zz).lt.sum) .and. (zz.lt.0.0d0)) then sum = ABS(zz) end if end if end do 5000 if (zz .gt. 0.0d0) then sum = 0.0d0 end if ifact = 0 if (sum .gt. 1.0d0) then ifact = INT(sum) if (ifact .gt. 6) then ifact = 6 end if if (ifact .gt. 0) then write (Nio,'(4X, "X 10.0D",I2,/)') -ifact end if end if jfact = 0 zz = LOG10(ABS(datax(1))+.0000000001d0) sum = zz do i = 2,Nz+nfor zz = LOG10(ABS(datax(i))+.0000000001d0) if ((zz.gt.sum) .and. (zz.gt.0.0d0)) then sum = zz end if end do if (sum .gt. 4.0d0) then jfact = INT(sum) - 2 if (jfact .gt. 0) then write (Nio,'(4X, "X 10.0D",I2,/)') jfact end if end if yr = Nyer if (Nfreq .eq. 12) then 7000 format (/,1x,'YEAR',2x,12(6x,a4)/) write (Nio,7000) (mth(i), i = 1,12) C ELSE IF (NFREQ.EQ.4) THEN C WRITE(NIO,2002) (QRT(I),I=1,4) C ELSE IF (NFREQ.EQ.6) THEN C WRITE(NIO,2003) (SRT(I),I=1,6) else if (Nfreq .eq. 3) then 7001 format (/,3x,'YEAR',5x,6(6x,a4)/) write (Nio,7001) (srt1(i), i = 1,6) else if (Nfreq .eq. 2) then 7002 format (/,3x,'YEAR',5x,4(6x,a4)/) write (Nio,7002) (srt0(i), i = 1,4) else if (Nfreq .eq. 1) then write (Nio,7002) (srt(i), i = 1,4) else wrt99(4) = fn1(Nfreq) write (Nio,wrt99) (srt(i), i = 1,Nfreq) end if nyr = (Nz-(Nfreq-Nper+1)) / Nfreq ny = (Nz-(Nfreq-Nper+1)) - nyr*Nfreq if (ny .ne. 0) then nyr = nyr + 1 end if nyr = nyr + 1 wrt2(6) = fdecp1(decp+1) do i = 1,nyr i1 = (i-1)*kfreq - (Nper-2) i2 = i*kfreq - (Nper-1) krest = 0 if (i2 .ge. Nz) then krest = i2-Nz i2 = Nz end if if (Nfreq .ge. 4) then wrt2(2) = fn2(1) wrt2(4) = fn1(kfreq) else wrt0(3) = fn2(1) wrt0(5) = fn1(kfreq) wrt0(7) = fdecp1(decp+1) end if if (i .eq. 1) then if (Nfreq .ge. 4) then wrt2(4) = fn1(kfreq-Nper+1) wrt2(2) = fn2(Nper) else wrt0(3) = fn2(Nper) wrt0(5) = fn1(kfreq-Nper+1) end if i1 = 1 end if if (Nfreq .lt. 4) then if (ifact .gt. 0) then write (Nio,wrt0) $ yr, (yr+kfreq/Nfreq-1), $ (datax(j)*(10.0d0**ifact), j = i1,i2) else write (Nio,wrt0) $ yr, (yr+kfreq/Nfreq-1), $ (datax(j)*(10.0d0**(-jfact)), j = i1,i2) end if else if (ifact .gt. 0) then write (Nio,wrt2) yr, (datax(j)*(10.0d0**ifact), j = i1,i2) else write (Nio,wrt2) yr, (datax(j)*(10.0d0**(-jfact)), j = i1,i2) end if if (Nfreq .lt. 4) then yr = yr + kfreq/Nfreq - krest/Nfreq else yr = yr + 1 end if if (i2 .ge. Nz) goto 5001 end do 5001 decp = ndecp Nper = nnper C C OUTPUT THE FORECAST C nfreq1 = Nfreq nper1 = 1 c nper1 = Kfreq - Krest + 1 nx = (Nz+nper-1) / nfreq1 nx = (Nz+nper-1) - nx*nfreq1 if (nx .gt. 0) then nper1 = nx+1 yr = yr - 1 if (nper1 .gt. nfreq1) then nper1 = nper1 - nfreq1 end if end if write (Nio,'(1X,"FORECAST : ")') nyr = (nfor-(nfreq1-nper1+1)) / nfreq1 ny = (nfor-(nfreq1-nper1+1)) - nyr*nfreq1 if (ny .ne. 0) then nyr = nyr + 1 end if nyr = nyr + 1 do i = 1,nyr i1 = (i-1)*kfreq - (Nper1-2) i2 = i*kfreq - (Nper1-1) if (Nz+i2 .ge. Nz+nfor) then i2 = nfor end if wrt2(2) = fn2(1) wrt2(4) = fnfreq(1) if (Nfreq .ge. 4) then wrt2(2) = fn2(1) wrt2(4) = fn1(kfreq) else wrt0(3) = fn2(1) wrt0(5) = fn1(kfreq) wrt0(7) = fdecp1(decp+1) end if if (i .eq. 1) then if (Nfreq .ge. 4) then wrt2(4) = fn1(kfreq-Nper1+1) wrt2(2) = fn2(Nper1) else wrt0(3) = fn2(Nper1) wrt0(5) = fn1(kfreq-Nper1+1) end if i1 = 1 end if if (Nfreq .lt. 4) then if (ifact .gt. 0) then write (Nio,wrt0) $ yr, (yr+kfreq/Nfreq-1), $ (datax(Nz+j)*(10.0d0**ifact), j = i1,i2) else write (Nio,wrt0) $ yr, (yr+kfreq/Nfreq-1), $ (datax(Nz+j)*(10.0d0**(-jfact)), j = i1,i2) end if else if (ifact .gt. 0) then write (Nio,wrt2) yr, (datax(Nz+j)*(10.0d0**ifact), j = i1,i2) else write (Nio,wrt2) yr, (datax(Nz+j)*(10.0d0**(-jfact)), j = i1,i2) end if if (Nfreq .lt. 4) then yr = yr + kfreq/Nfreq else yr = yr + 1 end if if (i2 .ge. nfor) goto 5002 end do 5002 decp = ndecp Nfreq = nfreq1 * Nper = nper1 end C C C subroutine RATESGROWTH(mq,lam,sqf,oz,trend,sa,nz,sigpt1, $ sigat1,nlen,sigptac,sigatac,sigptaf, $ sigataf,sigptmq,sigatmq,rcetre,rceadj, $ teetre,teeadj,psiep,psiea,psitot,lf,nyer, $ nper,reverse,pg,rogtable,iter,title,out, $ THstar,lTHstar,HFp,lHp0,Vrp,HFsa,lHFsa, $ Vrsa) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'stdio.i' INCLUDE 'srslen.prm' C Modified by REG, on 21 Apr 2006 INCLUDE 'tbl5x.i' real*8 sCoef integer nfl,mp,kp,nOutPar parameter (kp = PFCST, mp = POBS, nfl = 2*mp, nOutPar=36) C C.. Formal Arguments .. integer mq,lam,nz,nlen,lf,nyer,nper,pg,rogtable,iter,out,lTHstar, $ lHFsa,lHp0 integer Reverse character title*80 real*8 sqf,oz(*),trend(*),sa(*),sigpt1(0:kp),sigat1(0:kp), $ sigptac(kp),sigatac(kp),sigptaf(kp),sigataf(kp),sigptmq(2), $ sigatmq(2),rcetre(0:12),rceadj(0:12),teetre(0:12), $ teeadj(0:12),psiep(nfl),psiea(nfl),psitot(nfl),HFp(59),Vrp, $ THstar(27),HFsa(59),Vrsa C C.. Local Scalars .. integer finbucle real*8 wvalue integer i,ifact,ifail,j,jfact,k,kfact,lagr,nlastper,nlastpsave, $ nlastyear,nlastysave,nroga1,nrogamq,nrogp1,nrogpmq,nrogx1, $ nrogxmq,nsdrev,kmq integer Nyer2, Nper2 C LINES OF CODE ADDED FOR X-13A-S : 1 integer noutdir C END OF CODE BLOCK character filename*180,fname*30,subtitle*50 real*8 a,b,c,d,e,f,g,h,o,racca,raccp,raccx,rmqa1,rmqa2,rmqp1, $ rmqp2,rmqx1,rmqx2,sdatac,sdatac1,sdatac2,sdchecka,sdcheckp, $ sdptac,sdptac1,sdptac2, $ sdrmqx1,sdrmqx2,sum,sum1,suma,suma1,suma2,sump,sump1,sump2 real*8 sumx1,sumx2,varf,vart,vprf,vprt,vramq,vrpmq,zz C C.. Local Arrays .. character mth(12)*4,srt(8)*4,cq*1 real*8 roga1(kp),rogamq(kp),rogp1(kp),rogpmq(kp),rogx1(kp), $ rogxmq(kp), $ sdreva1tmp(kp), $ sdrevp1tmp(kp),tmp(8),tmpsa(8), $ tmpser(8),tmptr(8) real*8 SDrev_p(nOutPar), !SDrev(i):component revision SE of Trend $ SDR1_p(nOutPar), !SDR1(i):revision SE T(1,1) of Trend $ SDR1f_p, !SDR1f:revision SE (1-F) of Trend $ SDRmq_p(nOutPar), !SDRmq(i):revision SE T(1,mq) of Trend $ SDRmqF_p, !revision SE of (1-F^mq) for concurrent of Trend $ SDRmqC_p, !revision SE of (B^(mq/2-1)-F^(mq/2)) of Trend $ SDRmqC2_p,!revision SE of (B^(mq/2-2)-F^(mq/2-1)) of Trend $ SDRmqPf, !revision SE of annual rate for the present year $ SDrev_SA(nOutPar), !SDrev(i):component revision SE of SA $ SDR1_SA(nOutPar), !SDR1(i):revision SE T(1,1) of SA $ SDR1f_SA, !SDR1f:revision SE (1-F) of SA $ SDRmq_SA(nOutPar), !SDRmq(i):revision SE T(1,mq) of SA $ SDRmqF_SA, !revision SE of (1-F^mq) for concurrent of SA $ SDRmqC_SA, !revision SE of (B^(mq/2-1)-F^(mq/2)) $ SDRmqC2_SA, !revision SE of (B^(mq/2-2)-F^(mq/2-1)) $ SDRmqSAf !revision SE of annual rate for the present year C C.. External Functions .. integer ISTRLEN external ISTRLEN C C.. External Calls .. external CLOSEDEVICE, OPENDEVICE, ROGEST, ROGSIG C C.. Intrinsic Functions .. intrinsic ABS, INT, LOG10, MOD, SQRT include 'dirs.i' include 'stream.i' include 'seatop.cmn' C C.. Data Declarations .. data mth/ $ 'JAN ','FEB ','MAR ','APR ','MAY ','JUN','JUL','AUG ','SEP', $ 'OCT ','NOV ','DEC '/ data srt/'1ST','2ND','3RD','4TH','5TH','6TH','7TH','8TH'/ data cq/'"'/ C C ... Executable Statements ... C nlastper = nper nlastyear = nyer do i = 2,nz if (MOD(nlastper,mq) .eq. 0) then nlastyear = nlastyear + 1 nlastper = 0 end if nlastper = nlastper + 1 end do nlastpsave = nlastper nlastysave = nlastyear c write(nio,'("SErates of TREND",I3,G11.3,G11.3)') nOutPar,Sqf,Vrp call SErates(HFp,lHp0,THstar,lTHstar,PSIEP,lf,Vrp,Sqf*Sqf,mq, $ nLastPer,nOutPar, $ SDrev_p,SDR1_p,SDR1f_p,SDRmqF_p,SDRmqC_p,SDRmqPf, $ SDRmq_P,SDRmqC2_p) c call SEratesOut(SDrev_P,SDR1_P,SDR1f_P,SDRmq_P,SDRmqF_P, c $ SDRmqC_P,SDRmqPf,SDRmqC2_P,nOutPar,nio) c write(nio,'("SErates of SA")') call SErates(HFsa,lHFsa,THstar,lTHstar,PSIEA,lf,Vrsa,Sqf*Sqf,mq, $ nLastPer,nOutPar, $ SDrev_SA,SDR1_SA,SDR1f_SA,SDRmqF_SA,SDRmqC_SA,SDRmqSAf, $ SDRmq_SA,SDRmqC2_SA) c call SEratesOut(SDrev_SA,SDR1_SA,SDR1f_SA,SDRmq_SA,SDRmqF_SA, c $ SDRmqC_SA,SDRmqSAf,SDRmqC2_SA,nOutPar,nio) lagr = 1 a = 0D0 b = 0D0 c = 0D0 d = 0D0 e = 0D0 f = 0D0 g = 0D0 h = 0D0 o = 0D0 call ROGEST(oz,nz,rogx1,nrogx1,mq,lam,lagr) call ROGEST(sa,nz,roga1,nroga1,mq,lam,lagr) call ROGEST(trend,nz,rogp1,nrogp1,mq,lam,lagr) * do k = 1,nroga1 * suma = 0.0d0 * sump = 0.0d0 * do j = k,lf-1 * suma = suma + (psiea(lf+1-j)-psiea(lf+1-j-1))**2 * sump = sump + (psiep(lf+1-j)-psiep(lf+1-j-1))**2 * end do * sdreva1(k) = suma * sdrevp1(k) = sump * end do if (lam .eq. 0) then do j = 1,nroga1 SDR1_SA(j)=SDR1_SA(j)*100D0 SDR1_P(j)=SDR1_P(j)*100D0 end do end if if (out.eq.0) then write (nio, $'(///," PART 5 : RATES OF GROWTH",/, $" ------------------------",//)') if (lam .eq. 0) then write (nio,'(3x,"THE RATE-OF-GROWTH OF SERIES Z(t) OVER", $" THE PERIOD (t1,t2) IS EXPRESSED",/,3x, $"IN PERCENT POINTS AS",/,24x, $"[ (Z(t2) / Z(t1)) -1] * 100",/)') write (nio,'(/,3x,"ALL STANDARD ERRORS REPORTED FOR THE ", $"RATES-OF GROWTH IN THE FOLLOWING TABLES ARE COMPUTED",/,3x, $ "USING LINEAR APPROXIMATION TO THE RATES.",/,3x, $"WHEN PERIOD-TO-PERIOD CHANGES ARE LARGE, THESE STANDARD", $ " ERRORS SHOULD BE INTERPRETED",/,3x, $ "AS BROAD APPROXIMATIONS, THAT WILL TEND TO ", $ "UNDERESTIMATE THE TRUE VALUES",/)') write (nio,'(/,3x,"THE ERROR VARIANCES ARE BASED ON THE ", $"ESTIMATION ERROR OF THE STOCHASTIC TREND AND SA",/,3x, $ "SERIES, AND THE ERRORS IN THE PARAMETER ESTIMATES ", $ "ARE NOT CONSIDERED.",/,3x,"GIVEN THAT THE ", $ "VARIANCES OF THE LATER GO TO ZERO AS t BECOMES ", $ "LARGE, THEY WILL TYPICALLY",/,3x,"BE DOMINATED ", $ "BY THE ESTIMATION ERROR VARIANCE OF THE STOCHASTIC ", $ "COMPONENTS.",/,3x,"(THIS DOMINANCE WILL BE ", $ "WEAKEST IN THE VICINITY OF OUTLIERS.)",/)') else write (nio,'(3x,"GROWTH OF SERIES Z(t) OVER THE PERIOD", $ " (t1,t2) IS EXPRESSED AS",/,24x,"[ Z(t2) / Z(t1)]")') write (nio,'(/,3x,"THE ERROR VARIANCES ARE BASED ON THE ", $"ESTIMATION ERROR OF THE STOCHASTIC TREND AND SA",/,3x, $ "SERIES, AND THE ERRORS IN THE PARAMETER ESTIMATES ", $ "ARE NOT CONSIDERED.",/,3x,"GIVEN THAT THE ", $ "VARIANCES OF THE LATER GO TO ZERO AS t BECOMES ", $ "LARGE, THEY WILL TYPICALLY BE DOMINATED",/,3x, $ "BY THE ESTIMATION ERROR VARIANCE OF THE STOCHASTIC ", $ "COMPONENTS.",/,3x,"(THIS DOMINANCE WILL BE ", $ "WEAKEST IN THE VICINITY OF OUTLIERS.),/")') write (nio,'(/,3x,''SINCE THE SERIES IS MODELLED IN LEVELS'', $ '' AND ITS DECOMPOSITION IS ADDITIVE, THE'',/,3x,a, $ ''"RATES OF GROWTH" ARE SIMPLY DENOTED "GROWTH" OF '', $ ''THE SERIES IN QUESTION.'',/,3x, $ ''This growth can be transformed easily into a rate '', $ ''(dividing by the value at the'',/,3x,''starting period '', $ ''and multiplying by 100).'',/,3x, $ ''Alternatively, a usually good approximation can be '', $ ''obtained by re-running'',/,3x, $ ''SEATS with LAM=0, the same model, and reestimating '', $ ''the parameters'',/)')cq,cq,cq,cq end if write (nio, $ '(/,3x,''IN THE TABLES THAT FOLLOW :'',//,3x,''ORIGINAL SERIES'' $ ,/,3x,"---------------",/,18x, $ ''DENOTES THE OBSERVED SERIES, UNLESS '', $ ''THERE ARE MISSING VALUES,'',/,18x, $ ''IN WHICH CASE IT DENOTES THE INTERPOLATED SERIES.''//,3x, $ ''TREND-CYCLE AND SA SERIES'',/,3x,''-------------------------'', $/,29x,''DENOTE THE FINAL ESTIMATORS, WITH DETERMINISTIC '',/,29x, $ ''EFFECTS (IF PRESENT) INCLUDED.'',/)') write (nio,'(/,4x,"A. PERIOD-TO-PERIOD RATE-OF-GROWTH OF ", $ "THE SERIES. T(1,1)",/)') end if C C TABLE 5.1 C C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.1, and an alternate finite sample version IF ( .not.Lfinit ) THEN tmp(1) = sigpt1(nlen+1)**2 tmp(2) = sigat1(nlen+1)**2 tmp(3) = SDR1_P(1)**2 tmp(4) = SDR1_SA(1)**2 tmp(5) = sigpt1(nlen+1)**2 + SDR1_P(1)**2 tmp(6) = sigat1(nlen+1)**2 + SDR1_SA(1)**2 tmp(7) = SQRT(sigpt1(nlen+1)**2+SDR1_P(1)**2) tmp(8) = SQRT(sigat1(nlen+1)**2+SDR1_SA(1)**2) ELSE C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 if ( lam .eq. 0 ) then sCoef = 10000D0 else sCoef = 1.0D0 end if tmp(1) = vTbl51(1)*sCoef tmp(2) = vTbl51(2)*sCoef tmp(3) = vTbl51(3)*sCoef tmp(4) = vTbl51(4)*sCoef tmp(5) = vTbl51(5)*sCoef tmp(6) = vTbl51(6)*sCoef tmp(7) = SQRT( vTbl51(5)*sCoef ) tmp(8) = SQRT( vTbl51(6)*sCoef ) END IF call setT11t(tmp(7)) call setT11sa(tmp(8)) zz = LOG10(ABS(tmp(1)+.0000000001d0)) sum = ABS(zz) do i = 2,8 if (zz .gt. 0.0d0) then sum = 0.0d0 goto 5000 else zz = LOG10(ABS(tmp(i)+.0000000001d0)) if ((ABS(zz).lt.sum) .and. (zz.lt.0.0d0)) then sum = ABS(zz) end if end if end do 5000 if (sum .gt. 1.0d0) then ifact = INT(sum) if (ifact .gt. 9) then ifact = 9 end if end if jfact = 0 zz = LOG10(ABS(tmp(1)+.0000000001d0)) sum = zz do i = 2,8 zz = LOG10(ABS(tmp(i)+.0000000001d0)) if ((zz.gt.sum) .and. (zz.gt.0.0d0)) then sum = zz end if end do if (sum .gt. 4.0d0) then jfact = INT(sum) - 2 end if ifact = -jfact if (out.eq.0) then write (nio, $ '(6x,''TABLE 5.1 RATE T(1,1) : ESTIMATION ERROR VARIANCE'')') write (nio, $ '(6x,''-------------------------------------------------'')') if (ABS(ifact) .gt. 0) then write (nio,'(8X,''(X 1.0D'',I2,'')'',//)') ifact else write (nio,'(/)') end if write (nio,'(8x,"CONCURRENT ESTIMATOR",12x,"TREND-CYCLE",4x, $ "SA SERIES",/)') write (nio,'(8X,"FINAL ESTIMATION ERROR",9X,F9.3,5X,F9.3,/)') $ tmp(1)*(10.0d0**ifact), tmp(2)*(10.0d0**ifact) write (nio,'(8X,"REVISION ERROR",17X,F9.3,5X,F9.3,/)') $ tmp(3)*(10.0d0**ifact), tmp(4)*(10.0d0**ifact) write (nio,'(8X,"TOTAL ESTIMATION ERROR"9X,F9.3,5X,F9.3,/)') $ tmp(5)*(10.0d0**ifact), tmp(6)*(10.0d0**ifact) write (nio,'(15x,"(SD)",19x,"(",f9.3,")",3x, $ "(",f9.3,")",/)') $ tmp(7)*(10.0d0**ifact), tmp(8)*(10.0d0**ifact) end if C C TABLE 5.2 C if (out.eq.0) then write (nio,'(//3x,"AS MENTIONED BEFORE, ", $"FOR APPLIED PURPOSES, THE RELEVANT ERROR IS THE FULL ", $"REVISION THE",/,3x,"MEASUREMENT WILL UNDERGO.",/,3x, $"ACCORDINGLY, THE STANDARD ERRORS APPEARING IN MOST ", $"OF THE NEXT TABLES ARE THE",/,3x,"ONES IMPLIED ", $"BY THE REVISION ERROR.")') write (nio,'(3x,"THESE S.E. CAN BE USED TO BUILD ", $ "CONFIDENCE INTERVALS AROUND THE CONCURRENT OR,",/,3x, $ "IN GENERAL, PRELIMINARY ESTIMATORS, THAT INDICATE ", $ "A LIKELY RANGE FOR THE EVENTUAL",/,3x,"FINAL ESTIMATOR.")' $ ) write (nio,'(3x,"THE S.E. CAN ALSO BE USED TO TEST FOR ", $ "SPECIFIC HYPOTHESIS.",/,3x, $ "FOR EXAMPLE IN TABLE 5.2 (BELOW), LET RC(t) BE THE ", $ "CONCURRENT ESTIMATOR OF A RATE FOR ",/,3x,"PERIOD t. IF : " $ ,//,18x,"| RC(t)/SE[RC(t)] | > 1.645",//,3x $ "WE CAN REJECT (AT THE 90% LEVEL) THAT THE EVENTUAL ", $ "FINAL ESTIMATOR OF THE RATE",/,3x, $ "FOR PERIOD t COULD BE ZERO.")') if (lam .eq. 0) then write (nio,'(//,6x,"TABLE 5.2 PERIOD-TO-PERIOD RATE T(1,1) ", $ "FOR THE MOST RECENT PERIODS")') write(nio,'(6x,''---------------------------------------'', $ ''---------------------------'')') write(nio,'(19x,''With associated SE in Percent points.'',//)') else write (nio,'(//,6x,"TABLE 5.2 PERIOD-TO-PERIOD GROWTH ", $ "T(1,1) FOR THE MOST RECENT PERIODS")') write (nio,'(6x,"---------------------------------------", $ "---------------------------")') write (nio,'(32X,"With associated SE.",//)') end if write (nio,'(8x,''DATE'',11x,''ORIGINAL'',21x,''TREND-CYCLE'', $ 24x,''SA SERIES'',/,23x,''SERIES'',/,46x,''ESTIMATE'',12x, $ ''SER'',11x,''ESTIMATE'',12x,''SER'',/)') if (mq .eq. 12) then do i = 1,nroga1 C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.2, and an alternate finite sample version if ( .not. Lfinit ) then write (nio,'(5x,a3,"-",i4,5x,g11.3,14x,g11.3,3x,g11.3, $ 9x,g11.3,3x,g11.3)') $ mth(nlastper), nlastyear, rogx1(i), rogp1(i), SDR1_P(i), $ roga1(i), SDR1_SA(i) else if ( i .le. nTreGRSE1(1) ) then C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 if ( lam .eq. 0 ) then sCoef = 100D0 else sCoef = 1.0D0 end if write (nio,'(5x,a3,"-",i4,5x,g11.3,14x,g11.3,3x,g11.3, $ 9x,g11.3,3x,g11.3)') $ mth(nlastper), nlastyear, rogx1(i), $ rogp1(i), vTreGRSE1(i)*sCoef, roga1(i), vSeaGRSE1(i)*sCoef end if if (nlastper .eq. 1) then nlastper = mq nlastyear = nlastyear - 1 else nlastper = nlastper - 1 end if end do else do i = 1,nroga1 C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.2, and an alternate finite sample version if ( .not. Lfinit ) then write (nio,'(5x,a3,"-",i4,5x,g11.3,14x,g11.3,3x,g11.3,9x, $ g11.3,3x,g11.3)') $ srt(nlastper), nlastyear, rogx1(i), rogp1(i), SDR1_P(i), $ roga1(i), SDR1_SA(i) else if ( i .le. nTreGRSE1(1) ) then C Modified by REG, on 26 May 2006, to provide percentage GRs for lam=0 if ( lam .eq. 0 ) then sCoef = 100D0 else sCoef = 1.0D0 end if write (nio,'(5x,a3,"-",i4,5x,g11.3,14x,g11.3,3x,g11.3,9x, $ g11.3,3x,g11.3)') $ srt(nlastper), nlastyear, rogx1(i), $ rogp1(i), vTreGRSE1(i)*sCoef, roga1(i), vSeaGRSE1(i)*sCoef end if if (nlastper .eq. 1) then nlastper = mq nlastyear = nlastyear - 1 else nlastper = nlastper - 1 end if end do end if end if c if (rogtable .eq. 1) then if (iter .ne. 0) then write (54,*) title end if write (54,'(30x,''ORIGINAL SERIES'',10x,''TREND-CYCLE'',12x, $ ''SA SERIES'')') write (54,'(4X,''T11 RATE :'',20X,g10.3,12X,g10.3,12X,g10.3,/)') $ rogx1(1), rogp1(1), roga1(1) end if C C HERE INTRODUCE THE GRAPH FOR T11 RATE C * if ((pg .eq. 0).and.(iter.eq.0).and.(out.lt.2)) then * Nper2 = Nper * Nyer2 = Nyer * Nper = nlastpsave * Nyer = nlastysave * Reverse = 1 *c cambiamos el sentido del arra1 Xi<-->Xn+1-i *c *CUNX#ifdef TSW *!DEC$ IF DEFINED (TSW) * reverse = 0 * finbucle=nroga1-1 * Do i=1,finbucle * nper=nper-1 * if (nper.eq.0) then * nyer = nyer-1 * nper = mq * end if * end do * finbucle = int(nroga1/2) * Do i=1, finbucle * wvalue = rogx1(i) * rogx1(i) = rogx1(nroga1+1-i) * rogx1(nroga1+1-i) = wvalue * wvalue = rogp1(i) * rogp1(i) = rogp1(nroga1+1-i) * rogp1(nroga1+1-i) = wvalue * wvalue = roga1(i) * roga1(i) = roga1(nroga1+1-i) * roga1(nroga1+1-i) = wvalue * end do *!DEC$ END IF *CUNX#end if * fname = 'ROGX1.T' * subtitle = 'T(1,1) RATE ORIGINAL SERIES' * call PLOTRSERIES(fname,subtitle,rogx1,nroga1,1,999.0d0) * fname = 'ROGP1.T' * subtitle = 'T(1,1) RATE TREND-CYCLE' * call PLOTRSERIES(fname,subtitle,rogp1,nroga1,1,999.0d0) * fname = 'ROGA1.T' * subtitle = 'T(1,1) RATE SA SERIES' * call PLOTRSERIES(fname,subtitle,roga1,nroga1,1,999.0d0) * Reverse = 0 * Nper = Nper2 * Nyer = Nyer2 * end if C C NOW INSERT THE CHECK ON THE ABOVE TABLE 5.2 C call ROGSIG(sigat1,nlen+1,sdreva1tmp,nsdrev) call ROGSIG(sigpt1,nlen+1,sdrevp1tmp,nsdrev) sdcheckp = 2.0d0*rcetre(0)*(1.0d0-rcetre(1))-psiep(lf)**2 if (sdcheckp.gt.0) then sdcheckp = sqf * SQRT(sdcheckp) end if sdchecka = 2.0d0*rceadj(0)*(1.0d0-rceadj(1))-psiea(lf)**2 if (sdchecka.gt.0) then sdchecka = sqf * SQRT(sdchecka) end if if (lam .eq. 0) then sdcheckp = sdcheckp * 100.0d0 sdchecka = sdchecka * 100.0d0 end if C C END THE CHECK ON THE TABLE 5.2 C C C TABLE 5.3 C C C FIRST METHOD C if (mq .ne.1) then if (out.eq.0) then write (nio,'(/,4x,''B. ACCUMULATED RATE OF GROWTH DURING '', $ ''THE PRESENT YEAR.'',/)') end if if (lam .eq. 0) then raccx = (oz(nz)/oz(nz-nlastpsave)-1.0d0) * 100.0d0 raccp = (trend(nz)/trend(nz-nlastpsave)-1.0d0) * 100.0d0 racca = (sa(nz)/sa(nz-nlastpsave)-1.0d0) * 100.0d0 sump = 0.0d0 suma = 0.0d0 do i = 1,lf-nlastpsave suma = suma + (psiea(lf+1-i)-psiea(lf+1-i-nlastpsave))**2 sump = sump + (psiep(lf+1-i)-psiep(lf+1-i-nlastpsave))**2 end do sdptac = sqf * SQRT(sump) * 100.0d0 sdatac = sqf * SQRT(suma) * 100.0d0 if (out.eq.0) then write (nio,'(/,6x,''TABLE 5.3 ACCUMULATED RATE OF GROWTH '', $ ''DURING THE PRESENT YEAR'')') write (nio,'(6x,''------------------------------------'', $ ''------------------------'')') write (nio,'(30X,''(In percent points)'',//)') if (mq .eq. 12) then write (nio,'(8x,a3,''-'',i4,18x,''ESTIMATE'',14x,''SER'',/)') $ mth(nlastpsave), nlastysave else write (nio,'(8x,a3,''-'',i4,18x,''ESTIMATE'',14x,''SER'',/)') $ srt(nlastpsave), nlastysave end if write (nio,'(8x,''ORIGINAL SERIES'',8x,g11.3,13x,''-'',/)') $ raccx C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.3, and an alternate finite sample version if ( .not. Lfinit ) then write (nio,'(8x,''TREND-CYCLE'',12x,g11.3,5x,g11.3,/)') $ raccp, sdptac write (nio,'(8x,''SA SERIES'',14x,g11.3,5x,g11.3,/)') $ racca, sdatac else C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 write (nio,'(8x,''TREND-CYCLE'',12x,g11.3,5x,g11.3,/)') $ raccp, vTbl53(1)*sCoef write (nio,'(8x,''SA SERIES'',14x,g11.3,5x,g11.3,/)') $ racca, vTbl53(2)*sCoef end if end if else raccx = oz(nz) - oz(nz-nlastpsave) raccp = trend(nz) - trend(nz-nlastpsave) racca = sa(nz) - sa(nz-nlastpsave) sump = 0.0d0 suma = 0.0d0 do i = 1,lf-nlastpsave suma = suma + (psiea(lf+1-i)-psiea(lf+1-i-nlastpsave))**2 sump = sump + (psiep(lf+1-i)-psiep(lf+1-i-nlastpsave))**2 end do sdptac = sqf * SQRT(sump) sdatac = sqf * SQRT(suma) if (out.eq.0) then write (nio, $ '(/,6x,''TABLE 5.3 ACCUMULATED GROWTH DURING THE PRESENT YEAR'') $ ') write (nio,'(6x,''------------------------------------'', $ ''------------------------'',//)') if (mq .eq. 12) then write (nio,'(8x,a3,''-'',i4,18x,''ESTIMATE'',14x,''SER'',/)') $ mth(nlastpsave), nlastysave else write (nio,'(8x,a3,''-'',i4,18x,''ESTIMATE'',14x,''SER'',/)') $ srt(nlastpsave), nlastysave end if write (nio,'(8x,''ORIGINAL SERIES'',8x,g11.3,13x,''-'',/)') $ raccx C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.3, and an alternate finite sample version if(.not. Lfinit)THEN write (nio,'(8x,''TREND-CYCLE'',12x,g11.3,5x,g11.3,/)') $ raccp, sdptac write (nio,'(8x,''SA SERIES'',14x,g11.3,5x,g11.3,/)') $ racca, sdatac else C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 write (nio,'(8x,''TREND-CYCLE'',12x,g11.3,5x,g11.3,/)') $ raccp, vTbl53(1)*sCoef write (nio,'(8x,''SA SERIES'',14x,g11.3,5x,g11.3,/)') $ racca, vTbl53(2)*sCoef end if end if end if if (rogtable .eq. 1) then write (54,'(4x,''ACCUMULATED RATE :'',12x,g10.3,12x,g10.3,12x, $ G10.3,/)') raccx, raccp, racca end if C C CHECK ON THE SE COMPUTATION, SECOND METHOD,THIRD METHOD C C SECOND METHOD sdptac1 = (sigptac(nlastpsave)**2-sigptaf(nlastpsave)**2) sdatac1 = (sigatac(nlastpsave)**2-sigataf(nlastpsave)**2) if (sdptac1 .lt. 0.0d0) then sdptac1 = 0.0d0 end if if (sdatac1 .lt. 0.0d0) then sdatac1 = 0.0d0 end if sdptac1 = SQRT(sdptac1) * ((nlastpsave*1.0d0)/(mq*1.0d0)) sdatac1 = SQRT(sdatac1) * ((nlastpsave*1.0d0)/(mq*1.0d0)) C THIRD METHOD sump = 0.0d0 suma = 0.0d0 do i = 1,lf-nlastpsave suma = suma + (psiea(lf+1-i)-psiea(lf+1-i-nlastpsave))**2 sump = sump + (psiep(lf+1-i)-psiep(lf+1-i-nlastpsave))**2 end do sdptac2 = sqf * SQRT(sump) sdatac2 = sqf * SQRT(suma) if (lam .eq. 0) then sdptac2 = sdptac2 * 100.0d0 sdatac2 = sdatac2 * 100.0d0 end if C C TABLE 5.4 C if (out.eq.0) then if (lam .eq. 0) then write (nio,'(/,4X,''C. RATES OF ANNUAL GROWTH T(1,MQ)'',/)') else write (nio,'(/,4X,''C. ANNUAL GROWTH T(1,MQ)'',/)') end if end if lagr = mq call ROGEST(oz,nz,rogxmq,nrogxmq,mq,lam,lagr) call ROGEST(sa,nz,rogamq,nrogamq,mq,lam,lagr) call ROGEST(trend,nz,rogpmq,nrogpmq,mq,lam,lagr) * do k = 1,nrogamq * suma = 0.0d0 * sump = 0.0d0 * do j = k,lf-mq * suma = suma + (psiea(lf+1-j)-psiea(lf+1-j-mq))**2 * sump = sump + (psiep(lf+1-j)-psiep(lf+1-j-mq))**2 * end do * sdrevamq(k) = suma * sdrevpmq(k) = sump * end do vrpmq = SDRmq_p(1)**2 vramq = SDRmq_sa(1)**2 if (lam .eq. 0) then do j = 1,nrogamq SDRmq_p(j) =SDRmq_p(j)*100 SDRmq_sa(j)=SDRmq_sa(j)*100 * sdrevamq(j) = SQRT(sdrevamq(j)) * sqf * 100.0d0 * sdrevpmq(j) = SQRT(sdrevpmq(j)) * sqf * 100.0d0 * end do * else * do j = 1,nrogamq * sdrevamq(j) = SQRT(sdrevamq(j)) * sqf * sdrevpmq(j) = SQRT(sdrevpmq(j)) * sqf end do end if vprt = 2.0d0 * teetre(0) * (1.0d0-teetre(mq)) vart = 2.0d0 * teeadj(0) * (1.0d0-teeadj(mq)) suma = 0.0d0 sump = 0.0d0 do i = 1,mq suma = suma + psiea(lf+1-i)**2 sump = sump + psiep(lf+1-i)**2 end do vprt = (vprt - sump)*(sqf**2) vart = (vart - suma)*(sqf**2) vprf = vprt - vrpmq varf = vart - vramq if (out.eq.0) then if (lam .eq. 0) then write (nio, $ '(/,6x,''TABLE 5.4 ESTIMATION ERROR VARIANCE :'',/,6x, $ ''-------------------------------------'',/,8x, $ ''Rate of annual growth T(1,MQ), not-centered and'',/,8x, $ ''dated at last observation.'')') else write (nio, $ '(/,6x,''TABLE 5.4 ESTIMATION ERROR VARIANCE :'',/,6x, $ ''-------------------------------------'',/,8x, $ ''Annual growth T(1,MQ), not-centered and dated '',/,8x, $ ''at last observation.'')') end if end if c end if C C HERE IT HAS TO BE INTRODUCED THE CODE TO RESCALE THE VALUES C C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.4, and an alternate finite sample version if ( out .eq. 1 ) then tmp(1) = vprf tmp(2) = varf tmp(3) = vrpmq tmp(4) = vramq tmp(5) = tmp(1) + tmp(3) tmp(6) = tmp(2) + tmp(4) if (tmp(5) .lt. 0) then !To avoid crashes tmp(5)=0 end if if (tmp(6) .lt. 0) then !to avoid crashes tmp(6)=0 end if tmp(7) = SQRT(tmp(5)) tmp(8) = SQRT(tmp(6)) else tmp(1) = vTbl54(1) tmp(2) = vTbl54(2) tmp(3) = vTbl54(3) tmp(4) = vTbl54(4) tmp(5) = vTbl54(5) tmp(6) = vTbl54(6) if (tmp(5) .lt. 0) then !To avoid crashes tmp(5)=0 end if if (tmp(6) .lt. 0) then !to avoid crashes tmp(6)=0 end if tmp(7) = SQRT(tmp(5)) tmp(8) = SQRT(tmp(6)) end if ifact = 0 jfact = 0 zz = LOG10(ABS(tmp(1)+.0000000001d0)) sum = ABS(zz) do i = 2,6 if (zz .gt. 0.0d0) then sum = 0.0d0 goto 5001 else zz = LOG10(ABS(tmp(i)+.0000000001d0)) if ((ABS(zz).lt.sum) .and. (zz.lt.0.0d0)) then sum = ABS(zz) end if end if end do 5001 if (sum .gt. 1.0d0) then ifact = INT(sum) if (ifact .gt. 9) then ifact = 9 end if end if zz = LOG10(ABS(tmp(7)+.0000000001d0)) sum = ABS(zz) if (zz .gt. 0.0d0) then sum = 0.0d0 else zz = LOG10(ABS(tmp(8)+.0000000001d0)) if ((ABS(zz).lt.sum) .and. (zz.lt.0.0d0)) then sum = ABS(zz) end if end if if (sum .gt. 1.0d0) then jfact = INT(sum) if (jfact .gt. 9) then jfact = 9 end if end if kfact = 0 zz = LOG10(ABS(tmp(1)+.0000000001d0)) sum = zz do i = 2,6 zz = LOG10(ABS(tmp(i)+.0000000001d0)) if ((zz.gt.sum) .and. (zz.gt.0.0d0)) then sum = zz end if end do if (sum .gt. 4.0d0) then kfact = INT(sum) - 2 end if if (ifact .eq. 0) then ifact = -kfact end if if (out.eq.0) then if (ABS(ifact) .gt. 0) then write (nio,'(8X,''(X 1.0D'',I1,'')'',//)') ifact else write (nio,'(//)') end if write (nio,'(8x,''CONCURRENT ESTIMATOR'',12x,''TREND-CYCLE'', $ 8x,''SA SERIES'',/)') write(nio,'(8x,''FINAL ESTIMATION ERROR'',12x,f9.3,8x,f9.3,/)') $ tmp(1)*(10.0d0**ifact), tmp(2)*(10.0d0**ifact) write(nio,'(8x,''REVISION ERROR'',20x,f9.3,8x,f9.3,/)') $ tmp(3)*(10.0d0**ifact), tmp(4)*(10.0d0**ifact) write(nio,'(8x,''TOTAL ESTIMATION ERROR'',12x,f9.3,8x,f9.3,/)') $ tmp(5)*(10.0d0**ifact), tmp(6)*(10.0d0**ifact) write(nio,'(12x,''(SD x 1.0D'',i1,'')'',15x,''('',f9.3,'')'', $ 7x,''('',f9.3,'')'',/)') jfact, tmp(7)*(10.0d0**jfact), $ tmp(8)*(10.0d0**jfact) end if C C TABLE 5.5 C if (out.eq.0) then if (lam .eq. 0) then write (nio,'(/,6x,''TABLE 5.5 INTERANNUAL RATE OF GROWTH :'', $ /,6x,''--------------------------------------'',/,8x, $ ''Rate T(1,MQ), not-centered and dated at last observation,'' $ ,/,8x,''FOR THE MOST RECENT PERIODS.'',/,8x, $ ''This rate measures the rate of growth with respect'', $ '' to 1-year ago.'',/,8x,''With standard errors.'',/,8x, $ ''In Percent points.'',//)') else write (nio,'(/,6x,''TABLE 5.5 INTERANNUAL RATE OF GROWTH :'', $ /,6x,''--------------------------------------'',/,8x, $ ''Growth T(1,MQ), not-centered and dated at last observation,'' $ ,/,8x,''FOR THE MOST RECENT PERIODS.'',/,8x, $ ''This rate measures the growth with respect to 1-year ago.'' $ ,/,8x,''With standard errors.'',//)') end if write (nio,'(8x,''DATE'',9x,''ORIGINAL'',21x,''TREND-CYCLE'', $ 24x,''SA SERIES'',/,21x,''SERIES'',/,46x,''ESTIMATE'',12x, $ ''SER'',11x,''ESTIMATE'',12x,''SER'',/)') nlastper = nlastpsave nlastyear = nlastysave if (mq .eq. 12) then do i = 1,nrogamq C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.5, and an alternate finite sample version if ( .not. Lfinit ) then write (nio,'(5x,a3,''-'',i4,5x,g11.3,14x,g11.3,3x, $ g11.3,9x,g11.3,3x,g11.3)') $ mth(nlastper), nlastyear, rogxmq(i), rogpmq(i), $ SDRmq_p(i), rogamq(i), SDRmq_sa(i) else if ( i .le. nTreGRSE2(1) ) then C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 write (nio,'(5x,a3,''-'',i4,5x,g11.3,14x,g11.3,3x, $ g11.3,9x,g11.3,3x,g11.3)') $ mth(nlastper), nlastyear, rogxmq(i), rogpmq(i), $ vTreGRSE2(i)*sCoef, rogamq(i), vSeaGRSE2(i)*sCoef end if if (nlastper .eq. 1) then nlastper = mq nlastyear = nlastyear - 1 else nlastper = nlastper - 1 end if end do else do i = 1,nrogamq C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.5, and an alternate finite sample version if ( .not. Lfinit ) then write (nio,'(5x,a3,''-'',i4,5x,g11.3,14x,g11.3,3x, $ g11.3,9x,g11.3,3x,g11.3)') $ srt(nlastper), nlastyear, rogxmq(i), rogpmq(i), $ SDRmq_p(i), rogamq(i), SDRmq_sa(i) else if ( i .le. nTreGRSE2(1) ) then C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 write (nio,'(5x,a3,''-'',i4,5x,g11.3,14x,g11.3,3x, $ g11.3,9x,g11.3,3x,g11.3)') $ srt(nlastper), nlastyear, rogxmq(i), rogpmq(i), $ vTreGRSE2(i)*sCoef, rogamq(i), vSeaGRSE2(i)*sCoef end if if (nlastper .eq. 1) then nlastper = mq nlastyear = nlastyear - 1 else nlastper = nlastper - 1 end if end do end if end if if (rogtable .eq. 1) then write (54,'(4x,''INTERANNUAL RATE :'',12x,g10.3,12x,g10.3, $ 12x,g10.3)') rogxmq(1), rogpmq(1), rogamq(1) write (54,'(5X,''(non_centered)'',/)') end if if (out.eq.0) then write (nio,'(/,3x,''THE ANNUAL RATE OF GROWTH IN TABLE 5.5'', $ '' MEASURES GROWTH WITH RESPECT TO ONE-YEAR AGO'',/,3x, $ ''BECAUSE IT IS NOT CENTERED, THE MEASURE INDUCES '', $ ''AN IMPORTANT PHASE EFFECT,'',/,3x, $ ''AND CAN BE STRONGLY INFLUENCED BY THE IRREGULAR '', $ ''AND MOVING SEASONAL COMPONENTS.'',/,3x''IT IS THUS A '', $ ''POOR INDICATOR OF THE PRESENT RATE OF ANNUAL'',/,3x, $ ''GROWTH, USEFUL IN SHORT-TERM ANALYSIS.'')') write (nio,'(/,3x,''ASSESSMENTS ON THE PRESENT RATE OF '', $ ''ANNUAL GROWTH SHOULD BE PREFERABLY BE BASED'',/,3x, $ ''ON THE CENTERED MEASUREMENT OF TABLE 5.6 BELOW, '', $ ''WHICH REQUIRES HALF-A-YEAR'',/,3x, $ ''OF FORECAST. THIS CENTERING MINIMIZES PHASE EFFECT '', $ ''AND IS LESS AFFECTED BY THE'',/,3x, $ ''IRREGULAR OR SEASONAL INNOVATIONS.'')') end if C C HERE INTRODUCE THE GRAPH FOR ANNUAL GROWTH C * if ((pg .eq. 0).and.(iter.eq.0).and.(out.lt.2)) then * kmq = mq * mq = 0 * Nper2 = Nper * Nyer2 = Nyer * Nper = nlastpsave * Nyer = nlastysave *CUNX#ifdef TSW *!DEC$ IF DEFINED (TSW) * mq=kmq * reverse = 0 * finbucle=nrogamq-1 * Do i=1,finbucle * nper=nper-1 * if (nper.eq.0) then * nyer = nyer-1 * nper = mq * end if * end do * finbucle = int(nrogamq/2) * Do i=1, finbucle * wvalue = rogxmq(i) * rogxmq(i) = rogxmq(nrogamq+1-i) * rogxmq(nrogamq+1-i) = wvalue * wvalue = rogpmq(i) * rogpmq(i) = rogpmq(nrogamq+1-i) * rogpmq(nrogamq+1-i) = wvalue * wvalue = rogamq(i) * rogamq(i) = rogamq(nrogamq+1-i) * rogamq(nrogamq+1-i) = wvalue * end do *!DEC$ end if *CUNX#end if * fname = 'ROGXMQ.T' * subtitle = 'ANNUAL RATE-OF-GROWTH ORIGINAL SERIES' * call PLOTRSERIES(fname,subtitle,rogxmq,nrogamq,1,999.0d0) * fname = 'ROGPMQ.T' * subtitle = 'ANNUAL RATE-OF-GROWTH TREND-CYCLE' * call PLOTRSERIES(fname,subtitle,rogpmq,nrogamq,1,999.0d0) * fname = 'ROGAMQ.T' * subtitle = 'ANNUAL RATE-OF-GROWTH SA SERIES' * call PLOTRSERIES(fname,subtitle,rogamq,nrogamq,1,999.0d0) * Nper = Nper2 * Nyer = Nyer2 * mq = kmq * end if if ((mq.eq.4) .or. (mq.eq.6) .or. (mq.eq.12)) then if (lam .eq. 0) then rmqx1 = (oz(nz+mq/2)/oz(nz-mq/2)-1.0d0) * 100.0d0 rmqp1 = (trend(nz+mq/2)/trend(nz-mq/2)-1.0d0) * 100.0d0 rmqa1 = (sa(nz+mq/2)/sa(nz-mq/2)-1.0d0) * 100.0d0 rmqx2 = (oz(nz+mq/2-1)/oz(nz-mq/2-1)-1.0d0) * 100.0d0 rmqp2 = (trend(nz+mq/2-1)/trend(nz-mq/2-1)-1.0d0) * 100.0d0 rmqa2 = (sa(nz+mq/2-1)/sa(nz-mq/2-1)-1.0d0) * 100.0d0 else rmqx1 = oz(nz+mq/2) - oz(nz-mq/2) rmqp1 = trend(nz+mq/2) - trend(nz-mq/2) rmqa1 = sa(nz+mq/2) - sa(nz-mq/2) rmqx2 = oz(nz+mq/2-1) - oz(nz-mq/2-1) rmqp2 = trend(nz+mq/2-1) - trend(nz-mq/2-1) rmqa2 = sa(nz+mq/2-1) - sa(nz-mq/2-1) end if sump1 = 0.0d0 sump2 = 0.0d0 sumx1 = 1.0d0 sumx2 = 1.0d0 do i = 1,mq/2-1 sumx1 = sumx1 + psitot(lf+1+i)**2 end do do i = 1,mq/2-2 sumx2 = sumx2 + psitot(lf+1+i)**2 end do if (lam .eq. 0) then sdrmqx1 = sqf * SQRT(sumx1) * 100.0d0 sdrmqx2 = sqf * SQRT(sumx2) * 100.0d0 SDRmqC_P =100*SDRmqC_P SDRmqC_SA=100*SDRmqC_SA SDRmqC2_P =100*SDRmqC2_P SDRmqC2_SA=100*SDRmqC2_SA if (out.eq.0) then write (nio, $ '(/,6x,''TABLE 5.6 PRESENT RATE OF ANNUAL GROWTH :'',/,6x, $ ''-----------------------------------------'',/,8x, $ ''Rate T(1,MQ), centered and dated '', $ ''Annual rate computed as the rate of growth '',/,8x, $ ''over the last (MQ/2) observed periods and '', $ ''the next (MQ/2) forecasts'',/,8x,''at last observed period.'' $ ,/,8x,''With associated standard errors.'',/,8x, $ ''In Percent points.'',//)') end if else sdrmqx1 = sqf * SQRT(sumx1) sdrmqx2 = sqf * SQRT(sumx2) * sdrmqp1 = sqf * SQRT(sump1) * sdrmqa1 = sqf * SQRT(suma1) * sdrmqp2 = sqf * SQRT(sump2) * sdrmqa2 = sqf * SQRT(suma2) if (out.eq.0) then write (nio,'(/,6x,''TABLE 5.6 PRESENT ANNUAL GROWTH :'',/,6x, $ ''---------------------------------'',/,8x, $ ''Growth T(1,MQ), centered and dated at last observed period.'', $ /,8x,''Annual growth computed as the growth '', $ ''over the last (MQ/2)'',/,8x,''observed periods and '', $ ''the next (MQ/2) forecasts'',/,8x, $ ''With associated standard errors.'',//)') end if end if c call setT112x(rmqx1) c call setT112t(rmqp1) c call setT112Sa(rmqa1) call setT112x(SDrmqx1) call setT112t(sqrt(sigptmq(2)**2+SDrmqC_P**2)) call setT112Sa(sqrt(sigatmq(2)**2+SDRmqC_SA**2)) c call setT112x(rmqx1) c call setT112t(rmqp1) c call setT112Sa(rmqa1) call setT112x(SDrmqx1) call setT112t(sqrt(sigptmq(2)**2+SDrmqC_P**2)) call setT112Sa(sqrt(sigatmq(2)**2+SDRmqC_SA**2)) c if (out.eq.0) then write(nio,'(32x,''DATE'',14x,''CENTERED RATE OF'',10x,''SER'', $ 17x,''TSE'')') write (nio,'(50X,''ANNUAL GROWTH'',/)') C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.6, and an alternate finite sample version if (mq .eq. 12) then if (.not.Lfinit) then write (nio,'(8x,''ORIGINAL SERIES'',7x,a3,''-'',i4,12x, $ g11.3,8x,g11.3,8x,g11.3,/)') mth(nlastpsave), nlastysave, $ rmqx1, sdrmqx1, sdrmqx1 if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(nlastpsave-1), nlastysave, rmqx2, sdrmqx2, sdrmqx2 else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(mq), nlastysave, rmqx2, sdrmqx2, sdrmqx2 end if C Modified by REG, on 29 Jun 2006, to correct SE calculation per C Agustin Maravall memo of 22 Jun 2006. write (nio,'(8x,''TREND-CYCLE'',11x,a3,''-'',i4,12x,g11.3, $ 8x,g11.3,8x,g11.3,/)') $ mth(nlastpsave), nlastysave, rmqp1, SDRmqC_p, $ SQRT(sigptmq(2)**2+SDRmqC_P**2) if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(nlastpsave-1), nlastysave, rmqp2, SDRmqC2_P, $ SQRT(sigptmq(2)**2+SDRmqC2_P**2) else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(mq), nlastysave, rmqp2, SDRmqC2_P, $ SQRT(sigptmq(2)**2+SDRmqC2_P**2) end if C Modified by REG, on 29 Jun 2006, to correct SE calculation per C Agustin Maravall memo of 22 Jun 2006. write (nio,'(8x,''SA SERIES'',13x,a3,''-'',i4,12x,g11.3,8x, $ g11.3,8x,g11.3,/)')mth(nlastpsave), nlastysave, $ rmqa1, SDRmqC_sa, $ SQRT(sigatmq(2)**2+SDRmqC_sa**2) if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(nlastpsave-1), nlastysave, rmqa2, SDRmqC2_sa, $ SQRT(sigatmq(2)**2+SDRmqC2_sa**2) else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(mq), nlastysave, rmqa2, SDRmqC2_sa, $ SQRT(sigatmq(2)**2+SDRmqC2_sa**2) end if c ----------------------------------------------------------------- else C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 write (nio,'(8x,''ORIGINAL SERIES'',7x,a3,''-'',i4,12x, $ g11.3,8x,g11.3,8x,g11.3,/)') mth(nlastpsave), nlastysave, $ rmqx1, vTbl56(1,1)*sCoef, vTbl56(1,2)*sCoef if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(nlastpsave-1), nlastysave, rmqx2, vTbl56(2,1)*sCoef, $ vTbl56(2,2)*sCoef else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(mq), nlastysave, rmqx2, vTbl56(2,1)*sCoef, $ vTbl56(2,2)*sCoef end if write (nio,'(8x,''TREND-CYCLE'',11x,a3,''-'',i4,12x,g11.3, $ 8x,g11.3,8x,g11.3,/)')mth(nlastpsave), nlastysave, $ rmqp1, vTbl56(3,1)*sCoef, vTbl56(3,2)*sCoef if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(nlastpsave-1), nlastysave, rmqp2, vTbl56(4,1)*sCoef, $ vTbl56(4,2)*sCoef else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(mq), nlastysave, rmqp2, vTbl56(4,1)*sCoef, $ vTbl56(4,2)*sCoef end if write (nio,'(8x,''SA SERIES'',13x,a3,''-'',i4,12x,g11.3,8x, $ g11.3,8x,g11.3,/)')mth(nlastpsave), nlastysave, $ rmqa1, vTbl56(5,1)*sCoef, vTbl56(5,2)*sCoef if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(nlastpsave-1), nlastysave, rmqa2, vTbl56(6,1)*sCoef, $ vTbl56(6,2)*sCoef else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ mth(mq), nlastysave, rmqa2, vTbl56(6,1)*sCoef, $ vTbl56(6,2)*sCoef end if end if c ----------------------------------------------------------------- else if (.not.Lfinit) then write (nio,'(8x,''ORIGINAL SERIES'',7x,a3,''-'',i4,12x,g11.3, $ 8x,g11.3,8x,g11.3,/)') $ srt(nlastpsave), nlastysave, rmqx1, sdrmqx1, sdrmqx1 if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(nlastpsave-1), nlastysave, rmqx2, sdrmqx2, sdrmqx2 else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(mq), nlastysave, rmqx2, sdrmqx2, sdrmqx2 end if C Modified by REG, on 29 Jun 2006, to correct SE calculation per C Agustin Maravall memo of 22 Jun 2006. write (nio,'(8x,''TREND-CYCLE'',11x,a3,''-'',i4,12x,g11.3, $ 8x,g11.3,8x,g11.3,/)')srt(nlastpsave), nlastysave, $ rmqp1, SDRmqC_p,SQRT(sigptmq(2)**2+SDRmqC_P**2) if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(nlastpsave-1), nlastysave, rmqp2, SDRmqC2_P, $ SQRT(sigptmq(2)**2+SDRmqC2_P**2) else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(mq), nlastysave, rmqp2, SDRmqC2_P, $ SQRT(sigptmq(2)**2+SDRmqC2_P**2) end if C Modified by REG, on 29 Jun 2006, to correct SE calculation per C Agustin Maravall memo of 22 Jun 2006. write (nio,'(8x,''SA SERIES'',13x,a3,''-'',i4,12x,g11.3,8x, $ g11.3,8x,g11.3,/)')srt(nlastpsave), nlastysave, $ rmqa1, SDRmqC_sa, $ SQRT(sigatmq(2)**2+SDRmqC_sa**2) if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(nlastpsave-1), nlastysave, rmqa2, SDRmqC2_sa, $ SQRT(sigatmq(2)**2+SDRmqC2_sa**2) else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(mq), nlastysave, rmqa2, SDRmqC2_sa, $ SQRT(sigatmq(2)**2+SDRmqC2_sa**2) end if c ----------------------------------------------------------------- C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 else write (nio,'(8x,''ORIGINAL SERIES'',7x,a3,''-'',i4,12x,g11.3, $ 8x,g11.3,8x,g11.3,/)') srt(nlastpsave), nlastysave, $ rmqx1, vTbl56(1,1)*sCoef, vTbl56(2,1)*sCoef if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(nlastpsave-1), nlastysave, rmqx2, vTbl56(2,1)*sCoef, $ vTbl56(2,2)*sCoef else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')''6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(mq), nlastysave, rmqx2, vTbl56(2,1)*sCoef, $ vTbl56(2,2)*sCoef end if write (nio,'(8x,''TREND-CYCLE'',11x,a3,''-'',i4,12x,g11.3, $ 8x,g11.3,8x,g11.3,/)')srt(nlastpsave), nlastysave, $ rmqp1, vTbl56(3,1)*sCoef, vTbl56(3,2)*sCoef if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(nlastpsave-1), nlastysave, rmqp2, vTbl56(4,1)*sCoef, $ vTbl56(4,2)*sCoef else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(mq), nlastysave, rmqp2, vTbl56(4,1)*sCoef, $ vTbl56(4,2)*sCoef end if write (nio,'(8x,''SA SERIES'',13x,a3,''-'',i4,12x,g11.3,8x, $ g11.3,8x,g11.3,/)')srt(nlastpsave), nlastysave, $ rmqa1, vTbl56(5,1)*sCoef, vTbl56(5,2)*sCoef if (nlastpsave .gt. 1) then write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(nlastpsave-1), nlastysave, rmqa2, vTbl56(6,1)*sCoef, $ vTbl56(6,2)*sCoef else write (nio,'(30x,a3,''-'',i4,11x,''('',g11.3,'')'',6x,''('', $ g11.3,'')'',6x,''('',g11.3,'')'',/)') $ srt(mq), nlastysave, rmqa2, vTbl56(6,1)*sCoef, $ vTbl56(6,2)*sCoef end if end if end if if (rogtable .eq. 1) then write (54,'(4x,''PRESENT ANNUAL RATE :'',9x,g10.3,12x,g10.3, $ 12x,g10.3)') rmqx1, rmqp1, rmqa1 write (54,'(8X,''(centered)'',/)') end if end if end if if (out.eq.0) then write (nio,'(/,4X,''D. FORECAST'',/)') end if if (lam .eq. 0) then C C ORIGINAL SERIES C tmpser(1) = (oz(nz+1)/oz(nz)-1.0d0) * 100.0d0 a = tmpser(1) tmpser(2) = sqf * 100.0d0 tmpser(3) = (oz(nz+mq)/oz(nz)-1.0d0) * 100.0d0 d = tmpser(3) sumx1 = 1.0d0 do i = 1,mq-1 sumx1 = sumx1 + psitot(lf+1+i)**2 end do tmpser(4) = SQRT(sumx1) * sqf * 100.0d0 tmpser(5) = (oz(nz+mq-nlastpsave)/oz(nz-nlastpsave)-1.0) * 100.0 g = tmpser(5) if (nlastpsave .eq. mq) then tmpser(6) = 0.0d0 else sum1 = 1.0d0 do i = 1,mq-nlastpsave-1 sum1 = sum1 + psitot(lf+1+i)**2 end do tmpser(6) = SQRT(sum1) * sqf * 100.0d0 end if C C TREND C tmptr(1) = (trend(nz+1)/trend(nz)-1.0d0) * 100.0d0 b = tmp(1) tmptr(2)=SDR1F_P*100.0D0 tmptr(3) = (trend(nz+mq)/trend(nz)-1.0d0) * 100.0d0 e = tmptr(3) tmptr(4)=SDRmqF_P*100.0D0 tmptr(5) = $ (trend(nz+mq-nlastpsave)/trend(nz-nlastpsave)-1.0) * 100.0 h = tmptr(5) tmptr(6) = SDRmqPF*100.0D0 C C SA SERIES C tmpsa(1) = (sa(nz+1)/sa(nz)-1.0d0) * 100.0d0 c = tmpsa(1) tmpsa(2)=SDR1F_SA*100.0D0 tmpsa(3) = (sa(nz+mq)/sa(nz)-1.0d0) * 100.0d0 f = tmpsa(3) tmpsa(4)=SDRmqF_SA*100.0D0 tmpsa(5) = (sa(nz+mq-nlastpsave)/sa(nz-nlastpsave)-1.0) * 100.0 o = tmpsa(5) tmpsa(6)=SDRmqSAF*100.0D0 else C C ORIGINAL SERIES C tmpser(1) = oz(nz+1) - oz(nz) tmpser(2) = sqf tmpser(3) = oz(nz+mq) - oz(nz) sumx1 = 1.0d0 do i = 1,mq-1 sumx1 = sumx1 + psitot(lf+1+i)**2 end do tmpser(4) = SQRT(sumx1) * sqf tmpser(5) = oz(nz+mq-nlastpsave) - oz(nz-nlastpsave) if (nlastpsave .eq. mq) then tmpser(6) = 0.0d0 else sum1 = 1.0d0 do i = 1,mq-nlastpsave-1 sum1 = sum1 + psitot(lf+1+i)**2 end do tmpser(6) = SQRT(sum1) * sqf end if C C TREND C tmptr(1) = trend(nz+1) - trend(nz) tmptr(2)=SDR1F_P tmptr(3) = trend(nz+mq) - trend(nz) tmptr(4) = SDRmqF_P tmptr(5) = trend(nz+mq-nlastpsave) - trend(nz-nlastpsave) tmptr(6) = SDRmqPF C C SA SERIES C tmpsa(1) = sa(nz+1) - sa(nz) tmpsa(2) = SDR1F_SA tmpsa(3) = sa(nz+mq) - sa(nz) tmpsa(4) = SDRmqF_SA tmpsa(5) = sa(nz+mq-nlastpsave) - sa(nz-nlastpsave) tmpsa(6) = SDRmqSAF end if if (out.eq.0) then write (nio, $ '(/,6x,"TABLE 5.7 RATES OF GROWTH FORECASTS :",/,6x, $ "-------------------------------------",/,16x, $ "In Percent Points",//)') write (nio,'(4x,"FORECAST",22x,"ORIGINAL",16x, "TREND-CYCLE", $ 16x,"SA SERIES")') write (nio,'(4X,"ORIGIN :",22X,"SERIES")') write (nio,'(4x,a3,''-'',i4,24x,''(SER)'',22x,''(SER)'', $ 22x,''(SER)'',//)')mth(nlastpsave), nlastysave C Modified by REG, on 21 Apr 2006, to select between SEATS version C of table 5.7, and an alternate finite sample version if ( Lfinit ) then C Modified by REG, on 26 May 2006, to give percentage GR SEs for lam=0 write (nio,'(2x,"ONE-PERIOD-AHEAD",/,2x,"FORECAST PERIOD ",/, $ 2x,"TO PERIOD RATE",13x,g11.2,16x,g11.2,15x,g11.2,/,2x, $ "T(1,1)",20x,"(",g11.2,")",14x,"(",g11.2,")",13x,"(",g11.2, $ ")"//)') $ tmpser(1), tmptr(1), tmpsa(1), vTbl57(1,1)*sCoef, $ vTbl57(1,2)*sCoef, vTbl57(1,3)*sCoef write (nio,'(2x,"FORECAST OF ANNUAL",/,2x, $ "RATE OF GROWTH OVER",/,2x,"THE NEXT ",i2," PERIODS", $ 8x,g11.2,16x,g11.2,15x,g11.2,/,2x, $ "(one year horizon)",8x,"(",g11.2,")",14x,"(",g11.2,")", $ 13x,"(",g11.2,")",//)') $ mq, tmpser(3), tmptr(3), tmpsa(3), vTbl57(2,1)*sCoef, $ vTbl57(2,2)*sCoef, vTbl57(2,3)*sCoef write (nio,'(2x,"FORECAST OF ANNUAL",/,2x, $ "RATE OF GROWTH FOR",/,2x, $ "THE PRESENT YEAR",11x,g11.2,16x,g11.2,15x,g11.2,/,2x, $ "(December over December)",2x,"(",g11.2,")",14x, $ "(",g11.2,")",13x,"(",g11.2,")",//)') $ tmpser(5), tmptr(5), tmpsa(5), vTbl57(3,1)*sCoef, $ vTbl57(3,2)*sCoef, vTbl57(3,3)*sCoef else write (nio,'(2x,"ONE-PERIOD-AHEAD",/,2x, $ "FORECAST PERIOD ",/,2x, $ "TO PERIOD RATE",13x,g11.2,16x,g11.2,15x,g11.2,/, $ 2x,"T(1,1)",20x, $ "(",g11.2,")",14x,"(",g11.2,")",13x,"(",g11.2, ")"//)') $ tmpser(1), tmptr(1), tmpsa(1), $ tmpser(2), tmptr(2), tmpsa(2) write (nio,'(2x,"FORECAST OF ANNUAL",/,2x, $ "RATE OF GROWTH OVER",/,2x,"THE NEXT ",i2," PERIODS", $ 8x,g11.2,16x,g11.2,15x,g11.2,/,2x, $ "(one year horizon)",8x,"(",g11.2,")",14x,"(",g11.2,")", $ 13x,"(",g11.2,")",//)') $ mq, tmpser(3), tmptr(3), tmpsa(3), $ tmpser(4), tmptr(4), tmpsa(4) write (nio,'(2x,"FORECAST OF ANNUAL",/,2x, $ "RATE OF GROWTH FOR",/,2x, $ "THE PRESENT YEAR",11x,g11.2,16x,g11.2,15x,g11.2,/,2x, $ "(December over December)",2x,"(",g11.2,")",14x, $ "(",g11.2,")",13x,"(",g11.2,")",//)') $ tmpser(5), tmptr(5), tmpsa(5), $ tmpser(6), tmptr(6), tmpsa(6) end if end if C C C if (rogtable .eq. 1) then write (54, $ '(4x,"FORECAST OF T11 RATE :",8x,g10.3,11x,g10.3,12x,g10.3,/)') $ a, b, c write (54, $ '(4x,"FORECAST 1-year ahead :",7x,g10.3,12x,g10.3,12x,g10.3,/)') $ d, e, f write (54, $ '(4x,"FORECAST for present year :",3x,g10.3,12x,g10.3,12x, $ g10.3,///)') g, h, o end if end if end C C C subroutine ROGEST(series,nz,rog,nrog,mq,lam,lagr) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer kp parameter (kp = PFCST) * integer mp * parameter (mp = POBS) C C.. Formal Arguments .. integer nz,nrog,mq,lam,lagr real*8 series(*),rog(kp) C C.. Local Scalars .. integer j C C ... Executable Statements ... C C if (mq .eq. 12) then nrog = 36 else if (mq .eq. 6) then nrog = 18 else if (mq .eq. 4) then nrog = 12 else nrog = 8 end if if ((nrog+1) .gt. nz) then nrog = nz - 1 end if if (lam .eq. 0) then do j = 1,nrog-lagr+1 rog(j) = ((series(nz-j+1)/series(nz-j+1-lagr))-1.0d0) * 100.0d0 end do else do j = 1,nrog-lagr+1 rog(j) = series(nz-j+1) - series(nz-j+1-lagr) end do end if nrog = nrog - lagr + 1 end C C C subroutine ROGSIG(s,ns,sdrev,nsdrev) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer kp parameter (kp = PFCST) C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 s(0:kp) C.. In/Out Status: Read, Not Written .. integer ns C.. In/Out Status: Maybe Read, Maybe Written .. real*8 sdrev(kp) C.. In/Out Status: Not Read, Overwritten .. integer nsdrev C C.. Local Scalars .. integer i character htmtit*120 C C.. Intrinsic Functions .. intrinsic SQRT C C ... Executable Statements ... C nsdrev = ns - 1 do i = 0,ns-1 sdrev(i+1) = s(i)**2 - s(ns)**2 if (sdrev(i+1) .le. 0.0d0) then sdrev(i+1) = 0.0d0 else sdrev(i+1) = SQRT(sdrev(i+1)) end if end do end C C C Modified by REG, on 28 Feb 2006, to add out to FINALSE parameter list. C Modified by BCM, on 7 May 2010, to replace out with Lfinit in FINALSE c parameter list. subroutine FINALSE(psiep,psiea,trend,sa,siepf,siepfl,sieaf,sieafl, $ sqf,ilen,mq,lfor,lam,out) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' INCLUDE 'revs.i' integer nfl parameter (nfl = mp*2) C LINES OF CODE ADDED FOR X-13A-S : 2 DOUBLE PRECISION ZERO parameter (ZERO=0D0) C END OF CODE BLOCK C C.. Formal Arguments .. integer ilen,mq,lfor,lam,out real*8 psiep(nfl),psiea(nfl),trend(mpkp),sa(mpkp),siepf(kl), $ siepfl(kl),sieaf(kl),sieafl(kl),sqf C C.. Local Scalars .. integer i,nfreqs,nlastper,nlastyear,npers,nse,nyers,nzs real*8 tempbm character htmtit*120 C C.. Local Arrays .. real*8 siea(kl),sieal(kl),siep(kl),siepl(kl),tmp(kl),tmp1(kl) C C.. External Calls .. real*8 RAIZ external RAIZ external TABLE C C.. Intrinsic Functions .. intrinsic LOG, MOD include 'sform.i' include 'stream.i' include 'seatop.cmn' C C ... Executable Statements ... C C C C BACKUP SFORM COMMON PARAMETERS C nzs = Nz nyers = Nyer npers = Nper nfreqs = Nfreq nse = 5 * mq if (nse .gt. Nz) then nse = Nz end if tmp(1) = ZERO tmp1(1) = ZERO do i = 1,ilen tmp(1) = tmp(1) + psiep(i)*psiep(i) tmp1(1) = tmp1(1) + psiea(i)*psiea(i) end do siep(1) = RAIZ(tmp(1)) * sqf siea(1) = RAIZ(tmp1(1)) * sqf do i = 2,nse tempbm = (psiep(ilen+2-i)*psiep(ilen+2-i)) tmp(i) = tmp(i-1) - tempbm tmp1(i) = tmp1(i-1) - (psiea(ilen+2-i)*psiea(ilen+2-i)) siep(i) = RAIZ(tmp(i)) * sqf siea(i) = RAIZ(tmp1(i)) * sqf end do tmp(1) = tmp(1) + (psiep(ilen+1)*psiep(ilen+1)) tmp1(1) = tmp1(1) + (psiea(ilen+1)*psiea(ilen+1)) siepf(1) = RAIZ(tmp(1)) * sqf sieaf(1) = RAIZ(tmp1(1)) * sqf do i = 2,lfor tmp(i) = tmp(i-1) + (psiep(ilen+i)*psiep(ilen+i)) tmp1(i) = tmp1(i-1) + (psiea(ilen+i)*psiea(ilen+i)) siepf(i) = RAIZ(tmp(i)) * sqf sieaf(i) = RAIZ(tmp1(i)) * sqf end do if (lam .eq. 1) then if (nse .lt. Nz) then C Modified by REG, on 28 Feb 2006, to identify finite sample SEs. 7000 format ( $ //,2x,a,'STANDARD ERROR OF REVISION IN TREND-CYCLE ','ESTIMATOR' $ ,/,2x,'LAST 5 YEARS') if (.not.Lfinit) then write (Nio,7000)'' else write (Nio,7000)'FINITE SAMPLE ' end if else C Modified by REG, on 28 Feb 2006, to identify finite sample SEs. 7001 format ( $ //,2x,a,'STANDARD ERROR OF REVISION IN TREND-CYCLE ','ESTIMATOR' $ ,/,2x,'LAST YEARS') if (.not.Lfinit) then write (Nio,7001)'' else write (Nio,7001)'FINITE SAMPLE ' end if end if do i = 1,nse C Modified by REG, on 28 Feb 2006, to select between SEATS output and C alternative standard error of revision developed by getDiag(). if (.not.Lfinit) then tmp(nse-i+1) = siep(i) else tmp(i)=seRevs(i,2) end if end do nlastper = npers nlastyear = nyers do i = 2,Nz-nse+1 if (MOD(nlastper,mq) .eq. 0) then nlastyear = nlastyear + 1 nlastper = 0 end if nlastper = nlastper + 1 end do Nyer = nlastyear Nper = nlastper Nz = nse C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK if (nse .lt. nzs) then C Modified by REG, on 28 Feb 2006, to identify finite sample SEs. 7002 format ( $ //,2x,a,'STANDARD ERROR OF REVISION IN SA SERIES ','ESTIMATOR' $ ,/,2x,'LAST 5 YEARS') if (.not.Lfinit) then write (Nio,7002)'' else write (Nio,7002)'FINITE SAMPLE ' end if else C Modified by REG, on 28 Feb 2006, to identify finite sample SEs. 7003 format ( $ //,2x,a,'STANDARD ERROR OF REVISION IN SA SERIES ','ESTIMATOR' $ ,/,2x,'LAST YEARS') if (.not.Lfinit) then write (Nio,7003)'' else write (Nio,7003)'FINITE SAMPLE ' end if end if do i = 1,nse C Modified by REG, on 28 Feb 2006, to select between SEATS output and C alternative standard error of revision developed by getDiag(). if (.not.Lfinit) then tmp(nse-i+1) = siea(i) else tmp(i) = seRevs(i,1) end if end do C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK Nz = nzs else do i = 1,nse siepl(i) = siep(i) * trend(Nz-i+1) sieal(i) = siea(i) * sa(Nz-i+1) end do do i = 1,lfor siepfl(i) = siepf(i) * trend(Nz+i) sieafl(i) = sieaf(i) * sa(Nz+i) end do if (nse .lt. Nz) then if (.not.Lfinit) then write (Nio,7000)'' else write (Nio,7000)'FINITE SAMPLE ' end if else if (.not.Lfinit) then write (Nio,7001)'' else write (Nio,7001)'FINITE SAMPLE ' end if end if do i = 1,nse if (.not.Lfinit) then tmp(nse-i+1) = siepl(i) else tmp(i)=seRevs(i,2) end if end do nlastper = npers nlastyear = nyers do i = 2,Nz-nse+1 if (MOD(nlastper,mq) .eq. 0) then nlastyear = nlastyear + 1 nlastper = 0 end if nlastper = nlastper + 1 end do Nyer = nlastyear Nper = nlastper Nz = nse C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK if (nse .lt. nzs) then if (.not.Lfinit) then write (Nio,7002)'' else write (Nio,7002)'FINITE SAMPLE ' end if else if (.not.Lfinit) then write (Nio,7003)'' else write (Nio,7003)'FINITE SAMPLE ' end if end if do i = 1,nse if (.not.Lfinit) then tmp(nse-i+1) = sieal(i) else tmp(i) = seRevs(i,1) end if end do C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK Nz = nzs end if C C RESTORE SFORM COMMON PARAMETERS C Nz = nzs Nyer = nyers Nper = npers Nfreq = nfreqs end C C subroutine NMOut(Type,Init,Lam,Imean,P,D,Q,Bp,Bd,Bq,Sqg,Mq,M, $ iqm,maxit,fh,noserie,Pg,modelsumm,Out,seas, $ Noadmiss,OutNa,StochTD, $ Iter,qmax,Har,Bias,Tramo,model,Noutr, $ Nouir,Nous,Npatd,Npareg,interp,Rsa,Fortr,Neast, $ epsiv,Epsphi,ta,Xl,Rmod,blqt,tmu,Phi,Th, $ Bphi,Bth,thlim,bthlim,crmean,hplan,hpcycle,rogtable, $ centrregs,statseas,units, $ kunits,acfe,posbphi,Nochmodel,printphtrf, $ tabtables,d_tabtables,psieinic,psiefin, $ firstobs,lastobs,HPper,maxSpect,brol,blamda, $ bserie,bmid,bcMark,Nz) C C.. Implicits .. implicit none C C.. Parameters .. integer n1 parameter (n1 = 1) C C.. Formal Arguments .. integer bd,bias,bp,bq,d,fh,fortr,har,hpcycle,imean, $ init,interp,iqm,iter,lam,m,maxit,model,mq, $ neast,noadmiss,OutNA,StochTD,modelsumm, $ noserie,nouir,noutr,npareg,npatd,out, $ p,pg,q,qmax,rogtable,rsa,statseas,units,kunits integer seas,sqg,tramo,type,crmean,acfe,posbphi,Nous,Nochmodel integer printphtrf,centrregs,Nz integer psieinic,psiefin real*8 blqt,epsiv,epsphi,hplan,rmod, $ ta,thlim,bthlim,tmu,xl,HPper,maxSpect,brol,blamda integer bserie,bmid,bcMark real*8 bphi(3*n1),bth(3*n1),phi(3*n1),th(3*n1) character tabtables*100, d_tabtables*100 character firstobs*7,lastobs*7 C C.. Local Scalars .. integer l_type,l_init,l_lam,l_imean,l_p,l_d,l_q,l_bp,l_bd,l_bq, $ l_sqg,l_mq,l_m,l_iqm,l_maxit,l_fh,l_noserie, $ l_pg,l_out,l_seas,l_noadmiss,l_OutNA,L_StochTD,l_iter, $ l_qmax,l_har,l_bias,l_tramo,l_model,l_noutr,l_nouir, $ l_npatd,l_npareg,l_interp,l_rsa,l_fortr,l_neast integer l_hpcycle,l_rogtable,l_statseas, $ l_units,l_kunits,l_crmean,l_acfe,l_posbphi,l_nous integer l_psieinic,l_psiefin integer l_Nochmodel,l_printphtrf,l_centrregs,l_modelsumm real*8 l_epsiv,l_epsphi,l_ta,l_xl,l_rmod,l_blqt, $ l_tmu,l_thlim,l_bthlim,l_hplan, $ l_HPper,l_maxSpect,l_brol,l_blamda integer l_bserie,l_bmid,l_bcMark integer CounterLine,ifail,i character tst*80, testo*1280, l_tabtables*100 character l_firstobs*7,l_lastobs*7,l_Odate*7 integer l_Olen,l_nds C.. Added by REG on 30 Aug 2005 to create local variable l_nfixed integer l_nfixed C C.. Local Arrays .. real*8 l_bphi(3*n1),l_bth(3*n1),l_phi(3*n1),l_th(3*n1) real*8 l_DetSeas(12*n1) C C.. External Functions .. integer ISTRLEN external ISTRLEN include 'stream.i' C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C CounterLine=1 C LINES OF CODE COMMENTED FOR X-13A-S : 2 C testo=" C tst=" C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 testo=' ' tst=' ' C END OF CODE BLOCK C.. Modified by REG on 30 Aug 2005 to add l_nfixed to NMLSTS parameter list call NMLSTS(l_Nochmodel,l_Type,l_Init,l_Lam,l_Imean,l_P,l_D, $ l_Q,l_Bp,l_Bd,l_Bq,l_Sqg,l_Mq,l_M,l_iqm, $ l_maxit,l_fh,l_noserie,l_Pg,l_modelsumm,l_Out, $ l_seas,l_Noadmiss,l_OutNA,l_StochTD, $ l_Iter,l_qmax,l_Har,l_Bias,l_Tramo, $ l_model,l_Noutr,l_Nouir,l_Nous,l_Npatd,l_Npareg, $ l_interp,l_Rsa,l_Fortr,l_Neast,l_epsiv, $ l_Epsphi,l_ta,l_Xl,l_Rmod,l_blqt, $ l_tmu,l_Phi,l_Th,l_Bphi,l_Bth,l_thlim,l_bthlim, $ l_crmean,l_hplan,l_hpcycle,l_rogtable, $ l_centrregs,l_statseas,l_units,l_kunits, $ l_acfe,l_posbphi,l_printphtrf,l_tabtables, $ l_psieinic,l_psiefin, $ l_firstobs,l_lastobs,l_HPper,l_maxSpect,l_brol, $ l_blamda,l_bserie,l_bmid,l_bcMark,l_Odate, $ l_Olen,l_DetSeas,l_nds,Nz,l_nfixed,0,ifail) if (bd .ne. l_bd) then write (tst,'(3x,''bd=''I2)') bd testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (bias .ne. l_bias) then write (tst,'(3x,''bias=''I2)') bias testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (acfe .ne. l_acfe) then write (tst,'(3x,''acfe=''I2)') acfe testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (posbphi .ne. l_posbphi) then write (tst,'(3x,''acfe=''I2)') posbphi testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (printphtrf .ne. l_printphtrf) then write (tst,'(3x,''printphtrf=''I2)') printphtrf testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (Firstobs .ne. l_Firstobs) then write (tst,'(3x,''Firstobs='',A)') Firstobs testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (Lastobs .ne. l_Lastobs) then write (tst,'(3x,''Lastobs='',A)') Lastobs testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (bp .ne. l_bp) then write (tst,'(3x,''bp=''I2)') bp testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (bq .ne. l_bq) then write (tst,'(3x,''bq=''I2)') bq testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (centrregs .ne. l_centrregs) then write (tst,'(3x,''centrregs=''I2)') centrregs testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (d .ne. l_d) then write (tst,'(3x,''d=''I2)') d testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (fh .ne. l_fh) then write (tst,'(3x,''fh=''I2)') fh testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (fortr .ne. l_fortr) then write (tst,'(3x,''fortr=''I2)') fortr testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (har .ne. l_har) then write (tst,'(3x,''har=''I2)') har testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (hpcycle .ne. l_hpcycle) then write (tst,'(3x,''hpcycle=''I2)') hpcycle testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (imean .ne. l_imean) then write (tst,'(3x,''imean=''I2)') imean testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (init .ne. l_init) then write (tst,'(3x,''init=''I2)') init testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo=' ' CounterLine=0 end if if (interp .ne. l_interp) then write (tst,'(3x,''interp=''I2)') interp testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (iqm .ne. l_iqm) then write (tst,'(3x,''iqm=''I2)') iqm testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (iter .ne. l_iter) then write (tst,'(3x,''iter=''I2)') iter testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (lam .ne. l_lam) then write (tst,'(3x,''lam=''I2)') lam testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (m .ne. l_m) then write (tst,'(3x,''m=''I2)') m testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (maxit .ne. l_maxit) then write (tst,'(3x,''maxit=''I2)') maxit testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (model .ne. l_model) then write (tst,'(3x,''model=''I2)') model testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (mq .ne. l_mq) then write (tst,'(3x,''mq=''I2)') mq testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (nochmodel .ne. l_Nochmodel) then write (tst,'(3x,''nochmodel=''I2)') nochmodel testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (neast .ne. l_neast) then write (tst,'(3x,''neast=''I2)') neast testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (noadmiss .ne. l_noadmiss) then write (tst,'(3x,''noadmiss=''I2)') noadmiss testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (noserie .ne. l_noserie) then write (tst,'(3x,''noserie=''I2)') noserie testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (nouir .ne. l_nouir) then write (tst,'(3x,''nouir=''I2)') nouir testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (nous .ne. l_nous) then write (tst,'(3x,''nous=''I2)') nous testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (noutr .ne. l_noutr) then write (tst,'(3x,''noutr=''I2)') noutr testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (npareg .ne. l_npareg) then write (tst,'(3x,''npareg=''I2)') npareg testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (npatd .ne. l_npatd) then write (tst,'(3x,''npatd=''I2)') npatd testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (out .ne. l_out) then write (tst,'(3x,''out=''I2)') out testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (tabtables .ne. d_tabtables) then write (tst,'(3x,''tabtables=''3A)') char(39), $ tabtables(1:istrlen(tabtables)),char(39) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (p .ne. l_p) then write (tst,'(3x,''p=''I2)') p testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (pg .ne. l_pg) then write (tst,'(3x,''pg=''I2)') pg testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (q .ne. l_q) then write (tst,'(3x,''q=''I2)') q testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (qmax .ne. l_qmax) then write (tst,'(3x,''qmax=''I2)') qmax testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (rogtable .ne. l_rogtable) then write (tst,'(3x,''rogtable=''I2)') rogtable testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (rsa .ne. l_rsa) then write (tst,'(3x,''rsa=''I2)') rsa testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (statseas .ne. l_statseas) then write (tst,'(3x,''statseas=''I2)') statseas testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (units .ne. l_units) then write (tst,'(3x,''units=''I2)') units testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (kunits .ne. l_kunits) then write (tst,'(3x,''kunits=''I2)') kunits testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (seas .ne. l_seas) then write (tst,'(3x,''seas=''I2)') seas testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (sqg .ne. l_sqg) then write (tst,'(3x,''sqg=''I2)') sqg testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (tramo .ne. l_tramo) then write (tst,'(3x,''tramo=''I2)') tramo testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (type .ne. l_type) then write (tst,'(3x,''type=''I2)') type testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(blqt, l_blqt)) then write (tst,'(3x,''blqt=''f8.3)') blqt testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (crmean .ne. l_crmean) then write (tst,'(3x,''crmean=''I2)') crmean testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(epsiv, l_epsiv)) then write (tst,'(3x,''epsiv=''f8.3)') epsiv testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(epsphi, l_epsphi)) then write (tst,'(3x,''epsphi=''f8.3)') epsphi testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(hplan, l_hplan)) then write (tst,'(3x,''hplan=''f8.3)') hplan testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(hpPer, l_hpPer)) then write (tst,'(3x,''hpPer=''f8.3)') hpPer testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(rmod, l_rmod)) then write (tst,'(3x,''rmod=''f8.3)') rmod testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(ta, l_ta)) then write (tst,'(3x,''ta=''f8.3)') ta testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (thlim .ne. l_thlim) then write (tst,'(3x,''thlim=''f8.3)') thlim testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (bthlim .ne. l_bthlim) then write (tst,'(3x,''bthlim=''f8.3)') bthlim testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(tmu, l_tmu)) then write (tst,'(3x,''tmu=''f8.3)') tmu testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(xl, l_xl)) then write (tst,'(3x,''xl=''f8.3)') xl testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if do i=1,3 if (.not.dpeq(phi(i), l_phi (i))) then write (tst,'(3x,''phi('',I1,'')='',f8.3)') i,phi(i) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if end do do i=1,3 if (.not.dpeq(th(i), l_th(i))) then write (tst,'(3x,''th('',I1,'')='',f8.3)') i,th(i) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if end do if (.not.dpeq(bphi(1), l_bphi (1))) then write (tst,'(3x,''bphi('',I1,'')='',f8.3)') 1,bphi(1) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(bth(1),l_bth (1))) then write (tst,'(3x,''bth('',I1,'')='',f8.3)') 1,bth(1) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .eq. 5) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (psieinic .ne. l_psieinic) then write (tst,'(3x,''PSIEINIC='',I4)') psieinic testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (psiefin .ne. l_psiefin) then write (tst,'(3x,''PSIEFIN='',I3)') psiefin testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= & tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write(65,'(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(maxSpect, l_maxSpect)) then write(tst,'(3x,''MaxSpect='',F10.6)') MaxSpect testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(brol, l_brol)) then write(tst,'(3x,''Brol='',F10.6)') brol testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (.not.dpeq(blamda, l_blamda)) then write(tst,'(3x,''Blamda='',F10.6)') Blamda testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (bserie .ne. l_bserie) then write(tst,'(3x,''Bserie='',i2)') Bserie testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (bmid .ne. l_bmid) then write(tst,'(3x,''Bmid='',i2)') Bmid testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if if (bcMark .ne. l_bcMark) then write(tst,'(3x,''BcMark='',i2)') BcMark testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write (65, '(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if c if (OutNA .ne. l_OutNA) then c write(tst,'(3x,''OutNA='',I3)') OutNA c testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst c CounterLine=CounterLine+1 c end if c if (CounterLine .gt. 0) then c write(65,'(A)') testo(1:ISTRLEN(testo)) c testo='' c CounterLine=0 c end if if (stochTD .ne. l_stochTD) then write(tst,'(3x,''stochTD='',I3)') stochTD testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))=tst CounterLine=CounterLine+1 end if if (CounterLine .gt. 0) then write(65,'(A)') testo(1:ISTRLEN(testo)) testo='' CounterLine=0 end if return end CC C CC subroutine NMCHECK (Type,Init,Lam,Imean,P,D,Q,Bp,Bd,Bq,Sqg,Mq,M, $ iqm,maxit,fh,noserie,Pg,Out,seas, $ Noadmiss,OutNA,StochTD, $ Iter,qmax,Har,Bias,Tramo,model,Noutr,Nouir, $ Nous,Npatd,Npareg,interp,Rsa,Fortr,Neast, $ epsiv,Epsphi,Xl,Rmod,thlim,bthlim,crmean,hplan,hpcycle, $ rogtable,centrregs,statseas,units, $ acfe,posbphi,nochmodel, $ tabtables,d_tabtables,psieinic,psiefin, $ firstobs,lastobs,HPper,brol,blamda, $ bserie,bmid,bcMark,Nz) C C.. Implicits .. implicit none C C.. Parameters .. integer n1 parameter (n1 = 1) C.. Formal Arguments .. integer bd,bias,bp,bq,d,fh,fortr,har,hpcycle,imean, $ init,interp,iqm,iter,lam,m,maxit,model,mq, $ neast,noadmiss,OutNA,StochTD, $ noserie,nouir,noutr,npareg,npatd,out, $ p,pg,q,qmax,rogtable,rsa,statseas,units integer seas,sqg,tramo,type,crmean,Nous,acfe,posbphi integer nochmodel,centrregs integer psieinic,psiefin,Nz real*8 epsiv,epsphi,hplan,rmod, $ thlim,bthlim,xl, $ HPper c real*8 bphi(3*n1),bth(3*n1),phi(3*n1),th(3*n1) character tabtables*100, d_tabtables*100 character firstobs*7,lastobs*7 integer lobs real*8 brol,blamda integer bserie,bmid,bcMark C C.. Local Scalars .. real*8 perTolan,wpi integer l_type,l_init,l_lam,l_imean,l_p,l_d,l_q,l_bp,l_bd,l_bq, $ l_sqg,l_mq,l_m,l_iqm,l_maxit,l_fh,l_noserie, $ l_pg,l_out,l_seas,l_noadmiss,l_OutNA,l_stochTD,l_iter, $ l_qmax,l_har,l_bias,l_tramo,l_model,l_noutr,l_nouir, $ l_npatd,l_npareg,l_interp,l_rsa,l_fortr,l_neast integer l_hpcycle,l_rogtable,l_statseas, $ l_units,l_kunits,l_crmean,l_acfe,l_posbphi,l_Nous,ifail integer l_nochmodel,l_printphtrf,l_centrregs integer l_psieinic,l_psiefin real*8 l_epsiv,l_epsphi,l_ta,l_xl,l_ur,l_rmod,l_blqt, $ l_tmu,l_thlim,l_bthlim,l_hplan,l_HPper,l_maxSpect character l_tabtables*100 character l_firstobs*7,l_lastobs*7,l_Odate*7 integer l_Olen,l_nds real*8 l_brol,l_blamda integer l_bserie,l_bmid,l_bcMark integer i,l_modelsumm C.. Added by REG on 30 Aug 2005 to create local variable l_nfixed integer l_nfixed C C.. Local Arrays .. real*8 l_bphi(3*n1),l_bth(3*n1),l_phi(3*n1),l_th(3*n1) real*8 l_DetSeas(12*n1) integer ValidTables external ValidTables integer Date2Idx external Date2Idx character*7 Idx2Date external Idx2Date include 'stream.i' parameter (wpi = 3.14159265358979D0) C C C.. Modified by REG on 30 Aug 2005 to add l_nfixed to NMLSTS parameter list call NMLSTS(l_Nochmodel,l_Type,l_Init,l_Lam,l_Imean,l_P,l_D, $ l_Q,l_Bp,l_Bd,l_Bq,l_Sqg,l_Mq,l_M,l_iqm,l_maxit,l_fh, $ l_noserie,l_Pg,l_modelsumm,l_Out,l_seas, $ l_Noadmiss,l_OutNA,l_stochTD,l_Iter,l_qmax,l_Har,l_Bias,l_Tramo, $ l_model,l_Noutr,l_Nouir,l_Nous,l_Npatd,l_Npareg, $ l_interp,l_Rsa,l_Fortr,l_Neast,l_epsiv, $ l_Epsphi,l_ta,l_Xl,l_Rmod,l_blqt, $ l_tmu,l_Phi,l_Th,l_Bphi,l_Bth,l_thlim,l_bthlim, $ l_crmean,l_hplan,l_hpcycle,l_rogtable, $ l_centrregs,l_statseas,l_units, $ l_kunits,l_acfe,l_posbphi,l_printphtrf, $ l_tabtables,l_psieinic,l_psiefin, $ l_firstobs,l_lastobs,l_HPper,l_maxSpect,l_brol, $ l_blamda,l_bserie,l_bmid,l_bcMark,l_Odate,l_Olen, $ l_DetSeas,l_nds,Nz,l_nfixed,0,ifail) cc c if ((acfe .lt. 0) .or. (acfe .gt. 999)) then write (nio,'(/,2x,''Wrong value for the parameter "ACFE"'', & /,2x,''Admissible value : [0..999]'',/ & 2x,''ACFE set to the default value.'')') acfe=l_acfe end if if ((posbphi .lt. 0) .or. (posbphi .gt. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "POSBPHI"'', & /,2x,''Admissible value : [0,1]'',/ & 2x,''POSBPHI set to the default value.'')') posbphi=l_posbphi end if lobs = Date2Idx(Firstobs) if (lobs .eq. -1) then lobs = 1 end if if (lobs .lt. 0) then write (nio,'(/,2x,''Wrong value for the parameter "Firstobs"'', & /,2x,''Admissible value : [''A,'', '',A,'']'',/ & 2x,''Firstobs set to the default value.'')') & Idx2Date(1),Idx2Date(Nz) Firstobs=l_Firstobs end if lobs = Date2Idx(Lastobs) if (lobs .gt. Nz) then write (nio,'(/,2x,''Wrong value for the parameter "Lastobs"'', & /,2x,''Admissible value : [''A,'', '',A,'']'',/ & 2x,''Lastobs set to the default value.'')') & Idx2Date(1),Idx2Date(Nz) Lastobs=l_Lastobs end if if ((Date2Idx(Firstobs) .ge. Date2Idx(Lastobs)) .and. & (Date2Idx(lastobs) .ne. -1)) then write (nio,'(/,2x,''Wrong value for the parameters "Firstobs"'', & ''",Lastobs"'',/,2x,''Firstobs should be < Lastobs'',/ & 2x,''Firstobs,Lastobs set to the default value.'')') Firstobs=l_Firstobs Lastobs=l_Lastobs end if if ((bd .ne. 0) .and. (bd .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "BD"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''BD set to the default value.'')') bd=l_bd end if if ((bias .lt. -2) .or. (bias .gt. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "BIAS"'',/, & 2x,''Admissible value : [-1, 0, 1]'',/ & 2x,''BIAS set to the default value.'')') bias=l_bias end if if ((bp .ne. 0) .and. (bp .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "BP"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''BP set to the default value.'')') bp=l_bp end if if ((bq .ne. 0) .and. (bq .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "BQ"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''BQ set to the default value.'')') bq=l_bq end if if ((centrregs .ne. 0) .and. (centrregs .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "CENTRREGS"'', & /,2x,''Admissible value : [0, 1]'',/ & 2x,''CENTRREGS set to the default value.'')') centrregs=l_centrregs end if if ((d .lt. 0) .or. (d .gt. 3)) then write (nio,'(/,2x,''Wrong value for the parameter "D"'',/, & 2x,''Admissible value : 0<= d <=3'',/ & 2x,''D set to the default value.'')') d=l_d end if if (fh .lt. 0) then write (nio,'(/,2x,''Wrong value for the parameter "FH"'',/, & 2x,''Admissible value : fh > 0'',/ & 2x,''FH set to the default value.'')') fh=l_fh end if if ((fortr .ne. 0) .and. (fortr .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "FORTR"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''FORTR set to the default value.'')') fortr=l_fortr end if if ((har .ne. 0) .and. (har .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "HAR"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''HAR set to the default value.'')') har=l_har end if if ((hpcycle .lt. -1) .or. (hpcycle .gt.3)) then write (nio,'(/,2x,''Wrong value for the parameter "HPCYCLE"'',/, & 2x,''Admissible value : [-1, 0, 1, 2, 3]'',/ & 2x,''HPCYCLE set to the default value.'')') hpcycle=l_hpcycle end if if (hplan .lt. 0.0625d0 .and. hpLan .ne. l_hplan) then write (nio,'(/,2x,''Wrong value for the parameter "HPLAN"'',/, & 2x,''Admissible value >0.0625'',/ & 2x,''HPLAN set to the default value.'')') hplan=l_hplan end if if (hpPer .lt. 2.0d0 .and. hpPer .ne. l_hpPer) then write (nio,'(/,2x,''Wrong value for the parameter "HPPer"'',/, & 2x,''Admissible value >2.0 .'',/, & 2x,''HPper set to the default value.'')') hpper=l_hpPer end if if ((HPlan .ge. 0.0625) .and. (HPper.gt.2.0d0)) then perTolan=1/(4*(1-(cos(2*wpi/HPper)) **2)) if (abs(HPlan-perTolan)<10**(-8)) then write (nio,'(/,2x, & ''You have to choose between set "HPper"'',/, & 2x,'' or set "HPlan", you cannot set both.'',/, & 2x,'' HPlan set to the default value.'')') hpLan=l_hpLan end if end if if ((imean .ne. 0) .and. (imean .ne.1)) then write (nio,'(/,2x,''Wrong value for the parameter "IMEAN"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''IMEAN set to the default value.'')') imean=l_imean end if if ((init .ne. 0) .and. (init .ne. 1) .and. (init .ne.2)) then write (nio,'(/,2x,''Wrong value for the parameter "INIT"'',/, & 2x,''Admissible value : [0, 1, 2]'',/ & 2x,''INIT set to the default value.'')') init=l_init end if if ((interp .ne. 0) .and. (interp .ne. 1) .and. (interp .ne.2)) & then write (nio,'(/,2x,''Wrong value for the parameter "INTERP"'',/, & 2x,''Admissible value : [0, 1, 2]'',/ & 2x,''INTERP set to the default value.'')') interp=l_interp end if if (iqm .lt. 0) then write (nio,'(/,2x,''Wrong value for the parameter "IQM"'',/, & 2x,''Admissible value : iqm >= 0'',/ & 2x,''IQM set to the default value.'')') iqm=l_iqm end if if ((iter .lt. 0) .or. (iter .gt. 3)) then write (nio,'(/,2x,''Wrong value for the parameter "ITER"'',/, & 2x,''Admissible value : [0, 1, 2, 3]'',/ & 2x,''ITER set to the default value.'')') iter=l_iter end if if ((lam .ne. 0) .and. (lam .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "LAM"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''LAM set to the default value.'')') lam=l_lam end if if ((nochmodel .ne. 0) .and. (nochmodel .ne. 1)) then write (nio,'(/,2x, $ ''Wrong value for the parameter "NOCHMODEL"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NOCHMODEL set to the default value.'')') nochmodel=l_Nochmodel end if if (m .lt. 0) then write (nio,'(/,2x,''Wrong value for the parameter "M"'',/, & 2x,''Admissible value : m >= 0'',/ & 2x,''M set to the default value.'')') m=l_m end if if (maxit .lt. 1) then write (nio,'(/,2x,''Wrong value for the parameter "MAXIT"'',/, & 2x,''Admissible value : maxit > 0'',/ & 2x,''MAXIT set to the default value.'')') maxit=l_maxit end if if ((model .ne. 0) .and. (model .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "MODEL"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''MODEL set to the default value.'')') model=l_model end if if ((mq .ne. 1) .and. (mq .ne. 2) .and. (mq .ne. 4) .and. & (mq .ne. 6) .and. (mq .ne. 12)) then write (nio,'(/,2x,''Wrong value for the parameter "MQ"'',/, & 2x,''Admissible value : [1, 2, 4, 6, 12]'',/ & 2x,''MQ set to the default value.'')') mq=l_mq end if if ((neast .ne. 0) .and. (neast .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "NEAST"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NEAST set to the default value.'')') neast=l_neast end if if ((noadmiss .ne. 0) .and. (noadmiss .ne. 1).and. $ (Noadmiss .ne. -1)) then write (nio,'(/,2x,''Wrong value for the parameter "NOADMISS"'', & /,2x,''Admissible value : [0, 1]'',/ & 2x,''NOADMISS set to the default value.'')') noadmiss=l_noadmiss end if if ((OutNA .ne. 0) .and. (OutNA .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "OUTNA"'', & /,2x,''Admissible value : [0, 1]'',/ & 2x,''OUTNA set to the default value.'')') OutNA=l_OutNA end if if ((stochTD .ne. 0) .and. (stochTD .ne. 1).and. & (stochTD .ne. -1)) then write (nio,'(/,2x,''Wrong value for the parameter "STOCHTD"'', & /,2x,''Admissible value : [-1, 0, 1]'',/ & 2x,''StochTD set to the default value.'')') stochTD=l_stochTD end if if ((noserie .ne. 0) .and. (noserie .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "NOSERIE"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NOSERIE set to the default value.'')') noserie=l_noserie end if if ((nouir .ne. 0) .and. (nouir .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "NOUIR"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NOUIR set to the default value.'')') nouir=l_nouir end if if ((nous .ne. 0) .and. (nous .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "NOUS"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NOUS set to the default value.'')') nous=l_nous end if if ((noutr .ne. 0) .and. (noutr .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "NOUTR"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NOUTR set to the default value.'')') noutr=l_noutr end if if ((npareg .ne. 0) .and. (npareg .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "NPAREG"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NPAREG set to the default value.'')') npareg=l_npareg end if if ((npatd .ne. 0) .and. (npatd .ne. 1) .and. & (npatd .ne. 2) .and. (npatd .ne. 6) .and. & (npatd .ne. 7)) then write (nio,'(/,2x,''Wrong value for the parameter "NPATD"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''NPATD set to the default value.'')') npatd=l_npatd end if if ((out .lt. -1) .or. (out .gt. 3)) then write (nio,'(/,2x,''Wrong value for the parameter "OUT"'',/, & 2x,''Admissible value : [0, 1, 2, 3]'',/ & 2x,''OUT set to the default value.'')') out=l_out end if if (validTables(tabtables) .eq. 0) then write (nio,'(/,2x, & ''Wrong value for the parameter "TABTABLES"'',/, & 2x,''TABTABLES set to the default value.'')') tabtables=d_tabtables end if if ((p .lt. 0) .or. (p .gt. 3)) then write (nio,'(/,2x,''Wrong value for the parameter "P"'',/, & 2x,''Admissible value : 0<= p <=3'',/ & 2x,''P set to the default value.'')') p=l_p end if if ((pg .ne. 1) .and. (pg .ne. 0)) then write (nio,'(/,2x,''Wrong value for the parameter "PG"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''PG set to the default value.'')') pg=l_pg end if if ((q .lt. 0) .or. (q .gt. 3)) then write (nio,'(/,2x,''Wrong value for the parameter "Q"'',/, & 2x,''Admissible value : 0<= q <=3'',/ & 2x,''Q set to the default value'')') q=l_q end if if (qmax .lt. 0) then write (nio,'(/,2x,''Wrong value for the parameter "QMAX"'',/, & 2x,''Admissible value : qmax >= 0'',/ & 2x,''QMAX set to the default value.'')') qmax=l_qmax end if if ((rogtable .ne. 0) .and. (rogtable .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "ROGTABLE"'', & /,2x,''Admissible value : [0, 1]'',/ & 2x,''ROGTABLE set to the default value.'')') rogtable=l_rogtable end if if ((rsa .lt. 0) .and. (rsa .gt. 2)) then write (nio,'(/,2x,''Wrong value for the parameter "RSA"'',/, & 2x,''Admissible value : [0, 1, 2]'',/ & 2x,''RSA set to the default value.'')') rsa=l_rsa end if if ((statseas .ne. 0) .and. (statseas .ne. 1) .and. & (statseas.ne.-1)) then write (nio,'(/,2x,''Wrong value for the parameter "STATSEAS"'', & /,2x,''Admissible value : [-1,0, 1]'',/ & 2x,''STATSEAS set to the default value.'')') statseas=l_statseas end if if ((units .ne. 0) .and. (units .ne. 1) .and. $ (units .ne. -1)) then write (nio,'(/,2x,''Wrong value for the parameter "UNITS"'',/, & 2x,''Admissible value : [-1, 0, 1]'',/ & 2x,''UNITS set to the default value.'')') units=l_units end if c if (kunits .lt. 0) then c write (tst,'(3x,''kunits=''I2)') kunits c testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= c & tst c CounterLine=CounterLine+1 c end if if ((seas .ne. 0) .and. (seas .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "SEAS"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''SEAS set to the default value.'')') seas=l_seas end if if ((sqg .ne. 0) .and. (sqg .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "SQG"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''SQG set to the default value.'')') sqg=l_sqg end if if ((tramo .lt. -1) .and. (tramo .gt. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "TRAMO"'',/, & 2x,''Admissible value : [-1, 0, 1]'',/ & 2x,''TRAMO set to the default value.'')') tramo=l_tramo end if if ((type .ne. 0) .and. (type .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "TYPE"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''TYPE set to the default value.'')') type=l_type end if c if (blqt .ne. l_blqt) then c write (tst,'(3x,''blqt=''f8.3)') blqt c testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= c & tst c CounterLine=CounterLine+1 c end if if ((crmean .ne. 0) .and. (crmean .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "CRMEAN"'',/, & 2x,''Admissible value : [0, 1]'',/ & 2x,''CRMEAN set to the default value.'')') crmean=l_crmean end if if (epsiv .le. 0.0d0) then write (nio,'(/,2x,''Wrong value for the parameter "EPSIV"'',/, & 2x,''Admissible value : epsiv > 0'',/ & 2x,''EPSIV set to the default value.'')') epsiv=l_epsiv end if if (epsphi .lt. 0.0d0) then write (nio,'(/,2x,''Wrong value for the parameter "EPSPHI"'',/, & 2x,''Admissible value : epsphi >= 0.0'',/ & 2x,''EPSPHI set to the default value.'')') epsphi=l_epsphi end if c if (hplan .ne. l_hplan) then c write (tst,'(3x,''hplan=''f8.3)') hplan c testo(istrlen(testo)+1:istrlen(testo)+istrlen(tst))= c & tst c CounterLine=CounterLine+1 c end if if ((rmod .lt. 0.0d0) .or. (rmod .gt. 1.0d0)) then write (nio,'(/,2x,''Wrong value for the parameter "RMOD"'',/, & 2x,''Admissible value : 0.0 <= rmod <= 1.0'',/ & 2x,''RMOD set to the default value.'')') rmod=l_rmod end if if ((thlim .le. -1.0d0) .or. (thlim .gt. 0.0d0)) then write (nio,'(/,2x,''Wrong value for the parameter "THLIM"'',/, & 2x,''Admissible value : -1.0 < thlim < 0.0'',/ & 2x,''THLIM set to the default value.'')') thlim=l_thlim end if if ((bthlim .le. -1.0d0) .or. (bthlim .gt. 0.0d0)) then write (nio,'(/,2x,''Wrong value for the parameter "BTHLIM"'',/, & 2x,''Admissible value : -1.0 < bthlim < 0.0'',/ & 2x,''BTHLIM set to the default value.'')') bthlim=l_bthlim end if if ((xl .le. 0.0d0) .or. (xl .ge. 1.0d0)) then write (nio,'(/,2x,''Wrong value for the parameter "XL"'',/, & 2x,''Admissible value : 0.0 < xl <= 1.0'',/ & 2x,''XL set to the default value.'')') xl=l_xl end if if ((psieinic .gt. -24) .or. (psieinic .lt. -300))then write (nio,'(/,2x, & ''Wrong value for the parameter "Psieinic"'',/, & 2x,''Admissible value : [-300..-24]'',/ & 2x,''Psieinic set to the default value.'')') psieinic=l_psieinic end if if ((psiefin .lt. -1) .or. (psiefin .gt. 36))then write (nio,'(/,2x,''Wrong value for the parameter "Psiefin"'',/, & 2x,''Admissible value : [-1..36]'',/ & 2x,''Psiefin set to the default value.'')') psiefin=l_psiefin end if if ((Brol .lt. 0.0d0) .or. (Brol .gt. 1.0d0)) then write (nio,'(/,2x,''Wrong value for the parameter "Brol"'',/, & 2x,''Admissible value : [0:1.0]'',/ & 2x,''Brol set to the default value.'')') Brol=l_Brol end if if ((Blamda .lt. -3.0d0) .or. (Blamda .gt. 3.0d0)) then write (nio,'(/,2x,''Wrong value for the parameter "Blamda"'',/, & 2x,''Admissible value : [-3.0:3.0]'',/ & 2x,''Blamda set to the default value.'')') Blamda=l_Blamda end if if ((Bserie .lt. 0) .or. (Bserie .gt. 3)) then write (nio,'(/,2x,''Wrong value for the parameter "Bserie"'',/, & 2x,''Admissible value : [0,1,2,3]'',/ & 2x,''Bserie set to the default value.'')') Bserie=l_Bserie end if if ((BMid .ne. 0) .and. (BMid .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "BMid"'',/, & 2x,''Admissible value : [0,1]'',/ & 2x,''BMid set to the default value.'')') BMid=l_BMid end if if ((BcMark .ne. 0) .and. (BcMark .ne. 1)) then write (nio,'(/,2x,''Wrong value for the parameter "BcMark"'',/, & 2x,''Admissible value : [0,1]'',/ & 2x,''BcMark set to the default value.'')') BcMark=l_BcMark end if write (nio,'(/)') return end cc c cc subroutine SEATSLOG(Infile,TotalNum) C C.. Implicits .. implicit none C C.. Formal Arguments .. character Infile*180 integer TotalNum C C.. Local Scalars .. integer I,nrterr,nlenerr,ntrterr,ntlenerr,ntnmerr real*8 tmp C C.. Local Arrays .. integer Irterr(50000),Ilenerr(50000),ITrterr(50000), & ITnmerr(50000),ITlenerr(50000) C C.. External Calls .. include 'logtrace.i' nrterr=0 nlenerr=0 ntrterr=0 ntlenerr=0 ntnmerr=0 do i=1,ntrace-1 if (Dstdres(i) .eq. -99999.99) then nrterr=nrterr+1 Irterr(nrterr) = i else if (Dstdres(i) .eq. -88888.88) then nlenerr=nlenerr+1 Ilenerr(nlenerr) = i else if (Dstdres(i) .eq. -11111.11) then ntrterr=ntrterr+1 ITrterr(ntrterr) = i else if (Dstdres(i) .eq. -22222.22) then ntlenerr=ntlenerr+1 ITlenerr(ntlenerr) = i else if (Dstdres(i) .eq. -33333.33) then ntnmerr=ntnmerr+1 ITnmerr(ntnmerr) = i end if end do write (44,'(//)') !DEC$ IF DEFINED (DOS) CUNX#ifdef DOS write (44,'(6x,''Name of the series set: '',a)')Infile write (44,'(/)') CUNX#end if !DEC$ end if write (44,'(6x,''Total number of the series in the set :'', & i5.5)') TotalNum write (44,'(//)') write (44,'(6x,''Number of series not treated because not '', & ''enough observations, too many'',/,6x,''zeros, too many '', & ''constant values at the end, or too many missing'',/, & 6x,''observations :'',i5.5)') nlenerr if (nlenerr .gt. 0) then write (44,'(/)') do i=1, nlenerr write (44,'(12x,a)') TrTitle(Ilenerr(i))(1:32) end do end if write (44,'(//)') write (44,'(6x,''Number of series that produced '', $ ''a Run-Time EXCEPTION :'',i5.5)')nrterr if (nrterr .gt. 0) then write (44,'(/)') do i=1, nrterr write (44,'(12x,a)') TrTitle(Irterr(i))(1:32) end do end if if (ntrterr .gt. 0) then write (44,'(//)') write (44,'(6x,''Number of series that produced '', $ ''a Run-Time EXCEPTION in TRAMO :'',i5.5)')ntrterr write (44,'(/)') do i=1, ntrterr write (44,'(12x,a)') TrTitle(ITrterr(i))(1:32) end do end if if (ntlenerr .gt. 0) then write (44,'(//)') write (44,'(6x,''Number of series not treated because not '', & ''enough observations, too many'',/,6x,''zeros, too many '', & ''constant values at the end, or too many missing'',/, & 6x,''observations in TRAMO :'',i5.5)') ntlenerr write (44,'(/)') do i=1, ntlenerr write (44,'(12x,a)') TrTitle(ITlenerr(i))(1:32) end do end if end cc c cc CC C Return the number of token in the string. C The valid token separator are blank,comma,tab CC integer function GetTokenNum(Line) C C.. Implicits .. implicit none C C.. Parameters .. character*(*) Line C C.. Local Scalars .. integer i,numtok,intok C C.. External Functions .. integer ISTRLEN logical IsSeparator external ISTRLEN,IsSeparator numtok = 0 intok = 0 do i=1, ISTRLEN(Line) if ((intok .eq. 0) .and. .not. IsSeparator(Line(i:i)) & ) then numtok = numtok + 1 intok = 1 end if if (IsSeparator(Line(i:i))) then intok = 0 end if end do GetTokenNum = numtok return end cc c Return the Token(index) in the string Line c If index > GetTokenNum return a void string cc character*(*) function GetTokenidx(Line,index) C.. Implicits .. implicit none C.. Parameters .. integer index character*(*) Line C.. Local Scalars .. integer i,numtok,intok,istart,iend,LineLen C.. Local Arrays .. character*(1000) LocLine C.. External Functions .. integer ISTRLEN logical IsSeparator external ISTRLEN,IsSeparator LocLine = Line numtok = 0 intok = 0 GetTokenidx = '' istart = 0 LineLen = ISTRLEN(LocLine) if ((ichar(LocLine(LineLen+1:LineLen+1)) .ne. 9) .and. & (ichar(LocLine(LineLen+1:LineLen+1)) .ne. 44)) then LocLine(LineLen+1:LineLen+1) = ',' LineLen = LineLen + 1 end if do i=1, LineLen if ((intok .eq. 0) .and. .not. IsSeparator(LocLine(i:i)) & ) then numtok = numtok + 1 intok = 1 end if if (IsSeparator(LocLine(i:i))) then intok = 0 end if if ((numtok .eq. index) .and. (istart .eq. 0)) then istart = i end if if ((numtok .eq. index) .and. (intok .eq. 0)) then GetTokenidx = LocLine(istart:i-1) return end if end do return end cc c Return 1 if the syntax of the tabtablet is ok cc integer function Validtables(tabtables) implicit none character*100 tabtables C.. Local Scalars .. character*100 GetTokenidx integer nTokens,tokenLen,i character token*100 C.. External Functions .. external GetTokenNum,GetTokenidx,istrlen integer GetTokenNum,istrlen c... nTokens=GetTokenNum(tabtables) do i=1,nTokens token= GetTokenidx(tabtables,i) tokenLen=istrlen(token) if ('all'.ne. token(1:tokenLen) .and. & 'xo' .ne. token(1:tokenLen) .and. & 'p' .ne. token(1:tokenLen) .and. & 'n' .ne. token(1:tokenLen) .and. & 's' .ne. token(1:tokenLen) .and. & 'cal' .ne. token(1:tokenLen) .and. & 'uc' .ne. token(1:tokenLen) .and. & 'pa' .ne. token(1:tokenLen) .and. & 'cy' .ne. token(1:tokenLen) .and. & 'ltp' .ne. token(1:tokenLen) .and. & 'er' .ne. token(1:tokenLen) .and. & 'rg0' .ne. token(1:tokenLen) .and. & 'rgsa' .ne. token(1:tokenLen) .and. & 'stp' .ne. token(1:tokenLen) .and. & 'stn' .ne. token(1:tokenLen) ) then Validtables=0 return end if end do Validtables=1 return end cc c cc integer function IsSubstr (str,substr) C C.. Implicits .. implicit none C C.. Formal Arguments .. character*(*) substr character*100 str C C.. Local Scalars .. integer l1,l2,i,j,imat logical again C.. External Functions .. external istrlen,IsSeparator integer istrlen logical IsSeparator c... IsSubstr = 0 l1 = max(1,istrlen(str)) l2 = istrlen(substr) imat = 0 j = 1 again = .true. do while (j .le. l1) do while ((j .le. l1) .and. (again)) if (str(j:j) .eq. substr(1:1)) then again = .false. if (j .gt. 1) then again = .not. IsSeparator (str(j-1:j-1)) if (again) then J = J + 1 end if end if else j = j + 1 end if enddo if ((str(j:j+l2-1) .eq. substr(1:l2)) .and. & IsSeparator(str(j+l2:j+l2))) then IsSubstr = 1 return else j = j + 1 again = .true. end if enddo return end cc c cc logical function IsSeparator(char) C C.. Implicits .. implicit none C C.. Parameters .. character char C C.. IsSeparator = ((ichar(char).eq.9) .or. & (ichar(char).eq.44) .or. & (char .eq. ' ')) return end cc c cc cc c cc subroutine ProcTables(tabtables) C C.. Implicits .. implicit none C C.. Formal Arguments .. character tabtables*100 C C.. Local Scalars .. include 'prtous.i' integer itemp C.. External Functions .. external IsSubstr integer IsSubstr c... C.. xotab = 1 ptab = 1 ntab = 1 stab = 1 caltab = 1 patab = 1 cytab = 1 ltptab = 1 ertab = 1 rg0tab = 1 rgsatab = 1 stptab =1 stntab =1 utab=1 ctab=1 rtptab=0 rtsatab=0 itemp=IsSubstr(tabtables,'all') if (itemp .eq. 0) then xotab = IsSubstr(tabtables,'xo') ptab = IsSubstr(tabtables,'p') ntab = IsSubstr(tabtables,'n') stab = IsSubstr(tabtables,'s') caltab = IsSubstr(tabtables,'cal') patab = IsSubstr(tabtables,'pa') cytab = IsSubstr(tabtables,'cy') ltptab = IsSubstr(tabtables,'ltp') ertab = IsSubstr(tabtables,'er') rg0tab = IsSubstr(tabtables,'rg0') rgsatab = IsSubstr(tabtables,'rgsa') stptab = IsSubstr(tabtables,'stp') stntab = IsSubstr(tabtables,'stn') utab = IsSubstr(tabtables,'u') ctab = IsSubstr(tabtables,'c') rtptab=IsSubstr(tabtables,'rtp') rtsatab=IsSubstr(tabtables,'rtsa') end if return end c c c integer function Date2Idx(strdate) implicit none character*7 strdate character*2 tok1 character*4 tok2 integer period,year,retval integer lper,lyear,idx include 'date.i' logical IsInteger external IsInteger retval=-1 tok1=strdate(1:2) if (.not. IsInteger(tok1)) then Date2Idx=retval return end if read (tok1,'(i2)') period tok2=strdate(4:7) if (.not. IsInteger(tok2)) then Date2Idx=retval return end if read (tok2,'(i4)') year idx=1 lper=Dperiod lyear=Dyear do while ((idx.le.Dlen).and. $ ((lper.ne.period).or.(lyear.ne.year))) idx=idx+1 lper=lper+1 if (lper .gt. Dfreq) then lper=1 lyear=lyear+1 end if end do if (idx.le.Dlen) then retval=idx end if Date2Idx=retval return end c c c character*7 function Idx2Date(idx) implicit none integer idx character*7 strdate integer k,sp,sy include 'date.i' strdate='00-0000' sp=Dperiod sy=Dyear if (idx .gt. Dlen) then Idx2Date=strdate return end if do k=2,idx sp=sp+1 if (sp .gt. Dfreq) then sp=1 sy=sy+1 end if enddo write (strdate,'(i2.2,"-",i4.4)')sp,sy Idx2Date=strdate return end cc c cc logical function isInteger (Txt) C C.. Implicits .. implicit none C C.. Parameters .. character*(*) Txt C C.. Local Scalars .. integer iflag,Inum read (txt,'(i12)',iostat=iflag) Inum if (iflag > 0) then isInteger = .false. else isInteger = .true. end if return end cc c cc integer function LostB() implicit none character*2 tok1 character*4 tok2 integer period,year,retval integer lper,lyear,idx integer OCommDate,ACommDate include 'date.i' logical IsInteger external IsInteger retval=0 tok1=Odate(1:2) if (.not. IsInteger(tok1)) then LostB=retval return end if read (tok1,'(i2)') period tok2=Odate(4:7) if (.not. IsInteger(tok2)) then LostB=retval return end if read (tok2,'(i4)') year OCommDate=year*100+period ACommDate=Dyear*100+Dperiod if ((OCommDate .eq. 0) .or. (ACommDate .eq.0)) then retval=0 LostB=retval return end if if (OCommDate .ge. ACommDate) then retval=0 LostB=retval return end if idx=1 lper=period lyear=year do while ((lper.ne.Dperiod).or.(lyear.ne.Dyear)) idx=idx+1 lper=lper+1 if (lper .gt. Dfreq) then lper=1 lyear=lyear+1 end if end do retval=idx-1 LostB=retval return end cc c cc integer function LostE() implicit none character*2 tok1 character*4 tok2 integer period,year,retval integer lper,lyear,llper,llyear,idx integer OCommDate,ACommDate include 'date.i' logical IsInteger external IsInteger retval=0 tok1=Odate(1:2) if (.not. IsInteger(tok1)) then LostE=retval return end if read (tok1,'(i2)') period tok2=Odate(4:7) if (.not. IsInteger(tok2)) then LostE=retval return end if read (tok2,'(i4)') year idx=1 do while (idx .lt. Olen) idx=idx+1 period=period+1 if (period .gt. Dfreq) then period=1 year=year+1 end if end do OCommDate=year*100+period lper=Dperiod lyear=Dyear idx=1 do while (idx .lt. Dlen) idx=idx+1 lper=lper+1 if (lper .gt. Dfreq) then lper=1 lyear=lyear+1 end if end do ACommDate=lyear*100+lper if ((OCommDate .eq. 0) .or. (ACommDate .eq.0)) then retval=0 LostE=retval return end if if (ACommDate .ge. OCommDate) then retval=0 LostE=retval return end if idx=1 do while ((lper.ne.period).or.(lyear.ne.year)) idx=idx+1 lper=lper+1 if (lper .gt. Dfreq) then lper=1 lyear=lyear+1 end if end do retval=idx-1 LostE=retval return end cc c cc Subroutine Index2Date(index,sp,sy,nper,nyear,nfreq,len) implicit none integer index,sp,sy,nper,nyear,nfreq,len integer k sp=nper sy=nyear if (index .gt. len) then return end if do k=2,index sp=sp+1 if (sp .gt. nfreq) then sp=1 sy=sy+1 end if enddo return end c c c ExtendZ: this subroutine extends Z (backast and forecast) with a given model subroutine extendHP(Z,nz,THhp,nTHhp,lf,wm,eZ) implicit none INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n1,n10,n12 parameter (n1=1, n10=10, n12=12) c INPUT PARAMETERS integer nz,lf,nTHhp real*8 Z(*),THhp(*) c OUTPUT PARAMETERS real*8 eZ(*),wm c Common include 'calc.i' include 'calfor.i' include 'sesfcast.i' include 'xarr.i' c Local variables integer i,j,nd,tmplf real*8 sum real*8 tmpTH(3),tmpTHstar(40),tmpPHIST(30),BPHIST(60), $ tmpSESfcast(kp) integer tmpQ,tmpQstar,tmpPstar,tmpBQ,tmpP,tmpBP,tmpBPstar,tmpINIT integer Ierr,dummInt character ErrExt*180 real*8 a(mp+2*kp),ba(mp+2*kp),bz(mp+3*kp) integer na,BPSTAR real*8 f,forbias(kp) * integer nx * real*8 x(10) c ---------------------------------------------------------------------- do i=1,nz eZ(i)=Z(i) wd(i)=z(i) bz(i)=z(nz-i+1) enddo nw=nz nd=2 dummInt=3 BPHIST(1)=2.0d0 BPHIST(2)=-1.0d0 do j=1,nd do i=1,nw-1 wd(i)=wd(i+1)-wd(i) enddo nw=nw-1 enddo do i=1,kp tmpSESfcast(i)=SESfcast(i) enddo do i=1,Q tmpTH(i)=TH(i) enddo tmpQ=Q Q=2 TH(1)=-THhp(2) TH(2)=-THhp(3) do i=1,Qstar tmpTHstar(i)=THstar(i) enddo tmpQstar=Qstar Qstar=2 do i=1,Pstar tmpPHIST(i)=PHIST(i) enddo tmpPstar=Pstar tmpBQ=BQ tmpP=P tmpBP=BP Pstar=0 BQ=0 P=0 BP=0 tmpINIT=INIT INIT=2 Ierr=0 Na = Nw-Pstar+Qstar call calcFx(nx,x,f,na,a,Ierr,ErrExt,dummInt,*1000) do i=1,na a(i)=a(i)/Detpri enddo do i=1,INT(nw/2) sum=wd(i) wd(i)=wd(nw-i+1) wd(nw-i+1)=sum enddo if (nd.ne.INT(nd/2)*2) then do i=1,nw wd(i)=-wd(i) enddo end if sum=0.0d0 do i=1,nw sum=sum+wd(i) enddo wm=sum/nw BPSTAR=0 tmplf=lf call Fcast(PHIST,THstar,BPHIST,BPstar,eZ,nz,wm,a,na,-1,f,1,nd,0, $ 0,wm,tmplf,0,-300,forbias,1,1.645d0) call calcFx(nx,x,f,na,ba,Ierr,ErrExt,dummInt,*1000) do i=1,na ba(i)=ba(i)/Detpri enddo tmplf=lf call Fcast(PHIST,THstar,BPHIST,BPstar,bz,nz,wm,ba,na,-1,f,1,nd,0, $ 0,wm,tmplf,0,-300,forbias,1,1.645d0) do i=nz+lf,1,-1 eZ(lf+i)=ez(i) enddo do i=1,lf eZ(lf-i+1)=bz(nz+i) enddo 1000 if (Ierr.ne.0) then return end if INIT=tmpINIT BP=tmpBP P=tmpP BQ=tmpBQ Pstar=tmpPstar do i=1,Pstar PHIST(i)=tmpPHIST(i) enddo Qstar=tmpQstar do i=1,Qstar THstar(i)=tmpTHstar(i) enddo q=tmpQ do i=1,Q TH(i)=tmpTH(i) enddo do i=1,kp SESfcast(i)=tmpSESfcast(i) enddo end ansub11.f0000664006604000003110000012714214521201406011614 0ustar sun00315stepsC Last change: BCM 30 Sep 2005 12:38 pm cc c cc c La subrutina Afilter es equivalente a CalculaFilter.m de MAtlab junto con ErrorTotalAf.m c esta subroutine devuelve los pesos del filtro asimetrico asi como su fase y su funcion de Transferencia c se supone Xt=St+Nt Subroutine Afilter(alpha,transf,phase,phaseD,w,c,h, $ m,th,q,phis,ps,ths,qs,Vs, $ phin,pn) implicit none INCLUDE 'units.cmn' c c INPUT PARAMETERS c integer m !filter of t-m when the serie Xt is of -Inf:t integer q,qs, !length of MA(Xt),MA(St),MA(Nt) $ ps,pn !length of AR(St),AR(Nt) double precision th(0:q),phis(0:ps),ths(0:qs), $ phin(0:pn), $ Vs ! Variance of components noise where Va=1 c Note: seasonal operators are assumed to be stored in nonseasonal form, c e.g., if th(B) = 1 - .8*B^12, the corresponding coefficient c array is th = [1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -.8]'. c c c OUTPUT PARAMETERS c integer mx,mw parameter(mx=300,mw=1200) double precision alpha(0:2*mx) !weights of asymmetric filter double precision transf(0:mw),phase(0:mw),w(0:mw),phased(0:mw) c ! phase and transfer at different w values double precision c(0:mx) !Ignored part of asymmetric filter c c INTERNAL PARAMETERS c integer h,k,shft,lda,ipvt(mx),info,job double precision acgths(-mx:mx),acgth(-mx:mx),g(mx),a(mx,mx), $ tmp(-mx:mx),d(0:mx),thetil(0:mx),numer(0:mx), $ pi,rephin(0:mw),retheta(0:mw), $ imphin(0:mw),red(0:mw),imd(0:mw),imtheta(0:mw), $ refm(0:mw),imfm(0:mw),requot(0:mw),imquot(0:mw) integer i,j,ii !loop counters do i=0,mw transf(i)=0.0d0 phase(i) = 0.0d0 w(i) = 0.0d0 end do do i=0,2*mx alpha(i) = 0.0d0 end do pi=dacos(-1.0D0) lda=mx call mult0(ths,qs,qs,ths,0,qs,0,qs,acgths,mx,mx) call mult0(th,q,q,th,0,q,0,q,acgth,mx,mx) k= max(ps-1,qs+m) h= max(q,pn+qs-m) c----------------------------------------------------------------------- c Compute g(B) = phin(F)*ths(F)*ths(B). c Store coefficients of F^h, ... , B^k, where k = max(ps,qs) in c (g(1), ... , g(h+k+1))'. Note that some of c the first coefficients are zero if h > pn+qs, and some of the last c coefficients are zero if k > qs. The first nonzero computed c coefficient of phis(F)*ACGF(B) is stored in g(shft) c where shft = h-(pn+qs). c do 115 i=1,h+k+1 g(i)=0.0D0 115 continue call mult0(phin, pn, pn, acgths, mx,mx, qs, qs, tmp, mx,mx) shft = h + m - (pn+qs) do 120 i = shft+1, shft+1+pn+2*qs g(i) = tmp(i-shft-1-pn-qs) 120 continue c----------------------------------------------------------------------- c Set up and solve linear equations for c(q),...,c(0),d(1),...,d(k) where c c(F) = c(0) + c(1)*F + ... + c(h)*F^h, d(B) = 1 + d(1)*B + ... + d(k)*B^k, c and c(F)*phis(B) + th(F)*d(B) = g(B). Write linear equations as Ax = g. c c c Set up (h+k+1) by (h+k+1) matrix A for linear equations c do 130 j=1,mx do 131 i=1,mx a(i,j) = 0.0D0 131 continue 130 continue if (h. gt. 0) then do 140 j = 1, h do 141 i = j, ps+j if (i .eq. j) then a(i,j) = 1.0D0 else a(i,j) = phis(i-j) end if 141 continue 140 continue end if do 142 j = h+1, h+k+1 do 144 i = j, j-q, -1 if (i .eq. j) then a(i,j) = 1.0D0 else a(i,j) = th(j-i) end if 144 continue 142 continue c c Solve linear equations Ax = g for x = (c(h),...,c(1),d(0),...,d(k))' c Note that solution (as well as input) is stored in g call dgefa(a,lda,h+k+1,ipvt,info) job=0 call dgesl(a,lda,h+k+1,ipvt,g,job) c c fill d vector c do 200 i=0,k d(i)=g(i+h+1) 200 continue c c fill c vector c c(0)=0.0D0 do 201 i=h,1, -1 c(i)=g(h-i+1) 201 continue c----------------------------------------------------------------------- c c get coefficients of alpha(B)=(F**m)*phin(B)*d(B)/theta(B) c c first get coefficients of numer(B)=phin(B)*d(B) c call mult1(phin,pn,pn,d,mx,k,numer,mx) c c now get coefficients of thetil(B)=1/th(B) c only up to order mx c * write(ng,*)'pn, k, mx = ',pn, k, mx thetil(0)=1.0D0 do 205 j=1,mx * if(j.le.pn)write(ng,*)'j, phin = ',j,phin(j) * if(j.le.k)write(ng,*)'j, d = ',j,d(j) * write(ng,*)'j, numer = ',j,numer(j) thetil(j)=0.0D0 ii=min(j,q) do 206 i=1,ii thetil(j)=thetil(j)-th(i)*thetil(j-i) 206 continue 205 continue c c now get coefficients (up to mx) of alpha(B) (for m = 0) by taking c numer*thetil c first compute numer*thetil c then multiply by F**m (shift by m), and multiply by variance ratio c call mult1(numer,mx,pn+k,thetil,mx,mx,alpha,2*mx) do 210 i=0,2*mx alpha(i)=Vs*alpha(i) 210 continue c c alpha: pesos del filtro concurrent c----------------------------------------------------------------------- c----------------------------------------------------------------------- c The transfer and phase functions are computed in this section c C C Compute frequencies w(i) C do 238 i = 0,mw w(i) = pi*dble(i)/dble(mw) 238 continue C C Compute real and imaginary parts of polynomials evaluated at C B = exp(-iw(j)) C do 240 j = 0,mw rephin(j)=phin(0) imphin(j)=0.0D0 red(j)=d(0) imd(j)=0.0D0 retheta(j)=th(0) imtheta(j)=0.0D0 if (pn .gt. 0) then do 241 ii = 1,pn rephin(j)=rephin(j)+phin(ii)*dcos(w(j)*dble(ii)) imphin(j)=imphin(j)-phin(ii)*dsin(w(j)*dble(ii)) 241 continue else rephin(j)=rephin(j) end if if (k .gt. 0) then do 245 ii=1,k red(j)=red(j)+d(ii)*dcos(w(j)*dble(ii)) imd(j)=imd(j)-d(ii)*dsin(w(j)*dble(ii)) 245 continue else red(j)=red(j) end if if (q .gt. 0) then do 250 ii = 1,q retheta(j)=retheta(j)+th(ii)*dcos(w(j)*dble(ii)) imtheta(j)=imtheta(j)-th(ii)*dsin(w(j)*dble(ii)) 250 continue else retheta(j)=retheta(j) end if C C replacing F^^m by exp[i*cos(w(j))*m] C refm(j)=dcos(w(j)*dble(m)) imfm(j)=dsin(w(j)*dble(m)) 240 continue c compute transfer and phase functions c first compute real and imaginary parts of phin*d/th c store in requot and imquot c then multiply by exp(i*m*w(j)) (in place of F^^m) and re-store results c c do 300 i=0,mw requot(i)=retheta(i)*(rephin(i)*red(i)-imphin(i)*imd(i))+ 1 imtheta(i)*(rephin(i)*imd(i)+red(i)*imphin(i)) imquot(i)=retheta(i)*(rephin(i)*imd(i)+red(i)*imphin(i))- 1 imtheta(i)*(rephin(i)*red(i)-imphin(i)*imd(i)) requot(i)=requot(i)/(retheta(i)**2.0D0+imtheta(i)**2.0D0) imquot(i)=imquot(i)/(retheta(i)**2.0D0+imtheta(i)**2.0D0) requot(i)=requot(i)*refm(i)-imquot(i)*imfm(i) imquot(i)=imquot(i)*refm(i)+imfm(i)*requot(i) C C multiplying by square of variance ratio now C if (abs(requot(i)).lt.1E-10) then requot(i)=0 end if if (abs(imquot(i)).lt.1E-10) then imquot(i)=0 end if requot(i)=requot(i)*Vs imquot(i)=imquot(i)*Vs 300 continue c c compute squared gain c do 320 i=0,mw transf(i)=requot(i)**2.0D0+imquot(i)**2.0D0 c c compute phase shift c using arg function c if ((requot(i) .eq. 0.0D0) .and. (imquot(i) .gt. 0.0D0)) then phase(i)=pi/2.0D0 else if ((requot(i) .eq. 0.0D0) .and. (imquot(i) .lt. 0.0D0)) 1 then phase(i)=-pi/2.0D0 else if ((requot(i) .eq. 0.0D0) .and. (imquot(i) .eq. 0.0D0)) 1 then phase(i)=-pi/2.0D0 else if ((requot(i) .lt. 0.0D0) .and. (imquot(i) .ge. 0.0D0)) 1 then phase(i)=datan(imquot(i)/requot(i))+pi else if ((requot(i) .lt. 0.0D0) .and. (imquot(i) .lt. 0.0D0)) 1 then phase(i)=datan(imquot(i)/requot(i))-pi else phase(i)=datan(imquot(i)/requot(i)) end if c c the following piece is to take out discontinuities of phase when going from c quadrant 3 to 2 or quandrant 2 to 3 c c if ((i .ge. 2) .and. (requot(i-1) .lt. 0.0D0) .and. c 1 (imquot(i-1) .lt. 0.0D0) .and. (requot(i) .lt. 0.0D0) c 1 .and. (imquot(i) .gt. 0.0D0)) then c phase(i)=phase(i)-2.0d0*pi c else if ((i .ge. 2) .and. (requot(i-1) .lt. 0.0D0) .and. c 1 (imquot(i-1) .gt. 0.0D0) .and. (requot(i) .lt. 0.0D0) c 1 .and. (imquot(i) .lt. 0.0D0)) then c phase(i)=phase(i)+2.0d0*pi c else c phase(i)=phase(i) c end if c the following is to make the phase "continuous" (other than "holes" at undefined points) cc if (jj .ne. 2) then c if ((201 .le. i) .and. (400 .ge. i)) then c phase(i)=phase(i)-pi c else if ((401 .le. i) .and. (600 .ge. i)) then c phase(i)=phase(i)-2.0d0*pi c else if ((601 .le. i) .and. (800 .ge. i)) then c phase(i)=phase(i)-3.0d0*pi c else if ((801 .le. i) .and. (1000 .ge. i)) then c phase(i)=phase(i)-4.0d0*pi c else if ((1001 .le. i) .and. (1200 .ge. i)) then c phase(i)=phase(i)-5.0d0*pi c else c phase(i)=phase(i) c end if cc end if if (i .eq. 0) then phased(i)=0.0D0 else phased(i)=-phase(i)/w(i) end if c c write phase in units of cycles per year c c phase(i)=12.0d0*phase(i)/(2.0d0*pi) 320 continue c c write transfer and phase functions at frequencies w(i) c c end loop for m c 95 continue 5 continue end C Subroutine ErrorTAf C Equivalent to Matlab subroutine ErrorTotalAf C Va=1 C INPUT C C: part of asymmetric filter that needs the future C h:=max(q,pn+qs-m), is the maximum i such C(i)<>0 C th: theta of serie Xt C ths,thn: theta of St and Nt (Xt=St+Nt) C Vs,Vn: Variance of innovations of St and Nt in units of Va C OUTPUT C GMEM: autovariances(-2mx:2mx) of Total Error of Asymmetric filter subroutine ErrorTAf(C,h,th,q,ths,qs,thn,qn,Vs,Vn, $ GMEM) C INPUT PARAMETERS integer mx,mw parameter(mx=300,mw=1200) integer h,q,qs,qn double precision C(0:mx),th(0:q),ths(0:qs),thn(0:qn),Vs,Vn C INTERNAL PARAMETERS double precision acgths(-mx:mx),thetil(0:mx), $ acgthn(-mx:mx),gmeinf(-2*mx:2*mx), $ acgtil(-mx:mx), $ gminfn(-mx:mx),tmp2(-mx:mx) integer i,j,k !loop counters C OUTPUT PARAMETERS double precision gmem(-2*mx:2*mx) call mult0(ths,mx,qs,ths,0,mx,0,qs,acgths,mx,mx) call mult0(thn,mx,qn,thn,0,mx,0,qn,acgthn,mx,mx) c ----------------------------------------------------------------------------- c c first get coefficients of thetil(B)=1/th(B) c only up to order mx c thetil(0)=1.0D0 do 1205 j=1,mx thetil(j)=0.0D0 k=min(j,q) do 1206 i=1,k thetil(j)=thetil(j)-th(i)*thetil(j-i) 1206 continue 1205 continue c------------------------------------------------------------------- c now compute mean square error c compute autocovariance generation function gamma(eps,m) c first compute gamma(eps,infinity) c see Bell and Martin, formula (38) c c compute numerator call mult2(acgths,mx, mx, qs, qs, acgthn,mx,mx,qn, qn, 1 gminfn, mx,mx) c c compute denominator call mult0(thetil,mx,mx,thetil,0,mx,0,mx,acgtil,mx,mx) c now multiply to get gmeinf call mult2(gminfn,mx, mx, qs+qn, qs+qn, acgtil,mx,mx,mx,mx, 1 gmeinf, 2*mx, 2*mx) c c multiply by variances c do 219 j= -(mx+qs+qn), mx+qs+qn gmeinf(j)=gmeinf(j) * Vs * Vn 219 continue c c compute rest of gmem = gamma(eps,m) formula (43) c call mult0(C, mx, h , C, 0, mx, 0, h, tmp2, mx,mx) call mult2(tmp2, mx, mx, h, h, acgtil,mx,mx,mx,mx, 1 gmem, 2*mx,2*mx) do 220 j=-(mx+h),mx+h gmem(j)=gmem(j)*(Vs**2.0D0) 220 continue c c Now add coefficients of gamma(eps, inf) from above (equation 43) c do 228 j=-mx,mx gmem(j)=gmem(j)+gmeinf(j) 228 continue end cc c cc Subroutine FinitoFilter(ct,cs,cc,nz,nlen,mq,out,IsCloseToTD, $ FDelayp,FDelaySA,pg_iter) implicit none C INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C.. Parameters .. integer np parameter (np = 60) integer m, !the filter will be of observation nz-m $ nz, !Number of observations $ nlen, !length of w $ mq,out,pg_iter real*8 ct(32),cs(32),cc(32) logical IsCloseToTD C C.. Local Scalars .. integer i,j double precision pi,phmaxx C C.. Local Arrays .. double precision w(nlen+1) !frecuencies to which we calculate: c ! Transf*,phase* and PhaseDelay* c c OUTPUT PARAMETERS c double precision transp(nlen), c!Gain of p filter to each w(i) value $ transSA(nlen),!Gain of SA filter to each w(i) $ phasep(nlen), !phase of p filter to each w(i) $ phaseSA(nlen), !phase of SA filter to each w(i) $ FDelayp(nlen),!phase delay of p filter $ FDelaySA(nlen) c!phase delay of SA filter to each w(i) double precision tmp_Xlin(mpkp) double precision weightSA(0:nz-1), !weights of finite SA filter $ weightp(0:nz-1) !weights of finite Trend filter character fname*30,subtitle*50 include 'models.i' m = 0 pi=acos(-1.0D00) phmaxx = pi if (mq .gt. 1) then phmaxx = 2.0d0*pi/dble(mq) end if do i=1,nlen w(i)=pi*dble(i-1)/dble(nlen) end do do i=0,nz-1 do j=1,nz+kp tmp_Xlin(j)=0.0d0 end do tmp_Xlin(nz-i)=1.0d0 call GetStochWeight(nz-m,tmp_Xlin,nz, $ weightSA(i),weightp(i),ct,cs,cc,IsCloseToTD) end do call GetPhase(weightSA,nz,w,nlen,transSA,phaseSA,FDelaySA) * if (out.eq.0 .and. pg_iter.eq.0) then * fname = 'SQAFSA.T4F' * subtitle = 'SQUARED GAIN OF FINITE SA FILTER' * call PLOTFILTERS(fname,subtitle,transSA,nlen,Mq,-10.0d0,pi,1) * fname = 'PHAFSA.T4F' * subtitle = 'PHASE DELAY OF FINITE SA FILTER' * call PLOTFILTERS(fname,subtitle,FDelaySA,nlen,Mq,-10.0d0, * $ phmaxx,1) * end if if (nthetp .eq. 1) then do i=1,nlen transp(i) = 0.0d0 FDelayP(i) = 0.0d0 end do * if (out.eq.0 .and. pg_iter.eq.0) then * fname = 'SQAFTR.T4F' * subtitle = 'SQUARED GAIN OF FINITE TREND FILTER' * call PLOTFILTERS(fname,subtitle,transp,nlen,Mq,-10.0d0,pi,1) * fname = 'PHAFTR.T4F' * subtitle = 'PHASE DELAY OF FINITE TREND FILTER' * call PLOTFILTERS(fname,subtitle,FDelayP,nlen,Mq,-10.0d0, * $ phmaxx,1) * end if else call GetPhase(weightp,nz,w,nlen,transp,phasep,FDelayp) * if (out.eq.0 .and. pg_iter.eq.0) then * fname = 'SQAFTR.T4F' * subtitle = 'SQUARED GAIN OF FINITE TREND FILTER' * call PLOTFILTERS(fname,subtitle,transp,nlen,Mq,-10.0d0,pi,1) * fname = 'PHAFTR.T4F' * subtitle = 'PHASE DELAY OF FINITE TREND FILTER' * call PLOTFILTERS(fname,subtitle,FDelayP,nlen,Mq,-10.0d0, * $ phmaxx,1) * end if end if end cc c cc subroutine GetPhase(weights,nweights,w,nw, $ transf,phase,PhaseDelay) implicit none c c INPUT PARAMETERS c integer nw,nweights double precision w(nw),weights(nweights) c c OUTPUT PARAMETERS c double precision transf(nw),phase(nw),PhaseDelay(nw) c c INTERNAL PARAMETERS c integer k,l double precision freal(nw),fimag(nw),pi pi=dacos(-1.0D00) do k=1,nw fimag(k)=0 freal(k)=0 do l=0,nweights-1 fimag(k)=fimag(k)-weights(l+1)*sin(l*w(k)) freal(k)=freal(k)+weights(l+1)*cos(l*w(k)) enddo transf(k)=fimag(k)**2.0D0+freal(k)**2.0D0 if (abs(fimag(k)).lt.1.0D-10) then fimag(k)=0 end if if (abs(freal(k)).lt.1.0D-10) then freal(k)=0 end if if ((freal(k) .eq. 0.0D0) .and. (fimag(k) .gt. 0.0D0)) then phase(k)=pi/2.0D0 else if ((freal(k) .eq. 0.0D0) .and. (fimag(k) .lt. 0.0D0)) $ then phase(k)=-pi/2.0D0 else if ((freal(k) .eq. 0.0D0) .and. (fimag(k) .eq. 0.0D0)) $ then phase(k)=-pi/2.0D0 else if ((freal(k) .lt. 0.0D0) .and. (fimag(k) .ge. 0.0D0)) $ then phase(k)=datan(fimag(k)/freal(k))+pi else if ((freal(k) .lt. 0.0D0) .and. (fimag(k) .lt. 0.0D0)) $ then phase(k)=datan(fimag(k)/freal(k))-pi else phase(k)=datan(fimag(k)/freal(k)) end if PhaseDelay(k) = 0.0d0 if ( w(k) .gt. 1.0d-16) then PhaseDelay(k)=-phase(k)/w(k) end if end do return end cc c cc subroutine GetStochWeight(ind,z,nz,weightSa,weightP,ct,cs,cc, $ IscloseToTD) C C.. Implicits .. implicit none C C.. Parameters .. C INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' include 'units.cmn' C.. Parameters .. integer np parameter (np = 60) C C.. Formal Arguments .. integer ind,nz real*8 z(mpkp),weightSa, weightP real*8 ct(32),cs(32),cc(32) logical IsCloseToTD C C.. Local Scalars .. integer i,iqrow,irow,j,k,m,maxpq,n,nqst1 real*8 sum1,sum2,sum3,sum4,sum5,sum6,zaf,zab C C.. Local Arrays .. real*8 am(60,66),bxt(mpkp+np),bxs(mpkp+np),bxc(mpkp+np), $ byt(mpkp+np),bys(mpkp+np),byc(mpkp+np), $ fxt(mpkp+np),fxs(mpkp+np),fxc(mpkp+np), $ fyt(mpkp+np),fys(mpkp+np),fyc(mpkp+np), $ bz(mp+2*kp) include 'estgc.i' include 'models.i' C APPLY FILTERS GT AND GS TO FORWARD AND BACKWARDS C SERIES TO OBTAIN Y-SERIES C maxpq = MAX(ntotd,qstar0) cc c Here I have to extend the series with forecast, c compute the backward series and extend the series with backcast cc call ExtendSeries(z,bz,zaf,zab,nz) cc c cc if (ntotd .ne. qstar0) then nqst1 = qstar0 + 1 do i = nqst1,ntotd THSTR0(i) = 0.0d0 end do end if C C SET UP MATRIX C do i = 1,maxpq do j = i,maxpq am(i,j) = 0.0d0 end do do j = 1,i am(i,j) = THSTR0(i-j+1) end do m = maxpq - i + 1 do j = m,maxpq am(i,j) = am(i,j) + THSTR0(maxpq-j+m) end do k = maxpq - i + 1 am(i,maxpq+1) = ct(k) am(i,maxpq+2) = cs(k) am(i,maxpq+3) = cc(k) end do m = 3 * WRITE(Ng,*)' subroutine GetStochWeight, call 1' call MLTSOL(am,maxpq,m,60,66) do i = 1,maxpq k = maxpq - i + 1 gt(k) = am(i,maxpq+1) gs(k) = am(i,maxpq+2) gc(k) = am(i,maxpq+3) end do n = Nz + qstar0 - 1 do i = 1,n sum1 = 0.0d0 sum2 = 0.0d0 sum3 = 0.0d0 sum4 = 0.0d0 sum5 = 0.0d0 sum6 = 0.0d0 do j = 1,maxpq m = i + j - 1 sum1 = sum1 + gt(j)*z(m) sum2 = sum2 + gt(j)*bz(m) sum3 = sum3 + gs(j)*z(m) sum4 = sum4 + gs(j)*bz(m) sum5 = sum5 + gc(j)*z(m) sum6 = sum6 + gc(j)*bz(m) end do fyt(i) = sum1 byt(i) = sum2 fys(i) = sum3 bys(i) = sum4 fyc(i) = sum5 byc(i) = sum6 end do if (qstar0 .eq. 1) then do j = 1,Nz fxt(j) = fyt(j) bxt(j) = byt(j) fxs(j) = fys(j) bxs(j) = bys(j) fxc(j) = fyc(j) bxc(j) = byc(j) end do else C C DERIVE (PSTAR+QSTAR) TERMS OF X-SERIES BY SOLVING EQUATIONS C irow = ntotd + qstar0 - 2 do i = 1,irow do j = 1,irow am(i,j) = 0.0d0 end do end do n = Nz + qstar0 - ntotd iqrow = qstar0 - 1 do i = 1,iqrow do j = 1,ntotd m = i + j - 1 am(i,m) = totden(j) end do am(i,irow+1) = 0.5d0*zaf am(i,irow+2) = 0.5d0*zab do j = 3,6 am(i,irow+j) = 0.0d0 end do end do do i = qstar0,irow do j = 1,qstar0 m = i - j + 1 am(i,m) = THSTR0(j) end do k = n + irow - i + 1 am(i,irow+1) = fyt(k) am(i,irow+2) = byt(k) am(i,irow+3) = fys(k) am(i,irow+4) = bys(k) am(i,irow+5) = fyc(k) am(i,irow+6) = byc(k) end do m = 6 * WRITE(Ng,*)' subroutine GetStochWeight, call 2' call MLTSOL(am,irow,m,60,66) do i = 1,irow k = n + irow - i + 1 fxt(k) = am(i,irow+1) bxt(k) = am(i,irow+2) fxs(k) = am(i,irow+3) bxs(k) = am(i,irow+4) fxc(k) = am(i,irow+5) bxc(k) = am(i,irow+6) end do C C OBTAIN REST OF X-SERIES BY RECURRENCE AND C COMBINE X-SERIES TO GIVE SC AND TREND C do i = 1,n m = n - i + 1 sum1 = fyt(m) sum2 = byt(m) sum3 = fys(m) sum4 = bys(m) sum5 = fyc(m) sum6 = byc(m) do j = 2,qstar0 k = m + j - 1 sum1 = sum1 - THSTR0(j)*fxt(k) sum2 = sum2 - THSTR0(j)*bxt(k) sum3 = sum3 - THSTR0(j)*fxs(k) sum4 = sum4 - THSTR0(j)*bxs(k) sum5 = sum5 - THSTR0(j)*fxc(k) sum6 = sum6 - THSTR0(j)*bxc(k) end do fxt(m) = sum1 bxt(m) = sum2 fxs(m) = sum3 bxs(m) = sum4 fxc(m) = sum5 bxc(m) = sum6 end do end if if (IscloseToTD) then weightSa = z(ind) - fxs(ind) - bxs(Nz-ind+1) $ - fxc(ind) - bxc(Nz-ind+1) else weightSa = z(ind) - fxs(ind) - bxs(Nz-ind+1) end if weightP = fxt(ind) + bxt(Nz-ind+1) return end cc c cc subroutine ExtendSeries(z,bz,zaf,zab,nz) C C.. Implicits .. implicit none C C.. Parameters .. C INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C.. Parameters .. integer n1,n12,n10,np parameter (n10 = 10, n12 = 12, n1 = 1, np = 60) C C.. Formal Arguments .. integer nz real*8 z(mpkp),bz(mpkp+kp),zaf,zab C C.. Local Scalars .. integer i,j,ierr,jdd,kd,jmean,dummInt integer na,jfac,dof,lsig,lam,bias,out,fh,bpstar real*8 s,wm,alpha,f,ws C C.. Local Arrays .. real*8 a(mpkp),forbias(kp),bphist(6*n10) character Errext*180 C C.. Common include 'calc.i' include 'calfor.i' include 'xarr.i' cc c cc jmean = imean cc c We want all the time imean = 0 cc imean = 0 dummInt=3 alpha = 1.645d0 lsig = -1 lam = 1 bias = 0 out = 2 fh = -1 do i=1,nz Wd(i) = z(i) enddo nw = nz if (Bd .ne. 0) then do i = 1,Bd Nw = Nw - Mq do j = 1,Nw Wd(j) = Wd(j+Mq) - Wd(j) end do end do end if if (D .ne. 0) then do i = 1,D Nw = Nw - 1 do j = 1,Nw Wd(j) = Wd(j+1) - Wd(j) end do end do end if wm = 0.0d0 do i=1,nw wm = wm + wd(i) end do wm = wm /dble(nw) if (imean .eq. 1) then do i=1,nw wd(i) = wd(i) - wm end do end if Jfac = 1 Na = Nw - Pstar + Qstar Dof = Nw - Pstar - nx - Imean call CALCFX(nx,x,s,Na,a,Ierr,Errext,dummInt,*10) 10 continue f = s / Dof do i = 1,Na a(i) = a(i) / Detpri end do call FCAST(Phist,Thstar,bphist,bpstar,z,Nz,wm,a,Na, $ lsig,f,lam,D,Bd,Imean,zaf,fh,Out,Bias, $ forbias,0,alpha) cc c Reverse the series and compute the backward residuals cc do i = 1,Nz bz(Nz-i+1) = z(i) end do cc c Reverse the differenced series cc jdd = D + Bd kd = (-1)**jdd j = Nw do i = 1,Nw ws = Wd(i) * kd Wd(i) = Wd(Nw-i+1) * kd Wd(Nw-i+1) = ws j = j - 2 if (j .le. 0) goto 5009 end do 5009 zab = zaf * kd C C Generate backwards residuals and remove factor detpri C Jfac = 1 call CALCFX(Bpq,x,s,Na,a,Ierr,Errext,dummInt,*5010) 5010 do i = 1,Na a(i) = a(i) / Detpri end do call FCAST(Phist,Thstar,bphist,bpstar,bz,Nz,wm,a,Na, $ lsig,f,Lam,D,Bd,Imean,zab,fh,Out,-300, $ forbias,0,alpha) imean = jmean return end c smoothH make the smoothing of the histogram Transf(lTransf) c subroutine smoothH(Transf,lTransf,m,Stransf) c c INPUT PARAMETERS c integer lTransf,m double precision Transf(0:lTransf) c c OUTPUT PARAMETERS c double precision STransf(0:lTransf) c c INTERNAL PARAMETERS c integer k,j double precision window(0:m),ww do k=0,m-1 window(k)=1D0 end do window(m)=.5D0 do k=0,lTransf Stransf(k)=0D0 end do do j=0,m-1 ww=0 do k=0,j Stransf(j)=Stransf(j)+Transf(j-k)*window(k) ww=ww+window(k) end do do k=1,m Stransf(j)=Stransf(j)+Transf(j+k)*window(k) ww=ww+window(k) end do Stransf(j)=Stransf(j)/ww end do ww=window(0) do j=1,m ww=ww+2*window(j) end do do j=m,lTransf-m do k=1,m Stransf(j)=Stransf(j)+Transf(j-k)*window(k) end do do k=0,m Stransf(j)=Stransf(j)+Transf(j+k)*window(k) end do Stransf(j)=Stransf(j)/ww end do do j=lTransf-m+1,lTransf ww=0 do k=1,m Stransf(j)=Stransf(j)+Transf(j-k)*window(k) ww=ww+window(k) end do do k=0,lTransf-j Stransf(j)=Stransf(j)+Transf(j+k)*window(k) ww=ww+window(k) end do Stransf(j)=Stransf(j)/ww end do end cc c cc c c Windowing of Data or windowing of AutoVariances c INPUT: c wtype (0 windowing of Data, 1 windowing of autovariances) c iwindow (0=>square,1=>welch,2=>Tukey,3=>Bartlett,4=>Hamming,5=>Parzen) c m (2m-1 is the width of the window) c x(nz) (the serie to obtain its spectrum) c ovrlap (if wtype=0, .TRUE.=>overlap windows, .FALSE.=>don't overlap) c OUTPUT: c p(0:m-1) Spectrum Estimator * SUBROUTINE Windowin(wtype,iwindow,p,m,x,nz,ovrlap) * *c *c INPUT PARAMETERS *c * integer wtype,iwindow,m,nz * integer ovrlap * double precision x(nz) *c *c OUTPUT PARAMETERS *c * double precision p(0:m) *c *c INTERNAL PARAMETERS *c * double precision window(0:m) * * call getWind(iwindow,m,window) * if (wtype .eq. 0) then * call DataWind(p,m,x,nz,window,ovrlap) * else * call covwind(p,m,x,nz,window,60) * end if * * return * end * *c *c DataWind applies Data windowing to obtain the histogram. *c Data windowing is applied over Time domain *c and fft is calculated over each window * subroutine DataWind(p,m,x,nz,window,ovrlap) * *c *c INPUT PARAMETERS *c * integer m,nz * double precision x(nz),window(0:m) * integer ovrlap *c *c OUTPUT PARAMETERS *c * double precision p(0:m) *c *c INTERNAL PARAMETERS *c * integer j,k,mk,redu,Inc,Ini * double precision w1(2*m+1),sumw,ffr(0:m),ffi(0:m) * *c * do j=0,m * p(j)=0D0 * end do * if (ovrlap .eq. 2) then * Inc=1 * Ini=m * else * Inc=m * Ini=1 * end if * mk=nz/Inc * sumw=window(0)*window(0) * DO j=1,m * sumw=sumw+2*window(j)*window(j) * end do * * * redu=0 * do k=Ini,mk-1 * if (ovrlap .ge. 1) then * if ((k*Inc+1+m) .gt. nz) then * redu=nz-(k*Inc+1+m) * end if * do j=0,m * w1(m-j+1)=x(k*Inc+1-j+redu)*window(j) * w1(m+j+1)=x(k*Inc+1+j+redu)*window(j) * end do * else * if ((k*(2*m+1)+1+m) .gt. nz) then * redu=nz-(k*(2*m+1)+1+m) * end if * do j=0,m * w1(m-j+1)=x(k*(2*m+1)+1-j+redu)*window(j) * w1(m+j+1)=x(k*(2*m+1)+1+j+redu)*window(j) * end do * end if * call fft(w1,2*m+1,ffr,ffi) * p(0)=p(0)+ffr(0)*ffr(0) * do j=1,m * p(j)=p(j)+ffr(j)*ffr(j)+ffi(j)*ffi(j) * end do * end do * do j=0,m * p(j)=p(j)/(mk*sumw) * end do * * end * c covWind apply Fourier to the windowed ACF subroutine covwind(p,m,x,nz,window,pm) c c INPUT PARAMETERS c integer m,nz,pm,mm double precision window(0:120),x(*) c c OUTPUT PARAMETERS c double precision p(0:pm) c c INTERNAL PARAMETERS c integer j,k double precision c(0:m),pi2 parameter(pi2=6.28318530717959d0) call crosco(x,x,1,nz,nz,c,m+1) mm=min(pm,m) do j=0,mm p(j)=0D0 p(0)=p(0)+c(j)*window(j) end do do k=1,m/2+1 p(k)=c(0)*window(0) do j=1,m p(k)=p(k)+2*c(j)*window(j)*cos(pi2*j*k/m) end do end do end subroutine getWind(ind,m,window) c c INPUT PARAMETERS c integer ind,m c c OUTPUT PARAMETERS c double precision window(0:m) c c internal parameters c integer j double precision square,Welch,Tukey,Bartlett,Hamming,Parzen,pi parameter(pi=3.14159265358979D0) square(j)=1. welch(j)=1-(j/m)**2 Tukey(j)=.5*(1+cos(pi*j/m)) Bartlett(j)=1-j/m Hamming(j)=.54+.46*cos(pi*j/m) if (ind .eq. 1) then do j=0,m window(j)=welch(j) end do else if (ind .eq. 2) then do j=0,m window(j)=Tukey(j) !this is equivalent to Hanning end do else if (ind .eq. 3) then do j=0,m window(j)=Bartlett(j) end do else if (ind .eq. 4) then do j=0,m window(j)=Hamming(j) end do else if (ind .eq. 5) then do j=0,m window(j)=Parzen(j,m) end do else do j=0,m window(j)=square(j) end do end if end double precision function Parzen(j,m) integer j,m double precision parzen1,parzen2 parzen1(j)=1-6*(j/m)**2+6*(j/m)**3 parzen2(j)=2*(1-j/m)**3 if (j .le. m/2) then Parzen=parzen1(j) else Parzen=parzen2(j) end if end character*(*) function getWindN(ind) integer ind integer max_wind parameter(max_wind=5) character*16 windName(0:max_wind) data windName /'square','Welch','Tukey', $ 'Bartlett','Hamming','Parzen'/ if ((ind .ge. 1) .and. (ind .le. 5)) then getWindN=windName(ind) else getWindN=windName(0) end if end character*(*) function getWindT(wtype) integer wtype if (wtype .eq. 0) then getWindT='windData' else getWindT='windCovar' end if end cc c cc c getSpect subroutine that obtains the Spectrum of a given a serie subroutine getSpect(z,nz,Freq,nFreq,nAR,Sxx,Good) C C.. Implicits .. implicit none c----------------------------------------------------------------------- DOUBLE PRECISION PI,ZERO,ONE,TEN PARAMETER(PI=3.14159265358979D0,ZERO=0D0,ONE=1D0,TEN=10D0) c----------------------------------------------------------------------- c INPUT PARAMETERS integer nz,nFreq,nAR double precision z(nz),Freq(nFreq) c OUTPUT PARAMETERS LOGICAL Good double precision Sxx(nFreq) c INTERNAL PARAMETERS integer na,i,ifail,k,h1 DOUBLE PRECISION c2,s2,dj,pxx(nFreq) real*8 aic,Vz real*8 AR(nAR),b(nAR),tmpAR(nAR) c----------------------------------------------------------------------- real*8 getVar external getVar c----------------------------------------------------------------------- na = nz-nAR if (na .gt. 0) then call arfit(z,nz,nAR,AR,aic,ifail) if (ifail .eq. 1) then return end if DO i=1,nAR tmpAR(i)=-AR(i) END DO * call snrasp(tmpAR,b,Sxx,Freq,aic/na,nAR,0,nFreq,.true.) Vz=getVar(z,nz) c----------------------------------------------------------------------- h1=nFreq DO i=1,h1 c2=ONE DO k=1,nAR dj=dble(2*k)*PI*Freq(i) c2=c2+(tmpAR(k)*cos(dj)) END DO s2=ZERO DO k=1,nAR dj=dble(2*k)*PI*Freq(i) s2=s2+(tmpAR(k)*sin(dj)) END DO pxx(i)=Vz/(c2**2 + s2**2) END DO c----------------------------------------------------------------------- * do i=1,nFreq * Sxx(i) = exp(pxx(i)*log(10.0d0)/10.0d0) * end do * sSxx=0 * do i=2,nFreq * sSxx=sSxx+Sxx(i) * end do * sSxx=sSxx/(nFreq-1) do i=1,nFreq Sxx(i)=pxx(i) end do end if return end double precision function KENDALLS(x,nz,mq) C C.. Implicits .. implicit none C INCLUDE 'srslen.prm' C.. Parameters .. integer Nmod,Np,Mp,Kp,loopmax real*8 dbl_max parameter (kp = PFCST, mp = POBS, Np = 84, Nmod = 5, $ dbl_max = 1.0d307,loopmax = 1000) C C.. Formal Arguments .. integer nz,mq real*8 x(*) C C.. Local Scalars .. integer ny,res,i,j,k,ind,maxloop real*8 tmp,sum,min_val,value C C.. Local Arrays .. integer found(mq) real*8 obs(mq),m(mq),r(nz/mq,mq) C C.. External Functions .. real*8 AMIN external AMIN if (mq.le.1) then kendalls=0.0d0 return end if ny = nz/mq res = nz - ny*mq do i = 1,ny do j = 1,mq obs(j) = x(res+(i-1)*mq+j) end do ind = 1 maxloop = 0 do while ((ind .le. mq).and.(maxloop .lt.loopmax)) maxloop = maxloop +1 min_val = AMIN(obs,mq) k = 0 do j = 1,mq found(j) = 0 if (abs(obs(j)-min_val) .lt. 1.0d-20) then k = k + 1 found(j) = 1 end if end do value = ind + (k-1)/2.0d0 do j = 1,mq if (found(j) .eq. 1) then obs(j) = dbl_max r(i,j) = value end if end do ind = ind + k end do if (maxloop .gt. loopmax) then kendalls = 0.0d0 return end if end do do i = 1,mq sum = 0.0d0 do j = 1,ny sum = sum + r(j,i) end do m(i) = sum end do tmp = 0.0d0 do i = 1,mq tmp = tmp + (m(i)-ny*(mq+1)/2.0d0) * (m(i)-ny*(mq+1)/2.0d0) end do kendalls = 12.0d0*tmp / ((mq+1)*mq*ny) return end subroutine FFT(x,lx,ffr,ffi) c initialice and call FFTr c c INPUT PARAMETERS c integer lx double precision x(lx) EXTERNAL FFTr c c OUTPUT PARAMETERS c double precision ffr(0:lx/2),!real part of fourier Transf $ ffi(0:lx/2) !Imag part of Fourier Transform call initWg(lx) call FFTr(x,lx,ffr,ffi) return end subroutine FFTr(x,lx,ffr,ffi) c c INPUT PARAMETERS c integer lx double precision x(lx) double precision ffr(0:lx/2),!real part of fourier Transf $ ffi(0:lx/2) !Imag part of Fourier Transform include "fft.i" call sFourier(x,lx,ffr,ffi) return end double precision function getVar(z,nz) integer nz,j double precision z(nz),media,ss,zm media=0 do j=1,nz media=media+z(j) end do media=media/nz ss=0 do j=1,nz zm=z(j)-media ss=ss+zm*zm end do getVar=ss/nz return end c getHist return the histogram values of x subroutine getHist(x,lx,transf) c c INPUT PARAMETERS c integer lx double precision x(lx) c c OUTPUT PARAMETERS c double precision transf(0:lx/2) c c INTERNAL PARAMETERS c double precision ffr(0:lx/2),ffi(0:lx/2) integer k call FFT(x,lx,ffr,ffi) do k=0,lx/2 transf(k)=(ffr(k)*ffr(k)+ffi(k)*ffi(k))/lx end do return end cc c cc c Fast Fourier routines Subroutine initWg(lx) c initialize the common block FFT_block integer lx,k double precision w include "fft.i" nz=lx w=pi2/nz wgr(0)=1 wgi(0)=0 do k=1,(nz-1) wgr(k)=cos(w*k) wgi(k)=sin(w*k) end do end c slowFourier performs Fourier with O(N^2) computation Subroutine sFourier(x,lx,ffr,ffi) c c INPUT PARAMETERS c integer lx double precision x(lx) include "fft.i" c c OUTPUT PARAMETERS c double precision ffr(0:(lx-1)/2), !real part of fourier Transf $ ffi(0:(lx-1)/2) !Imag part of Fourier Transform c c Internal PARAMETERS c integer lx2,lx1,j,k double precision w if (lx .eq. 1) then ffr(0)=x(1) ffi(0)=0 return end if lx1=lx-1 lx2=(lx-1)/2 w=pi2/lx DO k=0,lx2 ffr(k)=0 ffi(k)=0 DO j=1,lx ffr(k)=ffr(k)+x(j)*cos(w*k*(j-1)) ffi(k)=ffi(k)+x(j)*sin(w*k*(j-1)) end DO !ffr(lx1-k)=ffr(k) !por simetria de la transformada al ser x real !ffr(lx1-k)=ffi(k) !por simetria de la FT al ser x real end DO end cc c cc c subroutine rellenarPico(pico,peakSA_S,nPeakSA_S,nPeakSA_TD, $ peakSA_TD,peakRes_S,nPeakRes_S,nPeakRes_TD,peakRes_TD) character pico(16) integer nPeakSA_S, nPeakSA_TD,nPeakRes_S, nPeakRes_TD integer PeakSA_S(16),peakSA_TD(16),PeakRes_S(16),peakRes_TD(16) c LOCAL VARIABLES integer i c include 'peaks.i' c do i=1,16 pico(i)='-' end do do i=1,nPeakSA_S select case (peakSA_S(i)) case (11) pico(1)='Y' case (21) pico(2)='Y' case (31) pico(3)='Y' case (41) pico(4)='Y' case (51) pico(5)='Y' case (61) pico(6)='Y' end select end do do i=1,nPeakSA_TD select case (peakSA_TD(i)) case (43) pico(7)='Y' case (53) pico(8)='Y' case (6) pico(7)='Y' case (12) pico(8)='Y' end select end do do i=1,npeakRes_S select case (peakRes_S(i)) case (11) pico(9)='Y' case (21) pico(10)='Y' case (31) pico(11)='Y' case (41) pico(12)='Y' case (51) pico(13)='Y' case (61) pico(14)='Y' end select end do do i=1,npeakRes_TD select case (peakRes_TD(i)) case (43) pico(15)='Y' case (53) pico(16)='Y' case (6) pico(15)='Y' case (12) pico(16)='Y' end select end do end C Last change: BCM 12 Nov 1998 10:53 am **==ispeak2.f processed by SPAG 4.03F at 14:16 on 28 Sep 1994 INTEGER FUNCTION ispeak2(Sxx,Lsa,Peaks,Lowlim,Uplim,Npeaks,Plimit, & Mlimit,Ny,Freq,Plocal,Ldecbl,ipeaks) IMPLICIT NONE c----------------------------------------------------------------------- c Function that flags possible trading day or seasonal peaks in a c given set of spectral estimates. Peak must be greater than the c median of the spectral estimates computed (Mlimit). The peaks of c interest are defined in the vector pkvec. c----------------------------------------------------------------------- DOUBLE PRECISION Mlimit,Sxx,slimit,Plimit,Freq,f0,f1,f2,Plocal INTEGER ipeaks LOGICAL Lsa,Ldecbl INTEGER i,ifreq,Peaks,Lowlim,Uplim,Peakwd,Npeaks,i2,Ny,k,k0,k1,k2 DIMENSION Sxx(*),Freq(*),Peaks(*),Lowlim(*),Uplim(*),ipeaks(6) c----------------------------------------------------------------------- ispeak2=0 i2=Npeaks IF(Lsa.and.Ny.eq.12)i2=i2-1 c----------------------------------------------------------------------- DO i=1,i2 ifreq=Peaks(i) IF(Sxx(ifreq).gt.Mlimit)THEN c----------------------------------------------------------------------- k=0 k1=Lowlim(i)+1 IF(Lsa.and.Ny.eq.12)THEN k2=ifreq-1 ELSE k2=Uplim(i)-1 END IF IF(k2.gt.k1)THEN f1=Freq(ifreq)-Plocal f2=Freq(ifreq)+Plocal DO k0=k1,k2 IF(k0.ne.ifreq)THEN f0=Freq(k0) IF((f0.lt.f1.or.f0.gt.f2).and.(Sxx(k0).gt.Sxx(ifreq)))k=k+1 END IF END DO END IF c----------------------------------------------------------------------- IF(k.eq.0)THEN IF(Ldecbl)THEN slimit=Sxx(ifreq)-Plimit IF(Sxx(Lowlim(i)).lt.slimit)THEN IF(Lsa.and.(i.eq.Npeaks))THEN ispeak2=ispeak2+1 ipeaks(ispeak2)=ifreq ELSE IF(Sxx(Uplim(i)).lt.slimit)THEN ispeak2=ispeak2+1 ipeaks(ispeak2)=ifreq END IF END IF END IF ELSE slimit=Sxx(ifreq)/Sxx(Lowlim(i)) IF(slimit.ge.Plimit)THEN IF(Lsa.and.(i.eq.i2))THEN ispeak2=ispeak2+1 ipeaks(ispeak2)=ifreq ELSE slimit=Sxx(ifreq)/Sxx(Uplim(i)) IF(slimit.ge.Plimit)THEN ispeak2=ispeak2+1 ipeaks(ispeak2)=ifreq END IF END IF END IF END IF END IF END IF END DO c----------------------------------------------------------------------- RETURN END ansub1.f0000664006604000003110000031021514521201406011526 0ustar sun00315stepsC Last change: REG 23 Dec 2005 C Previous change: BCM 4 Oct 2002 3:08 pm C C C SEARCH SUBROUTINE C FINDS THE VALUES OF THE PARAMETERS FOR WHICH THE VALUE OF A C FUNCTION IN THESE PARAMETERS IS MINIMISED. C PROGRAM VARIABLES INPUT FROM CALLING PROGRAM:- C VARIABLE NAME PURPOSE C C NX NUMBER OF PARAMETERS. C X ARRAY OF STARTING VALUES OF PARAMETERS. C XMIN ARRAY OF LOWER BOUNDS OF PARAMETERS. C XMAX ARRAY OF UPPER BOUNDS OF PARAMETERS. C EPSIV CONVERGENCE LIMIT FOR BOUNDED PARAMETERS. C EPSIF CONVERGENCE LIMIT FOR FUNCTION VALUES. C E ARRAY, -1 FOR PARAMETERS WITHOUT BOUNDS, C 0 FOR PARAMETERS WITH BOUNDS. C +1 FOR PARAMETERS TO BE FIXED. C CONV ARRAY OF CONVERGENCE TESTS FOR UNBOUNDED PARAMETERS. C N NUMBER OF OBSERVATIONS IN DATA. C F ARRAY OF ERRORS. C FI SUM OF SQUARES OF ERRORS (TO BE MINIMISED). C MAXIT MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MAXF MAXIMUM NUMBER OF FUNCTION VALUES ALLOWED. C IPRINT 1 FOR EXTRA PRINTING, 0 OTHERWISE. C SET ARRAY OF STANDARD ERRORS OF PARAMETERS. C CE CORRELATION MATRIX OF PARAMETERS. C FIXED RETURN 1 IF SOME PARAMETERS ARE FIXED 0 OTHERWISE C FIXVAL IS THE DIMENSION OF AUTOREGRESSIVE PART C UR THE VALUES TO WHICH THE AR PARAMETERS ARE FIXED C OUT 1,2 NO PRINT ARE PERFORMED C * RETURN STATEMENT IF PARAMETERS ARE OUT OF BOUNDS. C C C SUBROUTINES CALLED BY SEARCH: C FEASI (SUPPLIED WITH SEARCH). C CALCFX (SUPPLIED BY THE USER). C CALCFX IS USED TO CALCULATE THE VALUE OF THE FUNCTION TO BE C MINIMISED. THE ARGUMENTS PASSED TO CALCFX ARE NX,X,FI,N,F C DEFINED ABOVE (BUT X WILL CONTAIN THE CURRENT VALUES OF THE C PARAMETERS). C C subroutine SEARCH(nx,x,xmin,xmax,epsiv,e,convc,n,f,fi,maxit,maxf, $ iprint,set,ce,fixed,fixval,ipr,ur,out,itn,bd,dr,Ierr,Errext,*) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n10 parameter (n10 = 10) C INCLUDE 'units.cmn' C C.. Formal Arguments .. integer nx,e(*),n,maxit,maxf,iprint,fixed,fixval,out,Ierr,dr,bd, $ ipr real*8 x(*),xmin(*),xmax(*),epsiv,convc(*),f(*),fi,set(*), $ ce(n10,n10),ur character Errext*180 C C.. Local Scalars .. integer i,icom,ip,isp,itn,j,ji,jp,jsum,k,kl0,l,m,nv,nvc,nUnitReg real*8 b,ceps,cgam,cotb,det,dgam,fbt,fib,fit,fitt,gam,lam,minmu,q, $ qth,qtheti,r,range,red,rf,sa,sg,sgam,sp,st,stg,stj,sx, $ theta,ttheta,v,xtest C C.. Local Arrays .. real*8 a(2*n10,2*n10),bx(2*n10),c(2*n10,2*n10),d(2*n10), $ del(2*n10),ds(2*n10),f1(mpkp),fia(2*n10),g(2*n10), $ gs(2*n10),h(2*n10),mu(n10),p(mpkp,2*n10),qtheta(2*n10), $ s(2*n10,2*n10),se(2*n10),sig(2*n10),ss(2*n10),t(2*n10), $ ts(2*n10) C C.. External Calls .. external CALCFX, FEASI C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C.. Intrinsic Functions .. intrinsic ABS, ACOS, ATAN, SIN, SQRT include 'count.i' include 'stream.i' C C ... Executable Statements ... C Icomm = 0 fit = 0.0d0 ceps = 1.0d-12 C do i = 1,nx if (e(i) .eq. 0) then if (x(i).lt.xmin(i) .or. x(i).gt.xmax(i)) then if (out.eq.0) THEN 7000 format ( $ /,' ',' STARTING VALUES OUT OF RANGE', $ ' OR BOUNDS IN THE WRONG ORDER') write (Nio,7000) end if return 1 end if end if end do C C FIND INITIAL FUNCTION VALUE FI AND INITIAL ERROR ARRAY F Ifn = 0 call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) if (Ierr.ne.0) then return end if Ifn = 1 itn = 1 mu(1) = 0.0d0 mu(2) = 0.1d0 do j = 3,n10 mu(j) = 2.d0 * mu(j-1) / (1.d0+mu(j-1)) end do C C SET UP ARRAY DEL, USED TO CALCULATE DERIVATIVES do j = 1,nx if (e(j) .lt. 0) then del(j) = 0.1d0 * convc(j) else if (e(j) .eq. 0) then range = xmax(j) - xmin(j) del(j) = range * 0.0001d0 convc(j) = range * epsiv end if end do C C START OF ITERATION PROCEDURE. C TEST TO SEE IF MAXIMUM NUMBER OF ITERATIONS OR FUNCTION VALUES C EXCEEDED C do 15 while (itn.lt.maxit .and. Ifn.lt.maxf) C if ((iprint .gt. 0).and. (out.eq.0)) then 7001 format ( $ /,' '/' ITERATION ',i5,i12,' FUNCTION VALUES F = ', $ e17.8/(6e20.6)) write (Nio,7001) itn, Ifn, fi, (x(j), j = 1,nx) end if * write(Mtprof,7001) itn, Ifn, fi, (x(j), j = 1,nx) * CALL outARMAParam() do j = 1,nx bx(j) = x(j) end do C C TEST FUNCTION VALUE FOR ABSOLUTE MAGNITUDE. C if (fi .lt. 1.0d-9) THEN * call profiler(2,'**GO TO 5020**, line 165') goto 5020 END IF C C fib = fi nv = nx C C IF A BOUNDED PARAMETER IS WITHIN 1 PERCENT OF ITS BOUNDARY, C FIX IT AT THE BOUNDARY. THE BOUNDARY IS "UR" FOR AUTOREGRESSIVE C PARAMETERS AND XMAX(.) FOR MOVING AVERAGE PARAMETERS C nUnitReg=0 do 10 j = 1,nx if (e(j) .lt. 0) then * call profiler(2,'**GO TO 10**, line 172') goto 10 else if (e(j) .eq. 0) then xtest = (x(j)-xmin(j)) / (xmax(j)-xmin(j)) if (xtest .ge. 0.01d0) then if (xtest .gt. 0.99d0) then if (j .le. fixval) then bx(j) = 0.99d0 else bx(j) = xmax(j) end if else * call profiler(2,'**GO TO 10**, line 184') goto 10 end if else if (j .le. fixval) then if (j.gt.ipr) then if (bd.eq.0) then bx(j) = -ur else * call profiler(2,'**GO TO 10**, line 192') goto 10 end if else if ((dr+nUnitReg).lt.2) then bx(j)=-ur nUnitReg=nUnitReg+1 else * call profiler(2,'**GO TO 10**, line 201') goto 10 end if end if else bx(j) = xmin(j) end if e(j) = 1 * call profiler(2,'entering CALCFX, line 208') call CALCFX(nx,bx,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 if ((iprint.gt.0) .and. (out.eq.0)) then 7002 format (/,'PARAMETER ',i2,' FIXED ') write (Nio,7002) j end if end if nv = nv - 1 10 continue C C NV IS THE NUMBER OF PARAMETERS WHICH ARE NOT YET FIXED. C if (nv .le. 0) THEN * call profiler(2,'**GO TO 5018**, line 226') goto 5018 END IF C C CALCULATE FIRST DERIVATIVES k = 1 do j = 1,nx if (e(j) .ne. 1) then * write(Mtprof,*) ' bx(',j,'), del(',j,') = ', bx(j), del(j) bx(j) = bx(j) + del(j) * write(Mtprof,*) ' bx = ', (bx(i), i = 1, nx) * call profiler(2,'entering CALCFX, line 235') call CALCFX(nx,bx,fi,n,f1,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 do i = 1,n p(i,k) = (f(i)-f1(i)) / del(j) end do bx(j) = bx(j) - del(j) k = k + 1 end if end do C C CALCULATE MATRIX A=P'.P do j = 1,nv do k = 1,j sa = 0.0d0 do i = 1,n sa = sa + p(i,j)*p(i,k) end do a(j,k) = sa end do end do C C CALCULATE ARRAY G=F.P , $ CHECK THAT G HAS A NON-ZERO ELEMENT do j = 1,nv sg = 0.0d0 do i = 1,n sg = sg + f(i)*p(i,j) end do g(j) = sg end do do j = 1,nv if (ABS(g(j)) .gt. ceps) goto 5000 end do * call profiler(2,'**GO TO 5020**, line 272') goto 5020 C 5000 if (nv .gt. 1) then C C ROUTINE IF MORE THAN ONE PARAMETER STILL NOT FIXED. C C STANDARDISE MATRIX A AND ARRAY G. do j = 1,nv sig(j) = SQRT(a(j,j)) if (sig(j).lt.1.0D-30) then sig(j)=1.0D-30 end if gs(j) = g(j) / sig(j) kl0 = j - 1 do k = 1,kl0 a(j,k) = a(j,k) / (sig(j)*sig(k)) a(k,j) = a(j,k) end do a(j,j) = 1.0d0 end do C C C INVERT MATRIX A. det = 1.0d0 do i = 1,nv det = det * a(i,i) r = 10.d0**(-nv-3) if (det .lt. r) then if (det .gt. 0) then if ((iprint .gt. 0).and.(out.eq.0)) then 7003 format (/,' ',' MATRIX SINGULAR ') write (Nio,7003) end if else if (out.eq.0) then 7004 format (/,' MODEL DEGENERATE - DET < 0') write (Nio,7004) end if Ierr = 1 Errext = 'SEARCH : Model degenerate DET(A) <=0' return end if end if if (a(i,i) .le. 1.d-10) goto 5019 b = 1 / a(i,i) a(i,i) = b do j = 1,nv if (j .lt. i) then v = b * a(j,i) do k = j,nv if (k .lt. i) then a(j,k) = a(j,k) + v*a(k,i) end if if (k .gt. i) then a(j,k) = a(j,k) - v*a(i,k) end if end do a(j,i) = -v else if (j .ne. i) then v = b * a(i,j) do k = j,nv a(j,k) = a(j,k) - v*a(i,k) end do a(i,j) = v end if end do end do do j = 1,nv m = j - 1 do k = 1,m a(j,k) = a(k,j) end do end do C C CALCULATE T* st = 0.0d0 sg = 0.0d0 sp = 0.0d0 do j = 1,nv stj = 0.0d0 do k = 1,nv stj = stj + a(j,k)*gs(k) end do ts(j) = stj st = st + ts(j)*ts(j) sg = sg + gs(j)*gs(j) sp = sp + gs(j)*ts(j) end do C C CALCULATE GAMMA (THE ANGLE BETWEEN THE TAYLOR POINT DIRECTION C $ THE DIRECTION OF STEEPEST DESCENT.) cgam = sp / SQRT(st*sg) gam = ACOS(cgam) dgam = gam * 57.2957795d0 if ((iprint .gt. 0).and.(out.eq.0)) then 7005 format (/,' ',' GAMMA = ',f5.1) write (Nio,7005) dgam end if sgam = SIN(gam) stg = SQRT(st/sg) C C DESCALE T AND D do j = 1,nv t(j) = ts(j) / sig(j) ds(j) = gs(j) * stg d(j) = ds(j) / sig(j) end do C EXPAND T AND D TO VECTORS OF LENGTH NX WITH ZEROS FOR FIXED C PARAMETER SUBSCRIPTS. T IS THE TAYLOR POINT, D IS THE POINT C 0F STEEPEST DESCENT. nvc = nv do j = 1,nx ji = nx - j + 1 if (e(ji) .gt. 0) then t(ji) = 0.0d0 d(ji) = 0.0d0 else t(ji) = t(nvc) d(ji) = d(nvc) nvc = nvc - 1 end if end do C C SET SPIRAL COUNTERS icom = 0 isp = 1 q = 1 do j = 1,nx x(j) = bx(j) + t(j) end do C C IF TAYLOR POINT IS OUT OF BOUNDS FOR BOUNDED PARAMETERS, SCALE C IT TO BRING IT WITHIN BOUNDS. call FEASI(nx,x,bx,e,xmin,xmax,red) if (ABS(red-1.0d0) .ge. ceps) then rf = red * 0.8d0 do j = 1,nx t(j) = rf * t(j) d(j) = rf * d(j) end do * call profiler(2,'**GO TO 5010**, line 413') goto 5010 end if C .. Head of LOOP .. 5006 continue C C IF THE FUNCTION VALUE IS SMALLER AT THE TAYLOR POINT, THE C ITERATION IS COMPLETE. do j = 1,nx if (ABS(t(j)) .gt. convc(j)) goto 5007 end do * call profiler(2,'**GO TO 5020**, line 424') goto 5020 * 5007 call profiler(2,'entering CALCFX, line 426') 5007 call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX, line 427') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 if (fi .lt. fib) THEN * call profiler(2,'**GO TO 5011**, line 433') goto 5011 END IF C C if (isp .gt. 1) then fbt = fib*0.75d0 + fit*0.25d0 if (fi .lt. fbt) then C C INTERPOLATE ALONG OT. fitt = fi if ((iprint.gt.0).and.(out.eq.0)) then 7006 format (/,' ',' INTERPOLATION ALONG OT ') write (Nio,7006) end if lam = (fbt-fitt) / (fib*0.5d0+fit*0.5d0-fitt) do j = 1,nx x(j) = bx(j) + lam*t(j) end do * call profiler(2,'entering CALCFX, line 453') call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX, line 455') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 C C IF INTERPOLATION ALONG OT IS SUCCESSFUL, THE ITERATION IS COMPLETE. if (fi .lt. fib) THEN * call profiler(2,'**GO TO 5012**, line 460') goto 5012 END IF C C IF INTERPOLATION ALONG OT IS UNSUCCESSFUL, ADOPT LAMBDA (IF NECESSARY) C $ START ON SPIRAL. if (fi .ge. fitt) then fit = fitt if ((iprint .gt. 0).and.(out.eq.0)) then 7007 format (/,' ',' UNSUCCESSFUL ') write (Nio,7007) end if else if ((iprint .gt. 0).and.(out.eq.0)) then 7008 format (/,' ',' LAMBDA ADOPTED ',f12.3) write (Nio,7008) lam end if do j = 1,nx t(j) = t(j) * lam d(j) = d(j) * lam end do q = q * lam fit = fi cotb = 1.0d0 / sgam end if * call profiler(2,'**GO TO 5008**, line 486') goto 5008 end if end if fit = fi cotb = 1.0d0 / sgam C C START OF SPIRAL 5008 fia(1) = fit if ((iprint .gt. 0).and.(out.eq.0)) then 7009 format (/,' ',' SPIRAL NUMBER ',i4) write (Nio,7009) isp end if C C TRY SEVEN POINTS ON THE SPIRAL. do j = 2,8 if (icom .ne. 1) then ttheta = mu(j) * sgam / (1.d0-mu(j)+mu(j)*cgam) theta = ATAN(ttheta) qth = (1.d0-gam*cotb) * (theta/gam)**2 qtheta(j-1) = $ SIN(theta) * (1.d0-theta*cotb-qth) / (mu(j)*sgam) do k = 1,nx s(j,k) = qtheta(j-1) * (mu(j)*d(k)+(1.d0-mu(j))*t(k)) end do end if C do k = 1,nx x(k) = bx(k) + s(j,k)*q end do if (icom .ne. 1) then call FEASI(nx,x,bx,e,xmin,xmax,red) if (ABS(red-1.0d0) .ge. ceps) then jp = j - 1 * call profiler(2,'**GO TO 5009**, line 520') goto 5009 end if end if * call profiler(2,'entering CALCFX, line 524') call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX, line 526') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 jp = j - 1 C C IF THE FUNCTION VALUE IS SMALLER, THE ITERATION IS COMPLETE. if (fi .lt. fib) THEN * call profiler(2,'**GO TO 5013**, line 535') goto 5013 END IF C C INTERPOLATE BETWEEN POINTS ON THE SPIRAL. fia(j) = fi h(j) = (fia(j)-fia(j-1)) / (mu(j)-mu(j-1)) if (j .ge. 3) then if (h(j) .gt. h(j-1)) then minmu = h(j)*(mu(j-1)+mu(j-2)) - h(j-1)*(mu(j)+mu(j-1)) minmu = minmu / (2.d0*(h(j)-h(j-1))) if (minmu.lt.mu(j) .and. minmu.gt.mu(j-2)) then if ((iprint .gt. 0).and.(out.eq.0)) then 7010 format (/,' ',' INTERPOLATION ALONG SPIRAL STEP ',i4) write (Nio,7010) jp end if ttheta = minmu * sgam / (1.d0-minmu+minmu*cgam) theta = ATAN(ttheta) qtheti = (1.d0-gam*cotb) * (theta/gam)**2 qtheti = SIN(theta) * (1.d0-theta*cotb-qtheti) / $ (minmu*sgam) do k = 1,nx ss(k) = qtheti * (minmu*d(k)+(1.d0-minmu)*t(k)) x(k) = bx(k) + ss(k) end do if (icom .ne. 1) then call FEASI(nx,x,bx,e,xmin,xmax,red) if (red .lt. 1.0d0) goto 5009 end if * call profiler(2,'entering CALCFX, line 566') call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX, line 568') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 C C IF FUNCTION VALUE IS SMALLER, THE ITERATION IS COMPLETE. if (fi .ge. fib) then if ((iprint .gt. 0).and.(out.eq.0)) then write (Nio,7007) end if else * call profiler(2,'**GO TO 5014**, line 576') goto 5014 end if end if end if end if end do C C SCALE DOWN THE TAYLOR POINT $ POINT OF STEEPEST DESCENT, & TRY C ANOTHER SPIRAL (5 SPIRALS ALLOWED). icom = 1 5009 if (isp .ge. 5) THEN * call profiler(2,'**GO TO 5015**, line 588') goto 5015 END IF do j = 1,nx t(j) = t(j) * 0.5d0 d(j) = d(j) * 0.5d0 end do q = q * 0.5d0 isp = isp + 1 5010 do j = 1,nx x(j) = bx(j) + t(j) end do C .. End of LOOP .. * call profiler(2,'**GO TO 5006**, line 601') goto 5006 5011 if ((iprint .gt. 0).and.(out.eq.0)) then 7011 format (/,' ',' TAYLOR POINT ') write (Nio,7011) end if itn = itn + 1 * write (Mtprof,7011) * call profiler(2,'**GO TO 15**, line 609') goto 15 5012 if ((iprint .gt. 0).and.(out.eq.0)) then 7012 format (/,' ',' SUCCESSFUL ') write (Nio,7012) end if itn = itn + 1 * write (Mtprof,7012) * call profiler(2,'**GO TO 15**, line 617') goto 15 5013 if ((iprint .gt. 0).and.(out.eq.0)) then 7013 format (/,' ',' SUCCESSFUL AT STEP ',i4) write (Nio,7013) jp end if itn = itn + 1 * write (Mtprof,7013)jp * call profiler(2,'**GO TO 15**, line 625') goto 15 5014 if ((iprint .gt. 0).and.(out.eq.0)) then write (Nio,7012) end if itn = itn + 1 * write (Mtprof,7012) * call profiler(2,'**GO TO 15**, line 632') goto 15 C C STEEPEST DESCENT. 5015 do j = 1,nx d(j) = d(j) * 0.5d0 x(j) = bx(j) + d(j) end do call FEASI(nx,x,bx,e,xmin,xmax,red) if (red .lt. 1.0d0) then do j = 1,nx d(j) = 0.9d0 * red * d(j) x(j) = bx(j) + d(j) end do end if do while (.true.) if ((iprint .gt. 0).and.(out.eq.0)) then 7014 format (/,' ',' STEEPEST DESCENT ') write (Nio,7014) end if do j = 1,nx if (ABS(d(j)) .gt. convc(j)*0.5) THEN * call profiler(2,'**GO TO 5016**, line 654') goto 5016 END IF end do * call profiler(2,'**GO TO 5020**, line 658') goto 5020 * 5016 call profiler(2,'entering CALCFX, line 664') 5016 call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'entering CALCFX, line 666') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 C C IF FUNCTION VALUE IS SMALLER THE ITERATION IS COMPLETE. if (fi .ge. fib) then do j = 1,nx d(j) = d(j) * 0.5d0 x(j) = bx(j) + d(j) end do else * call profiler(2,'**GO TO 5017**, line 673') goto 5017 end if end do 5017 itn = itn + 1 else C C END OF SPIRAL. C C C ROUTINE IF ONLY ONE PARAMETER IS NOT FIXED. C IP IS THE PARAMETER NOT YET FIXED do j = 1,nx t(j) = 0.0d0 if (e(j) .ne. 1) then ip = j t(j) = g(1) / a(1,1) end if x(j) = bx(j) + t(j) end do isp = 1 call FEASI(nx,x,bx,e,xmin,xmax,red) if (ABS(red-1.0d0) .ge. ceps) then t(ip) = 0.8 * red * t(ip) * call profiler(2,'**GO TO 5003**, line 697') goto 5003 end if C .. Head of INNER_LOOP .. 5001 continue if (ABS(t(ip)) .lt. convc(ip)) THEN * call profiler(2,'**GO TO 5020**, line 703') goto 5020 END IF * call profiler(2,'before CALCFX, line 712') call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX, line 714') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 if (fi .lt. fib) THEN * call profiler(2,'**GO TO 5004**, line 720') goto 5004 END IF if (isp .gt. 1) then fbt = fib*0.75d0 + fit*0.25d0 if (fi .lt. fbt) then fitt = fi if ((iprint .gt. 0).and.(out.eq.0)) then write (Nio,7006) end if lam = (fbt-fitt) / (fib*0.5d0+fit*0.5d0-fitt) x(ip) = bx(ip) + lam*t(ip) * call profiler(2,'before CALCFX, line 732') call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX, line 734') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 if (fi .lt. fib) THEN * call profiler(2,'**GO TO 5005**, line 740') goto 5005 END IF if (fi .ge. fitt) then fit = fitt if (iprint .gt. 0) then write (Nio,7007) end if * WRITE(Mtprof,7007) * call profiler(2,'**GO TO 5002**, line 749') goto 5002 else t(ip) = lam * t(ip) end if end if fit = fi end if 5002 t(ip) = 0.5d0 * t(ip) isp = isp + 1 5003 x(ip) = bx(ip) + t(ip) C .. End of INNER_LOOP .. * call profiler(2,'**GO TO 5001**, line 761') goto 5001 5004 if ((iprint .gt. 0).and.(out.eq.0)) then write (Nio,7011) end if itn = itn + 1 * WRITE(Mtprof,7011) * call profiler(2,'**GO TO 15**, line 768') goto 15 5005 if ((iprint .gt. 0).and.(out.eq.0)) then write (Nio,7012) end if itn = itn + 1 end if * WRITE(Mtprof,7012) * call profiler(2,'**GO TO 15**, line 776') 15 continue C * if (out .eq. 0) then * if (HTML .eq. 1) then * 6015 format('

',i4,' ITERATIONS COMPLETED.
',i6, * $ ' FUNCTION VALUES F = ',e17.8,6('
',e20.6)) * write (Nio,6015) itn, Ifn, fi, (x(j), j = 1,nx) * write (Nio,'(''

'')') * else 7015 format ( $ /,' ',i4,' ITERATIONS COMPLETED '/i6, $ ' FUNCTION VALUES F = ',e17.8/(6e20.6)) * write (Mtprof,7015) itn, Ifn, fi, (x(j), j = 1,nx) * end if * end if * CALL outARMAParam() * call profiler(2,'**GO TO 5021**, line 793') goto 5021 5018 do j = 1,nx x(j) = bx(j) end do if ((iprint .gt. 0).and.(out.eq.0)) then 7016 format ( $ /,' ',' ALL PARAMETERS AT LIMITS ',10x,'F = ',e17.8/(6e20.6)) write (Nio,7016) fi, (x(j), j = 1,nx) end if * write(Mtprof,7016) fi, (x(j), j = 1,nx) fixed = 1 + fixed return 5019 continue if (out.eq.0) then 7017 format (/,' MODEL DEGENERATE - DIAGONAL ELEMENT',i4,' SMALL') write (Nio,7017) i do k = 1,nv if (a(k,k) .le. 1.d-10) then 7018 format (/,' ELEMENT',i4,5x,f10.6) write (Nio,7018) k, a(k,k) end if end do end if Ierr = 1 Errext = 'SEARCH : Model degenerate Diagonal Element too small' return C C END OF ITERATION PROCEDURE. C C CALCULATE FINAL FUNCTION VALUE. 5020 do j = 1,nx x(j) = bx(j) end do * call profiler(2,'before CALCFX, line 827') call CALCFX(nx,x,fi,n,f,Ierr,Errext,out,*5021) * call profiler(2,'exiting CALCFX, line 829') if (Ierr.ne.0) then return end if Ifn = Ifn + 1 * if (out .eq. 0) then * if (HTML .eq. 1) then * 6019 format ('

CONVERGED AFTER ',i2, * $ ' ITERATIONS AND ',i3, * $ ' FUNCTION VALUES F = ',e17.8, * $ 6('
',e20.6)) * write (Nio,6019) itn, Ifn, fi, (x(j), j = 1,nx) * write (Nio,'(''

'')') * else * 7019 format ( * $ /,' ',' CONVERGED AFTER ',i2,' ITERATIONS AND ',i3, * $ ' FUNCTION VALUES F =',e17.8/(6e20.6)) * write (Nio,7019) itn, Ifn, fi, (x(j), j = 1,nx) * end if * end if 5021 if (n .gt. nx) then C C INDICATE WHICH PARAMETERS HAVE BEEN FIXED. sx = fi / (n-nv) * if (out .ne. 2) then * if (HTML .eq. 1) then * 6020 format ('

PARAMETERS FIXED

') * write (Nio,6020) * else * 7020 format (/,' ','PARAMETERS FIXED ') * write (Nio,7020) * end if * end if jsum = 0 do j = 1,nx if (e(j) .ne. -1) then jsum = jsum + e(j) if (e(j) .eq. 1) then * if (out .eq. 0) then * if (HTML .eq. 1) then * 6021 format ('
',i6) * write (Nio,6021) j * else * 7021 format (i6) * write (Nio,7021) j * end if * end if fixed = 1 + fixed end if end if end do * if ((out.eq.0) .and. (jsum.eq.0)) then * write (Nio,7021) jsum * end if C C CALCULATE STANDARD ERRORS OF PARAMETERS AND CORRELATION MATRIX. if (nv .ne. 1) then if ((iprint .gt. 0).and.(out.eq.0)) then 7022 format (/,' ',' CORRELATION MATRIX ') write (Nio,7022) end if do j = 1,nv do k = 1,j c(j,k) = a(j,k) / SQRT(a(j,j)*a(k,k)) end do CC C Changed the computation os SE 02/11/2001 C Restored the old one, to be checked 23-10-2002 CC se(j) = SQRT(a(j,j)*sx) / sig(j) C se(j) = SQRT(a(j,j)*sx)/a(j,j) if (iprint .gt. 0) then 7023 format (' ',(7f14.6)) write (Nio,7023) (c(j,k), k = 1,j) end if end do else C ******************************************************************* if (ABS(a(1,1)) .lt. 1.0d-13) then a(1,1) = 1.0d-6 end if C HO AGGIUNTO L'IF PERCHE' DAVA LO ZERODIVIDE C ******************************************************************* se(1) = SQRT(sx/a(1,1)) c(1,1) = 1.d0 end if if ((iprint .gt. 0).and.(out.eq.0)) then 7024 format (/,' ',' STANDARD ERRORS OF PARAMETERS '/(1x,7f14.6)) write (Nio,7024) (se(j), j = 1,nv) end if C C SET UP ARRAYS SET,CE. C SET(I)=CE(I,J)=CE(J,I)=100 IF PARAMETER I IS FIXED. do i = 1,nx do j = 1,i ce(j,i) = 100.0d0 ce(i,j) = 100.0d0 end do set(i) = 100.0d0 end do k = 1 do i = 1,nx l = 1 if (e(i) .le. 0) then set(i) = se(k) do j = 1,i if (e(j) .le. 0) then ce(i,j) = c(k,l) ce(j,i) = ce(i,j) l = l + 1 end if end do k = k + 1 end if end do else if ((iprint .gt. 0).and.(out.eq.0)) then 7025 format (/,' ',' EXACT FIT ') write (Nio,7025) end if end C C C THIS SUBROUTINE CALCULATES THE VALUE OF THE SUM OF SQUARES FUNCTION C WHICH IS BEING MINIMISED. C THE ALGORITHIM USED FOR ML IS BASED ON OSBORN C C PARAMETERS IN CALLING STATEMENT ARE C NX = NO OF TRANSFORMED PARAMETERS C X = ARRAY CONTAINING VALUES OF TRANSFORMED PARAMETERS C F = VALUE OF SUM OF SQUARES C N = NO OF TERMS IN SS C A = ESTIMATE OF ERROR TERMS USED IN SS C subroutine CALCFX(nx,x,f,n,a,Ierr,Errext,out,*) C C C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n12,n10,n1 parameter (n1 = 1, n10 = 10, n12 = 12) C C.. Formal Arguments .. integer nx real*8 x(*) real*8 f integer n,out real*8 a(mpkp) integer Ierr character Errext*180 C C.. Local Scalars .. integer i,i1,i2,iflag,iproot,iqroot,iroot,j,j1,k,l,m,nith,np,nq1, $ nq2,p1,q1 real*8 ceps,det,detbnp,e,g,h,small,sum,sum1,sum2,sum3,diffpq C C.. Local Arrays .. integer ith(maxTH),jcol(3*n10) real*8 am(mpkp,2*n12+3*n1),ap(3*n1),aq(3*n1), $ b(2*n12+3*n1,2*n12+3*n1),r(3*n1),u(mpkp),v(2*n12+3*n1), $ y(4*n10) C C.. External Calls .. external TRANSC C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C.. Intrinsic Functions .. intrinsic ABS include 'calc.i' include 'calfor.i' include 'calshr.i' include 'count.i' include 'stream.i' include 'units.cmn' C C.. Save Declarations .. save iproot, iqroot, ith, nith, y C C ... Executable Statements ... C small = 10.d-10 ceps = 1.0d-12 C C NP = NO OF PERIODS WHEN DATA FOR FULL MODEL EXISTS C np = Nw - Pstar if (Init .ne. 2) then if (Ifn .gt. 0) goto 5000 end if iproot = 0 iqroot = 0 do i = 1,nx y(i) = x(i) + 0.01 end do C C INDICES OF NON-ZERO THSTAR TO ITH C if (Q .ne. 0) then do i = 1,Q ith(i) = i end do end if if (Bq .ne. 0) then k = Q do i = 1,Bq k = k + 1 j = i * Mq ith(k) = j if (Q .ne. 0) then do l = 1,Q k = k + 1 ith(k) = j + l end do end if end do end if nith = Q*Bq + Q + Bq C C PART 1 C CALCULATE PHI(I) AND BPHI(I) FROM TRANSFORMED PARAMETERS X(J) C 5000 iflag = 0 if (P .ne. 0) then C C CHANGE PHI ONLY IF SOME X(J)'S HAVE CHANGED, IF NOT IFLAG =1 C do i = 1,P if (.not.dpeq(y(i),x(i))) goto 5001 end do goto 5002 5001 if (Init .lt. 2) then * write(Mtprof,*) ' phi = ',(phi(i),i=1,P) call TRANSC(x,0,P,Phi,iproot,ap) * if (iproot.gt.0) THEN * write(Mtprof,*) ' ap = ',(ap(i),i=1,iproot) * ELSE * write(Mtprof,*) ' iproot = ',iproot * END IF end if goto 5003 end if 5002 iflag = 1 C 5003 if (Bp .ne. 0) then p1 = P + 1 C C CHANGE BPHI(I) ONLY IF X(J) HAS CHANGED C do i = p1,Pbp if (.not.dpeq(y(i),x(i))) goto 5004 end do goto 5005 5004 if (Init .lt. 2) then call TRANSC(x,P,Pbp,Bphi,iroot,r) end if goto 5006 end if 5005 if (iflag .eq. 1) goto 5007 C IROOT AND V ARE NOT USED C C STEP 1B C CALCULATE PHIST = FI * BFI C 5006 do i = 1,Pstar Phist(i) = 0.0d0 end do if (P .ne. 0) then do i = 1,P Phist(i) = Phi(i) end do end if if (Bp .ne. 0) then do i = 1,Bp j = i * Mq Phist(j) = Bphi(i) if (P .ne. 0) then do k = 1,P Phist(k+j) = -Phi(k)*Bphi(i) end do end if end do end if C C STEP 2 C CALCULATE U(I),I=1,NW-PSTAR C 5007 do i = 1,np sum = Wd(i+Pstar) if (Pstar .ne. 0) then do j = 1,Pstar sum = sum - Phist(j)*Wd(i+Pstar-j) end do end if u(i) = sum end do detbnp = 1.0d0 C C STEP 3 C C CALCULATE TH(I) AND BTH(I) FROM TRANSFORMED PARAMETERS X(J) C C IF QSTAR=0 NO PAST ESTIMATES OF ERRORS REQUIRED C if (Qstar .ne. 0) then iflag = 0 if (Q .ne. 0) then p1 = Pbp + 1 C C CHANGE TH(I) ONLY IF SOME X(J)'S HAVE CHANGED. IF NOT IFLAG =1 C do i = p1,Pq if (.not.dpeq(y(i),x(i))) goto 5008 end do goto 5009 5008 if (Init .lt. 2) then call TRANSC(x,Pbp,Pq,Th,iqroot,aq) end if goto 5010 end if 5009 iflag = 1 5010 if (Bq .ne. 0) then p1 = Pq + 1 C C CHANGE BTH(I) ONLY IF SOME X(J)'S HAVE CHANGED C do i = p1,Bpq if (.not.dpeq(y(i),x(i))) goto 5011 end do goto 5012 5011 if (Init .lt. 2) then call TRANSC(x,Pq,Bpq,Bth,iroot,r) end if goto 5013 end if 5012 if (iflag .eq. 1) goto 5014 C IROOT AND V ARE NOT USED C C STEP 3B C CALCULATE THSTAR=TH * BTH C 5013 do i = 1,Qstar Thstar(i) = 0.0d0 end do if (Q .ne. 0) then do i = 1,Q Thstar(i) = Th(i) end do end if if (Bq .ne. 0) then do i = 1,Bq j = i * Mq Thstar(j) = Bth(i) if (Q .ne. 0) then do k = 1,Q Thstar(k+j) = -Th(k)*Bth(i) end do end if end do end if * 5014 write(Mtprof,*)' iproot, iqroot, Jfac = ', iproot, iqroot, Jfac 5014 if (iproot.ne.0 .and. iqroot.ne.0 .and. Jfac.ne.1) then * CALL outARMAParam() j = 2*nx + 3 if (Ifn .gt. j) then do i = 1,iproot do j = 1,iqroot diffpq=ABS(ap(i)-aq(j)) * write(Mtprof,*)' ap(',i,'), aq(',j,'), diffpq = ', * & ap(i), aq(j), diffpq if ((ABS(ap(i)-aq(j)).lt.0.10d0)) THEN * call profiler(2,'**GO TO 5015**, line 1201') goto 5015 END IF end do end do goto 5016 5015 Ifac = 1 if (Icomm .eq. 0) then if ((Ipr .ne. 2).and.(out.eq.0)) then 7000 format (/,' AR AND MA HAVE COMMON FACTORS') write (Nio,7000) RETURN 1 end if Icomm = 1 end if end if end if C RETURN 1 C C C STEP 4 C ESTIMATE CONSTRAINED RESIDUALS C SET UP FIRST Q* ROWS OF MATRICES C K=AM AND K'K=B.ZEROISE VECTOR V C 5016 do i = 1,Qstar a(i) = 0.0d0 do j = 1,Qstar b(i,j) = 0.0d0 end do b(i,i) = 1.0d0 v(i) = 0.0d0 end do do j = 1,Qstar do i = 1,n am(i,j) = 0.0d0 end do am(j,j) = 1.0d0 end do C C FOR CONSTRAINED LEAST SQUARES GO TO STEP 8 C if (Type .ne. 1) then C C STEP 5 C RECURRENCE FORMULAE FOR CONSTRAINED RESIDUALS C MATRICES K=AM AND K'K, AND VECTOR V C q1 = Qstar + 1 do l = q1,n sum1 = u(l-Qstar) do i = 1,nith j = ith(i) sum1 = sum1 + Thstar(j)*a(l-j) end do a(l) = sum1 end do C C FIRST Q COLUMNS OF BLOCKS OF MQ IN MATRIX K (FOR SEASONAL MODELS) C nq2 = Q + 2 nq1 = Bq + 1 if (Q .eq. 0) then nq1 = Bq end if do i1 = 1,nq1 k = (i1-1) * Mq if (Q .ne. 0) then do i2 = 1,Q i = k + i2 jcol(i) = 0 do l = q1,n sum2 = 0.0d0 do j = 1,nith j1 = ith(j) sum2 = sum2 + Thstar(j1)*am(l-j1,i) end do if (ABS(sum2) .le. small) then sum2 = 0.0d0 end if am(l,i) = sum2 end do end do if (i .eq. Qstar) goto 5018 end if C C (Q+1)TH COLUMN OF EACH BLOCK HAS NON-ZEROS EVERY MQ ROWS C i2 = Q + 1 i = k + i2 jcol(i) = 1 l = q1 do while (.true.) sum2 = 0.0d0 do j = 1,Bq j1 = j * Mq sum2 = sum2 + Thstar(j1)*am(l-j1,i) end do am(l,i) = sum2 l = l + Mq if (l .gt. n) goto 5017 end do C C REMAINING COLUMNS OF EACH BLOCK OBTAINED BY SHIFTING ELEMENTS OF C (Q+1)TH COLUMN C 5017 do 10 i2 = nq2,Mq i = k + i2 jcol(i) = i2 - Q l = q1 + i2 - nq2 + 1 do while (.true.) am(l,i) = am(l-1,i-1) l = l + Mq if (l .gt. n) goto 10 end do 10 continue end do C C FORM K'K AND VECTOR V C 5018 do 20 i = 1,Qstar do 15 j = 1,i if ((jcol(i)+jcol(j)) .gt. 0) then if ((jcol(i)*jcol(j)) .gt. 0) then if (jcol(i) .ne. jcol(j)) goto 15 l = Qstar + jcol(i) else l = Qstar + jcol(i) + jcol(j) end if sum3 = b(j,i) do while (.true.) sum3 = sum3 + am(l,i)*am(l,j) l = l + Mq if (l .gt. n) goto 5019 end do 5019 b(j,i) = sum3 else sum3 = b(j,i) do l = q1,n sum3 = sum3 + am(l,i)*am(l,j) end do b(j,i) = sum3 end if 15 continue if (jcol(i) .gt. 0) then l = Qstar + jcol(i) do while (.true.) v(i) = v(i) + am(l,i)*a(l) l = l + Mq if (l .gt. n) goto 20 end do else do l = q1,n v(i) = v(i) + am(l,i)*a(l) end do end if 20 continue C C STEP 6 C COMPUTE INVERSE OF B AND DETB (B IS SYMMETRIC AND SPARSE) C B**-1 = (K'K)**-1 C if (Qstar .gt. 1) then det = 1.0d0 e = 10.d0**(-Qstar-3) do i = 1,Qstar det = det * b(i,i) C IF DETB ZERO OR NEGATIVE STOP if (det .lt. e) then if(out.eq.0) then 7001 format (/,' DETB ZERO OR NEGATIVE') write (Nio,7001) end if Ierr = 1 Errext = 'CALCFX : Error DET(B) Zero or Negative' return end if g = 1 / b(i,i) b(i,i) = g do j = 1,Qstar if (j .lt. i) then if (ABS(b(j,i)) .ge. ceps) then h = g * b(j,i) do k = j,Qstar if (k .lt. i) then b(j,k) = b(j,k) + h*b(k,i) else if (k .ne. i) then b(j,k) = b(j,k) - h*b(i,k) end if end do b(j,i) = -h end if else if (j .ne. i) then if (ABS(b(i,j)) .ge. ceps) then h = g * b(i,j) do k = j,Qstar b(j,k) = b(j,k) - h*b(i,k) end do b(i,j) = h end if end if end do end do do j = 1,Qstar m = j - 1 do k = 1,m b(j,k) = b(k,j) end do end do else det = b(1,1) b(1,1) = 1 / b(1,1) end if C C DETBNP = (DET(K'K))**(1/2(N-P)) C detbnp = det**(0.5d0/np) C C STEP 7 C COMPUTE ML VALUES OF FIRST QSTAR A(I) C do i = 1,Qstar sum = 0.0d0 do j = 1,Qstar sum = sum - b(i,j)*v(j) end do a(i) = sum end do end if end if C C C C PART 2 C C C STEP 8 C F0RM A(I), I=QSTAR+1,NW+QSTAR-PSTAR C THE VALUES OF THE ERRORS WITHIN PERIOD UNDER INVESTIGATION C C C q1 = Qstar + 1 do i = q1,n sum = u(i-Qstar) if (Qstar .ne. 0) then do j = 1,nith j1 = ith(j) sum = sum + Thstar(j1)*a(i-j1) end do end if a(i) = sum end do C C STEP 9 C CALCULATE FUNCTION TO BE MINIMISED C f = 0.0d0 Detpri = detbnp do i = 1,n a(i) = Detpri * a(i) f = f + a(i)*a(i) end do C C STORE PRESENT VALUES OF TRANSFORMED PARAMETERS FOR TESTING IN C THE NEXT ROUND C do i = 1,nx y(i) = x(i) end do end C C FEASI SUBROUTINE C CHECKS THAT PARAMETERS IN SEARCH ARE NOT OUT OF C BOUNDS. C INPUT/OUTPUT: PASSED FROM/RETURNED TO SEARCH. C THE ARRAY DIMENSIONS MUST CORRESPOND WITH THOSE IN SEARCH. subroutine FEASI(nx,x,bx,e,xmin,xmax,red) C C.. Implicits .. implicit none C C.. Parameters .. * integer n10 * parameter (n10 = 10) C C.. Formal Arguments .. integer nx,e(*) real*8 x(*),bx(*),xmin(*),xmax(*),red C C.. Local Scalars .. integer j real*8 rj C C ... Executable Statements ... C red = 1.0d0 do 10 j = 1,nx if (e(j) .eq. 0) then if (x(j) .le. xmax(j)) then if (x(j) .ge. xmin(j)) goto 10 rj = (bx(j)-xmin(j)) / (bx(j)-x(j)) else rj = (xmax(j)-bx(j)) / (x(j)-bx(j)) end if if (rj .lt. red) then red = rj end if end if 10 continue end C THIS SUBROUTINE CALCULATES VARIANCES OF MODEL PARAMETERS C C X = FINAL VALUES OF TRANSFORMED PARAMETRS C A = COVARIANCE MATRIX FOR FINAL TRANSFORMED PARAMETERS C PQ = NO OF TRANSFORMED PARAMETERS WITHIN GROUP C (E.G. NO OF TRANSFORMED THETA PARAMETERS) C VFT = STANDARD ERROR OF TRANSFORMED PARAMETERS C IB = POSITION OF FIRST TRANSFORMED PARAMETER IN GROUP WITHIN X C IE = POSITION OF LAST TRANSFORMED PARAMETER IN GROUP WITHIN X C C PROGRAM RETURNS WITH C VFT = STANDARD ERRORS OF MODEL PARAMETERS C subroutine VARMP(x,a,pq,vft,ib,ie) C C.. Implicits .. implicit none C C.. Parameters .. integer n10 parameter (n10 = 10) C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. C LINES OF CODE COMMENTED FOR X-13A-S : 1 C real*8 x(3) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 real*8 x(*) C END OF CODE BLOCK C.. In/Out Status: Maybe Read, Not Written .. real*8 a(n10,n10) C.. In/Out Status: Read, Not Written .. integer pq C.. In/Out Status: Maybe Read, Maybe Written .. real*8 vft(n10) C.. In/Out Status: Read, Not Written .. integer ib C.. In/Out Status: Maybe Read, Not Written .. integer ie C C.. Local Scalars .. integer i,im real*8 a1,a2,fx1,fx2,fx3,gx1,gx2,gx3,v C C.. Intrinsic Functions .. intrinsic SQRT,ABS C C ... Executable Statements ... C C if (pq .gt. 1) then if (pq .gt. 2) then im = ib + 1 fx1 = (3.d0+x(im)) * (1.d0+x(ie)) * 0.5d0 gx1 = -fx1 a1 = (1.d0-x(ie)) * 0.5d0 a2 = x(ib) * (1.d0+x(ie)) * 0.5d0 fx2 = a1 + a2 C gx2 = a1 - a2 a1 = -(1.d0+x(im))*0.5d0 a2 = x(ib) * (3.d0+x(im)) * 0.5d0 fx3 = a1 + a2 gx3 = a1 - a2 v = a(ib,ib)*fx1*fx1 + a(im,im)*fx2*fx2 + a(ie,ie)*fx3*fx3 vft(1) = $ v + (a(im,ib)*fx1*fx2+a(ie,ib)*fx1*fx3+a(ie,im)*fx2*fx3)*2.d0 v = a(ib,ib)*gx1*gx1 + a(im,im)*gx2*gx2 + a(ie,ie)*gx3*gx3 vft(2) = $ v + (a(im,ib)*gx1*gx2+a(ie,ib)*gx1*gx3+a(ie,im)*gx2*gx3)*2.d0 vft(3) = a(ie,ie) else fx1 = 1.d0 - x(ie) fx2 = -x(ib) vft(1) = $ a(ib,ib)*fx1*fx1 + a(ie,ie)*fx2*fx2 + 2.d0*a(ie,ib)*fx1*fx2 vft(2) = a(ie,ie) end if else vft(1) = a(ib,ib) end if do i = 1,pq vft(i) = SQRT(abs(vft(i))) end do end C C C subroutine RATF(th,q,bphi,p,ps,l,ipr) C C THIS SUBROUTINE CALCULATES THE POWER SERIES EXPANSION OF A RATIONAL C LAG FUNCTION C C C.. Implicits .. implicit none C C.. Formal Arguments .. integer q,p,l,ipr real*8 th(*),bphi(*),ps(*) C C.. Local Scalars .. integer i,iq,j,k real*8 sum C C.. Intrinsic Functions .. intrinsic MIN C C ... Executable Statements ... C C ps(1) = 1.0d0 if (q .ne. 0) then do i = 1,q ps(i+1) = -th(i) end do end if iq = q + 2 if (iq .le. l) then do i = iq,l ps(i) = 0.0d0 end do end if if (p .eq. 0) return do i = 2,l sum = ps(i) k = MIN(i-1,p) do j = 1,k if (j .eq. i) goto 5000 sum = sum + bphi(j)*ps(i-j) end do 5000 ps(i) = sum end do end C C SUBROUTINE TRANSFORMS PARAMETER VALUES WITHIN GROUPS C C PHITH = ARRAY OF MODEL PARAMETERS E.G.THETA PARAMETERS C PQ = NO OF ELEMENTS IN FITH C X = ARRAY OF TRANSFORMED PARAMETERS C XMIN = MINIMUM BOUNDS FOR X C XMAX = MAXIMUM BOUNDS FOR X C IB = POSITION OF FIRST TRANSFORMED MODEL PARAMETER WITHIN X C IE = POSITION OF LAST TRANSFORMED MODEL PARAMETER WITHIN X C C subroutine TRANS1(phith,pq,x,xmin,xmax,ib,ie,out) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer pq,ib,ie,out real*8 phith(*),x(*),xmin(*),xmax(*) C C.. Local Scalars .. integer i real*8 x1,x2 C C.. Intrinsic Functions .. intrinsic ABS, SIGN include 'stream.i' C C ... Executable Statements ... C C if (pq .gt. 1) then if (pq .gt. 2) then if (ABS(phith(3)-1.0d0) .lt. 1.0d-9) then phith(3) = SIGN(0.9999999d0,phith(3)) end if x(ib) = 0.5d0 * ((phith(1)+phith(2))/(1.0d0-phith(3))+1.0d0) x(ib+1) = (1.0d0+(phith(1)-phith(2))/(1.0d0+phith(3))) if (ABS(x(ib)+1.0d0) .lt. 1.0d-9) then x(ib) = -.9999999d0 end if x(ib+1) = x(ib+1)/(1.0d0+x(ib)) - 1.0d0 x(ie) = phith(3) else if (ABS(1.0d0-phith(2)) .lt. 1.0d-9) then phith(2) = .9999999d0 end if x(ib) = phith(1) / (1.0d0-phith(2)) x(ie) = phith(2) end if else x(ib) = phith(1) end if do i = ib,ie x1 = 0.95*xmin(i) + 0.05*xmax(i) if (x(i) .lt. x1) then x(i) = x1 if (out.eq.0) then 7000 format (' PARAMETER SET AWAY FROM BOUNDARY,I=',i2) write (Nio,7000) i end if end if x2 = 0.05*xmin(i) + 0.95*xmax(i) if (x(i) .gt. x2) then x(i) = x2 end if end do end cc c cc C LINES OF CODE COMMENTED FOR X-13A-S : 1 C subroutine AUTO(n,z,m,r,iq,nw,nx,imean,nfreq,sk,out) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 subroutine AUTO(n,z,m,r,iq,nw,nx,nfreq,sk, $ Qstat,df,se,Ierr,Errext) C END OF CODE BLOCK C C THIS SUBROUTINE CALCULATES THE FIRST M AUTOCORRELATIONS OF THE C Z SERIES AND THEIR STANDARD ERRORS.THE LJUNG-BOX Q-VALUE C AND THE PIERCE QS VALUE ARE ALSO OUTPUT. C INPUT PARAMETERS: C N : NUMBER OF OBSERVATIONS OF THE SERIES C Z : SERIES C M : NUMBER OF AUTOCORRELATIONS C R : AUTOCORRELATIONS C IQ : NUMBER OF AUTOCORRELATIONS ON WHICH LJUNG-BOX AND PIERCE C NW : NUMBER OF OBSERVATIONS OF DIFFERENCED SERIES TO COMPUTE C STATISTICS C NX : DIMENSION OF THE MODEL C SK : 1 MEAN CORRECTION OF THE SERIES, 0 NO MEAN CORRECTION C C THE INPUT IS MEAN CORRECTED AND THEN RESTORED AS IT WAS c c OUTPUT r(1:M) Autocorrelations c se(1:M) SE of Autocorrelations c Qstat c DF: the Qstat is distributed as CHI-Squared of DF (degrees of freedom) c OUTPUT IN COMMON: c BJstat1=QSTAT c BJSTAT2=DF c PSTAT1=QS c PSTAT2: degrees of freedom of CHI-SQUARED that behaves like QS. C C C.. Implicits .. implicit none C C.. Parameters .. integer n10 parameter (n10 = 10) C C.. Formal Arguments .. integer n,m,iq,nw,nx,nfreq,sk real*8 z(*),r(*),se(*) C C.. Local Scalars .. integer df,i,is,j,k,me,ms,mp,mr real*8 c0,qs,qstat,rn,sr,zmean C C.. Local Arrays .. real*8 c(5*n10) C C.. Intrinsic Functions .. intrinsic MOD, SQRT include 'eee.i' include 'dets.i' include 'calfor.i' include 'stream.i' C LINES OF CODE ADDED FOR X-13A-S : 4 CHARACTER Errext*(180) INTEGER Ierr LOGICAL dpeq EXTERNAL dpeq C END OF CODE BLOCK C C ... Executable Statements ... C C C MEAN CORRECTION C mp=m/12 if (MOD(m,12).eq.0) then mp=mp*12 else mp=(mp+1)*12 end if do i=m+1,mp r(i)=0.0d0 se(i)=0.0d0 enddo if (sk .ne. 0) then zmean = 0.0d0 do i = 1,n zmean = zmean + z(i) end do zmean = zmean / n do i = 1,n z(i) = z(i) - zmean end do end if C C CALCULATE AC'S C c0 = 0.0d0 do i = 1,n c0 = c0 + z(i)**2 end do C LINES OF CODE ADDED FOR X-13A-S : 6 IF (dpeq(c0,0D0)) THEN Errext='AUTO: Cannot generate autocorrelations from a series of z &eros.' Ierr=1 RETURN END IF C END OF CODE BLOCK c0 = c0 / n do k = 1,m c(k) = 0.0d0 is = k + 1 do i = is,n c(k) = c(k) + z(i)*z(i-k) end do c(k) = c(k) / n r(k) = c(k) / c0 end do rn = n se(1) = 1.0d0 / SQRT(rn) sr = 0.0d0 me = m - 1 do i = 1,me sr = sr + r(i)*r(i) se(i+1) = SQRT((1.0d0+2.0d0*sr)/n) end do if ((SeasCheck .gt. 0) .and. (nround .eq. 1)) then Acf1 = r(mq) Seacf1 = se (mq) end if C C IF IQ=0 THE TESTS ARE NOT COMPUTED C qstat=-1 if (iq .ne. 0) then C C CALCULATE Q AND QS VALUES FOR TESTING FIT OF MODEL C qstat = 0.0d0 do j = 1,iq qstat = qstat + r(j)**2/(nw-j) end do if (SeasCheck .gt. 0) then if (nround .eq. 0) then Jb0 = qstat else Jb1 = qstat end if end if qstat = qstat * nw * (nw+2) cc c Changed 22-10-2002 removed the mean cc c df = iq - nx - imean df = iq - nx Bjstat1 = qstat Bjstat2 = df C MS = IQ / NFREQ C LINES OF CODE COMMENTED FOR X-13A-S : 1 C if (2*nfreq.lt.m .and. nfreq.ne.1) then C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 if (2*nfreq.lt.m .and. 2*nfreq.lt.nw .and. nfreq.ne.1) then C END OF CODE BLOCK ms = 2 qs = 0.0d0 do j = 1,ms k = j * nfreq qs = qs + r(k)**2/(nw-k) end do qs = qs * nw * (nw+2) Pstat1 = qs Pstat2 = ms c if ((out.eq.3) .or. (out.eq.1)) then c 7003 format ( c $ ' THE PIERCE QS VALUE IS ',f12.2,' AND IF RESIDUALS ARE', c $ ' RANDOM IT SHOULD BE DISTRIBUTED AS CHI-SQUARE (',i2,')') c write (Nio,7003) qs, ms c end if end if end if c Call OutAuto(OUT,HTML,Nio,Icode,Qstat,df,r,se,M) C C THE ORIGINAL INPUT IS RESTORED C if (sk .ne. 0) then do i = 1,n z(i) = z(i) + zmean end do end if end C subroutine PartAuto(n,m,r,fi,sep,i) c n:numero de observaciones usado para calcular las autocorrelaciones(r) c m:numero de autocorrelaciones calculadas. c r(1:m): las autocorrelaciones de 1 a m c fi(1:m): las autocorrelaciones paraciales c Sep:error estandar de las autocorrelaciones C i= m si todo fue bien; C 0 1 NO PRINT OUT, 1 PRINTOUT C withSE: 1:print the associated SE; 0:do not print the SE C subroutine PART(n,m,r,out,fi,sep) C C.. Implicits .. implicit none C C.. Parameters .. integer n10 parameter (n10 = 10) C C.. Formal Arguments .. C.. In/Out Status: INPUT. integer n integer m real*8 r(*) integer out C.. In/Out Status: Output real*8 fi(5*n10) real*8 sep cc integer ISTRLEN external ISTRLEN C C.. Local Scalars .. integer i,ie,j,k,mp,mr C C.. Intrinsic Functions .. intrinsic MOD include 'stream.i' * include 'indhtml.i' C C ... Executable Statements ... C C CALCULATION OF PARTIAL CORRELATION C C SOLVES YULE-WALKER EQUATIONS C NOTE DIVISOR IN CALCULATION OF R(K) IS N C call PartAuto(n,m,r,fi,sep,i) if (i.lt.0) then if (out.eq.0) then write(nio,'("!!!!Error en PartAuto aumentar maxAutoCorr")') end if return end if if (i.lt.m .and. i.gt.0)then do j = i,m fi(j) = 1000.0d0 end do sep = 1000.0d0 end if return end C C THIS SUBROUTINE COMPUTES THE FORECAST OF THE SERIES C INPUT PARAMETERS: C PHIST : NON-SEASONAL AR PART OF THE MODEL B-J SIGN C THSTAR : THE FULL MA PART OF THE MODEL B-J SIGN C BPHIST : FULL AR PART OF THE MODEL (OUTPUT) TRUE SIGN C BPSTAR : THE DIMENSION OF BPHIST C Z : SERIES C NZ : DIMENSION OF Z C WM : MEAN OF DIFFERENCED SERIES C A : RESIDUALS C NA : DIMENSION OF A C L : NUMBER OF FORECAST C LSIG : -1 COMPUTE FORECAST BPHIST TO BE COMPUTED, C -2 COMPUTE BACKCAST BPHIST ALREADY COMPUTED C F : VARIANCE OF RESIDUALS C LAM : 0 LOGS, 1 NO LOGS OF DATA C D : DELTA OF THE MODEL C BD : DELTA*MQ OF THE MODEL C IMEAN : 0 NOMEAN, 1 MEAN C ZA : AMOUNT OF MEAN ADDED A FUNCTION OF THE MODEL (OUTPUT) C LF : MINIMUM NUMBER OF FORECAST C OUT : <> 1 NO PRINT OUT, 1 PRINTOUT C subroutine FCAST(phist,thstar,bphist,bpstar,z,nz,wm,a,na,lsig,f, $ lam,d,bd,imean,za,lf,out,bias,forbias, $ noadmiss,alpha) C C THIS SUBROUTINE CALCULATES L FORECASTS FOR THE Z SERIES. C C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n12,n10 parameter (n10 = 15, n12 = 12) C C.. Formal Arguments .. integer bpstar,nz,na,l,lsig,lam,d,bd,imean,lf,out,bias,noadmiss real*8 phist(*),thstar(*),bphist(*),z(*),wm,a(*),f,za,alpha, $ forbias(5*n12) C C.. Local Scalars .. integer i,j,k,kk,lp,maxpq real*8 cl,sz,vz,zaa,zexp,zlexp,zuexp C C.. Local Arrays .. real*8 zl(3*n10),zu(3*n10) C C.. External Calls .. external RATF C C.. Intrinsic Functions .. intrinsic EXP, MAX, SQRT include 'calfor.i' include 'cse.i' include 'sesfcast.i' include 'stream.i' C C ... Executable Statements ... C C COMMON /CBLOCK/ TEMP9,ZL,ZU,TEMP10 C Ffc = f C if (lsig .ne. -2) then C C C CALCULATE BPHIST COEFFICIENTS WHERE C BPHIST=PHIST*(1-B)**D*(1-B**MQ)**BD C bphist(1) = 1.0d0 if (Pstar .ne. 0) then do i = 1,Pstar bphist(i+1) = -phist(i) end do end if bpstar = Pstar + 1 if (d .ne. 0) then do i = 1,d bphist(bpstar+1) = 0.0d0 do j = 1,bpstar k = bpstar - j + 2 bphist(k) = bphist(k) - bphist(k-1) end do bpstar = bpstar + 1 end do end if if (bd .ne. 0) then do i = 1,bd do j = 1,Mq bphist(bpstar+j) = 0.0d0 end do do j = 1,bpstar k = bpstar - j + Mq + 1 bphist(k) = bphist(k) - bphist(k-Mq) end do bpstar = bpstar + Mq end do end if bpstar = bpstar - 1 do i = 1,bpstar bphist(i) = -bphist(i+1) end do end if if (lsig .lt. 0) then C C FORECAST PARAMETERS FOR SIGEX C*********************************************** maxpq = MAX(bpstar,Qstar) l = MAX(maxpq+Qstar,Mq+Mq) if ((lsig.lt.0) .and. (l.gt.lf)) then lf = MAX(lf,MAX(8,2*Mq)) end if if ((lsig.lt.0) .and. (l.lt.lf)) then l = lf end if if (lsig .eq. -2) goto 5000 end if C*********************************************** C za = 0.0d0 if (imean .ne. 0) then if (Pstar .ne. 0) then zaa = 1.0d0 do j = 1,Pstar zaa = zaa - phist(j) end do za = zaa * wm else C C FIND SUM OF PHIST COEFFICIENTS AND MULTIPLY BY MEAN IF SERIES C WAS MEAN CORRECTED C za = wm end if end if C C FORECAST SERIES C 5000 do i = 1,l k = na + i kk = nz + i a(k) = 0.0d0 sz = za if (Qstar .ne. 0) then do j = 1,Qstar sz = sz - thstar(j)*a(k-j) end do end if if (bpstar .ne. 0) then do j = 1,bpstar sz = sz + bphist(j)*z(kk-j) end do end if z(kk) = sz end do C C COMPUTE THE FORECAST FOR THE BIAS CORRECTION AND ANNUAL AVERAGE C EVERY TIME COMPUTE 59 FORECASTS (THE MAXIMUM NEEDED) C if ((lam.eq.0) .and. (bias.ne.-300)) then do i = 1,59 k = na + i kk = nz + i sz = za if (Qstar .ne. 0) then do j = 1,Qstar if ((k-j) .le. na) then sz = sz - thstar(j)*a(k-j) end if end do end if if (bpstar .ne. 0) then do j = 1,bpstar if ((kk-j) .le. nz) then sz = sz + bphist(j)*z(kk-j) else sz = sz + bphist(j)*forbias(i-j) end if end do end if forbias(i) = sz end do end if C IF (ISFIX.EQ.0) GO TO 61 C ****** TILL 74 DOES NOT DO MUCH ********************* C IT'S THE PART WERE THE SEAS. MEAN WAS READ T Z(I) C****************************************************** C COMMENTED BY GIANLUCA C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C K=NZ/MQ C NZOD=NZ-K*MQ C NZ1=NZ+1 C NZL=NZ+L C J=NZOD C DO 74 I=NZ1,NZL C J=J+1 C Z(I)=Z(I) C IF (J.GE.MQ) J=0 C 74 CONTINUE C C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C CALCULATE COEFFICIENTS FOR ESTIMATING BOUNDS ON FORECASTS C if ((noadmiss.eq.1) .and. (lsig.eq.-1)) then lp = MAX(lf,MAX(8,2*Mq)) lp = MIN(lp,5*N12-N12/3) call RATF(thstar,Qstar,bphist,bpstar,Ps,lp,1) vz = 0.0d0 do i = 1,lp vz = vz + Ps(i)*Ps(i) Sesfcast(i) = SQRT(vz*f) end do end if if (lsig .eq. -2) return lp = MAX(l,Qstar+1) lp = MIN(lp,5*N12-N12/3) call RATF(thstar,Qstar,bphist,bpstar,Ps,lp,1) if (lsig .lt. 0) return if (lam .eq. 0) then if (out .eq. 0) then 7000 format (//37x,' FORECAST OF TRANSFORMED SERIES') write (Nio,7000) end if else if (out .eq. 0) then 7001 format ('1',37x,'FORECAST OF ACTUAL SERIES') write (Nio,7001) end if if (l .gt. 3*n10) then write (Nio,'(2x, $''MAXIMUM ALLOWED VALUE FOR L IS '',i2,/,2x,''L CHANGED TO '' $ ,i2,/)') 3*n10, 3*n10 l = 3 * n10 end if if (out .ne. 2) then 7002 format (//' ',16x,'LOWER LIMIT',19x,'FORECAST',16x, $ 'UPPER LIMIT') write (Nio,7002) end if vz = 0.0d0 do i = 1,l vz = vz + Ps(i)*Ps(i) cl = vz * f C WRITE(*,*)DSQRT(VZ*F) cl = alpha * SQRT(cl) C C ZL AND ZU ARE THE LOWER AND UPPER BOUNDS ON Z(I) C kk = nz + i zl(i) = z(kk) - cl zu(i) = z(kk) + cl if (out .eq. 0) then 7003 format (/,' ',3f27.6) write (Nio,7003) zl(i), z(kk), zu(i) end if end do C C CALCULATE EXPONENTIAL OF SERIES IF LOG TRANSFORMED C if (lam .eq. 1) return if (out .ne. 2) then write (Nio,7001) end if if (out .eq. 0) then write (Nio,7002) end if do j = 1,l kk = nz + j zexp = EXP(z(kk)) zlexp = EXP(zl(j)) zuexp = EXP(zu(j)) if (out .eq. 0) then 7004 format (/,' ',3f27.6) write (Nio,7004) zlexp, zexp, zuexp end if end do end C C TO TRANSFORM SEARCH PARAMETERS INTO MODEL PARAMETERS C INPUT PARAMETERS C X : PARAMETERS OF THE MODEL C M : M VALUE VALUE IN X TO TRANSFORM C N : LAST VALUE IN X TO TRANSFORM C C : TRANSFORMED PARAMETERS C IROOT : NUMBER OF ROOTS OF THE TRANSFORMED PARAMETERS C ALPH : ROOTS OF TRANSFORMED PARAMETERS C C C subroutine TRANSC(x,m,n,c,iroot,alph) C C.. Implicits .. implicit none C C.. Parameters .. integer n1 parameter (n1 = 1) C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 x(*) C.. In/Out Status: Read, Not Written .. integer m C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Maybe Read, Maybe Written .. real*8 c(3*n1) C.. In/Out Status: Not Read, Overwritten .. integer iroot C.. In/Out Status: Maybe Read, Maybe Written .. real*8 alph(3*n1) C C.. Local Scalars .. integer i,icount,j real*8 d,delta,disc,e,s,y C C.. Intrinsic Functions .. intrinsic ABS, SQRT include 'stream.i' include 'units.cmn' C C ... Executable Statements ... C if (n.le.0) return j = n - m iroot = j if (j .lt. 2) then c(1) = x(n) alph(1) = c(1) * write(Mtprof,*)' first alph(1) = ', alph(1) else if (j .eq. 2) then c(1) = x(m+1) * (1.0d0-x(n)) c(2) = x(n) disc = c(1)**2 + 4.0d0*c(2) if (disc .ge. 0.0d0) then disc = SQRT(disc) alph(1) = 0.5d0 * (c(1)+disc) alph(2) = 0.5d0 * (c(1)-disc) * write(Mtprof,*)' alph(1), alph(2) = ', alph(1), alph(2) else iroot = 0 end if else s = (2.0d0*x(m+1)-1.0d0) * (1.0d0-x(n)) d = (1.0d0+x(n)) * ((1.0d0+x(m+1))*(1.0d0+x(m+2))-1.0d0) c(1) = 0.5d0 * (s+d) c(2) = 0.5d0 * (s-d) c(3) = x(n) * write(Mtprof,*)' s, d, c = ', s, d, c(1), c(2), c(3) C C TO FIND REAL ROOTS OF X**3-C(1)*X**2-C(2)*X-C(3)=0. C PUT X=Y+C(1)/3. EQUATION BECOMES Y**3-D*Y-E=0 C FIND ROOT BY NEWTON-RAPHSON C d = c(1)*c(1)/3.0d0 + c(2) e = (2.0d0*c(1)**3+9.0d0*c(1)*c(2))/27.0d0 + c(3) disc = 4.0d0*d**3 - 27.0d0*e**2 * write(Mtprof,*)' d, e, disc = ', d, e, disc if (disc .gt. 0.0d0) then y = -e/d * write(Mtprof,*)' y = ', y, '(1)' else if (e .gt. 0.0d0) then y = 1 - c(1)/3 * write(Mtprof,*)' y = ', y, '(2)' else y = -1 - c(1)/3 * write(Mtprof,*)' y = ', y, '(3)' end if icount = 0 do while (.true.) delta = (y**3-d*y-e) / (3.0d0*y*y-d) y = y - delta * write(Mtprof,*)' icount, delta, y = ', icount, ABS(delta), y if (ABS(delta) .le. 0.00005d0) goto 5000 icount = icount + 1 if (icount .gt. 10) then 7000 format (/,' CUBIC ITERATIONS EXCEEDED') write (Nio,7000) goto 5000 end if end do 5000 alph(1) = y * write(Mtprof,*)' alph(1) = ', alph(1) C C TEST IF ALL ROOTS ARE REAL C if (disc .ge. 0.0d0) then C C ROOTS REAL.DIVIDE BY (Y-ALPH(1)) C Y**2+ALPH(1)*Y+E/ALPH(1)=0 C disc = SQRT(alph(1)**2-4.0d0*e/alph(1)) alph(2) = 0.5d0 * (-alph(1)+disc) alph(3) = 0.5d0 * (-alph(1)-disc) * write(Mtprof,*)' disc, alph(2), alph(3) = ', * & disc, alph(2), alph(3) else iroot = 1 end if do i = 1,iroot alph(i) = alph(i) + c(1)/3.0d0 * write(Mtprof,*)' alph(',i,') = ', alph(i) end do end if end C C THIS SUBROUTINE COMPUTES THE STARTING VALUES OF MODEL PARAMETER C C INPUT PARAMETERS C P : DIMENSION OF NON-SEASONAL AR PART C Q : DIMENSION OF NON-SEASONAL MA PART C BP : DIMENSION OF SEASONAL AR PART C BQ : DIMENSION OF SEASONAL MA PART C PHI : NON-SEASONAL AR MODEL C TH : NON-SEASONAL MA MODEL C BPHI : SEASONAL AR MODEL C BTH : SEASONAL MA MODEL C R : AUTOCORRELATIONS OF DIFFERENCED SERIES C MQ : FREQUENCY C MQ2 : 2*MQ C subroutine STAVAL(p,q,bp,bq,phi,th,bphi,bth,r,mq,mq2) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer p,q,bp,bq,mq,mq2 real*8 phi(*),th(*),bphi(*),bth(*),r(*) C C.. Local Scalars .. real*8 a,b,b1,b2,b3,c,r0,rmq,rp1,rp2,x integer i C C.. Intrinsic Functions .. intrinsic ABS, SIGN, SQRT real*8 Dividecheck external Dividecheck C C ... Executable Statements ... C C C PROVIDES START VALUES FOR MODEL PARAMETERS C if (p .ne. 0) then if (q .eq. 0) then b1 = r(q+1) else b1 = r(q+1) / r(q) end if if ((mq.eq.12) .or. (mq.eq.0)) then b2 = r(q+2) / Dividecheck(r(q+1)) b3 = r(q+3) / Dividecheck(r(q+2)) else b2 = r(mq+q+2) / Dividecheck(r(mq+q+1)) b3 = r(mq2+q+2) / Dividecheck(r(mq2+q+1)) end if if ((b1*b2.le.0) .or. (b2*b3.le.0)) then phi(1) = 0.2 else phi(1) = (b1+b2+b3) / 3 if (phi(1) .ge. 1.0d0) then phi(1) = 0.9d0 end if end if if (p .ge. 2) then phi(2) = 0.50d0 * phi(1) if (p .eq. 3) then phi(3) = 0.5d0 * phi(2) else do i=3,p phi(i)=phi(i-1)*0.5d0 end do end if end if c = 1 + phi(1)**2 r0 = c - (2*phi(1)*r(1)) rp1 = c*r(1) - phi(1)*(1+r(2)) rp2 = c*r(2) - phi(1)*(r(1)+r(3)) r(1) = rp1 / Dividecheck(r0) r(2) = rp2 / Dividecheck(r0) if (bq .ne. 0) then rmq = c*r(mq) - phi(1)*(r(mq-1)+r(mq+1)) r(mq) = rmq / Dividecheck(r0) end if end if if (q .ne. 0) then if (q .ne. 1) then if (ABS(r(2)) .ge. 0.5d0) then r(2) = SIGN(0.45d0,r(2)) end if b = 1 + 2*r(2) if (r(2) .gt. 0.16666d0) then a = r(2) * (1-2*r(2)) if (r(1)**2 .ge. 4*a) then r(1) = SIGN(1.8d0*SQRT(a),r(1)) end if else if (ABS(r(1)) .ge. 0.5d0*b) then r(1) = SIGN(b*0.45d0,r(1)) end if x = (r(2)+r(2)-1-SQRT(b**2-4*r(1)**2)) / Dividecheck(2*r(2)) th(2) = 0.5d0 * x * (1-SQRT(1-4/Dividecheck(x**2))) th(1) = r(1) * th(2) / Dividecheck(r(2)*(1-th(2))) if (q .eq. 3) then th(3) = 0.0d0 end if else if (ABS(r(1)) .lt. 0.5d0) then th(1) = (SQRT(1-4*r(1)**2)-1) / Dividecheck(2*r(1)) else th(1) = -SIGN(0.9d0,r(1)) end if end if if (bq .ne. 0) then if (ABS(r(mq)) .lt. 0.5d0) then bth(1) = (SQRT(1-4*r(mq)**2)-1) / Dividecheck(2*r(mq)) C START VALUE IS WEIGHTED AVERAGE OF ESTIMATE AND 0.83 bth(1) = 0.50d0 + 0.40d0*bth(1) else bth(1) = -SIGN(0.9d0,r(mq)) end if if (bq .eq. 2) then bth(2) = 0.0d0 end if end if if (bp .ne. 0) then bphi(1) = r(mq2) / Dividecheck(r(mq)) if (bphi(1) .ge. 0.8d0) then bphi(1) = 0.8d0 end if if (bphi(1) .le. 0.0d0) then bphi(1) = 0.0d0 end if if (bp .ne. 1) then bphi(2) = 0.25d0 end if end if end C C FUNCTION TO COMPUTE THE VARIANCE C double precision function DVAR(n,x) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Maybe Read, Not Written .. real*8 x(*) C C.. Local Scalars .. integer i real*8 dmean2,ym2 C C.. External Functions .. real*8 DMEAN external DMEAN C C ... Executable Statements ... C dmean2 = (DMEAN(n,x)**2) ym2 = 0.d0 do i = 1,n ym2 = ym2 + x(i)**2 end do ym2 = ym2 / n DVAR = ym2 - dmean2 IF (DVAR.lt.0D0) DVAR = 0D0 end C C COMPUTE THE VARIANCE OF X SERIES C double precision function DVARMS(n,x) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Maybe Read, Not Written .. real*8 x(mpkp) C C.. Local Scalars .. integer i real*8 dmean2,ym2 C C.. External Functions .. real*8 DMEAN external DMEAN C C ... Executable Statements ... C dmean2 = DMEAN(n,x) ym2 = 0.0d0 do i = 1,n ym2 = ym2 + (x(i)-dmean2)**2 end do ym2 = ym2 / n DVARMS = ym2 end C C THIS SUBROUTINE COMPUTES TEST OF RUNS ON AUTOCORRELATIONS / RESIDUALS C C INPUT PARAMETERS C X : RESIDUALS OR AUTOCORRELATIONS C N : DIMENSION OF X C XMED : MEAN OF X C ITEST : <> 0 APPROXIMATE TEST IS COMPUTED C subroutine RACES(x,n,xmed,itest,tval,n1,n0) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 x(*) C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Read, Not Written .. real*8 xmed C.. In/Out Status: Read, Not Written .. integer itest C.. In/Out Status: Not Read, Maybe Written .. real*8 tval c OUTPUT PARAMETERS integer n0,n1 C C.. Local Scalars .. integer i,l,ll,nr real*8 runm,runstd,xn0,xn1 C C.. Intrinsic Functions .. intrinsic DBLE, SQRT include 'stream.i' C C ... Executable Statements ... C nr = 1 l = 0 if (x(1) .ge. xmed) then l = 1 end if n1 = l n0 = 1 - l do i = 2,n ll = 0 if (x(i) .ge. xmed) then ll = 1 end if n1 = n1 + ll n0 = n0 + 1 - ll if (ll .ne. l) then l = ll nr = nr + 1 end if end do if (itest .ne. 0) then xn0 = DBLE(n0) xn1 = DBLE(n1) runm = 1 + 2*xn1*xn0/(xn1+xn0) runstd = 2 * xn1 * xn0 * (2*xn1*xn0-xn1-xn0) runstd = runstd / (((xn1+xn0)**2)*(xn1+xn0-1)) runstd = SQRT(runstd) tval = (nr-runm) / runstd end if end C C THIS FUNCTION COMPUTES THE MEDIAN OF X SERIES C double precision function DMED(x,n) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 x(*) C.. In/Out Status: Read, Not Written .. integer n C C.. Local Scalars .. integer i,ipippo,j real*8 dmed1,sum,sumabs C C.. Intrinsic Functions .. intrinsic ABS C C ... Executable Statements ... C C ipippo = 0 dmed1 = 0.d0 sumabs = 1.0d12 do while (.true.) do i = 1,n sum = 0.0d0 do j = 1,n sum = sum + ABS(x(j)-x(i)) end do if (sum.le.sumabs .and. ABS(x(i)-dmed1).ge.1.0d-12) then sumabs = sum DMED = x(i) end if end do if (ipippo .ne. 0) goto 5000 if (2*(n/2) .ne. n) return ipippo = 1 dmed1 = DMED end do 5000 DMED = DMED/2 + dmed1/2 end C C THIS FUNCTION COMPUTES THE S.E. OF THE MEAN C C INPUT PARAMETER C VM : VARIANCE OF DIFFERENCED SERIES C WM : MEAN " " " " C NW : NUMBER OBSERVATIONS OF DIFFERENCED SERIES C PHI : NON-SEASONAL AR PART OF THE MODEL B-J SIGN C P : DIMENSION OF PHI C BPHI : SEASONAL AR PART OF THE MODEL B-J SIGN C BP : DIMENSION OF BPHI C TH : NON-SEASONAL MA PART OF THE MODEL B-J SIGN C Q : DIMENSION OF TH C BTH : SEASONAL MA PART OF THE MODEL B-J SIGN C BQ : DIMENSION OF BTH C MQ : FREQUENCY C SE : STANDARD ERROR OF THE MEAN C subroutine CHECK(vm,wm,nw,phi,p,bphi,bp,th,q,bth,bq,mq,se) C C.. Implicits .. implicit none include 'units.cmn' C C.. Parameters .. integer n12,n10,n1 * parameter (n1 = 10, n10 = 10, n12 = 12) parameter (n1 = 1, n10 = 10, n12 = 12) C C.. Formal Arguments .. integer nw,p,bp,q,bq,mq double precision vm,wm,phi(3*n1),bphi(3*n1),th(3*n1),bth(3*n1),se C C.. Local Scalars .. integer i,lll,lll1,m,mm,nbphi,nbth,nphi,nth double precision vc,vz,xx C C.. Local Arrays .. double precision bphi1(5*n10),bth1(5*n10),g(0:5*n10),gam(0:3*n12), $ phi1(4*n1),rho(0:3*n12),th1(4*n1) C C.. External Calls .. external BFAC, CONV C C.. Intrinsic Functions .. intrinsic SQRT C C ... Executable Statements ... C * call profiler(2,'subroutine CHECK') m = 24 phi1(1) = 1.0d0 do i = 1,p phi1(i+1) = -phi(i) * write(Mtprof,*) 'phi1(',i+1,') = ', phi1(i+1) end do bphi1(1) = 1.0d0 if (bp .gt. 0) then do i = 1,bp*mq bphi1(i+1) = 0.0d0 end do do i = 1,bp bphi1(i*mq+1) = -bphi(i) * write(Mtprof,*) 'bphi1(',i*mq+1,') = ', bphi1(i*mq+1) end do end if nphi = p + 1 nbphi = 1 + bp*mq * call profiler(2,'subroutine CONV') call CONV(phi1,nphi,bphi1,nbphi,bphi1,lll) if (lll .gt. 1) then do i = 2,lll bphi1(i-1) = -bphi1(i) * write(Mtprof,*) 'bphi1(',i-1,') = ', bphi1(i-1) end do end if lll = lll - 1 th1(1) = 1.0d0 do i = 1,q th1(i+1) = -th(i) * write(Mtprof,*) 'th1(',i+1,') = ', th1(i+1) end do bth1(1) = 1.0d0 if (bq .gt. 0) then do i = 1,bq*mq bth1(i+1) = 0.0d0 end do do i = 1,q bth1(i*mq+1) = -bth(i) * write(Mtprof,*) 'bth1(',i*mq+1,') = ', bth1(i*mq+1) end do end if nth = q + 1 nbth = 1 + bq*mq * call profiler(2,'subroutine CONV') call CONV(th1,nth,bth1,nbth,bth1,lll1) do i = 2,lll1 bth1(i-1) = -bth1(i) * write(Mtprof,*) 'bth1(',i-1,') = ', bth1(i-1) end do lll1 = lll1 - 1 mm = m vz = 1.0d0 * WRITE(Ng,*)' subroutine check, call 1' call BFAC(bphi1,bth1,lll,lll1,m,gam,rho,vc,vz,g,m) xx = 0.0d0 do i = 1,mm xx = xx + (1-(i*1.0d0)/(nw*1.0d0))*rho(i) * write(Mtprof,*) 'rho(i), xx = ', rho(i), xx end do xx = 1 + 2*xx * write(Mtprof,*) 'xx = ', xx xx = (vm/nw) * xx * write(Mtprof,*) 'vm, nw, xx = ', vm, nw, xx if (xx .gt. 0.0d0) then se = SQRT(xx) end if end C C C THIS FUNCTION COMPUTES THE MINIMUM BTHETA SUCH THAT GIVEN THETA C THE MODEL HAS A VALID DECOMPOSITION FOR MONTHLY AIRLINE MODEL, C QUARTERLY AIRLINE MODEL, AND MONTHLY AND QUARTERLY AIRLINE MODEL C WITH D^2 C C INPUT PARAMETER C THETA : THE VALUE OF THETA B-J SIGN C MQ : FREQUENCY C D : DELTA OF THE MODEL C real*8 function POLYVAL(theta,mq,d) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 theta C.. In/Out Status: Read, Not Written .. integer mq C.. In/Out Status: Read, Not Written .. integer d C C.. Local Scalars .. integer i,nairm,nairq,nd2m,nd2q C C.. Local Arrays .. real*8 airm(37),airq(36),d2m(28),d2q(25) C C.. Intrinsic Functions .. intrinsic ABS, ANINT, SIGN C C.. Data Declarations .. data airq/ $ -1.50568861051561d+07,-4.07864271885349d+06, $ 1.25495713468045d+08,3.72893488076512d+07, $ -4.79316449488926d+08,-1.55227766622531d+08, $ 1.11199260604581d+09,3.89926250516196d+08, $ -1.75105862443012d+09,-6.60203090340804d+08, $ 1.98087443551278d+09,7.96938928504665d+08, $ -1.66146607023159d+09,-7.07321965792925d+08, $ 1.05100610295520d+09,4.69148293267340d+08, $ -5.04888372223982d+08,-2.33997977625452d+08, $ 1.83900005449306d+08,8.76043491537447d+07, $ -5.02818844050958d+07,-2.43866695225120d+07, $ 1.01154607380367d+07,4.95920421687316d+06, $ -1.44719924386675d+06,-7.16551068193267d+05, $ 1.38950643779603d+05,7.05870266796903d+04, $ -7.97845888823479d+03,-4.45727946957010d+03, $ 1.83672933301260d+02,1.61704844615717d+02, $ 6.28102914263037d+00,-1.85013363024192d+00, $ -4.67101412373999d-01,-3.14388900223822d-01/ data airm/ $ 1.95347563065735d+07,1.40869407022632d+07, $ -1.82924843962725d+08,-1.24837916382162d+08, $ 7.84012309810082d+08,5.06656270824311d+08, $ -2.03824923561787d+09,-1.24723236243656d+09, $ 3.59083883274152d+09,2.07891569193133d+09, $ -4.53585473370324d+09,-2.48015536619207d+09, $ 4.23918446756410d+09,2.18248985662395d+09, $ -2.98178573585705d+09,-1.43853103116210d+09, $ 1.59018446079529d+09,7.13771251305322d+08, $ -6.42824470238530d+08,-2.65666810599684d+08, $ 1.95564418343889d+08,7.33014344799244d+07, $ -4.41316525032554d+07,-1.46797381353294d+07, $ 7.21747845147075d+06,2.06510268195992d+06, $ -8.25912908016856d+05,-1.94312700336529d+05, $ 6.26921279186573d+04,1.13487961429655d+04, $ -2.90128263818433d+03,-3.64564339836437d+02, $ 7.07021116258866d+01,5.00986705245536d+00, $ -8.06732206713255d-01,-1.29571848439844d-01, $ -1.50316939442371d-01/ data d2q/ $ -7.36886387334525d+03,5.71043080817024d+03, $ 4.89655041459870d+04,-2.72040336684033d+04, $ -1.40067644904055d+05,5.38068353807028d+04, $ 2.26611284963096d+05,-5.62886010543245d+04, $ -2.28695251634143d+05,3.21568573231266d+04, $ 1.49568754383030d+05,-8.38954361805799d+03, $ -6.37582467027026d+04,-4.93256763478040d+02, $ 1.73902925238205d+04,9.03967061027686d+02, $ -2.91111942281865d+03,-2.25701468391660d+02, $ 2.77900060158067d+02,2.36818663168160d+01, $ -1.32508103079524d+01,-9.99194312958687d-01, $ 2.39589706532146d-01,1.13994409953707d-02, $ -6.95571335187068d-04/ data d2m/ $ -6.16086458289453d+05,-1.93205965815733d+06, $ 1.88840463291657d+06,9.78701910995365d+06, $ -1.11444188423980d+06,-2.21556751224427d+07, $ -3.17747695176425d+06,2.95610373631368d+07, $ 7.13230914290129d+06,-2.57929135874340d+07, $ -6.93754106056724d+06,1.54167965673704d+07, $ 3.96437423488546d+06,-6.41657328297885d+06, $ -1.41686692105580d+06,1.84861784825349d+06, $ 3.14705412928108d+05,-3.58340765118489d+05, $ -4.10545347750240d+04,4.41702532829458d+04, $ 2.79277887146530d+03,-3.15413411558056d+03, $ -7.90998715967224d+01,1.14532961893102d+02, $ -6.90866544602480d-01,-9.20391422924575d-01, $ -5.95788710264705d-01,-6.82655329201659d-01/ C C ... Executable Statements ... C POLYVAL = 0.0d0 nairq = 36 nairm = 37 nd2q = 25 nd2m = 28 if (d .eq. 2) then if (mq .eq. 4) then do i = 1,nd2q POLYVAL = POLYVAL + d2q(i)*(-theta)**(nd2q-i) end do POLYVAL = -POLYVAL + .075d0 if (ABS(POLYVAL) .gt. .98d0) then POLYVAL = SIGN(.98d0,POLYVAL) end if end if C POLYVAL=(DNINT(POLYVAL*100.0D0+1)/100.0D0) if (mq .eq. 12) then do i = 1,nd2m POLYVAL = POLYVAL + d2m(i)*(-theta)**(nd2m-i) end do POLYVAL = -POLYVAL + .075d0 if (ABS(POLYVAL) .gt. .98d0) then POLYVAL = SIGN(.98d0,POLYVAL) end if end if else if (mq .eq. 4) then do i = 1,nairq POLYVAL = POLYVAL + airq(i)*theta**(nairq-i) end do end if if (mq .eq. 12) then do i = 1,nairm POLYVAL = POLYVAL + airm(i)*theta**(nairm-i) end do end if POLYVAL = POLYVAL + .01d0 POLYVAL = (ANINT(POLYVAL*100.0d0+1)/100.0d0) end if end C C C subroutine CHMODEL(x,se,nx,p,q,bp,bq,d,bd,w,nw,wm,vm,mq,ur,xl,phi, $ tst,imean,seas,pbp,pq,bpq,pstar,z,nz,out,*) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n10,n1 parameter (n1 = 1, n10 = 10) C C.. Formal Arguments .. integer nx,p,q,bp,bq,d,bd,nw,mq,tst,imean,seas,pbp,pq,bpq,pstar, $ nz,out real*8 x(n10),se(n10),w(mpkp),wm,vm,ur,xl,phi(3*n1),z(mpkp) C C.. Local Scalars .. integer i,iproot,j,nbp,nchanged,np logical ltest C C.. Local Arrays .. real*8 ap(3*n1) C C.. External Calls .. external TRANSC C C.. Intrinsic Functions .. intrinsic ABS, DBLE include 'stream.i' C C ... Executable Statements ... C nchanged = 0 C C.. Modified by REG on 12/23/2005 to access X in the next statement C only after if conditions are met. if ((seas.eq.0) .and. (bq.eq.1) .and. (bd.gt.0)) then if (ABS(x(p+bp+q+bq)-xl).lt.1.0d-12) then C C PER FARE QUESTO CONTROLLO MOLTO PROBABILMENETE BISOGNA C CALCOLARE LE RADICI DI PHI(P) E CONTROLLARE SE SONO RADICI C STAGIONALI (COME NELLA SUBROUTINE FIRST) C C CHIEDERE AD AGUSTIN SE NE VALE LA PENA C C NTST=0 C DO 80 I=1,P C 80 IF (DABS(X(I)).EQ.UR) NTST=1 C IF (NTST.EQ.0) THEN C WRITE(NIO,'(//,8X,A,/,8X,A)')'THE SERIES DOES NOT CONTAIN', C & 'SIGNIFICANT SEASONALITY' C ELSE C WRITE(NIO,'(//,8X,A,/,8X,A)')'THE SERIES ONLY CONTAINS', C & 'SOME STATIONARY SEASONALITY' C end if bd = bd - 1 bq = bq - 1 imean = 1 if (out.eq.0) then write (Nio,'(4X,''BD CHANGED TO '',I1)') bd write (Nio,'(4X,''BQ CHANGED TO '',I1)') bq write (Nio,'(4X,''THE MODEL IS CHANGED AND RE-ESTIMATED'')') end if nw = nz do i = 1,nz w(i) = z(i) end do do i = 1,d nw = nw - 1 do j = 1,nw w(j) = w(j+1) - w(j) end do end do wm = 0.0d0 do i = 1,nw wm = wm + w(i) end do wm = wm / DBLE(nw) do i = 1,nw w(i) = w(i) - wm end do pbp = p + bp pq = pbp + q bpq = p + q + bp + bq pstar = p + bp*mq return 1 end if else C C.. Modified by REG on 12/23/2005 to access X in the next statement C only after if conditions are met. if ((seas.eq.0) .and. (bp.eq.1) .and. (bd.eq.0)) then if (ABS(x(p+bp)-ur).lt.1.0d-12) then C C PER FARE QUESTO CONTROLLO MOLTO PROBABILMENETE BISOGNA C CALCOLARE LE RADICI DI PHI(P) E CONTROLLARE SE SONO RADICI C STAGIONALI (COME NELLA SUBROUTINE FIRST) C C CHIEDERE AD AGUSTIN SE NE VALE LA PENA C C NTST=0 C DO 180 I=1,P C 180 IF (DABS(X(I)).EQ.UR) NTST=1 C IF (NTST.EQ.0) THEN C WRITE(NIO,'(//,8X,A,/,8X,A)')'THE SERIES DOES NOT CONTAIN', C & 'SIGNIFICANT SEASONALITY' C ELSE C WRITE(NIO,'(//,8X,A,/,8X,A)')'THE SERIES ONLY CONTAINS', C & 'SOME STATIONARY SEASONALITY' C end if bp = bp - 1 bq = bq - 1 imean = 1 if (out.eq.0) then write (Nio,'(4X,''BP CHANGED TO '',I1)') bp write (Nio,'(4X,''BQ CHANGED TO '',I1)') bq write (Nio,'(4X,''THE MODEL IS CHANGED AND RE-ESTIMATED'')') end if pbp = p + bp pq = pbp + q bpq = p + q + bp + bq pstar = p + bp*mq return 1 end if end if ltest=.false. if ((p+bp) .gt. 0) then ltest = ABS(x(p+bp)-ur).le.1.0d-8 end if if ((seas.ne.0.or.bp.ne.1.or.bd.ne.0.or.ltest) .and. seas.ne.1) & return np = p nbp = bp if (p .gt. 0) then i = 1 do while (.true.) if ((ABS(x(i)-ur).lt.1.0d-12) .and. (d.lt.2)) then p = p - 1 d = d + 1 if (out.eq.0) then write (Nio,'(4X,''P CHANGED TO '',I1)') p write (Nio,'(4X,''D CHANGED TO '',I1)') d write (Nio,'(4X,''THE MODEL IS CHANGED AND RE-ESTIMATED'')') end if nchanged = 1 nw = nw - 1 do j = 1,nw w(j) = w(j+1) - w(j) end do do j = nx,i+1,-1 se(j-1) = se(j) x(j-1) = x(j) end do nx = nx - 1 tst = tst - 1 end if i = i + 1 if (i .gt. p) goto 5000 end do end if C 5000 if (bp .gt. 0) then do i = p+1,p+bp if ((ABS(x(i)-ur).lt.1.0d-10) .and. (bd.lt.1)) then bp = bp - 1 bd = bd + 1 if (out.eq.0) then write (Nio,'(4X,''BP CHANGED TO '',I1)') bp write (Nio,'(4X,''BD CHANGED TO '',I1)') bd end if nchanged = 1 nw = nw - mq do j = 1,nw w(j) = w(j+mq) - w(j) end do do j = i,nx se(j) = se(j+1) x(j) = x(j+1) end do nx = nx - 1 tst = tst - 1 end if end do end if if ((np.ne.p) .or. (nbp.ne.bp)) then wm = 0.0d0 do i = 1,nw wm = wm + w(i) end do wm = wm / DBLE(nw) vm = 0.0d0 do i = 1,nw vm = vm + w(i)*w(i) end do vm = vm / nw call TRANSC(x,0,p,phi,iproot,ap) end if if (nchanged .eq. 1) then return 1 end if end if end C C subroutine TRANS1I2(p,x,ib,ie,xl,ur) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer ib,ie real*8 p(*),x(*),xl,ur C C.. Local Scalars .. integer i,j,npq real*8 xmax,xmin,xtest C C.. Local Arrays .. real*8 phith(3) C C.. Intrinsic Functions .. intrinsic ABS, SIGN xmin = -xl xmax = xl npq = ie - ib + 1 do i = 1,npq phith(i) = -p(i) end do if (npq .le. 1) then x(ib) = phith(1) else if (npq .le. 2) then if (abs(1.0d0-phith(2)) .lt. 1.0d-9) then phith(2) = ur end if x(ib) = phith(1) / (1.0d0-phith(2)) x(ie) = phith(2) else if (ABS(phith(3)-1.0d0) .lt. 1.0d-9) then phith(3) = SIGN(ur,phith(3)) end if x(ib) = 0.5d0 * ((phith(1)+phith(2))/(1.0d0-phith(3))+1.0d0) x(ib+1) = (1.0d0+(phith(1)-phith(2))/(1.0d0+phith(3))) if (abs(x(ib)+1.0d0) .lt. 1.0d-9) then x(ib) = -ur end if x(ib+1) = x(ib+1)/(1.0d0+x(ib)) - 1.0d0 x(ie) = phith(3) end if do j = ib,ie xtest = (x(j)-xmin) / (xmax-xmin) if (xtest .lt. 0.01d0) then x(j) = -ur end if if (xtest .gt. xmax) then x(j) = ur end if end do end C C subroutine TRANSCI2(p,x,m,n) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer m,n real*8 p(*),x(*) C C.. Local Scalars .. integer i,icount,iroot,j real*8 d,delta,disc,e,s,y c c.. local arrays .. real*8 alph(3),c(3) c c.. intrinsic functions .. intrinsic ABS, SQRT c c.. Common Variables include 'stream.i' c c to transform search parameters into model parameters c j = n - m iroot = j if (j .lt. 2) then c(1) = x(n) alph(1) = c(1) else if (j .eq. 2) then c(1) = x(m+1) * (1.0d0-x(n)) c(2) = x(n) disc = c(1)**2 + 4.0d0*c(2) if (disc .ge. 0.0d0) then disc = SQRT(disc) alph(1) = 0.5d0 * (c(1)+disc) alph(2) = 0.5d0 * (c(1)-disc) else iroot = 0 end if else s = (2.0d0*x(m+1)-1.0d0) * (1.0d0-x(n)) d = (1.0d0+x(n)) * ((1.0d0+x(m+1))*(1.0d0+x(m+2))-1.0d0) c(1) = 0.5d0 * (s+d) c(2) = 0.5d0 * (s-d) c(3) = x(n) c c to find real roots of x**3-c(1)*x**2-c(2)*x-c(3)=0. c put x=y+c(1)/3. equation becomes y**3-d*y-e=0 c find root by newton-raphson c d = c(1)*c(1)/3.0d0 + c(2) e = (2.0d0*c(1)**3+9.0d0*c(1)*c(2))/27.0d0 + c(3) disc = 4.0d0*d**3 - 27.0d0*e**2 if (disc .gt. 0.0d0) then y = -e/d else if (e .gt. 0.0d0) then y = 1 - c(1)/3 else y = -1 - c(1)/3 end if icount = 0 do while (.true.) delta = (y**3-d*y-e) / (3.0d0*y*y-d) y = y - delta if (ABS(delta) .le. 0.00005d0) goto 1000 icount = icount + 1 if (icount .gt. 10) then 7000 format (/,' CUBIC ITERATIONS EXCEEDED') write (Nio,7000) goto 1000 end if end do goto 1005 1000 alph(1) = y c c test if all roots are real c if (disc .ge. 0.0d0) then c c roots real.divide by (y-alph(1)) c y**2+alph(1)*y+e/alph(1)=0 c disc = sqrt(alph(1)**2-4.0d0*e/alph(1)) alph(2) = 0.5d0 * (-alph(1)+disc) alph(3) = 0.5d0 * (-alph(1)-disc) else iroot = 1 end if do i = 1,iroot alph(i) = alph(i) + c(1)/3.0d0 end do end if 1005 do i = 1,n-m p(i) = -c(i) end do end C C subroutine CHECKI2(p,x,m,n,xl,ur) integer m,n real*8 p(*),x(*),xl,ur call TRANS1I2(p,x,m,n,xl,ur) call TRANSCI2(p,x,m-1,n) return end C C subroutine UnitsCheck(oz,nz,k) C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer nz real*8 oz(*) C C.. Local Scalars .. integer zlen,i,k C C.. Local Arrays .. real*8 z(MPKp),zmin,zmax C C.. External Functions .. real*8 AMIN,AMAX external AMIN,AMAX C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C.. zlen=0 k=0 do i=1,nz if (.not.dpeq(oz(i), -99999.0d0)) then z(i)=DABS(oz(i)) zlen=zlen+1 end if end do zmin=AMIN(z,zlen) if (zmin .ge. 10.0d4) then k=-1 zmin = zmin*10.0d-3 do while (zmin .gt. 10.0d3) k=k-1 zmin=zmin*10.0d-3 end do do i=1,nz if (.not.dpeq(oz(i), -99999.0d0)) then oz(i)=oz(i)*(10.0d0**(3*k)) end if end do end if zmax = AMAX(z,zlen) if (zmax .lt. 10.0d-3) then zmax=zmax*10.0d3 k=1 do while (zmax .le. 10.0d-1) k=k+1 zmax=zmax*10.0d3 end do do i=1,nz if (.not.dpeq(oz(i), -99999.0d0)) then oz(i)=oz(i)*(10.0d0**(3*k)) end if end do end if return end C C double precision function AMAX(z,nz) C.. Implicits .. implicit none C C.. Formal Arguments .. integer nz real*8 z(*) C C.. Local Scalars .. real*8 zmax integer i C C.. zmax = z(1) do i=1,nz if (z(i).gt.zmax) then zmax=z(i) end if end do AMAX=zmax return end C C double precision function AMIN(z,nz) C.. Implicits .. implicit none C C.. Formal Arguments .. integer nz real*8 z(*) C C.. Local Scalars .. real*8 zmin integer i C C.. zmin = z(1) do i=1,nz if (z(i).lt.zmin) then zmin=z(i) end if end do AMIN=zmin return end C Integer function getLastPeriod(Nz,Nper,Nyear,Mq) C.. Implicits .. implicit none C C.. Formal Arguments .. integer Nz,Nper,Nyear,Mq C C.. Local Scalars .. integer i,lper,lyear lper=Nper lyear=Nyear do i=2,Nz lper=lper+1 if (lper .gt. Mq) then lper=1 lyear=lyear+1 end if end do getLastPeriod=lper return end C Integer function getLastYear(Nz,Nper,Nyear,Mq) C.. Implicits .. implicit none C C.. Formal Arguments .. integer Nz,Nper,Nyear,Mq C C.. Local Scalars .. integer i,lper,lyear lper=Nper lyear=Nyear do i=2,Nz lper=lper+1 if (lper .gt. Mq) then lper=1 lyear=lyear+1 end if end do getLastYear=lyear return end CC C CC SUBROUTINE TITLECK (STRING) CHARACTER*(80) STRING CHARACTER CHAR INTEGER I,J,ISTRLEN INTEGER*4 IASC,ICHAR J=ISTRLEN(STRING) DO 10 I=1,J IASC = ICHAR(STRING(I:I)) IF (IASC .GT. 126) THEN IF ((IASC .ge. 192) .and. (IASC .le. 198)) THEN STRING(I:I) = CHAR(65) ELSE IF ((IASC .ge. 200) .and. (IASC .le. 203)) THEN STRING(I:I) = CHAR(67) ELSE IF ((IASC .ge. 204) .and. (IASC .le. 207)) THEN STRING(I:I) = CHAR(73) ELSE IF (IASC .eq. 208) THEN STRING(I:I) = CHAR(68) ELSE IF (IASC .eq. 209) THEN STRING(I:I) = CHAR(78) ELSE IF ((IASC .ge. 210) .and. (IASC .le. 216)) THEN STRING(I:I) = CHAR(79) ELSE IF ((IASC .ge. 217) .and. (IASC .le. 220)) THEN STRING(I:I) = CHAR(85) ELSE IF (IASC .eq. 221) THEN STRING(I:I) = CHAR(89) ELSE IF ((IASC .ge. 224) .and. (IASC .le. 230)) THEN STRING(I:I) = CHAR(97) ELSE IF (IASC .eq. 231) THEN STRING(I:I) = CHAR(99) ELSE IF ((IASC .ge. 232) .and. (IASC .le. 235)) THEN STRING(I:I) = CHAR(101) ELSE IF ((IASC .ge. 236) .and. (IASC .le. 239)) THEN STRING(I:I) = CHAR(105) ELSE IF (IASC .eq. 241) THEN STRING(I:I) = CHAR(110) ELSE IF ((IASC .ge. 242) .and. (IASC .le. 246)) THEN STRING(I:I) = CHAR(111) ELSE IF ((IASC .ge. 249) .and. (IASC .le. 252)) THEN STRING(I:I) = CHAR(117) ELSE IF (IASC .eq. 253) THEN STRING(I:I) = CHAR(121) ELSE STRING(I:I)=ACHAR(45) end if end if 10 CONTINUE RETURN END CC C CC C C FUNCTION TO COMPUTE THE VARIANCE C double precision function DIVIDECHECK(x) C C.. Implicits .. implicit none C C.. Formal Arguments .. real*8 x DIVIDECHECK = x if (abs(x) .lt. 1.0d-9) then DIVIDECHECK = 1.0d-9 end if return end cc c cc integer function ChangeModel(nio,init,nochmodel, $ statseas,posbphi,rmod,p,d,q,bp,bd,bq,th,bth,phi, $ bphi,imean,remMeanMCS,out,tramo,inputModel) C.. Parameters .. integer n1 parameter (n1 = 1) c integer nio,init,nochmodel,statseas,posbphi,p,d,q,bp,bd, $ bq,out,imean,tramo,inputModel, $ oP,oD,oQ,oBp,oBd,oBq,oImean real*8 phi(3*n1),bphi(3*n1),th(3*n1),bth(3*n1),rmod logical remMeanMCS c integer cambiado,difsOrig,origInit c cambiado=0 origInit=init oP=p oD=d oQ=q oBp=bp oBd=bd oBQ=bq oImean=imean difsOrig=d+bd if (nochmodel.eq.0) then if (bd.eq.0) then if ((bp.eq.1).and.(bq.eq.1).and. $ (abs(bphi(1)).lt.abs(bth(1))))then if ((bphi(1).gt.0.0d0).and.(bth(1).lt.0.0d0).and. $ (statseas.eq.1)) then bd=1 bp=0 cambiado=1 else if ((bphi(1).gt.0.0d0).and.(bth(1).gt.0.0d0)) then bq=0 cambiado=1 end if else if ((bp.eq.1).and.(bq.eq.0).and.(statseas.eq.1)) then if (bphi(1).gt.rmod-0.2d0) then bp=0 bq=1 bd=1 cambiado=1 else if ((bphi(1).le.0.0d0).and.(bphi(1).ge.-rmod+0.2d0)) then cambiado=1 bp=0 end if end if else if ((posbphi.eq.1).and.(bp.eq.1).and.(bphi(1).le.0.0d0)) then bp=0 bq=1 cambiado=1 end if end if if (d.eq.0) then if ((p.eq.1).and.(q.eq.1)) then if (abs(phi(1)).lt.abs(th(1))) then if ((phi(1).gt.0.0d0).and.(th(1).lt.0.d0).and. $ (statseas.eq.1)) then d=1 p=0 cambiado=1 end if end if else if ((p.eq.1).and.(statseas.eq.1).and. $ (phi(1).gt.rmod)) then p=0 q=1 d=1 cambiado=1 else if ((p.eq.0).and.(q.eq.1).and.(bp.eq.0).and.(bd.eq.0) $ .and.(bq.eq.0)) then q=0 cambiado=4 end if end if if (difsOrig.lt.d+bd) then imean=0 end if ChangeModel=cambiado if (cambiado.ne.0) then if (remMeanMCS) then imean=0 end if if ((cambiado.ne.2).and.(cambiado.ne.3)) then init=0 end if call setTmcs('Y') if (out.eq.0) then if (inputModel.eq.1) then call ShowFirstModel(Nio,oP,oD,oQ,oBp,oBd,oBq,th, $ Bth,phi,Bphi,oImean,tramo,origInit) end if if (cambiado.eq.2) then write (Nio,'(2x,"The negative seasonal correlation - ", $ "possibly induced by seasonal adjustment- ",/,2x, $ "is ignored. Model from regARIMA has been modified by ", $ "setting BTH=0.")') elseif (cambiado.eq.3) then write (Nio,'(2x,"A pure seasonal MA(1) does not yield ", $ "a proper seasonal component.",/,"Model from regARIMA ", $ "has been modified by setting BPHI=0")') end if write (Nio,'(2x,"MODEL CHANGED TO :",/,2x,"(",1x,i1, $ ",",2x,i1,",",2x,i1, $ ",",1x,")",4x,"(",1x,i1,",",2x,i1,",",2x,i1,1x,")")') $ p,d,q,bp,bd,bq end if end if end if return end cc c cc ansub2.f0000664006604000003110000027377314521201406011550 0ustar sun00315stepsC Last change: Mar. 2021- fix the program hangs issue when passed C certain input C previous change: BCM 4 Oct 2002 2:18 pm C ... SUBROUTINE RPQ -FINDS THE ROOTS OF A POLINOMYAL IN B- C C INPUT PARAMETER C B : POLYNOMIAL B(1)*X^N-1 + B(2)*X^N-2 + ..... + B(N) C N : DIMENSION OF B C REZ : REAL PART OF THE ROOTS C IMZ : IMAGINARY PART OF THE ROOTS C M : THE MODUL OF THE ROOTS C AR : THE ARGUMENT OF THE ROOTS C P : THE PERIOD OF THE ROOTS C NOPRINT : NO PRINTOUT OF THE ROOTS C subroutine RPQ(b,n,rez,imz,m,ar,p,noprint,out) C C.. Implicits .. implicit none C real*8 ZERO,ONE parameter (ZERO=0.0d0,ONE=1.0d0) C C.. Formal Arguments .. integer n,noprint,out real*8 b(*),rez(*),imz(*),m(*),ar(*),p(*) C C.. Local Scalars .. integer i,ifail,j,k,n1,nroots,iroot real*8 pi,tol double precision v,w C C.. Local Arrays .. real*8 a(65) C C.. External Functions .. double precision X02AAF external X02AAF C C.. External Calls .. external C02AEF C C.. Intrinsic Functions .. intrinsic ABS, ACOS, SQRT include 'stream.i' C LINES OF CODE ADDED FOR X-13A-S : 1 include 'error.cmn' C END OF CODE BLOCK C C.. Data Declarations .. C C ... Executable Statements ... C C tol = X02AAF() pi = 3.14159265358979D0 nroots = n - 1 if (n.gt.1)THEN rez(1) = -b(2) ELSE rez(1) = ZERO END IF imz(1) = 0.0d0 c if ((n.eq.4) .and. (a(1).ne.0.0D0)) then c call Tartaglia(b,n,reZ,imZ) c else if (n .gt. 2) then if (n .gt. 2) then rez(1) = ZERO imz(1) = ZERO C do i = 1,n a(i) = b(i) end do C C n1 = n ifail = 0 C C WRITE(*,*)' enter C02AEF' call C02AEF(a,n1,rez,imz,tol,ifail) C WRITE(*,*)' exit C02AEF' C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK C write(*,*)' ifail = ',ifail if (ifail .eq. 2) then C WRITE(*,*)' enter C02AEF' call C02AEF(a,n1,rez,imz,tol,ifail) C WRITE(*,*)' exit C02AEF' C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK end if if ((ifail .ne. 0).and.(noprint.eq.0).and.(out.eq.0)) then 7000 format (/,' ','IFAIL=',i2,' C02AEF UNSUCCESFULL') write (Nio,7000) ifail end if do while (.true.) C C THE ROOTS ARE REORDERED LISTING FIRST THOSE ONE THAT ARE C COMPLEX C C k = 0 j = 0 do i = 1,nroots if (imz(i).lt.tol .and. imz(i).gt.-tol) then k = i else j = i end if if (j.gt.k .and. k.gt.0) goto 5000 end do goto 5001 5000 v = rez(j) w = imz(j) rez(j) = rez(k) imz(j) = imz(k) rez(k) = v imz(k) = w end do end if C C WE PUT IN M THE MODULUS OF THE ROOT AND IN AR ITS ARGUMENT C 5001 do i = 1,nroots C m(i) = SQRT(rez(i)**2+imz(i)**2) if (m(i) .lt. 1.0d-8) then ar(i) = 0.0d0 else ar(i) = rez(i) / m(i) end if if (ABS(ar(i)) .le. ONE) then ar(i) = ACOS(ar(i)) if (imz(i) .lt. ZERO) then ar(i) = -ar(i) end if else ar(i) = ZERO if (rez(i) .lt. ZERO) then ar(i) = pi end if end if C C AR(I)=DSIGN(DACOS(REZ(I)/M(I)),IMZ(I)) C end do C C WE PUT IN P THE PERIOD OF THE COMPLEX ROOT C do i = 1,nroots if ((ABS(ar(i)).gt.1.0d-8) .and. $ (imz(i).gt.tol.or.imz(i).lt.-tol)) then p(i) = 2.d0 * pi / ar(i) else p(i) = 999.99 end if end do C C THE ARGUMENTS ARE EXPRESSED IN DEGREES C do i = 1,nroots ar(i) = 180.0d0 * ar(i) / pi end do C C C PRINTING OF THE RESULTS C if ((noprint .ne. 1).and.(out.eq.0)) then C WRITE(*,*)' enter OutRPQ' call OutRPQ(Nio,nroots,rez,imz,m,ar,p) C WRITE(*,*)' exit OutRPQ' end if end c c OutRPQ: PRINTING OF THE RESULTS OF RPQ C INPUT PARAMETER C NIO: unit file where to write C REZ : REAL PART OF THE ROOTS C IMZ : IMAGINARY PART OF THE ROOTS C M : THE MODUL OF THE ROOTS C AR : THE ARGUMENT OF THE ROOTS C P : THE PERIOD OF THE ROOTS subroutine OutRPQ(Nio,nroots,rez,imz,m,ar,p) implicit none C C.. Data Declarations .. character blan*4,two*4 data blan/' - '/ data two/'2.0 '/ include 'srslen.prm' include 'dimensions.i' C C.. Formal Parameters .. integer nio,nroots real*8 ar(*),p(*),rez(*),imz(*),m(*) C C.. Local Parameters integer iroot,i character per(Kp)*4 C do i = 1,nroots if (rez(i) .lt. 0.0d0) then per(i) = two else per(i) = blan end if end do C PRINTING OF THE RESULTS OF RPQ 7001 format ( $7x,' REAL PART ',' IMAGINARY PART',' MODULUS ', $' ARGUMENT ',' PERIOD') write (Nio,7001) do i = 1,nroots if (ar(i) .ge. 0.0d0) then if (ABS(p(i)-999.99) .lt. 1.0d-12) then 7002 format (6x,f11.4,4x,f11.4,5x,f11.4,4x,f11.4,5x,a4) write (Nio,7002) rez(i), imz(i), m(i), ar(i), per(i) else 7003 format (6x,f11.4,4x,f11.4,5x,f11.4,4x,f11.4,1x,f11.4) write (Nio,7003) rez(i), imz(i), m(i), ar(i), p(i) end if end if end do end C C c Tartaglia method to obtain the exact roots of polynomials of third order P(1:4): c given P(4)+P(3)*X+P(2)*X**2+P(1)*X**3 where P(1)<>0 c return the roots [Rez(1)+i*IMz(1),Rez(2)+i*Imz(2),Rez(3)+i*Imz(3)] subroutine Tartaglia(P,n,rez,imz) implicit none real*8 CR2,n2,n3,n4,n6,n9,n27,eps,sqrt3 parameter(CR2=1.259921049894873D0,sqrt3=1.732050807568877D0, $ n2=2.0D0,n3=3.0D0,n4=4.0D0,n6=6.0D0, $ n9=9.0D0,n27=27.0D0,eps=1.0D-13) c INPUT real*8 P(*) integer n !length of P(1:4) that must be 4 if not error c OUTPUT real*8 Rez(*),Imz(*) c LOCAL integer i real*8 Q,R,D,rD1,iD1,rS1,iS1,rS2,iS2,mS1,mS2, $ b_3a,rQ_aS,iQ_aS,rS_a,iS_a c EXTERNAL intrinsic ABS external SQROOTC,DivCompl,cubicRoot c do i=1,3 Rez(i)=0.0D0 Imz(i)=0.0D0 enddo if ((n.ne.4) .or.(P(1).eq.0.0D0)) then c ERROR this is not a 3th order polynomial return end if call cubicRoot(p(4)/p(1),0.0D0,Rez(1),Imz(1)) if ((Abs(p(3)/p(1)-n3*Rez(1)*Rez(1)).lt.eps).and. $ (Abs(p(2)/p(1)+n3*Rez(1)).lt.eps)) then Rez(2)=Rez(1) !Triple root Rez(3)=Rez(1) return end if Q=-p(2)*p(2)+n3*p(1)*p(3) R=-n2*p(2)*p(2)*p(2)+n9*p(1)*p(2)*p(3)-n27*p(1)*p(1)*p(4) D=n4*Q*Q*Q+R*R call SQROOTC(D,0.0D0,rD1,iD1) call CubicRoot(R+rD1,iD1,rS1,iS1) call CubicRoot(R-rD1,-iD1,rS2,iS2) mS1=rS1*rS1+iS1*iS1 mS2=rS2*rS2+iS2*iS2 if (mS2.gt.mS1) then rS1=rS2 iS1=iS2 end if b_3a=p(2)/(n3*p(1)) call DivCompl(Q,0.0D0,p(1)*rS1,p(1)*iS1,rQ_aS,iQ_aS) rS_a=rS1/p(1) iS_a=iS1/p(1) Rez(3)=-b_3a-(CR2*rQ_aS/n3)+rS_a/(n3*CR2) Imz(3)=-CR2*iQ_aS/n3+iS_a/(n3*CR2) if (abs(Imz(1)).lt.eps)then Imz(1)=0.0d0 end if Rez(2)=-b_3a+(rQ_aS-sqrt3*iQ_aS)/(n3*CR2*CR2) $ -(rS_a+SQRT3*iS_a)/(n6*CR2) Imz(2)=(iQ_aS+sqrt3*rQ_aS)/(n3*CR2*CR2)-(iS_a-SQRT3*rS_a)/(n6*CR2) if (abs(Imz(2)).lt.eps)then Imz(2)=0.0d0 end if Rez(1)=-b_3a+(rQ_aS+sqrt3*iQ_aS)/(n3*CR2*CR2) $ -(rS_a-SQRT3*iS_a)/(n6*CR2) Imz(1)=(iQ_aS-sqrt3*rQ_aS)/(n3*CR2*CR2)-(iS_a+SQRT3*rS_a)/(n6*CR2) if (abs(Imz(3)).lt.eps)then Imz(3)=0.0d0 end if end C C double precision function X02AAF() C C.. Implicits .. implicit none C C.. Local Scalars .. real*8 z C C data z/2.225073858507201d-14/ C C ... Executable Statements ... C X02AAF = z c real*8 dbl_eps c external dbl_eps c X02AAF = dbl_eps() end C C C THIS SUBROUTINE CALCULATES C,THE PRODUCT OF TWO POLYNOMIALS C YOUR PRODUCT ARRAY (OUTPUT ARGUMENT "C" ) HAVE TO BE DIFFERENT C FROM YOUR FIRST POLYNOMIAL (INPUT ARGUMENT "A"). C C I.E. CONV(A,N,B,M,A,J) UNCORRECT C C I.E. CONV(A,N,B,M,B,J) CORRECT C C C INPUT PARAMETER C A : FIRST POLYNOMIAL (true signs) A(1) + A(2)*B + ... + C A(MPLUS1)*B^(MPLUS1-1) C MPLUS1 : DIMENSION OF A C B : SECOND POLYNOMIAL (true signs) " " " C NPLUS1 : DIMENSION OF B C C : PRODUCT OF A * B (true signs) " " " C LPLUS1 : DIMENSION OF C C C subroutine CONV(a,mplus1,b,nplus1,c,lplus1) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 a(*) C.. In/Out Status: Read, Not Written .. integer mplus1 C.. In/Out Status: Maybe Read, Not Written .. real*8 b(*) C.. In/Out Status: Read, Not Written .. integer nplus1 C.. In/Out Status: Maybe Read, Maybe Written .. real*8 c(*) C.. In/Out Status: Not Read, Overwritten .. integer lplus1 C C.. Local Scalars .. integer i,j,jplus1,num C C.. Local Arrays .. real*8 d(500) C C ... Executable Statements ... C jplus1 = nplus1 lplus1 = mplus1 + jplus1 - 1 do i = 1,jplus1 d(i) = b(i) end do do i = 1,lplus1 c(i) = 0.0d0 end do do i = 1,mplus1 do j = 1,jplus1 num = i + j - 1 c(num) = c(num) + a(i)*d(j) end do end do end C C C THIS SUBROUTINE CALCULATES C,THE PRODUCT OF A(Z) C AND B(Z**-1). THE OUTPUT ARGUMENT C MUST BE DIFFERENT C FROM A,B THE TWO INPUT ARGUMENTS C C INPUT PARAMETER C A : FIRST POLYNOMIAL (true signs) A(1) + A(2)*COS(W) + ... + C A(MPLUS1)*COS((MPLUS1-1)*W) C MPLUS1 : DIMENSION OF A C B : SECOND POLYNOMIAL (true signs) " " " " C NPLUS1 : DIMENSION OF B C C : PRODUCT OF A * B (true signs) " " " " C LPLUS1 : DIMENSION OF C C C C subroutine CONJ(a,mplus1,b,nplus1,c,lplus1) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 a(*) C.. In/Out Status: Read, Not Written .. integer mplus1 C.. In/Out Status: Maybe Read, Not Written .. real*8 b(*) C.. In/Out Status: Read, Not Written .. integer nplus1 C.. In/Out Status: Maybe Read, Maybe Written .. real*8 c(*) C.. In/Out Status: Not Read, Overwritten .. integer lplus1 C C.. Local Scalars .. integer i,j,k,num C C.. Intrinsic Functions .. intrinsic ABS, MAX C C ... Executable Statements ... C lplus1 = MAX(mplus1,nplus1) do i = 1,lplus1 c(i) = 0.0d0 end do do i = 1,mplus1 do j = 1,nplus1 k = i - j num = ABS(k) + 1 c(num) = c(num) + a(i)*b(j) end do end do end C C C THIS SUBROUTINE CALCULATES C,THE PRODUCT OF TWO HARMONIC C FUNCTIONS A * B. C THE OUTPUT ARGUMENT C MUST BE DIFFERENT C FROM A,B THE TWO INPUT ARGUMENTS C C INPUT PARAMETER C A : FIRST POLYNOMIAL (true signs) C MPLUS1 : DIMENSION OF A C B : SECOND POLYNOMIAL (true signs) C NPLUS1 : DIMENSION OF B C C : PRODUCT OF A * B C LPLUS1 : DIMENSION OF C C C subroutine MULTFN(a,mplus1,b,nplus1,c,lplus1) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 a(*) C.. In/Out Status: Read, Not Written .. integer mplus1 C.. In/Out Status: Maybe Read, Not Written .. real*8 b(*) C.. In/Out Status: Read, Not Written .. integer nplus1 C.. In/Out Status: Not Read, Maybe Written .. real*8 c(*) C.. In/Out Status: Not Read, Overwritten .. integer lplus1 C C.. Local Scalars .. integer i,l1,l2 C C.. Local Arrays .. real*8 c1(165),c2(165) C C.. External Calls .. external CONJ, CONV C C ... Executable Statements ... C lplus1 = mplus1 + nplus1 - 1 do i = 1,lplus1 c2(i) = 0.0d0 end do call CONV(a,mplus1,b,nplus1,c1,l1) * write(*,*)' MULTFN : mplus1 = ',mplus1,' nplus1 = ',nplus1, * & ' l1 = ',l1 call CONJ(a,mplus1,b,nplus1,c2,l2) do i = 1,l1 c(i) = (c1(i)+c2(i)) / 2 C IF (DABS(C(I)) .LE. 1.0D-10) C(I) = 0.0D0 end do end C C C THIS SUBROUTINE CALCULATES THE QUOTIENT,Q,AND REMAINDER,R,OF C TWO HARMONIC FUNCTIONS A $ B. C THE TWO OUTPUT ARGUMENT Q,R MUST BE DIFFERENT C FROM A,B THE TWO INPUT ARGUMENTS C C INPUT PARAMETER C A : FIRST POLYNOMIAL (true signs) C MPLUS1 : DIMENSION OF A C B : SECOND POLYNOMIAL (true signs) C NPLUS1 : DIMENSION OF B C Q : QUOTIENT (true signs) C NQ : DIMENSION OF Q C R : REMAINDER (true signs) C NR : DIMENSION OF R C C subroutine DIVFCN(a,mplus1,b,nplus1,q,nq,r,nr) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer mplus1,nplus1,nq,nr real*8 a(*),b(*),q(*),r(*) C C.. Local Scalars .. integer i,j,jp,k,kprime,num real*8 factor C C.. Local Arrays .. real*8 wr(100) C C.. Intrinsic Functions .. intrinsic ABS C C ... Executable Statements ... C nq = mplus1 - nplus1 + 1 do i = 1,mplus1 wr(i) = a(i) if (i .le. nq) then q(i) = 0.0d0 end if end do if (nq .ge. 1) then if (nplus1 .eq. 1) then do i = 1,mplus1 q(i) = a(i) / b(1) end do r(1) = 0.0d0 nr = 0 return else do kprime = 1,nq k = nq - kprime num = mplus1 - kprime + 1 C IF (B(NPLUS1).LT.1.0D-12)B(NPLUS1)=1.0D-6 factor = wr(num) / b(nplus1) q(k+1) = 2.0d0 * factor if (k .eq. 0) then q(k+1) = factor end if do i = 1,nplus1 j = i + k jp = ABS(i-k-1) + 1 wr(j) = wr(j) - factor*b(i) if (k .ne. 0) then wr(jp) = wr(jp) - factor*b(i) end if end do end do end if else nq = 0 end if nr = nplus1 - 1 do i = 1,nr r(i) = wr(i) end do end C C THIS SUBPROGRAM DEFINES THE FUNCTION TO BE MINIMISED C IN MINIM. THE FUNCTIONS ARE SPECIFIED IN THE COMMON C "FUNC", "FUNC2", "FUNC3", "FUNC4". THE COMMON "TEST" C SPECIFIES WHICH FUNCTION MUST BE EVALUATED. C IFUNC = 1 'FUNC' C IFUNC = 2 'FUNC2' C IFUNC = 3 'FUNC3' C IFUNC = 4 'FUNC4' C IFUNC = 5 'FUNC5' C C INPUT ARGUMENT C C X : THE VALUE IN WHICH THE FUNCTION MUST BE EVALUATED C double precision function FUNC0(x) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 x C C.. Local Scalars .. integer i,l real*8 denom,numer,w C C.. Local Arrays .. real*8 c(32) C C.. Intrinsic Functions .. intrinsic ABS, COS, MAX, SIGN include 'func.i' include 'func2.i' include 'func3.i' include 'func4.i' include 'func5.i' include 'test.i' C C ... Executable Statements ... C w = 0.0d0 numer = 0.0d0 denom = 0.0d0 if (Ifunc .eq. 5) then l = MAX(Ndum,Ndum1) do i = 1,l c(i) = COS(w) w = w + x end do do i = 1,Ndum numer = numer + Dum(i)*c(i) end do do i = 1,Ndum1 denom = denom + Dum1(i)*c(i) end do if (ABS(denom) .lt. 1.0d-13) then denom = SIGN(1.0d-13,denom) end if FUNC0 = numer / denom else if (Ifunc .ne. 1) then if (Ifunc .eq. 3) then l = MAX(Nuc,Nc) do i = 1,l c(i) = COS(w) w = w + x end do do i = 1,Nuc numer = numer + Uc(i)*c(i) end do do i = 1,Nc denom = denom + Fc(i)*c(i) end do if (ABS(denom) .lt. 1.0d-13) then denom = SIGN(1.0d-13,denom) end if FUNC0 = numer / denom else if (Ifunc .eq. 4) then l = MAX(Nf,Nh) do i = 1,l c(i) = COS(w) w = w + x end do do i = 1,Nf numer = numer + Ff(i)*c(i) end do do i = 1,Nh denom = denom + Fh(i)*c(i) end do if (ABS(denom) .lt. 1.0d-13) then denom = SIGN(1.0d-13,denom) end if FUNC0 = numer / denom else l = MAX(Nut,Nt) do i = 1,l c(i) = COS(w) w = w + x end do do i = 1,Nut numer = numer + Ut(i)*c(i) end do do i = 1,Nt denom = denom + Ft(i)*c(i) end do if (ABS(denom) .lt. 1.0d-13) then denom = SIGN(1.0d-13,denom) end if FUNC0 = numer / denom end if else l = MAX(Nv,Ns) do i = 1,l c(i) = COS(w) w = w + x end do do i = 1,Nv numer = numer + V(i)*c(i) end do do i = 1,Ns denom = denom + Fs(i)*c(i) end do if (ABS(denom) .lt. 1.0d-13) then denom = SIGN(1.0d-13,denom) end if FUNC0 = numer / denom end if end C C MINIMISATION OF A FUNCTION IN ONE DIMENSION C C INPUT PARAMETERS ARE SUPPLIED BY THE CALLING PROGRAM C VIA THE COMMON BLOCK "MINIM". THEY ARE: C START : THE STARTING VALUE FOR THE SEARCH C STEP : THE STEP LENGTH USED IN MOVING C STOP : THE CONVERGENCE PARAMETER C C ALSO REQUIRED IS THE FUNCTION SUBPROGRAM WHICH DEFINES THE FUNCTION C F(X) TO BE MINIMISED C C INPUT PARAMETER : C FMIN : THE MINIMUM OF THE FUNCTION C XMIN : THE POINT AT WHICH IT OCCURS C ICONV : 1 IF THE PROCESS HAS NOT CONVERGED, 0 OTHERWISE C C C Changed (by Donald Martin, 7/23/02) to allow for the lower and upper c bound of the space being minimized to be specified. subroutine MINIM(fmin,xmin,lb,ub,iconv) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Not Read, Overwritten .. real*8 fmin C.. In/Out Status: Not Read, Overwritten .. real*8 xmin C.. In/Out Status: Not Read, Overwritten .. integer iconv C C.. Local Scalars .. integer icount,ilim real*8 d,f1,f2,f3,f4,h1,h3,x1,x2,x3,x4,lb,ub C C.. External Functions .. real*8 FUNC0 external FUNC0 C C.. Intrinsic Functions .. intrinsic ABS include 'min.i' C C ... Executable Statements ... C C C STEP 1: SET UP STARTING VALUES C iconv = 0 icount = 0 C C ICONV BECOMES 1 IF THE PROCESS DOES NOT CONVERGE C ICOUNT COUNTS THE NUMBER OF TIMES F4 IS CALCULATED C d = Step C x2 = Start x1 = Start - d x3 = Start + d C Changed (by Donald Martin, 7/23/02) change from 0 to lb. x4 = lb f1 = FUNC0(x1) f2 = FUNC0(x2) f3 = FUNC0(x3) C C C STEP 2: CALCULATE THE SLOPES C C CHECK THE NUMBER OF CALCULATIONS OF F4 C C Changed (by Donald Martin, 7/15/02) the number of iterations allowed C from 20 to 50 c Changed by Brian Monsell - change number of iterations only when new c models used c Changed by Brian Monsell - change number of iterations to 50 c as per Build 525 of SEATS ilim = 50 do 10 while (icount .le. ilim) C C Here, ABS(x3-x4) was changed to ABS(x3-x2) in the expression after .or. C (Changed by Donald Martin, July 15, 2002) if ((ABS(x1-x2).lt.1.d-12) .or. (ABS(x3-x2).lt.1.d-12)) goto 5003 h1 = (f2-f1) / (x2-x1) h3 = (f3-f2) / (x3-x2) C C WE TEST THE SLOPES C IF H3=

infinito). C Para ello sustituye el valor que obtendriamos llamando a F(w) por F(epsilon) en C [0,epsilon) C Parametros de entrada: C w frecuencia en la cual evaluamos el espectro C haydif 0 si no se ha diferenciado C mq #observaciones por año C tol epsilon en grados C C ifunc componente para el cual queremos calcular su espectro double precision function Fbis(w,haydif,mq,tol) C.. Implicits .. implicit none C C.. Parametros de la funcion C Frecuencias (gradianes) real*8 w integer haydif,mq,tol C.. External Functions .. real*8 FUNC0 external FUNC0 C...Commons include 'test.i' C Locales real*8 epsilon REAL*8 pi parameter (pi = 3.14159265358979D0) C tol está en grados, lo pasamos a radianes epsilon = 2.0d0*pi*dble(tol)/360.0d0 if (IFUNC.eq. 2) then if ((w.lt.epsilon) .and.(haydif .ne.0)) then FBIS=FUNC0(epsilon) else FBIS=FUNC0(w) end if else FBIS=FUNC0(w) end if end C (January 2006-Domingo Perez) c GlobalMinim search the minimum of all local minimum that minim searchs C INPUT PARAMETERS ARE SUPPLIED BY THE CALLING PROGRAM C VIA THE COMMON BLOCK "MINIM". THEY ARE: C STEP : THE STEP LENGTH USED IN MOVING C STOP : THE CONVERGENCE PARAMETER c INPUT PARAMETERS c lb,ub: lower and upper bound to search the minimum c n_step: we try with n_step+1 different Starting value for the search C C ALSO REQUIRED IS THE FUNCTION SUBPROGRAM WHICH DEFINES THE FUNCTION C F(X) TO BE MINIMISED C C OUTPUT PARAMETER : C FMIN : THE MINIMUM OF THE FUNCTION C XMIN : THE POINT AT WHICH IT OCCURS C ICONV : 1 IF THE PROCESS HAS NOT CONVERGED, 0 OTHERWISE C C ALSO REQUIRED IS THE FUNCTION SUBPROGRAM WHICH DEFINES THE FUNCTION C F(X) TO BE MINIMISED C C OUTPUT PARAMETER : C FMIN : THE MINIMUM OF THE FUNCTION C XMIN : THE POINT AT WHICH IT OCCURS C ICONV : 1 IF THE PROCESS HAS NOT CONVERGED, 0 OTHERWISE c subroutine globalMinim(fmin,xmin,lb,ub,iconv,n_step,haydif, & mq,tol) implicit none real*8 fmin,xmin,lb,ub,fmintmp,xmintmp,hs integer iconv,n_step,haydif,mq,tol real*8 x,e_step include 'min.i' intrinsic dble fmin=10.0d20 c !that is a bigger number that the one the function can have xmin=10.0d20 c ! a bigger index to indicate no minimum e_step=(ub-lb)/dble(n_step) start=lb do while(start.le.ub) c do start=lb,ub,e_step c call minim(fmintmp,xmintmp,lb,ub,iconv) call minimbis(fmintmp,xmintmp,lb,ub,iconv,haydif,mq,tol) if (fmintmp .lt. fmin) then fmin=fmintmp xmin=xmintmp end if start=start+e_step end do end subroutine cc c cc C C C GIVEN THREE HARMONIC FUNCTIONS RT(X),T(X),S(X). C THIS SUBROUTINE FINDS U(X) AND V(X) SUCH THAT: C C RT(X)/T(X)S(X) = U(X)/T(X) + V(X)/S(X) (X=COS(KW)) C C INPUT PARAMETERS C RT : FIRST HARMONIC FUNCTION C NRT : DIMENSION OF RT C T : SECOND HARMONIC FUNCTION C T : DIMENSION OF T C S : THIRD HARMONIC FUNCTION C NS : DIMENSION OF S C U : HARMONIC FUNCTION FIRST PARTIAL FRACTION C NU : DIMENSION OF RT C V : HARMONIC FUNCTION SECOND PARTIAL FRACTION C NV : DIMENSION OF RT C subroutine PARFRA(rt,nrt,t,nt,s,ns,u,nu,v,nv) C C.. Implicits .. implicit none include 'units.cmn' C C.. Formal Arguments .. integer nrt,nt,ns,nu,nv real*8 rt(*),t(*),s(*),u(*),v(*) C C.. Local Scalars .. integer i,j,m,n,ncol,p C C.. Local Arrays .. real*8 a(60),cc(60,66) C C.. External Calls .. external CONJM, CONVM, MLTSOL C C ... Executable Statements ... C do i = 1,60 do j = 1,66 cc(i,j) = 0.0d0 end do end do m = nt - 1 n = ns - 1 p = m + n do i = 1,m a(i) = 1.0d0 end do ncol = 0 call CONVM(s,ns,a,m,cc,ncol) call CONJM(s,ns,a,m,cc,ncol) do i = 1,n a(i) = 1.0d0 end do ncol = m call CONVM(t,nt,a,n,cc,ncol) call CONJM(t,nt,a,n,cc,ncol) do i = 1,p do j = 1,p cc(i,j) = cc(i,j) / 2.0d0 end do end do do i = 1,p cc(i,p+1) = rt(i) end do i = 1 * WRITE(Ng,*)' subroutine PARFRA, call 1' call MLTSOL(cc,p,i,60,66) do i = 1,m u(i) = cc(i,p+1) end do nu = m do i = m+1,p v(i-m) = cc(i,p+1) end do nv = n end C C THIS SUBROUTINE COMPUTES THE PRODUCT OF A COLUMN ARRAY AND C B ROW ARRAY. THE OUTPUT IS THE MATRIX C C INPUT PARAMETER C A : COLUMN ARRAY (true signs) C MPLUS1 : DIMENSION OF A C B : ROW ARRAY (true signs) C NPLUS1 : DIMENSION OF C C C : OUTPUT MATRIX C NCOL : NUMBER OF FIRST COLUMNS OF C WHERE PUT THE PRODUCT C subroutine CONVM(a,mplus1,b,nplus1,c,ncol) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 a(*) C.. In/Out Status: Read, Not Written .. integer mplus1 C.. In/Out Status: Maybe Read, Not Written .. real*8 b(*) C.. In/Out Status: Maybe Read, Not Written .. integer nplus1 C.. In/Out Status: Maybe Read, Maybe Written .. real*8 c(60,66) C.. In/Out Status: Maybe Read, Not Written .. integer ncol C C.. Local Scalars .. integer i,j,num C C ... Executable Statements ... C do i = 1,mplus1 do j = 1,nplus1 num = i + j - 1 c(num,j+ncol) = c(num,j+ncol) + a(i)*b(j) end do end do end C C C C THIS SUBROUTINE COMPUTES THE INVERTIBLE MA PROCESS WITH A C GIVEN AUTOCOVARIANCE FUNCTION C C INPUT PARAMETER C C UFIN : COEFFICENTS OF (B+F) C NUFIN : DIMENSION OF UFIN C THETA : MA POLYNOMIAL C NTHETA : DIMENDION OF THETA C VAR : VARIANCE OF THE MA PROCESS C NNIO : NO UNIT ROOTS IN THE MA POLYNOMIAL C NOPRINT : NO PRINTOUT OF THE ROOTS C C subroutine MAK1(ufin,nufin,theta,ntheta,var,nnio,noprint,caption, $ lenCaption,toterr) C C C THE INPUT ARRAY UFIN IS : C C UFIN(1)=GAM(0) C UFIN(2)=2*GAM(1) C .. C .. C .. C UFIN(NUFIN)=2*GAM(NUFIN-1) C C THE PARAMETER NNIO CONTROLS THAT THE MA POLYNOMIAL HAVE NOT UNIT C ROOTS. C C IF a+bi IS |.| = 1 WE TRANSFORM IT AS FOLLOW : C C X=a/b a' = X * XL / SQRT(X^2+1) AND b = XL / SQRT(X^2 + 1) C C WHERE XL IS THE INPUT PARAMETER. C C WITH THIS TRANSFORMATION THE ARGUMENT AND PERIOD OF THE NEW ROOT IS C THE SAME OF THE OLD ONE. C C C C C.. Implicits .. implicit none C C.. INPUT PARAMETERS. integer nufin,nnio,noprint,lenCaption real*8 ufin(*) character caption*60 c OUTPUT theta(*),var integer ntheta real*8 theta(*),var,toterr C C.. Local Scalars .. integer i,ia,ib,irow,j,k,n,nroots,nrpoly,last,ContR character blan*4,two*4 real*8 a,b,gamzer,pi,temp,temp1,tol,v,vv,vw,w,ww,xeps c real*8 tmp C C.. Local Arrays .. character per(64)*4 real*8 ar(64),ar1(32),imz(64),imz1(32),modul(64),modul1(32), $ poly(34),pr(64),pr1(32),r1(2),r2(2),rez(64),rez1(32), $ rdpoly(34) complex*16 az(64),bz(64) real*8 gRez(64),gImz(64),gModul(64),gAR(64),gPR(64) character gper(64)*4 integer gCont(64),ng real*8 vn(64) integer nvn C C.. External Calls .. external MPBC, ROOTC, RPQ, SYMPOLY,ISTRLEN,grRoots,HalfRoots integer ISTRLEN C C.. Intrinsic Functions .. intrinsic ABS, ACOS, DBLE, DCMPLX, SQRT include 'stream.i' include 'unitmak.i' C LINES OF CODE ADDED FOR X-13A-S : 1 include 'error.cmn' C END OF CODE BLOCK * include 'indhtml.i' C C.. Data Declarations .. data blan/' - '/ data two/'2.0 '/ C C ... Executable Statements ... C c added line to initialize per BCM 9-19-2002 do i=1,64 per(i)=blan gRez(i)=0d0 end do pi = 3.14159265358979D0 tol = 1.0d-5 C C C SET UP THE SYMMETRIC POLYNOMIAL C gamzer = ufin(1) n = nufin do i = 1,nufin-1 poly(i) = ufin(nufin+1-i) end do poly(nufin) = ufin(1) * 2 C C FIND THE ROOTS USING RPQ C C write(*,*)' n = ',n if (n .le. 2) then rez1(1) = -poly(2)/poly(1) imz1(1) = 0.0d0 nrpoly = 2 else C WRITE(*,*)' enter SYMPOLY' call SYMPOLY(poly,n,rdpoly,nrpoly) C WRITE(*,*)' enter RPQ' call RPQ(rdpoly,nrpoly,rez1,imz1,modul1,ar1,pr1,1,noprint) C WRITE(*,*)' exit RPQ' C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK end if C C FIND THE ROOTS OF THE ORIGINAL SYMMETRIC POLYNOMIAL C k = 1 do i = 1,nrpoly-1 a = -rez1(i) b = -imz1(i) C WRITE(*,*)' enter ROOTC' call ROOTC(a,b,r1,r2) C WRITE(*,*)' exit ROOTC' temp = SQRT(r1(1)**2+r1(2)**2) temp1 = SQRT(r2(1)**2+r2(2)**2) rez(k) = r1(1) imz(k) = r1(2) modul(k) = temp if (modul(k) .lt. 1.0d-8) then ar(k) = 0.0d0 else ar(k) = rez(k) / modul(k) end if if (ABS(ar(k)) .le. 1.0d0) then ar(k) = ACOS(ar(k)) if (imz(k) .lt. 0.0d0) then ar(k) = -ar(k) end if else ar(k) = 0.0d0 if (rez(k) .lt. 0.0d0) then ar(k) = pi end if end if k = k + 1 rez(k) = r2(1) imz(k) = r2(2) modul(k) = temp1 if (modul(k) .lt. 1.0d-8) then ar(k) = 0.0d0 else ar(k) = rez(k) / modul(k) end if if (ABS(ar(k)) .le. 1.0d0) then ar(k) = ACOS(ar(k)) if (imz(k) .lt. 0.0d0) then ar(k) = -ar(k) end if else ar(k) = 0.0d0 if (rez(k) .lt. 0.0d0) then ar(k) = pi end if end if k = k + 1 end do nroots = k - 1 do i = 1,nroots if ((imz(i).gt.tol) .or. (imz(i).lt.-tol)) then pr(i) = 2.0d0 * pi / ar(i) else pr(i) = 999.99 per(i) = blan if (rez(i) .lt. 0.0d0) then per(i) = two end if end if ar(i) = 180.0d0 * ar(i) / pi end do n = k xeps = 1.0d-30 C C SELECT THE ROOTS TO FIND THE MA PROCESS C C WRITE(*,*)' enter grRoots' call grRoots(rez,imz,modul,AR,PR,Per,n-1, $ gRez,gImz,gModul,gAR,gPR,gPer,gCont,ng) C WRITE(*,*)' enter HalfRoots' call HalfRoots(gRez,gImz,gModul,gAR,gPR,gPer,gCont,ng, $ Rez1,Imz1,modul1,ar1,PR1,Per,ia) if (nnio .eq. 1) then do i = 1,ia if (ABS(modul1(i)-1.0d0) .lt. 1.0d-8) then if ((imz1(i).gt.tol) .or. (imz1(i).lt.-tol)) then temp = rez1(i) / imz1(i) rez1(i) = (temp*Xl) / SQRT(temp**2+1) imz1(i) = Xl / SQRT(temp**2+1) modul1(i) = Xl else rez1(i) = Xl modul1(i) = Xl end if end if end do end if if (noprint .ne. 1) then 7036 format (//,5x,A,/,4x, $ ' ---------------------------------------------------------') if(lenCaption.gt.0)write (Nio,7036) caption(1:lenCaption) 7000 format ( $ 3x,' REAL PART ',' IMAGINARY PART',' MODULUS ', $ ' ARGUMENT',' PERIOD') write (Nio,7000) do i = 1,ia if (imz1(i) .ge. -tol) then if (ABS(pr1(i)-999.99) .lt. 1.d-12) then 7001 format (2x,f11.3,4x,f11.3,5x,f11.3,4x,f11.3,5x,a4) write (Nio,7001) rez1(i), imz1(i), modul1(i), ar1(i), per(i) else 7002 format (2x,f11.3,4x,f11.3,5x,f11.3,4x,f11.3,1x,f11.3) write (Nio,7002) rez1(i), imz1(i), modul1(i), ar1(i), pr1(i) end if end if end do end if C C BUILD IN THE POLYNOMIAL IN B (USING MPBC) C do i = 1,64 az(i) = (0.0d0,0.0d0) bz(i) = (0.0d0,0.0d0) end do ntheta = ia + 1 if (ia .gt. 1) then az(1) = (1.0d0,0.0d0) az(2) = -DCMPLX(rez1(1),imz1(1)) bz(1) = (1.0d0,0.0d0) bz(2) = -DCMPLX(rez1(2),imz1(2)) call MPBC(az,bz,1,1,bz) if (ia .gt. 2) then do i = 2,ia-1 az(1) = (1.0d0,0.0d0) az(2) = -DCMPLX(rez1(i+1),imz1(i+1)) call MPBC(bz,az,i,1,bz) end do end if do i = 1,ntheta theta(i) = DBLE(bz(i)) end do end if if (ia .eq. 1) then theta(1) = 1.0d0 theta(2) = -rez1(1) ntheta = 2 end if C C COMPUTE THE VARIANCE C var = 0.00d0 do i = 1,ia+1 var = var + theta(i)**2 end do var = gamzer / var c Compute Toterr call CONJ(theta,ntheta,theta,ntheta,vn,nvn) toterr = 0.0d0 do i = 1,nvn toterr = toterr + (vn(i)*var-ufin(i))**2 end do if (noprint.ne.1) then if (nvn .ne. nufin) then 7034 format ( $ /,' ','THE LENGTH OF THE MA DOESN''T MATCH WITH THE ACF') write (Nio,7034) end if 7035 format (/,5x,'TOTAL SQUARED ERROR=',d15.7) write (Nio,7035) toterr end if end c c c GrRoots group roots that are equal, and put consecutive roots that are conjugate complex subroutine grRoots(rez,Imz,modul,Ar,Pr,Per,nr, $ gRez,gImz,gModul,gAr,gPr,gPer,gCont,ng) implicit none real*8 Xeps parameter(Xeps=1.0D-13) c INPUT real*8 rez(64),Imz(64),modul(64),Ar(64),Pr(64) character Per(64)*4 integer nr c OUTPUT real*8 gRez(64),gImz(64),gModul(64),gAr(64),gPr(64) character gPer(64)*4 integer gCont(64),ng c EXTERNAL intrinsic abs integer getRoot,getRootc,closestRoot external getRoot,getRootc,closestRoot c Local variables integer i,ni,ic,i2 real*8 Xeps2 c ng=0 i=1 do while(i .le. nr) if (abs(modul(i)-1.0d0).lt.xeps) then xeps2=1.0D-30 else xeps2=1.0D-30 end if ni=getRoot(gRez,gImz,ng,rez(i),Imz(i),xeps2) if (ni .gt. 0) then gCont(ni)=gCont(ni)+1 else ng=ng+1 gRez(ng)=Rez(i) gImz(ng)=Imz(i) gModul(ng)=Modul(i) gAR(ng)=AR(i) gPr(ng)=Pr(i) gPer(ng)=Per(i) gCont(ng)=1 if (abs(Imz(i)).gt.xeps2) then c The root is complex, we search the conjugate complex iC=getRootc(Rez,Imz,i+1,nr,rez(i),-imz(i),xeps2) if (ic.eq.0) then c ERROR not found conjugate complex root ic=ic else ng=ng+1 gRez(ng)=Rez(ic) gImz(ng)=Imz(ic) gModul(ng)=Modul(ic) gAR(ng)=AR(ic) gPR(ng)=PR(ic) gPer(ng)=Per(ic) c !We will increment later when i reach Ic gCont(ng)=0 end if else c !We suppose is 0.0 Imz(i) is too close to 0.0 gIMz(ng)=0.0d0 end if end if i=i+1 enddo c NOW we avoid single unit roots i=1 do while(i.lt.ng) if ((gCont(i).eq.1).and.(abs(gmodul(i)-1.0d0).lt.Xeps)) then i2=closestRoot(gRez,gImz,gModul,i+1,ng,gRez(i),gImz(i),Xeps) call JoinRoot(gRez,gImz,gModul,gAR,gPr,gPer,gCont,ng,i,i2) end if i=i+1 enddo end c c c getRoot return an index to the arrays Rez,Img c so [Rez(getRoot),Imz(getroot)]=[realr,imagr] integer function getRoot(Rez,Imz,nr,realr,imagr,Xeps) implicit none c INPUT real*8 Xeps real*8 Rez(*),Imz(*),realr,imagr integer nr c LOCAL integer i c i=1 do while (i.le.nr) if ((abs(Rez(i)-realr) .le.xeps) .and. $ (abs(imz(i)-imagr).le.Xeps)) then getRoot=i return else i=i+1 end if enddo getRoot=0 !Root Not FOUND end c c c getRootc return an index to the arrays Rez,Img c so [Rez(getRoot),Imz(getroot)]=[realr,imagr] c we begin searching from the last integer function getRootc(Rez,Imz,ni,nr,realr,imagr,Xeps) implicit none c INPUT real*8 Xeps real*8 Rez(*),Imz(*),realr,imagr integer ni,nr c LOCAL integer i c i=nr do while (i.ge.ni) if ((abs(Rez(i)-realr) .le.xeps) .and. $ (abs(imz(i)-imagr).le.Xeps)) then getRootc=i return else i=i-1 end if enddo getRootc=0 !Root Not FOUND end c c ClosestRoot find the closest root to a given one integer function closestRoot(gRez,gImz,gModul,ni,ng, $ Realz,Imagz,Xeps) c INPUT real*8 gRez(*),gImz(*),gModul(*),Realz,Imagz,Xeps integer ng,ni,nr c LOCAL VARIABLES real*8 XepsRec,Xeps2,mindist,dist integer i,i2 c EXTERNAL * integer getRootM * external getRootM c i2=0 minDist=1.0d10 do i=ni,ng dist=(gRez(i)-Realz)*(gRez(i)-Realz)+ $ (gImz(i)-Imagz)*(gImz(i)-Imagz) if (dist.lt.mindist) then i2=i mindist=dist end if enddo ClosestRoot=i2 end c c JOINROOT join to roots in one subroutine JoinRoot(gRez,gImz,gModul,gAr,gPr,gPer,gCont,ng, $ ni,ni2) C INPUT integer ni,ni2 c INPUT&OUTPUT real*8 gRez(64),gImz(64),gModul(64),gAr(64),gPr(64),pi character gPer(64)*4 integer gCont(64),ng c External intrinsic SQRT,ATAN c LOCAL VARIABLES real*8 SUMgCont,m integer i c c pi = 3.14159265358979d0 SUMgCont=gCont(ni)+gCont(ni2) gModul(ni)=(gModul(ni)*gModul(ni2)) gRez(ni)=(gRez(ni)*gCont(ni)+gRez(ni2)*gCont(ni2))/SUMgcont gImz(ni)=(gImz(ni)*Gcont(ni)+gImz(ni2)*gCont(ni2))/SUMgcont gCont(ni)=SUMgCont m=gRez(ni)*gRez(ni)+gImz(ni)*gImz(ni) m=SQRT(gModul(ni)/m) gRez(ni)=gRez(ni)*m gImz(ni)=gImz(ni)*m gModul(ni)=SQRT(gModul(ni)) if (gRez(ni).gt.0.0D0) then gAR(ni)=(atan(gImz(ni)/gRez(ni))*180.0D0)/PI else if (gRez(ni).lt.0.0D0) then gAR(ni)=180.0D0+(atan(gImz(ni)/gRez(ni))*180.0D0)/PI if (gAR(ni).gt.180.0D0) gAR(ni)=180.0D0-gAR(ni) else if (gImz(ni).gt.0.0D0) then gAR(ni)=90.0D0 else gAR(ni)=-90.0D0 end if if (gAR(ni).ne.0.0D0) then gPR(ni)=360/gAR(ni) else gPR(ni)=999.99 end if ng=ng-1 do i=ni2,ng gRez(i)=gRez(i+1) gImz(i)=gImz(i+1) gModul(i)=gModul(i+1) gAR(i)=gAR(i+1) gPR(i)=gPR(i+1) gPer(i)=gPer(i+1) gCont(i)=gCont(i+1) enddo end c c c c c c HalfRoots: given the roots of a simetrical polynomial S(B,F) grouped by grRoots, c return the roots without grouping that generate a polynomial P(B) c that fullfil P(B)P(F)=S(B,F) c subroutine halfRoots(gRez,gImz,gModul,gAr,gPr,gPer,gCont,ng, $ rez,imz,modul,ar,pr,per,nr) implicit none real*8 Xeps parameter (Xeps=1.0D-13) c INPUT real*8 gRez(64),gImz(64),gModul(64),gAr(64),gPr(64) character gPer(64)*4 integer gCont(64),ng c OUTPUT real*8 rez(32),imz(32),modul(32),ar(32),pr(32) character per(32)*4 integer nr c LOCAL VARIABLES integer i,j,nRep,k real*8 xeps2 c xeps2=1.0D-10 i=1 j=1 do while (i.le.ng) if (abs(gmodul(i)-1).lt.Xeps) then nRep=gCont(i)/2 if (gCont(i).eq.1) then if (i.ge.ng) then c ERROR i=i else if ((gCont(i+1).eq.1).and. $ (abs(gModul(i+1)-1.0d0).lt.xeps)) then i=i+1 if (gRez(i).gt.0.0) then Rez(j)=gModul(i) Imz(j)=0.0d0 modul(j)=gModul(i) per(j)=gper(i) PR(j)=999.0D0 AR(j)=180.0d0 else Rez(j)=-gModul(i) Imz(j)=0.0d0 modul(j)=gModul(i) per(j)=gper(i) PR(j)=2.0d0 AR(j)=0.0d0 end if j=j+1 c else c !ERROR end if end if else if (gmodul(i) .lt. 1.0d0) then nRep=gCont(i) else nRep=0 end if do k=1,nRep Rez(j)=gRez(i) Imz(j)=gImz(i) Modul(j)=gModul(i) AR(j)=gAR(i) PR(j)=gPR(i) Per(j)=gPer(i) j=j+1 if ((abs(gImz(i)).gt.xeps2).and. $ (abs(grez(i)-grez(i+1)).lt.xeps2)) then c if (gCont(i).ne.gCont(i+1)) then c !ERROR c end if Rez(j)=gRez(i+1) Imz(j)=gImz(i+1) Modul(j)=gModul(i+1) AR(j)=gAR(i+1) PR(j)=gPR(i+1) Per(j)=gPer(i+1) j=j+1 end if enddo if ((abs(gImz(i)).gt.xeps2) .and. $ (abs(grez(i)-grez(i+1)).lt.Xeps2) .and. (nRep.gt.0)) then i=i+2 !We junk the conjugate complex root else i=i+1 end if enddo nr=j-1 end C C C THIS SUBROUTINE COMPUTES THE PRODUCT OF TWO HARMONIC FUNCTION C A COLUMN ARRAY AND B ROW ARRAY THE OUTPUT IS THE MATRIX C. C INPUT PARAMETER C A : COLUMN ARRAY (true signs) C MPLUS1 : DIMENSION OF A C B : ROW ARRAY (true signs) C NPLUS1 : DIMENSION OF C C C : OUTPUT MATRIX C NCOL : NUMBER OF FIRST COLUMNS OF C WHERE PUT THE PRODUCT C C C subroutine CONJM(a,mplus1,b,nplus1,c,ncol) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 a(*) C.. In/Out Status: Read, Not Written .. integer mplus1 C.. In/Out Status: Maybe Read, Not Written .. real*8 b(*) C.. In/Out Status: Maybe Read, Not Written .. integer nplus1 C.. In/Out Status: Maybe Read, Maybe Written .. real*8 c(60,66) C.. In/Out Status: Maybe Read, Not Written .. integer ncol C C.. Local Scalars .. integer i,j,k,num C C.. Intrinsic Functions .. intrinsic ABS C C ... Executable Statements ... C do i = 1,mplus1 do j = 1,nplus1 k = i - j num = ABS(k) + 1 c(num,j+ncol) = c(num,j+ncol) + a(i)*b(j) end do end do end C C C THIS SUBROUTINE COMPUTES THE PRODUCT OF TWO POLYNOMIALS IN B C WITH COMPLEX COEFFICIENT C=A*B C INPUT PARAMETERS C A : FIRST POLYNOMIAL (true signs) A(1) + A(2)*X + ... + C A(N)*X^(N-1) C B : SECOND POLYNOMIAL (true signs) " " " " C N : DIMENSION OF A C M : DIMENSION OF B C E : THE PRODUCT A * B C subroutine MPBC(a,b,n,m,e) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Read, Not Written .. integer m C.. In/Out Status: Maybe Read, Not Written .. complex*16 a(0:n) C.. In/Out Status: Maybe Read, Not Written .. complex*16 b(0:m) C.. In/Out Status: Maybe Read, Maybe Written .. complex*16 e(0:n+m) C C.. Local Scalars .. integer i,j,k C C.. Local Arrays .. complex*16 aa(0:100),bb(0:100) C C ... Executable Statements ... C do i = 0,m bb(i) = b(i) end do do i = 0,n aa(i) = a(i) end do do i = 0,n+m e(i) = (0.0d0,0.0d0) end do do i = 0,n do j = 0,m k = i + j e(k) = e(k) + aa(i)*bb(j) end do end do end C C THIS SUBROUTINE REDUCES A SYMMETRIC POLYNOMIAL WITH n COEFFICIENTS C TO A POLYNOMIAL OF n/2 COEFFICIENTS.( USED IN MAK; SEE DOCUMENTATION.) C C INPUT PARAMETER C POLY : THE ORIGINAL SYMMETRIC POLYNOMIAL WITH n COEFFICIENTS C NPOLY : DIMENSION OF POLY C RdPOLY : THE SIMPLIFIED POLYNOMIAL WITH n/2 COEFFICIENTS C NRPOLY : DIMENSION OF RPOLY C subroutine SYMPOLY(poly,npoly,rdpoly,nrpoly) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer npoly C.. In/Out Status: Maybe Read, Not Written .. real*8 poly(npoly) C.. In/Out Status: Not Read, Maybe Written .. real*8 rdpoly(34) C.. In/Out Status: Not Read, Overwritten .. integer nrpoly C C.. Local Scalars .. integer i,j,ns0,ns1,ns2 real*8 temp C C.. Local Arrays .. real*8 poly1(64),s(64,64),s0(64),s1(64),s2(64) C C ... Executable Statements ... C s0(1) = 2 ns0 = 1 s1(1) = 0 s1(2) = 1 ns1 = 2 do i = 1,npoly do j = 1,npoly s(i,j) = 0.0d0 end do end do s(1,1) = 1 s(2,2) = 1 do i = 3,npoly s2(1) = 0.0d0 do j = 2,ns1+1 s2(j) = s1(j-1) end do ns2 = ns1 + 1 s0(ns0+1) = 0.0d0 s0(ns0+2) = 0.0d0 ns0 = ns0 + 2 do j = 1,ns2 s2(j) = s2(j) - s0(j) end do do j = 1,ns2 s(j,i) = s2(j) end do do j = 1,ns1 s0(j) = s1(j) end do do j = 1,ns2 s1(j) = s2(j) end do ns1 = ns2 end do do i = 1,npoly poly1(npoly+1-i) = poly(i) end do do i = 1,npoly temp = 0.0d0 do j = 1,npoly temp = temp + s(i,j)*poly1(j) end do rdpoly(npoly+1-i) = temp end do nrpoly = npoly end C C THIS SUBROUTINE COMPUTES THE SQUARE ROOT OF A COMPLEX NUMBER C C INPUT PARAMETERS C REZ : REAL PART OF COMPLEX NUMBER C IMZ : IMAGINARY PART OF COMPLEX NUMBER C REZ1 : REAL PART OF SQUARE ROOT C IMZ1 : IMAGINARY PART OF SQUARE ROOT C C C subroutine SQROOTC(rez,imz,rez1,imz1) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. real*8 rez C.. In/Out Status: Read, Not Written .. real*8 imz C.. In/Out Status: Not Read, Overwritten .. real*8 rez1 C.. In/Out Status: Not Read, Overwritten .. real*8 imz1 C C.. Local Scalars .. real*8 temp C C.. Intrinsic Functions .. intrinsic ABS, SQRT C C ... Executable Statements ... C if (rez .ge. 0.0d0) then temp = SQRT((rez**2)+(imz**2)) rez1 = SQRT((rez+temp)/2.0d0) if (ABS(rez1) .lt. 1.0d-8) then imz1 = 0.0d0 else imz1 = imz / (2.0d0*rez1) end if else temp = SQRT((rez**2)+(imz**2)) if (imz .gt. 0.0d0) then imz1 = SQRT((ABS(rez)+temp)/2.0d0) else imz1 = -SQRT((ABS(rez)+temp)/2.0d0) end if if (ABS(imz1) .lt. 1.0d-8) then rez1 = 0.0d0 else rez1 = imz / (2.0d0*imz1) end if end if end c C C CubicRoot return the cubic root of a given complex number (rX+i*iX)=(rY+iY)^3 C if the number is real we will return a real root Subroutine CubicRoot(rX,iX,rY,iY) implicit none C INPUT real*8 rX,iX c OUTPUT real*8 rY,iY c LOCAL VARIABLES real*8 w,m,s,c c EXTERNAL FUNCTIONS real*8 ARG external ARG intrinsic ABS,SQRT,SIN,COS c if (iX.eq.0.0D0) then iY=0.0D0 rY=abs(rX)**(1.0D0/3.0D0) if (rX.lt.0.0D0) then rY=-rY end if else w=arg(rX,iX) m=rX*rX+iX*iX rY=(m**(1.0D0/6.0D0))*cos(w/3.0D0) iY=(m**(1.0D0/6.0D0))*sin(w/3.0D0) end if end c c ARG return the argument of a complex number rX+i*iX=sqrt(rX*rX+iX*iX)*exp(i*arg) real*8 function Arg(rX,iX) implicit none real*8 pi parameter(pi=3.14159265358979D0) c INPUT real*8 rX,iX intrinsic ABS,atan c if (rX .gt. 0.0D0) then arg=atan(iX/rX) else if (rX.lt.0.0D0) then arg=pi-abs(atan(iX/rX)) else if (iX.gt.0.0D0) then arg=pi/2 else arg=-pi/2 end if end c c MulCompl multiply two complex numbers subroutine MulCompl(rX,iX,rY,iY,rZ,iZ) implicit none c INPUT real*8 rX,iX,rY,iY c OUTPUT real*8 rZ,iZ rZ=rX*rY-iX*iY iZ=rX*iY+rY*iX end c c DivCompl divide two complex numbers subroutine DivCompl(rX,iX,rY,iY,rZ,iZ) implicit none c INPUT real*8 rX,iX,rY,iY c OUTPUT real*8 rZ,iZ c LOCAL real*8 m2 m2=rY*rY+iY*iY rZ=(rX*rY+iX*iY)/m2 iZ=(iX*rY-iY*rX)/m2 end C C THIS SUBROUTINE COMPUTES THE COMPLEX ROOTS OF A SECOND ORDER EQUATION C WITH COMPLEX COEFFICIENT OF THE FOLLOWING TYPE : C (X^2 + (REZ,IMZ) * X + 1) = 0 C C INPUT PARAMETERS C REZ : REAL PART OF THE SECOND COEFFICIENT OF EQUATION C IMZ : IMAGINARY PART OF THE SECOND COEFFICIENT OF EQUATION C R1 : (R1(1) REAL R1(2) IMAGINARY) FIRST SOLUTION C R2 : (R2(1) REAL R2(2) IMAGINARY) SECOND SOLUTION C subroutine ROOTC(rez,imz,r1,r2) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. real*8 rez C.. In/Out Status: Read, Not Written .. real*8 imz C.. In/Out Status: Not Read, Maybe Written .. real*8 r1(2) C.. In/Out Status: Not Read, Maybe Written .. real*8 r2(2) C C.. Local Scalars .. real*8 a,b,delta,deltai C C.. External Calls .. external SQROOTC C C ... Executable Statements ... C delta = (rez**2) - (imz**2) - 4.0d0 deltai = 2.0d0 * rez * imz call SQROOTC(delta,deltai,a,b) r1(1) = (-rez+a) / 2.0d0 r1(2) = (-imz+b) / 2.0d0 r2(1) = (-rez-a) / 2.0d0 r2(2) = (-imz-b) / 2.0d0 end C C C C THIS SUBROUTINE SOLVES UP TO 6 SETS OF EQUATIONS BY INVERTING THE C SPARSE MATRIX A. NOTE: A**(-1) IS NOT STORED C C INPUT PARAMETERS C A : THE MATRIX WITH THE SET OF EQUATIONS C N : DIMENSION OF THE SET IN A C L : NUMBER OF SET OF EQUATIONS C C subroutine MLTSOL(a,n,l,pr,pc) C C.. Implicits .. implicit none include 'units.cmn' C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Read, Not Written .. integer l,pr,pc C.. In/Out Status: Maybe Read, Maybe Written .. c real*8 a(n,n+l) real*8 a(pr,pc) C C.. Local Scalars .. integer i,i1,irev,j,k,n1,nl real*8 fac,pivot,u,min1,min2 * logical ldebug C C.. Local Arrays .. integer m(66) real*8 b(60) C C.. Intrinsic Functions .. intrinsic ABS C C ... Executable Statements ... C min1=10.d0**(-15.d0) min2=0-min1 * ldebug = .true. nl = n + l do k = 1,nl m(k) = 0 end do do irev = 1,n i = n - irev + 1 u = 10.d-30 do k = 1,n if (ABS(a(i,k)).gt.u .and. m(k).eq.0) then u = ABS(a(i,k)) i1 = k end if end do m(i1) = i pivot = 1 / a(i,i1) if (pivot.ge.min2 .and. pivot.le.min1) then pivot = 0.0d0 end if * if (ldebug) then * write(Ng,*)' i = ',i,' n = ',n,' irev = ', irev, * & ' pivot = ',pivot * end if do j = 1,n if (j .ne. i) then if (ABS(a(j,i1)) .ge. 1.0d-13) then fac = pivot * a(j,i1) do k = 1,nl if (a(i,k).ge.min2 .and. a(i,k).le.min1) then * if (ldebug) then * write(Ng,*)' a(',i,',',k,') = ',a(i,k) * end if a(i,k) = 0.0d0 else if (m(k) .eq. 0) then * if (ldebug) then * write(Ng,*)' a(',j,',',k,') = ',a(j,k), ' fac = ', fac, * $ ' a(',i,',',k,') = ',a(i,k), ' m(k) = ', m(k) * end if a(j,k) = a(j,k) - fac*a(i,k) * else * if (ldebug) then * write(Ng,*)' a(',j,',',k,') = ',a(j,k), ' m(k) = ', m(k) * end if end if end if end do end if end if end do do k = 1,nl if (m(k) .eq. 0) then * if (ldebug) then * write(Ng,*)' a(',i,',',k,') = ',a(i,k), ' m(k) = ', m(k) * end if a(i,k) = pivot * a(i,k) end if end do * if (ldebug) then * write(Ng,*)' ----- ' * end if end do n1 = n + 1 do k = n1,nl do i1 = 1,n if (m(i1) .ne. 0) then b(i1) = a(m(i1),k) else b(i1)=0 end if end do do i1 = 1,n a(i1,k) = b(i1) end do end do end C C C C LINES OF CODE COMMENTED FOR X-13A-S : 1 C subroutine TABLE(data,decp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 subroutine TABLE2(datax) C END OF CODE BLOCK C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 datax(*) C.. In/Out Status: Read, Overwritten .. C C.. Local Scalars .. integer i,i1,i2,ifact,j,jfact,kfreq,ndecp,nnper,ny,nyr integer*4 yr integer*4 decp real*8 sum,zz C C.. Local Arrays .. character fdecp1(7)*8,fn1(12)*8,fn2(12)*8,mth(12)*4,srt(11)*4, $ srt0(4)*4,srt1(6)*4,wrt0(8)*8,wrt2(7)*8,wrt99(7)*8 C C.. Intrinsic Functions .. intrinsic ABS, INT, LOG10 include 'sform.i' include 'stream.i' C C.. Data Declarations .. data mth/ $ 'JAN ','FEB ','MAR ','APR ','MAY ','JUN','JUL','AUG ','SEP', $ 'OCT ','NOV ','DEC '/ data srt/ $ '1ST','2ND','3RD','4TH','5TH','6TH','7TH','8TH','9TH','10TH', $ '11TH'/ data srt0/'1ST','2ND','1ST','2ND'/ data srt1/'1ST','2ND','3RD','1ST','2ND','3RD'/ data wrt2/'(1H ,I4,','N2','X,','N1','(F10','.DECP','))'/ data wrt0/ $ '(1H ,I4,','''-'',I4,','N2','X,','N1','(F10','.DECP','))'/ data wrt99/'(/,1X,','''YEAR''','2X,','N2','(6X,','A4','))'/ data fdecp1/'.0','.1','.2','.3','.4','.5','.6'/ data fn1/'1','2','3','4','5','6','7','8','9','10','11','12'/ data fn2/ $ '2','12','22','32','42','52','62','72','82','092','102','112' $ / C C ... Executable Statements ... C decp = 3 kfreq = Nfreq if (kfreq .lt. 4) then if (Nfreq .eq. 3) then kfreq = 6 else kfreq = 4 end if end if nnper = Nper if (Nper .gt. Nfreq) then Nper = Nfreq else if (Nper .eq. 0) then Nper = 1 end if ndecp = decp if (decp .ge. 6) then decp = 6 end if C 250 IF (DECP.NE.0) THEN C MDECP=10-DECP C A=0.00999999*10**MDECP C DO 151 I=1,NZ C IF(DATAx(I).LT.A) GO TO 151 C DECP=DECP-1 C 151 CONTINUE C end if C 251 CONTINUE ifact = 0 zz = LOG10(ABS(datax(1))+.0000000001d0) sum = ABS(zz) do i = 2,Nz if (zz .gt. 0.0d0) then sum = 0.0d0 goto 5000 else zz = LOG10(ABS(datax(i))+.0000000001d0) if ((ABS(zz).lt.sum) .and. (zz.lt.0.0d0)) then sum = ABS(zz) end if end if end do 5000 if (zz .gt. 0.0d0) then sum = 0.0d0 end if if (sum .gt. 1.0d0) then ifact = INT(sum) if (ifact .gt. 6) then ifact = 6 end if if (ifact .gt. 0) then write (Nio,'(4X, ''X 10.0D'',I2,/)') -ifact end if end if jfact = 0 zz = LOG10(ABS(datax(1))+.0000000001d0) sum = zz do i = 2,Nz zz = LOG10(ABS(datax(i))+.0000000001d0) if ((zz.gt.sum) .and. (zz.gt.0.0d0)) then sum = zz end if end do if (sum .gt. 4.0d0) then jfact = INT(sum) - 2 if (jfact .gt. 0) then write (Nio,'(4X, ''X 10.0D'',I2,/)') jfact end if end if yr = Nyer if (Nfreq .eq. 12) then 7000 format (/,1x,'YEAR',2x,12(6x,a4)/) write (Nio,7000) (mth(i), i = 1,12) C ELSE IF (NFREQ.EQ.4) THEN C WRITE(NIO,2002) (QRT(I),I=1,4) C ELSE IF (NFREQ.EQ.6) THEN C WRITE(NIO,2003) (SRT(I),I=1,6) else if (Nfreq .eq. 3) then 7001 format (/,3x,'YEAR',5x,6(6x,a4)/) write (Nio,7001) (srt1(i), i = 1,6) else if (Nfreq .eq. 2) then 7002 format (/,3x,'YEAR',5x,4(6x,a4)/) write (Nio,7002) (srt0(i), i = 1,4) else if (Nfreq .eq. 1) then write (Nio,7002) (srt(i), i = 1,4) else wrt99(4) = fn1(Nfreq) write (Nio,wrt99) (srt(i), i = 1,Nfreq) end if nyr = (Nz-(Nfreq-Nper+1)) / Nfreq ny = (Nz-(Nfreq-Nper+1)) - nyr*Nfreq if (ny .ne. 0) then nyr = nyr + 1 end if nyr = nyr + 1 wrt2(6) = fdecp1(decp+1) do i = 1,nyr i1 = (i-1)*kfreq - (Nper-2) i2 = i*kfreq - (Nper-1) if (i2 .ge. Nz) then i2 = Nz end if if (Nfreq .ge. 4) then wrt2(2) = fn2(1) wrt2(4) = fn1(kfreq) else wrt0(3) = fn2(1) wrt0(5) = fn1(kfreq) wrt0(7) = fdecp1(decp+1) end if if (i .eq. 1) then if (Nfreq .ge. 4) then wrt2(4) = fn1(kfreq-Nper+1) wrt2(2) = fn2(Nper) else wrt0(3) = fn2(Nper) wrt0(5) = fn1(kfreq-Nper+1) end if i1 = 1 end if if (Nfreq .lt. 4) then if (ifact .gt. 0) then write (Nio,wrt0) $ yr, (yr+kfreq/Nfreq-1), $ (datax(j)*(10.0d0**ifact), j = i1,i2) else write (Nio,wrt0) $ yr, (yr+kfreq/Nfreq-1), $ (datax(j)*(10.0d0**(-jfact)), j = i1,i2) end if else if (ifact .gt. 0) then write (Nio,wrt2) yr, (datax(j)*(10.0d0**ifact), j = i1,i2) else write (Nio,wrt2) yr, (datax(j)*(10.0d0**(-jfact)), j = i1,i2) end if if (Nfreq .lt. 4) then yr = yr + kfreq/Nfreq else yr = yr + 1 end if if (i2 .ge. Nz) goto 5001 end do 5001 decp = ndecp Nper = nnper end C C FUNCTION TO COMPUTE THE MEAN OF X SERIES C double precision function DMEAN(n,x) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Maybe Read, Not Written .. real*8 x(*) C C.. Local Scalars .. integer i C C ... Executable Statements ... C DMEAN = 0.0d0 do i = 1,n DMEAN = DMEAN + x(i) end do DMEAN = DMEAN / dble(n) end C C ALL THE FOLLOWING SUBROUTINES AND FUNCTIONS COMPUTE THE ROOTS OF A C REAL POLYNOMIAL C subroutine C02AEF(a,n,rez,imz,tol,ifail) C THIS ROUTINE ATTEMPTS TO SOLVE A REAL POLYNOMIAL EQUATION C HAVING N COEFFICIENTS (DEGREE EQUALS N-1) USING THE SEARCH C ALGORITHM PROPOSED IN GRANT AND HITCHINS (1971) TO C LIMITING MACHINE PRECISION. ON ENTRY THE COEFFICIENTS C OF THE POLYNOMIAL ARE HELD IN THE ARRAY A(N), WITH A(0) C HOLDING THE COEFFICIENT OF THE HIGHEST POWER. ON NORMAL C ENTRY THE PARAMETER IFAIL HAS VALUE 0 (HARD FAIL) OR 1 C (SOFT FAIL) AND WILL BE ZERO ON SUCCESFUL EXIT WITH C THE CALCULATED ESTIMATES OF THE ROOTS HELD AS C REZ(K)+I*IMZ(K), K EQUALS N-1, IN APPROXIMATE DECREASING C ORDER OF MODULUS. THE VALUE OF TOL IS OBTAINED BY C CALLING THE ROUTINE X02AJF. C ABNORMAL EXITS WILL BE INDICATED BY IFAIL HAVING C VALUE 1 OR 2. THE FORMER IMPLIES THAT EITHER A(1) EQUALS 0 C OR N.LT.2 OR N.GT.100. FOR IFAIL EQUALS 2, A POSSIBLE C SADDLE POINT HAS BEEN DETECTED. THE NUMBER OF COEFFICIENTS C OF THE REDUCED POLYNOMIAL IS STORED IN N AND ITS C COEFFICIENTS ARE STORED IN A(1) TO A(N), THE ROOTS C THUS FAR BEING STORED IN THE ARRAYS REZ AND IMZ C STARTING WITH REZ(N)+I*IMZ(N). AN IMMEDIATE RE-ENTRY C IS POSSIBLE WITH IFAIL UNCHANGED AND WITH A NEW C STARTING POINT FOR THE SEARCH HELD IN REZ(1)+IIMZ(1). C REF - J.I.M.A., VOL.8., PP122-129 (1971). C .. Parameters .. C C.. Implicits .. implicit none C C.. Parameters .. character srname*6 parameter (srname='C02AEF') C C.. Formal Arguments .. C.. In/Out Status: Read, Maybe Written .. integer n C.. In/Out Status: Maybe Read, Maybe Written .. double precision a(n) C.. In/Out Status: Maybe Read, Maybe Written .. double precision rez(n) C.. In/Out Status: Maybe Read, Maybe Written .. double precision imz(n) C.. In/Out Status: Read, Maybe Written .. double precision tol C.. In/Out Status: Read, Overwritten .. integer ifail C C.. Local Scalars .. integer i,i2,ii,ind,jtemp,k,jj logical cbig,flag double precision a1p5,cmax,fac,four,fun,g,nfun,one,p1,p2z1,p3z2, $ p4z1,p5,s,s1,s2,scale,sig,t,tol2,two,xxx,zero C C.. Local Arrays .. character p01rec(1) double precision b(100),c(100) C C.. External Functions .. integer P01ABF double precision X02AJF double precision X02ALF external P01ABF, X02AJF, X02ALF C C.. External Calls .. external C02AEZ,tartaglia C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C.. Intrinsic Functions .. intrinsic ABS, DBLE, INT, LOG, SQRT include 'ac02ae.i' C LINES OF CODE ADDED FOR X-13A-S : 2 DOUBLE PRECISION zzz include 'error.cmn' C END OF CODE BLOCK C C.. Data Declarations .. C .. Data statements .. data one/1.0d0/ a1p5/1.5d0/ zero/0.0d0/ p4z1/1.0d-5/ data two/2.0d0/ p5/0.5d0/ p2z1/1.0d-3/ p1/0.1d0/ data p3z2/2.0d-4/ four/4.0d0/ C .. Executable Statements .. xxx = X02AJF() if (tol .lt. xxx) then tol = xxx end if C THE ABOVE TEST WAS ADDED AT 4.5 TO PREVENT TOL BEING TOO C SMALL C LINES OF CODE COMMENTED FOR X-13A-S : 1 C cmax = SQRT(X02ALF()) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 ZZZ = X02ALF() CMAX = SQRT(ZZZ) C END OF CODE BLOCK fac = one flag = ifail .eq. 2 if (flag) then ifail = 1 end if ind = 0 tol2 = tol**a1p5 if ( c $(ABS(a(1)-zero).gt.1.d-15) .and. $ (n.ge.2) .and. (n.le.100)) then do while (dpeq(a(n), 0.d0) .and. n.ge.2) rez(n-1) = zero imz(n-1) = zero n = n - 1 end do do while (.true.) scale = zero do i = 1,n if (ABS(a(i)) .ge. p4z1) then scale = scale + LOG(ABS(a(i))) end if end do k = INT(scale/(DBLE(n)*LOG(two))+p5) scale = two**(-k) do i = 1,n a(i) = a(i) * scale b(i) = a(i) C write(*,*)'a(',i,'),b(',i,'),scale=',a(i),b(i),scale end do C write(*,*)'TEST FOR LOW ORDER POLYNOMIAL FOR EXPLICIT SOLUTION' C TEST FOR LOW ORDER POLYNOMIAL FOR EXPLICIT SOLUTION c write(*,*)' n = ', n if (n .le. 3) then goto (5009,5005,5006) n goto 5000 5005 rez(1) = -a(2)/a(1)*fac imz(1) = zero goto 5007 end if 5000 do 10 while (.true.) c write(*,*)' top of while loop 1' do i = 2,n ii = n - i + 2 C write(*,*)'b(',ii,')=',b(ii) if (dpeq(b(ii), 0.0d0)) goto 5001 t = b(1) / b(ii) C write(*,*)'b(1),t=',b(1),t if (ABS(t) .ge. one) goto 5001 do k = 2,ii i2 = ii - k + 1 c(k-1) = b(k) - t*b(i2) end do jtemp = ii - 1 do k = 1,jtemp b(k) = c(k) end do end do fac = fac * two scale = one jj = n do while (.true.) C write(*,*)' top of while loop 2, jj = ',jj jj = jj - 1 if (jj .lt. 1) goto 10 scale = scale * two a(jj) = a(jj) * scale b(jj) = a(jj) end do 10 continue 5001 if (.not. flag) then X = p2z1 Y0 = p1 else X = rez(1) Y0 = imz(1) + tol flag = .false. end if call C02AEZ(a,n,tol) fun = R*R + J*J do while (.true.) g = Rx*Rx + Jx*Jx if (g .lt. fun*tol2) goto 5008 s1 = -(R*Rx+J*Jx)/g s2 = (R*Jx-J*Rx) / g sig = p3z2 s = SQRT(s1*s1+s2*s2) if (s .gt. one) then s1 = s1 / s s2 = s2 / s sig = sig / s end if C WRITE(*,*)'VALID DIRECTION OF SEARCH HAS BEEN DETERMINED' C VALID DIRECTION OF SEARCH HAS BEEN DETERMINED, NOW C PROCEED TO DETERMINE SUITABLE STEP X = X + s1 Y0 = Y0 + s2 do while (.true.) call C02AEZ(a,n,tol) if (Sat) goto 5003 nfun = R*R + J*J if (fun-nfun .ge. sig*fun) goto 5002 s1 = p5 * s1 s2 = p5 * s2 if (ABS(s1).le.xxx*ABS(X) .and. ABS(s2).le.xxx*ABS(Y0)) $ goto 5008 s = p5 * s sig = p5 * sig X = X - s1 Y0 = Y0 - s2 end do 5002 fun = nfun end do 5003 fun = one / tol2 k = 0 imz(n-1) = Y0 * fac if (ABS(Y0) .le. p1) then C WRITE(*,*)'CHECK POSSIBILITY OF REAL ROOT' C CHECK POSSIBILITY OF REAL ROOT s1 = Y0 Y0 = zero call C02AEZ(a,n,tol) Y0 = s1 if (Sat) then C WRITE(*,*)'REAL ROOT ACCEPTED AND BOTH BACKWARD AND FORWARD ' C REAL ROOT ACCEPTED AND BOTH BACKWARD AND FORWARD DEFLATIONS C ARE PERFORMED WITH LINEAR FACTOR rez(n-1) = X * fac imz(n-1) = zero n = n - 1 b(1) = a(1) c(n) = -a(n+1)/X cbig = .false. do 15 i = 2,n b(i) = a(i) + X*b(i-1) ii = n - i + 1 if (.not. cbig) then c(ii) = (c(ii+1)-a(ii+1)) / X if (ABS(c(ii)) .le. cmax) goto 15 cbig = .true. end if c(ii) = cmax 15 continue goto 5004 end if end if C WRITE(*,*)'COMPLEX ROOT ACCEPTED AND BOTH BACKWARD AND FORWARD' C COMPLEX ROOT ACCEPTED AND BOTH BACKWARD AND FORWARD C DEFLATIONS ARE PERFORMED WITH QUADRATIC FACTOR rez(n-1) = X * fac rez(n-2) = X * fac imz(n-2) = -imz(n-1) n = n - 2 R = two * X J = -(X*X+Y0*Y0) b(1) = a(1) b(2) = a(2) + R*b(1) c(n) = -a(n+2)/J c(n-1) = -(a(n+1)+R*c(n))/J if (n .ne. 2) then cbig = .false. do 20 i = 3,n b(i) = a(i) + R*b(i-1) + J*b(i-2) ii = n - i + 1 if (.not. cbig) then c(ii) = -(a(ii+2)-c(ii+2)+R*c(ii+1))/J if (ABS(c(ii)) .le. cmax) goto 20 cbig = .true. end if c(ii) = cmax 20 continue end if C WRITE(*,*)'MATCHING POINT FOR COMPOSITE DEFLATION' C MATCHING POINT FOR COMPOSITE DEFLATION 5004 do i = 1,n nfun = ABS(b(i)) + ABS(c(i)) if (nfun .gt. tol) then nfun = ABS(b(i)-c(i)) / nfun if (nfun .lt. fun) then fun = nfun k = i end if end if end do if (k .ne. 1) then jtemp = k - 1 do i = 1,jtemp a(i) = b(i) end do end if if (k.ne.0) then a(k) = p5 * (b(k)+c(k)) end if if (k .ne. n) then jtemp = k + 1 do i = jtemp,n a(i) = c(i) end do end if end do 5006 R = a(2)*a(2) - four*a(1)*a(3) if (R .gt. zero) then imz(1) = zero imz(2) = zero if (a(2) .lt. 0.0d0) then rez(1) = p5 * (-a(2)+SQRT(R)) / a(1) * fac else if (dpeq(a(2), 0.0d0)) then rez(1) = -p5*SQRT(R)/a(1)*fac else rez(1) = p5 * (-a(2)-SQRT(R)) / a(1) * fac end if rez(2) = a(3) / (rez(1)*a(1)) * fac * fac else rez(2) = -p5*a(2)/a(1)*fac rez(1) = rez(2) imz(2) = p5 * SQRT(-R) / a(1) * fac imz(1) = -imz(2) end if 5007 n = 1 goto 5009 5008 ifail=1 c ind = P01ABF(ifail,2,srname,0,p01rec) cc No queremos que se corte la ejecucion de Seats C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK return scale = one i = n do while (.true.) i = i - 1 if (i .lt. 1) goto 5009 scale = scale * fac a(i) = a(i) / scale end do else ifail=1 return c ind = P01ABF(ifail,1,srname,0,p01rec) cc no queremos que se corte la ejecucion de Seats end if 5009 ifail = ind end C C subroutine C02AEZ(a,n,tol) C EVALUATES R,RX,J,JX AT THE POINT X+IY AND APPLIES THE ADAMS C TEST. C THE BOOLEAN VARIABLE SAT IS GIVEN THE VALUE TRUE IF THE TEST C IS SATISFIED. C .. Scalar Arguments .. C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Overwritten .. integer n C.. In/Out Status: Maybe Read, Not Written .. double precision a(n) C.. In/Out Status: Read, Not Written .. double precision tol C C.. Local Scalars .. integer k double precision a1,a2,a3,a8,b1,b2,b3,c,p,p8,q,t,ten,two,zero C C.. Intrinsic Functions .. intrinsic ABS, SQRT include 'ac02ae.i' C C.. Data Declarations .. C .. Data statements .. data two/2.0d0/ zero/0.0d0/ p8/0.8d0/ ten/1.0d1/ a8/8.0d0/ C .. Executable Statements .. p = -two*X q = X*X + Y0*Y0 t = SQRT(q) a2 = zero b2 = zero b1 = a(1) a1 = a(1) c = ABS(a1) * p8 n = n - 2 do k = 2,n a3 = a2 a2 = a1 a1 = a(k) - p*a2 - q*a3 c = t*c + ABS(a1) b3 = b2 b2 = b1 b1 = a1 - p*b2 - q*b3 end do n = n + 2 a3 = a2 a2 = a1 a1 = a(n-1) - p*a2 - q*a3 R = a(n) + X*a1 - q*a2 J = a1 * Y0 Rx = a1 - two*b2*Y0*Y0 Jx = two * Y0 * (b1-X*b2) c = t*(t*c+ABS(a1)) + ABS(R) Sat = (SQRT(R*R+J*J)) .lt. $ ((ten*c-a8*(ABS(R)+ABS(a1)*t)+two*ABS(X*a1))*tol) end C C integer function P01ABF(ifail,ierror,srname,nrec,rec) C C P01ABF either returns the value of IERROR through the routine C name (soft failure), or terminates execution of the program C (hard failure). Diagnostic messages may be output. C C If IERROR = 0 (successful exit from the calling routine), C the value 0 is returned through the routine name, and no C message is output C C If IERROR is non-zero (abnormal exit from the calling routine), C the action taken depends on the value of IFAIL. C C IFAIL = 1: soft failure, silent exit (i.e. no messages are C output) C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) C IFAIL =-13: soft failure, noisy exit but standard messages from C P01ABF are suppressed C IFAIL = 0: hard failure, noisy exit C C C a = 0: hard failure a = 1: soft failure C b = 0: silent exit b = 1: noisy exit C C except that hard failure now always implies a noisy exit. C C C .. Scalar Arguments .. C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. integer ifail C.. In/Out Status: Read, Not Written .. integer ierror C.. In/Out Status: Not Read, Not Written .. character*(*) srname C.. In/Out Status: Maybe Read, Not Written .. integer nrec C.. In/Out Status: Maybe Read, Not Written .. character*(*) rec(*) C C.. Local Scalars .. integer i,nerr character mess*72 C C.. External Calls .. external P01ABZ, X04AAF, X04BAF C C.. Intrinsic Functions .. intrinsic ABS, MOD include 'stream.i' C LINES OF CODE ADDED FOR X-13A-S : 1 INCLUDE 'stdio.i' INCLUDE 'units.cmn' C END OF CODE BLOCK C C ... Executable Statements ... C nerr = Nio if (ierror .ne. 0) then C Abnormal exit from calling routine if (ifail.eq.-1 .or. ifail.eq.0 .or. ifail.eq.-13 .or. $ (ifail.gt.0.and.MOD(ifail/10,10).ne.0)) then C Noisy exit C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call X04AAF(1,nerr) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 nerr = STDERR C END OF CODE BLOCK do i = 1,nrec call X04BAF(nerr,rec(i)) C LINES OF CODE ADDED FOR X-13A-S : 1 call X04BAF(Mt2,rec(i)) C END OF CODE BLOCK end do if (ifail .ne. -13) then C 7000 format ( $ ' ** ABNORMAL EXIT from RPQ ',a,': IFAIL',' =' $ ,i6) write (mess,FMT = 7000) 'RPQ', ierror call X04BAF(nerr,mess) C LINES OF CODE ADDED FOR X-13A-S : 1 call X04BAF(Mt2,mess) C END OF CODE BLOCK if (ABS(MOD(ifail,10)) .ne. 1) then C Hard failure call X04BAF(nerr,' ** RPQ hard failure - execution terminated' $ ) C LINES OF CODE ADDED FOR X-13A-S : 1 call X04BAF(Mt2,' ** RPQ hard failure - execution terminated') C END OF CODE BLOCK call P01ABZ else C Soft failure call X04BAF(nerr,' ** RPQ soft failure - control returned') C LINES OF CODE ADDED FOR X-13A-S : 1 call X04BAF(Mt2,' ** RPQ soft failure - control returned') C END OF CODE BLOCK end if end if end if end if P01ABF = ierror end C C subroutine P01ABZ C C.. Implicits .. implicit none C C ... Executable Statements ... C C LINES OF CODE ADDED FOR X-13A-S : 2 call abend() return C END OF CODE BLOCK * call RAISE * stop end C C double precision function X02AJF() C C RETURNS (1/2)*B**(1-P) IF ROUNDS IS .TRUE. C RETURNS B**(1-P) OTHERWISE C C For Prime: X02AJF = 2.0D0**(-45) = 2.842170943040D-14 C C C.. Implicits .. implicit none C C.. Local Scalars .. double precision z C C.. Local Arrays .. integer*2 l(4) C C.. Equivalences .. equivalence (z,l(1)) C LINES OF CODE ADDED FOR X-13A-S : 2 DOUBLE PRECISION dpmpar EXTERNAL dpmpar C END OF CODE BLOCK C C.. Data Declarations .. C DATA L(1),L(2),L(3),L(4)/:040000,:000000,:000000,:000124/ data l(1),l(2),l(3),l(4)/16384,0,0,84/ C .. Executable Statements .. C LINES OF CODE COMMENTED FOR X-13A-S : 1 C X02AJF = z C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 X02AJF = dpmpar(1) C END OF CODE BLOCK end C C subroutine X04AAF(i,nerr) C C IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER C (STORED IN NERR1). C IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO C VALUE SPECIFIED BY NERR. C C .. Scalar Arguments .. C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer i C.. In/Out Status: Maybe Read, Maybe Written .. integer nerr C C.. Local Scalars .. integer nerr1 C C.. Save Declarations .. save nerr1 C C.. Data Declarations .. C .. Data statements .. data nerr1/1/ C .. Executable Statements .. if (i .eq. 0) then nerr = nerr1 end if if (i .eq. 1) then nerr1 = nerr end if end C C subroutine X04BAF(nout,rec) C C X04BAF writes the contents of REC to the unit defined by NOUT. C C Trailing blanks are not output, except that if REC is entirely C blank, a single blank character is output. C If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier, C then no output occurs. C C .. Scalar Arguments .. C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer nout C.. In/Out Status: Maybe Read, Not Written .. character*(*) rec C C.. Local Scalars .. integer i C C.. Intrinsic Functions .. intrinsic LEN C .. Executable Statements .. if (nout .lt. 0) return C Remove trailing blanks do i = LEN(rec),2,-1 if (rec(i:i) .ne. ' ') goto 5000 end do C 7000 format (a) C Write record to external file 5000 write (nout,FMT = 7000) rec(1:i) end C C double precision function X02ALF() C C RETURNS (1 - B**(-P)) * B**EMAX (THE LARGEST POSITIVE MODEL C NUMBER) C C C C.. Implicits .. implicit none C LINES OF CODE COMMENTED FOR X-13A-S : 13 CC CC.. Local Scalars .. C double precision z CC CC.. Local Arrays .. C integer*2 l(4) CC CC.. Equivalences .. C equivalence (l(1),z) CC CC.. Data Declarations .. CC DATA L(1),L(2),L(3),L(4)/:077777,:177777,:177776,:040301/ C data l(1),l(2),l(3),l(4)/32767,65535,65534,16577/ C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 DOUBLE PRECISION dpmpar EXTERNAL dpmpar C END OF CODE BLOCK C .. Executable Statements .. c X02ALF = z C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 X02ALF = dpmpar(3) C END OF CODE BLOCK end C C C CC SUBROUTINE TABLE(DATA,DECP) CC IMPLICIT REAL*8 (A-H,O-Z) CC--- CC- CC EXPLORE CC CC REAL*4 MTH(12),QRT(4),SRT(6) CC REAL*8 DATA(1),FDECP1(7),WRT2(7),FN1(12),FN2(12),FNFREQ(3) C CHARACTER*4 MTH(12),QRT(4),SRT(6) C REAL*8 DATA(1) C CHARACTER*8 FDECP1(7),WRT2(7),FN1(12),FN2(12),FNFREQ(3) C INTEGER*4 DECP,YR C COMMON/SFORM/NZ,NYER,NPER,NFREQ C COMMON /STREAM/ NIO C DATA MTH/'JAN ','FEB ','MAR ','APR ','MAY ','JUN','JUL','AUG ', C $'SEP','OCT ','NOV ','DEC '/ C DATA QRT/'1ST','2ND','3RD','4TH'/ C DATA SRT/'1ST','2ND','3RD','4TH','5TH','6TH'/ C DATA WRT2/'(1H ,I4,','N2','X,','N1','(F10','.DECP','))'/ C DATA FDECP1/'.0','.1','.2','.3','.4','.5','.6'/ C DATA FN1/'1','2','3','4','5','6','7','8','9','10','11','12'/ C DATA FN2/'2','12','22','32','42','52','62','72','82','092','102', C $ '112'/ C DATA FNFREQ/'4','12','6'/ C 2001 FORMAT(/,1H ,'YEAR',1X,12(6X,A4)/) C 2002 FORMAT(/,1H ,'YEAR',1X,4(6X,A4)/) C 2003 FORMAT(/,1H ,'YEAR',1X,6(6X,A4)/) C NDECP=DECP C IF (DECP.GE.6) DECP=6 C 250 IF (DECP.EQ.0) GO TO 251 C MDECP=10-DECP C A=0.00999999*10**MDECP C DO 151 I=1,NZ C IF(DATA(I).LT.A) GO TO 151 C DECP=DECP-1 C GO TO 250 C 151 CONTINUE C 251 CONTINUE C IFACT=0 C ZZ=DLOG10(DABS(DATA(1)+.0000000001D0)) C SUM=DABS(ZZ) C DO 678 I=2,NZ C IF (ZZ.GT.0.0D0) THEN C SUM=0.0D0 C GOTO 679 C end if C ZZ=DLOG10(DABS(DATA(I)+.0000000001D0)) C IF ((DABS(ZZ).LT.SUM).AND.(ZZ.LT.0.0D0)) SUM=DABS(ZZ) C 678 CONTINUE C 679 IF (SUM.GT.1.0D0) THEN C IFACT=IDINT(SUM) C IF (IFACT.GT.6) IFACT=6 C IF (IFACT.GT.0) WRITE(NIO,'(4X, ''X 10.0D'',I2,/)') -IFACT C end if C JFACT=0 C ZZ=DLOG10(DABS(DATA(1)+.0000000001D0)) C SUM=ZZ C DO 878 I=2,NZ C ZZ=DLOG10(DABS(DATA(I)+.0000000001D0)) C IF ((ZZ.GT.SUM).AND.(ZZ.GT.0.0D0)) SUM=ZZ C 878 CONTINUE C IF (SUM.GT.4.0D0) THEN C JFACT=IDINT(SUM)-2 C IF (JFACT.GT.0) WRITE(NIO,'(4X, ''X 10.0D'',I2,/)') JFACT C end if C YR=NYER C IF (NFREQ.EQ.12) WRITE(NIO,2001) (MTH(I),I=1,12) C IF (NFREQ.EQ.4) WRITE(NIO,2002) (QRT(I),I=1,4) C IF (NFREQ.EQ.6) WRITE(NIO,2003) (SRT(I),I=1,6) C NYR=(NZ-(NFREQ-NPER+1))/NFREQ C NY=(NZ-(NFREQ-NPER+1))-NYR*NFREQ C IF (NY.EQ.0) GO TO 520 C NYR=NYR+1 C 520 NYR=NYR+1 C WRT2(6)=FDECP1(DECP+1) C DO 75 I=1,NYR C I1=(I-1)*NFREQ-(NPER-2) C I2=I*NFREQ-(NPER-1) C IF (I2.GE.NZ) I2=NZ C WRT2(2)=FN2(1) C WRT2(4)=FNFREQ(1) C IF (NFREQ.EQ.12) WRT2(4)=FNFREQ(2) C IF (NFREQ.EQ.6) WRT2(4)=FNFREQ(3) C IF (I.NE.1) GO TO 150 C WRT2(4)=FN1(NFREQ-NPER+1) C WRT2(2)=FN2(NPER) C I1=1 C 150 IF (IFACT.GT.0) THEN C WRITE(NIO,WRT2)YR,(DATA(J)*(10.0D0**IFACT),J=I1,I2) C ELSE C WRITE(NIO,WRT2)YR,(DATA(J)*(10.0D0**(-JFACT)),J=I1,I2) C end if C 75 YR=YR+1 C DECP=NDECP C RETURN C END C ansub3.f0000664006604000003110000012074414521201407011537 0ustar sun00315stepsC Last change: BCM 15 Nov 2002 1:54 pm C C THE SUBROUTINE ESTBUR ESTIMATES THE COMPONENTS USING THE C METHOD OF BURMAN(1980). C THE FILTERS NUMERATOR ARE PASSED: C CT=TREND; CS=SEASONAL; CC=CYCLE; C C CT(B,F) GT(B) GT(F) C ----------- = ------ + ------ (TUNICLIFFE-WILSON ALGOR.) C TH(B)*TH(F) TH(B) TH(F) C C THE COMMON "ESTB" CONTAINS : C NCHI : THE DIMENSION OF TREND NUMERATOR MODEL C NCYC : THE DIMENSION OF CYCLE NUMERATOR MODEL C C SEE THAT THE DIMENSION OF SEASONAL NUMERATOR MODEL IS PASSED C C C INPUT PARAMETERS C BZ : THE REVERSED ORIGINAL SERIES AND THE BACKCAST C TOTDEN : TOTAL DENOMINATOR OF THE MODEL (true signs) C PSTAR : DIMENSION OF TOTDEN C THSTAR : TOTAL NUMERATOR OF THE MODEL (true signs) C QSTAR : DIMENSION OF THSTAR C CT : NUMERATOR TREND FILTER C CS : NUMERATOR SEASONAL FILTER C CC : NUMERATOR CYCLE FILTER C MQ : FREQUENCY C ZAF : FORECAST SERIES (COMPUTED IN FCAST) C ZAB : BACKCAST SERIES (COMPUTED IN FCAST) C NPSI : DIMENSION OF THE SEASONAL NUMERATOR MODEL C D : DELTA OF MODEL C BD : DELTA^MQ OF THE MODEL c nCycTH : MA dimension -1 of the Cycle component C varwnc : Innovation variance of Cycle component c IMEAN : If mean is choosen in the Seats model c IsCloseToTD: If the Transitory component is a stochastic Td component c c OUTPUT PARAMETERS C TREND : THE TREND COMPONENT including forecast C SC : THE SEASONAL COMPONENT including forecast C CYCLE : THE CYCLE COMPONENT including forecast C SA : Seasonal Adjusted Component including forecast C IR : Irregular component including forecast C ForBias : Forecast of Z C ForTbias : Forecast of Trend C ForSBias : Forecast of SC C c INPUT/OUTPUT PARAMETERS C Z : THE ORIGINAL SERIES AND THE FORECAST (At the end of the function is the forecast of Tramo) C LF : NUMBER OF FORECAST AND BACKCAST, If TRAMO<>0 NF=NF-MQ/2 C C subroutine ESTBUR(z,bz,totden,pstar,thstar,qstar,ct,cs,cc,mq,zaf, $ zab,trend,sc,cycle,sa,ir,npsi,d,bd,lf,forbias, $ fortbias,forsbias,ncycth,varwnc,imean, $ iscloseToTD) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' include 'units.cmn' integer np parameter (np = 60) C C.. Formal Arguments .. logical isCloseToTD integer pstar,qstar,mq,npsi,d,bd,lf,ncycth,imean real*8 z(*),bz(*),totden(*),thstar(*),ct(*),cs(*),cc(*),zaf,zab, $ trend(*),sc(*),cycle(*),sa(*),ir(*),forbias(kp), $ fortbias(kp),forsbias(kp),varwnc C C.. Local Scalars .. integer i,iqrow,irow,j,k,l1,m,maxpq,n,nqst1,nz1,l2 real*8 sum,sum1,sum2,sum3,sum4,sum5,sum6,wmb,wmf,zmean,sum1b,maxZ C C.. Local Arrays .. real*8 am(60,66),bxc(mpkp+np),bxs(mpkp+np), $ bxt(mpkp+np),byc(mpkp+np), $ bys(mpkp+np),byt(mpkp+np), $ fxc(mpkp+np),fxs(mpkp+np), $ fxt(mpkp+np),fyc(mpkp+np), $ fys(mpkp+np),fyt(mpkp+np), $ extZ(mpkp),d1(mpkp) C C.. External Functions .. real*8 DMEAN external DMEAN C C.. External Calls .. external MLTSOL C C.. Intrinsic Functions .. intrinsic MAX,abs include 'estb.i' include 'sform.i' include 'estgc.i' include 'sig.i' include 'preadtr.i' C C ... Executable Statements ... C CALL setdp(0D0,mpkp,extZ) maxpq = MAX(pstar,qstar) l1= MAX(maxpq+Qstar,Mq+Mq) l1=max(l1,lf) * if (l.gt.lf) l = lf l2=min(l1,qstar+maxpq-2) l2=max(l2,lf) * write(Mtprof,*)' extz bz ' do i=1,nz+l2 extZ(i)=z(i) * write(Mtprof,*) extz(i), bz(i) enddo * write(Mtprof,*)' -----' * write(Mtprof,*)' maxpq=',maxpq,' Qstar=',Qstar,' l=',l * write(Mtprof,*)' l2=',l2,' nz+l2=',nz+l2 if ((d+bd .eq. 0).and.(imean.eq.1)) then zmean = DMEAN(Nz,z) do i = 1,Nz+l2 extz(i) = extz(i) - zmean bz(i) = bz(i) - zmean end do do i = 1,kp forbias(i) = forbias(i) - zmean end do zab = 0.0d0 zaf = 0.0d0 else zmean = 0.0d0 end if do i = 1,kp fortbias(i) = 0.0d0 forsbias(i) = 0.0d0 end do C C PARTITION EACH FILTER INTO TWO 1-SIDED FILTERS C if (pstar .ne. qstar) then nqst1 = qstar + 1 do i = nqst1,pstar thstar(i) = 0.0d0 end do end if C C SET UP MATRIX C do i = 1,maxpq do j = i,maxpq am(i,j) = 0.0d0 end do do j = 1,i am(i,j) = thstar(i-j+1) end do m = maxpq - i + 1 do j = m,maxpq am(i,j) = am(i,j) + thstar(maxpq-j+m) end do k = maxpq - i + 1 am(i,maxpq+1) = ct(k) am(i,maxpq+2) = cs(k) am(i,maxpq+3) = cc(k) end do m = 3 * call profiler(3,'subroutine MLTSOL, call 1') call MLTSOL(am,maxpq,m,60,66) do i = 1,maxpq k = maxpq - i + 1 gt(k) = am(i,maxpq+1) gs(k) = am(i,maxpq+2) gc(k) = am(i,maxpq+3) end do C WRITE(NIO,2003) (GT(I),I=1,MAXPQ) C WRITE(NIO,2004) (GS(I),I=1,MAXPQ) C WRITE(NIO,2015) (GC(I),I=1,MAXPQ) C 2003 FORMAT (//' NUMERATOR OF 1-SIDED FILTER GT(B)'/(12F12.5)) C 2004 FORMAT (//' NUMERATOR OF 1-SIDED FILTER GS(B)'/(12F12.5)) C 2015 FORMAT (//' NUMERATOR OF 1-SIDED FILTER GC(B)'/(12F12.5)) C C RE-ARRANGE COEFFICIENTS FROM ESTIMATION PROGRAM C l1 = maxpq + qstar - 2 C M = NZ+1 C K = NZ+L1 C WRITE(NIO,2005) (Z(I),I=M,K) C WRITE(NIO,2006) (BZ(I),I=M,K) C 2005 FORMAT (//'0FORECAST OF Z-SERIES'/(12F12.4)) C 2006 FORMAT (//'0BACKCAST OF Z-SERIES'/(12F12.4)) C C APPLY FILTERS GT AND GS TO FORWARD AND BACKWARDS C SERIES TO OBTAIN Y-SERIES C n = Nz + qstar - 1 do i = 1,n sum1 = 0.0d0 sum2 = 0.0d0 sum3 = 0.0d0 sum4 = 0.0d0 sum5 = 0.0d0 sum6 = 0.0d0 * write(Mtprof,*)' i= ',i do j = 1,maxpq m = i + j - 1 sum1 = sum1 + gt(j)*extz(m) sum2 = sum2 + gt(j)*bz(m) sum3 = sum3 + gs(j)*extz(m) sum4 = sum4 + gs(j)*bz(m) sum5 = sum5 + gc(j)*extz(m) sum6 = sum6 + gc(j)*bz(m) * write(Mtprof,*)' extz(',m,')= ',extz(m), * & ' gt(',j,')= ',gt(j) * write(Mtprof,*)' gt(',j,')*extz(',m,')= ',gt(j)*extz(m) end do * write(Mtprof,*)' sum1 ',sum1 * write(Mtprof,*)' -----' fyt(i) = sum1 byt(i) = sum2 fys(i) = sum3 bys(i) = sum4 fyc(i) = sum5 byc(i) = sum6 end do if (qstar .eq. 1) then * write(Mtprof,*)' j fxt(j)' do j = 1,Nz fxt(j) = fyt(j) bxt(j) = byt(j) fxs(j) = fys(j) bxs(j) = bys(j) fxc(j) = fyc(j) bxc(j) = byc(j) * write(Mtprof,*)' ',j,' ',fxt(j) end do * write(Mtprof,*)' -----' else C C DERIVE (PSTAR+QSTAR) TERMS OF X-SERIES BY SOLVING EQUATIONS C irow = pstar + qstar - 2 wmf = 0.5 * zaf wmb = 0.5 * zab * write(Mtprof,*)' irow = ',irow,' wmf = ',wmf,' wmb = ',wmb do i = 1,irow do j = 1,irow am(i,j) = 0.0d0 end do end do n = Nz + qstar - pstar iqrow = qstar - 1 * write(Mtprof,*)' iqrow = ',iqrow,' pstar = ',pstar do i = 1,iqrow * write(Mtprof,*)' i = ',i do j = 1,pstar m = i + j - 1 am(i,m) = totden(j) * write(Mtprof,*)' j = ',j,' totden(j) = ',totden(j) end do am(i,irow+1) = wmf am(i,irow+2) = wmb do j = 3,6 am(i,irow+j) = 0.0d0 end do end do do i = qstar,irow * write(Mtprof,*)' i = ',i do j = 1,qstar m = i - j + 1 am(i,m) = thstar(j) * write(Mtprof,*)' j = ',j,' thstar(j) = ',thstar(j) end do k = n + irow - i + 1 am(i,irow+1) = fyt(k) am(i,irow+2) = byt(k) am(i,irow+3) = fys(k) am(i,irow+4) = bys(k) am(i,irow+5) = fyc(k) am(i,irow+6) = byc(k) * write(Mtprof,*)' k = ',k,' fyt(k) = ',fyt(k),' byt(k) = ',byt(k) * write(Mtprof,*)' fys(k) = ',fys(k),' bys(k) = ',bys(k) * write(Mtprof,*)' fyc(k) = ',fyc(k),' byc(k) = ',byc(k) end do m = 6 * write(Mtprof,8999)'R/C',(i,i=1,irow+m) * 8999 format(3x,a3,6(5x,i5),/,4(6x,6(5x,i5),/),6x,3(5x,i5)) * do i = 1, irow * write(Mtprof,9000)i, (am(i,j), j = 1, irow+m) * 9000 format(i6,6f10.6,/,4(6x,6f10.6,/),6x,3f10.6) * end do * write(Mtprof,*)'------' * call profiler(3,'subroutine MLTSOL, call 2') call MLTSOL(am,irow,m,60,66) do i = 1,irow k = n + irow - i + 1 fxt(k) = am(i,irow+1) bxt(k) = am(i,irow+2) fxs(k) = am(i,irow+3) bxs(k) = am(i,irow+4) fxc(k) = am(i,irow+5) bxc(k) = am(i,irow+6) * write(Mtprof,9001)(am(i,j),j=irow+1,irow+6) 9001 format(6f12.6) end do * write(Mtprof,*)'------' C C OBTAIN REST OF X-SERIES BY RECURRENCE AND C COMBINE X-SERIES TO GIVE SC AND TREND C * write(Mtprof,*) * & ' sum1b j thstar(j) k fxt(k) sum1' do i = 1,n m = n - i + 1 sum1 = fyt(m) sum2 = byt(m) sum3 = fys(m) sum4 = bys(m) sum5 = fyc(m) sum6 = byc(m) do j = 2,qstar k = m + j - 1 sum1b = sum1 sum1 = sum1 - thstar(j)*fxt(k) sum2 = sum2 - thstar(j)*bxt(k) sum3 = sum3 - thstar(j)*fxs(k) sum4 = sum4 - thstar(j)*bxs(k) sum5 = sum5 - thstar(j)*fxc(k) sum6 = sum6 - thstar(j)*bxc(k) * write(Mtprof,*)' ',sum1b,' ',j,' ',thstar(j),' ',k,' ', * & fxt(k),' ',sum1 end do fxt(m) = sum1 bxt(m) = sum2 fxs(m) = sum3 bxs(m) = sum4 fxc(m) = sum5 bxc(m) = sum6 end do * write(Mtprof,*)'------' end if do i = 1,Nz trend(i) = fxt(i) + bxt(Nz-i+1) * write(Mtprof,*)' trend(',i,') = ',trend(i),' fxt(',i,') = ', * & fxt(i),' bxt(',Nz-i+1,') = ',bxt(Nz-i+1) sc(i) = fxs(i) + bxs(Nz-i+1) cycle(i) = fxc(i) + bxc(Nz-i+1) end do * write(Mtprof,*)'------' C C IF MODEL TOPHEAVY,CREATE WHITE NOISE IRREGULAR COMPONENT C C nz1 = Nz+lf * write(*,*) ' lf = ',lf do i = Nz+1,nz1 sc(i) = 0.0d0 trend(i) = 0.0d0 cycle(i) = 0.0d0 end do C if (npsi .ne. 1) then C C FORECAST SEASONALS C k = 2*qstar - 1 if (k .le. kp) then do i = k,kp sum = 0.0d0 do j = 2,pstar sum = sum - totden(j)*fxs(Nz+i-j+1) end do fxs(Nz+i) = sum end do end if do i = 1,qstar bxs(Nz-i+1) = bxs(i) end do do i = 1,kp sum = 0.0d0 k = Nz + i do j = 1,maxpq if ((k-j+1) .gt. (Nz+lf)) then sum = sum + gs(j)*forbias(k-j+1-Nz) else sum = sum + gs(j)*extZ(k-j+1) end if end do if (qstar .ne. 1) then do j = 2,qstar sum = sum - thstar(j)*bxs(k-j+1) end do end if bxs(k) = sum if (k .le. Nz+lf) then sc(k) = fxs(k) + bxs(k) forsbias(k-Nz) = fxs(k) + bxs(k) else forsbias(k-Nz) = fxs(k) + bxs(k) end if end do end if C C FORECAST TREND C if (Nchi .ne. 1) then k = 2*qstar - 1 if (k .le. kp) then do i = k,kp sum = 0.0d0 do j = 2,pstar sum = sum - totden(j)*fxt(Nz+i-j+1) end do fxt(Nz+i) = sum end do end if do i = 1,qstar bxt(Nz-i+1) = bxt(i) end do do i = 1,kp sum = 0.0d0 k = Nz + i do j = 1,maxpq if ((k-j+1) .gt. (Nz+lf)) then sum = sum + gt(j)*forbias(k-j+1-Nz) else sum = sum + gt(j)*extZ(k-j+1) end if end do byt(k) = sum if (qstar .ne. 1) then do j = 2,qstar sum = sum - thstar(j)*bxt(k-j+1) end do end if bxt(k) = sum if (k .le. Nz+lf) then trend(k) = fxt(k) + bxt(k) fortbias(k-Nz) = fxt(k) + bxt(k) else fortbias(k-Nz) = fxt(k) + bxt(k) end if end do end if C C C if (varwnc.gt.1.0d-10 .and. (ncycth.ne.0 .or. Ncyc.ne.1)) then C C FORECAST CYCLE C k = 2*qstar - 1 if (k .le. lf) then do i = k,lf sum = 0.0d0 do j = 2,pstar sum = sum - totden(j)*fxc(Nz+i-j+1) end do fxc(Nz+i) = sum end do end if do i = 1,qstar bxc(Nz-i+1) = bxc(i) end do do i = 1,lf sum = 0.0d0 k = Nz + i do j = 1,maxpq sum = sum + gc(j)*extZ(k-j+1) end do if (qstar .ne. 1) then do j = 2,qstar sum = sum - thstar(j)*bxc(k-j+1) end do end if bxc(k) = sum cycle(k) = fxc(k) + bxc(k) end do end if C DO 123 I=NZ+1,NZ+MQ C 123 TREND(I)=Z(I)-CYCLE(I)-SC(I) C WRITE(NIO,1998) C 1998 FORMAT(////50(1H*),' IT''S A VERY TEMPORARY OUTPUT ',50(1H*)// C $' FORECAST OF:',10X,'TRANSF. SERIES',10X,'TREND-CYCLE',4X, C $'SEAS.',10X,'CYCLE',10X,'DIFFERENCES'/) C DO 1999 I=NZ+1,NZ+MQ2 C A=Z(I)-CYCLE(I)-TREND(I)-SC(I) C 1999 WRITE(NIO,800) I,SC(I),FORSBIAS(I-NZ),TREND(I),FORTBIAS(I-NZ) C 800 FORMAT(3X,I5,16X,4(D15.8),5X,D15.8) if ((d+bd .eq. 0).and.(imean.eq.1)) then do i = 1,Nz+lf bz(i) = bz(i) + zmean enddo do i = 1,Nz+lf extz(i) = extz(i) + zmean trend(i) = trend(i) + zmean end do do i = 1,kp forbias(i) = forbias(i) + zmean fortbias(i) = fortbias(i) + zmean end do end if c c Z=SA+SC (Linealized observed series are equal to stochastic SA+SC) c Z=Trend+Cycle+Sc+IR (Linealized observed series are equal to stochastic Trend+Cycle+Sc+Ir) c nz1 = Nz + lf if (Npsi .eq. 1) then do i = 1,nz1 Sc(i) = 0.0d0 if (i .le. Nz) then if (noadmiss.eq.-1) then ir(i) =0.0d0 else ir(i) = z(i) - trend(i) - cycle(i) end if if (iscloseToTD) then sa(i) = z(i) - cycle(i) else sa(i) = z(i) endif end if end do else if (isCloseToTD) then do i = 1,Nz sa(i) = z(i) - sc(i) - cycle(i) if (noadmiss.eq.-1) then ir(i) =0.0d0 else ir(i) = z(i) - sc(i) - trend(i) - cycle(i) end if enddo else do i = 1,Nz sa(i) = z(i) - sc(i) if (noadmiss.eq.-1) then ir(i) =0.0d0 else ir(i) = z(i) - sc(i) - trend(i) - cycle(i) end if enddo end if end if do i = Nz+1,nz1 ir(i) = 0.0d0 end do c c To make Z=TramLin (Predictions of Tramo are equal to the ones in Seats) c Z=SA+SC (Predictions of Tramo are equal to SA+SC) c Z=Trend+Cycle+Sc+IR (Predictions of Tramo are equal to Trend+Cycle+Sc+Ir) c if (Tramo.ne.0) then do i=1,nz d1(i)=0.0d0 enddo if (ILAM.eq.0) then do i=nz+1,nz1 z(i)=trend(i)+sc(i)+cycle(i)+ir(i) d1(i)=LOG(TramLin(i))-Z(i) z(i)=LOG(TramLin(i)) forbias(i-nz)=z(i) enddo else do i=nz+1,nz1 z(i)=trend(i)+sc(i)+cycle(i)+ir(i) d1(i)=TramLin(i)-Z(i) z(i)=TramLin(i) enddo endif lf=lf-mq/2 if (mq.ne.3)then c CASE MQ=2,4,6,12 if (npsi.gt.1)then if (nchi.gt.1) then do i=Nz+1,nz+lf sc(i)=sc(i)+d1(i)-(d1(i+mq/2)+d1(i-mq/2))/dble(2*mq) do j=1-mq/2,mq/2-1 SC(i)=sc(i)-d1(i+j)/dble(mq) enddo enddo else do i=Nz+1,nz+lf sc(i)=sc(i)+d1(i) enddo endif elseif (.not.isCloseToTD .and. varwnc.gt.1.0d-10 .and. & (ncycth.ne.0 .or. Ncyc.ne.1)) then if (nchi.gt.1) then do i=Nz+1,nz+lf cycle(i)=cycle(i)+d1(i)-(d1(i+mq/2)+d1(i-mq/2))/dble(2*mq) do j=1-mq/2,mq/2-1 cycle(i)=cycle(i)-d1(i+j)/dble(mq) enddo enddo else do i=NZ+1,nz+lf cycle(i)=cycle(i)+d1(i) enddo endif else if (nchi.gt.1) then do i=Nz+1,nz+lf ir(i)=d1(i)-(d1(i+mq/2)+d1(i-mq/2))/dble(2*mq) do j=1-mq/2,mq/2-1 ir(i)=ir(i)-d1(i+j)/dble(mq) enddo enddo else do i=NZ+1,nz+lf ir(i)=d1(i) enddo endif endif else c CASE MQ=3 if (npsi.gt.1)then if (nchi.gt.1) then do i=Nz+1,nz+lf sc(i)=sc(i)+d1(i)-(d1(i-1)+d1(i)+d1(i+1))/dble(3) enddo else do i=NZ+1,nz+lf sc(i)=sc(i)+d1(i) enddo endif elseif (.not.isCloseToTD .and. varwnc.gt.1.0d-10 .and. & (ncycth.ne.0 .or. Ncyc.ne.1)) then if (nchi.gt.1) then do i=Nz+1,nz+lf cycle(i)=cycle(i)+d1(i)-(d1(i-1)+d1(i)+d1(i+1))/dble(3) enddo else do i=Nz+1,Nz+lf cycle(i)=cycle(i)+d1(i) enddo endif else if (nchi.gt.1) then do i=Nz+1,nz+lf ir(i)=d1(i)-(d1(i+mq/2)+d1(i-mq/2))/dble(2*mq) do j=1-mq/2,mq/2-1 ir(i)=ir(i)-d1(i+j)/dble(mq) enddo enddo else do i=NZ+1,nz+lf ir(i)=d1(i) enddo endif endif endif endif maxZ=0.0d0 do i=1,nz if (abs(z(i)).gt.maxZ) then maxZ=abs(Z(i)) endif enddo do i = Nz+1,nz1 trend(i) = z(i) - sc(i) - cycle(i)-ir(i) if (abs(trend(i)).lt.(1.0D-15*maxZ))then trend(i)=0.0d0 endif fortbias(i-nz)=trend(i) end do if (isCloseToTD) then do i = Nz+1,nz1 sa(i) = z(i) - sc(i) - cycle(i) forsbias(i-nz)=sc(i) end do else do i = Nz+1,nz1 sa(i) = z(i) - sc(i) forsbias(i-nz)=sc(i) end do endif end C C THIS SUBROUTINE COMPUTES THE DECOMPOSITION OF A FRACTION C P (B,F) C ---------- C Q (B,F) C C WHERE P(B,F), Q(B,F) ARE POLYNOMIALS IN B AND F IN THE SUM OF TWO C C P(B,F) AND Q(B,F) ARE COMPUTED AS : C C P(B,F)= THc(B)*THc(F)*PHInc(F) C C Q(B,F)= PHIc(B)*TH(F) C C C R(B) T(F) C FRACTION ------ + ------ C PHIc(B) TH(F) C C NOTE : ALL INPUT POLYNOMIAL ARE IN B C c DECFB given the model of a component and the ARIMA model return the PSIES of the component estimator c INPUT c PHIc(1:lPHIc) AR of component in Box-Jenkins signs c THc(1:lTHc) MA of component in Box-Jenkins signs c Vc: Variance of component in units of Va(variance of residuals) c TH(1:lTH) MA of ARIMA model of serie in Box-Jenkins sign c PHInc(1:lPHInc) Conv(PHInc,PHIc)=AR of ARIMA model in Box-Jenkins sings c OUTPUT c PSI(0:2pk) PSIEs of component estimator from F^pk to B^pk-1 c Rce(0): variance of concurrent revision error of component estimator c Rce(1:12): correlations 1 to 12 of concurrent revision error c H(1:lH): the MA of the revision Error c Vr: the variance of the innovations of the revision error c E_B(0:lB): MA of concurrent estimator model subroutine DECFB(PHIc,TH,lPHIc,lTH,THc,PHInc,lTHc,lPHInc,Vc, $ PSI,pk,Rce,H,lH,Vr,E_B,lB) C implicit none include 'units.cmn' c INPUT PARAMETERS integer lPHIc,lTHc,lTH,lPHInc,pk real*8 PHIc(*),THc(*),TH(*),PHInc(*),Vc c OUTPUT PARAMETERS real*8 PSI(0:2*pk+1),rce(0:12),Vr,H(60-1),E_B(0:60-1) integer lH,lB c LOCAL PARAMETERS integer lF,i,lM real*8 M(60-1),eM(60),eTH(60),ePHIc(60),eTHc(60), $ H_F(0:60-1),PSIE_B(1:pk+1),PSIE_F(1:pk+1), $ H1,TH1(60),Ve,g(60),rho(0:12) C C.. External Calls .. external CHBJB, MPBBJ, SeparaBF, getPSIE C C ... Executable Statements ... C C C CALCULO DE ALFA POR FISp C call MPBBJ(PHInc,THc,lPHInc,lTHc,M) lM=lPHInc+lTHc call CHBJB(M,lM,eM) call CHBJB(TH,lTH,eTH) call CHBJB(THc,lTHc,eTHc) call CHBJB(PHIc,lPHIc,ePHIc) call SeparaBF(eTHc,lTHc,eM,lM,ePHIc,lPHIc,eTH,lTH, $ E_B,lB,H_F,lF) call getPSIE(E_B,lB,ePHIc,lPHIc,Vc,pk+1,PSIE_B) call getPSIE(H_F,lF,eTH,lTH,Vc,pk+1,PSIE_F) DO i=pk,1,-1 PSI(pk-i)=PSIE_F(i+1) end do do i=0,pk PSI(pk+i)=PSIE_B(i+1) end do c DO i=2,lF c H(i-1)=-H_F(i)/H_F(1) c end do c lH=lF-1 c Vr=abs(H_F(1))*Vc Do i=0,LF H(i+1)=H_F(i) end do lH=LF+1 DO while ((H(1) .eq. 0) .and. (lH .gt. 0)) lH=lH-1 Do i=1,lH H(i)=H(i+1) end do end do if (lH .eq. 0) then Vr=0 else H1=H(1) Vr=abs(H1)*Vc lH=lH-1 Do i=1,lH H(i)=-H(i+1)/H1 end do end if Vr=Vr*Vr * WRITE(Ng,*)' subroutine DECFB, call 1' call BFAC(TH,H,lTH,lH,12,rce,rho,Ve,Vr,g,12) if (abs(rce(0)) .lt. 1.0D-20) then rce(0)=0.0d0 end if do i=1,12 if (rce(0) .eq. 0.0d0) then rce(i)=0 else rce(i)=rce(i)/rce(0) end if end do end subroutine C C THIS SUBROUTINE CHANGES THE SIGNS OF A POLYNOMIAL C TRUE SIGN -----> B-J SIGNS C C INPUT PARAMETER C A : POLYNOMIAL TRUE SIGN C N : DIMENSION OF A C B : POLYNOMIAL B-J SIGN C subroutine CHBJB(a,n,b) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 a(*) C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Not Read, Maybe Written .. real*8 b(0:*) C C.. Local Scalars .. integer i C C ... Executable Statements ... C b(0) = 1.0d0 do i = 1,n b(i) = -a(i) end do end C C THIS SUBROUTINE COMPUTES THE PSI-WEIGHTS (B,F) OF A MODEL C C INPUT PARAMETERS C FI : DENOMINATOR OF THE MODEL B-J SIGN C THE : NUMERATOR OF THE MODEL B-J SIGN C NP : DIMENSION OF FI C NQ : DIMENSION OF THE C NLONG : DIMENSION OF PSI-WEIGHTS(B,F) C PSI : PSI-WEIGHTS C VA : VARIANCE OF THE INNOVATION OF THE MODEL C subroutine DPSI(fi,the,np,nq,nlong,psi,va) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer np,nq,nlong real*8 fi(np),the(nq),psi(0:*),va C C.. Local Scalars .. integer i C C.. Local Arrays .. real*8 a(0:50),b(0:50) C C.. External Calls .. external INPOL, MPB C C ... Executable Statements ... C a(0) = 1.0d0 do i = 1,np a(i) = -fi(i) end do call INPOL(a,np,nlong,psi) b(0) = va do i = 1,nq b(i) = -the(i)*va end do call MPB(b,psi,nq,nlong,psi) end C C THIS SUBROUTINE COMPUTES THE PRODUCT OF TWO POLYNOMIALS IN B C WITH B-J SIGNS. C C INPUT PARAMETERS C A : FIRST POLYNOMIAL IN B C B : SECOND POLYNOMIAL IN B C N : DIMENSION OF A C M : DIMENSION OF B C E : PRODUCT A * B C subroutine MPBBJ(a,b,n,m,e) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Read, Not Written .. integer m C.. In/Out Status: Maybe Read, Not Written .. real*8 a(n) C.. In/Out Status: Maybe Read, Not Written .. real*8 b(m) C.. In/Out Status: Not Read, Maybe Written .. real*8 e(n+m) C C.. Local Scalars .. integer i C C.. Local Arrays .. real*8 aa(0:50),bb(0:50) C C.. External Calls .. external MPB C C ... Executable Statements ... C aa(0) = 1.0d0 bb(0) = 1.0d0 do i = 1,50 aa(i) = 0.0d0 bb(i) = 0.0d0 end do if ((n+m) .gt. 0) then do i = 1,n+m e(i) = 0.0d0 end do end if if (n .ge. 1) then do i = 1,n aa(i) = -a(i) end do end if if (m .ge. 1) then do i = 1,m bb(i) = -b(i) end do end if call MPB(aa,bb,n,m,aa) if ((n+m) .ge. 1) then do i = 1,n+m e(i) = -aa(i) end do end if end C C THIS SUBROUTINE COMPUTES THE PRODUCT OF TWO POLYNOMIALS IN B C WITH TRUE SIGNS (ATTENTION TO THE DIMENSION OF THE POLYNOMIALS) C C INPUT PARAMETERS C A : FIRST POLYNOMIAL IN B (true signs) C B : SECOND POLYNOMIAL IN B (true signs) C N : DIMENSION OF A C M : DIMENSION OF B C E : PRODUCT A * B C subroutine MPB(a,b,n,m,e) C C.. Implicits .. implicit none INCLUDE 'srslen.prm' integer nfl parameter (nfl = 2*POBS) C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Read, Not Written .. integer m C.. In/Out Status: Maybe Read, Not Written .. real*8 a(0:n) C.. In/Out Status: Maybe Read, Not Written .. real*8 b(0:m) C.. In/Out Status: Maybe Read, Maybe Written .. real*8 e(0:*) C C.. Local Scalars .. integer i,j,k C C.. Local Arrays .. real*8 vv(0:nfl),ww(0:nfl) C C.. Intrinsic Functions .. intrinsic MAX C C ... Executable Statements ... C do i = 0,MAX(m,n) vv(i) = 0.0d0 ww(i) = 0.0d0 end do do i = 0,m if (b(i).le.-(10.d0**(-30.0d0)) .or. b(i).ge.10.d0**(-30.d0)) $ then ww(i) = b(i) end if end do do i = 0,n if (a(i).le.-(10.d0**(-30.0d0)) .or. a(i).ge.10.d0**(-30.d0)) $ then vv(i) = a(i) end if end do do i = 0,n+m e(i) = 0.0d0 end do do i = 0,n do j = 0,m k = i + j e(k) = e(k) + vv(i)*ww(j) end do end do do k=1,m+n if (abs(e(k)) .lt. 1.0D-28) then e(k)=0.0D0 end if end do end C C THIS SUBROUTINE COMPUTES THE PRODUCT OF TWO POLYNOMIALS THE FIRST IN B C THE SECOND IN F WITH TRUE SIGNS C C INPUT PARAMETERS C A : POLYNOMIAL IN B (true signs) C B : POLYNOMIAL IN B (true signs) C N : DIMENSION OF A C M : DIMENSION OF B C E : PRODUCT A * B C subroutine MPBF(a,b,n,m,e) C C.. Implicits .. implicit none INCLUDE 'srslen.prm' integer nfl parameter (nfl = 2*POBS) C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Read, Not Written .. integer m C.. In/Out Status: Maybe Read, Not Written .. real*8 a(0:n) C.. In/Out Status: Maybe Read, Not Written .. real*8 b(0:m) C.. In/Out Status: Maybe Read, Maybe Written .. real*8 e(0:n+m) C C.. Local Scalars .. integer i C C.. Local Arrays .. real*8 vv(0:nfl),ww(0:nfl) C C.. External Calls .. external MPB C C ... Executable Statements ... C do i = 0,n vv(i) = a(i) end do do i = 0,m ww(i) = b(i) end do do i = 0,m e(m-i) = b(i) end do do i = 0,m ww(i) = e(i) end do call MPB(vv,ww,n,m,e) end C C THIS SUBROUTINE COMPUTE THE INVERSE OF A POLYNOMIAL IN B C C INPUT PARAMETERS C C A : POLYNOMIAL IN B (true signs) C N : DIMENSION OF A C M : DIMENSION OF E C E : INVERSE POLYNOMIAL (true signs) C subroutine INPOL(a,n,m,e) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer n C.. In/Out Status: Read, Not Written .. integer m C.. In/Out Status: Maybe Read, Not Written .. real*8 a(0:n) C.. In/Out Status: Maybe Read, Maybe Written .. real*8 e(0:m) C C.. Local Scalars .. integer i,j C C ... Executable Statements ... C e(0) = 1.d0 do i = 1,m e(i) = 0.d0 end do if (m .gt. n) then do i = 1,n e(i) = e(i) - a(i) do j = 1,i-1 if ((a(j).le.-(10.d0**(-30.0d0)).or.a(j).ge.10.d0**(-30.d0)) $ .and. $ (e(i-j).le.-(10.d0**(-30.d0)).or.e(i-j).ge.10.d0**(-30.d0)) $ ) then e(i) = e(i) - a(j)*e(i-j) end if end do end do do i = n+1,m do j = 1,n if ((a(j).le.-(10.d0**(-30.0d0)).or.a(j).ge.10.d0**(-30.d0)) $ .and. $ (e(i-j).le.-(10.d0**(-30.d0)).or.e(i-j).ge.10.d0**(-30.d0)) $ ) then e(i) = e(i) - a(j)*e(i-j) end if end do end do else do i = 1,m e(i) = e(i) - a(i) do j = 1,i-1 if ((a(j).le.-(10.d0**(-30.0d0)).or.a(j).ge.10.d0**(-30.d0)) $ .and. $ (e(i-j).le.-(10.d0**(-30.d0)).or.e(i-j).ge.10.d0**(-30.d0)) $ ) then e(i) = e(i) - a(j)*e(i-j) end if end do end do end if end C C THIS SUBROUTINE COMPUTES AUTOCORRELATION, AUTOCOVARIANCE C PSI-WEIGHTS AND THEORETICAL VARIANCE OF AN ARIMA MODEL C C INPUT PARAMETERS C PHI : AUTOREGRESSIVE PART OF THE MODEL B-J SIGN C TH : MOVING AVERAGE PART OF THE MODEL B-J SIGN C NP : DIMENSION OF PHI C NQ : DIMENSION OF TH C NLONG : DIMENSION OF GAM C GAM : AUTOCOVARIANCE C RHO : AUTOCORRELATIONS C VZ : THEORETICAL VARIANCE OF THE MODEL C VA : VARIANCE OF THE INNOVATIONS C G : DUMMY C NRHO : DIMENSION OF RHO C subroutine BFAC(phi,th,np,nq,nlong,gam,rho,vz,va,g,nrho) C C.. Implicits .. implicit none include 'units.cmn' C C.. Formal Arguments .. integer np,nq,nlong,nrho real*8 phi(np),th(nq),gam(0:nlong),rho(0:nrho),vz,va,g(0:*) C C.. Local Scalars .. integer i,imaxpq,j,m,npst1,nq2,pstar,qstar,sizeg C C.. Local Arrays .. c real*8 a(0:82),aa(0:82),am(100,100),e(0:999) real*8 a(0:100),aa(0:100),am(60,66),e(0:9999) C C.. External Calls .. external INPOL, MLTSOL, MPB, MPBF C C.. Intrinsic Functions .. intrinsic ABS, MAX, MIN C C ... Executable Statements ... C do i = 1,nlong gam(i) = 0.0d0 end do do i = 0,MAX(np,nq) a(i) = 0.0d0 aa(i) = 0.0d0 end do a(0) = 1.0d0 do i = 1,np a(i) = -phi(i) end do aa(0) = 1.0d0 do i = 1,nq aa(i) = -th(i) end do call MPBF(aa,aa,nq,nq,e) if (np .eq. 0) then do i = 0,nlong gam(i) = 0.0d0 end do nq2 = MIN(nq,nlong) do i = 0,nq2 gam(i) = e(nq-i) * va if (i .le. nrho) then if (ABS(va) .lt. 1.0d-13) then rho(i) = 0.0d0 else rho(i) = gam(i) / gam(0) end if end if end do vz = gam(0) do i = nq2+1,nrho rho(i) = 0.0d0 end do else pstar = np + 1 qstar = nq + 1 imaxpq = MAX(pstar,qstar) if (qstar .lt. pstar) then do i = 0,nq e(np-i) = e(nq-i) end do do i = 0,np-nq-1 e(i) = 0.0d0 end do else if (qstar .ne. pstar) then npst1 = pstar + 1 do i = npst1,qstar a(i) = 0.0d0 end do end if C C SET UP MATRIX C do i = 1,imaxpq do j = 1,imaxpq am(i,j) = 0.0d0 end do do j = 1,i am(i,j) = a(i-j) end do m = imaxpq - i + 1 do j = m,imaxpq am(i,j) = am(i,j) + a(imaxpq-j+m-1) end do am(i,imaxpq+1) = e(i-1) end do * WRITE(Ng,*)' subroutine BFAC, call 1' call MLTSOL(am,imaxpq,1,60,66) do i = 0,imaxpq-1 aa(i) = am(imaxpq-i,imaxpq+1) * g(i) = aa(i) end do * write(*,*)' imaxpq, np = ', imaxpq, np call getPSIE(aa,imaxpq-1,a,np,va,nlong+1,gam) gam(0) = 2 * gam(0) vz = gam(0) do i = 1,min(nlong,nrho) if (i .le. nrho) then if (ABS(va) .lt. 1.0d-13) then rho(i) = 0.0d0 else rho(i) = gam(i) / gam(0) end if end if end do end if end C C THIS SUBROUTINE COMPUTES THE CROSS CORRELATION BETWEEN TWO SERIES C C INPUT PARAMETERS C SER1 : FIRST SERIES C SER2 : SECOND SERIES C N1 : DIMENSION OF SER1 C N2 : DIMENSION OF SER2 C J : NUMBER OF CROSSCORRELATIONS C R : CROSSCORRELATIONS DIMENSION R(-J:J) C subroutine CROSS(ser1,ser2,n1,n2,j,r) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer mp,kp,mc parameter (kp = PFCST, mp = POBS, mc = 1000) C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 ser1(*) C.. In/Out Status: Maybe Read, Not Written .. real*8 ser2(*) C.. In/Out Status: Read, Not Written .. integer n1 C.. In/Out Status: Maybe Read, Not Written .. integer n2 C.. In/Out Status: Maybe Read, Not Written .. integer j C.. In/Out Status: Not Read, Maybe Written .. real*8 r(-mc:mc) C C.. Local Scalars .. integer i,in,is,k,nn real*8 chiqui,maser1,maser2,var1,var2,zmed1,zmed2 C C.. Local Arrays .. real*8 c(-mc:mc),w1(mp+2*kp),w2(mp+2*kp) C C.. Intrinsic Functions .. intrinsic ABS, MIN, SQRT C C ... Executable Statements ... C chiqui = 1.0d-15 maser1 = 0.0d0 maser2 = 0.0d0 do i = 1,n1 if (ABS(ser1(i)) .ge. maser1) then maser1 = ABS(ser1(i)) end if end do if (maser1.ge.0.0d0 .and. maser1.le.chiqui) return do i = 1,n2 if (ABS(ser2(i)) .ge. maser2) then maser2 = ABS(ser2(i)) end if end do maser2 = ABS(maser2) if (maser2.ge.0.0d0 .and. maser2.le.chiqui) return do i = 1,n1 w1(i) = ser1(i) end do do i = 1,n2 w2(i) = ser2(i) end do nn = MIN(n1,n2) if (n1 .lt. n2) then in = n2 - n1 do i = 1,nn w2(i) = w2(i+in) end do else if (n1 .ne. n2) then in = n1 - n2 do i = 1,nn w1(i) = w1(i+in) end do end if zmed1 = 0.0d0 zmed2 = 0.0d0 do i = 1,nn zmed1 = zmed1 + w1(i) zmed2 = zmed2 + w2(i) end do zmed1 = zmed1 / nn zmed2 = zmed2 / nn do i = 1,nn w1(i) = w1(i) - zmed1 w2(i) = w2(i) - zmed2 end do var1 = 0.0d0 var2 = 0.0d0 do i = 1,nn var1 = var1 + w1(i)*w1(i) var2 = var2 + w2(i)*w2(i) end do var1 = var1 / nn var2 = var2 / nn do i = 0,j c(i) = 0.0d0 is = i + 1 do k = is,nn c(i) = c(i) + w1(k)*w2(k-i) end do c(i) = c(i) / nn r(i) = c(i) / (SQRT(var1*var2)) end do do i = -j,-1 c(i) = 0.0d0 is = nn + i do k = 1,is c(i) = c(i) + w1(k)*w2(k-i) end do c(i) = c(i) / nn r(i) = c(i) / (SQRT(var1*var2)) end do end C C TO COMPUTE SQUARE ROOT, CONTROL IF ZERO C double precision function RAIZ(a) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. real*8 a C C.. Local Scalars .. real*8 peque C C.. Intrinsic Functions .. intrinsic SQRT * include 'stream.i' C C ... Executable Statements ... C peque = -1.0d-08 if (a .lt. 0.0d0) then RAIZ = 0.0d0 return end if if ((a.lt.0.0d0) .and. (a.lt.peque)) then RAIZ = 0.0d0 else RAIZ = SQRT(a) end if end c c c GetPSIE return the first nval PSIEs of Va*N(B)/D(B)=PSIE(1)+PSIE(2)B+PSIE(3)B^2+PSIE(4)B^3+... c where N(B)=N(0)+N(1)B+N(2)B^2+...+N(lN)B^lN c D(B)=D(0)+D(1)B+D(2)B^2+...+D(lD)B^lD with the aditional condition that D(0)<>0 c Va: is an escalar Subroutine getPSIE(N,lN,D,lD,Va,nval,PSIE) implicit none c c INPUT PARAMETERS real*8 N(0:60-1),D(0:60-1),Va integer nVal,lN,lD c c OUTPUT PARAMETERS real*8 PSIE(*) c c Intrinsic functions intrinsic MAX c c LOCAL PARAMETERS c real*8 k,D1(60),tmpPSIE(max(nval,lD)) real*8 k,D1(60),tmpPSIE(nval+lD) integer i,j D1(1)=1 do i=1,lD D1(i+1)=D(i)/D(0) end do tmpPSIE(1)=n(0) do j=2,lD k=0 do i=1,j-1 k=k-tmpPSIE(j-i)*D1(i+1) end do if (j .gt. lN+1) then tmpPSIE(j)=k else tmpPSIE(j)=k+N(j-1) end if end do do j=lD+1,nval k=0 do i=1,lD k=k-tmpPSIE(j-i)*D1(i+1) end do if (abs(k).lt.1.0d-60) then k=0.0d0 end if if (j .gt. lN+1) then tmpPSIE(j)=k else tmpPSIE(j)=k+N(j-1) end if end do do j=1,nval PSIE(j)=Va*tmpPSIE(j)/D(0) end do end subroutine c SeparaBF decompose in fraction in B and fraction in F c given N(B)M(F)/D1(B)Q1(F)=E_B(B)/D1(B)+H_F(F)/Q1(F) c INPUT c N(0:lN)=> N(0)+N(1)B+N(2)B^2+...+N(lN)B^lN c M(0:lM)=> M(0)+M(1)F+M(2)F^2+...+M(lM)F^lM c D1(0:lD1) c Q1(0:lQ1) c OUTPUT c E_B(1:lB+1)=>E_B(1)+E_B(2)B+E_B(3)B^2+...+E_B(lB+1)B^lB c H_F(1:lF+1)=>H_F(1)+H_F(2)F+H_F(3)F^2+...+H_F(lF+1)F^lF c Subroutine SeparaBF(N,lN,M,lM,D1,lD1,Q1,lQ1,E_B,lB,H_F,lF) implicit none include 'units.cmn' c INPUT PARAMETERS integer lN,lM,lD1,lQ1,nval real*8 N(0:lN),M(0:lM),D1(0:lD1),Q1(0:lQ1) c OUTPUT PARAMETERS integer lB,lF real*8 E_B(60),H_F(60) c LOCAL PARAMETERS integer i,j,lmQD real*8 mQD(60,61),MN(0:60-1),M0(0:60-1),N0(0:60-1) if (lN .ge. lD1) then lB=lN else c lB=lD1 !because H_F(1)=0 =>E_B(lD1+1)=0 lB=lD1-1 end if if (lM .ge. lQ1) then lF=lM else lF=lQ1 end if lmQD=lF+lB+2 c Preparing the matrix that define the linear equations system do j=1,lmQD do i=1,lB+1 if (((j-(lB+2)+i) .ge. 0) .and. ((j-(lB+2)+i) .le. lQ1)) then mQD(j,i)=Q1(j-(lB+2)+i) else mQD(j,i)=0 end if end do do i=1,lF+1 if (((lB-j+i) .ge. 0) .and. ((lB-j+i) .le. lD1)) then mQD(j,i+lB+1)=D1(lB-j+i) else mQD(j,i+lB+1)=0 end if end do end do mQD(2+lB+lF,lB+2)=1; c Preparing the non homogeneus part of the equations system call MPBF(M,N,lM,lN,MN) c NM^(1)B^lM+...+NM(lM)B+NM(lM+1)+NM(lM+2)F+...NM(lM+lN+1)F^lN DO j=-lB,lF+1 if (((j+lN) .ge. 0) .and. (j .le. lM)) then mQD(j+lB+1,lmQD+1)=MN(j+lN) else mQD(j+lB+1,lmQD+1)=0 end if end do * WRITE(Ng,*)' subroutine SeparaBF, call 1' call MLTSOL(mQD,lmQD,1,60,61) do j=0,lB E_B(j+1)=mQD(j+1,lmQD+1) end DO do j=0,lF H_F(j+1)=mQD(2+j+lB,lmQD+1) end do end subroutine ansub4.f0000664006604000003110000060174114521201407011541 0ustar sun00315stepsC Last change: Mar. 21 - add Filters table C Last change: REG 27 Apr 2006 C Previous change: REG 04 Apr 2006, 28 Feb 2006, 31 Aug 2005, 15 Sep 2005 C Previous change: BCM 19 May 2003 8:51 am C THIS SUBROUTINE COMPUTES THE AUTOCORRELATION FUNCTION OF THE COMPONENT C ESTIMATOR AND ESTIMATE (STATIONARY TRANSFORMATION) AND THE C WIENER-KOLMOGOROV FILTER C C INPUT PARAMETERS C TREND : TREND COMPONENT C TRENDS : NOSTATIONARY TREND ESTIMATOR C SA : SEASONALLY ADJUSTED SERIES C SC : SEASONAL COMPONENT C SCS : NOSTATIONARY SEASONAL ESTIMATOR C CYCLE : CYCLE COMPONENT C CYCLES : NOSTATIONARY CYCLE ESTIMATOR C IR : IRREGULAR COMPONENT C WVARA : ****** NOT USED ******* C WVARNP : INNOVATIONS VARIANCE OF TREND C WVARNS : INNOVATIONS VARIANCE OF SEASONAL C WVARNA : INNOVATIONS VARIANCE OF SEASONALLY ADJUSTED C WVARNC : INNOVATIONS VARIANCE OF CYCLE C QT1 : INNOVATIONS VARIANCE OF IRREGUALAR C PG : 0 FILES FOR GRAPH, 1 NO FILES C OUT : TO CONTROL THE PRINTOUT C MQ : FREQUENCY C TITLE : NAME OF THE SERIES C NOSERIE : 1 THEORETICAL ACFs. SET TO ZERO THE ONE FOR ESTIMATE. C SQF : STANDARD ERROR OF THE RESIDUALS C ITER : iter NMLSTS param C C subroutine AUTOCOMP(oz,z,trend,trends,sa,sc,scs,cycle,cycles,ir, $ wvara,varwnp,varwns,varwna,varwnc,phi,nphi, $ theta,nth,psieps,psiess,psiecs,psiue,nfl,qt1, $ pg,out,mq,title,noserie,sqf,ncycth,lamd,psiep, $ psies,psiec,psieas,lf,iter,IsCloseToTD) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer mc parameter (mc = 1000) real*8 t_ACF parameter (t_ACF=2.58d0) INCLUDE 'units.cmn' C C.. Formal Arguments .. integer nphi,nth,nfl,pg,out,mq,noserie,ncycth,lamd,lf,iter character title*80 real*8 oz(mpkp),z(mpkp),trend(mpkp),trends(mpkp),sa(mpkp), $ sc(mpkp),scs(mpkp),cycle(mpkp),cycles(mpkp), $ ir(mpkp),wvara,varwnp,varwns,varwna,varwnc,phi(*), $ theta(*),psieps(*),psiess(*),psiecs(*),psiue(*),qt1,sqf, $ psiep(*),psies(*),psiec(*),psieas(*),dvec(1) logical IsCloseToTD C C.. Local Scalars .. integer i,j,k,mq2,mqo,n,ndum,ndum1,ndum2,ndum3,ntd,nus,nvn integer mserror,nztr,nzs,nzsa,nstar character fname*30,subtitle*50, auxformat*80, ColsWk*4 real*8 tmean,varpas,vz,spurMarg data spurMarg /1.0D-4/ c integer nzlen C C.. Local Arrays .. real*8 dum(80),dum1(80),dum2(mpkp),dum3(80),imz(1000), $ rez(0:1000),sas(mpkp),us(50),vn(64),wkcyc(mpkp), $ wkir(mpkp),wks(mpkp),wksa(mpkp),wktrend(mpkp) C C.. External Calls .. external BFAC, CONV, USRENTRY C C.. Intrinsic Functions .. intrinsic DBLE include 'acfst.i' C Added by REG on 31 Aug 2005 for include file. include 'acfast.i' include 'estb.i' include 'hspect.i' include 'models.i' include 'sform.i' include 'stream.i' include 'bartlett.i' * include 'indhtml.i' include 'transcad.i' C C ... Executable Statements ... C mq2 = 2 * mq mserror = 1000 if (mq2 .gt. 24) then mq2 = 24 end if * write(Mtprof,*)' sqf, wvara = ', sqf, wvara C C COMPUTE THE ACF OF COMPONENTS,ESTIMATORS,ESTIMAT (STATION. TRANSF.) C C DUM() AND VN() US() ARE USED AS DUMMY TO COMPUTE THE ARRAYS TO BE PASSED C TO BFAC. IMZ AND REZ ARE USED FOR GAM AND G (NOT NEEDED). C C C ***TREND*** C C ntd = 60 colsWk='1111' if (out .eq. 0) then write (Nio,'(//,4x,''WIENER-KOLMOGOROV FILTERS (ONE SIDE)'',/, $ 4x,''------------------------------------'')') end if if (Nchi .eq. 1) then do i = 0,mq2 Acfpth(i) = 0.0d0 Acfper(i) = 0.0d0 Acfpem(i) = 0.0d0 end do do i = 1, mp wktrend(i) = 0.0d0 end do ColsWk(1:1)='0' else C C ACF OF THEORETICAL COMPONENT C do i = 1,Nchis-1 dum(i) = -Chis(i+1) end do do i = 1,Nthetp-1 vn(i) = -Thetp(i+1) end do ndum = Nchis - 1 if (ndum.lt.0) ndum = 0 nvn = Nthetp - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 1' call BFAC(dum,vn,ndum,nvn,mq2,rez,Acfpth,vz,varwnp,imz,mq2) Acfpth(0) = vz C C ACF OF ESTIMATOR C call CONV(Chis,Nchis,Thstr0,Qstar0,dum,ndum) do i = 1,ndum-1 dum(i) = -dum(i+1) end do call CONV(Thetp,Nthetp,Thetp,Nthetp,vn,nvn) call CONV(Psi,Npsi,Cycs,Ncycs,us,nus) call CONV(us,nus,vn,nvn,vn,nvn) C C********************************************************** C call CONV(us,nus,Thetp,Nthetp,dum2,ndum2) do i = 1,Qstar0-1 dum3(i) = -Thstr0(i+1) end do do i = 1,ndum2-1 dum1(i) = -dum2(i+1) end do ndum3 = Qstar0 - 1 ndum1 = ndum2 - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 2' call BFAC(dum3,dum1,ndum3,ndum1,ntd,wktrend,rez,vz,varwnp,imz,mq2 $ ) if (out .eq. 0) then write (Nio,'(/,4X,''TREND-CYCLE COMPONENT'',/)') write (Nio,'(12(2X,F7.4))') (wktrend(i), i = 1,ntd) * if ((pg .eq. 0).and.(iter.eq.0)) then * fname = 'FILTT.T4' * subtitle = 'TREND-CYCLE FILTER (T.D.)' * call PLOTFLT(fname,subtitle,wktrend,ntd,4,10) * end if end if C LINES OF CODE ADDED FOR X-13A-S : 3 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000, revised May 2001 CALL USRENTRY(wktrend,1,NTD,1,MPKP,2014) C END OF CODE BLOCK * call CONV(us,nus,vn,nvn,vn,nvn) do i = 1,nvn-1 vn(i) = -vn(i+1) end do ndum = ndum - 1 nvn = nvn - 1 varpas = varwnp**2 * WRITE(Ng,*)' subroutine AUTOCOMP, call 3' call BFAC(dum,vn,ndum,nvn,mserror,rez,Acfper,vz,varpas,imz, & mserror) Acfper(0) = vz C C ACF OF ESTIMATE C if (noserie .eq. 0) then tmean = 0.0d0 do i = 1,Nz-Nchins+1 trends(i) = 0.0d0 do j = 1,Nchins * write(Mtprof,*)' trends(',i,') = ',trends(i),' Chins(', * & j,') = ',Chins(j), ' trend(',i+Nchins-j,') = ', * & trend(i+Nchins-j) trends(i) = trends(i) + Chins(j)*trend(i+Nchins-j) * write(Mtprof,*)' trends(',i,') = ',trends(i) end do tmean = tmean + trends(i) end do n = Nz - Nchins + 1 tmean = tmean / DBLE(n) ** write(Mtprof,*)' tmean = ', tmean do k = 0,mq2 Acfpem(k) = 0.0d0 do i = k+1,n Acfpem(k) = Acfpem(k) + (trends(i)-tmean)*(trends(i-k)-tmean) end do Acfpem(k) = Acfpem(k) / DBLE(n) end do do i = 1,mq2 Acfpem(i) = Acfpem(i) / Acfpem(0) end do Acfpem(0) = Acfpem(0) / ((sqf**2)*wvara) end if end if C C C C ***SEASONALLY ADJUSTED*** C C if ((ncycth.eq.0) .and. (Nchcyc.eq.1)) then do i = 0,mq2 Acfath(i) = 0.0d0 Acfaer(i) = 0.0d0 Acfaem(i) = 0.0d0 end do do i = 1, mp wksa(i) = 0.0d0 end do ColsWk(2:2)='0' else C C ACF OF THEORETICAL COMPONENT C do i = 1,Nadjs-1 dum(i) = -Adjs(i+1) end do do i = 1,Nthadj-1 vn(i) = -Thadj(i+1) end do ndum = Nadjs - 1 nvn = Nthadj - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 4' call BFAC(dum,vn,ndum,nvn,mq2,rez,Acfath,vz,varwna,imz,mq2) Acfath(0) = vz C C ACF OF ESTIMATOR C call CONV(Adjs,Nadjs,Thstr0,Qstar0,dum,ndum) do i = 1,ndum-1 dum(i) = -dum(i+1) end do call CONV(Thadj,Nthadj,Thadj,Nthadj,vn,nvn) if (isCloseToTD) then call CONV(cyc,Ncyc,vn,nvn,vn,nvn) call CONV(Psi,Npsi,vn,nvn,vn,nvn) else call CONV(Psi,Npsi,vn,nvn,vn,nvn) end if C C********************************************************** call CONV(Thadj,Nthadj,Psi,Npsi,dum2,ndum2) do i = 1,Qstar0-1 dum3(i) = -Thstr0(i+1) end do do i = 1,ndum2-1 dum1(i) = -dum2(i+1) end do ndum3 = Qstar0 - 1 ndum1 = ndum2 - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 5' call BFAC(dum3,dum1,ndum3,ndum1,ntd,wksa,rez,vz,varwna,imz,mq2) if (out .eq. 0) then write (Nio,'(/,4X,''SA SERIES COMPONENT'',/)') write (Nio,'(12(2X,F7.4))') (wksa(i), i = 1,ntd) * if ((pg .eq. 0).and.(iter.eq.0)) then * fname = 'FILTADJ.T4' * subtitle = 'SA SERIES FILTER (T.D.)' * call PLOTFLT(fname,subtitle,wksa,ntd,4,10) * end if end if C LINES OF CODE ADDED FOR X-13A-S : 3 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000, revised May 2001 CALL USRENTRY(wksa,1,NTD,1,MPKP,2015) C END OF CODE BLOCK do i = 1,nvn-1 vn(i) = -vn(i+1) end do ndum = ndum - 1 nvn = nvn - 1 varpas = varwna**2 * WRITE(Ng,*)' subroutine AUTOCOMP, call 6' call BFAC(dum,vn,ndum,nvn,mserror,rez,Acfaer,vz,varpas,imz, & mserror) Acfaer(0) = vz C C ACF OF ESTIMATE C if (noserie .eq. 0) then tmean = 0.0d0 do i = 1,Nz-Nadjns+1 sas(i) = 0.0d0 do j = 1,Nadjns sas(i) = sas(i) + Adjns(j)*sa(i+Nadjns-j) end do tmean = tmean + sas(i) end do n = Nz - Nadjns + 1 tmean = tmean / DBLE(n) do k = 0,mq2 Acfaem(k) = 0.0d0 do i = k+1,n Acfaem(k) = Acfaem(k) + (sas(i)-tmean)*(sas(i-k)-tmean) end do Acfaem(k) = Acfaem(k) / DBLE(n) end do do i = 1,mq2 Acfaem(i) = Acfaem(i) / Acfaem(0) end do Acfaem(0) = Acfaem(0) / ((sqf**2)*wvara) end if end if C C C ***SEASONAL*** C C if (Npsi .eq. 1) then do i = 0,mq2 Acfsth(i) = 0.0d0 Acfser(i) = 0.0d0 Acfsem(i) = 0.0d0 end do do i = 1,mp wks(i) = 0.0D0 end do ColsWk(3:3)='0' else C C ACF OF THEORETICAL COMPONENT C do i = 1,Npsis-1 dum(i) = -Psis(i+1) end do do i = 1,Nthets-1 vn(i) = -Thets(i+1) end do ndum = Npsis - 1 nvn = Nthets - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 7' call BFAC(dum,vn,ndum,nvn,mq2,rez,Acfsth,vz,varwns,imz,mq2) Acfsth(0) = vz C C ACF OF ESTIMATOR C call CONV(Psis,Npsis,Thstr0,Qstar0,dum,ndum) do i = 1,ndum-1 dum(i) = -dum(i+1) end do call CONV(Thets,Nthets,Thets,Nthets,vn,nvn) call CONV(Chi,Nchi,vn,nvn,vn,nvn) call CONV(Cycs,Ncycs,vn,nvn,vn,nvn) C C********************************************************** call CONV(Thets,Nthets,Chi,Nchi,dum1,ndum1) call CONV(dum1,ndum1,Cyc,Ncyc,dum2,ndum2) do i = 1,Qstar0-1 dum3(i) = -Thstr0(i+1) end do do i = 1,ndum2-1 dum1(i) = -dum2(i+1) end do ndum3 = Qstar0 - 1 ndum1 = ndum2 - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 8' call BFAC(dum3,dum1,ndum3,ndum1,ntd,wks,rez,vz,varwns,imz,mq2) if (out .eq. 0) then write (Nio,'(/,4X,''SEASONAL COMPONENT'',/)') write (Nio,'(12(2X,F7.4))') (wks(i), i = 1,ntd) * if ((pg .eq. 0).and.(iter.eq.0)) then * fname = 'FILTS.T4' * subtitle = 'SEASONAL COMP. FILTER (T.D.)' * call PLOTFLT(fname,subtitle,wks,ntd,4,10) * end if end if C LINES OF CODE ADDED FOR X-13A-S : 3 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000, revised May 2001 CALL USRENTRY(wks,1,NTD,1,MPKP,2016) C END OF CODE BLOCK do i = 1,nvn-1 vn(i) = -vn(i+1) end do ndum = ndum - 1 nvn = nvn - 1 varpas = varwns**2 * WRITE(Ng,*)' subroutine AUTOCOMP, call 9' call BFAC(dum,vn,ndum,nvn,mserror,rez,Acfser,vz,varpas,imz, & mserror) Acfser(0) = vz C C ACF OF ESTIMATE C if (noserie .eq. 0) then tmean = 0.0d0 do i = 1,Nz-Npsins+1 scs(i) = 0.0d0 do j = 1,Npsins scs(i) = scs(i) + Psins(j)*sc(i+Npsins-j) end do tmean = tmean + scs(i) end do n = Nz - Npsins + 1 tmean = tmean / DBLE(n) do k = 0,mq2 Acfsem(k) = 0.0d0 do i = k+1,n Acfsem(k) = Acfsem(k) + (scs(i)-tmean)*(scs(i-k)-tmean) end do Acfsem(k) = Acfsem(k) / DBLE(n) end do do i = 1,mq2 Acfsem(i) = Acfsem(i) / Acfsem(0) end do Acfsem(0) = Acfsem(0) / ((sqf**2)*wvara) end if end if C C C ***CYCLE*** C C if (varwnc.lt.1.0d-10 .or.((ncycth.eq.0) .and. (Ncyc.eq.1))) then do i = 0,mq2 Acfcth(i) = 0.0d0 Acfcer(i) = 0.0d0 Acfcem(i) = 0.0d0 end do do i = 1,mp wkcyc(i) = 0.0D0 end do ColsWk(4:4)='0' else C C ACF OF THEORETICAL COMPONENT C do i = 1,Ncycs-1 dum(i) = -Cycs(i+1) end do ndum = Ncycs - 1 do i = 1,Nthetc-1 vn(i) = -Thetc(i+1) end do nvn = Nthetc - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 10' call BFAC(dum,vn,ndum,nvn,mq2,rez,Acfcth,vz,varwnc,imz,mq2) Acfcth(0) = vz C C ACF OF ESTIMATOR C call CONV(Cycs,Ncycs,Thstr0,Qstar0,dum,ndum) do i = 1,ndum-1 dum(i) = -dum(i+1) end do call CONV(Thetc,Nthetc,Thetc,Nthetc,vn,nvn) call CONV(Psi,Npsi,Chi,Nchi,us,nus) call CONV(us,nus,vn,nvn,vn,nvn) call CONV(Cycns,Ncycns,vn,nvn,vn,nvn) C C********************************************************** call CONV(Chi,Nchi,Psi,Npsi,dum1,ndum1) call CONV(dum1,ndum1,Thetc,Nthetc,dum2,ndum2) do i = 1,Qstar0-1 dum3(i) = -Thstr0(i+1) end do do i = 1,ndum2-1 dum1(i) = -dum2(i+1) end do ndum3 = Qstar0 - 1 ndum1 = ndum2 - 1 * WRITE(Ng,*)' subroutine AUTOCOMP, call 11' call BFAC(dum3,dum1,ndum3,ndum1,ntd,wkcyc,rez,vz,varwnc,imz,mq2) if (out .eq. 0) then If (IsCloseToTD) then write (Nio,'(/,4X,''TD STOCH. COMPONENT'',/)') else write (Nio,'(/,4X,''TRANSITORY COMPONENT'',/)') end if write (Nio,'(12(2X,F7.4))') (wkcyc(i), i = 1,ntd) * if ((pg .eq. 0).and.(iter.eq.0)) then * fname = 'FILTC.T4' * if (IsCloseToTD) then * subtitle = 'TD STOCH. COMP. FILTER (T.D.)' * else * subtitle = 'TRANSITORY COMP. FILTER (T.D.)' * end if * call PLOTFLT(fname,subtitle,wkcyc,ntd,4,10) * end if end if C LINES OF CODE ADDED FOR X-13A-S : 1 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000, revised May 2001 CALL USRENTRY(wkcyc,1,NTD,1,MPKP,2017) C END OF CODE BLOCK do i = 1,nvn-1 vn(i) = -vn(i+1) end do ndum = ndum - 1 nvn = nvn - 1 varpas = varwnc**2 * WRITE(Ng,*)' subroutine AUTOCOMP, call 12' call BFAC(dum,vn,ndum,nvn,mserror,rez,Acfcer,vz,varpas,imz, & mserror) Acfcer(0) = vz C C ACF OF ESTIMATE C if (noserie .eq. 0) then tmean = 0.0d0 do i = 1,Nz-Ncycns+1 cycles(i) = 0.0d0 do j = 1,Ncycns cycles(i) = cycles(i) + Cycns(j)*cycle(i+Ncycns-j) end do tmean = tmean + cycles(i) end do n = Nz - Ncycns + 1 tmean = tmean / DBLE(n) do k = 0,mq2 Acfcem(k) = 0.0d0 do i = k+1,n Acfcem(k) = Acfcem(k) + (cycles(i)-tmean)*(cycles(i-k)-tmean) end do Acfcem(k) = Acfcem(k) / DBLE(n) end do do i = 1,mq2 Acfcem(i) = Acfcem(i) / Acfcem(0) end do Acfcem(0) = Acfcem(0) / ((sqf**2)*wvara) end if end if c RREGULAR C IF (NOADMISS.EQ.2) GOTO 96 do i = 1,mq2 Acfith(i) = 0.0d0 end do Acfith(0) = qt1 if (qt1.ne.0.d0) then C C ACF OF ESTIMATOR C do i = 1,Qstar0-1 dum(i) = -Thstr0(i+1) end do do i = 1,Ntotd-1 vn(i) = -Totden(i+1) end do ndum = Qstar0 - 1 nvn = Ntotd - 1 C C********************************************************** * WRITE(Ng,*)' subroutine AUTOCOMP, call 13' call BFAC(dum,vn,ndum,nvn,ntd,wkir,rez,vz,qt1,imz,mq2) if (out .eq.0) then write (Nio,'(/,4X,''IRREGULAR COMPONENT'',/)') write (Nio,'(12(2X,F7.4))') (wkir(i), i = 1,ntd) * if ((pg .eq. 0).and.(iter.eq.0)) then * fname = 'FILTI.T4' * subtitle = 'IRREGULAR COMP. FILTER (T.D.)' * call PLOTFLT(fname,subtitle,wkir,ntd,4,10) * end if end if C LINES OF CODE ADDED FOR X-13A-S : 3 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000, revised May 2001 CALL USRENTRY(wkir,1,NTD,1,MPKP,2018) C END OF CODE BLOCK varpas = qt1**2 * WRITE(Ng,*)' subroutine AUTOCOMP, call 14' call BFAC(dum,vn,ndum,nvn,mserror,rez,Acfier,vz,varpas,imz, & mserror) Acfier(0) = vz c C C ACF OF ESTIMATE C if (noserie .eq. 0) then tmean = 0.0d0 do i = 1,Nz tmean = tmean + ir(i) end do n = Nz tmean = tmean / DBLE(n) do k = 0,mq2 Acfiem(k) = 0.0d0 do i = k+1,n Acfiem(k) = Acfiem(k) + (ir(i)-tmean)*(ir(i-k)-tmean) end do Acfiem(k) = Acfiem(k) / DBLE(n) end do do i = 1,mq2 Acfiem(i) = Acfiem(i) / Acfiem(0) end do Acfiem(0) = Acfiem(0) / ((sqf**2)*wvara) end if else do i = 1,mq2 Acfiem(i) =0.0d0 acfith(i)=0.0d0 acfier(i)=0.0d0 enddo do i=1,mp+kp wkir(i)=0.0d0 enddo end if if (out.eq.0) then write (Nio,'(/,4X,''Filters'',/)') 1000 format ( $ //,3x,' LAG',11x,'TREND-CYCLE',11x,'SA SERIES',11x,'SEASONAL', $ 11x,a,11x,'IRREGULAR',/) write (Nio,1000)transLCad(1:nTransLCad) do i=1,ntd write(Nio,1001)i-1,wktrend(i),wksa(i),wks(i),wkcyc(i),wkir(i) enddo 1001 format(3x,i3,5(11x,F7.4)) end if C C C HERE INTRODUCE THE NEW CONTRIBUTION TABLE C if (out .eq. 0) then write (Nio,'(////,4x,''CONTRIBUTION OF ORIGINAL SERIES AND '', $ ''OF ITS INNOVATIONS TO THE ESTIMATOR'',/,4x, $ ''OF THE COMPONENTS FOR THE PRESENT PERIOD.'',/)') write (Nio, $'(4x,''COMPONENT'',22x,''TREND-CYCLE'',18x, $ ''SEASONAL COMPONENT'',14x,''TRANS.+IRREGULAR'',/)') write (Nio,'(4x, $''CONTRIBUTION OF'',3(8x,''OBSERVATION'',4x,''INNOVATION''),/)') write (Nio,'(4X,''LAST PERIOD'',2X,3(9X,F9.3,6X,F9.3),/)') $ wktrend(1), psiep(lf+1), wks(1), psies(lf+1), $ wkcyc(1)+wkir(1), psiue(lf+1)+psiec(lf+1) write (Nio,'(4X,''NEXT PERIOD'',2X,3(9X,F9.3,6X,F9.3),/)') $ wktrend(2), psiep(lf), wks(2), psies(lf), wkcyc(2)+wkir(2), $ psiue(lf)+psiec(lf) write (Nio,'(4X,''1 YEAR AHEAD'',1X,3(9X,F9.3,6X,F9.3),/)') $ wktrend(mq+1), psiep(lf+1-mq), wks(mq+1), psies(lf+1-mq), $ wkcyc(mq+1)+wkir(mq+1), psiue(lf+1-mq)+psiec(lf+1-mq) write (Nio,'(4X,''2 YEAR AHEAD'',1X,3(9X,F9.3,6X,F9.3),/)') $ wktrend(2*mq+1), psiep(lf+1-2*mq), wks(2*mq+1), $ psies(lf+1-2*mq), wkcyc(2*mq+1)+wkir(2*mq+1), $ psiue(lf+1-2*mq)+psiec(lf+1-2*mq) write (Nio,'(/)') write (Nio,'(4x,''Check :'',/,12x,''- The sum of the 3 '', $''weights associated with the observation,'',/,14x, $''for the last period, should be 1.0.'',/,12x, $''- The same should happen with the 3 weights associated '', $''with the innovations for the last period.'',/,12x, $''- The sum of the 3 weights associated with the '', $''innovation, for future period,'',/,14x, $''should be zero.'',/)') write (Nio,'(4x,''Note : some examples'',/,12x, $ ''* If the last observation on the series has a '', $ ''relatively large weight for the seasonal'',/,14x, $ ''component, the series contains a relatively '', $ ''important seasonal component.'',/,12x, $ ''* If next period innovation has a relatively '', $ ''large weight for the trend-cycle'',/,14x, $ ''component, the estimator of this component '', $ ''will be strongly affected by the'',/,14x, $ ''next period forecast error (i.e., the first '', $ ''revision of the concurrent'',/,14x, $ ''estimator will be large).'',/,12x, $ ''* If the weight for some component, associated '', $ ''with the innovation two-year into'',/,14x, $ ''the future is large, this would indicate that '', $ ''the estimator, after two years of'',/,14x, $ ''revisions is still far from convergence.'')') end if C C C C C HERE INTRODUCE THE NEW VARIANCES TABLES * if (noserie .eq. 0) then * CALL VARIANCES(OZ,Z,TREND,SA,SC,CYCLE,IR,NZ,LAMD,OUT, * $ QT1,VARWNP,VARWNS,VARWNC, * $ THSTR0,QSTAR0,PSIEPS,PSIESS, * $ PSIECS,PSIUE,PSIEA,NFL) * end if C C C C OUTPUT ACF OF COMPONENTS C if (out .eq. 0) then write (Nio,'(//)') write (Nio,'(4x,''DISTRIBUTION OF COMPONENT, '', $ ''THEORETICAL ESTIMATOR AND EMPIRICAL ESTIMATE'',/,4x, $ ''---------------------------'', $ ''--------------------------------------------'',/)') 7000 format ( $ /,' ',10x,'AUTOCORRELATION FUNCTION OF COMPONENTS', $ ' (STATIONARY TRANSFORMATION)'///) c 34x,'TREND-CYCLE',45x, c $ 'SA SERIES',//,' LAG',5x,2(5x,'COMPONENT',4x,'ESTIMATOR',4x, c $ ' ESTIMATE',5x,'SE',9x)/) write (Nio,7000) end if mqo = mq nztr = nz - Nchins+1 nzs = nz - Npsins+1 nzsa = nz- Nadjns+1 nstar = 0 do i = 0,24 bsetr(i) = 0.0d0 bses(i) = 0.0d0 bsesa(i) = 0.0d0 bsecyc(i) = 0.0d0 bseir(i) = 0.0d0 end do if (noserie .eq. 0) then call SEBARTLETTACF (nz,nztr,nzs,nzsa,mserror,mqo,bsetr,bses, & bsesa,bsecyc,bseir,qt1) end if * if ((pg .eq. 0).and.(iter.eq.0).and.(out.eq.0)) then * fname = 'ACFTTRE.T2' * subtitle = 'THEOR. COMP.: ACF OF TREND-CYCLE (ST)' * call PLOTACF0(fname,subtitle,Acfpth,mq2,0,0) * fname = 'ACFRTRE.T2' * subtitle = 'THEOR. EST.: ACF OF TREND-CYCLE (ST)' * call PLOTACF0(fname,subtitle,Acfper,mq2,0,0) * fname = 'ACFETRE.T2' * subtitle = 'ESTIMATE: ACF OF TREND-CYCLE (ST)' * call PLOTACF0(fname,subtitle,Acfpem,mq2,0,0) * fname = 'ACFTSADJ.T2' * subtitle = 'THEOR. COMP.: ACF OF SA SERIES (ST)' * call PLOTACF0(fname,subtitle,Acfath,mq2,0,0) * fname = 'ACFRSADJ.T2' * subtitle = 'THEOR. EST.: ACF OF SA SERIES (ST)' * call PLOTACF0(fname,subtitle,Acfaer,mq2,0,0) * fname = 'ACFESADJ.T2' * subtitle = 'ESTIMATE: ACF OF SA SERIES (ST)' * call PLOTACF0(fname,subtitle,Acfaem,mq2,0,0) * end if * mqo = mq C IF (MQ.LT.4) MQO=2*MQ if (out .eq. 0) then 5412 format(///31x,'TREND-CYCLE'// $ ' LAG',10x,'COMPONENT',4x,'ESTIMATOR',4x,' ESTIMATE',6x,'SE'/) 7001 format (i4,4x,4(2x,f11.3)) 7011 format (i4,4x,3(2x,f11.3),8x,'(***)') if (Nthetp .gt. 1) then write (Nio,5412) do i = 1,mqo if (bsetr(i) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7011) $ i, Acfpth(i), Acfper(i), Acfpem(i) else write (Nio,7001) $ i, Acfpth(i), Acfper(i), Acfpem(i), bsetr(i) end if end do if (bsetr(0) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7012) $ Acfpth(0), Acfper(0), Acfpem(0) else write (Nio,7002) $ Acfpth(0), Acfper(0), Acfpem(0), bsetr(0) end if end if 5413 format(///28x,'SA SERIES'// $ ' LAG',10x,'COMPONENT',4x,'ESTIMATOR',4x,' ESTIMATE',6x,'SE'/) if (Nthadj .gt. 1) then write (Nio,5413) do i = 1,mqo if (bsesa(i) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7011) $ i, Acfath(i), Acfaer(i),Acfaem(i) else write (Nio,7001) $ i, Acfath(i), Acfaer(i),Acfaem(i),bsesa(i) end if end do if (bsesa(0) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7012) $ Acfath(0), Acfaer(0), Acfaem(0) else write (Nio,7002) $ Acfath(0), Acfaer(0), Acfaem(0), bsesa(0) end if end if 5414 format(///33x,'SEASONAL'// $ ' LAG',10x,'COMPONENT',4x,'ESTIMATOR',4x,' ESTIMATE',6x,'SE'/) if (Nthets .gt. 1) then write (Nio,5414) do i = 1,mqo if (bses(i) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7011) $ i, Acfsth(i), Acfser(i), Acfsem(i) else write (Nio,7001) $ i, Acfsth(i), Acfser(i), Acfsem(i), bses(i) end if end do if (bses(0) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7012) $ Acfsth(0), Acfser(0), Acfsem(0) else write (Nio,7002) $ Acfsth(0), Acfser(0), Acfsem(0), bses(0) end if end if * 6002 format ('VAR.(*)', * $ 4('',f11.3,''),'') * 6012 format ('VAR.(*)', * $ 3('',f11.3,''), * $ '(***)') 7002 format (///' VAR.(*)',4(2x,f11.3)) 7012 format (///' VAR.(*)',3(2x,f11.3),8x,'(***)') * if ((Acfpth(0).le.Acfper(0)).or.(Acfpth(0).le.Acfpem(0))) then * call setCvar('E') * end if * if ((Acfath(0).le.Acfaer(0)).or.(Acfath(0).le.Acfaem(0))) then * call setCvar('E') * end if C C COMMENT OUTPUT ACF CYCLE C c if ((ncycth.eq.0) .and. (Ncyc.eq.1)) then if (Nthetc .gt. 1 .and. varwnc.gt.1.0d-10 ) then 6401 format('LAG','COMPONENT', $ 'ESTIMATOR','ESTIMATE', $ 'SE') 5401 format(///32x,'TRANSITORY'// $ ' LAG',10x,'COMPONENT',4x,'ESTIMATOR',4x,' ESTIMATE',6x,'SE'/) 5411 format(///32x,'TD STOCH.'// $ ' LAG',10x,'COMPONENT',4x,'ESTIMATOR',4x,' ESTIMATE',6x,'SE'/) if (out.eq.0) then * if ((pg.eq.0).and.(iter.eq.0)) then * fname = 'ACFTTRA.T2' * write(subtitle,'("THEOR. COMP.: ACF OF ",A, * $ ". COMPONENT (ST)")') transCad(1:nTransCad) * call PLOTACF0(FNAME,SUBTITLE,ACFCTH,MQ2,0,0) * fname = 'ACFRTRA.T2' * write(subtitle,'("THEOR. EST.: ACF OF ",A, * $ ". COMPONENT (ST)")') transCad(1:nTransCad) * call PLOTACF0(FNAME,SUBTITLE,ACFCER,MQ2,0,0) * fname = 'ACFECYC.T2' * write(subtitle,'("ESTIMATE: ACF OF ",A, * $ ". COMPONENT (ST)")') transCad(1:nTransCad) * call PLOTACF0(FNAME,SUBTITLE,ACFCEM,MQ2,0,0) * end if if (IsCloseTOTD) then write (nio, 5411) else write (nio, 5401) end if do i=1,mqo if (bsecyc(i) .lt. 0.0d0) then nstar = nstar + 1 write (nio,7011) i,acfcth(i),acfcer(i),acfcem(i) else write (nio,7001) i,acfcth(i),acfcer(i),acfcem(i),bsecyc(i) end if end do if (bsecyc(0) .lt. 0.0d0) then nstar = nstar + 1 write (nio,7012) acfcth(0),acfcer(0),acfcem(0) else write (nio,7002) acfcth(0),acfcer(0),acfcem(0),bsecyc(0) end if end if end if * 6402 format('',i4,'', * $ 4('',f11.3,''),'') * 6404 format('VAR.(*)', * $ 4('',f11.3,''),'') 5402 format(i4,4x,4(2x,f11.3)) 5404 format(///' VAR.(*)',4(2x,f11.3)) * write (Nio,7003) 7004 format ( $ /,' ',10x,'AUTOCORRELATION FUNCTION OF COMPONENTS', $ ' (STATIONARY TRANSFORMATION)'///19x,'IRREGULAR',37x,'SEASONAL'// $ ' LAG',7x,2(4x,'COMPONENT',4x,'ESTIMATOR',4x,' ESTIMATE',3x)/) end if if (noserie.eq.0) then if ((QT1.gt.0.0d0 .or.NPSI.gt.1 .or. NTHETS.gt.1) .and. $ ((Acfpth(0).le. (Acfper(0)-spurMarg)).or. $ (abs(Acfper(0)-Acfpem(0)).gt.t_ACF*bsetr(0)))) then call setCvar('E') end if if ( (NPSI.gt.1 .or. NTHETS.gt.1) .and. $ ((Acfath(0).le. (Acfaer(0)-spurMarg)).or. $ (abs(Acfaer(0)-Acfaem(0)).gt.t_ACF*bsesa(0)))) then call setCvar('E') end if if ((Acfith(0).le. (Acfier(0)-spurMarg)).or. $ (abs(Acfier(0)-Acfiem(0)).gt.t_ACF*bseir(0))) then call setCvar('E') end if if ( (NPSI.gt.1 .or. NTHETS.gt.1) .and. $ (Acfsth(0).le. (Acfser(0)-spurMarg)).or. $ (abs(Acfser(0)-Acfsem(0)).gt.t_ACF*bses(0))) then call setCvar('E') end if end if * if ((out.eq.0).and.(iter.eq.0).and.(pg .eq. 0)) then * fname = 'ACFRIR.T2' * subtitle = 'THEOR. EST.: ACF OF IRREGULAR (ST)' * call PLOTACF0(fname,subtitle,Acfier,mq2,0,0) * fname = 'ACFEIR.T2' * subtitle = 'ESTIMATE: ACF OF IRREGULAR (ST)' * call PLOTACF0(fname,subtitle,Acfiem,mq2,0,0) * fname = 'ACFTSEAS.T2' * subtitle = 'THEOR. COMP.: ACF OF SEASONAL (ST)' * call PLOTACF0(fname,subtitle,Acfsth,mq2,0,0) * fname = 'ACFRSEAS.T2' * subtitle = 'THEOR. EST.: ACF OF SEASONAL (ST)' * call PLOTACF0(fname,subtitle,Acfser,mq2,0,0) * fname = 'ACFESEAS.T2' * subtitle = 'ESTIMATE: ACF OF SEASONAL (ST)' * call PLOTACF0(fname,subtitle,Acfsem,mq2,0,0) * end if dvec(1)=Acfpth(0) call USRENTRY(Acfpth(0),1,1,1,1,1910) dvec(1)=Acfper(0) call USRENTRY(Acfper(0),1,1,1,1,1911) dvec(1)=Acfpem(0) call USRENTRY(Acfpem(0),1,1,1,1,1912) dvec(1)=Acfath(0) call USRENTRY(Acfath(0),1,1,1,1,1913) dvec(1)=Acfaer(0) call USRENTRY(Acfaer(0),1,1,1,1,1914) dvec(1)=Acfaem(0) call USRENTRY(Acfaem(0),1,1,1,1,1915) dvec(1)=Acfith(0) call USRENTRY(Acfith(0),1,1,1,1,1916) dvec(1)=Acfier(0) call USRENTRY(Acfier(0),1,1,1,1,1108) dvec(1)=Acfiem(0) call USRENTRY(Acfiem(0),1,1,1,1,1109) dvec(1)=Acfsth(0) call USRENTRY(Acfsth(0),1,1,1,1,1917) dvec(1)=Acfser(0) call USRENTRY(Acfser(0),1,1,1,1,1918) dvec(1)=Acfsem(0) call USRENTRY(Acfsem(0),1,1,1,1,1919) if (out .eq. 0) then if (qt1.ne.0.0d0) then 5415 format(///33x,'IRREGULAR'// $ ' LAG',10x,'COMPONENT',4x,'ESTIMATOR',4x,' ESTIMATE',6x,'SE'/) write (Nio,5415) do i = 1,mqo if (bseir(i) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7011) $ i, Acfith(i), Acfier(i), Acfiem(i) else write (Nio,7001) $ i, Acfith(i), Acfier(i), Acfiem(i), bseir(i) end if end do if (bseir(0) .lt. 0.0d0) then nstar = nstar + 1 write (Nio,7012) $ Acfith(0), Acfier(0), Acfiem(0) else write (Nio,7002) $ Acfith(0), Acfier(0), Acfiem(0), bseir(0) end if if (nstar .gt. 0) then write (Nio,'(2x,''(***) : Unreliable SE estimate.'')') end if write (Nio,'(//,2x,''(*) IN UNITS OF VAR(A)'')') end if end if C C END COMMENT C C end C C THIS SUBPROGRAM COMPUTES THE STANDARD ERROR IN LEVELS FOR THE C COMPONENTS AND THEIR FORECAST C C INPUT PARAMETERS C Z : ORIGINAL SERIES + FORECAST C TREND : TREND COMPONENT + FORECAST C SC : SEASONAL COMPONENT + FORECAST C CYCLE : CYCLICAL COMPONENT + FORECAST C SA : SEASONALLY ADJUSTED SERIES + FORECAST C NCHI : DIMENSION OF THE TREND DENOMINATOR MODEL C NPSI : DIMENSION OF THE SEASONAL DENOMINATOR MODEL C NCYC : DIMENSION OF THE CYCLE DENOMINATOR MODEL C NZ : DIMENSION OF THE SERIES AND COMPONENTS C MQ : FREQUENCY C subroutine SERRORL(z,trend,sc,cycle,sa,nchi,npsi,ncyc,ncycth,nz, $ sqf,lfor,alpha,IsCloseToTD,varwnc,out) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n12 parameter (n12 = 12) C C.. Formal Arguments .. integer nchi,npsi,ncyc,ncycth,nz,lfor,out real*8 z(*),trend(*),sc(*),cycle(*),sa(*),sqf,alpha,varwnc logical IsCloseToTD C C.. Local Scalars .. integer i,j,mq2 real*8 rfactse,sminus,splus C C.. Local Arrays .. real*8 sic(kp),sip(kp),sis(kp),sisa(kp),siz(kp), $ tmp(kp),stmp(kp) C C.. Intrinsic Functions .. intrinsic EXP, LOG include 'sfcast.i' include 'serrlev.i' include 'sesfcast.i' include 'stream.i' include 'transcad.i' C C ... Executable Statements ... C mq2 = lfor * if (mq2 .gt. 24) then * mq2 = 24 * end if CALL setdp(0D0,kp,sic) CALL setdp(0D0,kp,sip) CALL setdp(0D0,kp,sis) CALL setdp(0D0,kp,sisa) CALL setdp(0D0,kp,siz) if (nchi .gt. 1) then do i = nz+1,nz+mq2 splus = LOG(trend(i)) + alpha*Setp(i-nz) sminus = LOG(trend(i)) - alpha*Setp(i-nz) sip(i-nz) = (EXP(splus)-EXP(sminus)) / (2.0d0 * alpha) end do end if if (npsi .gt. 1) then do i = nz+1,nz+mq2 splus = LOG(sc(i)/100.0d0) + alpha*Sets(i-nz) sminus = LOG(sc(i)/100.0d0) - alpha*Sets(i-nz) sis(i-nz) = (EXP(splus)-EXP(sminus)) / (2.0d0 * alpha) end do else do i = nz+1,nz+mq2 sis(i-nz) = 0.0d0 end do end if if (varwnc.gt.1.0D-10 .and. ((ncycth.eq.1) .or. (ncyc.gt.1))) then do i = nz+1,nz+mq2 splus = LOG(cycle(i)/100.0d0) + alpha*Setc(i-nz) sminus = LOG(cycle(i)/100.0d0) - alpha*Setc(i-nz) sic(i-nz) = (EXP(splus)-EXP(sminus)) / (2.0d0 * alpha) end do else do i = nz+1,nz+mq2 sic(i-nz) = 0.0d0 end do end if if ((nchi+ncyc+ncycth) .gt. 2) then do i = nz+1,nz+mq2 splus = LOG(sa(i)) + alpha*Seta(i-nz) sminus = LOG(sa(i)) - alpha*Seta(i-nz) sisa(i-nz) = (EXP(splus)-EXP(sminus)) / (2.0d0 * alpha) end do else do i = nz+1,nz+mq2 sisa(i-nz) = 0.0d0 end do end if if (Nsfcast .eq. 0) then do i = nz+1,nz+mq2 splus = z(i) + alpha*Seser(i-nz) sminus = z(i) - alpha*Seser(i-nz) siz(i-nz) = (EXP(splus)-EXP(sminus)) / (2.0d0 * alpha) end do else do i = 1,mq2 splus = Sfcast(i) + alpha*Sesfcast(i) sminus = Sfcast(i) - alpha*Sesfcast(i) Sesfcast(i) = (EXP(splus)-EXP(sminus)) / (2.0d0 * alpha) end do end if if (Nsfcast .eq. 0) then do i = 1,mq2 j = nz + i tmp(i) = EXP(z(j)) stmp(i) = siz(i) end do else rfactse = Sqfsave / sqf do i = 1,mq2 j = nz + i tmp(i) = EXP(Sfcast(i)) stmp(i) = Sesfcast(i) end do end if call usrentry(tmp,1,mq2,1,kp,1205) call usrentry(stmp,1,mq2,1,kp,1206) if (Nsfcast .eq. 0) then call usrentry(sip,1,mq2,1,kp,1256) call usrentry(sisa,1,mq2,1,kp,1257) else rfactse = Sqfsave / sqf do i=1,mq2 tmp(i) = sip(i)*rfactse enddo call usrentry(tmp,1,mq2,1,kp,1256) call usrentry(sisa,1,mq2,1,kp,1257) endif if (npsi .gt. 1) then do i=1,mq2 tmp(i) = sis(i)*100.0d0 enddo call usrentry(tmp,1,mq2,1,kp,1258) endif if (varwnc.gt.1.0D-10 .and. ((ncycth.eq.1) .or. (ncyc.gt.1))) then if (Nsfcast .eq. 0) then call usrentry(sic,1,mq2,1,kp,1259) else do i=1,mq2 tmp(i) = sic(i)*100.0d0 enddo call usrentry(tmp,1,mq2,1,kp,1259) endif endif if (out .ne.0) then return endif write (Nio,'(///,2x,'' FORECAST OF STOCHASTIC SERIES AND '', $ ''COMPONENTS (LEVELS)'',/,2x, $ '' -----------------------------------------------------'')') 7000 format (/, $ 1x,'PERIOD',10x,'SERIES',24x,' TREND-CYCLE',20x,'ADJUSTED',// $ 12x,'FORECAST',8x,'S.E.',9x,'FORECAST',10x,'S.E.',9x, $ 'FORECAST',9x,'S.E.'/) 7001 format ( $ 2x,i4,5x,G11.4,2x,G11.4,5x,G11.4,4x,G11.4,5x,G11.4,3x,G11.4) write (Nio,7000) if (Nsfcast .eq. 0) then do i = 1,mq2 j = nz + i tmp(i) = EXP(z(j)) stmp(i) = siz(i) write (Nio,7001) $ i, EXP(z(j)), siz(i), trend(j), sip(i), sa(j), sisa(i) end do else rfactse = Sqfsave / sqf do i = 1,mq2 j = nz + i tmp(i) = EXP(Sfcast(i)) stmp(i) = Sesfcast(i) write (Nio,7001) $ i, EXP(Sfcast(i)), Sesfcast(i), $ EXP(LOG(trend(j))*Rfact(i)), sip(i)*rfactse, $ EXP(Sfcast(i))-EXP(LOG(sc(j)/100.0d0)), sisa(i) end do end if if (varwnc.lt.1.0D-10 .or.(ncycth.eq.0) .and. (ncyc.eq.1)) then 7002 format ( $ //,' ',/1x,'PERIOD',13x,' SEASONAL FACTORS',//,18x,'FORECAST' $ ,10x,'S.E.',/) write (Nio,7002) if (Nsfcast .eq. 0) then do i = 1,mq2 j = nz + i 7003 format (2x,i4,11x,g11.4,4x,g11.4) write (Nio,7003) i, sc(j), sis(i)*100.0d0 end do else do i = 1,mq2 j = nz + i write (Nio,7003) $ i, EXP(LOG(sc(j)/100.0d0))*100.0d0, sis(i)*100.0d0 end do end if if (Nsfcast .eq. 1) then write (Nio,'(/8X,''THE APPROXIMATION WILL LIKELY INDUCE'')') write (Nio,'(8X,''NOZERO IRREGULAR FORECASTS,'')') write (Nio,'(8X,''AND HENCE THE FORECAST OF THE ADJUSTED'')') write (Nio,'(8x,''SERIES WILL NOT BE THAT OF '', $ ''THE TREND-CYCLE'')') end if else 7004 format ( $ //,' ',/1x,'PERIOD',20x,' SEASONAL FACTORS',17x,A, $ '. COMPONENT',//,16x,'FORECAST',10x,'S.E.',11x,'FORECAST' $ ,14x,'S.E.'/) write (Nio,7004) TransCad(1:nTransCad) if (Nsfcast .eq. 0) then do i = 1,mq2 j = nz + i 7005 format (2x,i4,7x,g11.4,4x,g11.4,7x,g11.4,7x,g11.4) write (Nio,7005) i, sc(j), sis(i)*100.0d0, cycle(j), sic(i) end do else do i = 1,mq2 j = nz + i write (Nio,7005) $ i, EXP(LOG(sc(j)/100.0d0))*100.0d0, sis(i)*100.0d0, $ EXP(LOG(cycle(j)/100.0d0))*100.0d0, sic(i)*100.0d0 end do end if if (Nsfcast .eq. 1) then write (Nio,'(/,30x,''DUE TO THE APPROXIMATION, THE S.E.'',/, $ 30x,''OF THE COMPONENT MAY BE UNRELIABLE'',/)') end if end if end C C C subroutine BIASCORR(forbias,forsbias,fortbias,trend,sc,z,cycle,ir, $ sa,mq,lfor,npsi,noC) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer kf parameter (kf = 20) C C.. Formal Arguments .. integer mq,lfor,npsi real*8 forbias(kp),forsbias(kp),fortbias(kp),trend(mpkp), $ sc(mpkp),z(mpkp),cycle(mpkp),ir(mpkp),sa(mpkp) logical noC C C.. Local Scalars .. integer i,itf,j,j0,jf,jj0,jl,k,nf,nind,nt,cont1,cont real*8 a,dn0,dp0,zln0,zlp0,zmn0,zmp0,zmx0 C C.. Local Arrays .. real*8 dln(mpkp+kf),dlp(mpkp+kf),dn(mpkp),dp(mpkp), $ satmp(mpkp+kf),trtmp(mpkp+kf),zln(mpkp),zlp(mpkp), $ zmn(mpkp),zmp(mpkp),zmx(mpkp),zsave(mpkp) C C.. Intrinsic Functions .. intrinsic DBLE, EXP, INT, MOD C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK include 'sform.i' C C ... Executable Statements ... C j0 = 0 do i = 1,Nz+lfor zsave(i) = z(i) end do if (Nper .ne. 1) then j0 = mq + 1 - Nper end if jf = Nz - j0 - (INT(Nz-j0)/mq)*mq jl = ((lfor/mq)+1)*mq - lfor - jf itf = lfor + 2*mq + jl nf = INT((jf+itf)/mq) nt = nf + INT((Nz-j0)/mq) do i = 1,Nz+lfor trend(i) = EXP(trend(i)) cycle(i) = EXP(cycle(i)) * 100.0d0 * if (npsi .gt. 1) then sa(i) = EXP(sa(i)) * end if z(i) = EXP(z(i)) end do do i = 1,kp fortbias(i) = EXP(fortbias(i)) if (npsi .gt. 1) then forsbias(i) = EXP(forsbias(i)) end if forbias(i) = EXP(forbias(i)) end do if (npsi .gt. 1) then do i = 1,kp forsbias(i) = forbias(i) / forsbias(i) end do end if if (j0 .ne. 0) then zmx0 = 0.0d0 zmn0 = 0.0d0 zmp0 = 0.0d0 do i = 1,j0 zmx0 = zmx0 + z(i) zmn0 = zmn0 + sa(i) zmp0 = zmp0 + trend(i) end do zmx0 = zmx0 / DBLE(j0) zmn0 = zmn0 / DBLE(j0) zmp0 = zmp0 / DBLE(j0) zln0 = zmx0 - zmn0 zlp0 = zmx0 - zmp0 end if do i = 1,nt zmx(i) = 0.0d0 zmp(i) = 0.0d0 zmn(i) = 0.0d0 end do do i = 1,nt do j = 1,mq k = j0 + (i-1)*mq + j if (k .gt. Nz) then zmx(i) = zmx(i) + forbias(k-Nz) zmp(i) = zmp(i) + fortbias(k-Nz) zmn(i) = zmn(i) + forsbias(k-Nz) else zmx(i) = zmx(i) + z(k) zmp(i) = zmp(i) + trend(k) zmn(i) = zmn(i) + sa(k) end if end do zmx(i) = zmx(i) / DBLE(mq) zmp(i) = zmp(i) / DBLE(mq) zmn(i) = zmn(i) / DBLE(mq) C C DEBUG C C WRITE(NIO,'(2X,''ANNUAL MEAN'',/''SERIES TREND-CYCLE SA'')') C WRITE(NIO,'(2X,3G18.6)')ZMX(I),ZMP(I),ZMN(I) end do do i = 1,nt zln(i) = zmx(i) - zmn(i) zlp(i) = zmx(i) - zmp(i) end do do i = 1,nt-1 dn(i) = zln(i) - zln(i+1) dp(i) = zlp(i) - zlp(i+1) end do dn0 = zln0 - zln(1) dp0 = zlp0 - zlp(1) C C WE OBTAIN THE PRELIMINARY CORRECTION FOR THE FIRST J0 OBS. C if (j0 .ne. 0) then if (j0 .eq. 1) then C C PROBLEMS WITH FORECAST TREND 25-07-96 C C SATMP(1)=SA(I) C TRTMP(1)=TREND(I) satmp(1) = sa(1) trtmp(1) = trend(1) else jj0 = j0 / 2 do i = 1,j0 if (MOD(j0,2) .eq. 0) then satmp(i) = sa(i) + (zln0+(dn0/(2*jj0))*(jj0-i+1)-dn0/(2*j0)) trtmp(i) = $ trend(i) + (zlp0+(dp0/(2*jj0))*(jj0-i+1)-dp0/(2*j0)) else satmp(i) = sa(i) + (zln0+(dn0/(2*jj0))*(jj0-i+1)) trtmp(i) = trend(i) + (zlp0+(dp0/(2*jj0))*(jj0-i+1)) end if end do end if end if C C if (j0 .eq. 0) then a = dn(1) / DBLE((mq+1)) dln(1) = zln(1) + (dn(1)/2.0d0) - a do j = 2,mq dln(j) = dln(j-1) - a end do else if (((dn0.gt.0.0d0).and.(dn(1).gt.0.0d0)) .or. $ ((dn0.lt.0.0d0).and.(dn(1).lt.0.0d0)) .or. $ (dpeq(dn0,0.0d0).and.dpeq(dn(1),0.0d0))) then a = dn(1) / DBLE(mq+1) dln(1) = zln(1) + (dn(1)/2.0d0) - a do j = 2,mq dln(j) = dln(j-1) - a end do else a = dn(1) / DBLE((mq/2.0d0)+1.0d0) dln(1) = zln(1) - dn(1)/2.0d0 + a do j = 2,mq/2 dln(j) = dln(j-1) + a end do dln((mq/2)+1) = dln(mq/2) do j = (mq/2)+2,mq dln(j) = dln(j-1) - a end do end if do i = 2,nt-1 if (((dn(i).gt.0.0d0).and.(dn(i-1).gt.0.0d0)) .or. $ ((dn(i).lt.0.0d0).and.(dn(i-1).lt.0.0d0)) .or. $ (dpeq(dn(i),0.0d0).and.dpeq(dn(i-1),0.0d0))) then a = dn(i) / DBLE((mq+1)) dln((i-1)*mq+1) = zln(i) + (dn(i)/2.0d0) - a do j = 2,mq dln((i-1)*mq+j) = dln((i-1)*mq+j-1) - a end do else a = dn(i) / DBLE((mq/2.0d0)+1.0d0) dln((i-1)*mq+1) = zln(i) - dn(i)/2.0d0 + a do j = 2,mq/2 dln((i-1)*mq+j) = dln((i-1)*mq+j-1) + a end do dln((i-1)*mq+(mq/2)+1) = dln((i-1)*mq+mq/2) do j = mq/2+2,mq dln((i-1)*mq+j) = dln((i-1)*mq+j-1) - a end do end if end do C C C if (j0 .eq. 0) then a = dp(1) / DBLE((mq+1)) dlp(1) = zlp(1) + (dp(1)/2.0d0) - a do j = 2,mq dlp(j) = dlp(j-1) - a end do else if (((dp0.gt.0.0d0).and.(dp(1).gt.0.0d0)) .or. $ ((dp0.lt.0.0d0).and.(dp(1).lt.0.0d0)) .or. $ (dpeq(dp0,0.0d0).and.dpeq(dp(1),0.0d0))) then a = dp(1) / DBLE((mq+1)) dlp(1) = zlp(1) + (dp(1)/2.0d0) - a do j = 2,mq dlp(j) = dlp(j-1) - a end do else a = dp(1) / DBLE((mq/2.0d0)+1.0d0) dlp(1) = zlp(1) - dp(1)/2.0d0 + a do j = 2,mq/2 dlp(j) = dlp(j-1) + a end do dlp((mq/2)+1) = dlp(mq/2) do j = mq/2+2,mq dlp(j) = dlp(j-1) - a end do end if do i = 2,nt-1 if (((dp(i).gt.0.0d0).and.(dp(i-1).gt.0.0d0)) .or. $ ((dp(i).lt.0.0d0).and.(dp(i-1).lt.0.0d0)) .or. $ (dpeq(dp(i),0.0d0).and.dpeq(dp(i-1),0.0d0))) then a = dp(i) / DBLE((mq+1)) dlp((i-1)*mq+1) = zlp(i) + (dp(i)/2.0d0) - a do j = 2,mq dlp((i-1)*mq+j) = dlp((i-1)*mq+j-1) - a end do else a = dp(i) / DBLE((mq/2.0d0)+1.0d0) dlp((i-1)*mq+1) = zlp(i) - dp(i)/2.0d0 + a do j = 2,mq/2 dlp((i-1)*mq+j) = dlp((i-1)*mq+j-1) + a end do dlp((i-1)*mq+(mq/2)+1) = dlp((i-1)*mq+mq/2) do j = mq/2+2,mq dlp((i-1)*mq+j) = dlp((i-1)*mq+j-1) - a end do end if end do C C C if (npsi.ne.1) then cont1=(nt-1)*mq else cont1=(nt-1-nf)*mq endif if (npsi.ne.1.or..not.noC)then cont=(nt-1)*mq else cont=(nt-1-nf)*mq endif do i = j0+1,cont1 if (i .le. Nz) then sa(i) = sa(i) + dln(i-j0) else sa(i) = forsbias(i-Nz) + dln(i-j0) end if end do do i = j0+1,cont if (i .le. Nz) then trtmp(i) = trend(i) + dlp(i-j0) else trtmp(i) = fortbias(i-Nz) + dlp(i-j0) end if end do C C C TEST C C DO 100 I=1,NT-1 C ZZT=0.0D0 C ZZS=0.0D0 C DO 101 J=1,MQ C ZZT=ZZT+TRTMP((I-1)*MQ+J+J0) C ZZS=ZZS+SATMP((I-1)*MQ+J+J0) C 101 CONTINUE C ZZT=ZZT/MQ C ZZS=ZZS/MQ C WRITE(*,*)ZZT,ZZS,I,(NT-1)*MQ C READ(*,*) C 100 CONTINUE C C SMOOTING THE TREND C if (mq .eq. 12) then trend(1) = trtmp(1) trend(2) = (trtmp(1)+trtmp(2)+trtmp(3)) / 3.0d0 do i = 3,cont-2 if (i .le. Nz+lfor) then trend(i) = $ (trtmp(i-2)+trtmp(i-1)+trtmp(i)+trtmp(i+1)+trtmp(i+2)) / $ 5.0d0 if (i .gt. Nz) then fortbias(i-Nz) = trend(i) end if else fortbias(i-Nz) = $ (trtmp(i-2)+trtmp(i-1)+trtmp(i)+trtmp(i+1)+trtmp(i+2)) / $ 5.0d0 end if end do else trend(1) = trtmp(1) do i = 2,cont-2 if (i .le. Nz+lfor) then trend(i) = (trtmp(i-1)+trtmp(i)+trtmp(i+1)) / 3.0d0 if (i .gt. Nz) then fortbias(i-Nz) = trend(i) end if else fortbias(i-Nz) = (trtmp(i-1)+trtmp(i)+trtmp(i+1)) / 3.0d0 end if end do end if nind = cont - 1 fortbias(nind-Nz) = $ (trtmp(nind-1)+trtmp(nind)+trtmp(nind+1)) / 3.0d0 fortbias(nind-Nz+1) = trtmp(nind+1) do i=cont,nz+lfor fortbias(i-nz)=trend(i) enddo do i = Nz+1,(nt-1)*mq forsbias(i-Nz) = sa(i) end do do i = 1,Nz+lfor sc(i) = (z(i)/sa(i)) * 100.0d0 ir(i) = sa(i) / (trend(i)*cycle(i)/100.0d0) * 100.0d0 end do do i = 1,Nz+lfor z(i) = zsave(i) end do end C C subroutine DETCOMP(hptmp,hptrtmp,hpcycle,psiep,psiea,sqf,ilen,oz, $ bz,z,trend,sa,sc,ir,cycle,pread,a,na,osa,ot, $ ftr,fsa,ncyc,ncycth,out,pg,nz,mq,lamd, $ title,npsi,nchi,iter,ioneout,fortr,lfor, $ nreestimated,itable,tabtables,nper,nyer, $ IsCloseToTD,varwnc) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer nfl parameter (nfl = mp*2) C LINES OF CODE ADDED FOR X-13A-S : 5 INCLUDE 'lzero.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' DOUBLE PRECISION ZERO,SMALL PARAMETER(ZERO=0.0D0,SMALL=1.0d-12) C END OF CODE BLOCK C C.. Formal Arguments .. integer hpcycle,ilen,ncyc,ncycth,out,pg,nz,mq,lamd,npsi,nchi, $ iter,ioneout,fortr,lfor,nreestimated,itable,nper,nyer,na character title*80 real*8 hptmp(mpkp),psiep(nfl),psiea(nfl),sqf,oz(mpkp), $ bz(mpkp+kp), $ z(mpkp),trend(mpkp),sa(mpkp),sc(mpkp),a(mpkp), $ ir(mpkp),cycle(mpkp),pread(mpkp),osa(mpkp), $ ot(mpkp),ftr(-kp:kp),fsa(-kp:kp),hptrtmp(mpkp),varwnc character tabtables*100 logical IsCloseToTD C C.. Local Scalars .. integer i,i2,j,nf,nfor,ntitle,nyr character fname*30,subtitle*50,cad8*50,cad9*50 real*8 bias1,bias2,bias3,sum c integer jadd,maxfat,maxfst,maxfxt,maxsat,maxsxt,zmax c real*8 mufat,mufst,mufxt,musat,musxt c real*8 aggsxt,aggfxt,aggsat,aggfat,aggfst c real*8 aavsxt,aavfxt,aavsat,aavfst,aavfat c real*8 sumfat,sumsxt,sumsat,sumfxt,sumfst c real*8 pplevfxt,pplevsat,pplevsxt,pplevfat,pplevfst c real*8 fat(MPKP),fst(MPKP),fxt(MPKP) c real*8 sat(MPKP),sxt(MPKP) c real*8 tmp1(MPKP) logical bool C C.. Local Arrays .. real*8 ceff(mpkp),fcyc(-kp:kp),fir(-kp:kp),fo(-kp:kp), $ freg(-kp:kp),fs(-kp:kp),ftmp(-kp:kp), $ ocyc(mpkp),oir(mpkp),osc(mpkp), $ sieaf(kl),sieafl(kl),siepf(kl),siepfl(kl), $ tmp(mpkp),fosa(mpkp) C C.. External Functions .. character*60 PERIODH external PERIODH real*8 DMEAN real*8 DMU integer ISTRLEN external DMEAN, DMU, ISTRLEN character GETCMTS external GETCMTS character GETCMTTC external GETCMTTC character GETCMTTS external GETCMTTS character GETCMTIR external GETCMTIR C.. External Calls .. external FINALSE, FORTBL, OUTTABFOR, OUTTABLE, $ TABLE2, USRENTRY C C.. Intrinsic Functions .. intrinsic ABS, DBLE, EXP, LOG, MAX, MOD include 'preadtr.i' include 'sfcast.i' include 'sesfcast.i' include 'stream.i' include 'titl.i' include 'bench.i' include 'force.cmn' include 'units.cmn' * include 'indhtml.i' C C ... Executable Statements ... C C C c nfor = MAX(lfor,MAX(8,2*mq)) nfor=lfor ntitle = ISTRLEN(title) if (Nsfcast .eq. 1) then if (lamd .eq. 0) then do i = 1,nfor ir(i+nz) = sa(i+nz) / (trend(i+nz)*(cycle(i+nz)/100.0d0)) end do else do i = 1,nfor ir(i+nz) = sa(i+nz) - (trend(i+nz)+cycle(i+nz)) end do end if end if if (Tramo .eq. 1) then C if (out .eq. 0) then C LINES OF CODE COMMENTED FOR X-13A-S : 1 C write (Nio,'(//,4x,''DETERMINISTIC COMPONENT (from TRAMO)'',/, C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 write (Nio,'(//,4x,''DETERMINISTIC COMPONENT (from regARIMA)'', C END OF CODE BLOCK $ /,4x,''------------------------------------'')') end if C C C if (lamd .eq. 1) then C if (nreestimated .eq. 1) then do i = nz+1,nz+MAX(lfor,MAX(8,2*mq)) sum = 0.0d0 do j = 0,5 sum = sum + Pareg(i,j) end do sum = sum + Pareg(i,7) Tram(i) = $ z(i) + Paoutr(i) + Paouir(i) + Paous(i) + Paeast(i) + $ Patd(i) + sum end do end if if (Noutr .eq. 1) then call USRENTRY(Paoutr,1,nz+lfor,1,MPKP,1300) if (out .eq. 0) then write (Nio,'(//,2X,''LEVEL SHIFT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(Paoutr) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(Paoutr) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PAOTRF.T' * subtitle = 'LEVEL SHIFT' * call PLOTSERIES(fname,subtitle,Paoutr,nz,1,0.0d0) * end if end if if (Nouir .eq. 1) then call USRENTRY(Paouir,1,nz+lfor,1,MPKP,1301) if (out .eq. 0) then write (Nio,'(//,2X,''TRANSITORY OUTLIERS'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(Paouir) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(Paouir) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PAOIRF.T' * subtitle = 'TRANSITORY OUTLIERS' * call PLOTSERIES(fname,subtitle,Paouir,nz,1,0.0d0) * end if end if if (Nous .eq. 1) then call USRENTRY(Paous,1,nz+lfor,1,MPKP,1298) if (out .eq. 0) then write (Nio,'(//,2X,''SEASONAL OUTLIERS'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(Paous) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(Paous) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.1).and. (iter.eq.0)) then * fname = 'PAOSF.T' * subtitle = 'SEASONAL OUTLIERS' * call PLOTSERIES(fname,subtitle,Paous,nz,1,0.0d0) * end if end if if (Neast .eq. 1) then call USRENTRY(Paeast,1,nz+lfor,1,MPKP,1302) if (out .eq. 0) then write (Nio,'(//,2X,''EASTER EFFECT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(Paeast) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(Paeast) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PAEASF.T' * subtitle = 'EASTER EFFECT' * call PLOTSERIES(fname,subtitle,Paeast,nz,1,0.0d0) * end if end if if (Npatd .gt. 0) then call USRENTRY(Patd,1,nz+lfor,1,MPKP,1303) if (out .eq. 0) then write (Nio,'(//,2X,''DETERMINISTIC TRADING DAY EFFECT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(Patd) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(Patd) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PATDF.T' * subtitle = 'DETERMINISTIC TRADING DAY EFFECT' * call PLOTSERIES(fname,subtitle,Patd,nz,1,0.0d0) * end if end if if (NDS .gt. 0) then if (out .eq. 0) then write (nio,'(/,2x,A)') & 'DETERMINISTIC SEASONAL COMPONENT' call DSOUT(nio,mq,DetSeas,lamd) end if end if if (Npareg .eq. 1) then if (Neff(2) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,2) end do call USRENTRY(tmp,1,nz+lfor,1,MPKP,1304) if (out .eq. 0) then write (Nio,'(//,2x,''CALENDAR REGRESSION EFFECT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'SREGC.T' * subtitle = 'CALENDAR REGRESSION EFFECT' * call PLOTSERIES(fname,subtitle,tmp,nz,1,0.0d0) * end if end if if (Neff(1) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,1) end do call USRENTRY(tmp,1,nz+lfor,1,MPKP,1305) if (out .eq. 0) then write (Nio,'(//,2x,''TREND-CYCLE REGRESSION EFFECT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'TREGC.T' * subtitle = 'TREND-CYCLE REGRESSION EFFECT' * call PLOTSERIES(fname,subtitle,tmp,nz,1,0.0d0) * end if end if if (Neff(7) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,7) end do call USRENTRY(tmp,1,nz+lfor,1,MPKP,1315) if (out.eq.0) then write (Nio,'(//,2x,''BUSINESS CYCLE REGRESSION EFFECT'',/)') call TABLE2(tmp) end if * if ((pg.eq.0) .and. (out.le.1).and. (iter.eq.0)) then * fname = 'BCREGC.T' * subtitle = 'BUSINESS CYCLE REGRESSION EFFECT' * call PLOTSERIES(fname,subtitle,tmp,nz,1,0.0d0) * end if end if if (Neff(3) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,3) end do call USRENTRY(tmp,1,nz+lfor,1,MPKP,1306) if ((Tramo .eq. 1).and.(out.eq.0)) then write (Nio,'(//,2x,''IRREGULAR REGRESSION EFFECT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'IREGC.T' * subtitle = 'IRREGULAR REGRESSION EFFECT' * call PLOTSERIES(fname,subtitle,tmp,nz,1,0.0d0) * end if end if if (Neff(5) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,5) end do call USRENTRY(tmp,1,nz+lfor,1,MPKP,1307) if (out .eq. 0) then write (Nio,'(//,2x,''TRANS. COMPONENT REGRESSION '', $ ''EFFECT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'TRAREGC.T' * subtitle = 'TRANSITORY COMPONENT REGRESSION EFFECT' * call PLOTSERIES(fname,subtitle,tmp,nz,1,0.0d0) * end if end if if (Neff(4) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,4) end do call USRENTRY(tmp,1,nz+lfor,1,MPKP,1308) if (out .eq. 0) then write (Nio, $ '(//,2x,''OTHER REGRESSION EFFECT IN SA SERIES'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'SAREGC.T' * subtitle = 'OTHER SA REGRESSION EFFECT' * call PLOTSERIES(fname,subtitle,tmp,nz,1,0.0d0) * end if end if end if if (out .eq. 0) then write (Nio,'(//,2x,''FINAL DECOMPOSITION'',/,2x, $ ''-------------------'')') end if call USRENTRY(sa,1,nz,1,MPKP,1309) call USRENTRY(trend,1,nz,1,MPKP,1310) call USRENTRY(sc,1,nz+lfor,1,MPKP,1311) call USRENTRY(ir,1,nz,1,MPKP,1312) if ((ncycth.eq.1) .or. (ncyc.gt.1)) then call USRENTRY(cycle,1,nz,1,MPKP,1313) end if if ((Npareg.eq.1) .and. (Neff(0).eq.1)) then do i = 1,nz bz(i) = Pareg(i,0) end do if (out .eq. 0) then write (Nio,'(//2x,''SEPARATE REGRESSION EFFECT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(bz) C END OF CODE BLOCK end if * if (pg .eq. 0) then * fname = 'SPREGC.T' * subtitle = 'SEPARATE REGRESSION EFFECT' * call PLOTSERIES(fname,subtitle,bz,nz,1,0.0d0) * end if end if if (out .eq. 0) then write (Nio,'(//,2x,''FINAL COMPONENT'',/,2x, $ ''---------------'')') end if C C FINAL SEASONALLY ADJUSTED C * if ((Neast.ne.0).or.(Neff(2).ne.0).or.(Npatd .ne.0).or. * $ (Neff(0).ne.0).or.(Nous.ne.0)) then * call setCmtSA('Y') * end if if (npsi.ne.1 .or. Neff(1).ne.0 .or. $ Neff(3).ne.0 .or. Neff(4).ne.0 .or. Neff(5).ne.0 .or. $ Noutr.ne.0 .or. Nouir.ne.0 .or. Nuspad.gt.0) then IF(Nuspad.gt.0)THEN do i = 1,nz+lfor i2 = Frstap + i - 1 osa(i) = Tram(i) - $ (sc(i)+Paeast(i)+Paous(i)+Patd(i)+Usrpad(i2)+ $ Pareg(i,2)+Pareg(i,0)) if (isCloseToTD) then osa(i)=osa(i)-(cycle(i)+pareg(i,5)) end if fosa(i) = osa(i) end do ELSE do i = 1,nz+lfor osa(i) = $ Tram(i) - (sc(i)+Paeast(i)+Paous(i)+Patd(i)+ $ Pareg(i,2)+Pareg(i,0)) if (isCloseToTD) then osa(i)=osa(i)-(cycle(i)+pareg(i,5)) end if fosa(i) = osa(i) end do END IF call USRENTRY(osa,1,nz,1,MPKP,1309) if (out .eq. 0) then write (Nio,'(//,2X,''FINAL SEASONALLY ADJUSTED SERIES'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(osa) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(osa) C END OF CODE BLOCK end if * if (pg.eq.0) then * if(iter.ne.0) then * if ((ioneout.eq.0) .and. (out.lt.2)) then * fname = title(1:ntitle) // '.SA' * subtitle = 'FINAL SEASONALLY ADJUSTED SERIES' * call PLOTSERIES(fname,subtitle,osa,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.3) then * fname = 'SAFIN.T' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,osa,nz,1,0.0d0) * end if * end if * end if cc c Benchmark cc if (((MQ.eq.4) .or. (MQ.eq.12)) .and. (bcMark.eq.1)) then Lamda = Blamda Mid = Bmid Rol = Brol IF (rol.gt.0.99999D00) THEN if (MQ .eq.12) then rol = 0.9d0 else rol = 0.729d0 end if end if Iftrgt = Bserie if (Bserie .eq. 0) then do i=1,nz+lfor tmp(i)=Tram(i) end do else if (Bserie .eq. 1) then do i=1,nz+lfor tmp(i)=Tram(i)-Paeast(i) - Patd(i) - Pareg(i,6) end do else if (Bserie .eq. 2) then do i=1,nz+lfor tmp(i)=z(i) + Paeast(i) + Patd(i) + Pareg(i,6) end do else if (Bserie .eq. 3) then do i=1,nz+lfor tmp(i)=z(i) end do end if Begyrt = 1 call qmap2(tmp,osa,fosa,1,nz+lfor,mq,0) if (out .eq. 0) then write (Nio,'(//,2X, $ ''FINAL SA SERIES WITH REVISED YEARLY'',/)') call TABLE2(fosa) end if * if (pg .eq. 0) then * if (iter.ne.0) then * if ((ioneout.eq.0) .and. (out.eq.0)) then * fname = title(1:ntitle) // '.SAR' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,fosa,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.2) then * fname = 'FSAFIN.T' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,fosa,nz,1,0.0d0) * end if * end if * end if call USRENTRY(fosa,1,nz,1,MPKP,1314) end if cc c cc else do i = 1,nz osa(i) =Tram(i) end do call USRENTRY(osa,1,nz,1,MPKP,1309) end if C C FINAL TREND C if ((Noutr.ne.0).or.(Neff(1).ne.0).or.(Neff(7).ne.0)) then call setCmtTc('Y') end if if (nchi.ne.1 .or. Noutr.ne.0 .or. Neff(1).ne.0 .or. $ Neff(7).ne.0) then do i = 1,nz ot(i) = trend(i) + Paoutr(i) + Pareg(i,1) + Pareg(i,7) end do call USRENTRY(ot,1,nz,1,MPKP,1310) if (out .eq. 0) then write (Nio,'(//,2X,''FINAL TREND-CYCLE'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(ot) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(ot) C END OF CODE BLOCK end if * if (pg .eq. 0) then * if (iter.ne.0) then * if ((ioneout.eq.0) .and. (out.lt.2)) then * fname = title(1:ntitle) // '.TRE' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,ot,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.3) then * fname = 'TRFIN.T' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,ot,nz,1,0.0d0) * end if * end if * end if else do i = 1,nz ot(i) = 0.0d0 end do end if C C FINAL SEASONAL C if ((Neast.ne.0).or.(Neff(2).ne.0).or.(Npatd.ne.0) .or. $ (Nous .ne. 0).or.(IsCloseToTD.and.neff(5).ne.0)) then call setCmtS('Y') end if if (npsi.ne.1 .or.( Neast.ne.0 .or. Neff(2).ne.0 .or. $ Npatd.ne.0.or. Nous.ne.0 .or. IsCloseToTD)) then do i = 1,nz+lfor osc(i) = sc(i) + Paeast(i) + Patd(i) + Pareg(i,2) + Paous(i) if (isCloseToTD) then osc(i)=osc(i)+cycle(i)+Pareg(i,5) end if end do call USRENTRY(osc,1,nz+lfor,1,MPKP,1311) if (npsi.ne.1 .and.( Neast.ne.0 .or. Neff(2).ne.0 .or. $ Npatd.ne.0.or. Nous.ne.0 .or. IsCloseToTD)) $ then if (out .eq. 0) then write (Nio,'(//,2X,''FINAL SEASONAL'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(osc) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(osc) C END OF CODE BLOCK end if * if (pg .eq. 0) then * if (iter.eq.0) then * if (out.lt.3) then * fname = 'SFIN.T' * subtitle = 'FINAL SEASONAL' * call PLOTSERIES(fname,subtitle,osc,nz,1,0.0d0) * end if * else * if (out.lt.2) then * fname = title(1:ntitle) // '.sf' * subtitle = 'FINAL SEASONAL' * call PLOTSERIES(fname,subtitle,osc,nz,1,0.0d0) * write (17,'(A)') fname * end if * end if * end if endif else do i = 1,nz osc(i) = 0.0d0 end do end if C C FINAL CYCLE or Final TD C do i = 1,nz ocyc(i) = cycle(i) + Pareg(i,5) end do if (isCloseToTD) then do i=1,nz ocyc(i)=ocyc(i)+patd(i) end do end if if (Neff(5) .eq. 1 .or. (iSCloseToTD.and.Npatd.ne.0)) then call setCmtTs('Y') end if if ((varwnc.gt.1.0D-10 .and.((ncycth.eq.1) .or. (ncyc.gt.1))) $ .or. (Neff(5).eq.1).or. $ (isCloseTotD.and.Npatd.ne.0)) then if (isCloseToTD) then cad8='FINAL TD COMPONENT' call USRENTRY(ocyc,1,nz,1,MPKP,1316) else cad8='FINAL TRANSITORY COMPONENT' call USRENTRY(ocyc,1,nz,1,MPKP,1313) end if C WRITE(NIO,'(//,2X,''FINAL TRANSITORY COMPONENT'',/)') * if (pg .eq. 0) then * if (iter.ne.0) then * if ((ioneout.eq.0) .and. (out.lt.0)) then * fname = title(1:ntitle) // '.CYC' * call PLOTSERIES(fname,cad8,ocyc,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.3) then * fname = 'TRAFIN.T' * call PLOTSERIES(fname,cad8,ocyc,nz,1,0.0d0) * end if * end if * end if end if C C FINAL IRREGULAR C do i = 1,nz oir(i) = ir(i) + Paouir(i) + Pareg(i,3) end do call USRENTRY(oir,1,nz,1,MPKP,1312) if ((Nouir.ne.0) .or. (Neff(3).ne.0)) then call setCmtIR('Y') C IF (OUT.LT.2) THEN C WRITE(NIO,'(//,2X,''FINAL IRREGULAR'',/)') C CALL TABLE(OIR) C end if * if (pg .eq. 0) then * if (iter.eq.0) then * if (out.lt.3) then * fname = 'IRFIN.T' * subtitle = 'FINAL IRREGULAR' * call PLOTSERIES(fname,subtitle,oir,nz,1,0.0d0) * end if * else * if (out.lt.2) then * fname = title(1:ntitle) // '.FIR' * subtitle = 'FINAL IRREGULAR' * call PLOTSERIES(fname,subtitle,oir,nz,1,0.0d0) * write (17,'(A)') fname * end if * end if * end if end if call SETCMTSA(GETCMTS()) call SETCMTSA(GETCMTTC()) call SETCMTSA(GETCMTTS()) call SETCMTSA(GETCMTIR()) if (NEFF(4).ne.0) then call SETCMTSA('Y') end if if (out.eq.0) then if ((varwnc.gt.1.0D-10 .and.((ncycth.eq.1) .or. (ncyc.gt.1))) $ .or. (Neff(5).eq.1) .or. $ (Nouir.ne.0) .or. (Neff(3).ne.0).or. $ (isCloseToTD.and.NpaTD.ne.0)) then do i = 1,nz tmp(i) = ocyc(i) + oir(i) end do write (Nio,'(//,2X,''FINAL TRANSITORY-IRREGULAR'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK else write (Nio,'(//,2X,''FINAL IRREGULAR COMPONENT'',/)') write (Nio,'(4x,''The same as the stochastic irregular.'')') end if end if C C C nf = lfor * call profiler(3,'Forecasts') if (Nsfcast .eq. 0) then do i = (-nf),nf ftr(i) = trend(nz+i) + Paoutr(nz+i) + Pareg(nz+i,1) $ + Pareg(nz+i,7) * if (i.gt.0) then * write(Mtprof,*) ' i, ftr(i), trend(nz+i), Paoutr(nz+i), ', * $ 'Pareg(nz+i,1), Pareg(nz+i,7) = ', i, ftr(i), * $ trend(nz+i), Paoutr(nz+i), Pareg(nz+i,1), * & Pareg(nz+i,7) * end if end do do i = (-nf),nf fir(i) = Paouir(nz+i) + ir(nz+i) + Pareg(nz+i,3) end do do i = (-nf),nf fs(i) = sc(nz+i) + Paeast(nz+i) + Paous(nz+i) + Patd(nz+i) + $ Pareg(nz+i,2) if (isCloseTotD) then fs(i)=fs(i)+cycle(nz+i)+Pareg(nz+i,5) end if end do do i = (-nf),nf fcyc(i) = cycle(nz+i) + Pareg(nz+i,5) if (isCloseToTD) then fcyc(i)=fcyc(i)+PaTD(nz+i) end if end do do i = (-nf),nf fsa(i) = $ Tram(nz+i) - $ (sc(nz+i)+Paeast(nz+i)+Patd(nz+i)+Pareg(nz+i,2)+ $ Pareg(nz+i,0)+Paous(nz+i)) * if (i.gt.0) then * write(Mtprof,*) ' i, fsa(i), Tram(nz+i), ', * $ 'sc(nz+i), Paeast(nz+i), Patd(nz+i), Pareg(nz+i,2), ', * $ 'Pareg(nz+i,0), Paous(nz+i) = ', i, fsa(i), * $ Tram(nz+i), sc(nz+i), Paeast(nz+i), Patd(nz+i), * $ Pareg(nz+i,2), Pareg(nz+i,0), Paous(nz+i) * end if if (isCloseToTD) then fsa(i)=fsa(i)-(cycle(nz+i)+Pareg(nz+i,5)) * if (i.gt.0) then * write(Mtprof,*) * $ ' i, fsa(i), cycle(nz+i), Pareg(nz+i,5) = ', * $ i, fsa(i), cycle(nz+i), Pareg(nz+i,5) * end if end if end do if (fortr .eq. 1) then do i = 1,nf if (isCloseToTD) then ftr(i) = fsa(i) - fir(i) else ftr(i) = fsa(i) - fcyc(i) - fir(i) end if * write(Mtprof,*) ' i, ftr(i), fsa(i), fcyc(i), fir(i) = ', * $ i, ftr(i), fsa(i), fcyc(i), fir(i) end do end if do i = (-nf),nf freg(i) = Pareg(nz+i,0) fo(i) = Tram(nz+i) end do else do i = (-nf),nf if (i .gt. 0) then ftr(i) = trend(nz+i)*Rfact(i) + Paoutr(nz+i) + Pareg(nz+i,1) $ +Pareg(nz+i,7) * write(Mtprof,*) ' i, ftr(i), trend(nz+i)*Rfact(i), ', * $ 'Paoutr(nz+i), Pareg(nz+i,1), Pareg(nz+i,7) = ', * $ i, ftr(i), trend(nz+i)*Rfact(i), Paoutr(nz+i), * & Pareg(nz+i,1), Pareg(nz+i,7) else ftr(i) = trend(nz+i) + Paoutr(nz+i) + Pareg(nz+i,1) $ +Pareg(nz+i,7) end if end do do i = (-nf),nf fir(i) = Paouir(nz+i) + ir(nz+i) + Pareg(nz+i,3) end do do i = (-nf),nf fs(i) = sc(nz+i) + Paeast(nz+i) + Patd(nz+i) + Paous(nz+i) + $ Pareg(nz+i,2) if (isCloseToTD) then fs(i)=fs(i)+cycle(nz+i)+Pareg(nz+i,5) end if end do do i = (-nf),nf fcyc(i) = cycle(nz+i) + Pareg(nz+i,5) end do do i = (-nf),nf fsa(i) = $ Tram(nz+i) - $ (sc(nz+i)+Paeast(nz+i)+Patd(nz+i)+Pareg(nz+i,2)+ $ Pareg(nz+i,0)+Paous(nz+i)) * if (i.gt.0) then * write(Mtprof,*) ' i, fsa(i), Tram(nz+i), ', * $ 'sc(nz+i), Paeast(nz+i), Patd(nz+i), Pareg(nz+i,2), ', * $ 'Pareg(nz+i,0), Paous(nz+i) = ', i, fsa(i), * $ Tram(nz+i), sc(nz+i), Paeast(nz+i), Patd(nz+i), * $ Pareg(nz+i,2), Pareg(nz+i,0), Paous(nz+i) * end if if (isCloseToTD) then fsa(i)=fsa(i)-(cycle(nz+i)+Pareg(nz+i,5)) * if (i.gt.0) then * write(Mtprof,*) * $ ' i, fsa(i), cycle(nz+i), Pareg(nz+i,5) = ', * $ i, fsa(i), cycle(nz+i), Pareg(nz+i,5) * end if end if end do if (fortr .eq. 1) then do i = 1,nf if (isCloseToTD) then ftr(i) = fsa(i) - fir(i) * write(Mtprof,*) ' i, ftr(i), fsa(i), fir(i) = ', * $ i, ftr(i), fsa(i), fir(i) else ftr(i) = fsa(i) - fir(i) - fcyc(i) * write(Mtprof,*) ' i, ftr(i), fsa(i), fir(i), fcyc(i) = ', * $ i, ftr(i), fsa(i), fir(i), fcyc(i) end if ftr(i) = ftr(i) * Rfact(i) * write(Mtprof,*) ' i, ftr(i), Rfact(i) = ', * $ i, ftr(i), Rfact(i) end do end if do i = (-nf),nf freg(i) = Pareg(nz+i,0) fo(i) = Tram(nz+i) end do end if if (nreestimated .eq. 1 .and. tramo.eq.0)then c if ((out.eq.0)) then c write (Nio, c $'(//,2x,''SINCE SEATS HAS RE-ESTIMATED AND CHANGED THE MODEL,'' c $,/,2x,''THE FORECAST OF THE ORIGINAL (UNCORRECTED) SERIES'',/,2x, C LINES OF CODE COMMENTED FOR X-13A-S : 1 C $ ''WILL DIFFER FROM THAT IN TRAMO.'')') C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 c $ ''WILL DIFFER FROM THAT IN regARIMA output.'')') C END OF CODE BLOCK c end if call USRENTRY(Tram,1,nz+nf,1,MPKP,213) end if if (itable .eq. 1) then do i = 1,nz+nfor ceff(i) = Paeast(i) + Patd(i) + Pareg(i,6) end do if (ITER .gt. 2) then call ProcTables(tabtables) end if call OUTTABLE2(titleg,Tram,ot,osa,osc,oir,ocyc,pread,ceff, $ eresid,numEresid,hptmp,hptrtmp,hpcycle,lamd,1, $ nz,mq,2,kunits,nf,trend,sa,fosa,IsCloseToTD) * call profiler(3,'Enter OUTTABFOR') call OUTTABFOR(ftr,fsa,fs,fir,fcyc,pread,ceff,hptmp, $ hptrtmp,hpcycle,lamd,1,nf,nz,mq,trend,sa,fosa) end if C C TABLES WITH THE SE OF FINAL COMPONENTS C if (out .eq. 0) then C Modified by REG, on 28 Feb 2006, to add out to FINALSE parameter list. call FINALSE(psiep,psiea,trend,sa,siepf,siepfl,sieaf,sieafl, $ sqf,ilen,mq,lfor,lamd,out) C C C write (Nio,'(//,1X,''FORECAST OF FINAL COMPONENT'')') call FORTBL(fo,freg,ftr,fsa,fs,fcyc,fir,Tse,siepf,siepfl, $ sieaf,sieafl,Neff,mq,Nouir,Noutr,Npatd,Neast, $ nchi,npsi,ncyc,ncycth,lamd,nper,nyer,nz,nf, $ isCloseToTD,varwnc) if (Nsfcast .ne. 0) then write (Nio,'(//4x,''THE FORECAST OF THE IRREGULAR '', $ ''ABSORBS'')') write (Nio,'(4X,''THE EFFECT OF THE APPROXIMATION.'')') end if end if do i=1,nf tmp(i)=fsa(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1409) do i=1,nf tmp(i)=ftr(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1410) do i=1,nf tmp(i)=fs(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1411) do i=1,nf tmp(i)=fir(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1412) if (varwnc.gt.1.0D-10 .and.((ncycth.eq.1).or.(ncyc.gt.1)))then do i=1,nf tmp(i)=fcyc(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1413) end if * if ((pg.eq.0).and.(iter.eq.0)) then * if (out.lt.2) then * if (Npareg .eq. 1) then * fname = 'FREG.T5' * subtitle = 'FORECAST TOTAL REGRESSION EFFECT' * call PLOTFCAST1(fname,subtitle,freg,nf,nz,0) * end if * if (Neff(0).eq. 1) then * fname = 'SPREGF.T5' * subtitle = 'FORECAST SEPARATE REG. EFFECT' * do i = (-nf),nf * ftmp(i) = Pareg(nz+i,0) * 100.0d0 * end do * call PLOTFCAST1(fname,subtitle,ftmp,nf,nz,0) * end if * if ((Neff(5).eq.1) .or. * $ (varwnc.gt.1.0D-10 .and.((ncycth.eq.1) .or. (ncyc.gt.1))) * $ .or.(isCloseTotD.and.Npatd.ne.0)) then * fname = 'FTRAFIN.T5' * if (IsCloseToTD) then * subtitle = 'FORECAST FINAL TD COMPONENT' * else * subtitle = 'FORECAST FINAL TRANSITORY COMPONENT' * end if * call PLOTFCAST1(fname,subtitle,fcyc,nf,nz,0) * end if * if ((Neff(3).eq.1) .or. (Nouir.eq.1)) then * fname = 'FIRFIN.T5' * subtitle = 'FORECAST FINAL IRREGULAR' * call PLOTFCAST1(fname,subtitle,fir,nf,nz,0) * end if * end if * if (out.lt.3) then * fname = 'FUNORIG.T5' * subtitle = 'FORECAST OF SERIES' * call PLOTFCAST1(fname,subtitle,fo,nf,nz,0) * if (npsi.ne.1 .or. (Neast+Neff(2)+Npatd).ne.0) then * fname = 'FSAFIN.T5' * subtitle = 'FORECAST FINAL SA SERIES' * call PLOTFCAST1(fname,subtitle,fsa,nf,nz,0) * fname = 'FSFIN.T5' * subtitle = 'FORECAST FINAL SEASONAL' * call PLOTFCAST1(fname,subtitle,fs,nf,nz,0) * end if * if (nchi.ne.1 .or. Noutr.ne.0 .or. Neff(1).ne.0 .or. * $ Neff(7).ne.0) then * fname = 'FTRFIN.T5' * subtitle = 'FORECAST FINAL TREND-CYCLE' * call PLOTFCAST1(fname,subtitle,ftr,nf,nz,0) * end if * end if * end if else C C LAMDA EQUAL TO ZERO C if (nreestimated .eq. 1) then do i = nz+1,nz+MAX(lfor,MAX(8,2*mq)) sum = 1.0d0 do j = 0,5 sum = sum * Pareg(i,j) end do sum = sum * Pareg(i,7) Tram(i) = $ EXP(z(i)) * Paoutr(i) * Paouir(i) * Paeast(i) * Patd(i) * $ sum end do end if C IF ((OUT.LT.2).OR.(OUT.EQ.3)) THEN if (Noutr .eq. 1) then do i = 1,nz+nfor bz(i) = Paoutr(i) * 100.0d0 end do call USRENTRY(bz,1,nz+nfor,1,MPKP,1300) if (out .eq. 0) then write (Nio,'(//,2X,''LEVEL SHIFT (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(bz) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PAOTRF.T' * subtitle = 'LEVEL SHIFT FACTORS' * call PLOTSERIES(fname,subtitle,bz,nz,1,888.0d0) * end if end if if (Nouir .eq. 1) then do i = 1,nz+nfor bz(i) = Paouir(i) * 100.0d0 end do call USRENTRY(bz,1,nz+nfor,1,MPKP,1301) if (out .eq. 0) then write (Nio,'(//,2X,''TRANSITORY OUTLIERS (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(bz) C END OF CODE BLOCK end if else * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PAOIRF.T' * subtitle = 'TRANSITORY OUTLIERS FACTORS' * call PLOTSERIES(fname,subtitle,bz,nz,1,888.0d0) * end if end if if (Neast .eq. 1) then do i = 1,nz+nfor bz(i) = Paeast(i) * 100.0d0 end do call USRENTRY(bz,1,nz+nfor,1,MPKP,1302) if (out .eq. 0) then write (Nio,'(//,2X,''EASTER EFFECT (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(bz) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PAEASF.T' * subtitle = 'EASTER EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,bz,nz,1,888.0d0) * end if end if if (Npatd .gt. 0) then do i = 1,nz+nfor bz(i) = Patd(i) * 100.0d0 end do call USRENTRY(bz,1,nz+nfor,1,MPKP,1303) if (out .eq. 0) then write (Nio,'(//,2X,''TRADING DAY EFFECT (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(bz) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'PATDF.T' * subtitle = 'TRADING DAY EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,bz,nz,1,888.0d0) * end if end if if (NDS .gt. 0) then if (out .eq. 0) then write (nio,'(/,2x,A)') & 'DETERMINISTIC SEASONAL FACTORS' call DSOUT(nio,mq,DetSeas,lamd) end if end if if (Npareg .eq. 1) then if (Neff(2) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,2) * 100.0d0 end do call USRENTRY(tmp,1,nz+nfor,1,MPKP,1304) if (out .eq. 0) then write (Nio, $'(//,2x,''SEASONAL REGRESSION EFFECT FACTORS (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'SREGF.T' * subtitle = 'SEASONAL REGRESSION EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,tmp,nz,1,888.0d0) * end if end if if (Neff(1) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,1) * 100.0d0 end do call USRENTRY(tmp,1,nz+nfor,1,MPKP,1305) if (out .eq. 0) then write (Nio, $'(//,2x,''TREND-CYCLE REGRESSION EFFECT FACTORS (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'TREGF.T' * subtitle = 'TREND-CYCLE REGRESSION EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,tmp,nz,1,888.0d0) * end if end if if (Neff(7) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,7) * 100.0d0 end do call USRENTRY(tmp,1,nz+nfor,1,MPKP,1315) if (out .eq. 0) then write (Nio, $'(//,2x,''BUSINESS CYCLE REGRESSION EFFECT FACTORS (X100)'',/)') call TABLE2(tmp) end if * if ((pg.eq.0) .and. (out.lt.2).and.(iter.eq.0)) then * fname = 'BCREGF.T' * subtitle = 'BUSINESS CYCLE REGRESSION EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,tmp,nz,1,888.0d0) * end if end if if (Neff(3) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,3) * 100.0d0 end do call USRENTRY(tmp,1,nz+nfor,1,MPKP,1306) if ((Tramo .eq. 1).and.(out.eq.0)) then write (Nio, $'(//,2x,''IRREGULAR REGRESSION EFFECT FACTORS (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.lt.2).and. (iter.eq.0)) then * fname = 'IREGF.T' * subtitle = 'IRREGULAR REGRESSION EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,tmp,nz,1,888.0d0) * end if end if if (Neff(4) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,4) * 100.0d0 end do call USRENTRY(tmp,1,nz+nfor,1,MPKP,1308) if (out .eq. 0) then write (Nio,'(//,2x,''OTHER REGRESSION EFFECT FACTORS '', $ ''IN SA SERIES (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'SAREGF.T' * subtitle = 'OTHER REG. EFFECT FACTORS IN SA SERIES' * call PLOTSERIES(fname,subtitle,tmp,nz,1,888.0d0) * end if end if if (Neff(5) .eq. 1) then do i = 1,nz+nfor tmp(i) = Pareg(i,5) * 100.0d0 end do call USRENTRY(tmp,1,nz+nfor,1,MPKP,1307) if (out .eq. 0) then write (Nio, $ '(//,2x,''TRANSITORY REGRESSION EFFECT FACTORS'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK end if * if ((pg.eq.0) .and. (out.le.2).and. (iter.eq.0)) then * fname = 'TRAREGF.T' * subtitle = 'TRANSITORY REGRESSION EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,tmp,nz,1,0.0d0) * end if end if end if C end if if (out .eq. 0) then write (Nio, $'(//,2x,''FINAL DECOMPOSITION'',/,2x,''-------------------'')') end if C C COMPUTE THE FACTOR FOR THE BIAS=1 CORRECTION C bias1 = 0.0d0 bias2 = 0.0d0 nyr = (nz/mq) * mq do i = 1,nz if (i .le. nyr) then if (isCloseToTD) then bias1=bias1+((sc(i)/100.0d0)*(cycle(i)/100.0d0)*Paeast(i)* $ Patd(i)*Pareg(i,2)*Pareg(i,5)) else bias1 = bias1 + (sc(i)/100.0d0*Paeast(i)*Patd(i)*Pareg(i,2)) end if end if bias2 = bias2 + (ir(i)/100.0d0*Paouir(i)*Pareg(i,3)) end do bias1 = bias1 / nyr bias2 = bias2 / nz bias3 = bias1 * bias2 C C Set Gianluca 16-02-2001 casino non torna piu' il prod delle componenti C C Cazzo questo e' da verificare C bias3=1.0d0 bias2=1.0d0 bias1=1.0d0 C C call USRENTRY(sa,1,nz,1,MPKP,1309) call USRENTRY(trend,1,nz,1,MPKP,1310) call USRENTRY(sc,1,nz+lfor,1,MPKP,1311) call USRENTRY(ir,1,nz,1,MPKP,1312) if (varwnc.gt.1.0D-10 .and.((ncycth.eq.1) .or.(ncyc.gt.1))) then call USRENTRY(cycle,1,nz,1,MPKP,1313) end if if ((Npareg.eq.1) .and. (Neff(0).eq.1)) then do i = 1,nz bz(i) = Pareg(i,0) * 100.0d0 end do if (out .eq. 0) then write (Nio, $ '(//2x,''SEPARATE REGRESSION EFFECT FACTORS (X100)'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(bz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(bz) C END OF CODE BLOCK end if * if ((pg .eq. 0).and.(iter.eq.0).and.(out.lt.2)) then * fname = 'SPREGF.T' * subtitle = 'SEPARATE REGRESSION EFFECT FACTORS' * call PLOTSERIES(fname,subtitle,bz,nz,1,888.0d0) * end if end if if (out .eq. 0) then write (Nio,'(//,2x,''FINAL COMPONENT'',/,2x, $ ''---------------'')') end if C C FINAL SEASONALLY ADJUSTED C * if ((Neast.ne.0).or.(Neff(2).ne.0).or.(Npatd .ne.0).or. * $ (Neff(0).ne.0).or.(Nous.ne.0)) then * call setCmtSA('Y') * end if if (npsi.ne.1 .or. Neff(1).ne.0 .or. $ Neff(3).ne.0 .or. Neff(4).ne.0 .or. Neff(5).ne.0 .or. $ Noutr.ne.0 .or. Nouir.ne.0 .or. Nuspad.gt.0) then IF(Nuspad.gt.0)THEN do i = 1,nz+lfor i2 = Frstap + i - 1 osa(i) = $ Tram(i) / $ (((sc(i)/100.0d0)*Paeast(i)*Paous(i)*Patd(i)*Pareg(i,2)* $ Usrpad(i2)*bias1*Pareg(i,0))) if (isCloseToTD) then osa(i)=osa(i)/(Pareg(i,5)*cycle(i)/100.0d0) end if fosa(i) = osa(i) end do ELSE do i = 1,nz+lfor osa(i) = $ Tram(i) / $ (((sc(i)/100.0d0)*Paeast(i)*Paous(i)*Patd(i)*Pareg(i,2)* $ bias1*Pareg(i,0))) if (isCloseToTD) then osa(i)=osa(i)/(Pareg(i,5)*cycle(i)/100.0d0) end if fosa(i) = osa(i) end do END IF call USRENTRY(osa,1,nz,1,MPKP,1309) if (out .eq. 0) then write (Nio,'(//,2X,''FINAL SEASONALLY ADJUSTED SERIES'',/)') call TABLE2(osa) end if * if (pg.eq.0) then * if (iter.ne.0) then * if ((ioneout.eq.0).and.(out.lt.2)) then * fname = title(1:ntitle) // '.SA' * subtitle = 'FINAL SEASONALLY ADJUSTED SERIES' * call PLOTSERIES(fname,subtitle,osa,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.3) then * fname = 'SAFIN.T' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,osa,nz,1,0.0d0) * end if * end if * end if cc c Benchmark cc if (((MQ.eq.4) .or. (MQ.eq.12)) .and. (BcMark .eq. 1)) then Lamda = Blamda Mid = Bmid Rol = Brol IF (rol.gt.0.99999D00) THEN if (MQ .eq.12) then rol = 0.9d0 else rol = 0.729d0 end if end if Iftrgt = Bserie if (Bserie .eq. 0) then do i=1,nz+lfor tmp(i)=Tram(i) end do else if (Bserie .eq. 1) then do i=1,nz+lfor tmp(i)=Tram(i) / (Paeast(i) * Patd(i) * Pareg(i,6)) end do else if (Bserie .eq. 2) then do i=1,nz+lfor tmp(i)=z(i) * Paeast(i) * Patd(i) * Pareg(i,6) end do else if (Bserie .eq. 3) then do i=1,nz+lfor tmp(i)=z(i) end do end if Begyrt = 1 call qmap2(tmp,osa,fosa,1,nz+lfor,mq,0) if (out .eq. 0) then write (Nio,'(//,2X, $ ''FINAL SA SERIES WITH REVISED YEARLY'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(osa) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(fosa) C END OF CODE BLOCK end if call USRENTRY(fosa,1,nz,1,MPKP,1314) * if (pg .eq. 0) then * if (iter.ne.0) then * if ((ioneout.eq.0) .and. (out.lt.1)) then * fname = title(1:ntitle) // '.SAR' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,fosa,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.eq.0) then * fname = 'FSAFIN.T' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,fosa,nz,1,0.0d0) * end if * end if * end if end if cc c cc else do i = 1,nz osa(i) =Tram(i) end do call USRENTRY(osa,1,nz,1,MPKP,1309) end if C C FINAL TREND C if ((Noutr.ne.0).or.(Neff(1).ne.0).or.(Neff(7).ne.0)) then call setCmtTc('Y') end if if (nchi.ne.1 .or. Noutr.ne.0 .or. Neff(1).ne.0 .or. $ Neff(7).ne.0) then do i = 1,nz ot(i) = trend(i) * Paoutr(i) * Pareg(i,1) *Pareg(i,7)* bias3 end do call USRENTRY(ot,1,nz,1,MPKP,1310) if (out.eq.0) then write (Nio,'(//,2X,''FINAL TREND-CYCLE'',/)') call TABLE2(ot) end if * if (pg .eq. 0) then * if (iter.ne.0) then * if ((ioneout.eq.0) .and. (out.lt.2)) then * fname = title(1:ntitle) // '.TRE' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,ot,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.3) then * fname = 'TRFIN.T' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,ot,nz,1,0.0d0) * end if * end if * end if else do i = 1,nz ot(i) = 1.0d0 end do end if C C FINAL SEASONAL C if ((Neast.ne.0).or.(Neff(2).ne.0).or.(Npatd.ne.0) .or. $ (Nous .ne.0).or. (IsCloseToTD.and.neff(5).ne.0)) then call setCmtS('Y') end if if (npsi.ne.1 .or. Neast.ne.0 .or. Neff(2).ne.0 .or. Npatd.ne.0 $ .or. Nous.ne.0 .or. isCloseToTD) then do i = 1,nz+lfor osc(i) = (sc(i)*Paeast(i)*Patd(i)*Paous(i)*Pareg(i,2)) / bias1 end do if (isCloseToTD) then osc(i)=osc(i)*cycle(i)*Pareg(i,5)/(100.0d0) end if call USRENTRY(osc,1,nz+lfor,1,MPKP,1311) if (out .eq. 0) then write (Nio,'(//,2X,''FINAL SEASONAL FACTORS'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(osc) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(osc) C END OF CODE BLOCK end if * if (pg .eq. 0) then * if (iter.eq.0) then * if (out.lt.3) then * fname = 'SFIN.T' * subtitle = 'FINAL SEASONAL FACTORS' * call PLOTSERIES(fname,subtitle,osc,nz,1,888.0d0) * end if * else * if (out.lt.2) then * fname = title(1:ntitle) // '.sf' * subtitle = 'FINAL SEASONAL FACTORS' * call PLOTSERIES(fname,subtitle,osc,nz,1,888.0d0) * write (17,'(A)') fname * end if * end if * end if else do i = 1,nz osc(i) = 100.0d0 end do end if C C FINAL CYCLE C do i = 1,nz ocyc(i) = cycle(i) * Pareg(i,5) if (IsCloseToTD) then ocyc(i)=ocyc(i)*Patd(i) end if end do if (Neff(5) .eq. 1) then call setCmtTs('Y') end if if ((varwnc.gt.1.0D-10 .and.((ncycth.eq.1).or.(ncyc.gt.1))) $ .or. (Neff(5).eq.1).or. $ (iscloseToTD.and.Npatd.ne.0)) then if (isCloseToTD) then cad9='FINAL TD FACTORS' call USRENTRY(ocyc,1,nz,1,MPKP,1316) else cad9='FINAL TRANSITORY FACTORS' call USRENTRY(ocyc,1,nz,1,MPKP,1313) end if * if (pg .eq. 0) then * if (iter.ne.0) then * if ((ioneout.eq.0) .and. (out.eq.0)) then * fname = title(1:ntitle) // '.CYC' * call PLOTSERIES(fname,cad9,ocyc,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.3) then * fname = 'TRAFIN.T' * call PLOTSERIES(fname,cad9,ocyc,nz,1,888.0d0) * end if * end if * end if C IF (OUT.eq.0) THEN C WRITE(NIO,'(//,2X,''FINAL TRANSITORY FACTORS'',/)') C CALL TABLE(OCYC) C end if end if C C FINAL IRREGULAR C do i = 1,nz oir(i) = ir(i) * Paouir(i) * Pareg(i,3) end do call USRENTRY(oir,1,nz,1,MPKP,1312) if ((Nouir.ne.0) .or. (Neff(3).ne.0)) then call setCmtIR('Y') C IF (OUT.LT.2) THEN C WRITE(NIO,'(//,2X,''FINAL IRREGULAR FACTORS'',/)') C CALL TABLE(OIR) C end if * if (pg .eq. 0) then * if (iter.eq.0) then * if (out.lt.3) then * fname = 'IRFIN.T' * subtitle = 'FINAL IRREGULAR FACTORS' * call PLOTSERIES(fname,subtitle,oir,nz,1,888.0d0) * end if * else * if (out.lt.2 .and. ioneout.eq.0) then * fname = title(1:ntitle) //'.FIR' * subtitle = 'FINAL IRREGULAR FACTORS' * call PLOTSERIES(fname,subtitle,oir,nz,1,888.0d0) * write (17,'(A)') fname * end if * end if * end if end if call SETCMTSA(GETCMTS()) call SETCMTSA(GETCMTTC()) call SETCMTSA(GETCMTTS()) call SETCMTSA(GETCMTIR()) if (NEFF(4).ne.0) then call SETCMTSA('Y') end if C if ((out.eq.0).and. $ ((varwnc.gt.1.0D-10 .and.((ncycth.eq.1).or.(ncyc.gt.1))).or. $ (Neff(5).eq.1) .or.(Nouir.ne.0) .or. (Neff(3).ne.0).or. $ (isCloseToTD.and.NpaTD.ne.0))) then do i = 1,nz tmp(i) = (ocyc(i)*oir(i)) / 100.0d0 end do write (Nio, $ '(//,2x,''FINAL TRANSITORY-IRREGULAR COMPONENT'',/)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(tmp) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(tmp) C END OF CODE BLOCK else if(out.eq.0)THEN write (Nio,'(//,2X,''FINAL IRREGULAR FACTORS'',/)') write (Nio,'(4x,''The same as the stochastic irregular.'')') end if C C C nf = MAX(lfor,MAX(8,2*mq)) if (Nsfcast .eq. 0) then do i = (-nf),nf ftr(i) = trend(nz+i) * Paoutr(nz+i) * Pareg(nz+i,1) $ *Pareg(nz+i,7)* bias3 * if( i .gt.0 ) THEN * write(Mtprof,*) ' i, ftr(i), trend(nz+i), Paoutr(nz+i), ', * $ 'Pareg(nz+i,1), Pareg(nz+i,7), bias3 = ', * $ i, ftr(i), trend(nz+i), Paoutr(nz+i), * & Pareg(nz+i,1), Pareg(nz+i,7), bias3 * end if end do do i = (-nf),nf if (i .le. 0) then fir(i) = Paouir(nz+i) * Pareg(nz+i,3) * ir(nz+i) else fir(i) = Paouir(nz+i) * Pareg(nz+i,3) end if end do do i = (-nf),nf fcyc(i) = cycle(nz+i) * Pareg(nz+i,5) if (isCloseToTD) then fcyc(i)=fcyc(i)*PaTD(nz+i) end if end do do i = (-nf),nf fsa(i) = $ Tram(nz+i) / $ ((sc(nz+i)/100.0d0*Paeast(nz+i)*Patd(nz+i)*Pareg(nz+i,2)* $ Paous(nz+i))/bias1*Pareg(nz+i,0)) * if (i.gt.0) then * write(Mtprof,*) ' i, fsa(i), Tram(nz+i), ', * $ 'sc(nz+i), Paeast(nz+i), Patd(nz+i), Pareg(nz+i,2), ', * $ 'Pareg(nz+i,0), Paous(nz+i), bias1 = ', i, fsa(i), * $ Tram(nz+i), sc(nz+i), Paeast(nz+i), Patd(nz+i), * $ Pareg(nz+i,2), Pareg(nz+i,0), Paous(nz+i), bias1 * end if if (iscloseTotD) then fsa(i)=fsa(i)/(Pareg(nz+i,5)*cycle(nz+i)/100.0d0) * if (i.gt.0) then * write(Mtprof,*) * $ ' i, fsa(i), cycle(nz+i), Pareg(nz+i,5) = ', * $ i, fsa(i), cycle(nz+i), Pareg(nz+i,5) * end if end if end do if (fortr .eq. 1) then do i = 1,nf if (isCloseTotD) then ftr(i) = (fsa(i)/fir(i)) * write(Mtprof,*) ' i, ftr(i), fsa(i), fir(i) = ', * $ i, ftr(i), fsa(i), fir(i) else ftr(i) = (fsa(i)/fir(i)) / (fcyc(i)/100.0d0) * write(Mtprof,*) ' i, ftr(i), fsa(i), fir(i), fcyc(i) = ', * $ i, ftr(i), fsa(i), fir(i), fcyc(i) end if end do end if do i = (-nf),nf fs(i) = $ sc(nz+i) * Paeast(nz+i) * Patd(nz+i) * Paous(nz+i) * $ Pareg(nz+i,2) / bias1 if (isCloseToTD) then fs(i)=fs(i)*PaReg(nz+i,5)*cycle(nz+i)/100.0d0 end if end do do i = (-nf),nf freg(i) = Pareg(nz+i,0) fo(i) = Tram(nz+i) end do else do i = (-nf),nf if (i .gt. 0) then ftr(i) = $ EXP(LOG(trend(nz+i))*Rfact(i)) * Paoutr(nz+i) * $ Pareg(nz+i,1) * bias3 * write(Mtprof,*) ' i, ftr(i), ', * $ 'EXP(LOG(trend(nz+i))*Rfact(i)), Paoutr(nz+i), ', * $ 'Pareg(nz+i,1), bias3 = ', i, ftr(i), * $ EXP(LOG(trend(nz+i))*Rfact(i)), Paoutr(nz+i), * & Pareg(nz+i,1), bias3 else ftr(i) = trend(nz+i) * Paoutr(nz+i) * Pareg(nz+i,1) * bias3 end if end do do i = (-nf),nf fir(i) = Paouir(nz+i) * Pareg(nz+i,3) * ir(nz+i) end do do i = (-nf),nf fcyc(i) = cycle(nz+i) * Pareg(nz+i,5) end do do i = (-nf),nf fsa(i) = $ Tram(nz+i) / $ ((sc(nz+i)/100.0d0*Paeast(nz+i)*Patd(nz+i)*Pareg(nz+i,2)* $ Paous(nz+i))/bias1*Pareg(nz+i,0)) * if (i.gt.0) then * write(Mtprof,*) ' i, fsa(i), Tram(nz+i), ', * $ 'sc(nz+i), Paeast(nz+i), Patd(nz+i), Pareg(nz+i,2), ', * $ 'Pareg(nz+i,0), Paous(nz+i), bias1 = ', i, fsa(i), * $ Tram(nz+i), sc(nz+i), Paeast(nz+i), Patd(nz+i), * $ Pareg(nz+i,2), Pareg(nz+i,0), Paous(nz+i), bias1 * end if end do if (fortr .eq. 1) then do i = 1,nf ftr(i) = (fsa(i)/fir(i)) / (fcyc(i)/100.0d0) * write(Mtprof,*) ' i, ftr(i), fsa(i), fir(i), fcyc(i) = ', * $ i, ftr(i), fsa(i), fir(i), fcyc(i) end do end if do i = (-nf),nf fs(i) = $ sc(nz+i) * Paeast(nz+i) * Patd(nz+i) * Paous(nz+i) * $ Pareg(nz+i,2) / bias1 end do do i = (-nf),nf freg(i) = Pareg(nz+i,0) * 100.0d0 fo(i) = Tram(nz+i) end do end if do i = 1,nf fir(i) = fir(i) * 100.0d0 end do if (nreestimated .eq. 1 .and. tramo.eq.0) then c if (out.eq.0) then c write (Nio, c $'(//,2x,''SINCE SEATS HAS RE-ESTIMATED AND CHANGED THE MODEL,'' c $,/,2x,''THE FORECAST OF THE ORIGINAL (UNCORRECTED) SERIES'',/,2x, C LINES OF CODE COMMENTED FOR X-13A-S : 1 C $ ''WILL DIFFER FROM THAT IN TRAMO.'')') C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 c $ ''WILL DIFFER FROM THAT IN regARIMA output.'')') C END OF CODE BLOCK c end if call USRENTRY(Tram,1,nz+nf,1,MPKP,213) end if C call USRENTRY(Tram,nz+1,nz+nf,1409) C call USRENTRY(trend,nz+1,nz+nf,1410) C call USRENTRY(sc,nz+1,nz+nf,1411) C call USRENTRY(ir,nz+1,nz+nf,1412) do i=1,nf tmp(i)=fsa(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1409) do i=1,nf tmp(i)=ftr(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1410) do i=1,nf tmp(i)=fs(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1411) do i=1,nf tmp(i)=fir(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1412) if ((ncycth.eq.1) .or. (ncyc.gt.1)) then do i=1,nf tmp(i)=fcyc(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1413) end if if (itable .eq. 1) then do i = 1,nz+nfor ceff(i) = Paeast(i) * Patd(i) * Pareg(i,6) end do if (ITER .gt. 2) then call ProcTables(tabtables) end if call OUTTABLE2(titleg,Tram,ot,osa,osc,oir,ocyc,pread,ceff, $ eresid,numEresid,hptmp,hptrtmp,hpcycle,lamd,1, $ nz,mq,2,kunits,nf,trend,sa,fosa,IsCloseToTD) * call profiler(3,'OUTTABFOR') call OUTTABFOR(ftr,fsa,fs,fir,fcyc,pread,ceff,hptmp, $ hptrtmp,hpcycle,lamd,1,nf,nz,mq,trend,sa,fosa) end if C C TABLES WITH THE SE OF FINAL COMPONENTS C if (out .eq. 0) then C Modified by REG, on 28 Feb 2006, to add out to FINALSE parameter list. call FINALSE(psiep,psiea,trend,sa,siepf,siepfl,sieaf,sieafl, $ sqf,ilen,mq,lfor,lamd,out) C write (Nio,'(//,1X,''FORECAST OF FINAL COMPONENT'')') call FORTBL(fo,freg,ftr,fsa,fs,fcyc,fir,Tse,siepf,siepfl, $ sieaf,sieafl,Neff,mq,Nouir,Noutr,Npatd,Neast, $ nchi,npsi,ncyc,ncycth,lamd,nper,nyer,nz,nf, $ isCloseToTD,varwnc) if (Nsfcast .ne. 0) then write (Nio,'(//4x,''THE FORECAST OF THE IRREGULAR '', $ ''ABSORBS'')') write (Nio,'(4X,''THE EFFECT OF THE APPROXIMATION.'')') end if end if do i=1,nf tmp(i)=fsa(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1409) do i=1,nf tmp(i)=ftr(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1410) do i=1,nf tmp(i)=fs(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1411) do i=1,nf tmp(i)=fir(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1412) if (varwnc.gt.1.0D-10 .and.((ncycth.eq.1).or.(ncyc.gt.1))) then do i=1,nf tmp(i)=fcyc(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1413) end if * if ((pg .eq. 0).and.(iter.eq.0)) then * if (out.lt.2) then * if (Npareg .eq. 1) then * fname = 'FREG.T5' * subtitle = 'FORECAST REGRESSION EFFECT' * call PLOTFCAST1(fname,subtitle,freg,nf,nz,0) * end if * if (Neff(0) .eq. 1) then * fname = 'SPREG.T5' * subtitle = 'FORECAST SEPARATE REG. EFFECT' * do i = (-nf),nf * ftmp(i) = Pareg(nz+i,0) * end do * call PLOTFCAST1(fname,subtitle,ftmp,nf,nz,0) * end if * if ((Neff(5).eq.1) .or. * $ (varwnc.gt.1.0D-10.and.((ncycth.eq.1).or.(ncyc.gt.1)))) then * fname = 'FTRAFIN.T5' * if (isCloseToTD) then * subtitle = 'FORECAST FINAL TD COMPONENT' * else * subtitle = 'FORECAST FINAL TRANSITORY COMPONENT' * end if * call PLOTFCAST1(fname,subtitle,fcyc,nf,nz,0) * end if * if ((Neff(3).eq.1) .or. (Nouir.eq.1)) then * fname = 'FIRFIN.T5' * subtitle = 'FORECAST FINAL IRREGULAR' * call PLOTFCAST1(fname,subtitle,fir,nf,nz,0) * end if * end if * if (out.lt.3) then * fname = 'FUNORIG.T5' * subtitle = 'FORECAST OF SERIES' * call PLOTFCAST1(fname,subtitle,fo,nf,nz,0) * if (npsi.ne.1 .or. (Neast+Neff(2)+Npatd).ne.0) then * fname = 'FSAFIN.T5' * subtitle = 'FORECAST FINAL SA SERIES' * call PLOTFCAST1(fname,subtitle,fsa,nf,nz,0) * fname = 'FSFIN.T5' * subtitle = 'FORECAST FINAL SEASONAL FACTORS' * call PLOTFCAST1(fname,subtitle,fs,nf,nz,0) * end if * if (nchi.ne.1 .or. Noutr.ne.0 .or. Neff(1).ne.0 .or. * $ Neff(7).ne.0) then * fname = 'FTRFIN.T5' * subtitle = 'FORECAST FINAL TREND-CYCLE' * call PLOTFCAST1(fname,subtitle,ftr,nf,nz,0) * end if * end if * end if end if C C end if LAMDA=0 C C C HERE INTRODUCE THE CHECK ON THE AGGREGATE C * if (out .ne. 2) then * if (lamd .eq. 1) then * aavsxt = 0.0d0 * aavfxt = 0.0d0 * aavsat = 0.0d0 * aavfat = 0.0d0 * aavfst = 0.0d0 * musxt = 0.0d0 * mufxt = 0.0d0 * musat = 0.0d0 * mufat = 0.0d0 * mufst = 0.0d0 * maxsxt = 1 * maxsat = 1 * maxfxt = 1 * maxfat = 1 * maxfst = 1 * do i = 1,nz+lfor * sxt(i) = z(i) - sa(i) - sc(i) * sat(i) = sa(i) - trend(i) - cycle(i) - ir(i) * if ((sxt(i)-sxt(maxsxt)) .gt. 1.0d-8) then * maxsxt = i * end if * if ((sat(i)-sat(maxsat)) .gt. 1.0d-8) then * maxsat = i * end if * aavsxt = aavsxt + ABS(sxt(i)) * aavsat = aavsat + ABS(sat(i)) * musxt = musxt + sxt(i) * musat = musat + sat(i) * end do * do i = 1,nz * fxt(i) = Tram(i) - osa(i) - osc(i) - Pareg(i,0) * fat(i) = osa(i) - ot(i) - ocyc(i) - oir(i) - Pareg(i,4) * fst(i) = osc(i) - sc(i) - Patd(i) - Paeast(i) - Pareg(i,2) - * $ Paous(i) * if ((fxt(i)-fxt(maxfxt)) .gt. 1.0d-8) then * maxfxt = i * end if * if ((fat(i)-fat(maxfat)) .gt. 1.0d-8) then * maxfat = i * end if * if ((fst(i)-fst(maxfst)) .gt. 1.0d-8) then * maxfst = i * end if * aavfxt = aavfxt + ABS(fxt(i)) * aavfat = aavfat + ABS(fat(i)) * aavfst = aavfst + ABS(fst(i)) * mufxt = mufxt + fxt(i) * mufat = mufat + fat(i) * mufst = mufst + fst(i) * end do * do i = 1,lfor * fxt(nz+i) = Tram(nz+i) - fsa(i) - fs(i) - Pareg(nz+i,0) * fat(nz+i) = fsa(i) - ftr(i) - fcyc(i) - fir(i) - Pareg(nz+i,4) * fst(nz+i) = * $ fs(i) - sc(nz+i) - Patd(nz+i) - Paeast(nz+i) - Pareg(nz+i,2) * $ - Paous(nz+i) * if ((fxt(nz+i)-fxt(maxfxt)) .gt. 1.0d-8) then * maxfxt = nz + i * end if * if ((fat(nz+i)-fat(maxfat)) .gt. 1.0d-8) then * maxfat = nz + i * end if * if ((fst(nz+i)-fst(maxfst)) .gt. 1.0d-8) then * maxfst = nz + i * end if * aavfxt = aavfxt + ABS(fxt(nz+i)) * aavfat = aavfat + ABS(fat(nz+i)) * aavfst = aavfst + ABS(fst(nz+i)) * mufxt = mufxt + fxt(nz+i) * mufat = mufat + fat(nz+i) * mufst = mufst + fst(nz+i) * end do * aavsxt = aavsxt / DBLE(nz+lfor) * aavfxt = aavfxt / DBLE(nz+lfor) * aavsat = aavsat / DBLE(nz+lfor) * aavfat = aavfat / DBLE(nz+lfor) * aavfst = aavfst / DBLE(nz+lfor) * musxt = musxt / DBLE(nz+lfor) * mufxt = mufxt / DBLE(nz+lfor) * musat = musat / DBLE(nz+lfor) * mufat = mufat / DBLE(nz+lfor) * mufst = mufst / DBLE(nz+lfor) * aggsxt = sxt(maxsxt) * aggfxt = fxt(maxfxt) * aggsat = sat(maxsat) * aggfat = fat(maxfat) * aggfst = fst(maxfst) * sumsxt = sa(maxsxt) + sc(maxsxt) * sumsat = trend(maxsat) + cycle(maxsat) + ir(maxsat) * if (maxfxt .le. nz) then * sumfxt = osa(maxfxt) + osc(maxfxt) + Pareg(maxfxt,0) * else * sumfxt = fsa(maxfxt-nz) + fs(maxfxt-nz) + Pareg(maxfxt,0) * end if * if (maxfat .le. nz) then * sumfat = ot(maxfat) + ocyc(maxfat) + oir(maxfat) + * $ Pareg(maxfat,4) * else * sumfat = ftr(maxfat-nz) + fcyc(maxfat-nz) + fir(maxfat-nz) + * $ Pareg(maxfat,4) * end if * if (maxfst .le. nz) then * sumfst = sc(maxfst) + Patd(maxfst) + Paeast(maxfst) + * $ Pareg(maxfst,2) + Paous(maxfst) * else * sumfst = fs(maxfst-nz) + Patd(maxfst) + Paeast(maxfst) + * $ Pareg(maxfst,2) + Paous(maxfst) * end if * IF(ABS(Tram(maxsxt)).le.SMALL)THEN * pplevsxt = (ABS(aggsxt)/ABS(Tram(maxsxt))) * 100.0d0 * ELSE * pplevsxt = ZERO * END IF * IF(ABS(Tram(maxsat)).le.SMALL)THEN * pplevsat = (ABS(aggsat)/ABS(Tram(maxsat))) * 100.0d0 * ELSE * pplevsat = ZERO * END IF * IF(ABS(Tram(maxfxt)).le.SMALL)THEN * pplevfxt = (ABS(aggfxt)/ABS(Tram(maxfxt))) * 100.0d0 * ELSE * pplevfxt = ZERO * END IF * IF(ABS(Tram(maxfat)).le.SMALL)THEN * pplevfat = (ABS(aggfat)/ABS(Tram(maxfat))) * 100.0d0 * ELSE * pplevfat = ZERO * END IF * IF(ABS(Tram(maxfst)).le.SMALL)THEN * pplevfst = (ABS(aggfst)/ABS(Tram(maxfst))) * 100.0d0 * ELSE * pplevfst = ZERO * END IF * if (HTML .eq. 1) then * write (Nio,'(''

DIFFERENCE BETWEEN AGGREGATE'', * $ '' AND AGGREGATE OF COMPONENTS'')') * write (nio,'('''')') * write (Nio,'('''', * $ '''', * $ '''', * $ '''', * $ '''')') * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ musxt, musat, mufxt, mufat, mufst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ aavsxt, aavsat, aavfxt, aavfat, aavfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ sxt(maxsxt), sat(maxsat), fxt(maxfxt), fat(maxfat), * $ fst(maxfst) * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ pplevsxt, pplevsat, pplevfxt, pplevfat, pplevfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ maxsxt, maxsat, maxfxt, maxfat, maxfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ aggsxt, aggsat, aggfxt, aggfat, aggfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ sumsxt, sumsat, sumfxt, sumfat, sumfst * write (Nio,'("
SXSAFXFAFS
MEAN'',G12.4,''
AAV'',G12.4,''
MAX DIFF.'',G12.4,''
MAX DIFF. '', * $ ''AS % OF LEVEL'',G12.4,''
PERIOD'',G12.4,''
AGGREGATE'',G12.4,''
THROUGH COMP.'',G12.4,''

")') * else * write (Nio,'(//,12x,''DIFFERENCE BETWEEN AGGREGATE'',/,12x, * $ ''AND AGGREGATE OF COMPONENTS'',//)') * write (Nio,'(34x,''SX'',16x,''SA'',16x,''FX'',16x, * $ ''FA'',16x,''FS'')') * write (Nio,'(4X,''MEAN'',20X,5(G12.4,6X),/)') * $ musxt, musat, mufxt, mufat, mufst * write (Nio,'(4X,''AAV'',21X,5(G12.4,6X),/)') * $ aavsxt, aavsat, aavfxt, aavfat, aavfst * write (Nio,'(4X,''MAX DIFF.'',15X,5(G12.4,6X),/)') * $ sxt(maxsxt), sat(maxsat), fxt(maxfxt), fat(maxfat), * $ fst(maxfst) * write (Nio,'(4X,''MAX DIFF. AS % '')') * write (Nio,'(4X,''OF LEVEL'',16X,5(G12.4,6X),/)') * $ pplevsxt, pplevsat, pplevfxt, pplevfat, pplevfst * write (Nio,'(4X,''PERIOD'',15X,5(I12,6X),/)') * $ maxsxt, maxsat, maxfxt, maxfat, maxfst * write (Nio,'(4X,''AGGREGATE'',15X,5(G12.4,6X),/)') * $ aggsxt, aggsat, aggfxt, aggfat, aggfst * write (Nio,'(4X,''THROUGH COMP.'',11X,5(G12.4,6X),/)') * $ sumsxt, sumsat, sumfxt, sumfat, sumfst * end if * else * aavsxt = 0.0d0 * aavfxt = 0.0d0 * aavsat = 0.0d0 * aavfat = 0.0d0 * aavfst = 0.0d0 * musxt = 0.0d0 * mufxt = 0.0d0 * musat = 0.0d0 * mufat = 0.0d0 * mufst = 0.0d0 * maxsxt = 1 * maxsat = 1 * maxfxt = 1 * maxfat = 1 * maxfst = 1 ** OPEN(66,file='z.txt',STATUS='UNKNOWN') * OPEN(66,file=Cursrs(1:Nfilcr)//'.tbz',STATUS='UNKNOWN') * do i = 1,nz * write(66,*)z(i),sa(i),sc(i),trend(i),cycle(i),ir(i) * sxt(i) = EXP(z(i)) / (sa(i)*(sc(i)/100.0d0)) * sat(i) = sa(i) / (trend(i)*(cycle(i)/100.0d0)*(ir(i)/100.0d0)) * if (ABS(sxt(i)-sxt(maxsxt)) .gt. 1.0d-8) then * maxsxt = i * end if * if (ABS(sat(i)-sat(maxsat)) .gt. 1.0d-8) then * maxsat = i * end if * aavsxt = aavsxt + ABS(sxt(i)) * aavsat = aavsat + ABS(sat(i)) * musxt = musxt + sxt(i) * musat = musat + sat(i) * end do * do i = nz+1,nz+lfor * write(66,*)z(i),sa(i),sc(i),trend(i),cycle(i),ir(i) * sxt(i) = EXP(z(i)) / (sa(i)*(sc(i)/100.0d0)) * sat(i) = sa(i) / (trend(i)*(cycle(i)/100.0d0)) * if ((sxt(i)-sxt(maxsxt)) .gt. 1.0d-8) then * maxsxt = i * end if * if ((sat(i)-sxt(maxsat)) .gt. 1.0d-8) then * maxsat = i * end if * aavsxt = aavsxt + ABS(sxt(i)) * aavsat = aavsat + ABS(sat(i)) * musxt = musxt + sxt(i) * musat = musat + sat(i) * end do * close(66) * OPEN(66,file=Cursrs(1:Nfilcr)//'.tbo',STATUS='UNKNOWN') * do i = 1,nz * write(66,*)Tram(i),osa(i),osc(i),ot(i),ocyc(i),oir(i) * fxt(i) = Tram(i) / (osa(i)*(osc(i)/100.0d0)*Pareg(i,0)) * fat(i) = * $ osa(i) / * $ (ot(i)*(ocyc(i)/100.0d0)*(oir(i)/100.0d0)*Pareg(i,4)) * fst(i) = * $ (osc(i)/((sc(i)/100.0d0)*Patd(i)*Paeast(i)*Paous(i)* * $ Pareg(i,2))) / 100.0d0 * if ((fxt(i)-fxt(maxsxt)) .gt. 1.0d-8) then * maxfxt = i * end if * if ((fat(i)-fat(maxfat)) .gt. 1.0d-8) then * maxfat = i * end if * if ((fst(i)-fst(maxfst)) .gt. 1.0d-8) then * maxfst = i * end if * aavfxt = aavfxt + ABS(fxt(i)) * aavfat = aavfat + ABS(fat(i)) * aavfst = aavfst + ABS(fst(i)) * mufxt = mufxt + fxt(i) * mufat = mufat + fat(i) * mufst = mufst + fst(i) * end do * close(66) * OPEN(66,file=Cursrs(1:Nfilcr)//'.tbf',STATUS='UNKNOWN') * do i = 1,lfor * write(66,*)Tram(nz+i),fsa(i),fs(i),ftr(i),fcyc(i),fir(i) * fxt(nz+i) = * $ Tram(nz+i) / (fsa(i)*(fs(i)/100.0d0)*Pareg(nz+i,0)) * fat(nz+i) = * $ fsa(i) / * $ (ftr(i)*(fcyc(i)/100.0d0)*(fir(i)/100.0d0)*Pareg(nz+i,4)) * fst(nz+i) = * $ (fs(i)/ * $ ((sc(nz+i)/100.0d0)*Patd(nz+i)*Paeast(nz+i)*Pareg(nz+i,2)* * $ Paous(nz+i))) / 100.0d0 * if ((fxt(i)-fxt(maxsxt)) .gt. 1.0d-8) then * maxfxt = nz + i * end if * if ((fat(i)-fat(maxfat)) .gt. 1.0d-8) then * maxfat = nz + i * end if * if ((fst(i)-fst(maxfst)) .gt. 1.0d-8) then * maxfst = nz + i * end if * aavfxt = aavfxt + ABS(fxt(nz+i)) * aavfat = aavfat + ABS(fat(nz+i)) * aavfst = aavfst + ABS(fst(nz+i)) * mufxt = mufxt + fxt(nz+i) * mufat = mufat + fat(nz+i) * mufst = mufst + fst(nz+i) * end do * close(66) * aavsxt = aavsxt / DBLE(nz+lfor) * aavfxt = aavfxt / DBLE(nz+lfor) * aavsat = aavsat / DBLE(nz+lfor) * aavfat = aavfat / DBLE(nz+lfor) * aavfst = aavfst / DBLE(nz+lfor) * musxt = musxt / DBLE(nz+lfor) * mufxt = mufxt / DBLE(nz+lfor) * musat = musat / DBLE(nz+lfor) * mufat = mufat / DBLE(nz+lfor) * mufst = mufst / DBLE(nz+lfor) * aggsxt = sxt(maxsxt) * aggfxt = fxt(maxfxt) * aggsat = sat(maxsat) * aggfat = fat(maxfat) * aggfst = fst(maxfst) * sumsxt = sa(maxsxt) * (sc(maxsxt)/100.0d0) * sumsat = trend(maxsat) * (cycle(maxsat)/100.0d0) * * $ (ir(maxsat)/100.0d0) * if (maxfxt .le. nz) then * sumfxt = osa(maxfxt) * (osc(maxfxt)/100.0d0) * Pareg(maxfxt,0) * else * sumfxt = fsa(maxfxt-nz) * (fs(maxfxt-nz)/100.0d0) * * $ Pareg(maxfxt,0) * end if * if (maxfat .le. nz) then * sumfat = ot(maxfat) * (ocyc(maxfat)/100.0d0) * * $ (oir(maxfat)/100.0d0) * Pareg(maxfat,4) * else * sumfat = ftr(maxfat-nz) * (fcyc(maxfat-nz)/100.0d0) * * $ (fir(maxfat-nz)/100.0d0) * Pareg(maxfat,4) * end if * if (maxfst .le. nz) then * sumfst = (sc(maxfst)/100.0d0) * Patd(maxfst) * Paeast(maxfst) * $ * Pareg(maxfst,2) * Paous(maxfst) * else * sumfst = (fs(maxfst-nz)/100.0d0) * Patd(maxfst) * * $ Paeast(maxfst) * Pareg(maxfst,2) * * $ Paous(maxfst) * end if *C LINES OF CODE COMMENTED FOR X-13A-S : 5 *C pplevsxt = (ABS(aggsxt)/ABS(Tram(maxsxt))) * 100.0d0 *C pplevsat = (ABS(aggsat)/ABS(Tram(maxsat))) * 100.0d0 *C pplevfxt = (ABS(aggfxt)/ABS(Tram(maxfxt))) * 100.0d0 *C pplevfat = (ABS(aggfat)/ABS(Tram(maxfat))) * 100.0d0 *C pplevfst = (ABS(aggfst)/ABS(Tram(maxfst))) * 100.0d0 *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 25 * IF(ABS(Tram(maxsxt)).le.SMALL)THEN * pplevsxt = (ABS(aggsxt)/ABS(Tram(maxsxt))) * 100.0d0 * ELSE * pplevsxt = ZERO * END IF * IF(ABS(Tram(maxsat)).le.SMALL)THEN * pplevsat = (ABS(aggsat)/ABS(Tram(maxsat))) * 100.0d0 * ELSE * pplevsat = ZERO * END IF * IF(ABS(Tram(maxfxt)).le.SMALL)THEN * pplevfxt = (ABS(aggfxt)/ABS(Tram(maxfxt))) * 100.0d0 * ELSE * pplevfxt = ZERO * END IF * IF(ABS(Tram(maxfat)).le.SMALL)THEN * pplevfat = (ABS(aggfat)/ABS(Tram(maxfat))) * 100.0d0 * ELSE * pplevfat = ZERO * END IF * IF(ABS(Tram(maxfst)).le.SMALL)THEN * pplevfst = (ABS(aggfst)/ABS(Tram(maxfst))) * 100.0d0 * ELSE * pplevfst = ZERO * END IF *C END OF CODE BLOCK * if (HTML .eq. 1) then * write (Nio,'(''

DIFFERENCE BETWEEN AGGREGATE'', * $ '' AND AGGREGATE OF COMPONENTS'')') * write (nio,'('''')') * write (Nio,'('''', * $ '''', * $ '''', * $ '''', * $ '''')') * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ musxt, musat, mufxt, mufat, mufst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ aavsxt, aavsat, aavfxt, aavfat, aavfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ sxt(maxsxt), sat(maxsat), fxt(maxfxt), fat(maxfat), * $ fst(maxfst) * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ pplevsxt, pplevsat, pplevfxt, pplevfat, pplevfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ maxsxt, maxsat, maxfxt, maxfat, maxfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ aggsxt, aggsat, aggfxt, aggfat, aggfst * write (Nio,'('''', * $ 5(''''), * $ '''')') * $ sumsxt, sumsat, sumfxt, sumfat, sumfst * write (Nio,'("
SXSAFXFAFS
MEAN'',G12.4,''
AAV'',G12.4,''
MAX DIFF.'',G12.4,''
MAX DIFF. '', * $ ''AS % OF LEVEL'',G12.4,''
PERIOD'',G12.4,''
AGGREGATE'',G12.4,''
THROUGH COMP.'',G12.4,''

")') * else * write (Nio,'(//,12x,''DIFFERENCE BETWEEN AGGREGATE'',/,12x, * $ ''AND AGGREGATE OF COMPONENTS'',//)') * write (Nio,'(34x,''SX'',16x,''SA'',16x,''FX'',16x, * $ ''FA'',16x,''FS'')') * write (Nio,'(4X,''MEAN'',20X,5(G12.4,6X),/)') * $ musxt, musat, mufxt, mufat, mufst * write (Nio,'(4X,''AAV'',21X,5(G12.4,6X),/)') * $ aavsxt, aavsat, aavfxt, aavfat, aavfst * write (Nio,'(4X,''MAX DIFF.'',15X,5(G12.4,6X),/)') * $ sxt(maxsxt), sat(maxsat), fxt(maxfxt), fat(maxfat), * $ fst(maxfst) * write (Nio,'(4X,''MAX DIFF. AS % '')') * write (Nio,'(4X,''OF LEVEL'',16X,5(G12.4,6X),/)') * $ pplevsxt, pplevsat, pplevfxt, pplevfat, pplevfst * write (Nio,'(4X,''PERIOD'',15X,5(I12,6X),/)') * $ maxsxt, maxsat, maxfxt, maxfat, maxfst * write (Nio,'(4X,''AGGREGATE'',15X,5(G12.4,6X),/)') * $ aggsxt, aggsat, aggfxt, aggfat, aggfst * write (Nio,'(4X,''THROUGH COMP.'',11X,5(G12.4,6X),/)') * $ sumsxt, sumsat, sumfxt, sumfat, sumfst * end if * end if * end if C C CHECK ON THE MEAN C * jadd = MOD(nz,mq) * if (jadd .gt. 0) then * jadd = mq - jadd * end if if (lamd .eq. 0) then do i=nz+1,nz+lfor oz(i) = Dexp(z(i)) end do else do i=nz+1,nz+lfor oz(i) = z(i) end do end if * if (HTML .eq. 1) then * write (Nio,'(''

COMPARISON OF MEANS'')') * write (nio,'('''')') * write (Nio,'('''', * $ '''')') * write (Nio,'('''', * $ 2('''', * $ ''''), * $ '''')') * write (Nio,'('''', * $ 2(''''),'''')') * $ DMEAN(nz+jadd,oz), DMU(oz,nz+1,nz+lfor), * $ DMEAN(nz+jadd,Tram), DMU(Tram,nz+1,nz+lfor) * else * write (Nio,'(/,45x,''COMPARISON OF MEANS'',/,28x, * $ ''STOCHASTIC'',32x,''FINAL'',/,28x,''COMPONENT'',33x, * $ ''COMPONENT'',/)') * write (Nio,'(13X,2(9X,''IN SAMPLE'',8X,''FORECAST'',6X))') * write (Nio,'(4X,''SERIES'',6X,2(4X,G13.4,3X,G13.4,8X),/)') *c $ DMEAN(nz+jadd,oz), DMU(oz,nz+1,nz+lfor), * $ DMEAN(nz,oz), 0.0D0, * $ DMEAN(nz+jadd,Tram), DMU(Tram,nz+1,nz+lfor) * end if do i = nz+1,nz+lfor osc(i) = fs(i-nz) osa(i) = fsa(i-nz) ocyc(i) = fcyc(i-nz) oir(i) = fir(i-nz) ot(i) = ftr(i-nz) end do * if ((pg.eq.0).and.(iter.ne.0).and.(ioneout.eq.0)) then * if (out.le.1) then *c if (nreestimated.eq.1 .or. tramo.eq.0) then * if (tramo.eq.0) then * fname = title(1:ntitle) // '.FX' * subtitle = 'FORECAST OF SERIES(MCS)' * call PLOTFCAST1(fname,subtitle,fo,nf,nz,0) ** write (27,'(A)') fname * end if * end if * if (nchi.ne.1 .or. Noutr.ne.0 .or. Neff(1).ne.0 * $ .or. Neff(7).ne.0) then * fname = title(1:ntitle) // '.FTR' * subtitle = 'FORECAST FINAL TREND-CYCLE' * call PLOTFCAST1(fname,subtitle,ftr,nf,nz,0) ** write (27,'(A)') fname * end if * end if if (out.eq.0) then * if (npsi.ne.1 .or. (Neast+Neff(2)+Npatd).ne.0) then * fname = title(1:ntitle) // '.FSA' * subtitle = 'FORECAST FINAL SA SERIES' * call PLOTFCAST1(fname,subtitle,fsa,nf,nz,0) ** write (27,'(A)') fname * end if * if ((Neff(5).eq.1) .or. * $ (varwnc.gt.1.0D-10 .and.(ncycth.eq.1.or.ncyc.gt.1)))then * fname = title(1:ntitle) // '.FCY' * if (isCloseToTD) then * subtitle = 'FORECAST FINAL TD COMPONENT' * else * subtitle = 'FORECAST FINAL TRANSITORY COMPONENT' * end if * call PLOTFCAST1(fname,subtitle,fcyc,nf,nz,0) ** write (27,'(A)') fname * end if end if end if end C C subroutine ABIASC(mq,lfor,oz,trend,z,sc,forbias,forsbias,fortbias, $ bias1,bias3,xx,npsi,noC) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer mq,lfor,nPSI real*8 oz(*),trend(*),z(*),sc(*),forbias(*),forsbias(*), $ fortbias(*),bias1,bias3,xx logical noC C C.. Local Scalars .. integer i,itf,j,j0,jf,jl,nf,nt real*8 sabsdif1,sfull2,sum1,sum2,sum3 C C.. Local Arrays .. real*8 forstemp(Kp),fortemp(Kp),forttemp(Kp),stemp(mpkp), $ ttemp(mpkp) C C.. Intrinsic Functions .. intrinsic ABS, DBLE, EXP include 'sform.i' C C ... Executable Statements ... C do i = 1,Nz+2*mq ttemp(i) = EXP(trend(i)) * bias3 stemp(i) = EXP(sc(i)) / bias1 stemp(i) = EXP(z(i)) / stemp(i) end do * do i = 1,59 do i = 1,Kp if (NPSI.ne.1) then forstemp(i) = EXP(forbias(i)) / (EXP(forsbias(i))/bias1) else forstemp(i) = EXP(forbias(i)) / (EXP(forsbias(i))) endif IF (NPSI.ne.1 .or. .not. noC)then forttemp(i) = EXP(fortbias(i)) * bias3 else forttemp(i) = EXP(fortbias(i)) endif fortemp(i) = EXP(forbias(i)) end do j0 = 0 if (Nper .ne. 1) then j0 = mq + 1 - Nper end if jf = Nz - j0 - ((Nz-j0)/mq)*mq jl = ((lfor/mq)+1)*mq - lfor - jf itf = lfor + 2*mq + jl nf = (jf+itf) / mq nt = nf + (Nz-j0)/mq sfull2 = 0.0d0 sabsdif1 = 0.0d0 do i = 1,nt-2 sum1 = 0.0d0 sum2 = 0.0d0 sum3 = 0.0d0 do j = 1,mq if (((i-1)*mq+j+j0) .le. Nz) then sum1 = sum1 + oz((i-1)*mq+j+j0) sum2 = sum2 + stemp((i-1)*mq+j+j0) sum3 = sum3 + ttemp((i-1)*mq+j+j0) else if (((i-1)*mq+j+j0-Nz).le.Kp) then sum1 = sum1 + fortemp((i-1)*mq+j+j0-Nz) sum2 = sum2 + forstemp((i-1)*mq+j+j0-Nz) sum3 = sum3 + forttemp((i-1)*mq+j+j0-Nz) end if end do sum1 = sum1 / DBLE(mq) sum2 = sum2 / DBLE(mq) sum3 = sum3 / DBLE(mq) sfull2 = sfull2 + sum2 sabsdif1 = sabsdif1 + (ABS(sum1-sum2)) end do sfull2 = sfull2 / DBLE(nt-2) sabsdif1 = sabsdif1 / DBLE(nt-2) if (ABS(sfull2) .lt. 1.0d-8) then sfull2 = 1.0d-6 end if xx = (sabsdif1/sfull2) * 100.0d0 end C C subroutine FORTBL(fo,freg,ftr,fsa,fs,fcyc,fir,tse,siepf,siepfl, $ sieaf,sieafl,neff,mq,nouir,noutr,npatd,neast, $ nchi,npsi,ncyc,ncycth,lamd,nper,nyer,nz,lfor, $ isCloseToTD,varwnc) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer neff(0:7),mq,nouir,noutr,npatd,neast,nchi,npsi,ncyc, $ ncycth,lamd,nper,nyer,nz, lfor real*8 fo(-kp:kp),freg(-kp:kp),ftr(-kp:kp),fsa(-kp:kp),fs(-kp:kp), $ fcyc(-kp:kp),fir(-kp:kp),tse(kl),siepf(kl),siepfl(kl), $ sieaf(kl),sieafl(kl),varwnc logical isCloseToTD C C.. Local Scalars .. integer i,j,jnlastper,jnlastyear,ncols,nf,nlastper,nlastyear,nse C C.. Local Arrays .. character fn(0:12)*12,fstline(7)*16,mth(12)*4,scnline(7)*16, $ srt(11)*4,thrline(7)*16,wrt(10)*12,wrt1(5)*12, $ wrt2(4)*12,wrt3(5)*12,wrt4(4)*12 real*8 formatrix(kp,14),tmp(kp) C C.. External Calls .. external USRENTRY C C.. Intrinsic Functions .. intrinsic MAX, MOD include 'stream.i' C C.. Data Declarations .. C DATA WRT/'(3X','''DATE'',10X','N','(''FORECAST''','6X', C $ '''SE'',8X','))'/ data fn/'0','1','2','3','4','5','6','7','8','9','10','11','12'/ data mth/ $ 'JAN ','FEB ','MAR ','APR ','MAY ','JUN','JUL','AUG ','SEP', $ 'OCT ','NOV ','DEC '/ data srt/ $ '1ST','2ND','3RD','4TH','5TH','6TH','7TH','8TH','9TH','10TH', $ '11TH'/ C C ... Executable Statements ... C c initialize wrt format variables so they are the same for each call c of the subroutine (BCM, JAN 2003) CALL setwrt(wrt,0) CALL setwrt(wrt1,1) CALL setwrt(wrt2,2) CALL setwrt(wrt3,3) CALL setwrt(wrt4,4) c end of change BCM ncols = 1 nse = 1 nf = MAX(lfor,MAX(8,2*mq)) do i = 1,nf formatrix(i,ncols) = fo(i) formatrix(i,ncols+1) = tse(i) end do ncols = ncols + 1 fstline(ncols-nse) = 'ORIGINAL' scnline(ncols-nse) = '(UNCORRECTED)' thrline(ncols-nse) = 'SERIES' if ((nchi.gt.1) .or. (noutr.eq.1) .or. (neff(1).eq.1) $ .or. (neff(7).eq.1)) then nse = nse + 1 ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = ftr(i) tmp(i) = ftr(i) end do ncols = ncols + 1 if (lamd .eq. 0) then do i = 1,nf formatrix(i,ncols) = siepfl(i) end do call usrentry(siepfl,1,nf,1,kl,1256) else do i = 1,nf formatrix(i,ncols) = siepf(i) end do call usrentry(siepf,1,nf,1,kl,1256) end if call USRENTRY(tmp,1,nf,1,PFCST,1410) fstline(ncols-nse) = 'TREND-CYCLE' scnline(ncols-nse) = ' ' thrline(ncols-nse) = ' ' end if if ((npsi.gt.1) .or. (neast.eq.1) .or. (neff(2).eq.1) .or. $ (npatd.eq.1)) then nse = nse + 1 ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = fsa(i) tmp(i) = fsa(i) end do ncols = ncols + 1 if (lamd .eq. 0) then do i = 1,nf formatrix(i,ncols) = sieafl(i) end do call usrentry(sieafl,1,nf,1,kl,1257) else do i = 1,nf formatrix(i,ncols) = sieaf(i) end do call usrentry(sieaf,1,nf,1,kl,1257) end if call USRENTRY(tmp,1,nf,1,PFCST,1409) fstline(ncols-nse) = 'SA SERIES' scnline(ncols-nse) = 'SERIES' C LINES OF CODE COMMENTED FOR X-13A-S : 1 C thrline(ncols-nse) = '' C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 thrline(ncols-nse) = ' ' C END OF CODE BLOCK else if (neff(0) .eq. 1) then nse = nse + 1 ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = fsa(i) tmp(i) = fsa(i) end do ncols = ncols + 1 if (lamd .eq. 0) then do i = 1,nf formatrix(i,ncols) = sieafl(i) end do call usrentry(sieafl,1,nf,1,kl,1257) else do i = 1,nf formatrix(i,ncols) = sieaf(i) end do call usrentry(sieaf,1,nf,1,kl,1257) end if call USRENTRY(tmp,1,nf,1,PFCST,1409) fstline(ncols-nse) = 'SA SERIES' scnline(ncols-nse) = 'SERIES' C LINES OF CODE COMMENTED FOR X-13A-S : 1 C thrline(ncols-nse) = '' C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 thrline(ncols-nse) = ' ' C END OF CODE BLOCK end if if (neff(0) .eq. 1) then ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = freg(i) end do fstline(ncols-nse) = 'SEPARATE' scnline(ncols-nse) = 'REGRESSION' thrline(ncols-nse) = 'EFFECT' end if if ((npsi.gt.1) .or. (neast.eq.1) .or. (neff(2).eq.1) .or. $ (npatd.eq.1)) then ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = fs(i) tmp(i) = fs(i) end do call USRENTRY(tmp,1,nf,1,PFCST,1411) fstline(ncols-nse) = 'SEASONAL' if (lamd .eq. 0) then scnline(ncols-nse) = 'FACTORS' else scnline(ncols-nse) = 'COMPONENT' end if thrline(ncols-nse) = ' ' end if C IF ((NCYCTH.EQ.1).OR.(NCYC.GT.1).OR.(NEFF(5).EQ.1)) THEN C NCOLS=NCOLS+1 C DO 50 I=1,NF C FORMATRIX(I,NCOLS)=FCYC(I) C TMP(I)=FCYC(I) C 50 CONTINUE C CALL USRENTRY(TMP,1,NF,1,PFCST,1413) C FSTLINE(NCOLS)='TRANSITORY' C IF (LAMD.EQ.0) THEN C SCNLINE(NCOLS)='FACTORS' C ELSE C SCNLINE(NCOLS)='COMPONENT' C end if C THRLINE(NCOLS)=' ' C end if if ((neff(3).eq.1) .or. (nouir.eq.1) .or. $ (varwnc.gt.1.0D-10 .and.(ncycth.eq.1.or.ncyc.gt.1)) $ .or. (neff(5).eq.1)) then ncols = ncols + 1 if (lamd .eq. 1) then do i = 1,nf formatrix(i,ncols) = fir(i) + fcyc(i) tmp(i) = fir(i) end do else do i = 1,nf formatrix(i,ncols) = (fir(i)*fcyc(i)) / 100.0d0 tmp(i) = fir(i) end do end if call USRENTRY(tmp,1,nf,1,PFCST,1412) if (isCloseToTD) then fstline(ncols-nse) = 'TDfinal.-IRREG.' else fstline(ncols-nse) = 'TRANS.-IRREG.' end if if (lamd .eq. 0) then scnline(ncols-nse) = 'FACTORS' else scnline(ncols-nse) = ' ' end if thrline(ncols-nse) = ' ' end if nlastper = nper nlastyear = nyer do i = 2,nz if (MOD(nlastper,mq) .eq. 0) then nlastyear = nlastyear + 1 nlastper = 0 end if nlastper = nlastper + 1 end do nlastper = nlastper + 1 if (nlastper .gt. mq) then nlastper = 1 nlastyear = nlastyear + 1 end if jnlastper = nlastper jnlastyear = nlastyear C C 100 FORMAT(9X,A13,11X,A13,11X,A13,11X,A13,11X, C $ A13,11X,A13,11X,A13) C 110 FORMAT(2X,A3,'-',I4,4X,F13.4,4X,F13.4,3X,F13.4,3X,F13.4,5X, C $ F13.4,3X,F13.4,4X,F13.4) write (Nio,'(//)') wrt2(2) = fn(nse) write (Nio,wrt2) (fstline(i), i = 1,nse) write (Nio,wrt2) (scnline(i), i = 1,nse) write (Nio,wrt2) (thrline(i), i = 1,nse) if (nse.eq.1)THEN wrt(6) = '1x)' DO i = 7,10 wrt(i) = ' ' END DO else wrt(6) = fn(nse-1) end if wrt1(3) = fn(nse) write (Nio,*) write (Nio,wrt) write (Nio,*) if (mq .eq. 12) then do i = 1,nf write (Nio,wrt1) $ mth(nlastper), nlastyear, (formatrix(i,j), j = 1,nse*2) if (nlastper .eq. mq) then nlastper = 1 nlastyear = nlastyear + 1 else nlastper = nlastper + 1 end if end do else do i = 1,nf write (Nio,wrt1) $ srt(nlastper), nlastyear, (formatrix(i,j), j = 1,nse*2) if (nlastper .eq. mq) then nlastper = 1 nlastyear = nlastyear + 1 else nlastper = nlastper + 1 end if end do end if if (nse*2 .lt. ncols) then write (Nio,'(/)') nlastper = jnlastper nlastyear = jnlastyear wrt4(2) = fn(ncols-2*nse) write (Nio,wrt4) (fstline(i), i = nse+1,ncols-nse) write (Nio,wrt4) (scnline(i), i = nse+1,ncols-nse) write (Nio,wrt4) (thrline(i), i = nse+1,ncols-nse) C LINES OF CODE COMMENTED FOR X-13A-S : 1 c wrt(3) = fn(ncols-2*nse) C END OF CODE BLOCK wrt3(3) = fn(ncols-2*nse) if (mq .eq. 12) then do i = 1,nf write (Nio,wrt3) $ mth(nlastper), nlastyear, $ (formatrix(i,j), j = nse*2+1,ncols) if (nlastper .eq. mq) then nlastper = 1 nlastyear = nlastyear + 1 else nlastper = nlastper + 1 end if end do else do i = 1,nf write (Nio,wrt3) $ srt(nlastper), nlastyear, $ (formatrix(i,j), j = nse*2+1,ncols) if (nlastper .eq. mq) then nlastper = 1 nlastyear = nlastyear + 1 else nlastper = nlastper + 1 end if end do end if end if write (Nio,'(//,2x,''SE : STANDARD ERROR OF THE OBSERVED '', $ ''SERIES FORECAST.''/,2x,''SER : STANDARD ERROR OF THE '', $ ''REVISION.'',//,2x,''Note 1 : SINCE THE COMPONENT IS '', $ ''NEVER OBSERVED,THE FORECAST ERROR IS OF LITTLE'',/,2x, $ ''APPLIED INTEREST. WHAT IS OF INTEREST '', $ ''IS THE SE OF THE REVISION THE FORECAST'',/,2x, $ ''OF THE COMPONENT WILL UNDERGO (UNTIL IT BECOMES '', $ ''THE FINAL OR HISTORICAL ESTIMATOR).'',/)') write (Nio,'(2x,''Note 2 : SER(Seasonal) = SER (SA Series)'',/)') end C C subroutine RATES(tram,otr,osa,fo,ftr,fsa,nchi,npsi,lfor,nfinal) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer nchi,npsi,lfor,nfinal real*8 tram(*),otr(*),osa(*),fo(-kp:kp),ftr(-kp:kp),fsa(-kp:kp) C C.. Local Scalars .. integer i,k,nper2,nrg,nyer2,nzs C C.. Local Arrays .. real*8 rg(mpkp),temp(mpkp) C C.. External Calls .. external TABLE C C.. Intrinsic Functions .. intrinsic EXP include 'sform.i' include 'stream.i' C C ... Executable Statements ... C nzs = Nz nyer2 = Nyer nper2 = Nper C C RATES OF ORIGINAL SERIES C if (nfinal .eq. 1) then do i = 1,Nz temp(i) = tram(i) end do do i = 1,lfor temp(Nz+i) = fo(i) end do else do i = 1,Nz+lfor temp(i) = EXP(tram(i)) end do end if k = Nz - lfor nrg = (Nz+lfor/2) - (Nz-lfor) + 1 do i = Nz-lfor,Nz+lfor/2 rg(i-k+1) = ((temp(i)-temp(i-1))/temp(i-1)) * 100.0d0 end do Nz = nrg Nper = Nper + nzs - lfor - 1 do while (Nper.gt.Nfreq .and. Nfreq.ne.0) Nper = Nper - Nfreq Nyer = Nyer + 1 end do if (nfinal .eq. 1) then C LINES OF CODE COMMENTED FOR X-13A-S : 1 C write (Nio,'(//,6X,''ORIGINAL SERIES (from TRAMO)'')') C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 write (Nio,'(//,6X,''ORIGINAL SERIES (from regARIMA)'')') C END OF CODE BLOCK else write (Nio,'(//,6X,''ORIGINAL SERIES'')') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(rg) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(rg) C END OF CODE BLOCK end if Nz = nzs if (npsi .gt. 1) then if (nfinal .eq. 1) then do i = 1,Nz temp(i) = osa(i) end do do i = 1,lfor temp(Nz+i) = fsa(i) end do else do i = 1,Nz+lfor temp(i) = osa(i) end do end if k = Nz - lfor nrg = (Nz+lfor/2) - (Nz-lfor) + 1 do i = Nz-lfor,Nz+lfor/2 rg(i-k+1) = ((temp(i)-temp(i-1))/temp(i-1)) * 100.0d0 end do Nz = nrg if (nfinal .eq. 1) then write (Nio,'(//,6X,''FINAL SEASONALLY ADJUSTED SERIES'')') else write (Nio,'(//,6X,''SEASONALLY ADJUSTED SERIES'')') end if C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(rg) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(rg) C END OF CODE BLOCK Nz = nzs end if if (nchi .gt. 1) then if (nfinal .eq. 1) then do i = 1,Nz temp(i) = otr(i) end do do i = 1,lfor temp(Nz+i) = ftr(i) end do else do i = 1,Nz+lfor temp(i) = otr(i) end do end if k = Nz - lfor nrg = (Nz+lfor/2) - (Nz-lfor) + 1 do i = Nz-lfor,Nz+lfor/2 rg(i-k+1) = ((temp(i)-temp(i-1))/temp(i-1)) * 100.0d0 end do Nz = nrg if (nfinal .eq. 1) then write (Nio,'(//,6X,''FINAL TREND-CYCLE'')') else write (Nio,'(//,6X,''TREND-CYCLE'')') end if C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(rg,lndec) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(rg) C END OF CODE BLOCK Nz = nzs end if Nyer = nyer2 Nper = nper2 end C C C subroutine VARIANCES(oz,z,trend,sa,sc,cycle,ir,nz,lamda,out,qt1, $ varwnp,varwns,varwnc,theta,nth,psieps,psiess, $ psiecs,psiue,psieas,nfl) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer nfilt c parameter (kl = PFCST, kp = PFCST, mp = POBS, nfilt = 1200) parameter (nfilt = mp * 4) C C.. Formal Arguments .. integer nz,lamda,out,nth,nfl real*8 oz(mpkp),z(mpkp),trend(mpkp),sa(mpkp),sc(mpkp), $ cycle(mpkp),ir(mpkp),qt1,varwnp,varwns,varwnc, $ theta(*),psieps(*),psiess(*),psiecs(*),psiue(*),psieas(*) C C.. Local Scalars .. integer i,j,ndum,ndum1,nlenght real*8 aa,ac,ap,as,au,bias1,bias3,dmfcyc,dmfir,dmfsa,dmfsea, $ dmftre,ga,gc,gp,gs,gu,gx,vc,vcycle,vfcycle,vfir,vfsa, $ vfsc,vftrend,vir,vp,vs,vsa,vsc,vtrend,vu,vx,vxlin,vxorig C C.. Local Arrays .. real*8 dum(nfilt+kp*2),dum1(40),fcyc(mpkp),fir(mpkp), $ flcyc(mpkp),flir(mpkp),flsa(mpkp),flsea(mpkp), $ fltre(mpkp),fsa(mpkp),fsea(mpkp),ftre(mpkp),temp(mpkp) C C.. External Functions .. real*8 DMEAN real*8 DVAR LOGICAL dpeq external DMEAN, DVAR, dpeq C C.. External Calls .. external CONV, GETTHVARIANCE C C.. Intrinsic Functions .. intrinsic EXP, LOG, SQRT include 'cxfinal.i' include 'estb.i' include 'hspect.i' include 'models.i' include 'preadtr.i' include 'stream.i' include 'transcad.i' C C ... Executable Statements ... C C C if (Tramo .eq. 1) then if (lamda .eq. 1) then vtrend = DVAR(nz,trend) vsa = DVAR(nz,sa) vsc = DVAR(nz,sc) vir = DVAR(nz,ir) vcycle = DVAR(nz,cycle) do i = 1,nz ftre(i) = trend(i) + Paoutr(i) + Pareg(i,1) +Pareg(i,7) end do vftrend = DVAR(nz,ftre) do i = 1,nz fsa(i) = $ Tram(i) - (sc(i)+Paeast(i)+Patd(i)+Pareg(i,2)+Pareg(i,0)) end do vfsa = DVAR(nz,fsa) do i = 1,nz fsea(i) = sc(i) + Paeast(i) + Patd(i) + Pareg(i,2) end do vfsc = DVAR(nz,fsea) do i = 1,nz fir(i) = ir(i) + Paouir(i) + Pareg(i,3) end do vfir = DVAR(nz,fir) do i = 1,nz fcyc(i) = cycle(i) + Pareg(i,5) end do vfcycle = DVAR(nz,fcyc) else C C VEDERE COSA FARE CON IL BIAS CORRECTION C bias3 = 1.0d0 do i = 1,nz ftre(i) = EXP(trend(i)) * Paoutr(i) * Pareg(i,1) * $ Pareg(i,7) * bias3 end do vftrend = DVAR(nz,ftre) bias1 = 1.0d0 do i = 1,nz fsa(i) = $ Tram(i) / $ (EXP(sc(i))*Paeast(i)*Patd(i)*(Pareg(i,2)/bias1)*Pareg(i,0)) end do vfsa = DVAR(nz,fsa) bias1 = 1.0d0 do i = 1,nz fsea(i) = (EXP(sc(i))*Paeast(i)*Patd(i)*Pareg(i,2)) / bias1 end do vfsc = DVAR(nz,fsea) do i = 1,nz fir(i) = EXP(ir(i)) * Paouir(i) * Pareg(i,3) end do vfir = DVAR(nz,fir) do i = 1,nz fcyc(i) = EXP(cycle(i)) * Pareg(i,5) end do vfcycle = DVAR(nz,fcyc) do i = 1,nz temp(i) = EXP(trend(i)) end do vtrend = DVAR(nz,temp) do i = 1,nz temp(i) = EXP(sa(i)) end do vsa = DVAR(nz,temp) do i = 1,nz temp(i) = EXP(sc(i)) end do vsc = DVAR(nz,temp) do i = 1,nz temp(i) = EXP(ir(i)) end do vir = DVAR(nz,temp) do i = 1,nz temp(i) = EXP(cycle(i)) end do vcycle = DVAR(nz,temp) end if vxorig = DVAR(nz,Tram) vxlin = DVAR(nz,oz) C C COMPUTE CROSS-CORRELATION OF FINAL ADDITIVE COMPONENT C if (lamda .eq. 1) then dmfsa = DMEAN(nz,fsa) dmfsea = DMEAN(nz,fsea) dmftre = DMEAN(nz,ftre) dmfir = DMEAN(nz,fir) dmfcyc = DMEAN(nz,fcyc) Crssa = 0.0d0 Crtsa = 0.0d0 Crts = 0.0d0 Crirsa = 0.0d0 Crirs = 0.0d0 Crirt = 0.0d0 Crcycsa = 0.0d0 Crcycs = 0.0d0 Crcyct = 0.0d0 Crcycir = 0.0d0 do i = 1,nz Crssa = (fsa(i)-dmfsa)*(fsea(i)-dmfsea) + Crssa Crtsa = (ftre(i)-dmftre)*(fsa(i)-dmfsa) + Crtsa Crts = (ftre(i)-dmftre)*(fsea(i)-dmfsea) + Crts Crirsa = (fir(i)-dmfir)*(fsa(i)-dmfsa) + Crirsa Crirs = (fir(i)-dmfir)*(fsea(i)-dmfsea) + Crirs Crirt = (fir(i)-dmfir)*(ftre(i)-dmftre) + Crirt if (Ncyc .gt. 1) then Crcycsa = (fcyc(i)-dmfcyc)*(fsa(i)-dmfsa) + Crcycsa if (NPSI .gt. 1) then Crcycs = (fcyc(i)-dmfcyc)*(fsea(i)-dmfsea) + Crcycs else Crcycs = 0.0d0 end if if (NCHI .gt. 1) then Crcyct = (fcyc(i)-dmfcyc)*(ftre(i)-dmftre) + Crcyct else Crcyct = 0.0d0 end if Crcycir = (fcyc(i)-dmfcyc)*(fir(i)-dmfir) + Crcycir end if end do else do i = 1,nz flsa(i) = LOG(fsa(i)) flsea(i) = LOG(fsea(i)) fltre(i) = LOG(ftre(i)) flcyc(i) = LOG(fcyc(i)) flir(i) = LOG(fir(i)) end do dmfsa = DMEAN(nz,flsa) dmfsea = DMEAN(nz,flsea) dmftre = DMEAN(nz,fltre) dmfir = DMEAN(nz,flir) dmfcyc = DMEAN(nz,flcyc) Crssa = 0.0d0 Crtsa = 0.0d0 Crts = 0.0d0 Crirsa = 0.0d0 Crirs = 0.0d0 Crirt = 0.0d0 Crcycsa = 0.0d0 Crcycs = 0.0d0 Crcyct = 0.0d0 Crcycir = 0.0d0 do i = 1,nz Crssa = (flsa(i)-dmfsa)*(flsea(i)-dmfsea) + Crssa Crtsa = (fltre(i)-dmftre)*(flsa(i)-dmfsa) + Crtsa Crts = (fltre(i)-dmftre)*(flsea(i)-dmfsea) + Crts Crirsa = (flir(i)-dmfir)*(flsa(i)-dmfsa) + Crirsa Crirs = (flir(i)-dmfir)*(flsea(i)-dmfsea) + Crirs Crirt = (flir(i)-dmfir)*(fltre(i)-dmftre) + Crirt if (Ncyc .gt. 1) then Crcycsa = (flcyc(i)-dmfcyc)*(flsa(i)-dmfsa) + Crcycsa Crcycs = (flcyc(i)-dmfcyc)*(flsea(i)-dmfsea) + Crcycs Crcyct = (flcyc(i)-dmfcyc)*(fltre(i)-dmftre) + Crcyct Crcycir = (flcyc(i)-dmfcyc)*(flir(i)-dmfir) + Crcycir end if end do end if if ((NADJS .gt. 1) .and. (NPSI .gt. 1)) then Crssa = Crssa / (SQRT(vfsa)*SQRT(vfsc)) else Crssa = 0.0d0 end if if ((NADJS .gt. 1) .and. (NCHI .gt. 1)) then Crtsa = Crtsa / (SQRT(vftrend)*SQRT(vfsa)) else Crtsa = 0.0d0 end if if ((NPSI .gt. 1) .and. (NCHI .gt. 1)) then Crts = Crts / (SQRT(vftrend)*SQRT(vfsc)) else Crts = 0.0d0 end if if (NADJS .gt. 1) then Crirsa = Crirsa / (SQRT(vfir)*SQRT(vfsa)) else Crirsa = 0.0d0 end if if (NPSI .gt. 1) then Crirs = Crirs / (SQRT(vfir)*SQRT(vfsc)) else Crirs = 0.0d0 end if if (NCHI .gt. 1) then Crirt = Crirt / (SQRT(vfir)*SQRT(vftrend)) else Crirt = 0.0d0 end if if (Ncyc .gt. 1) then IF(NADJS .gt. 1 .and. (.not.dpeq(vfcycle,0D0)))THEN Crcycsa = Crcycsa / (SQRT(vfcycle)*SQRT(vfsa)) ELSE Crcycsa = 0.0d0 end if IF(NPSI .gt. 1 .and. (.not.dpeq(vfcycle,0D0)))THEN Crcycs = Crcycs / (SQRT(vfcycle)*SQRT(vfsc)) ELSE Crcycs = 0.0d0 end if IF(NCHI .gt. 1 .and. (.not.dpeq(vfcycle,0D0)))THEN Crcyct = Crcyct / (SQRT(vfcycle)*SQRT(vftrend)) ELSE Crcyct = 0.0d0 end if IF(.not.dpeq(vfcycle,0D0))THEN Crcycir = Crcycir / (SQRT(vfcycle)*SQRT(vfir)) ELSE Crcycir = 0.0d0 end if end if C C OUTPUT VARIANCES C c rober revisar esta parte c if (out .eq. 0) then write (Nio,'(//,2X,''DECOMPOSITION OF VARIANCE (IN %)'')') write (Nio,'(2X,''--------------------------------'')') write (Nio,'(/,6x,''A) SAMPLE VARIANCE FOR ORIGINAL SERIES'')') write (Nio,'(/,22X,''FINAL'',12X,''STOCHASTIC'',/)') write (Nio,'(4X,''SEASONAL'',6X,F12.4,6X,F12.4)') $ (vfsc/vxorig)*100.0d0, (vsc/vxlin)*100.0d0 write (Nio,'(4X,''COMPON.'',/)') write (Nio,'(4X,''TREND-CYCLE'',3X,F12.4,6X,F12.4,/)') $ (vftrend/vxorig)*100.0d0, (vtrend/vxlin)*100.0d0 write (Nio,'(4X,''IRREGULAR'',5X,F12.4,6X,F12.4)') $ (vfir/vxorig)*100.0d0, (vir/vxlin)*100.0d0 write (Nio,'(4X,''COMPON.'',/)') if (Ncyc .gt. 1) then write (Nio,'(4X,A,4X,F12.4,6X,F12.4)')transLcad(1:nTransLcad), $ (vfcycle/vxorig)*100.0d0, (vcycle/vxlin)*100.0d0 write (Nio,'(4X,''COMPON.'',/)') end if write (Nio,'(4X,''TOTAL'',9X,F12.4,6X,F12.4,/)') $ ((vfir+vfcycle+vftrend+vfsc)/vxorig)*100.0d0, $ ((vir+vcycle+vtrend+vsc)/vxlin)*100.0d0 write (Nio,'(4X,''SA SERIES'',5X,F12.4,6X,F12.4)') $ (vfsa/vxorig)*100.0d0, (vsa/vxlin)*100.0d0 end if end if C C THEORETICAL VARIANCE C C C SERIES C call CONV(Chis,Nchis,Psis,Npsis,dum,ndum) call CONV(dum,ndum,Cyc,Ncyc,dum1,ndum1) call GETTHVARIANCE(dum1,ndum1,theta,nth,1.0d0,vx) C C THEORETICAL VARIANCE C TREND C call CONV(Psins,Npsins,Thetp,Nthetp,dum,ndum) call GETTHVARIANCE(Chis,Nchis,dum,ndum,varwnp,vp) C C THEORETICAL VARIANCE C SEASONAL C call CONV(Chins,Nchins,Thets,Nthets,dum,ndum) call GETTHVARIANCE(Psis,Npsis,dum,ndum,varwns,vs) C C THEORETICAL VARIANCE C IRREGULAR C call CONV(Chins,Nchins,Psins,Npsins,dum,ndum) dum1(1) = 1.0d0 ndum1 = 1 call GETTHVARIANCE(dum1,ndum1,dum,ndum,qt1,vu) C C THEORETICAL VARIANCE C CYCLE C call CONV(Chins,Nchins,Psins,Npsins,dum,ndum) call CONV(dum,ndum,Thetc,Nthetc,dum1,ndum1) call GETTHVARIANCE(Cyc,Ncyc,dum1,ndum1,varwnc,vc) C C CHECK C C WRITE(*,*)'VX ',VX C WRITE(*,*)'VU ',VU C WRITE(*,*)'VS ',VS C WRITE(*,*)'VP ',VP C WRITE(*,*)VX-VC-VU-VS-VP,' SHOULD BE ZERO' C READ(*,*) C C MMSE THEORETICAL VARIANCE C TREND C call CONV(psieps,nfl,Psins,Npsins,dum,ndum) ap = 0.0d0 do i = 1,ndum ap = ap + dum(i)*dum(i) end do C AP=DSQRT(AP/(NDUM*1.0D0)) C C MMSE THEORETICAL VARIANCE C SEASONAL C call CONV(psiess,nfl,Chins,Nchins,dum,ndum) as = 0.0d0 do i = 1,ndum as = as + dum(i)*dum(i) end do C AS=DSQRT(AS/(NDUM*1.0D0)) C C MMSE THEORETICAL VARIANCE C IRREGULAR C call CONV(Chins,Nchins,Psins,Npsins,dum1,ndum1) call CONV(psiue,nfl,dum1,ndum1,dum,ndum) au = 0.0d0 do i = 1,ndum au = au + dum(i)*dum(i) end do C AR=DSQRT(AR/(NDUM*1.0D0)) C C MMSE THEORETICAL VARIANCE C CYCLE C call CONV(psiecs,nfl,dum1,ndum1,dum,ndum) ac = 0.0d0 do i = 1,ndum ac = ac + dum(i)*dum(i) end do C C MMSE THEORETICAL VARIANCE C SA C call CONV(psieas,nfl,adjns,nadjns,dum,ndum) aa = 0.0d0 do i = 1,ndum aa = aa + dum(i)*dum(i) end do C C DECOMPOSITION OF THE VARIANCE OF THE STATIONARY SERIES IN TERMS C OF THE ESTIMATES OBTAINED BY SEATS. C C DUM1 IS CHINS*PSINS C C TREND C nlenght = nz - ndum1 + 1 do i = 1,nlenght dum(i) = 0.0d0 do j = 1,ndum1 dum(i) = dum(i) + dum1(j)*trend(i+ndum1-j) end do end do gp = DVAR(nlenght,dum) C C SEASONAL C do i = 1,nlenght dum(i) = 0.0d0 do j = 1,ndum1 dum(i) = dum(i) + dum1(j)*sc(i+ndum1-j) end do end do gs = DVAR(nlenght,dum) C C IRREGULAR C do i = 1,nlenght dum(i) = 0.0d0 do j = 1,ndum1 dum(i) = dum(i) + dum1(j)*ir(i+ndum1-j) end do end do gu = DVAR(nlenght,dum) C C CYCLE C do i = 1,nlenght dum(i) = 0.0d0 do j = 1,ndum1 dum(i) = dum(i) + dum1(j)*cycle(i+ndum1-j) end do end do gc = DVAR(nlenght,dum) C C ADJUSTED C do i = 1,nlenght dum(i) = 0.0d0 do j = 1,ndum1 dum(i) = dum(i) + dum1(j)*sa(i+ndum1-j) end do end do ga = DVAR(nlenght,dum) C C SERIES C do i = 1,nlenght dum(i) = 0.0d0 do j = 1,ndum1 dum(i) = dum(i) + dum1(j)*z(i+ndum1-j) end do end do gx = DVAR(nlenght,dum) C C CHECK C C WRITE(*,*) ((VP+VS+VU+VC)/VX)*100.0D0,' SHOULD BE 100' C if (out .eq. 0) then if (Tramo .ne. 1) then write (Nio,'(//,2X,''DECOMPOSITION OF VARIANCE (IN %)'')') write (Nio,'(2X,''--------------------------------'')') end if write (Nio,'(/,6X,''B) VARIANCE OF THE STATIONARY SERIES'')') write (Nio,'(/,22x,''THEORETICAL'',12x,''MMSE'',12x, $ ''ESTIMATED'')') write (Nio,'(22x,''COMPONENT'',11x,''ESTIMATOR'',10x, $ ''COMPONENT''/)') write (Nio,'(4X,''SEASONAL'',6X,F12.4,8X,F12.4,7X,F12.4)') $ (vs/vx)*100.0d0, (as/vx)*100.0d0, (gs/gx)*100.0d0 write (Nio,'(4X,''COMPON.'',/)') write (Nio,'(4X,''TREND-CYCLE'',3X,F12.4,8X,F12.4,7X,F12.4,/)') $ (vp/vx)*100.0d0, (ap/vx)*100.0d0, (gp/gx)*100.0d0 write (Nio,'(4X,''IRREGULAR'',5X,F12.4,8X,F12.4,7X,F12.4)') $ (vu/vx)*100.0d0, (au/vx)*100.0d0, (gu/gx)*100.0d0 write (Nio,'(4X,''COMPON.'',/)') if (Ncyc .gt. 1) then write (Nio,'(4X,A,4X,F12.4,8X,F12.4,7X,F12.4)') $ transLcad(1:nTransLcad), $ (vc/vx)*100.0d0, (ac/vc)*100.0d0, (gc/gx)*100.0d0 write (Nio,'(4X,''COMPON.'',/)') end if write (Nio,'(4X,''TOTAL'',9X,F12.4,8X,F12.4,7X,F12.4/)') $ ((vp+vs+vc+vu)/vx)*100.0d0, ((as+ap+au+ac)/vx)*100.0d0, $ ((gs+gp+gu+gc)/gx)*100.0d0 write (Nio,'(4X,''SA SERIES'',5X,F12.4,8X,F12.4,7X,F12.4,//)') $ ((vp+vu+vc)/vx)*100.0d0, ((ac+ap+au)/vx)*100.0d0, $ (ga/gx)*100.0d0 end if end C C subroutine GETTHVARIANCE(phi,nphi,theta,ntheta,varinn,var) C C.. Implicits .. implicit none include 'units.cmn' C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 phi(*) C.. In/Out Status: Read, Not Written .. integer nphi C.. In/Out Status: Maybe Read, Not Written .. real*8 theta(*) C.. In/Out Status: Read, Not Written .. integer ntheta C.. In/Out Status: Maybe Read, Not Written .. real*8 varinn C.. In/Out Status: Not Read, Overwritten .. real*8 var C C.. Local Scalars .. integer i,nbjphi,nbjtheta,ndum,ndum3 c integer ndum1 C C.. Local Arrays .. real*8 bjphi(32),bjtheta(32),dum(0:50),dum1(0:50),dum3(0:50) C C.. External Calls .. external BFAC C C ... Executable Statements ... C do i = 1,nphi-1 bjphi(i) = -phi(i+1) end do nbjphi = nphi - 1 do i = 1,ntheta-1 bjtheta(i) = -theta(i+1) end do nbjtheta = ntheta - 1 * ndum1 = 24 ndum = 24 ndum3 = 24 * WRITE(Ng,*)' subroutine GETTHVARIANCE, call 1' call BFAC(bjphi,bjtheta,nbjphi,nbjtheta,ndum,dum,dum1,var,varinn, $ dum3,ndum3) end C C FUNCTION TO COMPUTE THE MEAN OF X SERIES C double precision function DMU(x,nstart,nend) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 x(*) C.. In/Out Status: Read, Not Written .. integer nstart C.. In/Out Status: Read, Not Written .. integer nend C C.. Local Scalars .. integer i C C.. Intrinsic Functions .. intrinsic DBLE C C ... Executable Statements ... C DMU = 0.0d0 do i = nstart,nend DMU = DMU + x(i) end do DMU = DMU / DBLE(nend-nstart+1) end CC C CC subroutine SEBARTLETTACF (nz,nztr,nzs,nzsa,acflen,nzlen,bsetr, & bses,bsesa,bsecyc,bseir,qt1) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer mc,kp parameter (mc = 1000,kp = PFCST) C C.. Formal Arguments .. integer nzlen,acflen,nz,nztr,nzs,nzsa real*8 bsetr(0:kp),bses(0:kp),bsesa(0:kp),bsecyc(0:kp), & bseir(0:kp),qt1 C C.. Local Scalars .. integer j,i c integer iminusj,iplusj real*8 sum real*8 star C C.. Local Arrays .. real*8 dum(-mc : mc) C C.. include 'acfst.i' include 'models.i' cc c Compute Bartelett SE for Trend ACF cc star = -9999 sum = 0.0d0 if (qt1.ne.0.0d0) then do j = 0, nzlen bsetr(j) = 0.0d0 end do if (Nthetp .gt. 1) then do j = 1,acflen sum = sum + Acfper(j)*Acfper(j) end do sum = (sum * 2.0d0 + 1.0d0) * Acfper(0) * Acfper(0) * 2.0d0 sum = sum / dble(nztr) if (sum .lt. 0.0d0) then bsetr(0) = star else bsetr(0) = sqrt(sum) end if do j = 1, acflen dum(-j) = Acfper(j) dum(j) = Acfper(j) end do dum(0) = 1.0d0 do j = 1, nzlen sum = 0.0d0 do i = -acflen+j, acflen-j sum = dum(i)*dum(i) + dum(i+j)*dum(i-j) + 2.0d0*dum(j)*dum(j)* & dum(i)*dum(i) - 4.0d0*dum(j)*dum(i)*dum(i-j) + sum end do sum = sum / dble(nztr) if (sum .lt. 0.0d0) then bsetr(j) = star else bsetr(j) = sqrt(sum) end if end do end if cc c Compute Bartelett SE for Seasonal ACF cc do j = 0, nzlen bses(j) = 0.0d0 end do sum = 0.0d0 do j = 1,acflen sum = sum + Acfser(j)*Acfser(j) end do sum = (sum * 2.0d0 + 1.0d0) * Acfser(0) * Acfser(0) * 2.0d0 sum = sum / dble(nzs) if (sum .lt. 0.0d0) then bses(0) = star else bses(0) = sqrt(sum) end if do j = 1, acflen dum(-j) = Acfser(j) dum(j) = Acfser(j) end do dum(0) = 1.0d0 do j = 1, nzlen sum = 0.0d0 do i = -acflen+j, acflen-j sum = dum(i)*dum(i) + dum(i+j)*dum(i-j) + 2.0d0*dum(j)*dum(j)* & dum(i)*dum(i) - 4.0d0*dum(j)*dum(i)*dum(i-j) + sum end do sum = sum / dble(nzs) if (sum .lt. 0.0d0) then bses(j) = star else bses(j) = sqrt(sum) end if end do cc c Compute Bartelett SE for SA ACF cc do j = 0, nzlen bsesa(j) = 0.0d0 end do if (Nthets .gt. 1) then sum = 0.0d0 do j = 1,acflen sum = sum + Acfaer(j)*Acfaer(j) end do sum = (sum * 2.0d0 + 1.0d0) * Acfaer(0) * Acfaer(0) * 2.0d0 sum = sum / dble(nzsa) if (sum .lt. 0.0d0) then bsesa(0) = star else bsesa(0) = sqrt(sum) end if do j = 1, acflen dum(-j) = Acfaer(j) dum(j) = Acfaer(j) end do dum(0) = 1.0d0 do j = 1, nzlen sum = 0.0d0 do i = -acflen+j, acflen-j sum = dum(i)*dum(i) + dum(i+j)*dum(i-j) + 2.0d0*dum(j)*dum(j)* & dum(i)*dum(i) - 4.0d0*dum(j)*dum(i)*dum(i-j) + sum end do sum = sum / dble(nzsa) if (sum .lt. 0.0d0) then bsesa(j) = star else bsesa(j) = sqrt(sum) end if end do end if cc c Compute Bartelett SE for IRREGULAR ACF cc do j = 0, nzlen bseir(j) = 0.0d0 end do sum = 0.0d0 do j = 1,acflen sum = sum + Acfier(j)*Acfier(j) end do sum = (sum * 2.0d0 + 1.0d0) * Acfier(0) * Acfier(0) * 2.0d0 sum = sum / dble(nz) if (sum .lt. 0.0d0) then bseir(0) = star else bseir(0) = sqrt(sum) end if do j = 1, acflen dum(-j) = Acfier(j) dum(j) = Acfier(j) end do dum(0) = 1.0d0 do j = 1, nzlen sum = 0.0d0 do i = -acflen+j, acflen-j sum = dum(i)*dum(i) + dum(i+j)*dum(i-j) + 2.0d0*dum(j)*dum(j)* & dum(i)*dum(i) - 4.0d0*dum(j)*dum(i)*dum(i-j) + sum end do sum = sum / dble(nz) if (sum .lt. 0.0d0) then bseir(j) = star else bseir(j) = sqrt(sum) end if end do endif cc c Compute Bartelett SE for TRANSITORY ACF cc do j = 0, nzlen bsecyc(j) = 0.0d0 end do if (Nthetc .gt. 1) then sum = 0.0d0 do j = 1,acflen sum = sum + Acfcer(j)*Acfcer(j) end do sum = (sum * 2.0d0 + 1.0d0) * Acfcer(0) * Acfcer(0) * 2.0d0 sum = sum / dble(nz) if (sum .lt. 0.0d0) then bsecyc(0) = star else bsecyc(0) = sqrt(sum) end if do j = 1, acflen dum(-j) = Acfcer(j) dum(j) = Acfcer(j) end do dum(0) = 1.0d0 do j = 1, nzlen sum = 0.0d0 do i = -acflen+j, acflen-j sum = dum(i)*dum(i) + dum(i+j)*dum(i-j) + 2.0d0*dum(j)*dum(j)* & dum(i)*dum(i) - 4.0d0*dum(j)*dum(i)*dum(i-j) + sum end do sum = sum / dble(nz) if (sum .le. 0d0) then sum=1.0d-8 end if bsecyc(j) = sqrt(sum) end do end if return end C CC C CC subroutine SEBARTLETTCC (nzlen,acflen,crpsem,crpcem,crpiem, & crscem,crsiem,crciem,bseps,bsepc, & bsepi,bsesc,bsesi,bseci,qt1,numSer) C C.. Implicits .. implicit none C C.. Parameters .. integer mc parameter (mc = 1000) C C.. Formal Arguments .. integer nzlen,acflen,numSer real*8 crpsem (-mc:mc),crpcem(-mc:mc),crpiem(-mc:mc), & crscem(-mc:mc),crsiem(-mc:mc),crciem(-mc:mc) real*8 bseps,bsepc,bsepi,bsesc,bsesi,bseci,qt1 C C.. Local Scalars .. integer j,i c integer iminusj,iplusj real*8 sum real*8 star C C.. Local Arrays .. real*8 dum(-mc : mc) real*8 dum1(-mc : mc) C C.. include 'acfst.i' include 'models.i' cc c Compute Bartelett SE for Trend ACF cc star = -9999 bseps = 0.0d0 bsepc = 0.0d0 bsepi = 0.0d0 bsesc = 0.0d0 bsesi = 0.0d0 bseci = 0.0d0 if (Nthetp .gt. 1) then cc c Compute SE Trend-Seasonal cc if (Nthetc .gt. 1) then do j = 1, acflen dum(-j) = Acfper(j) dum(j) = Acfper(j) dum1(-j) = Acfser(j) dum1(j) = Acfser(j) end do dum(0) = 1.0d0 dum1(0) = 1.0d0 sum = 0.0d0 do i = -acflen, acflen sum = sum + dum(i)*dum1(i) + crpsem(i)*crpsem(-i) + & crpsem(0)*crpsem(0) * (crpsem(i)*crpsem(i) + & (dum1(i)*dum1(i)) / 2.0d0 + (dum(i)*dum(i)) /2.0d0 ) - & 2.0d0*crpsem(0)* (dum(i)*crpsem(i)+dum1(i)*crpsem(-i)) end do if (sum .lt. 0.0d0) then bseps = star else bseps = sqrt(sum/dble(nzlen)) end if end if cc c Compute SE Trend-Transitory cc if (Nthetc .gt. 1) then do j = 1, acflen dum(-j) = Acfper(j) dum(j) = Acfper(j) dum1(-j) = Acfcer(j) dum1(j) = Acfcer(j) end do dum(0) = 1.0d0 dum1(0) = 1.0d0 sum = 0.0d0 do i = -acflen, acflen sum = sum + dum(i)*dum1(i) + crpcem(i)*crpcem(-i) + & crpcem(0)*crpcem(0) * (crpcem(i)*crpcem(i) + & (dum1(i)*dum1(i)) / 2.0d0 + (dum(i)*dum(i)) /2.0d0) - & 2.0d0*crpcem(0)* (dum(i)*crpcem(i)+dum1(i)*crpcem(-i)) end do if (sum .lt. 0.0d0) then bsepc = star else bsepc = sqrt(sum/dble(nzlen)) end if end if cc c Compute SE Trend-Irregular cc if (qt1.ne.0.0d0) then do j = 1, acflen dum(-j) = Acfper(j) dum(j) = Acfper(j) dum1(-j) = Acfier(j) dum1(j) = Acfier(j) end do dum(0) = 1.0d0 dum1(0) = 1.0d0 sum = 0.0d0 do i = -acflen, acflen sum = sum + dum(i)*dum1(i) + crpiem(i)*crpiem(-i) + & crpiem(0)*crpiem(0) * (crpiem(i)*crpiem(i) + & 0.5d0*dum1(i)*dum1(i) + 0.5d0*dum(i)*dum(i))- & 2.0d0*crpiem(0)* (dum(i)*crpiem(i)+dum1(i)*crpiem(-i)) end do if (sum .lt. 0.0d0) then bsepi = star else bsepi = sqrt(sum/dble(nzlen)) end if end if end if cc c cc if (Nthets .gt. 1.and.numser.le.5) then cc c Compute SE Seasonal-Transitory cc if (Nthetc .gt. 1) then do j = 1, acflen dum(-j) = Acfser(j) dum(j) = Acfser(j) dum1(-j) = Acfcer(j) dum1(j) = Acfcer(j) end do dum(0) = 1.0d0 dum1(0) = 1.0d0 sum = 0.0d0 do i = -acflen, acflen sum = sum + dum(i)*dum1(i) + crscem(i)*crscem(-i) + & crscem(0)*crscem(0) * (crscem(i)*crscem(i) + & 0.5d0*dum1(i)*dum1(i) + 0.5d0*dum(i)*dum(i)) - & 2.0d0*crscem(0)* (dum(i)*crscem(i)+dum1(i)*crscem(-i)) end do if (sum .lt. 0.0d0) then bsesc = star else bsesc = sqrt(sum/dble(nzlen)) end if end if cc c Compute SE Seasonal-Irregular cc if (qt1.ne.0.0d0) then do j = 1, acflen dum(-j) = Acfser(j) dum(j) = Acfser(j) dum1(-j) = Acfier(j) dum1(j) = Acfier(j) end do dum(0) = 1.0d0 dum1(0) = 1.0d0 sum = 0.0d0 do i = -acflen, acflen sum = sum + dum(i)*dum1(i) + crsiem(i)*crsiem(-i) + & crsiem(0)*crsiem(0) * (crsiem(i)*crsiem(i) + & (dum1(i)*dum1(i)) / 2.0d0 + (dum(i)*dum(i)) /2.0d0) - & 2.0d0*crsiem(0)* (dum(i)*crsiem(i)+dum1(i)*crsiem(-i)) end do if (sum .lt. 0.0d0) then bsesi = star else bsesi = sqrt(sum/dble(nzlen)) end if end if end if cc c cc if ((Nthetc .gt. 1).and.(numSer.le.5).and.(qt1.ne.0.0d0)) then cc c Compute SE Transitory-Irregular cc do j = 1, acflen dum(-j) = Acfcer(j) dum(j) = Acfcer(j) dum1(-j) = Acfier(j) dum1(j) = Acfier(j) end do dum(0) = 1.0d0 dum1(0) = 1.0d0 sum = 0.0d0 do i = -acflen, acflen sum = sum + dum(i)*dum1(i) + crciem(i)*crciem(-i) + & crciem(0)*crciem(0) * (crciem(i)*crciem(i) + & (dum1(i)*dum1(i)) / 2.0d0 + (dum(i)*dum(i)) /2.0d0) - & 2.0d0*crciem(0)* (dum(i)*crciem(i)+dum1(i)*crciem(-i)) end do if (sum .lt. 0.0d0) then bseci = star else bseci = sqrt(sum/dble(nzlen)) end if end if return end C C.. Extensively modified by REG on 31 Aug 2005 in order to reduce C the amount of repeated code. A new subroutine getUnderOverClass C was added to handle the repeated code. Comments were also added. subroutine UnderOverTest(Mq,bseps,bsepc,bsepi,bsesc,bsesi,bseci, $ qt1,numSer) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer kp, mc parameter (kp = PFCST, mc = 1000) C C.. Formal Arguments .. integer Mq,numSer real*8 bseps,bsepc,bsepi,bsesc,bsesi,bseci,qt1 C.. Local Scalars .. character uotest*6, uotest1*6, uotest2*6 integer nstar,ncomp C C.. Common include include 'stream.i' include 'models.i' include 'acfst.i' include 'bartlett.i' include 'cross.i' include 'transcad.i' cc cc Output over/under title cc write (Nio,'(////, $ 2x,''SECOND ORDER MOMENTS OF THE (STATIONARY)'', $ '' COMPONENTS '', $ ''OVER / UNDER ESTIMATION TESTS'',/,2x, $ 81(''-''))') write (Nio, '(//,4x,''1. VARIANCE'',/,4x,11(''-''),/)') cc cc Output subtest title for Variance test cc cc c Trend Variance Over/Under estimation cc nstar = 0 call getUnderOverClass( nstar, Acfpem(0), Acfper(0), bsetr(0), $ uotest ) if (nthetp .gt. 1) then write (Nio, '(6x, ''TREND-CYCLE'',4x,a)') uotest end if cc c Seasonal Variance Over/Under estimation cc call getUnderOverClass( nstar, Acfsem(0), Acfser(0), bses(0), $ uotest ) if (nthets .gt. 1) then write (Nio, '(6x, ''SEASONAL'',7x,a)') uotest end if cc c Transitory Variance Over/Under estimation cc call getUnderOverClass( nstar, Acfcem(0), Acfcer(0), bsecyc(0), $ uotest ) if (nthetc .gt. 1) then if (nTransLcad.gt.11) then write (Nio, '(6x, A,2x,a)') transLcad(1:nTransLcad),uotest else write (Nio, '(6x, A,5x,a)') transLcad(1:nTransLcad),uotest end if end if cc c Irregular Variance Over/Under estimation cc if (qt1.ne.0.0d0) then call getUnderOverClass( nstar, Acfiem(0), Acfier(0), bseir(0), $ uotest ) write (Nio, '(6x, ''IRREGULAR'',6x,a)') uotest end if cc cc Output table of class definitions cc write (Nio, '(//,4x,'' ++ : Overestimation of component.'', $ '' Strong evidence (t>3).'')') write (Nio, '(4x,'' + : Overestimation of component.'', $ '' Mild evidence (23).'')') write (Nio, '(4x,'' + : Too much positive correlation.'', $ '' Mild evidence (23).'')') write (Nio, '(4x,'' + : Too much positive crosscorrelation.'', $ '' Mild evidence (2no trend) *c ncycth: length-1 of Transitory MA (>0 => transitory) *c ncyc: length of Transitory AR polynomial (>1=>Transitory) *c nchcyc: length of Transitory+trend AR polynomial *c npsi: length of Seasonal AR polynomial (>1 => Seasonal) *c hpcycle: if the user wanted HP cycle (>0=>BC and long Term Trend) *c OUTPUT: FILES graph\spectra\*.T3 * subroutine plotSpectra(MQ,HS,nchi,ncycth,ncyc,nchcyc,npsi,hpcycle, * $ varwnc) * implicit none * include 'spectra.i' * integer MQ,nchi,ncycth,ncyc,nchcyc,npsi,hpcycle * real*8 hs,varwnc *c LOCAL VARIABLES * include 'transcad.i' * character fname*30,subtitle*50,longTermCad*22 * integer i * character SCM * real*8 Ymaxgraph *C * character gettmcs * integer ISTRLEN * EXTERNAL gettmcs,ISTRLEN *c * Ymaxgraph=1.5d0 * If (HPcycle.eq.1) then * LongTermCad='LONG TERM TREND' * else if (HPcycle.eq.2) then * LongTermCad='SA series without BC' * else * LongTermCad='Series without BC' * end if * i=Lspect *c Ahora lo calculamos al comienzo porque aqui sale el modelo que ha cambiado seats *c si lo cambia antes de entrar a la descomposicion *c fname='SPECT.T3' *c subtitle='SPECTRUM MODEL SERIES' *c call PlotSpectrum(fname,subtitle,spect,dble(Lspect),mq,hs,1) * SCM=gettmcs() ** if (SCM.eq.'Y') then ** ** fname='SPECTSE.T3' ** subtitle='SPECTRUM MODEL SERIES SEATS' ** call PlotSpectrum(fname,subtitle,spectse,dble(Lspect),mq,hs,1) ** end if ** fname='SPECTEI.T3' ** subtitle='SPECTRUM MODEL: IRREGULAR ESTIMATOR' ** call PlotSpectrum(fname,subtitle,spectei,dble(Lspect),mq,-10d0,1) ** if (nchi.ne.1) then ** fname='SPECTT.T3' ** subtitle='SPECTRUM MODEL TREND CYCLE' ** call PlotSpectrum(fname,subtitle,spectt, ** $ dble(Lspect),mq,Ymaxgraph,0) ** fname='SPECTET.T3' ** subtitle='SPECTRUM MODEL: TREND-CYCLE ESTIMATOR' ** call PlotSpectrum(fname,subtitle,spectet,dble(Lspect),mq, ** $ Ymaxgraph,0) ** end if ** if (varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. ncyc.ne.1)) then ** fname='SPECTY.T3' ** write(subtitle,1001)transLcad(1:nTransLcad) ** 1001 FORMAT('SPECTRUM MODEL ',A) ** call PlotSpectrum(fname,subtitle,specty,dble(Lspect),mq,-10D0,1) ** fname='SPECTEY.T3' ** write(subtitle,1001)transLcad(1:nTransLcad)//' ESTIMATOR' ** call PlotSpectrum(fname,subtitle,spectey,dble(Lspect), ** $ mq,-10D0,1) ** end if ** if (mq.ne.1 .and. npsi.ne.1) then ** fname='SPECTS.T3' ** subtitle='SPECTRUM MODEL SEASONAL' ** call PlotSpectrum(fname,subtitle,spects,dble(Lspect),mq, ** $ Ymaxgraph,1) ** fname='SPECTES.T3' ** subtitle='SPECTRUM MODEL: SEASONAL ESTIMATOR' ** call PlotSpectrum(fname,subtitle,spectes,dble(Lspect),mq, ** $ Ymaxgraph,1) ** end if ** if ((varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. nchcyc.ne.1)) ** $ .and. npsi.ne.1) then ** fname='SPECTSA.T3' ** subtitle='SPECTRUM MODEL SA SERIES' ** call PlotSpectrum(fname,subtitle,spectsa,dble(Lspect),mq, ** $ Ymaxgraph,1) ** fname='SPECTESA.T3' ** subtitle='SPECTRUM MODEL: SA SERIES ESTIMATOR' ** call PlotSpectrum(fname,subtitle,spectesa,dble(Lspect),mq, ** $ Ymaxgraph,1) ** end if ** if (hpcycle.gt.0) then ** fname='SPECTBC.T3' ** subtitle='SPECTRUM MODEL BUSINESS CYCLE' ** call PLOTSPECTRUM(fname,subtitle,spectbc,dble(Lspect),mq,hs,0) ** fname='SPECTM.T3' ** subtitle='SPECTRUM MODEL '//LongTermCad(1:istrlen(LongTermCad)) ** call PLOTSPECTRUM(fname,subtitle,spectm,dble(Lspect),mq,hs,0) ** fname='SPECTEBC.T3' ** subtitle='SPECTRUM MODEL: BUSINESS CYCLE ESTIMATOR' ** call PLOTSPECTRUM(fname,subtitle,spectebc,dble(Lspect),mq,hs,0) ** fname='SPECTEM.T3' ** subtitle='SPECTRUM MODEL: '// ** $ LongTermCad(1:istrlen(LongTermCad))//' ESTIMATOR' ** call PLOTSPECTRUM(fname,subtitle,spectem,dble(Lspect),mq,hs,0) ** end if * end c SPC: computes the spectrum of a component c INPUT PARAMETERS c A: cosine transform of MA of the model c na: dimension of A c E: cosine transform of AR of the model c ne: dimmension of E c Var: variance of innovations of the model c OUTPUT PARAMETERS c spect(1:Lspect): theoretical spectrum of the model for w=(1:Lspect)*pi/Lspect subroutine SPC(a,na,e,ne,Var,spect) implicit none include 'spectrum.i' include 'func5f1.i' include 'testf1.i' real*8 pi parameter (pi=3.14159265358979D0) c INPUT PARAMETERS integer na,ne real*8 A(na),E(ne),Var c OUTPUT PARAMETERS real*8 spect(Lspect) c EXTERNAL external FUNC1 real*8 FUNC1 c LOCAL VARIABLES integer i real*8 x c Ifunc1=5 do i=1,na Dumf1(i)=a(i) endDo Ndumf1=na do i=1,ne Dum1f1(i)=e(i) enddo nD1f1=ne do i=1,Lspect x=(1.0d0/Lspect)*pi*i spect(i)=FUNC1(x) if (spect(i) .lt. -1.0D-2) then spect(i)=1000.0d0 end if spect(i)=Var*spect(i)/(2*pi) enddo end C C SPCEST COMPUTES THE SPECTRUM OF THE ESTIMATOR OF THE COMPONENT C C INPUT PARAMETERS C A : MA in cosine transform OF THE COMPONENT C NA : DIMENSION OF A C B : AR in cosine transform OF OTHER COMPONENT 1 C NB : DIMENSION OF B C C : AR in cosine transform OF OTHER COMPONENT 2 C NCC : DIMENSION OF C C D : AR is cosine transform OF THE COMPONENT C ND : DIMENSION OF D C E : MA in cosine transform OF THE FULL MODEL C NE : DIMENSION OF E c OUTPUT PARAMETERS c spect(1:Lspect): theoretical spectrum of the estimator for w=(1:lspect)*pi/Lspect C C subroutine SPCEST(a,na,b,nb,c,ncc,d,nd,e,ne,spect) C C.. Implicits .. implicit none include 'spectrum.i' C C.. INPUT Arguments .. integer na,nb,ncc,nd,ne real*8 a(na),b(nb),c(ncc),d(nd),e(ne) c c OUTPUT ARGUMENTS real*8 spect(Lspect) C C.. Local Scalars .. integer i,ndum2,ndum5 real*8 arg,pi,x C C.. Local Arrays .. real*8 dum2(170),dum5(180) C C.. External Functions .. real*8 FUNC1 external FUNC1 C C.. External Calls .. external MULTFN include 'func5f1.i' include 'hspect.i' include 'spe.i' include 'testf1.i' C C ... Executable Statements ... C pi = 3.14159265358979D0 call MULTFN(a,na,a,na,dum2,ndum2) call MULTFN(d,nd,e,ne,Dum1f1,ND1f1) call MULTFN(dum2,ndum2,b,nb,dum5,ndum5) if (ncc .eq. 1) then do i = 1,ndum5 Dumf1(i) = dum5(i) end do Ndumf1 = ndum5 else call MULTFN(dum5,ndum5,c,ncc,Dumf1,Ndumf1) end if Ifunc1 = 5 do i = 1,Lspect x = (1.0d0/Lspect) * pi * i arg = FUNC1(x) if (arg .lt. -1.0d-2) then arg = 10.0d10 end if spect(i) = arg spect(i) = spect(i) / (2*pi) end do end c c c PHIbc(B)Bc=THETbc(B)Abt Abt~niid(0,Vbc) Bc:Business Cycle Component c PHIm(B)Mt=THETm(B)Amt Amt~niid(0,Vm) Mt:Long Term Trend Component c THstar(1:qstar) :MA of the serie c PHInc(1:nPHInc)*PHIc(B): AR serie, where PHIc:is PHIp(if hpcycle=1) c is PHIsa(if hpcycle=2) c PHInc=1 (if HPcycle=3) c (Vm/Vc)*1/HPTH(B)HPTH(F):Is the filter over C(P,SA or Xt) to obtain M(long term trend) c MQ: the frequency of the observations. subroutine getBcSpectra(PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ PHIm,nPHIm,THETm,nTHETm,Vm, $ THstar,qstar,PHI,p,d,bphi,bp,bd,MQ) implicit none include 'func5f1.i' include 'component.i' include 'spectra.i' include 'srslen.prm' include 'dimensions.i' real*8 TWO parameter (TWO=2.0d0) c INPUT PARAMETERS real*8 PHIbc(MaxCompDim),THETbc(MaxCompDim),Vbc, $ PHIm(MaxCompDim),THETm(MaxCompDim),Vm, $ THstar(maxTh),PHI(*),bphi(*) integer nPHIbc,nTHETbc,nPHIm,nTHETm,qstar,p,d,bp,bd,MQ c EXTERNAL CALLS external getAR,getSpectrum c CONSTANT PARAMETERS real*8 pi parameter(pi=3.14159265358979D0) c LOCAL PARAMETERS real*8 AR(MaxCompDim),spectX(300) integer nAR,i c call getSpectrum(THETbc,nTHETbc,PHIbc,nPHIbc,SpectBC) call getSpectrum(THETm,nTHETm,PHIm,nPHIm,SpectM) call getAR(phi,p,d,bphi,bp,bd,MQ,AR,nAR) call getSpectrum(THstar,qstar,AR,nAR,SpectX) do i=1,300 spectBC(i)=spectBC(i)*Vbc spectM(i)=spectM(i)*Vm specteBC(i)=spectBC(i)*spectBC(i)/(TWO*pi*spectX(i)) specteM(i)=spectM(i)*spectM(i)/(TWO*pi*spectX(i)) spectBC(i)=spectBC(i)/(TWO*pi) spectM(i)=spectM(i)/(TWO*pi) end do end c c c GetSpectrum given a model Numerator(B)Mt=Denominator(B), c return its spectrum in Spect(1:300) for frequencies pi*(1:300)/300 c subroutine getSpectrum(Numerator,nNum,Denominator,nDen,spect) implicit none include 'component.i' include 'func5f1.i' include 'testf1.i' include 'spectrum.i' c INPUT PARAMETERS real*8 Numerator(*),Denominator(*),spect(*) integer nNum,nDen c CONSTANT PARAMETERS real*8 pi parameter(pi=3.14159265358979D0) c LOCAL PARAMETERS integer i real*8 x,arg c EXTERNAL external CONJ,FUNC1 real*8 FUNC1 c call CONJ(Denominator,nDen,Denominator,nDen,Dum1f1,nD1f1) call CONJ(Numerator,nNum,Numerator,nNum,Dumf1,Ndumf1) Ifunc1=5 DO i=1,Lspect x=(1.0D0/Lspect)*pi*i arg=Func1(x) if (arg .lt. -1.0d-2) then arg = 10.0d10 end if spect(i)=abs(arg) END DO end C getAR: return in AR(B)=phi(B)*bphi(B^mq)*[(1-B)^d]*[(1-B^mq)^bd] subroutine getAR(phi,p,d,bphi,bp,bd,mq,AR,nAR) implicit none include 'component.i' c INPUT PARAMETERS real*8 phi(*),bphi(*) integer p,d,bp,bd,mq c OUTPUT PARAMETERS real*8 AR(*) integer nAR c LOCAL PARAMETERS real*8 Delta(2),Deltas(13),tmp(60),tmp2(60),bphiE(60) integer i,j,ntmp,ntmp2 c External CONV c Delta(1)=1.0D0 Delta(2)=-1.0D0 tmp(1)=1.0D0 ntmp=1 ntmp2=1 tmp2(1)=1.0D0 Do i=1,p+1 tmp(i)=phi(i) end do ntmp=p+1 Do j=1,d Call Conv(Delta,2,tmp,ntmp,tmp2,ntmp2); Do i=1,ntmp2 tmp(i)=tmp2(i) end do ntmp=ntmp2 end do if (bp.gt.0) then do i=1,mq*bp+1 bphiE(i)=0.0D0 end do do i=1,bp bphiE(i*mq+1)=bphi(i+1) end do call conv(tmp,ntmp,bphi,bp*mq+1,tmp2,ntmp2) do i=1,ntmp2 tmp(i)=tmp2(i) end do ntmp=ntmp2 end if if (bd.gt.0) then Deltas(1)=1.0d0 do i=2,mq Deltas(i)=0.0d0 end do Deltas(mq+1)=-1.0d0 Do j=1,bd call CONV(tmp,ntmp,Deltas,mq+1,tmp2,ntmp2) do i=1,ntmp2 tmp(i)=tmp2(i) end do ntmp=ntmp2 end do end if do i=1,ntmp AR(i)=tmp(i) end Do nAR=ntmp end c TruncaSpectra: para los espectros teóricos trunca c todos los valores próximos a los picos estacionales y W=0 subroutine truncaSpectra(d,bd,mq,maxValue,nchi, $ ncycth,nchcyc,npsi,HpCycle,varwnc) implicit none include 'spectra.i' c INPUT PARAMETERS integer d,bd,mq,nchi,ncycth,nchcyc,npsi,HpCycle real*8 maxValue,varwnc c LOCAL VARIABLES integer iTO,wide c-------------------------------------------------------------------- wide=Lspect/MQ iTO=1 if ((d+bd).gt.0) then call truncaValor(spect,Lspect,wide,iTO,maxValue) call truncaValor(spectse,Lspect,wide,iTO,maxvalue) end if if (bd.gt.0) then call truncaSeasSpect(spect,mq,maxValue) call truncaSeasSpect(spectSE,mq,maxValue) end if if (nchi.ne.1 .and. (d+bd).gt.0) then call truncaValor(spectt,Lspect,wide,iTO,maxvalue) call truncaValor(spectet,Lspect,wide,iTO,maxValue) end if if (mq.ne.1 .and. npsi.ne.1 .and. bd.ge.1) then call truncaSeasSpect(spects,mq,maxValue) call truncaSeasSpect(spectes,mq,maxValue) end if if ((varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. nchcyc.ne.1)) $ .and. npsi.ne.1 .and. (bd+d).gt.0) then call truncaValor(spectSA,Lspect,wide,iTO,maxValue) call truncaValor(specteSA,LSpect,wide,iTO,maxValue) end if if (HPCYCLE.ge.1 .and. (d+bd).gt.0) then call truncaValor(spectM,Lspect,wide,iTO,maxValue) call TruncaValor(specteM,Lspect,wide,iTO,maxValue) end if if (HPCYCLE.ge.1 .and. (d+bd).ge.3) then call truncaValor(spectBC,Lspect,wide,iTO,maxValue) call truncaValor(specteBC,Lspect,wide,iTO,maxValue) end if if (HPCYCLE.eq.3 .and .bd.ge.1) then call truncaSeasSpect(spectM,mq,maxValue) call truncaSeasSpect(specteM,mq,maxValue) call truncaSeasSpect(spectBc,mq,maxValue) call truncaSeasSpect(specteBC,mq,maxValue) end if end c TruncaSeasSpect: trunca a un valor máximo en la proximidad c de las frecuencias estacionales del espectro. subroutine truncaSeasSpect(spect,mq,maxValue) implicit none include 'spectrum.i' c INPUT PARAMETERS real*8 maxValue integer mq c INPUT/OUTPUT parameters real*8 spect(Lspect) c EXTERNAL external truncaValor c LOCAL parameters integer i,iTo,wide c ----------------------------------- wide=Lspect/mq do i=1,mq/2 iTo=2*i*wide call truncaValor(spect,Lspect,iTo-wide,iTo,maxValue) if (iTo.lt.Lspect) then call truncaValor(spect,Lspect,iTo+wide,iTo,maxValue) end if enddo end c subroutine truncaValor(arr,nArr,ifrom,iTo,maxVal) implicit none c INPUT PARAMETERS integer narr,ifrom,ito real*8 maxVal c INPUT/OUTPUT real*8 arr(nArr) c LOCAL VARIABLES integer i,i1,foundMax c foundMax=0 i1=iFrom if (iFrom.lt.iTo) then do while((foundMax.eq.0) .and. (i1.le.iTo)) if (arr(i1).gt.maxVal) then foundMax=1 else i1=i1+1 end if endDo do i=i1,iTo arr(i)=maxVal endDo else do while((foundMax.eq.0) .and. (i1.ge.ito)) if (arr(i1).gt.maxVal) then foundMax=1 else i1=i1-1 end if endDo do i=i1,iTo,-1 arr(i)=MaxVal endDo end if end *c *c maxValT nos devuelve el mayor valor no infinito de los máximos de los espectros * real*8 function maxValT(ncycth,ncyc,npsi,Hpcycle,d,bd,mq,varwnc) * implicit none * include 'spectra.i' *c INPUT PARAMETERS * integer ncycth,ncyc,npsi,HPcycle,d,bd,mq * real*8 varWnc *c EXTERNAL FUNCTIONS * external maxVspec * real*8 maxVspec *c LOCAL VARIABLES * real*8 maxVal1,mVal2 *c * mVal2=maxVspec(spectei,Lspect) * if ((d+bd).eq.0) then * maxVal1=maxVspec(spectse,Lspect) * if (maxVal1.gt.mVal2) mVal2=maxVal1 * end if * if (varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. ncyc.ne.1)) then * maxVal1=maxVspec(specty,Lspect) * if (maxVal1.gt.mVal2) mVal2=maxVal1 * end if * if (mq.ne.1 .and. npsi.ne.1 .and. bd.eq.0) then * maxVal1=maxVspec(spects,Lspect) * if (maxVal1.gt.mVal2) mVal2=maxVal1 * end if * if ((bd+d).le.2 .and. (HPCYCLE.eq.1 .or. HPCYCLE.eq.2) .or. * $ (HPCYCLE.eq.3 .and. bd.eq.0)) then * maxVal1=maxVspec(spectBC,Lspect) * if (maxVal1.gt.mVal2) mVal2=maxVal1 * else if (HPCYCLE.eq.3 .and. (d+bd).le.2)then * maxVal1=maxVspec(spectBC,Lspect/MQ) * if (maxVal1.gt.mVal2) mVal2=maxVal1 * end if * maxValT=mVal2; * end c real*8 function maxVspec(arr,nArr) implicit none c INPUT PARAMETERS integer nArr real*8 arr(nArr) c LOCAL VARIABLES integer i real*8 max1 c max1=-1.0D30 do i=1,nArr if (max1.lt.arr(i)) then max1=arr(i) end if endDo maxVspec=max1 end c c getSGmfilter: obtain the Squared Gain filter for Long Term Trend c INPUT: c ARnc(1:nARnc): polynomial of the roots that are in AR of series but not in ARp (Trend,SA or AR serie depending on HPcycle) c MAm(1:nMAm): Moving average of the long term trend c THhp(1:nTHhp): the THhp that only depend on the landa of HP filter c THstar(1:Qstar): the MA of the series c Vc: tha variance of the Long Term Trend in terms of Va c nSG: the number of values plus one that will output in SG c SQG: 1:squared gain, ELSE: Gain of the filter c OUTPUT: c SG: the squared Gain of the filter c SG(1:nSG+1)=Fourier(Vm*ACF(ARnc(B)*MAm(B)/[THhp(B)*THstar(B)], w=pi*(0:nSG)/nSG).^2 subroutine getSGmfilter(ARnc,nARnc,MAm,nMAm,THhp,nTHhp, $ THstar,Qstar,Vc,SG,nSG,SQG) implicit none include 'component.i' include 'func5f1.i' include 'testf1.i' c CONSTANT PARAMETERS real*8 pi parameter(pi=3.14159265358979D0) c INPUT PARAMETERS integer nARnc,nMAm,nTHhp,Qstar,nSG,SQG real*8 ARnc(*),MAm(*),THhp(*),THstar(*),Vc c OUTPUT PARAMETERS real*8 SG(*) c EXTERNAL external CONJ,CONV,FUNC0 real*8 FUNC0 C LOCAL PARAMETERS real*8 arg,x,nume(MaxCompDim),Deno(MaxCompDim) integer i,nNume,nDeno c --------------------------------------------------------- call CONV(ARnc,nARnc,MAm,nMAm,Nume,nNume) call CONV(THhp,nTHhp,THstar,Qstar,Deno,nDeno) call CONJ(Nume,nNume,Nume,nNume,Dumf1,Ndumf1) call CONJ(Deno,nDeno,Deno,nDeno,Dum1f1,nD1f1) Ifunc1=5 do i=0,nSG x=(1.0d0/120.0d0)*pi*i arg=Vc*FUNC0(x) if (SQG.eq.1) then SG(i+1)=arg*arg else SG(i+1)=arg end if enddo end c c c c HPSGfilters: obtain the Squared Gain filter for Long Term Trend c INPUT: c ARnp(1:nARnp): polynomial of the roots that are in AR of series but not in ARp (Trend,SA or AR serie depending on HPcycle) c MAm(1:nMAm): Moving average of the long term trend c Vm: the variance of the Long Term Trend in terms of Va c MAbc(1:nMAbc): Moving average of the Business Cycle c Vbc: the variance of the Business Cycle in terms of Va c THhp(1:nTHhp): the THhp that only depend on the landa of HP filter c THstar(1:Qstar): the MA of the series c d,bd,mq c SQG: 1: squared gain of the filter, ELSE: Gain of the Filter c plotg: 0 -->call PlotFilters c OUTPUT: c SGm: the squared Gain of the LONG TERM TREND filter c SGm(1:120+1)=Fourier(Vm*ACF(ARnp(B)*MAm(B)/[THhp(B)*THstar(B)], w=pi*(0:120)/120).^2 c SGbc: the squared Gain of the LONG TERM TREND filter c SGbc(1:120+1)=Fourier(Vbc*ACF(ARnp(B)*MAbc(B)/[THhp(B)*THstar(B)*Delta^min(2,d+bd)], w=pi*(0:120)/120).^2 subroutine HPSGfilters(HPcycle,ARnp,nARnp,MAm,nMAm,MAbc,nMAbc,Vbc, $ HPth,nHPth,Vm,THstar,Qstar,d,bd,mq,SQG,plotG) implicit none include 'component.i' c CONSTANT PARAMETERS real*8 pi integer nSG parameter(pi=3.14159265358979D0,nSG=120) c INPUT PARAMETERS integer HPcycle integer nARnp,nMAm,nMAbc,nHPth,Qstar,d,bd,mq,SQG,plotG real*8 ARnp(*),MAm(*),MAbc(*),HPth(*),THstar(*),Vbc,Vm c EXTERNAL integer istrlen external CONV,getSGmFilter,istrlen c LOCAL VARIABLES integer nMAmDelta real*8 MAmDelta(MaxCompDim), $ Delta(3),SGm(nSG+1),SGbc(nSG+1) character fname*30,subtitle*50,LongTermCad*22 c --------------------------------------------------------- If (HPcycle.eq.1) then LongTermCad='LONG TERM TREND' else if (HPcycle.eq.2) then LongTermCad='SA series without BC' else LongTermCad='Series without BC' end if call getSGmFilter(ARnp,nARnp,MAm,nMAm, $ HPth,nHPth,THstar,Qstar,Vm,SGm,nSG,SQG) if ((d+bd).ge.1) then SGm(1)=1.0d0 end if * if (plotg.eq.0) then * fname='FILTFM.T4F' * if (SQG.eq.1) then * subtitle='SQUARED GAIN OF '// * $ LongTermCad(1:istrlen(Long TermCad)) * else * subtitle='GAIN OF '//LongTermCad(1:istrlen(LongTermCad)) * $ //' FILTER' * end if * call PlotFilters(fname,subtitle,SGm,nSG+1,mq,0.0d0,pi,0) * end if Delta(1)=1.0D0 Delta(2)=-2.0D0 Delta(3)=1.0D0 call Conv(Delta,3,MAm,nMAm,MAmDelta,nMAmDelta) call getSGmfilter(ARnp,nARnp,MAmDelta,nMAmDelta, $ HPth,nHPth,THstar,Qstar,Vbc,SGbc,nSG,SQG) * if (plotg.eq.0) then * fname='FILTFBC.T4F' * if (SQG.eq.1) then * subtitle='SQUARED GAIN OF BUSINESS CYCLE' * else * subtitle='GAIN OF BUSINESS CYCLE FILTER' * end if * call PLOTFILTERS(fname,subtitle,SGBC,nSG+1,mq,0.0d0,pi,0) * end if end C C C LINES OF CODE COMMENTED FOR X-13A-S : 65 C subroutine GETCOMMLINE(nover,ioneout,outdir,graphdir,infile, C $ outfile,itable) CC CC.. Implicits .. C implicit none CC CC.. Formal Arguments .. C integer nover,ioneout,itable C character outdir*180,graphdir*180,infile*180,outfile*180 CC.. Local Scalars .. C integer i C integer*4 nar C character buff*180 CC CC.. External Functions .. C integer IARGC C external IARGC CC CC.. External Calls .. C external GETARG CC CC ... Executable Statements ... CC CC CC C outdir = 'output' C graphdir = 'graph' C infile = 'serie' C outfile='' C nover = 0 C ioneout = 0 C itable = 0 C nar = IARGC() C if (nar .lt. 1) return C i = 1 C do while (.true.) C call GETARG(i,buff) C if (buff .eq. '-s') then C nover = 1 C end if C if (buff .eq. '-t') then C itable = 1 C end if C if (buff .eq. '-i') then C i = i + 1 C call GETARG(i,infile) C end if C if (buff .eq. '-o') then C i = i + 1 C call GETARG(i,outdir) C end if C if (buff .eq. '-g') then C i = i + 1 C call GETARG(i,graphdir) C end if C if (buff .eq. '-OF') then C ioneout = 1 C i = i + 1 C call GETARG(i,outfile) C end if C i = i + 1 C if (nar .lt. i) return C end do C end C END OF CODE BLOCK C C C subroutine PROUT1(mq,lam,type,ioneout,nz,titleg,tramo,interp,init, $ p,d,q,bd,bp,bq,out,npers,nyer,npread) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer mq,lam,type,ioneout,nz,tramo,interp,init,p,d,q,bd,bp,bq, $ out,npers,nyer,npread character titleg*80 C C.. Local Scalars .. character buff*80,buff1*80 C C.. External Functions .. integer ISTRLEN external ISTRLEN include 'stream.i' C C ... Executable Statements ... C * if (out .eq. 2) then * write (buff,'(I2,2X,A)') mq, 'OBS. PER YEAR' * if (mq .eq. 12) then * buff = 'MONTHLY' * end if * if (mq .eq. 4) then * buff = 'QUARTERLY' * end if * if (mq .eq. 1) then * buff = 'ANNUAL' * end if * if (ioneout .eq. 1) then * if (HTML .eq. 1) then * write (Nio,'("


")') * else * write (Nio,'(///)') * end if * end if * if (HTML .eq. 1) then * write (nio,'(''
'', * $ ''STOCHASTIC COMPONENT'', * $ ''FINAL COMPONENT
IN SAMPLEFORECAST
SERIES'',G13.4, * $ '''',G13.4, * $ ''
'')') * write (Nio,'("")') * $ titleg(1:ISTRLEN(titleg)), buff(1:ISTRLEN(buff)), nz, * $ 'OBSERVATIONS', 'STARTS :', npers, '/', nyer * write (Nio,'("
",A,"",A,"",I3,2X,A, * & "",A,2X,I2,A,I4,"
")') * if (npread .eq. 1) then * write (Nio,'("
",A,"")') 'PREADJUSTED WITH regARIMA' * end if * if ((tramo.eq.1) .and. (interp.eq.1)) then * write (Nio,'(''
MISSING OBSERVATIONS IN ORIGINAL'', * $ '' SERIES HAVE BEEN INTERPOLATED'')') * end if * else * write (Nio,'(A,4X,A,2X,I3,2X,A,4X,A,2X,I2,A,I4)') * $ titleg(1:ISTRLEN(titleg)), buff(1:ISTRLEN(buff)), nz, * $ 'OBSERVATIONS', 'STARTS :', npers, '/', nyer * if (npread .eq. 1) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 * write (Nio,'(2X,A)') 'PREADJUSTED WITH TRAMO' *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * write (Nio,'(2X,A)') 'PREADJUSTED WITH regARIMA' *C END OF CODE BLOCK * end if * if ((tramo.eq.1) .and. (interp.eq.1)) then * write (Nio,'(2x,"MISSING OBSERVATIONS IN ORIGINAL SERIES", * $ 1x,"HAVE BEEN INTERPOLATED")') * end if * end if * buff1 = 'MULTIPLICATIVE' * if (lam .eq. 1) then * buff1 = 'ADDITIVE' * end if * if ((init.eq.2) .and. (tramo.eq.1)) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C buff = 'MAX. LIKE. FROM TRAMO' *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * buff = 'MAX. LIKE. FROM regARIMA' *C END OF CODE BLOCK * else if ((init.eq.2) .and. (tramo.eq.0)) then * buff = 'PARAMETERS FIXED' * else if ((init.eq.2) .and. (tramo.eq.-1)) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C buff = 'FROM TRAMO' *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * buff = 'FROM regARIMA' *C END OF CODE BLOCK * else if (type .eq. 0) then * buff = 'MAXIMUM LIKELIHOOD' * else if (type .eq. 1) then * buff = 'CONSTRAINED LEAST SQUARES' * end if * if (HTML .eq. 1) then * write (Nio,'("
",A,"",A,2X,"",A,2X,A,"")') * $ 'TYPE OF DECOMPOSITION : ', buff1(1:ISTRLEN(buff1)), * $ ',TYPE OF ESTIMATION : ', buff(1:ISTRLEN(buff)) * write (buff,'(''('',1x,i1,'','',2x,i1,'','',2x, * $ i1,'','',1x,'')'',4x,''('', * $ 1x,i1,'','',2x,i1,'','',2x,i1,1x, * $ '')'',4x,i2)') p, d, q, bp, bd, bq, mq * else * write (Nio,'(A,2X,A,2X,A,2X,A)') * $ 'TYPE OF DECOMPOSITION :', buff1(1:ISTRLEN(buff1)), * $ ',TYPE OF ESTIMATION :', buff(1:ISTRLEN(buff)) * write (buff, * $'("(",1x,i1,",",2x,i1,",",2x,i1,",",1x,")",4x,"(", * $1x,i1,",",2x,i1,",",2x,i1,1x,")",4x,i2)') p, d, q, bp, * $ bd, bq, mq * end if * if ((p.eq.0) .and. (bp.eq.0) .and. (d.eq.1) .and. (bd.eq.1) .and. * $ (q.eq.1) .and. (bq.eq.1)) then * buff = 'DEFAULT' * end if * if (HTML .eq. 1) then * if (lam .eq. 0) then * write (Nio,'(''
ARIMA MODEL : '',2X, * $ ''LOGS'',/,17X,A)') buff * else * write (Nio,'(''
ARIMA MODEL : '',2X, * $ ''LEVELS'',/,17X,A)') buff * end if * else * if (lam .eq. 0) then * write (Nio,'(2X,"ARIMA MODEL :",2X,"LOGS",/,17X,A)') buff * else * write (Nio,'(2X,"ARIMA MODEL :",2X,"LEVELS",/,17X,A)') buff * end if * end if * else if (out.eq.0) then if (ioneout .eq. 1) then write (Nio,'(///)') end if 7000 format (' SERIES TITLE: ',a) write (Nio,7000) titleg buff = 'NO' if (npread .eq. 1) then buff = 'YES' end if C LINES OF CODE COMMENTED FOR X-13A-S : 1 C write (Nio,'(1X,A,2X,A)') 'PREADJUSTED WITH TRAMO :', buff C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 write (Nio,'(1X,A,2X,A)') 'PREADJUSTED WITH regARIMA :', buff C END OF CODE BLOCK end if end C C subroutine FITMODEL(bjstat1,bjstatsave,sigsave,qmax,ntry,sqf,th,d, $ bd,p,bp,q,bq,imean,init,*) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer qmax,ntry,d,bd,p,bp,q,bq,imean,init real*8 bjstat1,bjstatsave(3),sigsave(3),sqf,th C C.. Local Scalars .. integer nmax real*8 sigmax,sigmin C C.. Intrinsic Functions .. intrinsic DBLE include 'fitmod.i' include 'stream.i' C LINES OF CODE ADDED FOR X-13A-S : 1 include 'units.cmn' C END OF CODE BLOCK C C ... Executable Statements ... C if (ntry .eq. 1) then if (bjstat1 .lt. DBLE(qmax)) then C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK ntry = 0 return 1 else if (-th .gt. -.1d0) then d = 2 q = 2 p = 0 bd = 1 bq = 1 bp = 0 imean = 0 init = 0 ntry = 2 return 1 else p = 3 d = 1 bd = 1 q = 1 bq = 1 bp = 0 imean = 1 init = 0 ntry = 3 return 1 end if else if (ntry .eq. 2) then if ((bjstat1.lt.DBLE(qmax)) .and. (sqf.lt.(1.1d0*Sisv1))) then C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK d = 2 q = 2 p = 0 bd = 1 bq = 1 bp = 0 imean = 0 init = 0 ntry = 0 write (Nio,'(//,2X,"*******************************")') write (Nio,'(2x,"TO PROVIDE A BETTER FIT, SEATS",/,7x, $ "HAS CHANGED THE MODEL")') write (Nio,'(2X,"*******************************",/)') return 1 else p = 3 d = 1 bd = 1 q = 1 bq = 1 bp = 0 imean = 1 init = 0 ntry = 3 return 1 end if else if (ntry .ne. 3) return if ((bjstat1.lt.DBLE(qmax)) .and. (sqf.lt.(1.1d0*Sisv1))) then C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK write (Nio,'(//,2X,"*******************************")') write (Nio,'(2x,"TO FIT BETTER THE SERIES, SEATS",/,7x, $ "HAS CHANGED THE MODEL")') write (Nio,'(2X,"*******************************",/)') ntry = 0 p = 3 d = 1 bd = 1 q = 1 bq = 1 bp = 0 imean = 1 init = 0 C IF (P.EQ.3) TYPE=1 return 1 end if sigmax = sigsave(1) nmax = 1 if (sigmax .lt. sigsave(2)) then sigmax = sigsave(2) nmax = 2 end if if (sigmax .lt. sigsave(3)) then sigmax = sigsave(3) nmax = 3 end if sigmin = sigsave(1) if ((sigmin.gt.sigsave(2)) .and. (sigsave(2).gt.0.0d0)) then sigmin = sigsave(2) end if if ((sigmin.gt.sigsave(3)) .and. (sigsave(3).gt.0.0d0)) then sigmin = sigsave(3) end if if ((bjstatsave(3).lt.bjstatsave(2)) .and. $ (bjstatsave(3).lt.bjstatsave(1)) .and. $ ((sigmax-sigmin).lt.(1.0d-1*sigmin))) then p = 3 d = 1 bd = 1 q = 1 bq = 1 bp = 0 imean = 1 init = 0 ntry = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK write (Nio,'(//,2X,"*******************************")') write (Nio,'(2x,"TO FIT BETTER THE SERIES, SEATS",/,7x, $ "HAS CHANGED THE MODEL")') write (Nio,'(2X,"*******************************",/)') return 1 end if if ((bjstatsave(2).lt.bjstatsave(3)) .and. $ (bjstatsave(2).lt.bjstatsave(1)) .and. $ ((sigmax-sigmin).lt.(1.0d-1*sigmin))) then d = 2 q = 2 p = 0 bq = 1 bp = 0 bd = 1 imean = 0 init = 0 ntry = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK write (Nio,'(//,2X,"*******************************")') write (Nio,'(2x,"TO FIT BETTER THE SERIES, SEATS",/,7x, $ "HAS CHANGED THE MODEL")') write (Nio,'(2X,"*******************************",/)') return 1 end if if (((bjstatsave(2).lt.bjstatsave(1)).and.(nmax.eq.3)) .or. $ ((bjstatsave(2).lt.bjstatsave(3)).and.(nmax.eq.1))) then d = 2 q = 2 p = 0 bq = 1 bp = 0 bd = 1 imean = 0 init = 0 ntry = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK write (Nio,'(//,2X,"*******************************")') write (Nio,'(2x,"TO FIT BETTER THE SERIES, SEATS",/,7x, $ "HAS CHANGED THE MODEL")') write (Nio,'(2X,"*******************************",/)') return 1 else if (((bjstatsave(3).lt.bjstatsave(2)).and.(nmax.eq.1)) .or. $ ((bjstatsave(3).lt.bjstatsave(1)).and.(nmax.eq.2))) then p = 3 d = 1 bd = 1 q = 1 bq = 1 bp = 0 imean = 1 init = 0 ntry = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK write (Nio,'(//,2X,"*******************************")') write (Nio,'(2x,"TO FIT BETTER THE SERIES, SEATS",/,7x, $ "HAS CHANGED THE MODEL")') write (Nio,'(2X,"*******************************",/)') return 1 else C LINES OF CODE COMMENTED FOR X-13A-S : 2 C close (12) c Nio = 16 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 close (42) Nio = Mt1 C END OF CODE BLOCK ntry = 100 return 1 end if end if end C C C * subroutine SMOOTHING(p,d,q,bp,bd,bq,mq,smtr,thlim,bthlim, * $ ths,th,bth,bths,thstar) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Maybe Written .. * integer p,d,q,bp,bd,bq,mq,smtr *C.. In/Out Status: Maybe Read, Maybe Written .. * real*8 thlim,bthlim *C.. In/Out Status: Maybe Read, Maybe Written .. * real*8 ths(*),thstar(*) *C.. In/Out Status: Not Read, Maybe Written .. * real*8 th(*),bth(*),bths(*) *C *C.. Local Scalars .. * integer nthstar,i * include 'stream.i' *C *C ... Executable Statements ... *C * smtr = 0 * if ((p.ne.0).or.(d.ne.1).or.(q.ne.1) .or. * $ (bp.ne.0).or.(bd.ne.1).or.(bq.ne.1)) then * if (HTML .eq. 1) then * call SNote(Nio) * write (Nio,'(''
SINCE MODEL IS NOT THE DEFAULT ONE,'', * $ '' THE SMOOTHER CANNOT BE COMPUTED;'')') * call ENote(Nio) * else * write (Nio,'(//8x,''SINCE MODEL IS NOT THE DEFAULT ONE,'', * $ /,8x,'' THE SMOOTHER CANNOT BE COMPUTED;'')') * end if * return * end if * if (thlim .lt. 0.0d0) then * if (ths(2) .le. thlim) then * if (HTML .eq. 1) then * call SNote(Nio) * write (Nio,'(''
SINCE TH(1) <= THLIM, NO FURTHER'', * $ '' SMOOTHING IS NEEDED'')') * call ENote(Nio) * else * write (Nio,'(2x,''SINCE TH(1) <= THLIM, NO FURTHER'',/,2x, * $ "SMOOTHING IS NEEDED")') * end if * else * ths(2) = thlim * th(1) = -thlim * smtr = 1 * if (HTML .eq. 1) then * write (Nio,'(''

'', * $ ''THE TREND-CYCLE HAS BEEN MODIFIED TO'', * $ '' BECOME SMOOTHER;
'', * $ ''THE IRREGULAR COMPONENT'', * $ '' IS LIKELY TO PRESENT (LOW ORDER)
'', * $ ''AUTOCORRELATION, AND A LARGER VARIANCE.'', * $ ''

'')') * else * write (Nio,'(///,2x,''THE TREND-CYCLE HAS BEEN MODIFIED TO'', * $ '' BECOME SMOOTHER;'',/,2x,''THE IRREGULAR COMPONENT'', * $ '' IS LIKELY TO PRESENT (LOW ORDER)'',/,2x, * $ ''AUTOCORRELATION, AND A LARGER VARIANCE'',//)') * end if * end if * end if * if (bthlim .lt. 0.0d0) then * if (-bth(1) .le. bthlim) then * if (HTML .eq. 1) then * call SNote(Nio) * write (Nio,'(''
SINCE BTH(1) <= BTHLIM, NO FURTHER'', * $ '' SMOOTHING IS NEEDED'')') * call ENote(Nio) * else * write (Nio,'(2x,''SINCE BTH(1) <= BTHLIM, NO FURTHER'',/,2x, * $ ''SMOOTHING IS NEEDED'')') * end if * else * bth(1) = -bthlim * smtr = 1 * if (HTML .eq. 1) then * write (Nio,'(''

'', * $ ''THE SEASONAL HAS BEEN MODIFIED TO'', * $ '' BECOME SMOOTHER;
'', * $ ''THE IRREGULAR COMPONENT'', * $ '' IS LIKELY TO PRESENT (LOW ORDER)
'', * $ ''AUTOCORRELATION, AND A LARGER VARIANCE.'', * $ ''

'')') * else * write (Nio,'(///,2x,''THE SEASONAL HAS BEEN MODIFIED TO'', * $ " BECOME SMOOTHER;",/,2x,"THE IRREGULAR COMPONENT", * $ " IS LIKELY TO PRESENT (LOW ORDER)",/,2x, * $ "AUTOCORRELATION, AND A LARGER VARIANCE",//)') * end if * end if * end if * do i=1,mq+1 * bths(i)=0.0d0 * enddo * bths(1)=1.0d0 * bths(mq+1)=-bth(1) * call CONV(ths,q+1,bths,MQ+1,thstar,nthstar) * do i=2,nthstar * thstar(i-1)=-thstar(i) * enddo * return * end C C * subroutine OPENFILE(iter,title,titleg,tout,ioneout,out,opened, * $ outdir,outfile,noserie,itable,niter,numser) *C *C.. Implicits .. * implicit none * integer maxLen * parameter(maxLen=80) *C * INCLUDE 'stdio.i' *C.. Formal Arguments .. * integer iter,ioneout,out,noserie,itable,niter,ilen,numser * character title*80,tout*80,outdir*180,outfile*180 * character titleg*80 * character pkindex*80,Tidx*80,Tmain*80, * $ Tfname*80,PFix*4 * character TMainName*180,TidxName*180 * logical opened *C *C.. Local Scalars .. * integer i,ifail,ii,jj,noutdir,noutfile * character fname*180,seqname*19,FilenameC*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external OPENDEVICE, OPENDEVSCRATCH * include 'stream.i' * include 'build.i' *C *C ... Executable Statements ... *C * PFix='.out' * TmainName = '' * noutfile = ISTRLEN(outfile) * noutdir = ISTRLEN(outdir) * if (iter .eq. 1) then * write (seqname,'(I12)') niter * i = 1 * do while (seqname(i:i).ne.'1' .and. seqname(i:i).ne.'2' .and. * $ seqname(i:i).ne.'3' .and. seqname(i:i).ne.'4' .and. * $ seqname(i:i).ne.'5' .and. seqname(i:i).ne.'6' .and. * $ seqname(i:i).ne.'7' .and. seqname(i:i).ne.'8' .and. * $ seqname(i:i).ne.'9') * i = i + 1 * end do * ii = i * i = ii * do while (seqname(i:i) .ne. ' ') * i = i + 1 * end do * jj = i - 1 * title = 'MODEL' // seqname(ii:jj) * titleg = title *C LINES OF CODE ADDED FOR X-13A-S : 5 * if (noutdir.gt.0) THEN * tout = outdir(1:noutdir) // 's_model' // seqname(ii:jj) // PFix * else * tout = 's_model' // seqname(ii:jj) // PFix * end if * Tfname = 's_model' // seqname(ii:jj) // PFix *C END OF CODE BLOCK *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C tout = outdir(1:noutdir) // '\MODEL' // seqname(ii:jj) // PFix *C END OF CODE BLOCK * if (ioneout .eq. 0) then * if (out .ne. 0) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVSCRATCH(16) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVSCRATCH(46) *C END OF CODE BLOCK * else * fname = tout *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVICE(fname,16,0,ifail) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVICE(fname,46,0,ifail) *C END OF CODE BLOCK * end if * else if (.not. opened) then * if (out .ne. 0) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVSCRATCH(16) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVSCRATCH(46) *C END OF CODE BLOCK * else * if (noutfile .gt. 1) then *C LINES OF CODE ADDED FOR X-13A-S : 5 * if (noutdir.gt.0) then * fname = outdir(1:noutdir) // outfile(1:noutfile) // PFix * else * fname = outfile(1:noutfile) // PFix * end if *C END OF CODE BLOCK * Tfname = outfile(1:noutfile) // PFix *C LINES OF CODE COMMENTED FOR X-13A-S : 6 *ccdos *c fname = outdir(1:noutdir) // '\\' // outfile(1:noutfile) // *c $ '.OUT' *ccunix *cc fname = outdir(1:noutdir) // '/' // outfile(1:noutfile) // *cc $ '.OUT' *C END OF CODE BLOCK * else * fname = tout * end if *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVICE(fname,16,0,ifail) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVICE(fname,46,0,ifail) *C END OF CODE BLOCK * end if * end if * else * tout = title * if ((iter.eq.2) .or. (iter.eq.3)) then * jj = 1 * do while (tout(jj:jj) .eq. ' ' .and. jj.le.maxLen) * jj = jj + 1 * end do * ii = jj * do while (tout(ii:ii) .ne. ' ' .and. ii.le.maxLen) * ii = ii + 1 * end do * ii = ii - 1 * if (ii-jj+1 .gt. 8) then * ii = jj + 7 * end if * do i = jj,ii * if ((tout(i:i).eq.'"') .or. (tout(i:i).eq.'\\') .or. * $ (tout(i:i).eq.'/') .or. (tout(i:i).eq.'[') .or. * $ (tout(i:i).eq.']') .or. (tout(i:i).eq.'<') .or. * $ (tout(i:i).eq.'>') .or. (tout(i:i).eq.'+') .or. * $ (tout(i:i).eq.';') .or. (tout(i:i).eq.',') .or. * $ (tout(i:i).eq.'*') .or. (tout(i:i).eq.'?') .or. * $ (tout(i:i).eq.':') .or. (tout(i:i).eq.'=')) then * tout(i:i) = '-' * end if * end do * write(pkindex,'(i4)')niter * call LEFTTRIM(pkindex) * pkindex = 'S'//pkindex(1:ISTRLEN(pkindex)) * ilen = istrlen(pkindex) * ilen = 8 - (ii-jj+1)-ilen-1 * if (ilen .ge.0) then * ilen = -1 * else * ilen = -ilen * end if * title = pkindex(1:istrlen(pkindex))//'_'//tout(jj:ii-ilen) * tout = pkindex(1:istrlen(pkindex))//'_'//tout(jj:ii-ilen) * tout = tout(1:ISTRLEN(tout)) // PFix * call STRTOLOW(title) * call STRTOLOW(tout) * Tfname = tout * Tmain = pkindex(1:istrlen(pkindex))//'_main' // PFix * Tidx = pkindex(1:istrlen(pkindex))//'_idx' // PFix *C LINES OF CODE COMMENTED FOR X-13A-S : 4 *ccdos *c tout = outdir(1:noutdir) // '\\' // tout(jj:ii) // PFix *ccunix *cc tout = outdir(1:noutdir) // '/' // tout(jj:ii) // PFix *C END OF CODE BLOCK * if (ioneout .eq. 0) then * if (out .ne. 0) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVSCRATCH(16) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVSCRATCH(46) *C END OF CODE BLOCK * else *cdos backslash for directory * fname = outdir(1:noutdir) // '\\' // tout(1:istrlen(tout)) *cunix forward slash for directory *cunix fname = outdir(1:noutdir) // '/' // tout(1:istrlen(tout)) *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVICE(fname,16,0,ifail) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVICE(fname,46,0,ifail) * end if * else if (.not. opened) then * if (out .ne. 0) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVSCRATCH(16) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVSCRATCH(46) *C END OF CODE BLOCK * else * call STRTOLOW(outfile) * if (noutfile .gt. 1) then *C LINES OF CODE ADDED FOR X-13A-S : 5 * if (noutdir .gt. 0) then * fname = outdir(1:noutdir) // outfile(1:noutfile) // PFix * else * fname = outfile(1:noutfile) // PFix * end if * Tfname = outfile(1:noutfile) // PFix *C END OF CODE BLOCK *C LINES OF CODE COMMENTED FOR X-13A-S : 6 *ccdos *c fname = outdir(1:noutdir) // '\\' // outfile(1:noutfile) // *c $ PFix *cccunix *cc fname = outdir(1:noutdir) // '/' // outfile(1:noutfile) // *cc $ PFix *C END OF CODE BLOCK * else * if (noutdir .gt. 0) then * fname = outdir(1:noutdir) // tout * else * fname = tout * end if * end if *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVICE(fname,16,0,ifail) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVICE(fname,46,0,ifail) *C END OF CODE BLOCK * end if * end if * else * if (noserie .eq. 1) then * title = 'noserie' * end if * tout = title * jj = 1 * do while (tout(jj:jj) .eq. ' ') * jj = jj + 1 * end do * ii = jj * do while (tout(ii:ii) .ne. ' ') * ii = ii + 1 * end do * ii = ii - 1 * if (ii-jj+1 .gt. 8) then * ii = jj + 7 * end if * write(pkindex,'(i4)')niter * call LEFTTRIM(pkindex) * pkindex = 'S'//pkindex(1:ISTRLEN(pkindex)) * ilen = istrlen(pkindex) * ilen = 8 - (ii-jj+1)-ilen-1 * if (ilen .ge.0) then * ilen = -1 * else * ilen = -ilen * end if * title = pkindex(1:istrlen(pkindex))//'_'//tout(jj:ii-ilen) * tout = pkindex(1:istrlen(pkindex))//'_'//tout(jj:ii-ilen) * tout = tout(1:ISTRLEN(tout)) // PFix * call STRTOLOW(title) * call STRTOLOW(tout) * Tfname = tout * Tmain = pkindex(1:istrlen(pkindex))//'_main' // PFix * Tidx = pkindex(1:istrlen(pkindex))//'_idx' // PFix * do i = 1,istrlen(tout) * if ((tout(i:i).eq.'"') .or. (tout(i:i).eq.'\\') .or. * $ (tout(i:i).eq.'/') .or. (tout(i:i).eq.'[') .or. * $ (tout(i:i).eq.']') .or. (tout(i:i).eq.'<') .or. * $ (tout(i:i).eq.'>') .or. (tout(i:i).eq.'+') .or. * $ (tout(i:i).eq.';') .or. (tout(i:i).eq.',') .or. * $ (tout(i:i).eq.'*') .or. (tout(i:i).eq.'?') .or. * $ (tout(i:i).eq.':') .or. (tout(i:i).eq.'=')) then * tout(i:i) = '-' * end if * end do * if (ioneout .eq. 0) then * if ((out .ne. 0)) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVSCRATCH(16) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVSCRATCH(46) *C END OF CODE BLOCK * else * call STRTOLOW(tout) *C LINES OF CODE ADDED FOR X-13A-S : 5 * if (noutdir .gt. 0) then *cdos backslash for directory * fname = outdir(1:noutdir) // '\\' // tout(1:istrlen(tout)) *cunix forward slash for directory *cunix fname = outdir(1:noutdir) // '/' // tout(1:istrlen(tout)) * else * fname = tout(1:istrlen(tout)) * end if * Tfname = tout(1:istrlen(tout)) *C END OF CODE BLOCK *C LINES OF CODE COMMENTED FOR X-13A-S : 4 *ccdos *c fname = outdir(1:noutdir) // '\\' // tout(jj:ii+4) *ccunix *cc fname = outdir(1:noutdir) // '/' // tout(jj:ii+4) *C END OF CODE BLOCK *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVICE(fname,16,0,ifail) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVICE(fname,46,0,ifail) *C END OF CODE BLOCK * end if * else if (.not. opened) then * if (out .eq. 3) then *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVSCRATCH(16) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVSCRATCH(46) *C END OF CODE BLOCK * else * call STRTOLOW(outfile) * if (noutfile .gt. 1) then *C LINES OF CODE ADDED FOR X-13A-S : 5 * if (noutdir .gt. 0) then * fname = outdir(1:noutdir) // outfile(1:noutfile) // PFix * else * fname = outfile(1:noutfile) // PFix * end if *C END OF CODE BLOCK *C LINES OF CODE COMMENTED FOR X-13A-S : 6 *ccdos *c fname = outdir(1:noutdir) // '\\' // outfile(1:noutfile) // *c $ '.OUT' *ccunix *cc fname = outdir(1:noutdir) // '/' // outfile(1:noutfile) // *cc $ '.OUT' *C END OF CODE BLOCK * else * fname = tout * Tfname = tout(1:istrlen(tout)) * end if *C LINES OF CODE COMMENTED FOR X-13A-S : 1 *C call OPENDEVICE(fname,16,0,ifail) *C END OF CODE BLOCK *C LINES OF CODE ADDED FOR X-13A-S : 1 * call OPENDEVICE(fname,46,0,ifail) *C END OF CODE BLOCK * end if * end if * end if * end if * if (itable .eq. 1) then * call OpenFileTables(ifail,iter,niter,title,numser) * if ((iter .eq.0).or.(niter.le.1)) then * call OpenFilePsie(ifail) * end if * end if * end C C C THIS SUBPROGRAM EVALUATES THE HARMONIC FUNCTION IN THE COMMON C "FUNC5F1" C C INPUT ARGUMENT C C X : THE VALUE AT WHICH THE FUNCTION MUST BE EVALUATED C double precision function FUNC1(x) C C C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 x C C.. Local Scalars .. integer i,l real*8 denom,numer,w C C.. Local Arrays .. real*8 c(250) C C.. Intrinsic Functions .. intrinsic ABS, COS, MAX, SIGN include 'func5f1.i' C C ... Executable Statements ... C C w = 0.0d0 numer = 0.0d0 denom = 0.0d0 l = MAX(Ndumf1,Nd1f1) do i = 1,l c(i) = COS(w) w = w + x end do do i = 1,Ndumf1 numer = numer + Dumf1(i)*c(i) end do do i = 1,Nd1f1 denom = denom + Dum1f1(i)*c(i) end do if (ABS(denom) .lt. 1.0d-13) then denom = SIGN(1.0d-13,denom) end if FUNC1 = numer / denom end C C THIS SUBPROGRAM COMPUTES THE STANDARD ERROR OF A COMPONENT C C INPUT PARAMETERS C SE : STANDARD ERROR OF THE COMPONENT C NZ : DIMENSION OF COMP AND SE C PSIE : PSI-WEIGHTS OF THE COMPOPNENT (B,F) C NFILT : DIMENSION OF PSIE C FEE : THEORETICAL VARIANCE OF THE MODEL FOR THE COMPONENT C SQF : STANDARD ERROR OF RESIDUALS C COMP : COMPONENT C LAMD : 0 LOGS, 1 NO LOGS C C subroutine SERROR(se,nz,psie,nfilt,fee,sqf,comp,lamd) C C.. Implicits .. implicit none C C.. Parameters .. * INCLUDE 'srslen.prm' * integer nfl,mp,kp * parameter (kp = PFCST, mp = POBS, nfl = mp*2) C C.. Formal Arguments .. integer nz,nfilt,lamd real*8 se(*),psie(*),fee,sqf,comp(*) C C.. Local Scalars .. integer i,k,mq2 real*8 sminus,splus C C.. Intrinsic Functions .. intrinsic EXP, MOD, SQRT C C ... Executable Statements ... C C C mq2 = nz / 2 if (MOD(nz,2) .eq. 1) then mq2 = mq2 + 1 end if se(mq2) = 0.0d0 do i = 1,nfilt-mq2 se(mq2) = se(mq2) + psie(i)*psie(i) end do i = mq2 C if (MOD(nz,2) .eq. 1 ) then C do k = mq2,nz C i = i - 1 C se(k) = se(k-1) + psie(nfilt-i)*psie(nfilt-i) C end do C else do k = mq2+1,nz i = i - 1 se(k) = se(k-1) + psie(nfilt-i)*psie(nfilt-i) end do C end if do k = mq2,nz se(k) = SQRT(fee+se(k)) * sqf end do do k = 1,mq2-1 se(k) = se(nz-k+1) end do if (lamd .eq. 0) then do i = 1,nz splus = comp(i) + 1.96d0*se(i) sminus = comp(i) - 1.96d0*se(i) se(i) = (EXP(splus)-EXP(sminus)) / (2.0d0 * 1.96d0) end do end if end C C C THIS SUBPROGRAM COMPUTES THE STANDARD ERROR OF A COMPONENT C C INPUT PARAMETERS C SE : STANDARD ERROR OF THE COMPONENT C NZ : DIMENSION OF COMP AND SE c lFor: number of forecast C PSIE : PSI-WEIGHTS OF THE COMPOPNENT (B,F) C NFILT : DIMENSION OF PSIE C FEE : THEORETICAL VARIANCE OF THE MODEL FOR THE COMPONENT C SQF : STANDARD ERROR OF RESIDUALS C COMP : COMPONENT C LAMD : 0 LOGS, 1 NO LOGS C C subroutine SERRORF(se,nz,lfor,psie,nfilt,fee,sqf,comp,lamd) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer nfl,mp,kp parameter (kp = PFCST, mp = POBS, nfl = mp*2) C C.. Formal Arguments .. integer nz,lfor,nfilt,lamd real*8 se(*),psie(*),fee,sqf,comp(*) C C.. Local Scalars .. integer i,k,mq2 real*8 sminus,splus C C.. Intrinsic Functions .. intrinsic EXP, MOD, SQRT C C ... Executable Statements ... C C C mq2 = (nz/2) + 1 se(mq2) = 0.0d0 do i = 1,nfilt-mq2 se(mq2) = se(mq2) + psie(i)*psie(i) end do i = mq2 C if (MOD(nz,2) .eq. 1 ) then C do k = mq2,nz C i = i - 1 C se(k) = se(k-1) + psie(nfilt-i)*psie(nfilt-i) C end do C else do k = mq2+1,nz+lfor i = i - 1 se(k) = se(k-1) + psie(nfilt-i)*psie(nfilt-i) end do C end if do k = mq2,nz+lfor se(k) = SQRT(fee+se(k)) * sqf end do do k = 1,mq2-1 se(k) = se(nz-k+1) end do if (lamd .eq. 0) then do i = 1,nz+lfor splus = comp(i) + 1.96*se(i) sminus = comp(i) - 1.96*se(i) se(i) = (EXP(splus)-EXP(sminus)) / (2.0d0*1.96d0) end do end if end C C C THIS SUBROUTINE COMPUTES THE PSEUDO-INNOVATIONS OF THE COMPONENTS C C INPUT PARAMETERS C THI : NUMERATOR OF THE MODEL FOR THE COMPONENT C NTHI : DIMENSION OF THI C PHINI : DENOMINATOR OF THE MODEL FOR THE COMPONENT C NPHINI : DIMENSION OF PHINI C THSTAR : NUMERATOR OF THE MODEL C QSTAR : DIMENSION OF THSTAR C A : RESIDUALS C NA : DIMENSION OF A C NDEC : NUMBER OF DIGITS IN THE TABLES C VARPSE : INNOVATIONS VARIANCE OF THE COMPONENT C PG : 0 FILES FOR GRAPH, 1 NO FILES C COMP : NAME OF THE COMPONENT C TITLE : TITLE OF THE SERIES C subroutine PINNOV(thi,nthi,phini,nphini,thstar,qstar,a,na, $ varpse,pg,comp) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer nthi,nphini,qstar,na,pg character comp*32 real*8 thi(*),phini(*),thstar(*),a(*),varpse C C.. Local Scalars .. integer i,iavant,indiet,j,nfnum character fname*30,subtitle*50 real*8 sum C C.. Local Arrays .. real*8 fnum(55),pse(mpkp) character tabtit*120 C C.. External Functions .. integer ISTRLEN external ISTRLEN C C.. External Calls .. external CONV, TABLE include 'sform.i' include 'stream.i' include 'transcad.i' C C ... Executable Statements ... C C C C VARPSE=VARIANCE OF PSEUDO-INN. (IN UNITS OF VARIANCE OF A) C C INIT.COND. PSE(NZ+1),..,PSE(NZ+QSTAR),..,A(NZ+1),.,.A(NZ+FNUM)=0 C C THE VECTORS A(NA) AND NA ARE NOT CHANGED C call CONV(thi,nthi,phini,nphini,fnum,nfnum) do i = 1,nfnum fnum(i) = fnum(i) * varpse end do C C NUMERATOR FILTERING C iavant = Nz - na if (iavant .lt. 0) then iavant = 0 end if indiet = 0 if (Nz-na .le. 0) then indiet = na - Nz end if do i = 1,Nz sum = 0.0d0 do j = 1,nfnum if (i+j-1.gt.iavant .and. i+j-1.le.Nz) then sum = sum + fnum(j)*a(i+j-1+indiet-iavant) end if end do pse(i) = sum end do C C DENOMINATOR FILTERING C do i = 1,Nz sum = pse(Nz+1-i) do j = 2,qstar if (Nz-i+j .le. Nz) then sum = sum - thstar(j)*pse(Nz-i+j) end if end do pse(Nz+1-i) = sum end do C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(pse,ndec) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(pse) *C END OF CODE BLOCK C PSEMEAN=DMEAN(NZ,PSE) C PSEVAR=DVAR(NZ,PSE) C RSTD=0.0D0 C RSTD=PSEVAR**0.5D0 C SKEWNE=0.0D0 C RKURT=0.0D0 C DO 25 I=1,NZ C SKEWNE=SKEWNE+((PSE(I)-PSEMEAN)**3)/(PSEVAR**1.50D0*NZ) C 25 RKURT=RKURT+((PSE(I)-PSEMEAN)**4)/(PSEVAR**2.0D0*NZ) C DO 26 I=1,NZ C PSE(I)=PSE(I)/RSTD C IF (MOD(I,NFREQ).EQ.0) THEN C IYEAR=I/NFREQ C IYEAR=NYER+IYEAR-1 C IPER=NFREQ C ELSE C IYEAR=I/NFREQ C IPER=I-IYEAR*NFREQ C IYEAR=NYER+IYEAR C end if C IPER=IPER+NPER-1 C IF (IPER.GT.NFREQ) THEN C IYEAR=IYEAR+1 C IPER=IPER-NFREQ C end if C 26 CONTINUE C NN=0 C IMEAN=1 C WRITE(NIO,'(/,4X,"ACF OF ESTIMATED INNOVATIONS IN ",A,/)')COMP C CALL AUTO(NZ,PSE,M,R,IQ,NZ,NN,IMEAN,NFREQ,1,1) C DO 126 I=1,NZ C 126 PSE(I)=PSE(I)**2 C WRITE(NIO,'(/,4X,"ACF OF SQUARED ESTIMATED INNOVATIONS IN ", C & A,/)')COMP C CALL AUTO(NZ,PSE,M,R,IQ,NZ,NN,IMEAN,NFREQ,1,1) C 1015 FORMAT(/,1H ,'OUTLIER OF ',F8.4,' AT T=',I3, C , 4X,'(',I2,1X,I4,')') C RSTD=RSTD/DSQRT(DBLE(NZ)) C WRITE(NIO,30)PSEMEAN,RSTD,PSEVAR,SKEWNE,RKURT C 30 FORMAT(//,1H ,' MEAN=',D12.4,/ C $ ' STAND. DEV.=',D12.4,/ C $ ' VARIANCE =',D12.4,/ C $ ' SKEWNESS=',F8.4,/ C $ ' KURTOSIS=',F8.4,/) C * if (pg .eq. 0) then * if (comp .eq. 'TREND-CYCLE') then * fname = 'PITREND.T' * end if * if (comp .eq. 'SEASONAL') then * fname = 'PISEAS.T' * end if * if (comp .eq. transLcad(1:nTransLcad)) then * fname = 'PITRANS.T' * end if * if (comp .eq. 'SEASONALLY ADJUSTED SERIES') then * fname = 'PISA.T' * end if * subtitle = 'PSEUDO INNOVATIONS IN ' // comp(1:ISTRLEN(comp)) * call PLOTSERIES(fname,subtitle,pse,Nz,0,999.0d0) * end if C LINES OF CODE ADDED FOR X-13A-S : 9 if (comp .eq. 'TREND-CYCLE') then CALL usrentry(pse,1,Nz,1,mpkp,2021) end if if (comp .eq. 'SEASONAL') then CALL usrentry(pse,1,Nz,1,mpkp,2022) end if if (comp .eq. 'TRANSITORY') then CALL usrentry(pse,1,Nz,1,mpkp,2023) end if if (comp .eq. 'SEASONALLY ADJUSTED SERIES') then CALL usrentry(pse,1,Nz,1,mpkp,2024) end if C END OF CODE BLOCK end CC CC CC C subroutine APPROXIMATE(p,q,d,bd,bp,bq,rez,imz,init,noadmiss, $ imean,type,th,bth,phi,bphi,mq,status,out,fixparam,remMeanMCS,*,*) C C.. Implicits .. implicit none integer n10,n1 parameter(n10=10,n1=1) C C.. Formal Arguments .. integer p,q,d,bd,bp,bq,init,noadmiss,imean,type,mq,out character status real*8 rez(*),imz(*),th(*),bth(*),phi(*),bphi(*) integer fixparam(n10) logical remMeanMCS C C.. Local Scalars .. integer i,nth,flagRmod,aux,difsOrig real*8 rdroot C C.. Local Arrays .. real*8 dar(64),dimz(64),dmodul(64),dpr(64),drez(64),ths(4) C C.. External Functions .. real*8 POLYVAL external POLYVAL integer KnownApprox external KnownApprox C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C.. External Calls .. external RPQ C C.. Intrinsic Functions .. intrinsic MAX, MIN include 'stream.i' C LINES OF CODE ADDED FOR X-13A-S : 1 include 'error.cmn' C END OF CODE BLOCK c c c integer pBak,dBak,qBak,bpBak,bdBak,bqBak c real*8 phiBak(3*n1),thBak(3*n1),bphiBak(3*n1),bthBak(3*n1) c common /ARMAbak/ phiBak,thBak,bphiBak,bthBak,pBak, c $ dBak,qBak,bpBak,bdBak,bqBak C C ... Executable Statements ... C c Th y bth entran con sus coeficientes *(-1) flagRmod=0 difsOrig=d+bd if (remMeanMCS) then imean=0 end if c c if (status.eq.'X') then c Si nos sale no admisible no mantenemos el TD stoch, dejamos libertad a Seats if (q.gt.0) then q=q-1 end if init=0 do i=1,n10 fixParam(i)=0 enddo status = 'Z' noadmiss=2 return 1 else if (status .eq. 'G') then d = 1 q = 1 bd = 1 bq = 1 init = 0 type = 1 noadmiss = 2 status = 'F' return 1 end if if (status .eq. 'I') then q = 1 type = 1 init = 0 noadmiss = 2 status = 'H' return 1 end if if ((p.gt.3) .or. (q.gt.3) .or. (d.gt.2) .or. (bp.gt.1) .or. $ (bd.gt.1) .or. (bq.gt.1)) then if (p .gt. 3) then p = 3 end if if (q .gt. 3) then q = 3 end if if (d .gt. 2) then d = 2 end if if (bp .gt. 1) then bp = 1 end if if (bd .gt. 1) then bd = 1 end if if (bq .gt. 1) then bq = 1 end if noadmiss = 2 init = 0 return 1 C C P > 0 REDUCE THE VALUE OF P C else if (p .gt. 0) then rdroot = 0.0d0 do i = 1,p if ((rez(i).gt.0.0d0) .and. dpeq(imz(i),0.0d0)) then rdroot = rez(i) end if end do do i = 1,p if ((rez(i).gt.rdroot) .and. dpeq(imz(i),0.0d0)) then rdroot = rez(i) end if end do if (rdroot .gt. 5.0d-1) then d = MIN(d+1,2) p = p - 1 q = MIN(q+1,p+d,3) init = 0 if (difsOrig.lt.d+bd) then imean=0 end if noadmiss = 2 return 1 else p = p - 1 q = MIN(q+1,p+d,3) init = 0 noadmiss = 2 return 1 end if else C C BP > 0 REDUCE THE VALUE OF BP (aqui siempre p=0) C if (bp .gt. 0) then if (bphi(1).ge.0.0d0.or.bd.gt.0) then bp = 0 bd = MIN(bd+1,1) bq = MIN(bq+1,1) if (bd.eq.0) then imean=0 end if else if (d.ne.1.or.q.ne.1) then if (d.eq.0) then imean=0 end if d=1 q=1 else if (bq.eq.1) then bq=0 else bp=0 end if type = 1 init = 0 noadmiss = 2 return 1 end if if (bd .eq. 0) then if (bq .gt. 0) then bq = 0 type = 1 init = 0 noadmiss = 2 return 1 C C END NEW CORRECTION C C C CASE A) SEE DOCUMENTATION AGUSTIN c (BD=0 BQ=0 P=0 BP=0) C else if (d .eq. 2) then q = MAX(q-1,1) init = 0 noadmiss = 2 return 1 else if (d .eq. 1) then q = MAX(q-1,1) init = 0 noadmiss = 2 return 1 end if C C ELSE BD.EQ.0 C C C CASE B) SEE DOCUMENTATION AGUSTIN (BD=1,P=0,BP=0) C else if (d .eq. 0) then if (q .ge. 2) then q = q-1 type = 1 noadmiss = 2 init = 0 return 1 else d = 1 q = 1 bd = 1 bq = 1 imean = 0 type = 1 init = 0 noadmiss = 2 return 1 end if else if (d .eq. 1) then if (q .gt. 2) then q = 2 type = 1 noadmiss = 2 init = 0 status = 'G' return 1 else q = 1 init = 0 noadmiss = 2 return 1 end if else d = 2 q = q-1 bd = 1 type = 1 init = 0 noadmiss = 2 return 1 end if end if end if end C C subroutine OUTTABLE(titleg,oz,trend,sa,sc,ir,cycle,pread,ceff, $ a,na,hpcyc,hptrend,hpcycle,lamd,nstart,nzs, $ mq,nex,nunits,ilen) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer hpcycle,lamd,nstart,nzs,mq,nex,na,nunits,ilen,EndLoop character titleg*80 real*8 oz(*),trend(*),sa(*),sc(*),ir(*),cycle(*),pread(*),ceff(*), $ hpcyc(*),a(*),hptrend(*) C C.. Local Scalars .. integer i,nperiod,nyear,k,Ncol,nblank real*8 DONE character LongTermCad*22 C C.. Local Arrays .. real*8 eresid(mpkp) real*8 Matrix(mpkp,14) character testo*1280 character tstmp*50 character*2 fdec(21) character*28 frt(6), frthtml(6) character*(100) GetTokenIdx C C.. External Functions .. integer ISTRLEN external ISTRLEN,GetTokenIdx C C.. Intrinsic Functions .. intrinsic EXP, MAX include 'sform.i' include 'preadtr.i' include 'prtous.i' data fdec /'0','1','2','3','4','5','6','7','8','9','10','11', & '12','13','14','15','16','17','18','19','20'/ * data frthtml /'("",', * & '"DATE"', * & ',','b','x',',A)'/ data frt /'(2x,','"DATE"',',','b','x',',A)'/ include 'stream.i' C C ... Executable Statements ... C If (HPcycle.eq.1) then LongTermCad='LONG TERM TREND' else if (HPcycle.eq.2) then LongTermCad='SA series without BC' else LongTermCad='Series without BC' end if testo = ' ' nperiod = Nper nyear = Nyer if ((NZ .eq. 1) .and. (NYER+NPER+NFREQ .eq. 0)) then DONE = -1.0d0 write (36,*) '"',titleg(1:ISTRLEN(titleg)),'"' write (testo,'(2x,''DATE'',11x,A)') 'Failed' write (36,'(A)') testo(1:ISTRLEN(testo)) write (36,'(I2,''-'',I4,64(6X,G18.9))') & 0, 0, DONE return end if if (nunits .ne. 0) then write (36,'(2A,2x,A,i3,2A)') '"',titleg(1:ISTRLEN(titleg)), & '(Series in input file has been multiplied by 10**', & 3*nunits,').','"' else write (36,*) titleg(1:ISTRLEN(TITLEg)) end if Ncol = 0 if (nex .eq. 1) then EndLoop = nzs+ilen else endLoop =nzs end if cc c Print Original Series cc if (xotab.eq.1) then Ncol = Ncol + 1 if (nex .eq. 1) then if (lamd .eq. 0) then do i=nstart, endLoop Matrix(i,Ncol) = EXP(oz(i)) end do else do i=nstart, endLoop Matrix(i,Ncol) =oz(i) end do end if else do i=nstart, endLoop Matrix(i,Ncol) =oz(i) end do end if write (tstmp,'(14x,A)')'Series' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Trend cc if (ptab .eq. 1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,Ncol) =trend(i) end do write (tstmp,'(10x,A)')'TrendCycle' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print SA Series cc if (ntab .eq.1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,Ncol) = sa(i) end do write (tstmp,'(11x,A)')'SA Series' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Seasonal Series cc if (stab .eq. 1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,Ncol) = sc(i) end do write (tstmp,'(12x,A)')'Seasonal' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Calendar Effect cc if (caltab .eq. 1) then ncol=ncol+1 if (lamd .eq. 0) then do i=nstart, endLoop Matrix(i,Ncol) = ceff(i)*100.0d0 end do else do i=nstart, endLoop Matrix(i,Ncol) = ceff(i) end do end if write (tstmp,'(12x,A)')'Calendar' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Peradjusted components cc if (patab .eq. 1) then ncol=ncol+1 if (nex .eq. 1) then if (lamd .eq. 0) then do i=nstart, endLoop Matrix(i,ncol) = 100.0d0 enddo else do i=nstart, endLoop Matrix(i,ncol) = 0.0d0 enddo end if else do i=nstart, endLoop Matrix(i,ncol) = pread(i) enddo end if write (tstmp,'(11x,A)')'Preadjust' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c If HPCYCLE >= 1 Print Long Term Trend and Business Cycle cc if (hpcycle .ge. 1) then cc c Print Business Cycle cc if (cytab .eq. 1) then ncol=ncol+1 if (nex .eq. 1) then do i = nstart,nzs+ilen/2 Matrix(i,ncol) = hpcyc(i) enddo do i=nzs+ilen/2+1,ilen Matrix(i,ncol) = 0.0d0 enddo else do i= nstart,nzs Matrix(i,ncol) = hpcyc(i) enddo end if write (tstmp,'(15x,A)')'Cycle' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Long Term Trend cc if (ltptab .eq. 1) then ncol=ncol+1 if (nex .eq. 1) then do i = nstart,nzs+ilen/2 Matrix(i,ncol) = hptrend(i) enddo do i=nzs+ilen/2+1,ilen Matrix(i,ncol) = 0.0d0 enddo else do i= nstart,nzs Matrix(i,ncol) = hptrend(i) enddo end if write (tstmp,'(5x,A)')LongTermCad(1:Istrlen(LongTermCad)) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if end if cc c Print Extended residuals cc if (ertab .eq. 1) then k = nzs - na if (k .ge.0) then do i = 1, k eresid(i)=0.0d0 end do do i = 1, na eresid(k+i)=a(i) end do do i = na+k+1, nzs+ilen eresid(i) = 0.0d0 end do else do i = -k+1, na eresid (i+k) = a(i) end do do i = nzs+1, nzs+ilen eresid(i) = 0.0d0 end do end if ncol=ncol+1 do i=nstart, endLoop Matrix(i,ncol) = eresid(i) enddo write (tstmp,'(13x,A)')'E-Resid' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Separate Effect Regression Component cc if (rg0tab .eq. 1) then ncol=ncol+1 if (lamd .eq. 1) then do i=nstart, endLoop Matrix(i,ncol) = pareg(i,0) enddo else do i=nstart, endLoop Matrix(i,ncol) = pareg(i,0)*100.0d0 enddo end if write (tstmp,'(6x,A)')'Sep. REG Comp.' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print SA Effect Regression Component cc if (rgsatab .eq. 1) then ncol=ncol+1 if (lamd .eq. 1) then do i=nstart, endLoop Matrix(i,ncol) = pareg(i,4) enddo else do i=nstart, endLoop Matrix(i,ncol) = pareg(i,4)*100.0d0 enddo end if write (tstmp,'(5x,A)')'REG Comp. in SA' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print all the matrix cc call LEFTTRIM(testo) nblank = 16-istrlen(GetTokenidx(testo,1))+2 frt(4) = fdec(nblank) write (36,frt)testo(1:ISTRLEN(testo)) do I = 1,endLoop write (36,'(I2,''-'',I4,64(2X,G18.9))') & nperiod, nyear, (Matrix(I,K),K=1,Ncol) nperiod = nperiod + 1 if (nperiod .gt. mq) then nperiod = 1 nyear = nyear + 1 end if end do return end C C subroutine OUTTABFOR(ftr,fsa,fs,fir,fcyc,pread,ceff,hpcyc, $ hptrend,hpcycle,lamd,nstart,nf,nzs,mq, $ strend,ssa,fosa) C C.. Implicits .. implicit none INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer hpcycle,lamd,nstart,nf,nzs,mq real*8 ftr(-kp:kp),fsa(-kp:kp),fs(-kp:kp),fir(-kp:kp), $ fcyc(-kp:kp),pread(*),ceff(*),hpcyc(*),hptrend(*), $ strend(*),ssa(*),fosa(*) C C.. Local Scalars .. integer i,nperiod,nyear,Ncol,k character tstmp*120 include 'sform.i' include 'preadtr.i' include 'prtous.i' include 'stream.i' include 'bench.i' C C.. Local Arrays .. real*8 Matrix(Kp,18) character*2 fdec(0:20) c c data fdec /'0','1','2','3','4','5','6','7','8','9','10','11', & '12','13','14','15','16','17','18','19','20'/ C C ... Executable Statements ... C nperiod = Nper nyear = Nyer do i = 1,nzs nperiod = nperiod + 1 if (nperiod .gt. mq) then nperiod = 1 nyear = nyear + 1 end if end do Ncol = 0 cc c Print Original Series Forecast cc if (xotab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,Ncol) = tram(nzs+i) end do end if cc c Print Trend Forecast cc if (ptab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,Ncol) =ftr(i) end do end if c Real-Time Trend Estimator cc if (rtptab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,Ncol) =0.0d0 end do end if cc cc c Print SA Series Forecast cc if (ntab .eq.1) then ncol=ncol+1 do i=nstart, nf Matrix(i,Ncol) = fsa(i) end do end if cc c Real-Time SA Series Estimator cc if (rtsatab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,Ncol) =0.0d0 end do end if cc c Print SA Yearly Revised Series Forecast cc if ((BcMark.eq.1).and.((Mq.eq.4).or.(Mq.eq.12))) then if (ntab .eq.1) then ncol=ncol+1 do i=nstart, nf Matrix(i,Ncol) = fosa(nzs+i) end do end if end if cc c Print Seasonal Forecast cc if (stab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,Ncol) = fs(i) end do end if cc c Print Calendar Forecast cc if (caltab .eq. 1) then ncol=ncol+1 if (lamd .eq. 0) then do i=nstart, nf Matrix(i,Ncol) = ceff(nzs+i)*100.0d0 end do else do i=nstart, nf Matrix(i,Ncol) = ceff(nzs+i) end do end if end if cc c Print Ir Forecast cc if (utab .eq. 1) then ncol=ncol+1 do i=nstart,nf Matrix(i,ncol)=fir(i) end do end if cc c Print Transtory cc if (ctab .eq. 1) then ncol=ncol+1 do i=nstart,nf Matrix(i,ncol)=fcyc(i) end do end if cc c Print Preadjusted Forecast cc if (patab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,ncol) = pread(nzs+i) enddo end if cc c If HPCYCLE >= 1 Print Business Cycle and Long Trend Term cc if (hpcycle .ge. 1) then cc c Print Business Cycle forecast cc if (cytab .eq. 1) then ncol=ncol+1 do i = nstart,nf Matrix(i,ncol) = hpcyc(nzs+i) enddo end if cc c Print Long Term Trend Forecast cc if (ltptab .eq. 1) then ncol=ncol+1 do i= nstart,nf Matrix(i,ncol) = hptrend(Nzs+i) enddo end if end if cc c Extended residuals forecast (all zero) cc if (ertab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,ncol) = 0.0d0 enddo end if cc c Print Separate Regression Effect Forecast cc if (rg0tab .eq. 1) then ncol=ncol+1 if (lamd .eq. 0) then do i=nstart, nf Matrix(i,ncol) = pareg(nzs+i,0)*100.0d0 enddo else do i=nstart, nf Matrix(i,ncol) = pareg(nzs+i,0) enddo end if end if cc c Print SA Regression Effect Forecast cc if (rgsatab .eq. 1) then ncol=ncol+1 if (lamd .eq. 0) then do i=nstart, nf Matrix(i,ncol) = pareg(nzs+i,4)*100.0d0 enddo else do i=nstart, nf Matrix(i,ncol) = pareg(nzs+i,4) enddo end if end if cc c Print Stochastic Trend-Cycle Forecast cc if (stptab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,ncol) = strend(nzs+i) enddo end if cc c Print Stochastic SA Forecast cc if (stntab .eq. 1) then ncol=ncol+1 do i=nstart, nf Matrix(i,ncol) = ssa(nzs+i) enddo end if do I = 1,nf write (36,'(I2,''-'',I4,64(2X,G18.9))') & nperiod, nyear, (Matrix(I,K),K=1,Ncol) nperiod = nperiod + 1 if (nperiod .gt. mq) then nperiod = 1 nyear = nyear + 1 end if end do return end CC C CC subroutine CheckLen(OZ,NZ,Mq,IsOk) C C.. Implicits .. implicit none C C.. Formal Arguments .. real*8 OZ(*) integer NZ,Mq,IsOk C C.. Local Scalars .. integer i,nfirst,nlast,nzmin,noa,kk1,kk2 C C.. Intrinsic Functions .. intrinsic MAX C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C .. nfirst=0 nlast=0 do i=1,NZ if ((.not.dpeq(OZ(i),-99999.0d0)) .and. (nfirst .eq. 0)) then nfirst=i nlast=i end if if ((.not.dpeq(OZ(i),-99999.0d0)) .and. (nfirst .ne. 0)) then nlast=i end if end do nzmin = 0 noa = 0 do i=nfirst,nlast if (.not.dpeq(OZ(i),-99999.0d0)) then nzmin = nzmin + 1 else noa = noa + 1 end if end do if (Mq .eq. 12) then kk1 = 36 kk2 = 30 else kk1 = max(12, 4*Mq) kk2 = max (8, 3*Mq) end if if ((nzmin .ge. kk1) .and. (nzmin-noa .ge. kk2)) then IsOk = 1 end if return end CC c CC subroutine LEFTTRIM(string) C C.. Implicits .. C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Maybe Written .. character*(*) string C C.. Local Scalars .. integer i,jlen,fnoblank C C.. External Functions .. integer ISTRLEN external ISTRLEN C C ... Executable Statements ... C CC C CC jlen = ISTRLEN(string) fnoblank = 0 do i = 1,jlen if (string(i:i).ne.' ') then fnoblank = i goto 10 end if end do 10 if (fnoblank .gt. 1) then do i=fnoblank,jlen string(i-fnoblank+1:i-fnoblank+1) = string(i:i) end do do i=jlen-fnoblank+2,jlen string(i:i)= ' ' end do end if end CC C CC subroutine OUTTABLE2(titleg,oz,trend,sa,sc,ir,cycle,pread,ceff, $ a,na,hpcyc,hptrend,hpcycle,lamd,nstart,nzs, $ mq,nex,nunits,ilen,strend,ssa,fosa,IsCloseToTD) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer hpcycle,lamd,nstart,nzs,mq,nex,na,nunits,ilen,EndLoop character titleg*80 real*8 oz(*),trend(*),sa(*),sc(*),ir(*),cycle(*),pread(*),ceff(*), $ hpcyc(*),a(*),hptrend(*),ssa(*),strend(*),fosa(*) logical IsCloseToTD C C.. Local Scalars .. integer i,nperiod,nyear,k,Ncol,nblank real*8 DONE character LongTermCad*22 character cad1*80 C C.. Local Arrays .. real*8 eresid(mpkp) real*8 Matrix(mpkp,18) character testo*1280 character tstmp*50 character*2 fdec(21) character*28 frt(6) character*(100) GetTokenIdx character*100 lineFormat C C.. External Functions .. integer ISTRLEN external ISTRLEN,GetTokenIdx C C.. Intrinsic Functions .. intrinsic EXP, MAX include 'sform.i' include 'preadtr.i' include 'rtestm.i' include 'prtous.i' data fdec /'0','1','2','3','4','5','6','7','8','9','10','11', & '12','13','14','15','16','17','18','19','20'/ * data frthtml /'('''',', * & '''DATE''', * & ',','b','x',',A)'/ data frt /'(2x,','"DATE"',',','b','x',',A)'/ include 'stream.i' include 'bench.i' C C ... Executable Statements ... C If (HPcycle.eq.1) then LongTermCad='LONG TERM TREND' else if (HPcycle.eq.2) then LongTermCad='SA series without BC' else LongTermCad='Series without BC' end if testo = ' ' nperiod = Nper nyear = Nyer if ((NZ .eq. 1) .and. (NYER+NPER+NFREQ .eq. 0)) then DONE = -1.0d0 write (36,*) '"',titleg(1:ISTRLEN(titleg)),'"' write (testo,'(2x,''DATE'',11x,A)') 'Failed' write (36,'(A)') testo(1:ISTRLEN(testo)) write (36,'(I2,''-'',I4,64(6X,G18.9))') & 0, 0, DONE return end if if (nunits .ne. 0) then write (36,'(2A,2x,A,i3,2A)') '"',titleg(1:ISTRLEN(titleg)), & '(Series in input file has been multiplied by 10**', & 3*nunits,').','"' else write (36,*) '"',titleg(1:ISTRLEN(titleg)),'"' end if Ncol = 0 if (nex .eq. 1) then EndLoop = nzs+ilen else endLoop =nzs end if cc c Print Original Series cc if (xotab.eq.1) then Ncol = Ncol + 1 if (nex .eq. 1) then if (lamd .eq. 0) then do i=nstart, endLoop Matrix(i,Ncol) = EXP(oz(i)) end do else do i=nstart, endLoop Matrix(i,Ncol) =oz(i) end do end if else do i=nstart, endLoop Matrix(i,Ncol) =oz(i) end do end if write (tstmp,'(14x,A)')'Series' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Trend cc if (ptab .eq. 1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,Ncol) =trend(i) end do write (tstmp,'(10x,A)')'TrendCycle' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print RealTimeTrend cc if (rtptab .eq. 1) then ncol=ncol+1 do i=nstart, nzs-nrt-1 Matrix(i,Ncol) =0.0d0 end do do i=1,nrt Matrix(nzs-nrt-1+i,Ncol) = RTtre(i) end do do i=nzs,nzs+ilen Matrix(i,Ncol) =0.0d0 end do write (tstmp,'(2x,A)')'RealTimeTrendCycle' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print SA Series cc if (ntab .eq.1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,Ncol) = sa(i) end do write (tstmp,'(11x,A)')'SA Series' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print RealTime SA Series cc if (rtsatab .eq. 1) then ncol=ncol+1 do i=nstart, nzs-nrt-1 Matrix(i,Ncol) =0.0d0 end do do i=1,nrt Matrix(nzs-nrt-1+i,Ncol) = RTsa(i) end do do i=nzs,nzs+ilen Matrix(i,Ncol) =0.0d0 end do write (tstmp,'(2x,A)')'RealTime SA Series' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print SA Series Yearly Revised cc if ((BcMark .eq. 1) .and. ((Mq .eq.4).or.(Mq .eq.12))) then if (ntab .eq.1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,Ncol) = fosa(i) end do write (tstmp,'(7x,A)')'Y. Revised SA' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if end if cc c Print Seasonal Series cc if (stab .eq. 1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,Ncol) = sc(i) end do write (tstmp,'(12x,A)')'Seasonal' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Calendar Effect cc if (caltab .eq. 1) then ncol=ncol+1 if (lamd .eq. 0) then do i=nstart, endLoop Matrix(i,Ncol) = ceff(i)*100.0d0 end do else do i=nstart, endLoop Matrix(i,Ncol) = ceff(i) end do end if write (tstmp,'(12x,A)')'Calendar' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Irregular component cc if (utab .eq. 1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,ncol) = ir(i) end do write (tstmp,'(11x,A)')'Irregular' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Transitory component cc if (ctab .eq. 1) then if (IsCloseToTD) then cad1='finalTD' else cad1='Transitory' end if ncol=ncol+1 do i=nstart, endLoop Matrix(i,ncol) = cycle(i) end do write (tstmp,'(10x,A)')cad1(1:istrlen(cad1)) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Peradjusted components cc if (patab .eq. 1) then ncol=ncol+1 if (nex .eq. 1) then if (lamd .eq. 0) then do i=nstart, endLoop Matrix(i,ncol) = 100.0d0 enddo else do i=nstart, endLoop Matrix(i,ncol) = 0.0d0 enddo end if else do i=nstart, endLoop Matrix(i,ncol) = pread(i) enddo end if write (tstmp,'(11x,A)')'Preadjust' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c If HPCYCLE >= 1 Print Long Term Trend and Business Cycle cc if (hpcycle .ge. 1) then cc c Print Long Term Trend cc if (cytab .eq. 1) then ncol=ncol+1 if (nex .eq. 1) then do i = nstart,nzs+ilen/2 Matrix(i,ncol) = hpcyc(i) enddo do i=nzs+ilen/2+1,nzs+ilen Matrix(i,ncol) = 0.0d0 enddo else do i= nstart,nzs Matrix(i,ncol) = hpcyc(i) enddo end if write (tstmp,'(15x,A)')'Cycle' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Business Cycle cc if (ltptab .eq. 1) then ncol=ncol+1 if (nex .eq. 1) then do i = nstart,nzs+ilen/2 Matrix(i,ncol) = hptrend(i) enddo do i=nzs+ilen/2+1,nzs+ilen Matrix(i,ncol) = 0.0d0 enddo else do i= nstart,nzs Matrix(i,ncol) = hptrend(i) enddo end if write (tstmp,'(5x,A)')LongTermCad(1:istrlen(LongTermCad)) testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if end if cc c Print Extended residuals cc if (ertab .eq. 1) then k = nzs - na if (k .ge.0) then do i = 1, k eresid(i)=0.0d0 end do do i = 1, na eresid(k+i)=a(i) end do do i = na+k+1, nzs+ilen eresid(i) = 0.0d0 end do else do i = -k+1, na eresid (i+k) = a(i) end do do i = nzs+1, nzs+ilen eresid(i) = 0.0d0 end do end if ncol=ncol+1 do i=nstart, endLoop Matrix(i,ncol) = eresid(i) enddo write (tstmp,'(13x,A)')'E-Resid' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Separate Effect Regression Component cc if (rg0tab .eq. 1) then ncol=ncol+1 if (lamd .eq. 1) then do i=nstart, endLoop Matrix(i,ncol) = pareg(i,0) enddo else do i=nstart, endLoop Matrix(i,ncol) = pareg(i,0)*100.0d0 enddo end if write (tstmp,'(6x,A)')'Sep. REG Comp.' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print SA Effect Regression Component cc if (rgsatab .eq. 1) then ncol=ncol+1 if (lamd .eq. 1) then do i=nstart, endLoop Matrix(i,ncol) = pareg(i,4) enddo else do i=nstart, endLoop Matrix(i,ncol) = pareg(i,4)*100.0d0 enddo end if write (tstmp,'(4x,A)') 'REG Comp. in SA' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc rober cc c Print Stochastic Trend-Cycle cc if (stptab .eq. 1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,ncol) = strend(i) enddo write (tstmp,'(4x,A)')'Stoch TrendCycle' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print Stochastic SA cc if (stntab .eq. 1) then ncol=ncol+1 do i=nstart, endLoop Matrix(i,ncol) = ssa(i) enddo write (tstmp,'(5x,A)')'Stoch. SASeries' testo(istrlen(testo)+1:istrlen(testo)+istrlen(tstmp))=tstmp end if cc c Print all the matrix cc call LEFTTRIM(testo) nblank = 16-istrlen(GetTokenidx(testo,1))+2 frt(4) = fdec(nblank) write (36,frt) testo(1:ISTRLEN(testo)) do I = 1,endLoop write (36,'(I2,''-'',I4,64(2X,G18.9))') & nperiod, nyear, (Matrix(I,K),K=1,Ncol) nperiod = nperiod + 1 if (nperiod .gt. mq) then nperiod = 1 nyear = nyear + 1 end if end do return end C cc c cc integer function KnownApprox(p,q,d,bd,bp,bq,init,noadmiss, $ th,bth,phi,bphi,mq,status) C C.. Implicits .. implicit none c parameters integer n1 parameter (n1=1) C C.. Formal Arguments .. integer p,q,d,bd,bp,bq,init,noadmiss,mq character status real*8 th(*),bth(*),phi(*),bphi(*) C C integer pBak,dBak,qBak,bpBak,bdBak,bqBak real*8 phiBak(3*n1),thBak(3*n1),bphiBak(3*n1),bthBak(3*n1) common /ARMAbak/ phiBak,thBak,bphiBak,bthBak,pBak, $ dBak,qBak,bpBak,bdBak,bqBak c locals integer i C C ... Executable Statements ... C c Th y bth entran con sus coeficientes *(-1) KnownApprox=0 if (status.ne.'J') then do i=1,3 thBak(i)=th(i) bthBak(i)=bth(i) phiBak(i)=phi(i) bphibak(i)=bphi(i) pBak=p dBak=d qBak=q bpBak=bp bdBak=bd bqBak=bq enddo if ((bp.eq.0).and.(bd.eq.1)) then c (001) (011) mq=4 if ((p.eq.0).and.(d.eq.0).and.(q.le.1).and.(mq.eq.4)) then init=2 bq=0 Bth(1) = 0.0d0 noadmiss=2 KnownApprox=2 c (110)(010) mq=12 else if((p.eq.1).and.(d.eq.1).and.(q.eq.0).and.(bq.eq.0) & .and. (mq.eq.12)) then phi(1)=0.55 noadmiss=2 KnownApprox=2 init=2 c (110)(011) o (010)(011) mq=12 else if((p.le.1).and.(d.eq.1).and.(q.eq.0).and.(bq.eq.1)) then if (mq.eq.12) then if (phi(1).le.0.15d0) then bth(1)=0 bq=0 else if (phi(1).le.0.33d0) then if (bth(1).lt.0.d0) then bth(1)=0.d0 bq=0 else phi(1)=0.15d0 end if else if(phi(1).le.0.5d0) then phi(1)=0.5d0 if (bth(1).lt.0.d0) then bth(1)=0.d0 bq=0 end if else bth(1)=phi(1)+phi(1)-1 end if noadmiss=2 init = 2 status='J' KnownApprox= 2 c (110)(011) mq=4 else if (mq.eq.4) then if (phi(1).le.-0.5d0) then bth(1)=-0.35d0 else if (phi(1).le.-0.15d0) then bth(1)= -phi(1)-0.4d0 if (abs(bth(1)).lt.1.d-5) then bth(1)=0.d0 bq=0 end if else if (phi(1).le.0.15d0) then bth(1)=-0.25d0 else if (phi(1).le.0.33d0) then phi(1)=0.15d0 if (bth(1).lt.-0.2d0) then bth(1)=-0.2d0 end if else if (phi(1).lt.0.5d0) then phi(1)=0.5d0 if (bth(1).lt.0.d0) then bq=0 bth(1)=0.0d0 end if else bth(1)=-0.3d0 end if noadmiss=2 init = 2 status='J' KnownApprox=2 end if c c mq=12 (001)(011) o (100)(011) c else if ((mq.eq.4).and.((p.eq.1).or.(p.eq.0)) c .and.(d.eq.2).and.(q.eq.0)) then c if (phi(1).le.-0.5d0) then c bth(1)=-0.4d0 c elseif (phi(1).lt.-0.35d0) then c bth(1)=-0.15d0 c elseif (phi(1).le.0.1d0) then c if (bth(1).gt.0.95d0) then c bth(1)=0.95d0 c else c bth(1)=-0.35d0 c end if c elseif (phi(1).lt.0.3d0) then c bq=0 c bth(1)=0.d0 c elseif (phi(1).le.0.5d0) then c phi(1)=0.5d0 c if (bth(1).lt.-0.2d0) then c bth(1)=-0.2d0 c end if c else c bq=0 c bth(1)=0.d0 c end if c init=2 c noadmiss=2 c status='J' c KnownApprox= 2 c******** c mq=4 (100)(011) else if ((mq.eq.4).and.(p.eq.1).and.(d.eq.0).and.(q.eq.0)) then if (bth(1) .gt.0.95d0) then bth(1)=0.95 else if ((phi(1).lt.0.45d0).and.(phi(1).gt.-0.65)) then bth(1)=0 bq=0 else if (phi(1).le.-0.65) then bth(1)=-0.15d0 else if (phi(1).ge.0.45) then bth(1)=-0.3d0 end if end if init=2 noadmiss=2 status='J' KnownApprox= 2 c lineas aereas else if ((p.eq.0).and.((q.eq.1).or.(q.eq.0)) & .and.((d.eq.1).or.(d.eq.2))) then init = 2 if (d .eq. 2) then if (mq .eq. 12) then if (-bth(1) .gt. -1.0d-1) then bth(1) = 1.0d-1 end if if (-th(1) .gt. ((-5.0d0/9.0d0)*(-bth(1)+1.0d0))) then th(1) = 5.0d0 / 9.0d0 * (-bth(1)+1.0d0) q=1 end if elseif (mq .eq. 4) then if (-bth(1) .gt. -1.0d-1) then bth(1) = 1.0d-1 end if if (-th(1) .gt. ((-3.0d0/11.0d0)*(-bth(1)+.1d0)+0.6d0)) then th(1) = 3.0d0/11.0d0*(-bth(1)+.1d0) + .6d0 q=1 end if end if end if if (abs(th(1)) .gt. 1.0d0) then init = 1 endif noadmiss = 2 KnownApprox= 2 if (bth(1) .lt. 0.0d0) then BQ=0 KnownApprox= 1 end if end if end if else noadmiss=-1 do i=1,3 th(i)=thBak(i) bth(i)=bthBak(i) phi(i)=phiBak(i) bphi(i)=bphibak(i) p=pBak dBak=d q=qBak bp=bpBak bd=bdBak bq=bqBak enddo c if (html.eq.1) then c luego ya pondremos un mensaje mas explicativo c write(nio,'(''

NOADMISS changed to -1

'')') c else c write(nio,*) c write(nio,*) 'NOADMISS changed to -1' c end if KnownApprox=1 end if end ansub7.f0000664006604000003110000003554714521201407011551 0ustar sun00315stepsC C C REMOVED AMI SUBROUTINE - BCM June 2001 C C C subroutine MOCOMPARE(p,q,d,bd,bq,bp,imean,prec) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer p,q,d,bd,bq,bp,imean real*8 prec C C.. Local Scalars .. integer i,ndvmin,nstart real*8 dvmin,qxmin,sgmin C C.. Local Arrays .. real*8 dvalue(4) include 'amic.i' C C ... Executable Statements ... C if ((0.0d0.lt.prec) .or. (1.0d0.gt.prec)) then prec = 0.5d0 end if qxmin = 1.0d12 do i = 1,4 nstart = (i-1)*2 + 1 if (Statistics(nstart) .lt. qxmin) then qxmin = Statistics(nstart) sgmin = Statistics(nstart+1) end if end do do i = 1,4 nstart = (i-1)*2 + 1 Statistics(nstart) = Statistics(nstart) / sgmin Statistics(nstart+1) = Statistics(nstart+1) / sgmin end do do i = 1,4 nstart = (i-1)*2 + 1 dvalue(i) = $ prec*Statistics(nstart+1) + (1-prec)*Statistics(nstart) end do dvmin = 1.0d12 do i = 1,4 if (dvalue(i) .lt. dvmin) then dvmin = dvalue(i) ndvmin = i end if end do C C NOW WE RETORE THE BEST MODEL C nstart = (ndvmin-1)*7 + 1 p = Models(nstart) d = Models(nstart+1) q = Models(nstart+2) bp = Models(nstart+3) bd = Models(nstart+4) bq = Models(nstart+5) imean = Models(nstart+6) end C C C subroutine SETMODEL(p,d,q,bp,bd,bq,imean,nmodel) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer p,d,q,bp,bd,bq,imean,nmodel C C.. Local Scalars .. integer nstart C C.. Local Arrays .. integer models(28) C C.. Data Declarations .. C THE STRUCTURE OF THE MATRIX IS : C P,D,Q,BP,BD,BQ,IMEAN C data models/ $0,1,1,0,1,1,1,0,2,2,0,1,1,0,3,2,2,0,1,1,0,3,1,1,0,1,1,1/ C First Model C Second Model C Third Model C C ... Executable Statements ... C C Fourth Model C nstart = (nmodel-1)*7 + 1 p = models(nstart) d = models(nstart+1) q = models(nstart+2) bp = models(nstart+3) bd = models(nstart+4) bq = models(nstart+5) imean = models(nstart+6) end C subroutine STOREMODEL(p,d,q,bp,bd,bq,imean,sqf,qbox,nmodel) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer p,d,q,bp,bd,bq,imean,nmodel real*8 sqf,qbox C C.. Local Scalars .. integer nstart include 'amic.i' C C ... Executable Statements ... C C THE STRUCTURE OF THE ARRAY MODELS IS : C P,D,Q,BP,BD,BQ,IMEAN C nstart = (nmodel-1)*7 + 1 Models(nstart) = p Models(nstart+1) = d Models(nstart+2) = q Models(nstart+3) = bp Models(nstart+4) = bd Models(nstart+5) = bq Models(nstart+6) = imean nstart = (nmodel-1)*2 + 1 Statistics(nstart) = qbox Statistics(nstart+1) = sqf end C C integer function CHECKADM(p,q,bp,bq,d,bd,th,bth,phi,bphi,mq,rmod, $ epsphi,varwnc,out) C C.. Implicits .. implicit none C C.. Parameters .. integer n1,n12 parameter (n12 = 12, n1 = 1) C C.. Formal Arguments .. integer p,q,bp,bq,d,bd,mq,out real*8 th(*),bth(*),phi(*),bphi(*),rmod,epsphi,varwnc C C.. Local Scalars .. integer i,j,jk,k,nbths,nchi,nchins,nchis,ncyc,ncycns,ncycs,nphis, $ npsi,npsins,npsis,nths,pstar,qstar,dumInt real*8 cmu,dplusd logical root0c,rootPIc,rootPIs,IsCloseToTD C C.. Local Arrays .. real*8 ar(5*n12+n12/3),bths(2*n12+1),chi(8),chins(8),chis(5), $ cyc(17),cycns(5),cycs(17),dum(80),imz(5*n12+n12/3), $ modul(5*n12+n12/3),phis(4*n1),pr(5*n12+n12/3),psi(27), $ psins(27),psis(16),rez(5*n12+n12/3),ths(4*n1),thstar(40) C C.. External Functions .. integer CHKSPCT external CHKSPCT C C.. External Calls .. external CONV, F1RST, RPQ C C.. Intrinsic Functions .. intrinsic ABS C LINES OF CODE ADDED FOR X-13A-S : 1 include 'error.cmn' C END OF CODE BLOCK C C ... Executable Statements ... C C C C dumInt=3 if (p .gt. 0) then phis(1) = 1.d0 do i = 1,p phis(i+1) = -phi(i) end do nphis = p + 1 call RPQ(phis,nphis,rez,imz,modul,ar,pr,0,out) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK end if ths(1) = 1.0d0 do i = 1,q ths(i+1) = -th(i) end do nths = q + 1 bths(1) = 1.0d0 do i = 1,bq j = i*mq + 1 bths(j) = -bth(i) do k = 2,mq jk = k + mq*(i-1) bths(jk) = 0.0d0 end do end do nbths = bq*mq + 1 C C COMPUTE THE MODEL FOR THE COMPONENTS C pstar = p + d + mq*(bd+bp) + 1 call CONV(ths,nths,bths,nbths,thstar,qstar) chins(1) = 1.0d0 dplusd = d + bd do i = 1,INT(dplusd) chins(i+1) = 0.0d0 do j = 1,i k = i - j + 2 chins(k) = chins(k) - chins(k-1) end do end do nchins = dplusd + 1 chis(1) = 1.0d0 nchis = 1 if (bp .ne. 0) then cmu = (-bphi(mq+1))**(1.0d0/mq) dum(1) = 1.0d0 dum(2) = -cmu if (ABS(1.0d0-cmu) .lt. 1.0d-13) then call CONV(dum,2,chins,nchins,chins,nchins) else call CONV(dum,2,chis,nchis,chis,nchis) end if end if psins(1) = 1.0d0 do i = 2,27 psins(i) = 0.0d0 psi(i) = 0.0d0 end do npsins = 1 psis(1) = 1.0d0 npsis = 1 if (bd .ne. 0) then do i = 1,mq dum(i) = 1.0d0 end do call CONV(dum,mq,psins,npsins,psins,npsins) if (bd .ne. 1) then call CONV(dum,mq,psins,npsins,psins,npsins) goto 5000 end if end if if (bp .ne. 0) then dum(1) = 1.0d0 do i = 2,mq dum(i) = cmu * dum(i-1) end do if (ABS(1.0d0-cmu) .lt. 1.0d-13) then call CONV(dum,mq,psins,npsins,psins,npsins) else call CONV(dum,mq,psis,npsis,psis,npsis) end if end if 5000 cycs(1) = 1.0d0 cycns(1) = 1.0d0 ncycs = 1 ncycns = 1 C C COMPUTATION OF THE STATIONARY AND NON-STATIONARY (IF UNIT ROOTS) C DENOMINATOR OF THE COMPONENTS C IsCloseToTD=.FALSE. call F1RST(p,imz,rez,ar,epsphi,mq,cycns,ncycns,psins,npsins,cycs, $ ncycs,chins,nchins,chis,nchis,modul,psis,npsis,rmod, $ root0c,rootPIc,rootPIs,IsCloseToTD) C C call CONV(chis,nchis,chins,nchins,chi,nchi) call CONV(psis,npsis,psins,npsins,psi,npsi) call CONV(cycs,ncycs,cycns,ncycns,cyc,ncyc) C C CHECKADM = CHKSPCT(thstar,qstar,chi,nchi,cyc,ncyc,psi,npsi,pstar, $ mq,d,bd,varwnc) end C C C C integer function CHKSPCT(thstar,qstar,chi,nchi,cyc,ncyc,psi,npsi, $ pstar,mq,d,bd,varwnc) C C.. Implicits .. implicit none include 'srslen.prm' include 'dimensions.i' C C.. Formal Arguments .. integer qstar,nchi,ncyc,npsi,pstar,mq,d,bd real*8 thstar(maxTh),chi(8),cyc(5),psi(27),varwnc C C.. Local Scalars .. integer i,ipipp,j,jmq,jsfix,ncycth,ndum,nn,nqt,nrt,nu,nus,nvn real*8 ce1,ce2,cexmin1,cexmin2,e1,e2,enoc,enot,estar,exmin1, $ exmin2,pi,qmin,qt1,lb,ub,exmin7 cc c (Roberto Lopez: New 01/2006 cc outputs minimGrid) real*8 ce3,cexmin3,e3,exmin3 integer doMinimGrid,n_Step parameter (doMinimGrid = 1) cc c cc integer ixmin C C.. Local Arrays .. integer iconv(7),jconv(4) real*8 dum(80),efmin(7),exmin(7),fn(8),qt(32),rt(32),u(22),us(50), $ vn(80) C C.. External Calls .. external CONJ, DIVFCN, MINIM, MULTFN, PARFRA, GLOBALMINIM, $ MINIMGRID C C.. Intrinsic Functions .. intrinsic MAX, MIN include 'func.i' include 'func2.i' include 'func3.i' include 'func4.i' include 'min.i' include 'test.i' C C ... Executable Statements ... C jsfix = 0 ncycth = 0 pi = 3.14159265358979D0 call CONJ(thstar,qstar,thstar,qstar,Ff,Nf) call CONJ(chi,nchi,chi,nchi,Ft,Nt) call CONJ(cyc,ncyc,cyc,ncyc,Fc,Nc) call CONJ(psi,npsi,psi,npsi,Fs,Ns) call MULTFN(Ft,Nt,Fc,Nc,fn,nn) call MULTFN(fn,nn,Fs,Ns,Fh,Nh) if (qstar .lt. pstar) then nqt = 1 qt(1) = 0.0d0 do i = 1,qstar rt(i) = Ff(i) end do j = qstar + 1 do i = j,pstar rt(i) = 0.0d0 end do nrt = pstar else call DIVFCN(Ff,Nf,Fh,Nh,qt,nqt,rt,nrt) end if if (npsi .eq. 1) then jsfix = 1 end if if (mq .eq. 1) then jsfix = 1 end if C C 8484 IS THE END OF COMPUTATION OF NUMERATORS OF SPECTRA COMPONENTS C if (jsfix.eq.1 .and. ncyc.eq.1 .and. ncycth.eq.0 .and. nchi.gt.1) $ then do i = 1,nrt Ut(i) = rt(i) end do Nut = nrt estar = 0.0d0 enoc = 0.0d0 C else if (jsfix.ne.1 .and. ncyc.eq.1 .and. ncycth.eq.0 .and. $ nchi.eq.1) then do i = 1,nrt V(i) = rt(i) end do Nv = nrt enot = 0.0d0 enoc = 0.0d0 C else if (jsfix.eq.1 .and. ncycth.eq.0 .and. $ (varwnc.gt.1.0D-10 .and. ncyc.gt.1 ) $ .and.nchi.eq.1) then do i = 1,nrt Uc(i) = rt(i) end do Nuc = nrt estar = 0.0d0 enot = 0.0d0 C C else if (jsfix.ne.1 .and. ncycth.eq.0 .and. $ varwnc.gt.1.0D-10 .and. ncyc.gt.1 .and.nchi.gt.1) then call PARFRA(rt,nrt,fn,nn,Fs,Ns,u,nu,V,Nv) call MULTFN(u,nu,Fs,Ns,us,nus) call MULTFN(V,Nv,fn,nn,vn,nvn) do i = 1,nus dum(i) = rt(i) - us(i) - vn(i) end do C C FIND H.C.F OF FT(X) AND FC(X) C ipipp = ncyc + nchi - 1 do i = nu+1,ipipp u(i) = 0.0d0 end do nu = ipipp call PARFRA(u,nu,Fc,Nc,Ft,Nt,Uc,Nuc,Ut,Nut) call MULTFN(Uc,Nuc,Ft,Nt,us,nus) call MULTFN(Ut,Nut,Fc,Nc,vn,nvn) do i = 1,nu dum(i) = u(i) - us(i) - vn(i) end do C else if (jsfix.eq.1 .and. ncycth.eq.0 .and. $ varwnc.gt.1.0D-10 .and.ncyc.gt.1 .and.nchi.gt.1) then C call PARFRA(rt,nrt,Ft,Nt,Fc,Nc,Ut,Nut,Uc,Nuc) call MULTFN(Uc,Nuc,Ft,Nt,us,nus) call MULTFN(Ut,Nut,Fc,Nc,vn,nvn) do i = 1,nus dum(i) = rt(i) - us(i) - vn(i) end do estar = 0.0d0 else if (jsfix.ne.1 .and. ncycth.eq.0 .and. $ varwnc.gt.1.0D-10 .and.ncyc.gt.1 .and.nchi.eq.1) then call PARFRA(rt,nrt,Fc,Nc,Fs,Ns,Uc,Nuc,V,Nv) call MULTFN(Uc,Nuc,Fs,Ns,us,nus) call MULTFN(V,Nv,Fc,Nc,vn,nvn) do i = 1,nus dum(i) = rt(i) - us(i) - vn(i) end do enot = 0.0d0 else if (jsfix.ne.1 .and. ncycth.eq.0 .and. $ varwnc.gt.1.0D-10 .and. ncyc.eq.1 .and.nchi.gt.1) then call PARFRA(rt,nrt,Ft,Nt,Fs,Ns,Ut,Nut,V,Nv) call MULTFN(V,Nv,Ft,Nt,us,nus) call MULTFN(Ut,Nut,Fs,Ns,vn,nvn) do i = 1,nus dum(i) = rt(i) - us(i) - vn(i) end do enoc = 0.0d0 end if C C if (qstar .gt. pstar) then call MULTFN(qt,nqt,Fc,Nc,dum,ndum) Nuc = MAX(ndum,Nuc) do i = 1,Nuc Uc(i) = dum(i) + Uc(i) end do ncycth = 1 end if C C if (nchi .ne. 1) then C C FIND MINIMUM OF TREND SPECTRUM AND PLOT C Ifunc = 2 Dstop = 0.000005d0 Step = 0.01d0 n_Step = 12 Start = pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0.5d0 * 2D0 ub = pi C call MINIM(e1,exmin1,lb,ub,jconv(1)) call GlobalMINIM(e1,exmin1,lb,ub,jconv(1),n_step,d+bd,mq,2) Start = 0.5d0 * pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0D0 ub = 0.5d0 * 2D0 c call MINIM(e2,exmin2,lb,ub,jconv(2)) call GlobalMINIM(e2,exmin2,lb,ub,jconv(2),n_step,d+bd,mq,2) enot = MIN(e1,e2) c c MY ADDITION (Donald Martin, July 2002) TO 'SPECTRUM' OF TREND USING GRID SEARCH ALSO c c if (Newmdl.gt.0) THEN c call minim2(e3, ixmin) c exmin3 = dble(float(ixmin)) c end if if ((doMinimGrid.gt.0) .and. (ut(1)-enot*ft(1).lt.0.0d0)) then call minimGrid(e3,exmin3,mq,2,2) if (e3 .lt. enot) enot = e3 end if end if C if (varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. ncyc.ne.1)) then C C FIND MINIMUM OF CYCLE SPECTRUM AND PLOT C Ifunc = 3 Dstop = 0.000005d0 Step = 0.01d0 Start = pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0.5d0*pi ub = pi c call MINIM(ce1,cexmin1,lb,ub,jconv(3)) call GlobalMINIM(ce1,cexmin1,lb,ub,jconv(3),n_step,d+bd,mq,2) Start = 0.5d0 * pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0D0 ub = 0.5d0 * pi c call MINIM(ce2,cexmin2,lb,ub,jconv(4)) call GlobalMINIM(ce2,cexmin2,lb,ub,jconv(4),n_step,d+bd,mq,2) enoc = MIN(ce1,ce2) if ((doMinimGrid.gt.0) .and. (uc(1)-enoc*fc(1).lt.0.0d0)) then call minimGrid(ce3,cexmin3,mq,2,1) if (ce3 .lt. enoc) enoc = ce3 end if end if C if (jsfix .ne. 1) then C C FIND MINIMUM OF SEASONAL SPECTRUM AND PLOT C Ifunc = 1 Dstop = 0.000005d0 Step = 0.01d0 Start = 0.0d0 jmq = mq / 2 C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0D0 ub = pi / dble(jmq) call MINIM(efmin(1),exmin(1),lb,ub,iconv(1)) do i = 2,jmq Start = (dble(i-0.5d0) * pi) / dble(jmq) C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = (dble(i-1) * pi) / dble(jmq) ub = (dble(i) * pi) / dble(jmq) call MINIM(efmin(i),exmin(i),lb,ub,iconv(i)) end do estar = 10.0d0 do i = 1,jmq if (efmin(i) .lt. estar) then estar = efmin(i) end if end do if ((doMinimGrid.gt.0) .and. (v(1)- estar*fs(1) .lt. 0.0d0)) THEN call minimGrid(efmin(jmq+1), exmin(jmq+1),mq,2,1) if (efmin(jmq+1) .lt. estar) then estar = efmin(jmq+1) end if end if end if C C CHECK DECOMPOSITION VALID C C qt1 = qt(1) + enot + estar + enoc if (qstar .gt. pstar) then qt1 = enot + estar + enoc end if C C qmin = qt1 if (qmin .lt. 0.0d0) then CHKSPCT = 0 else CHKSPCT = 1 end if end C C ansub8.f0000664006604000003110000014670514521201407011551 0ustar sun00315steps*C Last change: BCM 30 Sep 2005 11:28 am *C *C*PLOTSERIES *C+ *C SUBROUTINE PLOTSERIES(FNAME,SUBTITLE,A,NA,FLAG,XSE) *C *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "SERIES" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of A *C FLAG : INTEGER option used by graph routine *C XSE : REAL*8 option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C *C-- * subroutine PLOTSERIES(fname,subtitle,a,na,flag,xse) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xse *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * ngraphdir = ISTRLEN(Graphdir) * call STRTOLOW(fname) *cdos * filename = Graphdir(1:ngraphdir) // '\\series\\' // * & fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/series/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I5,/,I1,/,F11.4,/,2X,A)') na, flag, xse, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * if (flag.eq.555) then * write(48,'(i3)') nz-na * end if * call CLOSEDEVICE(48) * end if * end *C *C *C *C*PLOTLSERIES *C+ *C SUBROUTINE PLOTLSERIES(FNAME,SUBTITLE,A,NA,FLAG,XSE) *C *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "SERIES\LOGS" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of A *C FLAG : INTEGER option used by graph routine *C XSE : REAL*8 option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C *C-- * subroutine PLOTLSERIES(fname,subtitle,a,na,flag,xse) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xse *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * ngraphdir = ISTRLEN(Graphdir) * call STRTOLOW(fname) *cdos * filename = Graphdir(1:ngraphdir) // * & '\\series\\' // fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/series/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I5,/,I3,/,F11.4,/,2X,A)') na, flag, xse, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * if (flag.eq.555) then * write(48,'(i3)') nz-na * end if * call CLOSEDEVICE(48) * end if * end *cc *c *cc * subroutine PLOTRSERIES(fname,subtitle,a,na,flag,xse) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xse *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * ngraphdir = ISTRLEN(Graphdir) * call STRTOLOW(fname) *cdos * filename = Graphdir(1:ngraphdir) // * & '\\series\\' // fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/series/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/,F11.4,/,2X,A)') na, flag, xse, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * if (flag.eq.555) then * write(48,'(i3)') nz-na * end if * call CLOSEDEVICE(48) * end if * end *cc *c *cc * subroutine PLOTSERIESCI(fname,subtitle,a,b,na,flag,xse) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na),b(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xse *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * ngraphdir = ISTRLEN(Graphdir) * call STRTOLOW(fname) *cdos * filename = Graphdir(1:ngraphdir) // '\\series\\' // * c fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/series/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I1,/,F11.4,/,2X,A)') na, flag, xse, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * write (48,7000) (a(i)+1.96d0*b(i), i = 1,na) * write (48,7000) (a(i)-1.96d0*b(i), i = 1,na) * call CLOSEDEVICE(48) * end if * end *C *C *C*PLOTACF *C+ *C SUBROUTINE PLOTACF(FNAME,SUBTITLE,A,NA,FLAG,FLAG1) *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "ACF" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of A *C FLAG : INTEGER option used by graph routine *C FLAG1 : INTEGER option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C-- * subroutine PLOTACF(fname,subtitle,a,na,flag,flag1) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * integer flag1 *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\acf\\' // fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/acf/' // fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/,I3,/,2X,A)') na, flag, flag1, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * call CLOSEDEVICE(48) * end if * end *C *C *C *C*PLOTACF0 *C+ *C SUBROUTINE PLOTACF0(FNAME,SUBTITLE,A,NA,FLAG,FLAG1) *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "ACF" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot which index begin from 0 *C NA : INTEGER dimension of A *C FLAG : INTEGER option used by graph routine *C FLAG1 : INTEGER option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C-- * subroutine PLOTACF0(fname,subtitle,a,na,flag,flag1) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*12 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(0:na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * integer flag1 *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\acf\\' // fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/acf/' // fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/,I3,/,2X,A)') na, flag, flag1, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * call CLOSEDEVICE(48) * end if * end *C *C *C *C*PLOTSPECTRUM *C+ *C SUBROUTINE PLOTSPECTRUM(FNAME,SUBTITLE,A,NA,FLAG,XSE,withTD) *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "SPECTRA" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of A *C FLAG : INTEGER option used by graph routine *C XSE : REAL*8 option used by graph routine *C WithTD : 1=> With vertical lines in the frequencies of TD *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C-- * subroutine PLOTSPECTRUM(fname,subtitle,a,nar,flag,xse,withTD) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * real*8 nar *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(*) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag,withTD *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xse *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub,na * real*8 pi * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C *c na=floor(nar) * na=nar * pi = acos(-1.0d0) * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\spectra\\' // * & fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/spectra/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(F6.2,/,F11.4,/,2X,A)') nar, xse, Titleg * write (48,'(2X,A,/,I4,/,g16.8,/,I4)') * $ subtitle(1:nsub), flag, pi,withTD * 6999 FORMAT(2X,A,/,I4,/,f16.8) * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * call CLOSEDEVICE(48) * end if * end * * *c * subroutine PLOTSPCT(fname,subtitle,a,na,peak,npeak,flag,xse, * $ withTD) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na,npeak *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag,withTD,peak(npeak) *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xse *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * real*8 pi * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * pi = acos(-1.0d0) * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\spectra\\' // * & fname(1:lfname) *cunix *cunix filename = Graphdir(1:ngraphdir) // '/spectra/' // fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,F11.4,/,2X,A)') na, xse, Titleg * write (48,'(2X,A,/,I4,/,g16.8,/,I4)') * $ subtitle(1:nsub), flag, pi, withTD * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * write (48,'(i3)') npeak * write(48,'(i3)') (peak(i),i=1,npeak) * call CLOSEDEVICE(48) * end if * end * * * * * *C *C *C *C*PLOTFILTERS *C+ *C SUBROUTINE PLOTFILTERS(FNAME,SUBTITLE,A,NA,FLAG,XSE) *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "FILTERS" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of A *C FLAG : INTEGER option used by graph routine (MQ) *C XSE : REAL*8 option used by graph routine (MaxY) *C XMAX : max value in X ordinates *C withTD : (1 with frequency TD vertical lines) *c *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C-- * subroutine PLOTFILTERS(fname,subtitle,a,na,flag,xse,xmax,withTD) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag,withTD *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xse *C.. In/Out Status: Maybe Read, Not Written .. * real*8 xmax *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\filters\\' // * & fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/filters/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I4,/,F11.4,/,2X,A)') na, xse,Titleg * write (48,'(2X,A,/,I3,/,g16.8,/,I4)') * $ subtitle(1:nsub), flag, xmax, withTD * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * call CLOSEDEVICE(48) * end if * end *C *C *C *C*PLOTFLT *C+ *C SUBROUTINE PLOTFLT(FNAME,SUBTITLE,A,NA,FLAG,FLAG1) *C *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "FILTERS" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of A *C FLAG : INTEGER option used by graph routine *C FLAG1 : INTEGER option used by graph routine *C (this parameter is the difference *C form the subroutine PLOTFILTERS) *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C-- * subroutine PLOTFLT(fname,subtitle,a,na,flag,flag1) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * integer flag1 *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\filters\\' // * & fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/filters/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/I3,/,2X,A)') na, flag, flag1, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = 1,na) * call CLOSEDEVICE(48) * end if * end *C *C *C *C*PLOTFLT1 *C+ *C SUBROUTINE PLOTFLT1(FNAME,SUBTITLE,A,NA,LF,FLAG,FLAG1) *C *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "FILTERS" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of data to plot, 2*NA+1 *C LF : INTEGER starting point of the data *C use the data from LF-NA to LF+NA *C (this parameter is the difference *C form the subroutine PLOTFLT) *C FLAG : INTEGER option used by graph routine *C FLAG1 : INTEGER option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C-- * subroutine PLOTFLT1(fname,subtitle,a,na,lf,flag,flag1) *C *C.. Implicits .. * implicit none *C *C.. Parameters .. ** INCLUDE 'srslen.prm' ** integer nfl ** parameter (nfl = POBS*2) *C *C.. Formal Arguments .. * integer na,lf,flag,flag1 * character fname*30,subtitle*50 * real*8 a(*) *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * integer Nper2, Nyer2 * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * Nyer2=Nyer * Nper2=Nper * do i=2,lf-na * Nper2=Nper2+1 * if (Nper2 .gt. Mq) then * Nper2 = 1 * Nyer2 = Nyer2 + 1 * end if * end do * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\filters\\' // * & fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/filters/' // *c & fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/I3,/,2X,A)') 2*na+1, flag, flag1, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = lf-na+1,lf+na+1) * call CLOSEDEVICE(48) * end if * end *C *C *C*PLOTFCAST *C+ *C SUBROUTINE PLOTFCAST (FNAME,SUBTITLE,A,NA,LF,FLAG) *C *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "FORECAST" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of data to plot, 2*NA+1 *C LF : INTEGER starting point of the data *C use the data from LF-NA to LF+NA *C FLAG : INTEGER option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C-- * subroutine PLOTFCAST(fname,subtitle,a,na,lf,flag) *C *C.. Implicits .. * implicit none *C *C.. Formal Arguments .. *C.. In/Out Status: Read, Not Written .. * integer lf *C.. In/Out Status: Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(lf+na) *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 * integer Nper2, Nyer2 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * Nyer2=Nyer * Nper2=Nper * do i=2,flag-na * Nper2=Nper2+1 * if (Nper2 .gt. Mq) then * Nper2 = 1 * Nyer2 = Nyer2 + 1 * end if * end do * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\forecast\\' // * $ fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/forecast/' // *c $ fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/I3,/,2X,A)') 2*na+1, lf, flag, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = lf-na,lf+na) * close (48) * end if * end *C *C*PLOTFCAST1 *C+ *C SUBROUTINE PLOTFCAST1 (FNAME,SUBTITLE,A,NA,FLAG,FLAG1) *C *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "FORECAST" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 ARRAY the data to plot *C NA : INTEGER dimension of A(-NA:NA), *C the data to plot are 2*NA+1 *C FLAG : INTEGER option used by graph routine *C FLAG1 : INTEGER option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C *C-- * subroutine PLOTFCAST1(fname,subtitle,a,na,flag,flag1) *C *C.. Implicits .. * implicit none * INCLUDE 'srslen.prm' * integer kp * parameter (kp = PFCST) *C *C.. Formal Arguments .. *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(-kp:kp) *C.. In/Out Status: Maybe Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * integer flag1 *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\forecast\\' // * $ fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/forecast/' // *c $ fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/I3,/,2X,A)') 2*na+1, flag, flag1, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq * 7000 format (g16.8) * write (48,7000) (a(i), i = (-na),na) * call CLOSEDEVICE(48) * end if * end *C *C*PLOTFCAST2 *C+ *C SUBROUTINE PLOTFCAST2 (FNAME,SUBTITLE,A,NA,FLAG,FLAG1) *C *C THIS ROUTINE PROVIDE TO WRITE THE FILE FOR THE GRAPHICS *C IN THE "FORECAST" SUBDIRECTORY OF GRAPH. *C *C FNAME : CHARACTER*12 file name of the external file *C SUBTITLE : CHARACTER*50 subtitle of the graph *C A : REAL*8 MATRIX the data to plot A(51,3) *C NA : INTEGER the data to plot are (2*NA+1)*3 *C FLAG : INTEGER option used by graph routine *C FLAG1 : INTEGER option used by graph routine *C *C THIS SUBROUTINE USE ALSO THE FOLLOWING COMMON VARIABLE *C TITLEG : CHARACTER*19 the title of the series *C GRAPHDIR : CHARACTER*80 the path of the directory graph *C MQ : the frequency of the series *C *C THE FOLLOWING IS THE COMMON DECLARATION USED : *C *C COMMON /DIR/ OUTDIR,GRAPHDIR *C COMMON /TITL/ TITLEG *C COMMON /CALFOR/ PSTAR,QSTAR,MQ *C *C-- * subroutine PLOTFCAST2(fname,subtitle,a,na,flag,flag1) *C *C.. Implicits .. * implicit none * INCLUDE 'srslen.prm' * integer kp * parameter (kp = PFCST) *C *C.. Formal Arguments .. *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(2*kp+1,3) *C.. In/Out Status: Maybe Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * integer flag1 *C *C.. Local Scalars .. * integer i,ireturn,j,lfname,ngraphdir,nsub * character filename*180 * integer Nper2, Nyer2 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'dirs.i' * include 'calfor.i' * include 'sform.i' * include 'titl.i' *C *C ... Executable Statements ... *C * Nyer2=Nyer * Nper2=Nper * do i=2,flag-na * Nper2=Nper2+1 * if (Nper2 .gt. Mq) then * Nper2 = 1 * Nyer2 = Nyer2 + 1 * end if * end do * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\forecast\\' // * $ fname(1:lfname) *cunix *c filename = Graphdir(1:ngraphdir) // '/forecast/' // *c $ fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/I3,/,2X,A)') 2*na+1, flag, flag1, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), na/2 * do j = 1,3 * 7000 format (g16.8) * write (48,7000) (a(i,j), i = (kp-na),kp+na) * end do * call CLOSEDEVICE(48) * end if * end *cc *c *cc * subroutine PLOTFCAST3(fname,subtitle,a,na,flag,flag1) *C *C.. Implicits .. * implicit none *C *C.. Parameters .. * INCLUDE 'srslen.prm' * integer kp * parameter (kp = PFCST) *C *C.. Formal Arguments .. *C.. In/Out Status: Maybe Read, Maybe Written .. * character*30 fname *C.. In/Out Status: Maybe Read, Not Written .. * character*50 subtitle *C.. In/Out Status: Maybe Read, Not Written .. * real*8 a(-kp:kp) *C.. In/Out Status: Maybe Read, Not Written .. * integer na *C.. In/Out Status: Maybe Read, Not Written .. * integer flag *C.. In/Out Status: Maybe Read, Not Written .. * integer flag1 *C *C.. Local Scalars .. * integer i,ireturn,lfname,ngraphdir,nsub * character filename*180 * integer Nper2, Nyer2 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C *C ... Executable Statements ... *C * Nyer2=Nyer * Nper2=Nper * do i=2,flag-na * Nper2=Nper2+1 * if (Nper2 .gt. Mq) then * Nper2 = 1 * Nyer2 = Nyer2 + 1 * end if * end do * lfname = ISTRLEN(fname) * nsub = ISTRLEN(subtitle) * call STRTOLOW(fname) * ngraphdir = ISTRLEN(Graphdir) *cdos * filename = Graphdir(1:ngraphdir) // '\\forecast\\' // * $ fname(1:lfname) *cunix *cunix filename = Graphdir(1:ngraphdir) // '/forecast/' // *cunix $ fname(1:lfname) * call OPENDEVICE(filename,48,0,ireturn) * if (ireturn .eq. 0) then * write (48,'(I3,/,I3,/I3,/,2X,A)') 2*na+1, flag, flag1, Titleg * write (48,'(2X,A,/,I3)') subtitle(1:nsub), Mq *CUNX#ifdef TSW *!DEC$ IF DEFINED (TSW) * write (48,'(2X,I3,/,I4,/,I3)') Nper2, Nyer2, Mq *CUNX#end if *!DEC$ end if * 7000 format (g16.8) * write (48,7000) (a(i), i = (-na),na) * call CLOSEDEVICE(48) * end if * end C C*ISTRLEN C+ C INTEGER FUNCTION ISTRLEN (STRING) C C THIS FUNCTION COMPUTE THE LENGTH OF THE CHARACTER ARRAY STRING C WITHOUT THE TRAILING LAST BLANK CHARACTER C C STRING : CHARACTER*(*) C C-- integer function ISTRLEN(string) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. character*(*) string C C.. Local Scalars .. integer i,lstr C C.. Intrinsic Functions .. intrinsic LEN,ACHAR,ichar C C ... Executable Statements ... C lstr = LEN(string) if (lstr.eq.0) then ISTRLEN=0 return end if i=1 do while( ichar(string(i:i)) .ne.0 .and. i.lt.lstr) i=i+1 end do do while (string(i:i) .eq. ' '.or. $ string(i:i).eq.achar(0)) i = i - 1 if (i .eq. 0) goto 5000 end do 5000 ISTRLEN = i end C C*STRTOLOW C+ C SUBROUTINE STRTOLOW (STRING) C C THIS SUBROUTINE TRANSFORM ALL THE CHARACTER OF THE INPUT C CHARACTER ARRAY IN LOWER CASE C C STRING : CHARACTER*(*) C C-- subroutine STRTOLOW(string) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Maybe Written .. character*(*) string C C.. Local Scalars .. integer i,iasc,j C C.. External Functions .. integer ISTRLEN external ISTRLEN C C.. Intrinsic Functions .. intrinsic CHAR, ICHAR C C ... Executable Statements ... C j = ISTRLEN(string) do i = 1,j iasc = ICHAR(string(i:i)) if ((iasc.gt.64) .and. (iasc.lt.91)) then string(i:i) = CHAR(iasc+32) end if end do end C C C C*OPENDEVICE C+ C SUBROUTINE OPENDEVICE(FILENAME,DEVNUM,icheck,IRETURN) C C THIS SUBROUTINE TRY TO OPEN A FILE WITH A SPECIFIC DEVICE C NUMBER AND WRITES IN THE FIRST LINE ITS VERSION AND Building DATE. C C FILENAME : CHARACTER*180 file name C DEVNUM : INTEGER device number to open C icheck : INTEGER 1 check if file exist, 0 no check C IRETURN : RETURN VALUE : C 0 ok C 1 an error condition during the open C 2 check if file exist failed C C C-- subroutine OPENDEVICE(filename,devnum,icheck,ireturn) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. character*180 filename C.. In/Out Status: Maybe Read, Not Written .. integer devnum C.. In/Out Status: Read, Not Written .. integer icheck C.. In/Out Status: Not Read, Overwritten .. integer ireturn C C.. Local Scalars .. integer err,flen logical bool C.. Local Arrays .. C character dir*180 C.. External Functions .. integer ISTRLEN external ISTRLEN include 'stream.i' include 'dirs.i' include 'build.i' C C ... Executable Statements ... C if (icheck .ne. 2) then close(devnum) end if inquire (unit=devnum,opened=bool) if (bool) then return end if flen = ISTRLEN(filename) * call STRTOLOW(filename) if (icheck .eq. 1) then inquire (FILE = filename(1:flen),EXIST = bool) if (.not. bool) then ireturn = 2 return end if end if if (icheck.eq.2) then inquire (FILE = filename(1:flen),EXIST = bool) if (.not. bool) then open (devnum,FILE = filename(1:flen),IOSTAT = err) if (err .ne. 0) then ireturn = 1 end if else CUNX#ifdef TSW !DEC$ IF DEFINED (TSW) cdos cdos open(devnum,file=filename(1:flen),status='old', cdos $ position='append') cunix open(devnum,file=filename(1:flen),status='old') dir = outdir * call STRTOLOW(dir) cc c Write the Build date in the Output files cc No queremos la fecha en main output devnum= 16,70 y 71 if (index(filename,dir(1:ISTRLEN(dir))) .ge. 1) then if (devnum.ne.16) then write ( Devnum,'(2x,''*** Seats Build date :'',A,'' ***'')') $ CompDate end if end if CUNX#else !DEC$ ELSE open(devnum,file=filename(1:flen)) dir = outdir * call STRTOLOW(dir) cc c Write the Build date in the Output files cc if (index(filename,dir(1:ISTRLEN(dir))) .ge. 1) then write ( Devnum,'(2x,''*** Seats Build date :'',A,'' ***'')') $ CompDate end if CUNX#end if !DEC$ end if ireturn=0 end if return end if open (devnum,FILE = filename(1:flen),IOSTAT = err) if (err .ne. 0) then ireturn = 1 else ireturn = 0 end if if (ireturn .eq. 0) then dir = outdir * call STRTOLOW(dir) cc c Write the Build date in the Output files cc if (index(filename,dir(1:ISTRLEN(dir))) .ge. 1) then write ( Devnum,'(2x,''*** Seats Build date :'',A,'' ***'')') $ CompDate end if end if CUNX#end if c!DEC$ end if return end C C C logical function isopen(ndevice) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer ndevice C C.. Local Scalars .. logical qopen inquire (unit=ndevice,opened=qopen) isopen=qopen return end C C*CLOSEDEVICE C+ C SUBROUTINE CLOSEDEVICE(IDEVICE) C C THIS SUBROUTINE PROVIDE TO CLOSE THE DEVICE ASSOCIATED TO THE C DEVICE NUMBER IDEVICE C C IDEVICE : INTEGER the device number to close C-- subroutine CLOSEDEVICE(idevice) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer idevice C C ... Executable Statements ... C close (idevice) end C C subroutine CLOSEDEVICE2(idevice) C C.. Implicits .. implicit none c include 'stream.i' C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer idevice C C.. External Functions .. logical isopen external isopen C C ... Executable Statements ... C if (.not. isopen(idevice)) then return end if close (idevice) end C*OPENDEVSCRATCH C+ C SUBROUTINE OPENDEVSCRATCH(DEVNUM) C C THIS SUBROUTINE TRY TO OPEN A SCRATCH FILE WITH A SPECIFIC DEVICE C NUMBER. C C DEVNUM : INTEGER device number to open C C-- subroutine OPENDEVSCRATCH(devnum) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer devnum * integer ipos * character*3 devstr C C ... Executable Statements ... C close(devnum) open (devnum,STATUS = 'SCRATCH') * ipos=1 * CALL itoc(devnum,devstr,ipos) * open(devnum,file="unit"//devstr(1:(ipos-1)),status="UNKNOWN") end C CC C CC C THIS SUBROUTINE TRY TO OPEN A FILE WITH A SPECIFIC DEVICE C NUMBER THE FILE NAME IS NOT TRANSFORMED IN LOWERCASE C C FILENAME : CHARACTER*180 file name C DEVNUM : INTEGER device number to open C CHECK : INTEGER 1 check if file exist, 0 no check C IRETURN : RETURN VALUE : C 0 ok C 1 an error condition during the open C 2 check if file exist failed C C C-- subroutine OPENDEVICEASIS(filename,devnum,icheck,ireturn) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. character*180 filename C.. In/Out Status: Maybe Read, Not Written .. integer devnum C.. In/Out Status: Read, Not Written .. integer icheck C.. In/Out Status: Not Read, Overwritten .. integer ireturn C C.. Local Scalars .. integer err,flen logical bool C C.. External Functions .. integer ISTRLEN external ISTRLEN C C ... Executable Statements ... C close(devnum) CUNX#ifdef NBB && !DEBUG c!DEC$ IF DEFINED (NBB) .AND. .NOT. DEFINED (DEBUG) call OPENDEVSCRATCH(devnum) CUNX#else c!DEC$ ELSE flen = ISTRLEN(filename) if (icheck .eq. 1) then inquire (FILE = filename(1:flen),EXIST = bool) if (.not. bool) then ireturn = 2 return end if end if if (icheck.eq.2) then inquire (FILE = filename(1:flen),EXIST = bool) if (.not. bool) then open (devnum,FILE = filename(1:flen),IOSTAT = err) if (err .ne. 0) then ireturn = 1 end if else CUNX#ifdef TSW c!DEC$ IF DEFINED (TSW) c open(devnum,file=filename(1:flen),status='old', c $ position='append') CUNX#else c!DEC$ ELSE open(devnum,file=filename(1:flen)) CUNX#end if c!DEC$ end if ireturn=0 end if return end if open (devnum,FILE = filename(1:flen),IOSTAT = err) if (err .ne. 0) then ireturn = 1 else ireturn = 0 end if CUNX#end if c!DEC$ end if return end cc c cc * subroutine PlotPureMA(oz,sa,p,s,trans,ir,iter,out,ioneout,title, * $ ntitle) *C.. Parameters .. * integer kl,mp,kp * parameter (kl = PFCST,kp = 65, mp = 600) *c Formal parameters * real*8 oz(mp+kp),sa(mp+kp),p(mp+kp),s(mp+kp),trans(mp+kp), * $ ir(mp+kp) * integer out,iter,ioneout,ntittle * character TITLE*80 * include 'preadtr.i' * include 'calfor.i' * include 'sform.i' * include 'dirs.i' * include 'titl.i' *C Local variables * character subtitle*50,fname*30 *c.. *c * if (tramo.gt.0) then * if (iter.eq.0) then * if (out.lt.3) then * if ( Neast.ne.0 .or. Neff(2).ne.0 .or. * $ Neff(0).ne.0 .or. Nous.ne.0 .or. Npatd.ne.0) then * fname = 'SAFIN.T' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,sa,nz,1,0.0d0) * fname = 'Sasadjo.t' * subtitle = 'STOCHASTIC SA SERIES' * call PLOTSERIES(fname,subtitle,oz,nz,1,0.0d0) * else * fname = 'Sasadjo.t' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,oz,nz,1,0.0d0) * end if * if (Noutr.ne.0 .or. Neff(1).ne.0 .or. Neff(7).ne.0) then * fname = 'TRFIN.T' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,p,nz,1,0.0d0) * end if * if (Neast.ne.0.or.Neff(2).ne.0.or.Npatd.ne.0.or.Nous.ne.0) * $ then * fname = 'SFIN.T' * subtitle = 'FINAL SEASONAL' * call PLOTSERIES(fname,subtitle,s,nz,1,0.0d0) * end if * if (Neff(5).eq.1) then * fname = 'TRAFIN.T' * subtitle = 'FINAL TRANSITORY COMPONENT' * call PLOTSERIES(fname,subtitle,trans,nz,1,0.0d0) * end if * if (Nouir.ne.0 .or. Neff(3).ne.0) then * fname = 'IRFIN.T' * subtitle = 'FINAL IRREGULAR' * call PLOTSERIES(fname,subtitle,ir,nz,1,0.0d0) * end if * end if * else * if (out.lt.2 .and. ioneout.eq.0) then * if ( Neast.ne.0 .or. Neff(2).ne.0 .or. * $ Neff(0).ne.0 .or. Nous.ne.0 .or. Npatd.ne.0) then * fname = title(1:ntitle) // '.SA' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,sa,nz,1,0.0d0) * write (17,'(A)') fname * end if * if (Noutr.ne.0 .or. Neff(1).ne.0 .or. Neff(7).ne.0) then * fname = title(1:ntitle) // '.TRE' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,p,nz,1,0.0d0) * end if * if (Neast.ne.0.or.Neff(2).ne.0.or.Npatd.ne.0.or.Nous.ne.0) * $ then * fname = title(1:ntitle) // '.SF' * subtitle = 'FINAL SEASONAL' * call PLOTSERIES(fname,subtitle,s,nz,1,0.0d0) * end if * if (Nouir.ne.0 .or. Neff(3).ne.0) then * fname = title(1:ntitle) // '.FIR' * subtitle = 'FINAL IRREGULAR' * call PLOTSERIES(fname,subtitle,ir,nz,1,0.0d0) * end if * end if * if (out.eq.0) then * if (Neff(5).eq.1) then * fname = title(1:ntitle) // '.CYC' * subtitle = 'FINAL TRANSITORY COMPONENT' * call PLOTSERIES(fname,subtitle,trans,nz,1,0.0d0) * end if * end if * end if * else * if (iter.eq.0) then * if (out.lt.3) then * fname = 'Sasadjo.t' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,oz,nz,1,0.0d0) * end if * else * if (out.lt.2 .and. ioneout.eq.0) then * fname = title(1:ntitle) // '.SA' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,sa,nz,1,0.0d0) * write (17,'(A)') fname * end if * end if * end if * end cc c cc * subroutine PlotFitted(serie,eres,nz,nres,lam,nyear,nper,mq) * integer kp,mp * parameter (kp = 65, mp = 600) * integer nz,nres,lam,nyear,nper,mq * real*8 serie(mp+kp),eres(mp) *C.. Local Scalars .. * integer k,i,na,ifault * character filename*180,subtitle*50,fname*30 *C *C.. External Functions .. * integer ISTRLEN * external ISTRLEN *C *C.. External Calls .. * external CLOSEDEVICE, OPENDEVICE, STRTOLOW * include 'dirs.i' * include 'titl.i' *c *c * fname = 'FITT.T' * subtitle = 'FITTED VALUE' * call STRTOLOW(fname) * filename = GRAPHDIR(1:ISTRLEN(GRAPHDIR)) // '\series\' * $ // fname(1:ISTRLEN(fname)) *CUNX#end if *!DEC$ end if * call OPENDEVICE(filename,48,0,ifault) * if (ifault .eq. 0) then * na=min(nz,nres) * write(48,'(I3,/,I2,/f8.3,/,2X,A)')na,1,-0.0d0,TITLEG * write(48,'(2X,A,/,I3)') subtitle(1:ISTRLEN(subtitle)),mq * * if (Lam .eq. 1) then * if (nres .lt. nz) then * do i=1,nres * k=nz-nres+i * write (48,'(g16.8)') serie(k)-eres(i) * end do * else * do i=1,nz * k=nres-nz+i * write (48,'(g16.8)') serie(i)-eres(k) * end do * end if * else * if (nres .lt. nz) then * do i=1,nres * k=nz-nres+i * write (48,'(g16.8)') Dlog(serie(k))-eres(i) * end do * else * do i=1,nz * k=nres-nz+i * write (48,'(g16.8)') Dlog(serie(i))-eres(k) * end do * end if * end if * call CLOSEDEVICE(48) * end if * end ansub9.f0000664006604000003110000015424114521201407011544 0ustar sun00315stepsC Last change: REG 30 Aug 2005 C Previous change: BCM 4 Oct 2002 1:11 pm C subroutine USRENTRY(rbuff,brbuff,erbuff,lim1,lim2,ifunc) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Read, Not Written .. integer brbuff,lim1,lim2,erbuff C.. In/Out Status: Not Read, Not Written .. real*8 rbuff(lim1:lim2) C.. In/Out Status: Not Read, Not Written .. integer ifunc C LINES OF CODE ADDED FOR X-13A-S : 8 LOGICAL dpeq,allzro INTEGER i EXTERNAL dpeq INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'x11ptr.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'seatcm.cmn' INCLUDE 'seatdg.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'seatmd.cmn' C END OF CODE BLOCK C C ... Executable Statements ... C C LINES OF CODE ADDED FOR X-13A-S : 333 IF (IFUNC.eq.1309) THEN allzro = .true. DO i = BRBUFF, ERBUFF Seatsa(i+Pos1ob-1) = RBUFF(i) allzro = (dpeq(RBUFF(i),DNOTST).or.dpeq(RBUFF(i),0D0)).and.allzro END DO Havesa=.not.allzro ELSE IF (IFUNC.eq.1310) THEN allzro = .true. DO i = BRBUFF, ERBUFF Seattr(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Havetr = .not.allzro ELSE IF (IFUNC.eq.1201) THEN allzro = .true. DO i = BRBUFF, ERBUFF Seatsf(i+Pos1ob-1) = RBUFF(i) allzro = (dpeq(RBUFF(i),DNOTST).or.dpeq(RBUFF(i),0D0)).and.allzro END DO Havesf = .not.allzro c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1409) THEN allzro = .true. DO i = BRBUFF, ERBUFF Setfsa(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Havfsa=.not.allzro Nsfsa=ERBUFF-BRBUFF+1 ELSE IF (IFUNC.eq.1410) THEN allzro = .true. DO i = BRBUFF, ERBUFF Setftr(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Havftr = .not.allzro Nsftr=ERBUFF-BRBUFF+1 ELSE IF (IFUNC.eq.1411) THEN allzro = .true. DO i = BRBUFF, ERBUFF Setfsf(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Havfsf = .not.allzro Nsfsf=ERBUFF-BRBUFF+1 ELSE IF (IFUNC.eq.1412) THEN allzro = .true. DO i = BRBUFF, ERBUFF Setfir(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Havfir = .not.allzro Nsfir=ERBUFF-BRBUFF+1 ELSE IF (IFUNC.eq.1413) THEN allzro = .true. DO i = BRBUFF, ERBUFF Setfcy(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Havfcy = .not.allzro Nsfcy=ERBUFF-BRBUFF+1 c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1010) THEN Iprsm=ERBUFF-BRBUFF ELSE IF (IFUNC.eq.1011) THEN Iqrsm=ERBUFF-BRBUFF ELSE IF (IFUNC.eq.1012) THEN Ipssm=ERBUFF-BRBUFF ELSE IF (IFUNC.eq.1013) THEN Iqssm=ERBUFF-BRBUFF ELSE IF (IFUNC.eq.1016) THEN Idrsm=INT(RBUFF(BRBUFF)) ELSE IF (IFUNC.eq.1017) THEN Idssm=INT(RBUFF(BRBUFF)) END IF c----------------------------------------------------------------------- IF(Issap.eq.2.or.Irev.eq.4)RETURN c----------------------------------------------------------------------- IF (IFUNC.eq.1311) THEN allzro = .true. DO i = BRBUFF, ERBUFF Seataf(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Haveaf = .not.allzro ELSE IF (IFUNC.eq.1312) THEN allzro = .true. DO i = BRBUFF, ERBUFF Seatir(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Haveir = .not.allzro ELSE IF (IFUNC.eq.1313) THEN allzro = .true. DO i = BRBUFF, ERBUFF Seatcy(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Havecy = .not.allzro ELSE IF (IFUNC.eq.1203) THEN allzro = .true. DO i = BRBUFF, ERBUFF Stocsa(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvstsa = .not.allzro ELSE IF (IFUNC.eq.1204) THEN allzro = .true. DO i = BRBUFF, ERBUFF Stocir(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvstir = .not.allzro c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1139) THEN allzro = .true. DO i = BRBUFF, ERBUFF Sttfsa(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvftsa=.not.allzro ELSE IF (IFUNC.eq.1135) THEN allzro = .true. DO i = BRBUFF, ERBUFF Sttftr(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvfttr = .not.allzro ELSE IF (IFUNC.eq.1141) THEN allzro = .true. DO i = BRBUFF, ERBUFF Sttfsf(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvftsf = .not.allzro ELSE IF (IFUNC.eq.1133) THEN allzro = .true. DO i = BRBUFF, ERBUFF Sttfor(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvftor = .not.allzro ELSE IF (IFUNC.eq.1170) THEN allzro = .true. DO i = BRBUFF, ERBUFF Sttfcy(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvftcy = .not.allzro ELSE IF (IFUNC.eq.1139) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssefsa(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsefsa=.not.allzro ELSE IF (IFUNC.eq.1136) THEN allzro = .true. DO i = BRBUFF, ERBUFF Sseftr(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hseftr = .not.allzro ELSE IF (IFUNC.eq.1142) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssefsf(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsefsf = .not.allzro ELSE IF (IFUNC.eq.1134) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssefor(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsefor = .not.allzro ELSE IF (IFUNC.eq.1171) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssefcy(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsefcy = .not.allzro ELSE IF (IFUNC.eq.1140) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssrfsa(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsrfsa=.not.allzro ELSE IF (IFUNC.eq.1137) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssrftr(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsrftr = .not.allzro ELSE IF (IFUNC.eq.1143) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssrfsf(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsrfsf = .not.allzro ELSE IF (IFUNC.eq.1172) THEN allzro = .true. DO i = BRBUFF, ERBUFF Ssrfcy(i-BRBUFF+1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hsrfcy = .not.allzro ELSE IF (IFUNC.eq.2021) THEN allzro = .true. DO i = BRBUFF, ERBUFF Spitrc(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hpitrc = .not.allzro ELSE IF (IFUNC.eq.2022) THEN allzro = .true. DO i = BRBUFF, ERBUFF Spis(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hpis = .not.allzro ELSE IF (IFUNC.eq.2023) THEN allzro = .true. DO i = BRBUFF, ERBUFF Spitra(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hpitra = .not.allzro ELSE IF (IFUNC.eq.2024) THEN allzro = .true. DO i = BRBUFF, ERBUFF Spisa(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hpisa = .not.allzro c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1042) THEN Kurt=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1043) THEN Kurtse=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1044) THEN Testnm=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1045) THEN Skew=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1046) THEN Skewse=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1047) THEN Sdres=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1048) THEN Dwstat=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1049) THEN SeasNP=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.2051) THEN Ssghst=INT(RBUFF(BRBUFF)) ELSE IF (IFUNC.eq.2052) THEN Ssgcnc=INT(RBUFF(BRBUFF)) ELSE IF (IFUNC.eq.2053) THEN Ssgfct=INT(RBUFF(BRBUFF)) c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1103) THEN Ceetrn=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1106) THEN Ceesad=RBUFF(BRBUFF) c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1517) THEN DO i=BRBUFF,ERBUFF Prsetr(i-BRBUFF+1)=RBUFF(i) END DO ELSE IF (IFUNC.eq.1518) THEN DO i=BRBUFF,ERBUFF Prsesa(i-BRBUFF+1)=RBUFF(i) END DO c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1950) THEN Aadasa=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1951) THEN Aadatr=RBUFF(BRBUFF) c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1900) THEN Tsetrn=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1901) THEN Tsesea=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1902) THEN Tsetcm=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1903) THEN Tsesad=RBUFF(BRBUFF) c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.1910) THEN Vartrn(1)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1911) THEN Vartrn(2)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1912) THEN Vartrn(3)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1913) THEN Varsad(1)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1914) THEN Varsad(2)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1915) THEN Varsad(3)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1916) THEN Varirr(1)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1108) THEN Varirr(2)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1109) THEN Varirr(3)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1917) THEN Varsea(1)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1918) THEN Varsea(2)=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.1919) THEN Varsea(3)=RBUFF(BRBUFF) c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.2001) THEN DO i = BRBUFF, ERBUFF Tcnum(i-BRBUFF+1) = RBUFF(i) END DO Ntcnum = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2002) THEN DO i = BRBUFF, ERBUFF Tcden(i-BRBUFF+1) = RBUFF(i) END DO Ntcden = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2003) THEN Tcvar=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.2004) THEN DO i = BRBUFF, ERBUFF Snum(i-BRBUFF+1) = RBUFF(i) END DO Nsnum = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2005) THEN DO i = BRBUFF, ERBUFF Sden(i-BRBUFF+1) = RBUFF(i) END DO Nsden = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2006) THEN Svar=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.2007) THEN DO i = BRBUFF, ERBUFF Trnum(i-BRBUFF+1) = RBUFF(i) END DO Ntrnum = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2008) THEN DO i = BRBUFF, ERBUFF Trden(i-BRBUFF+1) = RBUFF(i) END DO Ntrden = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2009) THEN Trvar=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.2010) THEN Irrvar=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.2011) THEN DO i = BRBUFF, ERBUFF Sanum(i-BRBUFF+1) = RBUFF(i) END DO Nsanum = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2012) THEN DO i = BRBUFF, ERBUFF Saden(i-BRBUFF+1) = RBUFF(i) END DO Nsaden = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2013) THEN Savar=RBUFF(BRBUFF) ELSE IF (IFUNC.eq.2014) THEN DO i = BRBUFF, ERBUFF Tcwkf(i-BRBUFF+1) = RBUFF(i) END DO Ntcwkf = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2015) THEN DO i = BRBUFF, ERBUFF Sawkf(i-BRBUFF+1) = RBUFF(i) END DO Nsawkf = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2016) THEN DO i = BRBUFF, ERBUFF Swkf(i-BRBUFF+1) = RBUFF(i) END DO Nswkf = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2017) THEN DO i = BRBUFF, ERBUFF Trwkf(i-BRBUFF+1) = RBUFF(i) END DO Ntrwkf = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2018) THEN DO i = BRBUFF, ERBUFF Irwkf(i-BRBUFF+1) = RBUFF(i) END DO Nirwkf = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.2049) THEN DO i = BRBUFF, ERBUFF Srsdex(i-BRBUFF+1) = RBUFF(i) END DO Nrsdex = ERBUFF - BRBUFF + 1 ELSE IF (IFUNC.eq.1110) THEN DO i = BRBUFF, ERBUFF Sep(i) = RBUFF(i) END DO ELSE IF (IFUNC.eq.1111) THEN DO i = BRBUFF, ERBUFF Seq(i) = RBUFF(i) END DO ELSE IF (IFUNC.eq.1112) THEN DO i = BRBUFF, ERBUFF Sebp(i) = RBUFF(i) END DO ELSE IF (IFUNC.eq.1113) THEN DO i = BRBUFF, ERBUFF Sebq(i) = RBUFF(i) END DO c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.2200) THEN allzro = .true. DO i = BRBUFF, ERBUFF Sttrse(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvtrse=.not.allzro Lsttse = ERBUFF + Pos1ob - 1 ELSE IF (IFUNC.eq.2201) THEN allzro = .true. DO i = BRBUFF, ERBUFF Stsfse(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvsfse = .not.allzro Lstsse = ERBUFF + Pos1ob - 1 ELSE IF (IFUNC.eq.2202) THEN allzro = .true. DO i = BRBUFF, ERBUFF Stcyse(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvcyse = .not.allzro Lstyse = ERBUFF + Pos1ob - 1 ELSE IF (IFUNC.eq.2203) THEN allzro = .true. DO i = BRBUFF, ERBUFF Stsase(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvsase = .not.allzro Lstase = ERBUFF + Pos1ob - 1 ELSE IF (IFUNC.eq.1256) THEN allzro = Hvtrse DO i = BRBUFF, ERBUFF Sttrse(i+Posfob) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvtrse=.not.allzro Lsttse = ERBUFF + Posfob ELSE IF (IFUNC.eq.1258) THEN allzro = Hvsfse DO i = BRBUFF, ERBUFF Stsfse(i+Posfob) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvsfse = .not.allzro Lstsse = ERBUFF + Posfob ELSE IF (IFUNC.eq.1259) THEN allzro = Hvcyse DO i = BRBUFF, ERBUFF Stcyse(i+Posfob) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvcyse = .not.allzro Lstyse = ERBUFF + Posfob ELSE IF (IFUNC.eq.1257) THEN allzro = Hvsase DO i = BRBUFF, ERBUFF Stsase(i+Posfob) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvsase = .not.allzro Lstase = ERBUFF + Posfob c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.2501) THEN allzro = .true. DO i = BRBUFF, ERBUFF Setcyc(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvscyc = .not.allzro ELSE IF (IFUNC.eq.2502) THEN allzro = .true. DO i = BRBUFF, ERBUFF Setltt(i+Pos1ob-1) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvsltt = .not.allzro c----------------------------------------------------------------------- ELSE IF (IFUNC.eq.3001) THEN allzro = .true. DO i = BRBUFF, ERBUFF Odiff(i) = RBUFF(i) allzro = dpeq(RBUFF(i),0D0).and.allzro END DO Hvodff = .not.allzro Nodiff = ERBUFF - BRBUFF END IF C END OF CODE BLOCK end C C C*GETSERIENAMES C+ C C SUBROUTINE GETSERIENAMES (TITLE,NZ,NYER,NPERS,IFAIL) C C THIS SUBROUTINE PROVIDE THE SERIES TITLE, ITS C NUMBER OF OBSERVATION, ITS STARTING YEAR, ITS FIRST PERIOD C AND ITS THE FREQUENCY FOR THE TABLE OUTPUT TO SEATS C C TITLE : CHARACTER*80 the series title C NZ : INTEGER the number of observations C NYER : INTEGER the first year of the series C NPERS : INTEGER the first period of the series C IFAIL : INTEGER the return values are : C 0 if the read is OK C 1 some error has occurred C-- C LINES OF CODE COMMENTED FOR X-13A-S : 1 C subroutine GETSERIENAMES(title,nz,nyer,npers,ifail) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 subroutine GETSERIENAMES(stitle,nz,nyer,npers,nfreq,ifail) C END OF CODE BLOCK C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Not Read, Overwritten .. C LINES OF CODE COMMENTED FOR X-13A-S : 1 C character*80 title C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 character*80 stitle C END OF CODE BLOCK integer nz integer nyer integer npers integer nfreq integer ifail C LINES OF CODE ADDED FOR X-13A-S : 3 INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'title.cmn' C END OF CODE BLOCK C C ... Executable Statements ... C ifail = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 2 C read (5,'(A)',END = 5000) title C read (5,*,END = 5000) nz, nyer, npers C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 4 stitle=Title nz=Nspobs nyer=Begspn(YR) npers=Begspn(MO) nfreq=Sp C END OF CODE BLOCK return C LINES OF CODE COMMENTED FOR X-13A-S : 1 C 5000 ifail = 1 C END OF CODE BLOCK end C C C*GETSERIES C+ C SUBROUTINE GETSERIES(OZ,NZ,IFAIL) C C THIS SUBROUTINE PROVIDE THE SERIES TO SEATS C C OZ : REAL*8 ARRAY the series to be processed C NZ : INTEGER the number of observation C IFAIL : INTEGER return value are : C 0 if everything is OK C 1 if some error has occurred C C-- subroutine GETSERIES(oz,nz,ifail) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. C.. In/Out Status: Not Read, Maybe Written .. real*8 oz(mpkp) C.. In/Out Status: Read, Not Written .. integer nz C.. In/Out Status: Not Read, Overwritten .. integer ifail C C.. Local Scalars .. integer i C LINES OF CODE ADDED FOR X-13A-S : 3 INCLUDE 'x11ptr.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'units.cmn' integer i2 C END OF CODE BLOCK C C ... Executable Statements ... C ifail = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 1 C read (5,*,ERR = 5000,END = 5000) (oz(i), i = 1,nz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 4 DO I=1,NZ i2=i+Pos1ob-1 * OZ(I)=Orig(i2) OZ(I)=Stcsi(i2) END DO * write(Mtprof,*) ' oz(1) = ',oz(1) C END OF CODE BLOCK return C LINES OF CODE COMMENTED FOR X-13A-S : 1 C 5000 ifail = 1 C END OF CODE BLOCK end C C C C* NMLSTS C+ C C C THIS SUBROUTINE PROVIDE TO MANIPULATE THE NAMELIST INPUT. C C The list of parameter named L_... correspond exactly to the C SEATS input parameter. C ICODE : INTEGER is used to specify the action to be taken C on the namelist : C 0 set the namelist to the default values C 1 read the namelist C 2 save the namelist C 3 remove the saved namelist C 4 get the saved namelist C 5 write NAMELIST in REPORT.BUG file C opened with devnum 77 C IFAIL : INTEGER the return value : C 0 everything OK C 1 some error has occurred C-- C Modified by REG on 30 Aug 2005 to add l_nfixed to NMLSTS parameter list subroutine NMLSTS(l_Nochmodel,l_type,l_init,l_lam,l_imean,l_p, $ l_d,l_q,l_bp,l_bd,l_bq, $ l_sqg,l_mq,l_m,l_iqm,l_maxit,l_fh,l_noserie,l_pg,l_modelsumm, $ l_out,l_seas,l_noadmiss,l_OutNA,l_stochTD, $ l_iter,l_qmax,l_har,l_bias,l_tramo, $ l_model,l_noutr,l_nouir,l_nous,l_npatd,l_npareg,l_interp,l_rsa, $ l_fortr,l_neast,l_epsiv,l_epsphi,l_ta,l_xl,l_rmod, $ l_blqt,l_tmu,l_phi,l_th,l_bphi,l_bth,l_thlim,l_bthlim,l_crmean, $ l_hplan, $ l_hpcycle,l_rogtable,l_centrregs, $ l_statseas,l_units,l_kunits,l_acfe,l_posbphi,l_printphtrf, $ l_tabtables,l_psieinic,l_psiefin, $ l_firstobs,l_lastobs,l_HPper,l_maxSpect,l_brol,l_blamda, $ l_bserie,l_bmid,l_bcMark,l_Odate,l_Olen,l_DetSeas, $ l_nds,nz,l_nfixed,icode,ifail) C C C.. Implicits .. implicit none C C.. Parameters .. integer n1 LOGICAL F,T parameter (n1 = 1,F=.false.,T=.true.) C C.. Formal Arguments .. integer l_type,l_init,l_lam,l_imean,l_p,l_d,l_q,l_bp,l_bd,l_bq, $ l_sqg,l_mq,l_m,l_iqm,l_maxit,l_fh,l_noserie, $ l_pg,l_out,l_seas,l_noadmiss,l_outNA,l_stochTD,l_iter, $ l_qmax,l_har,l_bias,l_tramo,l_model,l_noutr,l_nouir, $ l_npatd,l_npareg,l_interp,l_rsa,l_fortr,l_neast integer l_nous,l_Nochmodel,nz,ifail integer l_hpcycle,l_rogtable,l_statseas, $ l_units,l_kunits,l_crmean,l_acfe,l_posbphi, $ l_printphtrf,icode,l_centrregs,l_psieinic,l_psiefin real*8 l_epsiv,l_epsphi,l_ta,l_xl,l_rmod,l_blqt, $ l_tmu,l_phi(3*n1),l_th(3*n1),l_bphi(3*n1),l_bth(3*n1), $ l_thlim,l_bthlim,l_hplan,l_HPper,l_maxSpect real*8 l_brol,l_blamda real*8 l_DetSeas(12*n1) integer l_bserie,l_bmid,l_bcMark character l_tabtables*100 character l_firstobs*7,l_lastobs*7,l_Odate*7 integer l_Olen,l_nds,l_modelsumm C.. Added by REG on 30 Aug 2005 to create input/output variable l_nfixed integer l_nfixed C C.. Local Scalars .. integer bd,bias,bp,bq,d,fh,fortr,har,hpcycle,i,imean, $ init,interp,iqm,iter,l,lam,m,maxit,model,mq, $ neast,noadmiss,outNA,stochTD,modelsumm, $ noserie,nouir,noutr,npareg,npatd,out, $ p,pg,q,qmax,rogtable,rsa,statseas,units,kunits integer nous,Nochmodel,centrregs,psieinic,psiefin integer Olen,nds integer seas,sqg,tramo,type,crmean,acfe,posbphi,printphtrf real*8 blqt,epsiv,epsphi,hplan,rmod, $ ta,thlim,bthlim,tmu,xl,HPper,maxSpect real*8 brol,blamda real*8 DetSeas(12*n1) integer bserie,bmid,bcMark character tabtables*100 character firstobs*7,lastobs*7,Odate*7 C.. Added by REG on 30 Aug 2005 to create local variable nfixed integer nfixed C C.. Local Arrays .. real*8 bphi(3*n1),bth(3*n1),phi(3*n1),th(3*n1) C C.. External Calls .. external CLOSEDEVICE, OPENDEVSCRATCH, SETDEFAULT C C.. Namelist Declarations .. C.. Modified by REG on 30 Aug 2005 to add nfixed to input namelist namelist /input/ type, init, lam, imean, p, d, q, bp, bd, bq, sqg, $ mq, phi, th, bphi, bth, l, m, iqm, $ maxit, epsiv, epsphi, fh, noserie, pg,modelsumm, $ ta, xl, out, seas, noadmiss, outNA, stochTD, $ crmean, iter, bias, tramo, model, noutr, nouir, $ neast, npatd, npareg, interp, rsa, qmax, rmod, $ thlim, bthlim, har, fortr, blqt, tmu, $ hplan, hpcycle, rogtable, $ statseas, units, kunits, acfe, $ posbphi, nous, nochmodel, printphtrf, centrregs, $ tabtables, psieinic, psiefin, $ firstobs,lastobs,HPper,maxSpect,brol, $ blamda,bserie,bmid,bcMark,Odate,Olen, $ DetSeas,Nds,nfixed C LINES OF CODE ADDED FOR X-13A-S : 40 INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'seattb.i' INCLUDE 'seatop.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ INTEGER strinx LOGICAL dpeq,istrue DOUBLE PRECISION totals EXTERNAL dpeq,totals,istrue,strinx c ------------------------------------------------------------------ DOUBLE PRECISION Y,Userx,Critvl,Ciprob,Lam2,tmp,Cvalfa,Cvrduc, & Chi2cv,Tlimit,Pvaic DOUBLE PRECISION QsRsd,QsRsd2 INTEGER Fcntyp,Nobs,Nrusrx,Bgusrx,Mxiter,Mxnlit,Mxcklg,Begtst, & Endtst,Fctdrp,Begsrs,Frstsy,Begmdl,Endmdl,Nomnfy,iqst, & Lsrun,imu DIMENSION Y(PLEN),Begsrs(2),Userx(PUSERX),Bgusrx(2),Critvl(POTLR), & Begtst(2),Endtst(2),Begmdl(2),Endmdl(2) c ------------------------------------------------------------------ COMMON /armalm/ Lam2,Fcntyp c add DOUBLE PRECISION QsRsd,QsRsd2, same as arima.cmn - Jan. 2021 COMMON /armadp/ Y,Userx,Critvl,Ciprob,Cvalfa,Cvrduc,Chi2cv,Tlimit, & Pvaic,QsRsd,QsRsd2 COMMON /armain/ Nobs,Nrusrx,Bgusrx,Mxiter,Mxnlit,Mxcklg,Begtst, & Endtst,Fctdrp,Begsrs,Frstsy,Begmdl,Endmdl,Nomnfy, & Lsrun c ------------------------------------------------------------------ INTEGER PR PARAMETER (PR=PLEN/4) INCLUDE 'autoq.cmn' C END OF CODE BLOCK C C ... Executable Statements ... C C C ifail = 0 if (icode .eq. 0) then C.. Modified by REG on 30 Aug 2005 to add l_nfixed to SETDEFAULT c parameter list call SETDEFAULT(l_Nochmodel,l_type,l_init,l_lam,l_imean,l_p, $ l_d,l_q,l_bp,l_bd,l_bq,l_sqg,l_mq,l_m,l_iqm, $ l_maxit,l_fh,l_noserie,l_pg,l_modelsumm, $ l_out,l_seas,l_noadmiss,l_outNa,l_stochTD, $ l_iter,l_qmax,l_har, $ l_bias,l_tramo,l_model,l_noutr,l_nouir,l_nous, $ l_npatd,l_npareg,l_interp,l_rsa,l_fortr, $ l_neast,l_epsiv,l_epsphi,l_ta,l_xl,l_rmod, $ l_blqt,l_tmu,l_phi,l_th,l_bphi,l_bth, $ l_thlim,l_bthlim,l_crmean,l_hplan,l_hpcycle, $ l_rogtable,l_centrregs, $ l_statseas,l_units,l_kunits, $ l_acfe,l_posbphi,l_printphtrf, $ l_tabtables,l_psieinic, $ l_psiefin,l_firstobs,l_lastobs, $ l_hpPer,l_maxSpect,l_brol,l_blamda,l_bserie, $ l_bmid,l_bcMark,l_Odate,l_Olen,l_DetSeas,l_nds,nz,l_nfixed) return end if if (icode .eq. 1) then do i=1,12*n1 DetSeas(i)=l_DetSeas(i) enddo modelsumm=l_modelsumm nds = l_nds Olen = l_Olen Odate = l_Odate firstobs = l_firstobs lastobs = l_lastobs psieinic = l_psieinic psiefin = l_psiefin maxSpect = l_maxSpect brol=l_brol blamda=l_blamda bserie=l_bserie bmid=l_bmid bcmark=l_bcMark tabtables = l_tabtables nochmodel = l_Nochmodel acfe = l_acfe posbphi=l_posbphi printphtrf = l_printphtrf units = l_units kunits = l_kunits statseas = l_statseas seas = l_seas blqt = l_blqt tmu = l_tmu fortr = l_fortr har = l_har rsa = l_rsa rmod = l_rmod thlim = l_thlim bthlim = l_bthlim qmax = l_qmax model = l_model noutr = l_noutr nouir = l_nouir nous = l_nous neast = l_neast npatd = l_npatd npareg = l_npareg bias = l_bias sqg = l_sqg type = l_type init = l_init interp = l_interp noserie = l_noserie lam = l_lam imean = l_imean p = l_p d = l_d fh = l_fh q = l_q bp = l_bp bd = l_bd bq = l_bq mq = l_mq out = l_out do i = 1,3*n1 phi(i) = l_phi(i) bphi(i) = l_bphi(i) th(i) = l_th(i) epsphi = l_epsphi bth(i) = l_bth(i) end do xl = l_xl m = l_m iqm = l_iqm ta = l_ta maxit = l_maxit epsiv = l_epsiv pg = l_pg noadmiss = l_noadmiss OutNA = l_outNA stochTD = l_stochTD tramo = l_tramo crmean = l_crmean iter = l_iter hplan = l_hplan hpPer = l_HPper hpcycle = l_hpcycle rogtable = l_rogtable centrregs = l_centrregs C.. Added by REG on 30 Aug 2005 to set nfixed based on l_nfixed nfixed = l_nfixed C LINES OF CODE COMMENTED FOR X-13A-S : 83 C read (5,input,END = 5000,ERR = 5000) C do i=1,12*n1 C l_DetSeas(i)=DetSeas(i) C enddo C l_modelsumm=modelsumm C l_nds = nds C l_Odate = Odate C l_Olen = Olen C l_firstobs = firstobs C l_lastobs = lastobs C l_html = html C l_psieinic = psieinic C l_psiefin = psiefin * l_maxSpect = maxSpect * l_brol=brol * l_blamda=blamda * l_bserie=bserie * l_bmid=bmid * l_bcMark=bcMark C l_tabtables = tabtables C l_Nochmodel = nochmodel C l_printphtrf = printphtrf C l_acfe = acfe C l_posbphi=posbphi C l_units = units C l_kunits = kunits C l_statseas = statseas C l_seas = seas C l_blqt = blqt C l_tmu = tmu C l_fortr = fortr C l_har = har C l_rsa = rsa C l_rmod = rmod * l_thlim = thlim * l_bthlim = bthlim C l_qmax = qmax C l_model = model C l_noutr = noutr C l_nouir = nouir C l_neast = neast C l_npatd = npatd C l_npareg = npareg C l_bias = bias C l_sqg = sqg C l_type = type C l_init = init C l_interp = interp C l_noserie = noserie C l_lam = lam C l_imean = imean C l_p = p C l_d = d C l_fh = fh C l_q = q C l_bp = bp C l_bd = bd C l_bq = bq C l_mq = mq C do i = 1,3*n1 C l_phi(i) = phi(i) C l_bphi(i) = bphi(i) C l_th(i) = th(i) C l_epsphi = epsphi C l_bth(i) = bth(i) C end do C l_xl = xl C l_m = m C l_iqm = iqm C l_ta = ta C l_maxit = maxit C l_epsiv = epsiv C l_pg = pg C l_noadmiss = noadmiss C OutNA =l_outNA C stochTD = l_stochTD C l_tramo = tramo C l_crmean = crmean C l_iter = iter C l_out = out C l_hplan = hplan C l_HPper = HPper C l_hpcycle = hpcycle C l_rogtable = rogtable C l_centrregs = centrregs C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 61 c ------------------------------------------------------------------ c set up values from X-12 modeling procedures c ------------------------------------------------------------------ IF (dpeq(Lam2,0D0)) THEN L_LAM=0 ELSE L_LAM=1 END IF C.. Modified by REG on 30 Aug 2005 to add l_nfixed to nmlmdl parameter list CALL nmlmdl(3*N1,L_p,L_bp,L_d,L_bd,L_q,L_bq,L_Th,L_Bth,L_Phi, & L_BPhi,Xl,L_Nfixed) IF(Lfatal)RETURN L_PG = 1 L_INIT = 2 IF((Issap.eq.2.and.Sstran).or.(Irev.eq.4.and.Rvtran))THEN * L_OUT = 3 L_OUT = 2 Lsgud=F ELSE IF(Out2.ne.NOTSET)L_Out=Out2 IF(istrue(Prttab,LSETRN,NTBL-11))L_OUT=3 Lsgud=T END IF L_TRAMO = 1 IF(Nusrrg.gt.0)L_NPAREG=1 IF(Nflwtd.gt.0.or.Nln.gt.0.or.Nlp.gt.0)L_NPATD=1 IF(NAO.gt.0.or.NTC.gt.0)L_NOUIR=1 IF(NLS.gt.0.or.NRamp.gt.0)L_NOUTR=1 IF(Nhol.gt.0)L_NEAST=1 IF(NSO.gt.0)L_NOUS=1 iqst = MIN(Mxcklg,2*Sp) L_BLQT = Qs(iqst) tmp = totals(Y,Frstsy,Frstsy+Nspobs-1,1,1) L_TMU = tmp L_MQ = Sp IF(Lnoadm)THEN L_NOADMISS=1 ELSE L_NOADMISS=0 END IF l_outNA = 0 l_stochTD = -1 IF(Kmean.eq.NOTSET)THEN L_IMEAN=0 imu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(imu.gt.0)L_IMEAN=1 ELSE IF (Kmean.eq.1) THEN L_IMEAN=1 ELSE L_IMEAN=0 END IF IF(Lhp)THEN IF(dpeq(Hplan2,DNOTST))THEN L_hpcycle=-1 ELSE L_hpcycle=1 IF(Hptrgt.ne.NOTSET)L_hpcycle=Hptrgt END IF ELSE L_hpcycle=0 END IF IF(Lstsea)THEN L_statseas=1 ELSE L_statseas=0 END IF IF(Lmdsum)THEN L_modelsumm=1 ELSE L_modelsumm=0 END IF IF(Qmax2.ne.NOTSET)L_QMAX=Qmax2 IF(Maxit2.ne.NOTSET)L_MAXIT=Maxit2 IF(Iphtrf.ne.NOTSET)L_printphtrf=Iphtrf IF(Tabtbl(1:1).ne.CNOTST)L_tabtables=Tabtbl IF(.not.dpeq(Epsph2,DNOTST))L_Epsphi=Epsph2 IF(.not.dpeq(Xl2,DNOTST))L_Xl=Xl2 IF(.not.dpeq(Rmod2,DNOTST))L_rmod=Rmod2 IF(.not.dpeq(Epsiv2,DNOTST))L_epsiv=Epsiv2 IF(.not.dpeq(Hplan2,DNOTST))THEN L_hplan=Hplan2 IF(L_hpcycle.eq.0)THEN L_hpcycle=1 IF(Hptrgt.ne.NOTSET)L_hpcycle=Hptrgt END IF END IF L_fh=Nfcst * IF(Nfcst.gt.2*Sp)L_fh=2*Sp IF(Bias2.eq.NOTSET)THEN IF(L_Bias.eq.-2)L_Bias=1 ELSE L_Bias=Bias2 END IF C END OF CODE BLOCK c add code for benchmarking options once I know what they are * l_maxSpect = * l_brol = * l_blamda = * l_bserie = * l_bround = * l_bmid = * l_bcMark = * return else if (icode .eq. 2) then call OPENDEVSCRATCH(32) do i=1,12*n1 DetSeas(i)=l_DetSeas(i) enddo modelsumm=l_modelsumm firstobs = l_firstobs lastobs = l_lastobs psieinic = l_psieinic psiefin = l_psiefin maxSpect = l_maxSpect brol=l_brol blamda=l_blamda bserie=l_bserie bmid=l_bmid bcMark=l_bcMark tabtables = l_tabtables nochmodel = l_Nochmodel printphtrf = l_printphtrf acfe = l_acfe posbphi=l_posbphi units = l_units kunits = l_kunits statseas = l_statseas seas = l_seas blqt = l_blqt tmu = l_tmu fortr = l_fortr har = l_har rsa = l_rsa rmod = l_rmod thlim = l_thlim bthlim = l_bthlim qmax = l_qmax model = l_model noutr = l_noutr nouir = l_nouir nous = l_nous neast = l_neast npatd = l_npatd npareg = l_npareg bias = l_bias sqg = l_sqg type = l_type init = l_init interp = l_interp noserie = l_noserie lam = l_lam imean = l_imean p = l_p d = l_d fh = l_fh q = l_q bp = l_bp bd = l_bd bq = l_bq mq = l_mq out = l_out do i = 1,3*n1 phi(i) = l_phi(i) bphi(i) = l_bphi(i) th(i) = l_th(i) epsphi = l_epsphi bth(i) = l_bth(i) end do xl = l_xl m = l_m iqm = l_iqm ta = l_ta maxit = l_maxit epsiv = l_epsiv pg = l_pg noadmiss = l_noadmiss tramo = l_tramo crmean = l_crmean iter = l_iter hplan = l_hplan HPper = l_HPper hpcycle = l_hpcycle rogtable = l_rogtable centrregs = l_centrregs C.. Added by REG on 30 Aug 2005 to set nfixed based on l_nfixed nfixed = l_nfixed write (32,input) return else if (icode .eq. 3) then call CLOSEDEVICE(32) return end if if (icode .eq. 4) then rewind (32) read (32,input) do i=1,12*n1 l_DetSeas(i)=DetSeas(i) enddo l_modelsumm = modelsumm l_nds = nds l_Odate = Odate l_Olen = Olen l_firstobs = firstobs l_lastobs = lastobs l_psieinic = psieinic l_psiefin = psiefin l_maxSpect = maxSpect l_brol=brol l_blamda=blamda l_bserie=bserie l_bmid=bmid l_bcMark=bcMark l_tabtables = tabtables l_Nochmodel = nochmodel l_printphtrf = printphtrf l_acfe = acfe l_posbphi=posbphi l_units = units l_kunits = kunits l_statseas = statseas l_seas = seas l_blqt = blqt l_tmu = tmu l_fortr = fortr l_har = har l_rsa = rsa l_rmod = rmod l_bthlim = bthlim l_qmax = qmax l_model = model l_noutr = noutr l_nouir = nouir l_nous = nous l_neast = neast l_npatd = npatd l_npareg = npareg l_bias = bias l_sqg = sqg l_type = type l_init = init l_interp = interp l_noserie = noserie l_lam = lam l_imean = imean l_p = p l_d = d l_fh = fh l_q = q l_bp = bp l_bd = bd l_bq = bq l_mq = mq do i = 1,3*n1 l_phi(i) = phi(i) l_bphi(i) = bphi(i) l_th(i) = th(i) l_epsphi = epsphi l_bth(i) = bth(i) end do l_m = m l_iqm = iqm l_ta = ta l_maxit = maxit l_epsiv = epsiv l_pg = pg l_noadmiss = noadmiss l_outNA= OutNA l_stochTD = stochTD l_tramo = tramo l_crmean = crmean l_iter = iter l_out = out l_hplan = hplan l_HPper = HPper l_hpcycle = hpcycle l_rogtable = rogtable l_centrregs = centrregs C.. Added by REG on 30 Aug 2005 to set l_nfixed based on nfixed l_nfixed = nfixed return end if end if 5000 ifail = 1 end C C* TAKEDETTRAMO C+ C C SUBROUTINE TAKEDETTRAMO (TRAM,PAOUTR,PAOUIR,PAEAST,PATD, C NEFF,PAREG,NPAREG,NLEN,LAM,IFAIL) C C THIS FUNCTION PROVIDE TO TAKE THE DETERMINISTIC COMPONENT FORM TRAMO C C TRAM : REAL*8 array with the original series from tramo C PAOUTR : REAL*8 array with the level shift outlier component from TRAMO C PAOUIR : REAL*8 array with transitory change outlier component from TRAMO C PAEAST : REAL*8 array withe the easter effect component from TRAMO C PATD : REAL*8 array with the trading day effect component from TRAMO C NEFF : INTEGER ARRAY which test if the regression component variable C for the sthocastic component of SEATS exist or not C PAREG : REAL*8 matrix with the regression component effects to assigne C to the SEATS components C NPAREG : INTEGER check if exists the regression variable component C NLEN : INTEGER the length of the series + its forecast C LAM : INTEGER the transformation used by SEATS C IFAIL : INTEGER return the value : C 0 if everything is OK C 1 if some error is occurred C-- subroutine TAKEDETTRAMO(tram,paoutr,paouir,paous,paeast,patd, C LINES OF CODE COMMENTED FOR X-13A-S : 1 C $ pareg,tse,npareg,nlen,nf,lam,ifail) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 $ neff,pareg,tse,npareg,nlen,nf,lam2,ifail) C END OF CODE BLOCK C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' * INCLUDE 'model.prm' C C.. Formal Arguments .. C LINES OF CODE COMMENTED FOR X-13A-S : 1 C integer neff(0:6),npareg,nlen,nf,lam,ifail C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 integer neff(0:7),npareg,nlen,nf,lam2,ifail C END OF CODE BLOCK real*8 tram(mpkp),paoutr(mpkp),paouir(mpkp),paous(mpkp), $ paeast(mpkp),patd(mpkp),pareg(mpkp,0:7),tse(kp), $ facint C C.. Local Scalars .. integer i,j C LINES OF CODE ADDED FOR X-13A-S : 7 integer i2 * INCLUDE 'arima.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'seatad.cmn' * INCLUDE 'inpt.cmn' C END OF CODE BLOCK C C ... Executable Statements ... C ifail = 0 C LINES OF CODE COMMENTED FOR X-13A-S : 8 C read (5,*,END = 5000) C $ ( C $ tram(i), paoutr(i), paouir(i), paeast(i), patd(i), i = 1,nlen C $ ) C read (5,*,END = 5000) C $ ( C $ tram(nlen+i), paoutr(nlen+i), paouir(nlen+i), paeast(nlen+i), C $ patd(nlen+i), tse(i), i = 1,nf) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 22 DO i = 1,NLEN+Nf TRAM(i)=Orixs(i) i2=i+Pos1ob-1 PATD(i)=FACTD(i2) PAEAST(i)=FACHOL(i2) PAOUTR(i)=FACLS(i2) IF(LAM2.eq.0)THEN PAOUIR(i)=FACAO(i2)*FACTC(i2) ELSE PAOUIR(i)=FACAO(i2)+FACTC(i2) END IF PAOUS(i)=FACSO(i2) END DO do i = 1,nf tse(i)=Fctses(i) end do neff(0) = 0 neff(1) = 0 neff(2) = 0 neff(3) = 0 neff(4) = 0 neff(5) = 0 neff(6) = 0 neff(7) = 0 C END OF CODE BLOCK facint=0D0 if (lam2 .eq. 0) facint=1D0 if (npareg .eq. 1) then C LINES OF CODE COMMENTED FOR X-13A-S : 6 C read (5,*,END = 5000) (neff(i), i = 0,6) C read (5,*,END = 5000) C $ ( C $ pareg(i,0), pareg(i,1), pareg(i,2), pareg(i,3), pareg(i,4), C $ pareg(i,5), pareg(i,6), i = 1,nlen+nf) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 19 IF(Nusrrg.gt.0)THEN IF(Adjusr.eq.1)THEN IF(Finusr)THEN Neff(0)=1 ELSE Neff(4)=1 END IF END IF c source added to generate seasonal regression factor when SEATS c is specified for seasonal adjustment (BCM 04-10-05) IF(Adjsea.eq.1)NEFF(2)=1 IF(Adjcyc.eq.1)NEFF(5)=1 DO i=1,NLEN+nf i2=i+Pos1ob-1 IF(Adjusr.eq.1)THEN IF(Finusr)THEN PAREG(i,0)=Facusr(i2) PAREG(i,4)=facint ELSE PAREG(i,4)=Facusr(i2) PAREG(i,0)=facint END IF ELSE pareg(i,0)=facint PAREG(i,4)=facint END IF PAREG(i,1)=facint c source added to generate seasonal regression factor when SEATS c is specified for seasonal adjustment (BCM 04-10-05) IF(Adjsea.eq.1)THEN PAREG(i,2)=Facsea(i2) ELSE PAREG(i,2)=facint END IF PAREG(i,3)=facint IF(Adjcyc.eq.1)THEN PAREG(i,5)=Faccyc(i2) ELSE PAREG(i,5)=facint END IF PAREG(i,6)=facint PAREG(i,7)=facint END DO END IF C END OF CODE BLOCK return else C LINES OF CODE COMMENTED FOR X-13A-S : 1 C if (lam .eq. 0) then C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 if (lam2 .eq. 0) then C END OF CODE BLOCK do i = 1,mpkp do j = 0,7 pareg(i,j) = 1.0d0 end do end do else do i = 1,mpkp do j = 0,7 pareg(i,j) = 0.0d0 end do end do end if return end if C LINES OF CODE COMMENTED FOR X-13A-S : 1 C 5000 ifail = 1 C END OF CODE BLOCK end C.. Modified by REG on 30 Aug 2005 to add l_nfixed to SETDEFAULT c parameter list subroutine SETDEFAULT(l_Nochmodel,l_type,l_init,l_lam,l_imean, $ l_p,l_d,l_q,l_bp,l_bd,l_bq,l_sqg,l_mq,l_m,l_iqm, $ l_maxit,l_fh,l_noserie,l_pg,l_modelsumm, $ l_out,l_seas,l_noadmiss,l_outNa,l_stochTD,l_iter, $ l_qmax,l_har,l_bias,l_tramo,l_model,l_noutr, $ l_nouir,l_nous,l_npatd,l_npareg,l_interp, $ l_rsa,l_fortr,l_neast,l_epsiv, $ l_epsphi,l_ta,l_xl,l_rmod, $ l_blqt,l_tmu,l_phi,l_th,l_bphi,l_bth, $ l_thlim,l_bthlim,l_crmean,l_hplan, $ l_hpcycle,l_rogtable,l_centrregs, $ l_statseas,l_units,l_kunits, $ l_acfe,l_posbphi,l_printphtrf, $ l_tabtables,l_psieinic,l_psiefin, $ l_firstobs,l_lastobs,l_HPper,l_maxSpect, $ l_brol,l_blamda,l_bserie,l_bmid,l_bcMark, $ l_Odate,l_Olen,l_DetSeas,l_nds,nz,l_nfixed) C C C.. Implicits .. implicit none C C.. Parameters .. integer n1 parameter (n1 = 1) C C.. Formal Arguments .. integer l_type,l_init,l_lam,l_imean,l_p,l_d,l_q,l_bp,l_bd,l_bq, $ l_sqg,l_mq,l_m,l_iqm,l_maxit,l_fh,l_noserie, $ l_pg,l_modelsumm,l_out,l_seas,l_noadmiss,l_outNA, $ l_stochTD,l_iter,l_qmax,l_har,l_bias,l_tramo,l_model, $ l_noutr,l_nouir,l_npatd,l_npareg,l_interp,l_rsa integer l_fortr,l_neast,l_nous,l_Nochmodel integer l_hpcycle,l_rogtable,l_statseas, $ l_units, l_kunits,l_crmean, $ l_acfe,l_posbphi,l_printphtrf, $ l_centrregs,l_psieinic,l_psiefin,nz real*8 l_epsiv,l_epsphi,l_ta,l_xl,l_rmod,l_blqt, $ l_tmu,l_phi(3*n1),l_th(3*n1),l_bphi(3*n1),l_bth(3*n1), $ l_thlim,l_bthlim,l_hplan,l_HPper,l_maxSpect real*8 l_brol,l_blamda real*8 l_DetSeas(12*n1) integer l_bserie,l_bmid,l_bcMark character l_tabtables*100 character l_firstobs*7,l_lastobs*7,l_Odate*7 integer l_Olen,l_nds C.. Added by REG on 30 Aug 2005 to create input/output variable l_nfixed integer l_nfixed C C.. Local Scalars .. integer i C C ... Executable Statements ... C do i=1,12*n1 l_DetSeas(i)=0.0d0 enddo l_modelsumm = -1 l_nds = 0 l_Odate='00-0000' l_Olen=0 l_tabtables = 'all' l_psieinic = -24 l_psiefin = 24 l_maxSpect = 100.0D0 l_brol=1.0d0 l_blamda=0.0d0 l_bserie=0 l_bmid=0 l_bcMark=0 l_firstobs = '00-0000' l_lastobs = '00-0000' l_Nochmodel = 0 l_printphtrf = 0 l_acfe = 0 l_posbphi = 0 l_units = 0 l_kunits = 0 l_statseas = 0 l_seas = 1 l_blqt = 0.0d0 l_tmu = 0.0d0 l_fortr = 1 l_har = 0 l_rsa = 0 l_rmod = .50d0 l_thlim = 0.0d0 l_bthlim = 0.0d0 l_qmax = 50 l_model = 0 l_noutr = 0 l_nouir = 0 l_nous = 0 l_neast = 0 l_npatd = 0 l_npareg = 0 l_bias = -2 l_sqg = 1 l_type = 0 l_init = 0 l_interp = 0 l_noserie = 0 l_lam = 1 l_imean = 1 l_p = 0 l_d = 1 l_fh = 8 l_q = 1 l_bp = 0 l_bd = 1 l_bq = 1 l_mq = 12 l_out = 0 do i = 1,3 l_phi(i) = 0.0d0 l_bphi(i) = 0.0d0 l_th(i) = 0.0d0 l_epsphi = 2.0d0 l_bth(i) = 0.0d0 end do l_xl = 0.99d0 l_m = 36 l_iqm = 999 l_ta = 100.0d0 l_maxit = 20 l_epsiv = 0.001d0 C LINES OF CODE COMMENTED FOR X-13A-S : 1 C l_pg = 0 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 l_pg = 1 C END OF CODE BLOCK l_noadmiss = 1 l_outNA = 0 l_stochTD = -1 l_tramo = 999 l_crmean = 0 l_hpcycle = -1 C LINES OF CODE COMMENTED FOR X-13A-S : 1 C l_rogtable = 0 C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 l_rogtable = 1 C END OF CODE BLOCK l_hplan = -1.0d0 l_hpPer = -1.0d0 l_centrregs = 1 c if ((l_iter.ne.1) .and. (l_iter.ne.3)) then l_iter = 0 c end if C.. Added by REG on 30 Aug 2005 to initialize l_nfixed l_nfixed = 0 end C C*OPENINFILE C+ C SUBROUTINE OPENINFILE(FNAME,IFAIL) C C THIS SUBROUTINE PROVIDE TO OPEN THE INPUT FILE C C FNAME : CHARACTER*180 the input file name C IFAIL : INTEGER the return value are : C C 0 ok C 1 an error condition during the open C 2 check if file exist failed C-- subroutine OPENINFILE(fname,ifail) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. character*180 fname C.. In/Out Status: Not Read, Overwritten .. integer ifail C C.. External Calls .. external OPENDEVICEASIS C C ... Executable Statements ... C call OPENDEVICEASIS(fname,5,1,ifail) end C*CLOSEINFILE C C SUBROUTINE CLOSEINFILE() C C THIS FUNCTION PROVIDE TO CLOSE THE INPUT DEVICE C-- subroutine CLOSEINFILE C C.. Implicits .. implicit none C C.. External Calls .. external CLOSEDEVICE C C ... Executable Statements ... C call CLOSEDEVICE(5) end C C C cc c cc cc c cc integer function SerCount() C C.. Implicits .. implicit none C C C.. Local Scalars .. include 'stdio.i' SerCount = Imeta RETURN end c cc character*(*) function GetToken(Line,index) C C.. Implicits .. implicit none C C.. Parameters .. integer index character*(*) Line C C.. Local Scalars .. integer i,numtok,intok,stTok,enTok C C.. External Functions .. integer ISTRLEN external ISTRLEN numtok = 0 intok = 0 stTok = 0 enTok = 0 do i=1, ISTRLEN(Line) if ((intok .eq. 0) .and. (Line(i:i) .ne. ' ')) then numtok = numtok + 1 intok = 1 stTok = i end if if (Line(i:i) .eq. ' ') then intok = 0 enTok = i-1 end if if ((numtok .eq. index) .and. (intok .eq. 0) ) then GetToken = Line(stTok:enTok) return end if end do if ((numtok .eq. index) .and. (intok .eq. 1) ) then GetToken = Line(stTok:ISTRLEN(Line)) return end if GetToken = '' return end CC C CC logical function isDouble (Txt) C C.. Implicits .. implicit none C C.. Parameters .. character*(*) Txt C C.. Local Scalars .. real*8 Dnum integer iflag read (txt,'(f18.0)',iostat=iflag) Dnum if (iflag > 0) then isDouble = .false. else isDouble = .true. end if return end CC C CC logical function isString (Txt) C C.. Implicits .. implicit none C C.. Parameters .. character*(*) Txt C C.. Local Scalars .. integer ntoken,i character token*180 C C.. External Functions .. integer GETNUMTOKEN logical ISDOUBLE character GETTOKEN*180 external GETNUMTOKEN, GETTOKEN, ISDOUBLE ntoken = GETNUMTOKEN(txt) do i = 1,ntoken token = GETTOKEN(Txt,i) if (.not. ISDOUBLE(token)) then isString = .true. return end if end do isString = .false. return end integer function GetNumToken(Line) C C.. Implicits .. implicit none C C.. Parameters .. character*(*) Line C C.. Local Scalars .. integer i,numtok,intok C C.. External Functions .. integer ISTRLEN external ISTRLEN numtok = 0 intok = 0 do i=1, ISTRLEN(Line) if ((intok .eq. 0) .and. (Line(i:i) .ne. ' ')) then numtok = numtok + 1 intok = 1 end if if (Line(i:i) .eq. ' ') then intok = 0 end if end do GetNumToken = numtok return end cc c cc integer function RIndex (Txt,subTxt) C C.. Implicits .. implicit none C C.. Parameters .. character*(*) Txt,subTxt C C.. Local Scalars .. integer nTxt,idx,idx0 C C.. External Functions .. integer ISTRLEN external ISTRLEN nTxt=ISTRLEN(Txt) idx = Index(Txt,subTxt) idx0=idx RIndex=0 do while ((idx .ne.0 ) .and. (idx0+1 .lt. nTxt)) idx = Index(Txt(idx0+1:nTxt),subTxt) idx0=idx+idx0 end do RIndex=idx0 return end antilg.f0000664006604000003110000000075314521201407011617 0ustar sun00315stepsC Last change: BCM 27 Apr 1998 7:27 am SUBROUTINE antilg(X,I,J) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER I,J,k DOUBLE PRECISION tmp,X DIMENSION X(J) c----------------------------------------------------------------------- DO k=I,J tmp=X(k) X(k)=exp(tmp) END DO c----------------------------------------------------------------------- RETURN END apply.f0000664006604000003110000000102314521201410011447 0ustar sun00315steps**==apply.f processed by SPAG 4.03F at 09:46 on 1 Mar 1994 DOUBLE PRECISION FUNCTION apply(X,K,W,N) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION W,X INTEGER i,j,K,l,m,N C*** End of declarations inserted by SPAG C C THIS FUNCTION APPLIES SYMMETRIC WEIGHTS TO X(K) C DIMENSION X(*),W(*) m=(N+1)/2 apply=W(1)*X(K) DO i=2,m j=K-i+1 l=K+i-1 apply=apply+W(i)*(X(j)+X(l)) END DO RETURN END ar30rg.f0000664006604000003110000000763014521201410011432 0ustar sun00315stepsC Last change: BCM 15 Jan 2008 12:40 pm SUBROUTINE ar30rg(YY,Nrxy,Maxar,Bar,Var) IMPLICIT NONE c----------------------------------------------------------------------- c Performs AR 30 using OLS regression on series YY for AR-spectrum c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- LOGICAL F INTEGER PMXAR DOUBLE PRECISION TWO,ZERO,MONE PARAMETER(PMXAR=30,TWO=2D0,ZERO=0D0,MONE=-1D0,F=.false.) c----------------------------------------------------------------------- DOUBLE PRECISION YY,ymat,txy,tchxpx,Bar,Var,apa,ta,amat,ainv,atmp, & bmat,btmp,zmat INTEGER Maxar,Nrxy,info,i,i1,j,j1,j2,mx1,na,nb,ny,nz,ntrxy LOGICAL Good c----------------------------------------------------------------------- DIMENSION YY(*),Bar(*),ta(PLEN),amat(Maxar,Maxar), & ainv(Maxar,Maxar),atmp(Maxar,Maxar),na(2),bmat(Maxar,1), & btmp(Maxar,1),nb(2),ymat(Maxar,1),ny(2),zmat(1,1),nz(2) c----------------------------------------------------------------------- DOUBLE PRECISION dpmpar EXTERNAL dpmpar c----------------------------------------------------------------------- c Initialize matrices c----------------------------------------------------------------------- do i=1,Maxar do j=1,Maxar amat(i,j)=ZERO end do bmat(i,1)=ZERO end do c----------------------------------------------------------------------- c Set dimensions for y,z matrix c----------------------------------------------------------------------- ny(1)=Maxar ny(2)=1 nz(1)=1 nz(2)=1 c----------------------------------------------------------------------- c Form A matrix from data c----------------------------------------------------------------------- mx1=Maxar+1 DO i=mx1,Nrxy i1=1 j1=i-1 j2=i-Maxar DO j=j1,j2,-1 ymat(i1,1)=YY(j) i1=i1+1 END DO CALL mulMatTr(ymat,ny,ymat,ny,atmp,na) CALL addMat(amat,na,atmp,na,amat,na) END DO c----------------------------------------------------------------------- c invert A matrix c----------------------------------------------------------------------- CALL invMat(amat,na,ainv,na) c----------------------------------------------------------------------- c Form B matrix from data c----------------------------------------------------------------------- DO i=mx1,Nrxy i1=1 j1=i-1 j2=i-Maxar DO j=j1,j2,-1 ymat(i1,1)=YY(j) i1=i1+1 END DO zmat(1,1)=YY(i) CALL mulMat(ymat,ny,zmat,nz,btmp,nb) CALL addMat(bmat,nb,btmp,nb,bmat,nb) END DO c----------------------------------------------------------------------- c generate betas, copy into Bar. c----------------------------------------------------------------------- CALL mulMat(ainv,na,bmat,nb,btmp,nb) do j=1,Maxar Bar(j)=btmp(j,1) end do c----------------------------------------------------------------------- c generate variance by first forming residuals c then summing their squares c----------------------------------------------------------------------- DO i=mx1,Nrxy i1=i-mx1+1 ta(i1)=YY(i) do j=1,Maxar ta(i1)=ta(i1)-(YY(i-j)*Bar(j)) END DO END DO ntrxy=Nrxy-Maxar CALL yprmy(ta,ntrxy,apa) c----------------------------------------------------------------------- c Calculate the variance c----------------------------------------------------------------------- Var=apa/dble(ntrxy-1) IF(Var.lt.TWO*dpmpar(1))Var=ZERO c----------------------------------------------------------------------- RETURN ENDarfit.f0000664006604000003110000001560514521201410011442 0ustar sun00315stepsCC C Routine qrdcmp(a,m,n,R) performs the QR decomposition A=QR C Returns R: upper triangular matrix, n*n. Q is such that: Q'Q=I. CC subroutine qrdcmp(A,m,n,R2) C .. C implicit none C C.. Formal Arguments .. integer m,n real*8 A(m,n),R2(n,n) C C.. Local Scalars .. integer i,j,k,l,n1 real*8 f,g,h,s C C.. Local Arrays .. real*8 R(m,n) do i = 1,m do j = 1,n R(i,j) = A(i,j) end do end do do i = 1,n l = i+1 s = 0.0d0 do j = i, m s = s + R(j,i)*R(j,i) end do f = R(i,i) g = sqrt(s) if ( f .ge. 0.0d0) then g = -g end if h = f*g - s R(i,i) = f - g do j = l,n s = 0.0 do k = i,m s = s + R(k,i)*R(k,j) end do f = s/h do k = i,m R(k,j) = R(k,j) + f*R(k,i) end do end do R(i,i) = g enddo if (m .lt. n) then n1 = m else n1 = n end if do i = 2,n1 do j = 1,i-1 R(i,j) = 0.0d0 end do enddo do i = 1,n do j = 1,n R2(i,j) = R(i,j) end do end do return end CC C Routine mat_sqr(A,la,ca,C) returns C=A'A, C[1...ca][1...ca]. CC subroutine mat_sqr(A,la,ca,C) C .. C implicit none C C.. Formal Arguments .. integer la,ca real*8 A(la,ca),C(ca,ca) C C.. Local Arrays .. real*8 AA(la,ca) call mat_trans(A,la,ca,AA) call mat_mult(AA,ca,la,A,ca,C) return end CC C mat_trans() transpose a matrix. CC subroutine mat_trans(A,la,ca,C) C .. C implicit none C C.. Formal Arguments .. integer la,ca real*8 A(la,ca),C(ca,la) C C.. Local Scalars .. integer i,j do i=1,la do j = 1,ca C(j,i) = A(i,j) enddo enddo return end CC C Routine mat_mult multiply two matrix A[1...la][1...ca] and B[1...ca][1...cb] CC subroutine mat_mult(A,la,ca,B,cb,C) C .. C implicit none C C.. Formal Arguments .. integer la,ca,cb real*8 A(la,ca),B(ca,cb),C(la,cb) C C.. Local Scalars .. integer i,j,k real*8 sum sum = 0.0d0 do i = 1,la do k = 1,cb do j = 1,ca sum = sum + A(i,j) * B(j,k) end do C(i,k) = sum sum = 0.0 end do end do return end CC C Routine mat_inv invert a square matrix of dim n. CC subroutine mat_inv(A,n,c,IA,ifail) C .. C implicit none C C.. Formal Arguments .. integer n,ifail real*8 A(n,n),IA(n,n) real*8 c C C.. Local Scalars .. integer i, j integer indx(n+1) real*8 col(n+1) call ludcmp(a,n,indx,c,ifail) if (ifail .eq. 1) then return end if do j = 1,n do i = 1,n col(i) = 0.0d0 end do col(j) = 1.0d0 call lubksb(a,n,indx,col) do i = 1,n ia(i,j) = col(i) end do end do return end CC C FUNCTION LUBKSB : LU BACK-SUBSTITUTION C Given a returned from ludcmp() lubsk solves aX=b. The solution is sent C back into b. n is the size of the squared matrix a, and indx is provided C by ludcmp(). CC subroutine lubksb(a,n,indx,b) C .. C implicit none C C.. Formal Arguments .. integer n integer indx(n+1) real*8 A(n,n) real*8 b(n+1) C C.. Local Scalars .. integer i, j,ip,ii real*8 sum ii = 0 do i=1,n ip=indx(i) sum=b(ip) b(ip)=b(i) if (ii .ne. 0) then do j=ii,i-1 sum = sum - a(i,j)*b(j) end do else if (sum .ne. 0.0d0) then ii=i end if b(i)=sum end do do i = n,1,-1 sum=b(i) do j=i+1,n sum = sum - a(i,j)*b(j) end do b(i)=sum/a(i,i) end do return end CC C FUNCTION LUDCMP : LU DECOMPOSITION C Given a nxn matrix a[1...n][1...n] this routine replace it by its LU C decomposition, outputted as a. The vector indx[1...n] records the row C permutation, and d = +-1 depending on the whether the number of row C interchanges is odd of even. CC subroutine ludcmp(a,n,indx,d,ifail) C .. C implicit none real*8 TINY parameter (TINY = 1.0d-20) C C.. Formal Arguments .. integer n,ifail integer indx(n+1) real*8 A(n,n) real*8 d C C.. Local Scalars .. integer i, imax, j, k real*8 sum, dum, big, temp real*8 vv(n+1) ifail = 0 d=1.0d0 big = 0.0d0 do i = 1,n big = 0.0d0 do j=1,n temp = abs(a(i,j)) if (temp .gt. big) then big=temp end if end do if (big .eq. 0.0d0) then ifail = 1 return c "Singular Matrix in Routine LUDCMP" end if vv(i) = 1.0/big end do do j=1,n do i=1,j-1 sum=a(i,j) do k=1,i-1 sum = sum - a(i,k)*a(k,j) end do a(i,j) = sum end do big = 0.0d0 do i = j,n sum=a(i,j) do k = 1,j-1 sum = sum - a(i,k)*a(k,j) end do a(i,j) = sum dum = vv(i)*abs(sum) if (dum .ge. big) then big=dum imax=i end if end do if (j .ne. imax) then do k=1,n dum = a(imax,k) a(imax,k) = a(j,k) a(j,k) = dum end do d = -d vv(imax) = vv(j) end if indx(j) = imax if (a(j,j) .eq. 0.0d0) then a(j,j) = TINY end if if (j .ne. n) then dum=1.0d0 / a(j,j) do i=j+1,n a(i,j) = a(i,j) * dum end do end if end do return end CC C CC subroutine arfit(x,nz,p,phi,aic,ifail) C .. C implicit none C C.. Formal Arguments .. integer nz,p,ifail real*8 x(nz),phi(p) real*8 aic C C.. Local Scalars .. integer i, j, ind real*8 c,ssr,sum,PI real*8 ylag(nz-p,p),tylag(p,nz-p), y(nz-p,1),Rylag(p,p), $ Sylag(p,p),Maux(p),Maux2(p,1),arparam(p+1) cc PI = dacos(-1.0d0) if (p .gt. 0) then do i = 1,p do j=1,nz-p ylag(j,i) = x(p-i+j) end do end do do j=1,nz-p y(j,1) = x(p+j) end do cc call qrdcmp(ylag,nz-p,p,Rylag) cc call mat_sqr(Rylag,p,p,Sylag) call mat_sqr(ylag,nz-p,p,Sylag) call mat_inv(Sylag,p,c,Rylag,ifail) if (ifail .eq. 1) then return end if call mat_trans(ylag,nz-p,p,tylag) call mat_mult(tylag,p,nz-p,y,1,Maux) call mat_mult(Rylag,p,p,Maux,1,Maux2) arparam(1)=1.0d0 do i=1,p arparam(i+1) = -Maux2(i,1) phi(i) = Maux2(i,1) end do ssr = 0.0d0 do i=1,nz-p sum =0 !Calculo de Residuos de arfit Domingo (11-11-04) do j=1,p+1 sum = sum + arparam(j) * x(p+i+1-j) end do ssr = ssr + sum*sum end do aic = ssr c aic = -2.0d0*(-.5d0*log(2.0d0*PI) - .5d0*log(ssr/(nz-p)) c $ - .5d0*(nz-p)) + log(dble(nz-p))*p else if (p .eq. 0) then ssr = .0 do i=1,nz ssr = ssr + x(i)*x(i) end do aic = ssr c aic = -2.0*(-.5*log(2.0*PI) - .5*log(ssr/nz) - .5*nz) end if return end arflt.f0000664006604000003110000000325214521201410011440 0ustar sun00315steps**==arflt.f processed by SPAG 4.03F at 09:46 on 1 Mar 1994 SUBROUTINE arflt(Nelta,Arimap,Arimal,Opr,Begopr,Endopr,C,Neltc) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Arimal,beglag,Begopr,endlag,Endopr,i,ilag,iopr,mxlag, & Nelta,Neltc,ntmpa,off,Opr DOUBLE PRECISION C,Arimap,tmp DIMENSION Arimal(*),Arimap(*),C(*),Opr(0:*) c----------------------------------------------------------------------- c Note c is the a matrix on input. First c calculate the number of elements in the c/a matrices c----------------------------------------------------------------------- ntmpa=Nelta c----------------------------------------------------------------------- DO iopr=Begopr,Endopr CALL maxlag(Arimal,Opr,iopr,iopr,mxlag) ntmpa=ntmpa-mxlag beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c----------------------------------------------------------------------- c Calculate the a(i)'s, i=lagb(nlag)+1,lag(nlag+1) c----------------------------------------------------------------------- DO i=1,ntmpa off=i+mxlag tmp=C(off) c----------------------------------------------------------------------- c Calculate c(i) c----------------------------------------------------------------------- DO ilag=beglag,endlag tmp=tmp-Arimap(ilag)*C(off-Arimal(ilag)) END DO C(i)=tmp END DO c----------------------------------------------------------------------- Neltc=ntmpa END DO c----------------------------------------------------------------------- RETURN END arima.cmn0000664006604000003110000002243214521201410011752 0ustar sun00315stepsc----------------------------------------------------------------------- c This common block contains all the variables which must be c transferred from gtinpt to the arima subroutines c----------------------------------------------------------------------- c NOTE : all dates are integer arrays of length two, with c DATE(1) = year, DATE(2) = period c----------------------------------------------------------------------- c Bstdsn - model description of the "best" model selected by the c automatic model identification procedure c----------------------------------------------------------------------- CHARACTER Autofl*(PFILMD),Bstdsn*(132) c----------------------------------------------------------------------- c Nobs : Number of observations read in for the original series c Mxnlit : Maximum number of nonlinear iterations c Endspn : Ending date for the span of data analyzed c Begsrs : Starting date of the original series c Nrusrx : Number of observations read in for the user-defined c regression variables. c Bgusrx : Starting date for the user-defined regression variables. c Mxiter : Maximum number of total iterations c Begtst : Starting date for the outlier testing procedure c Endtst : Ending date for the outlier testing procedure c Fctdrp : Number of observations to "drop" at the end of the series c to determine when the forecasts will start c Frstsy : Pointer for the location of the first observation of the c span in the original series c Mxcklg : Maximum number of lags to compute for ACF and PACF tables c (read in from the check spec) c Dflist : List of differences to be applied in the identification c output c Niddf : Number of regular differences to be applied in the c identification output c Nidsdf : Number of seasonal differences to be applied in the c identification output c Mxidlg : Maximum number of lags to compute for ACF and PACF tables c (read in from the identify spec) c Nrxy : Number of rows in Xy regression matrix c Lsrun : Maximum number of LS outliers to be grouped together in c temporary level shift test c Reglom : Regression variable prior adjustment indicator variable c (0,1=none, 2=td, and 3=all) c Fcntyp : Indicator variable specifying Box-Cox and other functions c (1=log,3=logistic,4=none,6=power transformation) c Itdtst : Indicator variable specifying whether an AIC-test will c be performed for the trading day regression variables c (1=td,2=td6,3=tdstock) c Aicstk : Stock day given in tdstock selected for TD AIC-test c Begxy : Beginning date of Xy regression matrix c Begmdl : Starting date for the span of data to be modelled c Endmdl : Ending date for the span of data to be modelled c Easvec : Vector for Easter windows used for Easter AIC-test c Neasvc : Number of Easter windows used for Easter AIC-test c Maxord : Vector of length two which contains the maximum order c (regular, seasonal) for the automatic model c identification procedure c Diffam : Vector of length two which contains the order of c differences (regular, seasonal) set by the user in c the automatic model identification procedure c Nbstds - length of description of "best" model c----------------------------------------------------------------------- INTEGER Nobs,Mxnlit,Endspn,Begsrs,Nrusrx,Bgusrx,Mxiter,Begtst, & Endtst,Fctdrp,Frstsy,Mxcklg,Dflist,Niddf,Nidsdf,Nomnfy, & Mxidlg,Nrxy,Lsrun,Reglom,Fcntyp,Itdtst,Aicstk,Begxy, & Aicind,Aicint,Begmdl,Endmdl,Easvec,Neasvc,Maxord,Diffam, & Frstar,Nbstds,Eastst,Lomtst,Exdiff,Tdayvc,Ntdvec c----------------------------------------------------------------------- c Lestim : Logical variable indicating whether REGARIMA model will c be estimated (.true.) or if the model parameters will c be fixed (.false.) c Ltstao : Logical variable indicating whether AO outliers will be c identified in outlier procedure c Ltstls : Logical variable indicating whether LS outliers will be c identified in outlier procedure c Ltsttc : Logical variable indicating whether TC outliers will be c identified in outlier procedure c Ladd1 : Logical variable indicating whether outliers will be c added one at a time c Lautom : Logical variable indicating whether automatic model c identification should be performed c Lautod : Logical variable indicating whether automatic difference c order identification should be performed c Ldestm : Logical variable indicating whether any REGARIMA model c estimation will be performed c Outfct : Logical variable indicating whether out-of-sample c forecast errors will be used as a diagnostic statistic. c Leastr : Logical variable for automatic easter AIC test c Luser : Logical variable for automatic AIC test for user-defined c regressors c Lttc : Logical variable for trendtc whether TC outlier will be c treated as level change or AO c----------------------------------------------------------------------- c LOGICAL Lestim,Ltstao,Ltstls,Ltsttc,Ltstso,Ladd1,Lautom,Lautod, LOGICAL Lestim,Ltstao,Ltstls,Ltsttc,Ladd1,Lautom,Lautod, & Ldestm,Outfct,Leastr,Luser,Lbalmd,Hrinit,Laccdf, & Lotmod,Lautox,Pck1st,Id1st,Outfer,Elong,Cvtype,Lchkmu, & Lmixmd,Lrejfc,Lognrm,Rmcnst,Ch2tst,Lceaic,Lsovdf,Lttc c----------------------------------------------------------------------- c Ub1lim : Acceptance limit for initial unit root test c Ub2lim : Acceptance limit for final unit root test c Ubfin : Acceptance limit for unit root test of final model c Tsig : T-value limit for final ARMA coefficient test c Predcv : Percent reduction in automatic outlier identification c threshold for automatic model identification c Cancel : Acceptance limit for cancellation of rootse c Y : Original series c Lam : Box-Cox transformation parameter c Userx : User-defined regression variables c Critvl : Critical value for outlier identification procedure c Traicd : The difference in AICC needed to accept no c transformation when the automatic transformation c AIC test isinvoked. Default value : 2D0 c Rgaicd : Vector of length 4 (TD, LOM, Easter, UserDef) - c The amount by which the AICC of the model with the c regressor(s) specified in the aictest argument must c fall below the AICC of the model without these c regressor(s) in order for the model with the c regressors to be chosen. Default value : 0D0 c Ciprob : Probability limit for the confidence interval of the c forecasts c Cvrduc : amount to reduce outlier critical value to identify c "almost" outliers c----------------------------------------------------------------------- DOUBLE PRECISION Ub1lim,Ub2lim,Ubfin,Cancel,Y,Lam,Userx,Critvl, & Fct,Rgaicd,Traicd,Ciprob,Pcr,Tsig,Predcv,Fctlim, & Bcklim,Qlim,Ovrdif,Cvalfa,Fctlm2,Cvrduc,Chi2cv, & Dfaict,Dfaicl,Dfaice,Dfaicu,Tlimit,Pvaic,QsRsd, & QsRsd2 c----------------------------------------------------------------------- DIMENSION Y(PLEN),Begsrs(2),Endspn(2),Userx(PUSERX),Bgusrx(2), & Begtst(2),Endtst(2),Dflist(PDFLG,2),Begxy(2), & Begmdl(2),Endmdl(2),Critvl(POTLR),Easvec(PAICEA), & Maxord(2),Diffam(2),Tdayvc(3),Rgaicd(PAICT) c----------------------------------------------------------------------- COMMON /armadp/ Y,Userx,Critvl,Ciprob,Cvalfa,Cvrduc,Chi2cv,Tlimit, & Pvaic,QsRsd,QsRsd2 COMMON /armain/ Nobs,Nrusrx,Bgusrx,Mxiter,Mxnlit,Mxcklg,Begtst, & Endtst,Fctdrp,Begsrs,Frstsy,Begmdl,Endmdl,Nomnfy, & Lsrun c COMMON /armalg/ Lestim,Ltstao,Ltstls,Ltsttc,Ltstso,Ladd1,Ldestm, COMMON /armalg/ Lestim,Ltstao,Ltstls,Ltsttc,Ladd1,Ldestm,Lttc, & Reglom,Outfct,Elong,Cvtype,Lognrm,Rmcnst,Ch2tst COMMON /armaid/ Dflist,Niddf,Nidsdf,Mxidlg COMMON /armamd/ Ub1lim,Ub2lim,Ubfin,Cancel,Pcr,Tsig,Predcv,Fct, & Fctlm2,Maxord,Diffam,Frstar,Exdiff,Lautom,Lautod, & Lbalmd,Hrinit,Laccdf,Lotmod,Lchkmu,Lmixmd,Lrejfc, & Lsovdf COMMON /armamx/ Fctlim,Bcklim,Qlim,Ovrdif,Lautox,Pck1st,Id1st, & Outfer,Autofl COMMON /armalm/ Lam,Fcntyp COMMON /aictst/ Rgaicd,Traicd,Dfaict,Dfaicl,Dfaice,Dfaicu,Itdtst, & Aicstk,Easvec,Neasvc,Tdayvc,Ntdvec,Aicind,Aicint, & Lomtst,Eastst,Leastr,Lceaic,Luser COMMON /armaxy/ Endspn,Begxy,Nrxy COMMON /autom / Nbstds,Bstdsn c----------------------------------------------------------------------- arima.f0000664006604000003110000020102214521201410011414 0ustar sun00315stepsc Last change: 8/01/2022 - add tcrate in .udg file C Last Change: Sep, 2021, change the Print out the roots of the AR C and MA polynomials condition to be the same as html version C previous change: SRD 25 Jan 100 1:30 pm SUBROUTINE arima(Hvmdl,Extok,Lx11,Lseats,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- c Estimates regression models with ARIMA errors c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c a d Pa/na long of innovation errors c----------------------------------------------------------------------- c Variable typing and initialization c----------------------------------------------------------------------- LOGICAL T,F DOUBLE PRECISION ZERO,ONE INTEGER BADITR PARAMETER(T=.true.,F=.false.,ZERO=0D0,ONE=1D0,BADITR=500) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'tbllog.prm' c----------------------------------------------------------------------- INTEGER PR PARAMETER (PR=PLEN/4) c----------------------------------------------------------------------- INCLUDE 'filext.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'prior.prm' INCLUDE 'rev.prm' INCLUDE 'svllog.prm' c----------------------------------------------------------------------- INCLUDE 'adj.cmn' INCLUDE 'arima.cmn' INCLUDE 'autoq.cmn' INCLUDE 'error.cmn' INCLUDE 'extend.cmn' INCLUDE 'fxreg.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'lzero.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'missng.cmn' INCLUDE 'model.cmn' INCLUDE 'mq3.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'picktd.cmn' INCLUDE 'priadj.cmn' INCLUDE 'prior.cmn' INCLUDE 'prittl.cmn' INCLUDE 'priusr.cmn' INCLUDE 'rev.cmn' INCLUDE 'rho.cmn' INCLUDE 'seatad.cmn' INCLUDE 'svllog.cmn' INCLUDE 'tbllog.cmn' INCLUDE 'tdtyp.cmn' INCLUDE 'title.cmn' INCLUDE 'tukey.cmn' INCLUDE 'units.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'x11ptr.cmn' c ------------------------------------------------------------------ INCLUDE 'mdlsvl.i' INCLUDE 'mdltbl.i' INCLUDE 'spcsvl.i' INCLUDE 'spctbl.i' INCLUDE 'tbllog.i' c ------------------------------------------------------------------ INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c ------------------------------------------------------------------ REAL ticks CHARACTER begstr*(10),cfcst*(3),tmpttl*(PCOLCR),tmpstr*(20) DOUBLE PRECISION a,trnsrs,orix,orixmv,ftd,fao,fls,ftc,fusr,fmv, & fhol,fsea,fcyc,mape,dvec,cv,Temp,fcstx,bcstx, & untfct,untbct,cvbak,fso,tval,rvar,dw,ken LOGICAL lester,Extok,Lx11,Lseats,litr,Hvmdl,lidotl,fctok,lfm, & Lgraf,gudrun,ldiag,ltmp,lauto,lsadj,ltdlom,lautid INTEGER i,frstry,idate,na,nefobs,n,nbeg,nf2,tdreg,iaic, & nend,nlagbl,i1,i2,hvstar,begopr,endopr,itmp,nobtst,iao, & ils,itc,iramp,itls,iauto,iuser,iso,outdec,ilom,lastpr, & iseq,nchr,rtype,ntmpcr,ipos DIMENSION a(PA),idate(2),trnsrs(PLEN),orix(PLEN),orixmv(PLEN), & ftd(PLEN),fao(PLEN),fls(PLEN),ftc(PLEN),fusr(PLEN), & fmv(PLEN),fhol(PLEN),mape(4),dvec(1), & fsea(PLEN),Temp(PLEN),fcstx(PFCST),bcstx(PFCST), & cvbak(POTLR),untfct(PFCST),untbct(PLEN),tval(PB), & fcyc(PLEN),fso(PLEN) c----------------------------------------------------------------------- c INTEGER iticks LOGICAL istrue,dpeq INTEGER strinx,nblank DOUBLE PRECISION setcv,setcvl,calcqs,chisq,kendalls EXTERNAL strinx,istrue,dpeq,setcv,nblank,setcvl,calcqs,chisq, & kendalls c ------------------------------------------------------------------ COMMON /work / Temp c----------------------------------------------------------------------- CHARACTER num*(2),cdef*(1) DIMENSION num(4) c----------------------------------------------------------------------- DATA num/'st','nd','rd','th'/ c----------------------------------------------------------------------- c Input series, regression variables, model, options c----------------------------------------------------------------------- itmp=0 na=0 lester=F fctok=T lidotl=Ltstao.or.Ltstls.or.Ltsttc Natotl=0 lauto=Lautom.or.Lautox lsadj=Lx11.or.Lseats gudrun=Issap.LT.2.AND.Irev.lt.4 ldiag=Lsumm.gt.0.and.gudrun lautid=lauto.and.gudrun ltdlom=Kfulsm.eq.2 CALL setdp(ZERO,PXPX,Chlxpx) ilom=Priadj ltmp=F QsRsd=DNOTST QsRsd2=DNOTST c----------------------------------------------------------------------- c Change Begspn and Endspn to match the model span, if necessary. c----------------------------------------------------------------------- nbeg=0 nend=0 IF(Ldestm)THEN CALL dfdate(Begmdl,Begspn,Sp,nbeg) CALL dfdate(Endspn,Endmdl,Sp,nend) IF(nbeg.gt.0)CALL cpyint(Begmdl,2,1,Begspn) IF(nend.gt.0)CALL cpyint(Endmdl,2,1,Endspn) END IF c----------------------------------------------------------------------- c Process the series c----------------------------------------------------------------------- CALL dfdate(Endspn,Begspn,Sp,Nspobs) Nspobs=Nspobs+1 IF(nbeg.gt.0.or.nend.gt.0.or.Issap.eq.2)THEN CALL dfdate(Begspn,Begsrs,Sp,Frstsy) Frstsy=Frstsy+1 Nomnfy=Nobs-Frstsy+1 Nobspf=min(Nspobs+Nfdrp,Nomnfy) CALL dfdate(Begspn,Begadj,Sp,Adj1st) Adj1st=Adj1st+1 END IF CALL setdp(ZERO,PLEN,trnsrs) * write(Mtprof,*) ' Sto(Pos1ob+nbeg) = ',Sto(Pos1ob+nbeg) CALL copy(Sto(Pos1ob+nbeg),Nobspf,-1,trnsrs) * write(Mtprof,*) ' trnsrs(1) = ',trnsrs(1) c---------------------------------------------------------------------- c IF critical value not set, replace with value based on length of c series c---------------------------------------------------------------------- cv=DNOTST IF((Ltstao.and.dpeq(Critvl(AO),DNOTST)).or. & (Ltstls.and.dpeq(Critvl(LS),DNOTST)).or. & (Ltsttc.and.dpeq(Critvl(TC),DNOTST)))THEN CALL dfdate(Endtst,Begtst,Sp,nobtst) nobtst=nobtst+1 IF(Cvtype)THEN cv=setcvl(nobtst,Cvalfa) ELSE cv=setcv(nobtst,Cvalfa) END IF IF(dpeq(cv,DNOTST))THEN CALL abend() RETURN END IF IF(Ltstao.and.dpeq(Critvl(AO),DNOTST))Critvl(AO)=cv IF(Ltstls.and.dpeq(Critvl(LS),DNOTST))Critvl(LS)=cv IF(Ltsttc.and.dpeq(Critvl(TC),DNOTST))Critvl(TC)=cv END IF c----------------------------------------------------------------------- c Write out model span and outlier testing span into diagnostics c summary file, if requested c----------------------------------------------------------------------- IF(Lsumm.gt.0.and.gudrun)THEN i1=Begmdl(MO) IF(i1.gt.4)i1=4 i2=Endmdl(MO) IF(i2.gt.4)i2=4 IF(Sp.eq.12.or.Sp.eq.4)THEN WRITE(Nform,1000)'modelspan: ',Begmdl(MO),num(i1), & Moqu(1:nblank(Moqu)),Begmdl(YR),Endmdl(MO), & num(i2),Moqu(1:nblank(Moqu)),Endmdl(YR) ELSE IF(Sp.eq.1)THEN WRITE(Nform,1001)'modelspan: ',Begmdl(YR),Endmdl(YR) ELSE WRITE(Nform,1000)'modelspan: ',Begmdl(MO),num(i1), & 'period',Begmdl(YR),Endmdl(MO),num(i2), & 'period',Endmdl(YR) END IF WRITE(Nform,1061)'nobsmodelspan: ',Nspobs IF(lidotl)THEN i1=Begtst(MO) IF(i1.gt.4)i1=4 i2=Endtst(MO) IF(i2.gt.4)i2=4 IF(Sp.eq.12.or.Sp.eq.4)THEN WRITE(Nform,1000)'outlierspan: ',Begtst(MO),num(i1), & Moqu(1:nblank(Moqu)),Begtst(YR),Endtst(MO), & num(i2),Moqu(1:nblank(Moqu)),Endtst(YR) ELSE IF(Sp.eq.1)THEN WRITE(Nform,1001)'outlierspan: ',Begtst(YR),Endtst(YR) ELSE WRITE(Nform,1000)'outlierspan: ',Begtst(MO),num(i1), & 'period',Begtst(YR),Endtst(MO),num(i2), & 'period',Endtst(YR) END IF WRITE(Nform,1061)'nobsoutlierspan: ',nobtst END IF IF(Itdtst.gt.0.or.Lomtst.gt.0.or.Leastr.or.Luser)THEN tmpstr = ' ' ipos=2 IF(Itdtst.gt.0)THEN tmpstr(ipos:(ipos+1))='td' ipos=5 END IF IF(Lomtst.eq.1)THEN tmpstr(ipos:(ipos+2))='lom' ipos=ipos+4 ELSE IF(Lomtst.eq.2)THEN tmpstr(ipos:(ipos+2))='loq' ipos=ipos+4 ELSE IF(Lomtst.eq.3)THEN tmpstr(ipos:(ipos+5))='lpyear' ipos=ipos+7 END IF IF(Leastr)THEN tmpstr(ipos:(ipos+5))='easter' ipos=ipos+7 END IF IF(Luser)THEN tmpstr(ipos:(ipos+3))='user' ipos=ipos+5 END IF WRITE(Nform,1060)'aictest:',tmpstr(1:ipos) ELSE WRITE(Nform,1060)'aictest:',' none' END IF END IF c----------------------------------------------------------------------- c BoxCox transform the (prior adjusted, if requested) data. c Lam=1 means no transformation, Lam=0 is the log transform, c this is all part of the Box-Cox transformation. c----------------------------------------------------------------------- IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Prttab(LTRNDT))THEN CALL prtshd( & 'Transformed (prior-adjusted) data for regARIMA modeling', & Begspn,Sp,Nspobs,T) IF(Lfatal)RETURN outdec=Kdec IF((.not.dpeq(Lam,ONE)).and.outdec.lt.3)outdec=3 CALL prttbl(Begspn,Sp,trnsrs,Nspobs,'Data',outdec) END IF c----------------------------------------------------------------------- IF(Savtab(LTRNDT))THEN CALL savtbl(LTRNDT,Begspn,1,Nspobs,Sp,trnsrs,Serno,Nser,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Set up the regression matrix c----------------------------------------------------------------------- CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF((.not.Lfatal).and.Iregfx.ge.2)THEN CALL rmfix(trnsrs,Nbcst,Nrxy,1) IF(.not.Lfatal) & CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Identify the differencing in the model c----------------------------------------------------------------------- IF(Niddf.gt.0.or.Nidsdf.gt.0)THEN CALL prprad(Adjttl,Nadjcr,Nustad,Nuspad,Priadj,Reglom) IF(Priadj.gt.0.or.Nustad.gt.0.or.Nuspad.gt.0)WRITE(Mt1,'()') IF(.not.Lhiddn)CALL prtnfn(Fcntyp,Lam,0) c----------------------------------------------------------------------- IF(.not.Lhiddn)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') IF(Nb.gt.0)THEN IF(.not.Lhiddn)WRITE(Mt1,1030) ELSE IF(.not.Lhiddn)WRITE(Mt1,1040) END IF END IF c----------------------------------------------------------------------- IF(Ngrp.gt.0) & CALL desreg('Regression Model',Ngrp,Grpttl,Grpptr,Ngrptl) IF(Ngrpfx.gt.0) & CALL desreg('Regression Model (fixed)',Ngrpfx,Gfxttl,Gfxptr, & Ngfxtl) IF(.not.Lfatal)CALL idmdl(Dflist,Niddf,Nidsdf,mxidlg,Lgraf) IF(Lfatal)RETURN IF(Niddf.gt.0)Niddf=0 IF(Nidsdf.gt.0)Nidsdf=0 END IF c----------------------------------------------------------------------- c Everything beyond, outlier identification, model checking, and c forecasting all require estimation so the program does not continue c unless estimation/evaluation is done. c----------------------------------------------------------------------- IF(Ldestm)THEN c----------------------------------------------------------------------- c If automatic modelling option selected, select a model. c----------------------------------------------------------------------- IF(lauto)THEN IF(Lautom)THEN IF(Lsumm.gt.0.and.gudrun) & WRITE(Nform,1060)'automodeltype: ','automdl' IF(lidotl)THEN DO i=1,POTLR cvbak(i)=Critvl(i) END DO END IF C----------------------------------------------------------------------- IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'bautomd:',ticks ELSE WRITE(Nform,9000) 'bautomd.diag:',ticks END IF END IF C----------------------------------------------------------------------- CALL automd(trnsrs,frstry,nefobs,a,na,Lsumm,lidotl, & Svltab(LSLADF),lsadj,Ltdlom,fctok,Lhiddn, & Lnoprt) IF((.not.Lautom).or.Lfatal)RETURN Hvmdl=T C----------------------------------------------------------------------- IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'eautomd:',ticks ELSE WRITE(Nform,9000) 'eautomd.diag:',ticks END IF END IF C----------------------------------------------------------------------- c If rejectfcst = yes, test forecast error to see if forecast c extension should be rejected (BCM July 2007) C----------------------------------------------------------------------- IF(Lrejfc)THEN cfcst='no ' CALL amdfct(trnsrs,mape,Nobspf,Nfcst,F,fctok,F) IF(Lfatal)RETURN IF(mape(4).gt.Fctlm2)THEN CALL nofcst(trnsrs,frstry,Lx11) IF(Lfatal)RETURN * IF(Laccss)CALL insacd(Mt1,'p',T) WRITE(Mt1,1160)mape(4),Fctlm2 * IF(Laccss)CALL insacd(Mt1,'p',F) cfcst='yes' END IF IF(Lsumm.gt.0.and.gudrun)THEN WRITE(Nform,1060)'rejectfcst: ','yes' WRITE(Nform,1200)'fcstlim: ',fctlm2 WRITE(Nform,1200)'mape3yr: ',mape(4) WRITE(Nform,1060)'fcstrejected: ',cfcst END IF END IF C----------------------------------------------------------------------- IF(Lsumm.gt.0.and.gudrun)THEN c add tcrate in .udg file WRITE(Nform,1020)'tcrate: ',Tcalfa IF(lidotl)THEN IF(Ltstao)THEN cdef=' ' IF(dpeq(Critvl(AO),cv))cdef='*' IF(.not.dpeq(Critvl(AO),cvbak(AO)))cdef='-' WRITE(Nform,1010)'aocrit: ',Critvl(AO),cdef END IF IF(Ltstls)THEN cdef=' ' IF(dpeq(Critvl(LS),cv))cdef='*' IF(.not.dpeq(Critvl(LS),cvbak(LS)))cdef='-' WRITE(Nform,1010)'lscrit: ',Critvl(LS),cdef END IF IF(Ltsttc)THEN cdef=' ' IF(dpeq(Critvl(TC),cv))cdef='*' IF(.not.dpeq(Critvl(TC),cvbak(TC)))cdef='-' WRITE(Nform,1010)'tccrit: ',Critvl(TC),cdef END IF WRITE(Nform,1020)'reducecv: ',Predcv END IF WRITE(Nform,1060)'automdl: ',Bstdsn(1:Nbstds) WRITE(Nform,1050)Bstdsn(1:Nbstds) WRITE(Nform,1061)'maxiter: ',Mxiter WRITE(Nform,1021)'tol: ',Tol END IF IF(Svltab(LSLAMD))WRITE(Ng,1080)Bstdsn(1:Nbstds) ELSE hvstar=0 IF(Lsumm.gt.0.and.gudrun) & WRITE(Nform,1060)'automodeltype: ','pickmdl' CALL automx(trnsrs,frstry,nefobs,a,na,Hvmdl,hvstar,lsadj, & lidotl,ltdlom,fctok,Lhiddn,Lsumm) IF(Lfatal)RETURN IF(Lsumm.gt.0.and.gudrun)THEN c add tcrate in .udg file WRITE(Nform,1020)'tcrate: ',Tcalfa IF(lidotl)THEN IF(Ltstao)THEN cdef=' ' IF(dpeq(Critvl(AO),cv))cdef='*' WRITE(Nform,1010)'aocrit: ',Critvl(AO),cdef END IF IF(Ltstls)THEN cdef=' ' IF(dpeq(Critvl(LS),cv))cdef='*' WRITE(Nform,1010)'lscrit: ',Critvl(LS),cdef END IF IF(Ltsttc)THEN cdef=' ' IF(dpeq(Critvl(TC),cv))cdef='*' WRITE(Nform,1010)'tccrit: ',Critvl(TC),cdef END IF END IF IF(hvstar.eq.2)THEN WRITE(Nform,1060)'automdl(default): ',Bstdsn(1:Nbstds) ELSE WRITE(Nform,1060)'automdl: ',Bstdsn(1:Nbstds) END IF WRITE(Nform,1050)Bstdsn(1:Nbstds) WRITE(Nform,1061)'maxiter: ',Mxiter WRITE(Nform,1021)'tol: ',Tol END IF IF(Svltab(LSLAMX))THEN IF(hvstar.eq.2)THEN WRITE(Ng,1070)Bstdsn(1:Nbstds) ELSE WRITE(Ng,1080)Bstdsn(1:Nbstds) END IF END IF END IF c----------------------------------------------------------------------- c Save aictest information in log file, if AIC tests performed. c----------------------------------------------------------------------- IF(Svltab(LSLTST).or.(Lsumm.gt.0.and.gudrun))THEN IF((Itdtst.gt.0.or.Lomtst.gt.0.or.Leastr.or.Luser).and. & (Lsumm.gt.0.and.gudrun))THEN IF(.not.dpeq(Pvaic,DNOTST)) & WRITE(Nform,1021)'aictest.pv: ',ONE-Pvaic END IF CALL svaict(Itdtst.gt.0,Lomtst.gt.0,Leastr,Luser, & Svltab(LSLTST),Hvmdl,Lsumm,'selected ',8) IF(Lfatal)RETURN END IF IF(Itdtst.gt.0)Itdtst=0 IF(Leastr)Leastr=F IF(Luser)Luser=F c----------------------------------------------------------------------- c If a model is not selected, turn off prior adjustment by regARIMA c factors. c----------------------------------------------------------------------- IF(Hvmdl)THEN CALL ssprep(T,F,F) ELSE IF(Adjtd.eq.1)Adjtd=0 IF(Adjhol.eq.1)Adjhol=0 IF(Adjao.eq.1)Adjao=0 IF(Adjls.eq.1)Adjls=0 IF(Adjtc.eq.1)Adjtc=0 IF(Adjso.eq.1)Adjso=0 IF(Adjcyc.eq.1)Adjcyc=0 IF(Adjusr.eq.1)Adjusr=0 IF(Adjsea.eq.1)Adjsea=0 IF((.NOT.(Axrghl.or.Axruhl.or.Khol.ge.1)).and.Finhol)Finhol=F IF(Finao)Finao=F IF(Finls)Finls=F IF(Fintc)Fintc=F IF(Finusr)Finusr=F IF(Nfcst.gt.0)THEN Posffc=Posfob IF(Nfdrp.gt.0)Nfdrp=0 END IF IF(nbeg.gt.0.or.nend.gt.0) & CALL setspn(Sp,nend,nbeg,Begspn,Endspn,Begmdl,Endmdl,Nspobs, & Frstsy,Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy, & Begadj,Adj1st) IF(Itdtst.gt.0)Itdtst=0 IF(Leastr)Leastr=F IF(Luser)Luser=F IF(Irev.gt.0)THEN IF(Lrvfct)Lrvfct=F IF(Lrvaic)Lrvaic=F IF(Lrvarma)Lrvarma=F IF(Lrvtdrg)Lrvtdrg=F IF(lsadj)THEN IF(.not.(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvtrn.or.Lrvtch))Irev=0 ELSE Irev=0 END IF END IF IF(Missng.and.lsadj)THEN IF(Lx11)Lx11=F IF(Lseats)Lseats=F CALL writln('ERROR: Cannot perform seasonal adjustment if '// & 'the automatic model',STDERR,Mt2,T) CALL writln(' selection procedure cannot select an '// & 'ARIMA model and missing',STDERR,Mt2,F) CALL writln(' value regressors are part of the model.', & STDERR,Mt2,T) END IF IF(.not.Convrg)CALL abend() RETURN END IF ELSE IF(Lsumm.gt.0.and.gudrun) & WRITE(Nform,1060)'automodeltype: ','none' c----------------------------------------------------------------------- c Print the BoxCox transformation parameter c----------------------------------------------------------------------- IF(Prttab(LESTMD))THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1090) CALL prprad(Adjttl,Nadjcr,Nustad,Nuspad,Priadj,Reglom) IF(Priadj.gt.0)WRITE(Mt1,'()') CALL prtnfn(Fcntyp,Lam,0) c----------------------------------------------------------------------- c Short description of the regression and ARIMA parts of the model c----------------------------------------------------------------------- IF(Ngrp.gt.0) & CALL desreg('Regression Model',Ngrp,Grpttl,Grpptr,Ngrptl) IF(Ngrpfx.gt.0) & CALL desreg('Regression Model (fixed)',Ngrpfx,Gfxttl,Gfxptr, & Ngfxtl) IF(Lfatal)RETURN CALL dsarma(Lcmpaq) CALL prtmsp(Begmdl,Endmdl,Sp,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(Lsumm.gt.0.and.gudrun)THEN IF(Nmdl.gt.0)THEN WRITE(Nform,1050)Mdldsn(1:Nmddcr) ELSE WRITE(Nform,1050)'(0 0 0)' END IF WRITE(Nform,1061)'maxiter: ',Mxiter WRITE(Nform,1021)'tol: ',Tol END IF c ------------------------------------------------------------------ IF(.not.Lhiddn.and.istrue(Prttab,LESTOP,LESTRS))WRITE(Mt1,1100) IF(Prttab(LESTOP))CALL prtopt(Lestim,Mxiter,Mxnlit) c----------------------------------------------------------------------- c Estimate the regression and ARMA parameters and print the results. c----------------------------------------------------------------------- IF(Leastr.or.(Luser.and.Ncusrx.gt.0).or.Itdtst.gt.0.or. & Lomtst.gt.0.or.(Ch2tst.and.Nguhl.gt.0))THEN litr=Prttab(LESTIT).or.Savtab(LESTIT) lfm=Prttab(LRGATS).and.Prttab(LESTFM) IF((Itdtst.gt.0.or.Lomtst.gt.0.or.Leastr.or.Luser).and. & (Lsumm.gt.0.and.gudrun))THEN IF(.not.dpeq(Pvaic,DNOTST)) & WRITE(Nform,1021)'aictest.pv: ',ONE-Pvaic END IF IF(Itdtst.gt.0)THEN CALL tdaic(trnsrs,a,nefobs,na,frstry,lester,iaic,ltdlom,litr, & Prttab(LRGATS),lfm,Svltab(LSLTST),Lsumm,Lhiddn) IF(Lfatal)RETURN IF(Svltab(LSLTST).or.(Lsumm.gt.0.and.gudrun))THEN CALL svaict(Itdtst.gt.0,F,F,F,Svltab(LSLTST),.not.lester, & Lsumm,'estimated',9) IF(Lfatal)RETURN END IF IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred du &ring the AIC testing of',STDERR,Mt2,T) CALL writln(' trading day regressor(s). The error mess &age appears below.',STDERR,Mt2,F) CALL prterr(nefobs,lauto) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If different trading day chosen, resave regARIMA model variables c for sliding spans analysis c----------------------------------------------------------------------- IF(iaic.ge.1)CALL ssprep(T,F,F) END IF c----------------------------------------------------------------------- IF(.not.lester.and.Lomtst.gt.0)THEN CALL lomaic(trnsrs,a,nefobs,na,frstry,lester,litr, & Prttab(LRGATS),lfm,Svltab(LSLTST),Lsumm,Lhiddn) IF(Lfatal)RETURN IF(Svltab(LSLTST).or.(Lsumm.gt.0.and.gudrun))THEN CALL svaict(F,Lomtst.gt.0,F,F,Svltab(LSLTST),.not.lester, & Lsumm,'estimated',9) IF(Lfatal)RETURN END IF IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred du &ring the AIC testing of',STDERR,Mt2,T) CALL writln(' lom/loq/lpyear regressor(s). The error m &essage appears below.',STDERR,Mt2,F) CALL prterr(nefobs,lauto) IF(Lfatal)RETURN END IF CALL ssprep(T,F,F) END IF c----------------------------------------------------------------------- IF(.not.lester.and.Leastr)THEN CALL easaic(trnsrs,a,nefobs,na,frstry,lester,litr, & Prttab(LRGATS),lfm,Svltab(LSLTST),Lsumm,Lhiddn) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Resave regARIMA model variables for sliding spans analysis c----------------------------------------------------------------------- IF(Svltab(LSLTST).or.(Lsumm.gt.0.and.gudrun))THEN CALL svaict(F,F,Leastr,F,Svltab(LSLTST),.not.lester,Lsumm, & 'estimated',9) IF(Lfatal)RETURN END IF IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred du &ring the AIC testing of',STDERR,Mt2,T) CALL writln(' an Easter regressor. The error message a &ppears below.',STDERR,Mt2,F) CALL prterr(nefobs,lauto) IF(Lfatal)RETURN END IF CALL ssprep(T,F,F) END IF IF(.not.lester.and.(Luser.and.Ncusrx.gt.0))THEN CALL usraic(trnsrs,a,nefobs,na,frstry,lester,litr, & Prttab(LRGATS),lfm,Svltab(LSLTST),Lsumm,Lhiddn) IF(Lfatal)RETURN IF(Svltab(LSLTST).or.(Lsumm.gt.0.and.gudrun))THEN CALL svaict(F,F,F,Luser,Svltab(LSLTST),.not.lester,Lsumm, & 'estimated',9) IF(Lfatal)RETURN END IF IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred du &ring the AIC testing of',STDERR,Mt2,T) CALL writln(' user defined regressor(s). The error mes &sage appears below.',STDERR,Mt2,F) CALL prterr(nefobs,lauto) IF(Lfatal)RETURN END IF CALL ssprep(T,F,F) END IF c----------------------------------------------------------------------- c perform chi-square testing for user-defined holiday regressors c----------------------------------------------------------------------- IF(.not.lester.and.Ch2tst.and.Ncusrx.eq.0)THEN Ch2tst=F Nguhl=0 IF(Prttab(LRGCTS))THEN write(Mt1,*)' All user-defined regressors deleted; '// & 'no chi-square testing will be performed.' IF(.not.Lcmpaq)WRITE(Mt1,*)' ' END IF IF(Svltab(LSLCTS))THEN write(Ng,*)' All user-defined regressors deleted; '// & 'no chi-square testing will be performed.' IF(.not.Lcmpaq)WRITE(Ng,*)' ' END IF END IF IF(.not.lester.and.(Ch2tst.and.Nguhl.gt.0))THEN CALL chkchi(trnsrs,a,nefobs,na,frstry,lester,litr, & Prttab(LRGCTS),Lsumm.gt.0.and.gudrun, & Svltab(LSLCTS)) IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred du &ring the testing of',STDERR,Mt2,T) CALL writln(' a user-defined holiday regressor. The er &ror message appears below.',STDERR,Mt2,F) CALL prterr(nefobs,lauto) IF(Lfatal)RETURN END IF CALL ssprep(T,F,F) END IF c----------------------------------------------------------------------- c Turn off AIC test options c----------------------------------------------------------------------- IF(Itdtst.gt.0)Itdtst=0 IF(Leastr)Leastr=F IF(Luser)Luser=F IF(Ch2tst)Ch2tst=F ELSE c----------------------------------------------------------------------- c Estimate the regression and ARMA parameters and print the results. c----------------------------------------------------------------------- CALL rgarma(Lestim,Mxiter,Mxnlit,(Prttab(LESTIT).or. & Savtab(LESTIT)),a,na,nefobs,ltmp) c----------------------------------------------------------------------- c check to see if there are estimation errors in previous model c estimation c----------------------------------------------------------------------- IF(.not.Lfatal)CALL prterr(nefobs,lauto) IF(Lfatal)RETURN c------------------------------------------------------------------------ c If model estimation saves the estimation iterations, turn this off c for the rest of the run c------------------------------------------------------------------------ IF(Savtab(LESTIT))Savtab(LESTIT)=F END IF Hvmdl=T c----------------------------------------------------------------------- c Outlier identification c----------------------------------------------------------------------- IF(.not.lester.and.lidotl)THEN c----------------------------------------------------------------------- IF(Prttab(LOTLHD))THEN CALL prothd(Begtst,Endtst,Ltstao,Ltstls,Ltsttc,Ladd1, & Critvl) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Prttab(LOTLIT))THEN IF(Prttab(LESAFC).and.Var.gt.ZERO)THEN CALL amdfct(trnsrs,mape,Nobspf,Nfcst,F,fctok,F) IF(Lfatal)RETURN IF(fctok)CALL prafce(Mt1,mape,Outfct,T) END IF IF(.not.Lfatal)CALL prtmdl(Lestim,Prttab(LESTES),Lcalcm,F,F,F, & Prttab(LESTCM),F,Prttab(LESTES), & itmp,Prttab(LESTES), & F,Prttab(LESTIT)) c----------------------------------------------------------------------- IF(.not.Lfatal)CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod, & Fcntyp,Lam,F,F,F) END IF C----------------------------------------------------------------------- IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'bidotlr:',ticks ELSE WRITE(Nform,9000) 'bidotlr.diag:',ticks END IF END IF C----------------------------------------------------------------------- IF(.not.Lfatal) & CALL idotlr(Ltstao,Ltstls,Ltsttc,Ladd1,Critvl,Cvrduc, & Begtst,Endtst,nefobs,Lestim,Mxiter,Mxnlit,lautid, & a,trnsrs,Nobspf,Nfcst,Outfct,fctok,F,0,F, & Prttab(LOTLTS),Prttab(LOTLIT),Savtab(LOTLIT), & Prttab(LOTLFT),Savtab(LOTLFT),Lgraf, & Lsumm.gt.0.and.gudrun) C----------------------------------------------------------------------- IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'eidotlr:',ticks ELSE WRITE(Nform,9000) 'eidotlr.diag:',ticks END IF END IF C----------------------------------------------------------------------- IF((.not.Lfatal).and.(.not.Convrg))CALL prterr(Nefobs,lauto) IF(.not.Lfatal)CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx, & Bgusrx,Nrusrx,Priadj,Reglom,Nrxy, & Begxy,frstry,T,Elong) IF(Lfatal)RETURN CALL ssprep(T,F,F) IF(Lsumm.gt.0.and.gudrun)THEN c add tcrate in .udg file WRITE(Nform,1020)'tcrate: ',Tcalfa IF(Ltstao)THEN cdef=' ' IF(dpeq(Critvl(AO),cv))cdef='*' WRITE(Nform,1010)'aocrit: ',Critvl(AO),cdef END IF IF(Ltstls)THEN cdef=' ' IF(dpeq(Critvl(LS),cv))cdef='*' WRITE(Nform,1010)'lscrit: ',Critvl(LS),cdef END IF IF(Ltsttc)THEN cdef=' ' IF(dpeq(Critvl(TC),cv))cdef='*' WRITE(Nform,1010)'tccrit: ',Critvl(TC),cdef END IF END IF END IF END IF c----------------------------------------------------------------------- c Check AO or LS sequence regressors (BCM: April 2012) c----------------------------------------------------------------------- IF(Nseq.gt.0)THEN IF(dpeq(Tlimit,DNOTST))THEN DO i=1,Nb rtype=Rgvrtp(i) IF(rtype.eq.PRSQLS.or.rtype.eq.PRSQAO)THEN Rgvrtp(i)=Rgvrtp(i)-100 END IF END DO ELSE c----------------------------------------------------------------------- c Print model with all members of sequence c----------------------------------------------------------------------- IF(Var.gt.ZERO)THEN IF(Prttab(LESAFC)) & CALL amdfct(trnsrs,mape,Nobspf,Nfcst,F,fctok,F) IF(Lfatal)RETURN IF(fctok.and.Prttab(LESAFC))CALL prafce(Mt1,mape,Outfct,T) END IF CALL prtmdl(Lestim,Prttab(LESTES),Lcalcm,F,F,F,F,F, & Prttab(LESTES),itmp,Prttab(LESTES),F,F) c----------------------------------------------------------------------- c Generate t-statistics c----------------------------------------------------------------------- CALL genrtt(tval) c----------------------------------------------------------------------- c Check to see if abs(t-stat) > Tlimit c----------------------------------------------------------------------- iseq=0 i=Nb DO WHILE (i.ge.1) rtype=Rgvrtp(i) IF(rtype.eq.PRSQLS.or.rtype.eq.PRSQAO)THEN IF(abs(tval(i)).lt.Tlimit)THEN c----------------------------------------------------------------------- IF(Prttab(LESTES))THEN CALL getstr(Colttl,Colptr,Ncoltl,i,tmpttl,ntmpcr) IF(iseq.eq.0)WRITE(Mt1,1120)Tlimit WRITE(Mt1,1130)tmpttl(1:ntmpcr),tval(i) END IF c----------------------------------------------------------------------- CALL dlrgef(i,Nrxy,1) IF(Lfatal)RETURN iseq=iseq+1 ELSE Rgvrtp(i)=Rgvrtp(i)-100 END IF END IF i=i-1 END DO c----------------------------------------------------------------------- IF(iseq.gt.0)THEN IF(Prttab(LESTES))WRITE(Mt1,1140) c ------------------------------------------------------------------ c If model has been changed, regenerate regression matrix c ------------------------------------------------------------------ CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) CALL rgarma(Lestim,Mxiter,Mxnlit,(Prttab(LESTIT).or. & Savtab(LESTIT)),a,na,nefobs,ltmp) c ------------------------------------------------------------------ IF(.not.Lfatal)CALL prterr(nefobs,lauto) IF(Lfatal)RETURN END IF END IF CALL ssprep(T,F,F) END IF c----------------------------------------------------------------------- c Compute and print out average forecast error from original c X-11-ARIMA c----------------------------------------------------------------------- IF(Var.gt.ZERO)THEN IF(Prttab(LESAFC).or.Svltab(LSLAFC).or.ldiag) & CALL amdfct(trnsrs,mape,Nobspf,Nfcst,F,fctok,F) IF(Lfatal)RETURN IF(fctok.and.Prttab(LESAFC))CALL prafce(Mt1,mape,Outfct,T) c----------------------------------------------------------------------- c Print out entry for log c----------------------------------------------------------------------- IF(fctok.and.Svltab(LSLAFC))THEN IF(Outfct)THEN WRITE(Ng,1210)'out-of-sample forecasts' ELSE WRITE(Ng,1210)'within-sample forecasts' END IF WRITE(Ng,1220)(mape(i),i=1,4) END IF IF(fctok.and.ldiag)THEN IF(Outfct)THEN WRITE(Nform,'(a)')'aape.mode: outofsample' ELSE WRITE(Nform,'(a)')'aape.mode: withinsample' END IF WRITE(Nform,1200)'aape.0: ',mape(4) WRITE(Nform,1200)'aape.1: ',mape(1) WRITE(Nform,1200)'aape.2: ',mape(2) WRITE(Nform,1200)'aape.3: ',mape(3) END IF ELSE fctok=F END IF IF(.not.fctok)THEN IF(Svltab(LSLAFC))WRITE(Ng,1210)'none' IF(ldiag)WRITE(Nform,'(a)')'aape.mode: none' END IF c----------------------------------------------------------------------- c Print out the final model c----------------------------------------------------------------------- IF(Iregfx.ge.2)THEN CALL addfix(trnsrs,Nbcst,0,1) IF(.not.Lfatal) & CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF(Lfatal)RETURN END IF CALL prtmdl(Lestim,Prttab(LESTES),Lcalcm,Savtab(LESTES),Lgraf, & ldiag,Prttab(LESTCM),Savtab(LESTCM),Prttab(LESTES), & Lsrun,Prttab(LESTES),Prttab(LOTLTL),Prttab(LESTIT)) c----------------------------------------------------------------------- c Print out entries for diagnostic and log files related to outlier c regressors c----------------------------------------------------------------------- CALL savotl(Lsumm,Svltab(LSLAOT),gudrun,lidotl) c----------------------------------------------------------------------- IF(Convrg.and.Lestim.and.gudrun.and.Nliter.gt.BADITR)THEN IF(.not.Lquiet)WRITE(STDERR,1101)BADITR IF(Prttab(LESTIT).or.Prttab(LESTES))WRITE(Mt1,1101)BADITR WRITE(Mt2,1101) 1101 FORMAT(/,' WARNING: Convergence of the coefficient estimation ', & 'procedure required',/, & ' more than ',i3,' iterations. This often ', & 'indicates some inadequacy',/ & ' in the model being estimated.',/) END IF c----------------------------------------------------------------------- IF(Lestim.and.Prttab(LESTES).and.gudrun)THEN begopr=Opr(Mdl(AR-1)-1) endopr=Opr(Mdl(MA)-1)-1 IF(istrue(Arimaf,begopr,endopr))THEN CALL writln(' NOTE: Fixed values have been assigned to some reg &ression and ARIMA model',Mt1,Mt2,T) CALL writln(' coefficients. If these values are estimate &s calculated by '//PRGNAM//',',Mt1,Mt2,F) CALL writln(' then the model comparison statistics (AIC, &AICC, Hannan Quinn, and BIC)',Mt1,Mt2,F) CALL writln(' and the P-values of the Q''s of the sample &autocorrelations of the',Mt1,Mt2,F) CALL writln(' residuals below are invalid and should not &be used.',Mt1,Mt2,F) ELSE IF(istrue(Regfx,1,Nb))THEN CALL writln(' NOTE: Fixed values have been assigned to some reg &ression coefficients.',Mt1,Mt2,T) CALL writln( & ' If these values are estimates calculated by '// & PRGNAM//', then the',Mt1,Mt2,F) CALL writln(' model comparison statistics (AIC, AICC, Han &nan Quinn and BIC)',Mt1,Mt2,F) CALL writln( & ' below are invalid and should not be used.',Mt1,Mt2,F) END IF END IF c----------------------------------------------------------------------- IF(.not.Lfatal.and.Prttab(LESTAM).and.Lcalcm)CALL armacr IF(.not.Lfatal.and.Savtab(LESTAM).and.Lcalcm)CALL svamcm IF(Lfatal)RETURN IF(Prttab(LESTST).or.Savtab(LESTST).or.Prttab(LESTFM).or. & Irev.eq.4.or.ldiag) & CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam, & Savtab(LESTST),Prttab(LESTST),Prttab(LESTFM)) IF(Lfatal)RETURN IF(ldiag.and.(.not.dpeq(Lnlkhd,DNOTST)))THEN WRITE(Nform,1061)'nefobs: ',nefobs WRITE(Nform,1200)'loglikelihood: ',Lnlkhd WRITE(Nform,1200)'aic: ',Aic WRITE(Nform,1200)'aicc: ',Aicc WRITE(Nform,1200)'bic: ',Bic WRITE(Nform,1200)'hq: ',Hnquin IF(Eick.gt.0)THEN WRITE(Nform,1200)'eic: ',Eic WRITE(Nform,1200)'k: ',Eick END IF END IF IF(Svltab(LSLAIC).and.(.not.dpeq(Aic,DNOTST))) & WRITE(Ng,1200)' AIC : ',Aic IF(Svltab(LSLACC).and.(.not.dpeq(Aicc,DNOTST))) & WRITE(Ng,1200)' AICC : ',Aicc IF(Svltab(LSLBIC).and.(.not.dpeq(Bic,DNOTST))) & WRITE(Ng,1200)' BIC : ',Bic IF(Svltab(LSLHQ).and.(.not.dpeq(Hnquin,DNOTST))) & WRITE(Ng,1200)' Hannan-Quinn : ',Hnquin IF(Svltab(LSLEIC).and.(.not.dpeq(Eic,DNOTST))) & WRITE(Ng,1201)' EIC (k=',Eick,') : ',Eic c----------------------------------------------------------------------- c Print out the roots of the AR and MA polynomials c----------------------------------------------------------------------- IF(Prttab(LESTRT).or.Savtab(LESTRT).or.Svltab(LSLRTS).or. & ldiag)THEN CALL prtrts(Prttab(LESTRT),Savtab(LESTRT),Svltab(LSLRTS),ldiag) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Print out the regression matrix with the added outliers c----------------------------------------------------------------------- IF(Prttab(LREGDT).and.Nb.gt.0)THEN CALL prtshd('Regression Matrix',Begxy,Sp,Nrxy,T) IF(.not.Lfatal)CALL prtmtx(Begxy,Sp,Xy,Nrxy,Ncxy,Colttl,Colptr, & Ncoltl) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Savtab(LREGDT))THEN CALL savmtx(LREGDT,Begxy,Sp,Xy,Nrxy,Ncxy,Colttl,Colptr,Ncoltl) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Prttab(LRGTDW).and.Lcalcm)CALL prtdwr() c----------------------------------------------------------------------- IF(Ldestm)THEN IF(Savtab(LESTMD))THEN CALL savmdl(Begxy,Nrxy,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print out the residuals c----------------------------------------------------------------------- IF(Prttab(LESTRS).or.Savtab(LESTRS))THEN CALL addate(Begspn,Sp,Nspobs-na,idate) c----------------------------------------------------------------------- IF(Prttab(LESTRS))THEN outdec=Kdec IF(outdec.lt.3)outdec=3 CALL prtshd('Model Residuals',idate,Sp,na,T) IF(Lfatal)RETURN CALL prttbl(idate,Sp,a,na,'Data',outdec) END IF c----------------------------------------------------------------------- IF(Savtab(LESTRS))THEN CALL savtbl(LESTRS,idate,1,na,Sp,a,Serno,Nser,F) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Calculate the ACF, ACF of squared residual, and residual histogram c----------------------------------------------------------------------- IF(Convrg)THEN IF(Mxcklg.gt.0)THEN IF(.not.Lhiddn.and.istrue(Prttab,LCKACF,LCKNRM))WRITE(Mt1,1110) CALL prtacf(LSPCHK,nefobs,a,na,Mxcklg,Lgraf,ldiag,NOTSET, & NOTSET) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(gudrun)THEN nlagbl=MIN(Mxcklg,Sp*2) IF(ldiag.or.Svltab(LSLLBQ).or.Svltab(LSLLBQ+1)) & CALL acfdgn(nefobs,a,na,Mxcklg,nlagbl,ldiag) c----------------------------------------------------------------------- CALL pracf2(nefobs,a,na,Mxcklg,Lgraf,ldiag) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Prttab(LCKHST).and.Var.gt.ZERO)THEN WRITE(Mt1,1170) CALL hist(a(na-nefobs+1),Begspn,Sp,nefobs,Nobs-nefobs,Muladd) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF((Prttab(LCKNRM).or.Savtab(LCKNRM).or.Svltab(LSLNRM)).and. & Var.gt.ZERO.and.gudrun)THEN IF(Prttab(LCKNRM))WRITE(Mt1,1180) CALL nrmtst(a(na-nefobs+1),nefobs,Prttab(LCKNRM), & Savtab(LCKNRM),Svltab(LSLNRM)) END IF c----------------------------------------------------------------------- IF((Prttab(LCKDW).or.Savtab(LCKDW).or.Svltab(LSLCDW)).and. & Var.gt.ZERO.and.gudrun)THEN IF(Prttab(LCKDW))WRITE(Mt1,1181) rvar = ZERO DO i = na-nefobs+1,na rvar = rvar + a(i)*a(i) END DO dw = ZERO do i = na-nefobs+2,Na dw = dw + (a(i)-a(i-1))**2 end do dw = dw / rvar IF(Prttab(LCKDW))write(Mt1,1300)'dw',dw IF(Svltab(LSLCDW))WRITE(Ng,1300)'Durbin-Watson statistic',dw IF(Savtab(LCKDW))write(Nform,9000)'durbinwatson: ',dw END IF c----------------------------------------------------------------------- IF((Prttab(LCKFRT).or.Savtab(LCKFRT).or.Svltab(LSLCFR)).and. & Var.gt.ZERO.and.gudrun)THEN IF(Prttab(LCKFRT))WRITE(Mt1,1182) Ken = kendalls(a(na-nefobs+1),nefobs,Sp) IF(Prttab(LCKFRT)) & write(Mt1,1310)'ken',Ken,Sp-1,chisq(Ken,Sp-1) IF(Savtab(LCKFRT)) & write(Nform,9001)'friedman: ',Ken,Sp-1,chisq(Ken,Sp-1) IF(Svltab(LSLCFR)) & write(Ng,1310)'Friedman test',Ken,Sp-1,chisq(Ken,Sp-1) END IF END IF c----------------------------------------------------------------------- IF((Prttab(LSPCQS).or.Savtab(LSPCQS).or.Svltab(LSLQS)).and. & Var.gt.ZERO.and.gudrun.and.Sp.gt.1)THEN QsRsd = calcqs(a,na-nefobs,na,Sp) IF(Prttab(LSPCQS)) & WRITE(Mt1,1185)'full series',QsRsd,chisq(QsRsd,2) CALL addate(Begspn,Sp,Nspobs-na,idate) CALL dfdate(Bgspec,idate,Sp,ipos) IF(ipos.gt.0)THEN QsRsd2 = calcqs(a,ipos,na,Sp) CALL wrtdat(Bgspec,Sp,begstr,nchr) IF(Prttab(LSPCQS)) & WRITE(Mt1,1185)'starting '//begstr(1:nchr),QsRsd2, & chisq(QsRsd2,2) END IF END IF c----------------------------------------------------------------------- IF((Prttab(LSPCRS).or.Savtab(LSPCRS).or.Prttab(LSPCTP).or. & Savtab(LSPCTP).or.Lsumm.gt.0.or.Lgraf).and.Var.gt.ZERO & .and.(Sp.eq.12).and.gudrun)THEN CALL addate(Begspn,Sp,Nspobs-na,idate) c CALL addate(idate,Sp,na-nefobs+1,idate) CALL spcrsd(a,na,idate,Sp,Endspn,LSPCRS,F,Lsumm,Lgraf) c CALL spcrsd(a(na-nefobs+1),nefobs,idate,Sp,Endspn,LSPCRS, c & Lsumm,Lgraf) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If Length of Month Adjustment indicator has changed, adjust c value of Sto and related variables (BCM 3-30-2011) c----------------------------------------------------------------------- IF(ilom.ne.Priadj)THEN CALL copy(Orig(Pos1ob),Nomnfy,-1,Sto(Pos1ob)) lastpr=Nofpob IF(Pos1ob.gt.1)lastpr=lastpr+Pos1ob-1 CALL divsub(Sto,Sto,Sprior,Pos1ob,lastpr) END IF c----------------------------------------------------------------------- c Reset ending date of span for forecasting, if necessary. c----------------------------------------------------------------------- IF(nend.gt.0)THEN CALL setspn(Sp,nend,0,Begspn,Endspn,Begmdl,Endmdl,Nspobs, & Frstsy,Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy, & Begadj,Adj1st) c----------------------------------------------------------------------- c Recopy the series into trnsrs, and redo the transformation c----------------------------------------------------------------------- CALL copy(Sto(Pos1ob+nbeg),Nspobs,-1,trnsrs) CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Generate regression matrix c----------------------------------------------------------------------- CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Forecasts c----------------------------------------------------------------------- IF(Nfcst.gt.0)THEN CALL prtfct(Nobspf,Nrxy,Fcntyp,Lam,Lognrm,Fctdrp,Nfcst,Ciprob, & fcstx,untfct,Kdec,Posfob,Lgraf, & Lsumm.gt.0.and.gudrun,Lseats,Khol,Kswv) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Backcasts c----------------------------------------------------------------------- IF(Nbcst.gt.0)THEN CALL mkback(trnsrs,Priadj,bcstx,untbct,Pos1bk,Kdec,Lgraf) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Reset beginning dates of span, if necessary. c----------------------------------------------------------------------- IF(nbeg.gt.0)THEN CALL setspn(Sp,nend,nbeg,Begspn,Endspn,Begmdl,Endmdl,Nspobs, & Frstsy,Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy, & Begadj,Adj1st) c----------------------------------------------------------------------- IF(ilom.ne.Priadj)THEN CALL copy(Orig(Pos1ob),Nomnfy,-1,Sto(Pos1ob)) lastpr=Nofpob IF(Pos1ob.gt.1)lastpr=lastpr+Pos1ob-1 CALL divsub(Sto,Sto,Sprior,Pos1ob,lastpr) IF(Nustad.gt.0)THEN CALL copy(Usrtad(Frstat+Lsp-1),Nspobs,1,dvec(Pos1ob)) CALL divsub(Stoap,Sto,dvec,Pos1ob,Posfob) END IF IF(Nuspad.gt.0)THEN CALL copy(Usrpad(Frstap+Lsp-1),Nspobs,1,dvec(Pos1ob)) CALL divsub(Stopp,Sto,dvec,Pos1ob,Posfob) CALL divsub(Stoap,Stoap,dvec,Pos1ob,Posfob) END IF END IF c----------------------------------------------------------------------- c Recopy the series into trnsrs, and redo the transformation c----------------------------------------------------------------------- CALL copy(Sto(Pos1ob),Nspobs,-1,trnsrs) CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Generate regression matrix c----------------------------------------------------------------------- CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If estimation did not converge, exit with an error c----------------------------------------------------------------------- ELSE CALL abend RETURN END IF END IF c----------------------------------------------------------------------- c Extend Series with backcasts and forecasts c----------------------------------------------------------------------- * write(Mtprof,*) ' trnsrs(1) = ',trnsrs(1) CALL setdp(ZERO,PLEN,orix) IF(Ldestm.and.((Nfcst.gt.0.and.Nfdrp.gt.0).or.Nbcst.gt.0))THEN CALL extend(trnsrs,Begxy,orix,Extok,Lam,fcstx,bcstx) IF(Lfatal)RETURN ELSE CALL copy(trnsrs,Nobspf,1,orix(Pos1ob)) END IF * write(Mtprof,*) ' Orix(Pos1bk) = ',Orix(Pos1bk) c----------------------------------------------------------------------- c initialize regression factors to zero c----------------------------------------------------------------------- CALL setdp(ZERO,PLEN,ftd) CALL setdp(ZERO,PLEN,fhol) CALL setdp(ZERO,PLEN,fao) CALL setdp(ZERO,PLEN,fls) CALL setdp(ZERO,PLEN,ftc) CALL setdp(ZERO,PLEN,fso) CALL setdp(ZERO,PLEN,fusr) CALL setdp(ZERO,PLEN,fsea) CALL setdp(ZERO,PLEN,fmv) CALL setdp(ZERO,PLEN,fcyc) c----------------------------------------------------------------------- c Print the header for the regression effects matrix, if necessary c----------------------------------------------------------------------- nf2=NOTSET IF(Ldestm)THEN IF(Prttab(LESTRE))THEN CALL prtshd('Regression Effects',Begxy,Sp,Nrxy,T) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- CALL chkadj(tdreg,Khol,Lseats,Lam) IF(Prttab(LESTRE).or.Savtab(LESTRE).or.Adjtd.eq.1.or.Adjhol.eq.1 & .or.Adjao.eq.1.or.Adjls.eq.1.or.Adjtc.eq.1.or.Adjso.eq.1.or. & Adjsea.eq.1.or.Adjcyc.eq.1.or.Adjusr.eq.1.or.Finhol.or.Finao & .or.Finls.or.Fintc.or.Finusr.or.Missng)THEN c----------------------------------------------------------------------- c If number of forecasts is less that the length of the seasonal c period, redo the regression variables so that there are enough c regressors for one year of forecasts. c----------------------------------------------------------------------- * IF(Nfcst.lt.Sp.and.(Adjtd.eq.1.or.Adjhol.eq.1.or.Adjao.eq.1.or. * & Adjls.eq.1.or.Adjtc.eq.1.or.Adjtc.eq.1.or.Adjsea.eq.1.or. * & Adjcyc.eq.1.or.Adjusr.eq.1.or.Finhol.or.Finao.or.Finls.or. * & Fintc.or.Finusr.or.Missng).and.Lx11)THEN * nf2=Nfcst * Nfcst=Sp * Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nomnfy) * CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, * & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) * IF(Lfatal)RETURN * END IF c----------------------------------------------------------------------- c Print out the regression effects with the added outliers for the c series extended by forecasts and backcasts c----------------------------------------------------------------------- outdec=Kdec IF((.not.dpeq(Lam,ONE)).and.outdec.lt.3)outdec=3 CALL regvar(orix,Nrxy,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF(Lfatal)RETURN CALL prtref(Begxy,Nrxy,Fctdrp,Nfcst,Nbcst,outdec,Prttab(LESTRE), & Savtab(LESTRE),ftd,fhol,fao,fls,ftc,fso,fusr,fsea, & fmv,fcyc,Nusrrg,Lseats,Rmcnst,Prttab(LESRRS), & Savtab(LESRRS),Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check for improper adjustment mode in seasonal adjustment c----------------------------------------------------------------------- IF(Lx11.and.(Adjtd.eq.1.or.Adjhol.eq.1.or.Adjao.eq.1.or. & Adjls.eq.1.or.Adjtc.eq.1.or.Adjso.eq.1.or.Adjsea.eq.1.or. & Adjcyc.eq.1.or.Adjusr.eq.1.or.Finao.or.(Finhol.and.Nhol.gt.0) & .or.Finls.or.Fintc.or.Finusr))THEN IF(Muladd.eq.1.AND.(.not.dpeq(Lam,ONE)))THEN CALL writln('ERROR: Additive seasonal adjustment will not be p &erformed when',STDERR,Mt2,T) CALL writln(' preadjustment factors are derived from a R &EGARIMA model ',STDERR,Mt2,F) CALL writln(' for transformed data.',STDERR,Mt2,F) CALL writln(' Check the values for the power or function & arguments of the ',STDERR,Mt2,T) CALL writln(' transform spec and mode of the x11 spec.', & STDERR,Mt2,F) CALL abend() c----------------------------------------------------------------------- ELSE IF((Muladd.eq.0.or.Muladd.eq.2).AND. & (.not.dpeq(Lam,ZERO)))THEN CALL writln('ERROR: Multiplicative or log additive seasonal ad &justment cannot be',STDERR,Mt2,T) CALL writln(' performed when preadjustment factors are d &erived from a regARIMA',STDERR,Mt2,F) CALL writln(' model for data which have not been log tra &nsformed.',STDERR,Mt2,F) CALL writln(' Check the values for the power or function & arguments of the ',STDERR,Mt2,T) CALL writln(' transform spec and mode of the x11 spec.', & STDERR,Mt2,F) CALL abend() END IF IF(Lfatal)RETURN END IF END IF END IF c----------------------------------------------------------------------- c Generate adjustment factors for regression variables c----------------------------------------------------------------------- CALL adjreg(orix,orixmv,Temp,ftd,fao,fls,ftc,fso,fsea,fcyc,fusr, & fmv,fhol,Fcntyp,Lam,Nrxy,n) c----------------------------------------------------------------------- c copy missing value adjusted series into variable for SEATS c (August 2008 BCM) c----------------------------------------------------------------------- IF(Lseats)THEN Nobspf=Nspobs+Nfcst DO i = 1, Nobspf Orixs(i)=orixmv(Pos1ob+i-1) END DO END IF c----------------------------------------------------------------------- c IF regression matrix was extended, restore variables to their c original state c----------------------------------------------------------------------- * IF(nf2.ne.NOTSET)THEN * Nfcst=nf2 * Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nomnfy) * CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, * & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) * IF(Lfatal)RETURN * END IF c----------------------------------------------------------------------- c Get regression trading day factors for type of month table c----------------------------------------------------------------------- IF((Tdtbl.ge.2.and.Lx11.and.gudrun).and.Ldestm)THEN IF(tdreg.eq.0)THEN Tdtbl=Tdtbl-2 ELSE IF(Irev.lt.4)THEN tdreg=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(tdreg.eq.0)tdreg=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'Stock Trading Day') IF(tdreg.eq.0)tdreg=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Trading Day') IF(tdreg.eq.0)tdreg=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Stock Trading Day') c IF(tdreg.eq.0)tdreg=-strinx(F,Grpttl,Grpptr,1,Ngrptl, c & 'User-defined') CALL getmtd(tdreg,Begxy,Nrxy,Fcntyp,Lam) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c If missing value codes are found in the series, replace values of c the original series with the missing value adjusted series. c----------------------------------------------------------------------- IF(Missng.and.Ldestm)THEN DO i=Pos1ob,Posfob IF(.not.dpeq(Series(i),Orixmv(i)))THEN Series(i)=Orixmv(i) Orig(i)=Orixmv(i) Stoap(i)=Orixmv(i) Stopp(i)=Orixmv(i) IF(Nuspad.gt.0)THEN i2=Frstap+Lsp-1+(i-Pos1ob) IF(Muladd.eq.1)THEN Stoap(i)=Stoap(i)-Usrpad(i2) Stopp(i)=Stopp(i)-Usrpad(i2) ELSE Stoap(i)=Stoap(i)/Usrpad(i2) Stopp(i)=Stopp(i)/Usrpad(i2) END IF END IF IF(Nustad.gt.0)THEN i2=Frstat+Lsp-1+(i-Pos1ob) IF(Muladd.eq.1)THEN Stoap(i)=Stoap(i)-Usrtad(i2) ELSE Stoap(i)=Stoap(i)/Usrtad(i2) END IF END IF END IF END DO c----------------------------------------------------------------------- c Print and/or save missing value adjusted series c----------------------------------------------------------------------- IF(Prttab(LSRSMV)) & CALL table(Series,Pos1ob,Posfob,1,1,2,dvec,LSRSMV) IF(.not.Lfatal.and.Savtab(LSRSMV)) & CALL punch(Series,Pos1ob,Posfob,LSRSMV,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Series,Pos1ob,Posfob,LSRSMV,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Delete missing value regressors c----------------------------------------------------------------------- i=Nb DO WHILE (i.ge.1) IF(Rgvrtp(i).eq.PRGTMV)THEN CALL dlrgef(i,Nrxy,1) IF(Lfatal)RETURN END IF i=i-1 END DO END IF c----------------------------------------------------------------------- c Reset model parameters for sliding spans, revisions history c----------------------------------------------------------------------- CALL ssprep(T,F,F) c----------------------------------------------------------------------- IF(.not.gudrun)CALL copy(Orig,PLEN,1,Orig2) IF(Nfcst.gt.0)THEN DO i=Posfob+1,Posffc Orig2(i)=untfct(i-Posfob) END DO END IF IF(Nbcst.gt.0)THEN DO i=Pos1bk,Pos1ob-1 Orig2(i)=untbct(i-Pos1bk+1) END DO END IF c----------------------------------------------------------------------- IF(ldiag)THEN IF(Nb.gt.0)THEN CALL svfnrg('finalreg',Ngrp,Grpttl,Grpptr,Ngrptl) ELSE WRITE(Nform,1190)'nfinalreg: ',1 WRITE(Nform,1060)'finalreg01:',' none' END IF END IF c----------------------------------------------------------------------- 1000 FORMAT(a,i2,a2,1x,a,',',i4,' to ',i2,a2,1x,a,',',i4) 1001 FORMAT(a,i4,' to ',i4) 1010 FORMAT(a,f6.3,1x,a) 1020 FORMAT(a,f10.6) 1021 FORMAT(a,e13.6) 1030 FORMAT(/,' MODEL IDENTIFICATION (Using regression residuals)') 1040 FORMAT(/,' MODEL IDENTIFICATION') 1050 FORMAT('arimamdl: ',a) 1060 FORMAT(a:,a) 1061 FORMAT(a,i6) 1070 FORMAT(5x,'Default model used : ',a,' (no model selected)',/) 1080 FORMAT(5x,'Automatic model chosen : ',a,/) 1090 FORMAT(/,' MODEL DEFINITION') 1100 FORMAT(//,' MODEL ESTIMATION/EVALUATION') 1110 FORMAT(//,' DIAGNOSTIC CHECKING') 1120 FORMAT(/,2x,'The following sequence outliers have been ', & 'deleted since the',/, & 2x,'absolute value of their t-values are less than ', & f10.3,':') 1130 FORMAT(5x,a,' (t-value = ',f10.3,')') 1140 FORMAT(/,2x,'regARIMA model will be restimated without these ', & 'regressors.',/) 1160 FORMAT(2x,'Number of forecasts/backcasts set to zero because ', & 'forecast error for the',/, & 2x,' model identified, ',F10.3,', is greater than ',f10.3, & '.') 1170 FORMAT(' Histogram of the Standardized and Mean-Centered', & ' Residuals') 1180 FORMAT(/,' Normality Statistics for regARIMA Model Residuals:') 1181 FORMAT(/,' Durbin-Watson Statistic for regARIMA Model Residuals:') 1182 FORMAT(/,' Friedman Non-Parametric Test for regARIMA Model', & ' Residuals:') 1185 FORMAT(/,' QS Statistic for regARIMA Model Residuals (',a,'):', & t65,f10.2,/,t56,'(P-Value = ',f10.4,')') 1190 FORMAT(a,i2) 1200 FORMAT(a,f12.4) 1201 FORMAT(a,f6.2,a,f12.4) 1210 FORMAT(' Average Absolute Percentage Error : ',a) 1220 FORMAT(' AAPE(Last year) : ',f16.2,/, & ' AAPE(Last-1 year) : ',f16.2,/, & ' AAPE(Last-2 year) : ',f16.2,/, & ' AAPE(Last 3 years): ',f16.2) 1300 FORMAT(2x,a,' = ',f12.6) 1310 FORMAT(2x,a,' = ',f12.6,' ( Asymptotically distributed as ', & 'Chi-Square(',i2,'), P-Value = ',f12.6,' )') 9000 FORMAT(a,e15.8) 9001 FORMAT(a,e15.8,1x,i3,1x,e15.8) c----------------------------------------------------------------------- RETURN END armacr.f0000664006604000003110000000456614521201410011606 0ustar sun00315stepsC Last change: BCM 24 Nov 97 12:26 pm SUBROUTINE armacr IMPLICIT NONE c----------------------------------------------------------------------- c Calculates and print the correlation matrix from (X'X)^-1 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ INTEGER OPRS PARAMETER(OPRS=2) c ------------------------------------------------------------------ CHARACTER cfix*7,tmpttl*(POPRCR) INTEGER beglag,begopr,endlag,endopr,icol,iestpm,iflt,ilag,iopr,j, & ntmpcr c ------------------------------------------------------------------ IF(Nestpm.le.1)RETURN iestpm=0 c ------------------------------------------------------------------ WRITE(Mt1,1010)(icol,icol=1,Nestpm) 1010 FORMAT(/,' ARMA Parameter Correlation matrix',/,' Parameter', & (:t15,10I6)) WRITE(Mt1,1020)('-',icol=1,12+6*min(Nestpm,10)) 1020 FORMAT(' ',(78a)) c ------------------------------------------------------------------ DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ CALL isfixd(OPRS,Arimaf,beglag,endlag,cfix) IF(cfix.eq.' ')THEN CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN WRITE(Mt1,1030)tmpttl(1:ntmpcr) 1030 FORMAT(' ',a,t39,a) c ------------------------------------------------------------------ DO ilag=beglag,endlag IF(.not.Arimaf(ilag))THEN iestpm=iestpm+1 WRITE(Mt1,1040)Arimal(ilag), & (Armacm(iestpm,j)/sqrt(Armacm(j,j) & *Armacm(iestpm,iestpm)),j=1,iestpm) 1040 FORMAT(' Lag',i3,5x,10F6.2,(:/,t14,10F6.2)) END IF END DO END IF END DO END DO c ------------------------------------------------------------------ RETURN END armafl.f0000664006604000003110000002652014521201410011575 0ustar sun00315stepsC Last change: REG 15 Sep 2005 C Previous change: BCM 9 Oct 97 10:36 am SUBROUTINE armafl(Nr,Nc,Linit,Lckrts,Mata,Na,Nata,Info) IMPLICIT NONE c----------------------------------------------------------------------- c armafl.f, Release 1, Subroutine Version 1.8, Modified 15 Sep 2005. c----------------------------------------------------------------------- c Changes: c Modified 15 Sep 2005, by REG, to add PORDER (size of acv vector) c to XPAND() argument list (new input variable), c----------------------------------------------------------------------- c Exact ARMA filter c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ LOGICAL F DOUBLE PRECISION ONE,ZERO INTEGER PMATD PARAMETER(ONE=1D0,ZERO=0D0,F=.false.,PMATD=(PLEN+PORDER)*PORDER) c ------------------------------------------------------------------ LOGICAL chkrts,Lckrts,Linit INTEGER begopr,endopr,i,ielt,ilag,Info,j,k,lastlg,maxpq,Na,nacv, & Nc,nelta,neltd,neltwp,nextma,nfular,nfulma,Nr,qprow,row, & Nata DOUBLE PRECISION acv,ldtvwp,ddot,fular,fulma,Mata,psiwgt,tmp DIMENSION acv(0:PORDER),fular(0:PORDER),fulma(0:PORDER), & Mata(Nata),psiwgt(0:PORDER) EXTERNAL chkrts,ddot c----------------------------------------------------------------------- SAVE nextma c----------------------------------------------------------------------- c No ARMA model to filter c----------------------------------------------------------------------- Info=0 IF(Nopr.eq.0)THEN Na=Nr c----------------------------------------------------------------------- c Check that the MA coeficients are invertibile, and the AR roots c are stationary if they are calculated exactly. If filtering c conditionally it will never reach the roots check. If the roots are c invertible and stationary then initialize G'G, D, and Var(w_p|z) c----------------------------------------------------------------------- ELSE IF(Lar)THEN begopr=Mdl(AR-1) ELSE begopr=Mdl(MA-1) END IF endopr=Mdl(MA)-1 c ------------------------------------------------------------------ IF(Lckrts.and.chkrts(begopr,endopr))THEN Info=PINVER GO TO 10 END IF c ------------------------------------------------------------------ IF(Linit.and.(Lma.or.Lar))THEN nextma=Nr-Mxdflg-Mxarlg+Mxmalg CALL intgpg(nextma,Info) c ------------------------------------------------------------------ IF(Info.gt.0)THEN Info=PGPGER GO TO 10 END IF c----------------------------------------------------------------------- c Expand the MA operator and put in a vector with all the zero c coefficients included. Do this by AR filtering a vector of zero's c with 1 at the first time point. \theta(B)\Theta(B)*1=fullMA(B). c----------------------------------------------------------------------- IF(Lar)THEN fulma(0)=ONE nfulma=Mxmalg+1 CALL mltpos(1,Arimap,Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,nfulma, & fulma) c ------------------------------------------------------------------ CALL copy(fulma,nfulma,1,psiwgt) CALL ratpos(nfulma,Arimap,Arimal,Opr,Mdl(AR-1),Mdl(AR)-1, & nfulma,psiwgt) c ------------------------------------------------------------------ maxpq=max(Mxarlg,Mxmalg) CALL uconv(fulma,Mxmalg,acv) * CALL uconv(fulma,Mxmalg,acv,PORDER) c----------------------------------------------------------------------- c Expand the AR operator and put in a vector with all the zero c coefficients included. Do this by AR filtering a vector of zero's c with 1 at the first time point. \phi(B)\Phi(B)*1=fullAR(B). c----------------------------------------------------------------------- fular(0)=ONE nfular=Mxarlg+1 CALL mltpos(1,Arimap,Arimal,Opr,Mdl(AR-1),Mdl(AR)-1,nfular, & fular) c matd is used as work space CALL euclid(fular,Matd,Matd(Mxarlg+1),maxpq,Mxarlg,Mxmalg,acv, & Info) c ------------------------------------------------------------------ IF(Info.gt.0)THEN Info=PACFER GO TO 10 END IF c ------------------------------------------------------------------ nacv=Mxarlg c CALL ratpos(maxpq,Arimap,Arimal,Opr,Mdl(AR-1),Mdl(AR)-1,nacv, c & acv) CALL xpand(fular,Mxarlg,maxpq,nacv,acv,PORDER) acv(0)=2D0*acv(0) END IF c----------------------------------------------------------------------- c Calculate D c Note, that only the last min(p,q) columns are nonzero so only need to c creat and filter those. GITWF. c----------------------------------------------------------------------- IF(Lar.and.Lma)THEN neltd=(Nr-Mxdflg-Mxarlg)*Mxarlg CALL setdp(ZERO,neltd,Matd) c ------------------------------------------------------------------ DO row=1,Mxmalg qprow=Mxmalg+row tmp=ZERO DO k=row,Mxmalg tmp=tmp+fulma(qprow-k)*psiwgt(Mxmalg-k) END DO c ------------------------------------------------------------------ ielt=Mxarlg*row DO k=max(1,Mxarlg-row+1),Mxarlg Matd(ielt)=tmp ielt=ielt-Mxarlg-1 END DO END DO c----------------------------------------------------------------------- c Multiply the lags by the number of columns c so a matrix can be filtered the same as a vector c----------------------------------------------------------------------- lastlg=Opr(endopr)-1 c ------------------------------------------------------------------ DO ilag=1,lastlg Arimal(ilag)=Mxarlg*Arimal(ilag) END DO c ------------------------------------------------------------------ CALL exctma(Mxarlg,Matd,neltd,PMATD) c----------------------------------------------------------------------- c Put the vector length and the lags back on a row basis c----------------------------------------------------------------------- nextma=neltd/Mxarlg c ------------------------------------------------------------------ DO ilag=1,lastlg Arimal(ilag)=Arimal(ilag)/Mxarlg END DO c ------------------------------------------------------------------ CALL xprmx(Matd,nextma,Mxarlg,Mxarlg,Chlvwp) c----------------------------------------------------------------------- c Calculate chol(\Sigma_p-D'D) c----------------------------------------------------------------------- ielt=0 DO j=1,Mxarlg DO i=1,j ielt=ielt+1 Chlvwp(ielt)=acv(j-i)-Chlvwp(ielt) END DO END DO c----------------------------------------------------------------------- c Calculate chol(\Sigma_p-D'D) c----------------------------------------------------------------------- ELSE IF(Lar)THEN ielt=0 DO j=1,Mxarlg DO i=1,j ielt=ielt+1 Chlvwp(ielt)=acv(j-i) END DO END DO END IF c----------------------------------------------------------------------- c Calculate the cholesky decomposition and determinate of var(w_p|z) c----------------------------------------------------------------------- IF(Lar)THEN CALL dppfa(Chlvwp,Mxarlg,Info) c ------------------------------------------------------------------ IF(Info.gt.0)THEN Info=PVWPER GO TO 10 c ------------------------------------------------------------------ ELSE CALL logdet(Chlvwp,Mxarlg,ldtvwp) Lndtcv=Lndtcv+ldtvwp END IF END IF ELSE IF(Lma.or.Lar)THEN nextma=Nr-Mxdflg-Mxarlg+Mxmalg END IF c----------------------------------------------------------------------- c Multiply the series length and the lags by the number of columns c so a matrix can be filtered the same as a vector c----------------------------------------------------------------------- nelta=Nr*Nc c ------------------------------------------------------------------ endopr=Mdl(MA)-1 lastlg=Opr(endopr)-1 c ------------------------------------------------------------------ DO ilag=1,lastlg Arimal(ilag)=Nc*Arimal(ilag) END DO c----------------------------------------------------------------------- c Difference the data, then if doing conditional AR AR filter also. c Note that nelta is reduced by differencing order, d*nc, and c conditional AR order, p*nc. c----------------------------------------------------------------------- CALL arflt(nelta,Arimap,Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1,Mata, & nelta) c----------------------------------------------------------------------- c Put \vecwp in first then \hat\veca c----------------------------------------------------------------------- IF(Lar)THEN neltwp=Mxarlg*Nc CALL copy(Mata,nelta,-1,Mata(neltwp+1)) ELSE neltwp=0 END IF c----------------------------------------------------------------------- c Conditionally filter the remaining data c----------------------------------------------------------------------- CALL arflt(nelta,Arimap,Arimal,Opr,Mdl(AR-1),Mdl(AR)-1, & Mata(neltwp+1),nelta) c----------------------------------------------------------------------- c Exact MA filter the data c----------------------------------------------------------------------- CALL exctma(Nc,Mata(neltwp+1),nelta,Nata-neltwp) c----------------------------------------------------------------------- c Multiply \vecwp-\matD'\hat\veca. Need LAPACK HERE c Need to check if this underflow is OK here. c----------------------------------------------------------------------- IF(Lar.and.Lma)THEN c CALL under0(T) ielt=0 DO i=1,Mxarlg DO j=1,Nc ielt=ielt+1 Mata(ielt)=Mata(ielt) & -ddot(nextma,Matd(i),Mxarlg,Mata(neltwp+j),Nc) END DO END DO c CALL under0(F) END IF c----------------------------------------------------------------------- c \chol(\condexpwp)\vecx=\vecwp-\matD'\hat\veca. Need LAPACK HERE c----------------------------------------------------------------------- IF(Lar)THEN CALL dsolve(Chlvwp,Mxarlg,Nc,F,Mata) nelta=nelta+neltwp END IF c----------------------------------------------------------------------- c Put the series length and the lags back on a row basis c----------------------------------------------------------------------- Na=nelta/Nc c ------------------------------------------------------------------ DO ilag=1,lastlg Arimal(ilag)=Arimal(ilag)/Nc END DO END IF c ------------------------------------------------------------------ 10 RETURN END armats.f0000664006604000003110000000325514521201410011622 0ustar sun00315stepsC Last change: SRD 31 Jan 100 8:37 am SUBROUTINE armats(Tval) IMPLICIT NONE c ------------------------------------------------------------------ c Generate t statistics for ARMA parameter estimates c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER itv,iflt,begopr,endopr,beglag,endlag,ilag,iopr DOUBLE PRECISION Tval DIMENSION Tval(*) c----------------------------------------------------------------------- c generate t-statistics for ARMA parameters c----------------------------------------------------------------------- IF(Armaer.eq.PACSER)THEN CALL writln('ERROR: The covariance matrix of the ARMA parameters &is singular;',STDERR,Mt2,T) CALL writln(' cannot compute t-statistics for the ARMA para &meters.',STDERR,Mt2,F) CALL abend() RETURN END IF itv=0 DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 DO ilag=beglag,endlag itv=itv+1 tval(itv)=Arimap(ilag)/sqrt(Var*Armacm(itv,itv)) END DO END DO END DO c----------------------------------------------------------------------- RETURN END arspc.f0000664006604000003110000000256614521201411011450 0ustar sun00315stepsC Last change: BCM 15 Jan 2008 12:40 pm SUBROUTINE arspc(Frq,Nfrq,Maxar,Bar,Var,Ldecbl,Sxx) IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION PI,ONE,ZERO,TEN PARAMETER(PI=3.14159265358979D0,ONE=1D0,ZERO=0D0,TEN=10D0) c----------------------------------------------------------------------- LOGICAL Ldecbl INTEGER Maxar,Nfrq,i,j DOUBLE PRECISION Frq,Bar,Var,Sxx,c2,s2,dj c----------------------------------------------------------------------- DIMENSION Bar(*),Frq(*),Sxx(*) c----------------------------------------------------------------------- DOUBLE PRECISION decibl EXTERNAL decibl c----------------------------------------------------------------------- DO i=1,Nfrq c2=ZERO DO j=1,Maxar dj=dble(2*j)*PI*Frq(i) c2=c2+(Bar(j)*cos(dj)) END DO s2=ZERO DO j=1,Maxar dj=dble(2*j)*PI*Frq(i) s2=s2+(Bar(j)*sin(dj)) END DO Sxx(i)=Var/((1-c2)*(1-c2) + s2*s2) c----------------------------------------------------------------------- IF(Ldecbl)THEN IF(Sxx(i).lt.ZERO)Sxx(i)=-Sxx(i) Sxx(i)=decibl(Sxx(i)) END IF c----------------------------------------------------------------------- END DO RETURN END autoer.f0000664006604000003110000000501414521201411011626 0ustar sun00315steps SUBROUTINE autoer(Info) IMPLICIT NONE c----------------------------------------------------------------------- c Check to see if ARIMA model estimation warnings are present. c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER info c----------------------------------------------------------------------- IF(info.eq.PINVER.or.info.eq.PGPGER.or.info.eq.PACFER.or. & info.eq.PVWPER)THEN CALL writln('Model estimation warnings encountered during '// & 'automatic model identification.',Mt1,Mt2,T) CALL writln('Program will cease execution; warning message '// & 'given below.',Mt1,Mt2,F) WRITE(STDERR,*)' Model estimation warnings encountered during ', & 'automatic model identification.' ELSE RETURN END IF c----------------------------------------------------------------------- IF(info.eq.PINVER)THEN CALL writln('ARMA roots inside the unit circle.',Mt1,Mt2,T) CALL abend() c ------------------------------------------------------------------ ELSE IF(info.eq.PGPGER)THEN CALL writln('Problem with MA parameter estimation. '//PRGNAM// & ' can''t',Mt1,Mt2,T) CALL writln(' invert the G''G matrix. Try a '// & 'simpler ARIMA model without',Mt1,Mt2,F) CALL writln(' parameter constraints. Please send '// & 'us the data and spec file',Mt1,Mt2,F) CALL writln(' that produced this message '// & '(x12@census.gov).',Mt1,Mt2,F) CALL abend() c ------------------------------------------------------------------ ELSE IF(info.eq.PACFER)THEN CALL writln('Problem calculating the theoretical ARMA '// & 'ACF.',Mt1,Mt2,T) CALL abend() c ------------------------------------------------------------------ ELSE IF(info.eq.PVWPER)THEN CALL writln('Problem calculating var(w_p|z)<.', & Mt1,Mt2,T) CALL abend() END IF c ------------------------------------------------------------------ RETURN END automd.f0000664006604000003110000012063014521201411011622 0ustar sun00315stepsc Last change:Mar. 2021- if there are fatal errors when calling c armats,return C previous change: BCM 18 Mar 2003 6:47 am SUBROUTINE automd(Trnsrs,Frstry,Nefobs,A,Na,Lsumm,Lidotl,Svldif, & Lsadj,Ltdlom,Fctok,Lhiddn,Lnoprt) IMPLICIT NONE c ------------------------------------------------------------------ c This subroutine performs an automatic ARIMA model selection. The c procedure is similar to that of Gomez and Maravall (1998) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'adj.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'title.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'mdlsvl.i' c ------------------------------------------------------------------ DOUBLE PRECISION BIGCV,TWOPT5,MALIM,ONE,ZERO,TWOPT8 LOGICAL T,F PARAMETER(T=.true.,F=.false.,BIGCV=1000001D0,TWOPT5=2.5D0, & MALIM=0.001D0,ONE=1D0,ZERO=0D0,TWOPT8=2.8D0) c ------------------------------------------------------------------ CHARACTER firstw*(11),mdl1st*(132) DOUBLE PRECISION A,Trnsrs,blpct0,blq0,rvr0,rtval0,fct2,blpct,blq, & tmpr,tmps,rvr,rtval,cvl0,cvlold,tair,a0,sumMA, & adj0,trns0 INTEGER lpr,lqr,lps,lqs,ldr,lds,lpr0,lqr0,lps0,lqs0,ldr0,lds0, & Frstry,Na,Nefobs,i,nbb,nauto0,nloop,icol,isig,nnsig,igo, & nround,imu,irt,ist,kstep,itmp,na0,tdauto,disp,nfirst, & Lsumm,bldf0,bldf,kmu,aici0,aicit0,fhnote,igrp,cnote,n1mdl * INTEGER iticks LOGICAL argok,Lidotl,Fctok,inptok,Svldif,lmu,Lsadj,pcktd0, & linv,ismd0,lmu0,lidold,redomd,lester,Ltdlom,Lhiddn,Lnoprt DIMENSION A(PLEN+2*PORDER),Trnsrs(PLEN),tair(2),cvl0(POTLR), & cvlold(POTLR),a0(PLEN+2*PORDER),adj0(PLEN),trns0(PLEN) c ------------------------------------------------------------------ DOUBLE PRECISION dpmpar INTEGER strinx LOGICAL dpeq EXTERNAL dpeq,dpmpar,strinx c ------------------------------------------------------------------ c print header for output c ------------------------------------------------------------------ IF(Prttab(LAUHDR))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(Lwdprt)THEN WRITE(Mt1,1001) 1001 FORMAT(50x,'Automatic ARIMA Model Selection',//, & 30x,'Procedure based closely on TRAMO method of Gomez', & ' and Maravall (2000)',/, & 39x,'"Automatic Modeling Methods for Univariate Series",',/, & 30x,'A Course in Time Series (Edited by D. Pena, G. C. ', & 'Tiao, R. S. Tsay),',/, & 50x,'New York : J. Wiley and Sons',//) ELSE WRITE(Mt1,1002) 1002 FORMAT(24x,'Automatic ARIMA Model Selection',//, & 20x,'Procedure based closely on TRAMO method ',/, & 25x,'of Gomez and Maravall (2000)',/, & 14x,'"Automatic Modeling Methods for Univariate Series",',/, & 28x,'A Course in Time Series',/, & 18x,'(Edited by D. Pena, G. C. Tiao, R. S. Tsay),',/, & 25x,'New York : J. Wiley and Sons',//) END IF WRITE(Mt1,1003)'regular ARMA parameters',Maxord(1) IF(Sp.gt.1)WRITE(Mt1,1003)'seasonal ARMA parameters',Maxord(2) IF(Lautod)THEN WRITE(Mt1,1003)'regular differencing',Diffam(1) IF(Sp.gt.1)WRITE(Mt1,1003)'seasonal differencing',Diffam(2) ELSE WRITE(Mt1,1004)'Regular differencing',Diffam(1) IF(Sp.gt.1)WRITE(Mt1,1004)'Seasonal differencing',Diffam(2) END IF IF(Laccdf)WRITE(Mt1,1005) 1003 FORMAT(' Maximum order for ',a,' : ',i3) 1004 FORMAT(' ',a,' set to ',i3) 1005 FORMAT(5x,'Default model will be accepted if residuals pass ', & 'Ljung-Box test') END IF c ------------------------------------------------------------------ c If diagnostic output saved, save automatic modeling settings to c .udg file (BCM July 2008) c ------------------------------------------------------------------ IF(Lsumm.gt.0)THEN WRITE(Nform,1100)'maxorder: ',(Maxord(i),i=1,2) IF(Lautod)THEN firstw='maxdiff: ' nfirst=9 ELSE firstw='diff: ' nfirst=6 END IF IF(Sp.gt.1)THEN WRITE(Nform,1100)firstw(1:nfirst),(Diffam(i),i=1,2) ELSE WRITE(Nform,1100)firstw(1:nfirst),Diffam(1),0 END IF IF(Laccdf)THEN WRITE(Nform,1050)'acceptdefault: ','yes' ELSE WRITE(Nform,1050)'acceptdefault: ','no' END IF IF(Lchkmu)THEN WRITE(Nform,1050)'checkmu: ','yes' ELSE WRITE(Nform,1050)'checkmu: ','no' END IF IF(Lbalmd)THEN WRITE(Nform,1050)'balanced: ','yes' ELSE WRITE(Nform,1050)'balanced: ','no' END IF IF(Lmixmd)THEN WRITE(Nform,1050)'mixed: ','yes' ELSE WRITE(Nform,1050)'mixed: ','no' END IF IF(Exdiff.eq.0)THEN WRITE(Nform,1050)'exactdiff: ','no' ELSE IF(Exdiff.eq.1)THEN WRITE(Nform,1050)'exactdiff: ','yes' ELSE IF(Exdiff.eq.2)THEN WRITE(Nform,1050)'exactdiff: ','first' END IF END IF c ------------------------------------------------------------------ c check to see if user requests that the outlier tables be saved; c if so, print out warning message. c ------------------------------------------------------------------ fhnote=STDERR IF(Lquiet)fhnote=0 IF(Savtab(LOTLFT).or.Savtab(LOTLIT))THEN CALL writln('NOTE: Tables associated with the outlier spec cannot & be saved during',fhnote,Mt2,T) CALL writln(' automatic model selection.',fhnote,Mt2,F) END IF c ------------------------------------------------------------------ c set initial "default" model to airline model c ------------------------------------------------------------------ nbb=0 itmp=0 nloop=0 nround=1 firstw=' Checking ' nfirst=9 igo=0 CALL setdp(DNOTST,POTLR,cvlold) lidold=Lidotl IF(Lidotl)THEN IF(Ltstao)cvlold(AO)=Critvl(AO) IF(Ltstls)cvlold(LS)=Critvl(LS) IF(Ltsttc)cvlold(TC)=Critvl(TC) * IF(Ltstso)cvlold(SO)=Critvl(SO) Lotmod=F ELSE IF(Lotmod)THEN Ltstao=T Lidotl=T Critvl(AO)=BIGCV DO i=LAUOTH,LAUOTT Prttab(i)=F Savtab(i)=F END DO END IF fct2=1D0 IF(Lsadj)fct2=Fct lmu=F imu=0 kstep=0 IF(Nb.gt.0)THEN imu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(imu.gt.0)lmu=T END IF inptok=T CALL mdlint() lpr=0 lqr=0 lps=0 lqs=0 lpr0=0 ldr0=1 lqr0=1 lps0=0 lds0=1 lqs0=1 IF(Lseff.or.Sp.eq.1)THEN lds0=0 lqs0=0 END IF * 1 CALL mdlset(lpr0,ldr0,lqr0,lps0,lds0,lqs0,inptok) CALL mdlset(lpr0,ldr0,lqr0,lps0,lds0,lqs0,inptok) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN CALL ssprep(T,F,F) c ------------------------------------------------------------------ c Perform AIC tests on default model c ------------------------------------------------------------------ argok=T lester=F IF(Itdtst.gt.0)THEN CALL tdaic(Trnsrs,A,Nefobs,Na,Frstry,lester,tdauto,Ltdlom,F,F,F, & F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.Lomtst.gt.0)THEN CALL lomaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.Leastr)THEN CALL easaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.(Luser.and.Ncusrx.gt.0))THEN CALL usraic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(Ncusrx.eq.0.and.Ch2tst)Ch2tst=F END IF IF(.not.lester.and.(Ch2tst.and.Nguhl.gt.0))THEN CALL chkchi(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F) IF(Lfatal)RETURN END IF IF(lester)THEN CALL writln('ERROR: A model estimation error has occurred during &AIC testing within',STDERR,Mt2,T) CALL writln(' the automatic model identification procedure. & The error message',STDERR,Mt2,F) CALL writln(' appears below.',STDERR,Mt2,F) CALL prterr(nefobs,F) IF((.not.Lfatal).and.(.not.Convrg))CALL abend() IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c Check for constant term in regressors with the default model if c user has not specified a mean term in the model. c----------------------------------------------------------------------- IF(Lchkmu)THEN CALL chkmu(Trnsrs,A,Nefobs,Na,Frstry,kstep,Prttab(LAUDFT)) IF(Lfatal)RETURN kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(kmu.gt.0)THEN lmu=T ELSE lmu=F END IF END IF CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c If outlier identification specified, do it here for default model c----------------------------------------------------------------------- c IF(.not.lester.and.Lidotl)THEN IF(Lidotl)THEN c----------------------------------------------------------------------- IF(Prttab(LAUOTH))THEN * CALL prothd(Begtst,Endtst,Ltstao,Ltstls,Ltsttc,Ltstso,Ladd1, * & Critvl) CALL prothd(Begtst,Endtst,Ltstao,Ltstls,Ltsttc,Ladd1,Critvl) IF(Lfatal)RETURN END IF IF(Prttab(LAUOTI))THEN CALL prtmdl(Lestim,Prttab(LESTES),Lcalcm,F,F,F, & Prttab(LESTCM),F,Prttab(LESTES),itmp, & Prttab(LESTES),F,Prttab(LESTIT)) END IF c----------------------------------------------------------------------- c Call routine that invokes automatic outlier identification, c prints out error messages and regenerates the regression c matrix (BCM April 2007) c----------------------------------------------------------------------- CALL amidot(A,Trnsrs,Frstry,Nefobs,Priadj,Convrg,Fctok,argok) IF(Lfatal)RETURN nauto0=Natotl IF(Ltstao)cvl0(AO)=Critvl(AO) IF(Ltstls)cvl0(LS)=Critvl(LS) IF(Ltsttc)cvl0(TC)=Critvl(TC) * IF(Ltstso)cvl0(SO)=Critvl(SO) c----------------------------------------------------------------------- c Recheck trading day and easter regressors after outlier c identification c----------------------------------------------------------------------- isig=0 CALL pass0(trnsrs,Frstry,isig,0,Prttab(LAUDFT)) IF(Lfatal)RETURN kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(kmu.gt.0)THEN lmu=T ELSE lmu=F END IF END IF c ------------------------------------------------------------------ c produce residual diagnostics for default model c ------------------------------------------------------------------ CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(.not.Lfatal) & CALL mdlchk(a,na,Nefobs,Blpct0,Blq0,Bldf0,Rvr0,Rtval0) IF(Lfatal)RETURN c----------------------------------------------------------------------- c generate t-statistics for airline model, if no c----------------------------------------------------------------------- IF(.not.Lidotl)CALL armats(tair) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If default model accepted, leave routine c----------------------------------------------------------------------- IF(Laccdf.and.Blpct0.lt.Pcr)THEN CALL mkmdsn(lpr0,ldr0,lqr0,lps0,lds0,lqs0,Bstdsn,Nbstds) IF(Lfatal)RETURN lpr=lpr0 ldr=ldr0 lqr=lqr0 lps=lps0 lds=lds0 lqs=lqs0 GO TO 70 END IF c----------------------------------------------------------------------- c save values for default model, update values for upcoming runs c----------------------------------------------------------------------- lmu0=lmu c nr0=nround nround=1 nloop=nloop+1 kstep=1 na0=Na CALL copy(A,Na,1,a0) aici0=Aicind aicit0=Aicint CALL copy(Adj,PLEN,1,adj0) CALL copy(Trnsrs,PLEN,1,trns0) pcktd0=Picktd c----------------------------------------------------------------------- c Remove regressors from series before automatic modeling is c performed c ------------------------------------------------------------------ 10 CALL ssprep(T,F,F) CALL bkdfmd(T) IF(nloop.gt.1.and.Natotl.eq.0)GO TO 40 IF(Nb.gt.0)THEN nbb=Nb CALL rmfix(trnsrs,Nbcst,Nrxy,2) IF(.not.Lfatal) & CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ ldr=Diffam(1) lds=Diffam(2) IF(Lautod)THEN CALL iddiff(ldr,lds,Trnsrs,Nefobs,Frstry,A,Na,imu,lmu,Svldif, & Lsumm) IF(Lfatal)RETURN ELSE CALL mdlint() CALL mdlset(0,ldr,0,0,lds,0,inptok) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Identify orders of ARIMA model c----------------------------------------------------------------------- ismd0=F 50 IF(nloop.eq.1.or.lidold)THEN IF(nloop.gt.1.and.Nb.gt.0)THEN nbb=Nb CALL rmfix(trnsrs,Nbcst,Nrxy,2) IF(.not.Lfatal) & CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- * IF(Lsumm.gt.0)THEN * CALL timer(iticks) * WRITE(Nform,9000) 'bamdid',nloop,':',iticks * 9000 FORMAT(a,i1,a,i10) * END IF c----------------------------------------------------------------------- CALL amdid(lpr,ldr,lqr,lps,lds,lqs,trnsrs,Frstry,Nefobs,A,Na,Lmu, & Lsumm,argok) c----------------------------------------------------------------------- * IF((.not.Lfatal).and.Lsumm.gt.0)THEN * CALL timer(iticks) * WRITE(Nform,9000) 'aamdid',nloop,':',iticks * END IF c----------------------------------------------------------------------- IF(Lfatal)RETURN c----------------------------------------------------------------------- c check to see if identified model is equivalent to default model c add check for mean term (BCM May 2004) c----------------------------------------------------------------------- ismd0=((Sp.gt.1.and. & (lpr.eq.lpr0.and.ldr.eq.ldr0.and.lqr.eq.lqr0.and. & lps.eq.lps0.and.lds.eq.lds0.and.lqs.eq.lqs0)).or. & (Sp.eq.1.and. & (lpr.eq.lpr0.and.ldr.eq.ldr0.and.lqr.eq.lqr0))).and. & (lmu.eqv.lmu0) c & .and.Lidotl.and.nloop.eq.1) END IF c----------------------------------------------------------------------- c put regressors back in regression matrix c----------------------------------------------------------------------- lester=F IF(nbb.gt.0)THEN CALL addfix(trnsrs,Nbcst,0,2) IF(Lfatal)RETURN IF(.not.Lmu)THEN igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Constant') IF (igrp.gt.0) THEN icol=Grp(igrp-1) CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN END IF END IF IF(Nb.gt.0)lester=T IF(nloop.eq.1)THEN nbb=0 IF(ismd0)THEN CALL restor(T,F,F) CALL copy(a0,Na,1,A) CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN GO TO 30 END IF END IF c IF((.not.(imu.eq.0.and.lmu)).and.(ismd0.and.nloop.eq.1))THEN c----------------------------------------------------------------------- c Remove automatic outliers from model c----------------------------------------------------------------------- IF(nauto0.gt.0.and.igo.eq.0)CALL clrotl(Nrxy) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF IF(imu.eq.0.and.lmu)THEN icol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(icol.eq.0)THEN CALL adrgef(DNOTST,'Constant','Constant',PRGTCN,F,F) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN lester=T END IF END IF IF(lester)THEN CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,argok) IF(Lfatal)RETURN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(ismd0.and.nloop.eq.1)THEN CALL copy(a0,Na,1,A) GO TO 30 END IF c ------------------------------------------------------------------ c Perform AIC tests on recently identified model c ------------------------------------------------------------------ argok=T lester=F CALL ssprep(T,F,F) IF(Itdtst.gt.0)THEN CALL tdaic(Trnsrs,A,Nefobs,Na,Frstry,lester,tdauto,Ltdlom,F,F,F, & F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.Lomtst.gt.0)THEN CALL lomaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.Leastr)THEN CALL easaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.(Luser.and.Ncusrx.gt.0))THEN CALL usraic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(Ncusrx.eq.0.and.Ch2tst)Ch2tst=F END IF IF(.not.lester.and.(Ch2tst.and.Nguhl.gt.0))THEN CALL chkchi(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F) IF(Lfatal)RETURN END IF IF(lester)THEN CALL writln('ERROR: A model estimation error has occurred during &AIC testing within',STDERR,Mt2,T) CALL writln(' the automatic model identification procedure. & The error message',STDERR,Mt2,F) CALL writln(' appears below.',STDERR,Mt2,F) CALL prterr(nefobs,F) IF((.not.Lfatal).and.(.not.Convrg))CALL abend() IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Redo automatic outlier identification on set of regressors without c automatic outliers identified earlier. c----------------------------------------------------------------------- 40 IF(Lidotl)THEN c IF(Nb.gt.0)THEN c CALL rgarma(Lestim,Mxiter,Mxnlit,F,A,Na,nefobs,argok) c IF(.not.Lfatal)CALL prterr(nefobs,T) c END IF c----------------------------------------------------------------------- IF(Prttab(LAUOTH))THEN * CALL prothd(Begtst,Endtst,Ltstao,Ltstls,Ltsttc,Ltstso,Ladd1, * & Critvl) CALL prothd(Begtst,Endtst,Ltstao,Ltstls,Ltsttc,Ladd1,Critvl) IF(Lfatal)RETURN END IF IF(Prttab(LAUOTI))THEN CALL prtmdl(Lestim,Prttab(LESTES),Lcalcm,F,F,F, & Prttab(LESTCM),F,Prttab(LESTES),itmp, & Prttab(LESTES),F,Prttab(LESTIT)) END IF c----------------------------------------------------------------------- c Call routine that invokes automatic outlier identification, c prints out error messages and regenerates the regression c matrix (BCM April 2007) c----------------------------------------------------------------------- CALL amidot(A,Trnsrs,Frstry,Nefobs,Priadj,Convrg,Fctok,argok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check to see if automatic model passes tests c----------------------------------------------------------------------- ELSE IF(.not.ismd0)THEN CALL tstmd1(Trnsrs,Frstry,A,Na,Nefobs,Blpct0,Rvr0,Rtval0,lpr,lps, & lqr,lqs,ldr,lds,Lmu,Prttab(LAUMCH),aici0,pcktd0,adj0, & trns0,tair) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Redo tests for trading day, Easter, other regressors c (if not airline model) c----------------------------------------------------------------------- IF(Itdtst.gt.0.or.Leastr.or.(Luser.and.Ncusrx.gt.0).or.imu.eq.0) & THEN argok=T lester=F IF(Itdtst.gt.0)THEN CALL tdaic(Trnsrs,A,Nefobs,Na,Frstry,lester,tdauto,Ltdlom,F,F, & F,F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.Lomtst.gt.0)THEN CALL lomaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.Leastr)THEN CALL easaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN END IF IF((.not.lester).and.(Luser.and.Ncusrx.gt.0))THEN CALL usraic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(Ncusrx.eq.0.and.Ch2tst)Ch2tst=F END IF IF((.not.lester).and.(Ch2tst.and.Nguhl.gt.0))THEN CALL chkchi(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F) IF(Lfatal)RETURN END IF IF(lester)THEN CALL writln('ERROR: A model estimation error has occurred durin &g AIC testing within',STDERR,Mt2,T) CALL writln(' the automatic model identification procedur &e. The error message',STDERR,Mt2,F) CALL writln(' appears below.',STDERR,Mt2,F) CALL prterr(nefobs,F) IF((.not.Lfatal).and.(.not.Convrg))CALL abend() IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c Check for constant term in regressors with the default model if c user has not specified a mean term in the model. c----------------------------------------------------------------------- IF(Lchkmu)THEN CALL chkmu(Trnsrs,A,Nefobs,Na,Frstry,kstep,Prttab(LAUFNT)) IF(Lfatal)RETURN kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(kmu.gt.0)THEN lmu=T ELSE lmu=F END IF END IF CALL rgarma(Lestim,Mxiter,Mxnlit,F,A,Na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Compare model to default (airline) model and change model c if necessary. c----------------------------------------------------------------------- 30 CALL mdlchk(a,na,Nefobs,blpct,blq,bldf,rvr,rtval) IF(Lfatal)RETURN c----------------------------------------------------------------------- c save first model in .udg file, if appropriate (June 2008) c----------------------------------------------------------------------- IF(Lsumm.gt.0.and.nloop.eq.1)THEN CALL mkmdsn(lpr,ldr,lqr,lps,lds,lqs,mdl1st,n1mdl) WRITE(Nform,1050)'automdl.first: ',mdl1st(1:n1mdl) END IF c----------------------------------------------------------------------- IF(Lidotl.and.nloop.le.2)THEN CALL pass2(Trnsrs,Frstry,lpr,ldr,lqr,lps,lds,lqs,lpr0,ldr0,lqr0, & lps0,lds0,lqs0,Natotl,nauto0,blpct,blpct0,bldf,bldf0, & rvr,rvr0,lmu,lmu0,A,a0,Na,na0,aici0,pcktd0,aicit0, & adj0,trns0,fct2,Prttab(LAUMCH),Prttab(LAUFLB),ismd0, & cvl0,nefobs,nloop,nround,igo) IF(Lfatal)RETURN IF(igo.eq.1) GO TO 10 IF(igo.eq.2) GO TO 40 IF(igo.eq.3) GO TO 50 END IF IF(nloop.gt.0)THEN isig=0 CALL pass0(trnsrs,Frstry,isig,1,Prttab(LAUFNT)) IF(Lfatal)RETURN IF(isig.gt.0)THEN CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) IF(Prttab(LAUFNT))WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN IF(nloop.lt.3)nloop=3 c GO TO 60 kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(kmu.gt.0)THEN lmu=T ELSE lmu=F END IF END IF END IF c----------------------------------------------------------------------- c Put final checks of model here, as found in TRAMO/SEATS - c Initialize variable to re-estimate model and set up "TRAMO" c integer variables for model. { BCM June 2001 } c----------------------------------------------------------------------- c Print out header for final checks ( BCM July 2007 ) c----------------------------------------------------------------------- IF(Prttab(LAUFNT))WRITE(Mt1,1140) redomd=F c----------------------------------------------------------------------- c Put routine here to check for unit roots. c----------------------------------------------------------------------- IF(Prttab(LAUFNT))write(Mt1,1011)' Checking for Unit Roots.' linv=T CALL chkrt1(irt,ist,tmpr,tmps,linv,Ubfin) c----------------------------------------------------------------------- c If unit roots found, decrease appropriate AR orders by 1, c increase appropriate differencing order by 1, and re-estimate model c----------------------------------------------------------------------- IF (irt.gt.0.or.ist.gt.0) then IF(irt.gt.0.and.ldr.le.2)THEN lpr=lpr-1 ldr=ldr+1 redomd=T IF(Prttab(LAUFNT))THEN write(Mt1,1070)'Regular','root' WRITE(Mt1,1020) lpr,ldr,lqr,lps,lds,lqs ENDIF end if IF(ist.gt.0.and.lds.le.1.and.(.not.Lseff))THEN lps=lps-1 lds=lds+1 redomd=T IF(Prttab(LAUFNT))THEN write(Mt1,1070)'Seasonal','root' WRITE(Mt1,1020) lpr,ldr,lqr,lps,lds,lqs end if end if ELSE IF(Prttab(LAUFNT))WRITE(MT1,1070)'No','roots' END IF IF(Svltab(LSLFUR))THEN IF(irt.eq.0.and.ist.eq.0)THEN WRITE(Ng,1080)'none' ELSE IF(irt.gt.0.and.ist.eq.0)THEN WRITE(Ng,1080)'nonseasonal' ELSE IF(irt.eq.0.and.ist.gt.0)THEN WRITE(Ng,1080)'seasonal' ELSE WRITE(Ng,1080)'nonseasonal seasonal' END IF END IF IF(Lsumm.gt.0)THEN IF(irt.eq.0.and.ist.eq.0)THEN WRITE(Nform,1050)'finalur: ','none' ELSE IF(irt.gt.0.and.ist.eq.0)THEN WRITE(Nform,1050)'finalur: ','nonseasonal' ELSE IF(irt.eq.0.and.ist.gt.0)THEN WRITE(Nform,1050)'finalur: ','seasonal' ELSE WRITE(Nform,1050)'finalur: ','nonseasonal seasonal' END IF END IF c----------------------------------------------------------------------- c if model changes, re-estimate model. c----------------------------------------------------------------------- IF(redomd)then CALL mdlint() CALL mdlset(lpr,ldr,lqr,lps,lds,lqs,inptok) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN c----------------------------------------------------------------------- c if model changes, recheck significance of constant term c (BCM, April 2007) c----------------------------------------------------------------------- kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(kmu.gt.0) & CALL chkmu(Trnsrs,A,Nefobs,Na,Frstry,kstep,Prttab(LAUFNT)) c----------------------------------------------------------------------- c If automatic outliers are identified for the model, eliminate the c outliers from the model (BCM April 2007) c----------------------------------------------------------------------- IF(Natotl.gt.0)THEN CALL clrotl(Nrxy) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) IF(Prttab(LAUFNT))WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Redo automatic outlier identification (BCM April 2007) c----------------------------------------------------------------------- IF(Lidotl.and.(.not.Lotmod))THEN CALL amidot(A,Trnsrs,Frstry,Nefobs,Priadj,Convrg,Fctok,Argok) IF(Lfatal)RETURN END IF CALL mdlchk(a,na,Nefobs,blpct,blq,bldf,rvr,rtval) IF(.not.Lfatal)CALL mkmdsn(lpr,ldr,lqr,lps,lds,lqs,Bstdsn,Nbstds) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If model has nonseasonal diffencing and MA, check for c overdifferencing by seeing if sum of MA parameters is close to 1. c----------------------------------------------------------------------- redoMd=F CALL tstodf(Trnsrs,Frstry,Nefobs,A,Na,Lsumm,lpr,ldr,lqr, & lps,lds,lqs,Kstep,Lidotl,Lnoprt,FctOK,redoMd,argok) IF(Lfatal)RETURN IF(redoMd)THEN CALL mdlchk(a,na,Nefobs,blpct,blq,bldf,rvr,rtval) IF(.not.Lfatal) & CALL mkmdsn(lpr,ldr,lqr,lps,lds,lqs,Bstdsn,Nbstds) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c if mean term not selected, see if t-statistic for residual mean c is significant. If so, add constant to model c----------------------------------------------------------------------- IF((.not.lmu).and.Lautod.and.rtval.gt.TWOPT5)THEN IF(Prttab(LAUFNT))write(Mt1,1010) & ' T-statistic for residual mean > 2.5;' IF(Lchkmu)THEN IF(Prttab(LAUFNT))write(Mt1,1011)' Checking for Constant term.' CALL adrgef(DNOTST,'Constant','Constant',PRGTCN,F,F) IF(Lfatal)RETURN CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal) & CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) IF(Prttab(LAUFNT))WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN IF(Prttab(LAUFNT)) & WRITE(Mt1,1010)' constant term added to identified model.' ELSE IF(Prttab(LAUFNT))THEN WRITE(Mt1,1010)' constant term not added to identified model' WRITE(Mt1,1010)' since checkmu=no in input specification file.' END IF END IF c----------------------------------------------------------------------- c CODE MOVED - CHANGE IN LATEST VERSION OF TRAMO - BCM JUNE 2001 c Check to see if insignificant ARMA coefficients can be eliminated c----------------------------------------------------------------------- 60 nnsig=0 IF(Prttab(LAUFNT))write(Mt1,1011) firstw(1:nfirst)// & ' for insignificant ARMA coefficients.' CALL tstmd2(nnsig,Nspobs,lpr,lqr,lps,lqs) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If more than one coefficient is eliminated and outlier c identification is performed, reduce outlier c critical value and redo automatic model identification c----------------------------------------------------------------------- IF(nnsig.gt.1.and.lidold.and.nloop.le.2)THEN IF((Ltstao.and.Critvl(AO).gt.TWOPT8).or. & (Ltstls.and.Critvl(LS).gt.TWOPT8).or. * & (Ltsttc.and.Critvl(TC).gt.TWOPT8).or. * & (Ltstso.and.Critvl(SO).gt.TWOPT8))THEN & (Ltsttc.and.Critvl(TC).gt.TWOPT8))THEN IF(Ltstao)THEN cvlold(AO)=Critvl(AO) Critvl(AO)=DMAX1(TWOPT8,Critvl(AO)-Critvl(AO)*Predcv) IF ((.not.dpeq(cvlold(AO),Critvl(AO))).and.Prttab(LAUFNT)) & WRITE(Mt1,1030)'Critical Value for AO outlier CHANGED TO:', & Critvl(AO) END IF IF(Ltstls)THEN cvlold(LS)=Critvl(LS) Critvl(LS)=DMAX1(TWOPT8,Critvl(LS)-Critvl(LS)*Predcv) IF ((.not.dpeq(cvlold(LS),Critvl(LS))).and.Prttab(LAUFNT)) & WRITE(Mt1,1030)'Critical Value for LS outlier CHANGED TO:', & Critvl(LS) END IF IF(Ltsttc)THEN cvlold(TC)=Critvl(TC) Critvl(TC)=DMAX1(TWOPT8,Critvl(TC)-Critvl(TC)*Predcv) IF ((.not.dpeq(cvlold(TC),Critvl(TC))).and.Prttab(LAUFNT)) & WRITE(Mt1,1030)'Critical Value for TC outlier CHANGED TO:', & Critvl(TC) END IF * IF(Ltstso)THEN * cvlold(SO)=Critvl(SO) * Critvl(SO)=DMAX1(TWOPT8,Critvl(SO)-Critvl(SO)*Predcv) * IF ((.not.dpeq(cvlold(SO),Critvl(SO))).and.Prttab(LAUFNT)) * & WRITE(Mt1,1030)'Critical Value for SO outlier CHANGED TO:', * & Critvl(SO) * END IF CALL rgarma(Lestim,Mxiter,Mxnlit,F,A,Na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) IF(Prttab(LAUFNT))WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal.or.(.not.argok))RETURN nround=nround+1 nloop=nloop+1 IF(Prttab(LAUFNT))WRITE(Mt1,1130) IF(Natotl.eq.0)THEN IF(Prttab(LAUMCH))THEN WRITE(Mt1,1010) & ' Since no outlier were found, model will be changed to' WRITE(Mt1,1020) lpr,ldr,lqr,lps,lds,lqs WRITE(Mt1,1010) & ' and automatic outlier identification will be redone.' END IF CALL mkmdsn(lpr,ldr,lqr,lps,lds,lqs,Bstdsn,Nbstds) IF(Lfatal)RETURN ELSE IF(Prttab(LAUMCH))THEN WRITE(Mt1,1010) & ' Identification of model and/or differencing order '// & 'will be redone.' END IF END IF GO TO 10 END IF END IF c----------------------------------------------------------------------- c If there are insignificant ARMA parameters, estimate reduced c model and check for more insignificant parameters. c----------------------------------------------------------------------- IF(nnsig.gt.0)THEN CALL rgarma(Lestim,Mxiter,Mxnlit,F,A,Na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) IF(Prttab(LAUFNT))WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal.or.(.not.argok))RETURN IF(Prttab(LAUMCH))THEN WRITE(Mt1,1010) & ' Due to insignificant ARMA coefficients, model changed to' WRITE(Mt1,1020) lpr,ldr,lqr,lps,lds,lqs END IF CALL mkmdsn(lpr,ldr,lqr,lps,lds,lqs,Bstdsn,Nbstds) IF(Lfatal)RETURN IF(nfirst.eq.6)THEN firstw=' Rechecking' nfirst=11 END IF GO TO 60 END IF c----------------------------------------------------------------------- 70 CALL autoer(Armaer) IF(Lfatal)RETURN IF(Prttab(LAUMCH))WRITE(Mt1,1040)Bstdsn(1:Nbstds) IF(Svltab(LSLMU).or.Lsumm.gt.0)THEN IF(Svltab(LSLMU))WRITE(Ng,1010)' ' IF(.not.Lchkmu)THEN IF(Svltab(LSLMU)) & WRITE(Ng,1050)'automean: ','no testing performed' IF(Lsumm.gt.0)WRITE(Nform,1050)'automean: ','nocheck' ELSE IF(imu.gt.0)THEN IF(Svltab(LSLMU)) & WRITE(Ng,1050)'automean: ','constant specified in model' IF(Lsumm.gt.0)WRITE(Nform,1050)'automean: ','userspecified' ELSE IF(lmu)THEN IF(Svltab(LSLMU))WRITE(Ng,1060)'automean: is' IF(Lsumm.gt.0)WRITE(Nform,1050)'automean: ','yes' ELSE IF(Svltab(LSLMU))WRITE(Ng,1060)'automean: not' IF(Lsumm.gt.0)WRITE(Nform,1050)'automean: ','no' END IF END IF IF(Lautod.and.Lsumm.gt.0)THEN WRITE(Nform,1110)'idnonseasonaldiff: ',ldr WRITE(Nform,1110)'idseasonaldiff: ',lds END IF IF(Lotmod.and.(.not.lidold))THEN Ltstao=F Lidotl=F Critvl(AO)=DNOTST END IF IF(Prttab(LAUMCH))write(Mt1,1010) & ' End of automatic model selection procedure.' c----------------------------------------------------------------------- 1010 FORMAT(' ',a) 1011 FORMAT(/,' ',a) 1020 FORMAT(' ',2(' (',i2,',',i2,',',i2,')')) 1030 FORMAT(/,A,1X,F12.3/) 1040 FORMAT(/,' Final automatic model choice : ',a) 1050 FORMAT(a,a) 1060 FORMAT(/,a,' significant.') 1070 format(3x,a,' unit ',a,' found.') 1080 FORMAT(' Unit roots in final model : ',a) 1090 FORMAT(/,' ERROR: Estimation failed to converge during the ', & 'automatic model', & /,' identification procedure.') 1100 FORMAT(a,2i5) 1110 FORMAT(a,i5) 1120 FORMAT(3x,'Nonseasonal MA not within ',f6.3, & ' of 1.0 - model passes test.') 1130 format(/,3x,'More than one ARMA coefficient was found to be ', & 'insignificant.') 1140 FORMAT(//,' Final Checks for Identified Model',/) 1150 FORMAT(a,f12.6) c----------------------------------------------------------------------- RETURN END automx.f0000664006604000003110000012250514521201411011651 0ustar sun00315stepsC Last change: BCM 3 Mar 1999 8:33 am SUBROUTINE automx(Trnsrs,Frstry,Nefobs,A,Na,Hvmdl,Hvstar,Lsadj, & Lidotl,Ltdlom,Fctok,Lhiddn,Lsumm) IMPLICIT NONE c ------------------------------------------------------------------ c This subroutine performs an automatic model selection from c model stored in the file x12a.mdl. The procedure is the same as c in X-11-ARIMA/88 c ------------------------------------------------------------------ LOGICAL T,F INTEGER MULT,DIV PARAMETER(MULT=3,DIV=4,T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'title.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'prittl.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'adj.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'usrreg.cmn' c ------------------------------------------------------------------ INTEGER PR PARAMETER(PR=PLEN/4) INCLUDE 'autoq.cmn' c INTEGER PXY c PARAMETER(PXY=PLEN*(PB+1)) c ------------------------------------------------------------------ CHARACTER tmpttl*(PCOLCR),cttl1*(PCOLCR*PB),gttl1*(PGRPCR*PGRP) DOUBLE PRECISION A,a2,b1,Trnsrs,mape,seacf,smpac,blchi,qchi,sma, & rma,loclim,tsrs INTEGER Frstry,i,Na,Nefobs,begopr,endopr,beglag,endlag,iopr,ilag, & ntmpcr,nummdl,numbst,nerr,padj2,ngr1,ngrt1,ncxy1,nb1,nct1, & clptr1,g1,gptr1,rgv1,tdauto,Hvstar,nf2,ncttl,ngttl,np, & dgfchi,fhnote,Lsumm LOGICAL argok,bstptd,Hvmdl,inptok,estbst,ovrdff,ovrsdf,mdskip, & tstmdl,Lidotl,id,pktd,Fctok,lester,gsovdf,begrgm,sviter, & Lsadj,anymdl,havfil,Lhiddn,Ltdlom DIMENSION A(PLEN+2*PORDER),a2(PLEN),b1(PB),begrgm(PLEN), & clptr1(0:PB),g1(0:PGRP),gptr1(0:PGRP),mape(4),rgv1(PB), & seacf(PR),smpac(PR),Trnsrs(PLEN),tsrs(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq INTEGER nblank EXTERNAL dpeq,nblank c ------------------------------------------------------------------ c check to see if user requests that the outlier tables be saved; c if so, print out warning message. c ------------------------------------------------------------------ fhnote=STDERR IF(Lquiet)fhnote=0 IF(Savtab(LOTLFT).or.Savtab(LOTLIT))THEN CALL writln('NOTE: Tables associated with the outlier spec cannot & be saved during',fhnote,Mt2,T) CALL writln(' automatic model selection.',fhnote,Mt2,F) END IF c ------------------------------------------------------------------ c Initialize input of automatic model selection procedure. c ------------------------------------------------------------------ sviter=F gsovdf=F loclim=Fctlim nerr=0 havfil=.not.(Autofl(1:1).eq.CNOTST) inptok=T IF(havfil)THEN CALL mdlinp(Autofl(1:nblank(Autofl)),inptok) IF(Lfatal)RETURN IF(.not.inptok)THEN CALL writln('ERROR: Must have user supplied models stored in '// & Autofl(1:nblank(Autofl))//'.',STDERR,Mt2,T) CALL abend RETURN END IF END IF c ------------------------------------------------------------------ c Set up temporary variables for transformed series, adjustment c factors for automatic trading day selection. c ------------------------------------------------------------------ pktd=Picktd padj2=Priadj CALL copy(Trnsrs,PLEN,1,tsrs) CALL copy(Adj,PLEN,1,a2) c----------------------------------------------------------------------- c Print automatic modelling heading c----------------------------------------------------------------------- IF(Prttab(LAXHDR))THEN IF(Lcmpaq)THEN WRITE(Mt1,1010) IF(Pck1st)THEN WRITE(Mt1,1020) ELSE WRITE(Mt1,1030) END IF ELSE WRITE(Mt1,1011) IF(Pck1st)THEN WRITE(Mt1,1021) ELSE WRITE(Mt1,1031) END IF END IF END IF c ------------------------------------------------------------------ c If diagnostic output saved, save automatic modeling settings to c .udg file (BCM July 2008) c ------------------------------------------------------------------ IF(Lsumm.gt.0)THEN IF(Pck1st)THEN WRITE(Nform,1140)'pickfirst','yes' ELSE WRITE(Nform,1140)'pickfirst','no' END IF IF(Id1st)THEN WRITE(Nform,1140)'idfirst','yes' ELSE WRITE(Nform,1140)'idfirst','no' END IF IF(havfil)THEN WRITE(Nform,1140)'mdlfile','yes' WRITE(Nform,1140)'mdlfilename',Autofl(1:nblank(Autofl)) ELSE WRITE(Nform,1140)'mdlfile','no' END IF WRITE(Nform,1150)'fcstlimit',Fctlim IF(Nbcst.gt.0)WRITE(Nform,1150)'bcstlimit',Bcklim WRITE(Nform,1150)'qlim',Qlim WRITE(Nform,1150)'overdiff',Ovrdif END IF c----------------------------------------------------------------------- c Print short description of the prior adjustment factors and c regression part of the model c----------------------------------------------------------------------- IF(Prttab(LAXHDR))THEN CALL prprad(Adjttl,Nadjcr,Nustad,Nuspad,Priadj,Reglom) IF(Priadj.gt.1)WRITE(Mt1,'()') CALL prtnfn(Fcntyp,Lam,0) IF(.not.Lfatal.and.Lidotl.and.Prttab(LOTLHD)) * & CALL prothd(Begtst,Endtst,Ltstao,Ltstls,Ltsttc,Ltstso,Ladd1, * & Critvl) & CALL prothd(Begtst,Endtst,Ltstao,Ltstls,Ltsttc,Ladd1,Critvl) IF(.not.Lfatal)CALL prtmsp(Begmdl,Endmdl,Sp,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c Set up temporary storage for regressors. c ------------------------------------------------------------------ ngr1=Ngrp ngrt1=Ngrptl ncxy1=Ncxy nb1=Nb nct1=Ncoltl ncttl=PCOLCR*PB cttl1(1:ncttl)=Colttl(1:ncttl) ngttl=PGRPCR*PB gttl1(1:ngttl)=Grpttl(1:ngttl) CALL cpyint(Colptr(0),PB+1,1,clptr1(0)) CALL cpyint(Grp(0),PGRP+1,1,g1(0)) CALL cpyint(Grpptr(0),PGRP+1,1,gptr1(0)) CALL cpyint(Rgvrtp,PB,1,rgv1) CALL copy(B,PB,1,b1) c ------------------------------------------------------------------ c Loop through models c ------------------------------------------------------------------ Hvmdl=F estbst=F nummdl=0 tstmdl=T numbst=0 bstptd=F anymdl=F DO WHILE (tstmdl) c----------------------------------------------------------------------- c Test to see if all of the models have been tested (ie, test for c an end of file, or if five models are done). c----------------------------------------------------------------------- IF((havfil.and.Nxtktp.eq.EOF).or.((.not.havfil).and. & nummdl.eq.5))THEN c----------------------------------------------------------------------- c If none of the models have been selected, close file and exit c routine c----------------------------------------------------------------------- IF(havfil)THEN CALL fclose(Inputx) c----------------------------------------------------------------------- c See if any models were read by the program - if not, print error c message and exit c----------------------------------------------------------------------- IF(nummdl.eq.0)THEN WRITE(STDERR,1050)Autofl(1:nblank(Autofl)) WRITE(Mt2,1050)Autofl(1:nblank(Autofl)) CALL abend RETURN END IF END IF c----------------------------------------------------------------------- c If one of the models was not read in correctly, print message c warning user to correct problem c----------------------------------------------------------------------- IF(.not.inptok)THEN IF(havfil)THEN IF(.not.Lquiet)WRITE(STDERR,1040)Autofl(1:nblank(Autofl)) WRITE(Mt2,1040)Autofl(1:nblank(Autofl)) ELSE IF(.not.Lquiet)WRITE(STDERR,1040)Autofl(1:nblank(Autofl)) WRITE(Mt2,1040)Autofl(1:nblank(Autofl)) END IF END IF c----------------------------------------------------------------------- c If no models selected, write out message c----------------------------------------------------------------------- IF(.not.Hvmdl.and.Hvstar.eq.0)THEN IF(nerr.gt.0)THEN IF(.not.Lquiet)WRITE(STDERR,1120)Cursrs(1:nblank(Cursrs)) WRITE(Mt1,1120)Cursrs(1:nblank(Cursrs)) END IF IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 RETURN END IF c----------------------------------------------------------------------- c If all of the models had estimation errors, stop execution now. c----------------------------------------------------------------------- IF(.not.anymdl)THEN CALL abend() RETURN END IF c----------------------------------------------------------------------- c Check to see if the best model was the last model estimated. c If this is not the case, reset and reestimate model parameters. c----------------------------------------------------------------------- IF(nummdl.eq.numbst)GO TO 20 CALL bstget(Nbstds,Bstdsn) estbst=T c----------------------------------------------------------------------- c If the current setting of Picktd is not equal to the setting for c the best model, change the values of the transformed series and c prior adjusted series to correspond to the best model's setting of c Picktd c----------------------------------------------------------------------- IF(.not.(bstptd.eqv.Picktd))THEN Picktd=bstptd IF(bstptd.eqv.pktd)THEN CALL copy(tsrs,PLEN,1,Trnsrs) CALL copy(a2,PLEN,1,Adj) padj2=Priadj ELSE IF(Picktd)THEN IF(Lrgmtd.and.MOD(Tdzero,2).ne.0)THEN CALL gtrgpt(Begadj,Tddate,Tdzero,begrgm,Nadj) ELSE CALL setlg(T,PLEN,begrgm) END IF IF(Lfatal)RETURN CALL td7var(Begadj,Sp,Nadj,1,1,F,F,T,Adj,begrgm) IF(Nustad.gt.0)CALL eltfcn(MULT,Adj,Usrtad(Frstat),Nspobs, & PLEN,Adj) IF(Nuspad.gt.0)CALL eltfcn(MULT,Adj,Usrpad(Frstap),Nspobs, & PLEN,Adj) CALL eltfcn(DIV,Y(Frstsy),Adj(Adj1st),Nspobs,PLEN,Trnsrs) Priadj=4 ELSE IF(Nustad.gt.0.or.Nuspad.gt.0)THEN IF(Nustad.gt.0)CALL eltfcn(DIV,Y(Frstsy),Usrtad(Frstat), & Nspobs,PLEN,Trnsrs) IF(Nuspad.gt.0)CALL eltfcn(DIV,Y(Frstsy),Usrpad(Frstap), & Nspobs,PLEN,Trnsrs) ELSE CALL copy(Y(Frstsy),Nspobs,-1,Trnsrs) END IF Priadj=1 END IF IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF END IF END IF c----------------------------------------------------------------------- c If an end of file has not been reached, initialize the parameters c and lag vectors. c----------------------------------------------------------------------- ELSE mdskip=F CALL mdlint() c----------------------------------------------------------------------- c IF identifying outliers and trading day for each model, restore c original regressors. c----------------------------------------------------------------------- IF(.not.Id1st.and.(Lidotl.or.Itdtst.gt.0).and.nummdl.gt.0)THEN Ngrp=ngr1 Ngrptl=ngrt1 Ncxy=ncxy1 Nb=nb1 Ncoltl=nct1 Colttl(1:ncttl)=cttl1(1:ncttl) Grpttl(1:ngttl)=gttl1(1:ngttl) CALL cpyint(clptr1(0),PB+1,1,Colptr(0)) CALL cpyint(g1(0),PGRP+1,1,Grp(0)) CALL cpyint(gptr1(0),PGRP+1,1,Grpptr(0)) CALL cpyint(rgv1,PB,1,Rgvrtp) CALL copy(b1,PB,1,B) c----------------------------------------------------------------------- c IF td has changed, restore transformed series, original prior c adjustment. c----------------------------------------------------------------------- IF(.not.(Picktd.eqv.pktd))THEN CALL copy(tsrs,PLEN,1,Trnsrs) CALL copy(a2,PLEN,1,Adj) Picktd=pktd Priadj=padj2 END IF END IF c----------------------------------------------------------------------- c Read in ARIMA lags for automatic model selection c----------------------------------------------------------------------- IF(havfil)THEN DO WHILE (Nxtktp.ne.LPAREN) CALL lex() IF(Nxtktp.eq.EOF)GO TO 10 END DO END IF c----------------------------------------------------------------------- nummdl=nummdl+1 argok=T id=(Id1st.and.nummdl.eq.1).or.(.not.Id1st) IF(havfil)THEN CALL getmdl(argok,inptok,T) IF(Lfatal)THEN WRITE(STDERR,1070)Autofl(1:nblank(Autofl)) WRITE(Mt2,1070)Autofl(1:nblank(Autofl)) RETURN END IF ELSE CALL setamx(nummdl,Lseff,argok,inptok) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Compute the number of effective observations and initialize |G'G| c----------------------------------------------------------------------- Lar=Lextar.and.Mxarlg.gt.0 Lma=Lextma.and.Mxmalg.gt.0 c ------------------------------------------------------------------ IF(Lextar)THEN Nintvl=Mxdflg Nextvl=Mxarlg+Mxmalg c ------------------------------------------------------------------ ELSE Nintvl=Mxdflg+Mxarlg c ------------------------------------------------------------------ Nextvl=0 IF(Lextma)Nextvl=Mxmalg END IF c----------------------------------------------------------------------- c If able to read model, store model parameters for later retrieval c----------------------------------------------------------------------- CALL ssprep(T,F,F) c----------------------------------------------------------------------- c IF one of the models was not read in correctly, attempt to read in c the next model in the file. c----------------------------------------------------------------------- IF(.not.argok)GO TO 10 c----------------------------------------------------------------------- IF(havfil.and.Nxtktp.eq.STAR)THEN IF(Hvstar.gt.0)THEN IF(.not.Lquiet)WRITE(STDERR,1071)Autofl(1:nblank(Autofl)) WRITE(Mt2,1071)Autofl(1:nblank(Autofl)) ELSE Hvstar=1 END IF ELSE IF(.not.havfil.and.nummdl.eq.1)THEN Hvstar=1 END IF END IF c----------------------------------------------------------------------- c Set up the regression matrix c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Estimate the regression and ARMA parameters c----------------------------------------------------------------------- argok=T lester=F c----------------------------------------------------------------------- c If automatic trading day testing is done, perform test here c----------------------------------------------------------------------- IF((Itdtst.gt.0.or.Leastr.or.(Luser.and.Ncusrx.gt.0).or. & Lomtst.gt.0).and.(id.and.(.not.estbst)))THEN IF(Itdtst.gt.0)THEN CALL tdaic(Trnsrs,A,Nefobs,Na,Frstry,lester,tdauto,Ltdlom,F,F, & F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred dur &ing the AIC testing of',STDERR,Mt2,T) CALL writln(' trading day regressor(s). The error messa &ge appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Id1st)THEN IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF END IF IF((.not.lester).and.Lomtst.gt.0)THEN CALL lomaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred dur &ing the AIC testing of',STDERR,Mt2,T) CALL writln(' lom/loq/lpyear regressor(s). The error me &ssage appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Id1st)THEN IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF END IF IF((.not.lester).and.Leastr)THEN CALL easaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred dur &ing the AIC testing of',STDERR,Mt2,T) CALL writln(' an Easter regressor. The error message ap &pears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Id1st)THEN IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF END IF IF((.not.lester).and.(Luser.and.Ncusrx.gt.0))THEN CALL usraic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred dur &ing the AIC testing of',STDERR,Mt2,T) CALL writln(' user defined regressor(s). The error mess &age appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Id1st)THEN IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF IF(Ncusrx.eq.0.and.Ch2tst)Ch2tst=F END IF IF(.not.lester.and.(Ch2tst.and.Nguhl.gt.0))THEN CALL chkchi(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred dur &ing the chi square testing',STDERR,Mt2,T) CALL writln(' of user defined holiday regressor(s). The & error message appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Id1st)THEN IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF END IF argok=.not.lester ELSE CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) END IF IF(Lfatal)RETURN IF(argok)THEN c----------------------------------------------------------------------- c If re-estimating the best model, break out of loop now c----------------------------------------------------------------------- IF(estbst)GO TO 20 c----------------------------------------------------------------------- c If outlier identification specified, do it here c----------------------------------------------------------------------- IF(Lidotl.and.id.and.argok.and.(.not.lester))THEN * CALL idotlr(Ltstao,Ltstls,Ltsttc,Ltstso,Ladd1,Critvl,Cvrduc, CALL idotlr(Ltstao,Ltstls,Ltsttc,Ladd1,Critvl,Cvrduc, & Begtst,Endtst,Nefobs,Lestim,Mxiter,Mxnlit,argok,A, & Trnsrs,Nobspf,Nfcst,Outfer,Fctok,F,0,F,F,F,sviter, & F,F,F,F) IF((.not.Lfatal).and.(.not.Convrg))THEN IF(Id1st)THEN WRITE(Mt1,1056) IF(havfil)THEN WRITE(Mt1,1057)Autofl(1:nblank(Autofl)) ELSE WRITE(Mt1,1058) END IF WRITE(Mt1,1059)PRGNAM IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF argok=F END IF IF((.not.Lfatal).and.argok) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print model estimation errors or warning messages in the error c file. c----------------------------------------------------------------------- IF(Armaer.lt.0.or.Armaer.gt.1)THEN nerr=nerr+1 WRITE(Mt2,1080)Mdldsn(1:Nmddcr) Nefobs=Nspobs-Nintvl CALL prterr(nefobs,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If the nature of the estimation error warrants, remove the model c from future consideration in the automatic model search. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.eq.PACSER.or.Armaer.lt.0)THEN mdskip=T IF(Hvstar.eq.1)THEN Hvstar=0 IF(.not.Lquiet)WRITE(STDERR,1072) WRITE(Mt2,1072) END IF END IF Armaer=0 END IF anymdl=anymdl.or.argok IF((.not.argok).and.(.not.mdskip))mdskip=T c----------------------------------------------------------------------- c Calculate forecasts, average MAPE for three years c----------------------------------------------------------------------- IF(.not.mdskip)THEN CALL amdfct(Trnsrs,mape,Nobspf,Nfcst,F,Fctok,argok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Get Ljung-Box Chi-Square results c check to see if argok false - if so, do not perform remaining c tests (BCM May 2007) c----------------------------------------------------------------------- IF(argok)THEN i=24 IF(Sp.eq.4)i=12 np=0 endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))np=np+1 END DO blchi=DNOTST IF(i.lt.Nefobs)THEN CALL acf(A(Na-Nefobs+1),Nefobs,Nefobs,smpac,seacf,i,np,Sp,0, & T,F) IF(.not.dpeq(Qpv(i),DNOTST))THEN blchi=Qpv(i)*100D0 qchi=Qs(i) dgfchi=Dgf(i) END IF END IF c----------------------------------------------------------------------- c Sum regular and seasonal MA terms to test for overdifferencing c----------------------------------------------------------------------- begopr=Mdl(MA-1) endopr=Mdl(MA)-1 sma=0D0 rma=0D0 ovrdff=F ovrsdf=F DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(tmpttl(1:ntmpcr).eq.'Seasonal MA')THEN DO ilag=beglag,endlag sma=sma+Arimap(ilag) END DO ELSE IF(tmpttl(1:ntmpcr).eq.'Nonseasonal MA')THEN DO ilag=beglag,endlag rma=rma+Arimap(ilag) END DO END IF END DO IF(Nnsedf.gt.0.and.rma.ge.Ovrdif)ovrdff=T IF(Nseadf.gt.0.and.sma.ge.Ovrdif)THEN ovrsdf=T IF(.not.gsovdf)gsovdf=T END IF END IF c----------------------------------------------------------------------- c Print out model information. c add argok to arguments of prtamd (BCM May 2007) c----------------------------------------------------------------------- IF(Prttab(LAXMDL))THEN CALL prtamd(Mdldsn(1:Nmddcr),mape,blchi,qchi,dgfchi,nummdl,T, & ovrdff,ovrsdf,Fctok,argok) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Test to see if model is accepted. If so, print out message and c exit while loop. c add check to see if argok false (BCM May 2007) c----------------------------------------------------------------------- IF(((Fctok.and.argok).and.mape(4).le.loclim).and.blchi.gt.Qlim & .and.(.not.ovrdff))THEN IF(.not.Hvmdl)THEN Hvmdl=T IF(Pck1st)tstmdl=F END IF numbst=nummdl loclim=mape(4) CALL bstmdl(Nbstds,Bstdsn,bstptd) IF(Hvstar.eq.2)Hvstar=3 ELSE IF(.not.Hvmdl.and.Hvstar.eq.1.and.argok)THEN Hvstar=2 numbst=nummdl CALL bstmdl(Nbstds,Bstdsn,bstptd) END IF END IF c----------------------------------------------------------------------- ELSE c----------------------------------------------------------------------- c Print model estimation errors or warning messages in the error c file. c----------------------------------------------------------------------- IF(Armaer.lt.0.or.Armaer.gt.1)THEN nerr=nerr+1 WRITE(Mt2,1080)Mdldsn(1:Nmddcr) Nefobs=Nspobs-Nintvl CALL prterr(Nefobs,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If the nature of the estimation error warrants, remove the model c from future consideration in the automatic model search. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.eq.PACSER.or.Armaer.lt.0)THEN mdskip=T IF(Hvstar.eq.1)THEN Hvstar=0 IF(Lquiet)WRITE(STDERR,1072) WRITE(Mt2,1072) END IF END IF Armaer=0 END IF END IF 10 CONTINUE END DO c----------------------------------------------------------------------- c Print out more complete message concerning seasonal c overdifferencing. c----------------------------------------------------------------------- IF(gsovdf)WRITE(Mt1,1130)Ovrdif c----------------------------------------------------------------------- c If first model used for identification of outliers and td, check c to see if another model was selected. c----------------------------------------------------------------------- 20 IF(Id1st.and.(Lidotl.or.Leastr.or.Itdtst.gt.0).and.numbst.gt.1) & THEN c----------------------------------------------------------------------- c If so, restore original regressors and redo model estimation. c----------------------------------------------------------------------- Ngrp=ngr1 Ngrptl=ngrt1 Ncxy=ncxy1 Nb=nb1 Ncoltl=nct1 Colttl(1:ncttl)=cttl1(1:ncttl) Grpttl(1:ngttl)=gttl1(1:ngttl) CALL cpyint(clptr1(0),PB+1,1,Colptr(0)) CALL cpyint(g1(0),PGRP+1,1,Grp(0)) CALL cpyint(gptr1(0),PGRP+1,1,Grpptr(0)) CALL cpyint(rgv1,PB,1,Rgvrtp) CALL copy(b1,PB,1,B) c----------------------------------------------------------------------- c IF td has changed, restore transformed series, original prior c adjustment. c----------------------------------------------------------------------- IF(.not.(Picktd.eqv.pktd))THEN CALL copy(tsrs,PLEN,1,Trnsrs) CALL copy(a2,PLEN,1,Adj) Picktd=pktd Priadj=padj2 END IF c----------------------------------------------------------------------- c Compute the number of effective observations and initialize |G'G| c----------------------------------------------------------------------- Lar=Lextar.and.Mxarlg.gt.0 Lma=Lextma.and.Mxmalg.gt.0 c ------------------------------------------------------------------ IF(Lextar)THEN Nintvl=Mxdflg Nextvl=Mxarlg+Mxmalg c ------------------------------------------------------------------ ELSE Nintvl=Mxdflg+Mxarlg c ------------------------------------------------------------------ Nextvl=0 IF(Lextma)Nextvl=Mxmalg END IF c----------------------------------------------------------------------- c Set up the regression matrix c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Estimate the regression and ARMA parameters c----------------------------------------------------------------------- argok=T lester=F IF(Leastr.or.Itdtst.gt.0.or.(Luser.and.Ncusrx.gt.0).or. & Lomtst.gt.0)THEN c----------------------------------------------------------------------- c If automatic trading day testing is done, perform test here c----------------------------------------------------------------------- CALL ssprep(T,F,F) IF((.not.lester).and.Itdtst.gt.0)THEN CALL tdaic(Trnsrs,A,Nefobs,Na,Frstry,lester,tdauto,Ltdlom,F,F, & F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: A model estimation error has occurred duri &ng the AIC testing of',STDERR,Mt2,T) CALL writln(' trading day regressor(s). The error messa &ge appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF IF((.not.lester).and.Lomtst.gt.0)THEN CALL lomaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: A model estimation error has occurred duri &ng the AIC testing of',STDERR,Mt2,T) CALL writln(' lom/loq/lpyear regressor(s). The error me &ssage appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF IF((.not.lester).and.Leastr)THEN CALL easaic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: A model estimation error has occurred duri &ng the AIC testing of',STDERR,Mt2,T) CALL writln(' an Easter regressor. The error message ap &pears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF IF((.not.lester).and.(Luser.and.Ncusrx.gt.0))THEN CALL usraic(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F,0,Lhiddn) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: A model estimation error has occurred duri &ng the AIC testing of',STDERR,Mt2,T) CALL writln(' user defined regressor(s). The error mess &age appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF IF(Ncusrx.eq.0.and.Ch2tst)Ch2tst=F END IF IF((.not.lester).and.(Ch2tst.and.Nguhl.gt.0))THEN CALL chkchi(Trnsrs,A,Nefobs,Na,Frstry,lester,F,F,F,F) IF(Lfatal)RETURN IF(lester)THEN CALL writln('ERROR: An model estimation error has occurred dur &ing the chi square testing',STDERR,Mt2,T) CALL writln(' of user defined holiday regressor(s). The & error message appears below.',STDERR,Mt2,F) CALL prterr(nefobs,T) IF(Id1st)THEN IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF END IF END IF ELSE CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF(.not.argok)CALL abend() END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c If outlier identification specified, do it here c----------------------------------------------------------------------- IF(Lidotl)THEN * CALL idotlr(Ltstao,Ltstls,Ltsttc,Ltstso,Ladd1,Critvl,Cvrduc, CALL idotlr(Ltstao,Ltstls,Ltsttc,Ladd1,Critvl,Cvrduc, & Begtst,Endtst,Nefobs,Lestim,Mxiter,Mxnlit,argok,A, & Trnsrs,Nobspf,Nfcst,Outfer,Fctok,F,0,F,F,F,sviter, & F,F,F,F) IF((.not.Lfatal).and.(.not.Convrg))THEN WRITE(Mt1,1050)Autofl(1:nblank(Autofl)) IF(Prttab(LAXMCH))WRITE(Mt1,1060) Bstdsn(1:4)='none' Nbstds=4 Hvmdl=F RETURN END IF IF(.not.argok)CALL abend() IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Check to see if default model is to be used. c----------------------------------------------------------------------- IF(.not.Hvmdl.and.Hvstar.eq.2)THEN IF(Prttab(LAXMCH))WRITE(Mt1,1060) IF(Adjtd.eq.1.OR.(AdjAO.eq.1.and.Nao.gt.0).OR.(AdjLS.eq.1.and. & (Nls.gt.0.or.Nramp.gt.0)).OR.(AdjTC.eq.1.and.Ntc.gt.0).or. & (AdjSO.eq.1.and.Nso.gt.0).or.Adjsea.eq.1.or.Adjusr.eq.1.or. & Adjhol.eq.1.or.Finusr.or.FinAO.or.FinLS.or.Fintc.or.Finhol) & THEN Hvmdl=T CALL nofcst(Trnsrs,Frstry,Lsadj) IF(Lfatal)RETURN IF(Prttab(LAXMCH))WRITE(Mt1,1091)Bstdsn(1:Nbstds) ELSE Bstdsn(1:4)='none' Nbstds=4 IF(nerr.gt.0)THEN IF(.not.Lquiet)WRITE(STDERR,1120)Cursrs(1:nblank(Cursrs)) WRITE(Mt1,1120)Cursrs(1:nblank(Cursrs)) END IF RETURN END IF c----------------------------------------------------------------------- c Print out message describing model chosen c----------------------------------------------------------------------- ELSE IF(Prttab(LAXMCH))THEN WRITE(Mt1,1090)Bstdsn(1:Nbstds) END IF c----------------------------------------------------------------------- c If Backcasting is done, test backcast extrapolation model. c----------------------------------------------------------------------- IF(Nbcst.gt.0.and.Hvstar.ne.2)THEN CALL amdfct(Trnsrs,mape,Nobspf,Nfcst,T,Fctok,argok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print out backcasting infromation c----------------------------------------------------------------------- IF(Prttab(LAXHDR))WRITE(Mt1,1100) c----------------------------------------------------------------------- IF(Prttab(LAXMDL))THEN CALL prtamd(Mdldsn(1:Nmddcr),mape,blchi,qchi,dgfchi,numbst,F, & ovrdff,ovrsdf,Fctok,argok) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Test to see if model is accepted. If so, print out message. c check to see if argok false and print out error message for c backcasts (BCM May 2007) c----------------------------------------------------------------------- IF(mape(4).gt.Bcklim.and.(.not.argok))THEN Nbcst=0 Pos1bk=Pos1ob IF(Prttab(LAXMCH))WRITE(Mt1,1110) ELSE IF(Prttab(LAXMCH))THEN WRITE(Mt1,1090)Mdldsn(1:Nmddcr) END IF END IF c----------------------------------------------------------------------- IF(nerr.gt.0.or.(.not.argok))THEN IF(.not.Lquiet)WRITE(STDERR,1120)Cursrs(1:nblank(Cursrs)) WRITE(Mt1,1120)Cursrs(1:nblank(Cursrs)) END IF c----------------------------------------------------------------------- 1010 FORMAT(/,' Autoregressive Integrated Moving Average (ARIMA) ', & 'extrapolation program',/,' ARIMA extrapolation', & ' model (forecast)',/) 1011 FORMAT(5X,'Autoregressive Integrated Moving Average (ARIMA) ', & 'extrapolation program',/,' ARIMA extrapolation', & ' model (forecast)',/) 1020 FORMAT(' Model selected: First model that meets ', & 'acceptance criteria.') 1021 FORMAT(/,5x,'Model selected: First model that meets acceptance', & ' criteria.') 1030 FORMAT(' Model selected: Model with lowest average ', & 'forecast error that',/,' meets acceptance criteria.') 1031 FORMAT(/,5x,'Model selected: Model with lowest average ', & 'forecast error that meets',/,21x,'acceptance criteria.') 1040 FORMAT(/,' WARNING: Unable to process at least one of the ARIMA', & ' models stored in ',/,' ',a,'.',/, & ' Check contents of this file and try again.') 1041 FORMAT(/,' WARNING: Unable to generate at least one of the ', & 'default ARIMA models.') 1050 FORMAT(/,' ERROR: No ARIMA models stored in ',a,'.', & /,' Check contents of file and try again.') 1056 FORMAT(' Rerun program trying one of the following:',/, & ' (1) Allow more iterations (set a larger ', & 'value of maxiter).') 1057 FORMAT(' (2) Remove model from automatic model ', & 'file',1x,a,'.') 1058 FORMAT(' (2) Use an automatic model file to specify ', & 'other models.') 1059 FORMAT(' See ',a,' of the ',a,' ',a,' for more',/, & ' discussion.') 1060 FORMAT(//,15x,'None of the models were chosen.',/) 1070 FORMAT(/,' ERROR: Unable to read automatic model for the ', & 'reason(s) given above.',/, & ' Check the models stored in ',a,'.') 1071 FORMAT(/,' NOTE: Default model already specified.',/, & ' Check the model file ',a,'.') 1072 FORMAT(/,' WARNING: Estimation error encountered for default ', & 'model.',/,' Default model will not be used.') 1080 FORMAT(' Estimation errors associated with the model: ',a) 1090 FORMAT(//,15x,'The model chosen is ',a,/) 1091 FORMAT(15x,'A default model specified by the user, ',a,',',/, & 15x,'will be used to generate regARIMA preadjustment ', & 'factors') 1100 FORMAT(5X,'Autoregressive Integrated Moving Average (ARIMA) ', & 'extrapolation program',/,7x,'ARIMA extrapolation model ', & '(backcast)',/) 1110 FORMAT(//,15x,'This model was not chosen for backcasting.',/) 1120 FORMAT(/,' WARNING: Estimation errors occured during the ', & 'automatic model ', & /,' selection procedure. For more details, ', & 'check error file ', & /,' ',a,'.err ') 1130 FORMAT(' WARNING: The seasonal MA coefficient(s) for at least', & ' one of the models',/, & ' tested above have a sum exceeding ',f6.3,'.', & //,' Examine whether a differencing can be ', & 'eliminated from the',/, & ' regARIMA model in favor of a trend constant ', & 'in the regression',/, & ' spec, or whether a seasonal differencing ', & 'should be replaced',/, & ' by the use of fixed seasonal effects in the ', & 'regression spec.') 1140 FORMAT(a,': ',a) 1150 FORMAT(a,': ',f12.6) c----------------------------------------------------------------------- RETURN END autoq.cmn0000664006604000003110000000133514521201411012012 0ustar sun00315stepsC Last change: BCM 5 Apr 2005 1:45 pm c----------------------------------------------------------------------- c Dgf - vector of degrees of freedom c Qs - vector of either Ljung-Box or Box-Pierce Q statistics c (controlled by Iqtype in arima.cmn) c Qpv - p-value for Q statistics - will be > 0 for all lags with c degrees of freedom > 0 c----------------------------------------------------------------------- INTEGER Dgf DOUBLE PRECISION C0,Qs,Qpv DIMENSION Dgf(PR),Qs(PR),Qpv(PR) c----------------------------------------------------------------------- COMMON /autoq / C0,Qs,Qpv,Dgf c----------------------------------------------------------------------- avedur.f0000664006604000003110000000261314521201411011617 0ustar sun00315stepsC Last change: BCM 29 Sep 97 9:37 am SUBROUTINE avedur(Y,L,M,Adr) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION Adr,count,runs,Y INTEGER i,L,M EXTERNAL dpeq c----------------------------------------------------------------------- C --- AVERAGE DURATION OF RUN SUBROUTINE c----------------------------------------------------------------------- DIMENSION Y(*) i=L runs=1D0 IF(Y(i).lt.Y(i+1))THEN ELSE IF(dpeq(Y(i),Y(i+1)))THEN DO WHILE (.true.) i=i+1 IF(i.ge.M)GO TO 30 IF(Y(i).lt.Y(i+1))GO TO 10 IF(Y(i).gt.Y(i+1))GO TO 20 c IF(.not.dpeq(Y(i),Y(i+1)))THEN C***** SPAG has made duplicate copies of the following statement c runs=runs+1D0 c GO TO 20 c END IF END DO ELSE GO TO 20 END IF 10 DO WHILE (.true.) i=i+1 IF(i.ge.M)GO TO 30 IF(Y(i).gt.Y(i+1))THEN C***** The following statement is a duplicate copy made by SPAG runs=runs+1D0 GO TO 20 END IF END DO 20 DO WHILE (.true.) i=i+1 IF(i.ge.M)GO TO 30 IF(Y(i).lt.Y(i+1))THEN runs=runs+1D0 GO TO 10 END IF END DO 30 count=M-L Adr=count/runs RETURN END averag.f0000664006604000003110000000144614521201411011601 0ustar sun00315steps**==averag.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE averag(X,Y,Ib,Ie,M,N) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION fmn,tmp,X,Y INTEGER i,i1,i2,Ib,Ie,j,ji,k,kb,ke,ki,M,N C*** End of declarations inserted by SPAG C C --- THIS SUBROUTINE APPLIES AN M-OF-N MOVING AVERAGE TO THE SERIES C --- X AND STORES THE RESULTS IN Y. C DIMENSION X(Ie),Y(Ie) ki=(M+N)/2-1 kb=Ib+ki ke=Ie-ki IF(ke.ge.kb)THEN fmn=dble(M*N) DO k=kb,ke tmp=0D0 i1=k-ki i2=i1+M-1 DO i=i1,i2 ji=i+N-1 DO j=i,ji tmp=tmp+X(j) END DO END DO Y(k)=tmp/fmn END DO END IF RETURN END aver.f0000664006604000003110000000303214521201411011262 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:57 pm **==aver.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE aver(Xval,N,I,Icode,Icod2,Jx) IMPLICIT NONE C*** Start of declarations inserted by SPAG INCLUDE 'srslen.prm' INCLUDE 'units.cmn' INCLUDE 'chrt.cmn' DOUBLE PRECISION Xval,summ INTEGER Icod2,Icode,imnth,istep,j,Jx,jyave,jyval,k,l,N C*** End of declarations inserted by SPAG C PLOT BY MONTH AROUND MEAN OF EACH MONTH C************************ DIMENSION Xval(*) CHARACTER*1 itype CHARACTER*1 I imnth=Ifrst itype=Ialpha(imnth) IF(Icode.eq.9)I=itype IF(Icod2.eq.19)THEN Xyvec=0D0 ELSE IF(Icod2.eq.29)THEN Xyvec=100D0 ELSE summ=0D0 DO l=1,N summ=summ+Xval(l) END DO Xyvec=summ/dble(N) END IF CALL value IF(Ixy.gt.110.or.Ixy.lt.1)THEN CALL writln('NOTE: Cannot generate plot since expected value of a &verage not in plotting range.',Mt1,Mt2,.true.) Icode=-1 RETURN END IF jyave=Ixy DO k=1,N Xyvec=Xval(k) CALL value jyval=Ixy istep=1 IF(jyval.lt.jyave)istep=-1 DO j=jyave,jyval,istep Ia(Jx,j)=I END DO IF((Icode-7)*(Icode-9).eq.0)Ia(Jx,jyave)=I1 Jx=Jx+1 IF(Icode.eq.9)THEN imnth=imnth+1 IF(imnth.eq.Nseas+1)imnth=1 I=Ialpha(imnth) END IF END DO RETURN END bakusr.f0000664006604000003110000000516114521201411011621 0ustar sun00315steps SUBROUTINE bakusr(Userx,Usrtyp,Usrptr,Ncusrx,Usrttl,Regfx,B, & Rgvrtp,Ngrp,Grpttl,Grp,Grpptr,Ngrptl,Rind,Is1st) IMPLICIT NONE c----------------------------------------------------------------------- c Making backup copy of user defined regressors for regARIMA, m. c----------------------------------------------------------------------- LOGICAL T PARAMETER(T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'urgbak.cmn' c----------------------------------------------------------------------- LOGICAL Regfx,Is1st CHARACTER Grpttl*(*),Usrttl*(*) DOUBLE PRECISION B,Userx INTEGER Usrtyp,Ncusrx,Usrptr,Rgvrtp,Ngrp,Grpptr,Ngrptl,Grp,disp,i, & iuser,igrp,begcol,endcol,Rind DIMENSION B(PB),Regfx(PB),Rgvrtp(PB),Userx(PUSERX),Usrtyp(PUREG), & Grp(0:PGRP),Grpptr(0:PGRP),Usrptr(0:PUREG) c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- c remove the user defined regressors from the regression matrix. c----------------------------------------------------------------------- iuser=(PUREG*Rind) DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF((Rgvrtp(begcol).ge.PRGTUH.and.Rgvrtp(begcol).le.PRGUH5).or. & Rgvrtp(begcol).eq.PRGTUS.or.Rgvrtp(begcol).eq.PRGUTD.or. & Rgvrtp(begcol).eq.PRGTUD.or.Rgvrtp(begcol).eq.PRGULM.or. & Rgvrtp(begcol).eq.PRGULQ.or.Rgvrtp(begcol).eq.PRGULY.or. & Rgvrtp(begcol).eq.PRGUAO.or.Rgvrtp(begcol).eq.PRGULS.or. & Rgvrtp(begcol).eq.PRGUSO.or.Rgvrtp(begcol).eq.PRGUCN.or. & Rgvrtp(begcol).eq.PRGUCY)THEN DO i=begcol,endcol iuser=iuser+1 Buser(iuser)=B(i) Fxuser(iuser)=Regfx(i) END DO END IF END DO c----------------------------------------------------------------------- c Make backup copy of user defined regressors. c----------------------------------------------------------------------- IF(.not.Is1st)RETURN disp=(PUSERX*Rind)+1 CALL copy(Userx(disp),PUSERX,1,Userx2) disp=(PUREG*Rind)+1 CALL cpyint(Usrtyp(disp),PUREG,1,Usrty2) disp=((PUREG+1)*Rind)+1 CALL cpyint(Usrptr(0),PUREG+1,1,Usrpt2(disp)) Ncusx2(Rind)=Ncusrx Usrtt2(Rind)=Usrttl c----------------------------------------------------------------------- RETURN END bartlett.i0000664006604000003110000000030714521201411012153 0ustar sun00315stepsC C... Variables in Common Block /bartlett SE/ ... real*8 bsetr(0:kp),bses(0:kp),bsesa(0:kp),bsecyc(0:kp), $ bseir(0:kp) common /bartlett/ bsetr,bses,bsesa,bsecyc,bseir bench.f0000664006604000003110000004017014521201412011411 0ustar sun00315steps SUBROUTINE BenchMark(Series,Stci,Stci2,Lfda,Llda,Ny,Iter, & Title,nfperiod,nfyear) C C Arguments C C C.. Implicits .. implicit none C C.. Formal Arguments .. integer Lfda,Llda,Ny,Iter,Nfyear,Nfperiod Real*8 Series(*),Stci(*),Stci2(*) character*80 title c Local scalar integer ntitle character fname*12,subtitle*50 C C.. External Functions .. integer ISTRLEN external ISTRLEN C C.. External Calls .. * external PLOTSERIES include 'calfor.i' include 'sform.i' include 'dirs.i' include 'titl.i' cc c cc if ((Ny.eq.4) .or. (Ny.eq.12)) then Mq=Ny NFREQ=Ny NPER=Nfperiod NYER=Nfyear TitleG=title call qmap2(Series,Stci,Stci2,Lfda,Llda,Ny,0) ntitle=istrlen(title) * if (iter.ne.0) then * fname = title(1:ntitle) // '.SAY' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,Stci2,Llda,1,0.0d0) * call AddList(fname) * else * fname = 'FSAYFIN.T' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,Stci2,Llda,1,0.0d0) * end if end if return end cc c cc subroutine AddList(fname) C.. Implicits .. implicit none C C.. Formal Arguments .. character fname*12 C C.. External Functions .. integer ISTRLEN external ISTRLEN c include 'dirs.i' cdos close(17) cdos open (17,FILE=Graphdir(1:ISTRLEN(GraphDir)) // cdos $ '\\series\\graph.lst', cdos $ status='old',access='append') cunix open (17,FILE=Graphdir(1:ISTRLEN(GraphDir)) // cunix $ '/series/graph.lst', cunix $ status='old',access='append') cunix write (17,'(A)') fname cunix close(17) return end cc c *cc ***==aa0001.f processed by SPAG 6.05Fc at 11:55 on 4 Oct 2004 * SUBROUTINE qmap2(Series,Stci,Stci2,Lfda,Llda,Ny,Iagr) * IMPLICIT NONE ***--AA00013 *C *C*** Start of declarations rewritten by SPAG *c ------------------------------------------------------------------ *c----------------------------------------------------------------------- *c PLEN is the integer PARAMETER for the maximum length of a *c series. *c----------------------------------------------------------------------- *c Name Type Description *c----------------------------------------------------------------------- *c PFCST i PARAMETER for the maximum number of forecasts *c POBS i PARAMETER for the maximum length of the series *c PLEN i PARAMETER for the maximum length of the series + back and *c forecasts *c PYRS i PARAMETER for the maximum number of years in the series + *c back and forecasts *c PYR1 i PARAMETER for the maximum number of years in the series *c PTD i PARAMETER for the number of types of trading day factors *c (based on lenght of month, starting period) *c PSP - maximum length of seasonal period (formerly in model.cmn) *c----------------------------------------------------------------------- * INTEGER POBS,PLEN,PFCST,PYR1,PYRS,PSRSCR,PTD,PSP * PARAMETER(PSP=12,PFCST=10*PSP,PYR1=65,POBS=PYR1*PSP,PYRS=PYR1+10, * & PLEN=POBS+(2*PFCST),PSRSCR=79,PTD=28) *c INCLUDE 'force.i' *c ------------------------------------------------------------------ * DOUBLE PRECISION ONE,ZERO,MONE * LOGICAL F * PARAMETER(F=.false.,ONE=1D0,ZERO=0D0,MONE=-1D0) *C *C Arguments *C * DOUBLE PRECISION Series,Stci,Stci2 * INTEGER Lfda,Llda,Ny * DIMENSION Series(*),Stci(*),Stci2(*) *C *C Local variables *C * REAL*8 and11(PYRS),ansum(PYRS),ttf,cratio(PLEN),rratio(PLEN), * & delta(PLEN,PLEN),deltapi(PLEN,PLEN),det,esp,r2(PLEN,PYRS), * & rtz(PLEN),wcomp1(PLEN,PLEN),wcomp2(PLEN,PLEN), * & wcomp3(PLEN,PLEN),xa(PLEN,1),xd(PLEN,1),xx(PLEN,1) * DOUBLE PRECISION DABS * INTEGER*4 i,j,k,kk,kkt,kmq,naly, * & np,npnp * INTEGER knpn,npn1,Iagr,ns * REAL*8 mx1(PYRS,1),mx2(PYRS,1),mx3(PYRS,1) * REAL*8 Cmat(PLEN,PLEN),Omec(PLEN,PLEN),R1(PLEN,PYRS), * & Tmx1(PLEN,PLEN),Ttmat(PLEN,PLEN),Ttmat2(PYRS,PLEN) * REAL*8 Invr(PYRS,PYRS),Jmat(PYRS,PLEN),Jmatpi(PLEN,PYRS) *C * DOUBLE PRECISION SIMUL * EXTERNAL SIMUL * INCLUDE 'force.i' *C * np=Llda-Lfda+1 ** ngrid=Ny *C ** WRITE (*,'('' NO. OF POINTS '',I4)') np * Begyrt=1 * ns=Begyrt-Lfda+1 * DO WHILE (ns.le.0) * ns=ns+ny * END DO * naly=(np-ns+1)/Ny * npnp=naly*Ny ** ne=ns+npnp-1 ** write(6,*) 'stpos, naly, npnp = ',ns, naly, npnp *C CONSTRUCTION OF MATRIX J AND J PI * DO i=1,naly * DO j=1,np * Jmat(i,j)=ZERO * END DO * END DO * k=ns * DO i=1,naly * kmq=k+Ny-1 * DO j=k,kmq * Jmat(i,j)=ONE * END DO * k=kmq+1 * END DO * DO i=1,naly * DO j=1,np * Jmatpi(j,i)=Jmat(i,j) * END DO * END DO * DO j=1,np * xx(j,1)=Series(j+Lfda-1) * xa(j,1)=Stci(j+Lfda-1) * END DO *C CONSTRUCTION OF MATRIX C *c TFF added by Statstics Canada, March 2006 *C *************** modify factor TTF ***************** * TTF = 0.0D0 * DO I =1, NP * TTF = TTF + DABS(XA(I,1)) * END DO * TTF = TTF/NP * DO i=1,np * DO j=1,np * Cmat(i,j)=ZERO * END DO * END DO *c TFF used to modifiy CMAT by Statstics Canada, March 2006 * DO i=1,np * CMAT(I,I) = DABS(XA(I,1)/TTF)**LAMDA * END DO *C ****************************************************** * IF (rol.LE.0.99999D00) THEN *C CONSTRUCTION OF MATRIX OMECA OMEC * IF (rol.LT.1.0D-10) THEN * DO i=1,np * DO j=1,np * Omec(i,j)=ZERO * END DO * END DO * DO i=1,np * Omec(i,i)=ONE * END DO * ELSE * DO i=1,np * DO j=1,np * k=ABS(i-j) * Omec(i,j)=rol**k * END DO * END DO * END IF * kk=PLEN * kkt=PYRS * CALL MATMLT(Cmat,Omec,Ttmat,np,np,np,kk,kk,kk) * CALL MATMLT(Ttmat,Cmat,Tmx1,np,np,np,kk,kk,kk) * CALL MATMLT(Tmx1,Jmatpi,R1,np,np,naly,kk,kk,kk) * CALL MATMLT(Jmat,Tmx1,Ttmat2,naly,np,np,kkt,kk,kkt) * CALL MATMLT(Ttmat2,Jmatpi,Invr,naly,np,naly,kkt,kk,kkt) * esp=1.0D-20 * det=SIMUL(naly,Invr,ansum,esp,-1,kkt) * CALL MATMLT(R1,Invr,r2,np,naly,naly,kk,kkt,kk) * CALL MATMLT(Jmat,xx,mx1,naly,np,1,kkt,kk,kkt) * CALL MATMLT(Jmat,xa,mx2,naly,np,1,kkt,kk,kkt) * CALL ADD_SUB(mx1,mx2,mx3,naly,1,kkt,0) * CALL MATMLT(r2,mx3,xd,np,naly,1,kk,kkt,kk) * CALL ADD_SUB(xa,xd,xx,np,1,kk,1) * DO j=1,np * Stci2(j+Lfda-1)=xx(j,1) * END DO * ELSE *C *c inverse of CMAT computed by Statstics Canada, March 2006 *C *************************************************************** *C ***************** FIND THE INVERSE OF CMAT ******************** *C *************************************************************** * DO I = 1, NP * CMAT(I,I) = ONE/CMAT(I,I) * END DO *C **************************************************************** *C CONSTRUCTION OF MATRIX DELTA * npn1=np-1 * DO i=1,np * DO j=1,np * delta(i,j)=ZERO * END DO * END DO * DO i=1,npn1 * delta(i,i)=MONE * delta(i,i+1)=ONE * END DO * DO i=1,npn1 * DO j=1,np * deltapi(j,i)=delta(i,j) * END DO * END DO *C CONSTRUCTION OF MATRIX OMECA OMEC * kk=PLEN * kkt=PYRS * CALL MATMLT(deltapi,delta,Ttmat,np,npn1,np,kk,kk,kk) * CALL MATMLT(Cmat,Ttmat,Omec,np,np,np,kk,kk,kk) * CALL MATMLT(Omec,Cmat,Tmx1,np,np,np,kk,kk,kk) *C TMX1 = C*DEL'*DEL*C, A T by T square matrix. *C Construction of the big matrix. * knpn=np+naly * DO i=1,knpn * DO j=1,knpn * wcomp1(i,j)=ZERO * END DO * END DO * DO i=1,np * DO j=1,np * wcomp1(i,j)=Tmx1(i,j) * END DO * END DO * DO i=1,np * DO j=1,naly * wcomp1(i,np+j)=Jmatpi(i,j) * END DO * END DO * DO i=1,naly * DO j=1,np * wcomp1(np+i,j)=Jmat(i,j) * END DO * END DO * DO i=1,knpn * DO j=1,knpn * wcomp2(i,j)=ZERO * END DO * END DO * DO i=1,np * DO j=1,np * wcomp2(i,j)=Tmx1(i,j) * END DO * END DO * DO i=1,naly * wcomp2(np+i,np+i)=ONE * END DO * DO i=1,naly * DO j=1,np * wcomp2(np+i,j)=Jmat(i,j) * END DO * END DO *C Find the inverse of WCOMP1 * esp=1.0D-10 * det=SIMUL(knpn,wcomp1,rratio,esp,-1,kk) * CALL MATMLT(wcomp1,wcomp2,wcomp3,knpn,knpn,knpn,kk,kk,kk) *C R2 IS A SUBMATRIX OF WCOMP3 * DO i=1,np * DO j=1,naly * r2(i,j)=wcomp3(i,j+np) * END DO * END DO * DO j=1,np * xx(j,1)=Series(j+Lfda-1) * xa(j,1)=Stci(j+Lfda-1) * END DO * CALL MATMLT(Jmat,xx,mx1,naly,np,1,kkt,kk,kkt) * CALL MATMLT(Jmat,xa,mx2,naly,np,1,kkt,kk,kkt) * CALL ADD_SUB(mx1,mx2,mx3,naly,1,kkt,0) * CALL MATMLT(r2,mx3,xd,np,naly,1,kk,kkt,kk) * CALL ADD_SUB(xa,xd,xx,np,1,kk,1) * DO j=1,np * Stci2(j+Lfda-1)=xx(j,1) * END DO * END IF *C *********** ADDITION NEW OUTPUT ************** * DO j=1,naly * ansum(j)=mx1(j,1) * and11(j)=mx2(j,1) * END DO * IF (Mid.EQ.0) THEN * DO j=1,np * cratio(j)=Stci2(j+Lfda-1)/Stci(j+Lfda-1)-ONE * rratio(j)=ZERO * END DO * ELSE * DO j=1,np * cratio(j)=Stci2(j+Lfda-1)-Stci(j+Lfda-1) * rratio(j)=ZERO * END DO * END IF * CALL MEANCRA(ansum,and11,rtz,Mid,Ny,naly) * npnp=naly*Ny * DO j=1,npnp * rratio(j+ns-1)=rtz(j) * END DO *c IF(Iagr.eq.4)THEN *c IF(Savtab(LCPCRI))CALL punch(cratio,Lfda,Llda,LCPCRI,F,F) *c IF(.not.Lfatal.and.Savtab(LCPRRI)) *c & CALL punch(rratio,Lfda,Llda,LCPRRI,F,F) *c ELSE *c IF(Savtab(LFRCCR))CALL punch(cratio,Lfda,Llda,LFRCCR,F,F) *c IF(.not.Lfatal.and.Savtab(LFRCRR)) *c & CALL punch(rratio,Lfda,Llda,LFRCRR,F,F) *c END IF * RETURN * END ***==mult.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 * SUBROUTINE MATMLT(A,B,C,M,Ip,Iq,Ia,Ib,Ic) * IMPLICIT NONE ***--MULT5 *C *C*** Start of declarations rewritten by SPAG *C *C Dummy arguments *C * INTEGER*4 Ia,Ib,Ic,Ip,Iq,M * REAL*8 A(Ia,*),B(Ib,*),C(Ic,*) *C *C Local variables *C * INTEGER*4 i,ir,is * REAL*8 sum *C *C*** End of declarations rewritten by SPAG *C *c **** Start of Executable Program *C a(m,p)*b(p,q) = c(m,q) * DO ir=1,M * DO is=1,Iq * sum=0.0D0 * DO i=1,Ip * sum=sum+(A(ir,i)*B(i,is)) * END DO * C(ir,is)=sum * END DO * END DO * END ***==simul.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 * DOUBLE PRECISION FUNCTION SIMUL(N,A,X,Eps,Indic,Ia) * IMPLICIT NONE ***--SIMUL7 *C *C*** Start of declarations rewritten by SPAG * INCLUDE 'srslen.i' *C *C Dummy arguments *C * REAL*8 Eps * INTEGER Ia,Indic,N * REAL*8 A(Ia,*),X(N) *C *C Local variables *C * REAL*8 aijck,deter,pivot,y(PLEN) * DOUBLE PRECISION DABS,DBLE * INTEGER i,intch,ip1,irowi,irowj,irowk,iscan,j,jcoli,jcolj,jcolk, * & jscan,jtemp,k,km1,imax,nm1,INT * REAL*8 irow(PLEN),jcol(PLEN),jord(PLEN) * LOGICAL dpeq * EXTERNAL dpeq *C *C*** End of declarations rewritten by SPAG *C *c **** Start of Executable Program * imax=N * DO i=1,N * irow(i)=0D0 * jcol(i)=0D0 * END DO * IF (Indic.GE.0) imax=N+1 * IF (N.LE.396) THEN * deter=1.0D0 * DO k=1,N * km1=k-1 * pivot=0.0D0 * DO i=1,N * DO j=1,N * IF (k.NE.1) THEN * DO iscan=1,km1 * DO jscan=1,km1 * IF (dpeq(DBLE(i),irow(iscan))) GO TO 10 * IF (dpeq(DBLE(j),jcol(jscan))) GO TO 10 * END DO * END DO * END IF * IF (DABS(A(i,j)).GT.DABS(pivot)) THEN * pivot=A(i,j) * irow(k)=DBLE(i) * jcol(k)=DBLE(j) * END IF * 10 END DO * END DO * IF (DABS(pivot).GT.Eps) THEN * irowk=INT(irow(k)) * jcolk=INT(jcol(k)) * deter=deter*pivot * DO j=1,imax * A(irowk,j)=A(irowk,j)/pivot * END DO * A(irowk,jcolk)=1.0D0/pivot * DO i=1,N * aijck=A(i,jcolk) * IF (i.NE.irowk) THEN * A(i,jcolk)=-aijck/pivot * DO j=1,imax * IF (j.NE.jcolk) A(i,j)=A(i,j)-aijck*A(irowk,j) * END DO * END IF * END DO * ELSE * SIMUL=0.0D0 * RETURN * END IF * END DO * DO i=1,N * irowi=INT(irow(i)) * jcoli=INT(jcol(i)) * jord(irowi)=jcol(i) * IF (Indic.GE.0) X(jcoli)=A(irowi,imax) * END DO * intch=0 * nm1=N-1 * DO i=1,nm1 * ip1=i+1 * DO j=ip1,N * IF (jord(j).LT.jord(i)) THEN * jtemp=INT(jord(j)) * jord(j)=jord(i) * jord(i)=DBLE(jtemp) * intch=intch+1 * END IF * END DO * END DO * IF (intch/2*2.NE.intch) deter=-deter * IF (Indic.LE.0) THEN * DO j=1,N * DO i=1,N * irowi=INT(irow(i)) * jcoli=INT(jcol(i)) * y(jcoli)=A(irowi,j) * END DO * DO i=1,N * A(i,j)=y(i) * END DO * END DO * DO i=1,N * DO j=1,N * irowj=INT(irow(j)) * jcolj=INT(jcol(j)) * y(irowj)=A(i,jcolj) * END DO * DO j=1,N * A(i,j)=y(j) * END DO * END DO * SIMUL=deter * RETURN * END IF * ELSE *c WRITE (6,1010) *c 1010 FORMAT ('ON TOO BIG') * SIMUL=0.0D0 * RETURN * END IF * SIMUL=deter * RETURN * END ***==addsub.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 * SUBROUTINE ADD_SUB(A,B,C,N,M,Id,Ind) * IMPLICIT NONE ***--ADDSUB6 *C *C*** Start of declarations rewritten by SPAG *C *C Dummy arguments *C * INTEGER Id,Ind,M,N * REAL*8 A(Id,*),B(Id,*),C(Id,*) *C *C Local variables *C * INTEGER i,j *C *C*** End of declarations rewritten by SPAG *C *c **** Start of Executable Program *C INTEGER*4 N,M,ID,IND * DO i=1,N * DO j=1,M * IF (Ind.GT.0) THEN * C(i,j)=A(i,j)+B(i,j) * ELSE * C(i,j)=A(i,j)-B(i,j) * END IF * END DO * END DO * END ***==meancra.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 * SUBROUTINE MEANCRA(A1x,Aty,Rtz,Modlid,Mq,Ny) * IMPLICIT NONE ***--MEANCRA5 *C *C*** Start of declarations rewritten by SPAG *C *C Dummy arguments *C * INTEGER Modlid,Mq,Ny * REAL*8 A1x(*),Aty(*),Rtz(*) *C *C Local variables *C * INTEGER i,j,k * REAL*8 tt *C *C*** End of declarations rewritten by SPAG *C *C ----------- ATY IS D11 *c **** Start of Executable Program * IF (Modlid.EQ.0) THEN * DO i=1,Ny * tt=A1x(i)/Aty(i)-1D0 * k=Mq*(i-1) * DO j=1,Mq * Rtz(k+j)=tt * END DO * END DO * ELSE * DO i=1,Ny * tt=A1x(i)-Aty(i) * k=Mq*(i-1) * DO j=1,Mq * Rtz(k+j)=tt/Mq * END DO * END DO * END IF * END bench.i0000664006604000003110000000024114521201412011407 0ustar sun00315stepsC C... Variables in Common Block /bench/ ... real*8 brol,blamda integer bserie,bmid,bcMark common /bench/ brol,blamda,bserie,bmid,bcMark bestmd.f0000664006604000003110000000303114521201412011603 0ustar sun00315steps SUBROUTINE bestmd(Irar,Irdf,Irma,Isar,Isdf,Isma,Bstrar,Bstrdf, & Bstrma,Bstsar,Bstsdf,Bstsma,Bstbic) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'lkhd.cmn' c ------------------------------------------------------------------ INTEGER Bstrar,Bstrdf,Bstrma,Bstsar,Bstsdf,Bstsma,i,Irar,Irdf, & Irma,Isar,Isdf,Isma,j DOUBLE PRECISION Bstbic DIMENSION Bstrar(5),Bstrdf(5),Bstrma(5),Bstsar(5),Bstsdf(5), & Bstsma(5),Bstbic(5) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ i=1 DO WHILE(i.le.5) IF(dpeq(Bstbic(i),DNOTST).or.Bstbic(i).gt.Bic2)THEN IF(i.lt.5.and.(.not.dpeq(Bstbic(i),DNOTST)))THEN DO j=4,i,-1 IF(.not.dpeq(Bstbic(j),DNOTST))THEN Bstbic(j+1)=Bstbic(j) Bstrdf(j+1)=Bstrdf(j) Bstrar(j+1)=Bstrar(j) Bstrma(j+1)=Bstrma(j) Bstsdf(j+1)=Bstsdf(j) Bstsar(j+1)=Bstsar(j) Bstsma(j+1)=Bstsma(j) END IF END DO END IF Bstbic(i)=Bic2 Bstrdf(i)=Irdf Bstrar(i)=Irar Bstrma(i)=Irma Bstsdf(i)=Isdf Bstsar(i)=Isar Bstsma(i)=Isma i=6 ELSE i=i+1 END IF END DO RETURN END bkdfmd.f0000664006604000003110000000737614521201412011574 0ustar sun00315stepsC Last change: BCM 16 Jul 2003 5:11 pm SUBROUTINE bkdfmd(Backup) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'tbllog.prm' c INCLUDE 'tbllog.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'ss2rv.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' c----------------------------------------------------------------------- INTEGER PACM PARAMETER(PACM=(PLEN+2*PORDER)*PARIMA) c----------------------------------------------------------------------- LOGICAL Backup INTEGER i c----------------------------------------------------------------------- IF(Backup)THEN Pri2rv=Priadj Ngr2rv=Ngrp Ngrt2r=Ngrptl Ncxy2r=Ncxy Nbbrv=Nb Nct2rv=Ncoltl i=PCOLCR*PB Cttlrv(1:i)=Colttl(1:i) i=PGRPCR*PGRP Gttlrv(1:i)=Grpttl(1:i) CALL cpyint(Colptr(0),PB+1,1,Clptrv(0)) CALL cpyint(Grp(0),PGRP+1,1,G2rv(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Gptrrv(0)) CALL cpyint(Rgvrtp,PB,1,Rgv2rv) CALL copy(Arimap,PARIMA,1,Ap2rv) CALL copy(B,PB,1,Bbrv) CALL copylg(Arimaf,PARIMA,1,Fxarv) Nr2rv=Nrxy Ncus2r=Ncusrx Irfx2r=Iregfx CALL copylg(Regfx,PB,1,Rgfx2r) Pktd2r=Picktd Atdrv=Adjtd Aholrv=Adjhol Aaorv=Adjao Alsrv=Adjls Atcrv=Adjtc Asorv=Adjso Asearv=Adjsea Ausrrv=Adjusr Fnholr=Finhol Fnaorv=Finao Fnlsrv=Finls Fntcrv=Fintc Fnusrv=Finusr Flltdr=Fulltd Ltaorv=Ltstao Ltlsrv=Ltstls Lttcrv=Ltsttc * Ltsorv=Ltstso Lma2r=Lma Lar2r=Lar Nint2r=Nintvl Next2r=Nextvl Mxdf2r=Mxdflg Mxar2r=Mxarlg Mxma2r=Mxmalg V2r=Var CALL copy(Chlxpx,PXPX,1,Chx2r) CALL copy(Chlgpg,PGPG,1,Chg2r) CALL copy(Armacm,PACM,1,Acm2r) Dtcv2r=Lndtcv c----------------------------------------------------------------------- ELSE Priadj=Pri2rv Ngrp=Ngr2rv Ngrptl=Ngrt2r Ncxy=Ncxy2r Nb=Nbbrv Ncoltl=Nct2rv i=PCOLCR*PB Colttl(1:i)=Cttlrv(1:i) i=PGRPCR*PGRP Grpttl(1:i)=Gttlrv(1:i) CALL cpyint(Clptrv(0),PB+1,1,Colptr(0)) CALL cpyint(G2rv(0),PGRP+1,1,Grp(0)) CALL cpyint(Gptrrv(0),PGRP+1,1,Grpptr(0)) CALL cpyint(Rgv2rv,PB,1,Rgvrtp) CALL copy(Ap2rv,PARIMA,1,Arimap) CALL copy(Bbrv,PB,1,B) CALL copylg(Fxarv,PARIMA,1,Arimaf) Nrxy=Nr2rv Ncusrx=Ncus2r Iregfx=Irfx2r CALL copylg(Rgfx2r,PB,1,Regfx) Picktd=Pktd2r Adjhol=Aholrv Adjtd=Atdrv Adjao=Aaorv Adjls=Alsrv Adjtc=Atcrv Adjso=Asorv Adjsea=Asearv Adjusr=Ausrrv Finhol=Fnholr Finao=Fnaorv Finls=Fnlsrv Fintc=Fntcrv Finusr=Fnusrv Fulltd=Flltdr Ltstao=Ltaorv Ltstls=Ltlsrv Ltsttc=Lttcrv * Ltstso=Ltsorv Lma=Lma2r Lar=Lar2r Nintvl=Nint2r Nextvl=Next2r Mxdflg=Mxdf2r Mxarlg=Mxar2r Mxmalg=Mxma2r Var=V2r CALL copy(Chx2r,PXPX,1,Chlxpx) CALL copy(Chg2r,PGPG,1,Chlgpg) CALL copy(Acm2r,PACM,1,Armacm) Lndtcv=Dtcv2r c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- RETURN END bldcov.f0000664006604000003110000005366114521201412011614 0ustar sun00315steps SUBROUTINE bldCov( nT, dS, dT, nPer, lSeaPre, & lSigUf, lInvSigUS, lInvSigUT, & lInvSigW, lInvSigWS, lInvSigWT, & vSeaAR, oSeaAR, vSeaMA, oSeaMA, & vTreAR, oTreAR, vTreMA, oTreMA, & vCycAR, oCycAR, vCycMA, oCycMA, & dDel, nDel, dDelS, nDelS, dDelT, nDelT, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & sSeaVar, sTreVar, sCycVar, sIrrVar, & mSigUS, nSigUS, mSigUT, nSigUT, mSigUI, nSigUI, & mSigWS, nSigWS, mSigWT, nSigWT, mSigW, nSigW, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigWf, nSigWf, mSigWfW, nSigWfW, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW ) c----------------------------------------------------------------------- c bldCov.f, Release 1, Subroutine Version 1.8, Modified 30 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 04 Apr 2005. c Modified by REG, on 15 Sep 2005, to change local variable sResult c from a non-dimensioned variable to a vector of size one. c Modified by REG, on 20 Sep 2005, to move calculation of sdSigAlt c to extSgnl(), and to correct tab stops. c Modified by REG, on 07 Nov 2005, to generalize structure of c irregular component, by adding mSigUI matrix; to modify c calculation of mSigWT and mSigWS; and to add cycle covariance c matrix to irregular covariance matrix, instead of to c trend covariance matrix. c Modified by REG, on 05 Jan 2006, to add logical c for inverting mSigW. c Modified by REG, on 20 Jan 2006, to optimze processing c by using diagonal form of mDel matrices. c Modified by REG, on 04 Apr 2006, to add calculation of c future covariance matrices for UT, W, and WT. c Modified by REG, on 27 Apr 2006, to handle special case c of no seasonal component. c Modified by REG, on 30 May 2006, to add generalized check c for no seasonal component processing. c----------------------------------------------------------------------- c This subroutine calculates the covariance matrices for differenced c trend and differenced seasonal. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dS i size of Seasonal Differencing c dT i size of Trend Differencing c lInvSigUS l logical when true to invert mSigUS c lInvSigUT l logical when true to invert mSigUT c lInvSigW l logical when true to invert mSigW c lInvSigWS l logical when true to invert mSigWS c lInvSigWT l logical when true to invert mSigWT c lSeaPre l logical indicating rpesence of seasonal component c lSigUf l logical to generate future covariance matrices c dDel d diagonal form of overall differencing matrix: mDel c dDelS d diagonal form of seasonal differencing matrix: mDelS c dDelT d diagonal form of trend differencing matrix: mDelT c mInvSigUS d contains inverse of mSigUS c mInvSigUT d contains inverse of mSigUT c mInvSigW d contains inverse of mSigW c mInvSigWS d contains inverse of mSigWS c mInvSigWT d contains inverse of mSigWT c dRedDelS d diagonal form of smaller version of mDelS c dRedDelT d diagonal form of smaller version of mDelT c mSigUI d covariance matrix for undifferenced irregular c mSigUS d covariance matrix for differenced seasonal c mSigUT d covariance matrix for differenced trend (UT) c mSigUTf d covariance matrix for future differenced trend (UTf) c mSigUTfUT d cross covariance matrix for (UTf,UT) c mSigW d covariance matrix for differenced data (W) c mSigWf d covariance matrix for future differenced data (Wf) c mSigWfW d cross covariance matrix for (Wf,W) c mSigWS d covariance matrix for differenced trend adjusted c mSigWT d covariance matrix for differenced seasonally adjusted (WT) c mSigWTf d covariance matrix for future WT (WTf) c mSigWTfWT d cross covariance matrix for (WTf,WT) c nDel i size (rows,columns) of mDel c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nInvSigUS i size (rows,columns) of mInvSigUS matrix c nInvSigUT i size (rows,columns) of mInvSigUT matrix c nInvSigW i size (rows,columns) of mInvSigW matrix c nInvSigWS i size (rows,columns) of mInvSigWS matrix c nInvSigWT i size (rows,columns) of mInvSigWT matrix c nPer i length of period asssociated with the seasonal component c nRedDelS i size (rows,columns) of mRedDelS c nRedDelT i size (rows,columns) of mRedDelT c nSigUI i size (rows,columns) of mSigUI matrix c nSigUS i size (rows,columns) of mSigUS matrix c nSigUT i size (rows,columns) of mSigUT matrix c nSigUTf i size (rows,columns) of mSigUTf matrix c nSigUTfUT i size (rows,columns) of mSigUTfUT matrix c nSigW i size (rows,columns) of mSigW matrix c nSigWf i size (rows,columns) of mSigWf matrix c nSigWfW i size (rows,columns) of mSigWfW matrix c nSigWS i size (rows,columns) of mSigWS matrix c nSigWT i size (rows,columns) of mSigWT matrix c nSigWTf i size (rows,columns) of mSigWTf matrix c nSigWTfWT i size (rows,columns) of mSigWTfWT matrix c nT i size of data available c oCycAR i max order of vCycAR polynomial c oCycAR i max order of vCycMA polynomial c oSeaMA i max order of vSeaAR polynomial c oSeaAR i max order of vSeaMA polynomial c oTreAR i max order of vTreAR polynomial c oTreMA i max order of vTreMA polynomial c sCycVar d cycle innovation variance c sIrrVar d irregular innovation variance c sSeaVar d seasonal innovation variance c sTreVar d trend innovation variance c vCycAR d AR polynomial vector for cycle component c vCycMA d MA polynomial vector for cycle component c vSeaAR d AR polynomial vector for seasonal component c vSeaMA d MA polynomial vector for seasonal component c vTreAR d AR polynomial vector for Trend component c vTreMA d MA polynomial vector for Trend component c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i i for index varable c ind1 i result indicator variable from GTWACF (1 = ok) c ind2 i result indicator variable from GTWACF (1 = ok) c ind3 i result indicator variable from GTWACF (1 = ok) c mPartA d temporary matrix used to calculate mSigW c mSigUC d covariance matrix for differenced cycle c mU d working covariance matrix for any component c including future elements c mW d local version of mSigW including future elements c mWT d local version of mSigWT including future elements c nFurDel i size (rows,columns) of future version of dDel c using full differencing c nFurDelS i size (rows,columns) of future version of dDelS c using trend differencing c nFurDelT i size (rows,columns) of future version of dDelT c using seasonal differencing c nForTDelT i size (rows,columns) of future version of dDelT c nLags i identifies maximum number of lags to calculate c nPartA i size (rows,columns) of mPartA matrix c nSave i identifies default size of large matrices c that are saved (not dynamic) c nSigUC i size (rows,columns) of mSigUC matrix c nU i size (rows,columns) of mU matrix c nW i size (rows,columns) of mW matrix c nWT i size (rows,columns) of mWT matrix c vCorC d vector of Cycle autocorrelations c vCorS d vector of Seasonal autocorrelations c vCorT d vector of Trend autocorrelations c vCovC d vector of Cycle autocovariances c vCovS d vector of Seasonal autocovariances c vCovT d vector of Trend autocovariances c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' LOGICAL lInvSigUS, lInvSigUT, lInvSigW, lInvSigWS, lInvSigWT, & lSeaPre, lSigUf INTEGER dS, dT, nPer, nT INTEGER oSeaAR, oSeaMA, oTreAR, oTreMA, oCycAR, oCycMA INTEGER nDel(2), nDelS(2), nDelT(2), nRedDelS(2), nRedDelT(2) INTEGER nSigUI(2), nSigUS(2), nSigUT(2) INTEGER nSigWS(2), nSigWT(2), nSigW(2) INTEGER nInvSigUS(2), nInvSigUT(2) INTEGER nInvSigWS(2), nInvSigWT(2), nInvSigW(2) INTEGER nSigUTf(2), nSigUTfUT(2), nSigWTf(2), nSigWTfWT(2) INTEGER nSigWf(2), nSigWfW(2) DOUBLE PRECISION sSeaVar, sTreVar, sCycVar, sIrrVar DOUBLE PRECISION vSeaAR(0:oSeaAR), vSeaMA(0:oSeaMA) DOUBLE PRECISION vTreAR(0:oTreAR), vTreMA(0:oTreMA) DOUBLE PRECISION vCycAR(0:oCycAR), vCycMA(0:oCycMA) DOUBLE PRECISION dDel(dS+dT+1), dDelS(dS+1), dDelT(dT+1), & dRedDelS(dS+1), dRedDelT(dT+1) c DOUBLE PRECISION mDel(nT-dS-dT,nT), mDelS(nT-dS,nT), c & mDelT(nT-dT,nT), mRedDelS(nT-dS-dT,nT-dT), c & mRedDelT(nT-dS-dT,nT-dS) DOUBLE PRECISION mSigUS(nT-dS,nT-dS), mSigUT(nT-dT,nT-dT), & mSigUI(nT,nT) DOUBLE PRECISION mSigWS(nT-dS,nT-dS), mSigWT(nT-dT,nT-dT), & mSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION mInvSigUS(nT-dS,nT-dS), mInvSigUT(nT-dT,nT-dT) DOUBLE PRECISION mInvSigWS(nT-dS,nT-dS), mInvSigWt(nT-dT,nT-dT), & mInvSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION mSigUTf(nPer,nPer), mSigUTfUT(nPer,nT-dT), & mSigWTf(nPer,nPer), mSigWTfWT(nPer,nT-dT), & mSigWf(nPer,nPer), mSigWfW(nPer,nT-dS-dT) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER ind1, ind2, ind3, i, nLags, ppqa, pp1 INTEGER nPartA(2), nSigUC(2), nU(2), nW(2), nWT(2) INTEGER nFurDel(2), nFurDelS(2), nFurDelT(2), nForTDelT(2) DOUBLE PRECISION vCovS(nT+nPer), vCorS(nT+nPer-1) DOUBLE PRECISION vCovT(nT+nPer), vCorT(nT+nPer-1) DOUBLE PRECISION vCovC(nT+nPer), vCorC(nT+nPer-1) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mPartA(nT-dS-dT,nT-dS-dT) c DOUBLE PRECISION mSigUC(nT,nT) c ------------------------------------------------------------------ INTEGER nSave,nSave2 PARAMETER ( nSave=POBS*POBS, nSave2=(POBS+12)*(POBS+12) ) DOUBLE PRECISION mPartA(nSave2), mSigUC(nSave2), & mU(nSave2), mW(nSave2), mWT(nSave2) SAVE mPartA, mSigUC, mU, mW, mWT c----------------------------------------------------------------------- c Initialize some size variables: for diagonal matrices, c and for working matrices mW and mWT. c----------------------------------------------------------------------- IF ( lSigUf ) THEN nLags = nT + nPer nFurDel(1) = nT + nPer - dS - dT nFurDel(2) = nT + nPer nFurDelS(1) = nT + nPer - dS - dT nFurDelS(2) = nT + nPer - dT nFurDelT(1) = nT + nPer - dS - dT nFurDelT(2) = nT + nPer - dS nForTDelT(1) = nT + nPer - dT nForTDelT(2) = nT + nPer ELSE nLags = nT END IF nW(1) = 0 nW(2) = 0 nWT(1) = 0 nWT(2) = 0 c----------------------------------------------------------------------- c Calculate seasonal, trend, and cycle auto covariance functions c----------------------------------------------------------------------- ppqa = max( oSeaAR, oSeaMA, nLags ) pp1 = max( oSeaAR, 1 ) CALL GTWACF( oSeaAR, oSeaMA, nLags, vSeaAR, vSeaMA, sSeaVar, & vCovS, vCorS, ind1, ppqa, pp1 ) ppqa = max( oTreAR, oTreMA, nLags ) pp1 = max( oTreAR, 1 ) CALL GTWACF( oTreAR, oTreMA, nLags, vTreAR, vTreMA, sTreVar, & vCovT, vCorT, ind2, ppqa, pp1 ) ppqa = max( oCycAR, oCycMA, nLags ) pp1 = max( oCycAR, 1 ) CALL GTWACF( oCycAR, oCycMA, nLags, vCycAR, vCycMA, sCycVar, & vCovC, vCorC, ind3, ppqa, pp1 ) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,1000)(vSeaAR(i),i=0,oSeaAR) c WRITE(6,1000)(vSeaMA(i),i=0,oSeaMA) c WRITE(6,1001)oSeaAR,oSeaMA,sSeaVar c WRITE(6,1000)(vCovS(i),i=1,nT) c WRITE(6,1001)nT,ind1 c1000 FORMAT( 300(1x,G12.5) ) c1001 FORMAT( 2(1x,I5), (1x,G12.5) ) c ------------------------------------------------------------------ c WRITE(6,1000)(vTreAR(i),i=0,oTreAR) c WRITE(6,1000)(vTreMA(i),i=0,oTreMA) c WRITE(6,1001)oTreAR,oTreMA,sTreVar c WRITE(6,1000)(vCovT(i),i=1,nT) c WRITE(6,1001)nT,ind2 c ------------------------------------------------------------------ c WRITE(6,1000)(vCycAR(i),i=0,oCycAR) c WRITE(6,1000)(vCycMA(i),i=0,oCycMA) c WRITE(6,1001)oCycAR,oCycMA,sCycVar c WRITE(6,1000)(vCovC(i),i=1,nT) c WRITE(6,1001)nT,ind3 c----------------------------------------------------------------------- c Calculate output covariance matrices c----------------------------------------------------------------------- c Get Toeplitz matrices for seasonal component c ------------------------------------------------------------------ IF (ind1 .eq. 0) THEN IF ( .not.lSigUf ) THEN CALL getTpltz( vCovS, nLags, nT-dS, mSigUS, nSigUS ) c ------------------------------------------------------------------ c If future covariance matrices required c then extract from overall covariance matrix c and initialize mW matrix c ------------------------------------------------------------------ ELSE CALL getTpltz( vCovS, nLags, nT-dS+nPer, mU, nU ) CALL getSMat( mU, nU, 1, nT-dS, mSigUS, nSigUS ) CALL mulQdMat( dDelT, nFurDelT, mU, nU, mW, nW ) END IF c ------------------------------------------------------------------ c Else error encountered when calculating autocovariances c for desired lags c ------------------------------------------------------------------ ELSE nSigUS(1) = 0 nSigUS(2) = 0 END IF c ------------------------------------------------------------------ c Get Toeplitz matrices for trend component c ------------------------------------------------------------------ IF (ind2 .eq. 0) THEN IF ( .not.lSigUf ) THEN CALL getTpltz( vCovT, nT, nT-dT, mSigUT, nSigUT ) c ------------------------------------------------------------------ c If future covariance matrices required c then extract from overall covariance matrix, c adjust mW matrix, and initialize mWT matrix c ------------------------------------------------------------------ ELSE CALL getTpltz( vCovT, nT+nPer, nT-dT+nPer, mU, nU ) CALL getSMat( mU, nU, 1, nT-dT, mSigUT, nSigUT ) CALL getSMat( mU, nU, nT-dT+1, nT-dT+nPer, mSigUTf, nSigUTf ) CALL getSRMat( mU, nU, nT-dT+1, nT-dT+nPer, 1, nT-dT, & mSigUTfUT, nSigUTfUT ) CALL mulQdMat( dDelS, nFurDelS, mU, nU, mPartA, nPartA ) CALL addMat( mPartA, nPartA, mW, nW, mW, nW ) CALL cpyMat( mU, nU, mWT, nWT ) END IF c ------------------------------------------------------------------ c Else error encountered when calculating autocovariances c for desired lags c ------------------------------------------------------------------ ELSE nSigUT(1) = 0 nSigUT(2) = 0 END IF c ------------------------------------------------------------------ c Get Toeplitz matrices for cycle component c ------------------------------------------------------------------ IF (ind3 .eq. 0) THEN CALL getTpltz( vCovC, nLags, nLags, mSigUC, nSigUC ) c ------------------------------------------------------------------ c Else error encountered when calculating autocovariances c for desired lags c ------------------------------------------------------------------ ELSE nSigUC(1) = 0 nSigUC(2) = 0 END IF c ------------------------------------------------------------------ c Get Toeplitz matrices for irregular component c ------------------------------------------------------------------ IF ( .not.lSigUf ) THEN CALL getIdM( nLags, mSigUI, nSigUI ) CALL mulSca( sIrrVar, mSigUI, nSigUI ) ELSE CALL getIdM( nLags, mU, nU ) CALL mulSca( sIrrVar, mU, nU ) END IF c ------------------------------------------------------------------ c Add mSigUC to mSigUI c ------------------------------------------------------------------ IF ( .not.lSigUf ) THEN CALL addMat( mSigUC, nSigUC, mSigUI, nSigUI, mSigUI, nSigUI ) c ------------------------------------------------------------------ c If future covariance matrices required c then adjust mW matrix and mWT matrix c ------------------------------------------------------------------ ELSE CALL addMat( mSigUC, nSigUC, mU, nU, mU, nU ) CALL getSMat( mU, nU, 1, nT, mSigUI, nSigUI ) CALL mulQdMat( dDel, nFurDel, mU, nU, mPartA, nPartA ) CALL addMat( mPartA, nPartA, mW, nW, mW, nW ) CALL mulQdMat( dDelT, nForTDelT, mU, nU, mPartA, nPartA ) CALL addMat( mPartA, nPartA, mWT, nWT, mWT, nWT ) END IF c ------------------------------------------------------------------ c Calculate mInvSigUS and mInvSigUT c ------------------------------------------------------------------ IF (lInvSigUS) THEN IF (lSeaPre) THEN CALL invMat( mSigUS, nSigUS, mInvSigUS, nInvSigUS ) ELSE CALL getIdM( nT, mInvSigUS, nInvSigUS ) CALL mulSca( ZERO, mInvSigUS, nInvSigUS ) END IF END IF c ------------------------------------------------------------------ IF (lInvSigUT) THEN CALL invMat( mSigUT, nSigUT, mInvSigUT, nInvSigUT ) END IF c ------------------------------------------------------------------ c Calculate mSigWS only if inverse needed. c ------------------------------------------------------------------ IF (lInvSigWS) THEN CALL mulQdMat( dDelS, nDelS, mSigUI, nSigUI, mSigWS, nSigWS ) CALL addMat( mSigUS, nSigUS, mSigWS, nSigWS, mSigWS, nSigWS ) CALL invMat( mSigWS, nSigWS, mInvSigWS, nInvSigWS ) END IF c ------------------------------------------------------------------ c Calculate mSigWT only if inverse needed. c ------------------------------------------------------------------ IF (lInvSigWT) THEN IF ( .not.lSigUf ) THEN CALL mulQdMat( dDelT, nDelT, mSigUI, nSigUI, mSigWT, nSigWT ) CALL addMat( mSigUT, nSigUT, mSigWT, nSigWT, mSigWT, nSigWT ) c ------------------------------------------------------------------ c If future covariance matrices required c then extract from overall covariance matrix mWT c ------------------------------------------------------------------ ELSE CALL getSMat( mWT, nWT, 1, nT-dT, mSigWT, nSigWT ) CALL getSMat( mWT, nWT, nT-dT+1, nT+nPer-dT, & mSigWTf, nSigWTf ) CALL getSRMat( mWT, nWT, nT-dT+1, nT+nPer-dT, 1, nT-dT, & mSigWTfWT, nSigWTfWT ) END IF CALL invMat( mSigWT, nSigWT, mInvSigWT, nInvSigWT ) END IF c ------------------------------------------------------------------ c Calculate mSigW only if inverse needed. c ------------------------------------------------------------------ IF (lInvSigW) THEN IF ( .not.lSigUf ) THEN CALL mulQdMat( dRedDelS, nRedDelS, mSigUT, nSigUT, & mSigW, nSigW ) CALL mulQdMat( dRedDelT, nRedDelT, mSigUS, nSigUS, & mPartA, nPartA ) CALL addMat( mPartA, nPartA, mSigW, nSigW, mSigW, nSigW ) CALL mulQdMat( dDel, nDel, mSigUI, nSigUI, mPartA, nPartA ) CALL addMat( mPartA, nPartA, mSigW, nSigW, mSigW, nSigW ) c ------------------------------------------------------------------ c If future covariance matrices required c then extract from overall covariance matrix mW c ------------------------------------------------------------------ ELSE CALL getSMat( mW, nW, 1, nT-dS-dT, mSigW, nSigW ) CALL getSMat( mW, nW, nT-dS-dT+1, nT+nPer-dS-dT, & mSigWf, nSigWf ) CALL getSRMat( mW, nW, nT-dS-dT+1, nT-dS-dT+nPer, & 1, nT-dS-dT, mSigWfW, nSigWfW ) END IF c ------------------------------------------------------------------ c Calculate inverse of mSigW c ------------------------------------------------------------------ CALL invMat( mSigW, nSigW, mInvSigW, nInvSigW ) END IF c ------------------------------------------------------------------ RETURN ENDblddif.f0000664006604000003110000002025214521201412011555 0ustar sun00315steps SUBROUTINE bldDif( dS, dT, nT, nPer, nDiff, vSeaD, oSeaD, & vTreD, oTreD, mDelS, dDelS, nDelS, & mDelT, dDelT, nDelT, & mRedDelS, dRedDelS, nRedDelS, & mRedDelT, dRedDelT, nRedDelT, & mDel, dDel, nDel ) c----------------------------------------------------------------------- c bldDif.f, Release 1, Subroutine Version 1.3, Modified 19 Jan 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 04 Apr 2005. c Modified by REG on 12 Sep 2005, to reverse order of difference c polynomials inserted into difference matrices. c Modified by REG on 19 Sep 2005, to correct tab stops. c Modified by REG on 19 Jan 2006, to optimize mDel processing, c and to utilize diagonal matrix representation. c----------------------------------------------------------------------- c This subroutine calculates the differencing matrices needed for c forming the reduced model filters. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dS i size of Seasonal Differencing c dT i size of Trend Differencing c dDel d diagonal representation for overall differencing matrix c dDelS d diagonal representation for seasonal differencing matrix c dDelT d diagonal representation for trend differencing matrix c mDel d overall differencing matrix c mDelS d seasonal differencing matrix c mDelT d trend differencing matrix c nDiff i vector of (d,D) differencing orders c nPer i size of seasonal period c mRedDelS d smaller version of mDelS c mRedDelT d smaller version of mDelT c nDel i size (rows,columns) of mDel c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nRedDelS i size (rows,columns) of mRedDelS c nRedDelT i size (rows,columns) of mRedDelT c oSeaD i max order of vSeaD polynomial c oTreD i max order of vTreD polynomial c nT i number of observations available c vSeaD d seasonal differencing polynomial of size nSeaD c vTreD d trend differencing polynomial of size vTreD c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c uS d seasonal differencing polynomial of length dS c uT d trend differencing polynomial of length dT+1 c ZERO d parameter variable c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER dS, dT, nT, oSeaD, oTreD INTEGER nDelS(2), nDelT(2), nDel(2), nDiff(2), nPer, & nRedDelS(2), nRedDelT(2) DOUBLE PRECISION vSeaD(oSeaD+1), vTreD(oTreD+1) DOUBLE PRECISION mDelS(nT-dS,nT), mDelT(nT-dT,nT), & mDel(nT-dS-dT,nT), mRedDelS(nT-dS-dT,nT-dT), & mRedDelT(nT-dS-dT,nT-dS) DOUBLE PRECISION dDel(dS+dT+1), dDelS(dS+1), dDelT(dT+1), & dRedDelS(dS+1), dRedDelT(dT+1) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, sFulD DOUBLE PRECISION uD(oSeaD+oTreD+1), uS(oSeaD+1), uT(oTreD+1), & vFulD(oSeaD+oTreD+1), ZERO PARAMETER (ZERO=0.0D0) c----------------------------------------------------------------------- c Create seasonal differencing polynomial. c----------------------------------------------------------------------- DO j = 1, oSeaD+1 uS(j) = vSeaD(oSead+2-j) END DO c ------------------------------------------------------------------ c Create seasonal differencing matrix (full and diagonal forms) c ------------------------------------------------------------------ nDelS(1) = nT - dS nDelS(2) = nT DO j= 1, nDelS(2) DO i = 1, nDelS(1) mDelS( i, j ) = ZERO END DO END DO DO i = 1, nDelS(1) DO j = 1, dS+1 mDelS( i, i+j-1 ) = uS(j) END DO END DO c ------------------------------------------------------------------ DO j = 1, dS+1 dDelS(j) = mDelS(1,j) END DO c ------------------------------------------------------------------ c Create reduced seasonal differencing matrix c (full and diagonal forms) c ------------------------------------------------------------------ nRedDelS(1) = nT - dS - dT nRedDelS(2) = nT - dT DO j = 1, nRedDelS(2) DO i = 1, nRedDelS(1) mRedDelS( i, j ) = mDelS( i, j ) END DO END DO c ------------------------------------------------------------------ DO j = 1, dS+1 dRedDelS(j) = mRedDelS(1,j) END DO c----------------------------------------------------------------------- c Create trend differencing polynomial. c----------------------------------------------------------------------- DO j = 1, oTreD+1 uT(j) = vTreD(oTreD+2-j) END DO c ------------------------------------------------------------------ c Create trend differencing matrix (full and diagonal forms). c ------------------------------------------------------------------ nDelT(1) = nT - dT nDelT(2) = nT DO j= 1, nDelT(2) DO i = 1, nDelT(1) mDelT( i, j ) = ZERO END DO END DO DO i = 1, nDelT(1) DO j = 1, min(3,dT+1) mDelT( i, i+j-1 ) = uT(j) END DO END DO c ------------------------------------------------------------------ DO j = 1, dT+1 dDelT(j) = mDelT(1,j) END DO c ------------------------------------------------------------------ c Create reduced trend differencing matrix (full and diagonal forms). c ------------------------------------------------------------------ nRedDelT(1) = nT - dS - dT nRedDelT(2) = nT - dS DO j = 1, nRedDelT(2) DO i = 1, nRedDelT(1) mRedDelT( i, j ) = mDelT( i, j ) END DO END DO c ------------------------------------------------------------------ DO j = 1, dT+1 dRedDelT(j) = mRedDelT(1,j) END DO c----------------------------------------------------------------------- c Create full differencing polynomial. c----------------------------------------------------------------------- CALL CONV( vSeaD, oSeaD+1, vTreD, oTreD+1, vFulD, sFulD ) DO j = 1, sFulD uD(j) = vFulD(sFulD+1-j) END DO c ------------------------------------------------------------------ c Create full differencing matrix. Could use product of reduced c seasonal differencing matrix and trend differencing matrix or c vice versa using either of two different matrix multiplcations. c Instead for optimization reasons, use polynomial calculated above. c ------------------------------------------------------------------ c CALL mulMat( mRedDelT, nRedDelT, mDelS, nDelS, mDel, nDel ) c CALL mulMat( mRedDelS, nRedDelS, mDelT, nDelT, mDel, nDel ) c ------------------------------------------------------------------ nDel(1) = nT - dS - dT nDel(2) = nT DO j= 1, nDel(2) DO i = 1, nDel(1) mDel( i, j ) = ZERO END DO END DO DO i = 1, nDel(1) DO j = 1, sFulD mDel( i, i+j-1 ) = uD(j) END DO END DO c ------------------------------------------------------------------ DO j = 1, dS+dT+1 dDel(j) = mDel(1,j) END DO c ------------------------------------------------------------------ RETURN ENDbrkdsp.prm0000664006604000003110000000141014521201412012162 0ustar sun00315stepsc----------------------------------------------------------------------- c pointer for tables, access codes c----------------------------------------------------------------------- c BRKDSP, BRKDS2 = c table number where break in the table dictionary occurs c this is done to keep the length of the table dictionaries c under 2000 characters, a requirement for the VAX/VMS c FORTRAN c----------------------------------------------------------------------- INTEGER BRKDSP PARAMETER (BRKDSP=86) c----------------------------------------------------------------------- INTEGER BRKDS2 PARAMETER (BRKDS2=232) c----------------------------------------------------------------------- bstget.f0000664006604000003110000000776714521201412011641 0ustar sun00315stepsC Last change: BCM 3 Dec 97 11:53 am SUBROUTINE bstget(Nbstds,Bstdsn) IMPLICIT NONE c----------------------------------------------------------------------- c Routine which loads the best model found by the automatic c ARIMA modelling routine from temporary storage variables into c their correct locations. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'bstmdl.cmn' c----------------------------------------------------------------------- INTEGER Nbstds,i,ilag,endlag CHARACTER Bstdsn*(132) c----------------------------------------------------------------------- c Initialize ARIMA modeling variables c----------------------------------------------------------------------- CALL setlg(.false.,PARIMA,Arimaf) CALL setint(0,PARIMA,Arimal) CALL setint(0,POPR,Oprfac) c Bob Fay CALL setdp(0.D0,PB,B) CALL setdp(0.D0,PARIMA,Arimap) CALL intlst(POPR,Opr,Nopr) CALL intlst(POPR,Oprptr,Noprtl) CALL intlst(3*PMDL,Mdl,Nmdl) Mdl(AR)=1 Mdl(MA)=1 CALL setchr(' ',POPRCR*POPR,Oprttl) c----------------------------------------------------------------------- c Copy temporary storage variables containing best model into c current model variables. c----------------------------------------------------------------------- CALL cpyint(Bsto(0),POPR+1,1,Opr(0)) CALL cpyint(Bstopt(0),POPR+1,1,Oprptr(0)) CALL cpyint(Bstofc,POPR,1,Oprfac) CALL cpyint(Bstm(0),3*PMDL+1,1,Mdl(0)) CALL copy(Bstap,PARIMA,1,Arimap) CALL copy(Bstb,PB,1,B) CALL copylg(Bstafx,PARIMA,1,Arimaf) CALL cpyint(Bstalg,PARIMA,1,Arimal) Lseadf=Bstsdf Oprttl=Bstot Nopr=Bstno Noprtl=Bstnot Nmdl=Bstnm Mdldsn(1:Nbstds)=Bstdsn(1:Nbstds) Nnsedf=Bnsedf Nseadf=Bseadf Nmddcr=Nbstds c----------------------------------------------------------------------- Ngrp=Bstngr Ngrptl=Bsngrt Ncxy=Bsncxy Nb=Bstnb Ncoltl=Bstnct Colttl=Bstctl Grpttl=Bstgtl CALL cpyint(Bclptr(0),PB+1,1,Colptr(0)) CALL cpyint(Bstgrp(0),PGRP+1,1,Grp(0)) CALL cpyint(Bsgptr(0),PGRP+1,1,Grpptr(0)) CALL cpyint(Bstrgv,PB,1,Rgvrtp) c----------------------------------------------------------------------- c Clear model parameters so estimation of the model parameters c will begin from scratch c----------------------------------------------------------------------- DO i=1,Nb B(i)=DNOTST END DO IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=DNOTST END DO END IF c----------------------------------------------------------------------- c Compute maximum lags for best model c----------------------------------------------------------------------- CALL maxlag(Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1,Mxdflg) CALL maxlag(Arimal,Opr,Mdl(AR-1),Mdl(AR)-1,Mxarlg) CALL maxlag(Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,Mxmalg) c----------------------------------------------------------------------- c Compute the number of effective observations and initialize |G'G| c----------------------------------------------------------------------- Lar=Lextar.and.Mxarlg.gt.0 Lma=Lextma.and.Mxmalg.gt.0 c ------------------------------------------------------------------ IF(Lextar)THEN Nintvl=Mxdflg Nextvl=Mxarlg+Mxmalg c ------------------------------------------------------------------ ELSE Nintvl=Mxdflg+Mxarlg c ------------------------------------------------------------------ Nextvl=0 IF(Lextma)Nextvl=Mxmalg END IF c----------------------------------------------------------------------- RETURN END bstmdl.cmn0000664006604000003110000000227214521201412012150 0ustar sun00315stepsc----------------------------------------------------------------------- c Model variables for the "best" model found by the automatic model c selection procedure c----------------------------------------------------------------------- LOGICAL Bstsdf,Bstafx DOUBLE PRECISION Bstap,Bstb INTEGER Bstalg,Bstm,Bsto,Bstofc,Bstopt,Bstno,Bstnot,Bstnm, & Bnsedf,Bseadf,Bstngr,Bsngrt,Bsncxy,Bstnb,Bstnct,Bclptr, & Bstgrp,Bsgptr,Bstrgv CHARACTER Bstctl*(PCOLCR*PB),Bstgtl*(PGRPCR*PGRP), & Bstot*(POPRCR*POPR) c----------------------------------------------------------------------- DIMENSION Bstap(PARIMA),Bstb(PB),Bstafx(PARIMA),Bstalg(PARIMA), & Bstm(0:3*PMDL),Bsto(0:POPR),Bstofc(POPR),Bstopt(0:POPR), & Bclptr(0:PB),Bstgrp(0:PGRP),Bsgptr(0:PGRP),Bstrgv(PB) c----------------------------------------------------------------------- COMMON /bstcmn/ Bstap,Bstb,Bstalg,Bstm,Bsto,Bstofc,Bstopt,Bstno, & Bstnot,Bstnm,Bnsedf,Bseadf,Bstngr,Bsngrt,Bsncxy, & Bstnb,Bstnct,Bclptr,Bstgrp,Bsgptr,Bstrgv,Bstsdf, & Bstafx,Bstctl,Bstgtl,Bstot bstmdl.f0000664006604000003110000000502214521201412011614 0ustar sun00315stepsC Last change: BCM 2 Apr 98 12:55 pm SUBROUTINE bstmdl(Nbstds,Bstdsn,Bstptd) IMPLICIT NONE c----------------------------------------------------------------------- c Routine which either stores best model found by the automatic c ARIMA modelling routine into temporary storage variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'bstmdl.cmn' c----------------------------------------------------------------------- LOGICAL Bstptd INTEGER Nbstds CHARACTER Bstdsn*(132) c----------------------------------------------------------------------- c Initialize temporary storage variables c----------------------------------------------------------------------- CALL setlg(.false.,PARIMA,Bstafx) CALL setint(0,PARIMA,Bstalg) CALL setint(0,POPR,Bstofc) CALL setdp(0D0,PB,Bstb) CALL setdp(0D0,PARIMA,Bstap) CALL intlst(POPR,Bsto,Bstno) CALL intlst(POPR,Bstopt,Bstnot) CALL intlst(3*PMDL,Bstm,Bstnm) Bstm(AR)=1 Bstm(MA)=1 CALL setchr(' ',POPRCR*POPR,Bstot) CALL setchr(' ',132,Bstdsn) c----------------------------------------------------------------------- c Copy current model variables into temporary storage variables. c----------------------------------------------------------------------- CALL cpyint(Opr(0),POPR+1,1,Bsto(0)) CALL cpyint(Oprptr(0),POPR+1,1,Bstopt(0)) CALL cpyint(Oprfac,POPR,1,Bstofc) CALL cpyint(Mdl(0),3*PMDL+1,1,Bstm(0)) CALL copy(Arimap,PARIMA,1,Bstap) CALL copy(B,PB,1,Bstb) CALL copylg(Arimaf,PARIMA,1,Bstafx) CALL cpyint(Arimal,PARIMA,1,Bstalg) Bstsdf=Lseadf Bstot=Oprttl Bstno=Nopr Bstnot=Noprtl Bstnm=Nmdl Bstdsn(1:Nmddcr)=Mdldsn(1:Nmddcr) Bnsedf=Nnsedf Bseadf=Nseadf Nbstds=Nmddcr Bstptd=Picktd c----------------------------------------------------------------------- Bstngr=Ngrp Bsngrt=Ngrptl Bsncxy=Ncxy Bstnb=Nb Bstnct=Ncoltl Bstctl=Colttl Bstgtl=Grpttl CALL cpyint(Colptr(0),PB+1,1,Bclptr(0)) CALL cpyint(Grp(0),PGRP+1,1,Bstgrp(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Bsgptr(0)) CALL cpyint(Rgvrtp,PB,1,Bstrgv) c----------------------------------------------------------------------- RETURN END btrit.f0000664006604000003110000001564314521201413011466 0ustar sun00315stepsC Last change: BCM 20 May 1998 11:27 am **==btrit.f processed by SPAG 4.03F at 14:07 on 24 Aug 1994 SUBROUTINE btrit(Nyearz,Nopt,No2,Iagr,Ext,Eststr,Nstr,Cpobs, & Lrange,Ssdiff,Lp,Ls) IMPLICIT NONE c----------------------------------------------------------------------- C ***** PRINTS OUT SUMMARY BREAKDOWN TABLES FOR TOTAL, MONTHS, YEARS. C ***** CALCULATES PERCENTAGE OF MONTHS FLAGGED (FPER), PERCENTAGE OF C ***** MONTHS WITH CHANGE IN DIRECTION (SPER), PERCENTAGE OF MONTHS C ***** WITH CHANGE OF DIRECTION THAT WERE FLAGGED (SFPER). c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'ssap.cmn' INCLUDE 'sspvec.cmn' c----------------------------------------------------------------------- LOGICAL Ls,Lp,Lrange,Ssdiff CHARACTER Eststr*(45),Ext*(2),Cpobs*(9),fmt*(35) INTEGER Iagr,ij,iy,j,j1,Nstr,next,No2,Nopt,Nyearz,lfmt,nfmt DIMENSION Cpobs(20) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c---------------------------------------------------------------------- IF(.not.(Lp.or.Ls))RETURN c---------------------------------------------------------------------- c Set number of nonblank characters in Ext c---------------------------------------------------------------------- next=1 IF(Iagr.eq.6)next=2 c---------------------------------------------------------------------- c Print out table header c---------------------------------------------------------------------- IF(Lp)THEN IF(Ssdiff)THEN IF(Lwdprt)THEN WRITE(Mt1,1005)Ext,Eststr(1:Nstr),Serno(1:Nser) 1005 FORMAT(' S 3.',a2,' Breakdown of Average Maximum Absolute ', & 'Differences across spans for ',a,/,10x,'of ',a,'.',/) ELSE WRITE(Mt1,1006)Ext,Eststr(1:Nstr),Serno(1:Nser) 1006 FORMAT(' S 3.',a2,' Breakdown of the Average Maximum ', & 'Absolute Differences across spans for ',/,10x,a,' of ', & a,'.',/) END IF ELSE IF(Lrange)THEN IF(Lwdprt)THEN WRITE(Mt1,1010)Ext,Eststr(1:Nstr),Eststr(1:Nstr),Serno(1:Nser) 1010 FORMAT(/,' S 3.',a2,' Breakdowns of unstable ',a, & ' and Average Maximum Percent Differences', & /,10x,'across spans for ',a,' of ',a,'.',/) ELSE WRITE(Mt1,1011)Ext,Eststr(1:Nstr),Eststr(1:Nstr),Serno(1:Nser) 1011 FORMAT(/,' S 3.',a2,' Breakdowns of unstable ',a,/,10x, & 'and Average Maximum Percent Differences across ', & 'spans for ',/,10x,a,' of ',a,'.',/) END IF ELSE IF(Lwdprt)THEN WRITE(Mt1,1015)Ext,Eststr(1:Nstr),Serno(1:Nser) 1015 FORMAT(' S 3.',a2,' Breakdown of Average Maximum Percent ', & 'Differences across spans for ',a,/,10x,'of ',a,'.',/) ELSE WRITE(Mt1,1016)Ext,Eststr(1:Nstr),Serno(1:Nser) 1016 FORMAT(' S 3.',a2,' Breakdown of the Average Maximum ', & 'Percent Differences across spans for ',/,10x,a,' of ', & a,'.',/) END IF END IF IF(Iagr.eq.6)WRITE(Mt1,1020) 1020 FORMAT(10x,'Indirect seasonal adjustment',/) END IF c---------------------------------------------------------------------- c Print out summaries for each period and year c---------------------------------------------------------------------- ij=Icyr-Iyr IF(Icyr.eq.Iyr)THEN IF(No2.eq.3)ij=ij+1 IF((No2.eq.1.or.No2.eq.2).and.Im.eq.Nsea)ij=ij+1 END IF c---------------------------------------------------------------------- IF(Lp)THEN IF(Aobsmx(Nopt).lt.1000D0)THEN IF((.not.Ssdiff).and.Lrange)THEN fmt='(10X,A9,A3,I3,5X,A8,F5.1,a)' nfmt=27 ELSE fmt='(10X,A9,A3,F6.2)' nfmt=16 END IF ELSE lfmt=idint(dlog10(Aobsmx(Nopt)))+1 IF((.not.Ssdiff).and.Lrange)THEN fmt='(10X,A9,A3,I3,5X,A8,F' nfmt=22 CALL itoc(lfmt+2,fmt,nfmt) fmt(nfmt:(nfmt+4))='.1,a)' nfmt=nfmt+4 ELSE fmt='(10X,A9,A3,F' nfmt=13 CALL itoc(lfmt+3,fmt,nfmt) fmt(nfmt:(nfmt+2))='.2)' nfmt=nfmt+2 END IF END IF j1=0 IF(Nsea.eq.4)j1=12 DO j=1,Nsea IF((.not.Ssdiff).and.Lrange)THEN WRITE(Mt1,fmt(1:nfmt))Cpobs(j+j1),' : ',SSnobs(j,Nopt), & '(AMPD = ',Aobs(j,Nopt),')' ELSE WRITE(Mt1,fmt(1:nfmt))Cpobs(j+j1),' : ',Aobs(j,Nopt) END IF END DO WRITE(Mt1,1040) 1040 FORMAT(/) IF(Ayrmx(Nopt).lt.1000D0)THEN IF((.not.Ssdiff).and.Lrange)THEN fmt='(10X,I4,5X,A3,I3,5X,A8,F5.1,a)' nfmt=30 ELSE fmt='(10X,I4,5X,A3,F6.2)' nfmt=19 END IF ELSE lfmt=idint(dlog10(Ayrmx(Nopt)))+1 IF((.not.Ssdiff).and.Lrange)THEN fmt='(10X,I4,5X,A3,I3,5X,A8,F' nfmt=25 CALL itoc(lfmt+2,fmt,nfmt) fmt(nfmt:(nfmt+4))='.1,a)' nfmt=nfmt+4 ELSE fmt='(10X,I4,5X,A3,F' nfmt=16 CALL itoc(lfmt+3,fmt,nfmt) fmt(nfmt:(nfmt+2))='.2)' nfmt=nfmt+2 END IF END IF DO j=ij,Nyearz iy=Iyr+j IF((.not.Ssdiff).and.Lrange)THEN WRITE(Mt1,fmt(1:nfmt))iy,' : ',SSnyr(j,Nopt),'(AMPD = ', & Ayr(j,Nopt),')' ELSE WRITE(Mt1,fmt(1:nfmt))iy,' : ',Ayr(j,Nopt) END IF END DO c IF(Lrange)WRITE(Mt1,1060) c 1060 FORMAT(/,' AMPD = Average Maximum Percentage Difference') END IF c---------------------------------------------------------------------- c Save summaries for each period and year c---------------------------------------------------------------------- IF(Ls)THEN j1=0 IF(Nsea.eq.4)j1=16 DO j=1,Nsea IF((.not.Ssdiff).and.Lrange)THEN WRITE(Nform,1070)Ext(1:next),j,Cpobs(j+j1)(1:3),SSnobs(j,Nopt), & Aobs(j,Nopt) ELSE WRITE(Nform,1070)Ext(1:next),j,Cpobs(j+j1)(1:3),0,Aobs(j,Nopt) END IF 1070 FORMAT('s3.',a,'.brk.p',i2.2,': ',A3,1x,I3,2X,E17.10) END DO DO j=ij,Nyearz iy=Iyr+j IF((.not.Ssdiff).and.Lrange)THEN WRITE(Nform,1080)Ext(1:next),j,iy,SSnyr(j,Nopt),Ayr(j,Nopt) ELSE WRITE(Nform,1080)Ext(1:next),j,iy,0,Ayr(j,Nopt) END IF 1080 FORMAT('s3.',a,'.brk.y',i2.2,': ',I4,1x,I3,2X,E17.10) END DO END IF c---------------------------------------------------------------------- RETURN END buffers.i0000664006604000003110000000007514521201413011772 0ustar sun00315stepsC... character buffS*80 common /bufferS/ buffSBuild.comp.i0000664006604000003110000000030014521201413012321 0ustar sun00315steps character Revision*4 character Build*19 character compdate*100 Revision='341' Build='2010/04/29 15:58:30' compdate='Revision: '//Revision//' Build: ' // Build build.i0000664006604000003110000000031714521201413011434 0ustar sun00315steps character Revision*4 character Build*19 character compdate*100 Revision='657' Build='2012/11/28 12:09:23' compdate='Revision: '//Revision//' Build: ' // Build build.prm0000664006604000003110000000055514521201413012006 0ustar sun00315stepsc----------------------------------------------------------------------- c Contains text with build number for current working version of c X-12-ARIMA c!---------------------------------------------------------------------- CHARACTER*2 BUILD parameter (BUILD='61') c!---------------------------------------------------------------------- calc.i0000664006604000003110000000056314521201413011242 0ustar sun00315stepsC C... Variables in Common Block /calc/ ... integer TYPE,P,D,Q,BP,BD,BQ,PBP,PQ,NW,INIT,BPQ,IMEAN,IPR real*8 DETPRI real*8 Wd(MPKP),PHI(3*N1),TH(3*N1),BPHI(3*N1),BTH(3*N1), $ PHIST(2*N12+3*N1),THSTAR(40) common /calc/ Wd,PHI,TH,BPHI,BTH,PHIST,THSTAR,DETPRI,TYPE,P,D,Q, $ BP,BD,BQ,PBP,PQ,NW,INIT,BPQ,IMEAN,IPR calcqs2.f0000664006604000003110000000301214521201413011655 0ustar sun00315stepsc cc subroutine calcQS2(Z,nz,mq,QS,PosCorr) C C THIS SUBROUTINE CALCULATES THE PIERCE QS STATISTIC OF THE C Z SERIES C NZ : NUMBER OF OBSERVATIONS OF THE SERIES C C.. Implicits .. implicit none C C.. Parameters .. integer n10 parameter (n10 = 10) C C.. Input parameters integer nz,mq real*8 z(*) C C.. Output parameters real*8 QS integer PosCorr C C.. Local Scalars .. integer i,j,k,nr real*8 c0 C C.. Local Arrays .. real*8 c(5*n10), r(24) C ... Executable Statements ... c0 = 0.0d0 do i = 1,nz c0 = c0 + z(i)*z(i) end do c0 = c0 / nz nr=MQ+MQ do k = 1,nr c(k) = 0.0d0 j = k + 1 do i = j,nz c(k) = c(k) + z(i)*z(i-k) end do c(k) = c(k) / nz r(k) = c(k) / c0 end do posCorr=1 if (mq.gt.4) then if (r(mq).le.0.0d0) then posCorr=0 else do i=1,4 if (r(i).le.0.0d0) then posCorr=0 endif enddo endif else do i=1,mq if (r(i).le.0.2d0) then posCorr=0 endif enddo endif QS = 0.0d0 if (mq.ne.1 .and. r(mq).gt.0.0d0) then do j = 1,2 k = j * mq if (r(k).gt.0) then QS = QS + (r(k)*r(k))/(nz-k) end if end do QS = QS * nz * (nz+2) end if return end c calcqs.f0000664006604000003110000000227214521201413011602 0ustar sun00315stepsc cc real*8 function calcQS(Z,Iconce,nz,mq) C C THIS SUBROUTINE CALCULATES THE PIERCE QS STATISTIC OF THE C Z(Iconce+1:nz) SERIES C NZ : NUMBER OF OBSERVATIONS OF THE SERIES C C.. Implicits .. implicit none C C.. Parameters .. integer n10 parameter (n10 = 10) C C.. Formal Arguments .. integer Iconce,nz,mq real*8 z(*) C C.. Local Scalars .. integer i,j,k,nr real*8 c0,QS C C.. Local Arrays .. real*8 c(2), r(2) c r(1):autocorr(mq), r(2):autocorr(2*mq) C ... Executable Statements ... c0 = 0.0d0 nr=nz-Iconce do i = Iconce+1,nz c0 = c0 + z(i)*z(i) end do c0 = c0 / nr do k = 1,2 c(k) = 0.0d0 j = k*mq + 1+ICONCE do i = j,nz c(k) = c(k) + z(i)*z(i-k*mq) end do c(k) = c(k) / nr r(k) = c(k) / c0 end do QS = 0.0d0 if (mq.ne.1 .and. r(1).gt.0.0d0) then do k = 1,2 if (r(k).gt.0) then QS = QS + (r(k)*r(k))/(nr-k*mq) end if end do QS = QS * nr * (nr+2) end if calcQS=QS return end c calcsc.f0000664006604000003110000000435214521201413011565 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:45 pm SUBROUTINE calcsc(Type) IMPLICIT NONE C ********************************************************************** C * * C * THIS ROUTINE CALCULATES SCALAR QUANTITIES USED TO COMPUTE THE NEXT * C * K POLYNOMIAL AND NEW ESTIMATES OF THE QUADRATIC COEFFICIENTS. * C * TYPE - INTEGER VARIABLE SET HERE INDICATING HOW THE * C * CALCULATIONS ARE NORMALIZED TO AVOID OVERFLOW * C * * C ********************************************************************** INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'global.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION dabs INTEGER Type C----------------------------------------------------------------------- C SYNTHETIC DIVISION OF K BY THE QUADRATIC 1,U,V0 C----------------------------------------------------------------------- CALL quadsd(N,U,V0,K,Qk,C,D0) IF(dabs(C).le.dabs(K(N))*100D0*Eta)THEN IF(dabs(D0).le.dabs(K(N-1))*100D0*Eta)THEN Type=3 C----------------------------------------------------------------------- C TYPE=3 INDICATES THE QUADRATIC IS ALMOST A FACTOR OF K C----------------------------------------------------------------------- RETURN END IF END IF IF(dabs(D0).ge.dabs(C))THEN Type=2 C----------------------------------------------------------------------- C TYPE=2 INDICATES THAT ALL FORMULAS ARE DIVIDED BY D C----------------------------------------------------------------------- E=A0/D0 F=C/D0 G=U*B0 H=V0*B0 A3=(A0+G)*E+H*(B0/D0) A1=B0*F-A0 A7=(F+U)*A0+H RETURN END IF Type=1 C----------------------------------------------------------------------- C TYPE=1 INDICATES THAT ALL FORMULAS ARE DIVIDED BY C C----------------------------------------------------------------------- E=A0/C F=D0/C G=U*E H=V0*B0 A3=A0*E+(H/C+G)*B0 A1=B0-A0*(D0/C) A7=A0+G*D0+H*F RETURN END calfor.i0000664006604000003110000000016614521201414011606 0ustar sun00315stepsC C... Variables in Common Block /calfor/ ... integer PSTAR,QSTAR,MQ common /calfor/ PSTAR,QSTAR,MQ calshr.i0000664006604000003110000000014214521201414011606 0ustar sun00315stepsC C... Variables in Common Block /calshr/ ... integer IFAC common /calshr/ IFAC cchars.i0000664006604000003110000000012414521201414011575 0ustar sun00315steps CHARACTER*1 CHREOF,NEWLIN,TABCHR COMMON /cchars/ CHREOF,NEWLIN,TABCHR ceilng.f0000664006604000003110000000103314521201414011570 0ustar sun00315stepsC Last change: BCM 24 Aug 2001 11:38 am C JK 4 Mar 2009 4:43 pm STATCAN DOUBLE PRECISION FUNCTION ceilng(X) IMPLICIT NONE c ------------------------------------------------------------------- DOUBLE PRECISION X INTEGER*8 y c ------------------------------------------------------------------- y=X ceilng=dble(y) IF(X.gt.ceilng)ceilng=ceilng+1 c ------------------------------------------------------------------- RETURN END change.f0000664006604000003110000000224014521201414011555 0ustar sun00315steps SUBROUTINE change(X,Y,Ib,Ie) IMPLICIT NONE c ------------------------------------------------------------------ c --- this subroutine calculates the percent changes (differences) in c --- x and stores them in y. c ------------------------------------------------------------------ c Set Gudval in separate routine - BCM March 2006 c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'x11opt.cmn' INCLUDE 'goodob.cmn' c----------------------------------------------------------------------- INTEGER i,Ib,Ie DOUBLE PRECISION X,Y DIMENSION X(PLEN),Y(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ IF(Muladd.ne.1)THEN DO i=Ib,Ie IF(Gudval(i-1))THEN Y(i)=(X(i)-X(i-1))/X(i-1) ELSE Y(i)=DNOTST END IF END DO RETURN END IF DO i=Ib,Ie Y(i)=X(i)-X(i-1) END DO RETURN END chisq.f0000664006604000003110000000377114521201414011451 0ustar sun00315steps**==chisq.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 DOUBLE PRECISION FUNCTION chisq(X,N) c----------------------------------------------------------------------- c This function calculates chi-squared probability levels for c pr( chi-sq. r.v. with n degrees of freedom > x ). c----------------------------------------------------------------------- c This function/subroutine was developed by Statistics Canada. c We thank them for permission to use it here. c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION C,c1,c2,c3,y,X,gauss INTEGER N,i,m EXTERNAL gauss PARAMETER(C=0.797884560802864D0) c----------------------------------------------------------------------- IF(X.le.0D0)THEN chisq=1D0 RETURN c----------------------------------------------------------------------- ELSE IF(X.lt.90D0)THEN c1=1.0D0 c2=c1 c3=0.0D0 y=dble(X) m=N/2 i=m*2-N c----------------------------------------------------------------------- IF(i.eq.0)THEN y=y/2.0D0 c----------------------------------------------------------------------- IF(m.ne.1)THEN m=m-1 DO i=1,m c2=c2*y/i c1=c1+c2 END DO END IF c----------------------------------------------------------------------- ELSE IF(m.ne.0)THEN DO i=1,m c1=c1*y/c2 c3=c3+c1 c2=c2+2.0D0 END DO END IF c----------------------------------------------------------------------- c2=dsqrt(y) chisq=1.0D0-gauss(c2)+C*c3*dexp(-y/2.0D0)/c2 RETURN END IF c----------------------------------------------------------------------- ELSE chisq=0.0D0 RETURN END IF chisq=c1*dexp(-y) c----------------------------------------------------------------------- RETURN END chitst.f0000664006604000003110000000457614521201414011644 0ustar sun00315stepsC Last change: BCM 28 May 1998 9:26 am SUBROUTINE chitst(Xpxinv,Begcol,Endcol,Chi2vl,Pv,Regidx,Is1grp, & Info) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'mdldat.cmn' c----------------------------------------------------------------------- INCLUDE 'units.cmn' c----------------------------------------------------------------------- c replace dimension length for Xpxinv (BCM May 2007) LOGICAL Is1grp INTEGER Begcol,coldsp,Endcol,icol,ielt,Info,irow,ncol,Regidx,jcol, & jelt,kelt,lstcol,nnfix,fstcol,kcol DOUBLE PRECISION chisq,Chi2vl,Pv,rhs,subinv,Xpxinv DIMENSION rhs(PB),subinv(PB*(PB+1)),Xpxinv(PXPX),Regidx(PB) EXTERNAL chisq c----------------------------------------------------------------------- c Compute chi square values for variables [begcol:endcol] c----------------------------------------------------------------------- ncol=0 ielt=1 jelt=NOTSET c----------------------------------------------------------------------- DO icol=Begcol,Endcol IF(Regidx(icol).ne.NOTSET)lstcol=icol END DO c----------------------------------------------------------------------- DO icol=Begcol,Endcol IF(Regidx(icol).ne.NOTSET)THEN ncol=ncol+1 IF(jelt.eq.NOTSET)jelt=Regidx(icol) rhs(ncol)=B(icol) coldsp=(Regidx(icol)-1)*Regidx(icol)/2 nnfix=0 c----------------------------------------------------------------------- DO irow=jelt,lstcol IF(Is1grp.or.Regidx(irow).ne.NOTSET)THEN nnfix=nnfix+1 IF(nnfix.le.ncol)THEN subinv(ielt)=Xpxinv(coldsp+nnfix+jelt-1) ielt=ielt+1 END IF END IF END DO c----------------------------------------------------------------------- END IF END DO c----------------------------------------------------------------------- CALL dppfa(subinv,ncol,Info) IF(Info.eq.0)THEN CALL dppsl(subinv,ncol,rhs,.true.) CALL yprmy(rhs,ncol,Chi2vl) Chi2vl=Chi2vl/Var Pv=chisq(Chi2vl,ncol) END IF c----------------------------------------------------------------------- RETURN END chkadj.f0000664006604000003110000002332114521201414011557 0ustar sun00315steps SUBROUTINE chkadj(Ntd,Khol,Lseats,Lam) IMPLICIT NONE c ------------------------------------------------------------------ c This routine checks to see if Adj and Fin variables need to be c updated by seeing which types of regression effects are present c in the regression. c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ INTEGER nusr,nsea,iusr,icol,rtype,Ntd,Khol,ncyc LOGICAL Lseats DOUBLE PRECISION Lam c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- IF(Adjhol.lt.0.and.Finhol)Finhol=F IF(Adjusr.lt.0.and.Finusr)Finusr=F IF(Adjao.lt.0.and.Finao)Finao=F IF(Adjls.lt.0.and.Finls)Finls=F IF(Adjtc.lt.0.and.Fintc)Fintc=F c----------------------------------------------------------------------- IF(.not.(Adjtd.ge.0.or.Adjhol.ge.0.or.Adjao.ge.0.or.Adjls.ge.0.or. & Adjtc.ge.0.or.Adjso.ge.0.or.Adjsea.ge.0.or.Adjcyc.ge.0.or. & Adjusr.ge.0.or.Finhol.or.Finao.or.Finls.or.Fintc.or.Finusr)) & RETURN c ------------------------------------------------------------------ c Check to see if Adj and Fin variables need to be updated c First, initialize variables c ------------------------------------------------------------------ nusr=0 nsea=0 Ntd=0 Nao=0 Nls=0 Ntc=0 Nso=0 Nramp=0 Nflwtd=0 Nln=0 Nsln=0 Nlp=0 Nhol=0 Neas=0 ncyc=0 iusr=1 Nseq=0 c----------------------------------------------------------------------- c Determine type of regression variable c----------------------------------------------------------------------- DO icol=1,Nb rtype=Rgvrtp(icol) IF(Nusrrg.gt.0)THEN IF(rtype.eq.PRGTUD)THEN rtype=Usrtyp(iusr) iusr=iusr+1 ELSE IF((rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGTUS)THEN iusr=iusr+1 END IF END IF c----------------------------------------------------------------------- c Generate regARIMA trading day factors c----------------------------------------------------------------------- IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY))THEN Ntd=Ntd+1 IF(rtype.eq.PRGTTD.or.rtype.eq.PRRTTD.or.rtype.eq.PRATTD.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & (Isrflw.eq.0.and.rtype.eq.PRGUTD)) & Nflwtd=Nflwtd+1 IF(rtype.eq.PRGTLM.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRRTLM.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRATLM.or.rtype.eq.PRATLQ.or. & rtype.eq.PRGULM.or.rtype.eq.PRGULQ) & Nln=Nln+1 IF(rtype.eq.PRGTSL.or.rtype.eq.PRRTSL.or.rtype.eq.PRATSL) & Nsln=Nsln+1 IF(rtype.eq.PRGTLY.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLY.or. & rtype.eq.PRGULY)Nlp=Nlp+1 END IF c----------------------------------------------------------------------- c Generate regARIMA holiday factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTEA.or.rtype.eq.PRGTLD.or.rtype.eq.PRGTTH.or. & rtype.eq.PRGTEC.or.rtype.eq.PRGTES.or.(rtype.ge.PRGTUH.and. & rtype.le.PRGUH5))THEN Nhol=Nhol+1 IF(rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES) & Neas=Neas+1 END IF c----------------------------------------------------------------------- c Generate regARIMA User-defined regression factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTUD)nusr=nusr+1 c----------------------------------------------------------------------- c Generate regARIMA seasonal regression factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTUS.or.(Lseats.and.(rtype.eq.PRGTSE.or. & rtype.eq.PRGTTS.or.rtype.eq.PRRTSE.or.rtype.eq.PRRTTS.or. & rtype.eq.PRATSE.or.rtype.eq.PRATTS)))nsea=nsea+1 c----------------------------------------------------------------------- c Generate regARIMA AO outlier factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTAO.or.rtype.eq.PRGUAO.or.rtype.eq.PRGTAA) & Nao=Nao+1 c----------------------------------------------------------------------- c Generate regARIMA Level Change Outlier factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTLS.or.rtype.eq.PRGULS.or.rtype.eq.PRGTRP.or. & rtype.eq.PRGTAL.or.rtype.eq.PRGTTL.or.rtype.eq.PRGTQD.or. & rtype.eq.PRGTQI)THEN Nls=Nls+1 IF(rtype.eq.PRGTRP.or.rtype.eq.PRGTQI.or.rtype.eq.PRGTQD) & Nramp=Nramp+1 END IF c----------------------------------------------------------------------- c Generate regARIMA Temporary Change Outlier factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTTC.or.rtype.eq.PRGTAT)Ntc=Ntc+1 c----------------------------------------------------------------------- c Generate regARIMA So outlier factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTSO.or.rtype.eq.PRGUSO)Nso=Nso+1 c----------------------------------------------------------------------- c Generate regARIMA MV outlier factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTMV)Nao=Nao+1 c----------------------------------------------------------------------- c Generate transitory component c----------------------------------------------------------------------- IF(rtype.eq.PRGCYC)ncyc=ncyc+1 c----------------------------------------------------------------------- END DO c----------------------------------------------------------------------- c reset regression adjustment indicators if no regession effect c found and print warning messages. c----------------------------------------------------------------------- IF(Adjtd.eq.1.and.Ntd.eq.0)Adjtd=0 IF(Adjtd.eq.0.and.Ntd.gt.0)Adjtd=1 IF(Adjhol.eq.1.and.Nhol.eq.0)THEN Adjhol=0 IF((.NOT.(Axrghl.or.Axruhl.or.Khol.ge.1)).and.Finhol)Finhol=F END IF IF(Adjhol.eq.0.and.Nhol.gt.0)Adjhol=1 IF(Adjsea.eq.1.and.nsea.eq.0)Adjsea=0 IF(Adjsea.eq.0.and.nsea.gt.0)Adjsea=1 IF(nusr.eq.0)THEN IF(Adjusr.eq.1)Adjusr=0 IF(Finusr)Finusr=F ELSE IF(nusr.gt.0)THEN IF(Adjusr.eq.0)Adjusr=1 END IF IF(Nao.eq.0)THEN IF(Adjao.eq.1)Adjao=0 IF(Finao)Finao=F ELSE IF(Nao.gt.0)THEN IF(Adjao.eq.0)Adjao=1 END IF IF(Nls.eq.0)THEN IF(Adjls.eq.1)Adjls=0 IF(Finls)Finls=F ELSE IF(Nls.gt.0)THEN IF(Adjls.eq.0)Adjls=1 END IF IF(Ntc.eq.0)THEN IF(Adjtc.eq.1)Adjtc=0 IF(Fintc)Fintc=F ELSE IF(Ntc.gt.0)THEN IF(Adjtc.eq.0)Adjtc=1 END IF IF(Adjso.eq.1.and.Nso.eq.0)Adjso=0 IF(Adjso.eq.0.and.nso.gt.0)Adjso=1 IF(Adjcyc.eq.1.and.ncyc.eq.0)Adjcyc=0 IF(Adjcyc.eq.0.and.ncyc.gt.0)Adjcyc=1 c----------------------------------------------------------------------- c If log or no transformation not generated, then regression factors c will not be generated - produce warning message and reset the c indicator variables (BCM - December 2006) c----------------------------------------------------------------------- IF(.not.(dpeq(Lam,0D0).or.dpeq(Lam,1D0)))THEN IF((Adjtd.eq.1).or.(Adjhol.eq.1).or.(Adjao.eq.1).or. & (Adjls.eq.1).or.(Adjtc.eq.1).or.(Adjusr.eq.1).or.(Adjso.eq.1) & .or.(Adjsea.eq.1).or.(Adjcyc.eq.1).or. & ((.NOT.(Axrghl.or.Axruhl.or.Khol.ge.1)).and.Finhol).or. & Finao.or.Fintc.or.Finusr)THEN CALL writln('WARNING: regARIMA preadjustment factors are only pr &oduced for either the log',STDERR,Mt2,T) CALL writln(' or no transformation.',STDERR,Mt2,F) END IF IF(Adjtd.eq.1)Adjtd=0 IF(Adjhol.eq.1)Adjhol=0 IF(Adjao.eq.1)Adjao=0 IF(Adjls.eq.1)Adjls=0 IF(Adjtc.eq.1)Adjtc=0 IF(Adjusr.eq.1)Adjusr=0 IF(Adjsea.eq.1)Adjsea=0 IF(Adjso.eq.1)Adjso=0 IF(Adjcyc.eq.1)Adjcyc=0 IF((.NOT.(Axrghl.or.Axruhl.or.Khol.ge.1)).and.Finhol)Finhol=F IF(Finao)Finao=F IF(Finls)Finls=F IF(Fintc)Fintc=F IF(Finusr)Finusr=F END IF c----------------------------------------------------------------------- RETURN END chkchi.f0000664006604000003110000002135014521201414011564 0ustar sun00315stepsC last change: Oct.25, 2023 based on BCM's fixes to construct C regression matrix correctly if user defined holiday regressors C are removed from the model C Last change: BCM 25 Sep 2008 9:23 am SUBROUTINE chkchi(Trnsrs,A,Nefobs,Na,Frstry,Lester,Lprtit,Lprchi, & Lsvchi,Lsvlch) IMPLICIT NONE c----------------------------------------------------------------------- c estimate chi-square for groups of user defined holiday regressors c and delete the groups that are not significant. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'arima.cmn' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'extend.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ONEHND,ZERO INTEGER PA,PTBLWD PARAMETER(F=.false.,T=.true.,ONEHND=100D0,ZERO=0D0, & PA=PLEN+2*PORDER,PTBLWD=PGRPCR+6) c----------------------------------------------------------------------- CHARACTER str*(PGRPCR) DOUBLE PRECISION Trnsrs,A,xpxinv,tmp,pv,chi2vl INTEGER iuhl,Nefobs,Na,nelt,iuser,idel,igrp,begcol,endcol,icol, & rtype,nfix,regidx,nchr,baselt,info,df,tbwdth,i,ncol, & Frstry,j,jcol LOGICAL argok,lprthd,lprund,luhl,Lprchi,Lsvchi,Lsvlch,Lester, & Lprtit DIMENSION Trnsrs(PLEN),A(PA),xpxinv(PXPX),tmp(2),regidx(PB), & iuhl(PUHLGP),luhl(PUHLGP) c----------------------------------------------------------------------- c Estimate current regARIMA model c----------------------------------------------------------------------- argok=Lautom.or.Lautox CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok))Lester=T IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0.or. & ((Lautom.or.Lautox).and..not.argok))THEN Lester=T RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c initialize xpxinv to zero c----------------------------------------------------------------------- CALL setdp(ZERO,PXPX,xpxinv) c----------------------------------------------------------------------- c Get X'X inverse. c----------------------------------------------------------------------- nelt=Ncxy*(Ncxy+1)/2 CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,Nb,tmp,1) c----------------------------------------------------------------------- lprthd=F lprund=F IF(Lprchi)lprthd=T iuser=0 tbwdth=PTBLWD c----------------------------------------------------------------------- nfix=0 DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 DO icol=begcol,endcol IF(Regfx(icol))THEN nfix=nfix+1 regidx(icol)=NOTSET ELSE regidx(icol)=icol-nfix END IF END DO END DO c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) rtype=Rgvrtp(begcol) c----------------------------------------------------------------------- IF(rtype.ge.PRGTUH.and.rtype.le.PRGUH5)THEN endcol=Grp(igrp)-1 iuser=iuser+1 iuhl(iuser)=igrp IF(Lprchi)lprund=T CALL getstr(Grpttl,Grpptr,Ngrp,igrp,str,nchr) IF(Lfatal)RETURN info=0 df=endcol-begcol+1 baselt=regidx(begcol) c----------------------------------------------------------------------- IF(Iregfx.eq.2)THEN IF(baselt.eq.NOTSET)df=df-1 DO icol=begcol+1,endcol IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE baselt=regidx(icol) END IF END DO END IF c----------------------------------------------------------------------- IF(baselt.ne.NOTSET) & CALL chitst(xpxinv,begcol,endcol,chi2vl,pv,regidx,T,info) CALL savchi(Lsvchi,Lsvlch,lprthd,tbwdth,baselt,str,nchr,info, & df,chi2vl,pv,'User-defined Holiday Regressors', & 'chitst$') IF(Lprchi)THEN CALL prtchi(Mt1,lprthd,tbwdth,baselt,str,nchr,info,df,chi2vl, & pv,'User-defined Holiday Regressors') IF(lprthd)lprthd=F END IF luhl(iuser)=pv.lt.Chi2cv END IF END DO c----------------------------------------------------------------------- IF(Lprchi.or.Lsvlch)lprthd=T idel=0 DO i=1,iuser c----------------------------------------------------------------------- c Check to see if the chi square statistic is insignificant c----------------------------------------------------------------------- IF(.not.luhl(i))THEN c----------------------------------------------------------------------- c If so, print output to output or log file c----------------------------------------------------------------------- IF(Lprchi.or.Lsvlch)THEN IF(lprthd)THEN IF(Lprchi)WRITE(Mt1,1010)Chi2cv*ONEHND IF(Lsvlch)WRITE(Ng,1010)Chi2cv*ONEHND lprthd=F END IF CALL getstr(Grpttl,Grpptr,Ngrp,iuhl(i),str,nchr) IF(Lfatal)RETURN IF(Lprchi)WRITE(Mt1,1020)str(1:nchr) IF(Lsvlch)WRITE(Ng,1020)str(1:nchr) END IF END IF c----------------------------------------------------------------------- c Count number of regression groups deleted c----------------------------------------------------------------------- idel=idel+1 END DO c----------------------------------------------------------------------- c If any groups are insignificant, delete them, starting from the c back and working forward c----------------------------------------------------------------------- IF(idel.gt.0)THEN icol = Grp(iuhl(1)-1) DO i=iuser,1,-1 IF(.not.luhl(i))THEN igrp=iuhl(i) begcol=Grp(igrp-1) ncol=Grp(igrp)-begcol CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Update User-defined regressors - changed by BCM June 2023 c----------------------------------------------------------------------- DO j=ncol,1,-1 jcol=begcol-icol+1 CALL dlusrg(jcol) END DO END IF END DO c----------------------------------------------------------------------- c Update number of user-defined regressors groups c----------------------------------------------------------------------- Nguhl=Nguhl-idel c----------------------------------------------------------------------- c Estimate reduced model c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,Lprtit,A,Na,Nefobs, & argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok))Lester=T c----------------------------------------------------------------------- c if no groups removed, print message c----------------------------------------------------------------------- ELSE IF(Lprchi)WRITE(Mt1,1030) END IF c----------------------------------------------------------------------- 1010 FORMAT(//,' User-defined Holiday Regression groups removed (at ', & f12.6,' percent level):') 1020 FORMAT(5x,a) 1030 FORMAT(//,' No User-defined Holiday Regression groups removed.') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- chkcvr.f0000664006604000003110000000160414521201414011613 0ustar sun00315steps LOGICAL FUNCTION chkcvr(Begsrs,Nobs,Begspn,Nspobs,Sp) IMPLICIT NONE c----------------------------------------------------------------------- c chkcvr.f, Release 1, Subroutine Version 1.4, Modified 30 Nov 1994. c----------------------------------------------------------------------- c Check whether the span (begspn,nspobs) is covered by the c series (begsrs,nobs). Returns true if the span is covered. c----------------------------------------------------------------------- INTEGER Begspn,Begsrs,idif,Nobs,Nspobs,Sp DIMENSION Begspn(2),Begsrs(2) c ------------------------------------------------------------------ chkcvr=.true. CALL dfdate(Begspn,Begsrs,Sp,idif) IF(idif.lt.0.or.idif+Nspobs.gt.Nobs.or.Nspobs.le.0)chkcvr=.false. c ------------------------------------------------------------------ RETURN END chkeas.f0000664006604000003110000000350314521201415011572 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:39 pm **==chkeas.f processed by SPAG 4.03F at 09:45 on 3 Oct 1994 SUBROUTINE chkeas(Lmar,Llda) IMPLICIT NONE c----------------------------------------------------------------------- c Check to see if X-11 Easter adjustment can be computed. c---------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'xeastr.cmn' c---------------------------------------------------------------------- INTEGER i,Lmar,Llda c----------------------------------------------------------------------- CALL setint(0,4,Ieast) DO i=Lmar,Llda,12 c----------------------------------------------------------------------- C---- CALCULATE Number of Easters BEFORE APRIL 2 c----------------------------------------------------------------------- IF(Xhol(i).le.10D0)THEN Ieast(1)=Ieast(1)+1 c----------------------------------------------------------------------- C---- CALCULATE Number of Easters AFTER APRIL 16 c----------------------------------------------------------------------- ELSE IF(Xhol(i).gt.24D0)THEN Ieast(2)=Ieast(2)+1 c----------------------------------------------------------------------- C---- CALCULATE Number of Easters From APRIL 2 to April 8 c----------------------------------------------------------------------- ELSE IF(Xhol(i).gt.10D0.and.Xhol(i).le.17D0)THEN Ieast(3)=Ieast(3)+1 c----------------------------------------------------------------------- C---- CALCULATE Number of Easters From APRIL 9 to April 15 c----------------------------------------------------------------------- ELSE Ieast(4)=Ieast(4)+1 END IF END DO c----------------------------------------------------------------------- RETURN END chkmu.f0000664006604000003110000001171714521201415011451 0ustar sun00315stepsC Last change: BCM 14 Oct 2005 4:33 pm SUBROUTINE chkmu(Trnsrs,A,Nefobs,Na,Frstry,Kstep,Lprt) IMPLICIT NONE c ------------------------------------------------------------------ c This subroutine performs an automatic ARIMA model selection. The c procedure is similar to that of Gomez and Maravall (1998) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'error.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' c INCLUDE 'adj.cmn' c INCLUDE 'priadj.cmn' c INCLUDE 'priusr.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ DOUBLE PRECISION A,Trnsrs,tval,cval LOGICAL argok,Lprt,usermu INTEGER igrp,begcol,icol,Kstep,Nefobs,Na,Frstry,kmu DIMENSION tval(PB),Trnsrs(PLEN),A(*) c ------------------------------------------------------------------ LOGICAL dpeq INTEGER strinx EXTERNAL dpeq,strinx c ------------------------------------------------------------------ c If not in model, add constant regressor c ------------------------------------------------------------------ kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') usermu=kmu.gt.0 IF(kmu.eq.0)THEN CALL adrgef(DNOTST,'Constant','Constant',PRGTCN,F,F) IF(Lfatal)RETURN kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') END IF c ------------------------------------------------------------------ c Revise regression matrix c ------------------------------------------------------------------ CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN c ------------------------------------------------------------------ c estimate model c ------------------------------------------------------------------ argok=T CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF(.not.argok)THEN CALL writln('ERROR: A model estimation error has occurred during &testing for a constant',STDERR,Mt2,T) CALL writln(' term within the automatic model identificatio &n procedure. The',STDERR,Mt2,F) CALL writln(' error message appears below.',STDERR,Mt2,F) CALL prterr(nefobs,F) IF(Lfatal)RETURN CALL abend() END IF IF(Lfatal)RETURN c ------------------------------------------------------------------ c Generate t-statistics for regressors c ------------------------------------------------------------------ IF(Convrg)THEN CALL genrtt(tval) c ------------------------------------------------------------------ IF(Kstep.eq.0)THEN cval=1.96D0 ELSE c ------------------------------------------------------------------ C IN THE SECOND ROUND (Kstep=1), CVAL IS DECREASED c ------------------------------------------------------------------ cval=1.6D0 c cvalm1=.5D0 c cvalm2=1.96D0 END IF c ------------------------------------------------------------------ c check t-test for constant term, if needed c ------------------------------------------------------------------ icol=Grp(kmu)-1 IF(DABS(tval(icol)).lt.cval)kmu=-1 ELSE IF(Lprt)WRITE(Mt1,1010) WRITE(Mt2,1010) 1010 FORMAT(/,' NOTE: Cannot perform test for constant term:',/, & ' Model estimation does not converge when ', & 'constant term added.',//, & ' Constant term will not be included in regARIMA', & ' model',/) kmu=-1 END IF c ------------------------------------------------------------------ c remove constant regressor if not significant c ------------------------------------------------------------------ IF(kmu.lt.0)THEN igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Constant') begcol=Grp(igrp-1) CALL dlrgef(begcol,Nrxy,1) IF(Lfatal)RETURN c ------------------------------------------------------------------ c If model has been changed, regenerate regression matrix c ------------------------------------------------------------------ CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN IF(Lprt.and.usermu)WRITE(Mt1,1020) 1020 FORMAT(' Constant term removed from model') END IF c ------------------------------------------------------------------ RETURN END chkorv.f0000664006604000003110000002121714521201415011632 0ustar sun00315stepsC Last change: BCM 22 Sep 2003 7:05 am SUBROUTINE chkorv(Begxy,Endrev,Botr,Otrptr,Notrtl,Fixotr,Otrttl, & Othndl,Otlfix,Nrxy,Lprt,Lsav,Lhdr,Lmdl) IMPLICIT NONE c----------------------------------------------------------------------- c Routine that checks the outliers saved by rmaootl to see if they c can be reentered into the regression matrix. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'ssprep.cmn' INCLUDE 'cchars.i' c----------------------------------------------------------------------- CHARACTER CPLUS*(1) LOGICAL T,F PARAMETER(CPLUS='+',T=.true.,F=.false.) c----------------------------------------------------------------------- CHARACTER str*(PCOLCR),outstr*(PCOLCR*PB),datstr*(10), & str2*(PCOLCR),lstr*(PCOLCR),Otrttl*(PCOLCR*PB) LOGICAL locok,Lprt,Lsav,Lhdr,update,Fixotr,Lmdl,Otlfix,fx,lastLS DOUBLE PRECISION Botr INTEGER Begxy,otltyp,begotl,endotl,endcol,icol,Endrev,i,nchr,nout, & otypvc,curdat,nchr2,Othndl,nchdat,Otrptr,Notrtl,nlast, & Nrxy,rtype,delcol,ltype,ilast,lcol,opref,lchr,jchr DIMENSION otypvc(9),Begxy(2),curdat(2),Otrptr(0:PB),opref(7), & Botr(PB),Fixotr(PB) c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx C----------------------------------------------------------------------- DATA otypvc/PRGTAO,PRGTLS,PRGTTC,PRGTRP,PRGTAO,PRGTTL,PRGTSO, & PRGTQI,PRGTQD/ DATA opref/1,4,2,0,0,0,3/ c----------------------------------------------------------------------- endcol=Notrtl nout=1 icol=1 update=F endotl=PLEN+1 nlast=0 lastLS=F DO WHILE (icol.le.endcol) CALL getstr(Otrttl,Otrptr,Notrtl,icol,str,nchr) IF(Lfatal)RETURN CALL rdotlr(str(1:nchr),Begxy,Sp,otltyp,begotl,endotl,locok) c----------------------------------------------------------------------- c Check to see if AO outlier is defined. If so, then add outlier c to regression c----------------------------------------------------------------------- IF(((otltyp.eq.RP.or.otltyp.eq.TLS.or.otltyp.eq.QI.or. & otltyp.eq.QD).and.(begotl.le.Endrev.and. & endotl.le.Endrev)).or.((otltyp.ne.RP.and.otltyp.ne.TLS.or. & otltyp.ne.QI.or.otltyp.ne.QD).and. & begotl.le.Endrev))THEN fx=Fixotr(icol).or.Otlfix CALL adrgef(Botr(icol),str(1:nchr),str(1:nchr),otypvc(otltyp), & fx,F) IF(Lfatal)RETURN IF(.not.update)update=T IF(Iregfx.eq.3.and.(.not.fx))Iregfx=2 c----------------------------------------------------------------------- c check to see if outlier being added is in last observation. c update lastLS and nlast if this is so. c----------------------------------------------------------------------- IF((otltyp.ne.RP.and.otltyp.ne.TLS.and.otltyp.ne.QI.and. & otltyp.ne.QD).and.(begotl.eq.Endrev))THEN nlast=nlast+1 IF(.not.lastLS)lastLS=otltyp.eq.LS icol=icol+1 ELSE c----------------------------------------------------------------------- c delete outlier from the AO data dictionary c----------------------------------------------------------------------- CALL delstr(icol,Otrttl,Otrptr,Notrtl,PB) IF(Lfatal)RETURN c---------------------------------------------------------------------- c Update AO beta and fix vector, endcol c---------------------------------------------------------------------- IF(icol.lt.endcol)THEN DO i=icol+1,endcol Botr(i-1)=Botr(i) Fixotr(i-1)=Fixotr(i) END DO END IF endcol=endcol-1 c----------------------------------------------------------------------- c Store outlier being added to regression. Initialize outstr. c----------------------------------------------------------------------- IF(nout.eq.1)THEN CALL addate(Begxy,Sp,Endrev-1,curdat) CALL wrtdat(curdat,Sp,datstr,nchdat) IF(Lfatal)RETURN nchr2=1 ELSE outstr(nchr2:nchr2)=CPLUS nchr2=nchr2+1 END IF outstr(nchr2:(nchr+nchr2-1))=str(1:nchr) nchr2=nchr+nchr2 nout=nout+1 END IF ELSE c---------------------------------------------------------------------- c Else, update counter c---------------------------------------------------------------------- icol=icol+1 END IF c---------------------------------------------------------------------- END DO c----------------------------------------------------------------------- c if more than one outlier appears on the final observation, delete c outliers that will cause singularities in the regression matrix. c----------------------------------------------------------------------- IF(nlast.gt.0)THEN icol=Nb ltype=0 ilast=0 lcol=0 DO WHILE(icol.ge.1) rtype=Rgvrtp(icol) IF(rtype.eq.PRGTAO.or.rtype.eq.PRGTAA.or.rtype.eq.PRGTLS.or. * & rtype.eq.PRGTAL.or.rtype.eq.PRGTTC.or.rtype.eq.PRGTAT.or. * & rtype.eq.PRGTSO.or.rtype.eq.PRGTAS)THEN & rtype.eq.PRGTAL.or.rtype.eq.PRGTTC.or.rtype.eq.PRGTAT.or. & rtype.eq.PRGTSO)THEN CALL getstr(Colttl,Colptr,Nb,icol,str2,jchr) IF(Lfatal)RETURN CALL rdotlr(str2(1:jchr),Begxy,Sp,otltyp,begotl,endotl,locok) IF(otltyp.ne.RP.and.begotl.eq.Endrev)THEN ilast=ilast+1 IF(ilast.eq.1)THEN ltype=otltyp lcol=icol lstr(1:jchr)=str2(1:jchr) lchr=jchr ELSE IF(opref(ltype).lt.opref(otltyp))THEN CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN IF(ilast.lt.nlast)lcol=lcol-1 ELSE CALL dlrgef(lcol,Nrxy,1) IF(Lfatal)RETURN ltype=otltyp lcol=icol lstr(1:jchr)=str2(1:jchr) lchr=jchr END IF END IF END IF END IF icol=icol-1 END DO c----------------------------------------------------------------------- c Remove outlier from AO data dictionary c----------------------------------------------------------------------- delcol=strinx(T,Otrttl,Otrptr,1,Notrtl,lstr(1:lchr)) IF(delcol.lt.Notrtl)THEN DO i=delcol+1,Notrtl Botr(i-1)=Botr(i) Fixotr(i-1)=Fixotr(i) END DO END IF CALL delstr(delcol,Otrttl,Otrptr,Notrtl,PB) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Store outlier being added to regression. Initialize outstr. c----------------------------------------------------------------------- IF(nout.eq.1)THEN CALL addate(Begxy,Sp,Endrev-1,curdat) CALL wrtdat(curdat,Sp,datstr,nchdat) IF(Lfatal)RETURN nchr2=1 ELSE outstr(nchr2:nchr2)=CPLUS nchr2=nchr2+1 END IF outstr(nchr2:(lchr+nchr2-1))=lstr(1:lchr) nchr2=lchr+nchr2 nout=nout+1 END IF c----------------------------------------------------------------------- c Update stored model parameters with newly stored regressor c----------------------------------------------------------------------- IF(update.and.Lmdl)THEN Ngr2=Ngrp Ngrt2=Ngrptl Ncxy2=Ncxy Nbb=Nb Nct2=Ncoltl Cttl=Colttl Gttl=Grpttl CALL cpyint(Colptr(0),PB+1,1,Clptr(0)) CALL cpyint(Grp(0),PGRP+1,1,G2(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Gptr(0)) CALL copy(B,PB,1,Bb) CALL cpyint(Rgvrtp,PB,1,Rgv2) END IF c----------------------------------------------------------------------- IF(nout.gt.1.and.(Lsav.or.Lprt))THEN IF(Lhdr)THEN CALL rvrghd(Othndl,Mt1,Lsav,Lprt) IF(Lfatal)RETURN Lhdr=F END IF IF(Lprt.and.nchr.gt.0) & WRITE(Mt1,1030)datstr(1:nchdat),'added',outstr(1:nchr2-1) IF(Lsav)WRITE(Othndl,1010)datstr(1:nchdat),TABCHR,'added', & TABCHR,outstr(1:nchr2-1) END IF RETURN c----------------------------------------------------------------------- 1010 FORMAT(a,a,a,a,a) 1030 FORMAT(4x,a,t21,a,t36,a) END chkrt1.f0000664006604000003110000000735614521201415011542 0ustar sun00315stepsC Last change: BCM 19 Feb 1999 10:37 am SUBROUTINE chkrt1(Irunit,Isunit,Rmaxr,Rmaxs,Linv,Ublim) IMPLICIT NONE c----------------------------------------------------------------------- c Performs chek of the roots of phi(B)=0 and theta(B)=0; c each root has four components: Real, Imaginary, Module, and Frequency c The module of the AR roots are checked, and the . c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c degree i Maximum lag of phi(B) or theta(B) c degp1 i degree + 1 c coeff d Coefficients of phi(B) or theta(B) in order of increasing c powers c rcoef d Coefficients of phi(B) or theta(B) in order of decreasing c powers c zeror d Real part of the roots c zeroi d Imaginary part of the roots c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL allinv,Linv INTEGER i,beglag,begopr,endlag,endopr,factor,iflt,ilag,iopr, & Irunit,Isunit,degree DOUBLE PRECISION coeff,zeror,zeroi,zerom,zerof,Rmaxr,Rmaxs,Ublim, & zmi DIMENSION coeff(PORDER+1),zeror(PORDER),zeroi(PORDER), & zerom(PORDER),zerof(PORDER) c----------------------------------------------------------------------- c Set up indicator varibles for the unit root test. c----------------------------------------------------------------------- Irunit=0 Isunit=0 Rmaxr=DNOTST Rmaxs=DNOTST c----------------------------------------------------------------------- c Print out the roots of phi(B)=0 and theta(B)=0 with AR part first c----------------------------------------------------------------------- begopr=Mdl(AR-1) beglag=Opr(begopr-1) endopr=Mdl(MA)-1 c ------------------------------------------------------------------ IF(endopr.gt.0)THEN endlag=Opr(endopr)-1 c ------------------------------------------------------------------ iflt=AR begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 IF(begopr.gt.endopr)RETURN c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ factor=Oprfac(iopr) degree=Arimal(endlag)/factor coeff(1)=-1.0D0 CALL setdp(0D0,degree,coeff(2)) c ------------------------------------------------------------------ DO ilag=beglag,endlag coeff(Arimal(ilag)/factor+1)=Arimap(ilag) END DO CALL roots(coeff,degree,allinv,zeror,zeroi,zerom,zerof) IF(Lfatal)RETURN Linv=Linv.and.allinv c ------------------------------------------------------------------ DO i=1,degree IF (zerom(i).le.Ublim.AND.zeroi(i).LE.5.0D-2.AND. & zeror(i).GT.0.D0) THEN IF (factor.eq.1) THEN Irunit=Irunit+1 ELSE Isunit=Isunit+1 END IF ELSE IF (zeroi(i).LE.2.0D-2.AND.zeror(i).GT.0.D0) THEN zmi=1/zerom(i) IF (factor.eq.1) THEN IF (zmi.GT.Rmaxr) Rmaxr=zmi ELSE IF (zmi.GT.Rmaxs) Rmaxs=zmi END IF END IF END DO END DO END IF c ------------------------------------------------------------------ RETURN END chkrt2.f0000664006604000003110000001112414521201415011527 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:38 pm SUBROUTINE chkrt2(Lprmsg,Inverr,Lhiddn) c----------------------------------------------------------------------- c chkrt2.f, Release 1, Subroutine Version 1.1, Modified 07 Dec 1995. c----------------------------------------------------------------------- c Check the roots of theta(B)=0 and makes them invertible if c their roots are inside the unit circle. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c dotln c Local pgrpcr character dotted line under the model title c degree i Maximum lag of phi(B) or theta(B) c degp1 i degree + 1 c coef d Coefficients of phi(B) or theta(B) in order of increasing c powers c rcoef d Coefficients of phi(B) or theta(B) in order of decreasing c powers c zeror d Real part of the roots c zeroi d Imaginary part of the roots c----------------------------------------------------------------------- IMPLICIT NONE LOGICAL F,T PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER dotln*(POPRCR+1),tmpttl*(POPRCR) LOGICAL allinv,Lprmsg,Lhiddn INTEGER beglag,begopr,degree,endlag,endopr,factor,i,ilag,Inverr, & iopr,ntmpcr,imt DOUBLE PRECISION coef(PORDER+1),zeror(PORDER),zeroi(PORDER), & zerom(PORDER),zerof(PORDER) DATA dotln/ & ' -----------------------------------------------------------' & / c----------------------------------------------------------------------- c Check the roots of theta(B)=0 and phi(B)=0 if using exact AR c----------------------------------------------------------------------- Inverr=0 c ------------------------------------------------------------------ IF(Lextar)THEN begopr=Mdl(AR-1) ELSE begopr=Mdl(MA-1) END IF c ------------------------------------------------------------------ beglag=Opr(begopr-1) endopr=Mdl(MA)-1 c ------------------------------------------------------------------ IF(endopr.gt.0)THEN endlag=Opr(endopr)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ factor=Oprfac(iopr) degree=Arimal(endlag)/factor coef(1)=-1.0D0 CALL setdp(0D0,degree,coef(2)) c ------------------------------------------------------------------ DO ilag=beglag,endlag coef(Arimal(ilag)/factor+1)=Arimap(ilag) END DO c ------------------------------------------------------------------ allinv=F CALL roots(coef,degree,allinv,zeror,zeroi,zerom,zerof) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check invertibility and modify the polynomial and sigma_square c the roots are g(i)=(zeror(i), zeroi(i)), i=1,2,...,degree c complex roots are g(i) and g(i+1) c If all zeros are invertible do nothing; otherwise expand c polynomials to get new coefficients. c----------------------------------------------------------------------- IF(.not.allinv)THEN IF(Lprier)THEN CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(Lprmsg)CALL writln(tmpttl(1:ntmpcr)// & ' roots inside the unit circle. Will attempt to invert them.', & Mt2,STDERR,T) c ------------------------------------------------------------------ imt=Mt1 IF(Lhiddn)imt=Mt2 WRITE(imt,1010)tmpttl(1:ntmpcr),dotln 1010 FORMAT(' ',a,' Roots',/,' Root',t25,'Real',t31,'Imaginary', & t44,'Modulus',t53,'Frequency',/,a) c ------------------------------------------------------------------ DO i=1,degree WRITE(imt,1020)i,zeror(i),zeroi(i),zerom(i),zerof(i) 1020 FORMAT(' Root',i3,t18,4F11.4) END DO END IF END IF END DO END IF c ------------------------------------------------------------------ RETURN END chkrts.f0000664006604000003110000001134314521201415011633 0ustar sun00315steps LOGICAL FUNCTION chkrts(Begopr,Endopr) IMPLICIT NONE c----------------------------------------------------------------------- c chkrts.f, Release 1, Subroutine Version 1.1, Modified 16 Feb 1995. c----------------------------------------------------------------------- c Check the roots of theta(B)=0 and makes them invertible if c their roots are inside the unit circle. c----------------------------------------------------------------------- c Changed: c To recompute the degree of the polynomial if the lag is not the c highest lag, by REG on 04 Feb 2004, revised by BCM on 06 Feb 2004. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ LOGICAL F,T DOUBLE PRECISION ONE PARAMETER(F=.false.,T=.true.,ONE=1D0) c ------------------------------------------------------------------ LOGICAL allfix,allinv INTEGER beglag,Begopr,degree,endlag,Endopr,factor,i,ic,icc,ihlf, & ilag,iopr,lagone DOUBLE PRECISION coef(PORDER+1),cfncsq,coefi,coefc,coefnc c----------------------------------------------------------------------- c Check and possibly inverts the roots of theta(B)=0 c----------------------------------------------------------------------- chkrts=F c ------------------------------------------------------------------ IF(Endopr.gt.0)THEN DO iopr=Begopr,Endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ factor=Oprfac(iopr) lagone=Arimal(beglag) degree=lagone/factor DO ilag=beglag,endlag IF(lagone.lt.Arimal(ilag))THEN degree=Arimal(ilag)/factor lagone=Arimal(ilag) END IF END DO CALL setdp(0D0,degree,coef) c ------------------------------------------------------------------ allfix=T DO ilag=beglag,endlag IF(.not.Arimaf(ilag))allfix=F coef(Arimal(ilag)/factor)=Arimap(ilag) END DO c ------------------------------------------------------------------ IF(.not.allfix)THEN allinv=F DO ic=degree,1,-1 c----------------------------------------------------------------------- c \phi_{p+1} c----------------------------------------------------------------------- coefnc=coef(ic) c----------------------------------------------------------------------- c 1=\phi^2_{p+1,p+1} c----------------------------------------------------------------------- cfncsq=ONE-coefnc*coefnc IF(cfncsq.le.0)GO TO 20 c ------------------------------------------------------------------ IF(ic.eq.1)GO TO 10 ihlf=ic/2 c ------------------------------------------------------------------ DO i=1,ihlf c----------------------------------------------------------------------- c \phi_{p+1,j} c----------------------------------------------------------------------- coefi=coef(i) c----------------------------------------------------------------------- c p-j+1 c----------------------------------------------------------------------- icc=ic-i c----------------------------------------------------------------------- c \phi_{p+1,p-j+1} c----------------------------------------------------------------------- coefc=coef(icc) c----------------------------------------------------------------------- c \phi_{p,j}=\phi_{p+1,j}+\phi_{p+1,p+1}\phi_{p+1,p-j+1}/ c (1=\phi^2_{p+1,p+1}) c----------------------------------------------------------------------- coef(i)=(coefi+coefnc*coefc)/cfncsq c----------------------------------------------------------------------- c \phi_{p,p-j+1}=\phi_{p+1,p-j+1}+\phi_{p+1,p+1}\phi_{p+1,j}/ c (1=\phi^2_{p+1,p+1}) c----------------------------------------------------------------------- IF(icc.ne.ihlf)coef(icc)=(coefc+coefnc*coefi)/cfncsq END DO END DO c ------------------------------------------------------------------ 10 allinv=T c----------------------------------------------------------------------- c Check invertibility, set the error flag, and print the error c message if necessary. c----------------------------------------------------------------------- 20 IF(.not.allinv)THEN chkrts=T Prbfac=iopr END IF END IF END DO END IF c ------------------------------------------------------------------ RETURN END chksmd.f0000664006604000003110000000654014521201415011611 0ustar sun00315stepsC Last change: BCM 25 Feb 1999 9:36 am SUBROUTINE chksmd(Nn) IMPLICIT NONE c ------------------------------------------------------------------ c Checks X-13ARIMA-SEATS ARIMA modeling data structures to see if c the model can be used by the SEATS seasonal adjustment routines. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ CHARACTER tmpttl*(PGRPCR) INTEGER Nn,iflt,begopr,endopr,nlag,iopr,ntmpcr,iparma,ardsp,i c----------------------------------------------------------------------- c set counter for first AR/MA coefficient c----------------------------------------------------------------------- ardsp=Nnsedf+Nseadf iparma=ardsp+1 c----------------------------------------------------------------------- c Loop through other operators, getting number of lags in each c ------------------------------------------------------------------ DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 DO iopr=begopr,endopr nlag=Opr(iopr)-Opr(iopr-1) CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN c ------------------------------------------------------------------ c check to see if there are too many lags for SEATS to handle c ------------------------------------------------------------------ IF(nlag.gt.Nn)THEN WRITE(Mt1,1010)Nn,tmpttl(1:ntmpcr) WRITE(Mt2,1010)Nn,tmpttl(1:ntmpcr) WRITE(STDERR,1010)Nn,tmpttl(1:ntmpcr) CALL abend END IF c ------------------------------------------------------------------ c check to see if there are missing lags in the model c ------------------------------------------------------------------ IF(tmpttl(1:ntmpcr).eq.'Nonseasonal AR'.or. & tmpttl(1:ntmpcr).eq.'Nonseasonal MA')THEN DO i=1,nlag IF(Arimal(iparma).ne.i)THEN WRITE(Mt1,1020) WRITE(Mt2,1020) WRITE(STDERR,1020) CALL abend END IF IF(Lfatal)RETURN iparma=iparma+1 END DO ELSE IF(tmpttl(1:ntmpcr).eq.'Seasonal AR'.or. & tmpttl(1:ntmpcr).eq.'Seasonal MA')THEN DO i=1,nlag IF(Arimal(iparma).ne.i*Sp)THEN WRITE(Mt1,1020) WRITE(Mt2,1020) WRITE(STDERR,1020) CALL abend END IF IF(Lfatal)RETURN iparma=iparma+1 END DO END IF END DO END DO c ------------------------------------------------------------------ 1010 FORMAT(/,' NOTE: The SEATS signal extraction routines cannot', & ' process more than ',i3,/,' ',a,' terms.',/, & ' The program will stop executing; try specifying', & ' another ARIMA model.',/) 1020 FORMAT(/,' NOTE: The SEATS signal extraction routines cannot', & ' process missing lag models.',/, & ' The program will stop executing; try specifying', & ' another ARIMA model.',/) RETURN END chktrn.f0000664006604000003110000001245214521201415011630 0ustar sun00315steps SUBROUTINE chktrn(Stc,Kpart,Ktabl,Trnchr,Tstfct,Oktrn) IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,TWO LOGICAL F PARAMETER(F=.false.,TWO=2D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' c----------------------------------------------------------------------- CHARACTER cpart*1,Trnchr*1 DOUBLE PRECISION Stc LOGICAL Oktrn,Tstfct,prtmsg INTEGER after,before,i,i2,i3,Kpart,Ktabl,last,kp DIMENSION Stc(*),cpart(4),Trnchr(*) c----------------------------------------------------------------------- LOGICAL ispos EXTERNAL ispos c----------------------------------------------------------------------- DATA cpart /'A','B','C','D'/ c----------------------------------------------------------------------- last=Posfob IF(Tstfct.and.Nfcst.gt.0)last=Posffc prtmsg=.not.ispos(Stc,Pos1bk,Posffc) IF(.not.prtmsg)THEN IF(Tstfct)Tstfct=F RETURN END IF Oktrn=ispos(Stc,Pos1ob,last) c----------------------------------------------------------------------- DO i=Pos1bk,Posffc Trnchr(i)=' ' IF(Stc(i).le.0)THEN Trnchr(i)='*' c----------------------------------------------------------------------- c IF negative trend value found, print out warning message. c----------------------------------------------------------------------- IF((.not.Lhiddn).and.prtmsg)THEN kp=Kpart if(kp.eq.6)kp=4 IF(.not.Lquiet)WRITE(STDERR,1010)cpart(kp),Ktabl CALL errhdr WRITE(Mt2,1010)cpart(kp),Ktabl 1010 FORMAT(/,' WARNING: At least one negative value was found in', & ' one of the trend', & /,' cycle estimates (',a,i3,'). Negative ', & 'value(s) will be replaced', & /,' either by the mean of its two closest ', & 'neighbors that are greater', & /,' than zero, or by the nearest value that ', & ' is greater than zero', & /,' (if the value is on either end of the ', & 'series).') prtmsg=F END IF c----------------------------------------------------------------------- c Replace negative trend value with either the mean of the two c nearest positive replacements before and after the value, or c the nearest value if it is on the ends of the series. c----------------------------------------------------------------------- i2=1 before=0 after=0 DO WHILE (before.eq.0.or.after.eq.0) IF(before.eq.0)THEN i3=i-i2 IF(i3.lt.Pos1ob)THEN before=NOTSET ELSE IF(Stc(i3).gt.ZERO)THEN before=i3 END IF END IF IF(after.eq.0)THEN i3=i+i2 IF(i3.gt.Posfob)THEN after=NOTSET ELSE IF(Stc(i3).gt.ZERO)THEN after=i3 END IF END IF i2=i2+1 END DO IF(before.eq.NOTSET)THEN Stc(i)=Stc(after) ELSE IF(after.eq.NOTSET)THEN Stc(i)=Stc(before) ELSE Stc(i)=(Stc(after)+Stc(before))/TWO END IF END IF END DO IF(Lhiddn)RETURN c----------------------------------------------------------------------- IF(Oktrn)THEN IF(.not.prtmsg)THEN WRITE(STDERR,1020) CALL errhdr WRITE(Mt2,1020) 1020 FORMAT(/,' These are often caused by poor forecasts ', & 'and/or backcasts.', & /,' Users should check the fit of any existing', & ' regARIMA model,', & /,' using the diagnostics in the check spec.') END IF ELSE IF(Nfcst.gt.0.or.Nbcst.gt.0)THEN WRITE(STDERR,1030) CALL errhdr WRITE(Mt2,1030) 1030 FORMAT(/,' These are often caused by substantial ', & 'outliers in the original', & /,' series, or poor forecasts and/or ', & 'backcasts. Users should', & /,' fit a regARIMA model to the series using ', & 'outlier regression', & /,' variables to correct for such effects, and', & ' check the fit of', & /,' any existing regARIMA model, using the ', & 'diagnostics in the', & /,' check spec.') ELSE WRITE(STDERR,1040) CALL errhdr WRITE(Mt2,1040) 1040 FORMAT(/,' These are often caused by substantial ', & 'outliers in the original', & /,' series. Users should fit a regARIMA ', & 'model to the series', & /,' using outlier regression variables to ', & 'correct for such effects.') END IF END IF c----------------------------------------------------------------------- RETURN END chkuhg.f0000664006604000003110000000315014521201415011603 0ustar sun00315stepsC Last change: BCM 25 Sep 2008 9:23 am SUBROUTINE chkuhg(Iuhl,Nguhl,Herror) IMPLICIT NONE c----------------------------------------------------------------------- c check input for groups of user defined holiday regressors to see c if correct sequence of codes. Will also compute number of groups c specified. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INTEGER Iuhl,Nguhl,i LOGICAL Herror,hzero DIMENSION Iuhl(PUHLGP) c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- herror=F hzero=F Nguhl=0 c----------------------------------------------------------------------- c Loop through holiday groups, checking to see if there are c inconsistencies c----------------------------------------------------------------------- DO i=1,PUHLGP IF(Iuhl(i).eq.0)THEN IF(.not.hzero)hzero=T ELSE IF(hzero)THEN Herror=T ELSE IF(.not.Herror)THEN Nguhl=Nguhl+1 END IF END IF END DO c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- chkurt.f0000664006604000003110000000773414521201415011646 0ustar sun00315stepsC Last change: SRD 31 Jan 100 8:17 am SUBROUTINE chkurt(Urpr,Urps,Urqr,Urqs) IMPLICIT NONE c----------------------------------------------------------------------- c Performs chek of the roots of phi(B)=0 and theta(B)=0; c each root has four components: Real, Imaginary, Module, and Frequency c The module of the roots are checked, and indicator variables are c returned that show where a unit root has occurred. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c degree i Maximum lag of phi(B) or theta(B) c degp1 i degree + 1 c coeff d Coefficients of phi(B) or theta(B) in order of increasing c powers c rcoef d Coefficients of phi(B) or theta(B) in order of decreasing c powers c zeror d Real part of the roots c zeroi d Imaginary part of the roots c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO,MONE PARAMETER(ONE=1D0,ZERO=0D0,MONE=-1D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL allinv INTEGER i,beglag,begopr,endlag,endopr,factor,iflt,ilag,iopr, & degree,Urpr,Urps,Urqr,Urqs DOUBLE PRECISION coeff,zeror,zeroi,zerom,zerof,modlim DIMENSION coeff(PORDER+1),zeror(PORDER),zeroi(PORDER), & zerom(PORDER),zerof(PORDER) c----------------------------------------------------------------------- c Set up indicator varibles for the unit root test. c----------------------------------------------------------------------- Urpr=0 Urps=0 Urqr=0 Urqs=0 c----------------------------------------------------------------------- c check for unit roots in all c----------------------------------------------------------------------- begopr=Mdl(AR-1) beglag=Opr(begopr-1) endopr=Mdl(MA)-1 c ------------------------------------------------------------------ IF(endopr.gt.0)THEN modlim=ONE/0.95D0 endlag=Opr(endopr)-1 c ------------------------------------------------------------------ DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ factor=Oprfac(iopr) degree=Arimal(endlag)/factor coeff(1)=MONE CALL setdp(ZERO,degree,coeff(2)) c ------------------------------------------------------------------ DO ilag=beglag,endlag coeff(Arimal(ilag)/factor+1)=Arimap(ilag) END DO CALL roots(coeff,degree,allinv,zeror,zeroi,zerom,zerof) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Test to see if there are unit roots in any of the AR or MA c polynomials c ------------------------------------------------------------------ DO i=1,degree c IF (zerom(i).le.ublim.AND.zeroi(i).LE.5.0D-2.AND. c & zeror(i).GT.0.D0) THEN IF(zerom(i).le.modlim)THEN IF(factor.eq.1)THEN IF(iflt.eq.AR)THEN Urpr=Urpr+1 ELSE Urqr=Urqr+1 END IF ELSE IF(iflt.eq.AR)THEN Urps=Urps+1 ELSE Urqs=Urqs+1 END IF END IF END IF END DO END DO END DO END IF c ------------------------------------------------------------------ RETURN END chkzro.f0000664006604000003110000000333314521201415011635 0ustar sun00315steps SUBROUTINE chkzro(Ori,Sa,Sa2,Sarnd,Ocal,Pos1,Pos2,Kfulsm) IMPLICIT NONE c ------------------------------------------------------------------ c --- this subroutine checks the values of the original series, c seasonally adjusted series, trend and calendar adjusted series c prior to the computation of month-to-month changes to set the c value of Gudval to false if any of the values are less than or c equal to zero. c ------------------------------------------------------------------ c written by Brian Monsell, March 2006 c ------------------------------------------------------------------ LOGICAL F DOUBLE PRECISION ZERO PARAMETER(F=.false.,ZERO=0D0) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'force.cmn' INCLUDE 'goodob.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION Ori,Sa,Sa2,Sarnd,Ocal INTEGER Pos1,Pos2,i,Kfulsm DIMENSION Ori(PLEN),Sa(PLEN),Sa2(PLEN),Sarnd(PLEN),Ocal(PLEN) c ------------------------------------------------------------------ DO i = Pos1, Pos2 IF(Gudval(i))THEN IF(.not.(Ori(i).gt.ZERO.and.(Kfulsm.eq.0.and.Sa(i).gt.ZERO) & .and.Ocal(i).gt.ZERO))THEN Gudval(i)=F ELSE IF((Iyrt.gt.0.or.Lrndsa).and.Kfulsm.eq.0)THEN IF(Iyrt.gt.0)THEN IF(.not.(Sa2(i).gt.ZERO))Gudval(i)=F END IF IF(Lrndsa)THEN IF(.not.(Sarnd(i).gt.ZERO))Gudval(i)=F END IF END IF END IF END DO c ------------------------------------------------------------------ RETURN END chqsea.f0000664006604000003110000004204114521201416011601 0ustar sun00315stepsC Last change: BCM 19 May 2003 9:46 am SUBROUTINE chqsea(Lmodel,Lseats,Lx11,Lprt,Lsvlg,Lsumm) IMPLICIT NONE c----------------------------------------------------------------------- c Check for seasonality in a Quarterly analog of a monthly series c----------------------------------------------------------------------- c Will generate QS statistics for quarterly original data and c quarterly seasonally adjusted data. c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE LOGICAL F,T PARAMETER(F=.false.,T=.true.,ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'adxser.cmn' INCLUDE 'inpt.cmn' INCLUDE 'units.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'rho.cmn' INCLUDE 'seatcm.cmn' INCLUDE 'seatlg.cmn' c----------------------------------------------------------------------- CHARACTER begstr*(10) DOUBLE PRECISION srs,yq,yq2,saq,saq2,qSoriq,qSoriSq,QSori2q, & qSori2Sq,qSsadjq,qSsadjSq,QSsadj2q,qSsadj2Sq LOGICAL Lmodel,lplog,Lprt,Lsvlg,lqs,lqss,lqsa,lqsas,Lseats,Lx11, & gosa INTEGER startq,Nobsq,Lsumm,pos1q,posfq,bgqspc,nyq,l0,l1,nchr1,i, & ipos DIMENSION startq(2),bgqspc(2),srs(PLEN),Yq(PLEN),yq2(PLEN), & saq(PLEN),saq2(PLEN) c----------------------------------------------------------------------- DOUBLE PRECISION Stex(PLEN) COMMON /mq10 / Stex c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION calcqs,chisq EXTERNAL dpeq,calcqs,chisq c----------------------------------------------------------------------- CALL setdp(ZERO,PLEN,Yq) CALL setdp(ZERO,PLEN,Yq2) CALL setdp(ZERO,PLEN,saq) CALL setdp(ZERO,PLEN,saq2) c----------------------------------------------------------------------- nyq=4 CALL m2q(Series,yq,Pos1ob,Posfob,pos1q,posfq,Begspn,startq, & Isrflw) c----------------------------------------------------------------------- c Convert monthly spectral start to quarterly c----------------------------------------------------------------------- bgqspc(YR)=Bgspec(YR) IF(Bgspec(MO).eq.1)THEN bgqspc(MO)=1 ELSE IF(Bgspec(MO).le.4)THEN bgqspc(MO)=2 ELSE IF(Bgspec(MO).le.7)THEN bgqspc(MO)=3 ELSE IF(Bgspec(MO).le.10)THEN bgqspc(MO)=4 ELSE bgqspc(MO)=1 bgqspc(YR)=bgqspc(YR)+1 END IF CALL dfdate(bgqspc,startq,nyq,ipos) CALL wrtdat(bgqspc,nyq,begstr,nchr1) c----------------------------------------------------------------------- c Generate QS stat for the quarterly original series c----------------------------------------------------------------------- qSoriq=DNOTST qSoriSq=DNOTST c----------------------------------------------------------------------- CALL copy(yq,PLEN,1,srs) c----------------------------------------------------------------------- c take log of series if necessary (12-2-2014) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=pos1q,posfq srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=pos1q,posfq srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF END IF END IF c----------------------------------------------------------------------- CALL qsDiff(srs,pos1q,posfq,Lmodel,Nnsedf,Nseadf,nyq,qSoriq) IF((ipos+1).gt.pos1q) & CALL qsDiff(srs,ipos+1,posfq,Lmodel,Nnsedf,Nseadf,nyq,QSoriSq) c----------------------------------------------------------------------- CALL copy(Stcsi,PLEN,1,srs) IF(Lx11)THEN IF(Psuadd)THEN DO i=Pos1ob,Posfob IF(Kfulsm.eq.2)THEN srs(i)=Stc(i)*Sti(i) ELSE srs(i)=Stc(i)*(Sts(i)+(Sti(i)-ONE)) END IF END DO ELSE CALL addmul(srs,srs,Stex,Pos1ob,Posfob) END IF END IF CALL m2q(srs,yq2,Pos1ob,Posfob,pos1q,posfq,Begspn,startq,Isrflw) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=pos1q,posfq yq2(i)=log(yq2(i)) END DO IF(.not.lplog)lplog=T END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=pos1q,posfq yq2(i)=log(yq2(i)) END DO IF(.not.lplog)lplog=T END IF END IF END IF c----------------------------------------------------------------------- QSori2q=DNOTST QSori2Sq=DNOTST CALL qsDiff(yq2,pos1q,posfq,Lmodel,Nnsedf,Nseadf,Nyq,QSori2q) IF((ipos+1).gt.pos1q) & CALL qsDiff(yq2,ipos+1,posfq,Lmodel,Nnsedf,Nseadf,Nyq,QSori2Sq) c----------------------------------------------------------------------- c Convert monthly SA to quarterly c----------------------------------------------------------------------- qSsadjq=DNOTST qSsadjSq=DNOTST IF((Lx11.and.Kfulsm.eq.0).or.Lseats)THEN gosa=T IF(Lseats)gosa=Hvstsa END IF IF(gosa)THEN IF(Lseats)THEN CALL m2q(Seatsa,saq,Pos1ob,Posfob,pos1q,posfq,Begspn,startq, & Isrflw) ELSE CALL m2q(Stci,saq,Pos1ob,Posfob,pos1q,posfq,Begspn,startq, & Isrflw) END IF CALL copy(saq,PLEN,1,srs) c----------------------------------------------------------------------- c take log of seasonally adjusted series if necessary (12-2-2014) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=pos1q,posfq srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=pos1q,posfq srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF END IF END IF c----------------------------------------------------------------------- CALL qsDiff(srs,pos1q,posfq,Lmodel,Nnsedf,Nseadf,nyq,qSsadjq) IF((ipos+1).gt.pos1q) & CALL qsDiff(srs,ipos+1,posfq,Lmodel,Nnsedf,Nseadf,nyq,QSsadjSq) END IF c----------------------------------------------------------------------- c Generate QS stat for the seasonally adjusted series adjusted for c extreme values and outliers c----------------------------------------------------------------------- QSsadj2q=DNOTST qSsadj2Sq=DNOTST IF(gosa)THEN IF(Lx11)THEN CALL copy(Stcime,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,Posfob,Posfob) ELSE CALL copy(Stocsa,PLEN,1,srs) END IF CALL m2q(srs,saq2,Pos1ob,Posfob,pos1q,posfq,Begspn,startq, & Isrflw) c----------------------------------------------------------------------- c take log of series if necessary (12-2-2014) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=pos1q,posfq srs(i)=log(saq2(i)) END DO END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=pos1q,posfq srs(i)=log(saq2(i)) END DO END IF END IF END IF c----------------------------------------------------------------------- CALL qsDiff(srs,pos1q,posfq,Lmodel,Nnsedf,Nseadf,nyq,QSsadj2q) IF((ipos+1).gt.pos1q) & CALL qsDiff(srs,ipos+1,posfq,Lmodel,Nnsedf,Nseadf,nyq,qSsadj2Sq) END IF c----------------------------------------------------------------------- c Print out Qs c----------------------------------------------------------------------- lqs=.not.(dpeq(QSoriq,DNOTST).and.dpeq(QSori2q,DNOTST)) lqss=.not.(dpeq(QSoriSq,DNOTST).and.dpeq(QSori2Sq,DNOTST)) lqsa=.not.(dpeq(qSsadjq,DNOTST).and.dpeq(QSsadj2q,DNOTST)) lqsas=.not.(dpeq(QSsadjSq,DNOTST).and.dpeq(qSsadj2Sq,DNOTST)) IF(Lprt.and.(lqs.or.lqss.or.lqsa.or.lqsas))THEN IF(lqs)THEN WRITE(Mt1,1010)' QS statistic for (quarterly) seasonality:' END IF IF(lplog)THEN IF(.not.dpeq(QSoriq,DNOTST)) & WRITE(Mt1,1020)' log(Original Series) ',QSoriq, & chisq(QSoriq,2) IF(.not.dpeq(QSori2q,DNOTST)) & WRITE(Mt1,1020)' log(Original Series (EV adj)) ',QSori2q, & chisq(QSori2q,2) ELSE IF(.not.dpeq(QSoriq,DNOTST)) & WRITE(Mt1,1020)' Original Series ',QSoriq, & chisq(QSoriq,2) IF(.not.dpeq(QSori2q,DNOTST)) & WRITE(Mt1,1020)' Original Series (EV adj) ',QSori2q, & chisq(QSori2q,2) END IF IF(lqss)THEN WRITE(Mt1,1010)' QS statistic for (quarterly) seasonality '// & '(starting '//begstr(1:nchr1)//'):' END IF IF(lplog)THEN IF(.not.dpeq(QSoriSq,DNOTST)) & WRITE(Mt1,1020)' log(Original Series) ', & QSoriSq,chisq(QSoriSq,2) IF(.not.dpeq(QSori2Sq,DNOTST)) & WRITE(Mt1,1020)' log(Original Series (EV adj)) ', & QSori2Sq,chisq(QSori2Sq,2) ELSE IF(.not.dpeq(QSoriSq,DNOTST)) & WRITE(Mt1,1020)' Original Series ', & QSoriSq,chisq(QSoriSq,2) IF(.not.dpeq(QSori2Sq,DNOTST)) & WRITE(Mt1,1020)' Original Series (EV adj) ', & QSori2Sq,chisq(QSori2Sq,2) END IF c----------------------------------------------------------------------- IF(lqsa)THEN WRITE(Mt1,1010)' QS statistic for (quarterly) seasonality:' END IF IF(lplog)THEN IF(.not.dpeq(qSsadjq,DNOTST)) & WRITE(Mt1,1020)' log(Seasonally Adjusted Series) ', & qSsadjq,chisq(qSsadjq,2) IF(.not.dpeq(QSsadj2q,DNOTST)) & WRITE(Mt1,1020)' log(Seasonally Adjusted Series (EV adj)) ', & QSsadj2q,chisq(QSsadj2q,2) ELSE IF(.not.dpeq(qSsadjq,DNOTST)) & WRITE(Mt1,1020)' Seasonally Adjusted Series ', & qSsadjq,chisq(qSsadjq,2) IF(.not.dpeq(QSsadj2q,DNOTST)) & WRITE(Mt1,1020)' Seasonally Adjusted Series (EV adj) ', & QSsadj2q,chisq(QSsadj2q,2) END IF IF(lqsas)THEN WRITE(Mt1,1010)' QS statistic for (quarterly) seasonality '// & '(starting '//begstr(1:nchr1)//'):' END IF IF(lplog)THEN IF(.not.dpeq(QSsadjSq,DNOTST)) & WRITE(Mt1,1020)' log(Seasonally Adjusted Series) ', & QSsadjSq,chisq(QSsadjSq,2) IF(.not.dpeq(qSsadj2Sq,DNOTST)) & WRITE(Mt1,1020)' log(Seasonally Adjusted Series (EV adj)) ', & qSsadj2Sq,chisq(qSsadj2Sq,2) ELSE IF(.not.dpeq(QSsadjSq,DNOTST)) & WRITE(Mt1,1020)' Seasonally Adjusted Series ', & QSsadjSq,chisq(QSsadjSq,2) IF(.not.dpeq(qSsadj2Sq,DNOTST)) & WRITE(Mt1,1020)' Seasonally Adjusted Series (EV adj) ', & qSsadj2Sq,chisq(qSsadj2Sq,2) END IF END IF c----------------------------------------------------------------------- IF(Lsvlg.and.(lqs.or.lqss.or.lqsa.or.lqsas))THEN WRITE(Ng,1010)' QS statistic for (quarterly) seasonality:' IF(lplog)THEN IF(.not.dpeq(QSoriq,DNOTST).and.lqs) & WRITE(Ng,1020)' log(Original Series) ', & QSoriq,chisq(QSoriq,2) IF(.not.dpeq(QSori2q,DNOTST).and.lqs) & WRITE(Ng,1020)' log(Original Series (EV adj)) ', & QSori2q,chisq(QSori2q,2) ELSE IF(.not.dpeq(QSoriq,DNOTST).and.lqs) & WRITE(Ng,1020)' Original Series ', & QSoriq,chisq(QSoriq,2) IF(.not.dpeq(QSori2q,DNOTST).and.lqs) & WRITE(Ng,1020)' Original Series (EV adj) ', & QSori2q,chisq(QSori2q,2) END IF WRITE(Ng,1010)' QS statistic for (quarterly) seasonality '// & '(starting '//begstr(1:nchr1)//'):' IF(lplog)THEN IF(.not.dpeq(QSoriSq,DNOTST).and.lqss) & WRITE(Ng,1020)' log(Original Series) ', & QSoriSq,chisq(QSoriSq,2) IF(.not.dpeq(QSori2Sq,DNOTST).and.lqss) & WRITE(Ng,1020)' log(Original Series (EV adj)) ', & QSori2Sq,chisq(QSori2Sq,2) ELSE IF(.not.dpeq(QSoriSq,DNOTST).and.lqss) & WRITE(Ng,1020)' Original Series ', & QSoriSq,chisq(QSoriSq,2) IF(.not.dpeq(QSori2Sq,DNOTST).and.lqss) & WRITE(Ng,1020)' Original Series (EV adj) ', & QSori2Sq,chisq(QSori2Sq,2) END IF c----------------------------------------------------------------------- IF(lqsa)THEN WRITE(Ng,1010)' QS statistic for (quarterly) seasonality:' END IF IF(lplog)THEN IF(.not.dpeq(qSsadjq,DNOTST)) & WRITE(Ng,1020)' log(Seasonally Adjusted Series) ', & qSsadjq,chisq(qSsadjq,2) IF(.not.dpeq(QSsadj2q,DNOTST)) & WRITE(Ng,1020)' log(Seasonally Adj. Series (EV adj)) ', & QSsadj2q,chisq(QSsadj2q,2) ELSE IF(.not.dpeq(qSsadjq,DNOTST)) & WRITE(Ng,1020)' Seasonally Adjusted Series ', & qSsadjq,chisq(qSsadjq,2) IF(.not.dpeq(QSsadj2q,DNOTST)) & WRITE(Ng,1020)' Seasonally Adjusted Series (EV adj) ', & QSsadj2q,chisq(QSsadj2q,2) END IF IF(lqsas)THEN WRITE(Ng,1010)' QS statistic for (quarterly) seasonality '// & '(starting '//begstr(1:nchr1)//'):' END IF IF(lplog)THEN IF(.not.dpeq(QSsadjSq,DNOTST)) & WRITE(Ng,1020)' log(Seasonally Adjusted Series) ', & QSsadjSq,chisq(QSsadjSq,2) IF(.not.dpeq(qSsadj2Sq,DNOTST)) & WRITE(Ng,1020)' log(Seasonally Adj. Series (EV adj)) ', & qSsadj2Sq,chisq(qSsadj2Sq,2) ELSE IF(.not.dpeq(QSsadjSq,DNOTST)) & WRITE(Ng,1020)' Seasonally Adjusted Series ', & QSsadjSq,chisq(QSsadjSq,2) IF(.not.dpeq(qSsadj2Sq,DNOTST)) & WRITE(Ng,1020)' Seasonally Adjusted Series (EV adj) ', & qSsadj2Sq,chisq(qSsadj2Sq,2) END IF END IF c----------------------------------------------------------------------- IF(Lsumm.gt.0.and.(lqs.or.lqss.or.lqsa.or.lqsas))THEN IF(lqs)THEN IF(.not.dpeq(QSoriq,DNOTST)) & WRITE(Nform,1030)'qsori.qseas',QSoriq,chisq(QSoriq,2) IF(.not.dpeq(QSori2q,DNOTST)) & WRITE(Nform,1030)'qsorievadj.qseas',QSori2q,chisq(QSori2q,2) END IF IF(lqss)THEN IF(.not.dpeq(QSoriSq,DNOTST)) & WRITE(Nform,1030)'qssori.qseas',QSoriSq,chisq(QSoriSq,2) IF(.not.dpeq(QSori2Sq,DNOTST)) & WRITE(Nform,1030)'qssorievadj.qseas',QSori2Sq, & chisq(QSori2Sq,2) END IF IF(lqsa)THEN IF(.not.dpeq(QSsadjq,DNOTST)) & WRITE(Nform,1030)'qssadj.qseas',QSsadjq,chisq(qSsadjq,2) IF(.not.dpeq(QSsadj2q,DNOTST)) & WRITE(Nform,1030)'qssadjevadj.qseas',QSsadj2q, & chisq(QSsadj2q,2) END IF IF(lqsas)THEN IF(.not.dpeq(QSsadjSq,DNOTST)) & WRITE(Nform,1030)'qsssadj.qseas',QSsadjSq,chisq(QSsadjSq,2) IF(.not.dpeq(QSsadj2Sq,DNOTST)) & WRITE(Nform,1030)'qsssadjevadj.qseas',QSsadj2Sq, & chisq(QSsadj2Sq,2) END IF END IF c----------------------------------------------------------------------- 1000 FORMAT(3f15.4) 1010 FORMAT(/,1x,a) 1020 FORMAT(a,5x,f16.2,' (P-Value = ',f10.4,')') 1030 FORMAT(a,':',f16.5,1x,f10.5) c----------------------------------------------------------------------- RETURN END chrt.cmn0000664006604000003110000000172514521201416011631 0ustar sun00315stepsc----------------------------------------------------------------------- CHARACTER I1*1,I3*1,I4*1,I7*1,I8*1,I9*1,I10*1,I11*1,I12*1,Ia*1, & Ip*1,Ialpha*1,Ialphq*1 INTEGER Ibeg2,Ienda,Ixy,Nseas,Nyr,Npts,N1,Ifrst,Last,Llyr,Lastyr, & Imid,Icmax,Iyear,Inyr,Ibottm,Ifact2 DOUBLE PRECISION Ab1,Ser1,Xdata3,Xyvec,Y1,Y2,Ydiff,Ymax,Ymin,Ymid, & Fact1 DIMENSION Y1(PLEN),Y2(PLEN),Xdata3(61),Ia(110,55),Ip(10),Ymid(14), & Imid(14),Ialpha(12),Ialphq(4),Ser1(61,12),Ab1(61), & Iyear(61) c----------------------------------------------------------------------- COMMON /chrtcr / Ia,Ialpha,Ip,Ialphq,I1,I3,I4,I7,I8,I9,I10,I11,I12 COMMON /chrtdp / Ab1,Fact1,Ser1,Xyvec,Y1,Y2,Xdata3,Ymin,Ymax, & Ydiff,Ymid COMMON /chrtin / Nyr,Npts,N1,Ifrst,Last,Llyr,Lastyr,Nseas,Ixy, & Ibeg2,Ienda,Iyear,Inyr,Icmax,Ibottm,Imid,Ifact2 chrt.f0000664006604000003110000000340114521201416011272 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:57 pm SUBROUTINE chrt(Title,Ntitle,Icodeo,Noser,Nyc) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'tbltitle.prm' INCLUDE 'error.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'chrt.cmn' c----------------------------------------------------------------------- CHARACTER Title*(PTTLEN),caver*1 INTEGER icod2,icode,Icodeo,jx,l,Noser,Nyc,Ntitle DIMENSION Title(2),Ntitle(2) c -------------------------------------------------------------------- icode=Icodeo I3='+' I4='I' I8='I' I9='I' I10=I4 I11=I10 I12='@' DO l=1,10 Ip(l)=I3 END DO Nseas=Nyc IF(Ymax.le.Ymin)RETURN icod2=0 IF(icode.eq.15)THEN icod2=icode icode=5 END IF IF(icode.eq.20.or.icode.eq.21)THEN icod2=icode-20 icode=0 END IF IF(icode.eq.17)THEN icod2=icode icode=7 END IF IF(icode.eq.29)THEN IF(Muladd.eq.0)THEN icod2=icode ELSE icod2=19 END IF icode=9 END IF CALL setup(icode,icod2) jx=2 IF(icode.le.6)CALL yrly(icode,icod2,jx,Noser) IF(icode.eq.7)CALL month(icode,jx) IF(icode.eq.9)THEN caver='I' CALL aver(Y1,N1,caver,icode,icod2,jx) END IF IF(Lfatal.or.icode.lt.0)RETURN c ------------------------------------------------------------------ c Change 9/96 to handle more than one title c ------------------------------------------------------------------ CALL outchr(Title,Ntitle,icode,icod2) RETURN END chsppf.f0000664006604000003110000002034514521201416011623 0ustar sun00315steps SUBROUTINE CHSPPF(P,NU,PPF,Ipr) IMPLICIT NONE C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE CHI-SQUARED DISTRIBUTION C WITH INTEGER DEGREES OF FREEDOM PARAMETER = NU. C THE CHI-SQUARED DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL NON-NEGATIVE X, C AND ITS PROBABILITY DENSITY FUNCTION IS GIVEN C IN REFERENCES 2, 3, AND 4 BELOW. C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --NU = THE INTEGER NUMBER OF DEGREES C OF FREEDOM. C NU SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE CHI-SQUARED DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER = NU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NU SHOULD BE A POSITIVE INTEGER VARIABLE. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DEXP, DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN. C ACCURACY--(ON THE UNIVAC 1108, EXEC 8 SYSTEM AT NBS) C COMPARED TO THE KNOWN NU = 2 (EXPONENTIAL) C RESULTS, AGREEMENT WAS HAD OUT TO 6 SIGNIFICANT C DIGITS FOR ALL TESTED P IN THE RANGE P = .001 TO C P = .999. FOR P = .95 AND SMALLER, THE AGREEMENT C WAS EVEN BETTER--7 SIGNIFICANT DIGITS. C (NOTE THAT THE TABULATED VALUES GIVEN IN THE WILK, C GNANADESIKAN, AND HUYETT REFERENCE BELOW, PAGE 20, C ARE IN ERROR FOR AT LEAST THE GAMMA = 1 CASE-- C THE WORST DETECTED ERROR WAS AGREEMENT TO ONLY 3 C SIGNIFICANT DIGITS (IN THEIR 8 SIGNIFICANT DIGIT TABLE) C FOR P = .999.) C REFERENCES--WILK, GNANADESIKAN, AND HUYETT, 'PROBABILITY C PLOTS FOR THE GAMMA DISTRIBUTION', C TECHNOMETRICS, 1962, PAGES 1-15, C ESPECIALLY PAGES 3-5. C --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 257, FORMULA 6.1.41, C AND PAGES 940-943. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 166-206. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGES 46-51. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE: 301-921-2315 C ORIGINAL VERSION--SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C C--------------------------------------------------------------------- C DOUBLE PRECISION DP,DGAMMA DOUBLE PRECISION Z,Z2,Z3,Z4,Z5,DEN,A,B,C,D,G DOUBLE PRECISION XMIN0,XMIN,AI,XMAX,DX,PCALC,XMID DOUBLE PRECISION XLOWER,XUPPER,XDEL DOUBLE PRECISION SUM,TERM,CUT1,CUT2,AJ,CUTOFF,T DOUBLE PRECISION DEXP,DLOG DOUBLE PRECISION P,PPF,ANU,GAMMA INTEGER IPR,NU,MAXIT,ILOOP,ICOUNT,J DIMENSION D(10) DATA C/ .918938533204672741D0/ DATA D(1),D(2),D(3),D(4),D(5) 1 /+.833333333333333333D-1,-.277777777777777778D-2, 1+.793650793650793651D-3,-.595238095238095238D-3,+.8417508417508417 151D-3/ DATA D(6),D(7),D(8),D(9),D(10) 1 /-.191752691752691753D-2,+.641025641025641025D-2,-.2955065359 147712418D-1,+.179644372368830573D0,-.139243221690590111D1/ C * IPR=6 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)GO TO 50 IF(NU.LT.1)GO TO 55 GO TO 90 50 WRITE(IPR,1) WRITE(IPR,46)P PPF=0.0 RETURN 55 WRITE(IPR,15) WRITE(IPR,47)NU PPF=0.0 RETURN 90 CONTINUE 1 FORMAT(' ***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'CHSPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ', & '*****') 15 FORMAT(' ***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'CHSPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT(' ***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT(' ***** THE VALUE OF THE ARGUMENT IS ',I8 ,' *****') C C-----START POINT----------------------------------------------------- C C EXPRESS THE CHI-SQUARED DISTRIBUTION PERCENT POINT C FUNCTION IN TERMS OF THE EQUIVALENT GAMMA C DISTRIBUTION PERCENT POINT FUNCTION, C AND THEN EVALUATE THE LATTER. C ANU=DBLE(NU) GAMMA=ANU/2D0 DP=P DGAMMA=ANU/2.0D0 MAXIT=10000 C C COMPUTE THE GAMMA FUNCTION USING THE ALGORITHM IN THE C NBS APPLIED MATHEMATICS SERIES REFERENCE. C THIS GAMMA FUNCTION NEED BE CALCULATED ONLY ONCE. C IT IS USED IN THE CALCULATION OF THE CDF BASED ON C THE TENTATIVE VALUE OF THE PPF IN THE ITERATION. C Z=DGAMMA DEN=1.0D0 150 IF(Z.GE.10.0D0)GO TO 160 DEN=DEN*Z Z=Z+1.0D0 GO TO 150 160 Z2=Z*Z Z3=Z*Z2 Z4=Z2*Z2 Z5=Z2*Z3 A=(Z-0.5D0)*DLOG(Z)-Z+C B=D(1)/Z+D(2)/Z3+D(3)/Z5+D(4)/(Z2*Z5)+D(5)/(Z4*Z5)+ 1D(6)/(Z*Z5*Z5)+D(7)/(Z3*Z5*Z5)+D(8)/(Z5*Z5*Z5)+D(9)/(Z2*Z5*Z5*Z5) G=DEXP(A+B)/DEN C C DETERMINE LOWER AND UPPER LIMITS ON THE DESIRED 100P C PERCENT POINT. C ILOOP=1 XMIN0=(DP*DGAMMA*G)**(1.0D0/DGAMMA) XMIN=XMIN0 ICOUNT=1 350 AI=ICOUNT XMAX=AI*XMIN0 DX=XMAX GO TO 1000 360 IF(PCALC.GE.DP)GO TO 370 XMIN=XMAX ICOUNT=ICOUNT+1 IF(ICOUNT.LE.30000)GO TO 350 370 XMID=(XMIN+XMAX)/2.0D0 C C NOW ITERATE BY BISECTION UNTIL THE DESIRED ACCURACY IS ACHIEVED. C ILOOP=2 XLOWER=XMIN XUPPER=XMAX ICOUNT=0 550 DX=XMID GO TO 1000 560 IF(PCALC.EQ.DP)GO TO 570 IF(PCALC.GT.DP)GO TO 580 XLOWER=XMID XMID=(XMID+XUPPER)/2.0D0 GO TO 590 580 XUPPER=XMID XMID=(XMID+XLOWER)/2.0D0 590 XDEL=XMID-XLOWER IF(XDEL.LT.0.0D0)XDEL=-XDEL ICOUNT=ICOUNT+1 IF(XDEL.LT.0.0000000001D0.OR.ICOUNT.GT.100)GO TO 570 GO TO 550 570 PPF=2.0D0*XMID RETURN C C******************************************************************** C THIS SECTION BELOW IS LOGICALLY SEPARATE FROM THE ABOVE. C THIS SECTION COMPUTES A CDF VALUE FOR ANY GIVEN TENTATIVE C PERCENT POINT X VALUE AS DEFINED IN EITHER OF THE 2 C ITERATION LOOPS IN THE ABOVE CODE. C C COMPUTE T-SUB-Q AS DEFINED ON PAGE 4 OF THE WILK, GNANADESIKAN, C AND HUYETT REFERENCE C 1000 SUM=1.0D0/DGAMMA TERM=1.0D0/DGAMMA CUT1=DX-DGAMMA CUT2=DX*10000000000.0D0 DO700J=1,MAXIT AJ=J TERM=DX*TERM/(DGAMMA+AJ) SUM=SUM+TERM CUTOFF=CUT1+(CUT2*TERM/SUM) IF(AJ.GT.CUTOFF)GO TO 750 700 CONTINUE WRITE(IPR,705)MAXIT WRITE(IPR,706)P WRITE(IPR,707)NU WRITE(IPR,708) PPF=0.0 RETURN C 750 T=SUM PCALC=(DX**DGAMMA)*(DEXP(-DX))*T/G IF(ILOOP.EQ.1)GO TO 360 GO TO 560 C 705 FORMAT(' *****ERROR IN INTERNAL OPERATIONS IN THE CHSPPF ', 1 'SUBROUTINE--THE NUMBER OF ITERATIONS EXCEEDS ',I7) 706 FORMAT(' THE INPUT VALUE OF P IS ',E15.8) 707 FORMAT(' THE INPUT VALUE OF NU IS ',I8) 708 FORMAT(' THE OUTPUT VALUE OF PPF HAS BEEN SET TO 0.0') C END chusrg.f0000664006604000003110000000752214521201416011635 0ustar sun00315stepsC Last change: BCM 11 Jun 1998 4:04 pm SUBROUTINE chusrg(Upuser,Usfxtl,Nusfx,Nusftl,Usfptr) IMPLICIT NONE c----------------------------------------------------------------------- c check user defined regressors c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'error.cmn' INCLUDE 'usrreg.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE LOGICAL F,T PARAMETER(F=.false.,T=.true.,ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- CHARACTER str*(PCOLCR),Usfxtl*(PCOLCR*PUREG) LOGICAL Upuser,allfix INTEGER i,iuser,j,disp,uptr,nuser,nchr,Nusfx,Nusftl,Usfptr,k,rtype DOUBLE PRECISION fvec DIMENSION fvec(PLEN),Usfptr(0:PUREG) c----------------------------------------------------------------------- LOGICAL dpeq INTEGER strinx EXTERNAL dpeq,strinx c----------------------------------------------------------------------- c Initialize variables. c----------------------------------------------------------------------- IF(Upuser)RETURN iuser=Ncusrx+1 c----------------------------------------------------------------------- c Compute difference between start of user-defined regressors and c beginning of model span c----------------------------------------------------------------------- CALL dfdate(Begmdl,Bgusrx,Sp,disp) c----------------------------------------------------------------------- c Find user-defined regression variables. c----------------------------------------------------------------------- allfix=T DO i=Nb,1,-1 rtype=Rgvrtp(i) IF((rtype.eq.PRGTUD.or.(rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGTUS).and.(.not.Regfx(i)))THEN iuser=iuser-1 nuser=Nspobs c----------------------------------------------------------------------- c Find the first non-zero observation in the differenced user c defined regressor c----------------------------------------------------------------------- CALL setdp(ZERO,PLEN,fvec) uptr=(Ncusrx*disp)+iuser CALL daxpy(nuser,ONE,Userx(uptr),Ncusrx,fvec,1) CALL arflt(nuser,Arimap,Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1, & fvec,nuser) j=1 DO WHILE(dpeq(fvec(j),ZERO).and.j.le.nuser) j=j+1 END DO c----------------------------------------------------------------------- c Use this value to check if the user-defined regressor should be c removed from the regression matrix c----------------------------------------------------------------------- IF(j.gt.nuser)THEN c----------------------------------------------------------------------- c If the user defined regressor is not defined for the period up c to the start of the sliding span, fix the regressor for this run. c----------------------------------------------------------------------- Regfx(i)=T IF(.not.Upuser)Upuser=T CALL getstr(Colttl,Colptr,Ncoltl,i,str,nchr) IF(Lfatal)RETURN k=0 IF(Nusftl.gt.0)k=strinx(F,Usfxtl,Usfptr,1,Nusftl,str(1:nchr)) IF(k.eq.0)THEN CALL insstr(str(1:nchr),Nusfx,PUREG,Usfxtl,Usfptr,Nusftl) IF(Lfatal)RETURN Nusfx=Nusfx+1 END IF END IF END IF IF(.not.Regfx(i).and.allfix)allfix=F END DO c----------------------------------------------------------------------- IF(Upuser)THEN IF(allfix)THEN Iregfx=3 ELSE Iregfx=2 END IF END IF RETURN END clrotl.f0000664006604000003110000000216114521201416011633 0ustar sun00315steps SUBROUTINE clrotl(Nrxy) IMPLICIT NONE c----------------------------------------------------------------------- c Remove automatically identified outlier regressors from model c This routine is done before redoing automatic outlier c identification in the automatic model identification procedure c (BCM April 2007) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER icol,Nrxy c----------------------------------------------------------------------- icol=Nb DO WHILE (icol.ge.1) IF(Rgvrtp(icol).eq.PRGTAA.or.Rgvrtp(icol).eq.PRGTAL.or. * & Rgvrtp(icol).eq.PRGTAT.or.Rgvrtp(icol).eq.PRGTAS)THEN & Rgvrtp(icol).eq.PRGTAT)THEN CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN END IF icol=icol-1 END DO Natotl=0 c----------------------------------------------------------------------- RETURN END clsgrp.f0000664006604000003110000000214414521201416011627 0ustar sun00315steps**==clsgrp.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 INTEGER FUNCTION clsgrp(Opnchr) IMPLICIT NONE c---------------------------------------------------------------------- c Return the ascii value of the closing character given the c opening character, i.e. ) for (,] for [, and { for }. c---------------------------------------------------------------------- INTEGER Opnchr c ----------------------------------------------------------------- IF(Opnchr.eq.40)THEN clsgrp=41 c ----------------------------------------------------------------- ELSE IF(Opnchr.eq.47)THEN clsgrp=47 c ----------------------------------------------------------------- ELSE IF(Opnchr.eq.91)THEN clsgrp=93 c ----------------------------------------------------------------- ELSE IF(Opnchr.eq.123)THEN clsgrp=125 c ----------------------------------------------------------------- ELSE clsgrp=-1 END IF c ----------------------------------------------------------------- RETURN END cmpchi.f0000664006604000003110000006053114521201416011604 0ustar sun00315steps SUBROUTINE cmpchi(Xpxinv,Regidx,Lsvchi,Lsvlch,Lprchi,Lprhdr, & Tbwdth,Lxreg) IMPLICIT NONE c----------------------------------------------------------------------- c perform chi square tests for combinations of regression groups, c such as change of regime regressors and length of month with c trading day c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'picktd.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- c replace dimension length for Xpxinv (BCM May 2007) CHARACTER grpstr*(PGRPCR),rg0str*(PGRPCR),rg1str*(PGRPCR), & rg2str*(PGRPCR) DOUBLE PRECISION chi2vl,pv,Xpxinv LOGICAL allusr,havlp,havlm,Lsvchi,Lprchi,Lprhdr,Lxreg,Lsvlch INTEGER begcol,endcol,gtdall,gtdrg,gtdrg1,gtdrg2,gsearg,Regidx, & info,igrp,ipos,nchr,nchr0,nchr1,nchr2,df,baselt,rtype, & rgi2,icol,iusr,gutd,guhol,gusea,utype,udrest,Tbwdth,ud1st, & udlast,guall,nuh1,nuh2,nuh3,nuh4,nuh5 DIMENSION gtdall(0:2),gtdrg(0:2),gtdrg1(0:2),gtdrg2(0:2), & gsearg(0:2),rgi2(PB),Regidx(PB),Xpxinv(PXPX),gutd(0:2), & guhol(0:2),gusea(0:2),guall(0:2) c----------------------------------------------------------------------- c Initialize counts for the pointer dictionaries c----------------------------------------------------------------------- DO icol=0,2 gtdall(icol)=0 gtdrg(icol)=0 gtdrg1(icol)=0 gtdrg2(icol)=0 gsearg(icol)=0 gutd(icol)=0 guhol(icol)=0 gusea(icol)=0 guall(icol)=0 END DO udrest=0 ud1st=NOTSET udlast=NOTSET iusr=1 c----------------------------------------------------------------------- c Create pointer dictionaries for different tests we wish to c perform c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 rtype=Rgvrtp(begcol) c----------------------------------------------------------------------- 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 IF(ud1st.eq.NOTSET)ud1st=begcol IF(guall(0).eq.0)guall(1)=begcol guall(0)=guall(0)+1 guall(2)=endcol IF(Lxreg)THEN utype=Usxtyp(begcol) ELSE utype=Usrtyp(begcol) END IF IF(utype.eq.PRGUTD.or.utype.eq.PRGULM.or.utype.eq.PRGULQ.or. & utype.eq.PRGULY)THEN IF(gtdall(0).eq.0)gtdall(1)=begcol gtdall(0)=gtdall(0)+1 gtdall(2)=endcol IF(utype.eq.PRGUTD)THEN IF(gutd(0).eq.0)gutd(1)=begcol gutd(0)=gutd(0)+1 gutd(2)=endcol END IF ELSE IF(utype.eq.PRGTUS)THEN IF(gusea(0).eq.0)gusea(1)=begcol gusea(0)=gusea(0)+1 gusea(2)=endcol ELSE IF((utype.ge.PRGTUH.and.utype.le.PRGUH5))THEN IF(guhol(0).eq.0)THEN guhol(1)=begcol guhol(0)=guhol(0)+1 ELSE IF(.not.(utype.eq.udlast))guhol(0)=guhol(0)+1 END IF guhol(2)=endcol ELSE udrest=udrest+1 END IF iusr=iusr+1 IF(icol.lt.endcol)udlast=utype END IF c----------------------------------------------------------------------- IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY))THEN gtdall(0)=gtdall(0)+1 IF(gtdall(0).eq.1)gtdall(1)=begcol gtdall(2)=endcol END IF IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRG1TD).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY))THEN gtdrg(0)=gtdrg(0)+1 IF(gtdrg(0).eq.1)gtdrg(1)=begcol gtdrg(2)=endcol CALL getstr(Grpttl,Grpptr,Ngrp,igrp,rg0str,nchr0) IF(Lfatal)RETURN END IF IF((rtype.eq.PRRTTD.or.rtype.eq.PRRTST.or.rtype.eq.PRR1TD).or. & (rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRRTLY))THEN gtdrg1(0)=gtdrg1(0)+1 IF(gtdrg1(0).eq.1)gtdrg1(1)=begcol gtdrg1(2)=endcol CALL getstr(Grpttl,Grpptr,Ngrp,igrp,rg1str,nchr1) IF(Lfatal)RETURN END IF IF((rtype.eq.PRATTD.or.rtype.eq.PRATST.or.rtype.eq.PRA1TD).or. & (rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or. & rtype.eq.PRATLY))THEN gtdrg2(0)=gtdrg2(0)+1 IF(gtdrg2(0).eq.1)gtdrg2(1)=begcol gtdrg2(2)=endcol CALL getstr(Grpttl,Grpptr,Ngrp,igrp,rg2str,nchr2) IF(Lfatal)RETURN END IF IF(rtype.eq.PRRTTS.or.rtype.eq.PRRTSE.or.rtype.eq.PRATTS.or. & rtype.eq.PRATSE.or.rtype.eq.PRGTTS.or.rtype.eq.PRGTSE)THEN gsearg(0)=gsearg(0)+1 IF(gsearg(0).eq.1)gsearg(1)=begcol gsearg(2)=endcol END IF END DO c----------------------------------------------------------------------- c Generate combined Chi-Square test for user defined holiday c regressors. c----------------------------------------------------------------------- IF((guhol(2)-guhol(1)).gt.0.and.(guhol(0).lt.guall(0)))THEN CALL setint(NOTSET,Nb,rgi2) df=guhol(2)-guhol(1)+1 baselt=regidx(guhol(1)) nuh1=0 nuh2=0 nuh3=0 nuh4=0 nuh5=0 DO icol=guhol(1),guhol(2) iusr=icol-ud1st+1 IF(Lxreg)THEN utype=Usxtyp(iusr) ELSE utype=Usrtyp(iusr) END IF IF((utype.ge.PRGTUH.and.utype.le.PRGUH5))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF IF(utype.eq.PRGTUH.and.nuh1.eq.0)nuh1=nuh1+1 IF(utype.eq.PRGUH2.and.nuh2.eq.0)nuh2=nuh2+1 IF(utype.eq.PRGUH3.and.nuh3.eq.0)nuh3=nuh3+1 IF(utype.eq.PRGUH4.and.nuh4.eq.0)nuh4=nuh4+1 IF(utype.eq.PRGUH5.and.nuh5.eq.0)nuh5=nuh5+1 ELSE df=df-1 END IF END DO IF((nuh1+nuh2+nuh3+nuh4+nuh5).gt.1)THEN CALL chitst(Xpxinv,guhol(1),guhol(2),chi2vl,pv,rgi2, & guhol(0).lt.2,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=35 grpstr(1:nchr)='All User-defined Holiday Regressors' CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF END IF c----------------------------------------------------------------------- IF(gtdrg(0).ge.2.and.gtdrg(2).lt.gtdall(2))THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdrg(2)-gtdrg(1)+1 baselt=regidx(gtdrg(1)) DO icol=gtdrg(1),gtdrg(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRG1TD.or. & rtype.eq.PRG1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRGTLY)havlp=T IF(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ)havlm=T END DO CALL chitst(Xpxinv,gtdrg(1),gtdrg(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=13 grpstr(1:nchr)='Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+12)='+ Leap Year ' nchr=nchr+12 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+20)='+ Length of Quarter ' nchr=nchr+20 ELSE grpstr(nchr+1:nchr+18)='+ Length of Month ' nchr=nchr+18 END IF END IF ipos=index(rg0str(1:nchr0),'(') if (ipos.gt.0) then grpstr(nchr+1:(nchr+nchr0-ipos+1))=rg0str(ipos:nchr0) nchr=nchr+nchr0-ipos+1 end if CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df,chi2vl, & pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for trading day and lom c change of regime regressors c----------------------------------------------------------------------- IF(gtdrg1(0).ge.2.and.(.not.(gtdrg1(1).eq.gtdall(1).and. & gtdrg1(2).eq.gtdall(2))))THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdrg1(2)-gtdrg1(1)+1 baselt=regidx(gtdrg1(1)) DO icol=gtdrg1(1),gtdrg1(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRRTTD.or.rtype.eq.PRRTST.or.rtype.eq.PRR1TD.or. & rtype.eq.PRR1ST).or. & (rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRRTLY).or.(Fulltd.and. & (rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRG1TD.or. & rtype.eq.PRG1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY)))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRRTLY)THEN havlp=T ELSE IF(rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ & .or.(Fulltd.and.(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or. & rtype.eq.PRGTLQ.or.rtype.eq.PRGTLY)))THEN havlm=T END IF END DO CALL chitst(Xpxinv,gtdrg1(1),gtdrg1(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=13 grpstr(1:nchr)='Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+12)='+ Leap Year ' nchr=nchr+12 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+20)='+ Length of Quarter ' nchr=nchr+20 ELSE grpstr(nchr+1:nchr+18)='+ Length of Month ' nchr=nchr+18 END IF END IF ipos=index(rg1str(1:nchr1),'(') grpstr(nchr+1:(nchr+nchr1-ipos+1))=rg1str(ipos:nchr1) nchr=nchr+nchr1-ipos+1 CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df,chi2vl, & pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF c----------------------------------------------------------------------- IF(gtdrg2(0).ge.2.and.(.not.(gtdrg2(1).eq.gtdall(1).and. & gtdrg2(2).eq.gtdall(2))))THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdrg2(2)-gtdrg2(1)+1 baselt=regidx(gtdrg2(1)) DO icol=gtdrg2(1),gtdrg2(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRATTD.or.rtype.eq.PRATST.or.rtype.eq.PRA1TD).or. & (rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or. & rtype.eq.PRATLY))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRATLY)THEN havlp=T ELSE IF(rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ) & THEN havlm=T END IF END DO CALL chitst(Xpxinv,gtdrg2(1),gtdrg2(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=13 grpstr(1:nchr)='Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+12)='+ Leap Year ' nchr=nchr+12 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+20)='+ Length of Quarter ' nchr=nchr+20 ELSE grpstr(nchr+1:nchr+18)='+ Length of Month ' nchr=nchr+18 END IF END IF ipos=index(rg2str(1:nchr2),'(') grpstr(nchr+1:(nchr+nchr2-ipos+1))=rg2str(ipos:nchr2) nchr=nchr+nchr2-ipos+1 CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df,chi2vl, & pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for user defined trading day c regressors. c----------------------------------------------------------------------- IF(ud1st.eq.NOTSET)THEN IF((gutd(2)-gutd(1)).gt.0)THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gutd(2)-gutd(1)+1 baselt=regidx(gutd(1)) DO icol=gutd(1),gutd(2) iusr=icol-ud1st+1 IF(Lxreg)THEN utype=Usxtyp(iusr) ELSE utype=Usrtyp(iusr) END IF IF(utype.eq.PRGUTD)THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF END DO CALL chitst(Xpxinv,gutd(1),gutd(2),chi2vl,pv,rgi2,gutd(0).lt.2, & info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=25 grpstr(1:nchr)='User-defined Trading Day ' grpstr(nchr+1:nchr+10)='Regressors' nchr=nchr+10 CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for trading day and lom c regressors c----------------------------------------------------------------------- IF(gtdall(0).ge.2)THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F allusr=T df=gtdall(2)-gtdall(1)+1 baselt=regidx(gtdall(1)) DO icol=gtdall(1),gtdall(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY.or. & rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF IF(.not.(rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ & .or.rtype.eq.PRGULY))allusr=F ELSE df=df-1 END IF IF(rtype.eq.PRGTLY.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLY.or. & rtype.eq.PRGULY)THEN havlp=T ELSE IF(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ & .or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ & .or.rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ & .or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ) & THEN havlm=T END IF END DO CALL chitst(Xpxinv,gtdall(1),gtdall(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=9 grpstr(1:nchr)='Combined ' IF(allusr)THEN grpstr(nchr+1:nchr+14)='User-Defined ' nchr=nchr+14 END IF grpstr(nchr+1:nchr+12)='Trading Day ' nchr=nchr+12 IF(havlp)THEN grpstr(nchr+1:nchr+14)='and Leap Year ' nchr=nchr+14 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+22)='and Length of Quarter ' nchr=nchr+22 ELSE grpstr(nchr+1:nchr+20)='and Length of Month ' nchr=nchr+20 END IF END IF grpstr(nchr+1:nchr+10)='Regressors' nchr=nchr+10 CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df,chi2vl, & pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for seasonal regressors c----------------------------------------------------------------------- IF(gsearg(0).ge.2)THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gsearg(2)-gsearg(1)+1 baselt=regidx(gsearg(1)) DO icol=gsearg(1),gsearg(2) rtype=Rgvrtp(icol) IF(rtype.eq.PRRTTS.or.rtype.eq.PRRTSE.or.rtype.eq.PRATTS.or. & rtype.eq.PRATSE.or.rtype.eq.PRGTTS.or.rtype.eq.PRGTSE)THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF END DO CALL chitst(Xpxinv,gsearg(1),gsearg(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=9 grpstr(1:nchr)='Combined ' rtype=Rgvrtp(gsearg(1)) IF(rtype.eq.PRRTTS.or.rtype.eq.PRATTS)THEN grpstr(nchr+1:nchr+14)='Trigonometric ' nchr=nchr+14 END IF grpstr(nchr+1:nchr+19)='Seasonal Regressors' nchr=nchr+19 CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df,chi2vl, & pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for user defined seasonal c regressors. c----------------------------------------------------------------------- c IF((gusea(2)-gusea(1)).gt.0)THEN c CALL setint(NOTSET,Nb,rgi2) c df=gusea(2)-gusea(1)+1 c baselt=regidx(gusea(1)) c DO icol=gusea(1),gusea(2) c iusr=icol-ud1st+1 c IF(Lxreg)THEN c utype=Usxtyp(iusr) c ELSE c utype=Usrtyp(iusr) c END IF c IF(utype.eq.PRGTUS)THEN c rgi2(icol)=Regidx(icol) c IF(regidx(icol).eq.NOTSET)THEN c df=df-1 c ELSE IF(baselt.eq.NOTSET)THEN c baselt=rgi2(icol) c END IF c ELSE c df=df-1 c END IF c END DO c CALL chitst(Xpxinv,gusea(1),gusea(2),chi2vl,pv,rgi2, c & gusea(0).lt.2,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- c nchr=32 c grpstr(1:nchr)='User-defined Seasonal Regressors' c CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, c & chi2vl,pv,CNOTST,'chi$') c IF(Lprchi)THEN c CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, c & chi2vl,pv,'Regressors') c IF(Lprhdr)Lprhdr=F c END IF c END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for user defined regressors c if there are more than one type of user defined regressor defined c or if there are no special types of user defined regressors c defined. c----------------------------------------------------------------------- IF((guall(0).eq.1.and.((guall(2)-guall(1)+1).gt.udrest)).or. & guall(0).gt.1)THEN CALL setint(NOTSET,Nb,rgi2) df=guall(2)-guall(1)+1 baselt=regidx(guall(1)) DO icol=guall(1),guall(2) rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF END DO CALL chitst(Xpxinv,guall(1),guall(2),chi2vl,pv,rgi2, & guall(0).lt.2,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- IF(guall(0).eq.1)THEN nchr=23 grpstr(1:nchr)='User-defined Regressors' ELSE nchr=27 grpstr(1:nchr)='All User-defined Regressors' END IF CALL savchi(Lsvchi,F,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(Lprchi)THEN CALL prtchi(Mt1,Lprhdr,Tbwdth,baselt,grpstr,nchr,info,df,chi2vl, & pv,'Regressors') IF(Lprhdr)Lprhdr=F END IF END IF c----------------------------------------------------------------------- * 1010 FORMAT('chi$',a,': ',i4,2(1x,e22.15)) * 1020 FORMAT(' ',a,t41,'All coefficients fixed') * 1030 FORMAT(' ',a,/,t35,i4,f16.2,f13.2) * 1040 FORMAT(' ',a,t35,i4,f16.2,f13.2) * 1050 FORMAT(' ',a,t52,'Not tested') RETURN END cmpflts.i0000664006604000003110000000216414521201416012012 0ustar sun00315stepsC C component filters common block C C filters: column 1 = symmetric, column 2 = concurrent C size of filters is the same as size of data. DOUBLE PRECISION treFlt(1200,2), SAFlt(1200,2) C cycles/period set - all 1200 entries used. DOUBLE PRECISION fltW(0:1200) C for each filter: squared-gain, time-shift = - phase-delays; C all 1200 entries used. DOUBLE PRECISION treGain(0:1200,2), treTmShf(0:1200,2) DOUBLE PRECISION SAGain(0:1200,2), SATmShf(0:1200,2) C concurrent filter zero (at some frequency): 1 for SA, 2 for trend logical concFltZ(2), C Does each quantity exist. for each filter, squared-gain, phase-delays C column 1 = symmetric, column 2 = concurrent & ltreFlt(2), ltreGain(2), ltreTmShf(2), & lSAFlt(2), lSAGain(2), lSATmShf(2) common / cmpflts / fltW, & treFlt, treGain, treTmShf, & SAFlt, SAGain, SATmShf common / lcmpflt / concFltZ, & ltreFlt, ltreGain, ltreTmShf, & lSAFlt, lSAGain, lSATmShf cmpstr.f0000664006604000003110000000250014521201417011642 0ustar sun00315steps**==cmpstr.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 LOGICAL FUNCTION cmpstr(Toktyp,Str1,Str2) IMPLICIT NONE c---------------------------------------------------------------------- INCLUDE 'lex.i' c---------------------------------------------------------------------- CHARACTER chr1*1,chr2*1,Str1*(*),Str2*(*) INTEGER Toktyp,ichr,nchr1,nchr2 c---------------------------------------------------------------------- IF(Toktyp.eq.QUOTE)THEN cmpstr=Str1.eq.Str2 c---------------------------------------------------------------------- ELSE IF(Toktyp.eq.NAME)THEN nchr1=len(Str1) nchr2=len(Str2) c---------------------------------------------------------------------- IF(nchr1.eq.nchr2)THEN cmpstr=.true. DO ichr=1,nchr1 CALL map(UCASE,LCASE,Str1(ichr:ichr),chr1) CALL map(UCASE,LCASE,Str2(ichr:ichr),chr2) IF(chr1.ne.chr2)GO TO 10 END DO GO TO 20 END IF c---------------------------------------------------------------------- 10 cmpstr=.false. c---------------------------------------------------------------------- ELSE cmpstr=Str1.eq.Str2 END IF c---------------------------------------------------------------------- 20 RETURN END cmpsvl.i0000664006604000003110000000170014521201417011642 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for svltbl are of the form LSL c where the types are c----------------------------------------------------------------------- c ind M1 M1 c ind Q Q c ind Q without M2 Q2 c ind Moving seasonality ratio MSR c ind I/C Ratio ICR c ind F-test for stable seasonality, D8 FD8 c ind F-test for moving seasonality, D8 MSF c test for aggregation smoothness ITT c----------------------------------------------------------------------- INTEGER LSLIM1,LSLISR,LSLIIR,LSLID8,LSLISF,LSLIID,LSLITT,LSLALI PARAMETER( & LSLIM1= 75,LSLISR= 88,LSLIIR= 89,LSLID8= 90,LSLISF= 91, & LSLIID= 92,LSLITT= 93,LSLALI= 94) cmptbl.i0000664006604000003110000000642514521201417011630 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c composite CMP, CP c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c aggregate series A1 c aggheader AH c aggtest AT c indirect d8 D8 c indirect d9 D9 c indirect seasonal SF c indirect final seasonal diff. FSD c indirect seasonally adjusted SA c indirect trend TRN c indirect irregular IRR c indirect e1 E1 c indirect e2 E2 c indirect e3 E3 c indirect change original srs E5 c indirect change sa E6 c indirect change adjusted sa E6A c indirect change rounded sa E6R c indirect mcd moving avg F1 c indirect x11 diagnostics F2 c indirect q stats F3 c indirect yearly totals E4 c indirect ftest d8 D8F c indirect moving seasonality ratio D9A c indirect residual seas f-test RSF c indirect adjusted fin seas adj SAA c indirect rounded fin seas adj RND c original series A1P c series vrs. ind sa series E0 c ratios of ind series R1 c ratios of ind sa series R2 c ind final seasonal factors SP c ind final seasonally adj. AP c ind final trend component TP c ind final irregular component IP c----------------------------------------------------------------------- INTEGER LCMPA1,LCMPA3,LCMPB1,LCPB1P,LCPA18,LCPA19,LCMPAH,LCMPAT, & LCMPD8,LCMPD9,LCMPSF,LCPIPS,LCPFSD,LCMPSA,LCPTRN,LCPIRR, & LCPIPI,LCMPE1,LCMPE2,LCMPE3,LCMPE5,LCPE5P,LCMPE6,LCPE6P, & LCPE6A,LCP6AP,LCPE6R,LCP6RP,LCMPE7,LCPE7P,LCMPE8,LCPE8P, & LCPE11,LCPE18,LCPEEB,LCMPF1,LCMPF2,LCMPF3,LCMPE4,LCPD8F, & LCPD9A,LCPRSF,LCPSAA,LCPRND,LCPA1P,LCMPE0,LCMPR1,LCMPR2, & LCMPSP,LCMPAP,LCMPTP,LCMPIP,LCPILS,LCPIAO,LCPFCF,LCPCAF, & LCPIPA,LCPCRI,LCPRRI,LCPFFC PARAMETER( & LCMPA1=289,LCMPA3=290,LCMPB1=291,LCPB1P=292,LCPA18=293, & LCPA19=294,LCMPAH=295,LCMPAT=296,LCMPD8=297,LCMPD9=298, & LCMPSF=299,LCPIPS=300,LCPFSD=301,LCMPSA=302,LCPTRN=303, & LCPIRR=304,LCPIPI=305,LCMPE1=306,LCMPE2=307,LCMPE3=308, & LCMPE5=309,LCPE5P=310,LCMPE6=311,LCPE6P=312,LCPE6A=313, & LCP6AP=314,LCPE6R=315,LCP6RP=316,LCMPE7=317,LCPE7P=318, & LCMPE8=319,LCPE8P=320,LCPE11=321,LCPE18=322,LCPEEB=323, & LCMPF1=324,LCMPF2=325,LCMPF3=326,LCMPE4=327,LCPD8F=328, & LCPD9A=329,LCPRSF=330,LCPSAA=331,LCPRND=332,LCPA1P=333, & LCMPE0=334,LCMPR1=335,LCMPR2=336,LCMPSP=337,LCMPAP=338, & LCMPTP=339,LCMPIP=340,LCPILS=341,LCPIAO=342,LCPFCF=343, & LCPCAF=344,LCPIPA=345,LCPCRI=346,LCPRRI=347,LCPFFC=348) cncrnt.f0000664006604000003110000007612414521201417011636 0ustar sun00315stepsC Last change: BCM 19 May 2003 7:50 am c This subroutine will compute signal extraction filter weights for ARIMA component models c The squared gain and phase delay of the filter will also be computed c See Bell and Martin (2003) for more details c With appropriate definitions of S(t) and N(t) the program can be used for signal + noise, c seasonal + nonseasonal, and trend + (seasonal + irregular), etc. The general model form is c c z(t) = S(t) + N(t) c c phi(B) z(t) = theta(B) a(t) c c phis(B) S(t) = thetas(B) b(t) c c phin(B) N(t) = thetan(B) e(t) c c The filter computed is alpha(B), the signal extraction filter for S(t) c The corresponding filter for N(t) is 1 - alpha(B). (true if m >= 0) c The filter is based on observations up to Z(t+m), for arbitrary m c c The phi(B), phis(B), and phin(B) operators include both AR and differencing c operators. It is assumed that phis(B) and phin(B) have no common zeroes c on or inside the unit circle. Any operators in the model with c multiplicative structure are assumed to have been multiplied out. c Operators are taken to be of the following general form c c phis(B) = phis(0) + phis(1)*B + ... + phis(ps)*B^ps, c c and their coefficients are stored in corresponding arrays as follows: c c phis = [phis(0), phis(1), ... , phis(ps)]'. c c Analogous definitions apply for the other operators in the model. c Notice (1) the operators are written with + signs between terms c (2) the array of coefficients includes the lag-0 coefficient c (which will always be 1) c (3) seasonal operators are assumed to be stored in nonseasonal form, c e.g., if theta(B) = 1 - .8*B^12, the corresponding coefficient c array is theta = [1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -.8]'. c c The program is currently set up to take vectors and dimensions from subroutine spectrum.forarguments print out c spectrum.for does the spectral decomposition to obtain MA operators for the component models c We currently print out (file trans.out) the squared gain and phase delay for the seasonally adjusted, seasonal, trend and cycle components c To do this, we must form (in sigex.for) and/or capture seasonally adjusted, seasonal, trend, non-trend, cycle and noncycle components from spectrum.for c Also printed are filter weights (file weights.out) c----------------------------------------------------------------------- SUBROUTINE CONCURRENT(thstar, qstar, pstar, thets, nthets, psi, 1 npsi, varwns, thadj, nthadj, chcyc, nchcyc, varwna, thetp, 1 nthetp, chi, nchi, varwnp, thtra, nthtra, pscyc, npscyc, 1 varwnt, cyc, ncyc, thetc, nthetc, varwnc, 1 thcya, nthcya, chpsi, nchpsi, varwca, Lgraf) c----------------------------------------------------------------------- c input argument variables and arrays (from SEATS subroutine SPECTRUM) c c thstar(1,...qstar) -- coefficients of MA operator for z(t) c thets(1,nthets) -- seasonal numerator c psi(1,npsi) -- seasonal denominator c thadj(1,nthadj) -- seasonally adjusted numerator c chcyc(1,nchcyc) -- trend-cycle denominator c thetp(1,nthetp) -- trend numerator c chi(1,nchi) -- trend denominator c thtra(1,nthtra) -- trend adjusted numerator c pscyc(1,npscyc) -- seasonal-cycle denominator c thcya(1,nthcya) -- cycle adjusted numerator c chpsi(1,nchpsi) -- cycle adjusted denominator c varwns -- variance ratio for seasonal component c varwna -- variance ratio for seasonally adjusted component c varwnp -- variance ratio for trend component c varwnt -- variance ratio for the trend adjusted component c varwca -- variance ratio for the cycle adjusted component c----------------------------------------------------------------------- c Internal variables and arrays c (note not all model operators need be input) c c p, ps, pn, q, qs, qn = model orders c phi(0:p) = coefficients of AR + differencing operator for Z(t) c phis(0:ps) = coefficients of AR + differencing operator for S(t) c phin(0:pn) = coefficients of AR + differencing operator for N(t) c theta(0:q) = coefficients of MA operator for z(t) c thetan(0:qn) = coefficients of MA operator for N(t) c thetas(0:qs) = coefficients of MA operator for S(t) c sigrts = Var(b(t))/Var(a(t)), the variance ratio for S(t) c sigrtn = Var(e(t))/Var(a(t)), the variance ratio for N(t) c mx is some order greater than what is needed for a general problem c kk = number of subdivisions of the interval [0,pi] for transfer c and phase delay functions c m is number of "future" observations available on Z c (or steps ahead if m is negative) c c ACGTHT(-qs:qs)= autocovariance generating function of MA side of model c (without variance ratio) c for S(t), that is, thetas(B)*thetas(F). c g = vector (h+k+1 by 1) containing coefficients of B^(-h),...B^0, c B^1,..B^k c (g also holds the coefficients c(h),...c(1), d(0), ...d(k) as c output of subroutine) c a is matrix (h+k+1 by h+k+1) containing proper coefficients of c phin and theta c d is vector (k+1 by 1) containing coefficients of B^0, ... B^k c (part of output g) c w is vector of frequencies for computing squared gain c rephis is real part of phis(exp(i*w(j)), similarly for red, retheta c imphis is imaginary part of phis(exp(i*w(j)), c similarly for imd, imtheta c requot is real part of (F^m)*phis*d/theta c (evaluated at exp(i*w(j)) in place of B) c imquot is imaginary part of (F^m)*phis*d/theta c (evaluated at exp(i*w(j)) in place of B) c transf is the transfer function (requot^2+imquot^2) times square of c phased is phase delay function c implicit none c----------------------------------------------------------------------- c add include files to define print and save logical vectors, pointer c variables BCM May 2003 c add include files for notset parameters BCM April 2004 c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'cchars.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'error.cmn' include 'seattb.i' c----------------------------------------------------------------------- c c declare input variables c integer qstar,pstar,nthets,npsi,nchcyc,nthadj,nthetp,nchi, 1 nthtra, npscyc, nchpsi, nthcya, ncyc, nthetc double precision thstar(qstar), thets(nthets), 1 psi(npsi), varwns, thadj(nthadj), chcyc(nchcyc), 1 varwna, thetp(nthetp), chi(nchi), varwnp, thtra(nthtra), 1 pscyc(npscyc), varwnt, chpsi(nchpsi), thcya(nthcya), varwca, 1 cyc(ncyc), thetc(nthetc), varwnc c c declare internal variables c character outstr*(110) integer i, j, ii, jj, k, p, q, ps, qs, pn, qn, shft, lda, job, h, 1 kk, info, mx, lb, ub, m, ipos double precision sigrts, sigrtn parameter (mx = 300, kk=1200) double precision phis(0:mx),phin(0:mx),acgths(-mx:mx), 1 acgth(-mx:mx), acgthn(-mx:mx), thetan(0:mx), 1 gmeinf(-2*mx:2*mx), gmem(-2*mx:2*mx), gminfn(-mx:mx), 1 acgtil(-mx:mx), 1 theta(0:mx), g(mx), a(mx,mx),thetas(0:mx), d(0:mx), 1 w(0:kk), rephin(0:kk), imphin(0:kk), c(0:mx), 1 red(0:kk), imd(0:kk), retheta(0:kk), imtheta(0:kk), 1 transf(0:kk), pi, requot(0:kk), imquot(0:kk), phase(0:kk), 1 numer(0:mx), thetil(0:mx),alpha(0:2*mx), refm(0:kk), imfm(0:kk), 1 tmp(-mx:mx), tmp2(-mx:mx), phased(0:kk), svalph(0:60,4) integer ipvt(mx) C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK c----------------------------------------------------------------------- c file handles for signal extraction weights (fhw) and spectral c estimates (fhs) and logical variables for whether file is opened c successfully (locok) and parameters for true and false (T, F) c added by BCM, May 2003 c----------------------------------------------------------------------- INTEGER fhw, fhs, fhc LOGICAL Lgraf, lsvsew, lsvcsp, lsvcsc LOGICAL locok, T, F PARAMETER(T=.TRUE.) * LOGICAL F * PARAMETER(F=.false.) c----------------------------------------------------------------------- c open (unit=6, file='trans.out') c open (unit=7, file='weights.out') c c trans.out contains squared gain, phase and phase delay functions c weights.out contains the filter weights c c----------------------------------------------------------------------- c change to opening separate files with filename, bcm May 2003 c----------------------------------------------------------------------- * IF(Lgraf)THEN * lsvsew=T * lsvcsp=T * ELSE * lsvsew=Savtab(LSESEW) * lsvcsp=Savtab(LSECSP) * END IF * locok=T * IF(lsvsew)call opnfil(T,Lgraf,LSESEW,fhw,locok) * if (locok.and.lsvcsp)call opnfil(T,Lgraf,LSECSP,fhs,locok) * IF (.not.locok) THEN * CALL abend * RETURN * END IF c----------------------------------------------------------------------- c end of change BCM c----------------------------------------------------------------------- p=pstar-1 q=qstar-1 pi=dacos(-1.0D0) lda=mx lb=0 ub=0 do 1 i=0,q theta(i)=thstar(i+1) 1 continue do i=q+1,mx theta(i)=0.0D0 end do c c jj=1 seasonal adjustment filter (S(t) = nonseasonal) c jj=2 seasonal filter (S(t) = seasonal) c jj=3 trend filter (S(t) = trend) c jj=4 cycle filter (S(t) is cycle) c do 5 jj=1,4 * lsvcsc=Lgraf * IF(.not.lsvcsc)lsvcsc=Savtab(LSECSA+jj-1) c seasonal adjustment filter if (jj .eq. 1) then ps=nchcyc-1 pn=npsi-1 qs=nthadj-1 qn=nthets-1 sigrts=varwna sigrtn=varwns do 6 i=0,ps phis(i)=chcyc(i+1) 6 continue do 7 i=0,pn phin(i)=psi(i+1) 7 continue do 8 i=0,qs thetas(i)=thadj(i+1) 8 continue do 9 i=0,qn thetan(i)=thets(i+1) 9 continue end if c c set up for seasonal filter c if (jj .eq. 2) then ps=npsi-1 pn=nchcyc-1 qs=nthets-1 qn=nthadj-1 sigrts=varwns sigrtn=varwna do 10 i=0,ps phis(i)=psi(i+1) 10 continue do 11 i=0,pn phin(i)=chcyc(i+1) 11 continue do 12 i=0,qs thetas(i)=thets(i+1) 12 continue do 13 i=0,qn thetan(i)=thadj(i+1) 13 continue end if C C set up for trend filter C if (jj .eq. 3) then ps=nchi-1 pn=npscyc-1 qs=nthetp-1 qn=nthtra-1 sigrts=varwnp sigrtn=varwnt do 14 i=0,ps phis(i)=chi(i+1) 14 continue do 15 i=0,pn phin(i)=pscyc(i+1) 15 continue do 16 i=0,qs thetas(i)=thetp(i+1) 16 continue do 17 i=0,qn thetan(i)=thtra(i+1) 17 continue end if c c set up for cycle filter c if (jj .eq. 4) then ps=ncyc-1 pn=nchpsi-1 qs=nthetc-1 qn=nthcya-1 sigrts=varwnc sigrtn=varwca do 21 i=0,ps phis(i)=cyc(i+1) 21 continue do 22 i=0,pn phin(i)=chpsi(i+1) 22 continue do 23 i=0,qs thetas(i)=thetc(i+1) 23 continue do 24 i=0,qn thetan(i)=thcya(i+1) 24 continue end if c ---------------------------------------------------------------------- c * IF(lsvcsp)write(fhs,96) if (jj .eq. 1) then if (ps .eq. 0 ) then * IF(lsvcsp)write(fhs,960) * IF(lsvsew)THEN *c write(fhw,960) * DO i=0,60 * svalph(i,jj)=DNOTST * END DO * END IF goto 5 else * IF(lsvcsp)write(fhs, 330) * IF(lsvcsc)THEN * call opnfil(T,Lgraf,LSECSA,fhc,locok) * IF (.not.locok) THEN * CALL abend * RETURN * END IF * END IF end if else if (jj .eq. 2) then if (ps .eq. 0) then * IF(lsvcsp)write(fhs,961) * IF(lsvsew)THEN *c write(fhw,961) * DO i=0,60 * svalph(i,jj)=DNOTST * END DO * END IF goto 5 else ** IF(lsvcsp)write(fhs,340) * IF(lsvcsc)THEN * call opnfil(T,Lgraf,LSECSS,fhc,locok) * IF (.not.locok) THEN * CALL abend * RETURN * END IF * END IF end if else if (jj .eq. 3) then if (ps .eq. 0) then * IF(lsvcsp)write(fhs,962) * IF(lsvsew)THEN *c write(fhw,962) * DO i=0,60 * svalph(i,jj)=DNOTST * END DO * END IF goto 5 else * IF(lsvcsp)write(fhs,350) * IF(lsvcsc)THEN * call opnfil(T,Lgraf,LSECST,fhc,locok) * IF (.not.locok) THEN * CALL abend * RETURN * END IF * END IF end if else if (ps .eq. 0) then * IF(lsvcsp)write(fhs,963) * IF(lsvsew)THEN *c write(fhw,963) * DO i=0,60 * svalph(i,jj)=DNOTST * END DO * END IF goto 5 else * IF(lsvcsp)write(fhs,360) * IF(lsvcsc)THEN * call opnfil(T,Lgraf,LSECSC,fhc,locok) * IF (.not.locok) THEN * CALL abend * RETURN * END IF * END IF end if end if * IF(lsvcsp)write(fhs,96) c c write variables c IF (lsvcsp)THEN write (fhs,50) p, ps, pn,q, qs, qn, sigrts, sigrtn write (fhs,60) (phis(i), i = 0,ps) write (fhs,70) (phin(i), i = 0,pn) write (fhs,80) (thetas(i), i=0,qs) write (fhs,85) (thetan(i), i=0,qn) write (fhs,90) (theta(i), i = 0,q) end if c c compute thetas(F)*thetas(B), note, c will multiply by variance ratio later) c compute thetan(F)*thetan(B) c compute theta(F)*theta(B) call mult0(thetas,mx,qs,thetas,0,mx,0,qs,acgths,mx,mx) call mult0(thetan,mx,qn,thetan,0,mx,0,qn,acgthn,mx,mx) call mult0(theta,mx,q,theta,0,mx,0,q,acgth,mx,mx) c IF(lsvcsp)THEN c write(fhs,96) c write(fhs,101) c 101 format(1x, 'thetan(F)*thetan(B)') c do 100 j=-qn,qn c write(fhs, 102) acgthn(j) c 100 continue c 102 format(1x, f6.3) c write(fhs,96) c write(fhs,103) c 103 format(1x, 'thetas(F)*thetas(B)') c do 104 j=-qs,qs c write(fhs, 102) acgths(j) c 104 continue c write(fhs,96) c write(fhs,105) c 105 format(1x, 'theta(F)*theta(B)') c do 106 j=-q,q c write(fhs, 102) acgth(j) c 106 continue c end if c ---------------------------------------------------------------------- c c start loop for m c compute h and k do 95 m=lb,ub k= max(ps-1,qs+m) h= max(q,pn+qs-m) * * IF(lsvcsp)THEN * write(fhs,96) c write(fhs,97) m c 97 format(1x, 'm is', 1x, i5) c write(fhs,96) * write(fhs,99) h,k * END IF c----------------------------------------------------------------------- c Compute g(B) = phis(F)*thetas(F)*thetas(B). c Store coefficients of F^h, ... , B^k, where k = max(ps,qs) in c (g(1), ... , g(h+k+1))'. Note that some of the first c coefficients are zero if h > pn+qs, and some of the last coefficients c are zero if k > qs. The first nonzero computed coefficient of c phis(F)*ACGF(B) is stored in g(shft) where shft = h-(pn+qs). c do 115 i=1,h+k+1 g(i)=0.0D0 115 continue call mult0(phin, mx, pn, acgths, mx,mx, qs, qs, tmp, mx,mx) shft = h + m - (pn+qs) do 120 i = shft+1, shft+1+pn+2*qs g(i) = tmp(i-shft-1-pn-qs) 120 continue c IF(lsvcsp)write (fhs,125) (g(i), i = 1, h+k+1) c 125 format(/1x, 'g vector',1x, 16(f12.6)) c----------------------------------------------------------------------- c Set up and solve linear equations for c(q),...,c(0),d(1),...,d(k) c where c(F) = c(0) + c(1)*F + ... + c(h)*F^h, d(B) = c 1 + d(1)*B + ... + d(k)*B^k, c and c(F)*phis(B) + theta(F)*d(B) = g(B). c Write linear equations as Ax = g. c c c Set up (h+k+1) by (h+k+1) matrix A for linear equations c do 130 j=1,mx do 131 i=1,mx a(i,j) = 0.0D0 131 continue 130 continue if (h. gt. 0) then do 140 j = 1, h do 141 i = j, ps+j if (i .eq. j) then a(i,j) = 1.0D0 else a(i,j) = phis(i-j) end if 141 continue 140 continue end if do 142 j = h+1, h+k+1 do 144 i = j, j-q, -1 if (i .eq. j) then a(i,j) = 1.0D0 else a(i,j) = theta(j-i) end if 144 continue 142 continue c c write A matrix c c IF(lsvcsp)THEN c write(fhs,150) c 150 format(/1x, 'The "A" matrix') c do 160 i = 1,h+k+1 c write (fhs,170) (a(i,j), j = 1,h+k+1) c 170 format(/1x, 16(f8.2)) c 160 continue c end if c c Solve linear equations Ax = g for x = (c(h),...,c(1),d(0),...,d(k))' c Note that solution (as well as input) is stored in g call dgefa(a,lda,h+k+1,ipvt,info) job=0 call dgesl(a,lda,h+k+1,ipvt,g,job) c c write coefficients g = (c(h),...,c(1),d(0),...,d(k))' c c IF(lsvcsp)THEN c write(fhs,180) c 180 format(/1x, 'coefficients c(h) .. c(1)') c do 190 i=1,h c write(fhs,195) g(i) c 190 continue c 195 format(1x, f14.6) c write(fhs,196) c 196 format(/1x, 'coefficients d(0) .. d(k)') c do 197 i=h+1,h+k+1 c write(fhs,198) g(i) c 197 continue c 198 format(1x, f14.6) c end if c c fill d vector c do 200 i=0,k d(i)=g(i+h+1) 200 continue c c fill c vector c c(0)=0.0D0 do 201 i=h,1, -1 c(i)=g(h-i+1) 201 continue c ---------------------------------------------------------------------- c get coefficients of alpha(B)=(F**m)*phin(B)*d(B)/theta(B) c c first get coefficients of numer(B)=phin(B)*d(B) c call mult1(phin,mx,pn,d,mx,k,numer,mx) c c now get coefficients of thetil(B)=1/theta(B) c only up to order mx c thetil(0)=1.0D0 do 205 j=1,mx thetil(j)=0.0D0 do 206 i=1,j thetil(j)=thetil(j)-theta(i)*thetil(j-i) 206 continue 205 continue c c now get coefficients (up to mx) of alpha(B) (for m = 0) c by taking numer*thetil c first compute numer*thetil c then multiply by F**m (shift by m), and multiply by variance ratio c call mult1(numer,mx,pn+k,thetil,mx,mx,alpha,2*mx) c c store coefficients of F^m, F^m+1,....in alpha(0), alpha(1),... c shifted by m c multiply by variance ratio c do 210 i=0,mx c alpha(i)=sigrts*alpha(i) c 210 continue c c write as many filter coefficients as desired c c IF(lsvcsp)THEN c write(fhs,96) c write(fhs,212) m c 212 format(1x, 'some coefficients of B^i alpha filter for m = ', i3) c write(fhs,211) c write(fhs,217) mx c 217 format(1x, 'mx is', i5) c end if c * IF(lsvsew)THEN * write(fhw,96) * if (jj .eq. 1) then * write(fhw, 213) * else if (jj .eq. 2) then * write(fhw,214) * else if (jj .eq. 3) then * write(fhw,215) * else * write(fhw,216) * end if * write(fhw,96) * write(fhw,217) * write(fhw,96) * do 290 i=0,60 * write(fhw,218) i-m, alpha(i) c write(fhw,218) alpha(i) * svalph(i,jj)=alpha(i) * 290 continue * write(fhw,96) * END IF c 218 format(1x, f10.6) c end if c----------------------------------------------------------------------- c compute mean square error c compute autocovariance generation function gamma(eps,m) c first compute gamma(eps,infinity) c see Bell and Martin, formula (38) c c compute numerator call mult2(acgths, mx, mx, qs, qs, acgthn, mx, mx, qn, qn, 1 gminfn, mx,mx) c c compute denominator call mult0(thetil,mx,mx,thetil,0,mx,0,mx,acgtil,mx,mx) c now multiply to get gmeinf call mult2(gminfn,mx, mx, qs+qn, qs+qn, acgtil, mx, mx, mx, 1 mx, gmeinf, 2*mx, 2*mx) c c multiply by variances c do 219 j=-(mx+qs+qn),mx+qs+qn gmeinf(j)=gmeinf(j)*sigrts*sigrtn 219 continue c c compute rest of gmem = gamma(eps,m) formula (43) c call mult0(c, mx, h, c, 0, mx, 0, h, tmp2, mx,mx) call mult2(tmp2, mx, mx, h, h, acgtil, mx, mx, mx, mx, 1 gmem, 2*mx,2*mx) do 220 j=-(mx+h),mx+h gmem(j)=gmem(j)*(sigrts**2.0D0) 220 continue c IF(lsvcsp)THEN c write(fhs,96) c write(fhs,224) c 224 format(1x, 'coefficients of c(F)*c(B)') c do 225 j=-h,h c write(fhs,226) tmp2(j) c 225 continue c 226 format(1x, f10.3) c END IF c c Now add coefficients of gamma(eps, inf) from above (equation 43) c do 228 j=-mx,mx gmem(j)=gmem(j)+gmeinf(j) 228 continue c IF(lsvcsp)THEN c write(fhs,96) c write(fhs,229) c 229 format(1x, c 1 'coefficients of autocovariance gen. funct. gamma(eps,m)') c do 230 j=0,0 c write(fhs,232) gmem(j) c 230 continue c 232 format(1x, f13.7) c END IF c----------------------------------------------------------------------- c The transfer and phase functions are computed in this section c C C Compute frequencies w(i) C do 238 i = 0,kk w(i) = pi*dble(i)/dble(kk) 238 continue C C Compute real and imaginary parts of polynomials evaluated at c B = exp(-iw(j)) C do 240 j = 0,kk rephin(j)=phin(0) imphin(j)=0.0D0 red(j)=d(0) imd(j)=0.0D0 retheta(j)=theta(0) imtheta(j)=0.0D0 if (pn .gt. 0) then do 241 ii = 1,pn rephin(j)=rephin(j)+phin(ii)*dcos(w(j)*dble(ii)) imphin(j)=imphin(j)-phin(ii)*dsin(w(j)*dble(ii)) 241 continue else rephin(j)=rephin(j) end if do 245 ii=1,k red(j)=red(j)+d(ii)*dcos(w(j)*dble(ii)) imd(j)=imd(j)-d(ii)*dsin(w(j)*dble(ii)) 245 continue if (q .gt. 0) then do 250 ii = 1,q retheta(j)=retheta(j)+theta(ii)*dcos(w(j)*dble(ii)) imtheta(j)=imtheta(j)-theta(ii)*dsin(w(j)*dble(ii)) 250 continue else retheta(j)=retheta(j) end if refm(j)=dcos(w(j)*dble(m)) imfm(j)=dsin(w(j)*dble(m)) 240 continue c compute transfer and phase functions c first compute real and imaginary parts of phis*d/theta c store in requot and imquot c then multiply by exp(i*m*wj) and store result in imquot c c do 300 i=0,kk requot(i)=retheta(i)*(rephin(i)*red(i)-imphin(i)*imd(i))+ 1 imtheta(i)*(rephin(i)*imd(i)+red(i)*imphin(i)) imquot(i)=retheta(i)*(rephin(i)*imd(i)+red(i)*imphin(i))- 1 imtheta(i)*(rephin(i)*red(i)-imphin(i)*imd(i)) requot(i)=requot(i)/(retheta(i)**2.0D0+imtheta(i)**2.0D0) imquot(i)=imquot(i)/(retheta(i)**2.0D0+imtheta(i)**2.0D0) requot(i)=requot(i)*refm(i)-imquot(i)*imfm(i) imquot(i)=imquot(i)*refm(i)+imfm(i)*requot(i) 300 continue do 320 i=0,kk transf(i)=requot(i)**2.0D0+imquot(i)**2.0D0 C C multiplying by square of variance ratio now C transf(i)=transf(i)*(sigrts**2.0D0) c c compute phase shift c if (dpeq(requot(i),0.0D0).and.(imquot(i).gt.0.0D0)) then phase(i)=pi/2.0D0 else if (dpeq(requot(i),0.0D0).and.(imquot(i).lt.0.0D0)) 1 then phase(i)=-pi/2.0D0 else if ((requot(i).lt.0.0D0) .and. (imquot(i).ge.0.0D0)) 1 then phase(i)=datan(imquot(i)/requot(i))+pi else if ((requot(i).lt.0.0D0) .and. (imquot(i).lt.0.0D0)) 1 then phase(i)=datan(imquot(i)/requot(i))-pi else if (requot(i) .gt. 0.0D0) then phase(i)=datan(imquot(i)/requot(i)) else phase(i)=9999.0D0 end if if (i .eq. 0) then phased(i)=0.0D0 else phased(i)=-phase(i)/w(i) end if 320 continue c c write transfer and phase functions at frequencies w(i) c * IF(lsvcsp)write(fhs,96) * IF(lsvcsc)THEN * * write(fhc,1000)'freq',TABCHR,'transferfnc',TABCHR, * & 'phaseshift',TABCHR,'phasedelay' * WRITE(fhc,1000)'----------------------', * & (TABCHR,'----------------------',k=1,3) * * do 400 i=0,kk * ipos=1 * CALL setchr(' ',110,outstr) * CALL dtoc(w(i),outstr,ipos) * IF(Lfatal)RETURN * outstr(ipos:ipos)=TABCHR * ipos=ipos+1 * CALL dtoc(transf(i),outstr,ipos) * IF(Lfatal)RETURN * outstr(ipos:ipos)=TABCHR * ipos=ipos+1 * CALL dtoc(phase(i),outstr,ipos) * IF(Lfatal)RETURN * outstr(ipos:ipos)=TABCHR * ipos=ipos+1 * CALL dtoc(phased(i),outstr,ipos) * IF(Lfatal)RETURN * write(fhc,1002)outstr(1:(ipos-1)) * 400 continue * CALL fclose(fhc) * END IF c 351 format(1x, i4, 1x, f8.3, 1x, 2(f12.6, 1x)) c end loop for m c 95 continue 5 continue c----------------------------------------------------------------------- c write out saved filter weights, if weights are to be saved. c (BCM April 2004) c----------------------------------------------------------------------- * IF(lsvsew)THEN * WRITE(fhw,1001)'lag',TABCHR,'sadj',TABCHR,'seasonal',TABCHR, * & 'trend',TABCHR,'cycle' * WRITE(fhw,1001)'------',(TABCHR,'----------------------',k=1,4) c----------------------------------------------------------------------- * DO i=0,60 * ipos=1 * CALL setchr(' ',110,outstr) * CALL itoc(i,outstr,ipos) * IF(Lfatal)RETURN * DO k=1,4 * outstr(ipos:ipos)=TABCHR * ipos=ipos+1 * CALL dtoc(svalph(i,k),outstr,ipos) * IF(Lfatal)RETURN * END DO c----------------------------------------------------------------------- * WRITE(fhw,1002)outstr(1:(ipos-1)) * END DO c----------------------------------------------------------------------- * END IF c----------------------------------------------------------------------- c Close files opened during routine (BCM, May 2003) c----------------------------------------------------------------------- * IF(locok)THEN * IF(lsvcsp)CALL fclose(fhs) * IF(lsvsew)CALL fclose(fhw) * END IF c----------------------------------------------------------------------- 50 format(1x, 'p =', i3, 1x, 'ps =', i3, 1x, 'pn =', i3, 1x, 1 'q =', i3, 1x, 'qs =', i3, 1x, 'qn =', i3, 1x, 1 'variance ratio for s =', f12.6, 1x, 1 'variance ratio for n =', f12.6) 60 format(/1x, 'phis coefficients',1x, 50(f21.15)) 70 format(/1x, 'phin coefficients',1x, 50(f21.15)) 80 format(/1x, 'thetas coefficients',1x, 50(f21.15)) 85 format(/1x, 'thetan coefficients',1x, 50(f21.15)) 90 format(/1x, 'theta coefficients',1x, 50(f21.15)) 96 format(1x, ' ') 99 format(1x, 'h =', i3, 1x, 'k =', i3) c----------------------------------------------------------------------- 213 format(1x, 1 'weights (for infinite concurrent seasonal adjustment filter)') 214 format(1x, 'weights (for infinite concurrent seasonal filter)') 215 format(1x, 'weights (for infinite concurrent trend filter)') 216 format(1x, 'weights (for infinite concurrent cycle filter)') 217 format(1x, ' i alpha(i)') 218 format(1x, i4, 1x, f10.6) c----------------------------------------------------------------------- 960 format(1x, ' there is no seasonally adjusted component') 961 format(1x, ' there is no seasonal component') 962 format(1x, ' there is no trend component') 963 format(1x, ' there is no cycle component') c----------------------------------------------------------------------- 330 format(1x, 'infinite concurrent seasonal adjustment filter') 340 format(1x, 'infinite concurrent seasonal filter') 350 format(1x, 'infinite concurrent trend filter') 360 format(1x, 'infinite concurrent cycle filter') c----------------------------------------------------------------------- 1000 format(7a) 1001 format(9a) 1002 format(a) c----------------------------------------------------------------------- return end cnvfil.f0000664006604000003110000000274114521201417011622 0ustar sun00315steps SUBROUTINE cnvfil(Oldfile,Nold,Newfile,Nnew,Nlstpth) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine replaces spaces in file names and paths with %20 c and (for DOS systems) forward slashes for back slashes c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' c----------------------------------------------------------------------- CHARACTER Oldfile*(PFILCR),Newfile*(PFILCR) INTEGER Nold,Nnew,Nlstpth,i,jchr c----------------------------------------------------------------------- Nnew=0 DO i=1,Nold jchr=ichar(Oldfile(i:i)) Nnew=Nnew+1 IF(Oldfile(i:i).eq.' ')THEN Newfile(Nnew:(Nnew+2))='%20' Nnew=Nnew+2 ELSE IF(jchr.eq.BSLASH)THEN Newfile(Nnew:Nnew)='/' ELSE Newfile(Nnew:Nnew)=Oldfile(i:i) END IF END DO c----------------------------------------------------------------------- DO Nlstpth=Nnew,1,-1 jchr=ichar(Newfile(Nlstpth:Nlstpth)) cdos backslash for directory cdos IF(jchr.eq.COLON.or.jchr.eq.SLASH)GO TO 10 cunix forward slash for directory IF(jchr.eq.SLASH.or.jchr.eq.COLON)GO TO 10 END DO c ------------------------------------------------------------------ Nlstpth=0 c----------------------------------------------------------------------- 10 RETURN END cnvfmt.f0000664006604000003110000000521614521201417011636 0ustar sun00315stepsC Last change: BCM 12 Mar 98 9:51 am SUBROUTINE cnvfmt(Base,Xfmt,Fobs,Fsum,Fpos,Nfmt) IMPLICIT NONE c----------------------------------------------------------------------- c converts base format to format used in X-13A-S table routine. c Author: Brian C. Monsell c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- CHARACTER base*(110),xfmt*(110),Fobs*(*),Fsum*(*) INTEGER begpos,begxf,Fpos,nfmt,i,n1,n2 c----------------------------------------------------------------------- n1=nblank(Fobs) n2=nblank(Fsum) c----------------------------------------------------------------------- c initialize starting position of base segment, x12 format segment. c----------------------------------------------------------------------- begpos=1 begxf=1 c----------------------------------------------------------------------- c loop through base format c----------------------------------------------------------------------- DO i=1,Fpos c----------------------------------------------------------------------- c search for conversion code (@ for observation fmt, # for summary c fmt). c----------------------------------------------------------------------- IF(Base(i:i).eq.'@'.or.Base(i:i).eq.'#')THEN c----------------------------------------------------------------------- c When code is found, update x12 format with base format before the c last occurance of the code. c----------------------------------------------------------------------- Xfmt(begxf:(begxf+i-begpos-1))=Base(begpos:(i-1)) begxf=begxf+i-begpos c----------------------------------------------------------------------- c Insert proper format instead of code c----------------------------------------------------------------------- IF(Base(i:i).eq.'@')THEN Xfmt(begxf:(begxf+n1-1))=Fobs begxf=begxf+n1 ELSE Xfmt(begxf:(begxf+n2-1))=Fsum begxf=begxf+n2 END IF begpos=i+1 c----------------------------------------------------------------------- c if i is last position of base format, append the final portion c of the format to the x12 format. c----------------------------------------------------------------------- ELSE IF(i.eq.Fpos)THEN Xfmt(begxf:(begxf+i-begpos))=Base(begpos:i) Nfmt=begxf+i-begpos END IF END DO c----------------------------------------------------------------------- RETURN END cnvmdl.f0000664006604000003110000000465414521201417011631 0ustar sun00315stepsC Last change: BCM 25 Feb 1999 9:36 am SUBROUTINE cnvmdl(Ipr,Ips,Idr,Ids,Iqr,Iqs,Id,Ip,Iq,Iprs,Iqrs,N) IMPLICIT NONE c ------------------------------------------------------------------ c Converts X-13ARIMA-SEATS ARIMA modeling data structures to c variables used by TRAMO/SEATS program. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER tmpttl*(PGRPCR) INTEGER Ipr,Ips,Idr,Ids,Iqr,Iqs,Id,Ip,Iq,Iprs,Iqrs,N,iflt,begopr, & endopr,nlag,iopr,ntmpcr c ------------------------------------------------------------------ c Set up values for difference orders from variables on hand. c ------------------------------------------------------------------ Idr=Nnsedf Ids=Nseadf Id=Idr+Sp*Ids c ------------------------------------------------------------------ c Initialize terms for nonseasonal and seasonal AR, MA c ------------------------------------------------------------------ Ipr=0 Ips=0 Iqr=0 Iqs=0 c----------------------------------------------------------------------- c Loop through other operators, getting number of lags in each c ------------------------------------------------------------------ DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 DO iopr=begopr,endopr nlag=Opr(iopr)-Opr(iopr-1) CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(tmpttl(1:ntmpcr).eq.'Nonseasonal AR')THEN Ipr=nlag ELSE IF(tmpttl(1:ntmpcr).eq.'Seasonal AR')THEN Ips=nlag ELSE IF(tmpttl(1:ntmpcr).eq.'Nonseasonal MA')THEN Iqr=nlag ELSE IF(tmpttl(1:ntmpcr).eq.'Seasonal MA')THEN Iqs=nlag END IF END DO END DO c ------------------------------------------------------------------ c Finish setting up other variables relating to AR and MA c ------------------------------------------------------------------ Ip=Ipr+Sp*Ips Iq=Iqr+Sp*Iqs Iprs=Ipr+Ips Iqrs=Iqr+Iqs N=Iprs+Iqrs c ------------------------------------------------------------------ RETURN END cogreg.prm0000664006604000003110000000043614521201417012157 0ustar sun00315steps CHARACTER COGDIC*130 INTEGER cogptr,PCOG PARAMETER(PCOG=9) DIMENSION cogptr(0:PCOG) PARAMETER(COGDIC='seasonaltrigonometric seasonaltrading daylength- &of-monthlength-of-quarterleap yearstock trading daystock length-of &-monthregression') cogreg.var0000664006604000003110000000006614521201421012143 0ustar sun00315steps DATA cogptr / 1,9,31,42,57,74,83,100,121,131 / coladd.f0000664006604000003110000000741414521201421011564 0ustar sun00315stepsC Last change: BCM 14 May 1998 7:50 am **==coladd.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE coladd(Begcol,Endcol,Nrxy,Peltxy,Xy,Ncxy) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine makes room for columns starting at begcol to endcol. c Updates xy and ncxy. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begcol i Local index for the column to make space at c grp i Input 2 element array where the first element is first c column of the added columns in the expanded matrix, c the second element is the number of added columns c i i Local do loop row index c ibeg i Local index bound for the begining element of a row c iend i Local index bound for the last element of a row c j i Local do loop element index c ncxy i Ouput number of columns in X with space for the added columns c naddc i Local number of columns to make room for c nnewc i Local for the number of new columns this equal to ncxy c nrxy i Input number of rows c offset i Local number of elements that a row must be moved c xy d In/out nrxy by noldc or ncxy<=peltxy matrix c----------------------------------------------------------------------- c Data typing c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ INTEGER Begcol,Endcol,i,ibeg,iend,j,Ncxy,naddc,nnewc,Nrxy,offset, & Peltxy DOUBLE PRECISION Xy DIMENSION Xy(Peltxy) c----------------------------------------------------------------------- c Check that 1<=begcol<=noldc+1 and nrxy*(noldc+naddc)<=peltxy c----------------------------------------------------------------------- naddc=Endcol-Begcol+1 nnewc=Ncxy+naddc c ------------------------------------------------------------------ IF(Begcol.lt.1.or.Begcol.gt.Ncxy+1)THEN WRITE(STDERR,1010)Begcol,Ncxy CALL errhdr WRITE(Mt2,1010)Begcol,Ncxy 1010 FORMAT(/,' ERROR: Invalid column information: Beginning ', & 'column of the insertion',/, & ' must be between 1<=begcol<=ncxy+1',/, & ' 1<=',i4,'<=',i4,'.') CALL abend RETURN c ------------------------------------------------------------------ ELSE IF(Nrxy*nnewc.gt.Peltxy)THEN WRITE(STDERR,1020)Nrxy,Ncxy,naddc,Peltxy CALL errhdr WRITE(Mt2,1020)Nrxy,Ncxy,naddc,Peltxy 1020 FORMAT(/,' ERROR: nrxy*(noldc+naddc)=',i4,'*(',i4,'+',i4,')>', & i6,'.') CALL abend RETURN END IF c----------------------------------------------------------------------- c Since elements are added to the same matrix start at the end. c First setup the indices and index bounds c----------------------------------------------------------------------- offset=Nrxy*naddc iend=Nrxy*Ncxy ibeg=iend-Ncxy+Begcol c ------------------------------------------------------------------ DO j=iend,ibeg,-1 Xy(j+offset)=Xy(j) END DO c ------------------------------------------------------------------ DO i=Nrxy-1,1,-1 offset=i*naddc iend=ibeg-1 ibeg=iend-Ncxy+1 c ------------------------------------------------------------------ DO j=iend,ibeg,-1 Xy(j+offset)=Xy(j) END DO END DO Ncxy=nnewc c ------------------------------------------------------------------ RETURN END combft.f0000664006604000003110000000475514521201422011616 0ustar sun00315stepsC Last change: BCM 29 Jan 98 1:14 pm **==combft.f processed by SPAG 4.03F at 15:12 on 1 Aug 1994 SUBROUTINE combft(Lprt) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINUE PRODUCES THE COMBINED TEST FOR THE PRESENCE OF C --- IDENTIFIABLE SEASONALITY. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'units.cmn' INCLUDE 'ssap.prm' INCLUDE 'ssft.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'tests.cmn' c----------------------------------------------------------------------- CHARACTER xb*50 DOUBLE PRECISION test INTEGER sp1 LOGICAL Lprt c----------------------------------------------------------------------- sp1=0 IF(Lwdprt)sp1=18 xb=' ' c----------------------------------------------------------------------- Iqfail=1 Test1=9D0 IF(Fstabl*9D0.ge.7D0)Test1=7D0/Fstabl IF(Fstabl.gt.0D0)Test2=(3D0*Fmove)/Fstabl IF(Test2.gt.9D0.or.Fstabl.le.0D0)Test2=9D0 IF(.not.Lhiddn.and.Lprt)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1010)xb(1:(sp1+2)) END IF 1010 FORMAT(/,a, & 'COMBINED TEST FOR THE PRESENCE OF IDENTIFIABLE SEASONALITY') IF(P1.lt.0.1D0)THEN IF(P2.le.5D0)THEN test=(Test1+Test2)/2D0 IF(test.ge.1D0)GO TO 10 END IF IF(Test1.lt.1D0)THEN IF(P5.le.0.1D0)THEN IF(Test2.lt.1D0)THEN IF(.not.Lhiddn.and.Lprt)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1020)xb(1:(sp1+12)) END IF 1020 FORMAT(/,a,'IDENTIFIABLE SEASONALITY PRESENT') IF(Issap.eq.2)Issqf(Icol)=0 RETURN END IF END IF END IF IF(.not.Lhiddn.and.Lprt)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1030)xb(1:(sp1+12)) END IF 1030 FORMAT(/,a,'IDENTIFIABLE SEASONALITY PROBABLY NOT PRESENT') IF(Issap.eq.2)Issqf(Icol)=1 RETURN END IF 10 IF(.not.Lhiddn.and.Lprt)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1040)xb(1:(sp1+12)) END IF 1040 FORMAT(/,a,'IDENTIFIABLE SEASONALITY NOT PRESENT') Iqfail=2 IF(Issap.eq.2)Issqf(Icol)=2 c----------------------------------------------------------------------- RETURN END compb.f0000664006604000003110000000571214521201422011436 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:39 pm **==compb.f processed by SPAG 4.03F at 12:23 on 21 Jun 1994 SUBROUTINE compb(Xavg,Xmnx,Xran,I,Xcm,Ncol) IMPLICIT NONE c----------------------------------------------------------------------- c ***** computes monthly means of seasonal factors for each span and c ***** all spans. determines which months have the maximum and c ***** minimum averages for each span and all spans (xmnx). c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' c----------------------------------------------------------------------- CHARACTER Xcm*(3) DOUBLE PRECISION Xavg,xmax,xmin,Xmnx,Xran INTEGER I,i2,ij,j,ji,k,Kountr,Ncol DIMENSION Xavg((MXCOL+1),PSP),Xmnx((MXCOL+1),2),Xran(MXCOL+1), & Xcm((MXCOL+1),PSP),Kountr(MXCOL,PSP) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- COMMON /kcom / Kountr c----------------------------------------------------------------------- c compute range of the ith span c----------------------------------------------------------------------- Xran(I)=Xmnx(I,2)-Xmnx(I,1) c----------------------------------------------------------------------- c compute average sf for all spans c----------------------------------------------------------------------- IF(I.eq.Ns1)THEN DO j=1,Nsea k=0 DO i2=1,Ncol k=Kountr(i2,j)+k END DO Xavg(I,j)=Xavg(I,j)/k END DO ELSE c----------------------------------------------------------------------- c compute average sf for span i c----------------------------------------------------------------------- DO j=1,Nsea Xavg(I,j)=Xavg(I,j)/Kountr(I,j) END DO c----------------------------------------------------------------------- c compute min and max for all spans c----------------------------------------------------------------------- IF(Xmnx(Ns1,1).gt.Xmnx(I,1))Xmnx(Ns1,1)=Xmnx(I,1) IF(Xmnx(Ns1,2).lt.Xmnx(I,2))Xmnx(Ns1,2)=Xmnx(I,2) END IF c----------------------------------------------------------------------- C Label min and max seasonal factor for span i c----------------------------------------------------------------------- xmax=100.D0 xmin=100.D0 ij=0 ji=0 DO j=1,Nsea Xcm(I,j)=' ' IF(xmin.gt.Xavg(I,j))THEN xmin=Xavg(I,j) Xcm(I,j)='min' IF(ij.gt.0)Xcm(I,ij)=' ' ij=j ELSE IF(xmax.lt.Xavg(I,j))THEN xmax=Xavg(I,j) Xcm(I,j)='max' IF(ji.gt.0)Xcm(I,ji)=' ' ji=j END IF END DO c----------------------------------------------------------------------- RETURN END compcrodiag.f0000664006604000003110000005120014521201422012616 0ustar sun00315steps SUBROUTINE compCroDiag( nT, dS, dT, nPer, & finfact, sdSig, vIrrEst, nIrrEst, & vSeaEst, nSeaEst, vTreEst, nTreEst, & dDelS, nDelS, dDelT, nDelT, dDel, nDel, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & mInvSigW, nInvSigW, mSigUS, nSigUS, & mSigUT, nSigUT, mSigUI, nSigUI, & fulEst, fulEso, fulVar, fulDia, pLagSmT ) c----------------------------------------------------------------------- c compLagDiag.f, Release 1, Subroutine Version 1.3, Modified 04 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 21 Jul 2005. c Modified by REG, on 11/10/2005, to generalize covariance structure c of irregular component, using mSigUI instead of sIrrVar; c and to clean up tab stops in code. c Modified by REG, on 13 Jan 2006, to optimize matrix operations, c by using diagonal matrix utilities. c Modified by REG, on 04 May 2006, to calculate estimate and variance c for each diagnostic relative to the innovation variance to match c SEATS output, and to move finite factor processing to getDiag() c eliminating the need for input nParam, nFixed, and nDiff. c----------------------------------------------------------------------- c This subroutine calculates some cross component diagnostics. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dDel d diagonal form of overall differencing matrix: mDel c dDelS d diagonal form of seasonal differencing matrix: mDelS c dDelT d diagonal form of trend differencing matrix: mDelT c dRedDelS d diagonal form of reduced mDelS: mRedDelS c dRedDelT d diagonal form of reduced mDelT: mRedDelT c dS i size of Seasonal Differencing c dT i size of Trend Differencing c finfact d finite sample correction factor c fulDia d vector of normalized diagnostics from full signals c for irregular, seasonal, and trend c fulEso d vector of null means of estimates from full signals c for irregular, seasonal, and trend c fulEst d vector of diagnostic estimates from full signals c for irregular, seasonal, and trend c fulVar d vector of variances of diagnostics from full signals c for irregular, seasonal, and trend c mDel d full differencing matrix c mDelS d seasonal differencing matrix c mDelT d trend differencing matrix c mDel d size (rows,columns) of mDel c mInvSigW d inverse of matrix mSigW c mRedDelS d smaller version of mDelS c mRedDelT d smaller version of mDelT c mSigUI d covariance matrix for undifferenced irregular c mSigUS d covariance matrix for differenced seasonal c mSigUT d covariance matrix for differenced trend c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nInvSigW i size (rows,columns) of mInvSigW c nRedDelS i size (rows,columns) of mRedDelS c nRedDelT i size (rows,columns) of mRedDelT c nSigUI i size (rows,columns) of mSigUI matrix c nSigUS i size (rows,columns) of mSigUS matrix c nSigUT i size (rows,columns) of mSigUT matrix c nIrrEst d size (rows,columns) of vIrrEst vector c nSeaEst d size (rows,columns) of vSeaEst vector c nTreEst d size (rows,columns) of vTreEst vector c nPer i size of seasonal period c nT i size of data available c sdSig d estimated data innovation stdev corrected for number of c estimated model parameters c vIrrEst d estimated irregular c vSeaEst d estimated seasonal c vTreEst d estimated trend c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c ddot d external function reference c dLagS d diagonal form of seasonal selection matrix: mLagS c dLagSmT d diagonal form of seasonal-trend selection matrix: mLagSmT c dLagT d diagonal form of trend selection matrix: mLagT c getTrc d external function reference c HALF d constant parameter c innovar d model innovation variance adjusted for finite sample c i,j i index variables for do loops c k1,k2,k3 d miscellaneous constants c mCov d storage of covariance matrix for each diagnostic c mLagS d seasonal selection matrix c mLagSmT d seasonal-trend selection matrix c mLagT d trend selection matrix c mTemp3 d temporary matrix 3 used as storage for intermediate results c mTemp4 d temporary matrix 4 used as storage for intermediate results c mTemp5 d temporary matrix 5 used as storage for intermediate results c mTemp6 d temporary matrix 6 used as storage for intermediate results c mTemp6Tr d temporary matrix 6Tr used as storage for intermediate results c mTemp7 d temporary matrix 7 used as storage for intermediate results c mTempA d temporary matrix A used as storage for intermediate results c mTempB d temporary matrix B used as storage for intermediate results c mTempD d temporary matrix D used as storage for intermediate results c mTempE d temporary matrix E used as storage for intermediate results c mTempF d temporary matrix F used as storage for intermediate results c nCov i size (rows,columns) of mCov matrix c nLagS i size (rows,columns) of mLagS matrix c nLagT i size (rows,columns) of mLagT matrix c nLagSmT i size (rows,columns) of mLagSmT matrix c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp1 i size (rows,columns) of vTemp1 vector c nTemp2 i size (rows,columns) of vTemp2 vector c nTemp3 i size (rows,columns) of mTemp3 scalar c nTemp4 i size (rows,columns) of mTemp4 matrix c nTemp5 i size (rows,columns) of mTemp5 matrix c nTemp6 i size (rows,columns) of mTemp6 matrix c nTemp6Tr i size (rows,columns) of mTemp6Tr matrix c nTemp7 i size (rows,columns) of mTemp7 matrix c nTemp9 i size (rows,columns) of vTemp9 vector c nTempA i size (rows,columns) of mTempA matrix c nTempB i size (rows,columns) of mTempB matrix c nTempC i size (rows,columns) of vTempC vector c nTempD i size (rows,columns) of mTempD matrix c nTempE i size (rows,columns) of mTempE matrix c nTempF i size (rows,columns) of mTempF matrix c ONE d constant parameter c TWO d constant parameter c vTemp1 d temporary vector 1 c vTemp2 d temporary vector 2 c vTemp9 d temporary vector 9 c vTempC d temporary vector C c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER lag, nT, dS, dT, nPer INTEGER nIrrEst(2), nSeaEst(2), nTreEst(2) INTEGER nDel(2), nDelS(2), nDelT(2) INTEGER nRedDelS(2), nRedDelT(2), nInvSigW(2) INTEGER nSigUS(2), nSigUT(2), nSigUI(2), pLagSmT DOUBLE PRECISION finfact, sdSig DOUBLE PRECISION vIrrEst(nT), vSeaEst(nT), vTreEst(nT) DOUBLE PRECISION dDel(dS+dT+1), dDelS(dS+1), dDelT(dT+1), & dRedDelS(dS+1), dRedDelT(dT+1) c DOUBLE PRECISION mDel(nT-dS-dT,nT), mDelS(nT-dS,nT), c & mDelT(nT-dT,nT) c DOUBLE PRECISION mRedDelS(nT-dS-dT,nT-dT),mRedDelT(nT-dS-dT,nT-dS) DOUBLE PRECISION mInvSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION mSigUS(nT-dS,nT-dS), mSigUT(nT-dT,nT-dT), & mSigUI(nT,nT) DOUBLE PRECISION fulEst(3), fulEso(3), fulVar(3), fulDia(3) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j INTEGER nLagS(2), nLagT(2), nLagSmT(2) INTEGER nTemp1(2), nTemp2(2), nTemp3(2), nTemp4(2), nTemp5(2), & nTemp6(2), nTemp6Tr(2), nTemp7(2), nTemp9(2), nTempA(2), & nTempB(2), nTempC(2), nTempD(2), nTempE(2), nTempF(2) INTEGER nCov(2) DOUBLE PRECISION innovar DOUBLE PRECISION dLagS(dS+1), dLagT(dT+1), dLagSmT(pLagSmT) DOUBLE PRECISION vTemp1(nT-dS), vTemp2(nT-dS), & vTemp9(nT-dT), vTempC(nT-dT) DOUBLE PRECISION ddot DOUBLE PRECISION k1, k2, k3, ZERO, HALF, ONE, TWO DOUBLE PRECISION getTrc, getTrcAB PARAMETER (ZERO=0.0D0, HALF=0.5D0, ONE=1.0D0, TWO=2.0D0) LOGICAL dpeq c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mLagS(nT-dS,nT), mLagT(nT-dT,nT), c & mLagSmT(nT-dS,nT-dT) c DOUBLE PRECISION mTemp3(nT-dS,nT), mTemp4(nT-dS-dT,nT-dS), c & mTemp5(nT-dS,nT-dS-dT), c & mTemp6(nT-dS-dT,nT-dS-dT), c & mTemp6Tr(nT-dS-dT,nT-dS-dT), c & mTemp7(nT-dS-dT,nT-dS-dT), c & mTempA(nT-dS,nT-dT), mTempB(nT-dS,nT-dS-dT), c & mTempD(nT-dS-dT,nT-dT), mTempE(nT-dT,nT-dS-dT) c & mTempF(nT-dT,nT) c DOUBLE PRECISION mCov(nT-dS-dT,nT-dS-dT) c ------------------------------------------------------------------ INTEGER nSave PARAMETER (nSave=POBS*POBS) c DOUBLE PRECISION mLagS(nSave), mLagT(nSave), mLagSmT(nSave) DOUBLE PRECISION mTemp3(nSave), mTemp4(nSave), mTemp5(nSave), & mTemp6(nSave), mTemp6Tr(nSave), & mTemp7(nSave), mTempA(nSave), mTempB(nSave), & mTempD(nSave), mTempE(nSave), mTempF(nSave) DOUBLE PRECISION mCov(nSave) c SAVE mLagS, mLagT, mLagSmT SAVE mTemp4, mTemp5, mTemp6, mTemp6Tr, mCov, mTempA EQUIVALENCE (mTemp4,mTemp7),(mTemp5, mTempB),(mTemp4,mTempD), & (mTemp5,mTempE),(mTempA,mTemp3),(mTempA,mTempF) c----------------------------------------------------------------------- c Initialize the outputs. c----------------------------------------------------------------------- DO i = 1,3 fulEst(i) = ZERO fulEso(i) = ZERO fulVar(i) = ZERO fulDia(i) = ZERO END DO c----------------------------------------------------------------------- c Calculate model innovation variance adjusted for finite sample. c----------------------------------------------------------------------- innovar = ( sdSig*sdSig ) k1 = TWO/DBLE(nT*nT) k3 = (TWO*finfact - (finfact*finfact))/DBLE(nT-dS-dT) c----------------------------------------------------------------------- c Compute the lag matrices. c----------------------------------------------------------------------- nLagS(1) = nT-dS nLagS(2) = nT nLagT(1) = nT-dT nLagT(2) = nT nLagSmT(1) = nT-dS nLagSmT(2) = nT-dT c ------------------------------------------------------------------ c DO j = 1, nLagS(2) c DO i = 1, nLagS(1) c mLagS((j-1)*nLagS(1)+i) = ZERO c END DO c IF (j.gt.dS) THEN c i = j-dS c mLagS((j-1)*nLagS(1)+i) = ONE c END IF c END DO c ------------------------------------------------------------------ DO j = 1, dS dLagS(j) = ZERO END DO dLagS(dS+1) = ONE c ------------------------------------------------------------------ c DO j = 1, nLagT(2) c DO i = 1, nLagT(1) c mLagT((j-1)*nLagT(1)+i) = ZERO c END DO c IF (j.gt.dT) THEN c i = j-dT c mLagT((j-1)*nLagT(1)+i) = ONE c END IF c END DO c ------------------------------------------------------------------ DO j = 1, dT dLagT(j) = ZERO END DO dLagT(dT+1) = ONE c ------------------------------------------------------------------ c DO j = 1, nLagSmT(2) c DO i = 1, nLagSmT(1) c mLagSmT((j-1)*nLagSmT(1)+i) = ZERO c END DO c IF (j.gt.(dS-dT)) THEN c i = j-(dS-dT) c mLagSmT((j-1)*nLagSmT(1)+i) = ONE c END IF c END DO c ------------------------------------------------------------------ DO j = 1, dS-dT dLagSmT(j) = ZERO END DO dLagSmT(max(dS-dT+1,1)) = ONE c----------------------------------------------------------------------- c Compute the Seasonal-Irregular cross component diagnostic c----------------------------------------------------------------------- c Calculate the estimate c ------------------------------------------------------------------ pdA = max(nDelS(2)-nDelS(1)+1, 1) CALL mulDMat( dDelS, nDelS, vSeaEst, nSeaEst, vTemp1, nTemp1, & pdA ) pdA = max(nLagS(2)-nLagS(1)+1, 1) CALL mulDMat( dLagS, nLagS, vIrrEst, nIrrEst, vTemp2, nTemp2, & pdA ) IF (( nTemp1(1) .ne. 0 ) .and. ( nTemp1(1) .eq. nTemp2(1) )) THEN fulEst(1) = ddot( nTemp1(1), vTemp1, 1, vTemp2, 1 ) & / (innovar*DBLE(nT)) END IF c ------------------------------------------------------------------ c Calculate the covariance matrix c ------------------------------------------------------------------ pdA = max(nRedDelT(2)-nRedDelT(1)+1, 1) CALL mulDMat( dRedDelT, nRedDelT, mSigUS, nSigUS, mTemp4, nTemp4, & pdA ) pdA = max(nLagS(2)-nLagS(1)+1, 1) CALL mulDMat( dLagS, nLagS, mSigUI, nSigUI, mTemp3, nTemp3, pdA ) pdA = max(nDel(2)-nDel(1)+1, 1) CALL mulMatDTr( mTemp3, nTemp3, dDel, nDel, mTemp5, nTemp5, pdA ) CALL mulMat( mTemp4, nTemp4, mTemp5, nTemp5, mTemp6, nTemp6 ) CALL getTr( mTemp6, nTemp6, mTemp6Tr, nTemp6Tr ) CALL addMat( mTemp6, nTemp6, mTemp6Tr, nTemp6Tr, mCov, nCov ) CALL mulSca( HALF, mCov, nCov ) c ------------------------------------------------------------------ c Calculate the estimator c ------------------------------------------------------------------ CALL mulMat( mInvSigW, nInvSigW, mCov, nCov, mTemp7, nTemp7 ) IF ( nTemp7(1) .ne. 0 ) THEN fulEso(1) = getTrc( mTemp7, nTemp7 )/DBLE(nT) END IF c ------------------------------------------------------------------ c Calculate the variance c ------------------------------------------------------------------ fulVar(1) = k1*( getTrcAB( mTemp7, nTemp7, mTemp7, nTemp7 ) & - k3*( getTrc( mTemp7, nTemp7 )**2 )) c ------------------------------------------------------------------ c Calculate the cross component diagnostic c ------------------------------------------------------------------ IF ( .not. dpeq(fulVar(1),ZERO) ) THEN fulDia(1) = (fulEst(1) - fulEso(1))/DSQRT(fulVar(1)) END IF c----------------------------------------------------------------------- c Compute the Seasonal-Trend cross component diagnostic c----------------------------------------------------------------------- c Calculate the estimate relative to the innovation variance c ------------------------------------------------------------------ c CALL mulDMat( dDelS, nDelS, vSeaEst, nSeaEst, vTemp1, nTemp1 ) pdA = max(nDelT(2)-nDelT(1)+1, 1) CALL mulDMat( dDelT, nDelT, vTreEst, nTreEst, vTemp9, nTemp9, & pdA ) pdA = max(nLagSmT(2)-nLagSmT(1)+1, 1) CALL mulDMat( dLagSmT, nLagSmT, vTemp9, nTemp9, vTemp2, nTemp2, & pdA ) IF (( nTemp1(1) .ne. 0 ) .and. ( nTemp1(1) .eq. nTemp2(1) )) THEN fulEst(2) = ddot( nTemp1(1), vTemp1, 1, vTemp2, 1 ) & / (innovar*DBLE(nT)) END IF c ------------------------------------------------------------------ c Calculate the covariance matrix c ------------------------------------------------------------------ pdA = max(nRedDelT(2)-nRedDelT(1)+1, 1) CALL mulDMat( dRedDelT, nRedDelT, mSigUS, nSigUS, mTemp4, nTemp4, & pdA ) pdA = max(nLagSmT(2)-nLagSmT(1)+1, 1) CALL mulDMat( dLagSmT, nLagSmT, mSigUT, nSigUT, mTempA, nTempA, & pdA ) pdA = max(nRedDelS(2)-nRedDelS(1)+1, 1) CALL mulMatDTr( mTempA, nTempA, dRedDelS, nRedDelS, & mTempB, nTempB, pdA ) CALL mulMat( mTemp4, nTemp4, mTempB, nTempB, mTemp6, nTemp6 ) CALL getTr( mTemp6, nTemp6, mTemp6Tr, nTemp6Tr ) CALL addMat( mTemp6, nTemp6, mTemp6Tr, nTemp6Tr, mCov, nCov ) CALL mulSca( HALF, mCov, nCov ) c ------------------------------------------------------------------ c Calculate the estimator c ------------------------------------------------------------------ CALL mulMat( mInvSigW, nInvSigW, mCov, nCov, mTemp7, nTemp7 ) IF ( nTemp7(1) .ne. 0 ) THEN fulEso(2) = getTrc( mTemp7, nTemp7 )/DBLE(nT) END IF c ------------------------------------------------------------------ c Calculate the variance relative to the innovation variance c ------------------------------------------------------------------ fulVar(2) = k1*( getTrcAB( mTemp7, nTemp7, mTemp7, nTemp7 ) & - k3*( getTrc( mTemp7, nTemp7 )**2 )) c ------------------------------------------------------------------ c Calculate the cross component diagnostic c ------------------------------------------------------------------ IF ( .not. dpeq(fulVar(2),ZERO) ) THEN fulDia(2) = (fulEst(2) - fulEso(2))/DSQRT(fulVar(2)) END IF c----------------------------------------------------------------------- c Compute the Trend-Irregular cross component diagnostic c----------------------------------------------------------------------- c Calculate the estimate relative to the innovation variance c ------------------------------------------------------------------ c CALL mulDMat( dDelT, nDelT, vTreEst, nTreEst, vTemp9, nTemp9 ) pdA = max(nLagT(2)-nLagT(1)+1, 1) CALL mulDMat( dLagT, nLagT, vIrrEst, nIrrEst, vTempC, nTempC, & pdA ) IF (( nTemp9(1) .ne. 0 ) .and. ( nTemp9(1) .eq. nTempC(1) )) THEN fulEst(3) = ddot( nTemp9(1), vTemp9, 1, vTempC, 1 ) & / (innovar*DBLE(nT)) END IF c ------------------------------------------------------------------ c Calculate the covariance matrix c ------------------------------------------------------------------ pdA = max(nRedDelS(2)-nRedDelS(1)+1, 1) CALL mulDMat( dRedDelS, nRedDelS, mSigUT, nSigUT, mTempD, nTempD, & pdA ) pdA = max(nLagT(2)-nLagT(1)+1, 1) CALL mulDMat( dLagT, nLagT, mSigUI, nSigUI, mTempF, nTempF, & pdA ) pdA = max(nDel(2)-nDel(1)+1, 1) CALL mulMatDTr( mTempF, nTempF, dDel, nDel, mTempE, nTempE, pdA ) CALL mulMat( mTempD, nTempD, mTempE, nTempE, mTemp6, nTemp6 ) CALL getTr( mTemp6, nTemp6, mTemp6Tr, nTemp6Tr ) CALL addMat( mTemp6, nTemp6, mTemp6Tr, nTemp6Tr, mCov, nCov ) CALL mulSca( HALF, mCov, nCov ) c ------------------------------------------------------------------ c Calculate the estimator c ------------------------------------------------------------------ CALL mulMat( mInvSigW, nInvSigW, mCov, nCov, mTemp7, nTemp7 ) IF ( nTemp7(1) .ne. 0 ) THEN fulEso(3) = getTrc( mTemp7, nTemp7 )/DBLE(nT) END IF c ------------------------------------------------------------------ c Calculate the variance relative to the innovation variance c ------------------------------------------------------------------ fulVar(3) = k1*( getTrcAB( mTemp7, nTemp7, mTemp7, nTemp7 ) & - k3*( getTrc( mTemp7, nTemp7 )**2 )) c ------------------------------------------------------------------ c Calculate the cross component diagnostic c ------------------------------------------------------------------ IF ( .not. dpeq(fulVar(3),ZERO) ) THEN fulDia(3) = (fulEst(3) - fulEso(3))/DSQRT(fulVar(3)) END IF c----------------------------------------------------------------------- RETURN ENDcompdiag.f0000664006604000003110000004421314521201422012120 0ustar sun00315steps SUBROUTINE compDiag( nT, dS, dT, nPer, nParam, nFixed, nDiff, & sdSig, sdSigAlt, vIrrEst, nIrrEst, & vSeaEst, nSeaEst, vTreEst, nTreEst, & dDelS, nDelS, dDelT, nDelT, & mCovIrr, nCovIrr, mCovSea, nCovSea, & mCovTre, nCovTre, mCovSA, nCovSA, & fulEst, noeEst, fulEso, noeEso, & fulVar, noeVar, fulDia, noeDia ) c----------------------------------------------------------------------- c compDiag.f, Release 1, Subroutine Version 1.1, Modified 13 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 14 Apr 2005. c Modified by REG, on 13 Jan 2006, to optimize matrix processing, c by using getTrcAB utility, and by using diagonal matrix c utilities; to clean up tab stops. c----------------------------------------------------------------------- c This subroutine calculates some diagnostics. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dDelS d diagonal form of seasonal differencing matrix: mDelS c dDelT d diagonal form of trend differencing matrix: mDelT c dS i size of Seasonal Differencing c dT i size of Trend Differencing c fulDia d vector of normalized diagnostics from full signals c for irregular, seasonal, trend, and SA c fulEso d vector of null means of estimates from full signals c for irregular, seasonal, trend, and SA c fulEst d vector of diagnostic estimates from full signals c for irregular, seasonal, trend, and SA c fulVar d vector of variances of diagnostics from full signals c for irregular, seasonal, trend, and SA c mCovIrr d covariance of estimated irregular c mCovSA d covariance of estimated seasonal adjusted c mCovSea d covariance of estimated seasonal c mCovTre d covariance of estimated trend c mDelS d seasonal differencing matrix c mDelT d trend differencing matrix c nCovIrr d size (rows,columns) of mCovIrr matrix c nCovSA d size (rows,columns) of mCovSA matrix c nCovSea d size (rows,columns) of mCovSea matrix c nCovTre d size (rows,columns) of mCovTre matrix c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nIrrEst d size (rows,columns) of vIrrEst vector c nSeaEst d size (rows,columns) of vSeaEst vector c nTreEst d size (rows,columns) of vTreEst vector c nDiff i vector of (d,D) differencing orders c nFixed i number of fixed parameters c nPer i size of seasonal period c nParam i number of parameters c nT i size of data available c noeDia d vector of normalized diagnostics from trimmed signals c for irregular, seasonal, trend, and SA c noeEso d vector of null means of estimate from trimmed signals c for irregular, seasonal, trend, and SA c noeEst d vector of diagnostic estimates from trimmed signals c for irregular, seasonal, trend, and SA c noeVar d vector of variances of diagnostics from trimmed signals c for irregular, seasonal, trend, and SA c sdSig d data innovation stdev c sdSigAlt d alternate data innovation stdev when parameters are fixed c vIrrEst d estimated irregular c vSeaEst d estimated seasonal c vTreEst d estimated trend c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c finfact d finite sample correction factor c getTrc d external function reference c innovar d model innovation variance adjusted for finite sample c k1,k2,k3 d miscellaneous constants c mCovIrrNoe d no-end irregular covariance matrix c mCovSeaNoe d no-end seasonal covariance matrix c mCovTreNoe d no-end trend covariance matrix c mCovSANoe d no-end SA covariance matrix c nCovIrrNoe d size (rows,columns) of mCovIrrNoe matrix c nCovSeaNoe d size (rows,columns) of mCovSeaNoe matrix c nCovTreNoe d size (rows,columns) of mCovTreNoe matrix c nCovSANoe d size (rows,columns) of mCovSANoe matrix c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp1 d size (rows,columns) of vTemp1 vector c nTemp2 d size (rows,columns) of vTemp2 vector c nTemp3 d size (rows,columns) of vTemp3 vector c ONE d constant paramenter c sumsqr d external function reference c trCovIrr d trace of mCovIrr matrix c trCovIrrNoe d trace of mCovIrrNoe matrix c trCovSea d trace of mCovSea matrix c trCovSeaNoe d trace of mCovSeaNoe matrix c trCovTre d trace of mCovTre matrix c trCovTreNoe d trace of mCovTreNoe matrix c trCovSA d trace of mCovSA matrix c trCovSANoe d trace of mCovSANoe matrix c trCovIrrSq d trace of mCovIrr squared matrix c trCovIrrNoeSq d trace of mCovIrrNoe squared matrix c trCovSeaSq d trace of mCovSea squared matrix c trCovSeaNoeSq d trace of mCovSeaNoe squared matrix c trCovTreSq d trace of mCovTre squared matrix c trCovTreNoeSq d trace of mCovTreNoe squared matrix c trCovSASq d trace of mCovSA squared matrix c trCovSANoeSq d trace of mCovSANoe squared matrix c vTemp1 d temporary vector 1 c vTemp2 d temporary vector 2 c vTemp3 d temporary vector 3 c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nT, dS, dT, nPer, nParam, nFixed, nDiff(2) INTEGER nIrrEst(2), nSeaEst(2), nTreEst(2) INTEGER nDelS(2), nDelT(2) INTEGER nCovIrr(2), nCovSea(2), nCovTre(2), nCovSA(2) DOUBLE PRECISION sdSig, sdSigAlt DOUBLE PRECISION vIrrEst(nT), vSeaEst(nT), vTreEst(nT) DOUBLE PRECISION dDelS(dS+1), dDelT(dT+1) c DOUBLE PRECISION mDelS(nT-dS,nT), mDelT(nT-dT,nT) DOUBLE PRECISION mCovIrr(nT,nT), mCovSea(nT-dS,nT-dS), & mCovTre(nT-dT,nT-dT), mCovSA(nT-dT,nT-dT) DOUBLE PRECISION fulEst(4), noeEst(4), fulEso(4), noeEso(4), & fulVar(4), noeVar(4), fulDia(4), noeDia(4) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i INTEGER nTemp1(2), nTemp2(2), nTemp3(2) INTEGER nCovIrrNoe(2), nCovSeaNoe(2), nCovTreNoe(2), nCovSANoe(2) DOUBLE PRECISION finfact, innovar DOUBLE PRECISION vTemp1(nT-dS), vTemp2(nT-dT), vTemp3(nT) DOUBLE PRECISION trCovIrr, trCovIrrNoe, trCovSea, trCovSeaNoe, & trCovTre, trCovTreNoe, trCovSA, trCovSANoe DOUBLE PRECISION trCovIrrSq, trCovIrrNoeSq, trCovSeaSq, & trCovSeaNoeSq, trCovTreSq, trCovTreNoeSq, & trCovSASq, trCovSANoeSq DOUBLE PRECISION k1, k2, k3, TWO, ZERO DOUBLE PRECISION getTrc, getTrcAB, sumsqr PARAMETER (ZERO=0.0D0, TWO=2.0D0) LOGICAL dpeq c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mCovIrrNoe(nT-2*nPer,nT-2*nPer), c & mCovSeaNoe(nT-2*nPer,nT-2*nPer), c & mCovTreNoe(nT-2*nPer,nT-2*nPer), c & mCovSANoe(nT-2*nPer,nT-2*nPer) c ------------------------------------------------------------------ INTEGER nSave PARAMETER (nSave=POBS*POBS) DOUBLE PRECISION mCovIrrNoe(nSave), mCovSeaNoe(nSave), & mCovTreNoe(nSave), mCovSANoe(nSave) SAVE mCovIrrNoe, mCovSeaNoe, mCovTreNoe, mCovSANoe c----------------------------------------------------------------------- c Initialize the outputs. c----------------------------------------------------------------------- DO i = 1,4 fulEst(i) = ZERO fulEso(i) = ZERO fulVar(i) = ZERO fulDia(i) = ZERO noeEst(i) = ZERO noeEso(i) = ZERO noeVar(i) = ZERO noeDia(i) = ZERO END DO c----------------------------------------------------------------------- c Calculate finite sample correction factor and c model innovation variance adjusted for finite sample. c----------------------------------------------------------------------- finfact = DBLE(nT - ( nDiff(1) + nPer*nDiff(2) ))/ & DBLE(nT - ( nDiff(1) + nPer*nDiff(2) + (nParam - nFixed) )) innovar = finfact*( sdSigAlt*sdSigAlt ) c innovar = finfact*( sdSig*sdSig ) c----------------------------------------------------------------------- c Compute the estimates. c----------------------------------------------------------------------- IF ( nIrrEst(1) .ne. 0 ) THEN fulEst(1) = sumsqr( vIrrEst, 1, nIrrEst(1) )/DBLE( nIrrEst(1) ) END IF IF ( nIrrEst(1) .gt. 2*nPer ) THEN noeEst(1) = sumsqr( vIrrEst, nPer+1, nIrrEst(1)-nPer ) & /DBLE( nIrrEst(1) - 2*nPer ) END IF c ------------------------------------------------------------------ pdA = max(nDelS(2)-nDelS(1)+1, 1) CALL mulDMat( dDelS, nDelS, vSeaEst, nSeaEst, vTemp1, nTemp1, & pdA ) IF ( nTemp1(1) .ne. 0 ) THEN fulEst(2) = sumsqr( vTemp1, 1, nTemp1(1) )/DBLE( nTemp1(1) ) END IF IF ( nTemp1(1) .gt. 2*nPer ) THEN noeEst(2) = sumsqr( vTemp1, nPer+1, nTemp1(1)-nPer ) & /DBLE( nTemp1(1) - 2*nPer ) END IF c ------------------------------------------------------------------ pdA = max(nDelT(2)-nDelT(1)+1, 1) CALL mulDMat( dDelT, nDelT, vTreEst, nTreEst, vTemp2, nTemp2, & pdA ) IF ( nTemp2(1) .ne. 0 ) THEN fulEst(3) = sumsqr( vTemp2, 1, nTemp2(1) )/DBLE( nTemp2(1) ) END IF IF ( nTemp2(1) .gt. 2*nPer ) THEN noeEst(3) = sumsqr( vTemp2, nPer+1, nTemp2(1)-nPer ) & /DBLE( nTemp2(1) - 2*nPer ) END IF c ------------------------------------------------------------------ CALL addMat( vTreEst, nTreEst, vIrrEst, nIrrEst, vTemp3, nTemp3 ) pdA = max(nDelT(2)-nDelT(1)+1, 1) CALL mulDMat( dDelT, nDelT, vTemp3, nTemp3, vTemp2, nTemp2, pdA ) IF ( nTemp2(1) .ne. 0 ) THEN fulEst(4) = sumsqr( vTemp2, 1, nTemp2(1) )/DBLE( nTemp2(1) ) END IF IF ( nTemp2(1) .gt. 2*nPer ) THEN noeEst(4) = sumsqr( vTemp2, nPer+1, nTemp2(1)-Nper ) & /DBLE( nTemp2(1) - 2*nPer ) END IF c----------------------------------------------------------------------- c Get some covariance submatrices c----------------------------------------------------------------------- CALL getSMat( mCovIrr, nCovIrr, nPer+1, nCovIrr(1)-nPer, & mCovIrrNoe, nCovIrrNoe ) CALL getSMat( mCovSea, nCovSea, nPer+1, nCovSea(1)-nPer, & mCovSeaNoe, nCovSeaNoe ) CALL getSMat( mCovTre, nCovTre, nPer+1, nCovTre(1)-nPer, & mCovTreNoe, nCovTreNoe ) CALL getSMat( mCovSA, nCovSA, nPer+1, nCovSA(1)-nPer, & mCovSANoe, nCovSANoe ) c----------------------------------------------------------------------- c Compute some traces of matrices. c----------------------------------------------------------------------- trCovIrr = getTrc( mCovIrr, nCovIrr ) trCovSea = getTrc( mCovSea, nCovSea ) trCovTre = getTrc( mCovTre, nCovTre ) trCovSA = getTrc( mCovSA, nCovSA ) c ------------------------------------------------------------------ trCovIrrNoe = getTrc( mCovIrrNoe, nCovIrrNoe ) trCovSeaNoe = getTrc( mCovSeaNoe, nCovSeaNoe ) trCovTreNoe = getTrc( mCovTreNoe, nCovTreNoe ) trCovSANoe = getTrc( mCovSANoe, nCovSANoe ) c ------------------------------------------------------------------ trCovIrrSq = getTrcAB( mCovIrr, nCovIrr, mCovIrr, nCovIrr ) trCovSeaSq = getTrcAB( mCovSea, nCovSea, mCovSea, nCovSea ) trCovTreSq = getTrcAB( mCovTre, nCovTre, mCovTre, nCovTre ) trCovSASq = getTrcAB( mCovSA, nCovSA, mCovSA, nCovSA ) c ------------------------------------------------------------------ trCovIrrNoeSq = getTrcAB( mCovIrrNoe, nCovIrrNoe, & mCovIrrNoe, nCovIrrNoe ) trCovSeaNoeSq = getTrcAB( mCovSeaNoe, nCovSeaNoe, & mCovSeaNoe, nCovSeaNoe ) trCovTreNoeSq = getTrcAB( mCovTreNoe, nCovTreNoe, & mCovTreNoe, nCovTreNoe ) trCovSANoeSq = getTrcAB( mCovSANoe, nCovSANoe, & mCovSANoe, nCovSANoe ) c----------------------------------------------------------------------- c Compute the full estimators, null variances, and diagnostics c----------------------------------------------------------------------- k1 = TWO*(innovar**2) k3 = (TWO*finfact - finfact**2)/DBLE(nT-dS-dT) c ------------------------------------------------------------------ c For the irregular component (lag 0) c ------------------------------------------------------------------ IF ( nCovIrr(1) .ne. 0 ) THEN fulEso(1) = trCovIrr/DBLE(nCovIrr(1)) fulVar(1) = k1*(trCovIrrSq - k3*(trCovIrr**2)) & /DBLE(nCovIrr(1)**2) IF ( .not. dpeq(fulVar(1),ZERO) ) THEN fulDia(1) = (fulEst(1) - innovar*fulEso(1))/DSQRT(fulVar(1)) END IF END IF c ------------------------------------------------------------------ c For the seasonal component (lag 0) c ------------------------------------------------------------------ IF ( nCovSea(1) .ne. 0 ) THEN fulEso(2) = trCovSea/DBLE(nCovSea(1)) fulVar(2) = k1*(trCovSeaSq - k3*(trCovSea**2)) & /DBLE(nCovSea(1)**2) IF ( .not. dpeq(fulVar(2),ZERO) ) THEN fulDia(2) = (fulEst(2) - innovar*fulEso(2))/DSQRT(fulVar(2)) END IF END IF c ------------------------------------------------------------------ c For the trend component (lag 0) c ------------------------------------------------------------------ IF ( nCovTre(1) .ne. 0 ) THEN fulEso(3) = trCovTre/DBLE(nCovTre(1)) fulVar(3) = k1*(trCovTreSq - k3*(trCovTre**2)) & /DBLE(nCovTre(1)**2) IF ( .not. dpeq(fulVar(3),ZERO) ) THEN fulDia(3) = (fulEst(3) - innovar*fulEso(3))/DSQRT(fulVar(3)) END IF END IF c ------------------------------------------------------------------ c For the seasonal adjustment (lag 0) c ------------------------------------------------------------------ IF ( nCovSA(1) .ne. 0 ) THEN fulEso(4) = trCovSA/DBLE(nCovSA(1)) fulVar(4) = k1*(trCovSASq - k3*(trCovSA**2)) & /DBLE(nCovSA(1)**2) IF ( .not. dpeq(fulVar(4),ZERO) ) THEN fulDia(4) = (fulEst(4) - innovar*fulEso(4))/DSQRT(fulVar(4)) END IF END IF c----------------------------------------------------------------------- c Compute the noend estimators, null variances, and diagnostics c----------------------------------------------------------------------- k2 = TWO*(innovar**2) c k3 = (TWO*finfact - finfact**2)/DBLE(nT-dS-dT) c ------------------------------------------------------------------ c For the irregular component (lag 0) c ------------------------------------------------------------------ IF ( nCovIrrNoe(1) .ne. 0 ) THEN noeEso(1) = trCovIrrNoe/DBLE(nCovIrrNoe(1)) noeVar(1) = k2*(trCovIrrNoeSq - k3*(trCovIrrNoe**2)) & /DBLE(nCovIrrNoe(1)**2) IF ( .not. dpeq(noeVar(1),ZERO) ) THEN noeDia(1) = (noeEst(1) - innovar*noeEso(1))/DSQRT(noeVar(1)) END IF END IF c ------------------------------------------------------------------ c For the seasonal component (lag 0) c ------------------------------------------------------------------ IF ( nCovSeaNoe(1) .ne. 0 ) THEN noeEso(2) = trCovSeaNoe/DBLE(nCovSeaNoe(1)) noeVar(2) = k2*(trCovSeaNoeSq - k3*(trCovSeaNoe**2)) & /DBLE(nCovSeaNoe(1)**2) IF ( .not. dpeq(noeVar(2),ZERO) ) THEN noeDia(2) = (noeEst(2) - innovar*noeEso(2))/DSQRT(noeVar(2)) END IF END IF c ------------------------------------------------------------------ c For the trend component (lag 0) c ------------------------------------------------------------------ IF ( nCovTreNoe(1) .ne. 0 ) THEN noeEso(3) = trCovTreNoe/DBLE(nCovTreNoe(1)) noeVar(3) = k2*(trCovTreNoeSq - k3*(trCovTreNoe**2)) & /DBLE(nCovTreNoe(1)**2) IF ( .not. dpeq(noeVar(3),ZERO) ) THEN noeDia(3) = (noeEst(3) - innovar*noeEso(3))/DSQRT(noeVar(3)) END IF END IF c ------------------------------------------------------------------ c For the seasonal adjustment (lag 0) c ------------------------------------------------------------------ IF ( nCovSANoe(1) .ne. 0 ) THEN noeEso(4) = trCovSANoe/DBLE(nCovSANoe(1)) noeVar(4) = k2*(trCovSANoeSq - k3*(trCovSANoe**2)) & /DBLE(nCovSANoe(1)**2) IF ( .not. dpeq(noeVar(4),ZERO) ) THEN noeDia(4) = (noeEst(4) - innovar*noeEso(4))/DSQRT(noeVar(4)) END IF END IF c ------------------------------------------------------------------ RETURN ENDcomplagdiag.f0000664006604000003110000013375314521201422012614 0ustar sun00315steps SUBROUTINE compLagDiag( lag, nT, dS, dT, nPer, & finfact, sdSig, vIrrEst, nIrrEst, & vSeaEst, nSeaEst, vTreEst, nTreEst, & dDelS, nDelS, dDelT, nDelT, & mCovIrr, nCovIrr, mCovSea, nCovSea, & mCovTre, nCovTre, mCovSA, nCovSA, & fulEst, noeEst, fulEso, noeEso, & fulVar, noeVar, fulDia, noeDia ) c----------------------------------------------------------------------- c compLagDiag.f, Release 1, Subroutine Version 1.3, Modified 01 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 21 Jul 2005. c Modified by REG, on 15 Sep 2005, to change local variable sTemp8 c from an undimensioned variable to a vector of size one, c and to correct tab alignments. c Modified by REG, on 13 Jan 2006, to optimize matrix operations, c by using getTrcAB utility, and by using diagonal matrix c utilities. c Modified by REG, on 01 May 2006, to calculate estimate and c variance relative to innovation variance to match SEATS output, c and to move sdSig finite correction factor processing c to getDiag() eliminating need for input nParam, nFixed, c and nDiff. c----------------------------------------------------------------------- c This subroutine calculates some lag diagnostics. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dDelS d diagonal form of seasonal differencing matrix: mDelS c dDelT d diagonal form of trend differencing matrix: mDelT c dS i size of Seasonal Differencing c dT i size of Trend Differencing c finfact d finite sample correction factor c fulDia d vector of normalized diagnostics from full signals c for irregular, seasonal, trend, and SA c fulEso d vector of null means of estimates from full signals c for irregular, seasonal, trend, and SA c fulEst d vector of diagnostic estimates from full signals c for irregular, seasonal, trend, and SA c fulVar d vector of variances of diagnostics from full signals c for irregular, seasonal, trend, and SA c lag i lag of diagnostics to calculate c mCovIrr d covariance of estimated irregular c mCovSA d covariance of estimated seasonal adjusted c mCovSea d covariance of estimated seasonal c mCovTre d covariance of estimated trend c mDelS d seasonal differencing matrix c mDelT d trend differencing matrix c nCovIrr d size (rows,columns) of mCovIrr matrix c nCovSA d size (rows,columns) of mCovSA matrix c nCovSea d size (rows,columns) of mCovSea matrix c nCovTre d size (rows,columns) of mCovTre matrix c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nIrrEst d size (rows,columns) of vIrrEst vector c nSeaEst d size (rows,columns) of vSeaEst vector c nTreEst d size (rows,columns) of vTreEst vector c nPer i size of seasonal period c nT i size of data available c noeDia d vector of normalized diagnostics from trimmed signals c for irregular, seasonal, trend, and SA c noeEso d vector of null means of estimate from trimmed signals c for irregular, seasonal, trend, and SA c noeEst d vector of diagnostic estimates from trimmed signals c for irregular, seasonal, trend, and SA c noeVar d vector of variances of diagnostics from trimmed signals c for irregular, seasonal, trend, and SA c sdSig d estimated data innovation stdev adjusted for number of c estimated parameters c vIrrEst d estimated irregular c vSeaEst d estimated seasonal c vTreEst d estimated trend c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c getTrc d external function reference c HALF d constant parameter c innovar d model innovation variance adjusted for finite sample c i,j i index variables c k1,k2,k3 d miscelaneous constants c mCovIrrNoe d no-end irregular covariance matrix c mCovSeaNoe d no-end seasonal covariance matrix c mCovTreNoe d no-end trend covariance matrix c mCovSANoe d no-end SA covariance matrix c mLag d selection matrix (using all data) c mLagNoe d selection matrix (using noend data) c mLagS d seasonal selection matrix (using all data) c mLagSNoe d seasonal selection matrix (using noend data) c mLagT d trend selection matrix (using all data) c mLagTNoe d trend selection matrix (using noend data) c mTemp4 d temporary matrix 4 c mTemp5 d temporary matrix 5 c mTemp6 d temporary matrix 6 c mTemp7 d temporary matrix 7 c nCovIrrNoe d size (rows,columns) of mCovIrrNoe matrix c nCovSeaNoe d size (rows,columns) of mCovSeaNoe matrix c nCovTreNoe d size (rows,columns) of mCovTreNoe matrix c nCovSANoe d size (rows,columns) of mCovSANoe matrix c nLag i size (rows,columns) of mLag matrix c nLagS i size (rows,columns) of mLagS matrix c nLagT i size (rows,columns) of mLagT matrix c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp1 d size (rows,columns) of vTemp1 vector c nTemp2 d size (rows,columns) of vTemp2 vector c nTemp3 d size (rows,columns) of vTemp3 vector c nTemp4 d size (rows,columns) of mTemp4 matrix c nTemp5 d size (rows,columns) of mTemp5 matrix c nTemp6 d size (rows,columns) of mTemp6 matrix c nTemp7 d size (rows,columns) of mTemp7 matrix c nTemp8 d size (rows,columns) of sTemp8 scalar c nTemp9 d size (rows,columns) of vTemp9 vector c ONE d constant parameter c sTemp8 d temporary scalar 8 c sumsqr d external function reference c trCovIrr d trace of mCovIrr matrix c trCovIrrNoe d trace of mCovIrrNoe matrix c trCovIrrNoeSq d trace of mCovIrrNoe squared matrix c trCovIrrSq d trace of mCovIrr squared matrix c trCovSea d trace of mCovSea matrix c trCovSeaNoe d trace of mCovSeaNoe matrix c trCovSeaNoeSq d trace of mCovSeaNoe squared matrix c trCovSeaSq d trace of mCovSea squared matrix c trCovTre d trace of mCovTre matrix c trCovTreNoe d trace of mCovTreNoe matrix c trCovTreNoeSq d trace of mCovTreNoe squared matrix c trCovTreSq d trace of mCovTre squared matrix c trCovSA d trace of mCovSA matrix c trCovSANoe d trace of mCovSANoe matrix c trCovSANoeSq d trace of mCovSANoe squared matrix c trCovSASq d trace of mCovSA squared matrix c TWO d constant parameter c vTemp1 d temporary vector 1 c vTemp2 d temporary vector 2 c vTemp3 d temporary vector 3 c vTemp9 d temporary vector 9 c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER lag, nT, dS, dT, nPer INTEGER nIrrEst(2), nSeaEst(2), nTreEst(2) INTEGER nDelS(2), nDelT(2) INTEGER nCovIrr(2), nCovSea(2), nCovTre(2), nCovSA(2) DOUBLE PRECISION finfact, sdSig DOUBLE PRECISION vIrrEst(nT), vSeaEst(nT), vTreEst(nT) DOUBLE PRECISION dDelS(dS+1), dDelT(dT+1) c DOUBLE PRECISION mDelS(nT-dS,nT), mDelT(nT-dT,nT) DOUBLE PRECISION mCovIrr(nT,nT), mCovSea(nT-dS,nT-dS), & mCovTre(nT-dT,nT-dT), mCovSA(nT-dT,nT-dT) DOUBLE PRECISION fulEst(4), noeEst(4), fulEso(4), noeEso(4), & fulVar(4), noeVar(4), fulDia(4), noeDia(4) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j INTEGER nLag(2), nLagS(2), nLagT(2) INTEGER nLagNoe(2), nLagSNoe(2), nLagTNoe(2) INTEGER nTemp1(2), nTemp2(2), nTemp3(2), nTemp4(2), nTemp5(2) INTEGER nTemp6(2), nTemp7(2), nTemp8(2), nTemp9(2) INTEGER nCovIrrNoe(2), nCovSeaNoe(2), nCovTreNoe(2), nCovSANoe(2) DOUBLE PRECISION innovar DOUBLE PRECISION vTemp1(nT-dS), vTemp2(nT-dT), vTemp3(nT), & vTemp9(nT-2*nPer) DOUBLE PRECISION trCovIrr, trCovIrrNoe, trCovSea, trCovSeaNoe, & trCovTre, trCovTreNoe, trCovSA, trCovSANoe DOUBLE PRECISION trCovIrrSq, trCovIrrNoeSq, trCovSeaSq, & trCovSeaNoeSq, trCovTreSq, trCovTreNoeSq, & trCovSASq, trCovSANoeSq DOUBLE PRECISION k1, k2, k3, ZERO, HALF, ONE, TWO DOUBLE PRECISION getTrc, getTrcAB, sumsqr PARAMETER (ZERO=0.0D0, HALF=0.5D0, ONE=1.0D0, TWO=2.0D0) DOUBLE PRECISION sTemp8(1) LOGICAL dpeq c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mLag(nT,nT), mLagS(nT-dS,nT-dS), c & mLagT(nT-dT,nT-dT), mLagNoe(nT-2*nPer,nT-2*nPer) c & mLagSNoe(nT-dS-2*nPer,nT-dS-2*nPer), c & mLagTNoe(nT-dT-2*nPer,nT-dT-2*nPer) c DOUBLE PRECISION mTemp4(nT,nT),mTemp5(nT-dS,nT-dS), c & mTemp6(nT-dT,nT-dT), mTemp7(nT-2*nPer,nT-2*nPer) c DOUBLE PRECISION mCovIrrNoe(nT-2*nPer,nT-2*nPer), c & mCovSeaNoe(nT-2*nPer,nT-2*nPer), c & mCovTreNoe(nT-2*nPer,nT-2*nPer), c & mCovSANoe(nT-2*nPer,nT-2*nPer) c ------------------------------------------------------------------ INTEGER nSave PARAMETER (nSave=POBS*POBS) DOUBLE PRECISION mLag(nSave), mLagS(nSave), mLagT(nSave), & mLagNoe(nSave), mLagSNoe(nSave), mLagTNoe(nSave) DOUBLE PRECISION mTemp4(nSave), mTemp5(nSave), & mTemp6(nSave), mTemp7(nSave) DOUBLE PRECISION mCovIrrNoe(nSave), mCovSeaNoe(nSave), & mCovTreNoe(nSave), mCovSANoe(nSave) SAVE mLag, mLagS, mLagT, mLagNoe, mLagSNoe, mLagTNoe, & mTemp4, mCovIrrNoe, mCovSeaNoe, mCovTreNoe, mCovSANoe EQUIVALENCE (mTemp4, mTemp5), (mTemp4, mTemp6), (mTemp4, mTemp7) c----------------------------------------------------------------------- c Initialize the outputs. c----------------------------------------------------------------------- DO i = 1,4 fulEst(i) = ZERO fulEso(i) = ZERO fulVar(i) = ZERO fulDia(i) = ZERO noeEst(i) = ZERO noeEso(i) = ZERO noeVar(i) = ZERO noeDia(i) = ZERO END DO c----------------------------------------------------------------------- c Calculate model innovation variance adjusted for finite sample. c----------------------------------------------------------------------- innovar = ( sdSig*sdSig ) c----------------------------------------------------------------------- c Compute the lag matrix. c----------------------------------------------------------------------- c DO j = 1, nT c DO i = 1, nT c mLag((j-1)*nT+i) = ZERO c END DO c END DO c DO j = 1, nT c IF (lag.eq.0) THEN c i = j c mLag((j-1)*nT+i) = ONE c ELSE c i = j+lag c IF ((i.ge.1) .and. (i.le.nT)) THEN c mLag((j-1)*nT+i) = HALF c mLag((i-1)*nT+j) = HALF c END IF c END IF c END DO c nLag(1) = nT c nLag(2) = nT c ------------------------------------------------------------------ CALL getLagM( nT, lag, ONE, HALF, .true., mLag, nLag ) c ------------------------------------------------------------------ CALL getSMat( mLag, nLag, 1, nT-dS, mLagS, nLagS ) CALL getSMat( mLag, nLag, 1, nT-dT, mLagT, nLagT ) CALL getSMat( mLag, nLag, nPer+1, nT-nPer, mLagNoe, nLagNoe ) CALL getSmat( mLag, nLag, nPer+1, nT-dS-nPer, mLagSNoe, nLagSNoe ) CALL getSMat( mLag, nLag, nPer+1, nT-dT-nPer, mLagTNoe, nLagTNoe ) c----------------------------------------------------------------------- c Compute the estimates relative to the innovation variance. c----------------------------------------------------------------------- IF ( nIrrEst(1) .ne. 0 ) THEN CALL mulQMatTr( vIrrEst, nIrrEst, mLag, nLag, & sTemp8(1), nTemp8 ) fulEst(1) = sTemp8(1)/(innovar*DBLE( nIrrEst(1) )) END IF c ------------------------------------------------------------------ CALL getSVec( vIrrEst, nIrrEst, nPer+1, nIrrEst(1)-nPer, & vTemp9, nTemp9 ) IF ( nTemp9(1) .ne. 0 ) THEN CALL mulQMatTr( vTemp9, nTemp9, mLagNoe, nLagNoe, & sTemp8(1), nTemp8 ) noeEst(1) = sTemp8(1)/(innovar*DBLE( nTemp9(1) )) END IF c ------------------------------------------------------------------ pdA = max(nDelS(2)-nDelS(1)+1, 1) CALL mulDMat( dDelS, nDelS, vSeaEst, nSeaEst, vTemp1, nTemp1, & pdA ) IF ( nTemp1(1) .ne. 0 ) THEN CALL mulQMatTr( vTemp1, nTemp1, mLagS, nLagS, & sTemp8(1), nTemp8 ) fulEst(2) = sTemp8(1)/(innovar*DBLE( nTemp1(1) )) END IF c ------------------------------------------------------------------ CALL getSVec( vTemp1, nTemp1, nPer+1, nTemp1(1)-nPer, & vTemp9, nTemp9 ) IF ( nTemp9(1) .ne. 0 ) THEN CALL mulQMatTr( vTemp9, nTemp9, mLagSNoe, nLagSNoe, & sTemp8(1), nTemp8 ) noeEst(2) = sTemp8(1)/(innovar*DBLE( nTemp9(1) )) END IF c ------------------------------------------------------------------ pdA = max(nDelt(2)-nDelT(1)+1, 1) CALL mulDMat( dDelT, nDelT, vTreEst, nTreEst, vTemp2, nTemp2, & pdA ) IF ( nTemp2(1) .ne. 0 ) THEN CALL mulQMatTr( vTemp2, nTemp2, mLagT, nLagT, & sTemp8(1), nTemp8 ) fulEst(3) = sTemp8(1)/(innovar*DBLE( nTemp2(1) )) END IF c ------------------------------------------------------------------ CALL getSVec( vTemp2, nTemp2, nPer+1, nTemp2(1)-nPer, & vTemp9, nTemp9 ) IF ( nTemp9(1) .ne. 0 ) THEN CALL mulQMatTr( vTemp9, nTemp9, mLagTNoe, nLagTNoe, & sTemp8(1), nTemp8 ) noeEst(3) = sTemp8(1)/(innovar*DBLE( nTemp9(1) )) END IF c ------------------------------------------------------------------ CALL addMat( vTreEst, nTreEst, vIrrEst, nIrrEst, vTemp3, nTemp3 ) pdA = max(nDelT(2)-nDelT(1)+1, 1) CALL mulDMat( dDelT, nDelT, vTemp3, nTemp3, vTemp2, nTemp2, pdA ) IF ( nTemp2(1) .ne. 0 ) THEN CALL mulQMatTr( vTemp2, nTemp2, mLagT, nLagT, & sTemp8(1), nTemp8 ) fulEst(4) = sTemp8(1)/(innovar*DBLE( nTemp2(1) )) END IF c ------------------------------------------------------------------ CALL getSVec( vTemp2, nTemp2, nPer+1, nTemp2(1)-nPer, & vTemp9, nTemp9 ) IF (nTemp9(1) .ne. 0 ) THEN CALL mulQMatTr( vTemp9, nTemp9, mLagTNoe, nLagTNoe, & sTemp8(1), nTemp8 ) noeEst(4) = sTemp8(1)/(innovar*DBLE( nTemp9(1) )) END IF c----------------------------------------------------------------------- c Get some covariance submatrices c----------------------------------------------------------------------- CALL getSMat( mCovIrr, nCovIrr, nPer+1, nCovIrr(1)-nPer, & mCovIrrNoe, nCovIrrNoe ) CALL getSMat( mCovSea, nCovSea, nPer+1, nCovSea(1)-nPer, & mCovSeaNoe, nCovSeaNoe ) CALL getSMat( mCovTre, nCovTre, nPer+1, nCovTre(1)-nPer, & mCovTreNoe, nCovTreNoe ) CALL getSMat( mCovSA, nCovSA, nPer+1, nCovSA(1)-nPer, & mCovSANoe, nCovSANoe ) c----------------------------------------------------------------------- c Compute some traces of matrices and their squares. c----------------------------------------------------------------------- CALL mulMat( mCovIrr, nCovIrr, mLag, nLag, mTemp4, nTemp4 ) trCovIrr = getTrc( mTemp4, nTemp4 ) trCovIrrSq = getTrcAB( mTemp4, nTemp4, mTemp4, nTemp4 ) c ------------------------------------------------------------------ CALL mulMat( mCovSea, nCovSea, mLagS, nLagS, mTemp5, nTemp5 ) trCovSea = getTrc( mTemp5, nTemp5 ) trCovSeaSq = getTrcAB( mTemp5, nTemp5, mTemp5, nTemp5 ) c ------------------------------------------------------------------ CALL mulMat( mCovTre, nCovTre, mLagT, nLagT, mTemp6, nTemp6 ) trCovTre = getTrc( mTemp6, nTemp6 ) trCovTreSq = getTrcAB( mTemp6, nTemp6, mTemp6, nTemp6 ) c ------------------------------------------------------------------ CALL mulMat( mCovSA, nCovSA, mLagT, nLagT, mTemp6, nTemp6 ) trCovSA = getTrc( mTemp6, nTemp6 ) trCovSASq = getTrcAB( mTemp6, nTemp6, mTemp6, nTemp6 ) c ------------------------------------------------------------------ CALL mulMat( mCovIrrNoe, nCovIrrNoe, mLagNoe, nLagNoe, & mTemp7, nTemp7 ) trCovIrrNoe = getTrc( mTemp7, nTemp7 ) trCovIrrNoeSq = getTrcAB( mTemp7, nTemp7, mTemp7, nTemp7 ) c ------------------------------------------------------------------ CALL mulMat( mCovSeaNoe, nCovSeaNoe, mLagSNoe, nLagSNoe, & mTemp7, nTemp7 ) trCovSeaNoe = getTrc( mTemp7, nTemp7 ) trCovSeaNoeSq = getTrcAB( mTemp7, nTemp7, mTemp7, nTemp7 ) c ------------------------------------------------------------------ CALL mulMat( mCovTreNoe, nCovTreNoe, mLagTNoe, nLagTNoe, & mTemp7, nTemp7 ) trCovTreNoe = getTrc( mTemp7, nTemp7 ) trCovTreNoeSq = getTrcAB( mTemp7, nTemp7, mTemp7, nTemp7 ) c ------------------------------------------------------------------ CALL mulMat( mCovSANoe, nCovSANoe, mLagTNoe, nLagTNoe, & mTemp7, nTemp7 ) trCovSANoe = getTrc( mTemp7, nTemp7 ) trCovSANoeSq = getTrcAB( mTemp7, nTemp7, mTemp7, nTemp7 ) c----------------------------------------------------------------------- c Compute the full estimators, null estimators, and diagnostics. c----------------------------------------------------------------------- k1 = TWO k3 = (TWO*finfact - finfact**2)/DBLE(nT-dS-dT) c ------------------------------------------------------------------ c For the irregular component (for input lag) c ------------------------------------------------------------------ IF ( nCovIrr(1) .ne. 0 ) THEN fulEso(1) = trCovIrr/DBLE(nCovIrr(1)) fulVar(1) = k1*(trCovIrrSq - k3*(trCovIrr**2)) & /DBLE(nCovIrr(1)**2) IF ( .not. dpeq(fulVar(1),ZERO) ) THEN fulDia(1) = (fulEst(1) - fulEso(1))/DSQRT(fulVar(1)) END IF END IF c ------------------------------------------------------------------ c For the seasonal component (for input lag) c ------------------------------------------------------------------ IF ( nCovSea(1) .ne. 0 ) THEN fulEso(2) = trCovSea/DBLE(nCovSea(1)) fulVar(2) = k1*(trCovSeaSq - k3*(trCovSea**2)) & /DBLE(nCovSea(1)**2) IF ( .not. dpeq(fulVar(2),ZERO) ) THEN fulDia(2) = (fulEst(2) - fulEso(2))/DSQRT(fulVar(2)) END IF END IF c ------------------------------------------------------------------ c For the trend component (for input lag) c ------------------------------------------------------------------ IF ( nCovTre(1) .ne. 0 ) THEN fulEso(3) = trCovTre/DBLE(nCovTre(1)) fulVar(3) = k1*(trCovTreSq - k3*(trCovTre**2)) & /DBLE(nCovTre(1)**2) IF ( .not. dpeq(fulVar(3),ZERO) ) THEN fulDia(3) = (fulEst(3) - fulEso(3))/DSQRT(fulVar(3)) END IF END IF c ------------------------------------------------------------------ c For the seasonal adjustment (for input lag) c ------------------------------------------------------------------ IF ( nCovSA(1) .ne. 0 ) THEN fulEso(4) = trCovSA/DBLE(nCovSA(1)) fulVar(4) = k1*(trCovSASq - k3*(trCovSA**2)) & /DBLE(nCovSA(1)**2) IF ( .not. dpeq(fulVar(4),ZERO) ) THEN fulDia(4) = (fulEst(4) - fulEso(4))/DSQRT(fulVar(4)) END IF END IF c----------------------------------------------------------------------- c Compute the noend estimators, null estimators, and diagnostics. c----------------------------------------------------------------------- k2 = TWO c k3 = (TWO*finfact - finfact**2)/DBLE(nT-dS-dT) c ------------------------------------------------------------------ c For the irregular component (for input lag) c ------------------------------------------------------------------ IF ( nCovIrrNoe(1) .ne. 0 ) THEN noeEso(1) = trCovIrrNoe/DBLE(nCovIrrNoe(1)) noeVar(1) = k2*(trCovIrrNoeSq - k3*(trCovIrrNoe**2)) & /DBLE(nCovIrrNoe(1)**2) IF ( .not. dpeq(noeVar(1),ZERO) ) THEN noeDia(1) = (noeEst(1) - noeEso(1))/DSQRT(noeVar(1)) END IF END IF c ------------------------------------------------------------------ c For the seasonal component (for input lag) c ------------------------------------------------------------------ IF ( nCovSeaNoe(1) .ne. 0 ) THEN noeEso(2) = trCovSeaNoe/DBLE(nCovSeaNoe(1)) noeVar(2) = k2*(trCovSeaNoeSq - k3*(trCovSeaNoe**2)) & /DBLE(nCovSeaNoe(1)**2) IF ( .not. dpeq(noeVar(2),ZERO) ) THEN noeDia(2) = (noeEst(2) - noeEso(2))/DSQRT(noeVar(2)) END IF END IF c ------------------------------------------------------------------ c For the trend component (for input lag) c ------------------------------------------------------------------ IF ( nCovTreNoe(1) .ne. 0 ) THEN noeEso(3) = trCovTreNoe/DBLE(nCovTreNoe(1)) noeVar(3) = k2*(trCovTreNoeSq - k3*(trCovTreNoe**2)) & /DBLE(nCovTreNoe(1)**2) IF ( .not. dpeq(noeVar(3),ZERO) ) THEN noeDia(3) = (noeEst(3) - noeEso(3))/DSQRT(noeVar(3)) END IF END IF c ------------------------------------------------------------------ c For the seasonal adjustment (for input lag) c ------------------------------------------------------------------ IF ( nCovSANoe(1) .ne. 0 ) THEN noeEso(4) = trCovSANoe/DBLE(nCovSANoe(1)) noeVar(4) = k2*(trCovSANoeSq - k3*(trCovSANoe**2)) & /DBLE(nCovSANoe(1)**2) IF ( .not. dpeq(noeVar(4),ZERO) ) THEN noeDia(4) = (noeEst(4) - noeEso(4))/DSQRT(noeVar(4)) END IF END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE getWghLagDia( lag, nT, dS, dT, nPer, & finfact, sdSig, vY, dDel, nDel, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & mSigUI, nSigUI, mSigUS, nSigUS, & mSigUT, nSigUT, mSigWT, nSigWT, & mInvSigW, nInvSigW, & wghEst, wghEso, wghVar, wghDia ) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.1, Modified 01 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 07 Apr 2006. c Modified by REG, on 01 May 2006, to calculate the estimate c and variance relative to the innovation variance, in order c to match SEATS output, and to remove finite factor processing c associated with the estimated innovation variance, eliminating c the need for input nParam, nFixed, and nDiff. c----------------------------------------------------------------------- c This subroutine calculates some weighted autocovariance c diagnostics for lags: 0, 1, nPer. For each diagnostic, c an estimate, estimator, and variance are calculated relative c to the innovation variance. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dDel d diagonal form of full differencing matrix: mDel c dRedDelS d diagonal form of reduced seasonal differencing matrix: c mRedDelS c dRedDelT d diagonal form of reduced trend differencing matrix: c mRedDelT c dS i size of Seasonal Differencing c dT i size of Trend Differencing c finfact d finite sample correction factor c lag i lag of diagnostics to calculate c mInvSigW d inverse of covariance matrix for differenced data c mRedDelS d reduced seasonal differencing matrix c mRedDelT d reduced trend differencing matrix c mSigUI d covariance matrix for undifferenced irregular c mSigUS d covariance matrix for differenced seasonal c mSigUT d covariance matrix for differenced trend c mSigWS d covariance matrix for differenced trend adjusted c mSigWT d covariance matrix for differenced seasonally adjusted c nDel i size (rows,columns) of mDel c nInvSigW i size (rows,columns) of mInvSigW matrix c nPer i size of seasonal period c nRedDelS i size (rows,columns) of mDelS c nRedDelT i size (rows,columns) of mDelT c nSigUI i size (rows,columns) of mSigUI matrix c nSigUS i size (rows,columns) of mSigUS matrix c nSigUT i size (rows,columns) of mSigUT matrix c nSigWS i size (rows,columns) of mSigWS matrix c nSigWT i size (rows,columns) of mSigWT matrix c nT i size of data available c sdSig d estimated data innovation stdev adjusted for number of c estimated model parameters c vY d vector of observations c wghDia d vector of normalized diagnostics from weighted signals c for irregular, seasonal, trend, and SA c wghEso d vector of null means of estimates from weighted signals c for irregular, seasonal, trend, and SA c wghEst d vector of diagnostic estimates from weighted signals c for irregular, seasonal, trend, and SA c wghVar d vector of variances of diagnostics from weighted signals c for irregular, seasonal, trend, and SA c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c dpeq l external function reference c i i index variables c innovar d model innovation variance adjusted for finite sample c getTrc d external function reference c getTrcAB d external function reference c k1,k3 d miscelaneous constants c mB d working matrix used to calculate estimators and variances c mLag d selection matrix (using all data) c mTemp1 d working matrix used to calculate mB matrix and estimates c mTemp2 d working matrix used to calculate mB matrix c nB i size (rows,columns) of mB matrix c nLag i size (rows,columns) of mLag matrix c nResult c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp1 i size (rows,columns) of mTemp1 matrix c nTemp2 i size (rows,columns) of mTemp1 matrix c nW i size (rows,columns) of mW matrix c nY i size (rows,columns) of vY vector c ONE d constant parameter c sResult d scalar result of quadratic matrix operation c trB d trace of mB matrix c trB2 d trace of mB squared matrix c TWO d constant paramenter c vW d vector of differenced data c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER dS, dT, lag, nPer, nT INTEGER nDel(2), nRedDelS(2), nRedDelT(2) INTEGER nSigUI(2), nSigUS(2), nSigUT(2), nSigWT(2), nInvSigW(2) DOUBLE PRECISION sdSig, vY(nT) DOUBLE PRECISION dDel(dS+dT+1), dRedDelS(dS+1), dRedDelT(dT+1) DOUBLE PRECISION mSigUI(nT,nT), mSigUS(nT-dS,nT-dS), & mSigUT(nT-dT,nT-dT), mSigWT(nT-dT,nT-dT), & mInvSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION wghEst(4), wghEso(4), wghVar(4), wghDia(4) c DOUBLE PRECISION wghAltVar(4), wghAltDia(4) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, nSave INTEGER nB(2), nLag(2), nResult(2), nTemp1(2), nTemp2(2), nW(2), & nY(2) DOUBLE PRECISION finfact, innovar, k1, k3, ONE, trB, trB2, & vW(nT-dS-dT), sResult(1), TWO, ZERO DOUBLE PRECISION getTrc, getTrcAB PARAMETER (nSave=POBS*POBS, ONE=1.0d0, TWO=2.0d0, ZERO=0.0d0) LOGICAL dpeq c DOUBLE PRECISION wghAltVar(4), wghAltDia(4) DOUBLE PRECISION mB(nSave), mLag(nSave), mTemp1(nSave), & mTemp2(nSave) SAVE mB, mLag, mTemp1, mTemp2 c----------------------------------------------------------------------- c Initialize the outputs. c----------------------------------------------------------------------- DO i = 1, 4 wghEst(i) = ZERO wghEso(i) = ZERO wghVar(i) = ZERO wghDia(i) = ZERO c wghAltVar(i) = ZERO c wghAltDia(i) = ZERO END DO c ------------------------------------------------------------------ c Identify size of observation vector. c ------------------------------------------------------------------ nY(1) = nT nY(2) = 1 c----------------------------------------------------------------------- c Calculate model innovation variance adjusted for finite sample. c----------------------------------------------------------------------- innovar = ( sdSig*sdSig ) c ------------------------------------------------------------------ k1 = TWO k3 = (TWO*finfact - finfact**2)/DBLE(nT-dS-dT) c----------------------------------------------------------------------- c Compute the weighted estimate, estimator, variance, c and diagnostic, for the irregular component. c----------------------------------------------------------------------- c Calculate the mB matrix used to calculate the estimator, variance. c ------------------------------------------------------------------ CALL getLagM( nT, lag, ONE, ONE, .false., mLag, nLag ) CALL mulMat( mSigUI, nSigUI, mLag, nLag, mTemp1, nTemp1 ) CALL getSymM( mTemp1, nTemp1, mTemp2, nTemp2 ) CALL mulQDMat( dDel, nDel, mTemp2, nTemp2, & mTemp1, nTemp1 ) CALL mulMat( mInvSigW, nInvSigW, mTemp1, nTemp1, mB, nB ) c ------------------------------------------------------------------ trB = getTrc( mB, nB ) trB2 = getTrcAB( mB, nB, mB, nB ) c ------------------------------------------------------------------ c Calculate the estimate relative to the innovation variance. c ------------------------------------------------------------------ pdA = max(nDel(2)-nDel(1)+1, 1) CALL mulDMat( dDel, nDel, vY, nY, vW, nW, pdA ) CALL mulMat( mB, nB, mInvSigW, nInvSigW, mTemp1, nTemp1 ) CALL mulQMatTr( vW, nW, mTemp1, nTemp1, sResult, nResult ) IF ( nResult(1) .eq. 1 ) THEN wghEst(1) = sResult(1)/(innovar*DBLE(nW(1))) END IF c ------------------------------------------------------------------ c Calculate the estimator and variance relative to the innovation c variance, and then calculate the diagostic. c ------------------------------------------------------------------ IF ( nB(1) . gt. 0 ) THEN wghEso(1) = trB/DBLE(nB(1)) wghVar(1) = k1*(trB2 - k3*(trB**2))/DBLE(nB(1)**2) c wghAltVar(1) = k1*trB2/DBLE(nB(1)**2) IF ( .not. dpeq(wghVar(1),ZERO) ) THEN wghDia(1) = (wghEst(1) - wghEso(1))/DSQRT(wghVar(1)) c wghAltDia(1) = (wghEst(1) - innovar*wghEso(1)) c & /DSQRT(wghAltVar(1)) END IF END IF c----------------------------------------------------------------------- c Compute the weighted estimate, estimator, variance, c and diagnostic, for the seasonal component. c----------------------------------------------------------------------- c Calculate the mB matrix used to calculate the estimator, variance. c ------------------------------------------------------------------ CALL getLagM( nT-dS, lag, ONE, ONE, .false., mLag, nLag ) CALL mulMat( mSigUS, nSigUS, mLag, nLag, mTemp1, nTemp1 ) CALL getSymM( mTemp1, nTemp1, mTemp2, nTemp2 ) CALL mulQDMat( dRedDelT, nRedDelT, mTemp2, nTemp2, & mTemp1, nTemp1 ) CALL mulMat( mInvSigW, nInvSigW, mTemp1, nTemp1, mB, nB ) c ------------------------------------------------------------------ trB = getTrc( mB, nB ) trB2 = getTrcAB( mB, nB, mB, nB ) c ------------------------------------------------------------------ c Calculate the estimate relative to the innovation variance. c ------------------------------------------------------------------ c CALL mulDMat( dDel, nDel, vY, nY, vW, nW ) CALL mulMat( mB, nB, mInvSigW, nInvSigW, mTemp1, nTemp1 ) CALL mulQMatTr( vW, nW, mTemp1, nTemp1, sResult, nResult ) IF ( nResult(1) .eq. 1 ) THEN wghEst(2) = sResult(1)/(innovar*DBLE(nW(1))) END IF c ------------------------------------------------------------------ c Calculate the estimator and variance relative to the innovation c variance, and then calculate the diagostic. c ------------------------------------------------------------------ IF ( nB(1) . gt. 0 ) THEN wghEso(2) = trB/DBLE(nB(1)) wghVar(2) = k1*(trB2 - k3*(trB**2))/DBLE(nB(1)**2) c wghAltVar(2) = k1*trB2/DBLE(nB(1)**2) IF ( .not. dpeq(wghVar(2),ZERO) ) THEN wghDia(2) = (wghEst(2) - innovar*wghEso(2))/DSQRT(wghVar(2)) c wghAltDia(2) = (wghEst(2) - innovar*wghEso(2)) c & /DSQRT(wghAltVar(2)) END IF END IF c----------------------------------------------------------------------- c Compute the weighted estimate, estimator, variance, c and diagnostic, for the trend component. c----------------------------------------------------------------------- c Calculate the mB matrix used to calculate the estimator, variance. c ------------------------------------------------------------------ CALL getLagM( nT-dT, lag, ONE, ONE, .false., mLag, nLag ) CALL mulMat( mSigUT, nSigUT, mLag, nLag, mTemp1, nTemp1 ) CALL getSymM( mTemp1, nTemp1, mTemp2, nTemp2 ) CALL mulQDMat( dRedDelS, nRedDelS, mTemp2, nTemp2, & mTemp1, nTemp1 ) CALL mulMat( mInvSigW, nInvSigW, mTemp1, nTemp1, mB, nB ) c ------------------------------------------------------------------ trB = getTrc( mB, nB ) trB2 = getTrcAB( mB, nB, mB, nB ) c ------------------------------------------------------------------ c Calculate the estimate relative to the innovation variance. c ------------------------------------------------------------------ c CALL mulDMat( dDel, nDel, vY, nY, vW, nW ) CALL mulMat( mB, nB, mInvSigW, nInvSigW, mTemp1, nTemp1 ) CALL mulQMatTr( vW, nW, mTemp1, nTemp1, sResult, nResult ) IF ( nResult(1) .eq. 1 ) THEN wghEst(3) = sResult(1)/(innovar*DBLE(nW(1))) END IF c ------------------------------------------------------------------ c Calculate the estimator and variance relative to the innovation c variance, and then calculate the diagostic. c ------------------------------------------------------------------ IF ( nB(1) . gt. 0 ) THEN wghEso(3) = trB/DBLE(nB(1)) wghVar(3) = k1*(trB2 - k3*(trB**2))/DBLE(nB(1)**2) c wghAltVar(3) = k1*trB2/DBLE(nB(1)**2) IF ( .not. dpeq(wghVar(3),ZERO) ) THEN wghDia(3) = (wghEst(3) - wghEso(3))/DSQRT(wghVar(3)) c wghAltDia(3) = (wghEst(3) - innovar*wghEso(3)) c & /DSQRT(wghAltVar(3)) END IF END IF c----------------------------------------------------------------------- c Compute the weighted estimate, estimator, variance, c and diagnostic, for the seasonally adjusted component. c----------------------------------------------------------------------- c Calculate the mB matrix used to calculate the estimator, variance. c ------------------------------------------------------------------ c CALL getLagM( nT-dT, lag, ONE, ONE, .false., mLag, nLag ) CALL mulMat( mSigWT, nSigWT, mLag, nLag, mTemp1, nTemp1 ) CALL getSymM( mTemp1, nTemp1, mTemp2, nTemp2 ) CALL mulQDMat( dRedDelS, nRedDelS, mTemp2, nTemp2, & mTemp1, nTemp1 ) CALL mulMat( mInvSigW, nInvSigW, mTemp1, nTemp1, mB, nB ) c ------------------------------------------------------------------ trB = getTrc( mB, nB ) trB2 = getTrcAB( mB, nB, mB, nB ) c ------------------------------------------------------------------ c Calculate the estimate relative to the innovation variance. c ------------------------------------------------------------------ c CALL mulDMat( dDel, nDel, vY, nY, vW, nW ) CALL mulMat( mB, nB, mInvSigW, nInvSigW, mTemp1, nTemp1 ) CALL mulQMatTr( vW, nW, mTemp1, nTemp1, sResult, nResult ) IF ( nResult(1) .eq. 1 ) THEN wghEst(4) = sResult(1)/(innovar*DBLE(nW(1))) END IF c ------------------------------------------------------------------ c Calculate the estimator and variance relative to the innovation c variance, and then calculate the diagostic. c ------------------------------------------------------------------ IF ( nB(1) . gt. 0 ) THEN wghEso(4) = trB/DBLE(nB(1)) wghVar(4) = k1*(trB2 - k3*(trB**2))/DBLE(nB(1)**2) c wghAltVar(4) = k1*trB2/DBLE(nB(1)**2) IF ( .not. dpeq(wghVar(4),ZERO) ) THEN wghDia(4) = (wghEst(4) - wghEso(4))/DSQRT(wghVar(4)) c wghAltDia(4) = (wghEst(4) - innovar*wghEso(4)) c & /DSQRT(wghAltVar(4)) END IF END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE getLagM( nRC, hLag, sC0, sCh, lSym, mL, nL ) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.0, Created 07 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 07 Apr 2006. c----------------------------------------------------------------------- c This subroutine creates a symetric or non-symetric selection c matrix. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c hLag i lag value denotes non-zero diagonal c lSym l t = create symetric selection matrix c mL d output selection matrix c nL i size (rows,columns) of mL matrix c nRC i size of square selection matrix to create c sC0 d main diagonal value for selection matrix c sCh d off diagonal value for selection matrix c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i,j i index variables c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nRC, hLag, nL(2) DOUBLE PRECISION mL(nRC,nRC), sC0, sCh, ZERO PARAMETER (ZERO=0.0d0) LOGICAL lSym c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j c----------------------------------------------------------------------- c Initialize the selection matrix to zeros. c----------------------------------------------------------------------- DO j = 1, nRC DO i = 1, nRC mL(i,j) = ZERO END DO END DO c----------------------------------------------------------------------- c Update the non-zero entries in the selection matrix. c----------------------------------------------------------------------- DO j = 1, nRC c ------------------------------------------------------------------ c Check for updating the main diagonal and use main diagonal value. c ------------------------------------------------------------------ IF ( hLag .eq. 0 ) THEN mL(j,j) = sC0 c ------------------------------------------------------------------ c Else for updating off diagonals use off diagonal value. c ------------------------------------------------------------------ ELSE i = j + hLag IF ((i .ge. 1) .and. (i .le. nRC )) THEN mL(i,j) = sCh c ------------------------------------------------------------------ c Check for creating symetric selection matrix. c ------------------------------------------------------------------ IF ( lSym ) THEN mL(j,i) = sCh END IF END IF END IF END DO c----------------------------------------------------------------------- c Identify size of selection matrix. c----------------------------------------------------------------------- nL(1) = nRC nL(2) = nRC RETURN END c----------------------------------------------------------------------- SUBROUTINE getSymM( mNonSymM, nNonSymM, mSymM, nSymM ) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.0, Created 07 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 07 Apr 2006. c----------------------------------------------------------------------- c This subroutine creates a symetric version of an input c non-symetric matrix using mSymM = (mNonSymM + mNonSymM')/2 . c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mNonSymM d input non-symetric matrix c mSymM d output symetric matrix c nNonSymM i size (rows,columns) of mNonSymM matrix c nSymM i size (rows,columns) of mSymM matrix c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i,j i index variables c TWO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nNonSymM(2), nSymM(2) DOUBLE PRECISION mNonSymM( nNonSymM(1), nNonSymM(2) ), & mSymM( nNonSymM(1), nNonSymM(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i,j DOUBLE PRECISION TWO PARAMETER (TWO=2.0d0) c----------------------------------------------------------------------- c Create symetric matrix if square and size is positive. c----------------------------------------------------------------------- IF (( nNonSymM(1) .eq. nNonSymM(2) ) .and. & ( nNonSymM(1) .gt. 0 )) THEN DO i = 1, nNonSymM(1) DO j = 1, nNonSymM(2) mSymM(i,j) = ( mNonSymM(i,j) + mNonSymM(j,i) )/TWO END DO END DO c ------------------------------------------------------------------ c Identify size of symetric matrix. c ------------------------------------------------------------------ nSymM(1) = nNonSymM(1) nSymM(2) = nNonSymM(2) c----------------------------------------------------------------------- c Else declare invalid result. c----------------------------------------------------------------------- ELSE nSymM(1) = 0 nSymM(2) = 0 END IF RETURN END compmsealt.f0000664006604000003110000002136414521201422012503 0ustar sun00315steps SUBROUTINE compMSEAlt( nT, dS, dT, mDel, nDel, mDelS, nDelS, & mDelT, nDelT, sIrrVar, sdSig, & mSigWS, nSigWS, mSigWT, nSigWT, & mInvSigW, nInvSigW, mIrrVar, nIrrVar, & mSeaVar, nSeaVar, mTreVar, nTreVar ) c----------------------------------------------------------------------- c compMSEAlt.f, Release 1, Subroutine Version 1.0, Created 20 Oct 2005. c----------------------------------------------------------------------- c Changes: c Created by REG, on 20 Oct 2005. c----------------------------------------------------------------------- c This subroutine calculates the signal extraction MSE matrices c relative to the innovation variance sdSig c using an alternate set of equations than used by compMSE(). c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dS i size of Seasonal Differencing c dT i size of Trend Differencing c mDel d overall differencing matrix c mDelS d seasonal differencing matrix c mDelT d trend differencing matrix c mInvSigW d inverse of mSigW: covariance matrix for differenced data c mSigWS d covariance matrix for differenced trend adjusted c mSigWT d covariance matrix for differenced seasonally adjusted c mIrrVar d variance matrix of estimated irregular c mSeaVar d variance matrix of estimated seasonal c mTreVar d variance matrix of estimated trend c nDel i size (rows,columns) of mDel c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nInvSigW i size (rows,columns) of mInvSigW matrix c nIrrVar i size (rows,columns) of mIrrVar matrix c nSigWS i size (rows,columns) of mSigWS matrix c nSigWT i size (rows,columns) of mSigWT matrix c nSeaVar i size (rows,columns) of mSeaVar matrix c nTreVar i size (rows,columns) of mTreVar matrix c sdSig d data innovation stdev c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c mFSISea d seasonal extraction matrix c mFTITre d trend extraction matrix c mFSTIIrr d irregular extraction matrix c mID d identity matrix c mInvSigWS d inverse of mSigWS c mInvSigWT d inverse of mSigWT c mQuadWS d result of quadratic matrix operation c mQuadWT d result of quadratic matrix operation c mQuadW d result of quadratic matrix operation c nSave i identifies default size of large matrices c that are saved (not dynamic) c mTemp2 d temporary matrix 2 c mTemp2A d temporary matrix 2A c nId i size (rows,columns) of mID matrix c nFSISea i size (rows,columns) of mFSISea matrix c nFTITre i size (rows,columns) of mFTITre matrix c nFSTIrr i size (rows,columns) of mFSTIrr matrix c nTemp2 i size (rows,columns) of mTemp2 matrix c nTemp2A i size (rows,columns) of mTemp2A matrix c nInvSigWS i size (rows,columns) of mInvSigWS matrix c nInvSigWT i size (rows,columns) of mInvSigWT matrix c nQuadWS i size (rows,columns) of nQuadWS matrix c nQuadWT i size (rows,columns) of nQuadWT matrix c nQuadW i size (rows,columns) of nQuadW matrix c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INTEGER nT, dS, dT INTEGER nDel(2), nDelS(2), nDelT(2) INTEGER nSigWS(2), nSigWT(2) INTEGER nInvSigW(2) INTEGER nIrrVar(2), nSeaVar(2), nTreVar(2) DOUBLE PRECISION sIrrVar, sdSig DOUBLE PRECISION mDel(nT-dS-dT,nT), mDelS(nT-dS,nT), & mDelT(nT-dT,nT) DOUBLE PRECISION mSigWS(nT-dS,nT-dS), mSigWT(nT-dT,nT-dT) DOUBLE PRECISION mInvSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION mIrrVar(nT,nT), mSeaVar(nT,nT), mTreVar(nT,nT) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER nInvSigWS(2), nInvSigWT(2) INTEGER nQuadWS(2), nQuadWT(2), nQuadW(2), nId(2) INTEGER nFSISea(2), nFTITre(2), nFSTIIrr(2) INTEGER nTemp2(2), nTemp2A(2) c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mInvSigWS(nT-dS,nT-dS), mInvSigWT(nT-dT,nT-dT) c DOUBLE PRECISION mQuadWS(nT,nT), mQuadWT(nT,nT), mQuadW(nT,nT) c DOUBLE PRECISION mFSISea(nT,nT), mFTITre(nT,nT), mFSTIIrr(nT,nT) c DOUBLE PRECISION mTemp2(nT,nT), mTemp2A(nT,nT) c DOUBLE PRECISION mId(nT,nT) c ------------------------------------------------------------------ INTEGER nSave PARAMETER (nSave=POBS*POBS) DOUBLE PRECISION mInvSigWS(nSave), mInvSigWT(nSave) DOUBLE PRECISION mQuadWS(nSave), mQuadWT(nSave), mQuadW(nSave) DOUBLE PRECISION mFSISea(nSave), mFTITre(nSave), & mFSTIIrr(nSave) DOUBLE PRECISION mTemp2(nSave), mTemp2A(nSave) DOUBLE PRECISION mId(nSave) SAVE mInvSigWS, mInvSigWT, mQuadWS, mQuadWT, mQuadW, mFSISea, & mFTITre, mFSTIIrr, mTemp2, mTemp2A, mId c----------------------------------------------------------------------- c Get the identity matrix (nTxnT). c----------------------------------------------------------------------- CALL getIdM( nT, mId, nId ) c----------------------------------------------------------------------- c Calculate some matrix inverses. c----------------------------------------------------------------------- CALL invMat( mSigWS, nSigWS, mInvSigWS, nInvSigWS ) CALL invMat( mSigWT, nSigWT, mInvSigWT, nInvSigWT ) c----------------------------------------------------------------------- c Calculate some quadratic matrices. c----------------------------------------------------------------------- CALL mulQMatTr( mDelS, nDelS, mInvSigWS, nInvSigWS, & mQuadWS, nQuadWS ) CALL mulQMatTr( mDelT, nDelT, mInvSigWT, nInvSigWT, & mQuadWT, nQuadWT ) CALL mulQMatTr( mDel, nDel, mInvSigW, nInvSigW, mQuadW, nQuadW ) c----------------------------------------------------------------------- c Calculate some extraction matrices. c----------------------------------------------------------------------- CALL cpyMat( mQuadW, nQuadW, mFSTIIrr, nFSTIIrr ) CALL mulSca( sIrrVar, mFSTIIrr, nFSTIIrr ) c ------------------------------------------------------------------ CALL cpyMat( mQuadWS, nQuadWS, mTemp2, nTemp2 ) CALL mulSca( DBLE(-sIrrVar), mTemp2, nTemp2 ) CALL addMat( mTemp2, nTemp2, mId, nId, mFSISea, nFSISea ) c ------------------------------------------------------------------ CALL cpyMat( mQuadWT, nQuadWT, mTemp2, nTemp2 ) CALL mulSca( DBLE(-sIrrVar), mTemp2, nTemp2 ) CALL addMat( mTemp2, nTemp2, mId, nId, mFTITre, nFTITre ) c----------------------------------------------------------------------- c Calculate signal extraction MSE matrices relative to sdSig, c i.e. do not multiply by sdSig^2. c----------------------------------------------------------------------- CALL cpyMat( mFSTIIrr, nFSTIIrr, mTemp2, nTemp2 ) CALL mulSca( -1.0D0, mTemp2, nTemp2 ) CALL addMat( mId, nId, mTemp2, nTemp2, mIrrVar, nIrrVar ) CALL mulSca( DBLE(sIrrVar), mIrrVar, nIrrVar ) c CALL mulSca( DBLE(sdSig*sdSig), mIrrVar, nIrrVar ) c ------------------------------------------------------------------ CALL mulQMat( mFTITre, nFTITre, mFSISea, nFSISea, mTemp2, nTemp2) CALL mulSca( -1.0D0, mTemp2, nTemp2 ) CALL addMat( mFTITre, nFTITre, mTemp2, nTemp2, mTemp2A, nTemp2A ) CALL invMat( mTemp2A, nTemp2A, mTemp2, nTemp2 ) CALL mulMat( mTemp2, nTemp2, mFTITre, nFTITre, mTemp2A, nTemp2A ) CALL mulMat( mTemp2A, nTemp2A, mFSISea, nFSISea, & mSeaVar, nSeaVar ) CALL mulSca( DBLE(sIrrVar), mSeaVar, nSeaVar ) c CALL mulSca( DBLE(sdSig*sdSig), mSeaVar, nSeaVar ) c ------------------------------------------------------------------ CALL mulQMat( mFSISea, nFSISea, mFTITre, nFTITre, mTemp2, nTemp2) CALL mulSca( -1.0D0, mTemp2, nTemp2 ) CALL addMat( mFSISea, nFSISea, mTemp2, nTemp2, mTemp2A, nTemp2A ) CALL invMat( mTemp2A, nTemp2A, mTemp2, nTemp2 ) CALL mulMat( mTemp2, nTemp2, mFSISea, nFSISea, mTemp2A, nTemp2A ) CALL mulMat( mTemp2A, nTemp2A, mFTITre, nFTITre, & mTreVar, nTreVar ) CALL mulSca( DBLE(sIrrVar), mTreVar, nTreVar ) c CALL mulSca( DBLE(sdSig*sdSig), mTreVar, nTreVar ) c----------------------------------------------------------------------- RETURN END compmse.f0000664006604000003110000003341314521201422012000 0ustar sun00315steps SUBROUTINE compMSE( nT, dS, dT, lSeaPre, dDel, nDel, dDelS, nDelS, & dDelT, nDelT, sdSig, mSigUI, nSigUI, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW, lInvSig, & mIrrVar, nIrrVar, mSeaVar, nSeaVar, & mTreVar, nTreVar ) c----------------------------------------------------------------------- c compMSE.f, Release 1, Subroutine Version 1.6, Modified 30 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 13 Oct 2005. c Modified by REG, on 07 Nov 2005, to generalize irregular component c via new mSigUI matrix. c Modified by REG, on 05 Jan 2006, to add compile time logicals c for enabling each of the tree covariance matrix calculations. c Modified by REG, on 12 Jan 2006, to optimize calculations c of mSeaVar and mTreVar. c Modified by REG, on 20 Jan 2006, to optimize processing c by using diagonal form of difference matrices, to use input c inverted mSig matrices, and to input logial switch for c for calculating mTreVar matrices. c Modified by REG, on 27 Apr 2006, to handle special case c of no seasonal component. c Modified by REG, on 30 May 2006, to add generalized check c for no seasonal component processing. c----------------------------------------------------------------------- c This subroutine calculates the signal extraction MSE matrices c relative to the innovation variance sdSig. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dDel d diagonal form of overall differencing matrix c dDelS d diagonal form of seasonal differencing matrix c dDelT d diagonal form of trend differencing matrix c dS i size of Seasonal Differencing c dT i size of Trend Differencing c lInvSig d logical when true then all mInvSig matrices are available c lSeaPre l logical indicating presence of seasonal component c mInvSigUS d inverse of mSigUS: covariance matrix for differenced c seasonal c mInvSigUT d inverse of mSigUT: covariance matrix of differenced trend c mInvSigW d inverse of mSigW: covariance matrix of differenced data c mInvSigWS d inverse of mSigWS: covariance matrix of differenced c trend adjusted c mInvSigWT d inverse of mSigWT: covariance matrix of differenced c seasonally adjusted c mSigUI d covariance matrix of undifferenced irregular c mIrrVar d variance matrix of estimated irregular c mSeaVar d variance matrix of estimated seasonal c mTreVar d variance matrix of estimated trend c nDel i size (rows,columns) of dDel c nDelS i size (rows,columns) of dDelS c nDelT i size (rows,columns) of dDelT c nInvSigUS i size (rows,columns) of mInvSigUS matrix c nInvSigUT i size (rows,columns) of mInvSigUT matrix c nInvSigW i size (rows,columns) of mInvSigW matrix c nInvSigWS i size (rows,columns) of mInvSigWS matrix c nInvSigWT i size (rows,columns) of mInvSigWT matrix c nSigUI i size (rows,columns) of mSigUI matrix c nIrrVar i size (rows,columns) of mIrrVar matrix c nSeaVar i size (rows,columns) of mSeaVar matrix c nTreVar i size (rows,columns) of mTreVar matrix c nT i size of data available c sdSig d data innovation stdev c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c lIrrVar l when true allows calculation of mIrrVar c lSeaVar l when true allows calculation of mSeaVar c lTreVar l when true allows calculation of mTreVar c mFTIT d Trend filter assuming 2 components: T + I c mId d Identity matrix c mInvFSIS d Inverse of seasonal filter assuming 2 components: S + I c MONE d constant parameter c mQuadUS d result of quadratic matrix operation c mQuadUT d result of quadratic matrix operation c mQuadW d result of quadratic matrix operation c mQuadWS d result of quadratic matrix operation c mQuadWT d result of quadratic matrix operation c mTemp1 d temporary matrix 1 c nFTIT i size (rows,columns) of mFTIT matrix c nId i size (rows,columns) of mId matrix c nInvFSIS i size (rows,columns) of mInvFSIS matrix c nQuadW i size (rows,columns) of nQuadW matrix c nQuadUS i size (rows,columns) of nQuadUS matrix c nQuadUT i size (rows,columns) of nQuadUT matrix c nQuadWS i size (rows,columns) of nQuadWS matrix c nQuadWT i size (rows,columns) of nQuadWT matrix c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp1 i size (rows,columns) of mTemp1 matrix c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INTEGER nT, dS, dT INTEGER nDel(2), nDelS(2), nDelT(2) INTEGER nSigUI(2) INTEGER nInvSigUS(2), nInvSigUT(2) INTEGER nInvSigW(2), nInvSigWS(2), nInvSigWT(2) INTEGER nIrrVar(2), nSeaVar(2), nTreVar(2) LOGICAL lInvSig, lSeaPre DOUBLE PRECISION sdSig DOUBLE PRECISION dDel(dS+dT+1), dDelS(dS+1), dDelT(dT+1) c DOUBLE PRECISION mDel(nT-dS-dT,nT), mDelS(nT-dS,nT), c & mDelT(nT-dT,nT) DOUBLE PRECISION mSigUI(nT,nT) DOUBLE PRECISION mIrrVar(nT,nT), mSeaVar(nT,nT), mTreVar(nT,nT) DOUBLE PRECISION mInvSigUS(nT-dS,nT-dS), mInvSigUT(nT-dT,nT-dT), & mInvSigWS(nT-dS,nT-dS), mInvSigWT(nT-dT,nT-dT), & mInvSigW(nT-dS-dT,nT-dS-dT) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ LOGICAL lIrrVar, lSeaVar, lTreVar INTEGER nFTIT(2), nId(2), nInvFSIS(2), nTemp1(2) INTEGER nQuadUS(2), nQuadUT(2), nQuadWS(2), nQuadWT(2), nQuadW(2) DOUBLE PRECISION MINUSONE, ZERO PARAMETER (lIrrVar=.false., lSeaVar=.true., lTreVar=.true.) PARAMETER (MINUSONE=-1.0D0, ZERO=0.0D0) c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mTemp2(nT,nT), c DOUBLE PRECISION mQuadUS(nT,nT), mQuadUT(nT,nT), c & mQuadWS(nT,nT), mQuadWT(nT,nT), mQuadW(nT,nT) c ------------------------------------------------------------------ INTEGER nSave PARAMETER (nSave=POBS*POBS) DOUBLE PRECISION mId(nSave), mTemp1(nSave) DOUBLE PRECISION mFTIT(nSave), mInvFSIS(nSave) DOUBLE PRECISION mQuadUS(nSave), mQuadUT(nSave), & mQuadWS(nSave), mQuadWT(nSave), mQuadW(nSave) SAVE mFTIT, mId, mQuadUS, mQuadW, mTemp1 EQUIVALENCE (mQuadUS, mQuadUT), (mFTIT, mInvFSIS), & (mQuadW, mQuadWS), (mQuadW, mQuadWT) c----------------------------------------------------------------------- c Calculate the Irregular extraction MSE matrices. c----------------------------------------------------------------------- c Calculate a quadratic matrix. c ------------------------------------------------------------------ IF (lIrrVar) THEN CALL mulQdMatTr( dDel, nDel, mInvSigW, nInvSigW, & mQuadW, nQuadW ) CALL mulQMat( mSigUI, nSigUI, mQuadW, nQuadW, mTemp1, nTemp1 ) c ------------------------------------------------------------------ c Calculate the MSE matrix relative to sdSig, c i.e. do not multiply by sdSig^2. c ------------------------------------------------------------------ CALL mulSca( MINUSONE, mTemp1, nTemp1 ) CALL addMat( mSigUI, nSigUI, mTemp1, nTemp1, mIrrVar, nIrrVar ) c CALL mulSca( DBLE(sdSig*sdSig), mIrrVar, nIrrVar ) END IF c----------------------------------------------------------------------- c Calculate the Seasonal extraction MSE matrices. c----------------------------------------------------------------------- c Calculate some quadratic matrices. c ------------------------------------------------------------------ IF (lSeaVar) THEN IF (lSeaPre) THEN CALL mulQdMatTr( dDelS, nDelS, mInvSigUS, nInvSigUS, & mQuadUS, nQuadUS ) c ------------------------------------------------------------------ CALL mulQdMatTr( dDelT, nDelT, mInvSigWT, nInvSigWT, & mQuadWT, nQuadWT ) c ------------------------------------------------------------------ c Calculate the MSE matrix relative to sdSig, c i.e. do not multiply by sdSig^2. c ------------------------------------------------------------------ CALL addMat( mQuadWT, nQuadWT, mQuadUS, nQuadUS, & mTemp1, nTemp1 ) CALL invMat( mTemp1, nTemp1, mSeaVar, nSeaVar ) c CALL mulSca( DBLE(sdSig*sdSig), mSeaVar, nSeaVar ) ELSE CALL getIdM( nT, mSeaVar, nSeaVar ) CALL mulSca( ZERO, mSeaVar, nSeaVar ) END IF END IF c----------------------------------------------------------------------- c Calculate the Trend extraction MSE matrices. c----------------------------------------------------------------------- IF (lTreVar) THEN c ------------------------------------------------------------------ c If the inverses for mSigUT and mSigWS are available then c calculate mTreVar starting from scratch. c ------------------------------------------------------------------ IF (lInvSig) THEN c ------------------------------------------------------------------ c Calculate some quadratic matrices. c ------------------------------------------------------------------ CALL mulQdMatTr( dDelT, nDelT, mInvSigUT, nInvSigUT, & mQuadUT, nQuadUT ) CALL mulQdMatTr( dDelS, nDelS, mInvSigWS, nInvSigWS, & mQuadWS, nQuadWS ) c ------------------------------------------------------------------ c Calculate the MSE matrix relative to sdSig, c i.e. do not multiply by sdSig^2. c ------------------------------------------------------------------ CALL addMat( mQuadUT, nQuadUT, mQuadWS, nQuadWS, & mTemp1, nTemp1 ) CALL invMat( mTemp1, nTemp1, mTreVar, nTreVar ) c CALL mulSca( DBLE(sdSig*sdSig), mTreVar, nTreVar ) c ------------------------------------------------------------------ c If mSeaVar previously calculated then take advantage previous c calculation of mSeaVar in order to calculate mTreVar using c MSE(\hat{T}) = inv(F_{SI}^S) x MSE(\hat(S)) x (F_{TI}^T)'. c ------------------------------------------------------------------ ELSE IF (lSeaVar) THEN IF (lSeaPre) THEN c ------------------------------------------------------------------ c Get Id Matrix c ------------------------------------------------------------------ CALL getIdM( nT, mId, nId ) c ------------------------------------------------------------------ c Calculate inverse of F_{SI}^S (2 component filter) c ------------------------------------------------------------------ CALL mulMat( mSigUI, nSigUI, mQuadUS, nQuadUS, & mInvFSIS, nInvFSIS ) CALL addMat( mId, nId, mInvFSIS, nInvFSIS, & mInvFSIS, nInvFSIS ) c ------------------------------------------------------------------ CALL mulMat( mInvFSIS, nInvFSIS, mSeaVar, nSeaVar, & mTemp1, nTemp1 ) c ------------------------------------------------------------------ c Calculate F_{TI}^T (2 component filter) c ------------------------------------------------------------------ CALL mulMat( mSigUI, nSigUI, mQuadWT, nQuadWT, mFTIT, nFTIT ) CALL mulSca( MINUSONE, mFTIT, nFTIT ) CALL addMat( mId, nId, mFTIT, nFTIT, mFTIT, nFTIT ) c ------------------------------------------------------------------ CALL mulMatTr( mTemp1, nTemp1, mFTIT, nFTIT, & mTreVar, nTreVar ) c ------------------------------------------------------------------ c Else for no seasonal component, calculate c MSE(\hat{T}) = F_{TI}^T x \Sigma_I c ------------------------------------------------------------------ ELSE c ------------------------------------------------------------------ c Calculate F_{TI}^T (2 component filter) c ------------------------------------------------------------------ CALL mulQdMatTr( dDelT, nDelT, mInvSigWT, nInvSigWT, & mQuadWT, nQuadWT ) CALL mulMat( mSigUI, nSigUI, mQuadWT, nQuadWT, mFTIT, nFTIT ) CALL mulSca( MINUSONE, mFTIT, nFTIT ) CALL addMat( mId, nId, mFTIT, nFTIT, mFTIT, nFTIT ) c ------------------------------------------------------------------ c Calculate MSE(\Hat{T}) c ------------------------------------------------------------------ CALL mulMat( mFTIT, nFTIT, mSigUI, nSigUI, mTreVar, nTreVar ) END IF END IF END IF c----------------------------------------------------------------------- RETURN ENDcomponent.f0000664006604000003110000001150314521201422012333 0ustar sun00315stepsc File Component.F c c subroutine AddComp c Add the component PHIc(1:nPHIc)Ct=THc(1:nTHc)Act Act~niid(0,Vc) c To the list of components save in {ARs(1:nComp,*),MAs(1:nComp,*),Vs(1:nComp)} c with dimensions {ARsDim(1:nComp),MAsDim(1:nComp)} c So the k component of the list will be: c ARs(k,1:ARsDim(k)) Ckt=MAs(k,1:MAsDim(k)))Akt Akt~niid(0,Vs(k)) c subroutine AddComp(PHIc,nPHIc,THc,nTHc,Vc, $ ARs,ARsDim,MAs,MAsDim,Vs,NComp) implicit none include 'component.i' c INPUT real*8 Vc,PHIc(*),THc(*) integer nPHIc,nTHc c INPUT/OUTPUT real*8 ARs(MaxComp,MaxCompDim),MAs(MaxComp,MaxCompDim), $ Vs(MaxComp) integer ARsDim(MaxComp),MAsDim(MaxComp),nComp c Local variables integer i c if (nComp.ge.MaxComp) then call ABORTA('nComp pass the MaxComp components') end if if (Vc.le.0.0d0) return nComp=nComp+1 Do i=1,nPHIc ARs(nComp,i)=PHIc(i) endDo ARsDim(nComp)=nPHIc Do i=1,nTHc MAs(nComp,i)=THc(i) endDo MAsDim(nComp)=nTHc Vs(nComp)=Vc end c c c subroutine CopyAddComp c given a groups of arrays {ARs1(1:nComp,*),ARsDim1(1:nComp),MAs1(1:nComp,*),MAsDim1(1:nComp),Vs1(1:nComp)} c that keep a group of components add them to another group of components subroutine CopyAddComp(ARs1,ARsDim1,MAs1,MAsDim1,Vs1,nComp1, $ ARs,ARsDim,MAs,MAsDim,Vs,nComp) implicit NONE include 'component.i' c INPUT real*8 ARs1(MaxComp,MaxCompDim),MAs1(MaxComp,MaxCompDim), $ Vs1(MaxComp) integer ARsDim1(MaxComp),MAsDim1(MaxComp),nComp1 c INPUT/OUTPUT real*8 ARs(MaxComp,MaxCompDim),MAs(MAxComp,MaxCompDim), $ Vs(MaxComp) integer ARsDim(MaxComp),MAsDim(MaxComp),nComp c Local Variables integer i,j c j=0 Do while (j.lt.nComp1) j=j+1 if ((j+nComp).gt.MaxComp) then j=j-1 EXIT end if Do i=1,ARsDim1(j) ARs(nComp+j,i)=ARs1(j,i) endDo ARsDim(nComp+j)=ARsDim1(j) Do i=1,MAsDim1(j) MAs(nComp+j,i)=MAs1(j,i) EndDo MAsDim(nComp+j)=MAsDim1(j) Vs(nComp+j)=Vs1(j) endDo nComp=nComp+j end c c Subroutine GetComp c Given a group of component return the component equivalent to the addition of all of them subroutine GetComp(ARs,ARsDim,MAs,MAsDim,Vs,nComp, $ PHIcomp,nPHIcomp,THcomp,nTHcomp,Vcomp,toterr) implicit none include 'component.i' c INPUT real*8 ARs(MaxComp,MaxCompDim),MAs(MaxComp,MaxCompDim), $ Vs(MaxComp),toterr integer ARsDim(MaxComp),MAsDim(MaxComp),nComp c OUTPUT real*8 PHIcomp(MaxCompDim),THcomp(MaxCompDim),Vcomp integer nPHIcomp,nTHcomp c Local Parameters real*8 Utmp(50),Utmp2(50),V(50), $ ARMAtmp(MaxCompDim),ARMAtmp2(MaxCompDim),ARStmp(MaxCompDim) integer i,j,l,nARMAtmp,nARMAtmp2,nUtmp,nUtmp2,nV,k integer nounit character caption0*60 c toterr=0.0d0 if (nComp.eq.0) then Vcomp=0.0D0 PHIcomp(1)=1.0D0 nPHIcomp=1 THcomp(1)=1.0D0 nTHcomp=1 return end if if (nComp.eq.1) then do i=1,ARsDim(1) PHIcomp(i)=ARs(1,i) enddo nPHIcomp=ARsDim(1) do i=1,MAsDim(1) THcomp(i)=MAs(1,i) enddo nTHcomp=MAsDim(1) Vcomp=Vs(1) return end if do i=1,50 Utmp(i)=0.0d0 endDo nUtmp=0 do j=1,nComp do i=1,MAsDim(j) ARMAtmp(i)=MAs(j,i) enddo nARMAtmp=MAsDim(j) do i=1,nComp if (i.ne.j) then DO k=1,ARsDim(i) ARStmp(k)=ARs(i,k) endDO call CONV(ARMAtmp,nARMAtmp,ARstmp,ARsDim(i), $ ARMAtmp2,nARMAtmp2) Do l=1,nARMAtmp2 ARMAtmp(l)=ARMAtmp2(l) enddo nARMAtmp=nARMAtmp2 end if enddo call CONJ(ARMAtmp,nARMAtmp,ARMAtmp,nARMAtmp,Utmp2,nUtmp2) nUtmp=max(nUtmp,nUtmp2) do i=nUtmp2+1,nUtmp Utmp2(i)=0.0d0 enddo do i=1,nUtmp Utmp(i)=Utmp(i)+Utmp2(i)*Vs(j) enddo enddo nounit=0 Do while(abs(Utmp(nUtmp))<1.0D-20) nUtmp=nUtmp-1; if (nUtmp.eq.0) exit enddo if (nUtmp.gt.0)then caption0=' ' call MAK1(Utmp,nUtmp,THcomp,nTHcomp,Vcomp,nounit, $ 1,caption0,0,toterr) else nTHcomp=0 Vcomp=0.0D0 THcomp(1)=1.0D0 end if c Computing the total squared error * call CONJ(THcomp,nTHcomp,THcomp,nTHComp,V,nV) * Do i=1,nV * toterr=toterr+(V(i)*Vcomp-Utmp(i))**2 * enddo c End of computing the total squared error PHIcomp(1)=1.0d0 nPHIcomp=1 do j=1,nComp DO k=1,ARsDim(j) ARStmp(k)=ARs(j,k) endDO call CONV(PHIcomp,nPHIcomp,ARstmp,ARsDim(j), $ ARMAtmp2,nARMAtmp2) do l=1,nARMAtmp2 PHIcomp(l)=ARMAtmp2(l) enddo nPHIcomp=nARMAtmp2 enddo end component.i0000664006604000003110000000015714521201423012342 0ustar sun00315stepsc File Component.i integer MaxComp,MaxCompDim parameter(MaxComp=5,MaxCompDim=59)comprevs.f0000664006604000003110000003774414521201423012207 0ustar sun00315steps SUBROUTINE compRevs( dS, dT, nT, nPer, nDiff, lSeaPre, & nSize, nSize2, nSize3, & vSeaAR, oSeaAR, vSeaMA, oSeaMA, & vTreAR, oTreAR, vTreMA, oTreMA, & vCycAR, oCycAR, vCycMA, oCycMA, & vSeaD, oSeaD, vTreD, oTreD, & sSeaVar, sTreVar, sCycVar, sIrrVar, & mDelS, dDelS, nDelS, & mDelT, dDelT, nDelT, & mDel, dDel, nDel, & mRedDelS, dRedDelS, nRedDelS, & mRedDelT, dRedDelT, nRedDelT, & mSigUS, nSigUS, mSigUT, nSigUT, & mSigUI, nSigUI, mSigWS, nSigWS, & mSigWT, nSigWT, mSigW, nSigW, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigWf, nSigWf, mSigWfW, nSigWfW, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW, mIrrVar, nIrrVar, & mSeaVar, nSeaVar, mTreVar, nTreVar, & sdSigAlt, curMSEs, finMSEs, finRevs ) c----------------------------------------------------------------------- c bldDif.f, Release 1, Subroutine Version 1.6, Modified 30 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 20 Oct 2005. c Modified by REG, on 07 Nov 2005, to generalize irregular component c via new mSigUI matrix. c Modified by REG, on 05 Jan 2006, to disable inverting of mSigW c in bldCov(). c Modified by REG, on 20 Jan 2006, to optimize processing, c by using diagonal form of mDel matrices. c Modified by REG, on 07 Apr 2006, to determine opitmization c based on non-zero seasonal and trend innovation variances. c Modified by REG, on 14 Apr 2006, to add future covariance c matrices associated with bldCov(). c Modified by REG, on 30 May 2006, to add generalized check c for no seasonal component processing. c----------------------------------------------------------------------- c This subroutine calculates finite revisions for lead times ranging c from one through five years. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dS i size of Seasonal Differencing c dT i size of Trend Differencing c curMSEs d MSEs of concurrent component estimates c (1: irregular, 2: seasonal, 3: trend) c finMSEs d MSEs of concurrent component estimates c with up to 5 years of future observations c finRevs d finite revisions of concurrent component estimates c with up to 5 years of future observations c nPer i size of seasonal period c nSize i allocated storage size for large matrices c nSize2 i allocated storage size for large matrices c (including future elements) c nSize3 i allocated storage size for large cross covariance matrices c nT i number of observations available c----------------------------------------------------------------------- c Name Type Description (bldDif Input/Output Variables) c----------------------------------------------------------------------- c dDel d diagonal form of overall differencing matrix c dDelS d diagonal form of seasonal differencing matrix c dDelT d diagonal form of trend differencing matrix c dRedDelS d diagonal form of smaller version of mDelS c dRedDelT d diagonal form of smaller version of mDelT c mDel d overall differencing matrix c mDelS d seasonal differencing matrix c mDelT d trend differencing matrix c nDiff i vector of (d,D) differencing orders c mRedDelS d smaller version of mDelS c mRedDelT d smaller version of mDelT c nDel i size (rows,columns) of mDel c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nRedDelS i size (rows,columns) of mRedDelS c nRedDelT i size (rows,columns) of mRedDelT c oSeaD i max order of vSeaD polynomial c oTreD i max order of vTreD polynomial c vSeaD d seasonal differencing polynomial of size nSeaD c vTreD d trend differencing polynomial of size vTreD c----------------------------------------------------------------------- c Name Type Description (bldCov Input/Output Variables) c----------------------------------------------------------------------- c mInvSigUS d contains inverse of mSigUS c mInvSigUT d contains inverse of mSigUT c mInvSigW d contains inverse of mSigW c mInvSigWS d contains inverse of mSigWS c mInvSigWT d contains inverse of mSigWT c mSigUI d covariance matrix for undifferenced irregular c mSigUS d covariance matrix for differenced seasonal c mSigUT d covariance matrix for differenced trend (UT) c mSigUTf d covariance matrix for future differenced trend (UTf) c mSigUTfUT d cross covariance matrix for (UTf,UT) c mSigW d covariance matrix for differenced data (W) c mSigWf d covariance matrix for future differenced data (Wf) c mSigWfW d cross covariance matrix for (Wf,W) c mSigWS d covariance matrix for differenced trend adjusted c mSigWT d covariance matrix for differenced seasonally adjusted (WT) c mSigWTf d covariance matrix for future differenced seasonally c adjusted (WTf) c mSigWTfWT d cross covariance matrix for (WTf,WT) c nInvSigUS i size (rows,columns) of mInvSigUS matrix c nInvSigUT i size (rows,columns) of mInvSigUT matrix c nInvSigW i size (rows,columns) of mInvSigW matrix c nInvSigWS i size (rows,columns) of mInvSigWS matrix c nInvSigWT i size (rows,columns) of mInvSigWT matrix c nSigUI i size (rows,columns) of mSigUI matrix c nSigUS i size (rows,columns) of mSigUS matrix c nSigUT i size (rows,columns) of mSigUT matrix c nSigUTf i size (rows,columns) of mSigUTf matrix c nSigUTfUT i size (rows,columns) of mSigUTfUT matrix c nSigW i size (rows,columns) of mSigW matrix c nSigWf i size (rows,columns) of mSigWf matrix c nSigWfW i size (rows,columns) of mSigWfW matrix c nSigWS i size (rows,columns) of mSigWS matrix c nSigWT i size (rows,columns) of mSigWT matrix c nSigWTf i size (rows,columns) of mSigWTf matrix c nSigWTfWT i size (rows,columns) of mSigWTfWT matrix c oCycAR i max order of vCycAR polynomial c oCycAR i max order of vCycMA polynomial c oSeaMA i max order of vSeaAR polynomial c oSeaAR i max order of vSeaMA polynomial c oTreAR i max order of vTreAR polynomial c oTreMA i max order of vTreMA polynomial c sCycVar d cycle innovation variance c sIrrVar d irregular innovation variance c sSeaVar d seasonal innovation variance c sTreVar d trend innovation variance c vCycAR d AR polynomial vector for cycle component c vCycMA d MA polynomial vector for cycle component c vSeaAR d AR polynomial vector for seasonal component c vSeaMA d MA polynomial vector for seasonal component c vTreAR d AR polynomial vector for Trend component c vTreMA d MA polynomial vector for Trend component c----------------------------------------------------------------------- c Name Type Description (compMSE Input/Output Variables) c----------------------------------------------------------------------- c lSeaPre l logical indicating presence of seasonal component c mIrrVar d variance matrix of estimated irregular c mSeaVar d variance matrix of estimated seasonal c mTreVar d variance matrix of estimated trend c nIrrVar i size (rows,columns) of mIrrVar matrix c nSeaVar i size (rows,columns) of mSeaVar matrix c nTreVar i size (rows,columns) of mTreVar matrix c sdSigAlt d alternate data innovation stdev when parameters are fixed c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c iLead i identifies Lead year 1 through 5 c lInvSig l logical indicates whether all inverses are available c for compMSE() c lInvSigUS l logical to enable calculation of mInvSigUS in bldCov() c lInvSigUT l logical to enable calculation of mInvSigUT in bldCov() c lInvSigW l logical to enable calculation of mInvSigW in bldCov() c lInvSigWS l logical to enable calculation of mInvSigWS in bldCov() c lInvSigWT l logical to enable calculation of mInvSigWT in bldCov() c lSigUf l logical to enable calculation of covariance matrices c for future elements in bldCov() c nTLead i adds iLead years to nT c ZERO d parameter constant c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables c----------------------------------------------------------------------- INTEGER dS, dT, nSize, nSize2, nSize3, nT DOUBLE PRECISION curMSEs(3), finMSEs(3,5), finRevs(3,5) c----------------------------------------------------------------------- c Declare additional Input/Output variables for bldDif() c----------------------------------------------------------------------- LOGICAL lSeaPre INTEGER oSeaD, oTreD INTEGER nDelS(2), nDelT(2), nDel(2), nDiff(2), nPer, & nRedDelS(2), nRedDelT(2) DOUBLE PRECISION vSeaD(0:oSeaD), vTreD(0:oTreD) DOUBLE PRECISION mDelS(nSize2), mDelT(nSize2), mDel(nSize2), & mRedDelS(nSize2), mRedDelT(nSize2) DOUBLE PRECISION dDel(dS+dT+1), dDelS(dS+1), dDelT(dT+1), & dRedDelS(dS+1), dRedDelT(dT+1) c----------------------------------------------------------------------- c Declare additional Input/Output variables for bldCov() c----------------------------------------------------------------------- INTEGER oSeaAR, oSeaMA, oTreAR, oTreMA, oCycAR, oCycMA INTEGER nSigUI(2), nSigUS(2), nSigUT(2) INTEGER nSigWS(2), nSigWT(2), nSigW(2) INTEGER nSigUTf(2), nSigUTfUT(2), nSigWTf(2), nSigWTfWT(2), & nSigWf(2), nSigWfW(2) INTEGER nInvSigUS(2), nInvSigUT(2) INTEGER nInvSigW(2), nInvSigWS(2), nInvSigWT(2) DOUBLE PRECISION sSeaVar, sTreVar, sCycVar, sIrrVar DOUBLE PRECISION vSeaAR(0:oSeaAR), vSeaMA(0:oSeaMA) DOUBLE PRECISION vTreAR(0:oTreAR), vTreMA(0:oTreMA) DOUBLE PRECISION vCycAR(0:oCycAR), vCycMA(0:oCycMA) DOUBLE PRECISION mSigUI(nSize2), mSigUS(nSize2), mSigUT(nSize2), & mSigWS(nSize2), mSigWT(nSize2), mSigW(nSize2) DOUBLE PRECISION mSigUTf(12*12), mSigUTfUT(nSize3), & mSigWTf(12*12), mSigWTfWT(nSize3), & mSigWf(12*12), mSigWfW(nSize3) DOUBLE PRECISION mInvSigUS(nSize2), mInvSigUT(nSize2), & mInvSigWS(nSize2), mInvSigWT(nSize2), & mInvSigW(nSize2) c----------------------------------------------------------------------- c Declare additional Input/Output variables for compMSE() c----------------------------------------------------------------------- INTEGER nIrrVar(2), nSeaVar(2), nTreVar(2) DOUBLE PRECISION sdSigAlt DOUBLE PRECISION mIrrVar(nSize2), mSeaVar(nSize2), mTreVar(nSize2) c----------------------------------------------------------------------- c Declare local variables c----------------------------------------------------------------------- LOGICAL lInvSigUS, lInvSigUT, lInvSigW, lInvSigWS, lInvSigWT, & lInvSig, lSigUf LOGICAL dpeq INTEGER iLead, nTLead DOUBLE PRECISION ZERO PARAMETER (lInvSigW=.false., lSigUf=.false., ZERO=0.0D0) c----------------------------------------------------------------------- c Decide on which inverses to perform. c----------------------------------------------------------------------- IF (( dpeq(sSeaVar,ZERO) ) .or. ( dpeq(sTreVar,ZERO) )) THEN lInvSigUS = .true. lInvSigUT = .true. lInvSigWS = .true. lInvSigWT = .true. lInvSig = .true. ELSE lInvSigUS = .true. lInvSigUT = .false. lInvSigWS = .false. lInvSigWT = .true. lInvSig = .false. END IF c----------------------------------------------------------------------- c Process each of the lead times c----------------------------------------------------------------------- DO iLead = 1, 5 c----------------------------------------------------------------------- c Calculate adjusted nT for desired lead time c----------------------------------------------------------------------- nTLead = nT + iLead*nPer c----------------------------------------------------------------------- c bldDif processing c----------------------------------------------------------------------- CALL bldDif( dS, dT, nTLead, nPer, nDiff, vSeaD, oSeaD, & vTreD, oTreD, mDelS, dDelS, nDelS, & mDelT, dDelT, nDelT, & mRedDelS, dRedDelS, nRedDelS, & mRedDelT, dRedDelT, nRedDelT, & mDel, dDel, nDel ) c----------------------------------------------------------------------- c bldCov processing c----------------------------------------------------------------------- CALL bldCov( nTLead, dS, dT, nPer, lSeaPre, & lSigUf, lInvSigUS, lInvSigUT, & lInvSigW, lInvSigWS, lInvSigWT, & vSeaAR, oSeaAR, vSeaMA, oSeaMA, & vTreAR, oTreAR, vTreMA, oTreMA, & vCycAR, oCycAR, vCycMA, oCycMA, & dDel, nDel, dDelS, nDelS, dDelT, nDelT, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & sSeaVar, sTreVar, sCycVar, sIrrVar, & mSigUS, nSigUS, mSigUT, nSigUT, mSigUI, nSigUI, & mSigWS, nSigWS, mSigWT, nSigWT, mSigW, nSigW, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigWf, nSigWf, mSigWfW, nSigWfW, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW ) c----------------------------------------------------------------------- c compMSE processing c----------------------------------------------------------------------- CALL compMSE( nTLead, dS, dT, lSeaPre, dDel, nDel, dDelS, nDelS, & dDelT, nDelT, sdSigAlt, mSigUI, nSigUI, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW, lInvSig, & mIrrVar, nIrrVar, mSeaVar, nSeaVar, & mTreVar, nTreVar ) c----------------------------------------------------------------------- c Calculate the finite revisions c----------------------------------------------------------------------- c finMSEs(1,iLead) = mIrrVar( (nT-1)*nTLead+nT ) finMSEs(1,iLead) = ZERO finMSEs(2,iLead) = mSeaVar( (nT-1)*nTLead+nT ) finMSEs(3,iLead) = mTreVar( (nT-1)*nTLead+nT ) c finRevs(1,iLead) = curMSEs(1) - finMSEs(1,iLead) finRevs(1,iLead) = ZERO finRevs(2,iLead) = curMSEs(2) - finMSEs(2,iLead) finRevs(3,iLead) = curMSEs(3) - finMSEs(3,iLead) c----------------------------------------------------------------------- c Some debug output c----------------------------------------------------------------------- c WRITE(6,1000)nTLead c1000 FORMAT(' nTLead = ', i4) END DO RETURN ENDconstant.f0000664006604000003110000003267514521201423012200 0ustar sun00315stepscc c cc Double precision function dbl_eps () integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp double precision eps,epsneg,xmin,xmax call machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, $ eps,epsneg,xmin,xmax) dbl_eps = eps / 2.0d0 return end cc c cc Double precision function dbl_epsneg () integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp double precision eps,epsneg,xmin,xmax call machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, $ eps,epsneg,xmin,xmax) dbl_epsneg = epsneg return end cc c cc Double precision function dbl_max () integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp double precision deps,epsneg,xmin,xmax call machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, $ deps,epsneg,xmin,xmax) dbl_max = xmax return end cc c cc Integer function dbl_max_exp () integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp double precision deps,epsneg,xmin,xmax call machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, $ deps,epsneg,xmin,xmax) dbl_max_exp = Int(Dlog10(xmax)) return end cc c cc Double precision function dbl_min () integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp double precision deps,epsneg,xmin,xmax call machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, $ deps,epsneg,xmin,xmax) dbl_min = xmin return end cc c cc Integer function dbl_min_exp () integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp double precision deps,epsneg,xmin,xmax call machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, $ deps,epsneg,xmin,xmax) dbl_min_exp = Int(Dlog10(xmin)) return end C ALGORITHM 665, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 14, NO. 4, PP. 303-311. SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) C----------------------------------------------------------------------- C This Fortran 77 subroutine is intended to determine the parameters C of the floating-point arithmetic system specified below. The C determination of the first three uses an extension of an algorithm C due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some, C but not all, of the improvements suggested by M. Gentleman and S. C Marovich, CACM 17 (1974), pp. 276-277. An earlier version of this C program was published in the book Software Manual for the C Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall, C Englewood Cliffs, NJ, 1980. C C The program as given here must be modified before compiling. If C a single (double) precision version is desired, change all C occurrences of CS (CD) in columns 1 and 2 to blanks. C C Parameter values reported are as follows: C C IBETA - the radix for the floating-point representation C IT - the number of base IBETA digits in the floating-point C significand C IRND - 0 if floating-point addition chops C 1 if floating-point addition rounds, but not in the C IEEE style C 2 if floating-point addition rounds in the IEEE style C 3 if floating-point addition chops, and there is C partial underflow C 4 if floating-point addition rounds, but not in the C IEEE style, and there is partial underflow C 5 if floating-point addition rounds in the IEEE style, C and there is partial underflow C NGRD - the number of guard digits for multiplication with C truncating arithmetic. It is C 0 if floating-point arithmetic rounds, or if it C truncates and only IT base IBETA digits C participate in the post-normalization shift of the C floating-point significand in multiplication; C 1 if floating-point arithmetic truncates and more C than IT base IBETA digits participate in the C post-normalization shift of the floating-point C significand in multiplication. C MACHEP - the largest negative integer such that C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that C MACHEP is bounded below by -(IT+3) C NEGEPS - the largest negative integer such that C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that C NEGEPS is bounded below by -(IT+3) C IEXP - the number of bits (decimal places if IBETA = 10) C reserved for the representation of the exponent C (including the bias or sign) of a floating-point C number C MINEXP - the largest in magnitude negative integer such that C FLOAT(IBETA)**MINEXP is positive and normalized C MAXEXP - the smallest positive power of BETA that overflows C EPS - the smallest positive floating-point number such C that 1.0+EPS .NE. 1.0. In particular, if either C IBETA = 2 or IRND = 0, EPS = FLOAT(IBETA)**MACHEP. C Otherwise, EPS = (FLOAT(IBETA)**MACHEP)/2 C EPSNEG - A small positive floating-point number such that C 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2 C or IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. C Otherwise, EPSNEG = (IBETA**NEGEPS)/2. Because C NEGEPS is bounded below by -(IT+3), EPSNEG may not C be the smallest number that can alter 1.0 by C subtraction. C XMIN - the smallest non-vanishing normalized floating-point C power of the radix, i.e., XMIN = FLOAT(IBETA)**MINEXP C XMAX - the largest finite floating-point number. In C particular XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP C Note - on some machines XMAX will be only the C second, or perhaps third, largest number, being C too small by 1 or 2 units in the last digit of C the significand. C C Latest revision - April 20, 1987 C C Author - W. J. Cody C Argonne National Laboratory C C----------------------------------------------------------------------- INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP, 1 MINEXP,MX,NEGEP,NGRD,NXRES CS REAL A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA, CS 1 TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO DOUBLE PRECISION A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE, 1 T,TEMP,TEMPA,TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO C----------------------------------------------------------------------- CS CONV(I) = REAL(I) CONV(I) = DBLE(I) ONE = CONV(1) TWO = ONE + ONE ZERO = ONE - ONE C----------------------------------------------------------------------- C Determine IBETA, BETA ala Malcolm. C----------------------------------------------------------------------- A = ONE 10 A = A + A TEMP = A+ONE TEMP1 = TEMP-A IF (TEMP1-ONE .EQ. ZERO) GO TO 10 B = ONE 20 B = B + B TEMP = A+B ITEMP = INT(TEMP-A) IF (ITEMP .EQ. 0) GO TO 20 IBETA = ITEMP BETA = CONV(IBETA) C----------------------------------------------------------------------- C Determine IT, IRND. C----------------------------------------------------------------------- IT = 0 B = ONE 100 IT = IT + 1 B = B * BETA TEMP = B+ONE TEMP1 = TEMP-B IF (TEMP1-ONE .EQ. ZERO) GO TO 100 IRND = 0 BETAH = BETA / TWO TEMP = A+BETAH IF (TEMP-A .NE. ZERO) IRND = 1 TEMPA = A + BETA TEMP = TEMPA+BETAH IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2 C----------------------------------------------------------------------- C Determine NEGEP, EPSNEG. C----------------------------------------------------------------------- NEGEP = IT + 3 BETAIN = ONE / BETA A = ONE DO 200 I = 1, NEGEP A = A * BETAIN 200 CONTINUE B = A 210 TEMP = ONE-A IF (TEMP-ONE .NE. ZERO) GO TO 220 A = A * BETA NEGEP = NEGEP - 1 GO TO 210 220 NEGEP = -NEGEP EPSNEG = A IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300 A = (A*(ONE+A)) / TWO TEMP = ONE-A IF (TEMP-ONE .NE. ZERO) EPSNEG = A C----------------------------------------------------------------------- C Determine MACHEP, EPS. C----------------------------------------------------------------------- 300 MACHEP = -IT - 3 A = B 310 TEMP = ONE+A IF (TEMP-ONE .NE. ZERO) GO TO 320 A = A * BETA MACHEP = MACHEP + 1 GO TO 310 320 EPS = A TEMP = TEMPA+BETA*(ONE+EPS) IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350 A = (A*(ONE+A)) / TWO TEMP = ONE+A IF (TEMP-ONE .NE. ZERO) EPS = A C----------------------------------------------------------------------- C Determine NGRD. C----------------------------------------------------------------------- 350 NGRD = 0 TEMP = ONE+EPS IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1 C----------------------------------------------------------------------- C Determine IEXP, MINEXP, XMIN. C C Loop to determine largest I and K = 2**I such that C (1/BETA) ** (2**(I)) C does not underflow. C Exit from loop is signaled by an underflow. C----------------------------------------------------------------------- I = 0 K = 1 Z = BETAIN T = ONE + EPS NXRES = 0 400 Y = Z Z = Y * Y C----------------------------------------------------------------------- C Check for underflow here. C----------------------------------------------------------------------- A = Z * ONE TEMP = Z * T IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410 TEMP1 = TEMP * BETAIN IF (TEMP1*BETA .EQ. Z) GO TO 410 I = I + 1 K = K + K GO TO 400 410 IF (IBETA .EQ. 10) GO TO 420 IEXP = I + 1 MX = K + K GO TO 450 C----------------------------------------------------------------------- C This segment is for decimal machines only. C----------------------------------------------------------------------- 420 IEXP = 2 IZ = IBETA 430 IF (K .LT. IZ) GO TO 440 IZ = IZ * IBETA IEXP = IEXP + 1 GO TO 430 440 MX = IZ + IZ - 1 C----------------------------------------------------------------------- C Loop to determine MINEXP, XMIN. C Exit from loop is signaled by an underflow. C----------------------------------------------------------------------- 450 XMIN = Y C----------------------------------------------------------------------- C Check for underflow here. C----------------------------------------------------------------------- c IF (((Y*ONE*BETAIN+Y*ONE*BETAIN) .EQ. ZERO) c 1 .OR. (ABS(Y*BETAIN) .GE. XMIN)) GO TO 460 Y = Y * BETAIN A = Y * ONE IF (((A+A) .EQ. ZERO) 1 .OR. (ABS(A) .GE. XMIN)) GO TO 460 TEMP = Y * T K = K + 1 TEMP1 = TEMP * BETAIN IF (TEMP1*BETA .NE. Y) GO TO 450 NXRES = 3 XMIN = Y 460 MINEXP = -K C----------------------------------------------------------------------- C Determine MAXEXP, XMAX. C----------------------------------------------------------------------- IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 MX = MX + MX IEXP = IEXP + 1 500 MAXEXP = MX + MINEXP C----------------------------------------------------------------- C Adjust IRND to reflect partial underflow. C----------------------------------------------------------------- IRND = IRND + NXRES C----------------------------------------------------------------- C Adjust for IEEE-style machines. C----------------------------------------------------------------- IF ((IRND .EQ. 2) .OR. (IRND .EQ. 5)) MAXEXP = MAXEXP - 2 C----------------------------------------------------------------- C Adjust for non-IEEE machines with partial underflow. C----------------------------------------------------------------- IF ((IRND .EQ. 3) .OR. (IRND .EQ. 4)) MAXEXP = MAXEXP - IT C----------------------------------------------------------------- C Adjust for machines with implicit leading bit in binary C significand, and machines with radix point at extreme C right of significand. C----------------------------------------------------------------- I = MAXEXP + MINEXP IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 IF (I .GT. 20) MAXEXP = MAXEXP - 1 IF (A .NE. Y) MAXEXP = MAXEXP - 2 XMAX = ONE - EPSNEG IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG XMAX = XMAX / (BETA * BETA * BETA * XMIN) I = MAXEXP + MINEXP + 3 IF (I .LE. 0) GO TO 520 DO 510 J = 1, I IF (IBETA .EQ. 2) XMAX = XMAX + XMAX IF (IBETA .NE. 2) XMAX = XMAX * BETA 510 CONTINUE 520 RETURN C---------- LAST CARD OF MACHAR ---------- END copycl.f0000664006604000003110000000344214521201423011626 0ustar sun00315steps**==copycl.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE copycl(From,Nr,Nfrmcl,Ifrmcl,Ntocl,Itocl,To) IMPLICIT NONE c----------------------------------------------------------------------- c Copies the column ifrmcl from from, an nr by nfrmcl matrix, to c column itocl of to, an nr by ntocl matrix c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c eltfrm i Local element of the from matrix c eltto i Local element of the to matrix c from d Input nr by nfrmcl matrix that column iform is copied from c i i Local do loop index c ifrmcl i Input column of from to copy c itocl i Input column of to to put column ifrmcl of from in c nfrmcl i Input number of from columns c nr i Input number of rows in to and from c ntocl i Input number of to columns c----------------------------------------------------------------------- c Data typing and definition c----------------------------------------------------------------------- INTEGER eltfrm,eltto,i,Ifrmcl,Itocl,Nfrmcl,Nr,Ntocl DOUBLE PRECISION From,To DIMENSION From(Nr*Nfrmcl),To(Nr*Ntocl) c----------------------------------------------------------------------- c Initialize the column indices then copy the colomns c----------------------------------------------------------------------- eltfrm=Ifrmcl-Nfrmcl eltto=Itocl-Ntocl c----------------------------------------------------------------------- DO i=1,Nr eltfrm=eltfrm+Nfrmcl eltto=eltto+Ntocl To(eltto)=From(eltfrm) END DO c----------------------------------------------------------------------- RETURN END copy.f0000664006604000003110000000260414521201423011306 0ustar sun00315stepsC Last change: BCM 25 Nov 97 10:28 am **==copy.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE copy(Invec,N,Inc,Outvec) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to copy one vector into another. Note, that you must c have enough space in both arrays to copy. This routine cannot check c this. Inc controls the direction if you are copying vector on to c another part of itself for example back to front copy(a,na,-1,a(nqstar)) c or front to back copy(a(nqstar),na,1,a), nqstar positive. c Inc also controls the intervals between for example c c double precision x(5,n),y(5,n) c call copy(x,n,5,y) @ to copy the 1st column c call copy(x(3),n,5,y(2))@ to copy the 3rd column to the 2ond c c----------------------------------------------------------------------- INTEGER i,N,Inc,begelt,endelt DOUBLE PRECISION Invec(*),Outvec(*) c----------------------------------------------------------------------- IF(Inc.gt.0)THEN begelt=1 endelt=N ELSE begelt=N endelt=1 END IF c----------------------------------------------------------------------- DO i=begelt,endelt,Inc Outvec(i)=Invec(i) END DO c----------------------------------------------------------------------- RETURN END copylg.f0000664006604000003110000000253214521201423011631 0ustar sun00315steps**==copylg.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE copylg(In,N,Inc,Out) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to copy one vector into another. Note, that you must c have enough space in both arrays to copy. This routine cannot check c this. Inc controls the direction if you are copying vector on to c another part of itself for example back to front c copylg(a,na,-1,a(nqstar)) c or front to back c copylg(a(nqstar),na,1,a), c nqstar positive. c c Inc also controls the intervals between for example c c logical x(5,n),y(5,n) c call copylg(x,n,5,y) @ to copy the 1st column c call copylg(x(3),n,5,y(2))@ to copy the 3rd column to the 2ond c c----------------------------------------------------------------------- LOGICAL In(*),Out(*) INTEGER i,N,Inc,begelt,endelt c ------------------------------------------------------------------ IF(Inc.gt.0)THEN begelt=1 endelt=N ELSE begelt=N endelt=1 END IF c ------------------------------------------------------------------ DO i=begelt,endelt,Inc Out(i)=In(i) END DO c ------------------------------------------------------------------ RETURN END cormtx.f0000664006604000003110000000535214521201423011653 0ustar sun00315stepsC Last change: BCM 2 Jun 1998 11:33 am SUBROUTINE cormtx(Xpxinv,Regidx) IMPLICIT NONE c----------------------------------------------------------------------- c Calculates and print the correlation matrix from (X'X)^-1 c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER str*(PCOLCR) INTEGER icol,idiag,ielt,irow,nchr,Regidx,tcol,jcol,i1,i2,j DOUBLE PRECISION scale,Xpxinv DIMENSION Xpxinv(Nb*Ncxy/2),Regidx(PB),tcol(PB) c----------------------------------------------------------------------- jcol=Nb j=1 IF(Iregfx.eq.2)THEN DO icol=1,Nb IF(Regidx(icol).ne.NOTSET)THEN tcol(j)=icol j=j+1 ElSE jcol=jcol-1 END IF END DO WRITE(Mt1,1010)(tcol(icol),icol=1,jcol) ELSE WRITE(Mt1,1010)(icol,icol=1,jcol) END IF 1010 FORMAT(/,' Correlation matrix',/,' Variable',(:t20,10I6)) WRITE(Mt1,1020)('-',icol=1,17+6*min(jcol,10)) 1020 FORMAT(' ',(78a)) c----------------------------------------------------------------------- idiag=0 DO icol=1,Nb IF(Regidx(icol).ne.NOTSET)THEN idiag=idiag+Regidx(icol) scale=sqrt(Xpxinv(idiag)) c----------------------------------------------------------------------- DO ielt=idiag-Regidx(icol)+1,idiag c IF(Regidx(ielt).ne.NOTSET)THEN c jcol=Regidx(ielt) Xpxinv(ielt)=Xpxinv(ielt)/scale c END IF END DO c----------------------------------------------------------------------- ielt=idiag DO irow=icol,Nb IF(Regidx(irow).ne.NOTSET)THEN Xpxinv(ielt)=Xpxinv(ielt)/scale ielt=ielt+Regidx(irow) END IF END DO c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN i1=idiag-Regidx(icol)+1 i2=i1+9 IF(i2.gt.idiag)i2=idiag WRITE(Mt1,1030)str(1:nchr),(Xpxinv(ielt),ielt=i1,i2) 1030 FORMAT(' ',a,t20,10F6.2) DO WHILE(i2.lt.idiag) i1=i2+1 i2=i1+9 IF(i2.gt.idiag)i2=idiag WRITE(Mt1,1040)(Xpxinv(ielt),ielt=i1,i2) 1040 FORMAT(t20,10F6.2) END DO END IF END DO c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END cornom.f0000664006604000003110000000077214521201423011635 0ustar sun00315steps**==cornom.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE cornom(C,Cn,Lagh1,Cx0,Cy0) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION C,Cn,cst1,Cx0,Cy0,ds INTEGER i,Lagh1 C*** End of declarations inserted by SPAG C COMMON SUBROUTINE C NORMALIZATION OF COVARIANCE DIMENSION C(*),Cn(*) cst1=1.0D-00 ds=cst1/sqrt(Cx0*Cy0) DO i=1,Lagh1 Cn(i)=C(i)*ds END DO RETURN END corplt.f0000664006604000003110000001564314521201423011646 0ustar sun00315stepsC Last change: BCM 21 Aug 1998 11:18 am SUBROUTINE corplt(R,Se,Nr,Nsp,Iflag) c----------------------------------------------------------------------- c corplt.f, Release 1, Subroutine Version 1.5, Modified 15 Feb 1995. c----------------------------------------------------------------------- c subroutine to plot sample ACF and PACF functions c----------------------------------------------------------------------- C modified 28 Mar 1996 to use =s instead of Xs for spikes, C use a | at 0.0, and indicate seasonal lags with dashes. C -Matt Kramer c----------------------------------------------------------------------- c modified 21 August 1998 to produce ACF plot for squared c residuals c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c r r vector of autorelations or partial autorelations c nr i number of relations and standard errors c nsp i length of the seasonal period c iflag i indicator for PACF and ACF, i = 1 PACF, i = 2 ACF, c i=3, ACF of squared residuals c se r vector of standard errors C ep i even value of p if = 0 C sl i seasonal lag if = 0 c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ONE,MONE,ZERO PARAMETER(F=.false.,T=.true.,ONE=1D0,MONE=-1D0,ZERO=0D0) c----------------------------------------------------------------------- C--- modified following line -MK INTEGER i,j,k,imax,imin,Nr,nlag,Nsp,Iflag,pin,plb,pub,sl,ep DOUBLE PRECISION rmax,rmin,rmid,R(Nr),Se(Nr),sqv C--- modified following line -MK CHARACTER p(51),x,cblnk,cdot,bar,dash CHARACTER*2 pmar * LOGICAL pinout,plbout,pubout LOGICAL plbout,pubout C--- following line modified -MK DATA x,cblnk,cdot,bar,dash/'X',' ','.','|','-'/ c----------------------------------------------------------------------- c Set the number of lags to be plotted c----------------------------------------------------------------------- nlag=Nr c----------------------------------------------------------------------- c Set the Plot Range c----------------------------------------------------------------------- rmin=MONE rmax=ONE rmid=ZERO sqv=(rmax-rmin)/50D0 c----------------------------------------------------------------------- c Write out header for the plot c----------------------------------------------------------------------- * IF(Iflag.eq.1)THEN * WRITE(Mt1,1010) * 1010 FORMAT(' Sample Partial Autocorrelations of the Residuals') * ELSE IF(Iflag.eq.2)THEN * WRITE(Mt1,1020)'Residuals' * 1020 FORMAT(' Sample Autocorrelations of the ',a) * ELSE IF(Iflag.eq.3)THEN * WRITE(Mt1,1020)'Squared Residuals' * END IF c----------------------------------------------------------------------- c Write out plot axes c----------------------------------------------------------------------- WRITE(Mt1,1030) 1030 FORMAT(17x, & '-1.0 -0.8 -0.6 -0.4 -0.2 0.0 0.2 0.4 0.6 0.8 1.0') WRITE(Mt1,1040) 1040 FORMAT(17x,' +',10('----+')) c----------------------------------------------------------------------- c plot sample autorelations one lag at a time c by filling print buffer character vector p c----------------------------------------------------------------------- DO i=1,nlag c----------------------------------------------------------------------- c initialize print buffer vector p and margin buffer pmar c----------------------------------------------------------------------- pmar=' ' DO j=1,51 p(j)=cblnk END DO c----------------------------------------------------------------------- IF(R(i).lt.MONE.or.R(i).ge.ONE)THEN WRITE(STDERR,1050) CALL errhdr WRITE(Mt2,1050) 1050 FORMAT(/,' ERROR: Sample ACF or PACF computations', & ' produced values greater than one in norm.') CALL abend RETURN END IF c----------------------------------------------------------------------- c Calculate plot point indices for the autorelation value, c and cplus and minus two standard error bounds c----------------------------------------------------------------------- pin=nint((R(i)-rmin)/sqv)+1 pub=nint((2D0*Se(i)-rmin)/sqv)+1 plb=52-pub c----------------------------------------------------------------------- c Check to see if plot indices are within bounds c----------------------------------------------------------------------- c pinout=F plbout=F pubout=F c IF((pin.gt.51).or.(pin.lt.1))pinout=T IF((plb.gt.51).or.(plb.lt.1))plbout=T IF((pub.gt.51).or.(pub.lt.1))pubout=T c ------------------------------------------------------------------ imin=pin imax=pin c----------------------------------------------------------------------- c Set up marker for the zero line, and standard error bounds c----------------------------------------------------------------------- IF(.not.plbout)p(plb)=cdot IF(.not.pubout)p(pub)=cdot C--- added lines to insert dashes at seasonal period -MK sl=mod(i,Nsp) IF((sl.eq.0).and.(Nsp.gt.1))THEN DO j=1,49 ep=mod(j,2) IF(((j.lt.(plb-2)).or.(j.gt.(pub+2))).and.(ep.eq.0))p(j)=dash END DO END IF C---END OF ADDED LINES c----------------------------------------------------------------------- c Set up bars c----------------------------------------------------------------------- IF(R(i).lt.rmid)imax=26 IF(R(i).ge.rmid)imin=26 DO k=imin,imax p(k)=x END DO C--- blank out seasonal dashes near ends of ACF or PACF spikes -MK IF((sl.eq.0).and.(imin.gt.3).and.(imin.lt.plb))THEN DO k=(imin-3),(imin-1) p(k)=cblnk END DO END IF IF((sl.eq.0).and.(imax.lt.48).and.(imax.gt.pub))THEN DO k=(imax+1),(imax+3) p(k)=cblnk END DO END IF p(26)=bar C--- IF(sl.eq.0)p(26)=cplus this wasn't being used anyway -MK c----------------------------------------------------------------------- c Write out print buffer for the autorelation at this lag c----------------------------------------------------------------------- WRITE(Mt1,1060)i,pmar,p,R(i) 1060 FORMAT(10x,i3,4x,a2,51A1,f6.3) END DO WRITE(Mt1,1070)' ' 1070 FORMAT(a) c ------------------------------------------------------------------ RETURN END count.i0000664006604000003110000000016414521201423011466 0ustar sun00315stepsC C... Variables in Common Block /count/ ... integer IFN,JFAC,ICOMM common /count/ IFN,JFAC,ICOMM covar.f0000664006604000003110000000701014521201424011443 0ustar sun00315steps SUBROUTINE covar(N,R,Ldr,Ipvt,Tol,Info) IMPLICIT NONE c----------------------------------------------------------------------- c covar.f, Release 1, Subroutine Version 1.4, Modified 03 Feb 1995. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INTEGER N,Ldr INTEGER Ipvt(N) DOUBLE PRECISION Tol DOUBLE PRECISION R(Ldr,N),wa(PARIMA) c----------------------------------------------------------------------- INTEGER i,ii,Info,j,jj,k,km1 LOGICAL sing DOUBLE PRECISION dpmpar,ONE,temp,tolr,ZERO PARAMETER(ONE=1D0,ZERO=0D0) EXTERNAL dpmpar c----------------------------------------------------------------------- c Form the inverse of R in the full upper triangle of R c----------------------------------------------------------------------- IF(Tol.le.ZERO)THEN tolr=dpmpar(1)*abs(R(1,1)) ELSE tolr=Tol*abs(R(1,1)) END IF c----------------------------------------------------------------------- Info=NOTSET DO k=1,N IF(abs(R(k,k)).le.tolr)GO TO 10 R(k,k)=ONE/R(k,k) km1=k-1 c----------------------------------------------------------------------- DO j=1,km1 temp=R(k,k)*R(j,k) R(j,k)=ZERO c----------------------------------------------------------------------- DO i=1,j R(i,k)=R(i,k)-temp*R(i,j) END DO END DO c----------------------------------------------------------------------- Info=k END DO c----------------------------------------------------------------------- c Form the full upper triangle of the inverse of R'R in the c full upper triangle of R c----------------------------------------------------------------------- 10 DO k=1,Info km1=k-1 c----------------------------------------------------------------------- DO j=1,km1 temp=R(j,k) c----------------------------------------------------------------------- DO i=1,j R(i,j)=R(i,j)+temp*R(i,k) END DO END DO c----------------------------------------------------------------------- temp=R(k,k) DO i=1,k R(i,k)=temp*R(i,k) END DO END DO c----------------------------------------------------------------------- c Form the full lower triangle of the covariance matrix in the c strict lower triangle of R and in WA c----------------------------------------------------------------------- DO j=1,N jj=Ipvt(j) sing=j.gt.Info DO i=1,j IF(sing)R(i,j)=ZERO ii=Ipvt(i) IF(ii.gt.jj)THEN R(ii,jj)=R(i,j) ELSE IF(ii.lt.jj)THEN R(jj,ii)=R(i,j) END IF END DO wa(jj)=R(j,j) END DO c----------------------------------------------------------------------- c Make R a symmetric matrix c----------------------------------------------------------------------- DO j=1,N DO i=1,j R(i,j)=R(j,i) END DO R(j,j)=wa(j) END DO c----------------------------------------------------------------------- c If the matrix is nonsingular then return info=0, otherwise c return the number of nonsingular columns. c----------------------------------------------------------------------- IF(Info.eq.N)Info=0 c----------------------------------------------------------------------- RETURN END cpyint.f0000664006604000003110000000256414521201424011650 0ustar sun00315stepsC Last change: BCM 25 Nov 97 10:33 am **==cpyint.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE cpyint(Invec,N,Inc,Outvec) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to copy one vector into another. Note, that you must c have enough space in both arrays to copy. This routine cannot check c this. Inc controls the direction if you are copying vector on to c another part of itself for example back to front copy(a,na,-1,a(nqstar)) c or front to back copy(a(nqstar),na,1,a), nqstar positive. c Inc also controls the intervals between for example c c double precision x(5,n),y(5,n) c call cpyint(x,n,5,y) @ to copy the 1st column c call cpyint(x(3),n,5,y(2))@ to copy the 3rd column to the 2ond c c----------------------------------------------------------------------- INTEGER i,Invec(*),Outvec(*),N,Inc,begelt,endelt c ------------------------------------------------------------------ IF(Inc.gt.0)THEN begelt=1 endelt=N ELSE begelt=N endelt=1 END IF c ------------------------------------------------------------------ DO i=begelt,endelt,Inc Outvec(i)=Invec(i) END DO c ------------------------------------------------------------------ RETURN END cpymat.f0000664006604000003110000000455714521201424011643 0ustar sun00315steps SUBROUTINE cpyMat( mA, nA, mB, nB ) c----------------------------------------------------------------------- c cpyMat.f, Release 1, Subroutine Version 1.0, Created 14 Apr 2005. c----------------------------------------------------------------------- c This subroutine copies matrix mA to matrix mB where nA and nB c contain the dimensions of mA and mB. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d input matrix to be copied from c mB d output matrix to be copied to c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nA(1), nA(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j c----------------------------------------------------------------------- c Establish dimensions of mB matrix. c----------------------------------------------------------------------- nB(1) = nA(1) nB(2) = nA(2) c----------------------------------------------------------------------- c Perform matrix copy of mB = mA c----------------------------------------------------------------------- DO j = 1, nA(2) c ------------------------------------------------------------------ c Copy mA column j to mB column j. c ------------------------------------------------------------------ DO i = 1, nA(1) mB(i,j) = mA(i,j) END DO END DO c ------------------------------------------------------------------ RETURN END crosco.f0000664006604000003110000000132614521201424011625 0ustar sun00315steps**==crosco.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE crosco(X,Y,N1,N2,N,C,Lagh1) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION t,an,bn,bn1,C,ct0,X,Y INTEGER i,ii,il,j,j1,Lagh1,N,N1,N2 C*** End of declarations inserted by SPAG C COMMON SUBROUTINE C THIS SUBROUTINE COMPUTES C(L)=COVARIANCE(X(S+L),Y(S)) C (L=0,1,...,LAGH1-1). DIMENSION X(*),Y(*),C(*) an=dble(N) bn1=1.0D-00 bn=bn1/an ct0=0.0D-00 DO ii=1,Lagh1 i=ii-1 t=ct0 il=N2-i DO j=N1,il j1=j+i t=t+X(j1)*Y(j) END DO C(ii)=t*bn END DO RETURN END cross.i0000664006604000003110000000065114521201424011471 0ustar sun00315stepsC C... Variables in Common Block /Crosscorr/ ... real*8 crciem(-mc:mc),crcier(-mc:mc),crpcem(-mc:mc), $ crpcer(-mc:mc),crpiem(-mc:mc),crpier(-mc:mc), $ crpsem(-mc:mc),crpser(-mc:mc),crscem(-mc:mc), $ crscer(-mc:mc),crsiem(-mc:mc),crsier(-mc:mc) common /crosscorr/ crciem,crcier,crpcem,crpcer,crpiem,crpier, $ crpsem,crpser,crscem,crscer,crsiem,crsier cse.i0000664006604000003110000000017214521201424011110 0ustar sun00315stepsC C... Variables in Common Block /cse/ ... real*8 FFC real*8 PS(5*N12+N12/3) common /cse/ PS,FFC ctodat.f0000664006604000003110000000442514521201424011616 0ustar sun00315steps SUBROUTINE ctodat(Str,Sp,Ipos,Idate,Locok) IMPLICIT NONE c----------------------------------------------------------------------- c Puts the date in character format for outlier variables and c printouts. Seasonal period, Sp, is assumed to be known here. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER Str*(*) LOGICAL isdate,Locok INTEGER ctoi,Idate,Ipos,lstpt,Sp,strinx DIMENSION Idate(2) EXTERNAL ctoi,isdate,strinx c ------------------------------------------------------------------ CHARACTER MODIC*36 INTEGER indx,moptr DIMENSION moptr(0:12) PARAMETER(MODIC='JanFebMarAprMayJunJulAugSepOctNovDec') EXTERNAL indx DATA moptr/1,4,7,10,13,16,19,22,25,28,31,34,37/ c ------------------------------------------------------------------ Locok=T lstpt=Ipos Idate(YR)=ctoi(Str,Ipos) Idate(MO)=0 c ------------------------------------------------------------------ IF(Ipos.lt.len(Str))THEN IF(Str(Ipos:Ipos).eq.'.')THEN Ipos=Ipos+1 IF(indx('0123456789',Str(Ipos:Ipos)).gt.0)THEN Idate(MO)=ctoi(Str,Ipos) c ------------------------------------------------------------------ ELSE Idate(MO)=strinx(F,MODIC,moptr,1,12,Str(Ipos:Ipos+2)) c ------------------------------------------------------------------ c Change by BCM Nov 1995 to test if seasonal period is 12 c ------------------------------------------------------------------ IF(Idate(MO).gt.0)THEN IF(Sp.eq.12)THEN Ipos=Ipos+3 ELSE Locok=F Ipos=lstpt END IF END IF END IF END IF END IF c ------------------------------------------------------------------ IF(.not.isdate(Idate,Sp))THEN Locok=F Ipos=lstpt END IF c ------------------------------------------------------------------ RETURN END ctod.f0000664006604000003110000000452714521201424011274 0ustar sun00315stepsC Last change: BCM 21 Nov 97 10:04 pm **==ctod.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 DOUBLE PRECISION FUNCTION ctod(Str,Ipos) IMPLICIT NONE c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ----------------------------------------------------------------- CHARACTER Str*(*) LOGICAL havdbl INTEGER ctoi,digit,expint,exppos,Ipos,indx,lstpt,nchr DOUBLE PRECISION scl,dpsign EXTERNAL ctoi,indx c ----------------------------------------------------------------- dpsign=1D0 nchr=len(Str) lstpt=Ipos havdbl=F c ----------------------------------------------------------------- IF(Str(Ipos:Ipos).eq.'+'.or.Str(Ipos:Ipos).eq.'-')THEN IF(Str(Ipos:Ipos).eq.'-')dpsign=-1D0 Ipos=Ipos+1 END IF c ----------------------------------------------------------------- ctod=0D0 DO Ipos=Ipos,nchr digit=indx('0123456789',Str(Ipos:Ipos))-1 IF(digit.eq.-1)GO TO 10 ctod=10D0*ctod+dble(digit) havdbl=T END DO Ipos=nchr+1 c ----------------------------------------------------------------- 10 IF(Str(Ipos:Ipos).eq.'.'.and.Ipos.le.nchr)THEN Ipos=Ipos+1 c ----------------------------------------------------------------- scl=1D0 DO Ipos=Ipos,nchr scl=scl*10D0 digit=indx('0123456789',Str(Ipos:Ipos))-1 IF(digit.eq.-1)GO TO 20 ctod=ctod+dble(digit)/scl havdbl=T END DO Ipos=nchr+1 END IF c ----------------------------------------------------------------- 20 ctod=dpsign*ctod c ----------------------------------------------------------------- IF(havdbl.and.Ipos.lt.nchr)THEN IF(indx('eEdD^',Str(Ipos:Ipos)).gt.0)THEN exppos=Ipos Ipos=Ipos+1 expint=ctoi(Str,Ipos) IF(Ipos.eq.exppos+1)THEN Ipos=exppos ELSE ctod=ctod*10D0**expint END IF END IF END IF c ----------------------------------------------------------------- IF(.not.havdbl)THEN ctod=0D0 Ipos=lstpt END IF c ----------------------------------------------------------------- RETURN END ctoi.f0000664006604000003110000000227014521201425011273 0ustar sun00315stepsC Last change: BCM 21 Nov 97 10:06 pm **==ctoi.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 INTEGER FUNCTION ctoi(Str,Ipos) IMPLICIT NONE c ----------------------------------------------------------------- CHARACTER Str*(*) LOGICAL havint INTEGER digit,indx,Ipos,lstpt,nchr,insign EXTERNAL indx c ----------------------------------------------------------------- insign=1 nchr=len(Str) lstpt=Ipos havint=.false. c ----------------------------------------------------------------- IF(Str(Ipos:Ipos).eq.'+'.or.Str(Ipos:Ipos).eq.'-')THEN IF(Str(Ipos:Ipos).eq.'-')insign=-1 Ipos=Ipos+1 END IF c ----------------------------------------------------------------- ctoi=0 DO Ipos=Ipos,nchr digit=indx('0123456789',Str(Ipos:Ipos))-1 IF(digit.eq.-1)GO TO 10 havint=.true. ctoi=10*ctoi+digit END DO c ----------------------------------------------------------------- 10 ctoi=insign*ctoi IF(.not.havint)Ipos=lstpt c ----------------------------------------------------------------- RETURN END cumnor.f0000664006604000003110000002020114521201425011632 0ustar sun00315stepsC Last change: BCM 21 Nov 97 10:07 pm **==cumnor.f processed by SPAG 4.03F at 14:31 on 28 Jul 1994 SUBROUTINE cumnor(Arg,Result,Ccum) IMPLICIT NONE C********************************************************************** C C SUBROUINE CUMNOR(X,RESULT,CCUM) C C C Function C C C Computes the cumulative of the normal distribution, i.e., C the integral from -infinity to x of C (1/sqrt(2*pi)) exp(-u*u/2) du C C X --> Upper limit of integration. C X is DOUBLE PRECISION C C RESULT <-- Cumulative normal distribution. C RESULT is DOUBLE PRECISION C C CCUM <-- Compliment of Cumulative normal distribution. C CCUM is DOUBLE PRECISION C C C Renaming of function ANORM from: C C Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN C Package of Special Function Routines and Test Drivers" C acm Transactions on Mathematical Software. 19, 22-32. C C with slight modifications to return ccum and to deal with C machine constants. C C********************************************************************** C C C Original Comments: C------------------------------------------------------------------ C C This function evaluates the normal distribution function: C C / x C 1 | -t*t/2 C P(x) = ----------- | e dt C sqrt(2 pi) | C /-oo C C The main computation evaluates near-minimax approximations C derived from those in "Rational Chebyshev approximations for C the error function" by W. J. Cody, Math. Comp., 1969, 631-637. C This transportable program uses rational functions that C theoretically approximate the normal distribution function to C at least 18 significant decimal digits. The accuracy achieved C depends on the arithmetic system, the compiler, the intrinsic C functions, and proper selection of the machine-dependent C constants. C C******************************************************************* C******************************************************************* C C Explanation of machine-dependent constants. C C MIN = smallest machine representable number. C C EPS = argument below which anorm(x) may be represented by C 0.5 and above which x*x will not underflow. C A conservative value is the largest machine number X C such that 1.0 + X = 1.0 to machine precision. C******************************************************************* C******************************************************************* C C Error returns C C The program returns ANORM = 0 for ARG .LE. XLOW. C C C Intrinsic functions required are: C C ABS, AINT, EXP C C C Author: W. J. Cody C Mathematics and Computer Science Division C Argonne National Laboratory C Argonne, IL 60439 C C Latest modification: March 15, 1992 C C------------------------------------------------------------------ INTEGER i DOUBLE PRECISION a,Arg,b,c,d,del,eps,half,p,one,q,Result,sixten, & temp,sqrpi,thrsh,root32,x,xden,xnum,y,xsq,zero, & minx,Ccum DIMENSION a(5),b(4),c(9),d(8),p(6),q(5) C------------------------------------------------------------------ C External Function C------------------------------------------------------------------ DOUBLE PRECISION spmpar EXTERNAL spmpar C------------------------------------------------------------------ C Mathematical constants C C SQRPI = 1 / sqrt(2*pi), ROOT32 = sqrt(32), and C THRSH is the argument for which anorm = 0.75. C------------------------------------------------------------------ DATA one,half,zero,sixten/1.0D0,0.5D0,0.0D0,1.60D0/, & sqrpi/3.9894228040143267794D-1/,thrsh/0.66291D0/, & root32/5.656854248D0/ C------------------------------------------------------------------ C Coefficients for approximation in first interval C------------------------------------------------------------------ DATA a/2.2352520354606839287D00,1.6102823106855587881D02, & 1.0676894854603709582D03,1.8154981253343561249D04, & 6.5682337918207449113D-2/ DATA b/4.7202581904688241870D01,9.7609855173777669322D02, & 1.0260932208618978205D04,4.5507789335026729956D04/ C------------------------------------------------------------------ C Coefficients for approximation in second interval C------------------------------------------------------------------ DATA c/3.9894151208813466764D-1,8.8831497943883759412D00, & 9.3506656132177855979D01,5.9727027639480026226D02, & 2.4945375852903726711D03,6.8481904505362823326D03, & 1.1602651437647350124D04,9.8427148383839780218D03, & 1.0765576773720192317D-8/ DATA d/2.2266688044328115691D01,2.3538790178262499861D02, & 1.5193775994075548050D03,6.4855582982667607550D03, & 1.8615571640885098091D04,3.4900952721145977266D04, & 3.8912003286093271411D04,1.9685429676859990727D04/ C------------------------------------------------------------------ C Coefficients for approximation in third interval C------------------------------------------------------------------ DATA p/2.1589853405795699D-1,1.274011611602473639D-1, & 2.2235277870649807D-2,1.421619193227893466D-3, & 2.9112874951168792D-5,2.307344176494017303D-2/ DATA q/1.28426009614491121D00,4.68238212480865118D-1, & 6.59881378689285515D-2,3.78239633202758244D-3, & 7.29751555083966205D-5/ C------------------------------------------------------------------ C Machine dependent constants C------------------------------------------------------------------ eps=spmpar(1)*0.5D0 minx=spmpar(2) C------------------------------------------------------------------ x=Arg y=abs(x) IF(y.le.thrsh)THEN C------------------------------------------------------------------ C Evaluate anorm for |X| <= 0.66291 C------------------------------------------------------------------ xsq=zero IF(y.gt.eps)xsq=x*x xnum=a(5)*xsq xden=xsq DO i=1,3 xnum=(xnum+a(i))*xsq xden=(xden+b(i))*xsq END DO Result=x*(xnum+a(4))/(xden+b(4)) temp=Result Result=half+temp Ccum=half-temp C------------------------------------------------------------------ C Evaluate anorm for 0.66291 <= |X| <= sqrt(32) C------------------------------------------------------------------ ELSE IF(y.le.root32)THEN xnum=c(9)*y xden=y DO i=1,7 xnum=(xnum+c(i))*y xden=(xden+d(i))*y END DO Result=(xnum+c(8))/(xden+d(8)) xsq=aint(y*sixten)/sixten del=(y-xsq)*(y+xsq) Result=exp(-xsq*xsq*half)*exp(-del*half)*Result Ccum=one-Result IF(x.gt.zero)THEN temp=Result Result=Ccum Ccum=temp END IF C------------------------------------------------------------------ C Evaluate anorm for |X| > sqrt(32) C------------------------------------------------------------------ ELSE Result=zero xsq=one/(x*x) xnum=p(6)*xsq xden=xsq DO i=1,4 xnum=(xnum+p(i))*xsq xden=(xden+q(i))*xsq END DO Result=xsq*(xnum+p(5))/(xden+q(5)) Result=(sqrpi-Result)/y xsq=aint(x*sixten)/sixten del=(x-xsq)*(x+xsq) Result=exp(-xsq*xsq*half)*exp(-del*half)*Result Ccum=one-Result IF(x.gt.zero)THEN temp=Result Result=Ccum Ccum=temp END IF END IF IF(Result.lt.minx)Result=0.0D0 IF(Ccum.lt.minx)Ccum=0.0D0 C------------------------------------------------------------------ C Fix up for negative argument, erf, etc. C------------------------------------------------------------------ C----------Last card of ANORM ---------- END cvcmma.f0000664006604000003110000000452614521201425011611 0ustar sun00315steps SUBROUTINE cvcmma(Chrstr,Ncomma) IMPLICIT NONE c----------------------------------------------------------------------- c Replace commas with periods in text string, return number of c commas found. c Created by : BCMonsell, April 2003 c----------------------------------------------------------------------- CHARACTER Chrstr*(*) INTEGER clen,i,i1,Ncomma c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- c Initialize variables for number of commas and length of string - c return if length of string = 0 c----------------------------------------------------------------------- i1=1 Ncomma=0 clen=nblank(Chrstr) IF(clen.eq.0)RETURN c----------------------------------------------------------------------- c search for a comma in Chrstr c----------------------------------------------------------------------- i=index(Chrstr(1:clen),',') c----------------------------------------------------------------------- c each time a comma is found, generate the position of that comma c in the string and replace it with a '.' c----------------------------------------------------------------------- DO WHILE (i.gt.0) i1=i+i1-1 Chrstr(i1:i1) = '.' c----------------------------------------------------------------------- c update number of commas (data observations) found c----------------------------------------------------------------------- Ncomma=Ncomma+1 c----------------------------------------------------------------------- c if position of last comma found is the end of the character c string, set i to 0 c----------------------------------------------------------------------- if (i1.eq.clen) then i=0 c----------------------------------------------------------------------- c else, search for a comma in rest of Chrstr, and store the c position relative to the last comma found. c----------------------------------------------------------------------- else i1 = i1+1 i=index(Chrstr(i1:clen),',') end if end do c----------------------------------------------------------------------- RETURN END cvdttm.f0000664006604000003110000000174514521201425011644 0ustar sun00315steps CHARACTER*24 FUNCTION cvdttm(datstr) IMPLICIT NONE c----------------------------------------------------------------------- c Function to convert Lahey fortran (PC) date and time convention c to a common format for date and time information c----------------------------------------------------------------------- CHARACTER datstr*24,cmonth*3,cm*3 INTEGER d,y,h,minute,s INTEGER mon DIMENSION cmonth(12) DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ c write(*,*)'*',datstr,'*' if(datstr(3:3).eq.'/')THEN READ(datstr,1010)mon,d,y,h,minute,s 1010 FORMAT(6(i2,1x)) WRITE(cvdttm,1020)cmonth(mon),d,y+2000,h,minute,s ELSE READ(datstr,1011)cm,d,h,minute,s,y 1011 FORMAT(4x,a3,4(1x,i2),1x,i4) WRITE(cvdttm,1020)cm,d,y,h,minute,s END IF 1020 FORMAT(1x,a3,1x,i2,', ',i4,2x,2(i2.2,'.'),i2.2,1x) RETURN END c Jan 30, 2003 11.56.55 cvrerr.f0000664006604000003110000000515514521201425011645 0ustar sun00315stepsC Last change: BCM 26 Jan 98 12:55 pm SUBROUTINE cvrerr(Srsttl,Begsrs,Nobs,Spnttl,Begspn,Nspobs,Sp) IMPLICIT NONE c----------------------------------------------------------------------- c cvrerr.f, Release 1, Subroutine Version 1.6, Modified 30 Nov 1994. c----------------------------------------------------------------------- c Check whether the span (begspn,nspobs) is covered by the c series (begsrs,nobs) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER chrdt1*(10),chrdt2*(10),Srsttl*(*),Spnttl*(*) INTEGER Begspn,Begsrs,idate,idif,nchr1,nchr2,Nobs,Nspobs,Sp DIMENSION Begspn(2),Begsrs(2),idate(2) c ------------------------------------------------------------------ CALL dfdate(Begspn,Begsrs,Sp,idif) IF(idif.lt.0)THEN CALL wrtdat(Begspn,Sp,chrdt1,nchr1) IF(.not.Lfatal)CALL wrtdat(Begsrs,Sp,chrdt2,nchr2) IF(Lfatal)RETURN WRITE(STDERR,1010)Spnttl,chrdt1(1:nchr1),Srsttl,chrdt2(1:nchr2) WRITE(Mt2,1010)Spnttl,chrdt1(1:nchr1),Srsttl,chrdt2(1:nchr2) 1010 FORMAT(' ERROR: ',a,' start date, ',a, & ', must begin on or after ',/,' ',a, & ' start date, ',a,'.',/) END IF c ------------------------------------------------------------------ IF(Nobs-idif.lt.Nspobs)THEN CALL addate(Begspn,Sp,Nspobs-1,idate) CALL wrtdat(idate,Sp,chrdt1,nchr1) IF(Lfatal)RETURN CALL addate(Begsrs,Sp,Nobs-1,idate) CALL wrtdat(idate,Sp,chrdt2,nchr2) IF(Lfatal)RETURN WRITE(STDERR,1020)Spnttl,chrdt1(1:nchr1),Srsttl,chrdt2(1:nchr2) WRITE(Mt2,1020)Spnttl,chrdt1(1:nchr1),Srsttl,chrdt2(1:nchr2) 1020 FORMAT(' ERROR: ',a,' end date, ',a,', must end on or before ',/, & ' ',a,' end date, ',a,'.',/) END IF c ------------------------------------------------------------------ IF(Nspobs.le.0)THEN CALL addate(Begsrs,Sp,Nobs-1,idate) CALL wrtdat(idate,Sp,chrdt1,nchr1) IF(.not.Lfatal)CALL wrtdat(Begsrs,Sp,chrdt2,nchr2) IF(Lfatal)RETURN WRITE(STDERR,1030)Spnttl,chrdt1(1:nchr1),chrdt2(1:nchr2) WRITE(Mt2,1030)Spnttl,chrdt1(1:nchr1),chrdt2(1:nchr2) 1030 FORMAT(' ERROR: ',a,' end date, ',a,', must end after ',/, & ' its own start date, ',a,'.',/) END IF c ------------------------------------------------------------------ RETURN END cxfinal.i0000664006604000003110000000041614521201425011764 0ustar sun00315stepsC C... Variables in Common Block /crossfinal/ ... real*8 CRSSA,CRTSA,CRTS,CRIRSA,CRIRS,CRIRT,CRCYCSA,CRCYCS,CRCYCT, $ CRCYCIR common /crossfinal/ CRSSA,CRTSA,CRTS,CRIRSA,CRIRS,CRIRT,CRCYCSA, $ CRCYCS,CRCYCT,CRCYCIR date.i0000664006604000003110000000025414521201425011255 0ustar sun00315stepsC C... Variables in Common Block /date/ ... integer Dperiod,Dyear,Dfreq,Dlen,Olen character*7 ODate common /date/ Dperiod,Dyear,Dfreq,Dlen,Olen,Odate daxpy.f0000664006604000003110000000317414521201425011466 0ustar sun00315steps**==daxpy.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE daxpy(N,Da,Dx,Incx,Dy,Incy) IMPLICIT NONE C C OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. C FOR I = 0 TO N-1, REPLACE DY(LY+I*INCY) WITH DA*DX(LX+I*INCX) + C DY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. C INTEGER i,Incx,Incy,ix,iy,m,mp1,N,ns DOUBLE PRECISION Dx(*),Dy(*),Da LOGICAL dpeq EXTERNAL dpeq IF(N.le.0.or.dpeq(Da,0.D0))RETURN IF(Incx.eq.Incy)THEN IF(Incx.lt.1)THEN ELSE IF(Incx.eq.1)THEN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. C m=mod(N,4) IF(m.ne.0)THEN DO i=1,m Dy(i)=Dy(i)+Da*Dx(i) END DO IF(N.lt.4)RETURN END IF mp1=m+1 DO i=mp1,N,4 Dy(i)=Dy(i)+Da*Dx(i) Dy(i+1)=Dy(i+1)+Da*Dx(i+1) Dy(i+2)=Dy(i+2)+Da*Dx(i+2) Dy(i+3)=Dy(i+3)+Da*Dx(i+3) END DO RETURN ELSE GO TO 10 END IF END IF C C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. C ix=1 iy=1 IF(Incx.lt.0)ix=(-N+1)*Incx+1 IF(Incy.lt.0)iy=(-N+1)*Incy+1 DO i=1,N Dy(iy)=Dy(iy)+Da*Dx(ix) ix=ix+Incx iy=iy+Incy END DO RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 10 ns=N*Incx DO i=1,ns,Incx Dy(i)=Da*Dx(i)+Dy(i) END DO RETURN END dcopy.f0000664006604000003110000000266214521201425011460 0ustar sun00315steps**==dcopy.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE dcopy(N,Dx,Incx,Dy,Incy) IMPLICIT NONE c ------------------------------------------------------------------ DOUBLE PRECISION Dx(*),Dy(*) INTEGER i,Incx,Incy,ix,iy,m,mp1,N c ------------------------------------------------------------------ IF(N.gt.0)THEN IF(Incx.ne.1.or.Incy.ne.1)THEN ix=1 iy=1 IF(Incx.lt.0)ix=(1-N)*Incx+1 IF(Incy.lt.0)iy=(1-N)*Incy+1 c ------------------------------------------------------------------ DO i=1,N Dy(iy)=Dx(ix) ix=ix+Incx iy=iy+Incy END DO c ------------------------------------------------------------------ ELSE m=mod(N,7) c ------------------------------------------------------------------ IF(m.ne.0)THEN DO i=1,m Dy(i)=Dx(i) END DO END IF c ------------------------------------------------------------------ IF(N.ge.7)THEN mp1=m+1 DO i=mp1,N,7 Dy(i)=Dx(i) Dy(i+1)=Dx(i+1) Dy(i+2)=Dx(i+2) Dy(i+3)=Dx(i+3) Dy(i+4)=Dx(i+4) Dy(i+5)=Dx(i+5) Dy(i+6)=Dx(i+6) END DO END IF END IF END IF c ------------------------------------------------------------------ RETURN END ddot.f0000664006604000003110000000554414521201426011277 0ustar sun00315stepsC Last change: DH 22 May 2019 **==ddot.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 DOUBLE PRECISION FUNCTION ddot(N,Dx,Incx,Dy,Incy) IMPLICIT NONE C C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. C DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C c LOGICAL UNDERFLOW EXTERNAL UNDERFLOW INTEGER i,Incx,Incy,ix,iy,m,mp1,N,ns DOUBLE PRECISION Dx(*),Dy(*) ddot=0.D0 IF(N.le.0)RETURN IF(Incx.eq.Incy)THEN IF(Incx.eq.1)THEN C C CODE FOR BOTH INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C m=mod(N,5) IF(m.ne.0)THEN DO i=1,m if (.not.UNDERFLOW(Dx(i),Dy(i))) ddot=ddot+Dx(i)*Dy(i) END DO IF(N.lt.5)RETURN END IF mp1=m+1 DO i=mp1,N,5 if (.not.UNDERFLOW(Dx(i),Dy(i))) ddot=ddot+Dx(i)*Dy(i) if (.not.UNDERFLOW(Dx(i+1),Dy(i+1))) ddot=ddot+Dx(i+1)*Dy(i+1) if (.not.UNDERFLOW(Dx(i+2),Dy(i+2))) ddot=ddot+Dx(i+2)*Dy(i+2) if (.not.UNDERFLOW(Dx(i+3),Dy(i+3))) ddot=ddot+Dx(i+3)*Dy(i+3) if (.not.UNDERFLOW(Dx(i+4),Dy(i+4))) ddot=ddot+Dx(i+4)*Dy(i+4) END DO RETURN ELSE IF (Incx.gt.1) THEN C C CODE FOR POSITIVE EQUAL INCREMENTS .GT.1. C ns=N*Incx DO i=1,ns,Incx if (.not.UNDERFLOW(Dx(i),Dy(i))) ddot=ddot+Dx(i)*Dy(i) END DO RETURN END IF ELSE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS C ix=1 iy=1 IF(Incx.lt.0)ix=(-N+1)*Incx+1 IF(Incy.lt.0)iy=(-N+1)*Incy+1 DO i=1,N if (.not.UNDERFLOW(Dx(ix),Dy(iy))) ddot=ddot+Dx(ix)*Dy(iy) ix=ix+Incx iy=iy+Incy END DO RETURN END IF END c----------------------------------------------------------------------- LOGICAL FUNCTION UNDERFLOW(x,y) IMPLICIT NONE c----------------------------------------------------------------------- c Return TRUE if the multiplication x*y is an UNDERFLOW c or either x,y is ZERO c dpmpar(2) is the machine defined lower limit c----------------------------------------------------------------------- DOUBLE PRECISION x,y,dpmpar,dmin,xp,ZERO PARAMETER(ZERO=0D0) EXTERNAL dpmpar c----------------------------------------------------------------------- UNDERFLOW=.TRUE. IF (x.eq.ZERO.or.y.eq.ZERO) RETURN dmin=DLOG10(dpmpar(2)) xp = DLOG10(DABS(x)) + DLOG10(DABS(y)) IF (xp.le.dmin) RETURN c----------------------------------------------------------------------- UNDERFLOW=.FALSE. RETURN END decibl.f0000664006604000003110000000072614521201426011564 0ustar sun00315stepsC Last change: BCM 5 Mar 2008 2:38 pm DOUBLE PRECISION FUNCTION decibl(X) IMPLICIT NONE c----------------------------------------------------------------------- c Convert X into decibels, use with spectral routines c----------------------------------------------------------------------- DOUBLE PRECISION X c----------------------------------------------------------------------- decibl=10D0*log10(X) RETURN ENDdeftab.prm0000664006604000003110000000057414521201426012141 0ustar sun00315stepsc----------------------------------------------------------------------- c deftab - logical variable which defines those tables to be printed c in a default X-13 run c DATA statement that defines deftab is in deftab.var c----------------------------------------------------------------------- LOGICAL deftab DIMENSION deftab(NTBL) deftab.var0000664006604000003110000000236614521201431012130 0ustar sun00315stepsc----------------------------------------------------------------------- c DATA statement that defines deftab, which defines those tables c to be printed in a default X-13ARIMA-SEATS run c----------------------------------------------------------------------- DATA deftab/ & T,T,F,T,T,T,F,F,T,F, T,F,T,F,F,F,F,F,F,F, T,F,T,T,T,T,T,T,T,T, & T,T,T,T,F,T,T,T,T,F, T,T,T,F,F,F,F,F,F,F, F,F,T,T,T,T,T,T,F,F, & T,F,T,F,T,F,F,F,F,F, T,T,F,F,T,F,T,T,F,F, T,T,T,T,T,T,T,T,F,T, & F,F,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,T,f,F,F,F,T, F,F,F,F,T,F,F,T,T,T, & F,F,F,T,F,F,T,T,T,T, T,F,F,T,T,F,T,F,F,F, F,F,T,T,F,F,T,F,F,T, & T,T,T,T,T,T,T,F,F,F, F,F,T,F,T,F,F,T,F,F, F,F,F,F,F,F,F,F,T,T, & T,F,T,F,T,T,T,T,F,T, F,T,F,T,F,T,F,T,F,T, F,T,T,F,F,F,F,F,T,T, & T,F,T,T,F,T,T,F,T,T, F,T,T,F,T,T,F,T,T,F, T,T,F,T,F,T,T,T,F,T, & T,T,T,F,F,T,T,F,F,F, F,F,F,F,F,F,F,F,T,F, T,F,F,F,T,T,T,T,T,T, & T,T,T,T,T,F,F,F,T,F, T,F,T,F,T,F,T,F,T,F, F,F,F,F,F,F,F,F,T,T, & T,T,F,F,F,F,F,F,F,F, T,T,T,T,T,T,T,T,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F/ delstr.f0000664006604000003110000000332314521201432011630 0ustar sun00315steps**==delstr.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE delstr(Istr,Chrvec,Ptrvec,Nstr,Nlim) IMPLICIT NONE c---------------------------------------------------------------------- c Deletes the istr string if possible c---------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ----------------------------------------------------------------- LOGICAL T PARAMETER(T=.true.) c ----------------------------------------------------------------- CHARACTER Chrvec*(*) INTEGER i,Istr,nchr,newbeg,nrest,Nstr,oldbeg,Ptrvec,Nlim DIMENSION Ptrvec(0:Nlim) c ----------------------------------------------------------------- IF(Istr.gt.Nstr.or.Istr.lt.1)THEN CALL writln('Index out of range vector',STDERR,Mt2,T) * CALL writln('Index out of range vector (delstr)',STDERR,Mt2,T) CALL abend RETURN END IF c ----------------------------------------------------------------- oldbeg=Ptrvec(Istr) newbeg=Ptrvec(Istr-1) nrest=Ptrvec(Nstr)-oldbeg-1 IF(nrest.ge.0)Chrvec(newbeg:newbeg+nrest) & =Chrvec(oldbeg:oldbeg+nrest) c ----------------------------------------------------------------- CALL eltlen(Istr,Ptrvec,Nstr,nchr) IF(Lfatal)RETURN c ----------------------------------------------------------------- DO i=Istr,Nstr-1 Ptrvec(i)=Ptrvec(i+1)-nchr END DO Nstr=Nstr-1 c ----------------------------------------------------------------- RETURN c ----------------------------------------------------------------- END deltst.f0000664006604000003110000001325614521201432011640 0ustar sun00315stepsC Last change: BCM 2 Apr 98 12:56 pm SUBROUTINE deltst(Nefobs,Begcol,Endcol,Mint,Mini,Minptr,Lauto, & Lxreg) IMPLICIT NONE c----------------------------------------------------------------------- c Finds the minimum absolute t statistic in the subset, subqrp, of c regression parameters. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c begcol i Local index to the first regression estimate to test c ielt i Local index for an element of the xpx matrix c endcol i Local index to the last (end) regression estimate to test c mini i Output index to the outlier with the smallest t-value c mint d Output smallest t-value of the identified outliers c nefobs i Input number of effective observations or number of c observations to compute the likelihood c nelt i Local number of elements in the packed form of c chol([X:y]'[X:y]) c rmse d Output root mean square error c tmp d Local temporary scalar c tval d Local t statistic*rmse for the current beta c xpxinv d Local pb(pb+1)/2, (ncxy-1)ncxy/2 used vector to hold the c packed form of the inverse of X'X c----------------------------------------------------------------------- c Variable typing and initialization c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0.0D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER tmpttl*(PCOLCR) LOGICAL locok,Lauto,Lxreg INTEGER i,i2,j,Begcol,ielt,Endcol,Mini,Nefobs,nelt,otltyp,ntmpcr, & t0,itmp,Minptr DOUBLE PRECISION Mint,rmse,tmp,tval,xpxinv DIMENSION tmp(2),xpxinv(PB*(PB+1)/2),Mini(POTLR),Mint(POTLR), & Minptr(POTLR) C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c Find the root mean square error, the first diagonal element c of chol(X'X), and initialize the minimum values c----------------------------------------------------------------------- nelt=Nb*Ncxy/2 rmse=Chlxpx(nelt+Ncxy) IF(dpeq(rmse,ZERO))THEN IF(.not.Lhiddn)THEN WRITE(STDERR,1010) WRITE(Mt1,1010) END IF CALL errhdr WRITE(Mt2,1010) 1010 FORMAT(/,' ERROR: Cannot compute outlier t-statistic for', & ' outlier backward deletion - ', & /,' the residual root mean square error is zero.') IF(.not.Lauto)THEN IF(Lxreg)THEN IF(.not.Lhiddn)THEN WRITE(STDERR,2020) WRITE(Mt1,2020) END IF WRITE(Mt2,2020) 2020 FORMAT(/,' Check the x11regression options specified', & ' in the input specification',/,' file.',/) ELSE IF(.not.Lhiddn)THEN WRITE(STDERR,1020) WRITE(Mt1,1020) END IF WRITE(Mt2,1020) 1020 FORMAT(/,' Check the regARIMA model specified in the', & ' input specification',/,' file.',/) END IF END IF CALL abend RETURN END IF rmse=rmse/sqrt(dble(Nefobs)) CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,Nb,tmp,1) CALL setint(NOTSET,POTLR,Mini) c----------------------------------------------------------------------- c Calculate b(i)/sqrt(X'X) for each regression effect in the subset c----------------------------------------------------------------------- DO i=Begcol,Endcol CALL getstr(Colttl,Colptr,Ncoltl,i,tmpttl,ntmpcr) IF(.not.Lfatal)CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0, & itmp,locok) IF((.not.locok).and.(.not.Lfatal))CALL abend() IF(Lfatal)RETURN IF(i.eq.Begcol)THEN ielt=Begcol*(Begcol+1)/2 ELSE ielt=ielt+i END IF tval=B(i)/sqrt(xpxinv(ielt))/rmse c----------------------------------------------------------------------- c Check to see if this outlier is the minimum for its type (AO or c LS) c----------------------------------------------------------------------- IF(Mini(otltyp).eq.NOTSET)THEN Mini(otltyp)=i Mint(otltyp)=tval ELSE IF(abs(tval).le.abs(Mint(otltyp)))THEN Mini(otltyp)=i Mint(otltyp)=tval END IF END DO c----------------------------------------------------------------------- c Create pointer that has rank of smallest t-stats of each type c----------------------------------------------------------------------- CALL setint(NOTSET,POTLR,Minptr) i2=1 DO i=1,POTLR IF(Mini(i).ne.NOTSET)THEN Minptr(i2)=i IF(i2.gt.1)THEN j=i2-1 DO WHILE(j.gt.0) IF(abs(Mint(Minptr(j))).gt.abs(Mint(Minptr(j+1))))THEN Minptr(j+1)=Minptr(j) Minptr(j)=i END IF j=j-1 END DO END IF i2=i2+1 END IF END DO c----------------------------------------------------------------------- RETURN END desadj.prm0000664006604000003110000000430614521201432012140 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c special X-11 and pre-adjustments. See desadj.var for pointers. c----------------------------------------------------------------------- CHARACTER DSADIC*1576 INTEGER dsaptr DIMENSION dsaptr(0:PDSA) c----------------------------------------------------------------------- PARAMETER(DSADIC='X-11 Easter adjustment factorscombined holiday c &omponentcombined adjustment factorscombined adjustment factors (sa &ved as percentages if multiplicative adj)final adjustment differen &cescombined calendar adjustment factorsfinal adjustment ratiostota &l adjustment factorsoriginal series adjusted by preliminary irregu &lar regression factorsoriginal series adjusted by final irregular ®ression factorssummary measuresmonitoring and quality assessmen &t statistics^ of annual totalsF-tests for seasonalityMoving season &ality ratiofinal seasonal filter selection via GLOBAL MSRoriginal &series,@-seasonally adjusted series,coincidence of points^ of the &original series modified for extremes^ of the S. A. series modifie &d for extremesfinal seasonal factors with one year forecastsfinal &seasonally adjusted seriesfinal trend cyclefinal irregular compone &ntforecasts of final seasonally adjusted seriesforecasts of final &trend cycleforecasts of final irregular weightsfinal seasonally ad &justed series with forced yearly totalsrounded final seasonally ad &justed series% in seasonally adjusted series with forced yearly to &tals (D11.A)% in seasonally adjusted series with forced yearly tot &als (D11.A - saved as percentages if appropriate)% in rounded seas &onally adjusted series (D11.R)% in rounded seasonally adjusted ser &ies (D11.R - saved as percentages if appropriate)factors applied t &o adjusted series to get adjusted series with forced yearly totals &ratios or differences in annual totals and indirect seasonally adj &usted seriesfactors applied to get adjusted series with forced yea &rly totals') desadj.var0000664006604000003110000000104514521201435012132 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c special X-11 and pre-adjustments. See desadj.prm for data dictionaries. c----------------------------------------------------------------------- DATA dsaptr / & 1, 31, 57, 84, 156, 184, 220, 243, 267, 335, & 397, 397, 413, 457, 475, 498, 522, 522, 568, 568, & 634, 680, 723, 769, 801, 818, 843, 888, 918, 954, & 1012,1052,1117,1220,1267,1352,1435,1513,1577 / descm2.prm0000664006604000003110000000335514521201435012071 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c composite seasonal adjustment. See descm2.var for pointers. c----------------------------------------------------------------------- CHARACTER DC2DIC*1162 INTEGER dc2ptr DIMENSION dc2ptr(0:PDC2) c----------------------------------------------------------------------- PARAMETER(DC2DIC='MCD moving average for indirect adjustmentsummar &y measures (indirect)monitoring and quality assessment statistics &(indirect)ratios of annual totals for indirect adjustmentF-tests f &or seasonalitymoving seasonality ratiofinal indirect seasonally ad &justed series with forced yearly totalsrounded indirect final seas &onally adjusted seriescomposite seriesoriginal series,@-indirect s &easonally adjusted series,coincidence of points^ of the composite &series modified for extremes^ of the S. A. series modified for ext &remesfinal indirect seasonal factors with one year forecastsfinal &indirect seasonally adjusted seriesfinal trend cycle from the indi &rect seasonal adjustmentfinal indirect irregular componentindirect & level change adjustment factorsindirect additive outlier adjustme &nt factorsindirect calendar componentindirect combined adjustment &factorsindirect combined adjustment factors (saved as percentages &if multiplicative adj)factors applied to adjusted series to get ad &justed series with forced yearly totalsratios or differences in an &nual totals and indirect seasonally adjusted seriesfactors applied & to get indirect adjusted series with forced yearly totals') descm2.var0000664006604000003110000000073014521201437012057 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c composite seasonal adjustment. See descm2.prm for data dictionaries. c----------------------------------------------------------------------- DATA dc2ptr / & 1, 43, 70, 125, 172, 195, 219, 219, 286, 335, & 351, 426, 473, 516, 571, 612, 667, 701, 741, 785, & 812, 848, 929,1012,1090,1163 / descmp.prm0000664006604000003110000000463614521201437012174 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c composite seasonal adjustment. See descmp.var for pointers. c----------------------------------------------------------------------- CHARACTER DSCDIC*1771 INTEGER dscptr DIMENSION dscptr(0:PDSC) c----------------------------------------------------------------------- PARAMETER(DSCDIC='composite time series data (for the span analyze &d)prior adjusted composite datacomposite series (prior adjusted)co &mposite series (prior adjusted)regARIMA calendar adjusted composit &e dataregARIMA outlier adjusted composite dataindirect seasonal ad &justment of composite seriescomposite smoothness diagnosticsindire &ct unmodified SI componentfinal replacement values for SI componen &t of indirect adjustmentindirect seasonal componentindirect season &al component (saved as percentages if multiplicative adj)indirect &final seasonal differenceindirect seasonally adjusted dataindirect & trend cycleindirect irregular componentindirect irregular compone &nt (saved as percentages if multiplicative adj)original data modif &ied for extremes from indirect adjustmentseasonally adjusted data &modified for extremes from indirect adjustmentirregular component &modified for extremes from indirect adjustment%s for composite ser &ies%s for composite series (saved as percentages if appropriate)%s & for indirect seasonally adjusted series%s for indirect seasonally & adjusted series (saved as percentages if appropriate)%s for indir &ect seasonally adjusted series with forced yearly totals%s for ind &irect seasonally adjusted series with forced yearly totals (saved &as percentages if appropriate)%s for rounded indirect seasonally a &djusted series%s for rounded indirect seasonally adjusted series ( &saved as percentages if appropriate)%s for indirect trend componen &t%s for indirect trend component (saved as percentages if appropri &ate)% in original series adjusted for calendar effects% in origina &l series adjusted for calendar effects (saved as percentages if ap &propriate)robust estimate of the indirect final seasonally adjuste &d seriesindirect final adjustment ratiosindirect total adjustment &factors') descmp.var0000664006604000003110000000102314521201440012143 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c composite seasonal adjustment. See descmp.prm for data dictionaries. c----------------------------------------------------------------------- DATA dscptr / & 1, 51, 80, 113, 146, 187, 227, 275, 307, 339, & 403, 430, 502, 536, 569, 589, 617, 690, 750, 821, & 887, 910, 971,1013,1093,1161,1267,1317,1405,1436, & 1505,1555,1643,1707,1739,1772 / desdg2.prm0000664006604000003110000000203114521201441012047 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c sliding spans analysis. See desdg2.var for pointers. c----------------------------------------------------------------------- CHARACTER DD2DIC*518 INTEGER dd2ptr DIMENSION dd2ptr(0:PDD2) c----------------------------------------------------------------------- PARAMETER(DD2DIC='sliding spans of the seasonal factorssliding spa &ns of the indirect seasonal factorssliding spans of the changes in & the seasonally adjusted seriessliding spans of the changes in the & indirect seasonally adjusted seriessliding spans of the seasonall &y adjusted seriessliding spans of the indirect seasonally adjusted & seriessliding spans of the year-to-year changes in the seasonally & adjusted seriessliding spans of the year-to-year changes in the i &ndirect seasonally adjusted seriessliding spans of the trading day & factors') desdg2.var0000664006604000003110000000067514521201442012056 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c sliding spans analysis. See desdg2.prm for data dictionaries. c----------------------------------------------------------------------- DATA dd2ptr / & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & 1, 1, 1, 38, 84, 146, 217, 264, 320, 395, & 479, 519 / desdgn.prm0000664006604000003110000000427114521201442012154 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c revisions histories. See desdgn.var for pointers. c----------------------------------------------------------------------- CHARACTER DSDDIC*1576 INTEGER dsdptr DIMENSION dsdptr(0:PDSD) c----------------------------------------------------------------------- PARAMETER(DSDDIC='revisions history analysisrevision history of th &e outliers identifiedrevision history of the Moving Seasonality Ra &tiopercent revisions of the concurrent seasonal adjustmentssummary & statistics : average absolute percent revisions of the seasonal a &djustmentsconcurrent and revised seasonal adjustments and revision &spercent revisions of the % of the adjustmentssummary statistics : & average absolute revisions of the % of the adjustmentshistory of &the % of the adjustmentspercent revisions of the concurrent indire &ct seasonal adjustmentssummary statistics : average absolute perce &nt revisions of the concurrent indirect seasonal adjustmentsconcur &rent and revised indirect seasonal adjustments and revisionspercen &t revision of the concurrent Henderson trend-cycle valuessummary s &tatistics : average absolute percent revision of the concurrent He &nderson trend-cycleconcurrent and revised Henderson trend-cycle va &lues and revisionspercent revisions of the % of the trend-cycle va &luessummary statistics : average absolute percent revisions of the & % of the trend-cyclehistory of the % of the trend-cycle valuesrev &isions of the concurrent and projected seasonal componentsummary s &tatistics : average absolute percent revisions of the concurrent a &nd projected seasonal componentconcurrent and projected seasonal c &omponent and their percent revisionsrevision history of the likeli &hood statisticsrevision history of the out-of-sample forecastsfore &cast and forecast error historySEATS ARIMA model historyseasonal f &orecast historyARMA model coefficient historytrading day coefficie &nt history') desdgn.var0000664006604000003110000000073514521201444012151 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c revisions histories. See desdgn.prm for data dictionaries. c----------------------------------------------------------------------- DATA dsdptr / & 1, 27, 70, 118, 174, 257, 314, 359, 434, 469, & 534, 637, 703, 766, 860, 925, 977,1060,1102,1162, & 1268,1339,1384,1431,1466,1491,1516,1546,1577 / desfc2.prm0000664006604000003110000000321414521201444012054 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c forecasts for SEATS adjustments. See desfc2.var for pointers. c----------------------------------------------------------------------- CHARACTER DF2DIC*1040 INTEGER df2ptr,PDF2 PARAMETER(PDF2=48) DIMENSION df2ptr(0:PDF2) c----------------------------------------------------------------------- PARAMETER(DF2DIC='Final trend component forecast (SEATS)Final tren &d component forecast with constant added (SEATS)Final seasonal com &ponent forecast (SEATS)Final seasonal component forecast (SEATS)Fi &nal irregular component forecast (SEATS)Final irregular component &forecast (SEATS)Final seasonally adjusted series forecast (SEATS)F &inal seasonally adjusted series forecast with constant added (SEAT &S)Final transitory component forecast (SEATS)Final transitory comp &onent forecast (SEATS)Final combined adjustment factor forecast (S &EATS)Final combined adjustment factor forecast (SEATS)final adjust &ment ratio forecasts (SEATS)total adjustment factor forecasts (SEA &TS)Final differenced forecast after transformation, prior adjustme &nt (SEATS)Final differenced seasonally adjusted series forecast (S &EATS)Final differenced trend forecast (SEATS)Final seasonal compon &ent forecast (SEATS)final cycle forecastfinal long term trend fore &castFinal seasonally adjusted series forecast adjusted for outlier &s (SEATS)Final irregular component forecast outlier adjusted (SEAT &S)') desfc2.var0000664006604000003110000000113714521201446012052 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c forecasts for SEATS adjustments. See desfc2.prm for data dictionaries. c----------------------------------------------------------------------- DATA df2ptr / & 1, 39, 97, 138, 179, 221, 263, 312, 381, 424, & 467, 516, 565, 565, 565, 565, 565, 565, 605, 646, & 646, 646, 646, 646, 646, 646, 646, 646, 646, 646, & 646, 646, 646, 646, 646, 646, 719, 780, 820, 861, & 881, 911, 911, 911, 911, 911, 982,1041,1041 / desfct.prm0000664006604000003110000000477714521201446012177 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c series forecasts and other additional tables. See desfct.var for pointers. c----------------------------------------------------------------------- CHARACTER DSFDIC*1821 INTEGER dsfptr,PDSF PARAMETER(PDSF=348) DIMENSION dsfptr(0:PDSF) c----------------------------------------------------------------------- PARAMETER(DSFDIC='forecasts of (prior adjusted) original seriesreg &ARIMA outlier componentregARIMA temporary change outlier component ®ARIMA temporary change outlier componentregARIMA trading day co &mponent forecastsregARIMA holiday component forecastsregARIMA user &-defined regression component forecastsregARIMA seasonal component & forecastsregARIMA transitory component forecastsfinal seasonal co &mponent forecastsfinal seasonal component forecastsfinal seasonal &difference forecastsfinal seasonal component forecasts, adjusted f &or regARIMA seasonal componentseasonal factors forecasts, before s &hrinkage appliedX-11 Easter adjustment factor forecastscombined ho &liday component forecastscombined adjustment component forecastsco &mbined adjustment component forecastsfinal adjustment difference f &orecastscombined calendar adjustment component forecastsfinal adju &stment ratio forecaststotal adjustment factor forecastsforecasted &factors applied to get adjusted series with forced yearly totalspr &ior trading day component forecastsfinal irregular component regre &ssion trading day component forecastsfinal irregular component reg &ression trading day component forecastsfinal irregular component r &egression holiday component forecastsfinal irregular component reg &ression calendar component forecastsfinal irregular component regr &ession combined calendar component forecastsforecasts of (prior ad &justed) original seriesfinal indirect seasonal component forecasts &final indirect seasonal component forecastsindirect final seasonal & difference forecastsfinal indirect adjustment ratio forecastsindi &rect total adjustment factor forecastsfinal indirect calendar comp &onent forecastsfinal indirect adjustment component forecastsfinal &indirect adjustment component forecastsforecasted factors applied &to get indirect adjusted series with forced yearly totals') desfct.var0000664006604000003110000000452614521201447012162 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c series forecasts and other additional tables. See desfct.prm for data dictionaries. c----------------------------------------------------------------------- DATA dsfptr / & 1, 1, 1, 1, 1, 1, 1, 1, 1, 46, & 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, & 46, 46, 46, 46, 72, 72, 72, 115, 158, 198, & 234, 286, 323, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 362, 362, 362, & 362, 362, 362, 362, 362, 362, 362, 396, 430, 465, & 541, 593, 593, 593, 593, 593, 593, 593, 593, 593, & 593, 593, 593, 593, 593, 593, 593, 593, 593, 593, & 632, 668, 707, 746, 783, 831, 863, 896, 896, 896, & 896, 896, 896, 896, 896, 896, 896, 896, 896, 896, & 896, 896, 896, 896, 896, 896, 896, 896, 896, 896, & 896, 896, 896, 896, 896, 896, 896, 971,1008,1008, & 1008,1008,1008,1008,1076,1076,1144,1144,1208,1208, & 1273,1273,1347,1347,1347,1347,1347,1347,1347,1347, & 1347,1347,1347,1347,1347,1347,1347,1347,1347,1347, & 1347,1347,1347,1347,1347,1347,1347,1347,1347,1347, & 1347,1347,1347,1347,1347,1347,1347,1347,1347,1347, & 1347,1347,1347,1347,1347,1347,1347,1347,1347,1347, & 1347,1347,1347,1347,1347,1347,1347,1347,1347,1347, & 1347,1392,1392,1392,1392,1392,1392,1392,1392,1435, & 1478,1522,1522,1522,1522,1522,1522,1522,1522,1522, & 1522,1522,1522,1522,1522,1522,1522,1522,1522,1522, & 1522,1522,1563,1605,1605,1605,1605,1605,1605,1605, & 1605,1605,1605,1605,1605,1605,1605,1605,1605,1605, & 1605,1605,1605,1648,1693,1738,1738,1738,1822 / desfsa.prm0000664006604000003110000000401214521201447012153 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c X-11 seasonal adjustment (tables 8-20). See desfsa.var for pointers. c----------------------------------------------------------------------- CHARACTER DSSDIC*1406 INTEGER dssptr DIMENSION dssptr(0:PDSS) c----------------------------------------------------------------------- PARAMETER(DSSDIC='unmodified SI ratios, B iterationfinal unmodifie &d SI ratiosfinal unmodified SI ratios, with labels for outliers an &d extreme values% in original series adjusted for calendar factors & (A18)% in original series adjusted for calendar factors (A18 - sa &ved as percentages if appropriate)replacement values for extremes &of SI componentmodified SI ratiosfinal replacement values for SI r &atiosseasonal factors, B iterationseasonal factors, C iterationfin &al seasonal factorsfinal seasonal factors (saved as percentages if & multiplicative adj)final seasonal differenceseasonal factors, adj &usted for user-defined seasonal regARIMA componentseasonal factors &, before shrinkage appliedseasonally adjusted data, B iterationsea &sonally adjusted data, C iterationfinal seasonally adjusted datafi &nal seasonally adjusted series with constant value addedseasonally & adjusted series with alternative extreme value modificationfinal &trend cyclefinal trend cycle not including outlier effectsbias cor &rection factorsfinal trend cycle with constant value addedirregula &r component, B iterationirregular component, C iterationfinal irre &gular componentfinal irregular component (saved as percentages if &multiplicative adj)final irregular component not including outlier & effectspreliminary weights for irregular componentfinal weights f &or irregular componentpreliminary extreme value adjustment factors &final extreme value adjustment factors') desfsa.var0000664006604000003110000000102214521201450012135 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c X-11 seasonal adjustment (tables 8-20). See desfsa.prm for data dictionaries. c----------------------------------------------------------------------- DATA dssptr / & 1, 34, 60, 131, 187, 281, 328, 346, 384, 413, & 442, 464, 531, 556, 627, 669, 706, 743, 773, 831, & 901, 918, 965, 988,1031,1063,1095,1120,1190,1245, & 1288,1325,1369,1407 / desmdl.prm0000664006604000003110000000512014521201451012152 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c regARIMA modelling. See desmdl.var for pointers. c----------------------------------------------------------------------- CHARACTER DSMDIC*1943 INTEGER dsmptr DIMENSION dsmptr(0:PDSM) c----------------------------------------------------------------------- PARAMETER(DSMDIC='matrix of regression variablesregARIMA combined &outlier componentregARIMA AO outlier componentregARIMA level chang &e outlier componentregARIMA temporary change outlier componentregA &RIMA seasonal outlier componentregARIMA trading day componentregAR &IMA holiday componentregARIMA user-defined regression componentreg &ARIMA user-defined seasonal componentregARIMA transitory component ®ression trading day weightsresidual autocorrelations for differ &ent orders of differencingautocorrelation for different orders of &differencingresidual partial autocorrelations for different orders & of differencingpartial autocorrelation for different orders of di &fferencingautomatic ARIMA model selectionmodel identification (for &ecast)model identification (backcast)detailed output for the estim &ation iterationsmodel specifications (regression and arima specs)c &orrelation matrix of regression parameter estimatesregression and &ARMA parameter estimatescorrelation matrix of ARMA parameter estim &atesmaximized log-likelihood and model selection criteriaroots of &the AR and MA operatorsestimated regression effects (X''beta)resid &uals from the estimated modelresiduals from the estimated regressi &on effectsoutlier detection results, by iterationoutlier AO and LS & test statisticsfinal outlier test statisticsresidual autocorrelat &ionsresidual autocorrelationresidual partial autocorrelationresidu &al partial autocorrelationsquared residual autocorrelationssquared & residual autocorrelationhistogram of the regARIMA residualsnormal &ity statistics for regARIMA residualsDurbin-Watson statistic for m &odel residualsFriedman non-parametric test for residual seasonalit &yInverse PACF Diagnosticpoint forecasts and standard errors for th &e transformed dataforecast error variances (transformed scale)poin &t forecasts and prediction intervals on the original scalepoint ba &ckcasts and standard errors for the transformed datapoint backcast &s and prediction intervals on the original scale') desmdl.var0000664006604000003110000000134014521201452012145 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c regARIMA modelling. See desmdl.prm for data dictionaries. c----------------------------------------------------------------------- DATA dsmptr / & 1, 31, 31, 66, 95, 134, 177, 212, 242, 268, & 310, 350, 379, 379, 409, 471, 523, 593, 653, 653, & 684, 684, 684, 684, 684, 684, 684, 684, 684, 684, & 684, 684, 684, 715, 746, 746, 746, 746, 791, 791, & 840, 892, 931, 977,1030,1030,1062,1099,1133,1180, & 1180,1180,1219,1252,1252,1281,1306,1330,1362,1394, & 1427,1459,1494,1537,1580,1633,1656,1716,1760,1822, & 1882,1944 / desreg.f0000664006604000003110000000426714521201452011616 0ustar sun00315stepsC Last change: BCM 13 May 1998 9:04 am SUBROUTINE desreg(Ttlstr,Ngrp,Grpttl,Grpptr,Ngrptl) IMPLICIT NONE c----------------------------------------------------------------------- c Constructs a description of the regression model c At some point need to show that the matrix might be length of month c adjusted c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' INCLUDE 'title.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ CHARACTER addon*3,str*(PGRPCR),tmpttl*80,Grpttl*(PGRPCR*PGRP), & Ttlstr*(*) INTEGER igrp,naddcr,nchr,nttlcr,Grpptr,Ngrptl,Ngrp DIMENSION Grpptr(0:PGRP) c----------------------------------------------------------------------- c Print the regression part of the model c----------------------------------------------------------------------- nttlcr=1 CALL setchr(' ',80,tmpttl) IF(Lcmpaq)THEN nttlcr=1+LEN(Ttlstr) tmpttl(2:nttlcr)=Ttlstr(1:len(Ttlstr)) IF(nttlcr.lt.21)nttlcr=21 ELSE WRITE(Mt1,1010)Ttlstr 1010 FORMAT(/,' ',a) END IF addon=' ' naddcr=1 c ------------------------------------------------------------------ DO igrp=1,Ngrp CALL getstr(Grpttl,Grpptr,Ngrptl,igrp,str,nchr) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(nttlcr+nchr+naddcr.ge.78)THEN WRITE(Mt1,1020)tmpttl(1:nttlcr)//addon(1:naddcr) 1020 FORMAT(a) nttlcr=2+nchr tmpttl(1:nttlcr)=' '//str(1:nchr) c ------------------------------------------------------------------ ELSE tmpttl(nttlcr+1:nttlcr+nchr+naddcr)=addon(1:naddcr) & //str(1:nchr) nttlcr=nttlcr+nchr+naddcr addon=' + ' naddcr=3 END IF END DO c ------------------------------------------------------------------ WRITE(Mt1,1020)tmpttl(1:nttlcr) c ------------------------------------------------------------------ RETURN END desset.prm0000664006604000003110000000517414521201452012203 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c SEATS seasonal adjustment. See desset.var for pointers. c----------------------------------------------------------------------- CHARACTER DSEDIC*1973 INTEGER dseptr DIMENSION dseptr(0:PDSE) c----------------------------------------------------------------------- PARAMETER(DSEDIC='final trend component (SEATS)final trend cycle w &ith constant value added (SEATS)final seasonal component (SEATS)fi &nal seasonal component (SEATS, saved as a percent if log transform &ation used)final irregular component (SEATS)final irregular compon &ent (SEATS, saved as a percent if log transformation used)final se &asonally adjusted series (SEATS)final seasonally adjusted series w &ith constant value added (SEATS)final transitory component (SEATS) &final transitory component (SEATS, saved as a percent if log trans &formation used)final combined adjustment factors (SEATS)final comb &ined adjustment factors (SEATS, saved as a percent if log transfor &mation used)final trend component forecast decomposition (SEATS)fi &nal seasonal component forecast decomposition (SEATS)series foreca &st decomposition (SEATS)final seasonally adjusted series forecast &decomposition (SEATS)final transitory component forecast decomposi &tion (SEATS)final adjustment ratios (SEATS)total adjustment factor &s (SEATS)Wiener-Kolmogorov end filtercomponent modelspseudo innova &tions in trend-cyclepseudo innovations in seasonalpseudo innovatio &ns in transitory componentpseudo innovations in seasonally adjuste &d seriessquared gain of the symmetric seasonal adjustment filtersq &uared gain of the concurrent seasonal adjustment filtersquared gai &n of the symmetric trend filtersquared gain of the concurrent tren &d filtertime shift of the concurrent seasonal adjustment filtertim &e shift of the concurrent trend filtersymmetric seasonal adjustmen &t filterconcurrent seasonal adjustment filtersymmetric trend filte &rconcurrent trend filterdifferenced original series after transfor &mation, prior adjustment (SEATS)differenced final seasonally adjus &ted series (SEATS)differenced final trend (SEATS)sum of final seas &onal component (SEATS)final cyclefinal long term trendstandard err &or of final seasonal component (SEATS)standard error of final seas &onally adjusted series (SEATS)standard error of final trend compon &ent (SEATS)') desset.var0000664006604000003110000000110514521201453012164 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c SEATS seasonal adjustment. See desset.prm for data dictionaries. c----------------------------------------------------------------------- DATA dseptr / & 1, 30, 81, 113, 192, 225, 305, 345, 411, 445, & 526, 567, 655, 707, 762, 799, 862, 919, 950, 982, & 1010,1026,1059,1089,1131,1179,1235,1292,1334,1377, & 1432,1473,1509,1546,1568,1591,1665,1717,1748,1787, & 1798,1819,1869,1927,1974 / desspc.prm0000664006604000003110000000334514521201454012175 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c spectral plots and diagnostics. See desspc.var for pointers. c----------------------------------------------------------------------- CHARACTER DSPDIC*1153 INTEGER dspptr DIMENSION dspptr(0:PDSP) c----------------------------------------------------------------------- PARAMETER(DSPDIC='spectrum of the original seriesspectrum of the r &egARIMA model residualsspectrum of differenced seasonally adjusted & seriesspectrum of irregular componentspectrum of the seasonally a &djusted series (SEATS)spectrum of the irregular component (SEATS)s &pectrum of the extended residuals (SEATS)spectrum of differenced i &ndirect seasonally adjusted seriesspectrum of indirect irregular c &omponentspectrum of the composite seriesTukey spectrum of the orig &inal seriesTukey spectrum of the regARIMA model residualsTukey spe &ctrum of differenced seasonally adjusted seriesTukey spectrum of i &rregular componentTukey spectrum of the seasonally adjusted series & (SEATS)Tukey spectrum of the irregular component (SEATS)Tukey spe &ctrum of the extended residuals (SEATS)Tukey spectrum of differenc &ed indirect seasonally adjusted seriesTukey spectrum of indirect i &rregular componentTukey spectrum of the composite seriesQS diagnos &tic to detect seasonalityQS diagnostic to detect seasonality (indi &rect adjustment)Peak probabilties for the Tukey spectrumQuarterly &seasonality checkNP test for seasonally adjusted seriesNP test for & seasonally adjusted series (indirect adjustment)') desspc.var0000664006604000003110000000073614521201455012171 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c spectral plots and diagnostics. See desspc.prm for data dictionaries. c----------------------------------------------------------------------- DATA dspptr / & 1, 32, 72, 122, 153, 203, 246, 288, 347, 387, & 419, 456, 502, 558, 595, 651, 700, 748, 813, 859, & 897, 932, 989,1029,1056,1094,1154 / dessrs.prm0000664006604000003110000000227614521201455012222 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c data and transformations. See dessrs.var for pointers. c----------------------------------------------------------------------- CHARACTER DSRDIC*665 INTEGER dsrptr DIMENSION dsrptr(0:PDSR) c----------------------------------------------------------------------- PARAMETER(DSRDIC='time series data (for the span analyzed)original & seriesinput specification fileoriginal series adjusted for missin &g value regressorsregARIMA calendar adjusted original dataregARIMA & outlier adjusted original dataoriginal series (prior adjusted)ori &ginal series (prior adjusted)time series data plus constant (for t &he span analyzed)original series plus constantprior-adjustment fac &torspermanent prior-adjustment factorstemporary prior-adjustment f &actorsprior-adjusted datapermanent prior-adjusted dataprior-adjust &ed data (including prior trading day adjustments)permanent prior-a &djusted data (including prior trading day adjustments)prior-adjust &ed and transformed data') dessrs.var0000664006604000003110000000067714521201456012220 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c data and transformations. See dessrs.prm for data dictionaries. c----------------------------------------------------------------------- DATA dsrptr / & 1, 1, 41, 56, 80, 80, 133, 173, 212, 244, & 276, 330, 359, 383, 417, 451, 470, 499, 560, 631, & 666, 666 / desst2.prm0000664006604000003110000000131114521201457012112 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c SEATS seasonal adjustment. See desst2.var for pointers. c----------------------------------------------------------------------- CHARACTER DS2DIC*219 INTEGER ds2ptr DIMENSION ds2ptr(0:PDS2) c----------------------------------------------------------------------- PARAMETER(DS2DIC='standard error of final transitory component (SE &ATS)final seasonally adjusted series adjusted for outliers (SEATS) &final irregular component outlier adjusted (SEATS)final trend cycl &e not including outlier effects (SEATS)') desst2.var0000664006604000003110000000053014521201460012100 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c SEATS seasonal adjustment. See desst2.prm for data dictionaries. c----------------------------------------------------------------------- DATA ds2ptr / & 1, 53, 115, 165,220 / desx11.prm0000664006604000003110000000330114521201460012006 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c X-11 seasonal adjustment (tables 1-7). See desx11.var for pointers. c----------------------------------------------------------------------- CHARACTER DSXDIC*1110 INTEGER dsxptr DIMENSION dsxptr(0:PDSX) c----------------------------------------------------------------------- PARAMETER(DSXDIC='modified original data, C iterationmodified orig &inal data, D iterationoriginal data modified for extremesMCD movin &g averagepreliminary trend cycle, B iterationpreliminary trend cyc &le, C iterationpreliminary trend cycle, D iterationmodified season &ally adjusted seriesunmodified SI ratios, B iterationmodified irre &gular seriesreplacement values for extremes of SI componentmodifie &d SI ratios, C iterationmodified SI ratios, D iterationpreliminary & seasonal factors, B iterationpreliminary seasonal factors, C iter &ationpreliminary seasonal factors, D iteration% in the original se &ries% in the original series (saved as percentages if appropriate) &preliminary seasonally adjusted series, B iterationpreliminary sea &sonally adjusted series, C iterationpreliminary seasonally adjuste &d series, D iteration% in seasonally adjusted series (D11)% in sea &sonally adjusted series (D11 - saved as percentages if appropriate &)preliminary trend cycle, B iterationpreliminary trend cycle, C it &erationpreliminary trend cycle, D iteration% in final trend cycle &(D12)% in final trend cycle (D12 - saved as percentages if appropr &iate )') desx11.var0000664006604000003110000000075714521201461012015 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c X-11 seasonal adjustment (tables 1-7). See desx11.prm for data dictionaries. c----------------------------------------------------------------------- DATA dsxptr / & 1, 36, 71, 106, 124, 160, 196, 232, 267, 300, & 325, 372, 403, 434, 475, 516, 557, 581, 643, 694, & 745, 796, 833, 908, 944, 980,1016,1044,1111 / desxrg.prm0000664006604000003110000000340114521201461012177 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c irregular component regressions. See desxrg.var for pointers. c----------------------------------------------------------------------- CHARACTER DSIDIC*1172 INTEGER dsiptr DIMENSION dsiptr(0:PDSI) c----------------------------------------------------------------------- PARAMETER(DSIDIC='prior trading day factorsextreme irregular value &s excluded from irregular component regressionextreme irregular va &lues excluded from irregular component regressionpreliminary irreg &ular component regressionfinal irregular component regressionpreli &minary trading day factors from irregular component regressionfina &l trading day factors from irregular component regressionprelimina &ry combined trading day factors from irregular component regressio &nfinal combined trading day factors from irregular component regre &ssionpreliminary holiday factors from irregular component regressi &onfinal holiday factors from irregular component regressionprelimi &nary calendar factors from irregular component regressionfinal cal &endar factors from irregular component regressionpreliminary combi &ned calendar factors from irregular component regressionfinal comb &ined calendar factors from irregular component regressionAO outlie &r detection results for irregular component regression, by iterati &onregression matrix used in final irregular component regressionco &variance matrix of irregular component regression parameter estima &tesresults of AIC tests used in final irregular component regressi &on') desxrg.var0000664006604000003110000000071314521201463012176 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c irregular component regressions. See desxrg.prm for data dictionaries. c----------------------------------------------------------------------- DATA dsiptr / & 1, 26, 95, 164, 206, 242, 309, 370, 446, 516, & 579, 636, 700, 758, 831, 898, 898, 975, 975, 975, & 1037,1108,1173 / dets.i0000664006604000003110000000050614521201463011301 0ustar sun00315stepsC C... Variables in Common Block /dets/ ... integer SeasCheck,nround,Nres0,Nres1 integer q0,df0,imean0,bq0,bd0,Init0 real*8 Va0,Va1,Jb0,Jb1,Acf1,Seacf1 common /dets/ SeasCheck,nround,Nres0,Nres1, $ q0,df0,imean0,bq0,bd0,Init0, $ Va0,Va1,Jb0,Jb1,Acf1,Seacf1 devlpl.f0000664006604000003110000000245514521201463011632 0ustar sun00315steps**==devlpl.f processed by SPAG 4.03F at 14:31 on 28 Jul 1994 DOUBLE PRECISION FUNCTION devlpl(A,N,X) IMPLICIT NONE C********************************************************************** C C DOUBLE PRECISION FUNCTION DEVLPL(A,N,X) C Double precision EVALuate a PoLynomial at X C C C Function C C C returns C A(1) + A(2)*X + ... + A(N)*X**(N-1) C C C Arguments C C C A --> Array of coefficients of the polynomial. C A is DOUBLE PRECISION(N) C C N --> Length of A, also degree of polynomial - 1. C N is INTEGER C C X --> Point at which the polynomial is to be evaluated. C X is DOUBLE PRECISION C C********************************************************************** C C .. Scalar Arguments .. DOUBLE PRECISION X INTEGER N C .. C .. Array Arguments .. DOUBLE PRECISION A(N) C .. C .. Local Scalars .. DOUBLE PRECISION term INTEGER i C .. C .. Executable Statements .. term=A(N) DO i=N-1,1,-1 term=A(i)+term*X END DO devlpl=term RETURN END dfdate.f0000664006604000003110000000136014521201464011566 0ustar sun00315steps**==dfdate.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE dfdate(Datea,Dateb,Sp,Diff) IMPLICIT NONE c----------------------------------------------------------------------- c Finds the difference between two dates where the dates, datea and c dateb are length 2 arrays of year then period. c----------------------------------------------------------------------- INTEGER Datea(2),Dateb(2),Sp,Diff c----------------------------------------------------------------------- IF(Sp.gt.1)THEN Diff=Sp*(Datea(1)-Dateb(1))+Datea(2)-Dateb(2) ELSE Diff=Datea(1)-Dateb(1) END IF c ------------------------------------------------------------------ RETURN END dgefa.f0000664006604000003110000000575414521201464011420 0ustar sun00315steps subroutine dgefa(a,lda,n,ipvt,info) integer lda,n,ipvt(*),info double precision a(lda,*) c c dgefa factors a double precision matrix by gaussian elimination. c c dgefa is usually called by dgeco, but it can be called c directly with a saving in time if rcond is not needed. c (time for dgeco) = (1 + 9/n)*(time for dgefa) . c c on entry c c a double precision(lda, n) c the matrix to be factored. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c on return c c a an upper triangular matrix and the multipliers c which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that dgesl or dgedi will divide by zero c if called. use rcond in dgeco for a reliable c indication of singularity. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal,idamax c c internal variables c double precision t integer idamax,j,k,kp1,l,nm1 C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK c c c gaussian elimination with partial pivoting c info = 0 nm1 = n - 1 if (nm1 .lt. 1) go to 70 do 60 k = 1, nm1 kp1 = k + 1 c c find l = pivot index c l = idamax(n-k+1,a(k,k),1) + k - 1 ipvt(k) = l c c zero pivot implies this column already triangularized c if (dpeq(a(l,k), 0.0d0)) go to 40 c c interchange if necessary c if (l .eq. k) go to 10 t = a(l,k) a(l,k) = a(k,k) a(k,k) = t 10 continue c c compute multipliers c t = -1.0d0/a(k,k) call dscal(n-k,t,a(k+1,k),1) c c row elimination with column indexing c do 30 j = kp1, n t = a(l,j) if (l .eq. k) go to 20 a(l,j) = a(k,j) a(k,j) = t 20 continue call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) 30 continue go to 50 40 continue info = k 50 continue 60 continue 70 continue ipvt(n) = n if (dpeq(a(n,n), 0.0d0)) info = n return end dgesl.f0000664006604000003110000000627614521201464011450 0ustar sun00315steps subroutine dgesl(a,lda,n,ipvt,b,job) integer lda,n,ipvt(*),job double precision a(lda,*),b(*) c c dgesl solves the double precision system c a * x = b or trans(a) * x = b c using the factors computed by dgeco or dgefa. c c on entry c c a double precision(lda, n) c the output from dgeco or dgefa. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c ipvt integer(n) c the pivot vector from dgeco or dgefa. c c b double precision(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if dgeco has set rcond .gt. 0.0 c or dgefa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dgeco(a,lda,n,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call dgesl(a,lda,n,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,ddot c c internal variables c double precision ddot,t integer k,kb,l,nm1 c nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/a(k,k) t = -b(k) call daxpy(k-1,t,a(1,k),1,b(1),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n t = ddot(k-1,a(1,k),1,b(1),1) b(k) = (b(k) - t)/a(k,k) 60 continue c c now solve trans(l)*x = y c if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end dgnsvl.i0000664006604000003110000000141414521201464011637 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for svltbl are of the form LSL c where the types are c----------------------------------------------------------------------- c Average absolute revision for seasonally adjusted series ASA c Average absolute revision for seasonal factors ASF c Average absolute revision for projected seasonal factors ASP c Percent flagged for seasonal factors SFP c----------------------------------------------------------------------- INTEGER LSLASA,LSLASF,LSLASP,LSLAFE,LSLALR,LSLPCT PARAMETER( & LSLASA= 50,LSLASF= 55,LSLASP= 56,LSLAFE= 57,LSLALR= 58, & LSLPCT= 59) difflt.f0000664006604000003110000000241514521201464011611 0ustar sun00315steps**==difflt.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE difflt(Nr,Nc,Ndf,Nsdf,Sp,C,Nefobs) c ------------------------------------------------------------------ IMPLICIT NONE INTEGER i,j,lag,Nc,Ndf,Nefobs,nelt,Nr,Nsdf,Sp DOUBLE PRECISION C DIMENSION C(*) c----------------------------------------------------------------------- c Regular differences c----------------------------------------------------------------------- nelt=Nr*Nc lag=Nc DO j=1,Ndf nelt=nelt-lag c ------------------------------------------------------------------ DO i=1,nelt C(i)=C(i+lag)-C(i) END DO END DO c----------------------------------------------------------------------- c Seasonal differences c----------------------------------------------------------------------- lag=Nc*Sp DO j=1,Nsdf nelt=nelt-lag c ------------------------------------------------------------------ DO i=1,nelt C(i)=C(i+lag)-C(i) END DO END DO c ------------------------------------------------------------------ Nefobs=nelt/Nc c ------------------------------------------------------------------ RETURN END dimensions.i0000664006604000003110000000042614521201465012515 0ustar sun00315stepsc DIMENSIONS.i integer nfrq,nw2 parameter (nfrq=61,nw2=600) integer MP,kp,mpkp parameter(MP=POBS,KP=PFCST,mpkp=MP+KP) integer maxTh parameter (maxTh=40) integer KL parameter (KL=PFCST) dinvnr.f0000664006604000003110000000503414521201465011642 0ustar sun00315steps**==dinvnr.f processed by SPAG 4.03F at 14:31 on 28 Jul 1994 DOUBLE PRECISION FUNCTION dinvnr(P,Q) IMPLICIT NONE C********************************************************************** C C DOUBLE PRECISION FUNCTION DINVNR(P,Q) C Double precision NoRmal distribution INVerse C C C Function C C C Returns X such that CUMNOR(X) = P, i.e., the integral from - C infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P C C C Arguments C C C P --> The probability whose normal deviate is sought. C P is DOUBLE PRECISION C C Q --> 1-P C P is DOUBLE PRECISION C C C Method C C C The rational function on page 95 of Kennedy and Gentle, C Statistical Computing, Marcel Dekker, NY , 1980 is used as a start C value for the Newton method of finding roots. C C C Note C C C If P or Q .lt. machine EPS returns +/- DINVNR(EPS) C C********************************************************************** C .. Parameters .. INTEGER MAXIT PARAMETER(MAXIT=100) DOUBLE PRECISION EPS PARAMETER(EPS=1.0D-13) DOUBLE PRECISION R2PI PARAMETER(R2PI=0.3989422804014326D0) DOUBLE PRECISION NHALF PARAMETER(NHALF=-0.5D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION P,Q C .. C .. Local Scalars .. DOUBLE PRECISION strtx,xcur,cum,ccum,pp,dx INTEGER i LOGICAL qporq C .. C .. External Functions .. DOUBLE PRECISION stvaln EXTERNAL stvaln C .. C .. External Subroutines .. EXTERNAL cumnor C .. C .. Statement Functions .. DOUBLE PRECISION dennor,x dennor(x)=R2PI*exp(NHALF*x*x) C .. C .. Executable Statements .. C C FIND MINIMUM OF P AND Q C qporq=P.le.Q IF(.not.qporq)THEN pp=Q ELSE pp=P END IF C C INITIALIZATION STEP C strtx=stvaln(pp) xcur=strtx C C NEWTON INTERATIONS C DO i=1,MAXIT CALL cumnor(xcur,cum,ccum) dx=(cum-pp)/dennor(xcur) xcur=xcur-dx IF(abs(dx/xcur).lt.EPS)GO TO 10 END DO dinvnr=strtx C C IF WE GET HERE, NEWTON HAS FAILED C IF(.not.qporq)dinvnr=-dinvnr RETURN C C IF WE GET HERE, NEWTON HAS SUCCEDED C 10 dinvnr=xcur IF(.not.qporq)dinvnr=-dinvnr RETURN END dirs.i0000664006604000003110000000017214521201465011304 0ustar sun00315stepsC C... Variables in Common Block /dir/ ... character OUTDIR*180,GRAPHDIR*180 common /dir/ OUTDIR,GRAPHDIR divgud.f0000664006604000003110000000215514521201465011625 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 10:54 pm SUBROUTINE divgud(Result,Array1,Array2,Jfda,Jlda) IMPLICIT NONE C----------------------------------------------------------------------- C --- THIS ROUTINE DIVIDES ARRAY1 BY ARRAY2 only for those observations c that are "good" for multiplicative seasonal adjustment c ------------------------------------------------------------------ c written by Brian Monsell, March 2006 C----------------------------------------------------------------------- DOUBLE PRECISION Array1,Array2,Result INTEGER i,Jfda,Jlda DIMENSION Result(*),Array1(*),Array2(*) C----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'goodob.cmn' C----------------------------------------------------------------------- DO i=Jfda,Jlda IF(Gudval(i))THEN Result(i)=Array1(i)/Array2(i) ELSE Result(i)=DNOTST END IF END DO C----------------------------------------------------------------------- RETURN END divsub.f0000664006604000003110000000174514521201465011643 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 10:54 pm SUBROUTINE divsub(Result,Array1,Array2,Jfda,Jlda) IMPLICIT NONE C----------------------------------------------------------------------- C --- THIS ROUTINE DIVIDES ARRAY1 BY ARRAY2 OR SUBTRACTS ARRAY2 C --- FROM ARRAY1 DEPENDING ON WHETHER A MULTIPLICATIVE OR ADDITIVE C --- ADJUSTMENT IS BEING MADE. C----------------------------------------------------------------------- DOUBLE PRECISION Array1,Array2,Result INTEGER i,Jfda,Jlda DIMENSION Result(*),Array1(*),Array2(*) C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11opt.cmn' C----------------------------------------------------------------------- IF(Muladd.eq.0)THEN DO i=Jfda,Jlda Result(i)=Array1(i)/Array2(i) END DO RETURN END IF DO i=Jfda,Jlda Result(i)=Array1(i)-Array2(i) END DO RETURN END dlrgef.f0000664006604000003110000001432214521201465011605 0ustar sun00315stepsC Last change: BCM 14 May 1998 8:45 am SUBROUTINE dlrgef(Begcol,Nrxy,Ndelc) IMPLICIT NONE c----------------------------------------------------------------------- c Deletes ndelc columns from [X:y] starting at begcol. c The regression effect estimates column and regression group title c and specification arrays are also updated. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c b d I/O pb long, nb used, vector of all the regression effects c begcol i Local begining column of columns to be deleted c endcol i Local index for the end column to delete c i i Local do loop row index c ibeg i Local index bound for the begining element of a row or the c begining column in the current regression group c idelc i Local number of columns to delete in the current regression c group c iend i Local index bound for the last element of a row or the last c column in the current regression group c igrp i Local the current regression group c j i Local do loop element index c ncol i Local number of columns in the current regression group c ndelc i Local for number of columns to delete c nloop i Local limit for the number of loops taken in a do loop. c Used so that ngrps can be updated within the loop. c noldc i Local number of columns before deletion c noffst i Local number of elements that a row must be moved or the c number of rows a regression group needs to be moved due c to deleted groups. c----------------------------------------------------------------------- c Type and dimension variables c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ INTEGER Begcol,endcol,i,ibeg,idelc,iend,igrp,j,ncol,Ndelc,nloop, & noldc,Nrxy,ntdelc,noffst,e1 c----------------------------------------------------------------------- c Calculate the number of regression variable and find the group. c If the group can't be found igrp is 0. c----------------------------------------------------------------------- noldc=Ncxy endcol=Begcol+Ndelc-1 c----------------------------------------------------------------------- c Check if columns are within a the X part of the Xy matrix c----------------------------------------------------------------------- IF(Begcol.lt.1.or.endcol.gt.Nb)THEN WRITE(STDERR,1010)Begcol,endcol,Ncxy-1 CALL errhdr WRITE(Mt2,1010)Begcol,endcol,Ncxy-1 1010 FORMAT(/,' ERROR: Deleted columns,',i3,':',i2,', not within',i3, & ' column regression matrix.') CALL abend RETURN END IF c----------------------------------------------------------------------- c Delete the column titles and regression estimates for the c deleted columns c----------------------------------------------------------------------- DO i=endcol,Begcol,-1 CALL delstr(i,Colttl,Colptr,Ncoltl,PB) IF(Lfatal)RETURN END DO c----------------------------------------------------------------------- c Delete the regression coeffcients and the regression types c----------------------------------------------------------------------- e1=endcol+1 IF(e1.le.PB)THEN CALL copy(B(e1),noldc-1-endcol,1,B(Begcol)) CALL cpyint(Rgvrtp(e1),noldc-1-endcol,1,Rgvrtp(Begcol)) CALL copylg(Regfx(e1),noldc-1-endcol,1,Regfx(Begcol)) END IF c----------------------------------------------------------------------- c Since elements are deleted from the same matrix start at the c begining. First setup the indices and index bounds c----------------------------------------------------------------------- Ncxy=noldc-Ndelc Nb=Ncxy-1 iend=Begcol-1 c ------------------------------------------------------------------ DO i=1,Nrxy-1 noffst=i*Ndelc ibeg=iend+1 iend=iend+Ncxy c ------------------------------------------------------------------ DO j=ibeg,iend Xy(j)=Xy(j+noffst) END DO END DO c ------------------------------------------------------------------ noffst=Nrxy*Ndelc ibeg=iend+1 c ------------------------------------------------------------------ DO j=ibeg,Nrxy*Ncxy Xy(j)=Xy(j+noffst) END DO c----------------------------------------------------------------------- c Update the grp and grpttl indices c----------------------------------------------------------------------- noffst=0 nloop=Ngrp c ------------------------------------------------------------------ ntdelc=Ndelc DO igrp=1,nloop ibeg=Grp(igrp-1) iend=Grp(igrp)-1 c ------------------------------------------------------------------ IF(iend.ge.Begcol.and.ntdelc.gt.0)THEN CALL eltlen(igrp,Grp,Ngrp,ncol) IF(Lfatal)RETURN IF(ntdelc.gt.0)THEN idelc=min(iend,Begcol+ntdelc-1)-max(ibeg,Begcol)+1 ncol=ncol-idelc ntdelc=ntdelc-idelc c ------------------------------------------------------------------ IF(ntdelc.gt.0)Begcol=ibeg+ncol ELSE idelc=0 END IF c ------------------------------------------------------------------ IF(ncol.gt.0)THEN i=igrp+noffst c Grp(i-1)=ibeg DO i=i,Ngrp Grp(i)=Grp(i)-idelc END DO c ------------------------------------------------------------------ ELSE CALL delstr(igrp,Grpttl,Grpptr,Ngrptl,PGRP) IF(Lfatal)RETURN Ngrp=Ngrp-1 noffst=noffst-1 DO i=igrp,Ngrp Grp(i)=Grp(i+1)-idelc END DO END IF END IF END DO c ------------------------------------------------------------------ RETURN END dlrgrw.f0000664006604000003110000000254214521201465011644 0ustar sun00315steps SUBROUTINE dlrgrw(Xy,Ncxy,Nrxy,Rgxcld) IMPLICIT NONE c----------------------------------------------------------------------- c Removes from the regression matrix Xy the values indicated in the c logical vector Rgxcld c----------------------------------------------------------------------- DOUBLE PRECISION Xy LOGICAL Rgxcld INTEGER disp1,disp2,i,i2,j,Ncxy,Nrxy DIMENSION Xy(*),Rgxcld(*) c----------------------------------------------------------------------- c Initialize index for matrix with rows excluded c----------------------------------------------------------------------- i2=1 c----------------------------------------------------------------------- c Check to see if observation not to be excluded c----------------------------------------------------------------------- DO i=1,Nrxy IF(.not.Rgxcld(i))THEN disp1=(i-1)*Ncxy disp2=(i2-1)*Ncxy DO j=1,Ncxy Xy(disp2+j)=Xy(disp1+j) END DO c----------------------------------------------------------------------- c Update index for matrix with rows excluded c----------------------------------------------------------------------- i2=i2+1 END IF END DO c----------------------------------------------------------------------- RETURN END dlusrg.f0000664006604000003110000000767614521201465011660 0ustar sun00315stepsC Last change: BCM 14 May 1998 7:51 am SUBROUTINE dlusrg(Begcol) IMPLICIT NONE c----------------------------------------------------------------------- c Deletes ndelc columns from user defined regressors starting at c begcol. Other arrays associated with the user defined regressors c are also updated. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begcol i Local begining column of columns to be deleted c i i Local do loop row index c ibeg i Local index bound for the begining element of a row or the c begining column in the current regression group c iend i Local index bound for the last element of a row or the last c column in the current regression group c j i Local do loop element index c ndelc i Local for number of columns to delete c noldc i Local number of columns before deletion c offset i Local number of elements that a row must be moved or the c number of rows a regression group needs to be moved due c to deleted groups. c----------------------------------------------------------------------- c Type and dimension variables c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'arima.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ INTEGER Begcol,i,ibeg,iend,j,noldc,offset c----------------------------------------------------------------------- c Calculate the number of regression variable and find the group. c If the group can't be found igrp is 0. c----------------------------------------------------------------------- noldc=Ncusrx c----------------------------------------------------------------------- c Check if columns are within a the X part of the Xy matrix c----------------------------------------------------------------------- IF(Begcol.lt.1.or.Begcol.gt.Ncusrx)THEN WRITE(STDERR,1010)Begcol,Ncusrx CALL errhdr WRITE(Mt2,1010)Begcol,Ncusrx 1010 FORMAT(/,' ERROR: Deleted column,',i3,' not within',i3, & ' column user-regression matrix.') CALL abend RETURN END IF c----------------------------------------------------------------------- c Delete the column titles and regression estimates for the c deleted columns c----------------------------------------------------------------------- CALL delstr(Begcol,Usrttl,Usrptr,Ncusrx,PUREG) c----------------------------------------------------------------------- c Delete the user regression types c----------------------------------------------------------------------- CALL cpyint(Usrtyp(Begcol+1),noldc-1-Begcol,1,Usrtyp(Begcol)) c----------------------------------------------------------------------- c Since elements are deleted from the same matrix start at the c begining. First setup the indices and index bounds c----------------------------------------------------------------------- IF(noldc.eq.1)RETURN iend=Begcol-1 c ------------------------------------------------------------------ DO i=1,Nrusrx-1 offset=i*1 ibeg=iend+1 iend=iend+Ncusrx c ------------------------------------------------------------------ DO j=ibeg,iend Userx(j)=Userx(j+offset) END DO END DO c ------------------------------------------------------------------ offset=Nrusrx ibeg=iend+1 c ------------------------------------------------------------------ DO j=ibeg,Nrusrx*Ncusrx Userx(j)=Userx(j+offset) END DO c ------------------------------------------------------------------ RETURN END dot.f0000664006604000003110000000101514521201465011123 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:57 pm **==dot.f processed by SPAG 4.03F at 09:47 on 1 Mar 1994 SUBROUTINE dot(Jy1,Jy2,Jx) IMPLICIT NONE C*** Start of declarations inserted by SPAG INTEGER j,j1,j2,Jx,Jy1,Jy2 C*** End of declarations inserted by SPAG INCLUDE 'srslen.prm' INCLUDE 'chrt.cmn' C************* j1=min(Jy1,Jy2)+1 j2=max(Jy1,Jy2)-1 IF(j2.ge.j1)THEN DO j=j1,j2 Ia(Jx,j)=I7 END DO END IF RETURN END dpeq.f0000664006604000003110000000151514521201465011273 0ustar sun00315stepsC Last change: BCM 30 Oct 97 10:24 am LOGICAL FUNCTION dpeq(X,Dtargt) IMPLICIT NONE c----------------------------------------------------------------------- c Avoids a floating point comparison error to test whether X is c equal to Dtargt c----------------------------------------------------------------------- DOUBLE PRECISION DELTA PARAMETER(DELTA=3.834D-20) c----------------------------------------------------------------------- DOUBLE PRECISION X,Dtargt,dx c----------------------------------------------------------------------- dpeq=.false. dx=dabs(X-Dtargt) IF(dx.lt.DELTA)dpeq=.true. c dpeq=.true. c IF(X.lt.Dtargt.or.X.gt.Dtargt)dpeq=.false. c----------------------------------------------------------------------- RETURN END dpmpar.f0000664006604000003110000000375714521201466011640 0ustar sun00315stepsC Last change: SRD 19 Nov 99 7:59 am **==dpmpar.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 DOUBLE PRECISION FUNCTION dpmpar(I) IMPLICIT NONE INTEGER I C ********** C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) = B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** DOUBLE PRECISION dmach(3) C ------------------------------------------------------------------ cdos value of dmach for lahey fortran cdos DATA dmach/2.220446D-16,2.23D-308,1.79D308/ C ------------------------------------------------------------------ cunix value of dmach for SparcCompiler for Solaris 3.0.1 DATA dmach/2.220446d-16,2.225074d-308,1.797693d308/ C ------------------------------------------------------------------ cvax value of dmach for VAX Alpha cvax DATA dmach/2.220446d-16,0.30d-38,1.69d38/ C ------------------------------------------------------------------ C dpmpar=dmach(I) RETURN C C LAST CARD OF FUNCTION DPMPAR. C END dppdi.f0000664006604000003110000000647514521201466011455 0ustar sun00315stepsC Last change: BCM 29 Sep 97 9:41 am **==dppdi.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE dppdi(Ap,N,Det,Job) IMPLICIT NONE DOUBLE PRECISION ZERO,ONE PARAMETER(ZERO=0D0,ONE=1D0) INTEGER N,Job DOUBLE PRECISION Ap(*) DOUBLE PRECISION Det(2) c c dppdi computes the determinant and inverse c of a double precision symmetric positive definite matrix c using the factors computed by dppco or dppfa . c c on entry c c ap double precision (n*(n+1)/2) c the output from dppco or dppfa. c c n integer c the order of the matrix a . c c job integer c = 11 both determinant and inverse. c = 01 inverse only. c = 10 determinant only. c c on return c c ap the upper triangular half of the inverse . c the strict lower triangle is unaltered. c c det double precision(2) c determinant of original matrix if requested. c otherwise not referenced. c determinant = det(1) * 10.0**det(2) c with 1.0 .le. det(1) .lt. 10.0 c or det(1) .eq. 0.0 . c c error condition c c a division by zero will occur if the input factor contains c a zero on the diagonal and the inverse is requested. c it will not occur if the subroutines are called correctly c and if dpoco or dpofa has set info .eq. 0 . c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal c fortran mod c c internal variables c DOUBLE PRECISION t DOUBLE PRECISION s INTEGER i,ii,j,jj,jm1,j1,k,kj,kk,kp1,k1 LOGICAL dpeq EXTERNAL dpeq c c compute determinant c IF(Job/10.ne.0)THEN Det(1)=ONE Det(2)=ZERO s=10.0D0 ii=0 DO i=1,N ii=ii+i Det(1)=Ap(ii)**2*Det(1) c ...exit IF(.not.dpeq(Det(1),ZERO))THEN DO WHILE (Det(1).lt.ONE) Det(1)=s*Det(1) Det(2)=Det(2)-ONE END DO DO WHILE (Det(1).ge.s) Det(1)=Det(1)/s Det(2)=Det(2)+ONE END DO END IF END DO END IF c c compute inverse(r) c IF(mod(Job,10).ne.0)THEN kk=0 DO k=1,N k1=kk+1 kk=kk+k Ap(kk)=ONE/Ap(kk) t=-Ap(kk) CALL dscal(k-1,t,Ap(k1),1) kp1=k+1 j1=kk+1 kj=kk+k IF(N.ge.kp1)THEN DO j=kp1,N t=Ap(kj) Ap(kj)=ZERO CALL daxpy(k,t,Ap(k1),1,Ap(j1),1) j1=j1+j kj=kj+j END DO END IF END DO c c form inverse(r) * trans(inverse(r)) c jj=0 DO j=1,N j1=jj+1 jj=jj+j jm1=j-1 k1=1 kj=j1 IF(jm1.ge.1)THEN DO k=1,jm1 t=Ap(kj) CALL daxpy(k,t,Ap(j1),1,Ap(k1),1) k1=k1+k kj=kj+1 END DO END IF t=Ap(jj) CALL dscal(j,t,Ap(j1),1) END DO END IF RETURN END dppfa.f0000664006604000003110000000475714521201466011450 0ustar sun00315steps**==dppfa.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE dppfa(Ap,N,Info) IMPLICIT NONE INTEGER N,Info DOUBLE PRECISION dpmpar,mprec,Ap(*) EXTERNAL dpmpar C C DPPFA FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE C MATRIX STORED IN PACKED FORM. C C DPPFA IS USUALLY CALLED BY DPPCO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR DPPCO) = (1 + 18/N)*(TIME FOR DPPFA) . C C ON ENTRY C C AP DOUBLE PRECISION (N*(N+1)/2) C THE PACKED FORM OF A SYMMETRIC MATRIX A . THE C COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY C IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+1)/2 . C SEE COMMENTS BELOW FOR DETAILS. C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C AP AN UPPER TRIANGULAR MATRIX R , STORED IN PACKED C FORM, SO THAT A = TRANS(R)*R . C C INFO INTEGER C = 0 FOR NORMAL RETURN. C = K IF THE LEADING MINOR OF ORDER K IS NOT C POSITIVE DEFINITE. C C C PACKED STORAGE C C THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER C TRIANGLE OF A SYMMETRIC MATRIX. C C K = 0 C DO 20 J = 1, N C DO 10 I = 1, J C K = K + 1 C AP(K) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DDOT C FORTRAN DSQRT C C INTERNAL VARIABLES C DOUBLE PRECISION ddot,t DOUBLE PRECISION s INTEGER j,jj,jm1,k,kj,kk C BEGIN BLOCK WITH ...EXITS TO 40 C C mprec=dpmpar(1) jj=0 DO j=1,N Info=j s=0.0D0 jm1=j-1 kj=jj kk=0 IF(jm1.ge.1)THEN DO k=1,jm1 kj=kj+1 t=Ap(kj)-ddot(k-1,Ap(kk+1),1,Ap(jj+1),1) kk=kk+k t=t/Ap(kk) Ap(kj)=t s=s+t*t END DO END IF jj=jj+j s=Ap(jj)-s C ......EXIT IF(s.gt.0.0D0)THEN Ap(jj)=dsqrt(s) ELSE IF(s.ge.-mprec)Ap(jj)=0D0 c ELSE GO TO 10 END IF END DO Info=0 10 RETURN END dppsl.f0000664006604000003110000000410014521201466011456 0ustar sun00315steps**==dppsl.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE dppsl(Ap,N,B,Alt) IMPLICIT NONE INTEGER N DOUBLE PRECISION Ap(*),B(*) LOGICAL Alt c c dppsl solves the double precision symmetric positive definite c system a * x = b c using the factors computed by dppco or dppfa. c unless alt is true, in which case it solves the system c l * x = b c where a=l*l' c c on entry c c ap double precision (n*(n+1)/2) c the output from dppco or dppfa. c c n integer c the order of the matrix a . c c b double precision(n) c the right hand side vector. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains c a zero on the diagonal. technically this indicates c singularity but it is usually caused by improper subroutine c arguments. it will not occur if the subroutines are called c correctly and info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dppco(ap,n,rcond,z,info) c if (rcond is too small .or. info .ne. 0) go to ... c do 10 j = 1, p c call dppsl(ap,n,c(1,j)) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c alt option added 5/1/90 by larry bobbitt, census bureau, c statistical research division. c c subroutines and functions c c blas daxpy,ddot c c internal variables c DOUBLE PRECISION ddot,t INTEGER k,kb,kk c kk=0 DO k=1,N t=ddot(k-1,Ap(kk+1),1,B(1),1) kk=kk+k B(k)=(B(k)-t)/Ap(kk) END DO c IF(Alt)RETURN c DO kb=1,N k=N+1-kb B(k)=B(k)/Ap(kk) kk=kk-k t=-B(k) CALL daxpy(k-1,t,Ap(kk+1),1,B(1),1) END DO RETURN END dsarma.f0000664006604000003110000000242314521201466011611 0ustar sun00315steps SUBROUTINE dsarma(Lcmpaq) IMPLICIT NONE c----------------------------------------------------------------------- c Constructs a description of an ARIMA model c ( 0 1 1)12 c or c ( 0 2*11 [ 1 3])( 0 0 1)12 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL Lcmpaq c----------------------------------------------------------------------- c Print the ARIMA part c----------------------------------------------------------------------- IF(Lcmpaq)THEN IF(Nmdl.gt.0)THEN WRITE(Mt1,1010)Mdlttl(1:Nmdlcr),Mdldsn(1:Nmddcr) ELSE WRITE(Mt1,1010)Mdlttl(1:Nmdlcr),'(0 0 0)' END IF ELSE IF(Nmdl.gt.0)THEN WRITE(Mt1,1020)Mdlttl(1:Nmdlcr),Mdldsn(1:Nmddcr) ELSE WRITE(Mt1,1020)Mdlttl(1:Nmdlcr),'(0 0 0)' END IF END IF c ------------------------------------------------------------------ 1010 FORMAT(' ',a,': ',a) 1020 FORMAT(/,' ',a,/,' ',a) c ------------------------------------------------------------------ RETURN END dscal.f0000664006604000003110000000177614521201466011442 0ustar sun00315steps**==dscal.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE dscal(N,Da,Dx,Incx) IMPLICIT NONE C C REPLACE DOUBLE PRECISION DX BY DOUBLE PRECISION DA*DX. C FOR I = 0 TO N-1, REPLACE DX(1+I*INCX) WITH DA * DX(1+I*INCX) C INTEGER i,Incx,m,mp1,N,ns DOUBLE PRECISION Da,Dx(*) IF(N.le.0)RETURN IF(Incx.eq.1)THEN C C CODE FOR INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C m=mod(N,5) IF(m.ne.0)THEN DO i=1,m Dx(i)=Da*Dx(i) END DO IF(N.lt.5)RETURN END IF ELSE C C CODE FOR INCREMENTS NOT EQUAL TO 1. C ns=N*Incx DO i=1,ns,Incx Dx(i)=Da*Dx(i) END DO RETURN END IF mp1=m+1 DO i=mp1,N,5 Dx(i)=Da*Dx(i) Dx(i+1)=Da*Dx(i+1) Dx(i+2)=Da*Dx(i+2) Dx(i+3)=Da*Dx(i+3) Dx(i+4)=Da*Dx(i+4) END DO RETURN END dsolve.f0000664006604000003110000000465414521201466011646 0ustar sun00315steps**==dsolve.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE dsolve(A,Nr,Nc,Lainvb,B) IMPLICIT NONE c----------------------------------------------------------------------- c A variation Linpack's DPOSL subroutine to solve a double precision c symmetric positive definite system A*x=b c using the factors computed by DPOFA where b can have more than one c column. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c a r Packed nr by nr cholesky decompostion calculated by c DPOFA with nr(nr+1)/2 elements c b r Nr by nc matrix. On input it is b, the right hand c side of the equation and on output it is the solution c ddot r Function that calculates the inner product c diag r Temporary scalar to store A(k,k) c i i Row counter c ib i Packed row counter c ielt i Packed element counter c j i Column counter c nc i Number of columns in the b and x matrices c nr i Number of rows in the a, b and x matrices c sum r Temporary scalar to store the inner product sum c tmp r Temporary scalar c----------------------------------------------------------------------- LOGICAL Lainvb INTEGER i,ib,j,ielt,Nc,Nr DOUBLE PRECISION A(Nr*(Nr+1)/2),B(Nc,Nr),sum,diag DOUBLE PRECISION ddot c----------------------------------------------------------------------- c Solve R'w=b c----------------------------------------------------------------------- ielt=0 DO i=1,Nr diag=A(ielt+i) DO j=1,Nc sum=ddot(i-1,A(ielt+1),1,B(j,1),Nc) B(j,i)=(B(j,i)-sum)/diag END DO ielt=ielt+i END DO c----------------------------------------------------------------------- c Solve R*x=w c----------------------------------------------------------------------- IF(Lainvb)THEN DO ib=1,Nr i=Nr+1-ib diag=A(ielt) ielt=ielt-i c ------------------------------------------------------------------ DO j=1,Nc B(j,i)=B(j,i)/diag CALL daxpy(i-1,-B(j,i),A(ielt+1),1,B(j,1),Nc) END DO END DO END IF c ------------------------------------------------------------------ RETURN END dtoc.f0000664006604000003110000000313214521201466011271 0ustar sun00315stepsC Last change: BCM 23 Jul 1998 3:36 pm **==dtoc.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE dtoc(Dnum,Str,Ipos) c ----------------------------------------------------------------- IMPLICIT NONE INCLUDE 'stdio.i' INCLUDE 'savcmn.cmn' INCLUDE 'units.cmn' c ----------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c ----------------------------------------------------------------- CHARACTER Str*(*),temp*22 INTEGER Ipos,nleft DOUBLE PRECISION Dnum,d10 c ----------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c ----------------------------------------------------------------- nleft=len(Str(Ipos:)) IF(dpeq(Dnum,ZERO))then d10=0 ELSE d10=log10(abs(Dnum)) END IF c ----------------------------------------------------------------- IF(Svsize.gt.nleft)THEN WRITE(temp,Svfmt)Dnum WRITE(STDERR,1010)Dnum,nleft CALL errhdr WRITE(Mt2,1010)temp(1:Svsize),nleft 1010 FORMAT(/,' ERROR: Cannot write ',a,' in ',i3,' spaces.',/) CALL abend RETURN c ----------------------------------------------------------------- ELSE IF(d10.gt.-100d0)THEN WRITE(Str(Ipos:),Svfmt)Dnum ELSE WRITE(Str(Ipos:),Svfmt)0D0 END IF Ipos=Ipos+Svsize END IF c ----------------------------------------------------------------- RETURN END easaic.f0000664006604000003110000003522414521201466011574 0ustar sun00315stepsC Last change: BCM 19 Feb 1999 10:39 am SUBROUTINE easaic(Trnsrs,A,Nefobs,Na,Frstry,Lester,Lprtit,Lprt, & Lprtfm,Lsavlg,Lsumm,Lhiddn) IMPLICIT NONE c----------------------------------------------------------------------- c Estimate a number of regARIMA model, each with either no easter c effect or an easter effect with length 1, 8, or 15. This routine c chooses the model with the lowest value of AICC and prints out the c resulting model. c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ZERO,ONE PARAMETER(F=.false.,T=.true.,ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'adj.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' * INCLUDE 'ssprep.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c----------------------------------------------------------------------- CHARACTER eastr*(155),temp*(30),fmtsvl*(25) LOGICAL Lprt,Lprtit,Lester,argok,lhide,Lprtfm,Lsavlg,Lhiddn,lmanyE DOUBLE PRECISION A,aicbst,Trnsrs,aicno,aiceas,thiscv INTEGER Frstry,i,Na,Nefobs,begcol,ncol,easgrp,Lsumm,neachr,endlag, & ilag,ieas,ntmp,j,nbnoe,nbe,aicdf DIMENSION A(PA),Trnsrs(PLEN) c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL strinx,dpeq c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- IF(.not.Lprt)THEN lhide=Lhiddn Lhiddn=T END IF aiceas=DNOTST lmanyE=F c----------------------------------------------------------------------- c Set up format for saving AICC results to log file c----------------------------------------------------------------------- IF(Lsavlg)THEN CALL mkealb(eastr,neachr,Eastst,Easidx,Easvec(Neasvc)+Easidx,F) CALL setchr(' ',25,fmtsvl) IF (Neas.gt.0) THEN WRITE(fmtsvl,1010)MAX(neachr*Neas,4)+10+Neas-1 ELSE WRITE(fmtsvl,1010)MAX(neachr,4)+10 END IF END IF c----------------------------------------------------------------------- c Start loop through model choices c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN IF(Easvec(Neasvc).eq.99)THEN WRITE(Nform,900)'testalleaster','yes' ELSE WRITE(Nform,900)'testalleaster','no' END IF WRITE(Nform,1020)'aictest.easter.num',Neasvc-1 END IF DO i=1,Neasvc c----------------------------------------------------------------------- c See if there is an easter effect in the model c----------------------------------------------------------------------- IF(Neas.gt.0)THEN DO j=1,Neas easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(easgrp.eq.0) & easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StatCanEaster') IF(easgrp.eq.0) & easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StockEaster') c----------------------------------------------------------------------- c If easter regressor in model, delete regressor from model c----------------------------------------------------------------------- IF(easgrp.gt.0)THEN begcol=Grp(easgrp-1) ncol=Grp(easgrp)-begcol CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN END IF END DO Neas=0 END IF c----------------------------------------------------------------------- c If i > 1, add new easter regressor to model c----------------------------------------------------------------------- IF(i.gt.1.or.easgrp.gt.0)THEN lmanyE=i.eq.Neasvc.and.Easvec(Neasvc).eq.99 IF(lmanyE)THEN ieas=1 DO j=2,Neasvc-1 CALL mkealb(temp,ntmp,Eastst,Easidx,Easvec(j)+Easidx,F) IF(.not.Lfatal)THEN CALL addeas(Easvec(j)+Easidx,Easidx,Eastst) eastr(ieas:(ieas+ntmp))=temp(1:ntmp)//'+' ieas=ieas+ntmp+1 END IF IF(Lfatal)RETURN END DO eastr(ieas-1:ieas-1)=' ' neachr=ieas-2 Neas=Neasvc-2 ELSE IF(i.gt.1)THEN CALL mkealb(eastr,neachr,Eastst,Easidx,Easvec(i)+Easidx,F) IF(.not.Lfatal)THEN CALL addeas(Easvec(i)+Easidx,Easidx,Eastst) Neas=1 END IF IF(Lfatal)RETURN END IF IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Estimate model c----------------------------------------------------------------------- argok=Lautom.or.Lautox CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & CALL abend() IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0.or. & ((Lautom.or.Lautox).and.(.not.argok)))THEN Lester=T RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- IF(i.eq.1)THEN IF(Lprt)WRITE(Mt1,1030) ELSE IF(Lprt)WRITE(Mt1,1040)eastr(1:neachr) END IF IF(i.eq.Neasvc)THEN CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt, & Lprtfm) ELSE CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,F) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c See if this AICC is the smallest. If so, update value and index c of best AICC. c----------------------------------------------------------------------- IF(i.eq.1)THEN aicno=Aicc nbnoe=Nb IF(Lsavlg)WRITE(Ng,fmtsvl)'AICC(no easter)',':',Aicc IF(Lsumm.gt.0)WRITE(Nform,1050)'noeaster',Aicc ELSE IF(Lsavlg)WRITE(Ng,fmtsvl)'AICC('//eastr(1:neachr)//')',':',Aicc IF(Lsumm.gt.0)THEN IF(lmanyE)THEN WRITE(Nform,1050)'alleaster',Aicc ELSE WRITE(Nform,1060)'easter',Easvec(i),Aicc END IF END IF IF(i.eq.2)THEN aiceas=Aicc Aicind=Easvec(i) nbe=Nb ELSE IF(lmanyE)THEN IF(.not.dpeq(Pvaic,DNOTST))THEN aicdf=Nb-nbe CALL chsppf(Pvaic,aicdf,thiscv,Mt1) Rgaicd(PEAIC)=thiscv-2D0*DBLE(aicdf) END IF END IF END IF Dfaice=aiceas-Aicc IF(Dfaice.gt.Rgaicd(PEAIC))THEN Aicind=Easvec(i) aiceas=Aicc IF(.not.dpeq(Pvaic,DNOTST))nbe=Nb END IF END IF END DO c----------------------------------------------------------------------- Dfaice=aicno-aiceas IF(.not.dpeq(Pvaic,DNOTST))THEN aicdf=nbe-nbnoe CALL chsppf(Pvaic,aicdf,thiscv,Mt1) Rgaicd(PEAIC)=thiscv-2D0 END IF IF(Dfaice.gt.Rgaicd(PEAIC))THEN aicbst=aiceas ELSE aicbst=Aicno Aicind=-1 END IF c----------------------------------------------------------------------- IF(.not.Lprt)Lhiddn=lhide c----------------------------------------------------------------------- c Show Easter effect that aic prefers c----------------------------------------------------------------------- IF(Lprt)THEN IF(Aicind.lt.0)THEN IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1070)Rgaicd(PEAIC) ELSE WRITE(Mt1,1100)ONE-Pvaic,Rgaicd(PEAIC) END IF IF(Finhol)Finhol=F ELSE IF(Easidx.eq.0)THEN IF(Eastst.eq.1)THEN IF(dpeq(Pvaic,DNOTST))THEN IF(Aicind.eq.99)THEN IF(neachr.le.32)THEN WRITE(Mt1,1080)Rgaicd(PEAIC),eastr(1:neachr) ELSE IF(neachr.le.54)THEN WRITE(Mt1,1081)Rgaicd(PEAIC),eastr(1:neachr) ELSE WRITE(Mt1,1082)Rgaicd(PEAIC),eastr(1:neachr) END IF ELSE WRITE(Mt1,1090)Rgaicd(PEAIC),'Easter',Aicind END IF ELSE IF(Aicind.eq.99)THEN IF(neachr.le.32)THEN WRITE(Mt1,1110)ONE-Pvaic,Rgaicd(PEAIC),eastr(1:neachr) ELSE IF(neachr.le.54)THEN WRITE(Mt1,1111)ONE-Pvaic,Rgaicd(PEAIC),eastr(1:neachr) ELSE WRITE(Mt1,1112)ONE-Pvaic,Rgaicd(PEAIC),eastr(1:neachr) END IF ELSE WRITE(Mt1,1120)ONE-Pvaic,Rgaicd(PEAIC),'Easter',Aicind END IF END IF ELSE IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1090)Rgaicd(PEAIC),'Stock Easter',Aicind ELSE WRITE(Mt1,1120)ONE-Pvaic,Rgaicd(PEAIC),'Stock Easter',Aicind END IF END IF ELSE IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1090) & Rgaicd(PEAIC),'Statistics Canada Easter',Aicind ELSE WRITE(Mt1,1120) & ONE-Pvaic,Rgaicd(PEAIC),'Statistics Canada Easter',Aicind END IF END IF END IF END IF c----------------------------------------------------------------------- c If model with best AICC wasn't the last one estimated, redo model c estimation so the best model is returned. c----------------------------------------------------------------------- IF(aicind.lt.Easvec(Neasvc))THEN DO j=1,Neas easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(easgrp.eq.0) & easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StatCanEaster') IF(easgrp.eq.0) & easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StockEaster') begcol=Grp(easgrp-1) ncol=Grp(easgrp)-begcol CALL dlrgef(begcol,Nrxy,ncol) END DO c----------------------------------------------------------------------- c Add new Easter variable, if necessary c----------------------------------------------------------------------- IF(.not.Lfatal.and.aicind.ge.0) & CALL addeas(aicind+Easidx,Easidx,Eastst) c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Estimate model c----------------------------------------------------------------------- IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal) & CALL rgarma(T,Mxiter,Mxnlit,Lprtit,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & Lester=T END IF c----------------------------------------------------------------------- 900 FORMAT(a,': ',a) 1010 FORMAT('(1x,a,t',i3.3,',a,1x,f15.4)') 1020 FORMAT(a,':',i5) 1030 FORMAT(//,' Likelihood statistics for model without Easter') 1040 FORMAT(//,' Likelihood statistics for model with ',a) 1050 FORMAT('aictest.e.aicc.',a,': ',e29.15) 1060 FORMAT('aictest.e.aicc.',a,i2.2,': ',e29.15) 1070 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model without Easter *****') 1080 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model with ',a,t67,'*****') 1081 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model with ',/,' ***** ',a,t67,'*****') 1082 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model with ',/,' ***** ',a,' *****') 1090 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model with ',a,'[',i2,'] *****') 1100 FORMAT(//,' ***** AICC (with p-value = ',F7.5,' and aicdiff=', & F7.4,') prefers model without Easter *****') 1110 FORMAT(//,' ***** AICC (with p-value = ',F7.5,' and aicdiff=', & F7.4,') prefers model with ',a,' *****') 1111 FORMAT(//,' ***** AICC (with p-value = ',F7.5,' and aicdiff=', & F7.4,') prefers model with ',/,' ***** ',a,t67, & '*****') 1112 FORMAT(//,' ***** AICC (with p-value = ',F7.5,' and aicdiff=', & F7.4,') prefers model with ',/,' ***** ',a, & ' *****') 1120 FORMAT(//,' ***** AICC (with p-value = ',F7.5,' and aicdiff=', & F7.4,') prefers model with ',a,'[',i2,'] *****') c----------------------------------------------------------------------- RETURN END easter.f0000664006604000003110000002762414521201467011640 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 12:12 pm **==easter.f processed by SPAG 4.03F at 09:45 on 3 Oct 1994 SUBROUTINE easter(Yhat,Khol,Kkhol,Kh2,Llda,Ihol,Nfcst) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'xeastr.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION TWOHND,TEN,TWO,ZERO,TWNTY4,ONE,SVNTN,ELEVEN,FOUR, & ONEHND,TWNTY1,FOURTN,TWNTY5,SEVEN PARAMETER(TWOHND=200D0,TEN=10D0,TWO=2D0,ZERO=0D0,TWNTY4=24D0, & ONE=1D0,SVNTN=17D0,ELEVEN=11D0,FOUR=4D0,TWNTY1=21D0, & FOURTN=14D0,ONEHND=100D0,TWNTY5=25D0,SEVEN=7D0) c----------------------------------------------------------------------- DOUBLE PRECISION dif,dif1,dif2,sd28,sd915,sda,sdm,sum0,sum1,sum2, & suma,suma1,suma1e,suma2,suma2e,sumae,sumd1,sumd2 DOUBLE PRECISION sumd3,summ,summe,var28,var915,vara,varm,yl1,yl2, & smfac,mfac,mfreq,Yhat INTEGER i,Ihol,Kh2,Khol,Kkhol,kk,ll,Llda,mm,nsuaa,nsuaa1,nsuaa2, & nsum,nsum1,nsum2,nsuma,nsuma1,nsuma2,Nfcst DIMENSION Yhat(PLEN),mfac(0:34),mfreq(0:34) c----------------------------------------------------------------------- DATA(mfreq(i),i=0,34)/ & 0.0100D0,0.0150D0,0.0050D0,0.0175D0,0.0300D0,0.0325D0,0.0250D0, & 0.0300D0,0.0300D0,0.0400D0,0.0375D0,0.0350D0,0.0250D0,0.0275D0, & 0.0425D0,0.0425D0,0.0275D0,0.0300D0,0.0225D0,0.0400D0,0.0425D0, & 0.0325D0,0.0300D0,0.0350D0,0.0300D0,0.0425D0,0.0375D0,0.0350D0, & 0.0300D0,0.0250D0,0.0350D0,0.0300D0,0.0100D0,0.0100D0,0.0100D0/ c----------------------------------------------------------------------- ll=Llda IF(Lgenx)THEN CALL chkeas(Khol,Llda) IF((Ieast(1)*Ieast(2)*Ieast(3)*Ieast(4)).eq.0)THEN Ihol=0 RETURN END IF END IF mm=ll+Nfcst c kk = Khol - 12 kk=Kkhol c----------------------------------------------------------------------- C---- INVERT APRIL c----------------------------------------------------------------------- DO i=Khol,ll-1,12 Yhol(i+1)=TWOHND-Yhol(i+1) END DO c----------------------------------------------------------------------- C---- CALCULATE AVERAGES OF IRREGULARS BEFORE APRIL 2 c----------------------------------------------------------------------- summ=ZERO sum0=ZERO DO i=Khol,ll,12 IF(Xhol(i).le.TEN)THEN summ=summ+Yhol(i) sum0=sum0+ONE IF(i.lt.ll)THEN summ=summ+Yhol(i+1) sum0=sum0+ONE END IF END IF END DO summ=summ/sum0 c----------------------------------------------------------------------- C---- CALCULATE STANDARD DEVIATION OF OBS BEFORE APRIL 2 c----------------------------------------------------------------------- summe=ZERO nsum=0 varm=ZERO DO i=Khol,ll,12 IF(Xhol(i).le.TEN)THEN varm=(Yhol(i)-summ)**2+varm IF(i.lt.ll)varm=(Yhol(i+1)-summ)**2+varm END IF END DO sdm=sqrt(varm)/sqrt(sum0)*TWO c----------------------------------------------------------------------- C---- GET RID OF EXTREMES c----------------------------------------------------------------------- DO i=Khol,ll,12 IF(Xhol(i).le.TEN)THEN yl1=Yhol(i) dif=abs(Yhol(i)-summ) nsum1=1 IF(dif.ge.sdm)THEN nsum1=0 yl1=ZERO END IF yl2=ZERO nsum2=0 IF(i.lt.ll)THEN dif=abs(Yhol(i+1)-summ) IF(dif.lt.sdm)THEN yl2=Yhol(i+1) nsum2=1 END IF END IF summe=yl1+yl2+summe nsum=nsum1+nsum2+nsum END IF END DO summ=summe/nsum c----------------------------------------------------------------------- C---- CALCULATE AVERAGE AFTER APRIL 16TH c----------------------------------------------------------------------- suma=ZERO sum0=ZERO DO i=Khol,ll,12 IF(Xhol(i).gt.TWNTY4)THEN suma=suma+Yhol(i) sum0=sum0+ONE IF(i.lt.ll)THEN suma=suma+Yhol(i+1) sum0=sum0+ONE END IF END IF END DO suma=suma/sum0 c----------------------------------------------------------------------- C---- CALCULATE STANDARD DEVIATION OF OBS AFTER APRIL 16 c----------------------------------------------------------------------- sumae=ZERO nsum=0 vara=ZERO DO i=Khol,ll,12 IF(Xhol(i).gt.TWNTY4)THEN vara=(Yhol(i)-suma)**2+vara IF(i.lt.ll)vara=(Yhol(i+1)-suma)**2+vara END IF END DO sda=sqrt(vara)/sqrt(sum0)*TWO c----------------------------------------------------------------------- C---- GET RID OF EXTREMES c----------------------------------------------------------------------- DO i=Khol,ll,12 IF(Xhol(i).gt.TWNTY4)THEN yl1=Yhol(i) dif=abs(Yhol(i)-suma) nsum1=1 IF(dif.ge.sda)THEN nsum1=0 yl1=ZERO END IF yl2=ZERO nsum2=0 IF(i.lt.ll)THEN dif=abs(Yhol(i+1)-suma) IF(dif.lt.sda)THEN yl2=Yhol(i+1) nsum2=1 END IF END IF sumae=yl1+yl2+sumae nsum=nsum1+nsum2+nsum END IF END DO suma=sumae/dble(nsum) sum1=ZERO sum2=ZERO suma1=ZERO suma2=ZERO DO i=Khol,ll,12 IF((Xhol(i).gt.TEN).and.(Xhol(i).lt.TWNTY5))THEN c----------------------------------------------------------------------- C---- DO PERIOD APRIL 2 TO 8, 9 TO 15 c----------------------------------------------------------------------- IF(Xhol(i).le.SVNTN)THEN suma1=suma1+Yhol(i) sum1=sum1+ONE IF(i.lt.ll)THEN suma1=suma1+Yhol(i+1) sum1=sum1+ONE END IF ELSE suma2=suma2+Yhol(i) sum2=sum2+ONE IF(i.lt.ll)THEN suma2=suma2+Yhol(i+1) sum2=sum2+ONE END IF END IF END IF END DO suma1=suma1/sum1 suma2=suma2/sum2 DO i=Khol,mm,12 IF(Xhol(i).lt.ELEVEN)THEN Yhat(i)=summ Yhat(i+1)=TWOHND-Yhat(i) ELSE IF(Xhol(i).gt.TWNTY4)THEN Yhat(i)=suma Yhat(i+1)=TWOHND-Yhat(i) ELSE IF(Xhol(i).le.FOURTN)THEN sumd1=FOURTN-Xhol(i) Yhat(i)=suma1+sumd1*(summ-suma1)/FOUR ELSE IF(Xhol(i).le.TWNTY1)THEN sumd2=TWNTY1-Xhol(i) Yhat(i)=suma2+sumd2*(suma1-suma2)/SEVEN ELSE sumd3=TWNTY5-Xhol(i) Yhat(i)=suma+sumd3*(suma2-suma)/FOUR END IF END DO c----------------------------------------------------------------------- C---- CALCULATE STANDARD ERRS FOR PERIODS APRIL 2-8,9-15 c----------------------------------------------------------------------- var28=ZERO var915=ZERO DO i=Khol,ll,12 IF((Xhol(i).gt.TEN).and.(Xhol(i).lt.TWNTY5))THEN IF(Xhol(i).gt.SVNTN)THEN var915=(Yhol(i)-Yhat(i))**2+var915 IF(i.lt.ll)var915=(Yhol(i+1)-Yhat(i))**2+var915 ELSE var28=(Yhol(i)-Yhat(i))**2+var28 IF(i.lt.ll)var28=(Yhol(i+1)-Yhat(i))**2+var28 END IF END IF END DO sd28=sqrt(var28)/sqrt(sum1)*TWO sd915=sqrt(var915)/sqrt(sum2)*TWO nsuma=0 suma1e=ZERO nsuaa=0 suma2e=ZERO c----------------------------------------------------------------------- C---- THROW OUT EXTREMES BEYOND 2 STANDARD ERRORS FOR PERIODS APR 2-8 C---- AND APRIL 9-15 c----------------------------------------------------------------------- DO i=Khol,ll,12 yl1=Yhol(i) IF(i.lt.ll)yl2=Yhol(i+1) IF((Xhol(i).gt.TEN).and.(Xhol(i).lt.TWNTY5))THEN IF(Xhol(i).gt.SVNTN)THEN c----------------------------------------------------------------------- C---- GET RID OF EXTREMES APRIL 9-15 c----------------------------------------------------------------------- dif2=abs(Yhol(i)-Yhat(i)) IF(dif2.lt.sd915)THEN nsuaa1=1 ELSE yl1=ZERO nsuaa1=0 END IF IF(i.ge.ll)GO TO 20 dif2=abs(Yhol(i+1)-Yhat(i)) IF(dif2.ge.sd915)GO TO 20 nsuaa2=1 GO TO 30 ELSE c----------------------------------------------------------------------- C---- APRIL 2-8 c----------------------------------------------------------------------- dif1=abs(Yhol(i)-Yhat(i)) IF(dif1.lt.sd28)THEN nsuma1=1 ELSE yl1=ZERO nsuma1=0 END IF IF(i.lt.ll)THEN dif1=abs(Yhol(i+1)-Yhat(i)) IF(dif1.lt.sd28)THEN nsuma2=1 GO TO 10 END IF END IF yl2=ZERO nsuma2=0 END IF 10 suma1e=yl1+yl2+suma1e nsuma=nsuma1+nsuma2+nsuma END IF GO TO 40 20 yl2=ZERO nsuaa2=0 30 suma2e=yl1+yl2+suma2e nsuaa=nsuaa1+nsuaa2+nsuaa 40 CONTINUE END DO IF(nsuma.ne.0)suma1=suma1e/dble(nsuma) IF(nsuaa.ne.0)suma2=suma2e/dble(nsuaa) c----------------------------------------------------------------------- C---- RECALCULATE FIT FOR PERIODS APR 2-8,9-15 WITH EXTREMES REMOVED c----------------------------------------------------------------------- DO i=kk,mm,12 IF((Xhol(i).gt.TEN).and.(Xhol(i).lt.TWNTY5))THEN IF(Xhol(i).le.FOURTN)THEN sumd1=FOURTN-Xhol(i) Yhat(i)=suma1+sumd1*(summ-suma1)/FOUR Yhat(i+1)=TWOHND-Yhat(i) ELSE IF(Xhol(i).le.TWNTY1)THEN sumd2=TWNTY1-Xhol(i) Yhat(i)=suma2+sumd2*(suma1-suma2)/SEVEN Yhat(i+1)=TWOHND-Yhat(i) ELSE sumd3=TWNTY5-Xhol(i) Yhat(i)=suma+sumd3*(suma2-suma)/FOUR Yhat(i+1)=TWOHND-Yhat(i) END IF END IF END DO c----------------------------------------------------------------------- c Compute seasonal component within easter effect for March. c----------------------------------------------------------------------- smfac=ZERO c di=ZERO DO i=0,34 c di=di+ONE IF(i.le.10)THEN mfac(i)=summ ELSE IF(i.gt.10.and.i.le.14)THEN sumd1=FOURTN-i mfac(i)=(suma1+sumd1*(summ-suma1)/FOUR) ELSE IF(i.gt.14.and.i.lt.21)THEN sumd2=TWNTY1-i mfac(i)=(suma2+sumd2*(suma1-suma2)/SEVEN) ELSE IF(i.ge.21.and.i.le.24)THEN sumd3=TWNTY5-i mfac(i)=(suma+sumd3*(suma2-suma)/FOUR) ELSE mfac(i)=suma END IF smfac=smfac+(mfreq(i)*mfac(i)) END DO c----------------------------------------------------------------------- c Divide out seasonal effect from March, April values. c----------------------------------------------------------------------- DO i=kk,mm,12 Yhat(i)=(Yhat(i)*ONEHND)/smfac Yhat(i+1)=(Yhat(i+1)*ONEHND)/(TWOHND-smfac) END DO c----------------------------------------------------------------------- IF(Kh2.eq.0)RETURN IF(Xhol(Kh2).le.TEN)THEN Yhat(Kh2+1)=TWOHND-summ ELSE IF(Xhol(Kh2).gt.TEN.and.Xhol(Kh2).le.FOURTN)THEN sumd1=FOURTN-Xhol(Kh2) Yhat(Kh2+1)=TWOHND-(suma1+sumd1*(summ-suma1)/FOUR) ELSE IF(Xhol(Kh2).gt.FOURTN.and.Xhol(Kh2).le.TWNTY1)THEN sumd2=TWNTY1-Xhol(Kh2) Yhat(Kh2+1)=TWOHND-(suma2+sumd2*(suma1-suma2)/SEVEN) ELSE IF(Xhol(Kh2).gt.TWNTY1.and.Xhol(Kh2).le.TWNTY4)THEN sumd3=TWNTY5-Xhol(Kh2) Yhat(Kh2+1)=TWOHND-(suma+sumd3*(suma2-suma)/FOUR) ELSE Yhat(Kh2+1)=TWOHND-nsuma END IF Yhat(Kh2+1)=(Yhat(Kh2+1)*ONEHND)/(TWOHND-smfac) c----------------------------------------------------------------------- RETURN END editor.f0000664006604000003110000035656414521201467011653 0ustar sun00315stepsC Last change:Mar 2021 Allow LS at the end of time C previous change: BCM 20 May 1999 8:46 am SUBROUTINE editor(Sscut,Srsttl,Nsrscr,Ttlvec,Notc,Lchkin,Lcomp, & Lx11,Lseats,Lmodel,Ldata,Hvmfil,Mdlfil,Dattim, & Lgraf,Lexgrf,Readok) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine checks the options entered by the user for errors c and inconsistencies. c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ZERO,ONE,SEVEN,MINONE,TEN PARAMETER(F=.false.,T=.true.,MINONE=-1D0,ZERO=0D0,ONE=1D0, & SEVEN=7D0,TEN=10D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'ssap.prm' * INCLUDE 'rev.prm' * INCLUDE 'tfmts.cmn' INCLUDE 'model.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'work2.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'adj.cmn' INCLUDE 'agr.cmn' INCLUDE 'agrsrs.cmn' INCLUDE 'lzero.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'ssap.cmn' INCLUDE 'xrgfct.cmn' INCLUDE 'xeastr.cmn' INCLUDE 'xtrm.cmn' INCLUDE 'mdltbl.i' INCLUDE 'spctbl.i' INCLUDE 'frctbl.i' INCLUDE 'cmptbl.i' INCLUDE 'sumtab.prm' c----------------------------------------------------------------------- c Include seasonal adjustment common blocks c----------------------------------------------------------------------- INCLUDE 'title.cmn' INCLUDE 'force.cmn' c----------------------------------------------------------------------- INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' * INCLUDE 'rev.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'missng.cmn' INCLUDE 'xrgum.cmn' INCLUDE 'rho.cmn' INCLUDE 'goodob.cmn' INCLUDE 'filetb.cmn' c----------------------------------------------------------------------- c Include metadata common blocks c----------------------------------------------------------------------- INCLUDE 'metadata.prm' INCLUDE 'metadata.cmn' c----------------------------------------------------------------------- c Include arima modelling common blocks c----------------------------------------------------------------------- INCLUDE 'arima.cmn' c----------------------------------------------------------------------- c Include prior factor common blocks c----------------------------------------------------------------------- INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' c----------------------------------------------------------------------- c Include files for savelog command c----------------------------------------------------------------------- INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'mdlsvl.i' INCLUDE 'x11svl.i' INCLUDE 'spcsvl.i' INCLUDE 'dgnsvl.i' INCLUDE 'cmpsvl.i' INCLUDE 'setsvl.i' INCLUDE 'sums.i' c ------------------------------------------------------------------ c maximum length of henderson filter c ------------------------------------------------------------------ INCLUDE 'hender.prm' c ------------------------------------------------------------------ CHARACTER ctmp*(1),Ttlvec*(80),Srsttl*(PSRSCR),clen*(4),clim*(4), & fil*(PFILCR),Mdlfil*(PFILCR),line*(PFILCR),Dattim*(24), & igrptl*(PGRPCR),str*(12),perstr*(7),ostr*(3) DOUBLE PRECISION Sscut,Maxsrs,Minsrs,tmp,divfac LOGICAL allmss,argok,Readok,Lchkin,Lx11,Lmodel,Lcomp,prt,prterr, & Hvmfil,lexsum,sav,Ldata,prtwrn,Lgraf,Lexgrf,lerr,lzero, & tdfneg,alltdf,Lseats,lsadj,leaic0 INTEGER ktd,Notc,i,itst,iyrs,nsp,j,Nsrscr,ip0,ip1,ip2,rgmgrp, & nyr,nchr,igrp,ipos,begcol,endcol,ndtchr,iper, & ndays,nspc,rtype,iusr,icol,rhol,idate,klm,klq,kly,kstd, & adjold,ntd,nusr,nseas,nbeg,otlgrp,frstmd,endmd,nobxot, & fhnote,nmiss,ndata,nwarn,id0,smpday,istock,ilag,endlag, & typidx,begdat,enddat,n1,n2,nostr,nelim c ------------------------------------------------------------------ DIMENSION Sscut(5),Ttlvec(10),idate(2),ndays(PEASTR),allmss(PSP), & nmiss(PSP),ndata(PSP) c ------------------------------------------------------------------ DOUBLE PRECISION setcv,setcvl INTEGER strinx,ctoi,nblank LOGICAL istrue,dpeq EXTERNAL setcv,strinx,istrue,ctoi,dpeq,nblank,setcvl c----------------------------------------------------------------------- COMMON /maxmin/ Maxsrs,Minsrs c----------------------------------------------------------------------- CHARACTER AICDIC*49 INTEGER aicidx,aicptr,PAICTD PARAMETER(PAICTD=6) DIMENSION aicptr(0:PAICTD) PARAMETER(AICDIC='tdtdnolpyeartdstocktd1coeftd1nolpyeartdstock1coe &f') c----------------------------------------------------------------------- c add local delotl vector to store the outlier which is beyond model c span and needed to be deleted in this routine c----------------------------------------------------------------------- CHARACTER XAICDC*28 INTEGER xaicpt,PXTAIC,delotl,ndelotl PARAMETER(PXTAIC=6) DIMENSION xaicpt(0:PXTAIC),delotl(PB) PARAMETER(XAICDC='tdtdstocktd1coeftdstock1coef') c ------------------------------------------------------------------ DATA aicptr / 1,3,13,20,27,38,50 / DATA xaicpt / 1,3,10,17,17,17,29 / c----------------------------------------------------------------------- INCLUDE 'sumtab.var' c----------------------------------------------------------------------- c Check series, regression variables, model and seasonal adjustment c options. Set default values. c----------------------------------------------------------------------- Kfmt=0 Ny=Sp Neasvx=0 Neasvc=0 fhnote=STDERR ndelotl=0 IF(Lquiet)fhnote=0 lsadj=Lx11.or.Lseats IF(Lx11)THEN tX11=tX11+1 ELSE IF(Lseats)THEN tSeats=tSeats+1 ELSE tNSA=tNSA+1 END IF c----------------------------------------------------------------------- IF(dpeq(Traicd,DNOTST))THEN IF(Sp.eq.4.or.Sp.eq.12)THEN Traicd=-2D0 ELSE Traicd=ZERO END IF END IF c----------------------------------------------------------------------- c Check to see if number of observations is > than 15 years. If so, c set number of backcasts to zero c----------------------------------------------------------------------- IF(Nbcst.gt.0)THEN IF(Ldestm)THEN CALL dfdate(Begmdl,Begspn,Sp,nbeg) IF(nbeg.gt.0)THEN CALL writln('WARNING: The program will not generate backcasts f &or series with a',fhnote,Mt2,T) CALL writln(' modelspan that starts after the start of &the span.',fhnote,Mt2,F) Nbcst=0 IF(Nbcstx.gt.0)Nbcstx=0 END IF END IF * IF(Nspobs.gt.(15*Sp).and.Nbcst.gt.0)THEN * CALL writln('WARNING: The program will not generate backcasts fo * &r series longer than',fhnote,Mt2,T) * CALL writln(' 15 years.',fhnote,Mt2,F) * Nbcst=0 * IF(Nbcstx.gt.0)Nbcstx=0 * END IF IF(Lseats)THEN CALL writln('WARNING: The program will not generate backcasts fo &r use with SEATS',fhnote,Mt2,T) CALL writln(' seasonal adjustments.',fhnote,Mt2,F) Nbcst=0 IF(Nbcstx.gt.0)Nbcstx=0 END IF END IF Length=Nspobs c----------------------------------------------------------------------- c calculate beginning date of backcasts c ------------------------------------------------------------------ CALL addate(Begspn,Sp,-Nbcst,Begbak) c ------------------------------------------------------------------ c if first month of backcasts not = 1, increase number of backcasts c to accomodate. c ------------------------------------------------------------------ IF(Begbak(MO).gt.1)THEN Nbcst2=Nbcst+Begbak(MO)-1 Begbk2(MO)=1 ELSE Nbcst2=Nbcst Begbk2(MO)=Begbak(MO) END IF Begbk2(YR)=Begbak(YR) c----------------------------------------------------------------------- c provide "pointers" for X-11 to tell where backcasts, data, c forecasts begin and end. c----------------------------------------------------------------------- CALL dfdate(Begspn,Begsrs,Sp,Frstsy) Frstsy=Frstsy+1 Nomnfy=Nobs-Frstsy+1 Nfdrp=Nfcst IF((.not.lsadj).and.Fctdrp.gt.0)Nfdrp=max(0,Nfcst-Fctdrp) Nobspf=min(Nspobs+Nfdrp,Nobs-Frstsy+1) Nofpob=Nspobs+Nfdrp Nbfpob=Nspobs+Nfdrp+Nbcst Lsp=1 CALL setxpt(Nfdrp,lsadj,Fctdrp) IF(Iagr.eq.3)CALL agrxpt(Begspn,Sp) Lyr=Begspn(1) Lstyr=Endspn(1) Lstmo=Endspn(2) CALL dfdate(Begmdl,Begsrs,Sp,frstmd) CALL dfdate(Endmdl,Begsrs,Sp,endmd) frstmd=frstmd+1 endmd=endmd+1 c----------------------------------------------------------------------- c Check to see if there is are outliers outside the model span. c----------------------------------------------------------------------- IF(Nb.gt.0)THEN DO icol=1,Nb rtype=Rgvrtp(icol) IF(rtype.eq.PRSQLS.or.rtype.eq.PRSQAO)rtype=rtype-100 IF((rtype.eq.PRGTLS).or.(rtype.eq.PRGTAO).or. & (rtype.eq.PRGTTC).or.(rtype.eq.PRGTRP).or. & (rtype.eq.PRGTQI).or.(rtype.eq.PRGTQD).or. & (rtype.eq.PRGTMV).or.(rtype.eq.PRGTSO).or. & (rtype.eq.PRGTTL))THEN CALL getstr(Colttl,Colptr,Nb,icol,igrptl,nchr) CALL rdotlr(igrptl(1:nchr),Begsrs,Sp,typidx,begdat,enddat, & argok) c----------------------------------------------------------------------- c Check to see if there is an LS outlier at the end of the model span. c and save the regressions beyond model span points (updated on 6/7/19) c----------------------------------------------------------------------- IF(rtype.eq.PRGTLS.or.rtype.eq.PRGTTL)THEN IF(rtype.eq.PRGTLS)THEN ostr='LS ' nostr=2 ELSE ostr='TLS' nostr=3 END IF IF(begdat.eq.endmd.and.rtype.eq.PRGTTL)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: '//ostr(1:nostr)//' regressor ('// & igrptl(1:nchr)//') not within model span.', & fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) ELSE IF (begdat.gt.endmd)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: '//ostr(1:nostr)//' regressor ('// & igrptl(1:nchr)//') not within model span.', & fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) ELSE IF(begdat.lt.frstmd+1)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: Beginning of '//ostr(1:nostr)// & ' regressor ('//igrptl(1:nchr)// & ') not within model span.',fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) END IF c----------------------------------------------------------------------- c Check to see if there is an AO outlier beyond the end of the c model span. c----------------------------------------------------------------------- ELSE IF(rtype.eq.PRGTAO.or.rtype.eq.PRGTMV)THEN IF(rtype.eq.PRGTAO)THEN ostr='AO ' nostr=2 ELSE ostr='MV ' nostr=2 END IF IF (begdat.gt.endmd.or.begdat.lt.frstmd)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: '//ostr(1:nostr)//' regressor ('// & igrptl(1:nchr)//') not within model span.', & fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) END IF c----------------------------------------------------------------------- c Check to see if there is a TC outlier beyond the end of the c model span. c----------------------------------------------------------------------- ELSE IF(rtype.eq.PRGTTC)THEN IF (begdat.gt.endmd.or.begdat.lt.frstmd)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: TC regressor ('//igrptl(1:nchr)// & ') not within model span.',fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) END IF c----------------------------------------------------------------------- c Check to see if there is a SO outlier beyond the end of the c model span. c----------------------------------------------------------------------- ELSE IF(rtype.eq.PRGTSO)THEN IF (begdat.gt.endmd.or.begdat.lt.frstmd)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: SO regressor ('//igrptl(1:nchr)// & ') not within model span.',fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) END IF c----------------------------------------------------------------------- c Check to see if there is a ramp outlier beyond the end of the c model span. c----------------------------------------------------------------------- ELSE IF((rtype.eq.PRGTRP).or.(rtype.eq.PRGTQI).or. & (rtype.eq.PRGTQD))THEN IF(enddat.gt.endmd)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: End of ramp ('//igrptl(1:nchr)// & ') not within model span.',fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) c ------------------------------------------------------------------ ELSE IF(begdat.lt.frstmd)THEN ndelotl = ndelotl +1 delotl(ndelotl) = icol CALL writln('WARNING: Beginning of ramp ('//igrptl(1:nchr)// & ') not within model span.',fhnote,Mt2,T) CALL writln(' Change the regARIMA model and rerun.', & fhnote,Mt2,F) END IF END IF END IF END DO c----------------------------------------------------------------------- c delete all the regressions beyond model span points c----------------------------------------------------------------------- IF (ndelotl.gt.0) then do i=1,ndelotl CALL dlrgef(delotl(i),Nrxy,1) do j=i+1,ndelotl delotl(j)=delotl(j) -1 end do end do END IF END IF c----------------------------------------------------------------------- c For seats seasonal adjustments, check to see if forecasts need to c be extended, if so, reset pointers c----------------------------------------------------------------------- IF(Lseats)THEN ip1=max(12,3*Sp) IF(Nfcst.lt.ip1)THEN Posffc=Posffc-Nfcst+ip1 Nfcst=ip1 Nfdrp=Nfcst Nobspf=min(Nspobs+Nfdrp,Nobs-Frstsy+1) Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst CALL setxpt(Nfdrp,Lseats,Fctdrp) ip2=1 CALL itoc(ip1,clen,ip2) IF(Lfatal)RETURN CALL writln('NOTE: A longer forecast horizon is required by the &SEATS signal extraction',Mt1,Mt2,T) CALL writln(' procedure, so the number of forecasts generat &ed by this run has',Mt1,Mt2,F) CALL writln(' been changed to '//clen(1:(ip2-1))//'.', & Mt1,Mt2,F) END IF c----------------------------------------------------------------------- c For seats seasonal adjustments, check to see if seasonal c overdifferencing is tested for in the automatic model identification c proceedings, if so, turn off the test c----------------------------------------------------------------------- IF(Lsovdf)THEN Lsovdf=F CALL writln('NOTE: Since SEATS signal extraction is selected,'// & ' the seasonal overdifferencing test ',Mt1,Mt2,T) CALL writln(' of the automatic model identification '// & 'procedure is turned off.',Mt1,Mt2,F) END IF END IF c----------------------------------------------------------------------- c --- Set up variables for sliding spans analysis c----------------------------------------------------------------------- L0=1 Ly0=Lyr Itd=0 Ihol=0 c----------------------------------------------------------------------- c Add constant specified in transform spec (added by BCM, July 2005) c----------------------------------------------------------------------- IF(.not.dpeq(Cnstnt,DNOTST))THEN DO i=1,Nobs IF(.not.(dpeq(Y(i),Mvcode)))Y(i)=Y(i)+Cnstnt END DO END IF c----------------------------------------------------------------------- c Check for missing values c----------------------------------------------------------------------- Maxsrs=Y(Frstsy) Minsrs=Y(Frstsy) lerr=T lzero=T CALL setlg(T,PSP,allmss) CALL setint(0,PSP,nmiss) CALL setint(0,PSP,ndata) ip0=Frstsy+Nspobs-1 DO i=Frstsy,ip0 CALL addate(Begsrs,Sp,i-1,idate) CALL wrtdat(idate,Sp,str,ndtchr) id0=idate(MO) IF(id0.eq.0)id0=1 IF(dpeq(Y(i),Mvcode))THEN lzero=F IF(.not.Missng)Missng=T Y(i)=Mvval IF(i.ge.frstmd.and.i.le.endmd)THEN c----------------------------------------------------------------------- c Create missing value regressor c----------------------------------------------------------------------- c CALL addate(Begbak,Sp,i-1,idate) IF(.not.Lfatal)CALL adrgef(DNOTST,'MV'//str(1:ndtchr), & 'Missing Value',PRGTMV,F,F) IF(Lfatal)RETURN nmiss(id0)=nmiss(id0)+1 ELSE CALL writln('ERROR: Missing value code found outside of model s &pan, where missing value',STDERR,Mt2,T) CALL writln(' cannot be replaced.',STDERR,Mt2,F) Readok=F lerr=F END IF ELSE IF(i.ge.frstmd.and.i.le.endmd)THEN allmss(id0)=F ndata(id0)=ndata(id0)+1 END IF IF(.not.dpeq(Y(i),ZERO))lzero=F c----------------------------------------------------------------------- c Determine largest and smallest value of the series c----------------------------------------------------------------------- IF(Maxsrs.lt.Y(i))Maxsrs=Y(i) IF(Minsrs.gt.Y(i))Minsrs=Y(i) c----------------------------------------------------------------------- c Test to see if all data is positive c----------------------------------------------------------------------- IF(Y(i).le.ZERO.and.lerr)THEN IF(Fcntyp.eq.0)THEN CALL writln('WARNING: Automatic transformation selection canno &t be done on a',fhnote,Mt2,T) CALL writln(' series with zero or negative values.', & fhnote,Mt2,F) lerr=F Muladd=1 Fcntyp=4 Lam=1D0 ELSE IF(Lx11.and.Muladd.ne.1)THEN IF(Psuadd)THEN IF(Y(i).lt.ZERO)THEN CALL writln('ERROR: Pseudo-additive seasonal adjustment cann &ot be done on a',STDERR,Mt2,T) CALL writln(' series with negative values.',STDERR, & Mt2,F) Readok=F lerr=F END IF ELSE CALL writln('ERROR: Multiplicative or log-additive seasonal a &djustment cannot be',STDERR,Mt2,T) CALL writln(' done with a series with zero or negative &values.',STDERR,Mt2,F) Readok=F lerr=F END IF END IF END IF END IF END DO IF(.not.Lx11.and.(Fcntyp.eq.4.or.Fcntyp.eq.0.or.dpeq(Lam,1D0))) & Muladd=1 c----------------------------------------------------------------------- c perform checks for the number of missing data codes read into the c program. c----------------------------------------------------------------------- IF(Missng)THEN IF(istrue(allmss,1,Sp))THEN IF(Sp.eq.12)THEN CALL writln('ERROR: All data values for at least one month are &missing values.',STDERR,Mt2,T) ELSE IF(Sp.eq.4)THEN CALL writln('ERROR: All data values for at least one quarter ar &e missing values.',STDERR,Mt2,T) ELSE CALL writln('ERROR: All data values for at least one period are & missing values.',STDERR,Mt2,T) END IF CALL writln(' regARIMA model cannot be estimated.', & STDERR,Mt2,F) Readok=F Muladd=1 ELSE nwarn=0 DO i=1,Sp IF(nmiss(i).gt.ndata(i))nwarn=nwarn+1 END DO IF(nwarn.gt.0)THEN IF(Sp.eq.12)THEN IF(.not.Lquiet) & WRITE(STDERR,1090)nwarn,'months','month',PRGNAM WRITE(Mt2,1090)nwarn,'months','month',PRGNAM ELSE IF(Sp.eq.4)THEN IF(.not.Lquiet) & WRITE(STDERR,1090)nwarn,'quarters','quarter',PRGNAM WRITE(Mt2,1090)nwarn,'quarters','quarter',PRGNAM ELSE IF(.not.Lquiet) & WRITE(STDERR,1090)nwarn,'periods','period',PRGNAM WRITE(Mt2,1090)nwarn,'periods','period',PRGNAM END IF END IF END IF END IF c----------------------------------------------------------------------- IF(lzero.and.Kfulsm.ne.1)THEN CALL writln('ERROR: All data values read into '//PRGNAM// & ' are equal to zero.',STDERR,Mt2,T) Readok=F ELSE IF(dpeq(Maxsrs,Minsrs))THEN CALL writln('WARNING: All data values read into '//PRGNAM// & ' are the same.',fhnote,Mt2,T) Same=T ELSE Same=F END IF c----------------------------------------------------------------------- c Check to see if data exists beyond the end of the span. If so, c see if there are missing value codes or negative numbers that may c occur in the forecast period. c----------------------------------------------------------------------- Lmvaft=F Ln0aft=F IF(Nobs.gt.ip0.and.Nfcst.gt.0)THEN ip1=ip0+1 ip2=min(Nobs,ip0+Nfcst) DO i=ip1,ip2 IF(dpeq(Y(i),Mvval))THEN Lmvaft=T ELSE IF(dpeq(Y(i),ZERO).or.Y(i).lt.ZERO)THEN IF(.not.(Fcntyp.eq.4.OR.dpeq(Lam,1D0)))Ln0aft=T END IF END DO IF((Lmvaft.or.Ln0aft).and.Fcntyp.gt.0)THEN CALL writln('NOTE: At least one value that is either less than o &r equal to zero or',fhnote,Mt2,T) CALL writln(' equal to the missing value code was found aft &er the span of data',fhnote,Mt2,F) CALL writln(' to be analyzed, but within the time frame of &the forecasts',fhnote,Mt2,F) CALL writln(' generated by the regARIMA model.', & fhnote,Mt2,F) CALL writln(' In this situation, the forecast output will n &ot include a',fhnote,Mt2,T) IF(Fcntyp.eq.4.OR.dpeq(Lam,1D0))THEN CALL writln(' comparison of the forecasts with the corresp &onding values of the',fhnote,Mt2,F) CALL writln(' original series.',fhnote,Mt2,F) ELSE CALL writln(' comparison of the transformed forecasts with & the corresponding',fhnote,Mt2,F) CALL writln(' values of the transformed original series.', & fhnote,Mt2,F) END IF END IF END IF c----------------------------------------------------------------------- C --- Adjust the series using DIVPOWER, if specified c---------------------------------------------------------------------- IF (.NOT.(Divpwr.eq.NOTSET)) THEN divfac=ONE IF (Divpwr.lt.0) THEN DO i = Divpwr, -1 divfac=divfac/TEN END DO else DO i = 1, Divpwr divfac=divfac*TEN END DO END IF DO i = 1, PLEN IF(.NOT.(dpeq(Y(i),Mvval).or.dpeq(Y(i),DNOTST)))Y(i)=Y(i)/divfac END DO Maxsrs=Maxsrs/divfac Minsrs=Minsrs/divfac END IF c----------------------------------------------------------------------- C --- This subroutine generates the formats for subroutine tables. c---------------------------------------------------------------------- CALL tfmts(Sp,Kdec,Maxsrs,Minsrs,Muladd,Lwdprt,Readok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check to see if modelling, trading day options are correct for c missing value regressors. c----------------------------------------------------------------------- IF(Missng)THEN IF(.not.Lmodel)THEN CALL writln('ERROR: Must specify a regARIMA model when the Missi &ng Value procedure is used.',STDERR,Mt2,T) Readok=F ELSE IF(Ixreg.eq.2)THEN CALL writln('ERROR: Cannot specify irregular component regressio &n with a',STDERR,Mt2,T) CALL writln(' regARIMA model when the Missing Value proced &ure is used.',STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- C --- If missing values are in series and the missing value code c used is small enough to be printed out, replace with a number c that will be larger than the table print format c---------------------------------------------------------------------- * tmp=10D0**(Tblwid+1) * IF(Mvval.lt.tmp)THEN * DO i=Frstsy,Frstsy+Nspobs-1 * IF(dpeq(Y(i),Mvval))Y(i)=tmp * END DO * Mvval=tmp * END IF END IF c----------------------------------------------------------------------- c Test to see if length of the forecast extended series exceeds c program limit. c----------------------------------------------------------------------- IF(Posffc.gt.PLEN)THEN ip1=1 ip2=1 CALL itoc(Posffc,clen,ip1) IF(.not.Lfatal)CALL itoc(PLEN,clim,ip2) IF(Lfatal)RETURN CALL writln('ERROR: Length of forecast augmented series ('// & clen(1:(ip1-1))//') exceeds program',STDERR,Mt2,T) CALL writln(' limit ('//clim(1:(ip2-1))//'). See '// & LIMSEC//' of the '//PRGNAM//' '//DOCNAM//'.', & STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c Test to see if the number of years spanned by the forecast and c backcast extended series exceeds program limit. c----------------------------------------------------------------------- nyr=Posffc/Ny IF(mod(Posffc,Ny).gt.0)nyr=nyr+1 IF(nyr.gt.PYRS.and.lsadj)THEN ip1=1 ip2=1 CALL itoc(nyr,clen,ip1) IF(.not.Lfatal)CALL itoc(PYRS,clim,ip2) IF(Lfatal)RETURN CALL writln('ERROR: Number of years spanned by the forecast augme &nted series ('//clen(1:(ip1-1))//')',STDERR,Mt2,T) CALL writln(' exceeds program limit ('//clim(1:(ip2-1))// & '). See '//LIMSEC//' of the '//PRGNAM,STDERR,Mt2,F) CALL writln(' '//DOCNAM//'.',STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c Test to see if series is too short c----------------------------------------------------------------------- itst=3*Ny IF(Length.lt.itst)THEN CALL writln('ERROR: Series to be modelled and/or seasonally adjus &ted must have at',STDERR,Mt2,T) CALL writln(' least 3 complete years of data.',STDERR, & Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c Check to see if user-defined prior adjustments are specified when c an automatic transformation adjustment is used. c----------------------------------------------------------------------- IF(Fcntyp.eq.0)THEN IF(Nprtyp.gt.0.OR.(Priadj.gt.1.AND.(.not.Picktd)))THEN CALL writln('ERROR: Cannot specify prior adjustment factors when & automatic',STDERR,Mt2,T) CALL writln(' transformation selection is used.',STDERR, & Mt2,F) IF(Nprtyp.gt.0)Nprtyp=0 IF(Priadj.gt.1)Priadj=1 Readok=F END IF c----------------------------------------------------------------------- c Check to see if fixed regressors are specified when an automatic c transformation selection is requested. (BCM June 2007) c----------------------------------------------------------------------- IF(Iregfx.ge.2)THEN CALL writln('ERROR: Cannot specify fixed regression coefficients & when automatic',STDERR,Mt2,T) CALL writln(' transformation selection is used.',STDERR, & Mt2,F) Readok=F END IF c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- c Generate prior adjustment factor to be used to adjust series. c----------------------------------------------------------------------- IF(Nprtyp.gt.0)THEN DO i=1,Nprtyp IF(Muladd.eq.1.and.Percnt(i).eq.NOTSET)THEN Percnt(i)=2 Adjmod=2 ELSE IF(Percnt(i).eq.NOTSET)Percnt(i)=0 IF((Muladd.eq.1.and.Lx11).and.Percnt(i).lt.2)THEN CALL writln('ERROR: Additive seasonal adjustment will not be p &erformed when the',STDERR,Mt2,T) CALL writln( &' prior adjustment factors are expressed as percentages.', & STDERR,Mt2,F) Readok=F ELSE Adjmod=1 IF(Percnt(i).eq.2)Adjmod=2 END IF END IF IF(i.eq.1)THEN adjold=Adjmod ELSE IF(Readok)THEN IF(Adjmod.eq.adjold)THEN adjold=Adjmod ELSE CALL writln('ERROR: Cannot combine prior adjustment factors ex &pressed as differences',STDERR,Mt2,T) CALL writln(' with prior adjustment factors expressed as & percentages.',STDERR,Mt2,F) Readok=F END IF END IF END DO ELSE IF(Muladd.eq.1)THEN Adjmod=2 ELSE Adjmod=1 END IF END IF c----------------------------------------------------------------------- c Check to see if leap year prior adjustments are specified with the c proper transformation/seasonal adjustment mode. c----------------------------------------------------------------------- IF(Priadj.eq.4)THEN IF(.not.dpeq(Lam,ZERO))THEN CALL writln('ERROR: Leap Year prior adjustment (adjust=lpyear) c &an only be specified',STDERR,Mt2,T) CALL writln(' when a log transformation is specified in th &e transform spec.',STDERR,Mt2,F) Readok=F ELSE IF(Muladd.eq.1.and.Lx11)THEN CALL writln('ERROR: Leap Year prior adjustment (adjust=lpyear) c &an only be specified',STDERR,Mt2,T) CALL writln(' when a multiplicative seasonal adjustment is &specified in the x11 spec.',STDERR,Mt2,F) Readok=F END IF ELSE IF (Priadj.gt.1) THEN IF(.not.dpeq(Lam,ZERO))THEN IF(Priadj.eq.2)THEN CALL writln('ERROR: Length of month prior adjustment (adjust=lo &m) can only be specified',STDERR,Mt2,T) ELSE CALL writln('ERROR: Length of quarter prior adjustment (adjust= &loq) can only be specified',STDERR,Mt2,T) END IF CALL writln(' when a log transformation is specified in th &e transform spec.',STDERR,Mt2,F) Readok=F ELSE IF(Muladd.eq.1.and.Lx11)THEN IF(Priadj.eq.2)THEN CALL writln('ERROR: Length of month prior adjustment (adjust=lo &m) cannot be specified',STDERR,Mt2,T) ELSE CALL writln('ERROR: Length of quarter prior adjustment (adjust= &loq) cannot be specified',STDERR,Mt2,T) END IF CALL writln(' when an additive seasonal adjustment is spec &ified in the x11 spec.',STDERR,Mt2,F) Readok=F END IF END IF c----------------------------------------------------------------------- IF(Axrgtd)THEN IF(Priadj.gt.1)THEN IF(Priadj.eq.2)THEN CALL writln('ERROR: Length of month prior adjustment (adjust=lo &m) cannot be specified',STDERR,Mt2,T) ELSE IF(Priadj.eq.3)THEN CALL writln('ERROR: Length of quarter prior adjustment (adjust= &loq) cannot be specified',STDERR,Mt2,T) ELSE CALL writln('ERROR: Leap year prior adjustment (adjust=lpyear) &cannot be specified',STDERR,Mt2,T) END IF CALL writln(' when td or td1coef is specified in the varia &bles argument of the',STDERR,Mt2,F) CALL writln(' x11regression spec.',STDERR,Mt2,F) Priadj=1 Readok=F END IF IF(Picktd)Picktd=F END IF c----------------------------------------------------------------------- CALL adjsrs(Nspobs,Sp,Begspn,Fctdrp,Nfcst,Nbcst,Readok) IF(Lfatal)RETURN Setpri=Pos1bk c----------------------------------------------------------------------- c Turn off print options for spectrum tables if not a monthly series c----------------------------------------------------------------------- IF(Ny.ne.12)THEN DO i=LSPCS0,LSPS0C IF(Prttab(i))Prttab(i)=F IF(Savtab(i))Savtab(i)=F END DO IF(Prttab(LSPCTP))Prttab(LSPCTP)=F IF(Savtab(LSPCTP))Savtab(LSPCTP)=F IF(Prttab(LSPCQC))Prttab(LSPCQC)=F IF(Savtab(LSPCQC))Savtab(LSPCQC)=F c----------------------------------------------------------------------- c check savelog c----------------------------------------------------------------------- IF(Svltab(LSLSPK))Svltab(LSLSPK)=F IF(Svltab(LSLDSP))Svltab(LSLDSP)=F IF(Svltab(LSLISP))Svltab(LSLISP)=F IF(Svltab(LSLTPK))Svltab(LSLTPK)=F IF(Svltab(LSLDTP))Svltab(LSLDTP)=F IF(Svltab(LSLITP))Svltab(LSLITP)=F IF(Svltab(LSLQCH))Svltab(LSLQCH)=F c----------------------------------------------------------------------- c check if Lqchk if true - if so, print warning message and set c Lqchk=F c----------------------------------------------------------------------- IF(Lqchk)THEN CALL writln('WARNING: Can only use qcheck option with '// & 'monthly series.',fhnote,Mt2,T) Lqchk=F END IF c ELSE c IF(Prttab(LSPCTP).or.Svltab(LSLTPK).or.Svltab(LSLDTP).or. c & Svltab(LSLDTP))THEN c END IF END IF c----------------------------------------------------------------------- c check to see if table D11A (final SA series with adjusted yearly c totals) and the rounded seasonally adjusted series are to be c printed out c----------------------------------------------------------------------- IF(.not.Lrndsa)THEN IF(Prttab(LFCRND))Prttab(LFCRND)=F IF(Prttab(LCPRND))Prttab(LCPRND)=F END IF IF(Iyrt.le.0)THEN IF(Prttab(LFCSAA))Prttab(LFCSAA)=F IF(Prttab(LCPSAA))Prttab(LCPSAA)=F END IF c----------------------------------------------------------------------- c IF Mxcklg = 0 and Lsumm > 0, set Mxcklg so that the diagnostics c can be generated, but turn off the printout for the tables in the c check spec, as the spec was not specified by the user. c BCM, August 30, 2006 c----------------------------------------------------------------------- IF(Lmodel)THEN IF(Lsumm.gt.0.and.Mxcklg.eq.0)THEN Mxcklg=2*Sp IF(Prttab(LCKACF))Prttab(LCKACF)=F IF(Prttab(LCKACF+1))Prttab(LCKACF+1)=F IF(Prttab(LCKAC2))Prttab(LCKAC2)=F IF(Prttab(LCKAC2+1))Prttab(LCKAC2+1)=F IF(Prttab(LCKHST))Prttab(LCKHST)=F IF(Prttab(LCKNRM))Prttab(LCKNRM)=F * IF(Prttab(LSPCRS))Prttab(LSPCRS)=F END IF c----------------------------------------------------------------------- c Make backup copy of initial ARMA coefficients c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Ap1(ilag)=Arimap(ilag) END DO END IF END IF c----------------------------------------------------------------------- c Check to see if any tables are being printed out or saved c----------------------------------------------------------------------- IF(.not.Ldata.and.Savtab(LSRSIN))Savtab(LSRSIN)=F prt=istrue(Prttab,1,NTBL) sav=istrue(Savtab,1,NTBL) IF(.not.(prt.or.sav))THEN CALL writln('ERROR: No tables were specified for printing or savi &ng.',STDERR,Mt2,T) Readok=F END IF c----------------------------------------------------------------------- c if ktd > 0, model includes trading day regressors. c----------------------------------------------------------------------- ktd=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(ktd.eq.0)ktd=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Trading Day') klm=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Length-of-Month') klq=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Length-of-Quarter') kly=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Leap Year') kstd=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Stock Trading Day') IF(kstd.eq.0)kstd=strinx(T,Grpttx,Gpxptr,1,Ngrptx, & '1-Coefficient Stock Trading Day') IF((ktd.eq.0.or.klm.eq.0.or.klq.eq.0.or.kly.eq.0.or.kstd.eq.0) & .and.Ncusrx.gt.0)THEN i=1 DO WHILE (i.le.Ncusrx) IF(Usrtyp(i).eq.PRGUTD.and.ktd.eq.0)ktd=-i IF(Usrtyp(i).eq.PRGULM.and.klm.eq.0)klm=-i IF(Usrtyp(i).eq.PRGULQ.and.klq.eq.0)klq=-i IF(Usrtyp(i).eq.PRGULY.and.kly.eq.0)kly=-i IF((Isrflw.eq.1.and.Usrtyp(i).eq.PRGUTD).and.kstd.eq.0)kstd=-i i=i+1 END DO END IF IF(ktd.lt.0.or.kstd.lt.0)THEN c----------------------------------------------------------------------- c If user-defined trading day regressors found, set AIC test to c test for user-defined regressors rather than conventional trading c day. c----------------------------------------------------------------------- IF(Itdtst.gt.0)THEN Itdtst=0 Luser=T END IF c ------------------------------------------------------------------ c If trading day regressor not specified, check to see if trading c day regressors can be generated for this run. c ------------------------------------------------------------------ ELSE IF(ktd.eq.0.and.Itdtst.gt.0)THEN IF((Itdtst.eq.3.or.Itdtst.eq.6).and.Sp.ne.12)THEN CALL writln('ERROR: Need monthly data to perform aictest for sto &ck trading day.',STDERR,Mt2,T) Readok=F ELSE IF(Sp.ne.12.and.Sp.ne.4)THEN CALL writln('ERROR: Need monthly or quarterly data to perform ai &ctest for trading day.',STDERR,Mt2,T) Readok=F ELSE IF(Begsrs(YR).lt.1776)THEN CALL writln('ERROR: Cannot generate trading variables for aictes &t before 1776.',Mt2,STDERR,T) CALL writln(' Either specify a starting date, or include t &he century in the',Mt2,STDERR,F) CALL writln(' start or modelspan arguments of the series s &pec.',Mt2,STDERR,F) Readok=F END IF END IF c----------------------------------------------------------------------- IF(Isrflw.eq.1)THEN IF(Itdtst.eq.3)THEN WRITE(STDERR,3000)'stock trading day','flow' WRITE(Mt2,3000)'stock trading day','flow' ELSE IF(Itdtst.eq.6)THEN WRITE(STDERR,3000)'stock 1-coefficient trading day','flow' WRITE(Mt2,3000)'stock 1-coefficient trading day','flow' END IF ELSE IF(Isrflw.eq.2)THEN IF(Itdtst.eq.2)THEN WRITE(STDERR,3000)'flow trading day','stock' WRITE(Mt2,3000)'flow trading day','stock' ELSE IF(Itdtst.eq.4.or.Itdtst.eq.5)THEN WRITE(STDERR,3000)'flow 1-coefficient trading day','stock' WRITE(Mt2,3000)'flow 1-coefficient trading day','stock' END IF END IF c----------------------------------------------------------------------- c If automatic trading day selection is performed, make sure that c if a trading day adjustment was specified in the variables c argument, it matches what was entered in the aictest argument. c----------------------------------------------------------------------- IF(Itdtst.gt.0.and.Ngrp.gt.0)THEN prterr=F DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF((Rgvrtp(begcol).eq.PRGTST.or.Rgvrtp(begcol).eq.PRG1ST.or. & Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRR1ST.or. & Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRA1ST).and. & (.not.prterr))THEN aicidx=3 IF(begcol.eq.endcol)aicidx=6 c----------------------------------------------------------------------- c See if td specified in aictest c----------------------------------------------------------------------- IF(Itdtst.eq.1)THEN IF(aicidx.gt.1)Itdtst=aicidx ELSE IF(Itdtst.ne.aicidx)THEN CALL getstr(AICDIC,aicptr,PAICTD,aicidx,str,nchr) IF(Lfatal)RETURN WRITE(STDERR,2000)str(1:nchr) WRITE(Mt2,2000)str(1:nchr) CALL getstr(AICDIC,aicptr,PAICTD,Itdtst,str,nchr) IF(Lfatal)RETURN WRITE(STDERR,2001)str(1:nchr) WRITE(Mt2,2001)str(1:nchr) CALL writln( & ' The type of trading day regressor must agree.', & STDERR,Mt2,F) Readok=F prterr=T END IF c----------------------------------------------------------------------- c Set date for stock trading day equal to Aicstk c----------------------------------------------------------------------- IF(.not.prterr)THEN CALL getstr(Grpttl,Grpptr,Ngrp,igrp,igrptl,nchr) IF(Lfatal)RETURN ipos=index(igrptl(1:nchr),'[')+1 Aicstk=ctoi(igrptl(1:nchr),ipos) END IF ELSE IF((Rgvrtp(begcol).eq.PRGTTD.or. & Rgvrtp(begcol).eq.PRG1TD.or. & Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRR1TD.or. & Rgvrtp(begcol).eq.PRATTD.or. & Rgvrtp(begcol).eq.PRA1TD).and.(.not.prterr))THEN c----------------------------------------------------------------------- c See if td specified correctly in aictest c----------------------------------------------------------------------- aicidx=2 IF(Picktd)aicidx=1 IF(begcol.eq.endcol)aicidx=aicidx+3 IF(Itdtst.eq.1)THEN IF(aicidx.gt.1)Itdtst=aicidx ELSE IF(Itdtst.ne.aicidx)THEN CALL getstr(AICDIC,aicptr,PAICTD,aicidx,str,nchr) IF(Lfatal)RETURN WRITE(STDERR,2000)str(1:nchr) WRITE(Mt2,2000)str(1:nchr) CALL getstr(AICDIC,aicptr,PAICTD,Itdtst,str,nchr) IF(Lfatal)RETURN WRITE(STDERR,2001)str(1:nchr) WRITE(Mt2,2001)str(1:nchr) CALL writln( & ' The type of trading day regressor must agree.', & STDERR,Mt2,F) Readok=F prterr=T END IF c----------------------------------------------------------------------- c for td and td1coef, check to see if length of month, c length of quarter, or leap year regressors are specified. c If they are, print error message. c----------------------------------------------------------------------- ELSE IF((.NOT.(Fcntyp.eq.0.OR.Fcntyp.eq.4.OR.dpeq(Lam,1D0))) & .and.(Rgvrtp(begcol).eq.PRGTLM.or.Rgvrtp(begcol).eq.PRGTLQ.or. & Rgvrtp(begcol).eq.PRGTLY.or.Rgvrtp(begcol).eq.PRGULM.or. & Rgvrtp(begcol).eq.PRGULQ.or.Rgvrtp(begcol).eq.PRGULY) & .AND.(Itdtst.eq.1.or.Itdtst.eq.4))THEN CALL writln('ERROR: Can''t specify a length of month, quarter, &or leap year variable when',STDERR,Mt2,T) IF(Itdtst.eq.1)THEN CALL writln(' using the td option of aictest.', & STDERR,Mt2,F) ELSE CALL writln(' using the td1coef option of aictest.', & STDERR,Mt2,F) END IF Readok=F END IF END DO c----------------------------------------------------------------------- IF(.not.(Lextar.or.Lextma))THEN CALL writln('ERROR: The aictest argument can only be specified w &hen the model is',STDERR,Mt2,T) CALL writln(' estimated using maximum likelihood estimatio &n.',STDERR,Mt2,F) Readok=F END IF END IF c----------------------------------------------------------------------- c Check to see if prior length of month or length of quarter c adjustment factors have been specified. c----------------------------------------------------------------------- IF((Itdtst.eq.1.or.Itdtst.eq.3.or.Itdtst.eq.4.or.Itdtst.eq.6).and. & (Priadj.eq.2.or.Priadj.eq.3))THEN IF(Priadj.eq.2)THEN WRITE(STDERR,2002)'Length-of-month','lom' WRITE(Mt2,2002)'Length-of-month','lom' ELSE WRITE(STDERR,2002)'Length-of-quarter','loq' WRITE(Mt2,2002)'Length-of-quarter','loq' END IF CALL getstr(AICDIC,aicptr,PAICTD,Itdtst,str,nchr) IF(Lfatal)RETURN WRITE(STDERR,2003)str(1:nchr),'regression' WRITE(Mt2,2003)str(1:nchr),'regression' Readok=F c----------------------------------------------------------------------- c Else, check to see if leap year prior adjustments are used c when aic=tdstock c----------------------------------------------------------------------- ELSE IF((Itdtst.eq.3.or.Itdtst.eq.6).and.Priadj.eq.4)THEN WRITE(STDERR,2002)'Leap year','lpyear' WRITE(Mt2,2002)'Leap year','lpyear' WRITE(STDERR,2003)'tdstock','regression' WRITE(Mt2,2003)'tdstock','regression' Readok=F END IF c----------------------------------------------------------------------- c Set up Tdayvc and Ntdvec (BCM, 3-28-2011) c----------------------------------------------------------------------- IF(Itdtst.gt.0)THEN Ntdvec=2 Tdayvc(1)=0 Tdayvc(2)=Itdtst IF((Itdtst.le.2.and.ktd.eq.0).or.(Itdtst.eq.3.and.kstd.eq.0))THEN Tdayvc(3)=Itdtst+3 Ntdvec=Ntdvec+1 END IF IF(Isrflw.eq.2)THEN IF((ktd.eq.0.and.kstd.eq.0).and.Itdtst.le.2)THEN Tdayvc(2)=3 Tdayvc(3)=6 Itdtst=3 END IF END IF END IF c----------------------------------------------------------------------- c Perform checks for AIC tests of length of month, quarter, or leap c year regressors (BCM, March 2008) c----------------------------------------------------------------------- IF((klm.lt.0).or.(klq.lt.0).or.(kly.lt.0))THEN c----------------------------------------------------------------------- c If user-defined regressors found, set AIC test to c test for user-defined regressors rather than conventional lom, loq c or lpyear regressors. c----------------------------------------------------------------------- IF(Lomtst.gt.0)THEN Lomtst=0 Luser=T END IF END IF c----------------------------------------------------------------------- IF(Lomtst.gt.0)THEN IF(klm.gt.0.and.Lomtst.gt.1)THEN WRITE(STDERR,2000)'lom' WRITE(Mt2,2000)'lom' IF(Lomtst.eq.2)THEN WRITE(STDERR,2001)'loq' WRITE(Mt2,2001)'loq' ELSE WRITE(STDERR,2001)'lpyear' WRITE(Mt2,2001)'lpyear' END IF CALL writln(' The type of regressor must agree.', & STDERR,Mt2,F) Readok=F Lomtst=0 END IF IF(klq.gt.0.and.(Lomtst.eq.1.or.Lomtst.eq.3))THEN WRITE(STDERR,2000)'loq' WRITE(Mt2,2000)'loq' IF(Lomtst.eq.1)THEN WRITE(STDERR,2001)'lom' WRITE(Mt2,2001)'lom' ELSE WRITE(STDERR,2001)'lpyear' WRITE(Mt2,2001)'lpyear' END IF CALL writln(' The type of regressor must agree.', & STDERR,Mt2,F) Readok=F Lomtst=0 END IF IF(kly.gt.0.and.Lomtst.lt.3)THEN WRITE(STDERR,2000)'lpyear' WRITE(Mt2,2000)'lpyear' IF(Lomtst.eq.2)THEN WRITE(STDERR,2001)'loq' WRITE(Mt2,2001)'loq' ELSE WRITE(STDERR,2001)'lom' WRITE(Mt2,2001)'lom' END IF CALL writln(' The type of regressor must agree.', & STDERR,Mt2,F) Readok=F Lomtst=0 END IF c----------------------------------------------------------------------- IF(ktd.eq.0)THEN IF(Itdtst.eq.1.or.Itdtst.eq.4)THEN IF(Lomtst.eq.1.or.Lomtst.eq.2)THEN IF(Lomtst.eq.1)THEN CALL writln('ERROR: AIC test for the length of month regresso &r cannot be specified when',Mt2,STDERR,T) ELSE IF(Lomtst.eq.2)THEN CALL writln('ERROR: AIC test for the length of quarter regres &sor cannot be specified when',Mt2,STDERR,T) END IF CALL writln(' the td or td1coef option is given in the a &ictest argument.',Mt2,STDERR,F) Lomtst=0 Readok=F ELSE IF(Lomtst.eq.3.and.(.not.dpeq(Lam,ONE)))THEN CALL writln('ERROR: AIC test for the leap year regressor canno &t be specified when the',Mt2,STDERR,T) CALL writln(' td or td1coef option is given in the varia &bles argument and a',Mt2,STDERR,F) CALL writln(' power transformation is performed.',Mt2, & STDERR,F) Lomtst=0 Readok=F END IF END IF END IF c----------------------------------------------------------------------- IF(kstd.ne.0)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 IF(kstd.gt.0)THEN CALL writln(' stock trading day is specified in the regAR &IMA model.',Mt2,STDERR,F) ELSE CALL writln(' stock trading day is specified as a user de &fined regressor.',Mt2,STDERR,F) END IF Lomtst=0 Readok=F END IF END IF c----------------------------------------------------------------------- IF(Leastr)THEN c----------------------------------------------------------------------- C Allow aictest = easter to be default for aic testing c BCM November 2011 c----------------------------------------------------------------------- IF(Eastst.lt.2.and.Isrflw.eq.2)THEN Eastst=2 ELSE IF(Eastst.eq.2.and.Isrflw.eq.1)THEN WRITE(STDERR,3000)'stock Easter','flow' WRITE(Mt2,3000)'stock Easter','flow' Readok=F Leastr=F END IF END IF c----------------------------------------------------------------------- c Check to see if proper Easter regressor is specified in aictest c----------------------------------------------------------------------- IF(Leastr.and.Ngrp.gt.0)THEN prterr=F DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF(Rgvrtp(begcol).eq.PRGTES)THEN IF(Eastst.eq.1)Eastst=2 ELSE IF((Rgvrtp(begcol).eq.PRGTEA.or.Rgvrtp(begcol).eq.PRGTEC) & .and.(Eastst.eq.2).and.(.not.prterr))THEN IF(Rgvrtp(begcol).eq.PRGTEA)THEN WRITE(STDERR,2000)'easter' WRITE(Mt2,2000)'easter' ELSE WRITE(STDERR,2000)'sceaster' WRITE(Mt2,2000)'sceaster' END IF WRITE(STDERR,2001)'easterstock' WRITE(Mt2,2001)'easterstock' CALL writln(' The type of Easter regressor must agree.', & STDERR,Mt2,F) Readok=F prterr=T END IF END DO END IF c----------------------------------------------------------------------- IF(Lmodel.and.Nb.gt.0)THEN c----------------------------------------------------------------------- c Check if stable seasonal regressors and seasonal differencing c to be done in automatic modeling procedure. (BCM 6-2011) c----------------------------------------------------------------------- IF(Lautom)THEN IF(Diffam(2).gt.0.and.Lseff)THEN Diffam(2)=0 CALL writln('NOTE: Stable seasonal regressors present in '// & 'the regARIMA model.',fhnote,Mt2,T) IF(Lautod)THEN CALL writln(' Maximum seasonal difference in '// & 'automatic model identification procedure set '// & 'to zero.',fhnote,Mt2,F) ELSE CALL writln(' Seasonal difference in automatic model '// & 'identification procedure set to zero.', & fhnote,Mt2,F) END IF END IF END IF c----------------------------------------------------------------------- c Make backup copy of user defined regressors if any of the user c defined regressors are fixed. c----------------------------------------------------------------------- IF(Userfx.or.((Ncusrx.gt.0).and.Lautom))THEN CALL bakusr(Userx,Usrtyp,Usrptr,Ncusrx,Usrttl,Regfx,B,Rgvrtp, & Ngrp,Grpttl,Grp,Grpptr,Ngrptl,0,T) END IF c----------------------------------------------------------------------- c Find out if easter regressors are in model c----------------------------------------------------------------------- igrp=strinx(T,Grpttl,Grpptr,1,Ngrp,'Easter') IF(igrp.eq.0)igrp=strinx(T,Grpttl,Grpptr,1,Ngrp,'StatCanEaster') IF(igrp.eq.0)igrp=strinx(T,Grpttl,Grpptr,1,Ngrp,'StockEaster') IF(igrp.gt.0)THEN begcol=Grp(igrp-1) endcol=Grp(igrp)-1 c----------------------------------------------------------------------- Neas=endcol-begcol+1 IF(Neas.gt.PEASTR)THEN CALL writln('ERROR: Too many Easter regressors specified in '// & 'variables argument.',Mt2,STDERR,T) Readok=F IF(Leastr)Leastr=F ELSE c----------------------------------------------------------------------- DO icol=begcol,endcol CALL getstr(Colttl,Colptr,Nb,icol,igrptl,nchr) IF(Lfatal)RETURN ipos=index(igrptl(1:nchr),'[')+1 ndays(icol-begcol+1)=ctoi(igrptl(1:nchr),ipos) END DO END IF c----------------------------------------------------------------------- c If only one Easter regressor is in the regression matrix, then c reset regression group name to be the same as the effect name c----------------------------------------------------------------------- IF((endcol-begcol).eq.0)THEN CALL delstr(igrp,Grpttl,Grpptr,Ngrp,PGRP) IF(.not.Lfatal) & CALL insstr(igrptl(1:nchr),igrp,PGRP,Grpttl,Grpptr,Ngrp) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Check to see if stock trading day group, if specified, is end of c month stock trading day. If not, print out error message. c (BCM December 2008) c----------------------------------------------------------------------- istock=strinx(T,Grpttl,Grpptr,1,Ngrp,'StockEaster') IF(istock.gt.0.and.kstd.gt.0)THEN ipos=index(igrptl(1:nchr),'[')+1 smpday=ctoi(igrptl(1:nchr),ipos) IF(smpday.ne.31)THEN CALL writln('ERROR: Must use end-of-month stock trading day wit &h current stock Easter',Mt2,STDERR,T) CALL writln(' regressor.',Mt2,STDERR,F) CALL writln(' Specify tdstock[31] in the variables argume &nt of the regression spec.',Mt2,STDERR,F) Readok=F END IF END IF c----------------------------------------------------------------------- c IF AIC test for easter is done, set up vector of easter window c choices to test over. c----------------------------------------------------------------------- IF(Leastr)THEN leaic0=F Easvec(1)=-1 IF(igrp.gt.0)THEN Neasvc=endcol-begcol+2 c----------------------------------------------------------------------- c Check if there are too many Easter regressors for AIC testing c----------------------------------------------------------------------- nelim=Neasvc IF(Lceaic)nelim=nelim+1 IF(nelim.gt.PAICEA)THEN CALL writln('ERROR: Too many Easter regressors specified '// & 'in variables argument to use',Mt2,STDERR,T) CALL writln(' aictest.',Mt2,STDERR,F) Readok=F Leastr=F ELSE DO icol=2,Neasvc Easvec(icol)=ndays(icol-1) END DO IF(Lceaic)THEN Neasvc=Neasvc+1 Easvec(Neasvc)=99 END IF END IF ELSE Easvec(2)=1 Easvec(3)=8 Easvec(4)=15 Neasvc=4 IF(.not.Finhol)Finhol=T leaic0=T END IF END IF ELSE IF(Leastr)THEN Easvec(1)=-1 Easvec(2)=1 Easvec(3)=8 Easvec(4)=15 Neasvc=4 IF(.not.Finhol)Finhol=T leaic0=T END IF c ------------------------------------------------------------------ c If Easter regressor not specified for regARIMA model, check to see c if Easter regressors can be generated for this run. c ------------------------------------------------------------------ IF(Leastr.and.leaic0)THEN CALL addate(Begsrs,Sp,Nofpob-1,idate) IF(Sp.ne.12.and.Sp.ne.4)THEN CALL writln('ERROR: Need monthly or quarterly data to perform ai &ctest for Easter.',Mt2,STDERR,T) Readok=F ELSE IF(Begsrs(YR).lt.1901)THEN CALL writln('ERROR: Cannot generate Easter variables for aictest & before 1901.',Mt2,STDERR,T) CALL writln(' Either specify a starting date, or include t &he century in the',Mt2,STDERR,F) CALL writln(' start or modelspan arguments of the series s &pec.',Mt2,STDERR,F) Readok=F ELSE IF(idate(YR).gt.2100)THEN CALL writln('ERROR: Cannot generate Easter variables for aictest & after 2100.',Mt2,STDERR,T) Readok=F END IF END IF c----------------------------------------------------------------------- c Set irregular regression variables to 0 before regression is done c----------------------------------------------------------------------- Easgrp=0 Tdgrp=0 Holgrp=0 Stdgrp=0 Kswv=0 IF(Lx11)THEN Kersa=0 c----------------------------------------------------------------------- c Check for errors in specifying prior trading day c----------------------------------------------------------------------- IF(dpeq(Dwt(1),DNOTST))THEN CALL setdp(ZERO,7,Dwt) Kswv=0 ELSE DO i=1,7 IF(Dwt(i).lt.ZERO.and.Muladd.eq.0)THEN CALL writln('ERROR: Prior Trading Day weights cannot be less t &han zero for a',STDERR,Mt2,T) CALL writln(' multiplicative seasonal adjustment.', & STDERR,Mt2,F) Readok=F ELSE IF(.not.dpeq(Dwt(i),ZERO))THEN Kswv=1 END IF END DO END IF IF(Kswv.eq.1)THEN IF((.not.Psuadd.and.Muladd.eq.0).or.Muladd.eq.2)THEN C --- STANDARDIZE WEIGHTS TO TOTAL 7.0 tmp=ZERO DO i=1,7 IF(Dwt(i).LT.ZERO.and.Lxrneg)Dwt(I)=ZERO tmp=tmp+Dwt(i) END DO DO i=1,7 Dwt(i)=Dwt(i)*(SEVEN/tmp) END DO C --- Check to see if there are any negative weights ELSE IF(Fcntyp.eq.0)THEN CALL writln('ERROR: Prior Trading Day weights cannot be specif &ied when automatic',STDERR,Mt2,T) CALL writln(' transformation selection is performed.', & STDERR,Mt2,F) ELSE CALL writln('ERROR: Prior Trading Day weights can only be spec &ified for a',STDERR,Mt2,T) CALL writln(' multiplicative or log-additive seasonal ad &justment.',STDERR,Mt2,F) END IF Readok=F END IF ELSE IF(Muladd.eq.0)THEN DO i=1,7 Dwt(i)=ONE END DO END IF IF(Ixreg.gt.0)THEN c----------------------------------------------------------------------- c Make backup copy of user defined regressors if any of the user c defined regressors are fixed. c----------------------------------------------------------------------- IF(Usrxfx)THEN CALL bakusr(Xuserx,Usxtyp,Usrxpt,Nusxrg,Usrxtt,Regfxx,Bx, & Rgxvtp,Nxgrp,Grpttx,Grpx,Gpxptr,Ngrptx,1,T) END IF c----------------------------------------------------------------------- c Find out if X-11 easter regressors are in model - if so, compute c monthly mean of easter effects. c----------------------------------------------------------------------- Easgrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Easter') IF(Easgrp.eq.0) & Easgrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'StatCanEaster') IF(Easgrp.gt.0)THEN begcol=Grpx(Easgrp-1) endcol=Grpx(Easgrp)-1 DO icol=begcol,endcol CALL getstr(Colttx,Clxptr,Nbx,icol,igrptl,nchr) IF(Lfatal)RETURN ipos=index(igrptl(1:nchr),'[')+1 ndays(icol-begcol+1)=ctoi(igrptl(1:nchr),ipos) END DO c----------------------------------------------------------------------- c If only one Easter regressor is in the regression matrix, then c reset regression group name to be the same as the effect name c----------------------------------------------------------------------- IF((endcol-begcol).eq.0)THEN CALL delstr(Easgrp,Grpttx,Gpxptr,Ngrptx,PGRP) IF(.not.Lfatal) & CALL insstr(igrptl(1:nchr),Easgrp,PGRP,Grpttx,Gpxptr,Ngrptx) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c IF AIC test for easter is done, set up vector of easter window c choices to test over. c----------------------------------------------------------------------- IF(Xeastr)THEN Xeasvc(1)=0 IF(Easgrp.gt.0)THEN Neasvx=endcol-begcol+2 DO icol=2,Neasvx Xeasvc(icol)=ndays(icol-1) END DO ELSE Xeasvc(2)=1 Xeasvc(3)=8 Xeasvc(4)=15 Neasvx=4 Finhol=T END IF END IF c ------------------------------------------------------------------ c If Easter regressor not specified, check to see if Easter c regressors can be generated for this run. c ------------------------------------------------------------------ IF(Xeastr.and.Neasvx.eq.4)THEN CALL addate(Begsrs,Sp,Nofpob-1,idate) IF(Sp.ne.12.and.Sp.ne.4)THEN CALL writln('ERROR: Need monthly or quarterly data to perform &aictest for Easter.',Mt2,STDERR,T) Readok=F ELSE IF(Begsrs(YR).lt.1901)THEN CALL writln('ERROR: Cannot generate Easter variables for aicte &st before 1901.',Mt2,STDERR,T) CALL writln(' Either specify a starting date, or include & the century in the',Mt2,STDERR,F) CALL writln(' start or modelspan arguments of the series & spec.',Mt2,STDERR,F) Readok=F ELSE IF(idate(YR).gt.2100)THEN CALL writln('ERROR: Cannot generate Easter variables for aicte &st after 2100.',Mt2,STDERR,T) Readok=F END IF END IF c----------------------------------------------------------------------- c Set pointers that tell if there are Easter, other holiday or c trading day regressors in the model c----------------------------------------------------------------------- Holgrp=Easgrp IF(Holgrp.eq.0) & Holgrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Thanksgiving') IF(Holgrp.eq.0) & Holgrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Labor') Tdgrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Trading Day') IF(Tdgrp.eq.0) & Stdgrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Stock Trading Day') c----------------------------------------------------------------------- IF(Stdgrp.gt.0.and.Holgrp.gt.0)THEN CALL writln('ERROR: Stock trading day and holiday irregular com &ponent regression',STDERR,Mt2,T) CALL writln(' variables cannot be specified in the same r &un.',STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c Check to see if, when rewieghting specificed, there are fixed c trading day regression coefficients that are < -1.0 c----------------------------------------------------------------------- IF(Tdgrp.gt.0.and.Lxrneg.and.Irgxfx.ge.2)THEN begcol=Grpx(Tdgrp-1) endcol=Grpx(Tdgrp)-1 tdfneg=F alltdf=T DO i=begcol,endcol IF(Regfxx(i))THEN IF(Bx(i).lt.MINONE)tdfneg=T ELSE IF(alltdf)alltdf=F END IF END DO IF(tdfneg)THEN CALL writln('ERROR: Cannot specify fixed coefficients for the &trading day regressors',STDERR,Mt2,T) CALL writln(' that imply daily weights less than zero w &hen specifying',STDERR,Mt2,F) CALL writln(' reweight=yes in the x11regression spec.', & STDERR,Mt2,F) Readok=F ELSE IF(alltdf)then CALL writln('NOTE: Cannot reweight trading day coefficients if & all trading day',fhnote,Mt2,T) CALL writln(' regressors are fixed; reweighting of daily &weights will not',fhnote,Mt2,F) CALL writln(' be performed.',fhnote,Mt2,F) Lxrneg=F END IF END IF c----------------------------------------------------------------------- c Check to see if there are fixed stock trading day regression c coefficients for the irregular regression that are <= -1.0, which c lead to nonpositive trading day factors for multiplicative seasonal c adjustments. c----------------------------------------------------------------------- IF(Stdgrp.gt.0.and.Irgxfx.ge.2.and.Muladd.eq.0)THEN begcol=Grpx(Tdgrp-1) endcol=Grpx(Tdgrp)-1 tdfneg=F DO ic=begcol,endcol IF(Regfxx(i).and.(Bx(i).lt.MINONE.or.dpeq(Bx(i),MINONE))) & tdfneg=T END DO IF(tdfneg)THEN CALL writln('ERROR: Cannot specify fixed coefficients for stoc &k trading day',STDERR,Mt2,T) CALL writln(' regressors in the x11regression spec that &produce a nonpositive',STDERR,Mt2,F) CALL writln(' trading day factor. Use the regression sp &ec to estimate the',STDERR,Mt2,F) CALL writln(' stock trading day effect.',STDERR,Mt2,F) Readok=F END IF END IF c----------------------------------------------------------------------- IF(Nusxrg.gt.0)THEN iusr=1 DO icol=1,Nbx IF(Rgxvtp(icol).eq.PRGUTD.and.Nusxrg.gt.0)THEN rtype=Usxtyp(iusr) iusr=iusr+1 IF(Tdgrp.eq.0)THEN Tdgrp=icol IF(Xtdtst.gt.0)THEN Xtdtst=0 Xuser=T END IF ELSE IF(Stdgrp.eq.0.and.Isrflw.eq.1)THEN Stdgrp=icol END IF ELSE IF((.not.(Holgrp.gt.0.or.Axruhl)).and. & rtype.ge.PRGTUH)THEN Holgrp=icol IF(.not.Axruhl)Axruhl=T IF(.not.Axrghl)Axrghl=T END IF END DO c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- c Check to see if X-11 and regARIMA adjustments are specified in the c same run. c----------------------------------------------------------------------- IF(Axrgtd.and.(Tdgrp.eq.0.and.Stdgrp.eq.0))Axrgtd=F IF(Axrghl.and.Holgrp.eq.0)Axrghl=F c----------------------------------------------------------------------- c Set options for extreme value treatment for X-11 regression c----------------------------------------------------------------------- otlgrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'AO') IF(dpeq(Sigxrg,DNOTST))THEN IF((Tdgrp.gt.0.or.Xtdtst.gt.0).AND. & (Holgrp.eq.0.and..not.Xeastr.and.otlgrp.eq.0).and. & dpeq(Critxr,DNOTST))THEN Sigxrg=2.5D0 ELSE IF(dpeq(Critxr,DNOTST))THEN Otlxrg=T END IF ELSE IF(Tdgrp.eq.0.OR.(Holgrp.gt.0.or.Xeastr.or.otlgrp.gt.0)) & THEN CALL writln( &'ERROR: The sigma argument of the x11regression spec can only be', & STDERR,Mt2,T) CALL writln( & ' specified when flow trading day variables are the only', & STDERR,Mt2,F) CALL writln(' regressors in the irregular regression.', & STDERR,Mt2,F) Readok=F END IF IF(Otlxrg.and.dpeq(Critxr,DNOTST))THEN CALL dfdate(Endxot,Begxot,Sp,nobxot) nobxot=nobxot+1 IF(Cvxtyp)THEN Critxr=setcvl(nobxot,Cvxalf) ELSE Critxr=setcv(nobxot,Cvxalf) END IF IF(dpeq(Critxr,DNOTST))Readok=F END IF c----------------------------------------------------------------------- c Check options for AIC trading day test c----------------------------------------------------------------------- IF(Xtdtst.gt.0)THEN IF(Stdgrp.gt.0.AND.Xtdtst.eq.1)THEN Xtdtst=2 ELSE IF(Stdgrp.gt.0.AND.Xtdtst.eq.3)THEN CALL writln('ERROR: A stocktd regressor has been specified in &the variables argument',STDERR,Mt2,T) CALL writln(' of x11regression but td1coef is given in t &he aictest argument.',STDERR,Mt2,F) CALL writln( & ' The type of trading day regressor must agree.', & STDERR,Mt2,F) Readok=F ELSE IF(Tdgrp.gt.0.and.Xtdtst.eq.2)THEN CALL writln('ERROR: A td or td1coef regressors has been specif &ied in the variables argument',STDERR,Mt2,T) CALL writln(' of x11regression but tdstock is given in t &he aictest argument. ',STDERR,Mt2,F) CALL writln( & ' The type of trading day regressor must agree.', & STDERR,Mt2,F) Readok=F ELSE IF (Xtdtst.eq.1.or.Xtdtst.eq.3)THEN begcol=Grpx(Tdgrp-1) endcol=Grpx(Tdgrp)-1 IF((Xtdtst.eq.1).and.(begcol.eq.endcol))THEN Xtdtst=3 ELSE IF((Xtdtst.eq.3).and.(begcol.ne.endcol))THEN CALL writln('ERROR: A td regressor has been specified in the &variables argument of',STDERR,Mt2,T) CALL writln(' x11regression but td1coef is given in th &e aictest argument. ',STDERR,Mt2,F) CALL writln( & ' The type of trading day regressor must agree.', & STDERR,Mt2,F) Readok=F END IF END IF c----------------------------------------------------------------------- c Set date for stock trading day variable c----------------------------------------------------------------------- IF(Readok)THEN IF(Stdgrp.gt.0)THEN CALL getstr(Grpttx,Gpxptr,Ngrptx,Stdgrp,igrptl,nchr) IF(Lfatal)RETURN ipos=index(igrptl(1:nchr),'[')+1 Xaicst=ctoi(igrptl(1:nchr),ipos) END IF c----------------------------------------------------------------------- c set change of regime date for trading day AIC test. c----------------------------------------------------------------------- IF(Xrgmtd)THEN ipos=Gpxptr(Ngrptx)-1 rgmgrp=index(Grpttx(1:ipos),'(before ')+8 IF(rgmgrp.eq.8) & rgmgrp=index(Grpttx(1:ipos),'(change for before ')+19 IF(rgmgrp.eq.19) & rgmgrp=index(Grpttx(1:ipos),'(starting ')+10 IF(rgmgrp.eq.10) & rgmgrp=index(Grpttx(1:ipos),'(change for after ')+18 CALL ctodat(Grpttx(1:ipos),Sp,rgmgrp,Xaicrg,argok) Readok=argok.and.Readok END IF c ------------------------------------------------------------------ c If trading day regressor not specified, check to see if trading c day regressors can be generated for this run. c ------------------------------------------------------------------ IF(Tdgrp.eq.0.and.Stdgrp.eq.0)THEN IF((Xtdtst.eq.3.or.Xtdtst.eq.4).and.Sp.ne.12)THEN CALL writln('ERROR: Need monthly data to perform aictest for & stock trading day.',STDERR,Mt2,T) Readok=F ELSE IF(Sp.ne.12.and.Sp.ne.4)THEN CALL writln('ERROR: Need monthly or quarterly data to perfor &m aictest for trading day.',STDERR,Mt2,T) Readok=F ELSE IF(Begsrs(YR).lt.1776)THEN CALL writln('ERROR: Cannot generate trading variables for ai &ctest before 1776.',Mt2,STDERR,T) CALL writln(' Either specify a starting date, or inclu &de the century in the',Mt2,STDERR,F) CALL writln(' start or modelspan arguments of the seri &es spec.',Mt2,STDERR,F) Readok=F END IF END IF END IF c----------------------------------------------------------------------- c Check to see if prior length of month or length of quarter c adjustment factors have been specified. c----------------------------------------------------------------------- IF(Priadj.gt.1)THEN IF(Priadj.eq.2)THEN WRITE(STDERR,2002)'Length-of-month','lom' WRITE(Mt2,2002)'Length-of-month','lom' ELSE IF(Priadj.eq.3)THEN WRITE(STDERR,2002)'Length-of-quarter','loq' WRITE(Mt2,2002)'Length-of-quarter','loq' ELSE IF(Priadj.eq.4)THEN WRITE(STDERR,2002)'Leap year','lpyear' WRITE(Mt2,2002)'Leap year','lpyear' END IF CALL getstr(XAICDC,xaicpt,PXTAIC,Xtdtst,str,nchr) IF(Lfatal)RETURN WRITE(STDERR,2003)str(1:nchr),'x11regression' WRITE(Mt2,2003)str(1:nchr),'x11regression' Readok=F END IF c----------------------------------------------------------------------- END IF END IF c----------------------------------------------------------------------- c Check to see if X-11 and regARIMA model based trading day c adjustments are in the same run. c----------------------------------------------------------------------- IF(Adjtd.eq.1)THEN IF((Axrgtd.or.Kswv.eq.1))THEN CALL writln('ERROR: Irregular component regression and regARIMA & model-based trading',STDERR,Mt2,T) CALL writln(' day adjustment cannot be specified in the s &ame run.',STDERR,Mt2,F) Readok=F END IF END IF c----------------------------------------------------------------------- c Check to see if X-11 and regARIMA model based holiday c adjustments are in the same run. c----------------------------------------------------------------------- IF(Adjhol.eq.1.and.Axrghl)THEN rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(rhol.eq.0) & rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StatCanEaster') IF(rhol.eq.0) & rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StockEaster') IF(rhol.eq.0)rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Labor') IF(rhol.eq.0)rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'Thanksgiving') IF(rhol.gt.0)THEN CALL writln('ERROR: Irregular component regression and regARIMA & model-based holiday',STDERR,Mt2,T) CALL writln(' adjustment cannot be specified in the same &run.',STDERR,Mt2,F) Readok=F END IF END IF c----------------------------------------------------------------------- c Check for errors in specifying holiday adjustment c----------------------------------------------------------------------- IF(Khol.eq.0)THEN Lgenx=F ELSE IF(Haveum)THEN Lgenx=F Khol=0 CALL writln('NOTE: An X-11 holiday adjustment cannot be performe &d when a user-defined',fhnote,Mt2,T) CALL writln(' mean is specified for the irregular regressio &n.',fhnote,Mt2,F) ELSE Lgenx=T Khol=1 IF(Sp.eq.4)THEN CALL writln('ERROR: Cannot calculate X-11 holiday adjustment fo &r a quarterly series.',STDERR,Mt2,T) Readok=F END IF IF(Khol.gt.0)THEN IF(Fcntyp.eq.0)THEN CALL writln('ERROR: An X-11 holiday adjustment cannot be perfo &rmed when the',STDERR,Mt2,T) CALL writln(' automatic transformation selection option &is chosen.',STDERR,Mt2,F) Readok=F ELSE IF(Muladd.gt.0)THEN CALL writln('ERROR: An X-11 holiday adjustment cannot be perfo &rmed unless the',STDERR,Mt2,T) CALL writln(' multiplicative seasonal adjustment option &is chosen.',STDERR,Mt2,F) Readok=F END IF END IF IF(Adjhol.eq.1)THEN rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(rhol.eq.0) & rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StatCanEaster') IF(rhol.eq.0) & rhol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StockEaster') IF(rhol.gt.0)THEN CALL writln('ERROR: X-11 and regARIMA model-based Easter adjus &tment cannot be',STDERR,Mt2,T) CALL writln(' specified in the same run.',STDERR,Mt2,F) Readok=F END IF END IF IF(Easgrp.gt.0.and.Axrghl)THEN CALL writln('ERROR: X-11 and irregular component regression-bas &ed Easter adjustment',STDERR,Mt2,T) CALL writln(' cannot be specified in the same run.', & STDERR,Mt2,F) Readok=F END IF IF(Begspn(1).lt.1901)THEN CALL writln('ERROR: No X-11 holiday effect before 1901.', & STDERR,Mt2,T) CALL writln( & ' Try including the century in the start date', & STDERR,Mt2,F) Readok=F END IF END IF c----------------------------------------------------------------------- c If X-11 holidays estimated and irregular regression performed or c if the 0.per setting is used in regspan, set Ixreg to indicate a c prior adjustment. c----------------------------------------------------------------------- IF(Ixreg.eq.1)THEN CALL dfdate(Endspn,Endxrg,Ny,Xdsp) IF(Khol.ge.1.or.Fxprxr.gt.0.or.Xdsp.gt.0)Ixreg=2 END IF c----------------------------------------------------------------------- c Check to see if only trading day factors are to be removed from c final sesonally adjusted series when user mean is specified for c x11regression. c----------------------------------------------------------------------- IF(Noxfac.and.(.not.Finhol))THEN CALL writln('ERROR: Must remove both trading day and holiday fro &m final seasonally',STDERR,Mt2,T) CALL writln(' adjusted series when user-defined mean is pr &esent.',STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c If multiplicative seasonal adjustment, test if factors are < 0, c set factors = 0 to 1.0, and convert percentages to ratios. c----------------------------------------------------------------------- IF(Readok)THEN IF(Muladd.ne.1)THEN DO i=1,Nadj IF(Adjmod.eq.2)THEN Adj(i)=exp(Adj(i)) ELSE IF(Adj(i).lt.ZERO)THEN CALL writln('ERROR: Negative prior adjustment factors cannot &be used for a',STDERR,Mt2,T) CALL writln(' multiplicative or log-additive seasonal a &djustment.',STDERR,Mt2,F) Readok=F ELSE IF(dpeq(Adj(i),ZERO))THEN Adj(i)=ONE END IF END DO IF(Adjmod.eq.2)Adjmod=0 END IF END IF IF(Iyrt.le.0)THEN IF(Iyrt.eq.NOTSET)Iyrt=0 c----------------------------------------------------------------------- c check to see if there are at least 5 complete years for the c SA totals adjustment option c----------------------------------------------------------------------- ELSE iyrs=Lstyr-Lyr+1 IF(Pos1bk.ne.1)iyrs=iyrs-1 IF(Lstmo.ne.Ny)iyrs=iyrs-1 IF(iyrs.lt.5)THEN CALL writln('ERROR: The series must have at least five complete & years to force the',STDERR,Mt2,T) CALL writln(' yearly totals of the seasonally adjusted se &ries.',STDERR,Mt2,F) Readok=F END IF IF(Mid.eq.NOTSET)THEN IF(Muladd.eq.1)THEN Mid=1 ELSE Mid=0 END IF END IF END IF c----------------------------------------------------------------------- c If any of the individual seasonal filter lengths are selected c using the global MSR, set Lterm to 6 c----------------------------------------------------------------------- Lstabl=F L3x5=F IF(Kfulsm.eq.2)THEN IF(Lterm.ne.NOTSET)THEN CALL writln('ERROR: Cannot specify a seasonal filter when type= &trend.',STDERR,Mt2,T) Readok=F END IF ELSE IF(Lterm.eq.NOTSET)THEN Lterm=6 DO i=1,Ny Lter(i)=Lterm END DO END IF i=1 DO WHILE (Lterm.lt.6.and.i.le.Ny) IF(Lter(i).eq.6)Lterm=6 i=i+1 END DO c----------------------------------------------------------------------- c Check to see if any of the seasonal filters is a 3x15. If so, c print out a warning message if the # of years is less than 20 c----------------------------------------------------------------------- c Set logical variables for use of a stable, 3x5 seasonal filters c----------------------------------------------------------------------- IF(Lterm.eq.5)Lstabl=T IF(Lterm.eq.2.or.Lterm.eq.0)L3x5=T c----------------------------------------------------------------------- prtwrn=T IF(Lterm.eq.4.and.nyr.lt.20)THEN CALL writln('WARNING: The program will not use a 3x15 seasonal &filter for',fhnote,Mt2,T) CALL writln(' series shorter than 20 years.',fhnote, & Mt2,F) Lterm=5 prtwrn=F Lstabl=T END IF DO i=1,Ny IF(Lter(i).eq.4.and.nyr.lt.20)THEN Lter(i)=5 IF(.not.Lstabl)Lstabl=T IF(prtwrn)THEN CALL writln('WARNING: The program will not use a 3x15 seasona &l filter for series',fhnote,Mt2,T) CALL writln(' series shorter than 20 years.',fhnote, & Mt2,F) prtwrn=F END IF c----------------------------------------------------------------------- ELSE IF(.not.Lstabl.and.Lter(i).eq.5)THEN Lstabl=T END IF c----------------------------------------------------------------------- IF(L3x5.and.(Lter(i).ne.2.and.Lter(i).ne.0))L3x5=F END DO c----------------------------------------------------------------------- c Set Lmsr c----------------------------------------------------------------------- Lmsr=0 IF(Lterm.eq.6)Lmsr=6 END IF c----------------------------------------------------------------------- c Check to see if Henderson moving average specified is too long. c----------------------------------------------------------------------- IF(Ktcopt.gt.PMXHND)THEN ip1=1 CALL itoc(PMXHND,clen,ip1) CALL writln('ERROR: Length of Henderson filter cannot exceed '// & clen(1:(ip1-1))//'.',STDERR,Mt2,T) Readok=F ELSE IF(Ktcopt.eq.1)THEN CALL writln('ERROR: Length of Henderson filter must exceed 1.', & STDERR,Mt2,T) Readok=F ELSE IF(Nbfpob.lt.Ktcopt)THEN ip1=1 CALL itoc(Ktcopt,clen,ip1) CALL writln('ERROR: Not enough observations in the series to app &ly a Henderson filter',STDERR,Mt2,T) CALL writln(' of length '//clen(1:(ip1-1))//'.', & STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c set up Trend I/C ratio for generating Henderson end weights. c----------------------------------------------------------------------- IF(dpeq(Tic,ZERO))THEN Tic=3.5D0 IF(Ktcopt.le.9.and.Ktcopt.gt.0)Tic=ONE IF(Ktcopt.gt.13)Tic=4.5D0 IF(Ktcopt.le.5.and.Ny.eq.4)Tic=0.001D0 IF(Ktcopt.ge.7.and.Ny.eq.4)Tic=4.5D0 c----------------------------------------------------------------------- c If Tic is preset and automatic trend selection option, bomb. c----------------------------------------------------------------------- ELSE IF(Ktcopt.eq.0)THEN CALL writln('ERROR: I/C ratio cannot be specified when the autom &atic trend',STDERR,Mt2,T) CALL writln(' filter option is used.',STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c If savelog=alldiagnostics in either the x11 or composite specs, c set svltab to allow all diagnostics to be saved to the log file c----------------------------------------------------------------------- IF(Svltab(LSLALX))THEN DO i=LSLM1,LSLIDS Svltab(i)=T END DO END IF IF(Svltab(LSLALI))THEN DO i=LSLIM1,LSLITT Svltab(i)=T END DO END IF END IF IF(Lmodel)THEN IF(Svltab(LSLALA))THEN DO i=LSLAMD,LSLFUR Svltab(i)=T END DO END IF IF(Svltab(LSLALE))THEN DO i=LSLAIC,LSLAFC Svltab(i)=T END DO END IF IF(Svltab(LSLALC))THEN DO i=LSLNRM,LSLSFT Svltab(i)=T END DO END IF END IF IF(Svltab(LSLALR))THEN DO i=LSLASA,LSLAFE Svltab(i)=T END DO END IF IF(Svltab(LSLALP))THEN IF(Ny.eq.12)THEN DO i=LSLSPK,LSLISP Svltab(i)=T END DO END IF DO i=LSLTPK,LSLQCH Svltab(i)=T END DO END IF c----------------------------------------------------------------------- c Set sliding spans indicator variable for trading day (itd) c----------------------------------------------------------------------- IF(Issap.gt.0)THEN IF((Axrgtd.and.(.not.Noxfac)).or.(Adjtd.eq.1.and.Ssinit.ne.1)) & Itd=1 c----------------------------------------------------------------------- c Set sliding spans indicator variable for holiday (ihol) c----------------------------------------------------------------------- IF(Khol.gt.0.or.((Adjhol.eq.1.or.Finhol).and.Ssinit.ne.1))Ihol=1 c----------------------------------------------------------------------- c Print error message if user-defined span length is not long c enough. c----------------------------------------------------------------------- IF(Nlen.gt.0.and.Nlen.lt.Ny*3)THEN CALL writln('WARNING: Length of sliding span must be at least 3 &years.',fhnote,Mt2,T) CALL writln(' Sliding spans analysis will not be perform &ed.',fhnote,Mt2,F) Issap=0 ELSE c----------------------------------------------------------------------- c Otherwise, set up cutoff values. c----------------------------------------------------------------------- DO i=1,5 DO j=1,4 IF(i.eq.4)THEN Cut(i,j)=Sscut(i)+(j-1)*2D0 ELSE Cut(i,j)=Sscut(i)+(j-1) END IF END DO END DO Cut(4,4)=Cut(4,4)+ONE END IF END IF c----------------------------------------------------------------------- c Initialize variables used for type-of-month trading day table. c----------------------------------------------------------------------- IF(Posfob.eq.Posffc)THEN nsp=Sp ELSE IF(Nfcstx.gt.Nfcst)THEN nsp=Nfcstx-Nfcst ELSE IF(Sp.gt.Nfcst)THEN nsp=Sp-Nfcst ELSE nsp=0 END IF CALL tdset(Sp,Tdgrp,Begbak,Pos1bk,Posffc+nsp,ktd,Ixreg,Adjtd, & Adjusr,Kswv,Noxfac) c----------------------------------------------------------------------- c Check composite adjustment options c----------------------------------------------------------------------- IF(Iagr.eq.1.and.(Lchkin.or.Lcomp))THEN c----------------------------------------------------------------------- c Set up indicator vector for beginning date, ending date and c seasonal period of composite adjustment c----------------------------------------------------------------------- Iagr=2 Itest(1)=Sp Itest(2)=Begspn(MO) Itest(3)=Endspn(MO) Itest(4)=Begspn(YR) Itest(5)=Endspn(YR) c----------------------------------------------------------------------- c Check if proper dates were specified for composite adjustment c----------------------------------------------------------------------- ELSE IF(Iagr.eq.2.and.Iag.ge.0.and.((Itest(2).ne.Begspn(MO)) & .or.(Itest(3).ne.Lstmo).or.(Itest(4).ne.Lyr) & .or.(Itest(5).ne.Lstyr)))THEN CALL writln('ERROR: Component series '//Serno(1:Nser)// & ' to be aggregated has a different',STDERR,Mt2,T) CALL writln( & ' time span. Aggregation will not be computed.', & STDERR,Mt2,F) Readok=F Iagr=-1 END IF c----------------------------------------------------------------------- c Check to see if regARIMA model will be fit when model based c regression effects are specified for adjustment. c----------------------------------------------------------------------- IF(Adjtd.eq.1.or.Adjhol.eq.1.or.Adjls.eq.1.or.Adjao.eq.1.or. & Adjtc.eq.1.or.Adjso.eq.1.or.Adjusr.eq.1.or.Adjsea.eq.1.or. & Finhol.or.Finao.or.Finls.or.Fintc.or.Finusr)THEN IF((.not.Lmodel).OR.(.not.Ldestm))THEN IF(Adjtd.eq.1)Adjtd=0 IF(Adjhol.eq.1)Adjhol=0 IF(Adjao.eq.1)Adjao=0 IF(Adjls.eq.1)Adjls=0 IF(Adjtc.eq.1)Adjtc=0 IF(Adjso.eq.1)Adjso=0 IF(Adjusr.eq.1)Adjusr=0 IF(Adjsea.eq.1)Adjsea=0 IF(Finhol.and.(.NOT.(Axrghl.or.Axruhl.OR.Khol.ge.1.or. & Leastr.or.Xeastr)))Finhol=F IF(Finao)Finao=F IF(Finls)Finls=F IF(Fintc)Fintc=F IF(Finusr)Finusr=F ELSE IF (Nb.gt.0) THEN c ------------------------------------------------------------------ c Determine which of the regressors are currently present in the c regARIMA model. First, initialize counters c ------------------------------------------------------------------ nusr=0 nseas=0 ntd=0 Nao=0 Nls=0 Ntc=0 Nso=0 Nramp=0 Nln=0 Nsln=0 Nlp=0 Nseq=0 Nhol=0 Neas=0 iusr=1 c----------------------------------------------------------------------- c Determine type of regression variable c----------------------------------------------------------------------- DO icol=1,Nb rtype=Rgvrtp(icol) IF(Nusrrg.gt.0)THEN IF(rtype.eq.PRGTUD)THEN rtype=Usrtyp(iusr) iusr=iusr+1 ELSE IF((rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGTUS)THEN iusr=iusr+1 END IF END IF c----------------------------------------------------------------------- c regARIMA trading day regressors c----------------------------------------------------------------------- IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY))THEN Ntd=Ntd+1 IF(rtype.eq.PRGTTD.or.rtype.eq.PRRTTD.or.rtype.eq.PRATTD.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & (Isrflw.eq.0.and.rtype.eq.PRGUTD)) & Nflwtd=Nflwtd+1 IF(rtype.eq.PRGTLM.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRRTLM.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRATLM.or.rtype.eq.PRATLQ.or. & rtype.eq.PRGULM.or.rtype.eq.PRGULQ) & Nln=Nln+1 IF(rtype.eq.PRGTSL.or.rtype.eq.PRRTSL.or.rtype.eq.PRATSL.or. & (Isrflw.eq.1.and.rtype.eq.PRGULM))Nsln=Nsln+1 IF(rtype.eq.PRGTLY.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLY.or. & rtype.eq.PRGULY)Nlp=Nlp+1 END IF c----------------------------------------------------------------------- c regARIMA holiday regressors c----------------------------------------------------------------------- IF(rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES.or. & rtype.eq.PRGTLD.or.rtype.eq.PRGTTH.or.(rtype.ge.PRGTUH.and. & rtype.le.PRGUH5))THEN Nhol=Nhol+1 IF(rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES) & Neas=Neas+1 END IF c----------------------------------------------------------------------- c regARIMA User-defined regressors c----------------------------------------------------------------------- IF(rtype.eq.PRGTUD)nusr=nusr+1 c----------------------------------------------------------------------- c regARIMA seasonal regressors c----------------------------------------------------------------------- IF(rtype.eq.PRGTUS)nseas=nseas+1 c----------------------------------------------------------------------- c regARIMA AO outlier regressors c----------------------------------------------------------------------- IF(rtype.eq.PRGTAO.or.rtype.eq.PRSQAO.or.rtype.eq.PRGTMV.or. & rtype.eq.PRGUAO)Nao=Nao+1 c----------------------------------------------------------------------- c regARIMA Level Change Outlier regressors c----------------------------------------------------------------------- IF(rtype.eq.PRGTLS.or.rtype.eq.PRGTRP.or.rtype.eq.PRGTTL.or. & rtype.eq.PRGTQI.or.rtype.eq.PRGTQD.or.rtype.eq.PRSQLS.or. & rtype.eq.PRGULS)THEN Nls=Nls+1 IF(rtype.eq.PRGTRP.or.rtype.eq.PRGTQI.or.rtype.eq.PRGTQD) & Nramp=Nramp+1 END IF c----------------------------------------------------------------------- c regARIMA Temporary Change Outlier regressors c----------------------------------------------------------------------- IF(rtype.eq.PRGTTC)Ntc=Ntc+1 c----------------------------------------------------------------------- c regARIMA Seasonal Outlier regressors c----------------------------------------------------------------------- IF(rtype.eq.PRGTSO.and.rtype.eq.PRGUSO)Nso=Nso+1 c----------------------------------------------------------------------- c regARIMA Sequence Outlier regressors c----------------------------------------------------------------------- IF(rtype.eq.PRSQAO.or.rtype.eq.PRSQLS)Nseq=Nseq+1 END DO c----------------------------------------------------------------------- c reset regression adjustment indicators if no regession effect c found and print warning messages. c----------------------------------------------------------------------- IF(Adjtd.eq.1.and.Ntd.eq.0)Adjtd=0 IF(Adjhol.eq.1.and.Nhol.eq.0)THEN Adjhol=0 IF((.NOT.(Axrghl.or.Axruhl.or.Khol.ge.1.or.Leastr.or.Xeastr)) & .and.Finhol)Finhol=F END IF IF(Adjsea.eq.1.and.nseas.eq.0)Adjsea=0 IF(nusr.eq.0)THEN IF(Adjusr.eq.1)Adjusr=0 IF(Finusr)Finusr=F END IF IF((.not.Ltstao).and.Nao.eq.0)THEN IF(Adjao.eq.1)Adjao=0 IF(Finao)Finao=F END IF IF((.not.Ltstls).and.Nls.eq.0)THEN IF(Adjls.eq.1)Adjls=0 IF(Finls)Finls=F END IF IF((.not.Ltsttc).and.Ntc.eq.0)THEN IF(Adjtc.eq.1)Adjtc=0 IF(Fintc)Fintc=F END IF IF(Adjso.eq.1.and.Nso.eq.0)Adjso=0 END IF END IF c----------------------------------------------------------------------- IF(Lmodel)THEN c----------------------------------------------------------------------- c IF automatic outlier identification done, set variables to allow c prior adjustment of outlier regressors c----------------------------------------------------------------------- IF(Adjao.eq.0.AND.Ltstao)Adjao=1 IF(Adjls.eq.0.AND.Ltstls)Adjls=1 IF(Adjtc.eq.0.AND.Ltsttc)Adjtc=1 * IF(Adjso.eq.0.AND.Ltstso)Adjso=1 c----------------------------------------------------------------------- c If automatic modeling or testing procedures performed, disable c saving of model iteration information. c----------------------------------------------------------------------- IF(((Lautom.or.Lautox).or.Itdtst.gt.0.or.Leastr.or.Luser.or. & Fcntyp.eq.0).and.Savtab(LESTIT))THEN Savtab(LESTIT)=F CALL writln('WARNING: Cannot save iteration iformation for regAR &IMA model estimation',fhnote,Mt2,T) CALL writln(' when automatic modeling, AIC tests, or aut &omatic transformation',fhnote,Mt2,F) CALL writln(' selection is used.',fhnote,Mt2,F) END IF c----------------------------------------------------------------------- c If automatic modeling or testing procedures performed, exact c maximum likelihood estimation must be selected for both MA and AR. c----------------------------------------------------------------------- IF(((Itdtst.gt.0.or.Leastr.or.Luser).or.Lautom.or.Fcntyp.eq.0) & .and.(.not.(Lextar.and.Lextma)))THEN CALL writln('ERROR: Exact maximum likelihood estimation must be &selected when',STDERR,Mt2,T) CALL writln(' AIC tests, automdl, or automatic transformat &ion selection is used.',STDERR,Mt2,F) CALL writln(' ',STDERR,Mt2,F) Readok=F END IF c----------------------------------------------------------------------- c Only test the forecast error of the identified model if X-11 c seasonal adjustment is done (BCM July 2007) c----------------------------------------------------------------------- IF((.not.Lx11).and.Lrejfc)THEN Lrejfc=F CALL writln('NOTE: Since X-11 seasonal adjustment is not done, t &he forecast error will not',fhnote,Mt2,T) CALL writln(' be checked after the ARIMA model is identifie &d.',fhnote,Mt2,F) END IF c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- IF((.not.Lx11).and.(Spcsrs.eq.3))THEN Spcsrs=2 CALL writln('NOTE: Since X-11 seasonal adjustment is not done, th &e E1 table is not available.',fhnote,Mt2,T) CALL writln(' The B1 table will be used for the spectrum of &the original series.',fhnote,Mt2,F) END IF c----------------------------------------------------------------------- c Copy data into variables Series and Orig c----------------------------------------------------------------------- Nomnfy=Nobs-Frstsy+1 * write(Mtprof,*) ' Y(Frstsy) = ',Y(Frstsy) CALL copy(Y(Frstsy),Nomnfy,-1,Orig2(Pos1ob)) CALL copy(Y(Frstsy),Nspobs,-1,Series(Pos1ob)) CALL copy(Y(Frstsy),Nomnfy,-1,Orig(Pos1ob)) * write(Mtprof,*) ' Orig(Pos1ob) = ',Orig(Pos1ob) c----------------------------------------------------------------------- C --- Set up logical vector which shows if all values for the series c is > 0 if pseudo-additive seasonal adjustment is performed. c----------------------------------------------------------------------- DO i=Pos1ob,Posfob Gudval(i)=T IF(Psuadd.and.Series(i).le.ZERO)Gudval(i)=F END DO c----------------------------------------------------------------------- c Check to see if pseudo-additive seasonal adjustment can be c performed. c----------------------------------------------------------------------- IF(Psuadd)THEN IF(Adjtd.eq.1.or.Adjls.eq.1.or.Adjhol.eq.1.or.Adjao.eq.1.or. & Adjtc.eq.1.or.Adjusr.eq.1.or.Adjsea.eq.1.or.Finhol.or. & Finao.or.Finls.or.Fintc.or.Finusr)THEN CALL writln('ERROR: Pseudo-additive seasonal adjustment cannot b &e performed when',fhnote,Mt2,T) CALL writln(' preadjustment factors are derived from a REG &ARIMA model.',fhnote,Mt2,F) Readok=F ELSE IF(Axrgtd.or.Axrghl)THEN CALL writln('ERROR: Pseudo-additive seasonal adjustment and irre &gular component',fhnote,Mt2,T) CALL writln(' calendar adjustment cannot be specified in t &he same run.',fhnote,Mt2,F) Readok=F ELSE IF(Priadj.gt.1.or.Nuspad.gt.0.or.Nustad.gt.0)THEN CALL writln('ERROR: Cannot use prior adjustment factors in a pse &udo-additive seasonal',fhnote,Mt2,T) CALL writln(' adjustment.',fhnote,Mt2,F) Readok=F ELSE IF(Nfcst.eq.0)THEN CALL writln('WARNING: Pseudo-additive seasonal adjustment will n &ot produce forecasts',fhnote,Mt2,T) CALL writln(' of the final seasonal difference unless re &gARIMA forecasts are',fhnote,Mt2,F) CALL writln(' used to extend the series.',fhnote,Mt2,F) CALL writln(' The regARIMA model used to extend the seri &es cannot include',fhnote,Mt2,T) CALL writln(' regressors that result in preadjustment fa &ctors (such as outlier,',fhnote,Mt2,F) CALL writln(' trading day or holiday regressors) when ps &eudo-additive seasonal',fhnote,Mt2,F) CALL writln(' adjustment is used. If your model has suc &h regressors, use the',fhnote,Mt2,F) CALL writln(' noapply argument of the regression spec.', & fhnote,Mt2,F) END IF END IF c----------------------------------------------------------------------- c If the series is a component series and the run is just checking c input, aggregate series before leaving routine. c----------------------------------------------------------------------- IF(Lchkin)THEN IF(Iagr.eq.2.and.Iag.ge.0)THEN CALL setapt(0,0,Begspn,Sp) CALL agr(Series,O,Iag,Pos1ob,Posfob,Pos1ob,W) END IF RETURN END IF c----------------------------------------------------------------------- c If composite adjustment chosen, set up data vectors. c----------------------------------------------------------------------- c IF(Iagr.eq.3)THEN cc IF(Lcomp)Lcomp=F c IF(Pos1ob.gt.1)THEN c n=Posfob-Pos1ob+1 c CALL copy(O,n,-1,O(Posfob)) c CALL copy(Omod,n,-1,Omod(Posfob)) c CALL copy(Ci,n,-1,Ci(Posfob)) c END IF c END IF c----------------------------------------------------------------------- c set prior adjustment indicator according to whether prior c adjustment is done to original series. c----------------------------------------------------------------------- Lpradj=F IF(Kfmt.gt.0)Lpradj=T c----------------------------------------------------------------------- c make changes to selected input parameters if SEATS is used for c seasonal adjustment c----------------------------------------------------------------------- IF(Lseats)THEN IF(Maxord(1).eq.4)THEN Maxord(1)=3 CALL writln('NOTE: The maximum regular ARIMA order that the auto &matic model selection',STDERR,Mt2,T) CALL writln(' procedure will identify has been changed to t &hree (3) since SEATS',STDERR,Mt2,F) CALL writln(' seasonal adjustments are generated in this ru &n.',STDERR,Mt2,F) END IF c----------------------------------------------------------------------- c If seats seasonal adjustment is to be done, and stable seasonal c regressors are specified, allow X-13A-S to generate seasonal c factors from the regressors and remove before doing signal c extraction (added by BCM 04-10-05) c----------------------------------------------------------------------- IF(Lseff)THEN IF(Adjsea.eq.0)Adjsea=1 END IF c----------------------------------------------------------------------- c If savelog=alldiagnostics in the seats spec, set svltab to allow c all diagnostics to be saved to the log file c----------------------------------------------------------------------- IF(Svltab(LSLALS))THEN DO i=LSLSMD,LSLSSG Svltab(i)=T END DO END IF c----------------------------------------------------------------------- c reset Iyrt to 0 c----------------------------------------------------------------------- IF(Iyrt.eq.NOTSET)Iyrt=0 END IF c----------------------------------------------------------------------- IF(Nbcst2.gt.0)Lyr=Begbk2(YR) c----------------------------------------------------------------------- c Generate peak indexes, frequencies for spectral estimates c----------------------------------------------------------------------- IF (Ny.eq.12) THEN CALL mkpeak(Peakwd,Lfqalt) CALL mkfreq(Peakwd,Lfqalt,Lprsfq) END IF c ------------------------------------------------------------------ c Try to open file to store seasonal adjustment diagnostics. c ------------------------------------------------------------------ lexsum=F IF(Lgraf.or.Lsumm.gt.0.or.Hvmtdt)THEN IF(Lgraf)THEN fil=Curgrf(1:Ngrfcr)//'.udg' nchr=Ngrfcr+4 ELSE fil=Cursrs(1:Nfilcr)//'.udg' nchr=Nfilcr+4 END IF INQUIRE(FILE=fil(1:nchr),EXIST=lexsum) IF(Lgraf.or.Lsumm.gt.0)THEN CALL fopen(fil(1:nchr), & 'seasonal adjustment and modeling diagnostics', & 'UNKNOWN',Nform,argok) ELSE CALL fopen(fil(1:nchr),'user specified metadata', & 'UNKNOWN',Nform,argok) END IF Readok=argok.and.Readok IF(argok)Opnudg=T IF(Lgraf.or.Lsumm.gt.0)THEN WRITE(STDERR,1063)'diagnostics output',fil(1:nchr) ELSE IF(Hvmtdt)THEN WRITE(STDERR,1063)'metadata',fil(1:nchr) ELSE WRITE(STDERR,1065)' ' END IF C----------------------------------------------------------------------- c If graphics and diagnostic option specified in same run, print c warning message that diagnostic file(s) will be written to c graphics file directory rather than output directory. C----------------------------------------------------------------------- IF(Readok.and.Lgraf)THEN IF(Lsumm.gt.0)THEN IF(.not.Lquiet)WRITE(STDERR,1062)PRGNAM,'diagnostic' WRITE(Ng,1062)PRGNAM,'diagnostic' ELSE IF(Hvmtdt)THEN IF(.not.Lquiet)WRITE(STDERR,1062)PRGNAM,'metadata' WRITE(Ng,1062)PRGNAM,'metadata' END IF END IF ELSE IF(Readok)THEN IF(Lgraf.or.Lsumm.gt.0)THEN WRITE(STDERR,1063)'diagnostics output',fil(1:nchr) ELSE IF(Hvmtdt)THEN WRITE(STDERR,1063)'metadata',fil(1:nchr) ELSE WRITE(STDERR,1065)' ' END IF END IF c----------------------------------------------------------------------- IF(Opnudg.and.Lsumm.eq.1)THEN IF(Ltimer.and.Lgraf)THEN WRITE(STDERR,1100)PRGNAM ELSE IF(Ltimer)THEN WRITE(STDERR,1200)PRGNAM,'timer (-t)' ELSE IF(Lgraf)THEN WRITE(STDERR,1200)PRGNAM,'graphics (-g)' END IF END IF c----------------------------------------------------------------------- c Print header page and Title info c----------------------------------------------------------------------- IF(Readok)THEN CALL x12hdr(Nfcst,Srsttl,Nsrscr,Ttlvec,Notc,Lx11,Lmodel,Lseats, & Lwdprt,Begspn,Nuspad,Nustad,Iqtype,Fcntyp,Lam,Ciprob, & Dattim,Cnstnt,Isrflw,Lognrm) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Write out summary of files saved by this run of X-13A-S (including c the main output, error, and seasonal adj. diagnostic files). c----------------------------------------------------------------------- IF(sav.or.Lexout.or.Lexerr.OR.(Lsumm.gt.0))THEN c----------------------------------------------------------------------- c If no tables are printed out, see if there are any tables being c overwritten. c----------------------------------------------------------------------- IF(.not.Prttab(LSRSSV).or.Lnoprt)THEN IF(Lexout.or.Lexerr.or.((Lsumm.gt.0).and.lexsum))THEN Fhandl=Mt2 ELSE Fhandl=0 Lexist=F i=1 DO WHILE (.not.Lexist.and.i.le.NTBL) IF(.not.sumtab(i))THEN IF(Savtab(i))CALL opnfil(F,F,i,Fhandl,argok) END IF i=i+1 END DO IF(Lexist)Fhandl=Mt2 END IF c----------------------------------------------------------------------- c IF no table printed out and files are overwritten, print warning c message. c----------------------------------------------------------------------- IF(Fhandl.gt.0)THEN IF(Lquiet)THEN WRITE(Mt1,1025)PRGNAM,Cursrs(1:Nfilcr) ELSE WRITE(STDERR,1025)PRGNAM,Cursrs(1:Nfilcr) END IF END IF ELSE Fhandl=Mt1 END IF c----------------------------------------------------------------------- c Print entries for save files c----------------------------------------------------------------------- IF(Fhandl.gt.0)THEN IF(sav)THEN Lfrtop=T DO i=1,NTBL IF(.not.sumtab(i))THEN IF(Savtab(i))CALL opnfil(F,F,i,Fhandl,argok) END IF END DO ELSE WRITE(Fhandl,1020) END IF c----------------------------------------------------------------------- c Print entries for the main output, error, and seasonal adj. c diagnostic files. c----------------------------------------------------------------------- ctmp=' ' IF(Lexout)ctmp='*' WRITE(Fhandl,1030)Cursrs(1:Nfilcr)//'.out',ctmp, & 'program output file' ctmp=' ' IF(Lexerr)ctmp='*' WRITE(Fhandl,1030)Cursrs(1:Nfilcr)//'.err',ctmp, & 'program error file' IF(Lsumm.gt.0)THEN ctmp=' ' IF(Lexsum)ctmp='*' WRITE(Fhandl,1030)Cursrs(1:Nfilcr)//'.udg',ctmp, & 'seasonal adjustment and model diagnostics file' END IF IF(Lgraf)THEN ctmp=' ' IF(Lexgrf)ctmp='*' WRITE(Fhandl,1030)Cursrs(1:Nfilcr)//'.gmt',ctmp, & 'graphics metafile' END IF END IF END IF c----------------------------------------------------------------------- c Print and/or Save contents of input spc file c----------------------------------------------------------------------- IF(Savtab(LSRSIN))THEN fil=Cursrs(1:Nfilcr)//'.spc' nchr=Nfilcr+4 CALL fopen(fil(1:nchr),'input specification file', & 'UNKNOWN',nspc,argok) Readok=argok.and.Readok END IF IF(Prttab(LSRSIN).or.Savtab(LSRSIN))THEN REWIND(Mt) IF(Prttab(LSRSIN).and.Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(Prttab(LSRSIN))WRITE(Mt1,1050)Infile(1:nblank(Infile)) i=1 DO WHILE (T) READ(Mt,1060,END=10)line IF(nblank(line).gt.0)THEN IF(Savtab(LSRSIN))WRITE(nspc,1065)line(1:nblank(line)) IF(Prttab(LSRSIN))WRITE(Mt1,1070)i,line(1:nblank(line)) ELSE IF(Savtab(LSRSIN))WRITE(nspc,1065)' ' IF(Prttab(LSRSIN))WRITE(Mt1,1070)i,' ' END IF i=i+1 END DO 10 CALL fclose(Mt) IF(Savtab(LSRSIN))CALL fclose(nspc) IF(Hvmfil)THEN REWIND(Mtm) IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1080)Mdlfil(1:nblank(Mdlfil)) i=1 DO WHILE (T) READ(Mtm,1060,END=20)line IF(nblank(line).gt.0)THEN WRITE(Mt1,1070)i,line(1:nblank(line)) ELSE WRITE(Mt1,1070)i,' ' END IF i=i+1 END DO 20 CALL fclose(Mtm) END IF END IF c----------------------------------------------------------------------- c If using compositing option to derive composite total without c adjusting series, update the direct original series c----------------------------------------------------------------------- IF(Lcomp.and.Iagr.eq.2.and.Iag.ge.0)THEN CALL setapt(0,0,Begspn,Sp) CALL agr(Series,O,Iag,Pos1ob,Posfob,Pos1ob,W) END IF c----------------------------------------------------------------------- ELSE IF(.not.Readok)THEN CALL writln(' No seasonal adjustment this run',STDERR,Mt2,T) END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1020 FORMAT(/,' FILE SAVE REQUESTS (* indicates file exists and will ', & 'be overwritten)') 1025 FORMAT(/,' WARNING: Existing files will be overwritten by ', & 'this run of ',a,'.', & /,10x,'A complete listing of all the files produced by ', & 'this run ', & /,10x,'can be found in ',a,'.err') 1030 FORMAT(' ',a,a,' ',a) 1050 FORMAT(/,5x,'Contents of spc file ',a,//,' Line #',/,' ------') 1060 FORMAT(a120) 1062 FORMAT(/,' NOTE: The ',a,' ',a,' file (.udg) has been stored', & /,' in the directory specified by the graphics ', & '(-g) option.') 1065 FORMAT(a) 1063 FORMAT(' Storing any ',a,' into ',a,/) 1070 FORMAT(1x,i6,': ',a) 1080 FORMAT(/,5x,'Contents of model file ',a,//,' Line #',/, & ' ------') 1090 FORMAT(' WARNING: For ',i2,1x,a,' the number of missing ', & 'values for the ',a,' is',/, & ' greater than the number of data values ', & 'specified.',//, & ' The missing value replacement procedure ', & 'used by ',a,/, & ' cannot be considered optimal for this ', & 'situation, and the user',/, & ' should consider other methods of missing ', & 'value replacement.') 1100 FORMAT(/,' NOTE: The ',a,' diagnostic file (.udg) is generated ', & /,' since both the graphics (-g) and timer (-t) ', & 'options were',/,' specified.') 1200 FORMAT(/,' NOTE: The ',a,' diagnostic file (.udg) is generated ', & /,' since the ',a,' option was specified.') 2000 FORMAT(/,' ERROR: ',a,' was specified in the variables argument ', & 'of the regression') 2001 FORMAT(' spec but ',a,' is given in the aictest argument.') 2002 FORMAT(/,' ERROR: ',a,' prior adjustment (adjust=',a,') cannot ', & 'be specified') 2003 FORMAT(' when ',a,' is given in the aictest argument ', & 'of the ',a,/, & ' spec.',/) 3000 FORMAT(/,' ERROR: Cannot perform an AICtest for ',a,/, & ' regressors on a ',a,' time series.') c----------------------------------------------------------------------- END eee.i0000664006604000003110000000021514521201467011101 0ustar sun00315stepsC C... Variables in Common Block /eee/ ... real*8 BJSTAT1,BJSTAT2,PSTAT1,PSTAT2 common /eee/ BJSTAT1,BJSTAT2,PSTAT1,PSTAT2 eltfcn.f0000664006604000003110000000225714521201467011623 0ustar sun00315steps**==eltfcn.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE eltfcn(Oprn,Avec,Bvec,Nelt,Pc,Cvec) IMPLICIT NONE c ------------------------------------------------------------------ INTEGER ADD,SUB,MULT,DIV PARAMETER(ADD=1,SUB=2,MULT=3,DIV=4) INTEGER Oprn,Nelt,Pc DOUBLE PRECISION Avec,Bvec,Cvec DIMENSION Avec(Nelt),Bvec(Nelt),Cvec(Pc) c ------------------------------------------------------------------ INTEGER i c ------------------------------------------------------------------ DO i=1,Nelt IF(Oprn.eq.ADD)THEN Cvec(i)=Avec(i)+Bvec(i) c ------------------------------------------------------------------ ELSE IF(Oprn.eq.SUB)THEN Cvec(i)=Avec(i)-Bvec(i) c ------------------------------------------------------------------ ELSE IF(Oprn.eq.MULT)THEN Cvec(i)=Avec(i)*Bvec(i) c ------------------------------------------------------------------ ELSE IF(Oprn.eq.DIV)THEN Cvec(i)=Avec(i)/Bvec(i) END IF END DO c ------------------------------------------------------------------ RETURN END eltlen.f0000664006604000003110000000167014521201467011631 0ustar sun00315stepsC Last change: BCM 1 Dec 1998 10:09 am **==eltlen.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE eltlen(Istr,Ptrvec,Nstr,Length) IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'stdio.i' INTEGER Istr,Length,Nstr,Ptrvec DIMENSION Ptrvec(0:Nstr) INCLUDE 'units.cmn' c ----------------------------------------------------------------- IF(Istr.lt.1.or.Istr.gt.Nstr)THEN WRITE(STDERR,1010)Istr,Nstr CALL errhdr WRITE(Mt2,1010)Istr,Nstr 1010 FORMAT(' ERROR: No position',i3,' in ',i3, & ' long character vector.') CALL abend RETURN c ----------------------------------------------------------------- ELSE Length=Ptrvec(Istr)-Ptrvec(Istr-1) END IF c ----------------------------------------------------------------- RETURN END emcomp.f0000664006604000003110000000547414521201467011634 0ustar sun00315steps SUBROUTINE emcomp(Emu,Efreq,Ndays) IMPLICIT NONE c----------------------------------------------------------------------- c Generate Easter means given a set of frequencies for Easter given c by the user (Efreq). c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c----------------------------------------------------------------------- INTEGER kdate,Ndays,period,cmlnmo,julbeg,julend,ibeg,iend,itmp, & juleas DOUBLE PRECISION Emu,Efreq,tmp DIMENSION Emu(2:4),Efreq(35),cmlnmo(13) c----------------------------------------------------------------------- DATA cmlnmo/0,31,59,90,120,151,181,212,243,273,304,334,365/ c----------------------------------------------------------------------- c initialize easter mean for each month (Feb, March, April) c----------------------------------------------------------------------- DO period=2,4 Emu(period)=ZERO c----------------------------------------------------------------------- c compute percentage within easter window for each possible day of c easter. c----------------------------------------------------------------------- DO kdate=1,35 c----------------------------------------------------------------------- c Monthly Easter effect. Calculating Julian date of beginning and c ending of present month c----------------------------------------------------------------------- julbeg=cmlnmo(period)+1 julend=cmlnmo(period+1) c----------------------------------------------------------------------- c Calculating Julian date of holidays and proportion of days in c month which fall within the holiday window. Easter first. c Computing beginning and ending dates of current month c which overlap with holiday effect window c----------------------------------------------------------------------- juleas=cmlnmo(3)+22+kdate ibeg=max(julbeg,juleas-ndays) iend=min(julend,juleas-1) c----------------------------------------------------------------------- c Dividing days in current month which fall within window c by length of window to computed proportion of days c----------------------------------------------------------------------- tmp=ZERO IF(ibeg.le.iend)THEN itmp=iend-ibeg+1 tmp=dble(itmp)/dble(ndays) END IF c----------------------------------------------------------------------- c multiply percentage by frequency of occurance to get easter mean c----------------------------------------------------------------------- Emu(period)=Emu(period)+tmp*Efreq(kdate) END DO END DO c----------------------------------------------------------------------- RETURN END ends.f0000664006604000003110000000467614521201467011310 0ustar sun00315steps**==ends.f processed by SPAG 4.03F at 12:14 on 10 Mar 1994 SUBROUTINE ends(Stc,Stci,Ib,Ie,K,Rbeta) IMPLICIT NONE c----------------------------------------------------------------------- C --- X11 TREND CYCLE END WEIGHTS. c----------------------------------------------------------------------- INCLUDE 'hender.prm' c----------------------------------------------------------------------- C Changed March, 1994 By Brian Monsell (SRD) to incorporate c Henderson end filter generation routine based on Doherty(1993) c algorithm. c----------------------------------------------------------------------- INTEGER i,Ib,Ie,j,K,l,m,n,lm DOUBLE PRECISION Stc,Stci,wtcntr,wtend,Rbeta DIMENSION Stc(*),Stci(*),wtcntr(PMXHN2),wtend(PMXHN1) c----------------------------------------------------------------------- C --- Code starts here c----------------------------------------------------------------------- c Generate central Henderson filter weight for a filter of length K c----------------------------------------------------------------------- CALL hender(wtcntr,K) c----------------------------------------------------------------------- m=K-1 l=m/2 lm=(K+1)/2 c----------------------------------------------------------------------- c Initialize end and beginning of trend c----------------------------------------------------------------------- DO i=1,l Stc(Ib+i-1)=0D0 Stc(Ie-i+1)=0D0 c----------------------------------------------------------------------- c Determine the length of the end filter needed for this observation c----------------------------------------------------------------------- n=lm+i-1 c----------------------------------------------------------------------- c Generate Henderson end filters for given value of Rbeta. c----------------------------------------------------------------------- CALL hndend(n,K,wtcntr,wtend,Rbeta) c----------------------------------------------------------------------- c Apply n-term end filter to the beginning and end of the series. c----------------------------------------------------------------------- DO j=1,n Stc(Ib+i-1)=wtend(n-j+1)*Stci(Ib+j-1)+Stc(Ib+i-1) Stc(Ie-i+1)=wtend(n-j+1)*Stci(Ie-j+1)+Stc(Ie-i+1) END DO END DO c----------------------------------------------------------------------- RETURN END endsf.f0000664006604000003110000000226314521201467011444 0ustar sun00315steps SUBROUTINE endsf(Simon,Savg,K,W,Nend) IMPLICIT NONE C----------------------------------------------------------------------- C --- APPLY END WEIGHTS FOR THE 3X9 or 3X15 C----------------------------------------------------------------------- DOUBLE PRECISION Simon,Savg,W,totals,Sumwt INTEGER K,kk,jj,j1,j2,jk,l,Nend DIMENSION Simon(*),Savg(*),W(*) EXTERNAL totals C----------------------------------------------------------------------- kk=0 jj=1 j1=jj j2=K DO WHILE (jj.le.Nend.and.j1.le.j2) jk=jj+Nend IF(jk.gt.K)THEN Savg(j1)=totals(Simon,1,K,1,1) IF(j1.ne.j2)Savg(j2)=Savg(j1) ELSE Savg(j1)=0D0 Savg(j2)=0D0 Sumwt=0D0 DO l=1,jk Savg(j1)=Savg(j1)+W(kk+l)*Simon(l) IF(j1.ne.j2)Savg(j2)=Savg(j2)+W(kk+l)*Simon(K-l+1) Sumwt=Sumwt+W(kk+l) END DO Savg(j1)=Savg(j1)/Sumwt Savg(j2)=Savg(j2)/Sumwt END IF kk=kk+jk jj=jj+1 j1=jj j2=K-jj+1 END DO C----------------------------------------------------------------------- RETURN END enorm.f0000664006604000003110000000670314521201467011470 0ustar sun00315stepsC Last change: BCM 29 Sep 97 9:42 am **==enorm.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 DOUBLE PRECISION FUNCTION enorm(N,X) IMPLICIT NONE INTEGER N DOUBLE PRECISION X(N) C ********** C C FUNCTION ENORM C C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE C EUCLIDEAN NORM OF X. C C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION ENORM(N,X) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE. C C X IS AN INPUT ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... DABS,DSQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** c----------------------------------------------------------------------- c Made the data statements parameters c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE,RDWARF,RGIANT PARAMETER(ZERO=0.0D0,ONE=1.0D0,RDWARF=3.834D-20,RGIANT=1.304D19) DOUBLE PRECISION agiant,floatn,s1,s2,s3,xabs,x1max,x3max INTEGER i c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c DOUBLE PRECISION AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS, c * X1MAX,X3MAX,ZERO c DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/ s1=ZERO s2=ZERO s3=ZERO x1max=ZERO x3max=ZERO floatn=N agiant=RGIANT/floatn DO i=1,N xabs=dabs(X(i)) IF(xabs.gt.RDWARF.and.xabs.lt.agiant)THEN C C SUM FOR INTERMEDIATE COMPONENTS. C s2=s2+xabs**2 ELSE IF(xabs.le.RDWARF)THEN C C SUM FOR SMALL COMPONENTS. C IF(xabs.le.x3max)THEN IF(.not.dpeq(xabs,ZERO))s3=s3+(xabs/x3max)**2 ELSE s3=ONE+s3*(x3max/xabs)**2 x3max=xabs END IF C C SUM FOR LARGE COMPONENTS. C ELSE IF(xabs.le.x1max)THEN s1=s1+(xabs/x1max)**2 ELSE s1=ONE+s1*(x1max/xabs)**2 x1max=xabs END IF END DO C C CALCULATION OF NORM. C IF(.not.dpeq(s1,ZERO))THEN enorm=x1max*dsqrt(s1+(s2/x1max)/x1max) ELSE IF(dpeq(s2,ZERO).and.s3.gt.ZERO)THEN enorm=x3max*dsqrt(s3) ELSE IF(dpeq(x3max,ZERO).and.dpeq(dsqrt(s2),ZERO))THEN enorm=ZERO ELSE IF(s2.ge.x3max)enorm=dsqrt(s2*(ONE+(x3max/s2)*(x3max*s3))) IF(s2.lt.x3max)enorm=dsqrt(x3max*((s2/x3max)+(x3max*s3))) END IF END IF RETURN C C LAST CARD OF FUNCTION ENORM. C END entsch.f0000664006604000003110000000143714521201470011625 0ustar sun00315steps**==entsch.f processed by SPAG 4.03F at 16:21 on 30 Mar 1994 C*********************************************************************** c This routine is modified code which originally appeared in X12W - c the seasonal adjustment program developed by the Budesbank C*********************************************************************** SUBROUTINE entsch(Ken,Ker,Ken1,Ker1,Iv) IMPLICIT NONE C*** Start of declarations inserted by SPAG INTEGER Iv,k,Ken,Ken1,Ker,Ker1 C*** End of declarations inserted by SPAG k=Ken+Ker+1 Ken1=0 Ker1=0 GO TO(10,20,30,40,50),k 10 Ken1=Iv Ker1=2 GO TO 50 20 Ken1=1 GO TO 50 30 Ken1=Iv Ker1=Iv GO TO 50 40 Ken1=1 Ker1=2 50 RETURN END eprint.f0000664006604000003110000000202714521201470011636 0ustar sun00315steps SUBROUTINE eprint(S) c----------------------------------------------------------------------- c eprint.f, Release 1, Subroutine Version 1.3, Modified 24 Jan 1995. c----------------------------------------------------------------------- c eprint - print error, Lahey pc version c----------------------------------------------------------------------- c Author - Larry Bobbitt c Statistical Research Division c U.S. Census Bureau c Room 3000-4 c Washington, D.C. 20233 c (301) 763-3957 c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'stdio.i' c ------------------------------------------------------------------ CHARACTER*(*) S c ------------------------------------------------------------------ WRITE(STDERR,*)'

ERROR: ',S,'

' c ------------------------------------------------------------------ RETURN END errhdr.f0000664006604000003110000000361114521201470011623 0ustar sun00315steps SUBROUTINE errhdr IMPLICIT NONE C----------------------------------------------------------------------- c print a header in the error file to denote that this error was c generated by a particular hidden run from the sliding spans or c revision history analysis. C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'ssap.prm' INCLUDE 'ssft.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'units.cmn' C----------------------------------------------------------------------- CHARACTER dash*(1),star*(1) INTEGER i c----------------------------------------------------------------------- DATA dash,star/'-','*'/ c----------------------------------------------------------------------- IF(Issap.lt.2.and.Irev.lt.4)RETURN IF((Issap.eq.2.and.Ierhdr.eq.Icol).or. & (Irev.eq.4.and.Ierhdr.eq.Revptr))RETURN C----------------------------------------------------------------------- IF(Issap.eq.2)THEN WRITE(Mt2,1010)(star,dash,i=1,40) WRITE(Mt2,1020)Icol Ierhdr=Icol ELSE IF(Issap.eq.3.and.Ierhdr.ne.NOTSET)THEN WRITE(Mt2,1010)(star,dash,i=1,40) WRITE(Mt2,1040)' ' Ierhdr=NOTSET ELSE IF(Irev.eq.4)THEN WRITE(Mt2,1010)(star,dash,i=1,40) WRITE(Mt2,1030)Crvend(1:Nrvend) Ierhdr=Revptr ELSE IF(Irev.eq.5.and.Ierhdr.ne.NOTSET)THEN WRITE(Mt2,1010)(star,dash,i=1,40) WRITE(Mt2,1040)' ' Ierhdr=NOTSET END IF C----------------------------------------------------------------------- 1010 FORMAT(80A1) 1020 FORMAT(' Error/Warning Messages for sliding span # ',i1,':') 1030 FORMAT(' Error/Warning Messages for history run ending ',a,':') 1040 FORMAT(A) RETURN END error.cmn0000664006604000003110000000053314521201470012016 0ustar sun00315stepsC----------------------------------------------------------------------- c Logical indicator variable for program errors during execution. C----------------------------------------------------------------------- LOGICAL Lfatal COMMON /fcnerr/ Lfatal C----------------------------------------------------------------------- estb.i0000664006604000003110000000015014521201470011270 0ustar sun00315stepsC C... Variables in Common Block /estb/ ... integer NCHI,NCYC common /estb/ NCHI,NCYC estgc.i0000664006604000003110000000007714521201470011450 0ustar sun00315steps real*8 gc(32),gs(32),gt(32) common /estgc/ gc,gs,gt estrmu.f0000664006604000003110000001112714521201470011655 0ustar sun00315stepsC Last change: BCM 3 Feb 1999 9:10 am SUBROUTINE estrmu(Begdat,Nrxy,Sp,Ndays,Hlong,Hmean,Hstock) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine computes a function that removes the easter mean c effect from combined calendar runs. c----------------------------------------------------------------------- c BCM April, 2016 - add mean for easter(0) regressor c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- LOGICAL F INTEGER MO DOUBLE PRECISION ZERO PARAMETER(MO=2,ZERO=0D0,F=.false.) c----------------------------------------------------------------------- LOGICAL Hlong,Hstock INTEGER Begdat,Ndays,Nrxy,i,i1,mnindx,n,Sp,n2,n3,tdat DOUBLE PRECISION txy,Hmean DIMENSION Begdat(2),txy(1,PLEN),Hmean(*),tdat(2) c----------------------------------------------------------------------- c Means of Easter regressors from 500 year span (1600-2099) c Source : Bednarek (http://home.swiftdsl.com.au/~mbednarek//easter.php) c----------------------------------------------------------------------- DOUBLE PRECISION emeans DIMENSION emeans(26,2:4) c----------------------------------------------------------------------- DATA(emeans(i,2),i=1,26)/ & 0.00368D0,0.002083333D0,0.001130435D0,0.0002727273D0,0D0, & 0D0,0D0,0D0,0D0,0D0, & 0D0,0D0,0D0,0D0,0D0, & 0D0,0D0,0D0,0D0,0D0, & 0D0,0D0,0D0,0D0,0D0,0D0/ DATA(emeans(i,3),i=1,26)/ & 0.6576D0,0.6450833D0,0.6311304D0,0.6162727D0,0.5999048D0, & 0.583D0,0.5661053D0,0.549D0,0.5318824D0,0.514625D0, & 0.4973333D0,0.4807143D0,0.4643077D0,0.4476667D0,0.4305455D0, & 0.4136D0,0.3975556D0,0.382D0,0.3654286D0,0.3483333D0, & 0.3304D0,0.3125D0,0.2966667D0,0.281D0,0.266D0,0.232D0/ DATA(emeans(i,4),i=1,26)/ & 0.33872D0,0.3528333D0,0.3677391D0,0.3834545D0,0.4000952D0, & 0.417D0,0.4338947D0,0.451D0,0.4681176D0,0.485375D0, & 0.5026667D0,0.5192857D0,0.5356923D0,0.5523333D0,0.5694545D0, & 0.5864D0,0.6024444D0,0.618D0,0.6345714D0,0.6516667D0, & 0.6696D0,0.6875D0,0.7033333D0,0.719D0,0.734D0,0.768D0/ c----------------------------------------------------------------------- c IF long term means requested, store means from previous version c of X-13ARIMA-SEATS into vector c----------------------------------------------------------------------- IF(Hlong)THEN c----------------------------------------------------------------------- c Set index for holiday means c----------------------------------------------------------------------- mnindx=25-Ndays+1 c----------------------------------------------------------------------- c Compute monthly means for Easter c----------------------------------------------------------------------- IF(Sp.eq.4)THEN DO i=1,Sp IF(i.eq.1)THEN Hmean(i)=emeans(mnindx,2)+emeans(mnindx,3) ELSE IF(i.eq.2)THEN Hmean(i)=emeans(mnindx,4) ELSE Hmean(i)=ZERO END IF END DO ELSE DO i=1,Sp IF(i.ge.2.and.i.le.4)THEN Hmean(i)=emeans(mnindx,i) ELSE Hmean(i)=ZERO END IF END DO END IF c----------------------------------------------------------------------- ELSE c----------------------------------------------------------------------- c Ensure that full years are used in computing Hmean c Update : BCM 2-1999 c----------------------------------------------------------------------- CALL cpyint(Begdat,2,1,tdat) n2=Nrxy IF(tdat(MO).gt.1)THEN n2=n2+tdat(MO)-1 tdat(MO)=1 END IF n3=MOD(n2,Sp) IF(n3.GT.0)n2=n2+Sp-n3 c----------------------------------------------------------------------- CALL adestr(tdat,n2,1,Sp,1,Ndays,0,txy,F,Hmean,Hstock) c----------------------------------------------------------------------- DO i=1,Sp Hmean(i)=ZERO IF((Sp.eq.12.AND.(i.ge.2.and.i.le.4)).OR. & (Sp.eq.4.AND.(i.eq.1.or.i.eq.2)))THEN i1=i n=1 DO WHILE(n.le.29.and.i1.le.n2) Hmean(i)=Hmean(i)+txy(1,i1) i1=i1+Sp n=n+1 END DO Hmean(i)=Hmean(i)/dble(n-1) END IF END DO END IF c----------------------------------------------------------------------- RETURN END euclid.f0000664006604000003110000001110714521201470011601 0ustar sun00315steps**==euclid.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE euclid(Fular,B,A,Maxpq,Mxarlg,Mxmalg,G,Err) c----------------------------------------------------------------------- c Solves the scalar polynomial equation : c Fular(Z).F(ZINV)+F(Z).Fular(ZINV)=G(Z) c using the Euclid algorithm . c Fular contains AR coefficients from lag 0 to lag Mxarlg c G contain autocovariances from the MA model from lags 0 to Mxmalg , c On completion the solution for F is in G from lags 0 to MAXPQ. c Fular is unchanged.This array could be removed by calling with\ c Fular in B. c The first loop in the subroutine merely copies Fular into B and does c not thereafter use Fular. c Working arrays : B holds the polynomial coefficients at c the start, and on completion holds the stability test scalars R. c A holds the corresponding values 1/(1-R*R). This array could also be c removed by recomputing 1/(1-R*R) from the contents of B in the DO 200 c loop. c ERR is set to 0 on successful exit, but if the AR coefficients do c not satisfy the stationarity condition an exit takes place part way c through the computation with ERR set to 1. c FORTRAN corrections made by Bill Bell -- 9/10/92 c 1. Integer declaration statement put before double precision c declaration statement c 2. REAL Fular(P),G(0:MAXPQ),B(Mxarlg),A(Mxarlg) changed to c double precision Fular(max(Mxarlg,1)),B(max(Mxarlg,1)), c A(max(Mxarlg,1)) to handle case c where Mxarlg = 0 c FORTRAN correction sent by Granville Tunnicliffe-Wilson -- 9/21/92 c IF (Mxarlg.GT.1)THEN changed to if (mxarlg.ge.1) then c at what is now line 99. c Changes made: 9/21/92, Bill Bell c 1. IMPLICIT NONE statement added c 2. REAL type statements changed to DOUBLE PRECISION c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION ONE,TWO,ZERO PARAMETER(ONE=1D0,TWO=2D0,ZERO=0D0) INTEGER i,Err,fsthlf,lsthlf,lim,Maxpq,midpt,Mxarlg,Mxmalg DOUBLE PRECISION G(0:Maxpq),Fular(0:Mxarlg),B(Mxarlg),A(Mxarlg),r, & s,bs,br,gs,gr c----------------------------------------------------------------------- c Initialization of coefficients of working arrays c----------------------------------------------------------------------- DO i=1,Mxarlg B(i)=Fular(i) END DO c----------------------------------------------------------------------- c Start of order reduction loop. c----------------------------------------------------------------------- Err=0 DO i=Maxpq,1,-1 IF(i.le.Mxarlg)THEN r=B(i) c ------------------------------------------------------------------ IF(abs(r).gt.ONE)THEN Err=1 GO TO 10 END IF c ------------------------------------------------------------------ s=ONE/(ONE-r*r) A(i)=s midpt=i/2 c ------------------------------------------------------------------ DO fsthlf=1,midpt lsthlf=i-fsthlf bs=B(fsthlf) br=B(lsthlf) B(fsthlf)=(bs-br*r)*s B(lsthlf)=(br-bs*r)*s END DO END IF c----------------------------------------------------------------------- c Correction of G by reduced coefficients c----------------------------------------------------------------------- lim=i-1 IF(i.gt.Mxarlg)lim=Mxarlg c ------------------------------------------------------------------ IF(i.gt.Mxmalg)THEN lim=0 G(i)=ZERO END IF c ------------------------------------------------------------------ DO fsthlf=1,lim lsthlf=i-fsthlf G(lsthlf)=G(lsthlf)-B(fsthlf)*G(i) END DO END DO c----------------------------------------------------------------------- c End of reduction loop, Start of construction loop c----------------------------------------------------------------------- G(0)=G(0)/TWO c----------------------------------------------------------------------- c Zero step completed c----------------------------------------------------------------------- DO i=1,Mxarlg midpt=i/2 c ------------------------------------------------------------------ DO fsthlf=0,midpt lsthlf=i-fsthlf gs=G(fsthlf) gr=G(lsthlf) G(fsthlf)=(gs-B(i)*gr)*A(i) G(lsthlf)=(gr-B(i)*gs)*A(i) END DO END DO c ------------------------------------------------------------------ 10 RETURN END exctma.f0000664006604000003110000000602014521201470011613 0ustar sun00315stepsC Last change: BCM 10 Jul 1998 2:34 pm **==exctma.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE exctma(Nc,A,Nelta,Nata) IMPLICIT NONE c----------------------------------------------------------------------- c Filters the matrix, A, using the MA operators c a=[1/th(B)]*z, c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,MONE PARAMETER(ZERO=0D0,MONE=-1D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ INTEGER PXA PARAMETER(PXA=(PB+1)*(PLEN+2*PORDER)) c ------------------------------------------------------------------ INTEGER Nc,Nelta,neltq,Nata DOUBLE PRECISION A,work DIMENSION A(Nata),work(PXA) c----------------------------------------------------------------------- c If there are no lag operators then there is no ARIMA model so c the input doesn't need to be filtered c----------------------------------------------------------------------- Nopr=Mdl(MA)-1 IF(Nopr.gt.0)THEN c----------------------------------------------------------------------- c Exact filtering requires calculating the initial values of the c differenced series, w*=-(G'G)^-1 G'Hw. c----------------------------------------------------------------------- IF(Lma)THEN neltq=Mxmalg*Nc CALL copy(A,Nelta,-1,A(neltq+1)) c----------------------------------------------------------------------- c Form Hw c----------------------------------------------------------------------- CALL copy(A(neltq+1),Nelta,1,work(neltq+1)) CALL setdp(ZERO,neltq,work) Nelta=neltq+Nelta c ------------------------------------------------------------------ CALL ratpos(Nelta,Arimap,Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,Nelta, & work) c----------------------------------------------------------------------- c Form G'Hw c----------------------------------------------------------------------- CALL ratneg(Nelta,Arimap,Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,work) c----------------------------------------------------------------------- c Get the w*'s=-inv(G'G) * G'Hw. c----------------------------------------------------------------------- CALL dsolve(Chlgpg,Mxmalg,Nc,.true.,work) c ------------------------------------------------------------------ CALL scrmlt(MONE,neltq,work) CALL copy(work,neltq,1,A) END IF c----------------------------------------------------------------------- c MA filter what's left c----------------------------------------------------------------------- CALL ratpos(Nelta,Arimap,Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,Nelta,A) END IF c ------------------------------------------------------------------ RETURN END extend.cmn0000664006604000003110000000153014521201470012152 0ustar sun00315stepsc----------------------------------------------------------------------- c Nobspf - number of observations copied c Nofpob - number of forecasts plus observations c Nbfpob - number of backcasts plus forecasts plus observations c Nfcst - number of forecasts c Nbcst - number of backcasts c Nbcst2 - number of backcasts + Number of observations from start c of series to January of first year c Begbak - beginning date of backcast extended series c Begbk2 - beginning date of data vectors (first period of Begbak) c----------------------------------------------------------------------- INTEGER Begbak,Begbk2,Nbcst2,Nobspf,Nfcst,Nbcst,Nofpob,Nbfpob, & Nfdrp DIMENSION Begbak(2),Begbk2(2) COMMON /fctcmn / Begbak,Begbk2,Nfcst,Nbcst,Nbcst2,Nobspf,Nofpob, & Nbfpob,Nfdrp extend.f0000664006604000003110000001202314521201471011622 0ustar sun00315stepsC Last change: BCM 29 Sep 97 10:13 am SUBROUTINE extend(Trnsrs,Begxy,Orix,Extok,Lam,Fcst,Bcst) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' c INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11opt.cmn' c ------------------------------------------------------------------ LOGICAL F,T DOUBLE PRECISION ZERO PARAMETER(F=.false.,T=.true.,ZERO=0D0) c ------------------------------------------------------------------ LOGICAL Extok INTEGER i,Begxy,fhnote DOUBLE PRECISION Orix,Trnsrs,Fcst,Bcst,Lam,bcst2 DIMENSION Fcst(PFCST),Bcst(PFCST),Orix(PLEN),Trnsrs(PLEN), & Begxy(2),bcst2(PFCST) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ c calculate ending date of series c ------------------------------------------------------------------ Extok=T fhnote=STDERR IF(Lquiet)fhnote=0 c----------------------------------------------------------------------- c If multiplicative SA and transformation not log, check forecasts c to see if they are negative. If so, print warning message and c do not perform forecast extension. c----------------------------------------------------------------------- IF(Nfcst.gt.0)THEN IF((.not.dpeq(Lam,ZERO)).and.Muladd.ne.1)THEN i=1 DO WHILE (i.le.Nfcst.and.Extok) IF(Psuadd.and.Fcst(i).lt.ZERO)THEN CALL writln('WARNING: Forecast extension cannot be done for ps &eudo-additive seasonal',fhnote,Mt2,T) CALL writln(' adjustment due to negative values found &in forecasts.',fhnote,Mt2,F) Extok=F ELSE IF(Fcst(i).le.ZERO)THEN CALL writln('WARNING: Forecast extension cannot be done for mu <iplicative or log-',fhnote,Mt2,F) CALL writln(' additive seasonal adjustment due to nega &tive or zero values ',fhnote,Mt2,F) CALL writln(' found in forecasts.',STDERR,Mt2,F) Extok=F END IF i=i+1 END DO END IF END IF c----------------------------------------------------------------------- c If multiplicative SA and transformation not log, check forecasts c to see if they are negative. If so, print warning message and c do not perform forecast extension. c----------------------------------------------------------------------- IF(Nbcst.gt.0.and.Extok)THEN IF((.not.dpeq(Lam,ZERO)).and.Muladd.ne.1)THEN i=1 DO WHILE (i.le.Nbcst.and.Extok) IF(Psuadd.and.Bcst(i).lt.ZERO)THEN CALL writln('WARNING: Backcast extension cannot be done for ps &eudo-additive seasonal',fhnote,Mt2,T) CALL writln(' adjustment due to negative values found &in backcasts.',fhnote,Mt2,F) Extok=F ELSE IF(Bcst(i).le.ZERO)THEN CALL writln('WARNING: Backcast extension cannot be done for mu <iplicative or log-',fhnote,Mt2,F) CALL writln(' additive seasonal adjustment due to nega &tive or zero values ',fhnote,Mt2,F) CALL writln(' found in backcasts.',STDERR,Mt2,F) Extok=F END IF i=i+1 END DO END IF END IF c----------------------------------------------------------------------- c copy transformed series to original vector c----------------------------------------------------------------------- CALL copy(Trnsrs,Nspobs,1,Orix(Pos1ob)) c----------------------------------------------------------------------- c Append forecasts, backcasts to series c----------------------------------------------------------------------- IF(.not.Extok)RETURN IF(Nfcst.gt.0)CALL copy(Fcst,Nfcst,1,Orix(Posfob+1)) c----------------------------------------------------------------------- c Append backcasts c----------------------------------------------------------------------- IF(Nbcst.gt.0)THEN c----------------------------------------------------------------------- c adjust Xy dates for backcasts c----------------------------------------------------------------------- Begxy(YR)=Begbak(YR) Begxy(MO)=Begbak(MO) c----------------------------------------------------------------------- c copy backcasts to beginning of series. c----------------------------------------------------------------------- CALL revrse(Bcst,Nbcst,1,bcst2) CALL copy(bcst2,Nbcst,1,Orix(Pos1bk)) END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END extsgnl.f0000664006604000003110000004520714521201471012031 0ustar sun00315steps SUBROUTINE extSgnl( nT, dS, dT, vY, mDel, dDel, nDel, & mDelS, dDelS, nDelS, mDelT, dDelT, nDelT, & sdSigAlt, mRedDelS, dRedDelS, nRedDelS, & mRedDelT, dRedDelT, nRedDelT, mSigUS, nSigUS, & mSigUT, nSigUT, mSigUI, nSigUI, & mSigWS, nSigWS, mSigWT, nSigWT, & mSigW, nSigW, mInvSigW, nInvSigW, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & vIrrEst, nIrrEst, vSeaEst, nSeaEst, & vTreEst, nTreEst, mCovIrr, nCovIrr, & mCovSea, nCovSea, mCovTre, nCovTre, & mCovSA, nCovSA, & mIrrPFlt, nIrrPFlt, mSeaPFlt, nSeaPFlt, & mTrePFlt, nTrePFlt, mSAPFlt, nSAPFlt ) c----------------------------------------------------------------------- c extSgnl.f, Release 1, Subroutine Version 1.4, Modified 24 Jan 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 11 Apr 2005. c Modified by REG, on 19 Sep 2005, to add output of SA filter, c and to clean up tab stops. c Modified by REG, on 20 Oct 2005, to move sdSigAlt processing c from bldCov() to this routine, and to remove calculation c of signal extraction MSE variances that are now calculated c by compMSE: mIrrVar, mSeaVar, mTreVar. c Modified by REG, on 07 Nov 2005, to generalize irregular component c to allow non white noise covariance structure: mSigUI. c Modified by REG, on 24 Jan 2006, to use the diagonal form of the c mDel matrices and associated matrix manipulation utilities, c and to use inverse of matrices calculated externally. c----------------------------------------------------------------------- c This subroutine calculates the some signal estimators and some c covariance matrices. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dS i size of Seasonal Differencing c dT i size of Trend Differencing c dDel d diagonal form of overall differencing matrix c dDelS d diagonal form of seasonal differencing matrix c dDelT d diagonal form of trend differencing matrix c dRedDelS d diagonal form of smaller version of mDelS c dRedDelT d diagonal form of smaller version of mDelT c mCovIrr d covariance of estimated irregular c mCovSA d covariance of estimated seasonal adjusted c mCovSea d covariance of estimated seasonal c mCovTre d covariance of estimated trend c mInvSigUS d inverse of mSigUS c mInvSigUT d inverse of mSigUT c mInvSigW d inverse of mSigW c mInvSigWS d inverse of mSigWS c mInvSigWT d inverse of mSigWT c mSigUI d covariance matrix for undifferenced irregular c mSigUS d covariance matrix for differenced seasonal c mSigUT d covariance matrix for differenced trend c mSigW d covariance matrix for differenced data c mSigWS d covariance matrix for differenced trend adjusted c mSigWT d covariance matrix for differenced seasonally adjusted c mIrrPFlt d irregular component filter matrix c (row 1 = symmetric, row 2 = concurrent) c mSAPFlt d seasonal adjustment filter matrix c (row 1 = symmetric, row 2 = concurrent) c mSeaPFlt d seasonal component filter matrix c (row 1 = symmetric, row 2 = concurrent) c mTrePFlt d trend component filter matrix c (row 1 = symmetric, row 2 = concurrent) c nCovIrr d size (rows,columns) of mCovIrr matrix c nCovSA d size (rows,columns) of mCovSA matrix c nCovSea d size (rows,columns) of mCovSea matrix c nCovTre d size (rows,columns) of mCovTre matrix c nDel i size (rows,columns) of dDel c nDelS i size (rows,columns) of dDelS c nDelT i size (rows,columns) of dDelT c nInvSigUS i size (rows,columns) of mInvSigUS matrix c nInvSigUT i size (rows,columns) of mInvSigUT matrix c nInvSigW i size (rows,columns) of mInvSigW matrix c nInvSigWS i size (rows,columns) of mInvSigWS matrix c nInvSigWT i size (rows,columns) of mInvSigWT matrix c nRedDelS i size (rows,columns) of dRedDelS c nRedDelT i size (rows,columns) of dRedDelT c nSigUI i size (rows,columns) of mSigUI matrix c nSigUS i size (rows,columns) of mSigUS matrix c nSigUT i size (rows,columns) of mSigUT matrix c nSigW i size (rows,columns) of mSigW matrix c nSigWS i size (rows,columns) of mSigWS matrix c nSigWT i size (rows,columns) of mSigWT matrix c nIrrEst i size (rows,columns) of vIrrEst vector c nIrrPFlt i size (rows,columns) of mIrrFlt matrix c nSAPFlt i size (rows,columns) of mSAFlt matrix c nSeaEst i size (rows,columns) of vSeaEst vector c nSeaPFlt i size (rows,columns) of mSeaFlt matrix c nTreEst i size (rows,columns) of vTreEst vector c nTrePFlt i size (rows,columns) of mTreFlt matrix c nT i size of data available c sdSigAlt d alternate data innovation stdev when parameters are fixed c vIrrEst d estimated irregular c vSeaEst d estimated seasonal c vTreEst d estimated trend c vY d data vector c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i,j i index variables c mFSTIIrr d irregular extraction matrix c mQuadUS d result of quadratic matrix operation c mQuadUT d result of quadratic matrix operation c mQuadWS d result of quadratic matrix operation c mQuadWSp1 d intermediate result of quadratic matrix operation c mQuadWT d result of quadratic matrix operation c mQuadWTp1 d intermediate result of quadratic matrix operation c mQuadW d result of quadratic matrix operation c mQuadWp1 d intermediate result of quadratic matrix operation c nSave i identifies default size of large matrices c that are saved (not dynamic) c mTemp1 d temporary matrix 1 c mTemp2 d temporary matrix 2 c mTemp4 d temporary matrix 4 c mTemp5 d temporary matrix 5 c mTemp6 d temporary matrix 6 c mTemp8 d temporary matrix 8 c nY i size (rows,columns) of vY vector c nFSTIrr i size (rows,columns) of mFSTIrr matrix c nResult i size (rows,columns) of sResult scalar c nTemp1 i size (rows,columns) of mTemp1 matrix c nTemp2 i size (rows,columns) of mTemp2 matrix c nTemp4 i size (rows,columns) of mTemp4 matrix c nTemp5 i size (rows,columns) of mTemp5 matrix c nTemp6 i size (rows,columns) of mTemp6 matrix c nTemp8 i size (rows,columns) of mTemp8 matrix c nTempC i size (rows,columns) of mTempC matrix c nQuadUS i size (rows,columns) of nQuadUS matrix c nQuadUT i size (rows,columns) of nQuadUT matrix c nQuadWS i size (rows,columns) of nQuadWS matrix c nQuadWSp1 i size (rows,columns) of nQuadWSp1 matrix c nQuadWT i size (rows,columns) of nQuadWT matrix c nQuadWTp1 i size (rows,columns) of nQuadWTp1 matrix c nQuadW i size (rows,columns) of nQuadW matrix c nQuadWp1 i size (rows,columns) of nQuadWp1 matrix c sResult d scalar result of matrix operations c vTempC d temporary vector C c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nT, dS, dT INTEGER nDel(2), nDelS(2), nDelT(2), nRedDelS(2), nRedDelT(2) INTEGER nSigUI(2), nSigUS(2), nSigUT(2), nInvSigUS(2), & nInvSigUT(2) INTEGER nSigWS(2), nSigWT(2), nSigW(2), nInvSigWS(2), & nInvSigWT(2) INTEGER nInvSigW(2) INTEGER nIrrEst(2), nSeaEst(2), nTreEst(2) INTEGER nCovIrr(2), nCovSea(2), nCovTre(2), nCovSA(2) INTEGER nIrrPFlt(2), nSeaPFlt(2), nTrePFlt(2), nSAPFlt(2) DOUBLE PRECISION vY(nT), sdSigAlt DOUBLE PRECISION dDel(dS+dT+1),dDelS(dS+1),dDelT(dT+1), & dRedDelS(dS+1), dRedDelT(dT+1) DOUBLE PRECISION mDel(nT-dS-dT,nT), mDelS(nT-dS,nT), & mDelT(nT-dT,nT), mRedDelS(nT-dS-dT,nT-dT), & mRedDelT(nT-dS-dT,nT-dS) DOUBLE PRECISION mSigUI(nT,nT), mSigUS(nT-dS,nT-dS), & mSigUT(nT-dT,nT-dT) DOUBLE PRECISION mSigWS(nT-dS,nT-dS), mSigWT(nT-dT,nT-dT), & mSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION vIrrEst(nT), vSeaEst(nT), vTreEst(nT) DOUBLE PRECISION mCovIrr(nT,nT), mCovSea(nT-dS,nT-dS), & mCovTre(nT-dT,nT-dT), mCovSA(nT-dT,nT-dT) DOUBLE PRECISION mInvSigUS(nT-dS,nT-dS), mInvSigUT(nT-dT,nT-dT) DOUBLE PRECISION mInvSigWS(nT-dS,nT-dS), mInvSigWT(nT-dT,nT-dT), & mInvSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION mIrrPFlt(nT-dS-dT,2), mSAPFlt(nT-dS,2), & mSeaPFlt(nT-dT,2), mTrePFlt(nT-dS,2) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, ibase INTEGER nResult(2), nY(2) INTEGER nTemp1(2), nTemp2(2), nTemp4(2), & nTemp5(2), nTemp6(2), nTemp8(2) INTEGER nTempC(2) INTEGER nFSTIIrr(2) INTEGER nQuadUS(2), nQuadUT(2), nQuadWS(2), nQuadWSp1(2), & nQuadWT(2), nQuadWTp1(2), nQuadW(2), nQuadWp1(2) DOUBLE PRECISION sResult(1) DOUBLE PRECISION vTempC(nT-dS-dT) c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mTemp1(nT,nT-dS-dT), mTemp2(nT,nT), c & mTemp4(nT-dS,nT-dS), mTemp5(nT,nT-dT), c & mTemp6(nT,nT-dS), mTemp8(nT-dT,nT-dT) c DOUBLE PRECISION mFSISea(nT,nT), mFTITre(nT,nT), mFSTIIrr(nT,nT) c DOUBLE PRECISION mQuadUS(nT,nT), mQuadUT(nT,nT), c & mQuadWS(nT,nT), mQuadWSp1(nT,nT-dS), c & mQuadWT(nT,nT), mQuadWTp1(nT,nT-dT), c & mQuadW(nT,nT), mQuadWp1(nT,nT-dS-dT) c ------------------------------------------------------------------ INTEGER nSave PARAMETER (nSave=POBS*POBS) DOUBLE PRECISION mTemp1(nSave), mTemp2(nSave), & mTemp4(nSave), mTemp5(nSave), & mTemp6(nSave), mTemp8(nSave) DOUBLE PRECISION mFSTIIrr(nSave) DOUBLE PRECISION mQuadUS(nSave), mQuadUT(nSave), & mQuadWS(nSave), mQuadWSp1(nSave), & mQuadWT(nSave), mQuadWTp1(nSave), & mQuadW(nSave), mQuadWp1(nSave) SAVE mTemp1, mTemp2, mFSTIIrr, & mQuadUS, mQuadUT, mQuadWS, mQuadWSp1, mQuadWT, mQuadWTp1, & mQuadW, mQuadWp1 EQUIVALENCE (mTemp1,mTemp4),(mTemp2,mTemp8),(mTemp5,mTemp6) c----------------------------------------------------------------------- c Set some local sizes. c----------------------------------------------------------------------- nY(1) = nT nY(2) = 1 c----------------------------------------------------------------------- c Calculate m_dSigmaAlt (scalar) c----------------------------------------------------------------------- pdA = max(nDel(2)-nDel(1)+1, 1) CALL mulDMat( dDel, nDel, vY, nY, vTempC, nTempC, pdA ) CALL mulQMatTr( vTempC, nTempC, mInvSigW, nInvSigW, & sResult(1), nResult ) IF (( nResult(1) .eq. 1 ) .and. ( nDel(1) .gt. 0 )) THEN sdSigAlt = DSQRT( sResult(1) / DBLE(nDel(1)) ) ELSE sdSigAlt = 0.0d0 END IF c----------------------------------------------------------------------- c Calculate some quadratic matrices. c----------------------------------------------------------------------- CALL mulQdMatTr( dDelS, nDelS, mInvSigUS, nInvSigUS, & mQuadUS, nQuadUS ) c ------------------------------------------------------------------ CALL mulQdMatTr( dDelT, nDelT, mInvSigUT, nInvSigUT, & mQuadUT, nQuadUT ) c ------------------------------------------------------------------ c The following commented code is carried out in 2 matrix operations c in order to save the intermediate matrix result. c ------------------------------------------------------------------ c CALL mulQMatTr( mDelS, nDelS, mInvSigWS, nInvSigWS, c & mQuadWS, nQuadWS ) pdA = max(nDelS(2)-nDelS(1)+1, 1) CALL mulDTrMat( dDelS, nDelS, mInvSigWS, nInvSigWS, & mQuadWSp1, nQuadWSp1, pdA ) CALL mulMatD( mQuadWSp1, nQuadWSp1, dDelS, nDelS, & mQuadWS, nQuadWS, pdA ) c ------------------------------------------------------------------ c The following commented code is carried out in 2 matrix operations c in order to save the intermediate matrix result. c ------------------------------------------------------------------ c CALL mulQMatTr( mDelT, nDelT, mInvSigWT, nInvSigWT, c & mQuadWT, nQuadWT ) pdA = max(nDelT(2)-nDelT(1)+1, 1) CALL mulDTrMat( dDelT, nDelT, mInvSigWT, nInvSigWT, & mQuadWTp1, nQuadWTp1, pdA ) CALL mulMatD( mQuadWTp1, nQuadWTp1, dDelT, nDelT, & mQuadWT, nQuadWT, pdA ) c ------------------------------------------------------------------ c The following commented code is carried out in 2 matrix operations c in order to save the intermediate matrix result. c ------------------------------------------------------------------ c CALL mulQMatTr( mDel, nDel, mInvSigW, nInvSigW, mQuadW, nQuadW ) pdA = max(nDel(2)-nDel(1)+1, 1) CALL mulDTrMat( dDel, nDel, mInvSigW, nInvSigW, & mQuadWp1, nQuadWp1, pdA ) CALL mulMatD( mQuadWp1, nQuadWp1, dDel, nDel, mQuadW, nQuadW, & pdA ) c----------------------------------------------------------------------- c Calculate some extraction matrices. c----------------------------------------------------------------------- CALL mulMat( mSigUI, nSigUI, mQuadW, nQuadW, mFSTIIrr, nFSTIIrr ) c----------------------------------------------------------------------- c Calculate the estimators and partial filters. c----------------------------------------------------------------------- c First the Irregular estimate and partial filter. c ------------------------------------------------------------------ CALL mulMat( mFSTIIrr, nFSTIIrr, vY, nY, vIrrEst, nIrrEst ) c ------------------------------------------------------------------ CALL mulMat( mSigUI, nSigUI, mQuadWp1, nQuadWp1, mTemp1, nTemp1 ) i = nTemp1(1) DO j = 1, nTemp1(2) ibase = (j-1)*i mIrrPFlt(j,1) = mTemp1(ibase+(i+1)/2) mIrrPFlt(j,2) = mTemp1(ibase+i) END DO nIrrPFlt(1) = nTemp1(2) nIrrPFlt(2) = 2 c ------------------------------------------------------------------ c And then the Seasonal estimate and partial filter. c ------------------------------------------------------------------ CALL addMat( mQuadUS, nQuadUS, mQuadWT, nQuadWT, mTemp1, nTemp1 ) CALL invMat( mTemp1, nTemp1, mTemp2, nTemp2 ) CALL mulMat( mTemp2, nTemp2, mQuadWT, nQuadWT, mTemp1, nTemp1 ) CALL mulMat( mTemp1, nTemp1, vY, nY, vSeaEst, nSeaEst ) c ------------------------------------------------------------------ CALL mulMat( mTemp2, nTemp2, mQuadWTp1, nQuadWTp1, & mTemp5, nTemp5 ) i = nTemp5(1) DO j = 1, nTemp5(2) ibase = (j-1)*i mSeaPFlt(j,1) = mTemp5(ibase+(i+1)/2) mSeaPFlt(j,2) = mTemp5(ibase+i) END DO nSeaPFlt(1) = nTemp5(2) nSeaPFlt(2) = 2 c ------------------------------------------------------------------ c Next the Trend estimate and partial filter. c ------------------------------------------------------------------ CALL addMat( mQuadUT, nQuadUT, mQuadWS, nQuadWS, mTemp1, nTemp1 ) CALL invMat( mTemp1, nTemp1, mTemp2, nTemp2 ) CALL mulMat( mTemp2, nTemp2, mQuadWS, nQuadWS, mTemp1, nTemp1 ) CALL mulMat( mTemp1, nTemp1, vY, nY, vTreEst, nTreEst ) c ------------------------------------------------------------------ CALL mulMat( mTemp2, nTemp2, mQuadWSp1, nQuadWSp1, & mTemp6, nTemp6 ) i = nTemp6(1) DO j = 1, nTemp6(2) ibase = (j-1)*i mTrePFlt(j,1) = mTemp6(ibase+(i+1)/2) mTrePFlt(j,2) = mTemp6(ibase+i) END DO nTrePFlt(1) = nTemp6(2) nTrePFlt(2) = 2 c ------------------------------------------------------------------ c Finally the SA partial filter. c ------------------------------------------------------------------ pdA = max(nRedDelT(2)-nRedDelT(1)+1, 1) CALL mulDTrMat( dRedDelT, nRedDelT, mIrrPFlt, nIrrPFlt, & mSAPFlt, nSAPFlt, pdA ) CALL addMat( mTrePFlt, nTrePFlt, mSAPFlt, nSAPFlt, & mSAPFlt, nSAPFlt ) c----------------------------------------------------------------------- c Calculate some covariance matrices. c----------------------------------------------------------------------- CALL mulQMat( mSigUI, nSigUI, mQuadW, nQuadW, mCovIrr, nCovIrr ) c ------------------------------------------------------------------ CALL mulQdMatTr( dRedDelT, nRedDelT, mInvSigW, nInvSigW, & mTemp4, nTemp4 ) CALL mulQMat( mSigUS, nSigUS, mTemp4, nTemp4, mCovSea, nCovSea ) c ------------------------------------------------------------------ CALL mulQdMatTr( dRedDelS, nRedDelS, mInvSigW, nInvSigW, & mTemp8, nTemp8 ) CALL mulQMat( mSigUT, nSigUT, mTemp8, nTemp8, mCovTre, nCovTre ) c ------------------------------------------------------------------ CALL mulQdMatTr( dRedDelS, nRedDelS, mInvSigW, nInvSigW, & mTemp8, nTemp8 ) CALL mulQMat( mSigWT, nSigWT, mTemp8, nTemp8, mCovSA, nCovSA ) c----------------------------------------------------------------------- RETURN ENDf3cal.f0000664006604000003110000001105414521201471011326 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:38 pm SUBROUTINE f3cal(Sts,Ifail) IMPLICIT NONE C----------------------------------------------------------------------- C --- THIS SUBROUTINE CALCULATES THE QUALITY CONTROL STATISTICS IN TABLE C --- F3. C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11ptr.cmn' INCLUDE 'inpt2.cmn' INCLUDE 'work2.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'tests.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE,TWO,THREE,TEN PARAMETER(ZERO=0D0,ONE=1D0,TWO=2D0,THREE=3D0,TEN=10D0) C----------------------------------------------------------------------- DOUBLE PRECISION ave,ave1,ave2,ave3,ave4,count,ct,ct1,ct2,diff, & dsmic,fn,rmcd,sd,sdev,Sts,Temp,twt,twt2,wt INTEGER i,i1,Ifail,j,k,klda,kny,l,n C----------------------------------------------------------------------- DIMENSION wt(11),Temp(PLEN),Sts(PLEN) C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- COMMON /work / Temp C----------------------------------------------------------------------- DATA wt/10D0,11D0,10D0,8D0,11D0,10D0,18D0,7D0,7D0,4D0,4D0/ C----------------------------------------------------------------------- Ifail=0 kny=Ny/4 Qu(1)=(Isq(kny)/(ONE-Psq(kny)))/0.10D0 kny=12/Ny IF(kny.lt.1)kny=1 Qu(2)=(Vi/dabs(100D0-Vp))/0.10D0 Qu(3)=(Ratic*kny-1D0)/TWO fn=Posfob-Pos1bk+1 Qu(4)=dabs(3D0*(fn-1D0)/Adri-2D0*fn+1D0)/ & (dsqrt(1.6D0*fn-2.9D0)*2.577D0) IF(Mcd.eq.1)THEN rmcd=1+(Smic(1)-ONE)/(Smic(1)-Smic(2)) IF(rmcd.lt.0.5D0)rmcd=0.5D0 IF(rmcd.gt.ONE)rmcd=ONE ELSE dsmic=Smic(Mcd-1)-Smic(Mcd) IF((dsmic.lt.ZERO.or.dpeq(dsmic,ZERO)).and.Mcd.eq.Ny)THEN rmcd=kny*15.5D0 ELSE rmcd=Mcd+(Smic(Mcd)-ONE)/dsmic END IF END IF Qu(5)=(rmcd*kny-0.5D0)/5D0 IF(Kfulsm.lt.2)Qu(6)=dabs(Ratis-4.0D0)/2.5D0 Qu(7)=dsqrt((Test1+Test2)/TWO) Nyrs=(Posfob-Pos1bk+1)/Ny Nn=7 IF((.not.Lstabl).and.Nyrs.ge.6.and.Kfulsm.lt.2)THEN Nn=11 n=2-Muladd sd=sdev(Sts,Pos1bk,Posfob,1,n) ave=1-Muladd DO i=Pos1bk,Posfob Temp(i)=(Sts(i)-ave)/sd END DO ct1=ZERO ct2=ZERO count=ZERO ave1=ZERO ave2=ZERO ave3=ZERO ave4=ZERO klda=Pos1bk+Ny-1 DO i=Pos1bk,klda ct=ZERO i1=i+Ny DO j=i1,Posfob,Ny ct=ct+ONE count=count+ONE diff=dabs(Temp(j)-Temp(j-Ny)) k=j ave1=ave1+diff END DO ave2=ave2+dabs(Temp(k)-Temp(i))/ct k=k-2*Ny j=k-3*Ny IF(j.ge.Pos1bk)THEN ave3=ave3+dabs(Temp(k)-Temp(j))/THREE ct1=ct1+ONE j=j+Ny DO l=j,k,Ny i1=l-Ny IF(i1.ge.Pos1bk)THEN ct2=ct2+ONE diff=dabs(Temp(l)-Temp(i1)) ave4=ave4+diff END IF END DO END IF END DO ave1=ave1/count ave2=ave2/DBLE(Ny) IF(.not.dpeq(ct1,ZERO))THEN ave3=ave3/ct1 ave4=ave4/ct2 END IF Qu(8)=TEN*ave1 Qu(9)=TEN*ave2 Qu(10)=TEN*ave4 Qu(11)=TEN*ave3 END IF C----------------------------------------------------------------------- Qual=ZERO twt=ZERO DO i=1,11 IF(i.le.Nn)THEN IF(Qu(i).lt.ZERO)Qu(i)=ZERO IF(Qu(i).gt.THREE)Qu(i)=THREE IF(Qu(i).ge.ONE)Ifail=Ifail+1 IF(((.not.L3x5).or.Kfulsm.eq.2).and.i.eq.6)GO TO 10 Qual=Qual+Qu(i)*wt(i) ELSE IF(i.lt.10)THEN Qual=Qual+Qu(7)*wt(i) ELSE IF(i.eq.10)THEN Qual=Qual+Qu(1)*wt(i) ELSE Qual=Qual+Qu(2)*wt(i) END IF twt=twt+wt(i) 10 CONTINUE END DO Qual=Qual/twt Kfail=Ifail c----------------------------------------------------------------------- c Calculate value of Q without M2 c----------------------------------------------------------------------- twt2=11D0 IF(Lstabl.or.Nyrs.lt.6.or.Kfulsm.eq.2)twt2=15D0 Q2m2=((Qual*twt)-(Qu(2)*twt2))/(twt-twt2) C----------------------------------------------------------------------- RETURN END f3gen.f0000664006604000003110000002217714521201471011350 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 11:15 am SUBROUTINE f3gen(Nw,Ny,Kfulsm,Lwdprt,Lcmpaq) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE PRINTS THE F3 TABLE. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'work2.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- LOGICAL Lwdprt,Lcmpaq INTEGER k,l,Nw,Ny,Kfulsm CHARACTER span*7,blank*(30) DIMENSION span(4) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- DATA span/'three ','months ','one ','quarter'/ DATA blank/' '/ c----------------------------------------------------------------------- c Print out individual quality control statistics c----------------------------------------------------------------------- k=1 IF(Ny.eq.4)k=3 l=k+1 IF(Lwdprt)THEN WRITE(Nw,1000) WRITE(Nw,1010)span(k)(1:nblank(span(k))), & span(l)(1:nblank(span(l))),Qu(1) WRITE(Nw,1020)Qu(2) WRITE(Nw,1030)Moqu(1:nblank(Moqu)),Moqu(1:nblank(Moqu)),Qu(3), & Moqu(1:nblank(Moqu)),Moqu(1:nblank(Moqu)) WRITE(Nw,1040)Qu(4) WRITE(Nw,1050)Moqu(1:nblank(Moqu)),Qu(5) IF(Kfulsm.lt.2)WRITE(Nw,1060)Qu(6) WRITE(Nw,1070)Qu(7) IF(Nn.ne.7)THEN WRITE(Nw,1080)Qu(8) WRITE(Nw,1090)Qu(9) WRITE(Nw,1100)Qu(10) WRITE(Nw,1110)Qu(11) END IF ELSE IF(Lcmpaq)THEN WRITE(Nw,2001) ELSE WRITE(Nw,2000) END IF WRITE(Nw,2010)span(k)(1:nblank(span(k))),Qu(1), & span(l)(1:nblank(span(l))) IF(.not.Lcmpaq)WRITE(Nw,'(/)') WRITE(Nw,2020)Qu(2) IF(.not.Lcmpaq)WRITE(Nw,'()') WRITE(Nw,2030)Moqu(1:nblank(Moqu)),Moqu(1:nblank(Moqu)),Qu(3), & Moqu(1:nblank(Moqu)),Moqu(1:nblank(Moqu)) IF(.not.Lcmpaq)WRITE(Nw,'()') WRITE(Nw,2040)Qu(4) IF(.not.Lcmpaq)WRITE(Nw,'(/)') WRITE(Nw,2050)Moqu(1:nblank(Moqu)),Qu(5) IF(.not.Lcmpaq)WRITE(Nw,'()') IF(Kfulsm.lt.2)THEN WRITE(Nw,2060)Qu(6) IF(.not.Lcmpaq)WRITE(Nw,'()') END IF WRITE(Nw,2070)Qu(7) IF(.not.Lcmpaq)WRITE(Nw,'(/)') IF(Nn.ne.7)THEN WRITE(Nw,2080)Qu(8) IF(.not.Lcmpaq)WRITE(Nw,'(/)') WRITE(Nw,2090)Qu(9) IF(.not.Lcmpaq)WRITE(Nw,'(/)') WRITE(Nw,2100)Qu(10) IF(.not.Lcmpaq)WRITE(Nw,'(//)') WRITE(Nw,2110)Qu(11) END IF END IF c----------------------------------------------------------------------- c Print out Q values, acceptance/rejection information c----------------------------------------------------------------------- k=10 IF(Lwdprt)k=30 IF(Lcmpaq)THEN k=2 ELSE WRITE(Nw,'()') END IF IF(Qual.lt.0.8D0)THEN WRITE(Nw,3010)blank(1:k),Qual ELSE IF(Qual.lt.1.0D0)THEN WRITE(Nw,3020)blank(1:k),Qual ELSE IF(Qual.lt.1.2D0)THEN WRITE(Nw,3030)blank(1:k),Qual ELSE WRITE(Nw,3040)blank(1:k),Qual END IF IF(Kfail.gt.0)THEN IF(.not.Lcmpaq)WRITE(Nw,'()') WRITE(Nw,3050)blank(1:k),Kfail END IF IF(.not.Lcmpaq)WRITE(Nw,'()') IF(Q2m2.lt.0.8D0)THEN WRITE(Nw,3060)blank(1:k),Q2m2 ELSE IF(Q2m2.lt.1.0D0)THEN WRITE(Nw,3070)blank(1:k),Q2m2 ELSE IF(Q2m2.lt.1.2D0)THEN WRITE(Nw,3080)blank(1:k),Q2m2 ELSE WRITE(Nw,3090)blank(1:k),Q2m2 END IF IF(.not.Lcmpaq)WRITE(Nw,'(/)') c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- c Formats for wide printout c----------------------------------------------------------------------- 1000 FORMAT(7X,'All the measures below are in the range from 0 to 3 wit &h an acceptance region from 0 to 1.') 1010 FORMAT(4X,'1. The relative contribution of the irregular over ',a, & ' ',a,' span (from Table F 2.B).',T99,'M1 = ',F6.3,//) 1020 FORMAT(4X,'2. The relative contribution of the irregular component & to the stationary portion of',t99,'M2 = ',f6.3,/,8x, & 'the variance (from Table F 2.F).',//) 1030 FORMAT(4X,'3. The amount of ',a,' to ',a,' change in the ', & 'irregular component as compared to the',T99,'M3 = ', & F6.3,/,8X,'amount of ',a,' to ',a,' change in the trend-', & 'cycle (from Table F2.H).',/) 1040 FORMAT(4X,'4. The amount of autocorrelation in the irregular as de &scribed by the average duration',T99,'M4 = ',F6.3,/,8X, &'of run (Table F 2.D).',/) 1050 FORMAT(4X,'5. The number of ',a,'s it takes the change in the tren &d-cycle to surpass the amount',T99,'M5 = ',F6.3,/,8X, & ' of change in the irregular (from Table F 2.E).',/) 1060 FORMAT(4X,'6. The amount of year to year change in the irregular a &s compared to the amount of year',T99,'M6 = ',F6.3,/,8X, &'to year change in the seasonal (from Table F 2.H).',/) 1070 FORMAT(4X,'7. The amount of moving seasonality present relative to & the amount of stable',T99,'M7 = ',F6.3,/,8X, &'seasonality (from Table F 2.I).',/) 1080 FORMAT(4X,'8. The size of the fluctuations in the seasonal compone &nt throughout the whole series.',T99,'M8 = ',F6.3,//) 1090 FORMAT(4X,'9. The average linear movement in the seasonal componen &t throughout the whole series.',T99,'M9 = ',F6.3,//) 1100 FORMAT(3X,'10. Same as 8, calculated for recent years only.',t99, & 'M10 = ',F6.3,//) 1110 FORMAT(3X,'11. Same as 9, calculated for recent years only.',T99, & 'M11 = ',F6.3) c----------------------------------------------------------------------- c Formats for standard printout c----------------------------------------------------------------------- 2000 FORMAT(7X,'All the measures below are in the range from 0 to 3 wit &h an ',/,7x,'acceptance region from 0 to 1.',/) 2001 FORMAT(6X,'The measures below are between 0 and 3; acceptance regi &on from 0 to 1.',/) 2010 FORMAT(4X, & '1. The relative contribution of the irregular over ',a, & T68,'M1 = ',F6.3,/,7x,a,' span (from Table F 2.B).') 2020 FORMAT(4X, & '2. The relative contribution of the irregular component', & t68,'M2 = ',f6.3,/,7x,'to the stationary portion of ', & 'the variance (from Table ',/,7x,'F 2.F).') 2030 FORMAT(4X,'3. The amount of ',a,' to ',a,' change in the ', & 'irregular',t68,'M3 = ',F6.3,/,7x, & 'component as compared to the amount of ',a,' to ',a,/,7x, & 'change in the trend-cycle (from Table F2.H).') 2040 FORMAT(4X,'4. The amount of autocorrelation in the irregular as', & t68,'M4 = ',F6.3,/,7x,'described by the average duration', & ' of run (Table F 2.D).') 2050 FORMAT(4X,'5. The number of ',a,'s it takes the change in the ', & 'trend-',t68,'M5 = ',F6.3,/,7x,'cycle to surpass the ', & 'amount of change in the irregular',/,7x, & '(from Table F 2.E).') 2060 FORMAT(4X, & '6. The amount of year to year change in the irregular as', & t68,'M6 = ',F6.3,/,7x,'compared to the amount of year to', & ' year change in the',/,7x,'seasonal (from Table F 2.H).') 2070 FORMAT(4X, & '7. The amount of moving seasonality present relative to', & t68,'M7 = ',F6.3,/,7x,'the amount of stable seasonality ', & '(from Table F 2.I).') 2080 FORMAT(4X, & '8. The size of the fluctuations in the seasonal component', & t68,'M8 = ',F6.3,/,7x,'throughout the whole series.') 2090 FORMAT(4X, & '9. The average linear movement in the seasonal component', & t68,'M9 = ',F6.3,/,7x,'throughout the whole series.') 2100 FORMAT(3X,'10. Same as 8, calculated for recent years only.',t68, & 'M10 = ',F6.3) 2110 FORMAT(3X,'11. Same as 9, calculated for recent years only.',t68, & 'M11 = ',F6.3) c----------------------------------------------------------------------- c Other output formats c----------------------------------------------------------------------- 3010 FORMAT(/,a,'*** ACCEPTED *** at the level ',F5.2) 3020 FORMAT(a,'*** CONDITIONALLY ACCEPTED *** at the level ',F5.2) 3030 FORMAT(a,'*** CONDITIONALLY REJECTED *** at the level ',F5.2) 3040 FORMAT(a,'*** REJECTED *** at the level ',F5.2) 3050 FORMAT(a,'*** Check the ',i2,' above measures which failed.') 3060 FORMAT(a,'*** Q (without M2) = ',f5.2,' ACCEPTED.') 3070 FORMAT(a,'*** Q (without M2) = ',f5.2,' CONDITIONALLY ACCEPTED.') 3080 FORMAT(a,'*** Q (without M2) = ',f5.2,' CONDITIONALLY REJECTED.') 3090 FORMAT(a,'*** Q (without M2) = ',f5.2,' REJECTED.') END factor.prm0000664006604000003110000000006414521201471012164 0ustar sun00315steps LOGICAL factor DIMENSION factor(NTBL) factor.var0000664006604000003110000000134614521201473012164 0ustar sun00315steps DATA factor/ & F,F,F,F,F,F,F,F,F,F, F,F,F,T,T,T,F,F,F,F, F,F,F,F,T,T,T,T,T,T, & T,T,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,T,T,T,T,T,T, F,F,F,F,F,F,F,T,T,T, T,F,F,T,T,T,T,T,F,T, & T,F,F,F,F,F,F,F,T,F, T,T,T,T,T,T,T,T,T,T, T,F,T,T,T,F,F,F,F,F, & T,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,T, T,T,T,T,T,T,T,F,F,T, & T,T,T,T,T,T,T,T,T,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, T,T,T,F,F,F,T,F,F,T, T,T,T,T,T,T,F,T,T,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,T,T, T,T,T,T,T/ fclose.f0000664006604000003110000000601514521201473011614 0ustar sun00315stepsC Last change: BCM 28 Oct 97 4:14 pm **==fclose.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE fclose(Handle) IMPLICIT NONE c----------------------------------------------------------------------- c Opens a file with the given options and assigns a file handle c----------------------------------------------------------------------- c Parameters and include files c----------------------------------------------------------------------- INCLUDE 'stdio.i' c----------------------------------------------------------------------- c Namelist Input Arguments c Name Type Description c----------------------------------------------------------------------- c handle i Unit number of the next available file c----------------------------------------------------------------------- INTEGER Handle c----------------------------------------------------------------------- c Local Arguments c Name Type Description c----------------------------------------------------------------------- c ifile i Index for the current file handle c jfile i Index for the current file c----------------------------------------------------------------------- INTEGER ifile,jfile c----------------------------------------------------------------------- c If handle=ALLFIL close all the files c----------------------------------------------------------------------- IF(Handle.eq.ALLFIL)THEN DO WHILE (Nfile.gt.1) CLOSE(Fillst(Nfile)) Nfile=Nfile-1 END DO IF(Opnsin)CLOSE(STDIN) IF(Opnsot)CLOSE(STDOUT) c----------------------------------------------------------------------- c Else close the file with the unit number handle c----------------------------------------------------------------------- ELSE IF(Handle.eq.STDIN)THEN IF(Opnsin)CLOSE(STDIN) ELSE IF(Handle.eq.STDOUT)THEN IF(Opnsot)CLOSE(STDOUT) ELSE DO ifile=1,Nfile IF(Fillst(ifile).eq.Handle)THEN c----------------------------------------------------------------------- c If the file is in the list of open files then close it and c put the file handle in the unopened files part of the list c----------------------------------------------------------------------- CLOSE(Handle) c ------------------------------------------------------------------ DO jfile=ifile,Nfile-1 Fillst(jfile)=Fillst(jfile+1) END DO c ------------------------------------------------------------------ Fillst(Nfile)=Handle Nfile=Nfile-1 GO TO 10 END IF END DO c ------------------------------------------------------------------ PRINT 1010,Handle c Later we are going to want to call the files by there file names c because the user won't know what the unit numbers are. 1010 FORMAT(/,' File',i3,' not found to close') END IF c ------------------------------------------------------------------ 10 RETURN END fcnar.f0000664006604000003110000001702714521201473011437 0ustar sun00315stepsC 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 fcstxy.f0000664006604000003110000002567314521201473011674 0ustar sun00315stepsC Last change: BCM 14 Jul 1998 9:03 am SUBROUTINE fcstxy(Fctori,Nfcst,Fcst,Se,Rgvar) IMPLICIT NONE c----------------------------------------------------------------------- c fcstxy.f, Release 1, Subroutine Version 1.5, Modified 03 Feb 1995. c----------------------------------------------------------------------- c Computes forecasts for the data. The data c has been transformed by a Box-Cox transformation and adjusted c for regression effects c----------------------------------------------------------------------- c Include files c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c INCLUDE 'units.cmn' c----------------------------------------------------------------------- c Input Arguments c Name Type Description c----------------------------------------------------------------------- c a d Nrsd long array of residuals c nfcst i Number of forcasts to calculate c fctori i Length of the undifferences series c nrsd i Number of residuals to calculate. Nwp if conditional, c na if exact. This number tell the maflt routine which c type of filtering to do. c Xy d Vector of transformed, undifferenced series c----------------------------------------------------------------------- INTEGER Nfcst,Fctori,nrsd c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c fcst d Ouput nfcst long vector of forecasts of the tranformed and c regression adjusted data (has mean though) c se d Output nfcst long vector of standard errors c----------------------------------------------------------------------- DOUBLE PRECISION Fcst,Rgvar,Se DIMENSION Fcst(Nfcst),Rgvar(Nfcst),Se(Nfcst) c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c aropr i Operator index vector (like opr) for the expanded AR c operator. Used as input to ratpos. c beglag i Index to the begining lag of an operator c begopr i Index to the begining operator of the differencing, AR, c MA. c i i Do loop index c ia i Index to the current residual c iopr i Index to the current lag operator c ishft1 i Index for the temporary forecast vector when calculating c the do index in terms of the data time index c ishft2 i Index for the exact residual vector when calculating the c do index in terms of the data time index c j i Do loop index c ndltar i Difference from the starting time point of the temporary c forecast vector to the starting time point of the data c vector c ndltma i Difference from the starting time point of the exact c residuals to the starting time point of the data vector c nlag i Number of lags in a lag operator c nopr i Number of differenceing and AR or MA lag operators c mxdfar i Length of the full AR operator (phi*differencing) c one d PARAMETER for 1.0d0 c tfcst d Pfcst long work array to calculate the forecasts c tmp d Temporary scalar to make intermediate calculations for c the regression adjustments and forecasts. c work d Work vector used to compute forecasts and hold psi(B) c weights when computing the standard errors c fularl i Work array for the lags in the full AR and c differencing operator (Nonseasonal x Seasonal for both). c fularp d Work array porder long for the full AR and differencing c operators. c fulmal i Work array for the lags in the full MA operator c associated with ma. (Nonseasonal x Seasonal) c fulmap d Work array porder long for the full MA operator c zero d PARAMETER for 0.0d0 c----------------------------------------------------------------------- c Variable typing and initialization c----------------------------------------------------------------------- LOGICAL T,F DOUBLE PRECISION ZERO,ONE,MONE INTEGER PCXY,PAF,PARDOR PARAMETER(ZERO=0.0D0,ONE=1.0D0,T=.true.,F=.FALSE.,PCXY=PB+1, & PAF=(2*PORDER+PLEN)*PCXY,PARDOR=PORDER+PDIFOR, & MONE=-1.0D0) c ------------------------------------------------------------------ INTEGER aropr,beglag,begopr,endopr,i,ia,ielt,ilag,info,iopr, & ishft1,ishft2,j,mxdfar,ndltar,ndltma,neltf,neltxy,nlag, & fularl,nfular,fulmal,nfulma,nb2 DOUBLE PRECISION a,tfcst,tmp,fctssq,fularp,fulmap,piwght DIMENSION a(PAF),aropr(0:POPR),fularl(PARDOR),fularp(PARDOR), & fulmal(PORDER),fulmap(PORDER),piwght(PARDOR+PFCST), & tfcst((PFCST+PARDOR)*PCXY) c----------------------------------------------------------------------- c Calculate the filtered Xy matrix c----------------------------------------------------------------------- CALL copy(Xy,Fctori*Ncxy,1,a) CALL armafl(Fctori,Ncxy,F,F,a,nrsd,PAF,info) c CALL armafl(Fctori,Ncxy,T,F,a,nrsd,info) c----------------------------------------------------------------------- c Calculate the full AR and Differencing operator, and its order c----------------------------------------------------------------------- nfular=0 begopr=Mdl(DIFF-1) endopr=Mdl(AR)-1 DO iopr=begopr,endopr beglag=Opr(iopr-1) CALL eltlen(iopr,Opr,Nopr,nlag) IF(Lfatal)RETURN CALL polyml(Arimap(beglag),Arimal(beglag),nlag,fularp,fularl, & nfular,PARDOR,fularp,fularl,nfular) END DO c ------------------------------------------------------------------ mxdfar=Mxdflg+Mxarlg c----------------------------------------------------------------------- c Calculate the full MA and its order. c----------------------------------------------------------------------- nfulma=0 begopr=Mdl(MA-1) endopr=Mdl(MA)-1 DO iopr=begopr,endopr beglag=Opr(iopr-1) CALL eltlen(iopr,Opr,Nopr,nlag) IF(Lfatal)RETURN CALL polyml(Arimap(beglag),Arimal(beglag),nlag,fulmap,fulmal, & nfulma,PORDER,fulmap,fulmal,nfulma) END DO c----------------------------------------------------------------------- c Calculate the psi(B) weights for the standard errors c----------------------------------------------------------------------- CALL setdp(ZERO,PARDOR+PFCST,piwght) c ------------------------------------------------------------------ piwght(1)=ONE DO i=1,nfulma piwght(fulmal(i)+1)=-fulmap(i) END DO c ------------------------------------------------------------------ aropr(0)=1 c I add the 1 because the pointers are to the first element of the c of the next operator. aropr(1)=nfular+1 CALL ratpos(Mxmalg+1,fularp,fularl,aropr,1,1,Nfcst,piwght) c----------------------------------------------------------------------- c ndltar is the difference in indexing between the vector of c observations and a temporary vector, tfcst, which contains only c the values for time points needed to calculate the forecasts. c Ndltma is the difference in indexing between the vector of c observations and the vector of residuals which maybe exact or c conditional (corresponding to the different lengths of these vectors). c Multiply the series length and the lags by the number of columns c so a matrix can be filtered the same as a vector c----------------------------------------------------------------------- DO ilag=1,nfular fularl(ilag)=Ncxy*fularl(ilag) END DO c ------------------------------------------------------------------ DO ilag=1,nfulma fulmal(ilag)=Ncxy*fulmal(ilag) END DO c ------------------------------------------------------------------ ndltar=mxdfar*Ncxy ndltma=nrsd*Ncxy neltxy=Fctori*Ncxy neltf=Nfcst*Ncxy c ------------------------------------------------------------------ CALL copy(Xy(neltxy-ndltar+1),ndltar+neltf,1,tfcst) DO ielt=ndltar+Ncxy,ndltar+neltf,Ncxy tfcst(ielt)=ZERO END DO c----------------------------------------------------------------------- c Calculate the forecasts. c----------------------------------------------------------------------- DO ielt=1,neltf ishft1=ielt+ndltar tmp=ZERO c ------------------------------------------------------------------ DO j=1,nfular tmp=tmp+fularp(j)*tfcst(ishft1-fularl(j)) END DO c ------------------------------------------------------------------ ishft2=ielt+ndltma DO j=1,nfulma ia=ishft2-fulmal(j) IF(ia.le.ndltma.and.ia.gt.0)tmp=tmp-fulmap(j)*a(ia) END DO c ------------------------------------------------------------------ tfcst(ielt)=tmp-tfcst(ishft1) IF(ielt.lt.ishft1)tfcst(ishft1)=tmp END DO c----------------------------------------------------------------------- c Calculate Ay-(AX-X_f)*b c----------------------------------------------------------------------- ielt=mxdfar*Ncxy+1 CALL resid(tfcst,Nfcst,Ncxy,Ncxy,1,Nb,MONE,B,Fcst) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Compute the standard errors for the forecasts where c se(lead)=sqrt(sum(psi(i)), i=0,lead-1). Psi(B)=AR(B)/MA(B). c First set up the expanded AR operator. c----------------------------------------------------------------------- c Compute the standard errors using var where var=a'a/nwp, a(i), c i=1,na. c get the chlxpx and use to LX vector and then take the sum of squares` c----------------------------------------------------------------------- fctssq=ZERO ielt=1 c ------------------------------------------------------------------ c Generate number of unfixed regressors c ------------------------------------------------------------------ nb2=Nb IF(Iregfx.ge.2)THEN DO j=1,Nb IF(Regfx(j))nb2=nb2-1 END DO END IF c ------------------------------------------------------------------ DO i=1,Nfcst IF(nb2.gt.0)THEN CALL dppsl(Chlxpx,nb2,tfcst(ielt),T) CALL yprmy(tfcst(ielt),nb2,tmp) c ------------------------------------------------------------------ ELSE tmp=ZERO END IF c ------------------------------------------------------------------ Rgvar(i)=tmp*Var fctssq=fctssq+piwght(i)**2 tmp=tmp+fctssq Se(i)=sqrt(tmp*Var) ielt=ielt+Ncxy END DO c ------------------------------------------------------------------ RETURN END fctlbl.prm0000664006604000003110000000166214521201474012164 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c X-13 output labels of forecasts and other special tables. See fctlbl.var for pointers. c----------------------------------------------------------------------- CHARACTER LBFDIC*373 INTEGER lbfptr,PLBF PARAMETER(PLBF=395) DIMENSION lbfptr(0:PLBF) c----------------------------------------------------------------------- PARAMETER(LBFDIC='B 1.AA 8.AA 8.TC.AA 8.SO.AA 6.AA 7.AA 9.AA 10.AA & 13.AD 10.AD 10.AD 10.ED 10.CD 10.TH 1.AA 16.AD 16.AD 16.AD 16.CD &18.AE 18.AE 18.CD 11.FFA 4.CC 16.AC 18.AC 16H.AC 16C.AC 18C.AB 1.A &D 10.AD 10.AD 10.CE 18.AE 18.CD 18.AD 16.AD 16.AD 11.FFS 12.AS 12. &DS 10.AS 10.AS 13.AS 13.AS 11.AS 11.DS 14.AS 14.AS 16.AS 16.AS 18. &AS 18.CS 1.FS 11.FS 12.FS 10.CS 14.TCFS 14.DTCFS 11.OAS 13.OA') fctlbl.var0000664006604000003110000000517214521201474012156 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c X-13 output labels of forecasts and other special tables. See fctlbl.prm for data dictionaries. c----------------------------------------------------------------------- DATA lbfptr / & 1, 1, 1, 1, 1, 1, 1, 1, 1, 6, & 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & 6, 6, 6, 6, 11, 11, 11, 19, 27, 32, & 37, 42, 48, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, & 54, 54, 54, 54, 54, 54, 54, 60, 66, 72, & 78, 84, 84, 84, 84, 84, 84, 84, 84, 84, & 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, & 89, 95, 101, 107, 113, 119, 125, 131, 131, 131, & 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, & 131, 131, 131, 131, 131, 131, 131, 131, 131, 131, & 131, 131, 131, 131, 131, 131, 131, 138, 143, 143, & 143, 143, 143, 143, 149, 149, 155, 155, 162, 162, & 169, 169, 176, 176, 176, 176, 176, 176, 176, 176, & 176, 176, 176, 176, 176, 176, 176, 176, 176, 176, & 176, 176, 176, 176, 176, 176, 176, 176, 176, 176, & 176, 176, 176, 176, 176, 176, 176, 176, 176, 176, & 176, 176, 176, 176, 176, 176, 176, 176, 176, 176, & 176, 176, 176, 176, 176, 176, 176, 176, 176, 176, & 176, 181, 181, 181, 181, 181, 181, 181, 181, 187, & 193, 199, 199, 199, 199, 199, 199, 199, 199, 199, & 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, & 199, 199, 205, 211, 211, 211, 211, 211, 211, 211, & 211, 211, 211, 211, 211, 211, 211, 211, 211, 211, & 211, 211, 211, 217, 223, 229, 229, 229, 236, 242, & 248, 254, 260, 266, 272, 278, 284, 290, 296, 302, & 308, 308, 308, 308, 308, 308, 314, 320, 320, 320, & 320, 320, 320, 320, 320, 320, 320, 320, 320, 320, & 320, 320, 320, 320, 325, 331, 337, 343, 351, 360, & 360, 360, 360, 360, 367, 374 / fcttitle.prm0000664006604000003110000000351114521201475012530 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionaries, pointers for titles of tables dealing with c forecasts of specified series and special tables c----------------------------------------------------------------------- CHARACTER TTFDIC*1295 INTEGER ttfptr,PTTF PARAMETER(PTTF=225) DIMENSION ttfptr(0:PTTF) PARAMETER(TTFDIC='A 7.A REGARIMA AO outlier component forecastsA &8.A REGARIMA level change outlier component forecastsA 5.A REGAR &IMA trading day component forecastsA 6.A REGARIMA holiday compone &nt forecastsA 9.A REGARIMA user-defined regression component fore &castsB 1.A Original series (prior adjusted), forecast extendedD 1 &0.A Final seasonal component forecastsD 10.C Final seasonal diff &erence forecastsH 1.A Holiday component forecastsD 16.A Combined & adjustment component forecastsD 10.C Final adjustment difference & forecastsA 4.C Prior trading day component forecastsC 16.A Fina &l X-11 regression trading day component forecastsC 18.A Final X-1 &1 regression trading day component forecastsC 16H.A Final X-11 re &gression holiday component forecastsC 16C.A Final X-11 calendar c &omponent forecastsC 18C.A Final X-11 combined calendar component &forecastsR 1.B Final seasonal adjustmentsR 2.B Final seasonal co &mponentR 3.B History of the % from the preceding period in the fi &nal seasonal adjustmentsR 4.B Final Henderson trend-cycle valuesR & 7.B History of the % from the preceding period in the final tren &d-cycle valuesR 8.B Final seasonal componentR 1I.B Final indirec &t seasonal adjustmentsD 10.A Final indirect seasonal component fo &recastsD 10.C Indirect final seasonal difference forecasts') fcttitle.var0000664006604000003110000000175114521201475012526 0ustar sun00315steps DATA ttfptr / 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,47,103,150,193,252,252, &310,310,310,310,310,310,310,310,310,310,310,310,310,310,310,310, &310,310,310,310,310,310,310,310,310,310,310,310,310,310,310,310, &310,310,310,352,395,395,395,395,395,395,395,395,395,395,395,395, &395,395,395,395,429,429,429,476,521,521,521,521,521,521,521,521, &521,521,521,521,521,521,521,521,521,521,521,521,521,521,521,565, &565,565,565,565,565,626,626,687,687,745,745,793,793,850,850,850, &850,850,850,850,850,850,883,883,914,914,997,997,1038,1038,1038, &1038,1119,1119,1150,1150,1193,1193,1193,1193,1193,1193,1193,1193, &1193,1193,1193,1193,1193,1193,1193,1193,1193,1193,1193,1193,1193, &1193,1193,1193,1244,1296,1296,1296,1296,1296,1296,1296,1296,1296, &1296,1296,1296,1296,1296,1296,1296,1296,1296,1296,1296,1296,1296, &1296,1296,1296,1296,1296,1296,1296,1296,1296,1296 / fdate.f0000664006604000003110000000210214521201475011417 0ustar sun00315steps SUBROUTINE fdate(Dattim) IMPLICIT NONE c----------------------------------------------------------------------- c Mimics the SUN system routine that prints the date and time c----------------------------------------------------------------------- CHARACTER Dattim*24 c----------------------------------------------------------------------- c date is a Lahey DOS interface routine that returns the c current time of day in MM/DD/YY format, left-justified and c space filled. c----------------------------------------------------------------------- call date_and_time(date=Dattim(3:10)) c----------------------------------------------------------------------- c time is a Lahey DOS interface routine that returns the c current time of day in HH:MM:SS.hh format, left-justified and c space filled. c----------------------------------------------------------------------- CALL date_and_time(time=Dattim(13:24)) c ------------------------------------------------------------------ RETURN END fdjac2.f0000664006604000003110000000744214521201476011502 0ustar sun00315steps SUBROUTINE fdjac2(fcn,M,N,X,Fvec,Lauto,Gudrun,Fjac,Ldfjac,Iflag, & Epsfcn,Wa,Lckinv) IMPLICIT NONE c----------------------------------------------------------------------- c fdjac2.f, Release 1, Subroutine Version 1.3, Modified 14 Feb 1995. c----------------------------------------------------------------------- INTEGER M,N,Ldfjac,Iflag DOUBLE PRECISION Epsfcn DOUBLE PRECISION X(N),Fvec(M),Fjac(Ldfjac,N),Wa(M) LOGICAL Lauto,Gudrun,dpeq EXTERNAL fcn,dpeq C ********** C C SUBROUTINE FDJAC2 C C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED C PROBLEM OF M FUNCTIONS IN N VARIABLES. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. c lckinv is added to constrain the estimation inside the c invertibility and stationarity regions. C C SUBROUTINE FCN(M,N,X,FVEC,IFLAG,lckinv) C INTEGER M,N,IFLAG C DOUBLE PRECISION X(N),FVEC(M) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C ---------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF VARIABLES. N MUST NOT EXCEED M. C C X IS AN INPUT ARRAY OF LENGTH N. C C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE C FUNCTIONS EVALUATED AT X. C C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. C C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. C C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C WA IS A WORK ARRAY OF LENGTH M. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... DPMPAR C C FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER i,j LOGICAL Lckinv DOUBLE PRECISION eps,epsmch,h,temp,zero DOUBLE PRECISION dpmpar DATA zero/0.0D0/ C C EPSMCH IS THE MACHINE PRECISION. C epsmch=dpmpar(1) C eps=dsqrt(dmax1(Epsfcn,epsmch)) DO j=1,N temp=X(j) h=eps*dabs(temp) IF(dpeq(h,zero))h=eps X(j)=temp+h CALL fcn(M,N,X,Wa,Lauto,Gudrun,Iflag,Lckinv) IF(Iflag.lt.0)GO TO 10 X(j)=temp DO i=1,M Fjac(i,j)=(Wa(i)-Fvec(i))/h END DO END DO 10 RETURN C C LAST CARD OF SUBROUTINE FDJAC2. C END fft.i0000664006604000003110000000036714521201476011132 0ustar sun00315stepsC C... Variables in Common Block /fft/ ... integer maxnz_1,nz double precision pi2 parameter( maxnz_1=1099,pi2=6.28318530717959d0) double precision wgr(0:maxnz_1),wgi(0:maxnz_1) common /FFT_block/ wgr,wgi,nz fgen.f0000664006604000003110000000371414521201476011266 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:39 pm **==fgen.f processed by SPAG 4.03F at 11:18 on 14 Sep 1994 SUBROUTINE fgen(Nw,Kfmt,Lf2,Lf3,Ldirect) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE GENERATES THE F2 AND F3 TABLES. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'title.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- LOGICAL Lf2,Lf3,Ldirect CHARACTER mqf2*(7) INTEGER Kfmt,khcfm,Nw c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- IF(Lf2)THEN IF(Ny.eq.4)THEN mqf2=Moqu ELSE mqf2=' month' END IF khcfm=1 IF(Kfmt.gt.0)khcfm=2 IF(Lpage)THEN WRITE(Nw,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF (Ldirect) THEN WRITE(Nw,1010) ELSE WRITE(Nw,1000) END IF 1000 FORMAT(//,' F 2. Summary Measures for Indirect Adjustment') 1010 FORMAT(//,' F 2. Summary Measures') IF(Lwdprt)THEN CALL prtf2w(Nw,mqf2,khcfm) ELSE CALL prtf2(Nw,mqf2,khcfm) END IF END IF IF(Lf3)THEN IF(Lpage)THEN WRITE(Nw,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF (Ldirect) THEN WRITE(Nw,1020) ELSE WRITE(Nw,1030) END IF 1030 FORMAT(//,' F 3. Monitoring and Quality Assessment Statistics for & Indirect Adjustment') 1020 FORMAT(//,' F 3. Monitoring and Quality Assessment Statistics') CALL f3gen(Nw,Ny,Kfulsm,Lwdprt,Lcmpaq) END IF RETURN END filetb.cmn0000664006604000003110000000073214521201476012141 0ustar sun00315stepsc ------------------------------------------------------------------ c common block to control printing of file table. c----------------------------------------------------------------------- INTEGER Fhandl LOGICAL Lexist,Lexout,Lexerr,Lfrtop c----------------------------------------------------------------------- COMMON /filetb/ Fhandl,Lexist,Lexout,Lexerr,Lfrtop c----------------------------------------------------------------------- filext.prm0000664006604000003110000000046114521201476012207 0ustar sun00315stepsc----------------------------------------------------------------------- c vector of file extensions used to save tables. See filext.var c for actual table names. c----------------------------------------------------------------------- CHARACTER tbxdic*3 DIMENSION tbxdic(NTBL) filext.var0000664006604000003110000000603614521201477012206 0ustar sun00315stepsc----------------------------------------------------------------------- c tbxdic - file extension used to store the tables - if xxx table c is assumed to not be stored. c----------------------------------------------------------------------- DATA tbxdic/ & 'xxx','a1 ','xxx','spc','xxx','mv ','a18','a19','b1 ','xxx', & 'a1c','xxx','a2 ','a2p','a2t','a3 ','a3p','a4d','a4p','trn', & 'xxx','rmx','xxx','otl','ao ','ls ','tc ','so ','td ','hol', & 'usr','a10','a13','xxx','xxx','iac','xxx','ipc','xxx','xxx', & 'xxx','xxx','xxx','xxx','xxx','xxx','xxx','xxx','xxx','xxx', & 'xxx','xxx','xxx','xxx','xxx','xxx','xxx','xxx','itr','xxx', & 'mdl','rcm','est','acm','lks','xxx','rts','ref','rsd','rrs', & 'xxx','xxx','oit','xxx','xxx','fts','acf','xxx','pcf','xxx', & 'ac2','xxx','xxx','xxx','xxx','xxx','xxx','ftr','fvr','fct', & 'btr','bct','sp0','spr','sp1','sp2','s1s','s2s','ser','is1', & 'is2','is0','st0','str','st1','st2','t1s','t2s','ter','it1', & 'it2','it0','xxx','xxx','xxx','xxx','xxx','xxx','c1 ','d1 ', & 'e1 ','f1 ','b2 ','c2 ','d2 ','e2 ','b3 ','e3 ','xxx','c4 ', & 'd4 ','b5 ','c5 ','d5 ','e5 ','pe5','b6 ','c6 ','d6 ','e6 ', & 'pe6','b7 ','c7 ','d7 ','e7 ','pe7','b8 ','d8 ','d8b','e8 ', & 'pe8','xxx','c9 ','d9 ','b10','c10','d10','psf','fsd','ars', & 'sns','b11','c11','d11','sac','e11','d12','tal','bcf','tac', & 'b13','c13','d13','pir','ira','b17','c17','b20','c20','h1 ', & 'chl','d16','paf','fad','d18','e18','tad','b19','c19','xxx', & 'xxx','xxx','e4 ','xxx','xxx','xxx','xxx','xxx','xxx','xxx', & 'xxx','xxx','xxx','xxx','xxx','saf','trf','iwf','saa','rnd', & 'e6a','p6a','e6r','p6r','cr ','rr ','ffc','a4 ','b14','c14', & 'b15','c15','b16','c16','b18','c18','bxh','xhl','bxc','xca', & 'bcc','xcc','xxx','xoi','xxx','xxx','xrm','xrc','xxx','xxx', & 'rot','sfh','sar','xxx','sae','chr','xxx','che','iar','xxx', & 'iae','trr','xxx','tre','tcr','xxx','tce','sfr','xxx','sfe', & 'lkh','fce','fch','smh','ssh','amh','tdh','xxx','xxx','xxx', & 'xxx','xxx','xxx','xxx','xxx','xxx','xxx','xxx','xxx','sfs', & 'sis','chs','cis','ads','ais','ycs','yis','tds','cms','ia3', & 'b1 ','xxx','cac','oac','xxx','xxx','id8','id9','isf','ips', & 'isd','isa','itn','iir','ipi','ie1','ie2','ie3','ie5','ip5', & 'ie6','ip6','i6a','ipa','i6r','ipr','ie7','ip7','ie8','ip8', & 'iee','i18','ita','if1','xxx','xxx','ie4','xxx','xxx','xxx', & 'iaa','irn','xxx','xxx','xxx','xxx','xxx','xxx','xxx','xxx', & 'ils','iao','ica','iaf','ipf','cri','rri','iff','s12','stc', & 's10','pss','s13','psi','s11','sec','s14','psc','s16','psa', & 'tfd','sfd','ofd','afd','yfd','s18','sta','wkf','mdc','pic', & 'pis','pit','pia','gaf','gac','gtf','gtc','tac','ttc','faf', & 'fac','ftf','ftc','dor','dsa','dtr','ssm','cyc','ltt','sse', & 'ase','tse','cse','se2','se3','stl'/ fis.f0000664006604000003110000000136114521201477011125 0ustar sun00315stepsC Last change: BCM 29 Oct 97 7:11 am **==fis.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 DOUBLE PRECISION FUNCTION fis(Cs,N) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION c,Cs INTEGER N C*** End of declarations inserted by SPAG C --- THIS FUNCTION ADJUSTS THE I/S RATIO FOR THE NUMBER OF YEARS C DIMENSION c(8) DATA c/1.00000D0,1.02584D0,1.01779D0,1.01383D0,1.00000D0, & 3.00000D0,1.55291D0,1.30095D0/ IF(N.lt.6)THEN fis=c(N-1) Cs=c(N+3) RETURN END IF Cs=dble(N)*1.732051D0/(8.485281D0+dble(N-6)*1.732051D0) fis=DBLE(N)*12.247449D0/(73.239334D0+dble(N-6)*12.247449D0) RETURN END fitmod.i0000664006604000003110000000015714521201477011633 0ustar sun00315stepsC C... Variables in Common Block /fitmod/ ... real*8 THSV1,SISV1 common /fitmod/ THSV1,SISV1 fopen.f0000664006604000003110000001276614521201477011466 0ustar sun00315stepsC Last change: BCM 23 Sep 1998 2:53 pm **==fopen.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE fopen(Fil,Fildes,Flstat,Handle,Locok) IMPLICIT NONE c----------------------------------------------------------------------- c Opens a file with the given options and assigns a file handle c Parameters and include files c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- c PFILE i Maximum number of files that can be opened at a time c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(T=.true.,F=.FALSE.) C----------------------------------------------------------------------- c Namelist Input Arguments c Name Type Description c----------------------------------------------------------------------- c fil c Filename c handle i Unit number of the next available file c Flstat c Status of the file, either new, old, unknown, or scratch c----------------------------------------------------------------------- CHARACTER Fildes*(*),Fil*(*),Flstat*(*) INTEGER Handle c----------------------------------------------------------------------- c Local Arguments c Name Type Description c----------------------------------------------------------------------- c ifile i Index for the current file c intfil l Switch to set up the file list first time through c flpext c Constructed file name plus the extension if there is one c nextcr i Number of characters in the extension c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- LOGICAL Locok,intfil INTEGER ifile,nchr SAVE intfil DATA intfil/.true./ c----------------------------------------------------------------------- c If this is the first call to the routine then initialize the list c of files. c----------------------------------------------------------------------- Locok=T IF(intfil)THEN DO ifile=1,PFILE Fillst(ifile)=ifile+9 END DO c----------------------------------------------------------------------- c Changed because of log file (BCM Dec 1994) c----------------------------------------------------------------------- Nfile=1 c----------------------------------------------------------------------- intfil=F Opnsin=F Opnsot=F END IF c----------------------------------------------------------------------- c Length of the file name c----------------------------------------------------------------------- nchr=nblank(Fil) c----------------------------------------------------------------------- c Open standard in. Note that a FORTRAN file cannot be opened with c read only status. This may cause a file without write permissions to c fail. c----------------------------------------------------------------------- IF(Handle.eq.STDIN)THEN IF(Infile.ne.'STDIN')THEN OPEN(UNIT=Handle,FILE=Fil(1:nchr),STATUS='OLD',ERR=10) Opnsin=T END IF c ------------------------------------------------------------------ c Open Standard out c----------------------------------------------------------------------- ELSE IF(Handle.eq.STDOUT)THEN IF(Infile.ne.'STDOUT')OPEN(UNIT=Handle,FILE=Fil(1:nchr),STATUS= & 'UNKNOWN',ERR=10) Opnsot=T c ------------------------------------------------------------------ ELSE IF(Nfile.ge.PFILE)THEN WRITE(STDERR,1010)Nfile,PFILE IF(Mt2.gt.0)THEN CALL errhdr WRITE(Mt2,1010)Nfile,PFILE END IF 1010 FORMAT(/,' ERROR: Too many open files',i3,'>',i3,'.') GO TO 20 c ------------------------------------------------------------------ ELSE Nfile=Nfile+1 Handle=Fillst(Nfile) OPEN(UNIT=Handle,FILE=Fil(1:nchr),STATUS=Flstat,ERR=10) END IF c----------------------------------------------------------------------- c Write out the the file and description c----------------------------------------------------------------------- IF(Flstat(1:3).eq.'OLD'.or.Flstat(1:3).eq.'old')THEN IF(Mt1.gt.0)THEN WRITE(Mt1,*)' Reading ',Fildes,' from ',Fil(1:nchr) ELSE WRITE(STDOUT,*)' Reading ',Fildes,' from ',Fil(1:nchr) END IF END IF c ------------------------------------------------------------------ RETURN c----------------------------------------------------------------------- c Error return c----------------------------------------------------------------------- 10 IF(Flstat.eq.'NEW'.or.Flstat.eq.'new')THEN WRITE(STDERR,1020)Fildes,Fil(1:nchr) IF(Mt2.gt.0)THEN CALL errhdr WRITE(Mt2,1020)Fildes,Fil(1:nchr) END IF 1020 FORMAT(/,' ERROR: ',a,' ',a,' already exists.',/) c ------------------------------------------------------------------ ELSE WRITE(STDERR,1030)Fildes,Fil(1:nchr) IF(Mt2.gt.0.and.Mt2.ne.Handle)THEN CALL errhdr WRITE(Mt2,1030)Fildes,Fil(1:nchr) END IF 1030 FORMAT(/,' ERROR: Unable to open ',a,', ',a,'.',/) END IF c ------------------------------------------------------------------ 20 Locok=F RETURN END force.cmn0000664006604000003110000000402214521201477011767 0ustar sun00315stepsc Lamda - Value of the parameter $\lambda$ used to determine the c weight matrix $C$ for the regression method. c Values range from -3.0 to 3.0, with a default of 0. c Rol - Value of the AR(1) parameter ($\rho$) used in the regression c method. Admissable values must be between 0 and 1, c inclusive. If Rol = 1, the modified Denton method is used. c The default is 0.9 for monthly series, 0.729 for quarterly c series ($(0.9)^3$). c Iyrt - constrain yearly totals of SA series c (0 - no constraint, 1 - denton method, c 2 - regression) c Begyrt - starting month/quarter for forcing totals c Iftrgt - Indicator variable denoting which series is used as the c target for forcing the totals of the seasonally adjusted c series (0 - Original series, 1 - Original series adjusted c for calendar effects, 2 - Original series adjusted for c permanent prior adjustment factors, 3 - Original series c adjusted for both calendar effects and permanent prior c adjustment factors). c Mid - Indicator variable denoting whether the forcing adjustment c factors are generated as ratios (Mid = 0) or differences c (Mid = 1) c Lrndsa - Logical variable which indicates when final seasonally c adjusted series is to be rounded c Lindfr - Logical variable which indicates when indirect seasonally c adjusted series is to be forced c Lfctfr - Logical variable which indicates when forecasts are to be c included in the forcing operation c----------------------------------------------------------------------- DOUBLE PRECISION Lamda,Rol INTEGER Iyrt,Begyrt,Iftrgt,Mid LOGICAL Lrndsa,Lindfr,Lfctfr c----------------------------------------------------------------------- COMMON /frccmn/ Lamda,Rol,Iyrt,Begyrt,Iftrgt,Mid,Lrndsa,Lindfr, & Lfctfr forcst.f0000664006604000003110000000241214521201477011642 0ustar sun00315stepsC Last change: BCM 29 Sep 97 9:44 am **==forcst.f processed by SPAG 4.03F at 17:25 on 7 Jun 1994 SUBROUTINE forcst(Sts,Ib,Ie,Ke,Nyr,Iorder,Wt,R) IMPLICIT NONE C*** Start of declarations inserted by SPAG INTEGER i,Ib,Ie,Iorder,j,k,Ke,l,Nyr DOUBLE PRECISION R,Sts,w,Wt,ONE C*** End of declarations inserted by SPAG PARAMETER (ONE=1D0) C --- THIS SUBROUTINE FORECASTS SEASONALS FROM IE+1 TO KE C --- IORDER REPRESENTS THE ORDER OF DIFFERENCES USED. C --- WT IS THE WEIGHT GIVEN TO THE FORECASTED DIFFERENCE. C --- THERE IS A RATIO OF R BETEEN SUCCESSIVE DIFFERENCES. LOGICAL dpeq EXTERNAL dpeq DIMENSION Sts(*) IF(.not.dpeq(R,ONE))THEN w=Wt*(R-ONE)/(R**Iorder-ONE) ELSE w=Wt END IF l=Ke-Ie DO i=1,l j=Ie+i Sts(j)=Sts(j-Nyr) DO k=1,Iorder Sts(j)=Sts(j)+w*(R**(Iorder-k))*(Sts(j-k*Nyr)-Sts(j-(k+1)*Nyr)) END DO END DO C --- THIS PART IS A BACKCAST FROM IB-1 TO IB-L. IF(Ib.gt.1)THEN DO i=1,l j=Ib-i Sts(j)=Sts(j+Nyr) DO k=1,Iorder Sts(j)=Sts(j)+w*(R**(Iorder-k))*(Sts(j+k*Nyr)-Sts(j+(k+1)*Nyr)) END DO END DO END IF RETURN END fouger.f0000664006604000003110000000277614521201477011646 0ustar sun00315stepsC Last change: BCM 12 Mar 98 9:48 am **==fouger.f processed by SPAG 4.03F at 11:38 on 7 Nov 1994 SUBROUTINE fouger(G,Lgp1,Fc,Fs,Lf1,Frq) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION ck,ck2,cst0,Fc,Fs,G,sk,t,tk,um0,um1,um2, & Frq INTEGER i,i2,k,Lf1,lg,lg3,lg4,Lgp1 C*** End of declarations inserted by SPAG C COMMON SUBROUTINE C FOURIER TRANSFORM (GOERTZEL METHOD) C THIS SUBROUTINE COMPUTES FOURIER TRANSFORM OF G(I),I=0,1,...,LG AT C FREQUENCIES K/(2*LF),K=0,1,...,LF AND RETURNS COSIN TRANSFORM IN C FC(K) AND SIN TRANSFORM IN FS(K). c INTEGER lf c DOUBLE PRECISION alf DOUBLE PRECISION PI PARAMETER(PI=3.14159265358979D0) DIMENSION G(*),Fc(*),Fs(*),Frq(*) lg=Lgp1-1 c lf=Lf1-1 cst0=0.0D-00 C REVERSAL OF G(I),I=1,...,LGP1 INTO G(LG3-I) LG3=LGP1+1 IF(Lgp1.gt.1)THEN lg3=Lgp1+1 lg4=Lgp1/2 DO i=1,lg4 i2=lg3-i t=G(i) G(i)=G(i2) G(i2)=t END DO END IF c pi=3.14159265358979D0 c alf=lf t=PI*2 DO k=1,Lf1 tk=t*Frq(k) ck=cos(tk) sk=sin(tk) ck2=ck+ck um2=cst0 um1=cst0 IF(lg.ne.0)THEN DO i=1,lg um0=ck2*um1-um2+G(i) um2=um1 um1=um0 END DO END IF Fc(k)=ck*um1-um2+G(Lgp1) Fs(k)=sk*um1 END DO RETURN END frctbl.i0000664006604000003110000000176114521201477011627 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c force FRC or FC c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c change in adjusted seasonal adjusted E6A c change in rounded seasonal adjusted E6R c seasonal adjusted, yr totals adj SAA c rounded seasonal adjusted RND c----------------------------------------------------------------------- INTEGER LFCSAA,LFCRND,LFCE6A,LFC6AP,LFCE6R,LFC6RP,LFRCCR,LFRCRR, & LFRFAC PARAMETER( & LFCSAA=209,LFCRND=210,LFCE6A=211,LFC6AP=212,LFCE6R=213, & LFC6RP=214,LFRCCR=215,LFRCRR=216,LFRFAC=217) fstop.f0000664006604000003110000000220714521201477011477 0ustar sun00315steps**==fstop.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE fstop() IMPLICIT NONE c----------------------------------------------------------------------- c Opens a file with the given options and assigns a file handle c----------------------------------------------------------------------- c Parameters and include files c----------------------------------------------------------------------- INCLUDE 'stdio.i' c----------------------------------------------------------------------- c Local Arguments c Name Type Description c----------------------------------------------------------------------- c ifile i Index for the current file c----------------------------------------------------------------------- INTEGER ifile c----------------------------------------------------------------------- c Close all the open files and stop c----------------------------------------------------------------------- DO ifile=1,Nfile CLOSE(Fillst(ifile)) END DO Nfile=0 c ------------------------------------------------------------------ RETURN END ftest.f0000664006604000003110000002443014521201500011456 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 11:15 am SUBROUTINE ftest(X,Ib,Ie,Nyr,Ind,Lprt,Lsav) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS ROUTINE COMPUTES A ONE-WAY ANALYSIS OF VARIANCE ON SERIES C --- X. IF THE TREND HAS NOT BEEN REMOVED FROM X, IT IS ELIMINATED C --- BY A FIRST DIFFERENCE. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'units.cmn' INCLUDE 'agr.cmn' INCLUDE 'ssap.prm' INCLUDE 'ssft.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'tests.cmn' c----------------------------------------------------------------------- CHARACTER blank*2,star*2,star2*2,fstar*2,xb*50 DOUBLE PRECISION dfb,f,prob,Temp,X,c,dfr,fmsm,fmsr,ssm,ssqt, & ssr,st,summ,sumt INTEGER i,Ib,Ie,Ind,itype,j,ji,kb,kdfb,kdfr,kdft,l,nm,nt,Nyr, & id11f,sp1 LOGICAL Lprt,Lsav DIMENSION X(Ie),Temp(PLEN) c----------------------------------------------------------------------- DOUBLE PRECISION fvalue LOGICAL dpeq EXTERNAL dpeq,fvalue c----------------------------------------------------------------------- COMMON /work / Temp c----------------------------------------------------------------------- DATA blank,star/' ','* '/,star2/'**'/ c----------------------------------------------------------------------- c=1.0D0 sp1=0 l=0 IF(Lwdprt)sp1=16 xb=' ' id11f=0 c----------------------------------------------------------------------- IF(Issap.eq.2.and.Ind.gt.0)RETURN IF(Muladd.eq.0)c=10000.0D0 itype=0 IF(Ind.eq.0.or.Ind.eq.2)THEN DO i=Ib,Ie Temp(i)=X(i) END DO kb=Ib ELSE IF(Same)THEN WRITE(Mt1,1000) CALL errhdr WRITE(Mt2,1000) 1000 FORMAT(' WARNING: Program cannot perform F-test on first ', & 'differenced data.') RETURN END IF l=Nyr/4 kb=Ib+l DO i=kb,Ie Temp(i)=X(i)-X(i-l) END DO END IF DO WHILE (.true.) nt=0 sumt=0.0D0 ssqt=0.0D0 ssm=0.0D0 DO i=1,Nyr nm=0 summ=0.0D0 ji=i+kb-1 DO j=ji,Ie,Nyr nm=nm+1 summ=summ+Temp(j) ssqt=ssqt+Temp(j)*Temp(j) END DO nt=nt+nm sumt=sumt+summ ssm=ssm+summ*summ/nm END DO st=nt ssqt=(ssqt-sumt*sumt/st)*c ssm=(ssm-sumt*sumt/st)*c ssr=ssqt-ssm kdfr=nt-Nyr kdft=nt-1 kdfb=Nyr-1 dfr=kdfr dfb=kdfb fmsm=ssm/dfb fmsr=ssr/dfr IF(dpeq(fmsr,0D0))THEN WRITE(Mt1,1001)xb(1:(sp1+12)),xb(1:(sp1+12)) CALL errhdr WRITE(Mt2,1001)' WARNING: ',xb(1:10) 1001 FORMAT(/,a,'Cannot compute F-statistic since residual mean', & ' square error',/,a,'is equal to zero for this series.') RETURN END IF f=fmsm/fmsr prob=fvalue(f,kdfb,kdfr)*100D0 IF(Ind.eq.0)THEN Fstabl=f P1=prob ELSE IF(Ind.ne.1)THEN Fpres=f P3=prob END IF IF(prob.le.0.1D0)THEN fstar=star2 ELSE IF(prob.gt.1.0D0)THEN fstar=blank ELSE fstar=star END IF IF((Lhiddn.and.Issap.lt.2).or.((Ixreg.eq.2.or.Khol.eq.1).and. & (.not.Prt1ps)))RETURN C --- IF THIS F TEST IS FOR TABLE D8 AND TABLE D8 IS NOT TO BE C --- PRINTED, DON'T PRINT THE RESULTS OF THIS TEST IF(Ind.eq.0.or.Ind.eq.2)THEN IF(Issap.eq.2.and.Ind.eq.0)THEN Ssfts(Icol)=f ELSE IF(.not.Lhiddn.and.Lprt)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1010)xb(1:(sp1+4)) IF(Lcmpaq)THEN IF(Nyr.eq.12)THEN WRITE(Mt1,1021)xb(1:(sp1+21)), & ' Between months',ssm,kdfb,fmsm,f,fstar, & xb(1:(sp1+10)),ssr,kdfr,fmsr,xb(1:(sp1+13)), & ssqt,kdft ELSE WRITE(Mt1,1021)xb(1:(sp1+21)), & ' Between quarters',ssm,kdfb,fmsm,f,fstar, & xb(1:(sp1+10)),ssr,kdfr,fmsr,xb(1:(sp1+13)), & ssqt,kdft END IF ELSE IF(Nyr.eq.12)THEN WRITE(Mt1,1020)xb(1:(sp1+27)),xb(1:(sp1+26)),xb(1:(sp1+2)), & ' Between months',ssm,kdfb,fmsm,f,fstar, & xb(1:(sp1+10)),ssr,kdfr,fmsr,xb(1:(sp1+13)), & ssqt,kdft ELSE WRITE(Mt1,1020)xb(1:(sp1+27)),xb(1:(sp1+26)),xb(1:(sp1+2)), & 'Between quarters',ssm,kdfb,fmsm,f,fstar, & xb(1:(sp1+10)),ssr,kdfr,fmsr,xb(1:(sp1+13)), & ssqt,kdft END IF END IF IF(fstar.eq.star2)WRITE(Mt1,1030)xb(1:(sp1+12)),fstar IF(fstar.ne.star2)WRITE(Mt1,1040)xb(1:(sp1+12)),fstar END IF IF(Muladd.ne.0.or.Lhiddn)RETURN IF(fmsr.gt.0.01D0)RETURN WRITE(Mt1,1130)xb(1:(sp1+12)),xb(1:(sp1+12)) RETURN END IF IF(.not.Lprt.and..not.Lsav)RETURN IF(itype.eq.0)THEN sp1=20 IF(Lwdprt)sp1=42 IF(Lprt)WRITE(Mt1,1050)xb(1:sp1) IF(fstar.eq.blank)THEN IF(Lprt)THEN IF(Lwdprt)THEN WRITE(Mt1,1070)fstar,f ELSE WRITE(Mt1,1071)fstar,f END IF END IF IF(Lsav)id11f=0 ELSE IF(Lprt)THEN IF(Lwdprt)THEN WRITE(Mt1,1060)fstar,f ELSE WRITE(Mt1,1061)fstar,f END IF END IF IF(Lsav)id11f=3 END IF IF(Lsav)THEN IF(Iagr.lt.4)THEN WRITE(Nform,1140)'d11.f: ',f,prob ELSE WRITE(Nform,1140)'id11.f: ',f,prob END IF END IF kb=Ie-3*Nyr+1 IF(kb.lt.(Ib+l))RETURN itype=1 GO TO 10 ELSE IF(fstar.ne.blank)THEN IF(Lprt)THEN IF(Lwdprt)THEN WRITE(Mt1,1110)fstar,f ELSE WRITE(Mt1,1111)fstar,f END IF END IF ELSE IF(Lprt)THEN IF(Lwdprt)THEN WRITE(Mt1,1080)fstar,f IF(prob.le.5D0)WRITE(Mt1,1090)fstar IF(prob.gt.5D0)WRITE(Mt1,1100)fstar ELSE WRITE(Mt1,1081)fstar,f IF(prob.le.5D0)WRITE(Mt1,1091)fstar IF(prob.gt.5D0)WRITE(Mt1,1101)fstar END IF END IF END IF IF(Lsav)THEN IF(Iagr.lt.4)THEN WRITE(Nform,1140)'d11.3y.f: ',f,prob ELSE WRITE(Nform,1140)'id11.3y.f: ',f,prob END IF END IF END IF IF(Lprt)THEN IF(Lwdprt)THEN WRITE(Mt1,1120) ELSE WRITE(Mt1,1121) END IF END IF RETURN 10 CONTINUE END DO c----------------------------------------------------------------------- 1010 FORMAT(a,'Test for the presence of seasonality assuming ', & 'stability.',/) 1020 FORMAT(a,'Sum of',5x,'Dgrs.of',9x,'Mean',/,a,'Squares',5x, & 'Freedom',8x,'Square',7x,'F-Value',/,a,a,f17.4,i9,f17.5, & f12.3,a2,/,a,'Residual',f17.4,i9,f17.5,/,a,'Total',f17.4, & i9,/) 1021 FORMAT(a,'Sum of squares',2x,'Dgrs.freedom',2x,'Mean square',5x, & 'F-value',/,a,f17.4,i9,f17.5, & f12.3,a2,/,a,'Residual',f17.4,i9,f17.5,/,a,'Total',f17.4, & i9,/) 1030 FORMAT(a,a2,'Seasonality present at the 0.1 per cent level.') 1040 FORMAT(a,A2, & 'No evidence of stable seasonality at the 0.1 per cent level.') 1050 FORMAT(/,a,'Test for the presence of residual seasonality.') 1060 FORMAT(/,18X,A2, &'Residual seasonality present in the entire series at the 1 per ce &nt level. F =',F10.2) 1061 FORMAT(/,5X,A2,'Residual seasonality present in the entire ', & 'series at the',/,12x,'1 per cent level. F =',F10.2) 1070 FORMAT(/,18X,A2, &'No evidence of residual seasonality in the entire series at the 1 & per cent level. F =',F10.2) 1071 FORMAT(/,5X,A2,'No evidence of residual seasonality in the ', & 'entire series at the',/,12x,'1 per cent level. F =', & F10.2) 1080 FORMAT(/,18X,A2, &'No evidence of residual seasonality in the last 3 years at the 1 &per cent level. F =',F10.2) 1081 FORMAT(/,5X,A2,'No evidence of residual seasonality in the ', & 'last 3 years at the',/,12x,'1 per cent level. F =', & F10.2) 1090 FORMAT(/,18X,A2, &'Residual seasonality present in the last 3 years at the 5 per cen &t level.') 1091 FORMAT(/,5X,A2,'Residual seasonality present in the last 3 ', & 'years at the',/,12x,'5 per cent level.') 1100 FORMAT(/,18X,A2, &'No evidence of residual seasonality in the last 3 years at the 5 &per cent level.') 1101 FORMAT(/,5X,A2,'No evidence of residual seasonality in the ', & 'last 3 years at the',/,12x,'5 per cent level.') 1110 FORMAT(/,18X,A2,'Residual seasonality present in the last 3 ', & 'years at the 1 per cent level. F =',F10.2) 1111 FORMAT(/,5X,A2,'Residual seasonality present in the last 3 ', & 'years at the',/,12x,'1 per cent level. F =',F10.2) 1120 FORMAT(/,1X,'Note: sudden large changes in the level of the ', & 'adjusted series will invalidate the results ', & 'of this test for the',/,50x,'last three year period.') 1121 FORMAT(/,1X,'Note: sudden large changes in the level of the ', & 'adjusted series will',/,7x,'invalidate the ', & 'results of this test for the last three year period.') 1130 FORMAT(/,a,'Due to the small residual mean square error all', & ' the analysis', & /,a,'of variance tests for this series may be invalid.') 1140 FORMAT(a,2(2x,f12.5)) c----------------------------------------------------------------------- END func2.i0000664006604000003110000000020514521201500011343 0ustar sun00315stepsC C... Variables in Common Block /func2/ ... integer NUT,NT real*8 UT(22),FT(8) common /func2/ UT,FT,NUT,NT func3.i0000664006604000003110000000020614521201500011345 0ustar sun00315stepsC C... Variables in Common Block /func3/ ... integer NUC,NC real*8 UC(32),FC(32) common /func3/ UC,FC,NUC,NC func4.i0000664006604000003110000000020414521201500011344 0ustar sun00315stepsC C... Variables in Common Block /func4/ ... integer NF,NH real*8 FF(32),FH(32) common /func4/ FF,FH,NF,NH func5f1.i0000664006604000003110000000024614521201500011602 0ustar sun00315stepsC C... Variables in Common Block /func5f1/ ... integer NDUMf1,ND1f1 real*8 DUMf1(200),DUM1f1(160) common /func5f1/ DUMf1,DUM1f1,NDUMf1,ND1f1 func5.i0000664006604000003110000000022414521201500011347 0ustar sun00315stepsC C... Variables in Common Block /func5/ ... integer NDUM,NDUM1 real*8 DUM(80),DUM1(80) common /func5/ DUM,DUM1,NDUM,NDUM1 func.i0000664006604000003110000000020014521201500011254 0ustar sun00315stepsC C... Variables in Common Block /func/ ... integer NV,NS real*8 V(50),FS(27) common /func/ V,FS,NV,NS fvalue.f0000664006604000003110000000362014521201500011611 0ustar sun00315steps**==fvalue.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 DOUBLE PRECISION FUNCTION fvalue(X,M,N) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION X INTEGER i,i1,j,j1,k,l,M,N C*** End of declarations inserted by SPAG C --- THIS FUNCTION CALCULATES F-DISTRIBUTION PROBABILITY LEVELS FOR C --- PR(R.V. WITH F-DISTRIBUTION WITH M AND N DEGREES OF FREEDOM > X) DOUBLE PRECISION w,z,p,y,d,zk IF(X.gt.0D0)THEN IF(X.le.90D0)THEN IF(X.le.40D0.or.N.le.150)THEN l=(M/2)*2-M+2 k=(N/2)*2-N+2 w=X*dble(M)/dble(N) z=1.0D0/(1.0D0+w) IF(l.ne.1)THEN IF(k.ne.1)THEN d=z*z p=w*z ELSE p=dsqrt(z) d=0.5D0*z*p p=1.0D0-p END IF ELSE IF(k.ne.1)THEN p=dsqrt(w*z) d=0.5D0*p*z/w ELSE p=dsqrt(w) y=0.31830988618379D0 d=y*z/p p=2.0D0*y*datan(p) END IF y=2.0D0*w/z j1=k+2 IF(N.ge.j1)THEN IF(l.ne.1)THEN zk=z**((N-1)/2) d=d*zk*dble(N)/dble(k) p=p*zk+w*z*(zk-1.0D0)/(z-1.0D0) ELSE DO j=j1,N,2 d=(1.0D0+dble(l)/dble(j-2))*d*z p=p+d*y/dble(j-1) END DO END IF END IF y=w*z i1=l+2 IF(M.ge.i1)THEN z=2.0D0/z k=N-2 DO i=i1,M,2 zk=dble(i+k) d=y*d*zk/dble(i-2) p=p-z*d/zk END DO END IF IF(p.lt.1.0D0)THEN IF(p.gt.0.0D0)GO TO 20 GO TO 10 END IF END IF END IF fvalue=0D0 RETURN END IF 10 fvalue=1D0 X=0D0 RETURN 20 fvalue=1.0D0-p RETURN END fxreg.cmn0000664006604000003110000000245514521201500011777 0ustar sun00315stepsc----------------------------------------------------------------------- c Cfxttl - data dictionary containing the names of the regression c variables held fixed for this regARIMA model c Bfx - parameter values of the regression c variables held fixed for this regARIMA model c Fxtype - type of regressor for the regression c variables held fixed for this regARIMA model c Cfxptr - pointer vector for data dictionary of the regression c variables held fixed for this regARIMA model c Nfxttl - number of the regression variables held fixed for this c regARIMA model c----------------------------------------------------------------------- CHARACTER Cfxttl*(PCOLCR*PB),Gfxttl*(PGRPCR*PGRP) DOUBLE PRECISION Bfx,Fixfac,Fixfc2 INTEGER Cfxptr,Nfxttl,Fxtype,Grpfix,Ngrpfx,Gfxptr,Ngfxtl,Fixind DIMENSION Bfx(PB),Fxtype(PB),Cfxptr(0:PB),Grpfix(0:PGRP), & Gfxptr(0:PGRP),Fixfac(PLEN),Fixfc2(PLEN),Fixind(PB) c----------------------------------------------------------------------- COMMON /Fxreg /Bfx,Fixfac,Fixfc2,Fxtype,Cfxptr,Nfxttl,Gfxptr, & Ngfxtl,Grpfix,Ngrpfx,Fixind,Cfxttl,Gfxttl c----------------------------------------------------------------------- fxshfr.f0000664006604000003110000001437014521201500011633 0ustar sun00315stepsC Last change: BCM 25 Nov 97 3:17 pm **==fxshfr.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 SUBROUTINE fxshfr(L2,Nz) IMPLICIT NONE C ********************************************************************** C * * C * COMPUTES UP TO L2 FIXED SHIFT K-POLYNOMIALS, TESTING FOR * C * CONVERGENCE IN THE LINEAR OR QUADRATIC CASE. * C * INITIATES ONE OF THE VARIABLE SHIFT ITERATIONS AND RETURNS * C * WITH THE NUMBER OF ZEROS FOUND. * C * L2 - LIMIT OF FIXED SHIFT STEPS * C * NZ - NUMBER OF ZEROS FOUND * C * * C ********************************************************************** INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'global.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION PT25,ZERO,ONE LOGICAL T,NT PARAMETER(T=.true.,NT=.false.,PT25=0.25D0,ZERO=0D0,ONE=1D0) c ------------------------------------------------------------------ DOUBLE PRECISION svu,svv,ui,vi,s DOUBLE PRECISION betas,betav,oss,ovv,ss,vv,ts,tv,ots,otv,tvv,tss INTEGER L2,Nz,rtype,i,j,iflag LOGICAL vpass,spass,vtry,stry c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ Nz=0 betav=PT25 betas=PT25 oss=Snr ovv=V0 C----------------------------------------------------------------------- C EVALUATE POLYNOMIAL BY SYNTHETIC DIVISION C----------------------------------------------------------------------- CALL quadsd(N0,U,V0,P0,Qp,A0,B0) CALL calcsc(rtype) DO j=1,L2 C----------------------------------------------------------------------- C CALCULATE NEXT K POLYNOMIAL AND ESTIMATE V0 C----------------------------------------------------------------------- CALL nextk(rtype) CALL calcsc(rtype) CALL newest(rtype,ui,vi) vv=vi C----------------------------------------------------------------------- C ESTIMATE S C----------------------------------------------------------------------- ss=ZERO IF(.not.dpeq(K(N),ZERO))ss=-P0(N0)/K(N) tv=ONE ts=ONE IF(j.eq.1.or.rtype.eq.3)GO TO 40 C----------------------------------------------------------------------- C COMPUTE RELATIVE MEASURES OF CONVERGENCE OF S AND V0 SEQUENCES C----------------------------------------------------------------------- IF(.not.dpeq(vv,ZERO))tv=abs((vv-ovv)/vv) IF(.not.dpeq(ss,ZERO))ts=abs((ss-oss)/ss) C----------------------------------------------------------------------- C IF DECREASING, MULTIPLY TWO MOST RECENT CONVERGENCE MEASURES C----------------------------------------------------------------------- tvv=ONE IF(tv.lt.otv)tvv=tv*otv tss=ONE IF(ts.lt.ots)tss=ts*ots C----------------------------------------------------------------------- C COMPARE WITH CONVERGENCE CRITERIA C----------------------------------------------------------------------- vpass=tvv.lt.betav spass=tss.lt.betas IF(.not.(spass.or.vpass))GO TO 40 C----------------------------------------------------------------------- C AT LEAST ONE SEQUENCE HAS PASSED THE CONVERGENCE TEST. C STORE VARIABLES BEFORE ITERATING C----------------------------------------------------------------------- svu=U svv=V0 DO i=1,N Svk(i)=K(i) END DO s=ss C----------------------------------------------------------------------- C CHOOSE ITERATION ACCORDING TO THE FASTEST CONVERGING SEQUENCE C----------------------------------------------------------------------- vtry=NT stry=NT IF(spass.and.((.not.vpass).or.tss.lt.tvv))GO TO 20 10 CALL quadit(ui,vi,Nz) IF(Nz.gt.0)RETURN C----------------------------------------------------------------------- C QUADRATIC ITERATION HAS FAILED. FLAG THAT IT HAS BEEN TRIED AND C DECREASE THE CONVERGENCE CRITERION. C----------------------------------------------------------------------- vtry=T betav=betav*PT25 C----------------------------------------------------------------------- C TRY LINEAR ITERATION IF IT HAS NOT BEEN TRIED AND THE S SEQUENCE IS C CONVERGING C----------------------------------------------------------------------- IF(stry.or.(.not.spass))GO TO 30 DO i=1,N K(i)=Svk(i) END DO 20 CALL realit(s,Nz,iflag) IF(Nz.gt.0)RETURN C----------------------------------------------------------------------- C LINEAR ITERATION HAS FAILED. FLAG THAT IT HAS BEEN C TRIED AND DECREASE THE CONVERGENCE CRITERION C----------------------------------------------------------------------- stry=T betas=betas*PT25 IF(iflag.ne.0)THEN C----------------------------------------------------------------------- C IF LINEAR ITERATION SIGNALS AN ALMOST DOUBLE REAL C ZERO ATTEMPT QUADRATIC INTERATION C----------------------------------------------------------------------- ui=-(s+s) vi=s*s GO TO 10 END IF C----------------------------------------------------------------------- C RESTORE VARIABLES C----------------------------------------------------------------------- 30 U=svu V0=svv DO i=1,N K(i)=Svk(i) END DO C----------------------------------------------------------------------- C TRY QUADRATIC ITERATION IF IT HAS NOT BEEN TRIED C AND THE V0 SEQUENCE IS CONVERGING C----------------------------------------------------------------------- IF(vpass.and.(.not.vtry))GO TO 10 C----------------------------------------------------------------------- C RECOMPUTE QP AND SCALAR VALUES TO CONTINUE THE SECOND STAGE C----------------------------------------------------------------------- CALL quadsd(N0,U,V0,P0,Qp,A0,B0) CALL calcsc(rtype) 40 ovv=vv oss=ss otv=tv ots=ts END DO RETURN END gauss.f0000664006604000003110000000413214521201501011451 0ustar sun00315stepsC Last change: BCM 29 Sep 97 9:27 am **==gauss.f processed by SPAG 4.03F at 09:48 on 1 Mar 1994 DOUBLE PRECISION FUNCTION gauss(X) c----------------------------------------------------------------------- c This function calculates normal probability levels for c pr(-x < N(0,1) r.v. < x ). c c This function/subroutine was developed by Statistics Canada. c We thank them for permission to use it here. c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION X,y,z,w c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ IF(.not.dpeq(X,0D0))THEN y=abs(X)/2.0D0 c ------------------------------------------------------------------ IF(y.ge.3.0D0)THEN gauss=1.0D0 RETURN c ------------------------------------------------------------------ ELSE IF(y.ge.1.0D0)THEN y=y-2.0D0 z=(((((((((((((-0.000045255659D0*y+0.000152529290D0)*y- & 0.000019538132D0)*y-0.000676904986D0)*y+0.001390604284D0) & *y-0.000794620820D0)*y-0.002034254874D0)*y+0.006549791214D0) & *y-0.010557625006D0)*y+0.011630447319D0)*y-0.009279453341D0) & *y+0.005353579108D0)*y-0.002141268741D0)*y+0.000535310849D0) & *y+0.999936657524D0 c ------------------------------------------------------------------ ELSE w=y*y z=((((((((0.000124818987D0*w-0.001075204047D0)*w+ & 0.005198775019D0)*w-0.019198292004D0)*w+0.059054035642D0) & *w-0.151968751364D0)*w+0.319152932694D0)*w-0.531923007300D0) & *w+0.797884560593D0)*y*2.0D0 END IF c ------------------------------------------------------------------ ELSE gauss=0.0D0 RETURN END IF c ------------------------------------------------------------------ gauss=z c ------------------------------------------------------------------ RETURN END gendff.f0000664006604000003110000000223114521201501011556 0ustar sun00315stepsC Last change: BCM 19 May 2003 9:29 am SUBROUTINE gendff(Srs,Pos1ob,Posfob,Srdiff,Df1ob,Taklog,Logten, & Thisd) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' c ------------------------------------------------------------------ DOUBLE PRECISION Srs,Srdiff LOGICAL Taklog,Logten INTEGER Pos1ob,Posfob,Df1ob,Thisd,i,j DIMENSION Srs(PLEN),Srdiff(PLEN) c ------------------------------------------------------------------ DO i=Pos1ob,Posfob IF(Taklog)THEN IF(Logten)THEN Srdiff(i)=log10(Srs(i)) ELSE Srdiff(i)=log(Srs(i)) END IF ELSE Srdiff(i)=Srs(i) END IF END DO c ------------------------------------------------------------------ Df1ob=Pos1ob IF(Thisd.eq.0)RETURN DO i=1,Thisd Df1ob=Df1ob+1 DO j=Posfob,Df1ob,-1 Srdiff(j)=Srdiff(j)-Srdiff(j-1) END DO END DO c ------------------------------------------------------------------ RETURN END genfoot.f0000664006604000003110000011341114521201501011771 0ustar sun00315steps SUBROUTINE genfoot(Fh,Ifoot,Icode) c----------------------------------------------------------------------- c genfoot.f, Release 1, Subroutine Version 1.1, Modified 19 Jun 2011 c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'htmlout.prm' c ------------------------------------------------------------------ INTEGER Fh,Ifoot,Icode c ------------------------------------------------------------------ IF(Icode.eq.PSTAR1F.or.Icode.eq.PLGLNK)THEN WRITE(Fh,1010)Ifoot,'*' ELSE IF (Icode.eq.PSTAR2F)THEN WRITE(Fh,1010)Ifoot,'**' ELSE IF (Icode.eq.PAMP1F)THEN WRITE(Fh,1010)Ifoot,'&' ELSE IF (Icode.eq.PAMP2F)THEN WRITE(Fh,1010)Ifoot,'&&' ELSE IF (Icode.eq.PATSG1F)THEN WRITE(Fh,1010)Ifoot,'@' ELSE IF (Icode.eq.PATSG2F)THEN WRITE(Fh,1010)Ifoot,'@@' ELSE IF (Icode.eq.PNOTINC)THEN WRITE(Fh,1010)Ifoot,'NT' ELSE IF (Icode.eq.PSIGNCH)THEN WRITE(Fh,1010)Ifoot,'SC' ELSE IF (Icode.eq.PINCON)THEN WRITE(Fh,1010)Ifoot,'IE' ELSE IF (Icode.eq.PTURNP)THEN WRITE(Fh,1010)Ifoot,'TP' ELSE IF (Icode.eq.PSSPCT1)THEN WRITE(Fh,1010)Ifoot,'1%' ELSE IF (Icode.eq.PSSPCT2)THEN WRITE(Fh,1010)Ifoot,'2%' ELSE IF (Icode.eq.PSSPCT3)THEN WRITE(Fh,1010)Ifoot,'3%' ELSE IF (Icode.eq.PSSPCT4)THEN WRITE(Fh,1010)Ifoot,'4%' ELSE IF (Icode.eq.PSSPLS1)THEN WRITE(Fh,1010)Ifoot,'1%' ELSE IF (Icode.eq.PSSPLS2)THEN WRITE(Fh,1010)Ifoot,'2%' ELSE IF (Icode.eq.PSSPLS3)THEN WRITE(Fh,1010)Ifoot,'3%' ELSE IF (Icode.eq.PSSPLS4)THEN WRITE(Fh,1010)Ifoot,'4%' ELSE IF (Icode.eq.PSSHSH1)THEN WRITE(Fh,1010)Ifoot,'1#' ELSE IF (Icode.eq.PSSHSH2)THEN WRITE(Fh,1010)Ifoot,'2#' ELSE IF (Icode.eq.PSSHSH3)THEN WRITE(Fh,1010)Ifoot,'3#' ELSE IF (Icode.eq.PSSHSH4)THEN WRITE(Fh,1010)Ifoot,'4#' ELSE IF (Icode.eq.PSSDLR1)THEN WRITE(Fh,1010)Ifoot,'1$' ELSE IF (Icode.eq.PSSDLR2)THEN WRITE(Fh,1010)Ifoot,'2$' ELSE IF (Icode.eq.PSSDLR3)THEN WRITE(Fh,1010)Ifoot,'3$' ELSE IF (Icode.eq.PSSDLR4)THEN WRITE(Fh,1010)Ifoot,'4$' ELSE IF (Icode.eq.PSSAT1)THEN WRITE(Fh,1010)Ifoot,'1@' ELSE IF (Icode.eq.PSSAT2)THEN WRITE(Fh,1010)Ifoot,'2@' ELSE IF (Icode.eq.PSSAT3)THEN WRITE(Fh,1010)Ifoot,'3@' ELSE IF (Icode.eq.PSSAT4)THEN WRITE(Fh,1010)Ifoot,'4@' ELSE IF (Icode.eq.PSIGNCH+PSSPCT1)THEN WRITE(Fh,1010)Ifoot,'SC, 1%' ELSE IF (Icode.eq.PSIGNCH+PSSPCT2)THEN WRITE(Fh,1010)Ifoot,'SC, 2%' ELSE IF (Icode.eq.PSIGNCH+PSSPCT3)THEN WRITE(Fh,1010)Ifoot,'SC, 3%' ELSE IF (Icode.eq.PSIGNCH+PSSPCT4)THEN WRITE(Fh,1010)Ifoot,'SC, 4%' ELSE IF (Icode.eq.PSIGNCH+PSSPLS1)THEN WRITE(Fh,1010)Ifoot,'SC, 1+' ELSE IF (Icode.eq.PSIGNCH+PSSPLS2)THEN WRITE(Fh,1010)Ifoot,'SC, 2+' ELSE IF (Icode.eq.PSIGNCH+PSSPLS3)THEN WRITE(Fh,1010)Ifoot,'SC, 3+' ELSE IF (Icode.eq.PSIGNCH+PSSPLS4)THEN WRITE(Fh,1010)Ifoot,'SC, 4+' ELSE IF (Icode.eq.PSIGNCH+PSSHSH1)THEN WRITE(Fh,1010)Ifoot,'SC, 1#' ELSE IF (Icode.eq.PSIGNCH+PSSHSH2)THEN WRITE(Fh,1010)Ifoot,'SC, 2#' ELSE IF (Icode.eq.PSIGNCH+PSSHSH3)THEN WRITE(Fh,1010)Ifoot,'SC, 3#' ELSE IF (Icode.eq.PSIGNCH+PSSHSH4)THEN WRITE(Fh,1010)Ifoot,'SC, 4#' ELSE IF (Icode.eq.PSIGNCH+PSSDLR1)THEN WRITE(Fh,1010)Ifoot,'SC, 1$' ELSE IF (Icode.eq.PSIGNCH+PSSDLR2)THEN WRITE(Fh,1010)Ifoot,'SC, 2$' ELSE IF (Icode.eq.PSIGNCH+PSSDLR3)THEN WRITE(Fh,1010)Ifoot,'SC, 3$' ELSE IF (Icode.eq.PSIGNCH+PSSDLR4)THEN WRITE(Fh,1010)Ifoot,'SC, 4$' ELSE IF (Icode.eq.PSIGNCH+PSSAT1)THEN WRITE(Fh,1010)Ifoot,'SC, 1@' ELSE IF (Icode.eq.PSIGNCH+PSSAT2)THEN WRITE(Fh,1010)Ifoot,'SC, 2@' ELSE IF (Icode.eq.PSIGNCH+PSSAT3)THEN WRITE(Fh,1010)Ifoot,'SC, 3@' ELSE IF (Icode.eq.PSIGNCH+PSSAT4)THEN WRITE(Fh,1010)Ifoot,'SC, 4@' ELSE IF (Icode.eq.PINCON+PSSPCT1)THEN WRITE(Fh,1010)Ifoot,'IE, 1%' ELSE IF (Icode.eq.PINCON+PSSPCT2)THEN WRITE(Fh,1010)Ifoot,'IE, 2%' ELSE IF (Icode.eq.PINCON+PSSPCT3)THEN WRITE(Fh,1010)Ifoot,'IE, 3%' ELSE IF (Icode.eq.PINCON+PSSPCT4)THEN WRITE(Fh,1010)Ifoot,'IE, 4%' ELSE IF (Icode.eq.PINCON+PSSPLS1)THEN WRITE(Fh,1010)Ifoot,'IE, 1+' ELSE IF (Icode.eq.PINCON+PSSPLS2)THEN WRITE(Fh,1010)Ifoot,'IE, 2+' ELSE IF (Icode.eq.PINCON+PSSPLS3)THEN WRITE(Fh,1010)Ifoot,'IE, 3+' ELSE IF (Icode.eq.PINCON+PSSPLS4)THEN WRITE(Fh,1010)Ifoot,'IE, 4+' ELSE IF (Icode.eq.PINCON+PSSHSH1)THEN WRITE(Fh,1010)Ifoot,'IE, 1#' ELSE IF (Icode.eq.PINCON+PSSHSH2)THEN WRITE(Fh,1010)Ifoot,'IE, 2#' ELSE IF (Icode.eq.PINCON+PSSHSH3)THEN WRITE(Fh,1010)Ifoot,'IE, 3#' ELSE IF (Icode.eq.PINCON+PSSHSH4)THEN WRITE(Fh,1010)Ifoot,'IE, 4#' ELSE IF (Icode.eq.PINCON+PSSDLR1)THEN WRITE(Fh,1010)Ifoot,'IE, 1$' ELSE IF (Icode.eq.PINCON+PSSDLR2)THEN WRITE(Fh,1010)Ifoot,'IE, 2$' ELSE IF (Icode.eq.PINCON+PSSDLR3)THEN WRITE(Fh,1010)Ifoot,'IE, 3$' ELSE IF (Icode.eq.PINCON+PSSDLR4)THEN WRITE(Fh,1010)Ifoot,'IE, 4$' ELSE IF (Icode.eq.PINCON+PSSAT1)THEN WRITE(Fh,1010)Ifoot,'IE, 1@' ELSE IF (Icode.eq.PINCON+PSSAT2)THEN WRITE(Fh,1010)Ifoot,'IE, 2@' ELSE IF (Icode.eq.PINCON+PSSAT3)THEN WRITE(Fh,1010)Ifoot,'IE, 3@' ELSE IF (Icode.eq.PINCON+PSSAT4)THEN WRITE(Fh,1010)Ifoot,'IE, 4@' ELSE IF (Icode.eq.PTURNP+PSSPCT1)THEN WRITE(Fh,1010)Ifoot,'TP, 1%' ELSE IF (Icode.eq.PTURNP+PSSPCT2)THEN WRITE(Fh,1010)Ifoot,'TP, 2%' ELSE IF (Icode.eq.PTURNP+PSSPCT3)THEN WRITE(Fh,1010)Ifoot,'TP, 3%' ELSE IF (Icode.eq.PTURNP+PSSPCT4)THEN WRITE(Fh,1010)Ifoot,'TP, 4%' ELSE IF (Icode.eq.PTURNP+PSSPLS1)THEN WRITE(Fh,1010)Ifoot,'TP, 1+' ELSE IF (Icode.eq.PTURNP+PSSPLS2)THEN WRITE(Fh,1010)Ifoot,'TP, 2+' ELSE IF (Icode.eq.PTURNP+PSSPLS3)THEN WRITE(Fh,1010)Ifoot,'TP, 3+' ELSE IF (Icode.eq.PTURNP+PSSPLS4)THEN WRITE(Fh,1010)Ifoot,'TP, 4+' ELSE IF (Icode.eq.PTURNP+PSSHSH1)THEN WRITE(Fh,1010)Ifoot,'TP, 1#' ELSE IF (Icode.eq.PTURNP+PSSHSH2)THEN WRITE(Fh,1010)Ifoot,'TP, 2#' ELSE IF (Icode.eq.PTURNP+PSSHSH3)THEN WRITE(Fh,1010)Ifoot,'TP, 3#' ELSE IF (Icode.eq.PTURNP+PSSHSH4)THEN WRITE(Fh,1010)Ifoot,'TP, 4#' ELSE IF (Icode.eq.PTURNP+PSSDLR1)THEN WRITE(Fh,1010)Ifoot,'TP, 1$' ELSE IF (Icode.eq.PTURNP+PSSDLR2)THEN WRITE(Fh,1010)Ifoot,'TP, 2$' ELSE IF (Icode.eq.PTURNP+PSSDLR3)THEN WRITE(Fh,1010)Ifoot,'TP, 3$' ELSE IF (Icode.eq.PTURNP+PSSDLR4)THEN WRITE(Fh,1010)Ifoot,'TP, 4$' ELSE IF (Icode.eq.PTURNP+PSSAT1)THEN WRITE(Fh,1010)Ifoot,'TP, 1@' ELSE IF (Icode.eq.PTURNP+PSSAT2)THEN WRITE(Fh,1010)Ifoot,'TP, 2@' ELSE IF (Icode.eq.PTURNP+PSSAT3)THEN WRITE(Fh,1010)Ifoot,'TP, 3@' ELSE IF (Icode.eq.PTURNP+PSSAT4)THEN WRITE(Fh,1010)Ifoot,'TP, 4@' ELSE IF (Icode.eq.PSIGNCH+PTURNP)THEN WRITE(Fh,1010)Ifoot,'SC, TP' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT1)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 1%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT2)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 2%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT3)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 3%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT4)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 4%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS1)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 1+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS2)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 2+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS3)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 3+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS4)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 4+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH1)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 1#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH2)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 2#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH3)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 3#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH4)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 4#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR1)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 1$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR2)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 2$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR3)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 3$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR4)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 4$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT1)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 1@' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT2)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 2@' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT3)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 3@' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT4)THEN WRITE(Fh,1010)Ifoot,'SC, TP, 4@' ELSE IF (Icode.eq.PSIGNCH+PTURNP)THEN WRITE(Fh,1010)Ifoot,'IE, TP' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT1)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 1%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT2)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 2%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT3)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 3%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT4)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 4%' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS1)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 1+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS2)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 2+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS3)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 3+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS4)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 4+' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH1)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 1#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH2)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 2#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH3)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 3#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH4)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 4#' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR1)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 1$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR2)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 2$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR3)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 3$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR4)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 4$' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT1)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 1@' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT2)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 2@' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT3)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 3@' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT4)THEN WRITE(Fh,1010)Ifoot,'IE, TP, 4@' ELSE IF (Icode.ge.PMINTR1.and.Icode.le.PMINTR6)THEN WRITE(Fh,1010)Ifoot,'-' ELSE IF (Icode.eq.PLSHD8) THEN WRITE(Fh,1010)Ifoot,'+' ELSE IF (Icode.eq.PSTRD8) THEN WRITE(Fh,1010)Ifoot,'*' ELSE IF (Icode.eq.PHSHD8) THEN WRITE(Fh,1010)Ifoot,'#' ELSE IF (Icode.eq.PATSD8) THEN WRITE(Fh,1010)Ifoot,'@' ELSE IF (Icode.eq.PAMPD8) THEN WRITE(Fh,1010)Ifoot,'&' ELSE IF (Icode.eq.PSTRD8+PLSHD8) THEN WRITE(Fh,1010)Ifoot,'*+' ELSE IF (Icode.eq.PHSHD8+PLSHD8) THEN WRITE(Fh,1010)Ifoot,'#+' ELSE IF (Icode.eq.PATSD8+PLSHD8) THEN WRITE(Fh,1010)Ifoot,'@+' ELSE IF (Icode.eq.PAMPD8+PLSHD8) THEN WRITE(Fh,1010)Ifoot,'&+' ELSE IF (Icode.eq.PSTR1TP) THEN WRITE(Fh,1010)Ifoot,'*' ELSE IF (Icode.eq.PSTR2TP) THEN WRITE(Fh,1010)Ifoot,'**' END IF c ------------------------------------------------------------------ CALL writTag(Fh,'
') IF(Icode.eq.PSTAR1F)THEN WRITE(Fh,1020) WRITE(Fh,1030)Ifoot,'Regression Table' ELSE IF(Icode.eq.PSTAR2F)THEN WRITE(Fh,1040) WRITE(Fh,1030)Ifoot,'Regression Table' ELSE IF(Icode.eq.PAMP1F)THEN WRITE(Fh,1050) WRITE(Fh,1030)Ifoot,'Regression Table' ELSE IF(Icode.eq.PAMP2F)THEN WRITE(Fh,1060) WRITE(Fh,1030)Ifoot,'Regression Table' ELSE IF(Icode.eq.PATSG1F)THEN WRITE(Fh,1070) WRITE(Fh,1030)Ifoot,'Regression Table' ELSE IF(Icode.eq.PATSG2F)THEN WRITE(Fh,1080) WRITE(Fh,1030)Ifoot,'Regression Table' ELSE IF (Icode.eq.PNOTINC)THEN WRITE(Fh,1090) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH)THEN WRITE(Fh,1100) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON)THEN WRITE(Fh,1110) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP)THEN WRITE(Fh,1120) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPCT1)THEN WRITE(Fh,1130)Cut(1,1),Cut(1,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPCT2)THEN WRITE(Fh,1130)Cut(1,2),Cut(1,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPCT3)THEN WRITE(Fh,1130)Cut(1,3),Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPCT4)THEN WRITE(Fh,1140)Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPLS1)THEN WRITE(Fh,1130)Cut(2,1),Cut(2,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPLS2)THEN WRITE(Fh,1130)Cut(2,2),Cut(2,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPLS3)THEN WRITE(Fh,1130)Cut(2,3),Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSPLS4)THEN WRITE(Fh,1140)Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSHSH1)THEN WRITE(Fh,1130)Cut(3,1),Cut(3,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSHSH2)THEN WRITE(Fh,1130)Cut(3,2),Cut(3,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSHSH3)THEN WRITE(Fh,1130)Cut(3,3),Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSHSH4)THEN WRITE(Fh,1140)Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSDLR1)THEN WRITE(Fh,1130)Cut(4,1),Cut(4,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSDLR2)THEN WRITE(Fh,1130)Cut(4,2),Cut(4,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSDLR3)THEN WRITE(Fh,1130)Cut(4,3),Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSDLR4)THEN WRITE(Fh,1140)Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSAT1)THEN WRITE(Fh,1130)Cut(5,1),Cut(5,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSAT2)THEN WRITE(Fh,1130)Cut(5,2),Cut(5,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSAT3)THEN WRITE(Fh,1130)Cut(5,3),Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSSAT4)THEN WRITE(Fh,1140)Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPCT1)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(1,1),Cut(1,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPCT2)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(1,2),Cut(1,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPCT3)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(1,3),Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPCT4)THEN WRITE(Fh,1100) WRITE(Fh,1140)Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPLS1)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(2,1),Cut(2,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPLS2)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(2,2),Cut(2,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPLS3)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(2,3),Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSPLS4)THEN WRITE(Fh,1100) WRITE(Fh,1140)Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSHSH1)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(3,1),Cut(3,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSHSH2)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(3,2),Cut(3,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSHSH3)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(3,3),Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSHSH4)THEN WRITE(Fh,1100) WRITE(Fh,1140)Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSDLR1)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(4,1),Cut(4,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSDLR2)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(4,2),Cut(4,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSDLR3)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(4,3),Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSDLR4)THEN WRITE(Fh,1100) WRITE(Fh,1140)Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSAT1)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(5,1),Cut(5,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSAT2)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(5,2),Cut(5,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSAT3)THEN WRITE(Fh,1100) WRITE(Fh,1130)Cut(5,3),Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PSSAT4)THEN WRITE(Fh,1100) WRITE(Fh,1140)Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPCT1)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(1,1),Cut(1,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPCT2)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(1,2),Cut(1,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPCT3)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(1,3),Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPCT4)THEN WRITE(Fh,1110) WRITE(Fh,1140)Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPLS1)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(2,1),Cut(2,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPLS2)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(2,2),Cut(2,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPLS3)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(2,3),Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSPLS4)THEN WRITE(Fh,1110) WRITE(Fh,1140)Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSHSH1)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(3,1),Cut(3,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSHSH2)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(3,2),Cut(3,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSHSH3)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(3,3),Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSHSH4)THEN WRITE(Fh,1110) WRITE(Fh,1140)Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSDLR1)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(4,1),Cut(4,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSDLR2)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(4,2),Cut(4,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSDLR3)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(4,3),Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSDLR4)THEN WRITE(Fh,1110) WRITE(Fh,1140)Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSAT1)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(5,1),Cut(5,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSAT2)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(5,2),Cut(5,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSAT3)THEN WRITE(Fh,1110) WRITE(Fh,1130)Cut(5,3),Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PINCON+PSSAT4)THEN WRITE(Fh,1110) WRITE(Fh,1140)Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPCT1)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,1),Cut(1,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPCT2)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,2),Cut(1,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPCT3)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,3),Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPCT4)THEN WRITE(Fh,1120) WRITE(Fh,1140)Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPLS1)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,1),Cut(2,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPLS2)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,2),Cut(2,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPLS3)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,3),Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSPLS4)THEN WRITE(Fh,1120) WRITE(Fh,1140)Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSHSH1)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,1),Cut(3,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSHSH2)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,2),Cut(3,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSHSH3)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,3),Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSHSH4)THEN WRITE(Fh,1120) WRITE(Fh,1140)Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSDLR1)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,1),Cut(4,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSDLR2)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,2),Cut(4,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSDLR3)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,3),Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSDLR4)THEN WRITE(Fh,1120) WRITE(Fh,1140)Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSAT1)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,1),Cut(5,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSAT2)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,2),Cut(5,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSAT3)THEN WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,3),Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PTURNP+PSSAT4)THEN WRITE(Fh,1120) WRITE(Fh,1140)Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT1)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,1),Cut(1,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT2)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,2),Cut(1,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT3)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,3),Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT4)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1140)Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS1)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,1),Cut(2,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS2)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,2),Cut(2,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS3)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,3),Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS4)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1140)Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH1)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,1),Cut(3,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH2)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,2),Cut(3,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH3)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,3),Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH4)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1140)Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR1)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,1),Cut(4,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR2)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,2),Cut(4,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR3)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,3),Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR4)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1140)Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT1)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,1),Cut(5,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT2)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,2),Cut(5,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT3)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,3),Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT4)THEN WRITE(Fh,1100) WRITE(Fh,1120) WRITE(Fh,1140)Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT1)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,1),Cut(1,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT2)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,2),Cut(1,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT3)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(1,3),Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPCT4)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1140)Cut(1,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS1)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,1),Cut(2,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS2)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,2),Cut(2,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS3)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(2,3),Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSPLS4)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1140)Cut(2,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH1)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,1),Cut(3,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH2)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,2),Cut(3,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH3)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(3,3),Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSHSH4)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1140)Cut(3,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR1)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,1),Cut(4,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR2)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,2),Cut(4,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR3)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(4,3),Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSDLR4)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1140)Cut(4,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT1)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,1),Cut(5,2) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT2)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,2),Cut(5,3) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT3)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1130)Cut(5,3),Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' ELSE IF (Icode.eq.PSIGNCH+PTURNP+PSSAT4)THEN WRITE(Fh,1110) WRITE(Fh,1120) WRITE(Fh,1140)Cut(5,4) WRITE(Fh,1030)Ifoot,'Sliding Spans Table' c ------------------------------------------------------------------ ELSE IF (Icode.ge.PMINTR1.and.Icode.le.PMINTR6)THEN WRITE(Fh,1150) IF(Icode.eq.PMINTR1)WRITE(Fh,1030)Ifoot,'Table B 7' IF(Icode.eq.PMINTR2)WRITE(Fh,1030)Ifoot,'Table B 12' IF(Icode.eq.PMINTR3)WRITE(Fh,1030)Ifoot,'Table C 7' IF(Icode.eq.PMINTR4)WRITE(Fh,1030)Ifoot,'Table C 12' IF(Icode.eq.PMINTR5)WRITE(Fh,1030)Ifoot,'Table D 7' IF(Icode.eq.PMINTR6)WRITE(Fh,1030)Ifoot,'Table D 12' c ------------------------------------------------------------------ ELSE IF (Icode.eq.PLSHD8) THEN WRITE(Fh,1160) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PSTRD8) THEN WRITE(Fh,1170) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PHSHD8) THEN WRITE(Fh,1180) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PATSD8) THEN WRITE(Fh,1190) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PAMPD8) THEN WRITE(Fh,1200) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PSTRD8+PLSHD8) THEN WRITE(Fh,1170) WRITE(Fh,1160) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PHSHD8+PLSHD8) THEN WRITE(Fh,1180) WRITE(Fh,1160) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PATSD8+PLSHD8) THEN WRITE(Fh,1190) WRITE(Fh,1160) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PAMPD8+PLSHD8) THEN WRITE(Fh,1200) WRITE(Fh,1160) WRITE(Fh,1030)Ifoot,'Table D 8.B' ELSE IF (Icode.eq.PLGLNK) THEN WRITE(Fh,1210) WRITE(Fh,1030)Ifoot,'Link to External Files' ELSE IF (Icode.eq.PSTR1TP) THEN WRITE(Fh,1220) WRITE(Fh,1030)Ifoot,'Tukey Spectral Peaks Table' ELSE IF (Icode.eq.PSTR2TP) THEN WRITE(Fh,1230) WRITE(Fh,1030)Ifoot,'Tukey Spectral Peaks Table' END IF CALL writTag(Fh,'
') c ------------------------------------------------------------------ 1010 FORMAT('
Definition of ',a,'
') 1020 FORMAT('

For full trading-day and stable seasonal effects,', & 'the derived',/, & 'parameter estimate is obtained indirectly as minus ', & 'the sum',/, & 'of the directly estimated parameters that define the ', & 'effect.

') 1030 FORMAT('

Back to ',a,'

') 1040 FORMAT('

For the one coefficient trading-day effect, the ', & 'derived',/, & ' parameter estimate is obtained indirectly as minus ', & '-2.5 times',/, & ' the directly estimated parameter that defines ', & 'the effect.

') 1050 FORMAT('

The I values estimate the regression coefficients', & /,' for the span of data before the change date.

') 1060 FORMAT('

The I values estimate how much the early regression', & /,' coefficients differ from those estimated for the span', & ' of data',/,' starting at the change date.

') 1070 FORMAT('

The II values estimate the regression coefficients', & /,' for the span of data starting at the change date.

') 1080 FORMAT('

The II values estimate how much the early regression', & /,' coefficients differ from those estimated for the span', & ' of data',/,' before the change date.

') 1090 FORMAT('

Observation not included in sliding spans ', & 'comparisons.

') 1100 FORMAT('

A sign change can be found for this observation.

') 1110 FORMAT('

The estimates of this effect are inconsistent', & ' for this observation;', & /,' one span indicates that the effect causes an ', & 'increase in the ', & /,' observed value, another that it causes a decrease.', & '

') 1120 FORMAT('

Span values for this observation have a turning ', & 'point.

') 1130 FORMAT('

The maximum percentage difference is greater than ', & 'or equal to ',f4.1,'%',/,' but less than ',f4.1,'%.

') 1140 FORMAT('

The maximum percentage difference is greater than ', & 'or equal to ',f4.1,'%.

') 1150 FORMAT('

Trend cycle estimate that had a negative value', & ' replaced.

') 1160 FORMAT('

Values around a level shift most likely to be ', & 'influenced by it.

') 1170 FORMAT('

Extreme value as determined by X-11 extreme value ', & 'procedure.

') 1180 FORMAT('

regARIMA outlier (either AO, LS, TC, or Ramp).

') 1190 FORMAT('

Extreme value and at least one type of regARIMA ', & 'outlier.

') 1200 FORMAT('

More than one type of regARIMA outlier.

') 1210 FORMAT('

Link to Log File specified is only valid if complete ', & 'paths were specified',/, & 'for the output and meta files.

') 1220 FORMAT('

Tukey spectral peak probability greater than 0.99

') 1230 FORMAT('

Tukey spectral peak probability greater than 0.90

') cc ------------------------------------------------------------------ RETURN END genfor.f0000664006604000003110000001265214521201501011615 0ustar sun00315stepsC Last change: BCM 1 Jun 1998 4:08 pm **==genfor.f processed by SPAG 4.03F at 11:36 on 10 Jun 1994 SUBROUTINE genfor(Ok,Lchkin,Isrs) IMPLICIT NONE c ------------------------------------------------------------------ C --- THIS SUBROUTINE PRINTS THE HEADINGS FOR THE VARIOUS FILES AND C --- INITIALIZES VALUES. C --- THE UNIT MT IS THE CONTROL CARD INPUT FILE C --- MT1 IS THE MAIN PRINTOUT C --- MT2 IS THE LOG C --- NG IS THE FILE CONTAINING ALL THE Q STATISTICS C --- NFORM CONTAINS ALL THE F TABLES FOR THE RUN C --- NR IS THE TAPE INPUT FILE AND IS DEFINED IN THE ROUTINE C --- INPUT c --- Note - not all of these variables are set in this routine (BCM) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'agr.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'filetb.cmn' c ------------------------------------------------------------------ LOGICAL F PARAMETER(F=.false.) c ------------------------------------------------------------------ CHARACTER ext*4,fil*(PFILCR) LOGICAL Ok,lok,Lchkin INTEGER Isrs,nfil c ------------------------------------------------------------------ INTEGER nblank EXTERNAL nblank c ------------------------------------------------------------------ c For first series, initialize values c ------------------------------------------------------------------ IF(Isrs.eq.1)THEN Newpg=char(12) Iagr=0 Nform=0 END IF c ------------------------------------------------------------------ Mt1=0 Mt2=0 c ------------------------------------------------------------------ c Check filenames for improper file extensions c ------------------------------------------------------------------ Nfilcr=nblank(Cursrs) nfil=nblank(Infile) IF(nfil.gt.3)THEN ext=Infile((nfil-3):nfil) IF((ext(1:2).eq.'.s'.or.ext(1:2).eq.'.S').and. & (ext(3:3).eq.'p'.or.ext(3:3).eq.'P').and. & (ext(4:4).eq.'c'.or.ext(4:4).eq.'C'))THEN WRITE(STDERR,1010)'input spec',ext 1010 FORMAT(' ERROR: Enter ',a,' filename without "',a, & '" file extension.') Ok=F END IF END IF IF(Nfilcr.gt.3)THEN ext=Cursrs((Nfilcr-3):Nfilcr) IF((ext(1:2).eq.'.o'.or.ext(1:2).eq.'.O').and. & (ext(3:3).eq.'u'.or.ext(3:3).eq.'U').and. & (ext(4:4).eq.'t'.or.ext(4:4).eq.'T'))THEN WRITE(STDERR,1010)'output',ext Ok=F END IF END IF IF(nfil.eq.0)THEN WRITE(STDERR,1011) 1011 FORMAT(' No filename specified for input specification file.') Ok=F ELSE IF(Nfilcr.eq.0)THEN WRITE(STDERR,1012) 1012 FORMAT(' No output filename specified.') Ok=F END IF IF(.not.Ok)THEN CALL abend RETURN END IF c ------------------------------------------------------------------ c Try to open output file c ------------------------------------------------------------------ fil=Cursrs(1:Nfilcr)//'.out' nfil=Nfilcr+4 INQUIRE(FILE=fil(1:nfil),EXIST=Lexout) CALL fopen(fil(1:nfil),'program output file','UNKNOWN',Mt1,lok) Ok=Ok.and.lok c ------------------------------------------------------------------ c Try to open spec file c ------------------------------------------------------------------ IF(Ok)THEN nfil=nblank(Infile) Infile=Infile(1:nfil)//'.spc' nfil=nfil+4 CALL fopen(Infile(1:nfil),'input spec file','OLD',Mt,lok) Ok=Ok.and.lok END IF c ------------------------------------------------------------------ c Try to open error file c ------------------------------------------------------------------ IF(Ok)THEN fil=Cursrs(1:Nfilcr)//'.err' nfil=Nfilcr+4 INQUIRE(FILE=fil(1:nfil),EXIST=Lexerr) CALL fopen(fil(1:nfil),'program error file','UNKNOWN',Mt2,lok) Ok=Ok.and.lok END IF c ------------------------------------------------------------------ c Print out summary of files opened by this routine if all files c have been opened c ------------------------------------------------------------------ IF(Ok)THEN nfil=nblank(Infile) WRITE(STDOUT,1030)Infile(1:nfil),Cursrs(1:Nfilcr)//'.out', & Cursrs(1:Nfilcr)//'.err' 1030 FORMAT(/,' Reading input spec file from ',a,/, & ' Storing any program output into ',a,/, & ' Storing any program error messages into ',a) c ------------------------------------------------------------------ WRITE(Mt2,1020)PRGNAM,Infile(1:nfil) 1020 FORMAT(5x,'Error messages generated from processing the ',a, & ' spec file',/,5x,A,':',//) c ------------------------------------------------------------------ c If all files have not been opened, close all files and return c ------------------------------------------------------------------ ELSE CALL fclose(-1) RETURN END IF c ------------------------------------------------------------------ IF((.not.Lchkin).and.Lpage)Kpage=1 c ------------------------------------------------------------------ RETURN END genindex.f0000664006604000003110000011144714521201501012140 0ustar sun00315steps SUBROUTINE genIndex(Fh,Indx,IndxCode) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL T,F INTEGER NLVL PARAMETER (T=.true.,F=.false.,NLVL=5) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'ssap.prm' INCLUDE 'tbltitle.prm' INCLUDE 'tbllog.prm' INCLUDE 'level.prm' INCLUDE 'htmlfile.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'error.cmn' INCLUDE 'spctbl.i' c INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER tblttl*(PTTLEN),eststr*(100),ex*(2),savstr*(100) INTEGER Fh,Indx,IndxCode,n1,ntbttl,i2,iss,nstr,npass,ipos,i,indxbk LOGICAL lerrbk DIMENSION ex(2*NEST) c----------------------------------------------------------------------- CHARACTER SSEDIC*174 INTEGER sseptr,PSSE PARAMETER(PSSE=6) DIMENSION sseptr(0:PSSE) PARAMETER(SSEDIC= &'Seasonal FactorsTrading Day FactorsFinal Seasonally Adjusted Seri &esMonth-to-Month Changes in SA SeriesYear-to-Year Changes in SA Se &riesQuarter-to-Quarter Changes in SA Series') c----------------------------------------------------------------------- CHARACTER SETDIC*126 INTEGER setptr,PSET PARAMETER(PSET=12) DIMENSION setptr(0:PSET) PARAMETER(SETDIC='StochasticRegressionTotalRevision error ofStocha &sticRegressionTotalRevision error ofStochasticRegressionTotalRevis &ion error of') c----------------------------------------------------------------------- CHARACTER SERDIC*568 INTEGER serptr,PSER PARAMETER(PSER=8) DIMENSION serptr(0:PSER) PARAMETER(SERDIC='Standard error of revision in trend-cycle estima &tor (last 5 years)Finite sample standard error of revision in tren &d-cycle estimator (last 5 years)Standard error of revision in tren &d-cycle estimator (last years)Finite sample standard error of revi &sion in trend-cycle estimator (last years)Standard error of revisi &on in SA series estimator (last 5 years)Finite sample standard err &or of revision in SA series estimator (last 5 years)Standard error & of revision in SA series estimator (last years)Finite sample stan &dard error of revision in SA series estimator (last years)') c----------------------------------------------------------------------- CHARACTER REGDIC*389 INTEGER regptr,PREG PARAMETER(PREG=14) DIMENSION regptr(0:PREG) PARAMETER(REGDIC='Level shiftTransitory outliersSeasonal outliersE &aster effectDeterministic trading day effectDeterministic seasonal & componentCalendar regression effectTrend-cycle regression effectB &usiness cycle regression effectIrregular regression effectTransito &ry component regression effectOther regression effect in seasonall &y adjusted seriesSeasonal regression effectSeparate regression eff &ect factors') c----------------------------------------------------------------------- CHARACTER FINDIC*210 INTEGER finptr,PFIN PARAMETER(PFIN=8) DIMENSION finptr(0:PFIN) PARAMETER(FINDIC='Final componentFinal seasonally adjusted seriesF &inal seasonally adjusted series with revised yearlyFinal trend-cyc &leFinal seasonalFinal td componentFinal transitory componentFinal &transitory-irregular component') c----------------------------------------------------------------------- CHARACTER RATDIC*132 INTEGER ratptr,PRAT PARAMETER(PRAT=6) DIMENSION ratptr(0:PRAT) PARAMETER(RATDIC='Original series (from regARIMA)Original seriesFi &nal seasonally adjusted seriesSeasonally adjusted seriesFinal tren &d-cycleTrend-cycle') c----------------------------------------------------------------------- CHARACTER OTLDIC*44 INTEGER otlptr,POTL PARAMETER(POTL=4) DIMENSION otlptr(0:POTL) PARAMETER(OTLDIC='AdditiveLevel ChangeTemporary ChangeSeasonal') c----------------------------------------------------------------------- CHARACTER PREDIC*381 INTEGER preptr,PPRE PARAMETER(PPRE=13) DIMENSION preptr(0:PPRE) PARAMETER(PREDIC='Seasonal componentSeasonal factors (x 100)Stocha &stic trading day factor (x 100)Transitory factors (x 100)Transitor &y componentStochastic trading day componentFinal trend-cycleReal-t &ime estimators of trend-cycleSeasonally adjusted seriesReal-time e &stimators of seasonally adjusted seriesIrregular componentIrregula &r factors (x 100)Final seasonally adjusted series with revised yea &rly') c----------------------------------------------------------------------- CHARACTER RSEDIC*320 INTEGER rseptr,PRSE PARAMETER(PRSE=7) DIMENSION rseptr(0:PRSE) PARAMETER(RSEDIC='Standard error of seasonal factorsStandard error & of stochastic trading day componentStandard error of transitory c &omponentStandard error of trend-cycleRevision from updating real-t &ime trend-cycle estimatorsStandard error of seasonally adjusted se &riesRevision from updating real-time seasonally adjusted series es &timators') c----------------------------------------------------------------------- DATA preptr/1,19,43,80,106,126,158,175,210,236,286,305,330,382/ DATA rseptr/1,35,85,123,152,207,251,321/ DATA otlptr/1,9,21,37,45/ DATA ratptr/1,32,47,79,105,122,133/ DATA finptr/1,16,48,100,117,131,149,175,211/ DATA regptr/1,12,31,48,61,93,125,151,180,212,239,277,330,356,390/ DATA setptr/1,11,21,26,43,53,63,68,85,95,105,110,127/ DATA sseptr/1,17,36,68,103,136,175/ DATA serptr/1,67,147,211,289,353,431,493,569/ DATA ex/'a ','ai','b ','bi','c ','ci','d ','di','e ','ei'/ c----------------------------------------------------------------------- INCLUDE 'level.var' c----------------------------------------------------------------------- lerrbk=Lfatal Lfatal=F indxbk=Indx c----------------------------------------------------------------------- n1=Ncslast+1 IF(IndxCode.lt.NTBL)THEN tblttl=' ' CALL getdes(IndxCode,tblttl,ntbttl,T) IF(level(IndxCode,4))THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & tblttl(1:ntbttl),T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Plot of '//tblttl(1:ntbttl),T,F) END IF RETURN END IF c----------------------------------------------------------------------- IF(IndxCode.eq.1000)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Over/Under Estimation Test',T,F) ELSE IF(IndxCode.eq.1001)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SEATS Part 1 : ARIMA estimation',T,F) ELSE IF(IndxCode.eq.1002)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SEATS input parameters',T,F) ELSE IF(IndxCode.eq.1003)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Wiener-Kolmogorov filters (one side)',T,F) ELSE IF(IndxCode.eq.1004)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Contribution of original series and '// $ 'of its innovations to the estimator '// $ 'of the components',T,F) ELSE IF(IndxCode.eq.1005)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Autocorrelation function of components '// $ '(stationary transformation)',T,F) ELSE IF(IndxCode.eq.1006)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Forecast of stochastic series and '// $ 'components (levels)',T,F) ELSE IF(IndxCode.eq.1007)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Forecast of Seasonal Factors',T,F) ELSE IF(IndxCode.eq.1008)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Deterministic Component (from regARIMA)',T,F) ELSE IF(IndxCode.eq.1009)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Final Decomposition',T,F) ELSE IF(IndxCode.eq.1010)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Program Header',T,F) ELSE IF(IndxCode.eq.1011)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Forecast of Final Component',T,F) ELSE IF(IndxCode.eq.1012)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Decomposition of VARIANCE',T,F) ELSE IF(IndxCode.eq.1013)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Model Identification',T,F) ELSE IF(IndxCode.eq.1014)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Model Definition',T,F) ELSE IF(IndxCode.eq.1015)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Model Estimation/Evaluation',T,F) ELSE IF(IndxCode.eq.1016)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Diagnostic Checking',T,F) ELSE IF(IndxCode.eq.1017)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for trading day regressor', & T,F) ELSE IF(IndxCode.eq.1018)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for Easter regressor',T,F) ELSE IF(IndxCode.eq.1019)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for user-defined regressor', & T,F) ELSE IF(IndxCode.eq.1020)THEN IF(Ny.eq.4)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for length-of-quarter or '// & 'leap year regressor',T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for length-of-month or '// & 'leap year regressor',T,F) END IF c----------------------------------------------------------------------- ELSE IF(IndxCode.ge.1021.and.IndxCode.le.1030)THEN iss=IndxCode-1020 i2=iss/2 + 1 IF(i2.eq.4.and.Ny.eq.4)THEN CALL getstr(SSEDIC,sseptr,PSSE,PSSE,eststr,nstr) ELSE CALL getstr(SSEDIC,sseptr,PSSE,i2,eststr,nstr) END IF i2=mod(iss,2) IF(I2.eq.1)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 3.'//ex(iss)//' Sliding spans '// & 'breakdown table for '//eststr(1:nstr),T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 3.'//ex(iss)//' Sliding spans '// & 'breakdown table for '//eststr(1:nstr)// & ' (indirect)',T,F) END IF c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1031)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Links to other HTML files',T,F) ELSE IF(IndxCode.eq.1032)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Content of input specification file',T,F) ELSE IF(IndxCode.eq.1033)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Content of saved model file',T,F) ELSE IF(IndxCode.eq.1034)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Tabular Histogram of the Residuals',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.ge.1035.and.IndxCode.le.1044)THEN iss=IndxCode-1034 i2=iss/2 + 1 IF(i2.eq.4.and.Ny.eq.4)THEN CALL getstr(SSEDIC,sseptr,PSSE,PSSE,eststr,nstr) ELSE CALL getstr(SSEDIC,sseptr,PSSE,i2,eststr,nstr) END IF i2=mod(iss,2) IF(i2.eq.1)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Sliding spans Histogram for '// & eststr(1:nstr),T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Sliding spans Histogram for '// & eststr(1:nstr)//' (indirect)',T,F) END IF c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1045)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Spectral Diagnostics',T,F) ELSE IF(IndxCode.eq.1046)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SEATS Part 2: Models for the components',T,F) ELSE IF(IndxCode.eq.1047)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Autocorrelations of extended residuals',T,F) ELSE IF(IndxCode.eq.1048)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Autocorrelations of squared extended residuals',T,F) ELSE IF(IndxCode.eq.1049)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Autocorrelations of stationary series',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1050)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SEATS Part 5 : Rates of growth',T,F) ELSE IF(IndxCode.eq.1051)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Table 5.1',T,F) ELSE IF(IndxCode.eq.1052)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Table 5.2',T,F) ELSE IF(IndxCode.eq.1053)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Table 5.3',T,F) ELSE IF(IndxCode.eq.1054)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Table 5.4',T,F) ELSE IF(IndxCode.eq.1055)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Table 5.5',T,F) ELSE IF(IndxCode.eq.1056)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Table 5.6',T,F) ELSE IF(IndxCode.eq.1057)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Table 5.7',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1058)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Test statistics',T,F) ELSE IF(IndxCode.eq.1059)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Residual seasonality (non-parametric test)',T,F) ELSE IF(IndxCode.eq.1060)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SEATS Part 6 : Estimation of the Cycle',T,F) ELSE IF(IndxCode.eq.1061)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Model fitted',T,F) ELSE IF(IndxCode.eq.1062)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Partial Autocorrelations of stationary series',T,F) ELSE IF(IndxCode.eq.1063)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Differences',T,F) ELSE IF(IndxCode.eq.1064)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Parameter Estimates',T,F) ELSE IF(IndxCode.eq.1065)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'ARIMA model for estimators',T,F) ELSE IF(IndxCode.eq.1066)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Backcasting',T,F) ELSE IF(IndxCode.eq.1067)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'File Save Requests',T,F) ELSE IF(IndxCode.eq.1068)THEN IF(Muladd.ne.1)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'F 4. Multiplicative Trading Day Component'// & ' Factors',T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'F 4. Additive Trading Day Component Factors', & T,F) END IF ELSE IF(IndxCode.eq.1069)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Forecasting',T,F) ELSE IF(IndxCode.eq.1070)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'F Tests for Seasonal Regressors',T,F) ELSE IF(IndxCode.eq.1071)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'F Tests for Trading Day Regressors',T,F) ELSE IF(IndxCode.eq.1072)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'ARMA Iterations',T,F) ELSE IF(IndxCode.eq.1073)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'regARIMA Iterations',T,F) ELSE IF(IndxCode.eq.1074)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Regression model',T,F) ELSE IF(IndxCode.eq.1075)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'ARIMA model',T,F) ELSE IF(IndxCode.eq.1076)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Roots of '//Mdlttl(1:Nmdlcr),T,F) ELSE IF(IndxCode.eq.1077)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Irregular Regression Model',T,F) ELSE IF(IndxCode.eq.1078)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Spectrum of cycle',T,F) ELSE IF(IndxCode.eq.1079)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Sliding Spans Analysis',T,F) ELSE IF(IndxCode.eq.1080)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Sliding Spans Analysis: Direct '// & 'seasonal adjustment ',T,F) ELSE IF(IndxCode.eq.1081)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Outlier detection',T,F) ELSE IF(IndxCode.ge.1082.and.IndxCode.le.1085)THEN iss=IndxCode-1081 CALL getstr(OTLDIC,otlptr,POTL,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr)//' Outlier t-values',T,F) ELSE IF(IndxCode.ge.1086.and.IndxCode.le.1089)THEN iss=IndxCode-1085 CALL getstr(OTLDIC,otlptr,POTL,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Final '//eststr(1:nstr)//' Outlier t-values',T,F) ELSE IF(IndxCode.eq.1090)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 1 Sliding Spans Means',T,F) ELSE IF(IndxCode.eq.1091)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 1 Sliding Spans Means (Indirect)',T,F) ELSE IF(IndxCode.eq.1092)THEN IF(Ny.eq.12)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 2 Percentage of Months Flagged',T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 2 Percentage of Quarters Flagged',T,F) END IF ELSE IF(IndxCode.eq.1093)THEN IF(Ny.eq.12)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 2 Percentage of Months Flagged (Indirect)',T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'S 2 Percentage of Quarters Flagged (Indirect)',T,F) END IF ELSE IF(IndxCode.eq.1094)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Summary statistics for mean',T,F) ELSE IF(IndxCode.eq.1095)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Summary statistics for mean (Indirect)',T,F) ELSE IF(IndxCode.eq.1096)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for transformation',T,F) ELSE IF(IndxCode.eq.1097)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for trading day '// & '(irregular regression)',T,F) ELSE IF(IndxCode.eq.1098)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for Easter (irregular '// & 'regression)',T,F) ELSE IF(IndxCode.eq.1099)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & ''// & 'AIC test for user-defined '// & 'regressors (irregular regression)',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1100)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Original uncorrected series (from regARIMA)', & T,F) ELSE IF(IndxCode.eq.1101)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ 'Preadjustment factors outliers and ' // $ 'other deterministic effects',T,F) ELSE IF(IndxCode.eq.1102)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ 'Original series',T,F) ELSE IF(IndxCode.eq.1103)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ 'ARIMA series (corrected by regARIMA)',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.ge.1104.and.IndxCode.le.1107)THEN iss=IndxCode-1103 CALL getstr(SETDIC,setptr,PSET,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr)//' cyclical component',T,F) ELSE IF(IndxCode.ge.1108.and.IndxCode.le.1111)THEN iss=IndxCode-1107 CALL getstr(SETDIC,setptr,PSET,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr)//' cyclical factor',T,F) ELSE IF(IndxCode.eq.1112)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ 'Cyclical component',T,F) ELSE IF(IndxCode.eq.1113)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ 'Cyclical factors',T,F) ELSE IF(IndxCode.eq.1114)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ 'Revision error of cyclical factors',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.ge.1115.and.IndxCode.le.1122)THEN iss=IndxCode-1113 CALL getstr(SERDIC,serptr,PSER,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr),T,F) ELSE IF(IndxCode.ge.1123.and.IndxCode.le.1136)THEN iss=IndxCode-1122 CALL getstr(REGDIC,regptr,PREG,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr),T,F) ELSE IF(IndxCode.ge.2135.and.IndxCode.le.2142)THEN iss=IndxCode-2134 CALL getstr(FINDIC,finptr,PFIN,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr),T,F) ELSE IF(IndxCode.ge.1143.and.IndxCode.le.1156)THEN iss=IndxCode-1142 CALL getstr(REGDIC,regptr,PREG,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr)//' (X100)',T,F) ELSE IF(IndxCode.ge.1157.and.IndxCode.le.1162)THEN iss=IndxCode-1156 CALL getstr(RATDIC,ratptr,PRAT,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ 'Rates for '//eststr(1:nstr),T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1163)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Innovations',T,F) ELSE IF(IndxCode.eq.1164)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Differenced Series',T,F) ELSE IF(IndxCode.eq.1165)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Transformed Series',T,F) ELSE IF(IndxCode.eq.1166)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Differenced Series',T,F) ELSE IF(IndxCode.eq.1167)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Differenced and Centered Series',T,F) ELSE IF(IndxCode.eq.1168)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Differenced and Centered Transformed Series', & T,F) ELSE IF(IndxCode.eq.1169)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Preadjustment Component',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.ge.1170.and.IndxCode.le.1182)THEN iss=IndxCode-1169 CALL getstr(PREDIC,preptr,PPRE,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr),T,F) ELSE IF(IndxCode.ge.1183.and.IndxCode.le.1189)THEN iss=IndxCode-1182 CALL getstr(RSEDIC,rseptr,PRSE,iss,eststr,nstr) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', $ eststr(1:nstr),T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1190)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Contribution of original series and '// $ 'of its innovations to the estimator '// $ 'of the components',T,F) ELSE IF(IndxCode.eq.1191)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Studentized residuals',T,F) ELSE IF(IndxCode.eq.1192)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Studentized extended residuals',T,F) ELSE IF(IndxCode.eq.1193)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'MA'// & ' representation of estimators',T,F) ELSE IF(IndxCode.eq.1194)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Deterministic component from regARIMA',T,F) ELSE IF(IndxCode.eq.1195)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Weights for asymmetric filter',T,F) ELSE IF(IndxCode.eq.1196)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SEATS Part 4 : Estimates of the components', & T,F) ELSE IF(IndxCode.eq.1197)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Cross-Correlation',T,F) ELSE IF(IndxCode.eq.1198)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Cross-Covariance',T,F) ELSE IF(IndxCode.eq.1199)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SEATS Part 3 : Error analysis',T,F) ELSE IF(IndxCode.eq.1200)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Recent Estimates',T,F) ELSE IF(IndxCode.eq.1201)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Forecast Stochastic Components',T,F) ELSE IF(IndxCode.eq.1202)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Significance of Seasonality',T,F) ELSE IF(IndxCode.eq.1203)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'MA '// $ 'approximate model',T,F) ELSE IF(IndxCode.eq.1204)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Models for the components',T,F) ELSE IF(IndxCode.eq.1205)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Factorization of the MA polynomial',T,F) ELSE IF(IndxCode.eq.1208)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Tests for Cancellation of Level Shifts',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.eq.1500)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Chi-squared Tests for Groups of User-defined Holiday '// & 'Regressors',T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.gt.2000.and.IndxCode.lt.2500)THEN ipos=1 npass=IndxCode-2000 CALL itoc(npass,savstr,ipos) c write(Mtprof,*)' IndxCode, npass, savstr',IndxCode, npass, c & savstr(1:ipos-1) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Outlier identification: Forward addition '// & 'pass '//savstr(1:ipos-1),T,F) c----------------------------------------------------------------------- ELSE IF(IndxCode.ge.2500.and.IndxCode.le.2513)THEN iss=IndxCode-2500 IF(iss.eq.0)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Long term trend',T,F) ELSE IF(iss.eq.13)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Long term trend Component',T,F) ELSE CALL getstr(SETDIC,setptr,PSET,iss,eststr,nstr) IF(iss.gt.8)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)//' long term trend factors',T,F) ELSE IF(iss.gt.4)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)//' long term trend component', & T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)//' long term trend',T,F) END IF END IF ELSE IF(IndxCode.ge.2600.and.IndxCode.le.2609)THEN iss=IndxCode-2600 IF(iss.eq.0)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SA series without Business Cycle',T,F) ELSE IF(iss.eq.13)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'SA series without Business Cycle Component', & T,F) ELSE CALL getstr(SETDIC,setptr,PSET,iss,eststr,nstr) IF(iss.gt.8)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)// & ' SA series without Business Cycle factors', & T,F) ELSE IF(iss.gt.4)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)// & ' SA series without Business Cycle component', & T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)// & ' SA series without Business Cycle',T,F) END IF END IF ELSE IF(IndxCode.ge.2700.and.IndxCode.le.2709)THEN iss=IndxCode-2700 IF(iss.eq.0)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Series without Business Cycle',T,F) ELSE IF(iss.eq.13)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Series without Business Cycle Component', & T,F) ELSE CALL getstr(SETDIC,setptr,PSET,iss,eststr,nstr) IF(iss.gt.8)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)// & ' Series without Business Cycle factors', & T,F) ELSE IF(iss.gt.4)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)// & ' series without Business Cycle component', & T,F) ELSE CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & eststr(1:nstr-1)// & ' series without Business Cycle',T,F) END IF END IF c----------------------------------------------------------------------- ELSE IF(IndxCode.gt.4000)THEN i2=IndxCode-4000 IF(i2.eq.LSPCQS)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'QS Statistic for regARIMA Model Residuals',T,F) ELSE IF(i2.eq.LSPCTP)THEN CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Peak probabilities for Tukey spectrum '// & 'estimator: Indirect adjustments',T,F) END IF c----------------------------------------------------------------------- ELSE IF(IndxCode.gt.3000)THEN ipos=1 npass=IndxCode-3000 CALL itoc(npass,savstr,ipos) CALL makeIndexLink(Fh,Indx,CsrsHTML(n1:NcsHTML)//'.html', & 'Outlier identification: Backward deletion '// & 'pass '//savstr(1:ipos-1),T,F) END IF c----------------------------------------------------------------------- Lfatal=lerrbk c----------------------------------------------------------------------- IF(Indx.eq.indxbk)THEN WRITE(STDERR,*)' ' WRITE(STDERR,*)' Cannot create index entry for code = ',IndxCode WRITE(STDERR,*)' Send this code to x12@census.gov' Indx=Indx+1 END IF c----------------------------------------------------------------------- RETURN END gennpsa.f0000664006604000003110000001673314521201501011774 0ustar sun00315steps SUBROUTINE gennpsa(Lmodel,Lseats,Lx11,X11agr,Muladd,Kfulsm, & Iagr,Ny,Tblind,Lsvlg) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'adxser.cmn' INCLUDE 'extend.cmn' INCLUDE 'seatcm.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'rho.cmn' INCLUDE 'units.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' c INCLUDE 'spctbl.i' c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ZERO PARAMETER(F=.false.,T=.true.,ZERO=0D0) c----------------------------------------------------------------------- INTEGER ipos,Muladd,Kfulsm,Iagr,Ny,NPsadj,NPsadjS,NPsadj2, & NPsadjS2,nchr,nchr1,Tblind DOUBLE PRECISION srs LOGICAL Lmodel,Lseats,Lx11,Lvslg,X11agr,gosa,lplog,Lsvlg,lnp,lnps CHARACTER begstr*(10),chdr*(30),str*(3) DIMENSION srs(PLEN) c----------------------------------------------------------------------- logical dpeq integer npsa external dpeq,npsa c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='noyes') c----------------------------------------------------------------------- DATA ysnptr/1,3,6/ c----------------------------------------------------------------------- str=' ' chdr=' ' gosa=F c----------------------------------------------------------------------- lplog=F IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)lplog=T ELSE IF(dpeq(Lam,ZERO))lplog=T END IF END IF c----------------------------------------------------------------------- CALL dfdate(Bgspec,Begbk2,Ny,ipos) c----------------------------------------------------------------------- c Generate NP stat for the seasonally adjusted series c----------------------------------------------------------------------- NPsadj=NOTSET NPsadjS=NOTSET IF((Lx11.and.Kfulsm.eq.0).or.Lseats)THEN gosa=T IF(Lseats)gosa=Hvstsa END IF IF(gosa)THEN IF(Lseats)THEN CALL copy(Seatsa,PLEN,1,srs) ELSE CALL copy(Stci,PLEN,1,srs) END IF c----------------------------------------------------------------------- NPSadj=NPsa(srs,Pos1ob,Posfob,Lmodel,Nnsedf,Nseadf,Ny,lplog) IF((ipos+1).gt.Pos1ob) & NPSadjS=NPsa(srs,ipos+1,Posfob,Lmodel,Nnsedf,Nseadf,Ny,lplog) c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- c Generate NP stat for the seasonally adjusted series adjusted for c extreme values and outliers c----------------------------------------------------------------------- NPsadj2=NOTSET NPsadjS2=NOTSET IF(gosa)THEN IF(Iagr.eq.4)THEN IF(X11agr)THEN CALL copy(Stcime,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,Pos1ob,Posfob) ELSE CALL copy(Stci,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,Pos1ob,Posfob) END IF ELSE IF(Lx11)THEN CALL copy(Stcime,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,Pos1ob,Posfob) ELSE CALL copy(Stocsa,PLEN,1,srs) END IF c----------------------------------------------------------------------- NPSadj2=npsa(srs,Pos1ob,Posfob,Lmodel,Nnsedf,Nseadf,Ny,Llogqs) IF((ipos+1).gt.Pos1ob) & NPSadjS2=npsa(srs,ipos+1,Posfob,Lmodel,Nnsedf,Nseadf,Ny,Llogqs) END IF c----------------------------------------------------------------------- c Print out NP stats c----------------------------------------------------------------------- lnp=.not.((Npsadj.eq.NOTSET).and.(Npsadj2.eq.NOTSET)) lnps=.not.((NpsadjS.eq.DNOTST).and.(NpsadjS2.eq.DNOTST)) IF(Prttab(Tblind).and.(lnp.or.lnps))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1010)' NP statistic for residual seasonality: '// & '(indirect adjustment)' ELSE WRITE(Mt1,1010)' NP statistic for residual seasonality:' END IF IF(lnp)THEN chdr(1:13)='(Full series)' CALL OutNP(Mt1,NPsadj,NPsadj2,chdr,13,Lplog) END IF IF(lnps)THEN CALL wrtdat(Bgspec,Sp,begstr,nchr1) chdr(1:(nchr1+18))='(Series start in '//begstr(1:nchr1)//')' CALL OutNP(Mt1,NPsadjS,NPsadjS2,chdr,nchr1+18,Lplog) END IF END IF c----------------------------------------------------------------------- c save q stats to udg file c----------------------------------------------------------------------- IF(Savtab(Tblind).and.lnp)THEN IF(Iagr.lt.4)THEN IF(lplog)THEN WRITE(Nform,1040)'nplog','yes' ELSE WRITE(Nform,1040)'nplog','no' END IF END IF c----------------------------------------------------------------------- IF(.not.(NPsadj.eq.NOTSET))THEN CALL getstr(YSNDIC,ysnptr,PYSN,NPsadj+1,str,nchr) IF(Iagr.eq.4)THEN WRITE(Nform,1040)'npindsadj',str(1:nchr) ELSE WRITE(Nform,1040)'npsadj',str(1:nchr) END IF END IF c----------------------------------------------------------------------- IF(.not.(NPsadj2.eq.NOTSET))THEN CALL getstr(YSNDIC,ysnptr,PYSN,NPsadj2+1,str,nchr) IF(Iagr.eq.4)THEN WRITE(Nform,1040)'npindsadjevadj',str(1:nchr) ELSE WRITE(Nform,1040)'npsadjevadj',str(1:nchr) END IF END IF END IF c----------------------------------------------------------------------- IF(Savtab(Tblind).and.lnps)THEN IF(.not.(NPsadjS.eq.NOTSET))THEN CALL getstr(YSNDIC,ysnptr,PYSN,NPsadjS+1,str,nchr) IF(Iagr.eq.4)THEN WRITE(Nform,1040)'npsindsadj',str(1:nchr) ELSE WRITE(Nform,1040)'npssadj',str(1:nchr) END IF END IF IF(.not.(NPsadjS2.eq.NOTSET))THEN CALL getstr(YSNDIC,ysnptr,PYSN,NPsadjS2+1,str,nchr) IF(Iagr.eq.4)THEN WRITE(Nform,1040)'npsindsadjevadj',str(1:nchr) ELSE WRITE(Nform,1040)'npssadjevadj',str(1:nchr) END IF END IF END IF c----------------------------------------------------------------------- c save q stats to .log file c----------------------------------------------------------------------- IF(Lsvlg.and.(lnp.or.lnps))THEN WRITE(Ng,1010)' NP statistic for residual seasonality:' IF(lnp)THEN chdr(1:13)='(Full series)' CALL OutNP(Ng,NPsadj,NPsadj2,chdr,13,Lplog) END IF IF(lnps)THEN CALL wrtdat(Bgspec,Sp,begstr,nchr1) chdr(1:(nchr1+18))='(Series start in '//begstr(1:nchr1)//')' CALL OutNP(Ng,NPsadjS,NPsadjS2,chdr,nchr1+18,Lplog) END IF END IF c----------------------------------------------------------------------- 1010 FORMAT(/,a) 1040 FORMAT(a,': ',a) c----------------------------------------------------------------------- RETURN END genqs.f0000664006604000003110000006177114521201501011460 0ustar sun00315steps SUBROUTINE genqs(Lmodel,Lseats,Lx11,X11agr,Psuadd,Muladd,Kfulsm, & Iagr,Ny,Tblind,Lsvlg,Lorig) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'inpt.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'extend.cmn' INCLUDE 'seatcm.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'adxser.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'units.cmn' INCLUDE 'rho.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' c INCLUDE 'spctbl.i' c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ONE,ONEHND,ZERO PARAMETER(F=.false.,T=.true.,ONE=1D0,ONEHND=100D0,ZERO=0D0) c----------------------------------------------------------------------- CHARACTER begstr*(10) LOGICAL Lmodel,Lseats,Lx11,X11agr,goirr,gosa,lqs,lqss,Psuadd, & Lsvlg,Lorig,lplog INTEGER i,j,Muladd,Kfulsm,Iagr,Ny,ipos,nchr1,Tblind DOUBLE PRECISION qsori,qsirr,qssadj,qsori2,qsirr2,qssadj2,srs, & xmean,qsoriS,qsirrS,qssadjS,qsoriS2,qsirrS2, & qssadjS2 DIMENSION srs(PLEN) c----------------------------------------------------------------------- DOUBLE PRECISION Stmcd(PLEN),Stime(PLEN),Stex(PLEN) COMMON /mq5a / Stmcd,Stime COMMON /mq10 / Stex c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION calcqs,chisq EXTERNAL dpeq,calcqs,chisq c----------------------------------------------------------------------- goirr=F gosa=F lplog=F c----------------------------------------------------------------------- CALL dfdate(Bgspec,Begbk2,Ny,ipos) c----------------------------------------------------------------------- c Generate QS stat for the original series c----------------------------------------------------------------------- QSori=DNOTST QSoriS=DNOTST IF(Lorig)THEN CALL copy(Series,PLEN,1,srs) c----------------------------------------------------------------------- c take log of series if necessary (12-2-2014) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF END IF END IF c----------------------------------------------------------------------- CALL qsDiff(srs,Pos1ob,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSori) IF((ipos+1).gt.Pos1ob) & CALL qsDiff(srs,ipos+1,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSoriS) END IF c----------------------------------------------------------------------- c Generate QS stat for the original series adjusted for c extreme values and outliers c----------------------------------------------------------------------- QSori2=DNOTST QSoriS2=DNOTST IF(Lorig)THEN CALL copy(Stcsi,PLEN,1,srs) IF(Lx11)THEN IF(Psuadd)THEN DO i=Pos1ob,Posfob IF(Kfulsm.eq.2)THEN srs(i)=Stc(i)*Sti(i) ELSE srs(i)=Stc(i)*(Sts(i)+(Sti(i)-ONE)) END IF END DO ELSE CALL addmul(srs,srs,Stex,Pos1bk,Posffc) END IF END IF c----------------------------------------------------------------------- c take log of series if necessary (12-2-2014) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF END IF END IF c----------------------------------------------------------------------- CALL qsDiff(srs,Pos1ob,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSori2) IF((ipos+1).gt.Pos1ob) & CALL qsDiff(srs,ipos+1,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSoriS2) END IF c----------------------------------------------------------------------- c Generate QS stat for the seasonally adjusted series c----------------------------------------------------------------------- QSsadj=DNOTST QSsadjS=DNOTST IF((Lx11.and.Kfulsm.eq.0).or.Lseats)THEN gosa=T IF(Lseats)gosa=Hvstsa END IF IF(gosa)THEN IF(Lseats)THEN CALL copy(Seatsa,PLEN,1,srs) ELSE CALL copy(Stci,PLEN,1,srs) END IF c----------------------------------------------------------------------- c take log of series if necessary (12-2-2014) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF END IF END IF c----------------------------------------------------------------------- CALL qsDiff(srs,Pos1ob,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSSadj) IF((ipos+1).gt.Pos1ob) & CALL qsDiff(srs,ipos+1,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSSadjS) END IF c----------------------------------------------------------------------- c Generate QS stat for the seasonally adjusted series adjusted for c extreme values and outliers c----------------------------------------------------------------------- QSsadj2=DNOTST QSsadjS2=DNOTST IF(gosa)THEN IF(Iagr.eq.4)THEN IF(X11agr)THEN CALL copy(Stcime,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,Pos1ob,Posfob) ELSE CALL copy(Stci,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,Pos1ob,Posfob) END IF ELSE IF(Lx11)THEN CALL copy(Stcime,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,Pos1ob,Posfob) ELSE CALL copy(Stocsa,PLEN,1,srs) END IF c----------------------------------------------------------------------- c take log of series if necessary (12-2-2014) c----------------------------------------------------------------------- IF(Llogqs)THEN IF(Lx11)THEN IF(Muladd.ne.1)THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF ELSE IF(dpeq(Lam,ZERO))THEN DO i=Pos1ob,Posfob srs(i)=log(srs(i)) END DO IF(.not.lplog)lplog=T END IF END IF END IF c----------------------------------------------------------------------- CALL qsDiff(srs,Pos1ob,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSSadj2) IF((ipos+1).gt.Pos1ob) & CALL qsDiff(srs,ipos+1,Posfob,Lmodel,Nnsedf,Nseadf,Ny,QSSadjS2) END IF c----------------------------------------------------------------------- c Generate QS stat for the irregular component c----------------------------------------------------------------------- QSirr=DNOTST QSirrS=DNOTST IF((Lx11.and.Kfulsm.eq.0).or.Lseats)THEN goirr=T IF(Lseats)goirr=Hvstir IF(Iagr.eq.4)goirr=goirr.and.X11agr END IF IF(goirr)THEN DO i=Pos1ob,Posfob IF(Lx11)THEN srs(i)=Sti(i) ELSE srs(i)=Seatir(i) END IF IF(Muladd.ne.1)srs(i)=srs(i)-ONE END DO QSirr = calcqs(srs,Pos1ob-1,Posfob,Ny) IF((ipos+1).gt.Pos1ob)QSirrS = calcqs(srs,ipos,Posfob,Ny) END IF c----------------------------------------------------------------------- c Generate QS stat for the irregular component adjusted for c extreme values and outliers c----------------------------------------------------------------------- QSirr2=DNOTST QSirrS2=DNOTST IF(goirr)THEN DO i=Pos1ob,Posfob IF(Lx11)THEN srs(i)=Stime(i) ELSE srs(i)=Stocir(i)/ONEHND END IF IF(Muladd.ne.1)srs(i)=srs(i)-ONE END DO QSirr2 = calcqs(srs,Pos1ob-1,Posfob,Ny) IF((ipos+1).gt.Pos1ob)QSirrS2 = calcqs(srs,ipos,Posfob,Ny) END IF c----------------------------------------------------------------------- c Print out q stats c----------------------------------------------------------------------- lqs=.not.(dpeq(QSori,DNOTST).and.dpeq(QSrsd,DNOTST).and. & dpeq(QSsadj,DNOTST).and.dpeq(QSirr,DNOTST).and. & dpeq(QSsadj2,DNOTST).and.dpeq(QSirr2,DNOTST).and. & dpeq(QSori2,DNOTST)) lqss=.not.(dpeq(QSoriS,DNOTST).and. & dpeq(QSrsd2,DNOTST).and.dpeq(QSsadjS,DNOTST).and. & dpeq(QSirrS,DNOTST).and.dpeq(QSsadjS2,DNOTST).and. & dpeq(QSirrS2,DNOTST).and.dpeq(QSoriS2,DNOTST)) IF(Prttab(Tblind).and.(lqs.or.lqss))THEN IF(lqs)THEN IF(Lorig)THEN WRITE(Mt1,1010)' QS statistic for seasonality:' ELSE WRITE(Mt1,1010)' QS statistic for seasonality (Indirect '// & 'Adjustment):' END IF END IF IF(lplog)THEN IF(.not.dpeq(QSori,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' log(Original Series) ',QSori, & chisq(QSori,2) IF(.not.dpeq(QSori2,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' log(Original Series (EV adj)) ',QSori2, & chisq(QSori2,2) ELSE IF(.not.dpeq(QSori,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' Original Series ',QSori, & chisq(QSori,2) IF(.not.dpeq(QSori2,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' Original Series (EV adj) ',QSori2, & chisq(QSori2,2) END IF IF(.not.dpeq(QSrsd,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' Residuals ',QSrsd, & chisq(QSrsd,2) IF(lplog)THEN IF(.not.dpeq(QSsadj,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' log(Indirect SA Series) ',QSsadj, & chisq(QSsadj,2) ELSE WRITE(Mt1,1020)' log(Seasonally Adjusted Series) ',QSsadj, & chisq(QSsadj,2) END IF END IF IF(.not.dpeq(QSsadj2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' log(Indirect SA Series (EV adj)) ', & QSsadj2,chisq(QSsadj2,2) ELSE WRITE(Mt1,1020)' log(SA Series (EV adj)) ', & QSsadj2,chisq(QSsadj2,2) END IF END IF ELSE IF(.not.dpeq(QSsadj,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect SA Series ',QSsadj, & chisq(QSsadj,2) ELSE WRITE(Mt1,1020)' Seasonally Adjusted Series ',QSsadj, & chisq(QSsadj,2) END IF END IF IF(.not.dpeq(QSsadj2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect SA Series (EV adj) ', & QSsadj2,chisq(QSsadj2,2) ELSE WRITE(Mt1,1020)' Seasonally Adjusted Series (EV adj)', & QSsadj2,chisq(QSsadj2,2) END IF END IF END IF IF(.not.dpeq(QSirr,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect Irregular Series ',QSirr, & chisq(QSirr,2) ELSE WRITE(Mt1,1020)' Irregular Series ',QSirr, & chisq(QSirr,2) END IF END IF IF(.not.dpeq(QSirr2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect Irregular Series (EV adj) ',QSirr2, & chisq(QSirr2,2) ELSE WRITE(Mt1,1020)' Irregular Series (EV adj) ',QSirr2, & chisq(QSirr2,2) END IF END IF IF(lqss)THEN CALL wrtdat(Bgspec,Sp,begstr,nchr1) IF(Lorig)THEN WRITE(Mt1,1010)' QS statistic for seasonality (starting '// & begstr(1:nchr1)//'):' ELSE WRITE(Mt1,1010)' QS statistic for seasonality (Indirect '// & 'Adjustment starting '//begstr(1:nchr1)//'):' END IF END IF IF(lplog)THEN IF(.not.dpeq(QSoriS,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' log(Original Series) ',QSoriS, & chisq(QSoriS,2) IF(.not.dpeq(QSoriS2,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' log(Original Series (EV adj)) ', & QSoriS2,chisq(QSoriS2,2) ELSE IF(.not.dpeq(QSoriS,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' Original Series ',QSoriS, & chisq(QSoriS,2) IF(.not.dpeq(QSoriS2,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' Original Series (EV adj) ', & QSoriS2,chisq(QSoriS2,2) END IF IF(.not.dpeq(QSrsd2,DNOTST).and.Iagr.lt.4) & WRITE(Mt1,1020)' Residuals ',QSrsd2, & chisq(QSrsd2,2) IF(lplog)THEN IF(.not.dpeq(QSsadjS,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' log(Indirect SA Series) ', & QSsadjS,chisq(QSsadjS,2) ELSE WRITE(Mt1,1020)' log(Seasonally Adjusted Series) ', & QSsadjS,chisq(QSsadjS,2) END IF END IF IF(.not.dpeq(QSsadjS2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' log(Indirect SA Series (EV adj)) ', & QSsadjS2,chisq(QSsadjS2,2) ELSE WRITE(Mt1,1020)' log(SA Series (EV adj)) ', & QSsadjS2,chisq(QSsadjS2,2) END IF END IF ELSE IF(.not.dpeq(QSsadjS,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect SA Series ', & QSsadjS,chisq(QSsadjS,2) ELSE WRITE(Mt1,1020)' Seasonally Adjusted Series ', & QSsadjS,chisq(QSsadjS,2) END IF END IF IF(.not.dpeq(QSsadjS2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect SA Series (EV adj) ', & QSsadjS2,chisq(QSsadjS2,2) ELSE WRITE(Mt1,1020)' Seasonally Adjusted Series (EV adj)', & QSsadjS2,chisq(QSsadjS2,2) END IF END IF END IF IF(.not.dpeq(QSirrS,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect Irregular Series ',QSirrS, & chisq(QSirrS,2) ELSE WRITE(Mt1,1020)' Irregular Series ',QSirrS, & chisq(QSirrS,2) END IF END IF IF(.not.dpeq(QSirrS2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Mt1,1020)' Indirect Irregular Series (EV adj) ',QSirrS2, & chisq(QSirrS2,2) ELSE WRITE(Mt1,1020)' Irregular Series (EV adj) ',QSirrS2, & chisq(QSirrS2,2) END IF END IF END IF c----------------------------------------------------------------------- c save qs stats to .udg file c----------------------------------------------------------------------- IF(Savtab(Tblind).and.lqs)THEN IF(Iagr.lt.4)THEN IF(lplog)THEN WRITE(Nform,1040)'qslog','yes' ELSE WRITE(Nform,1040)'qslog','no' END IF END IF IF(.not.dpeq(QSori,DNOTST).and.Iagr.lt.4) & WRITE(Nform,1030)'qsori',QSori,chisq(QSori,2) IF(.not.dpeq(QSori2,DNOTST).and.Iagr.lt.4) & WRITE(Nform,1030)'qsorievadj',QSori2,chisq(QSori2,2) IF(.not.dpeq(QSrsd,DNOTST).and.Iagr.lt.4) & WRITE(Nform,1030)'qsrsd',QSrsd,chisq(QSrsd,2) IF(.not.dpeq(QSsadj,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qsindsadj',QSsadj,chisq(QSsadj,2) ELSE WRITE(Nform,1030)'qssadj',QSsadj,chisq(QSsadj,2) END IF END IF IF(.not.dpeq(QSsadj2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qsindsadjevadj',QSsadj2,chisq(QSsadj2,2) ELSE WRITE(Nform,1030)'qssadjevadj',QSsadj2,chisq(QSsadj2,2) END IF END IF IF(.not.dpeq(QSirr,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qsindirr',QSirr,chisq(QSirr,2) ELSE WRITE(Nform,1030)'qsirr',QSirr,chisq(QSirr,2) END IF END IF IF(.not.dpeq(QSirr2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qsindirrevadj',QSirr2,chisq(QSirr2,2) ELSE WRITE(Nform,1030)'qsirrevadj',QSirr2,chisq(QSirr2,2) END IF END IF END IF IF(Savtab(Tblind).and.lqss)THEN IF(.not.dpeq(QSoriS,DNOTST).and.Iagr.lt.4) & WRITE(Nform,1030)'qssori',QSoriS,chisq(QSoriS,2) IF(.not.dpeq(QSoriS2,DNOTST).and.Iagr.lt.4) & WRITE(Nform,1030)'qssorievadj',QSoriS2,chisq(QSoriS2,2) IF(.not.dpeq(QSrsd2,DNOTST).and.Iagr.lt.4) & WRITE(Nform,1030)'qssrsd',QSrsd2,chisq(QSrsd2,2) IF(.not.dpeq(QSsadjS,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qssindsadj',QSsadjS,chisq(QSsadjS,2) ELSE WRITE(Nform,1030)'qsssadj',QSsadjS,chisq(QSsadjS,2) END IF END IF IF(.not.dpeq(QSsadjS2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qssindsadjevadj',QSsadjS2,chisq(QSsadjS2,2) ELSE WRITE(Nform,1030)'qsssadjevadj',QSsadjS2,chisq(QSsadjS2,2) END IF END IF IF(.not.dpeq(QSirrS,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qssindirr',QSirrS,chisq(QSirrS,2) ELSE WRITE(Nform,1030)'qssirr',QSirrS,chisq(QSirrS,2) END IF END IF IF(.not.dpeq(QSirrS2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Nform,1030)'qssindirrevadj',QSirrS2,chisq(QSirrS2,2) ELSE WRITE(Nform,1030)'qssirrevadj',QSirrS2,chisq(QSirrS2,2) END IF END IF END IF c----------------------------------------------------------------------- c save qs stats to log file c----------------------------------------------------------------------- IF(Lsvlg.and.lqs)THEN IF(Lorig)THEN WRITE(Ng,1010)' QS statistic for seasonality:' ELSE WRITE(Ng,1010) & ' QS statistic for seasonality (Indirect Adjustment):' END IF IF(lplog)THEN IF(.not.dpeq(QSori,DNOTST).and.Lorig) & WRITE(Ng,1020)' log(Original Series) ',QSori, & chisq(QSori,2) IF(.not.dpeq(QSori2,DNOTST).and.Lorig) & WRITE(Ng,1020)' log(Original Series (EV adj)) ',QSori2, & chisq(QSori2,2) ELSE IF(.not.dpeq(QSori,DNOTST).and.Lorig) & WRITE(Ng,1020)' Original Series ',QSori, & chisq(QSori,2) IF(.not.dpeq(QSori2,DNOTST).and.Lorig) & WRITE(Ng,1020)' Original Series (EV adj) ',QSori2, & chisq(QSori2,2) END IF IF(.not.dpeq(QSrsd,DNOTST).and.Lorig) & WRITE(Ng,1020)' Residuals ',QSrsd, & chisq(QSrsd,2) IF(lplog)THEN IF(.not.dpeq(QSsadj,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' log(Indirect SA Series) ',QSsadj, & chisq(QSsadj,2) ELSE WRITE(Ng,1020)' log(Seasonally Adjusted Series) ',QSsadj, & chisq(QSsadj,2) END IF END IF IF(.not.dpeq(QSsadj2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' log(Indirect SA Series (EV adj)) ',QSsadj2, & chisq(QSsadj2,2) ELSE WRITE(Ng,1020)' log(SA Series (EV adj)) ',QSsadj2, & chisq(QSsadj2,2) END IF END IF ELSE IF(.not.dpeq(QSsadj,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect SA Series ',QSsadj, & chisq(QSsadj,2) ELSE WRITE(Ng,1020)' Seasonally Adjusted Series ',QSsadj, & chisq(QSsadj,2) END IF END IF IF(.not.dpeq(QSsadj2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect SA Series (EV adj) ',QSsadj2, & chisq(QSsadj2,2) ELSE WRITE(Ng,1020)' Seasonally Adjusted Series (EV adj)',QSsadj2, & chisq(QSsadj2,2) END IF END IF END IF IF(.not.dpeq(QSirr,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect Irregular Series ',QSirr, & chisq(QSirr,2) ELSE WRITE(Ng,1020)' Irregular Series ',QSirr, & chisq(QSirr,2) END IF END IF IF(.not.dpeq(QSirr2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect Irregular Series (EV adj) ',QSirr2, & chisq(QSirr2,2) ELSE WRITE(Ng,1020)' Irregular Series (EV adj) ',QSirr2, & chisq(QSirr2,2) END IF END IF END IF IF(Lsvlg.and.lqss)THEN IF(Lorig)THEN WRITE(Ng,1010)' QS statistic for seasonality (starting '// & begstr(1:nchr1)//'):' ELSE WRITE(Ng,1010)' QS statistic for seasonality (Indirect '// & 'Adjustment starting '//begstr(1:nchr1)//'):' END IF IF(.not.dpeq(QSoriS,DNOTST).and.Lorig) & WRITE(Ng,1020)' Original Series ',QSoriS, & chisq(QSoriS,2) IF(.not.dpeq(QSoriS2,DNOTST).and.Lorig) & WRITE(Ng,1020)' Original Series (EV adj) ', & QSoriS2,chisq(QSoriS2,2) IF(.not.dpeq(QSrsd2,DNOTST).and.Lorig) & WRITE(Ng,1020)' Residuals ',QSrsd2, & chisq(QSrsd2,2) IF(.not.dpeq(QSsadjS,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect SA Series ',QSsadjS, & chisq(QSsadjS,2) ELSE WRITE(Ng,1020)' Seasonally Adjusted Series ',QSsadjS, & chisq(QSsadjS,2) END IF END IF IF(.not.dpeq(QSsadjS2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect SA Series (EV adj) ', & QSsadjS2,chisq(QSsadjS2,2) ELSE WRITE(Ng,1020)' Seasonally Adjusted Series (EV adj)', & QSsadjS2,chisq(QSsadjS2,2) END IF END IF IF(.not.dpeq(QSirrS,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect Irregular Series ',QSirrS, & chisq(QSirrS,2) ELSE WRITE(Ng,1020)' Irregular Series ',QSirrS, & chisq(QSirrS,2) END IF END IF IF(.not.dpeq(QSirrS2,DNOTST))THEN IF(Iagr.eq.4)THEN WRITE(Ng,1020)' Indirect Irregular Series (EV adj) ',QSirrS2, & chisq(QSirrS2,2) ELSE WRITE(Ng,1020)' Irregular Series (EV adj) ',QSirrS2, & chisq(QSirrS2,2) END IF END IF END IF IF(Lsvlg.and.(lqs.or.lqss))write(Ng,1010)' ' c----------------------------------------------------------------------- 1010 FORMAT(/,a) 1020 FORMAT(a,5x,f16.2,' (P-Value = ',f10.4,')') 1030 FORMAT(a,':',f16.5,1x,f10.5) 1040 FORMAT(a,': ',a) c----------------------------------------------------------------------- RETURN END genrtt.f0000664006604000003110000000537114521201501011640 0ustar sun00315steps SUBROUTINE genrtt(Tval) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c ------------------------------------------------------------------ DOUBLE PRECISION Tval,rmse,seb,xpxinv,tmp INTEGER nb2,j,nelt,nfix,igrp,begcol,endcol,icol,regidx DIMENSION Tval(PB),xpxinv(PB*(PB+1)/2),tmp(2) c ------------------------------------------------------------------ DOUBLE PRECISION dpmpar LOGICAL dpeq EXTERNAL dpeq,dpmpar c ------------------------------------------------------------------ c Generate number of unfixed regressors c ------------------------------------------------------------------ nb2=Nb IF(Iregfx.ge.2)THEN DO j=1,Nb IF(Regfx(j))nb2=nb2-1 END DO END IF c----------------------------------------------------------------------- c Get the root mean square error and X'X inverse. c----------------------------------------------------------------------- IF(nb2.gt.0)THEN nelt=(nb2+1)*(nb2+2)/2 IF(Var.gt.2D0*dpmpar(1))THEN rmse=sqrt(Var) CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,nb2,tmp,1) c---------------------------------------------------------------------- ELSE rmse=ZERO END IF ELSE rmse=ZERO END IF IF(dpeq(rmse,ZERO))RETURN c ------------------------------------------------------------------ c generate t-statistics for regressors c ------------------------------------------------------------------ nfix=0 c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 c----------------------------------------------------------------------- c For each regression variable in the group calculate the standard c error and t-value if the variance in nonzero c----------------------------------------------------------------------- DO icol=begcol,endcol IF(Regfx(icol))THEN seb=ZERO nfix=nfix+1 c regidx(icol)=NOTSET ELSE c regidx(icol)=icol-nfix regidx=icol-nfix seb=sqrt(xpxinv(regidx*(regidx+1)/2))*rmse END IF c----------------------------------------------------------------------- IF(seb.gt.ZERO)THEN Tval(icol)=B(icol)/seb ELSE Tval(icol)=ZERO END IF END DO END DO RETURN END genskip.f0000664006604000003110000000250414521201502011771 0ustar sun00315steps SUBROUTINE genSkip(LinkCode) IMPLICIT NONE c ------------------------------------------------------------------ c Generate entries for index, skip links c ------------------------------------------------------------------ LOGICAL T,F PARAMETER (T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'htmlout.cmn' c ------------------------------------------------------------------ INTEGER n1,LinkCode c----------------------------------------------------------------------- c Return if this is a transparent seasonal adjustment for sliding c spans, revisions, or X-11 Holiday adjustment. c----------------------------------------------------------------------- IF(Lhiddn.and.(Issap.eq.2.or.Irev.eq.4.or.Khol.eq.1))RETURN c ------------------------------------------------------------------ CALL makeAnchor(Mt1,Idxtab,'pos') CALL makeSkipLink(Mt1,Idxtab,'Table',F) CALL makeAnchor(Mt1,Idxtab,'skip') Vindx(Idxtab)=LinkCode Idxtab=Idxtab+1 c ------------------------------------------------------------------ RETURN END genssm.f0000664006604000003110000000355114521201502011630 0ustar sun00315stepsC Last change: BCM 19 May 2003 9:29 am SUBROUTINE genssm(Seatsf,Pos1ob,Posfob,Sfsum,Sf1ob,Ny,Lam) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' INCLUDE 'notset.prm' INCLUDE 'seatdg.cmn' c ------------------------------------------------------------------ INTEGER N1,N12 DOUBLE PRECISION ZERO PARAMETER (N12 = 12, N1 = 1, ZERO = 0D0) INCLUDE 'calc.i' c ------------------------------------------------------------------ DOUBLE PRECISION Seatsf,Sfsum,Lam INTEGER Pos1ob,Posfob,Sf1ob,thisbd,i,j,k,jk,Ny DIMENSION Seatsf(PLEN),Sfsum(PLEN) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ IF(Idssm.ne.NOTSET)THEN thisBd=Idssm ELSE thisbd=Bd ENDIF c ------------------------------------------------------------------ DO i=Pos1ob,Posfob IF(dpeq(Lam,ZERO))THEN Sfsum(i)=log10(Seatsf(i)) ELSE Sfsum(i)=Seatsf(i) END IF END DO c ------------------------------------------------------------------ Sf1ob=Pos1ob IF (thisbd.eq.0)RETURN IF (thisbd.eq.1)THEN Sf1ob=Pos1ob+Ny-1 DO i=Posfob,Sf1ob,-1 DO j=1,Ny-1 Sfsum(i)=Sfsum(i)+Sfsum(i-j) END DO END DO ELSE Sf1ob=Pos1ob+2*(Ny-1) DO i=Posfob,Sf1ob,-1 DO j=0,Ny-1 DO k=0,Ny-1 jk = j + k if(jk.gt.0)Sfsum(i)=Sfsum(i)+Sfsum(i-jk) END DO END DO END DO END IF c ------------------------------------------------------------------ RETURN ENDgetadj.f0000664006604000003110000006310014521201502011566 0ustar sun00315stepsC Last change: BCM 29 Jan 1999 11:36 am SUBROUTINE getadj(Begsrs,Havsrs,Havesp,Sp,Begspn,Nspobs,Endspn, & Usrtad,Nustad,Bgutad,Tmpnam,Ntser,Usrpad,Nuspad, & Bgupad,Prmnam,Npser,Adjttl,Nadjtl,Priadj,Reglom, & Fcntyp,Lam,Prtype,Nprtyp,Percnt,Traicd,Lprntr, & Hvx12f,Cnstnt,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c getadj.f, Release 1, Subroutine Version 1.6, Modified 16 Feb 1995. c----------------------------------------------------------------------- c Gets the Box-Cox transformation parameter, a series of adjustments c adjustments, and flags the length-of-month adjustment (prilom) as c opposed to the regression lom. c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'svllog.i' INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER DBLMSG*(34) INTEGER PNADJ,YR,MO LOGICAL T,F DOUBLE PRECISION ZERO PARAMETER(DBLMSG='Use either data or file, not both',YR=1,MO=2, & PNADJ=2,T=.true.,F=.false.,ZERO=0D0) C----------------------------------------------------------------------- CHARACTER adjfmt*(PFILCR),Adjttl*(*),adfile*(PFILCR),srsnam*(64), & fmtstr*(PNADJ*PFILCR),filstr*(PNADJ*PFILCR),tmpnam*(64), & Prmnam*(64),namstr*(PNADJ*64) LOGICAL argok,Hvx12f,havadj,Havesp,Havsrs,hvstrt,hvfile,Inptok, & havenm,hvafmt,havtad,havpad,havttl,Lprntr INTEGER Begspn,Begsrs,Bgutad,Bgupad,bgusra,Endspn,Fcntyp,Nadjtl, & nadfmt,Nspobs,Nuspad,Nustad,Priadj,Reglom,Sp,tmpptr, & Percnt,numdec,ivec,Prtype,Nprtyp,namptr,fmtptr, & filptr,numnam,nfmt,numfil,nadtmp,tmpdat,ndate,numper,nd, & nelt,nflchr,decvec,i,nsrs,Ntser,Npser,numpri,ltrim DOUBLE PRECISION Usrtad,Usrpad,adjtmp,Lam,dvec,Traicd,Cnstnt DIMENSION Begspn(2),Begsrs(2),Bgutad(2),Bgupad(2),bgusra(2), & Usrtad(PLEN),Usrpad(PLEN),adjtmp(PNADJ*PLEN),Endspn(2), & Prtype(PNADJ),Hvx12f(PNADJ),namptr(0:PNADJ),dvec(1), & ivec(1),fmtptr(0:PNADJ),filptr(0:PNADJ),tmpdat(2,PNADJ), & tmpptr(0:1),Percnt(PNADJ),decvec(PNADJ) c ------------------------------------------------------------------ INTEGER strinx LOGICAL chkcvr,gtarg,dpeq EXTERNAL chkcvr,gtarg,strinx,dpeq c ------------------------------------------------------------------ CHARACTER ARGDIC*126 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=20) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='datastarttitlefileformatadjustadjustregpowerfunc &tionprintsavemodenametypeprecisionsavelogaicdifftrimzerotemppriort &rendconstant') c ------------------------------------------------------------------ CHARACTER ADJDIC*16 INTEGER adjptr,PADJ PARAMETER(PADJ=4) DIMENSION adjptr(0:PADJ) PARAMETER(ADJDIC='nonelomloqlpyear') c ------------------------------------------------------------------ CHARACTER RGADIC*9 INTEGER rgaptr,PRGA PARAMETER(PRGA=3) DIMENSION rgaptr(0:PRGA) PARAMETER(RGADIC='nonetdall') c----------------------------------------------------------------------- CHARACTER MODDIC*18 INTEGER modptr,PMOD PARAMETER(PMOD=3) DIMENSION modptr(0:PMOD) PARAMETER(MODDIC='percentratiodiff') c ------------------------------------------------------------------ CHARACTER FCNDIC*30 INTEGER fcnptr,PFCN PARAMETER(PFCN=6) DIMENSION fcnptr(0:PFCN) PARAMETER(FCNDIC='logsqrtlogisticnoneinverseauto') c ------------------------------------------------------------------ CHARACTER TYPDIC*26 INTEGER typptr,PATYPE PARAMETER(PATYPE=4) DIMENSION typptr(0:PATYPE) PARAMETER(TYPDIC='temporarypermanenttempperm') c----------------------------------------------------------------------- CHARACTER XFSDIC*14 INTEGER xfsptr,PXFS PARAMETER(PXFS=2) DIMENSION xfsptr(0:PXFS) PARAMETER(XFSDIC='x12savex13save') c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- CHARACTER ZRODIC*9 INTEGER zroptr,PZRO PARAMETER(PZRO=3) DIMENSION zroptr(0:PZRO) PARAMETER(ZRODIC='yesspanno') c----------------------------------------------------------------------- DATA fcnptr/1,4,8,16,20,27,31/ DATA argptr/1,5,10,15,19,25,31,40,45,53,58,62,66,70,74,83,90,97, & 105,119,127/ DATA adjptr/1,5,8,11,17/ DATA rgaptr/1,5,7,10/ DATA modptr/1,8,13,17/ DATA typptr/1,10,19,23,27/ DATA xfsptr/1,8,15/ DATA ysnptr/1,4,6/ DATA zroptr/1,4,8,10/ c----------------------------------------------------------------------- c Assume the input is OK and we don't have any of the arguments c----------------------------------------------------------------------- havadj=F hvafmt=F havpad=F havtad=F hvfile=F CALL setlg(F,PNADJ,Hvx12f) hvstrt=F havttl=F havenm=F ltrim=0 nadfmt=1 numnam=0 numper=0 nfmt=0 numfil=0 CALL setint(3,PNADJ,decvec) CALL setint(NOTSET,2*PARG,arglog) c----------------------------------------------------------------------- c Initialize the starting date c----------------------------------------------------------------------- CALL cpyint(Begsrs,2,1,bgusra) CALL setint(NOTSET,2*PNADJ,tmpdat) c----------------------------------------------------------------------- c Initialize the format and file c----------------------------------------------------------------------- CALL setchr(' ',PFILCR,adfile) CALL setchr(' ',PFILCR,adjfmt) c----------------------------------------------------------------------- IF(.not.Havsrs)THEN CALL inpter(PERROR,Errpos, & 'Specify series before user-defined adjustments') Inptok=F END IF c----------------------------------------------------------------------- DO WHILE (T) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- 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,140,150,170, & 160,175,176,177)argidx c----------------------------------------------------------------------- c Data argument c----------------------------------------------------------------------- 10 IF(hvfile)THEN CALL inpter(PERROR,Errpos,DBLMSG) Inptok=F END IF c ------------------------------------------------------------------ CALL gtdpvc(LPAREN,T,PLEN*PNADJ,adjtmp,nadtmp,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(nadtmp.gt.0)THEN IF(argok)THEN havadj=T ELSE nadtmp=0 END IF c ------------------------------------------------------------------ END IF GO TO 180 c----------------------------------------------------------------------- c Start argument c----------------------------------------------------------------------- 20 CALL gtdtvc(Havesp,Sp,LPAREN,F,PNADJ,tmpdat,ndate,argok,Inptok) IF(Lfatal)RETURN hvstrt=argok.and.ndate.gt.0 GO TO 180 c----------------------------------------------------------------------- c Title argument c----------------------------------------------------------------------- 30 CALL getttl(LPAREN,T,1,Adjttl,tmpptr,nelt,argok,Inptok) IF(.not.Lfatal.and.argok.and.nelt.gt.0)THEN CALL eltlen(1,tmpptr,nelt,Nadjtl) havttl=T END IF IF(Lfatal)RETURN GO TO 180 c----------------------------------------------------------------------- c File argument c----------------------------------------------------------------------- 40 IF(havadj)THEN CALL inpter(PERROR,Errpos,DBLMSG) Inptok=F END IF c ------------------------------------------------------------------ CALL gtnmvc(LPAREN,T,PNADJ,filstr,filptr,numfil,PFILCR,argok, & Inptok) IF(Lfatal)RETURN IF(argok.and.numfil.gt.0)hvfile=T GO TO 180 c----------------------------------------------------------------------- c Format argument c----------------------------------------------------------------------- 50 CALL gtnmvc(LPAREN,T,PNADJ,fmtstr,fmtptr,nfmt,PFILCR,argok, & Inptok) IF(Lfatal)RETURN IF(argok.and.nfmt.gt.0)hvafmt=T GO TO 180 c----------------------------------------------------------------------- c Predefined prior adjustment argument (1=none, 2=lom, 3=loq, c and 4=lpyear) c----------------------------------------------------------------------- 60 CALL gtdcvc(LPAREN,T,1,ADJDIC,adjptr,PADJ, & 'The predefined adjustments are lom, loq, or lpyear.' & ,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(nelt.gt.0)THEN Priadj=ivec(1) IF(argok.and.Priadj.gt.1.and..not.Havesp)THEN CALL inpter(PERROR,Errpos, & 'No seasonal period specified in series spec.') Inptok=F c ------------------------------------------------------------------ ELSE IF(Sp.ne.12.and.Sp.ne.4)THEN CALL inpter(PERROR,Errpos, & ' Need monthly or quarterly data for adjustment') Inptok=F c ------------------------------------------------------------------ ELSE IF(Begsrs(1).lt.1776)THEN CALL inpter(PERROR,Errpos, &'No adjustment before 1776. Try including the century in the star &t date') Inptok=F END IF c----------------------------------------------------------------------- c Correct length of month and length of quarter errors c----------------------------------------------------------------------- IF(Priadj.eq.2.and.Sp.eq.4)Priadj=3 IF(Priadj.eq.3.and.Sp.eq.12)Priadj=2 END IF GO TO 180 c----------------------------------------------------------------------- c Regression variable prior adjustment argument (1=none, 2=td, and c 3=all). Regadjust determines which variables are going to be adjusted c and ajust determines the type of adjustment. c----------------------------------------------------------------------- 70 CALL gtdcvc(LPAREN,T,1,RGADIC,rgaptr,PRGA, & 'The predefined adjustments are none, td, or all', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(nelt.gt.0)THEN IF(argok.and.ivec(1).gt.0.and..not.Havesp)THEN CALL inpter(PERROR,Errpos, & 'No seasonal period specified in series spec.') Inptok=F ELSE IF(Sp.ne.12.and.Sp.ne.4)THEN CALL inpter(PERROR,Errpos, & 'Need monthly or quarterly data for adjustment') Inptok=F ELSE Reglom=ivec(1) END IF END IF GO TO 180 c----------------------------------------------------------------------- c Box-Cox power transformation parameter c----------------------------------------------------------------------- 80 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN Lam=dvec(1) c ------------------------------------------------------------------ IF(nelt.gt.0)THEN IF(argok)THEN Fcntyp=5 ELSE CALL inpter(PERROR,Errpos, & 'Enter a real number for the Box-Cox Transformation.') CALL lex() Inptok=F END IF END IF GO TO 180 c----------------------------------------------------------------------- c Box-Cox and other function specified by name c----------------------------------------------------------------------- 90 CALL gtdcvc(LPAREN,T,1,FCNDIC,fcnptr,PFCN, & 'Choices are log, sqrt, inverse, logistic, auto, or none', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(nelt.gt.0)THEN IF(argok.and.ivec(1).eq.1)THEN Fcntyp=1 Lam=0D0 ELSE IF(ivec(1).eq.2)THEN Fcntyp=6 Lam=.5D0 ELSE IF(ivec(1).eq.4)THEN Fcntyp=4 Lam=1D0 ELSE IF(ivec(1).eq.5)THEN Fcntyp=6 Lam=-1D0 ELSE IF(ivec(1).eq.3)THEN Fcntyp=3 Lam=DNOTST ELSE IF(ivec(1).eq.6)THEN Fcntyp=0 Lam=DNOTST END IF END IF GO TO 180 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 100 CALL getprt(LSPTRN,NSPTRN,Inptok) GO TO 180 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 110 CALL getsav(LSPTRN,NSPTRN,Inptok) GO TO 180 c----------------------------------------------------------------------- c Prior factor mode c----------------------------------------------------------------------- 120 CALL gtdcvc(LPAREN,T,PNADJ,MODDIC,modptr,PMOD, & 'Choices are percent, ratio, and diff', & Percnt,numper,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.numper.gt.0)THEN DO i=1,numper Percnt(i)=Percnt(i)-1 END DO END IF GO TO 180 c----------------------------------------------------------------------- c Series name argument c----------------------------------------------------------------------- 130 CALL gtnmvc(LPAREN,T,PNADJ,namstr,namptr,numnam,64,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.numnam.gt.0)havenm=T GO TO 180 c----------------------------------------------------------------------- c Type parameter c----------------------------------------------------------------------- 140 CALL gtdcvc(LPAREN,T,PNADJ,TYPDIC,typptr,PATYPE, & 'Choices are temporary, temp, permanent and perm.', & Prtype,Nprtyp,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok.and.Nprtyp.gt.0)THEN DO i=1,Nprtyp IF(Prtype(i).gt.2)Prtype(i)=Prtype(i)-2 END DO END IF GO TO 180 c----------------------------------------------------------------------- c Precision argument c----------------------------------------------------------------------- 150 CALL getivc(LPAREN,T,PNADJ,decvec,numdec,argok,Inptok) IF(Lfatal)RETURN IF(numdec.gt.0)THEN IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Invalid number of input decimals') Inptok=F ELSE DO i=1,numdec IF(decvec(i).lt.0.or.decvec(i).gt.5)THEN CALL inpter(PERROR,Errpos,'Number of input decimals must be &between 0 and 5, inclusive') Inptok=F END IF END DO END IF END IF GO TO 180 c----------------------------------------------------------------------- c AIC test difference for the transformation AIC test c----------------------------------------------------------------------- 160 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0.and.argok)Traicd=dvec(1) GO TO 180 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 170 CALL getsvl(LSLADJ,NSLADJ,Inptok) GO TO 180 c----------------------------------------------------------------------- c trimzero argument c----------------------------------------------------------------------- 175 CALL gtdcvc(LPAREN,T,1,ZRODIC,zroptr,PZRO, & 'Available options for trimzero are yes, span or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)ltrim=ivec(1)-1 GO TO 180 c----------------------------------------------------------------------- c temppriortrend argument c----------------------------------------------------------------------- 176 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for temppriortrend are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lprntr=ivec(1).eq.1 GO TO 180 c ------------------------------------------------------------------ c Constant argument c ------------------------------------------------------------------ 177 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(dvec(1).lt.ZERO.or.dpeq(dvec(1),ZERO))THEN CALL inpter(PERROR,Errpos, & 'Constant argument cannot be less than or equal to zero.') Inptok=F ELSE Cnstnt=dvec(1) END IF GO TO 180 END IF c ------------------------------------------------------------------ IF(Lfatal)RETURN c----------------------------------------------------------------------- c set how many prior adjustments there are c----------------------------------------------------------------------- IF(Nprtyp.gt.0)THEN numpri=Nprtyp ELSE IF(hvfile.or.havadj)THEN IF(numfil.eq.2.or.numnam.eq.2)THEN CALL writln(' ERROR: If more than one prior adjustment factor i &s read in, a type must',STDERR,Mt2,T) CALL writln(' be specified for each.',STDERR,Mt2,T) Inptok=F ELSE numpri=1 Prtype(1)=2 Nprtyp=numpri END IF ELSE numpri=0 END IF c----------------------------------------------------------------------- IF(numpri.gt.0)THEN IF(tmpdat(YR,1).ne.NOTSET)THEN bgusra(YR)=tmpdat(YR,1) bgusra(MO)=tmpdat(MO,1) END IF CALL setchr(' ',64,srsnam) IF(numnam.gt.0)THEN IF(numpri.gt.numnam)THEN CALL writln(' ERROR: If a series name is specified, there shou &ld be a name for each ',STDERR,Mt2,T) CALL writln(' prior adjustment series specifed.', & STDERR,Mt2,T) Inptok=F ELSE CALL getstr(namstr,namptr,numnam,1,srsnam,nsrs) END IF ELSE nsrs=1 END IF END IF c----------------------------------------------------------------------- c If the data are from the file get the data c----------------------------------------------------------------------- IF(Inptok.and.hvfile.and..not.havadj)THEN c----------------------------------------------------------------------- c initialize variables needed for file input. c----------------------------------------------------------------------- CALL getstr(filstr,filptr,numfil,1,adfile,nflchr) IF(hvafmt)THEN CALL getstr(fmtstr,fmtptr,nfmt,1,adjfmt,nadfmt) IF(strinx(F,XFSDIC,xfsptr,1,PXFS,adjfmt(1:nadfmt)).gt.0) & Hvx12f(1)=T END IF nd=decvec(1) c----------------------------------------------------------------------- c IF only one file specified for two sets of preadjustment factors, c read both sets of data into a temporary data set to be processed c later. c----------------------------------------------------------------------- IF(numfil.eq.1.and.numpri.gt.1)THEN CALL gtfldt(PLEN*PNADJ,adfile,nflchr,hvafmt, & adjfmt(1:nadfmt),ltrim,adjtmp,nadtmp,Havesp,Sp, & havenm,srsnam,nsrs,havttl,Adjttl,Nadjtl,nd,hvstrt, & bgusra,numnam,Begspn,Endspn,F,argok,Inptok) IF(argok)havadj=T ELSE c----------------------------------------------------------------------- c ELSE, read the series from the separate files and assign the c data from each to either the temporary or permanent prior c adjustment factors. c----------------------------------------------------------------------- DO i=1,numpri c----------------------------------------------------------------------- c reset variables needed for file input, if necessary. c----------------------------------------------------------------------- IF(i.gt.1)THEN CALL getstr(filstr,filptr,numfil,i,adfile,nflchr) IF(numnam.gt.0)CALL getstr(namstr,namptr,numnam,i,srsnam, & nsrs) IF(hvafmt.and.nfmt.gt.1)THEN CALL getstr(fmtstr,fmtptr,nfmt,i,adjfmt,nadfmt) IF(strinx(F,XFSDIC,xfsptr,1,PXFS,adjfmt(1:nadfmt)).gt.0) & Hvx12f(i)=T END IF IF(numdec.gt.1)nd=decvec(1) IF(tmpdat(YR,i).ne.NOTSET)THEN bgusra(YR)=tmpdat(YR,i) bgusra(MO)=tmpdat(MO,i) END IF END IF c----------------------------------------------------------------------- c Get data from file c----------------------------------------------------------------------- CALL gtfldt(PLEN,adfile,nflchr,hvafmt,adjfmt(1:nadfmt), & ltrim,adjtmp,nadtmp,Havesp,Sp,havenm,srsnam,nsrs, & havttl,Adjttl,Nadjtl,nd,hvstrt,bgusra,1,Begspn, & Endspn,F,argok,Inptok) c----------------------------------------------------------------------- c Put results into variable for correct type of prior adjustment c----------------------------------------------------------------------- IF(Prtype(i).eq.1)THEN IF(numnam.eq.0)THEN srsnam(1:7)='TempAdj' nsrs=7 END IF CALL setadj(Usrtad,Nustad,Tmpnam,Ntser,Bgutad,havtad,Nprtyp, & adjtmp,nadtmp,bgusra,srsnam,nsrs,0,Argok) ELSE IF(numnam.eq.0)THEN srsnam(1:7)='PermAdj' nsrs=7 END IF CALL setadj(Usrpad,Nuspad,Prmnam,Npser,Bgupad,havpad,Nprtyp, & adjtmp,nadtmp,bgusra,srsnam,nsrs,0,Argok) END IF END DO END IF END IF c ------------------------------------------------------------------ c IF data stored temporarily as matrix, separate results into c variables for correct type of prior adjustment c ------------------------------------------------------------------ IF(Inptok.and.havadj)THEN DO i=1,Nprtyp IF(numnam.gt.0)CALL getstr(namstr,namptr,numnam,i,srsnam,nsrs) IF(Prtype(i).eq.1)THEN IF(numnam.eq.0)THEN srsnam(1:7)='TempAdj' nsrs=7 END IF CALL setadj(Usrtad,Nustad,Tmpnam,Ntser,Bgutad,havtad,Nprtyp, & adjtmp,nadtmp,bgusra,srsnam,nsrs,i,Argok) ELSE IF(Prtype(i).eq.2)THEN IF(numnam.eq.0)THEN srsnam(1:7)='PermAdj' nsrs=7 END IF CALL setadj(Usrpad,Nuspad,Prmnam,Npser,Bgupad,havpad,Nprtyp, & adjtmp,nadtmp,bgusra,srsnam,nsrs,i,Argok) END IF END DO END IF havadj=havtad.or.havpad c ------------------------------------------------------------------ IF(hvstrt.and..not.havadj)THEN CALL writln(' ERROR: Have a start date without user-defined adju &stments.',STDERR,Mt2,T) Inptok=F END IF c ------------------------------------------------------------------ IF(havtad.and..not.chkcvr(Bgutad,Nustad,Begspn,Nspobs,Sp))THEN CALL cvrerr('temporary adjustments',Bgutad,Nustad,'span',Begspn, & Nspobs,Sp) IF(Lfatal)RETURN Inptok=F END IF IF(havpad.and..not.chkcvr(Bgupad,Nuspad,Begspn,Nspobs,Sp))THEN CALL cvrerr('permanent adjustments',Bgupad,Nuspad,'span',Begspn, & Nspobs,Sp) IF(Lfatal)RETURN Inptok=F END IF c ------------------------------------------------------------------ IF(numper.lt.numpri)THEN DO i=2,Nprtyp Percnt(i)=Percnt(1) END DO END IF c ------------------------------------------------------------------ RETURN 180 CONTINUE END DO c ------------------------------------------------------------------ END getarg.cmn0000664006604000003110000000061514521201502012133 0ustar sun00315stepsC----------------------------------------------------------------------- c Arg : Character vector containing command line arguments c Ptr : Pointer vector for arguments c Narg : Number of arguments in Arg C----------------------------------------------------------------------- CHARACTER Arg*(CLEN) INTEGER Ptr(0:NUMARG),Narg COMMON / argcmn / Narg,Ptr,Arg getarg.f0000664006604000003110000000241514521201502011603 0ustar sun00315stepsC Last change: BCM 2 Dec 97 7:19 am SUBROUTINE getarg2(N,Chr) IMPLICIT NONE c----------------------------------------------------------------------- c Matches UNIX getarg subroutine p. 280 in 3F Sun OS Manuel. c Note, this does not return the command name when narg is 0. c----------------------------------------------------------------------- INCLUDE 'getarg.prm' INCLUDE 'getarg.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER N CHARACTER Chr*(CLEN) c----------------------------------------------------------------------- LOGICAL frstar SAVE frstar DATA frstar/.true./ c----------------------------------------------------------------------- C Call subroutine which sets up argument list (PC Version) C----------------------------------------------------------------------- IF(frstar)THEN CALL setarg() IF(Lfatal)RETURN frstar=.false. END IF c----------------------------------------------------------------------- Chr=' & &' if (Narg.ge.N) Chr = Arg(Ptr(n-1):(ptr(n)-1)) RETURN END getarg.prm0000664006604000003110000000046214521201502012154 0ustar sun00315stepsC----------------------------------------------------------------------- c CLEN: Maximum length of argument vector c NUMARG: Maximum number of arguments C----------------------------------------------------------------------- INTEGER CLEN,NUMARG PARAMETER(CLEN=256,NUMARG=20) getchk.f0000664006604000003110000001443014521201502011577 0ustar sun00315stepsC Last change: BCM 14 Oct 1998 4:01 pm SUBROUTINE getchk(Mxcklg,Acflim,Qcheck,Iqtype,Sp,Inptok) c ------------------------------------------------------------------ IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'tbllog.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.i' INCLUDE 'mdltbl.i' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL F,T DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1.0D0,ZERO=0.0D0,F=.false.,T=.true.) c ------------------------------------------------------------------ DOUBLE PRECISION Acflim,Qcheck,dvec LOGICAL argok,Inptok INTEGER Mxcklg,Iqtype,nelt,ivec,Sp DIMENSION dvec(1),ivec(1) c----------------------------------------------------------------------- LOGICAL gtarg EXTERNAL gtarg c----------------------------------------------------------------------- c Argument dictionary was made with the following command c ../../dictionary/strary < ../../dictionary/check.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*41 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=7) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='maxlagprintsavesavelogacflimitqtypeqlimit') c ------------------------------------------------------------------ c Q stat type dictionary c ------------------------------------------------------------------ CHARACTER QDIC*21 INTEGER qptr,QARG PARAMETER(QARG=4) DIMENSION qptr(0:QARG) PARAMETER(QDIC='ljungboxlbboxpiercebp') c----------------------------------------------------------------------- DATA argptr/1,7,12,16,23,31,36,42/ DATA qptr/1,9,11,20,22/ c----------------------------------------------------------------------- c If Mxcklg is 0 if check{} is not specified and the acf's and c pacf's are not printed out so Mxcklg is set to the default 36 c (for monthly; 12 for quarterly series) c when check is specified. Whether or not the histogram and c summary statistics are printed out is controled by the prttab c switch. It is off in the default table set in gtinpt and is c turned on by default here. c----------------------------------------------------------------------- argok=T IF(.not.Lnoprt)THEN Prttab(LCKHST)=T Prttab(LCKNRM)=T END IF IF(Sp.eq.1)THEN Mxcklg=10 ELSE Mxcklg=2*Sp END IF CALL setint(NOTSET,2*PARG,arglog) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- DO WHILE (T) IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,argok))THEN IF(Lfatal)RETURN GO TO(10,20,30,40,50,60,70),argidx c----------------------------------------------------------------------- c Number of acf and pacf lags to calculate and print out c----------------------------------------------------------------------- 10 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(ivec(1).le.0)THEN CALL inpter(PERROR,Errpos, & 'Value of maxlag must be greater than 0.') Inptok=F ELSE Mxcklg=ivec(1) END IF END IF GO TO 80 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 20 CALL getprt(LSPCHK,NSPCHK,Inptok) GO TO 80 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 30 CALL getsav(LSPCHK,NSPCHK,Inptok) GO TO 80 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 40 CALL getsvl(LSLCHK,NSLCHK,Inptok) GO TO 80 c----------------------------------------------------------------------- c acflimit argument c----------------------------------------------------------------------- 50 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Value of acflimit must be greater than 0.') Inptok=F ELSE Acflim=dvec(1) END IF END IF GO TO 80 c----------------------------------------------------------------------- c qtype argument c----------------------------------------------------------------------- 60 CALL gtdcvc(LPAREN,T,1,QDIC,qptr,QARG, & 'Improper entry for qtype: valid choices are ', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.le.0)THEN CALL writln(' ljungbox, lb, boxpierce or bp.',STDERR,Mt2, & F) ELSE IF(ivec(1).gt.2)THEN Iqtype=1 ELSE Iqtype=0 END IF END IF GO TO 80 c----------------------------------------------------------------------- c qlimit argument c----------------------------------------------------------------------- 70 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Value of qlimit must be greater than 0.') Inptok=F ELSE IF(dvec(1).gt.ONE)THEN CALL inpter(PERROR,Errpos, & 'Value of qlimit must be less than 1.') ELSE Qcheck=dvec(1) END IF END IF GO TO 80 END IF c ----------------------------------------------------------------- RETURN 80 CONTINUE END DO END getchr.f0000664006604000003110000000201214521201502011577 0ustar sun00315stepsC Last change: BCM 15 Jan 98 11:08 am CHARACTER*1 FUNCTION getchr(Nxtchr) c----------------------------------------------------------------------- c getchr.f, Release 1, Subroutine Version 1.3, Modified 20 Oct 1994. c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'lex.i' LOGICAL rngbuf CHARACTER*1 Nxtchr EXTERNAL rngbuf c ----------------------------------------------------------------- IF(Pos(PCHAR).gt.Lineln)THEN IF(rngbuf(2,Lineno,Linex,Lineln))THEN Pos(PLINE)=Lineno Pos(PCHAR)=1 ELSE Pos(PCHAR)=1 END IF END IF c ----------------------------------------------------------------- getchr=Linex(Pos(PCHAR):Pos(PCHAR)) Pos(PCHAR)=Pos(PCHAR)+1 c ----------------------------------------------------------------- Nxtchr=getchr c ----------------------------------------------------------------- RETURN END getcmp.f0000664006604000003110000002534714521201502011622 0ustar sun00315stepsC Last change: BCM 16 Sep 2005 1:27 pm SUBROUTINE getcmp(Probs,Havesp,Sp,Y,Nobs,Start,Nspobs,Begspn, & Srsttl,Nttlcr,Srsnam,Nser,Itest,Kdec,Begmdl, & Endmdl,Svprec,Locok,Yr2000,Lindot,Isrflw, & Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Set options for final direct and indirect composite adjustment, c including the number of observations, nobs, start date, start, and c seasonal period, Sp. c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- c Add appendfcst and appendbcst arguments, october 2006, bcm c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.i' INCLUDE 'stdio.i' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F,T INTEGER YR,MO DOUBLE PRECISION ZERO PARAMETER(F=.false.,T=.true.,YR=1,MO=2,ZERO=0D0) c----------------------------------------------------------------------- CHARACTER Srsttl*(*),Srsnam*(64) LOGICAL argok,Locok,Inptok,Havesp,Yr2000,Lindot INTEGER Sp,nelt,Nobs,Nttlcr,Probs,Start,tmpptr,Itest,endspn,nspec, & Kdec,Begspn,Begmdl,Endmdl,spnmdl,nobmdl,Nspobs,Nser,ivec, & Isrflw,Svprec DOUBLE PRECISION Y,Spclim,dvec DIMENSION Start(2),tmpptr(0:1),Itest(5),endspn(2),Y(Probs), & Begspn(2),Begmdl(2),Endmdl(2),spnmdl(2,2),ivec(1), & dvec(1) c----------------------------------------------------------------------- LOGICAL gtarg,chkcvr EXTERNAL chkcvr,gtarg c----------------------------------------------------------------------- CHARACTER ARGDIC*95 INTEGER argidx,argptr,PARG,arglog PARAMETER(PARG=13) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='nametitleprintsavedecimalsmodelspansaveprecision &savelogyr2000indoutlierappendfcstappendbcsttype') c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c ------------------------------------------------------------------ CHARACTER TYPDIC*9 INTEGER typptr,PTYP PARAMETER(PTYP=2) DIMENSION typptr(0:PTYP) PARAMETER(TYPDIC='flowstock') c----------------------------------------------------------------------- DATA argptr / 1,5,10,15,19,27,36,49,56,62,72,82,92,96 / DATA ysnptr / 1,4,6 / DATA typptr/1,5,10/ c----------------------------------------------------------------------- c Assume the input is OK and we don't have any of the arguments c----------------------------------------------------------------------- Locok=T CALL setint(NOTSET,4,spnmdl) CALL setint(NOTSET,2*PARG,arglog) 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),argidx c----------------------------------------------------------------------- c Series name argument c----------------------------------------------------------------------- 10 CALL gtnmvc(LPAREN,T,1,Srsnam,tmpptr,nelt,64,argok,Locok) IF(Lfatal)RETURN IF(argok)CALL eltlen(1,tmpptr,nelt,Nser) GO TO 140 c----------------------------------------------------------------------- c Title argument c----------------------------------------------------------------------- 20 CALL getttl(LPAREN,T,1,Srsttl,tmpptr,nelt,argok,Locok) IF(Lfatal)RETURN IF(argok)CALL eltlen(1,tmpptr,nelt,Nttlcr) GO TO 140 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 30 CALL getprt(LSPCMP,NSPCMP,Locok) GO TO 140 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 40 CALL getsav(LSPCMP,NSPCMP,Locok) GO TO 140 c----------------------------------------------------------------------- c decimals argument c----------------------------------------------------------------------- 50 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Locok) IF(Lfatal)RETURN IF(argok)THEN IF(ivec(1).lt.0.or.ivec(1).gt.5)THEN CALL inpter(PERROR,Errpos, & 'Number of output decimals must be between 0 and 5, inclusive.') Locok=F ELSE Kdec=ivec(1) END IF END IF GO TO 140 c----------------------------------------------------------------------- c Span for the model estimation. c----------------------------------------------------------------------- 60 CALL gtdtvc(Havesp,Sp,LPAREN,F,2,spnmdl,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos,'Need two dates for the model span or & use a comma as place holder.') Inptok=F END IF GO TO 140 c----------------------------------------------------------------------- c saveprecision argument c----------------------------------------------------------------------- 70 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Locok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(ivec(1).le.0.or.ivec(1).gt.15)THEN CALL inpter(PERROR,Errpos,'Value of saveprecision must be grea &ter than zero and less than 15.') Inptok=F ELSE Svprec=ivec(1) END IF END IF GO TO 140 c----------------------------------------------------------------------- c Savelog argument c----------------------------------------------------------------------- 80 CALL getsvl(LSLCMP,NSLCMP,Locok) GO TO 140 c----------------------------------------------------------------------- c yr2000 argument c----------------------------------------------------------------------- 90 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for yr2000 are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Yr2000=ivec(1).eq.1 GO TO 140 c----------------------------------------------------------------------- c indoutlier argument c----------------------------------------------------------------------- 100 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for indoutlier are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lindot=ivec(1).eq.1 GO TO 140 c----------------------------------------------------------------------- c appendfcst argument c----------------------------------------------------------------------- 110 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for appending forecasts are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Savfct=ivec(1).eq.1 GO TO 140 c----------------------------------------------------------------------- c appendbcst argument c----------------------------------------------------------------------- 120 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for appending backcasts are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Savbct=ivec(1).eq.1 GO TO 140 c----------------------------------------------------------------------- c type argument c----------------------------------------------------------------------- 130 CALL gtdcvc(LPAREN,T,1,TYPDIC,typptr,PTYP, & 'Available options for type are flow or stock.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Isrflw=ivec(1) GO TO 140 END IF IF(Lfatal)RETURN c---------------------------------------------------------------------- c Set starting date, seasonal period c---------------------------------------------------------------------- Start(YR)=Itest(4) Start(MO)=Itest(2) Begspn(YR)=Itest(4) Begspn(MO)=Itest(2) endspn(YR)=Itest(5) endspn(MO)=Itest(3) Sp=Itest(1) Havesp=T CALL dfdate(endspn,Begspn,Sp,Nspobs) Nspobs=Nspobs+1 Nobs=Nspobs c---------------------------------------------------------------------- c If beginning or ending date in the model span is undefined, set c equal to beginning date of the span. c---------------------------------------------------------------------- IF(spnmdl(YR,1).eq.NOTSET)THEN CALL cpyint(Begspn,2,1,Begmdl) ELSE CALL cpyint(spnmdl,2,1,Begmdl) END IF IF(spnmdl(YR,2).eq.NOTSET.or.spnmdl(YR,2).eq.0)THEN CALL addate(Begspn,Sp,Nspobs-1,Endmdl) IF(spnmdl(YR,2).eq.0)THEN Endmdl(MO)=spnmdl(MO,2) IF(Endmdl(MO).gt.Endspn(MO))Endmdl(YR)=Endmdl(YR)-1 END IF ELSE CALL cpyint(spnmdl(1,2),2,1,Endmdl) END IF c----------------------------------------------------------------------- c Check that the span is within the series c----------------------------------------------------------------------- CALL dfdate(Endmdl,Begmdl,Sp,nobmdl) nobmdl=nobmdl+1 IF(.not.chkcvr(Begspn,Nspobs,Begmdl,nobmdl,Sp))THEN CALL inpter(PERRNP,Errpos, & 'Model span is not within the span of available data.') CALL cvrerr('span',Begspn,Nspobs,'model span',Begmdl,nobmdl,Sp) IF(Lfatal)RETURN Inptok=F END IF c----------------------------------------------------------------------- IF(Locok)CALL agr1(Y,Nobs) IF(Isrflw.eq.NOTSET)Isrflw=0 Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN 140 CONTINUE END DO c ------------------------------------------------------------------ END getdat.f0000664006604000003110000001125714521201502011606 0ustar sun00315stepsC Last change: BCM 6 Aug 1998 7:33 am SUBROUTINE getdat(Havesp,Sp,Idate,Argok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c getdat.f, Release 1, Subroutine Version 1.3, Modified 20 Oct 1994. c----------------------------------------------------------------------- c Puts the date in character format for outlier variables and c printouts. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'lex.i' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ LOGICAL Argok,Havesp,Inptok CHARACTER datstr*11 INTEGER Idate,ipos,llstps,nchr,Sp DIMENSION Idate(2),llstps(2) c ------------------------------------------------------------------ Argok=T ipos=1 CALL cpyint(Lstpos,2,1,llstps) c----------------------------------------------------------------------- c Initialize datstr and nchr - change by BCM June 2003 c----------------------------------------------------------------------- CALL setchr(' ',11,datstr) nchr=1 c----------------------------------------------------------------------- c Case for nonseasonal data c----------------------------------------------------------------------- IF(Nxtktp.eq.INTGR)THEN IF(Havesp.and.Sp.ne.1)THEN CALL inpter(PERRNP,Lstpos, & 'Invalid date, seasonal period of data not annual.') Argok=F c ------------------------------------------------------------------ ELSE IF(.not.Havesp)THEN Havesp=T Sp=1 END IF nchr=Nxtkln datstr=Nxttok(1:Nxtkln) END IF c----------------------------------------------------------------------- c Case for monthly data because monthly abbreviations used. c We know this because lex didn't pull off anything after the decimal, c ie if there were a numeric period 67.3 then it would have pick up c the period also. c----------------------------------------------------------------------- ELSE IF(Nxtktp.eq.DBL)THEN IF(Nxttok(Nxtkln:Nxtkln).ne.'.')THEN IF(Havesp.and.Sp.eq.1)THEN CALL inpter(PERROR,llstps, & 'Invalid date, no period for nonseasonal data') Argok=F c ------------------------------------------------------------------ ELSE IF(.not.Havesp)THEN Sp=PSP END IF c ------------------------------------------------------------------ nchr=Nxtkln datstr=Nxttok(1:Nxtkln) ELSE IF(Havesp.and.Sp.ne.12)THEN CALL inpter(PERROR,Lstpos, & 'Invalid date, seasonal period of data not monthly.') Argok=F c ------------------------------------------------------------------ ELSE IF(.not.Havesp)THEN Havesp=T Sp=12 END IF nchr=Nxtkln datstr=Nxttok(1:Nxtkln) CALL lex() c ------------------------------------------------------------------ IF(Nxtktp.ne.NAME)THEN CALL inpter(PERROR,llstps, & 'Invalid date, expected a monthly abbreviation') Argok=F c----------------------------------------------------------------------- c Case for seasonal but we can't determine the period. The default c if monthly though c----------------------------------------------------------------------- ELSE datstr(nchr+1:nchr+Nxtkln)=Nxttok(1:Nxtkln) nchr=nchr+Nxtkln END IF c ------------------------------------------------------------------ END IF END IF c ------------------------------------------------------------------ IF(Argok)THEN CALL ctodat(datstr(1:nchr),Sp,ipos,Idate,Argok) c----------------------------------------------------------------------- c Check to see if quotes are found, change error message to mention c quotes if they are found - change by BCM June 2003 c----------------------------------------------------------------------- IF(.not.Argok)THEN IF(Nxtktp.eq.QUOTE)THEN CALL inpter(PERROR,Lstpos,'Not a valid date - remove quotes.') ELSE CALL inpter(PERROR,Lstpos,'Not a valid date') END IF END IF c----------------------------------------------------------------------- END IF CALL lex() c ------------------------------------------------------------------ Inptok=Argok.and.Inptok RETURN END getdbl.f0000664006604000003110000000222114521201503011567 0ustar sun00315stepsC Last change: BCM 15 Jan 98 11:07 am **==getdbl.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 LOGICAL FUNCTION getdbl(Tmp) IMPLICIT NONE c---------------------------------------------------------------------- c Returns an integer from the input stream and returns c true otherwise returns false and tmp is undefined. c---------------------------------------------------------------------- INCLUDE 'lex.i' c ----------------------------------------------------------------- INTEGER ipos DOUBLE PRECISION ctod,Tmp EXTERNAL ctod c ----------------------------------------------------------------- getdbl=.false. c ----------------------------------------------------------------- IF(Nxtktp.ne.EOF)THEN ipos=Lstpos(PCHAR) c ----------------------------------------------------------------- Tmp=ctod(Linex(1:Lineln),ipos) IF(ipos.gt.Lstpos(PCHAR))THEN Pos(PCHAR)=ipos getdbl=.true. CALL lex() END IF END IF c ----------------------------------------------------------------- RETURN END getdes.f0000664006604000003110000000701114521201503011603 0ustar sun00315stepsC Last change: Jan.2021, use appropriate dictionary, c DSEDIC -> DS2DIC. C previous change: BCM 23 Aug 2006 6:51 am SUBROUTINE getdes(Itbl,Fildes,Ndescr,Label) IMPLICIT NONE c ------------------------------------------------------------------ c Subroutine to extract the description for table Itbl from the data c dictionaries into the character scalar Fildes c Since X-13ARIMA-SEATS has so many tables, the dictionary for the c table descriptions had to be divided into many parts so the length c of all of the data dictionaries was less than 2000 characters c ------------------------------------------------------------------ c Written by BCM August 22 2006 c ------------------------------------------------------------------ LOGICAL F PARAMETER(F=.false.) c ------------------------------------------------------------------ INCLUDE 'tbltitle.prm' INCLUDE 'dessrs.prm' INCLUDE 'desmdl.prm' INCLUDE 'desx11.prm' INCLUDE 'desfsa.prm' INCLUDE 'desdgn.prm' INCLUDE 'desdg2.prm' INCLUDE 'descmp.prm' INCLUDE 'descm2.prm' INCLUDE 'desadj.prm' INCLUDE 'desxrg.prm' INCLUDE 'desset.prm' INCLUDE 'desst2.prm' INCLUDE 'desspc.prm' c ------------------------------------------------------------------ CHARACTER Fildes*(PTTLEN) INTEGER Itbl,Ndescr LOGICAL Label c ------------------------------------------------------------------ INCLUDE 'dessrs.var' INCLUDE 'desmdl.var' INCLUDE 'desx11.var' INCLUDE 'desfsa.var' INCLUDE 'desdgn.var' INCLUDE 'desdg2.var' INCLUDE 'descmp.var' INCLUDE 'descm2.var' INCLUDE 'desadj.var' INCLUDE 'desxrg.var' INCLUDE 'desset.var' INCLUDE 'desst2.var' INCLUDE 'desspc.var' c ------------------------------------------------------------------ IF(Itbl.le.PDSR)THEN CALL makttl(DSRDIC,dsrptr,PDSR,Itbl,0,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM1)THEN CALL makttl(DSMDIC,dsmptr,PDSM,Itbl,PDSR,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM2)THEN CALL makttl(DSPDIC,dspptr,PDSP,Itbl,PDSUM1,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM3)THEN CALL makttl(DSXDIC,dsxptr,PDSX,Itbl,PDSUM2,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM4)THEN CALL makttl(DSSDIC,dssptr,PDSS,Itbl,PDSUM3,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM5)THEN CALL makttl(DSADIC,dsaptr,PDSA,Itbl,PDSUM4,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM6)THEN CALL makttl(DSIDIC,dsiptr,PDSI,Itbl,PDSUM5,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM7)THEN CALL makttl(DSDDIC,dsdptr,PDSD,Itbl,PDSUM6,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM8)THEN CALL makttl(DD2DIC,dd2ptr,PDD2,Itbl,PDSUM7,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM9)THEN CALL makttl(DSCDIC,dscptr,PDSC,Itbl,PDSUM8,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM10)THEN CALL makttl(DC2DIC,dc2ptr,PDC2,Itbl,PDSUM9,Fildes,Ndescr,Label,F) ELSE IF(Itbl.le.PDSUM11)THEN CALL makttl(DSEDIC,dseptr,PDSE,Itbl,PDSUM10,Fildes,Ndescr,Label, & F) ELSE CALL makttl(DS2DIC,ds2ptr,PDS2,Itbl,PDSUM11,Fildes,Ndescr,Label, & F) END IF c ------------------------------------------------------------------ RETURN END getdiag.f0000664006604000003110000021573714521201503011754 0ustar sun00315steps SUBROUTINE getDiag( dS, dT, nT, vY, out, init, & vSeaAR, oSeaAR, vSeaD, oSeaD, vSeaMA, oSeaMA, & vTreAR, oTreAR, vTreD, oTreD, vTreMA, oTreMA, & vCycAR, oCycAR, vCycMA, oCycMA, vMA, oMA, & vSAAR, oSAAR, vSAMA, oSAMA, & vTAAR, oTAAR, vTAMA, oTAMA, & sSeaVar, sTreVar, sCycVar, sSAVar, sTAVar, & sIrrVar, sdSig, nPer, nParam, nFixed, nDiff ) c----------------------------------------------------------------------- c getDiag.f, Release 1, Subroutine Version 1.9, Modified 30 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 03 Apr 2005. c Modified by REG, on 19 Sep 2005, to add SA Filter from extSgnl(), c to add filter gain\phase-delay calculation, c and to correct tab stops. c Modified by REG, on 20 Oct 2005, to move sdSigAlt processing c from bldCov() to extSgnl(). c Modified by REG, on 07 Nov 2005, to generalize irregular component c to include mSigUI, created by bldCov(), and used by other c routines. c Modified by REG, on 17 Nov 2005, to add revision processing. c Modified by REG, on 13 Mar 2006, to add growth rate processing. c Modified by REG, on 04 Apr 2006, to add weighted version c of over-under lag diagnostics. c Modified by REG, on 27 Apr 2008, to restrict finite revisions c calculations unless out=0, and to adjust sdSigAlt for c a finite sample factor previously performed in c compLagDiag() and compCrosDiag() processing. c Modified by REG, on 30 May 2006, to add check for no seasonal c component which affects bldCov(), compMSE(), and c compRevs() processing. c----------------------------------------------------------------------- c This subroutine provides a fortran implementation of Ox code c called SigDiag originally developed by Tucker McElroy that c calculates some diagnostics. The following code implements c four Ox procedures: buildDiffMatrices(), buildCovMatrices(), c ExtractSignals(), ComputeDiagnostics(). c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dS i size of Seasonal Differencing c dT i size of Trend Differencing c init i SEATS ARIMA model usage: c 0=initialize and re-estimate, c 1=re-estimate c 2=use X-13ARIMA-SEATS model c nDiff i vector of (d,D) differencing orders c nFixed i number of fixed parameters c nPer i size of seasonal period c nParam i number of parameters in model ARIMA: c (1) = p, (2) = q, (3) = bp, (4) = bq . c nT i size of data available c oCycAR i max order of vCycAR polynomial c oCycAR i max order of vCycMA polynomial c oMA i max order of vMA polynomial c oSAMA i max order of vSAMA polynomial c oSeaAR i max order of vSeaAR polynomial c oSeaD i max order of vSeaD polynomial c oSeaMA i max order of vSeaMA polynomial c oTAMA i max order of vTAMA polynomial c oTreAR i max order of vTreAR polynomial c oTreD i max order of vTreD polynomial c oTreMA i max order of vTreMA polynomial c out i SEATS output parameter c sdSig d data innovation stdev, note that Var provides another c estimate of the innovation variance c sCycVar d cycle innovation variance c sIrrVar d irregular innovation variance c sSAVar d seasonal adjusted innovation variance c sSeaVar d seasonal innovation variance c sTAVar d trend adjusted innovation variance c sTreVar d trend innovation variance c vCycAR d AR polynomial vector for cycle component c vCycMA d MA polynomial vector for cycle component c vMA d MA polynomial vector for original model c vSAMA d MA polynomial vector for seasonal adjusted component c vSeaAR d AR polynomial vector for seasonal component c vSeaD d D polynomial vector for seasonal component c vSeaMA d MA polynomial vector for seasonal component c vTAMA d MA polynomial vector for trend adjusted component c vTreAR d AR polynomial vector for Trend component c vTreD d D polynomial vector for Trend component c vTreMA d MA polynomial vector for Trend component c vY d data vector c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'acfast.i' INCLUDE 'across.i' INCLUDE 'model.prm' INCLUDE 'mdldat.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'revs.i' INCLUDE 'tbl5x.i' c----------------------------------------------------------------------- c Input variables c----------------------------------------------------------------------- INTEGER dS, dT, init, nT, out DOUBLE PRECISION vY(nT) INTEGER oSeaAR, oSeaD, oSeaMA, oTreAR, oTreD, oTreMA, & oCycAR, oCycMA, oSAAR, oSAMA, oTAAR, oTAMA, oMA DOUBLE PRECISION vSeaAR(0:oSeaAR), vSeaD(0:oSeaD), & vSeaMA(0:oSeaMA) DOUBLE PRECISION vTreAR(0:oTreAR), vTreD(0:oTred), & vTreMA(0:oTreMA) DOUBLE PRECISION vCycAR(0:oCycAR), vCycMA(0:oCycMA) DOUBLE PRECISION vSAAR(0:oSAAR), vSAMA(0:oSAMA) DOUBLE PRECISION vTAAR(0:oTAAR), vTAMA(0:oTAMA) DOUBLE PRECISION vMA(0:oMA) DOUBLE PRECISION sSeaVar, sTreVar, sCycVar, sMAVar, sIrrVar, & sSAVar, sTAVar DOUBLE PRECISION sdSig INTEGER nPer, nParam(4), nFixed, nDiff(2) c----------------------------------------------------------------------- c note - pLagSmT added by BCM April 24, 2006 to allow dimensioning of c dLagSmT argument in compCroDiag routine c also added 7 integer scalars below to allow getRevDec to dimension c variables c----------------------------------------------------------------------- INTEGER pd1, pd2, pd3, pd4, pd5, pd6, pd7, pLagSmT c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c fulPva d vector of p-values associated with fulDia c i,j i indexes c gauss d external function c getAma c external function declaration c getTmcs c external function declaration c lag i identifies lag to processed by compLagDiag() c noePva d vector of p-values associated with noeDia c nSave i identifies default size of large matrices c that are saved (not dynamic) c ONE,TWO d constant parameters c sInnovSd d innovation variance, one of SEATS (sdSig) or alternative c sdSigAlt. Note that a third version (SQRT(Var)) exists. c vSAAR d AR polynomial for seasonal adjusted c----------------------------------------------------------------------- INTEGER i, j, lag, nSave, nSave2, nSave3 CHARACTER getAna, getTmcs DOUBLE PRECISION gauss, fulPva(4), noePva(4), & ONE, ONEP, sInnovSd, TWO, ZERO PARAMETER (nSave=POBS*POBS, nSave2=(POBS+60)*(POBS+60), & nSave3=12*POBS, ONE=1.0D0, ONEP=100.0D0, TWO=2.0D0, & ZERO=0.0D0) LOGICAL dpeq c----------------------------------------------------------------------- c Name Type Description (bldDif local Variables) c----------------------------------------------------------------------- c dDel d diagonal form of overall differencing matrix: mDel c dDelS d diagonal form of seasonal differencing matrix: mDelS c dDelT d diagonal form of trend differencing matrix: mDelT c dRedDelS d diagonal form of reduced mDelS: mRedDelS c dRedDelT d diagonal form of reduced mDelT: mRedDelT c mDel d overall differencing matrix c mDelS d seasonal differencing matrix c mDelT d trend differencing matrix c mRedDelS d smaller version of mDelS c mRedDelT d smaller version of mDelT c nDel i size (rows,columns) of mDel c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nRedDelS i size (rows,columns) of mRedDelS c nRedDelT i size (rows,columns) of mRedDelT c----------------------------------------------------------------------- INTEGER nDelS(2), nDelT(2), nDel(2), nRedDelS(2), nRedDelT(2) DOUBLE PRECISION dDel(dS+dT+1), dDelS(dS+1), dDelT(dT+1), & dRedDelS(dS+1), dRedDelT(dT+1) c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mDel(nT-dS-dT,nT), mDelS(nT-dS,nT), c & mDelT(nT-dT,nT), mRedDelS(nT-dS-dT,nT-dT), c & mRedDelT(nT-dS-dT,nT-dS) c ------------------------------------------------------------------ DOUBLE PRECISION mDel(nSave2), mDelS(nSave2), mDelT(nSave2), & mRedDelS(nSave2), mRedDelT(nSave2) SAVE mDel, mDelS, mDelT, mRedDelS, mRedDelT c----------------------------------------------------------------------- c Name Type Description (bldCov local Variables) c----------------------------------------------------------------------- c lInvSigUS l logical to allow inverting of mSigUS c lInvSigUT l logical to allow inverting of mSigUT c lInvSigW l logical to allow inverting of mSigW c lInvSigWS l logical to allow inverting of mSigWS c lInvSigWT l logical to allow inverting of mSigWT c lSeaPre l logical indicating presence of seasonal component c lSigUf l logical to calculate future covariance matrices c mInvSigUS d inverse of mSigUS: covariance matrix c for seaonal differenced seasonal cpmponent c mInvSigUT d inverse of mSigUT: covariance matrix c for trend differenced trend component c mInvSigW d inverse of mSigW: covariance matrix for differenced data c mInvSigWS d inverse of mSigWS: covariance matrix c for seasonal differenced trend adjusted component c mInvSigWT d inverse of mSigWT: covariance matrix c for trend differenced seasonal adjusted component c mSigUI d covariance matrix for undifferenced irregular c mSigUS d covariance matrix for differenced seasonal c mSigUT d covariance matrix for differenced trend (UT) c mSigUTf d covariance matrix for future differenced trend (UTf) c mSigUTfUT d cross covariance matrix for (UTf,UT) c mSigW d covariance matrix for differenced data (W) c mSigWf d covariance matrix for future differenced data (Wf) c mSigWfW d cross covariance matrix for (Wf,W) c mSigWT d covariance matrix for differenced seasonally adjusted (WT) c mSigWTf d covariance matrix for differenced future seasonally c adjusted (WTf) c mSigWTfWT d cross covariance matrix for (WTf,WT) c nInvSigUS i size (rows,columns) of mInvSigUS matrix c nInvSigUT i size (rows,columns) of mInvSigUT matrix c nInvSigW i size (rows,columns) of mInvSigW matrix c nInvSigWS i size (rows,columns) of mInvSigWS matrix c nInvSigWT i size (rows,columns) of mInvSigWT matrix c mSigWT d covariance matrix for differenced seasonally adjusted c nInvSigW i size (rows,columns) of mInvSigW matrix c nSigUI i size (rows,columns) of mSigUI matrix c nSigUS i size (rows,columns) of mSigUS matrix c nSigUT i size (rows,columns) of mSigUT matrix c nSigUTf i size (rows,columns) of mSigUTf matrix c nSigUTfUT i size (rows,columns) of mSigUTfUT matrix c nSigW i size (rows,columns) of mSigW matrix c nSigWf i size (rows,columns) of mSigWf matrix c nSigWfW i size (rows,columns) of mSigWfW matrix c nSigWS i size (rows,columns) of mSigWS matrix c nSigWT i size (rows,columns) of mSigWT matrix c nSigWTf i size (rows,columns) of mSigWTf matrix c nSigWTfWT i size (rows,columns) of mSigWTfWT matrix c----------------------------------------------------------------------- LOGICAL lInvSigUS, lInvSigUT, lInvSigW, lInvSigWS, lInvSigWT, & lSeaPre, lSigUf INTEGER nSigUI(2), nSigUS(2), nSigUT(2) INTEGER nSigWS(2), nSigWT(2), nSigW(2) INTEGER nInvSigUS(2), nInvSigUT(2) INTEGER nInvSigW(2), nInvSigWS(2), nInvSigWT(2) INTEGER nSigUTf(2), nSigUTfUT(2), nSigWTf(2), nSigWTfWT(2), & nSigWf(2), nSigWfW(2) PARAMETER (lInvSigUS=.true., lInvSigUT=.true., lInvSigW=.true., & lInvSigWS=.true., lInvSigWT=.true., lSigUf=.true.) c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mSigUI(nT,nT), mSigUS(nT-dS,nT-dS), c & mSigUT(nT-dT,nT-dT) c DOUBLE PRECISION mSigWS(nT-dS,nT-dS), mSigWT(nT-dT,nT-dT), c & mSigW(nT-dS-dT,nT-dS-dT) c DOUBLE PRECISION mInvSigUS(nT-dS,nT-dS), mInvSigUT(nT-dT,nT-dT) c DOUBLE PRECISION mInvSigWS(nT-dS,nT-dS), mInvSigWT(nT-dT,nT-dT), c mInvSigW(nT-dS-dT,nT-dS-dT) c ------------------------------------------------------------------ DOUBLE PRECISION mSigUI(nSave2), mSigUS(nSave2), mSigUT(nSave2) DOUBLE PRECISION mSigWS(nSave2), mSigWT(nSave2), mSigW(nSave2) DOUBLE PRECISION mInvSigUS(nSave2), mInvSigUT(nSave2) DOUBLE PRECISION mInvSigWS(nSave2), mInvSigWT(nSave2), & mInvSigW(nSave2) DOUBLE PRECISION mSigUTf(12*12), mSigUTfUT(nSave3), & mSigWTf(12*12), mSigWTfWT(nSave3), & mSigWf(12*12), mSigWfW(nSave3) SAVE mSigUI, mSigUS, mSigUT, mSigW, mSigWS, mSigWT, & mInvSigUS, mInvSigUT, mInvSigW, mInvSigWS, mInvSigWT, & mSigUTf, mSigUTfUT, mSigWTf, mSigWTfWT, mSigWf, mSigWfW c----------------------------------------------------------------------- c Name Type Description (extSgnl local Variables) c----------------------------------------------------------------------- c finfact d finite sample correction factor c mCovIrr d covariance of estimated irregular c mCovSA d covariance of estimated seasonal adjusted c mCovSea d covariance of estimated seasonal c mCovTre d covariance of estimated trend c mIrrPFlt d irregular partial filters: c column 1 = symmetric, column 2 = concurrent c mSAPFlt d seasonal adjustment partial filters: c column 1 = symmetric, column 2 = concurrent c mSeaPFlt d seasonal partial filters: c column 1 = symmetric, column 2 = concurrent c mTrePFlt d trend partial filters: c column 1 = symmetric, column 2 = concurrent c nW i size of the differenced data c nCovIrr i size (rows,columns) of mCovIrr matrix c nCovSA i size (rows,columns) of mCovSA matrix c nCovSea i size (rows,columns) of mCovSea matrix c nCovTre i size (rows,columns) of mCovTre matrix c nIrrEst i size (rows,columns) of vIrrEst vector c nIrrPFlt i size (rows,columns) of mIrrPFlt matrix c nParams i total number of parameters in nParam c nPStar i total number of AR parameters c nSAPFlt i size (rows,columns) of mSAPFlt matrix c nSeaEst i size (rows,columns) of vSeaEst vector c nSeaPFlt i size (rows,columns) of mSeaPFlt matrix c nTreEst i size (rows,columns) of vTreEst vector c nTrePFlt i size (rows,columns) of mTrePFlt matrix c sdSigAlt d alternate estimated data innovation stdev adjusted for c number of estimated model parameters c vIrrEst d estimated irregular c vSeaEst d estimated seasonal c vTreEst d estimated trend c----------------------------------------------------------------------- INTEGER nIrrEst(2), nSeaEst(2), nTreEst(2) INTEGER nCovIrr(2), nCovSea(2), nCovTre(2), nCovSA(2) INTEGER nIrrPFlt(2), nSAPFlt(2), nSeaPFlt(2), nTrePFlt(2) INTEGER nParams, nPStar, nW DOUBLE PRECISION vIrrEst(nT), vSeaEst(nT), vTreEst(nT) DOUBLE PRECISION mIrrPFlt(nT-dS-dT,2), mSAPFlt(nT-dS,2), & mSeaPFlt(nT-dT,2), mTrePFlt(nT-dS,2) DOUBLE PRECISION finfact, sdSigAlt c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mCovIrr(nT,nT), mCovSea(nT-dS,nT-dS), c & mCovTre(nT-dT,nT-dT), mCovSA(nT-dT,nT-dT) c ------------------------------------------------------------------ DOUBLE PRECISION mCovIrr(nSave), mCovSea(nSave), & mCovTre(nSave), mCovSA(nSave) SAVE mCovIrr, mCovSea, mCovTre, mCovSA c----------------------------------------------------------------------- c Name Type Description (compMSE local Variables) c----------------------------------------------------------------------- c lInvSig l logical indicating whether all mInvSig matrices are c available c mIrrVar d variance matrix of estimated irregular c mSeaVar d variance matrix of estimated seasonal c mTreVar d variance matrix of estimated trend c nIrrVar i size (rows,columns) of mIrrVar matrix c nSeaVar i size (rows,columns) of mSeaVar matrix c nTreVar i size (rows,columns) of mTreVar matrix c----------------------------------------------------------------------- INTEGER nIrrVar(2), nSeaVar(2), nTreVar(2) LOGICAL lInvSig PARAMETER (lInvSig=.true.) c ------------------------------------------------------------------ c Dynamic (commented) versus static (uncommented) matrices c ------------------------------------------------------------------ c DOUBLE PRECISION mIrrVar(nT,nT), mSeaVar(nT,nT), mTreVar(nT,nT) c ------------------------------------------------------------------ DOUBLE PRECISION mIrrVar(nSave2), mSeaVar(nSave2), mTreVar(nSave2) SAVE mIrrVar, mSeaVar, mTreVar c----------------------------------------------------------------------- c Name Type Description (compDiagand, CompLagDiag, getWghLagDia, c and CompCroDiag local Variables) c----------------------------------------------------------------------- c fulDia d vector of normalized diagnostics from full signals c for irregular, seasonal, trend, and SA c fulEso d vector of null means of estimates from full signals c for irregular, seasonal, trend, and SA c fulEst d vector of diagnostic estimates from full signals c for irregular, seasonal, trend, and SA c fulVar d vector of variances of diagnostics from full signals c for irregular, seasonal, trend, and SA c noeDia d vector of normalized diagnostics from trimmed signals c for irregular, seasonal, trend, and SA c noeEso d vector of null means of estimate from trimmed signals c for irregular, seasonal, trend, and SA c noeEst d vector of diagnostic estimates from trimmed signals c for irregular, seasonal, trend, and SA c noeVar d vector of variances of diagnostics from trimmed signals c for irregular, seasonal, trend, and SA c wghDia d vector of normalized diagnostics from weighted signals c for irregular, seasonal, trend, and SA c wghEso d vector of null means of estimate from weighted signals c for irregular, seasonal, trend, and SA c wghEst d vector of diagnostic estimates from weighted signals c for irregular, seasonal, trend, and SA c wghVar d vector of variances of diagnostics from weighted signals c for irregular, seasonal, trend, and SA c----------------------------------------------------------------------- DOUBLE PRECISION fulEst(4), noeEst(4), fulEso(4), noeEso(4), & fulVar(4), noeVar(4), fulDia(4), noeDia(4), & wghEst(4), wghEso(4), wghVar(4), wghDia(4) c----------------------------------------------------------------------- c Name Type Description (Revision local Variables) c----------------------------------------------------------------------- c finMSEs d MSEs for each component given nT observations in the pass c and up to 5 years of future observations c (i,j), i=1,3 represents irregular, seasonal, trend comps c j=1,5 represents # years of future observations c finRevs d revisions for each component using finMSEs c infMSEs d MSEs for each component given nT observations in the pass c and infinite observations in the future c (i), i=1,3 represents irregular, seasonal, trend comps c infRevs d revisions for each component using infMSEs c lCurMSEs d MSEs for components estimates for the last 5 years: c first column for seasonal, second column for trend c lInfMSEs d lag 0 MSEs for component estimates for the last five years c and the next year: first column for seasonal, c second column for trend c lInfMSE1s d lag 1 MSEs for component estimates for the last five years c and the next year: first column for seasonal, c second column for trend c lInfMSE2s d lag nPer MSEs for component estimates c for the last five years and the next year: c first column for seasonal, second column for trend c lInfMSE3s d lag iTbl53Lag MSEs for component estimates c for the last five years and the next year: c first column for seasonal, second column for trend c nRevs i row index in lCurMSEs and lInfMSExs associated c with last observation c oIrrAR i order of AR polynomial for irregular component c oIrrMA i order of MA polynomial for irregular component c relRevs d finRevs relative to infRevs c sSeaARD i size of vSeaARD vector c sTreARD i size of vTreARD vector c vIrrAR i AR polynomial for the irregular component c vIrrMA i MA polynomial for the irregular component c vSeaARD d combined AR x D polynomial for the seasonal component c vTreARD d combined AR x D polynomial for the trend component c----------------------------------------------------------------------- INTEGER sSeaARD, sTreARD, oIrrAR, oIrrMA, nRevs c DOUBLE PRECISION finMSEs(3,5), finRevs(3,5), relRevs(3,5) DOUBLE PRECISION vSeaARD(0:(oSeaAR+oSeaD)) DOUBLE PRECISION vTreARD(0:(oTreAR+oTreD)) DOUBLE PRECISION vIrrAR(0:0), vIrrMA(0:0) DOUBLE PRECISION lCurMSEs(60,2), lInfMSEs(72,2), lInfMSE1s(72,2) DOUBLE PRECISION lInfMSE2s(72,2), lInfMSE3s(72,2) * PARAMETER (oIrrAR=0, oIrrMA=0, vIrrAR(0)=ONE, vIrrMA(0)=ONE) PARAMETER (oIrrAR=0, oIrrMA=0) c----------------------------------------------------------------------- c Name Type Description (Growth Rate local Variables) c----------------------------------------------------------------------- c iTbl53Lag i lag between last observation of data and last observation c of previous year c nSeaGRSE1 i size (rows,columns) of vSeaGRSE1 vector c nSeaGRSE2 i size (rows,columns) of vSeaGRSE2 vector c nTreGRSE1 i size (rows,columns) of vTreGRSE1 vector c nTreGRSE2 i size (rows,columns) of vTreGRSE2 vector c vSeaGRSE1 d vector of seasonal component growth rate SEs for table 5.2 c vSeaGRSE2 d vector of seasonal component growth rate SEs for table 5.5 c vTbl51 d vector of table 5.1 MSEs c vTbl53 d vector of table 5.3 SEs c vTbl54 d vector of table 5.4 MSEs c vTbl56 d vector of table 5.6 SEs c vTbl57 d vector of table 5.7 SEs c vTreGRSE1 d vector of trend component growth rate SEs for table 5.2 c vTreGRSE2 d vector of trend component growth rate SEs for table 5.5 c----------------------------------------------------------------------- INTEGER iTbl53Lag c INTEGER nSeaGRSE1(2), nSeaGRSE2(2), nTreGRSE1(2), nTreGRSE2(2) c DOUBLE PRECISION vSeaGRSE1(nT-1), vTreGRSE1(nT-1) c DOUBLE PRECISION vSeaGRSE2(nT-1), vTreGRSE2(nT-1) c DOUBLE PRECISION vTbl51(6), vTbl53(2), vTbl54(6), vTbl56(6,2), c & vTbl57(3,3) c----------------------------------------------------------------------- c Some debug output c----------------------------------------------------------------------- * WRITE (6, 9990) dS, dT, nT, oSeaAR, oSeaD, oSeaMA, * & oTreAR, oTreD, oTreMA, oCycAR, oCycMA, nPer, * & nParam(1), nParam(2), nParam(3), nParam(4), * & nFixed, nDiff(1), nDiff(2) * WRITE (6, 9991) sSeaVar, sTreVar, sCycVar, sSAVar, sTAVar, * & sIrrVar c WRITE (6, 9993) sdSig**2, Var * WRITE (6, 9992)(vSeaAR(i),i=0,oSeaAR) * WRITE (6, 9992)(vSeaD(i), i=0,oSeaD) * WRITE (6, 9992)(vSeaMA(i),i=0,oSeaMA) * WRITE (6, 9992)(vTreAR(i),i=0,oTreAR) * WRITE (6, 9992)(vTreD(i), i=0,oTreD) * WRITE (6, 9992)(vTreMA(i),i=0,oTreMA) * WRITE (6, 9992)(vCycAR(i),i=0,oCycAR) * WRITE (6, 9992)(vCycMA(i),i=0,oCycMA) * WRITE (6, 9992)(vSAAR(i),i=0,oSAAR) * WRITE (6, 9992)(vSAMA(i),i=0,oSAMA) * WRITE (6, 9992)(vTAAR(i),i=0,oTAAR) * WRITE (6, 9992)(vTAMA(i),i=0,oTAMA) * WRITE (6, 9992)(vMA(i),i=0,oMA) * 9990 FORMAT( 3( 8(1x, i4), / ) ) * 9991 FORMAT( 2( 5(1x, G12.5), / ) ) * 9992 FORMAT( 100(1x, G12.5) ) * 9993 FORMAT( 2(1x, G20.13) ) vIrrAR(0)=ONE vIrrMA(0)=ONE c----------------------------------------------------------------------- c Check for some differencing else exit with warning c----------------------------------------------------------------------- IF (( nDiff(1) .eq. 0 ).and.( nDiff(2) .eq. 0)) THEN IF(Issap.lt.2.and.Irev.lt.4)WRITE(STDERR,100) WRITE(Mt2,100) 100 FORMAT( ' *** No differencing provided, finite sample', & ' diagnostic processing aborted. ***' ) RETURN END IF c----------------------------------------------------------------------- c bldDif processing c----------------------------------------------------------------------- CALL bldDif( dS, dT, nT, nPer, nDiff, vSeaD, oSeaD, & vTreD, oTreD, mDelS, dDelS, nDelS, & mDelT, dDelT, nDelT, & mRedDelS, dRedDelS, nRedDelS, & mRedDelT, dRedDelT, nRedDelT, & mDel, dDel, nDel ) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,2000) c ------------------------------------------------------------------ c DO i= 1, nDelS(1), nDelS(1)-1 c WRITE(6,2001)(mDelS(i+(j-1)*nDelS(1)),j=1,nDelS(2)) c END DO c WRITE(6,2006)nDelS c ------------------------------------------------------------------ c DO i = 1, nDelT(1), nDelT(1)-1 c WRITE(6,2001)(mDelT(i+(j-1)*nDelT(1)),j=1,nDelT(2)) c END DO c WRITE(6,2006)nDelT c ------------------------------------------------------------------ c DO i = 1, nRedDelS(1), nRedDelS(1)-1 c WRITE(6,2001)(mRedDelS(i+(j-1)*nRedDelS(1)),j=1,nRedDelS(2)) c END DO c WRITE(6,2006)nRedDelS c ------------------------------------------------------------------ c DO i = 1, nRedDelT(1), nRedDelT(1)-1 c WRITE(6,2001)(mRedDelT(i+(j-1)*nRedDelT(1)),j=1,nRedDelT(2)) c END DO c WRITE(6,2006)nRedDelT c ------------------------------------------------------------------ c DO i= 1, nDel(1), nDel(1)-1 c WRITE(6,2001)(mDel(i+(j-1)*nDel(1)),j=1,nDel(2)) c END DO c WRITE(6,2006)nDel c ------------------------------------------------------------------ * 2000 FORMAT( ' Output from bldDif. ', /) c2001 FORMAT( 300(1x,F6.2) ) c2006 FORMAT( 2(1x,I3), / ) c----------------------------------------------------------------------- c bldCov processing c----------------------------------------------------------------------- lSeaPre = ( (nParam(3)+nParam(4)+nDiff(2)) .gt. 0 ) CALL bldCov( nT, dS, dT, nPer, lSeaPre, & lSigUf, lInvSigUS, lInvSigUT, & lInvSigW, lInvSigWS, lInvSigWT, & vSeaAR, oSeaAR, vSeaMA, oSeaMA, & vTreAR, oTreAR, vTreMA, oTreMA, & vCycAR, oCycAR, vCycMA, oCycMA, & dDel, nDel, dDelS, nDelS, dDelT, nDelT, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & sSeaVar, sTreVar, sCycVar, sIrrVar, & mSigUS, nSigUS, mSigUT, nSigUT, mSigUI, nSigUI, & mSigWS, nSigWS, mSigWT, nSigWT, mSigW, nSigW, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigWf, nSigWf, mSigWfW, nSigWfW, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW ) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,3000) c ------------------------------------------------------------------ c DO i = 1, nSigUS(1), nSigUS(1)-1 c WRITE(6,3001)(mSigUS(i+(j-1)*nSigUS(1)),j=1,nSigUS(2)) c END DO c WRITE(6,2006)nSigUS c ------------------------------------------------------------------ c DO i = 1, nSigUT(1), nSigUT(1)-1 c WRITE(6,3001)(mSigUT(i+(j-1)*nSigUT(1)),j=1,nSigUT(2)) c END DO c WRITE(6,2006)nSigUT c ------------------------------------------------------------------ c DO i = 1, nSigWS(1), nSigWS(1)-1 c WRITE(6,3001)(mSigWS(i+(j-1)*nSigWS(1)),j=1,nSigWS(2)) c END DO c WRITE(6,2006)nSigWS c ------------------------------------------------------------------ c DO i = 1, nSigWT(1), nSigWT(1)-1 c WRITE(6,3001)(mSigWT(i+(j-1)*nSigWT(1)),j=1,nSigWT(2)) c END DO c WRITE(6,2006)nSigWT c ------------------------------------------------------------------ c DO i = 1, nSigW(1), nSigW(1)-1 c WRITE(6,3001)(mSigW(i+(j-1)*nSigW(1)),j=1,nSigW(2)) c END DO c WRITE(6,2006)nSigW c ------------------------------------------------------------------ * 3000 FORMAT( ' Output from bldCov. ', /) c3001 FORMAT( 300(1x,F6.2) ) 3004 FORMAT( 1x,G17.10, / ) c----------------------------------------------------------------------- c extSgnl processing c----------------------------------------------------------------------- CALL extSgnl( nT, dS, dT, vY, mDel, dDel, nDel, & mDelS, dDelS, nDelS, mDelT, dDelT, nDelT, & sdSigAlt, mRedDelS, dRedDelS, nRedDelS, & mRedDelT, dRedDelT, nRedDelT, mSigUS, nSigUS, & mSigUT, nSigUT, mSigUI, nSigUI, & mSigWS, nSigWS, mSigWT, nSigWT, & mSigW, nSigW, mInvSigW, nInvSigW, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & vIrrEst, nIrrEst, vSeaEst, nSeaEst, & vTreEst, nTreEst, mCovIrr, nCovIrr, & mCovSea, nCovSea, mCovTre, nCovTre, & mCovSA, nCovSA, & mIrrPFlt, nIrrPFlt, mSeaPFlt, nSeaPFlt, & mTrePFlt, nTrePFlt, mSAPFlt, nSAPFlt ) c ------------------------------------------------------------------ c Calculate finite sample sample correction factor and c model innovation variance adjusted for finite sample. c If model estimated by X-13A-S then adjust for fixed parameters, c else if model estimated by SEATS then adjust for conditional c estimation using initial AR (nParam(1) + nPer*nParam(3)) values. c ------------------------------------------------------------------ nParams = nParam(1) + nParam(2) + nParam(3) + nParam(4) nPStar = nParam(1) + nPer*nParam(3) nW = nT - (nDiff(1) + nPer*nDiff(2)) if ((getAna() .ne. 'Y') .and. (getTmcs() .ne. 'Y') .and. & (init .eq. 2)) then finfact = DBLE( nW )/ DBLE( nW - (nParams - nFixed) ) ELSE finfact = DBLE( nW )/ DBLE( nW - (nParams + nPStar) ) END IF sdSigAlt = DSQRT( finfact )*sdSigAlt * WRITE(6,4010)getAna(), getTmcs(), init * 4010 FORMAT( 1x, a1, 1x, a1, 1x, i2 ) c ------------------------------------------------------------------ c Choose the innovation standard deviation to use: c sdSigAlt over sdSig. Note that there is also SQRT(Var) from SEATS. c ------------------------------------------------------------------ sInnovSd = sdSig c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ * WRITE(6,4000) c ------------------------------------------------------------------ * WRITE(6,3004)sdSigAlt c ------------------------------------------------------------------ c WRITE(6,4001)(vIrrEst(i),i=1,nIrrEst(1)) c WRITE(6,2006)nIrrEst c WRITE(6,4001)(vSeaEst(i),i=1,nSeaEst(1)) c WRITE(6,2006)nSeaEst c WRITE(6,4001)(vTreEst(i),i=1,nTreEst(1)) c WRITE(6,2006)nTreEst c ------------------------------------------------------------------ c DO i = 1, nCovIrr(1), nCovIrr(1)-1 c WRITE(6,4001)(mCovIrr(i+(j-1)*nCovIrr(1)),j=1,nCovIrr(2)) c END DO c WRITE(6,2006)nCovIrr c ------------------------------------------------------------------ c DO i = 1, nCovSea(1), nCovSea(1)-1 c WRITE(6,4001)(mCovSea(i+(j-1)*nCovSea(1)),j=1,nCovSea(2)) c END DO c WRITE(6,2006)nCovSea c ------------------------------------------------------------------ c DO i = 1, nCovTre(1), nCovTre(1)-1 c WRITE(6,4001)(mCovTre(i+(j-1)*nCovTre(1)),j=1,nCovTre(2)) c END DO c WRITE(6,2006)nCovTre c ------------------------------------------------------------------ c DO i = 1, nCovSA(1), nCovSA(1)-1 c WRITE(6,4001)(mCovSA(i+(j-1)*nCovSA(1)),j=1,nCovSA(2)) c END DO c WRITE(6,2006)nCovSA c ------------------------------------------------------------------ c WRITE(6,4002)(mIrrPFlt(j,1),j=1,5) c WRITE(6,4002)(mIrrPFlt(nIrrPFlt(2)-5+j,1),j=1,5) c WRITE(6,4002)(mIrrPFlt(j,2),j=1,5) c WRITE(6,4002)(mIrrPFlt(nIrrPFlt(2)-5+j,2),j=1,5) c WRITE(6,4002)(mSeaPFlt(j,1),j=1,5) c WRITE(6,4002)(mSeaPFlt(nSeaPFlt(2)-5+j,1),j=1,5) c WRITE(6,4002)(mSeaPFlt(j,2),j=1,5) c WRITE(6,4002)(mSeaPFlt(nSeaPFlt(2)-5+j,2),j=1,5) c WRITE(6,4002)(mTrePFlt(j,1),j=1,5) c WRITE(6,4002)(mTrePFlt(nTrePFlt(2)-5+j,1),j=1,5) c WRITE(6,4002)(mTrePFlt(j,2),j=1,5) c WRITE(6,4002)(mTrePFlt(nTrePFlt(2)-5+j,2),j=1,5) c ------------------------------------------------------------------ 4000 FORMAT( ' Output from extSgnl. ', /) c4001 FORMAT( 300(1x,F11.5), /) c4002 FORMAT( 100(6(1x,G12.5),/), /) c4006 FORMAT( ) c----------------------------------------------------------------------- c compMSE processing c----------------------------------------------------------------------- CALL compMSE( nT, dS, dT, lSeaPre, dDel, nDel, dDelS, nDelS, & dDelT, nDelT, DSQRT(Var), mSigUI, nSigUI, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW, lInvSig, & mIrrVar, nIrrVar, mSeaVar, nSeaVar, & mTreVar, nTreVar ) curMSEs(1) = ZERO curMSEs(2) = mSeaVar(nT*nT) curMSEs(3) = mTreVar(nT*nT) nRevs = min( nT,60) DO i=0,nRevs-1 lCurMSEs(nRevs-i,1) = mSeaVar( (nT-i-1)*nT + (nT-i) ) lCurMSEs(nRevs-i,2) = mTreVar( (nT-i-1)*nT + (nT-i) ) END DO c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,4100) c ------------------------------------------------------------------ c WRITE(6,4002)(mIrrVar((j-1)*nT+j),j=1,nT) c WRITE(6,4006) c ------------------------------------------------------------------ c WRITE(6,4002)(mSeaVar((j-1)*nT+j),j=1,nT) c WRITE(6,4006) c ------------------------------------------------------------------ c WRITE(6,4002)(mTreVar((j-1)*nT+j),j=1,nT) c WRITE(6,4006) c ------------------------------------------------------------------ * 4100 FORMAT( ' Output from compMSE. ', /) c----------------------------------------------------------------------- c compMSEAlt processing c----------------------------------------------------------------------- c call compMSEAlt( nT, dS, dT, mDel, nDel, mDelS, nDelS, c & mDelT, nDelT, sIrrVar, DSQRT(Var), c & mSigWS, nSigWS, mSigWT, nSigWT, c & mInvSigW, nInvSigW, mIrrVar, nIrrVar, c & mSeaVar, nSeaVar, mTreVar, nTreVar ) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,4200) c ------------------------------------------------------------------ c WRITE(6,4002)(mIrrVar((j-1)*nT+j),j=1,nT) c WRITE(6,4006) c ------------------------------------------------------------------ c WRITE(6,4002)(mSeaVar((j-1)*nT+j),j=1,nT) c WRITE(6,4006) c ------------------------------------------------------------------ c WRITE(6,4002)(mTreVar((j-1)*nT+j),j=1,nT) c WRITE(6,4006) c ------------------------------------------------------------------ c4200 FORMAT( ' Output from compMSEAlt. ', /) c----------------------------------------------------------------------- c compDiag processing c----------------------------------------------------------------------- c CALL compDiag( nT, dS, dT, nPer, nParam, nFixed, nDiff, c & DSQRT(Var), sInnovSd, vIrrEst, nIrrEst, c & vSeaEst, nSeaEst, vTreEst, nTreEst, c & dDelS, nDelS, dDelT, nDelT, c & mCovIrr, nCovIrr, mCovSea, nCovSea, c & mCovTre, nCovTre, mCovSA, nCovSA, c & fulEst, noeEst, fulEso, noeEso, c & fulVar, noeVar, fulDia, noeDia ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ c lag = 0 c Facfiem(lag)=fulEst(1) c Facfsem(lag)=fulEst(2) c Facfpem(lag)=fulEst(3) c Facfaem(lag)=fulEst(4) c Nacfiem(lag)=noeEst(1) c Nacfsem(lag)=noeEst(2) c Nacfpem(lag)=noeEst(3) c Nacfaem(lag)=noeEst(4) c ------------------------------------------------------------------ c Facfier(lag)=fulEso(1) c Facfser(lag)=fulEso(2) c Facfper(lag)=fulEso(3) c Facfaer(lag)=fulEso(4) c Nacfier(lag)=noeEso(1) c Nacfser(lag)=noeEso(2) c Nacfper(lag)=noeEso(3) c Nacfaer(lag)=noeEso(4) c ------------------------------------------------------------------ c Facfidg(lag)=fulDia(1) c Facfsdg(lag)=fulDia(2) c Facfpdg(lag)=fulDia(3) c Facfadg(lag)=fulDia(4) c Nacfidg(lag)=noeDia(1) c Nacfsdg(lag)=noeDia(2) c Nacfpdg(lag)=noeDia(3) c Nacfadg(lag)=noeDia(4) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c fulPva(1) = (ONE - gauss( fulDia(1) ))/TWO c fulPva(2) = (ONE - gauss( fulDia(2) ))/TWO c fulPva(3) = (ONE - gauss( fulDia(3) ))/TWO c fulPva(4) = (ONE - gauss( fulDia(4) ))/TWO c noePva(1) = (ONE - gauss( noeDia(1) ))/TWO c noePva(2) = (ONE - gauss( noeDia(2) ))/TWO c noePva(3) = (ONE - gauss( noeDia(3) ))/TWO c noePva(4) = (ONE - gauss( noeDia(4) ))/TWO c ------------------------------------------------------------------ c WRITE(6,5000) c WRITE(6,5001)fulEst(1), fulEst(2), fulEst(3), fulEst(4) c WRITE(6,5001)noeEst(1), noeEst(2), noeEst(3), noeEst(4) c WRITE(6,5001)fulEso(1), fulEso(2), fulEso(3), fulEso(4) c WRITE(6,5001)noeEso(1), noeEso(2), noeEso(3), noeEso(4) c WRITE(6,5001)fulVar(1), fulVar(2), fulVar(3), fulVar(4) c WRITE(6,5001)noeVar(1), noeVar(2), noeVar(3), noeVar(4) c WRITE(6,5001)fulDia(1), fulDia(2), fulDia(3), fulDia(4) c WRITE(6,5001)noeDia(1), noeDia(2), noeDia(3), noeDia(4) c WRITE(6,5001)fulPva(1), fulPva(2), fulPva(3), fulPva(4) c WRITE(6,5001)noePva(1), noePva(2), noePva(3), noePva(4) c ------------------------------------------------------------------ c5000 FORMAT( ' Output from compDiag. ', /) * 5001 FORMAT( 4(1x,G17.8), /) c----------------------------------------------------------------------- c compLagDiag(0) processing - same as compDiag() c----------------------------------------------------------------------- lag = 0 CALL compLagDiag( lag, nT, dS, dT, nPer, & finfact, sInnovSd, vIrrEst, nIrrEst, & vSeaEst, nSeaEst, vTreEst, nTreEst, & dDelS, nDelS, dDelT, nDelT, & mCovIrr, nCovIrr, mCovSea, nCovSea, & mCovTre, nCovTre, mCovSA, nCovSA, & fulEst, noeEst, fulEso, noeEso, & fulVar, noeVar, fulDia, noeDia ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ Facfiem(lag)=fulEst(1) Facfsem(lag)=fulEst(2) Facfpem(lag)=fulEst(3) Facfaem(lag)=fulEst(4) Nacfiem(lag)=noeEst(1) Nacfsem(lag)=noeEst(2) Nacfpem(lag)=noeEst(3) Nacfaem(lag)=noeEst(4) c ------------------------------------------------------------------ Facfier(lag)=fulEso(1) Facfser(lag)=fulEso(2) Facfper(lag)=fulEso(3) Facfaer(lag)=fulEso(4) Nacfier(lag)=noeEso(1) Nacfser(lag)=noeEso(2) Nacfper(lag)=noeEso(3) Nacfaer(lag)=noeEso(4) c ------------------------------------------------------------------ Facfidg(lag)=fulDia(1) Facfsdg(lag)=fulDia(2) Facfpdg(lag)=fulDia(3) Facfadg(lag)=fulDia(4) Nacfidg(lag)=noeDia(1) Nacfsdg(lag)=noeDia(2) Nacfpdg(lag)=noeDia(3) Nacfadg(lag)=noeDia(4) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c fulPva(1) = (ONE - gauss( fulDia(1) ))/TWO c fulPva(2) = (ONE - gauss( fulDia(2) ))/TWO c fulPva(3) = (ONE - gauss( fulDia(3) ))/TWO c fulPva(4) = (ONE - gauss( fulDia(4) ))/TWO c noePva(1) = (ONE - gauss( noeDia(1) ))/TWO c noePva(2) = (ONE - gauss( noeDia(2) ))/TWO c noePva(3) = (ONE - gauss( noeDia(3) ))/TWO c noePva(4) = (ONE - gauss( noeDia(4) ))/TWO c ------------------------------------------------------------------ c WRITE(6,6000) c WRITE(6,5001)fulEst(1), fulEst(2), fulEst(3), fulEst(4) c WRITE(6,5001)noeEst(1), noeEst(2), noeEst(3), noeEst(4) c WRITE(6,5001)fulEso(1), fulEso(2), fulEso(3), fulEso(4) c WRITE(6,5001)noeEso(1), noeEso(2), noeEso(3), noeEso(4) c WRITE(6,5001)fulVar(1), fulVar(2), fulVar(3), fulVar(4) c WRITE(6,5001)noeVar(1), noeVar(2), noeVar(3), noeVar(4) c WRITE(6,5001)fulDia(1), fulDia(2), fulDia(3), fulDia(4) c WRITE(6,5001)noeDia(1), noeDia(2), noeDia(3), noeDia(4) c WRITE(6,5001)fulPva(1), fulPva(2), fulPva(3), fulPva(4) c WRITE(6,5001)noePva(1), noePva(2), noePva(3), noePva(4) c ------------------------------------------------------------------ * 6000 FORMAT( ' Output from compLagDiag(0). ', /) c----------------------------------------------------------------------- c getWghLagDiag(0) processing c----------------------------------------------------------------------- CALL getWghLagDia( lag, nT, dS, dT, nPer, & finfact, sInnovSd, vY, dDel, nDel, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & mSigUI, nSigUI, mSigUS, nSigUS, & mSigUT, nSigUT, mSigWT, nSigWT, & mInvSigW, nInvSigW, & wghEst, wghEso, wghVar, wghDia ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ Wacfiem(lag)=wghEst(1) Wacfsem(lag)=wghEst(2) Wacfpem(lag)=wghEst(3) Wacfaem(lag)=wghEst(4) c ------------------------------------------------------------------ Wacfier(lag)=wghEso(1) Wacfser(lag)=wghEso(2) Wacfper(lag)=wghEso(3) Wacfaer(lag)=wghEso(4) c ------------------------------------------------------------------ Wacfidg(lag)=wghDia(1) Wacfsdg(lag)=wghDia(2) Wacfpdg(lag)=wghDia(3) Wacfadg(lag)=wghDia(4) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,6100) c WRITE(6,5001)wghEst(1), wghEst(2), wghEst(3), wghEst(4) c WRITE(6,5001)wghEso(1), wghEso(2), wghEso(3), wghEso(4) c WRITE(6,5001)wghVar(1), wghVar(2), wghVar(3), wghVar(4) c WRITE(6,5001)wghDia(1), wghDia(2), wghDia(3), wghDia(4) c ------------------------------------------------------------------ * 6100 FORMAT( ' Output from getWghLagDiag(0). ', /) c----------------------------------------------------------------------- c compLagDiag(1) processing c----------------------------------------------------------------------- lag = 1 CALL compLagDiag( lag, nT, dS, dT, nPer, & finfact, sInnovSd, vIrrEst, nIrrEst, & vSeaEst, nSeaEst, vTreEst, nTreEst, & dDelS, nDelS, dDelT, nDelT, & mCovIrr, nCovIrr, mCovSea, nCovSea, & mCovTre, nCovTre, mCovSA, nCovSA, & fulEst, noeEst, fulEso, noeEso, & fulVar, noeVar, fulDia, noeDia ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ Facfiem(lag)=fulEst(1) Facfsem(lag)=fulEst(2) Facfpem(lag)=fulEst(3) Facfaem(lag)=fulEst(4) Nacfiem(lag)=noeEst(1) Nacfsem(lag)=noeEst(2) Nacfpem(lag)=noeEst(3) Nacfaem(lag)=noeEst(4) c ------------------------------------------------------------------ Facfier(lag)=fulEso(1) Facfser(lag)=fulEso(2) Facfper(lag)=fulEso(3) Facfaer(lag)=fulEso(4) Nacfier(lag)=noeEso(1) Nacfser(lag)=noeEso(2) Nacfper(lag)=noeEso(3) Nacfaer(lag)=noeEso(4) c ------------------------------------------------------------------ Facfidg(lag)=fulDia(1) Facfsdg(lag)=fulDia(2) Facfpdg(lag)=fulDia(3) Facfadg(lag)=fulDia(4) Nacfidg(lag)=noeDia(1) Nacfsdg(lag)=noeDia(2) Nacfpdg(lag)=noeDia(3) Nacfadg(lag)=noeDia(4) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c fulPva(1) = (ONE - gauss( fulDia(1) ))/TWO c fulPva(2) = (ONE - gauss( fulDia(2) ))/TWO c fulPva(3) = (ONE - gauss( fulDia(3) ))/TWO c fulPva(4) = (ONE - gauss( fulDia(4) ))/TWO c noePva(1) = (ONE - gauss( noeDia(1) ))/TWO c noePva(2) = (ONE - gauss( noeDia(2) ))/TWO c noePva(3) = (ONE - gauss( noeDia(3) ))/TWO c noePva(4) = (ONE - gauss( noeDia(4) ))/TWO c ------------------------------------------------------------------ c WRITE(6,7000) c WRITE(6,5001)fulEst(1), fulEst(2), fulEst(3), fulEst(4) c WRITE(6,5001)noeEst(1), noeEst(2), noeEst(3), noeEst(4) c WRITE(6,5001)fulEso(1), fulEso(2), fulEso(3), fulEso(4) c WRITE(6,5001)noeEso(1), noeEso(2), noeEso(3), noeEso(4) c WRITE(6,5001)fulVar(1), fulVar(2), fulVar(3), fulVar(4) c WRITE(6,5001)noeVar(1), noeVar(2), noeVar(3), noeVar(4) c WRITE(6,5001)fulDia(1), fulDia(2), fulDia(3), fulDia(4) c WRITE(6,5001)noeDia(1), noeDia(2), noeDia(3), noeDia(4) c WRITE(6,5001)fulPva(1), fulPva(2), fulPva(3), fulPva(4) c WRITE(6,5001)noePva(1), noePva(2), noePva(3), noePva(4) c ------------------------------------------------------------------ * 7000 FORMAT( ' Output from compLagDiag(1). ', /) c----------------------------------------------------------------------- c getWghLagDiag(1) processing c----------------------------------------------------------------------- CALL getWghLagDia( lag, nT, dS, dT, nPer, & finfact, sInnovSd, vY, dDel, nDel, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & mSigUI, nSigUI, mSigUS, nSigUS, & mSigUT, nSigUT, mSigWT, nSigWT, & mInvSigW, nInvSigW, & wghEst, wghEso, wghVar, wghDia ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ Wacfiem(lag)=wghEst(1) Wacfsem(lag)=wghEst(2) Wacfpem(lag)=wghEst(3) Wacfaem(lag)=wghEst(4) c ------------------------------------------------------------------ Wacfier(lag)=wghEso(1) Wacfser(lag)=wghEso(2) Wacfper(lag)=wghEso(3) Wacfaer(lag)=wghEso(4) c ------------------------------------------------------------------ Wacfidg(lag)=wghDia(1) Wacfsdg(lag)=wghDia(2) Wacfpdg(lag)=wghDia(3) Wacfadg(lag)=wghDia(4) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,7100) c WRITE(6,5001)wghEst(1), wghEst(2), wghEst(3), wghEst(4) c WRITE(6,5001)wghEso(1), wghEso(2), wghEso(3), wghEso(4) c WRITE(6,5001)wghVar(1), wghVar(2), wghVar(3), wghVar(4) c WRITE(6,5001)wghDia(1), wghDia(2), wghDia(3), wghDia(4) c ------------------------------------------------------------------ * 7100 FORMAT( ' Output from getWghLagDiag(1). ', /) c----------------------------------------------------------------------- c compLagDiag(nPer) processing c----------------------------------------------------------------------- lag = nPer CALL compLagDiag( lag, nT, dS, dT, nPer, & finfact, sInnovSd, vIrrEst, nIrrEst, & vSeaEst, nSeaEst, vTreEst, nTreEst, & dDelS, nDelS, dDelT, nDelT, & mCovIrr, nCovIrr, mCovSea, nCovSea, & mCovTre, nCovTre, mCovSA, nCovSA, & fulEst, noeEst, fulEso, noeEso, & fulVar, noeVar, fulDia, noeDia ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ Facfiem(lag)=fulEst(1) Facfsem(lag)=fulEst(2) Facfpem(lag)=fulEst(3) Facfaem(lag)=fulEst(4) Nacfiem(lag)=noeEst(1) Nacfsem(lag)=noeEst(2) Nacfpem(lag)=noeEst(3) Nacfaem(lag)=noeEst(4) c ------------------------------------------------------------------ Facfier(lag)=fulEso(1) Facfser(lag)=fulEso(2) Facfper(lag)=fulEso(3) Facfaer(lag)=fulEso(4) Nacfier(lag)=noeEso(1) Nacfser(lag)=noeEso(2) Nacfper(lag)=noeEso(3) Nacfaer(lag)=noeEso(4) c ------------------------------------------------------------------ Facfidg(lag)=fulDia(1) Facfsdg(lag)=fulDia(2) Facfpdg(lag)=fulDia(3) Facfadg(lag)=fulDia(4) Nacfidg(lag)=noeDia(1) Nacfsdg(lag)=noeDia(2) Nacfpdg(lag)=noeDia(3) Nacfadg(lag)=noeDia(4) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c fulPva(1) = (ONE - gauss( fulDia(1) ))/TWO c fulPva(2) = (ONE - gauss( fulDia(2) ))/TWO c fulPva(3) = (ONE - gauss( fulDia(3) ))/TWO c fulPva(4) = (ONE - gauss( fulDia(4) ))/TWO c noePva(1) = (ONE - gauss( noeDia(1) ))/TWO c noePva(2) = (ONE - gauss( noeDia(2) ))/TWO c noePva(3) = (ONE - gauss( noeDia(3) ))/TWO c noePva(4) = (ONE - gauss( noeDia(4) ))/TWO c ------------------------------------------------------------------ c WRITE(6,8000) c WRITE(6,5001)fulEst(1), fulEst(2), fulEst(3), fulEst(4) c WRITE(6,5001)noeEst(1), noeEst(2), noeEst(3), noeEst(4) c WRITE(6,5001)fulEso(1), fulEso(2), fulEso(3), fulEso(4) c WRITE(6,5001)noeEso(1), noeEso(2), noeEso(3), noeEso(4) c WRITE(6,5001)fulVar(1), fulVar(2), fulVar(3), fulVar(4) c WRITE(6,5001)noeVar(1), noeVar(2), noeVar(3), noeVar(4) c WRITE(6,5001)fulDia(1), fulDia(2), fulDia(3), fulDia(4) c WRITE(6,5001)noeDia(1), noeDia(2), noeDia(3), noeDia(4) c WRITE(6,5001)fulPva(1), fulPva(2), fulPva(3), fulPva(4) c WRITE(6,5001)noePva(1), noePva(2), noePva(3), noePva(4) c ------------------------------------------------------------------ * 8000 FORMAT( ' Output from compLagDiag(nPer). ', /) c----------------------------------------------------------------------- c getWghLagDiag(nPer) processing c----------------------------------------------------------------------- CALL getWghLagDia( lag, nT, dS, dT, nPer, & finfact, sInnovSd, vY, dDel, nDel, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & mSigUI, nSigUI, mSigUS, nSigUS, & mSigUT, nSigUT, mSigWT, nSigWT, & mInvSigW, nInvSigW, & wghEst, wghEso, wghVar, wghDia ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ Wacfiem(lag)=wghEst(1) Wacfsem(lag)=wghEst(2) Wacfpem(lag)=wghEst(3) Wacfaem(lag)=wghEst(4) c ------------------------------------------------------------------ Wacfier(lag)=wghEso(1) Wacfser(lag)=wghEso(2) Wacfper(lag)=wghEso(3) Wacfaer(lag)=wghEso(4) c ------------------------------------------------------------------ Wacfidg(lag)=wghDia(1) Wacfsdg(lag)=wghDia(2) Wacfpdg(lag)=wghDia(3) Wacfadg(lag)=wghDia(4) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,8100) c WRITE(6,5001)wghEst(1), wghEst(2), wghEst(3), wghEst(4) c WRITE(6,5001)wghEso(1), wghEso(2), wghEso(3), wghEso(4) c WRITE(6,5001)wghVar(1), wghVar(2), wghVar(3), wghVar(4) c WRITE(6,5001)wghDia(1), wghDia(2), wghDia(3), wghDia(4) c ------------------------------------------------------------------ * 8100 FORMAT( ' Output from getWghLagDiag(nPer). ', /) c----------------------------------------------------------------------- c compCroDiag processing c----------------------------------------------------------------------- pLagSmT = max(dS-dT+1,1) CALL compCroDiag( nT, dS, dT, nPer, & finfact, sInnovSd, vIrrEst, nIrrEst, & vSeaEst, nSeaEst, vTreEst, nTreEst, & dDelS, nDelS, dDelT, nDelT, dDel, nDel, & dRedDelS, nRedDelS, dRedDelT, nRedDelT, & mInvSigW, nInvSigW, mSigUS, nSigUS, & mSigUT, nSigUT, mSigUI, nSigUI, & fulEst, fulEso, fulVar, fulDia, pLagSmT ) c ------------------------------------------------------------------ c Move the relevant results to common block output variables. c ------------------------------------------------------------------ seaIrrEst = fulEst(1) seaIrrEso = fulEso(1) seaIrrVar = fulVar(1) seaIrrDia = fulDia(1) c ------------------------------------------------------------------ seaTreEst = fulEst(2) seaTreEso = fulEso(2) seaTreVar = fulVar(2) seaTreDia = fulDia(2) c ------------------------------------------------------------------ treIrrEst = fulEst(3) treIrrEso = fulEso(3) treIrrVar = fulVar(3) treIrrDia = fulDia(3) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c fulPva(1) = (ONE - gauss( fulDia(1) ))/TWO c fulPva(2) = (ONE - gauss( fulDia(2) ))/TWO c fulPva(3) = (ONE - gauss( fulDia(3) ))/TWO c ------------------------------------------------------------------ c WRITE(6,9000) c WRITE(6,5001)fulEst(1), fulEst(2), fulEst(3) c WRITE(6,5001)fulEso(1), fulEso(2), fulEso(3) c WRITE(6,5001)fulVar(1), fulVar(2), fulVar(3) c WRITE(6,5001)fulDia(1), fulDia(2), fulDia(3) c WRITE(6,5001)fulPva(1), fulPva(2), fulPva(3) c ------------------------------------------------------------------ * 9000 FORMAT( ' Output from compCroDiag. ', /) c----------------------------------------------------------------------- c Filter square-gain/phase-delay processing (for Trend and SA) c----------------------------------------------------------------------- CALL procFlts( dS, dT, nT, nPer, mDelS, nDelS, & mSAPFlt, nSAPFlt, mTrePFlt, nTrePFlt ) c----------------------------------------------------------------------- c Semi-infinite Revision processing c----------------------------------------------------------------------- c Get Table 5.3 lag. c ------------------------------------------------------------------ CALL getTbl53Lag( nPer, iTbl53Lag ) c ------------------------------------------------------------------ c No revision processing for Irregular component. c ------------------------------------------------------------------ infMSEs(1)=ZERO infRevs(1)=ZERO c ------------------------------------------------------------------ c Revision processing for seasonal component. c ------------------------------------------------------------------ CALL CONV( vSeaAR, oSeaAR+1, vSeaD, oSeaD+1, vSeaARD, sSeaARD ) IF (( .not. dpeq(sSeaVar,ZERO) ) .and. & ( .not. dpeq(sSAVar,ZERO) )) THEN pd1 = max(sSeaARD-1,oSAAR,oMA) pd2 = max(oMA,oSAMA+sSeaARD-1) pd3 = max(nT+nPer-1+oSAMA,oSAAR,oMa-1) pd4 = max(oMa,oSAAR+oSeaMA) pd5 = max(nT+nPer-1+oSeaMA,sSeaARD-1,oMA-1) pd6 = max(sSeaARD-1+oSAMA,oSAAR+oSeaMA) pd7 = max(pd6,oMA) CALL getRevDecomp( vSeaARD, sSeaARD-1, vSAAR, oSAAR, & vSeaMA, oSeaMA, vSAMA, oSAMA, vMA, oMA, & nPer, iTbl53Lag, sInnovSd, sSeaVar, sSAVar, & nT-nRevs, nT+nPer-1,lInfMSEs(1,1), & lInfMSE1s(1,1), lInfMSE2s(1,1), & lInfMSE3s(1,1), pd1, pd2, pd3, pd4, pd5, & pd6, pd7 ) infMSEs(2) = lInfMSEs(nRevs,1) infRevs(2) = curMSEs(2) - lInfMSEs(nRevs,1) ELSE IF (( .not. dpeq(sSeaVar,ZERO) ) .and. & ( .not. dpeq(sIrrVar,ZERO) ) .and. & ( dpeq(sCycVar,ZERO) )) THEN pd1 = max(sSeaARD-1,oIrrAR,oMA) pd2 = max(oMA,oIrrMA+sSeaARD-1) pd3 = max(nT+nPer-1+oIrrMA,oIrrAR,oMa-1) pd4 = max(oMa,oIrrAR+oSeaMA) pd5 = max(nT+nPer-1+oSeaMA,sSeaARD-1,oMA-1) pd6 = max(sSeaARD-1+oIrrMA,oIrrAR+oSeaMA) pd7 = max(pd6,oMA) CALL getRevDecomp( vSeaARD, sSeaARD-1, vIrrAR, oIrrAR, & vSeaMA, oSeaMA, vIrrMA, oIrrMA, vMA, oMA, & nPer, iTbl53Lag, sInnovSd, sSeaVar, sIrrVar, & nT-nRevs, nT+nPer-1, lInfMSEs(1,1), & lInfMSE1s(1,1), lInfMSE2s(1,1), & lInfMSE3s(1,1), pd1, pd2, pd3, pd4, pd5, & pd6, pd7 ) infMSEs(2) = lInfMSEs(nRevs,1) infRevs(2) = curMSEs(2) - lInfMSEs(nRevs,1) ELSE infMSEs(2)=ZERO infRevs(2)=ZERO END IF c ------------------------------------------------------------------ c Revision processing for trend component. c ------------------------------------------------------------------ CALL CONV( vTreAR, oTreAR+1, vTreD, oTreD+1, vTreARD, sTreARD ) IF (( .not. dpeq(sTreVar,ZERO) ) .and. & ( .not. dpeq(sTAVar,ZERO) )) THEN pd1 = max(sTreARD-1,oTAAR,oMA) pd2 = max(oMA,sTreARD-1+oTAMA) pd3 = max(nT+nPer-1+oTAMA,oTAAR,oMa-1) pd4 = max(oMa,oTAAR+oTreMA) pd5 = max(nT+nPer-1+oTreMA,sTreARD-1,oMA-1) pd6 = max(sTreARD-1+oTAMA,oTAAR+oTreMA) pd7 = max(pd6,oMA) CALL getRevDecomp( vTreARD, sTreARD-1, vTAAR, oTAAR, & vTreMA, oTreMA, vTAMA, oTAMA, vMA, oMA, & nPer, iTbl53Lag, sInnovSd, sTreVar, sTAVar, & nT-nRevs, nT+nPer-1, lInfMSEs(1,2), & lInfMSE1s(1,2), lInfMSE2s(1,2), & lInfMSE3s(1,2), pd1, pd2, pd3, pd4, pd5, & pd6, pd7) infMSEs(3) = lInfMSEs(nRevs,2) infRevs(3) = curMSEs(3) - lInfMSEs(nRevs,2) ELSE IF (( .not. dpeq(sTreVar,ZERO) ) .and. & ( .not. dpeq(sIrrVar,ZERO) ) .and. & ( dpeq(sCycVar,ZERO) )) THEN pd1 = max(sTreARD-1,oIrrAR,oMA) pd2 = max(oMA,sTreARD-1+oIrrMA) pd3 = max(nT+nPer-1+oIrrMA,oIrrAR,oMa-1) pd4 = max(oMa,oIrrAR+oTreMA) pd5 = max(nT+nPer-1+oTreMA,sTreARD-1,oMA-1) pd6 = max(sTreARD-1+oIrrMA,oIrrAR+oTreMA) pd7 = max(pd6,oMA) CALL getRevDecomp( vTreARD, sTreARD-1, vIrrAR, oIrrAR, & vTreMA, oTreMA, vIrrMA, oIrrMA, vMA, oMA, & nPer, iTbl53Lag, sInnovSd, sTreVar, sIrrVar, & nT-nRevs, nT+nPer-1, lInfMSEs(1,2), & lInfMSE1s(1,2), lInfMSE2s(1,2), & lInfMSE3s(1,2), pd1, pd2, pd3, pd4, pd5, & pd6, pd7 ) infMSEs(3) = lInfMSEs(nRevs,2) infRevs(3) = curMSEs(3) - lInfMSEs(nRevs,2) ELSE infMSEs(3)=ZERO infRevs(3)=ZERO END IF c ------------------------------------------------------------------ c Calculate standard error of revisions for last 5 years. c ------------------------------------------------------------------ c Revision by BCM - only compute seRevs if the corresponding c infRevs are > ZERO - 4-11-2006 c ------------------------------------------------------------------ DO i=1,nRevs IF(infRevs(2).gt.ZERO)THEN seRevs(i,1) = lCurMSEs(i,1)-lInfMSEs(i,1) IF ( seRevs(i,1) .gt. ZERO ) THEN seRevs(i,1) = DSQRT( seRevs(i,1) )*sInnovSd ELSE seRevs(i,1) = ZERO END IF ELSE seRevs(i,1) = ZERO END IF IF(infRevs(3).gt.ZERO)THEN seRevs(i,2) = lCurMSEs(i,2)-lInfMSEs(i,2) IF ( seRevs(i,2) .gt. ZERO ) THEN seRevs(i,2) = DSQRT( seRevs(i,2) )*sInnovSd ELSE seRevs(i,2) = ZERO END IF ELSE seRevs(i,2) = ZERO END IF END DO c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,200) c WRITE(6,201)lInfMSEs(nRevs,1),lInfMSE1s(nRevs,1), c & lInfMSE2s(nRevs,1),lInfMSE3s(nRevs,1) c WRITE(6,201)lInfMSEs(nRevs,2),lInfMSE1s(nRevs,2), c & lInfMSE2s(nRevs,2),lInfMSE3s(nRevs,2) c WRITE(6,201)mSeaVar(nT*nT),mSeaVar(nT*nT-1), c & mSeaVar(nT*nT-nPer),mSeaVar(nT*nT-iTbl53Lag) c WRITE(6,201)mTreVar(nT*nT),mTreVar(nT*nT-1), c & mTreVar(nT*nT-nPer),mTreVar(nT*nT-iTbl53Lag) c 200 FORMAT(' getRevDecomp processing' ) c 201 FORMAT( 4( 1x, g12.5 ) ) c----------------------------------------------------------------------- c Growth Rate processing (for Trend and SA) c----------------------------------------------------------------------- CALL getGR( nT, dS, dT, nPer, dDel, nDel, dDelS, nDelS, & dDelT, nDelT, mInvSigUT, nInvSigUT, & mInvSigWT, nInvSigWT, mInvSigW, nInvSigW, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigWf, nSigWf, mSigWfW, nSigWfW, & mSeaVar, nSeaVar, mTreVar, nTreVar, & nRevs, lInfMSEs, lInfMSE1s, lInfMSE2s, lInfMSE3s, & sInnovSd, iTbl53Lag, & vSeaGRSE1, nSeaGRSE1, vTreGRSE1, nTreGRSE1, & vSeaGRSE2, nSeaGRSE2, vTreGRSE2, nTreGRSE2, & vTbl51, vTbl53, vTbl54, vTbl56, vTbl57 ) c ------------------------------------------------------------------ c Debug code. c WRITE(6,9001) c WRITE(6,9010)vTbl51(1),vTbl51(2) c WRITE(6,9010)vTbl51(3),vTbl51(4) c WRITE(6,9010)vTbl51(5),vTbl51(6) c WRITE(6,9010)DSQRT(vTbl51(5)),DSQRT(vTbl51(6)) c ------------------------------------------------------------------ c WRITE(6,9002) c DO i=1,nSeaGRSE1(1) c WRITE(6,9010)vSeaGRSE1(i),vTreGRSE1(i) c END DO c ------------------------------------------------------------------ c WRITE(6,9003) c WRITE(6,9010)vTbl53(1),vTbl53(2) c ------------------------------------------------------------------ c WRITE(6,9004) c WRITE(6,9010)vTbl54(1),vTbl54(2) c WRITE(6,9010)vTbl54(3),vTbl54(4) c WRITE(6,9010)vTbl54(5),vTbl54(6) c WRITE(6,9010)DSQRT(vTbl54(5)),DSQRT(vTbl54(6)) c ------------------------------------------------------------------ c WRITE(6,9005) c DO i=1,nSeaGRSE2(1) c WRITE(6,9010)vSeaGRSE2(i),vTreGRSE2(i) c END DO c ------------------------------------------------------------------ c WRITE(6,9006) c WRITE(6,9010)vTbl56(1,1),vTbl56(1,2),vTbl56(1,2)-vTbl56(1,1) c WRITE(6,9010)vTbl56(2,1),vTbl56(2,2) c WRITE(6,9010)vTbl56(3,1),vTbl56(3,2),vTbl56(3,2)-vTbl56(3,1) c WRITE(6,9010)vTbl56(4,1),vTbl56(4,2) c ------------------------------------------------------------------ 9010 FORMAT( 3( 1x, G12.5 ) ) 9001 FORMAT( /, ' Output from getGR: Table 5.1 ', /) 9002 FORMAT( /, ' Output from getGR: Table 5.2 ', /) 9003 FORMAT( /, ' Output from getGR: Table 5.3 ', /) 9004 FORMAT( /, ' Output from getGR: Table 5.4 ', /) 9005 FORMAT( /, ' Output from getGR: Table 5.5 ', /) 9006 FORMAT( /, ' Output from getGR: Table 5.6 ', /) c----------------------------------------------------------------------- c Finite Revision processing c----------------------------------------------------------------------- IF ( out .eq. 0 ) THEN CALL compRevs( dS, dT, nT, nPer, nDiff, lSeaPre, & nSave, nSave2, nSave3, & vSeaAR, oSeaAR, vSeaMA, oSeaMA, & vTreAR, oTreAR, vTreMA, oTreMA, & vCycAR, oCycAR, vCycMA, oCycMA, & vSeaD, oSeaD, vTreD, oTreD, & sSeaVar, sTreVar, sCycVar, sIrrVar, & mDelS, dDelS, nDelS, & mDelT, dDelT, nDelT, & mDel, dDel, nDel, & mRedDelS, dRedDelS, nRedDelS, & mRedDelT, dRedDelT, nRedDelT, & mSigUS, nSigUS, mSigUT, nSigUT, & mSigUI, nSigUI, mSigWS, nSigWS, & mSigWT, nSigWT, mSigW, nSigW, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigWf, nSigWf, mSigWfW, nSigWfW, & mInvSigUS, nInvSigUS, mInvSigUT, nInvSigUT, & mInvSigWS, nInvSigWS, mInvSigWT, nInvSigWT, & mInvSigW, nInvSigW, mIrrVar, nIrrVar, & mSeaVar, nSeaVar, mTreVar, nTreVar, & DSQRT(Var), curMSEs, finMSEs, finRevs ) c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,9100) c WRITE(6,9101)(infMSEs(i),i=1,3) c WRITE(6,9101)(infRevs(i),i=1,3) c WRITE(6,9101)(curMSEs(i),i=1,3) c WRITE(6,9101) c WRITE(6,9101)(finRevs(i,1)/infRevs(i),i=1,3) c WRITE(6,9101)(finRevs(i,2)/infRevs(i),i=1,3) c WRITE(6,9101)(finRevs(i,3)/infRevs(i),i=1,3) c WRITE(6,9101)(finRevs(i,4)/infRevs(i),i=1,3) c WRITE(6,9101)(finRevs(i,5)/infRevs(i),i=1,3) c DO j=1,5 c WRITE(6,9101)(finMSEs(i,j),i=1,3) c END DO c WRITE(6,9101) c ------------------------------------------------------------------ c Convert the revision variances to SEATS definition of c standard error of revisions. c ------------------------------------------------------------------ DO j=1,5 DO i=1,3 IF ( (infRevs(i) .gt. ZERO) .and. & (infRevs(i) .ge. finRevs(i,j)) ) THEN relRevs(i,j)=ONE-DSQRT((infRevs(i)-finRevs(i,j))/infRevs(i)) relRevs(i,j)=relRevs(i,j)*ONEP ELSE IF ( DABS(infRevs(i)-finRevs(i,j)) .lt. 1.0D-5 ) THEN relRevs(i,j)=ONEP ELSE relRevs(i,j)=ZERO END IF c WRITE(6,9101)infRevs(i),finRevs(i,j),finMSEs(i,j), c & finMSEs(i,j)-infMSEs(i) END DO c WRITE(6,9101)(relRevs(i,j),i=1,3) END DO c ------------------------------------------------------------------ c Debug code. c ------------------------------------------------------------------ c WRITE(6,9101) c DO i=1,nRevs,6 c WRITE(6,9101)(lCurMSEs(j,1)-lInfMSEs(j,1),j=i,min(i+5,nRevs)) c END DO c WRITE(6,9101) c DO i=1,nRevs,6 c WRITE(6,9101)(lCurMSEs(j,2)-lInfMSEs(j,2),j=i,min(i+5,nRevs)) c END DO c ------------------------------------------------------------------ * 9100 FORMAT( ' Output from Revision processing. ', /) * 9101 FORMAT( 6( 1x, G12.5 ) ) * 9102 FORMAT( 1x, a, 6( 1x, G12.5 ) ) END IF RETURN ENDgetfcn.f0000664006604000003110000000643514521201503011607 0ustar sun00315stepsC Last change: BCM 23 Jul 1998 3:37 pm LOGICAL FUNCTION getfcn(Fcns,Fcnptr,Nfcns,Fcnidx,Fcnlog,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c getfcn.f, Release 1, Subroutine Version 1.4, Modified 1/3/95. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'notset.prm' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------ CHARACTER Fcns*(*),fname*(LINLEN),linnum*5,colnum*5 LOGICAL argok,Inptok INTEGER fcnpos,Fcnptr,Nfcns,Fcnidx,nfname,Fcnlog,ilin,icol DIMENSION fcnpos(2),Fcnptr(0:Nfcns),Fcnlog(2,Nfcns) c----------------------------------------------------------------------- DO WHILE (T) c----------------------------------------------------------------------- IF(Nxtktp.eq.EOF)THEN getfcn=F c----------------------------------------------------------------------- ELSE getfcn=T fname=Nxttok(1:Nxtkln) nfname=Nxtkln CALL cpyint(Lstpos,2,1,fcnpos) c----------------------------------------------------------------------- CALL gtdcnm(Fcns,Fcnptr,Nfcns,Fcnidx,argok) c----------------------------------------------------------------------- IF(.not.argok)THEN CALL inpter(PERROR,fcnpos, & 'Expected specification name but found "'// & fname(1:nfname)//'"') Inptok=F CALL skpfcn(fname,nfname) c----------------------------------------------------------------------- c Added by BCM 12/28/94 c----------------------------------------------------------------------- GO TO 10 c----------------------------------------------------------------------- ELSE IF(Fcnidx.eq.0)THEN CALL inpter(PERROR,fcnpos,fname(1:nfname)// & ' is not a valid spec name.') Inptok=F CALL skpfcn(fname,nfname) GO TO 10 c----------------------------------------------------------------------- ELSE IF(Nxtktp.eq.EOF)getfcn=F IF(Nxtktp.ne.LBRACE)THEN CALL inpter(PERROR,Lstpos,' Expected "{" but found '// & Nxttok(1:Nxtkln)) Inptok=F CALL skpfcn(fname,nfname) GO TO 10 ELSE IF(Fcnlog(PLINE,Fcnidx).ne.NOTSET)THEN ilin=1 CALL itoc(Fcnlog(PLINE,Fcnidx),linnum,ilin) icol=1 CALL itoc(Fcnlog(PCHAR,Fcnidx),colnum,icol) CALL inpter(PERROR,fcnpos,fname(1:nfname)// & ' also found on line '//linnum(1:(ilin-1))// & ' position '//colnum(1:(icol-1))// & ' of the input file.') Inptok=F CALL skpfcn(fname,nfname) GO TO 10 ELSE Fcnlog(PLINE,Fcnidx)=fcnpos(PLINE) Fcnlog(PCHAR,Fcnidx)=fcnpos(PCHAR) CALL lex() END IF END IF END IF END IF c----------------------------------------------------------------------- RETURN 10 CONTINUE END DO END getfrc.f0000664006604000003110000002644714521201503011620 0ustar sun00315steps SUBROUTINE getfrc(Havesp,Iyrt,Lrndsa,Iftrgt,Begyrt,Mid,Lamda,Rol, & Sp,Lindfr,Lfctfr,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Get the seasonal adjustment options for X-13ARIMA-SEATS. c---------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'tbllog.i' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO,PT9,THREE,MINUS3 LOGICAL T,F PARAMETER(T=.true.,F=.false.,ONE=1D0,ZERO=0D0,PT9=0.9D0,THREE=3D0, & MINUS3=-3D0) c----------------------------------------------------------------------- DOUBLE PRECISION dvec,Lamda,Rol LOGICAL argok,Inptok,Lrndsa,Havesp,Lfctfr,Lindfr INTEGER Sp,nelt,Begyrt,Iftrgt,Iyrt,ivec,Mid DIMENSION dvec(1),ivec(1) c----------------------------------------------------------------------- LOGICAL gtarg,dpeq EXTERNAL gtarg,dpeq c----------------------------------------------------------------------- c arguments for force spec. c----------------------------------------------------------------------- CHARACTER ARGDIC*57 INTEGER argidx,argptr,PARG,arglog PARAMETER(PARG=11) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='typeroundtargetstartlambdarhomodeprintsaveindfor &ceusefcst') c----------------------------------------------------------------------- c type data dictionary c----------------------------------------------------------------------- CHARACTER FRCDIC*17 INTEGER frcptr,PFRC PARAMETER(PFRC=3) DIMENSION frcptr(0:PFRC) PARAMETER(FRCDIC='nonedentonregress') c----------------------------------------------------------------------- c forcesums data dictionary c----------------------------------------------------------------------- CHARACTER SUMDIC*118 INTEGER sumptr,PSUM PARAMETER(PSUM=28) DIMENSION sumptr(0:PSUM) PARAMETER(SUMDIC= &'janfebmaraprmayjunjulaugsepoctnovdecjanuaryfebruarymarchaprilmayj &unejulyaugustseptemberoctobernovemberdecemberq1q2q3q4') c----------------------------------------------------------------------- c data dictionary of yes/no choice c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- c data dictionary of ratio/diff choice c----------------------------------------------------------------------- CHARACTER FMDDIC*9 INTEGER fmdptr,PFMD PARAMETER(PFMD=2) DIMENSION fmdptr(0:PFMD) PARAMETER(FMDDIC='ratiodiff') c ------------------------------------------------------------------ c data dictionary for force target c ------------------------------------------------------------------ CHARACTER FRTDIC*35 INTEGER frtptr,PFRT PARAMETER(PFRT=4) DIMENSION frtptr(0:PFRT) PARAMETER(FRTDIC='originalcalendaradjpermprioradjboth') c ------------------------------------------------------------------ c Define data dictionary pointers c ------------------------------------------------------------------ DATA argptr/1,5,10,16,21,27,30,34,39,43,51,58/ DATA sumptr/1,4,7,10,13,16,19,22,25,28,31,34,37,44,52,57,62,65,69, & 73,79,88,95,103,111,113,115,117,119/ DATA ysnptr/1,4,6/ DATA frcptr/1,5,11,18/ DATA fmdptr/1,6,10/ DATA frtptr/1,9,20,32,36/ c ------------------------------------------------------------------ argok=T CALL setint(NOTSET,2*PARG,arglog) DO WHILE (T) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,Inptok))THEN IF(Lfatal)RETURN GO TO(10,20,30,40,90,100,110,120,130,70,80),argidx c----------------------------------------------------------------------- c type argument c----------------------------------------------------------------------- 10 CALL gtdcvc(LPAREN,T,1,FRCDIC,frcptr,PFRC, & 'Entry for type argument must be none, denton or regress.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Iyrt=ivec(1)-1 GO TO 140 c----------------------------------------------------------------------- c round argument c----------------------------------------------------------------------- 20 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for round are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lrndsa=ivec(1).eq.1 GO TO 140 c----------------------------------------------------------------------- c forcetarget argument c----------------------------------------------------------------------- 30 CALL gtdcvc(LPAREN,T,1,FRTDIC,frtptr,PFRT, & 'Entry for forcetarget argument must be original, calendaradj,', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(.not.argok) & CALL writln(' permprioradj, or both.',STDERR,Mt2,F) IF(argok.and.nelt.gt.0)Iftrgt=ivec(1)-1 GO TO 140 c----------------------------------------------------------------------- c start argument c----------------------------------------------------------------------- 40 CALL gtdcvc(LPAREN,T,1,SUMDIC,sumptr,PSUM, & 'Choices for start are the name of a month or quarter.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(.not.Havesp)THEN CALL inpter(PERROR,Errpos, & 'No seasonal period specified in series spec.') Inptok=F ELSE IF(ivec(1).ge.1.and.ivec(1).le.24.and.Sp.eq.12)THEN Begyrt=ivec(1) IF(ivec(1).gt.12)Begyrt=Begyrt-12 ELSE IF(ivec(1).ge.25.and.ivec(1).le.28.and.Sp.eq.4)THEN Begyrt=ivec(1)-24 ELSE IF(Sp.eq.12)THEN CALL inpter(PERROR,Errpos,'This entry for start only valid f &or monthly data.') ELSE CALL inpter(PERROR,Errpos,'This entry for start only valid f &or quarterly data.') END IF Inptok=F END IF END IF END IF GO TO 140 c----------------------------------------------------------------------- c indforce argument c----------------------------------------------------------------------- 70 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for indforce are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lindfr=ivec(1).eq.1 GO TO 140 c----------------------------------------------------------------------- c usefcst argument c----------------------------------------------------------------------- 80 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for usefcst are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lfctfr=ivec(1).eq.1 GO TO 140 c----------------------------------------------------------------------- c lambda argument c----------------------------------------------------------------------- 90 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Error Checking for lambda c----------------------------------------------------------------------- IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.MINUS3.or.dvec(1).gt.THREE)THEN CALL inpter(PERROR,Errpos, & 'Value of lambda must be between -3 and 3.') Inptok=F ELSE Lamda=dvec(1) END IF END IF GO TO 140 c----------------------------------------------------------------------- c rho argument c----------------------------------------------------------------------- 100 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Error Checking for rho c----------------------------------------------------------------------- IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO.or.dvec(1).gt.ONE.or.dpeq(dvec(1),ZERO))THEN CALL inpter(PERROR,Errpos,'Value of rho must be greater than 0 & and less than or equal to 1.') Inptok=F ELSE Rol=dvec(1) END IF END IF GO TO 140 c----------------------------------------------------------------------- c mode argument c----------------------------------------------------------------------- 110 CALL gtdcvc(LPAREN,T,1,FMDDIC,fmdptr,PFMD, & 'Available options for mode are ratio or diff.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Mid=ivec(1)-1 GO TO 140 c----------------------------------------------------------------------- c print argument c----------------------------------------------------------------------- 120 CALL getprt(LSPFRC,NSPFRC,Inptok) GO TO 140 c----------------------------------------------------------------------- c save argument c----------------------------------------------------------------------- 130 CALL getsav(LSPFRC,NSPFRC,Inptok) GO TO 140 c ------------------------------------------------------------------ END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(Iyrt.eq.NOTSET)THEN IF((.not.dpeq(Lamda,DNOTST)).or.(.not.dpeq(Rol,DNOTST)).or. * (Mid.ne.NOTSET))THEN Iyrt=2 ELSE IF((Begyrt.ne.NOTSET).or.(Iftrgt.ne.NOTSET))THEN Iyrt=1 ELSE Iyrt=0 END IF END IF c----------------------------------------------------------------------- IF(Iyrt.le.0)THEN Iftrgt=0 Begyrt=0 ELSE IF(Iftrgt.eq.NOTSET)Iftrgt=0 IF(Begyrt.eq.NOTSET)Begyrt=1 IF(Iyrt.eq.2)THEN IF(dpeq(Lamda,DNOTST))Lamda=ZERO IF(dpeq(Rol,DNOTST))THEN Rol=PT9 IF(Sp.ne.12)Rol=PT9**(12D0/dble(Sp)) END IF END IF END IF c----------------------------------------------------------------------- Inptok=Inptok.and.argok c----------------------------------------------------------------------- RETURN 140 CONTINUE END DO c ------------------------------------------------------------------ END getgr.f0000664006604000003110000013071314521201503011446 0ustar sun00315steps SUBROUTINE getGR( nT, dS, dT, nPer, dDel, nDel, dDelS, nDelS, & dDelT, nDelT, mInvSigUT, nInvSigUT, & mInvSigWT, nInvSigWT, mInvSigW, nInvSigW, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigWf, nSigWf, mSigWfW, nSigWfW, & mSeaVar, nSeaVar, mTreVar, nTreVar, & nRevs, infMSEs, infMSE1s, infMSE2s, infMSE3s, & sdSig, tbl53Lag, & vSeaGRSE1, nSeaGRSE1, vTreGRSE1, nTreGRSE1, & vSeaGRSE2, nSeaGRSE2, vTreGRSE2, nTreGRSE2, & vTbl51, vTbl53, vTbl54, vTbl56, vTbl57 ) c----------------------------------------------------------------------- c getGR.f, Release 1, Subroutine Version 1.0, Created 14 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 14 Apr 2006. c Modified by REG, on 26 May 2006, to add error processing c of square SEs numerically less than zero. c----------------------------------------------------------------------- c This subroutine calculates some growth rate MSEs and SEs per c McElroy's paper "Model-Based Formulas for Growth Rates and their c Standard Errors" in order to generate tables 5.1 through 5.7. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dDel d diagonal form of overall differencing matrix: mDel c dDelS d diagonal form of seasonal differencing matrix: mDelS c dDelT d diagonal form of trend differencing matrix: mDelT c dS i size of Seasonal Differencing c dT i size of Trend Differencing c infMSEs d lag 0 MSEs for component estimates for the last five years c and the next year: first column for seasonal, c second column for trend c infMSE1s d lag 1 MSEs for component estimates for the last five years c and the next year: first column for seasonal, c second column for trend c infMSE2s d lag nPer MSEs for component estimates c for the last five years and the next year: c first column for seasonal, second column for trend c infMSE3s d lag iTbl53Lag MSEs for component estimates c for the last five years and the next year: c first column for seasonal, second column for trend c mInvSigUT d inverse of mSigUT: covariance matrix c for trend differenced trend component c mInvSigW d inverse of mSigW: covariance matrix for differenced data c mInvSigWT d inverse of mSigWT: covariance matrix c for trend differenced seasonal adjusted component c mSeaVar d variance matrix of estimated seasonal c mSigUT d covariance matrix for differenced trend (UT) c mSigUTf d covariance matrix for future differenced trend (UTf) c mSigUTfUT d cross covariance matrix for (UTf,UT) c mSigW d covariance matrix for differenced data (W) c mSigWf d covariance matrix for future differenced data (Wf) c mSigWfW d cross covariance matrix for (Wf,W) c mSigWT d covariance matrix for differenced seasonally adjusted (WT) c mSigWTf d covariance matrix for future differenced seasonally c adjusted (WTf) c mSigWTfWT d cross covariance matrix for (WTf,WT) c mTreVar d variance matrix of estimated trend c nDel i size (rows,columns) of mDel c nDelS i size (rows,columns) of mDelS c nDelT i size (rows,columns) of mDelT c nInvSigUT i size (rows,columns) of mInvSigUT matrix c nInvSigW i size (rows,columns) of mInvSigW matrix c nInvSigWT i size (rows,columns) of mInvSigWT matrix c nPer i size of seasonal period c nRevs i row index in infMSExs associated c with last observation c nSeaGRSE1 i size (rows,columns) of vSeaGRSE1 vector c nSeaGRSE2 i size (rows,columns) of vSeaGRSE2 vector c nSeaVar i size (rows,columns) of mSeaVar matrix c nSigUT i size (rows,columns) of mSigUT matrix c nSigUTf i size (rows,columns) of mSigUTf matrix c nSigUTfUT i size (rows,columns) of mSigUTfUT matrix c nSigW i size (rows,columns) of mSigW matrix c nSigWf i size (rows,columns) of mSigWf matrix c nSigWfW i size (rows,columns) of mSigWfW matrix c nSigWT i size (rows,columns) of mSigWT matrix c nSigWTf i size (rows,columns) of mSigWTf matrix c nSigWTfWT i size (rows,columns) of mSigWTfWT matrix c nT i size of data available c nTreGRSE1 i size (rows,columns) of vTreGRSE1 vector c nTreGRSE2 i size (rows,columns) of vTreGRSE2 vector c nTreVar i size (rows,columns) of mTreVar matrix c sdSig d data innovation stdev c tbl53Lag i lag between last observation of data and last observation c of previous year c vSeaGRSE1 d vector of seasonal component growth rate SEs for table 5.2 c vSeaGRSE2 d vector of seasonal component growth rate SEs for table 5.5 c vTbl51 d vector of table 5.1 MSEs c vTbl53 d vector of table 5.3 SEs c vTbl54 d vector of table 5.4 MSEs c vTbl56 d vector of table 5.6 SEs c vTbl57 d vector of table 5.7 SEs c vTreGRSE1 d vector of trend component growth rate SEs for table 5.2 c vTreGRSE2 d vector of trend component growth rate SEs for table 5.5 c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c DSqrtOr0 d external function reference c finMSE i variable used to calculate finite sample MSE part c of growth rate c i1 i finite sample index of base entry in growth rate c i1m i semi-infinite sample index of base entry in growth rate c i2 i finite sample index of second entry in growth rate c i2m i semi-infinite sample index of second entry in growth rate c infMSE i variable used to calculate semi-finite sample MSE part c of growth rate c j i do loop index variable c nSigSAf i size (rows,columns) of mSigSAf matrix c nSigSAfSA i size (rows,columns) of mSigSAfSA matrix c nSigTf i size (rows,columns) of mSigTf matrix c nSigTfT i size (rows,columns) of mSigTfT matrix c nSigYf i size (rows,columns) of mSigYf matrix c mSigSAf d covariance matrix for residuals of forecasts of future c seasonal adjustment (SAf) c mSigSAfSA d cross covariance matrix of (SAf,SA) c mSigTf d covariance matrix for residuals of forecasts of future c trend (Tf) c mSigTfT d cross covariance matrix of (Tf,T) c mSigYf d covariance matrix for residuals of forecasts of future c observations (Yf) c num i identifies maximum number of entries in tables 5.2 and 5.5 c num1 i size of table 5.2 (vSeaGRSE1 and vTreGRSE1 vectors) c num2 i size of table 5.5 (vSeaGRSE2 and vTreGRSE2 vectors) c nSave2 i size of local large matrices c varSig d data innovation variance c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER dS, dT, nPer, nRevs, nT, tbl53Lag INTEGER nDel(2), nDelS(2), nDelT(2) INTEGER nInvSigUT(2), nInvSigWT(2), nInvSigW(2) INTEGER nSigUTf(2), nSigUTfUT(2), nSigWTf(2), nSigWTfWT(2), & nSigWf(2), nSigWfW(2) INTEGER nSeaVar(2), nTreVar(2) INTEGER nSeaGRSE1(2), nSeaGRSE2(2), nTreGRSE1(2), nTreGRSE2(2) DOUBLE PRECISION sdSig DOUBLE PRECISION dDel(dS+dT+1), dDelS(dS+1), dDelT(dT+1) DOUBLE PRECISION mInvSigUT(nT-dT,nT-dT), mInvSigWT(nT-dT,nT-dT), & mInvSigW(nT-dS-dT,nT-dS-dT) DOUBLE PRECISION mSigUTf(nPer,nPer), mSigUTfUT(nPer,nT-dT) * DOUBLE PRECISION mSigWTf(nPer,nPer), mSigWTfWT(nPer,nT-dS) DOUBLE PRECISION mSigWTf(nPer,nPer), mSigWTfWT(nPer,nT-dT) DOUBLE PRECISION mSigWf(nPer,nPer), mSigWfW(nPer,nT-dS-dT) DOUBLE PRECISION mSeaVar(nT,nT), mTreVar(nT,nT) DOUBLE PRECISION vSeaGRSE1(nT-1), vTreGRSE1(nT-1) DOUBLE PRECISION vSeaGRSE2(nT-1), vTreGRSE2(nT-1) DOUBLE PRECISION infMSEs(72,2), infMSE1s(72,2) DOUBLE PRECISION infMSE2s(72,2), infMSE3s(72,2) DOUBLE PRECISION vTbl51(6), vTbl53(2), vTbl54(6), vTbl56(6,2), & vTbl57(3,3) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i1, i1m, i2, i2m, j INTEGER num, num1, num2, nSave2 INTEGER nSigTf(2), nSigTfT(2), nSigSAf(2), nSigSAfSA(2), nSigYf(2) PARAMETER (nSave2=12*POBS) DOUBLE PRECISION varSig DOUBLE PRECISION mSigTf(nPer,nPer), mSigTfT(nSave2) DOUBLE PRECISION mSigSAf(nPer,nPer), mSigSAfSA(nSave2) DOUBLE PRECISION mSigYf(nPer,nPer) DOUBLE PRECISION finMSE, infMSE, ZERO DOUBLE PRECISION DSqrtOr0 PARAMETER (ZERO=0.0d0) SAVE mSigTfT, mSigSAfSA c----------------------------------------------------------------------- c Determine max size of tables 5.2 and 5.5 based on nPer. c----------------------------------------------------------------------- IF (nPer .eq. 12) THEN num = 36 ELSE IF (nPer .eq. 6) THEN num = 18 ELSE IF (nPer .eq. 4) THEN num = 12 ELSE num = 8 END IF varSig = sdSig**2 c----------------------------------------------------------------------- c Calculate Table 5.1 MSEs for last 2 months in sample using one c period (current month minus previous month) growth rates. c----------------------------------------------------------------------- c Identify one period behind growth rate indexes c for last month in data minus previous period. c ------------------------------------------------------------------ i1 = nT i1m = i1-1 i2 = nRevs i2m = i2-1 c ------------------------------------------------------------------ c Calculate one period behind growth rate SEs for the trend and c seasonal adjustment. c ------------------------------------------------------------------ vTbl51(1) = varSig * & (infMSEs(i2,2) + infMSEs(i2m,2) - 2.0d0*infMSE1s(i2m,2)) vTbl51(5) = varSig * & (mTreVar(i1,i1) + mTreVar(i1m,i1m) - 2.0d0*mTreVar(i1m,i1)) vTbl51(3) = vTbl51(5) - vTbl51(1) c ------------------------------------------------------------------ vTbl51(2) = varSig * & (infMSEs(i2,1) + infMSEs(i2m,1) - 2.0d0*infMSE1s(i2m,1)) vTbl51(6) = varSig * & (mSeaVar(i1,i1) + mSeaVar(i1m,i1m) - 2.0d0*mSeaVar(i1m,i1)) vTbl51(4) = vTbl51(6) - vTbl51(2) c----------------------------------------------------------------------- c Table 5.2 size restriction due to number of observations. c----------------------------------------------------------------------- IF (num .gt. nT-1) THEN num1 = nT-1 ELSE num1 = num END IF c----------------------------------------------------------------------- c Calculate Table 5.2 Standard Errors of Revision for each of the c desired periods using one period (current month minus previous c month) growth rates. c----------------------------------------------------------------------- c Identify size of table 5.2 vectors. c ------------------------------------------------------------------ nSeaGRSE1(1) = num1 nSeaGRSE1(2) = 1 nTreGRSE1(1) = num1 nTreGRSE1(2) = 1 c ------------------------------------------------------------------ c For each month in the table 5.2 c ------------------------------------------------------------------ DO j = 1, num1 c ------------------------------------------------------------------ c Identify one period behind growth rate indexes c for desired month in data minus previous period. c ------------------------------------------------------------------ i1 = nT-j+1 i1m = i1-1 i2 = nRevs-j+1 i2m = i2-1 c ------------------------------------------------------------------ c Calculate one period behind growth rate SEs for the trend and c seasonal adjustment. c ------------------------------------------------------------------ vSeaGRSE1(j) = & mSeaVar(i1,i1) + mSeaVar(i1m,i1m) - 2.0d0*mSeaVar(i1m,i1) & - infMSEs(i2,1) - infMSEs(i2m,1) + 2.0d0*infMSE1s(i2m,1) * vSeaGRSE1(j) = DSQRT( vSeaGRSE1(j) ) * sdSig vSeaGRSE1(j) = DSqrtOr0( vSeaGRSE1(j) ) * sdSig c ------------------------------------------------------------------ vTreGRSE1(j) = & mTreVar(i1,i1) + mTreVar(i1m,i1m) - 2.0d0*mTreVar(i1m,i1) & - infMSEs(i2,2) - infMSEs(i2m,2) + 2.0d0*infMSE1s(i2m,2) * vTreGRSE1(j) = DSQRT( vTreGRSE1(j) ) * sdSig vTreGRSE1(j) = DSqrtOr0( vTreGRSE1(j) ) * sdSig END DO c----------------------------------------------------------------------- c Calculate Table 5.3 Standard Errors of Revision using growth rate c from last month in data minus last month from previous year. c----------------------------------------------------------------------- c Identify growth rate indexes over current year c for last month in data minus last month in previous year. c ------------------------------------------------------------------ i1 = nT i1m = i1-tbl53Lag i2 = nRevs i2m = i2-tbl53Lag c ------------------------------------------------------------------ c Calculate current year growth rate SEs for the trend c and seasonal adjustment. c ------------------------------------------------------------------ vTbl53(1) = & mTreVar(i1,i1) + mTreVar(i1m,i1m) - 2.0d0*mTreVar(i1m,i1) & - infMSEs(i2,2) - infMSEs(i2m,2) + 2.0d0*infMSE3s(i2m,2) vTbl53(1) = DSqrtOr0( vTbl53(1) ) * sdSig c ------------------------------------------------------------------ vTbl53(2) = & mSeaVar(i1,i1) + mSeaVar(i1m,i1m) - 2.0d0*mSeaVar(i1m,i1) & - infMSEs(i2,1) - infMSEs(i2m,1) + 2.0d0*infMSE3s(i2m,1) vTbl53(2) = DSqrtOr0( vTbl53(2) ) * sdSig c----------------------------------------------------------------------- c Calculate Table 5.4 MSEs using growth rate from last month in data c minus one seasonal period previous. c----------------------------------------------------------------------- c Identify growth rate indexes over last seasonal period c for last month in data minus same month in previous year. c ------------------------------------------------------------------ i1 = nT i1m = i1-nPer i2 = nRevs i2m = i2-nPer c ------------------------------------------------------------------ c Calculate one seasonal period behind growth rate SEs for the trend c and seasonal adjustment. c ------------------------------------------------------------------ vTbl54(1) = varSig * & (infMSEs(i2,2) + infMSEs(i2m,2) - 2.0d0*infMSE2s(i2m,2)) vTbl54(5) = varSig * & (mTreVar(i1,i1) + mTreVar(i1m,i1m) - 2.0d0*mTreVar(i1m,i1)) vTbl54(3) = vTbl54(5) - vTbl54(1) c ------------------------------------------------------------------ vTbl54(2) = varSig * & (infMSEs(i2,1) + infMSEs(i2m,1) - 2.0d0*infMSE2s(i2m,1)) vTbl54(6) = varSig * & (mSeaVar(i1,i1) + mSeaVar(i1m,i1m) - 2.0d0*mSeaVar(i1m,i1)) vTbl54(4) = vTbl54(6) - vTbl54(2) c----------------------------------------------------------------------- c Table 5.5 size restriction due to number of observations. c----------------------------------------------------------------------- IF (num-nPer+1 .gt. nT-nPer) THEN num2 = nT-nPer ELSE num2 = num-nPer+1 END IF c----------------------------------------------------------------------- c Calculate Table 5.5 Standard Errors of Revision using growth rate c from current month minus one seasonal period previous. c----------------------------------------------------------------------- c Identify size of table 5.5 vectors. c ------------------------------------------------------------------ nSeaGRSE2(1) = num2 nSeaGRSE2(2) = 1 nTreGRSE2(1) = num2 nTreGRSE2(2) = 1 c ------------------------------------------------------------------ c For each month in the table 5.5 c ------------------------------------------------------------------ DO j = 1, num2 c ------------------------------------------------------------------ c Identify one seasonal period behind growth rate indexes c for desired month in data minus same month in previous year. c ------------------------------------------------------------------ i1 = nT-j+1 i1m = i1-nPer i2 = nRevs-j+1 i2m = i2-nPer c ------------------------------------------------------------------ c Calculate one seasonal period behind growth rate SEs for the trend c and seasonal adjustment. c ------------------------------------------------------------------ vSeaGRSE2(j) = & mSeaVar(i1,i1) + mSeaVar(i1m,i1m) - 2.0d0*mSeaVar(i1m,i1) & - infMSEs(i2,1) - infMSEs(i2m,1) + 2.0d0*infMSE2s(i2m,1) * vSeaGRSE2(j) = DSQRT( vSeaGRSE2(j) ) * sdSig vSeaGRSE2(j) = DSqrtOr0( vSeaGRSE2(j) ) * sdSig c ------------------------------------------------------------------ vTreGRSE2(j) = & mTreVar(i1,i1) + mTreVar(i1m,i1m) - 2.0d0*mTreVar(i1m,i1) & - infMSEs(i2,2) - infMSEs(i2m,2) + 2.0d0*infMSE2s(i2m,2) * vTreGRSE2(j) = DSQRT( vTreGRSE2(j) ) * sdSig vTreGRSE2(j) = DSqrtOr0( vTreGRSE2(j) ) * sdSig END DO c----------------------------------------------------------------------- c Calculate Table 5.6 Standard Errors using centered growth rate c from current month plus half of seasonal period (forecasts) c minus current month minus half of seasonal period, c----------------------------------------------------------------------- c Calculate covariance matrix for residuals of forecasts c of future data. c ------------------------------------------------------------------ CALL getForYMSE( nT, dS+dT, nPer, dDel, nDel, & mInvSigW, nInvSigW, mSigWf, nSigWf, & mSigWfW, nSigWfW, mSigYf, nSigYf ) c ------------------------------------------------------------------ c Calculate covariance matrices for residuals of forecasts c of future seasonal adjustment. c ------------------------------------------------------------------ CALL getForMSE( nT, dT, nPer, dDelT, nDelT, & mTreVar, nTreVar, mInvSigUT, nInvSigUT, & mSigUTf, nSigUTf, mSigUTfUT, nSigUTfUT, & mSigTf, nSigTf, mSigTfT, nSigTfT ) c ------------------------------------------------------------------ c Calculate covariance matrices for residuals of forecasts c of future trend adjustment. c ------------------------------------------------------------------ CALL getForMSE( nT, dT, nPer, dDelT, nDelT, & mSeaVar, nSeaVar, mInvSigWT, nInvSigWT, & mSigWTf, nSigWTf, mSigWTfWT, nSigWTfWT, & mSigSAf, nSigSAf, mSigSAfSA, nSigSAfSA ) c ------------------------------------------------------------------ c Identify centered seasonal growth rate indexes c for last month in data. c ------------------------------------------------------------------ i1 = nPer/2 i1m = nT-(nPer/2) i2 = nRevs+(nPer/2) i2m = nRevs-(nPer/2) c ------------------------------------------------------------------ c Calculate centered seasonal growth rate SEs for the data. c ------------------------------------------------------------------ * vTbl56(1,1) = DSQRT( mSigYf(i1,i1) * varSig ) * vTbl56(1,2) = DSQRT( mSigYf(i1,i1) * varSig ) vTbl56(1,1) = DSqrtOr0( mSigYf(i1,i1) ) * sdSig vTbl56(1,2) = vTbl56(1,1) c ------------------------------------------------------------------ c Calculate centered seasonal growth rate SEs for Trend. c ------------------------------------------------------------------ finMSE = mSigTf(i1,i1) + mTreVar(i1m,i1m) & - 2.0d0*mSigTfT((i1m-1)*nPer + i1) infMSE = infMSEs(i2,2) + infMSEs(i2m,2) & - 2.0d0*infMSE2s(i2m,2) * vTbl56(3,1) = DSQRT( (finMSE - infMSE) * varSig ) * vTbl56(3,2) = DSQRT( finMSE * varSig ) vTbl56(3,1) = DSqrtOr0( (finMSE - infMSE) ) * sdSig vTbl56(3,2) = DSqrtOr0( finMSE ) * sdSig c ------------------------------------------------------------------ c Calculate centered seasonal growth rate SEs for Seasonal Adjustment. c ------------------------------------------------------------------ finMSE = mSigSAf(i1,i1) + mSeaVar(i1m,i1m) & - 2.0d0*mSigSAfSA((i1m-1)*nPer + i1) infMSE = infMSEs(i2,1) + infMSEs(i2m,1) & - 2.0d0*infMSE2s(i2m,1) * vTbl56(5,1) = DSQRT( (finMSE - infMSE) * varSig ) * vTbl56(5,2) = DSQRT( finMSE * varSig ) vTbl56(5,1) = DSqrtOr0( (finMSE - infMSE) ) * sdSig vTbl56(5,2) = DSqrtOr0( finMSE ) * sdSig c ------------------------------------------------------------------ c Identify centered seasonal growth rate indexes c for next to last month in data. c ------------------------------------------------------------------ i1 = i1-1 i1m = i1m-1 i2 = i2-1 i2m = i2m-1 c ------------------------------------------------------------------ c Calculate centered seasonal growth rate SEs for the data. c ------------------------------------------------------------------ vTbl56(2,1) = DSqrtOr0( mSigYf(i1,i1) ) * sdSig vTbl56(2,2) = vTbl56(2,1) c ------------------------------------------------------------------ c Calculate centered seasonal growth rate SEs for Trend. c ------------------------------------------------------------------ finMSE = mSigTf(i1,i1) + mTreVar(i1m,i1m) & - 2.0d0*mSigTfT((i1m-1)*nPer + i1) infMSE = infMSEs(i2,2) + infMSEs(i2m,2) & - 2.0d0*infMSE2s(i2m,2) vTbl56(4,1) = DSqrtOr0( (finMSE - infMSE) ) * sdSig vTbl56(4,2) = DSqrtOr0( finMSE ) * sdSig c ------------------------------------------------------------------ c Calculate centered seasonal growth rate SEs for Seasonal Adjustment. c ------------------------------------------------------------------ finMSE = mSigSAf(i1,i1) + mSeaVar(i1m,i1m) & - 2.0d0*mSigSAfSA((i1m-1)*nPer + i1) infMSE = infMSEs(i2,1) + infMSEs(i2m,1) & - 2.0d0*infMSE2s(i2m,1) vTbl56(6,1) = DSqrtOr0( (finMSE - infMSE) ) * sdSig vTbl56(6,2) = DSqrtOr0( finMSE ) * sdSig c----------------------------------------------------------------------- c Calculate Table 5.7 Standard Errors using forcasted growth rates c MSEs. c----------------------------------------------------------------------- c Identify one period ahead growth rate indexes c from last month in data versus one period ahead. c ------------------------------------------------------------------ i1 = 1 i1m = nT i2 = nRevs+1 i2m = nRevs c ------------------------------------------------------------------ c Calculate growth rate SEs for the data. c ------------------------------------------------------------------ vTbl57(1,1) = DSqrtOr0( mSigYf(i1,i1) ) * sdSig c ------------------------------------------------------------------ c Calculate growth rate SEs for trend. c ------------------------------------------------------------------ finMSE = mSigTf(i1,i1) + mTreVar(i1m,i1m) & - 2.0d0*mSigTfT((i1m-1)*nPer + i1) infMSE = infMSEs(i2,2) + infMSEs(i2m,2) & - 2.0d0*infMSE1s(i2m,2) vTbl57(1,2) = DSqrtOr0( (finMSE - infMSE) ) * sdSig c ------------------------------------------------------------------ c Calculate growth rate SEs for seasonal adjustment. c ------------------------------------------------------------------ finMSE = mSigSAf(i1,i1) + mSeaVar(i1m,i1m) & - 2.0d0*mSigSAfSA((i1m-1)*nPer + i1) infMSE = infMSEs(i2,1) + infMSEs(i2m,1) & - 2.0d0*infMSE1s(i2m,1) vTbl57(1,3) = DSqrtOr0( (finMSE - infMSE) ) * sdSig c----------------------------------------------------------------------- c Identify one seasonal period ahead growth rate indexes c from last month in data versus one seasonal period ahead. c ------------------------------------------------------------------ i1 = nPer i1m = nT i2 = nRevs+nPer i2m = nRevs c ------------------------------------------------------------------ c Calculate growth rate SEs for the data. c ------------------------------------------------------------------ vTbl57(2,1) = DSqrtOr0( mSigYf(i1,i1) ) * sdSig c ------------------------------------------------------------------ c Calculate growth rate SEs for trend. c ------------------------------------------------------------------ finMSE = mSigTf(i1,i1) + mTreVar(i1m,i1m) & - 2.0d0*mSigTfT((i1m-1)*nPer + i1) infMSE = infMSEs(i2,2) + infMSEs(i2m,2) & - 2.0d0*infMSE2s(i2m,2) vTbl57(2,2) = DSqrtOr0( (finMSE - infMSE) ) * sdSig c ------------------------------------------------------------------ c Calculate growth rate SEs for seasonal adjustment. c ------------------------------------------------------------------ finMSE = mSigSAf(i1,i1) + mSeaVar(i1m,i1m) & - 2.0d0*mSigSAfSA((i1m-1)*nPer + i1) infMSE = infMSEs(i2,1) + infMSEs(i2m,1) & - 2.0d0*infMSE2s(i2m,1) vTbl57(2,3) = DSqrtOr0( (finMSE - infMSE) ) * sdSig c----------------------------------------------------------------------- c Identify growth rate indexes over current year c from last month in data versus last month in previous year. c ------------------------------------------------------------------ i1 = nPer-tbl53Lag i1m = nT-tbl53Lag i2 = nRevs+nPer-tbl53Lag i2m = nRevs-tbl53Lag c ------------------------------------------------------------------ c Calculate growth rate SEs for the data. c ------------------------------------------------------------------ IF ( i1 .gt. 0 ) THEN vTbl57(3,1) = mSigYf(i1,i1) ELSE vTbl57(3,1) = 0.0d0 END IF vTbl57(3,1) = DSqrtOr0( vTbl57(3,1) ) * sdSig c ------------------------------------------------------------------ c Calculate growth rate SEs for trend. c ------------------------------------------------------------------ IF ( i1 .gt. 0 ) THEN finMSE = mSigTf(i1,i1) + mTreVar(i1m,i1m) & - 2.0d0*mSigTfT((i1m-1)*nPer + i1) infMSE = infMSEs(i2,2) + infMSEs(i2m,2) & - 2.0d0*infMSE2s(i2m,2) ELSE finMSE = mTreVar(nT,nT) + mTreVar(i1m,i1m) & - 2.0d0*mTreVar(nT,i1m) infMSE = infMSEs(i2,2) + infMSEs(i2m,2) & - 2.0d0*infMSE2s(i2m,2) END IF vTbl57(3,2) = DSqrtOr0( (finMSE - infMSE) ) * sdSig c ------------------------------------------------------------------ c Calculate growth rate SEs for seasonal adjustment. c ------------------------------------------------------------------ IF ( i1 .gt. 0 ) THEN finMSE = mSigSAf(i1,i1) + mSeaVar(i1m,i1m) & - 2.0d0*mSigSAfSA((i1m-1)*nPer + i1) infMSE = infMSEs(i2,1) + infMSEs(i2m,1) & - 2.0d0*infMSE2s(i2m,1) ELSE finMSE = mSeaVar(nT,nT) + mSeaVar(i1m,i1m) & - 2.0d0*mSeaVar(nT,i1m) infMSE = infMSEs(i2,1) + infMSEs(i2m,1) & - 2.0d0*infMSE2s(i2m,1) END IF vTbl57(3,3) = DSqrtOr0( (finMSE - infMSE) ) * sdSig c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE getTbl53Lag( Mq, iLag ) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.0, Created 14 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 14 Apr 2006. c----------------------------------------------------------------------- c This subroutine calculates the lag between the last month c in the data versus the last month in the prior year of data. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c Mq i size of seasonal period c iLag i output lag between last month in data and last month c in prior year c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c getLastPeriod i external function reference c lastPer i iLag value returned from getLastPeriod() c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INCLUDE 'sform.i' INTEGER iLag, Mq c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER lastPer INTEGER getLastPeriod c----------------------------------------------------------------------- c Retrieve iLag value via call to getLastPeriod(). c----------------------------------------------------------------------- lastPer = getLastPeriod(Nz,Nper,Nyer,Mq) iLag = lastPer RETURN END c----------------------------------------------------------------------- SUBROUTINE getForMSE( nT, d, nPer, dDel, nDel, & mCmpVar, nCmpVar, mInvSigU, nInvSigU, & mSigUf, nSigUf, mSigUfU, nSigUfU, & mSigCf, nSigCf, mSigCfC, nSigCfC) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.0, Created 14 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 14 Apr 2006. c----------------------------------------------------------------------- c This subroutine calculates a components forecast covariance c structure as calculated in theorem 2 of McElroy's paper c "Matrix Formulas for Nonstationary ARIMA Signal Extraction". c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c d i degree of differencing polynomial dDel c dDel d diagonal form of differencing polynomial c mCmpVar d covariance matrix of estimated component c mInvSigU d inverse covariance matrix of differenced component (U) c mSigCf d component covariance matrix of forecast residuals c mSigCfC d component covariance matrix between forecast residuals c and earlier residuals c mSigUf d covariance matrix of future differenced component (Uf) c mSigUfU d covariance matrix of (Uf,U) c nCmpVar i size (rows,columns) of mCmpVar matrix c nDel i size (rows,columns) of differencing polynomial vector c nInvSigU i size (rows,columns) of mInvSigU matrix c nPer i size of seasonal period c nSigCf i size (rows,columns) of mSigCf matrix c nSigCfC i size (rows,columns) of mSigCfC matrix c nSigUf i size (rows,columns) of mSigUf matrix c nSigUfU i size (rows,columns) of mSigUfU matrix c nT i size of data available c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i, j i do loop index variables c iBaseD i base index associated with mD matrix processing c mA d contains lower left partition of mInvDif matrix c mB d contains lower right partition of mInvDif matrix c mD d working matrix needed to calculate results c mDif d difference matrix c mG d working matrix needed to calculate results c mInvDif d inverse of difference matrix that contains mA and mB c MONE d constant parameter c mTemp1 d temporary working matrix 1 c mTemp2 d temporary working matrix 2 c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nD i size (rows,columns) of mD matrix c nDif i size (rows,columns) of mDif matrix c nG i size (rows,columns) of mG matrix c nInvDif i size (rows,columns) of mInvDif matrix c nTemp1 i size (rows,columns) of mTemp1 matrix c nTemp2 i size (rows,columns) of mTemp2 matrix c nSave i size of local large matrices that are saved c ONE d constant parameter c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER d, nPer, nT INTEGER nCmpVar(2), nDel(2), nInvSigU(2) INTEGER nSigCf(2), nSigCfC(2), nSigUf(2), nSigUfU(2) DOUBLE PRECISION dDel(d+1) DOUBLE PRECISION mCmpVar(nT,nT), mInvSigU(nT-d,nT-d) DOUBLE PRECISION mSigCf(nPer,nPer), mSigCfC(nPer,nT) * DOUBLE PRECISION mSigUf(nPer,nPer), mSigUfU(nPer,nT) DOUBLE PRECISION mSigUf(nPer,nPer), mSigUfU(nPer,nT-d) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, iBaseD, j INTEGER nSave INTEGER nA(2), nB(2), nD(2), nDif(2), nG(2), nInvDif(2) INTEGER nTemp1(2), nTemp2(2) PARAMETER (nSave=12*POBS) DOUBLE PRECISION MONE, ONE, ZERO DOUBLE PRECISION mA(nPer,d), mB(nPer,nPer), mD(nSave) DOUBLE PRECISION mG(nPer,nPer) DOUBLE PRECISION mDif(d+nPer,d+nPer), mInvDif(d+nPer,d+nPer) DOUBLE PRECISION mTemp1(nSave), mTemp2(nSave) PARAMETER (MONE=-1.0d0, ONE=1.0d0, ZERO=0.0d0) SAVE mD, mTemp1, mTemp2 c----------------------------------------------------------------------- c Initialize mDif matrix including size. c----------------------------------------------------------------------- nDif(1) = d+nPer nDif(2) = d+nPer c ------------------------------------------------------------------ DO j = 1, nDif(2) DO i = 1, nDif(1) mDif(i,j) = ZERO END DO END DO c ------------------------------------------------------------------ DO i = 1, d mDif(i,i) = ONE END DO DO i = d+1, nDif(1) DO j = 1, d+1 mDif(i,j+i-d-1) = dDel(j) END DO END DO c----------------------------------------------------------------------- c Invert mDif matrix and extract mA and mB lower partitions. c----------------------------------------------------------------------- CALL invLTMat( mDif, nDif, mInvDif, nInvDif ) CALL getSMat( mInvDif, nInvDif, d+1, d+nPer, mB, nB ) CALL getSRMat( mInvDif, nInvDif, d+1, d+nPer, 1, d, mA, nA ) c----------------------------------------------------------------------- c Calculate D filter that provides forecast of component c given past values of component. c----------------------------------------------------------------------- CALL mulMat( mSigUfU, nSigUfU, mInvSigU, nInvSigU, & mTemp1, nTemp1 ) CALL mulMat( mB, nB, mTemp1, nTemp1, mTemp2, nTemp2 ) pdA = max(nDel(2)-nDel(1)+1, 1) CALL mulMatD( mTemp2, nTemp2, dDel, nDel, mD, nD, pdA ) DO j = 1, d iBaseD = (nT-d+j-1)*nPer DO i = 1, nPer mD(iBaseD+i) = mD(iBaseD+i) + mA(i,j) END DO END DO c----------------------------------------------------------------------- c Calculate G matrix as specified in proof of theorem 2. c----------------------------------------------------------------------- CALL mulMatTr( mTemp1, nTemp1, mSigUfU, nSigUfU, mTemp2, nTemp2 ) CALL mulSca( MONE, mTemp2, nTemp2 ) CALL addMat( mSigUf, nSigUf, mTemp2, nTemp2, mTemp1, nTemp1 ) CALL mulQMat( mB, nB, mTemp1, nTemp1, mG, nG ) c----------------------------------------------------------------------- c Calculate residual covariance matrix for estimated (Cf,C) and then c Calculate residual covariance matrix for forecasted Cf. c----------------------------------------------------------------------- CALL mulMat( mD, nD, mCmpVar, nCmpVar, mSigCfC, nSigCfC ) CALL mulMatTr( mSigCfC, nSigCfC, mD, nD, mSigCf, nSigCf ) CALL addMat( mSigCf, nSigCf, mG, nG, mSigCf, nSigCf ) RETURN END c----------------------------------------------------------------------- SUBROUTINE getForYMSE( nT, d, nPer, dDel, nDel, & mInvSigW, nInvSigW, mSigWf, nSigWf, & mSigWfW, nSigWfW, mSigYf, nSigYf ) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.0, Created 14 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 14 Apr 2006. c----------------------------------------------------------------------- c This subroutine calculates a components forecast covariance c structure as calculated in theorem 2 of McElroy's paper c "Matrix Formulas for Nonstationary ARIMA Signal Extraction". c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c d i degree of differencing polynomial dDel c dDel d diagonal form of differencing polynomial c mInvSigW d inverse covariance matrix of differenced data (W) c mSigWf d covariance matrix of future differenced data (Wf) c mSigWfW d covariance matrix of (Wf,W) c mSigYf d data covariance matrix of forecast residuals c nDel i size (rows,columns) of differencing polynomial vector c nInvSigW i size (rows,columns) of mInvSigW matrix c nPer i size of seasonal period c nSigWf i size (rows,columns) of mSigWf matrix c nSigWfW i size (rows,columns) of mSigWfW matrix c nSigYf i size (rows,columns) of mSigYf matrix c nT i size of data available c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i, j i do loop index variables c iBaseD i base index associated with mD matrix processing c mB d contains lower right partition of mInvDif matrix c mDif d difference matrix c mInvDif d inverse of difference matrix that contains mA and mB c MONE d constant parameter c mTemp1 d temporary working matrix 1 c nB i size (rows,columns) of mB matrix c nDif i size (rows,columns) of mDif matrix c nInvDif i size (rows,columns) of mInvDif matrix c nTemp1 i size (rows,columns) of mTemp1 matrix c nSave i size of local large matrices that are saved c ONE d constant parameter c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER d, nPer, nT INTEGER nDel(2), nInvSigW(2), nSigWf(2), nSigWfW(2), nSigYf(2) DOUBLE PRECISION dDel(d+1), mInvSigW(nT-d,nT-d) * DOUBLE PRECISION mSigWf(nPer,nPer), mSigWfW(nPer,nT) DOUBLE PRECISION mSigWf(nPer,nPer), mSigWfW(nPer,nT-d) DOUBLE PRECISION mSigYf(nPer,nPer) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, iBaseD, j INTEGER nSave INTEGER nB(2), nDif(2), nInvDif(2) INTEGER nTemp1(2) PARAMETER (nSave=12*POBS) DOUBLE PRECISION MONE, ONE, ZERO DOUBLE PRECISION mB(nPer,nPer) DOUBLE PRECISION mDif(d+nPer,d+nPer), mInvDif(d+nPer,d+nPer) DOUBLE PRECISION mTemp1(nSave) PARAMETER (MONE=-1.0d0, ONE=1.0d0, ZERO=0.0d0) SAVE mTemp1 c----------------------------------------------------------------------- c Initialize mDif matrix including size. c----------------------------------------------------------------------- nDif(1) = d+nPer nDif(2) = d+nPer c ------------------------------------------------------------------ DO j = 1, nDif(2) DO i = 1, nDif(1) mDif(i,j) = ZERO END DO END DO c ------------------------------------------------------------------ DO i = 1, d mDif(i,i) = ONE END DO DO i = d+1, nDif(1) DO j = 1, d+1 mDif(i,j+i-d-1) = dDel(j) END DO END DO c----------------------------------------------------------------------- c Invert mDif matrix and extract mB lower partition. c----------------------------------------------------------------------- CALL invLTMat( mDif, nDif, mInvDif, nInvDif ) CALL getSMat( mInvDif, nInvDif, d+1, d+nPer, mB, nB ) c----------------------------------------------------------------------- c Calculate residual covariance matrix for forecasted Yf. c----------------------------------------------------------------------- CALL mulQMat( mSigWfW, nSigWfW, mInvSigW, nInvSigW, & mTemp1, nTemp1 ) CALL mulSca( MONE, mTemp1, nTemp1 ) CALL addMat( mSigWf, nSigWf, mTemp1, nTemp1, mTemp1, nTemp1 ) CALL mulQMat( mB, nB, mTemp1, nTemp1, mSigYf, nSigYf ) RETURN END c----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION DSqrtOr0( Arg ) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.0, Created 30 May 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 30 May 2006. c----------------------------------------------------------------------- c This subroutine calculates the square root of a positive argument c or returns zero for negative arguments. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c Arg d input argument, should be positive in order to return c square root. c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE precision Arg c----------------------------------------------------------------------- c Return square root for positive argument, c else return zero for non-positive argument. c----------------------------------------------------------------------- IF ( Arg .gt. 0.0d0 ) THEN DSqrtOr0 = DSQRT( arg ) ELSE DSqrtOr0 = 0.0d0 END IF RETURN END getid.f0000664006604000003110000001055314521201503011431 0ustar sun00315stepsC Last change: BCM 4 Aug 1998 8:28 am SUBROUTINE getid(Dflist,Niddf,Nidsdf,Mxidlg,Inptok) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'tbllog.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ LOGICAL argok,gtarg,Inptok INTEGER Dflist,itmp,Mxidlg,mxnsdf,nelt,Niddf,Nidsdf,ivec DIMENSION Dflist(PDFLG,2),ivec(1) EXTERNAL gtarg c----------------------------------------------------------------------- c Argument dictionary was made with the following command c ../../dictionary/strary < ../../dictionary/identify.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*24 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=5) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='diffsdiffmaxlagprintsave') DATA argptr/1,5,10,16,21,25/ c----------------------------------------------------------------------- c Defaults for calling identify are diff=0, sdiff=0 which will c give the acf's and pacf's of undifferenced series. c----------------------------------------------------------------------- Niddf=1 Nidsdf=1 Dflist(1,1)=0 Dflist(1,2)=0 CALL setint(NOTSET,2*PARG,arglog) argok=T c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- DO WHILE (T) IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,argok))THEN IF(Lfatal)RETURN GO TO(10,20,30,40,50),argidx c----------------------------------------------------------------------- c List of nonseasonal differences c----------------------------------------------------------------------- 10 CALL getivc(LPAREN,T,PDFLG,Dflist,Niddf,argok,Inptok) IF(Lfatal)RETURN GO TO 60 c----------------------------------------------------------------------- c List of seasonal differences c----------------------------------------------------------------------- 20 CALL getivc(LPAREN,T,PDFLG,Dflist(1,2),Nidsdf,argok,Inptok) IF(Lfatal)RETURN CALL maxidx(Dflist(1,2),Nidsdf,itmp,mxnsdf) IF(mxnsdf.gt.0)THEN IF(Sp.le.1)THEN CALL inpter(PERROR,Errpos, & 'Must specify a seasonal period, PERIOD>1, to use SDIFF.' & ) Inptok=F ELSE IF(Lseff)THEN CALL inpter(PERROR,Errpos, &'Need to remove fixed seasonal effects in order to identify season &al orders of differencing') Inptok=F ELSE Lidsdf=T END IF END IF GO TO 60 c----------------------------------------------------------------------- c Number of acf and pacf lags to calculate and print out c----------------------------------------------------------------------- 30 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN Mxidlg=ivec(1) GO TO 60 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 40 CALL getprt(LSPIDN,NSPIDN,Inptok) GO TO 60 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 50 CALL getsav(LSPIDN,NSPIDN,Inptok) GO TO 60 END IF c ----------------------------------------------------------------- c change the default of annual series to 10 c BCM August 2010 c ----------------------------------------------------------------- IF(Mxidlg.eq.NOTSET)THEN IF(Sp.eq.1)THEN Mxidlg=10 ELSE Mxidlg=3*Sp END IF END IF c ----------------------------------------------------------------- RETURN 60 CONTINUE END DO c ----------------------------------------------------------------- END getidm.f0000664006604000003110000000464214521201503011610 0ustar sun00315steps SUBROUTINE getIdM( n, mId, nId ) c----------------------------------------------------------------------- c getIdM.f, Release 1, Subroutine Version 1.0, Created 14 Apr 2005. c----------------------------------------------------------------------- c This subroutine calculates the identity matrix mId of size c nId = ( n, n ). c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mId d output Identity matrix of size n x x c nId o size (rows,columns) of identity matrix mId c n i input row and column size for identity matrix mId c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER n, nId(2) DOUBLE PRECISION mId( n, n ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j c----------------------------------------------------------------------- c Calculate the dimensions of mAT. c----------------------------------------------------------------------- nId(1) = n nId(2) = n c----------------------------------------------------------------------- c Create the identity matrix one row at a time. c----------------------------------------------------------------------- DO j = 1, nId(2) c ------------------------------------------------------------------ c For the jth column of the identity matrix, set the jth element to 0. c ------------------------------------------------------------------ DO i = 1, nId(1) IF ( i .eq. j ) THEN mId(i,j) = 1.0D0 ELSE mId(i,j) = 0.0D0 END IF END DO END DO c ------------------------------------------------------------------ RETURN ENDgetint.f0000664006604000003110000000217114521201503011624 0ustar sun00315stepsC Last change: BCM 15 Jan 98 11:07 am **==getint.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 LOGICAL FUNCTION getint(Tmp) IMPLICIT NONE c---------------------------------------------------------------------- c Returns an integer from the input stream and returns c true otherwise returns false and tmp is undefined. c---------------------------------------------------------------------- INCLUDE 'lex.i' c---------------------------------------------------------------------- INTEGER ctoi,ipos,Tmp EXTERNAL ctoi c---------------------------------------------------------------------- getint=.false. c---------------------------------------------------------------------- IF(Nxtktp.ne.EOF)THEN ipos=Lstpos(PCHAR) c---------------------------------------------------------------------- Tmp=ctoi(Linex(1:Lineln),ipos) IF(ipos.gt.Lstpos(PCHAR))THEN Pos(PCHAR)=ipos getint=.true. CALL lex() END IF END IF c---------------------------------------------------------------------- RETURN END getivc.f0000664006604000003110000001362214521201504011617 0ustar sun00315stepsC Last change: BCM 1 Feb 98 0:40 am SUBROUTINE getivc(Grpchr,Flgnul,Pelt,Avec,Nelt,Locok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c getivc.f, Release 1, Subroutine Version 1.5, Modified 1/3/95. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ----------------------------------------------------------------- CHARACTER str*(LINLEN) LOGICAL Flgnul,getint,hvcmma,Inptok,Locok,opngrp INTEGER Avec,clsgtp,clsgrp,Grpchr,ipos,Nelt,Pelt,tmp DIMENSION Avec(Pelt) EXTERNAL clsgrp,getint c---------------------------------------------------------------------- Locok=T c ----------------------------------------------------------------- IF(Nxtktp.eq.EOF)THEN Locok=F c ----------------------------------------------------------------- ELSE IF(getint(Avec(1)))THEN Nelt=1 c ----------------------------------------------------------------- ELSE IF(Nxtktp.ne.Grpchr)THEN CALL inpter(PERROR,Lstpos, & 'Expected an integer or an integer list, not "'// & Nxttok(1:Nxtkln)//'"') Locok=F opngrp=F CALL lex() c ----------------------------------------------------------------- ELSE Nelt=0 opngrp=T hvcmma=F clsgtp=clsgrp(Grpchr) c ----------------------------------------------------------------- CALL lex() c---------------------------------------------------------------------- c Process the list of integers c---------------------------------------------------------------------- DO WHILE (T) DO WHILE (T) c ----------------------------------------------------------------- IF(Nxtktp.ne.clsgtp)THEN c---------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,10, -8) c or (6,,10,-8). This section is repeated because there may be c multiple NULLs c---------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ----------------------------------------------------------------- ELSE IF(Nelt.ge.Pelt)THEN str='Integer vector exceeds ' ipos=24 CALL itoc(Pelt,str,ipos) str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ----------------------------------------------------------------- ELSE Nelt=Nelt+1 Avec(Nelt)=NOTSET END IF END IF c ----------------------------------------------------------------- CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c---------------------------------------------------------------------- c There is not a close group or comma here so there must be a real. c---------------------------------------------------------------------- IF(.not.(getint(tmp)))THEN CALL inpter(PERROR,Lstpos,'Expected an integer not "'// & Nxttok(1:Nxtkln)//'"') Locok=F ELSE IF(Nelt.ge.Pelt)THEN str='Integer vector exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ----------------------------------------------------------------- ELSE Nelt=Nelt+1 Avec(Nelt)=tmp hvcmma=F opngrp=F GO TO 20 END IF c---------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. This indicates a NULL value, for example, c (6,10, -8,). These default values may exceed the length c of the list. c---------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ----------------------------------------------------------------- ELSE IF(Nelt.ge.Pelt)THEN str='Integer vector exceeds ' ipos=24 CALL itoc(Pelt,str,ipos) str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ----------------------------------------------------------------- ELSE Nelt=Nelt+1 Avec(Nelt)=NOTSET END IF c ----------------------------------------------------------------- ELSE IF(opngrp.and.Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check for null list.') Locok=F END IF c ----------------------------------------------------------------- IF(Locok)THEN CALL lex() ELSE CALL skplst(clsgtp) END IF GO TO 30 10 CONTINUE END DO 20 CONTINUE END DO c ----------------------------------------------------------------- END IF 30 Inptok=Inptok.and.Locok c ----------------------------------------------------------------- RETURN END getmdl.f0000664006604000003110000003157314521201504011617 0ustar sun00315stepsC Last change: BCM 15 Jan 98 12:12 pm SUBROUTINE getmdl(Locok,Inptok,Lauto) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER str*(POPRCR) LOGICAL arfix,argok,dffix,getint,havreg,hvsea,Inptok,Locok,mafix, & Lauto INTEGER arerr,arlag,begmdl,dferr,dflag,facsp,itmp,malag,MULT,nar, & naimcf,nchr,ndcoef,ndf,nma,numopr,maerr DOUBLE PRECISION arcoef,dfcoef,macoef PARAMETER(MULT=3) DIMENSION arcoef(PORDER),arerr(2),arfix(PORDER),arlag(PORDER), & dfcoef(PDIFOR),dferr(2),dffix(PDIFOR),dflag(PDIFOR), & macoef(PORDER),maerr(2),mafix(PORDER),malag(PORDER), & begmdl(2) EXTERNAL getint c----------------------------------------------------------------------- c Get factors (AR DIFF MA)SP until the next name. c----------------------------------------------------------------------- Locok=T havreg=F hvsea=F CALL cpyint(Lstpos,2,1,begmdl) Mdldsn(1:(1+Lineln-begmdl(PCHAR)))=Linex(begmdl(PCHAR):Lineln) Nseadf=0 Nnsedf=0 naimcf=0 numopr=0 c----------------------------------------------------------------------- c Get factors (AR DIFF MA)SP until the next name. Note that the c seasonal period (SP) after the parenthesis is optional in most cases. c There may also be commas between the operators. Also, we cannot c insert each operator into the model and check for errors as they c return from GETOPR because we need to have the periodicity of the c factor first. c----------------------------------------------------------------------- DO WHILE (Nxtktp.eq.LPAREN) c ------------------------------------------------------------------ CALL lex() CALL cpyint(Lstpos,2,1,arerr) CALL getopr(AR,arcoef,arlag,arfix,nar,itmp,naimcf,argok,Locok) IF(Lfatal)RETURN IF(Nxtktp.eq.COMMA)CALL lex() CALL cpyint(Lstpos,2,1,dferr) CALL getopr(DIFF,dfcoef,dflag,dffix,ndcoef,ndf,naimcf,argok, & Locok) IF(Lfatal)RETURN IF(Nxtktp.eq.COMMA)CALL lex() CALL cpyint(Lstpos,2,1,maerr) CALL getopr(MA,macoef,malag,mafix,nma,itmp,naimcf,argok,Locok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Nxtktp.ne.RPAREN)THEN CALL inpter(PERROR,Lstpos,'Expected ")" after (AR DIFF MA') Locok=F c----------------------------------------------------------------------- c Save the end of the model string so we can print out the model c description as is. Note we are in trouble if the model is written c over one line. Unfortunately it would be too hard to print out the c ARIMA model description from the data stored since all the AR c operators from all the factors are stored together, all the c differening, and MA. Also, we would have to figure the seasonal c period of each operator by figuring the least common denominator. c----------------------------------------------------------------------- ELSE Nmddcr=Pos(PCHAR)-begmdl(PCHAR) CALL lex() c----------------------------------------------------------------------- c Get the period of the factor if it exists. If it is implied, c determine it from the following rules: c----------------------------------------------------------------------- IF(Nxtktp.eq.INTGR)THEN Nmddcr=Pos(PCHAR)-begmdl(PCHAR) argok=getint(facsp) IF(facsp.le.0)THEN CALL inpter(PERROR,Lstpos,'Period specified in (AR DIFF MA)per &iod must be greater than zero.') Locok=F END IF c----------------------------------------------------------------------- c (1) If there has been no previous regular factor, then it is a c regular factor; c----------------------------------------------------------------------- ELSE IF(.not.havreg)THEN facsp=1 havreg=T c----------------------------------------------------------------------- c (2) If there has been a previous regular factor and the data has c a seasonal periodicity, then the factor has the seasonal periodicity, c Sp; c----------------------------------------------------------------------- ELSE IF(.not.hvsea.and.Sp.gt.1)THEN facsp=Sp hvsea=T c----------------------------------------------------------------------- c (3) Since only one regular and one seasonal factor are allowed per c model, anyother implicit factor is an error. c----------------------------------------------------------------------- ELSE CALL inpter(PERROR,Lstpos, & 'Must explicitly specify the period in (AR DIFF MA)period') Locok=F END IF c----------------------------------------------------------------------- c Check the the order of this AR operator and insert it if it is not c too large. If there is not enough room left in the model variables c to store the operator, INSOPR will report that error. c----------------------------------------------------------------------- IF(Locok)THEN IF(nar.gt.0)THEN numopr=numopr+1 IF(numopr.gt.POPR)THEN CALL inpter(PERROR,arerr, & 'Too many operators in specified ARIMA model') Locok=F GO TO 20 END IF CALL iscrfn(MULT,facsp,arlag,nar,PORDER,arlag) CALL mkoprt(AR,facsp,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(AR,arcoef,arlag,arfix,nar,facsp, & str(1:nchr),argok,Locok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check the of maximum lag of all the AR operators added so far c does not exceed the maximum order otherwise is will exceed temporary c storage in the filtering operations where the operators are c expanded/multiplied into just the coefficients of one full operator. c This is only going to be a problem for seasonal and missing lag c models. c----------------------------------------------------------------------- CALL maxlag(Arimal,Opr,Mdl(AR-1),Mdl(AR)-1,Mxarlg) IF(Mxarlg.gt.PORDER)THEN CALL inpter(PERROR,arerr, & 'Order of the AR operator is too large.') Locok=F END IF ELSE IF(nar.lt.0)THEN CALL inpter(PERROR,arerr, & 'Order of the AR operator cannot be less than zero.') Locok=F END IF c----------------------------------------------------------------------- c Check that we don't have a seasonal difference and a seasonal c effect variables or a U(B) operator. c----------------------------------------------------------------------- IF(ndcoef.gt.0)THEN numopr=numopr+1 IF(numopr.gt.POPR)THEN CALL inpter(PERROR,dferr, & 'Too many operators in specified ARIMA model') Locok=F GO TO 20 END IF Lseadf=(Sp.gt.1.and.facsp.eq.Sp).or. & (Sp.eq.1.and.ndcoef.eq.Sp-1) c ------------------------------------------------------------------ IF(Lseadf.and.Lseff)THEN CALL inpter(PERROR,dferr,'Cannot have '// & 'a seasonal difference with seasonal regression effects.') Locok=F END IF c ------------------------------------------------------------------ c Accumulate the number of seasonal and nonseasonal differences to c print out in the table of estimates. c----------------------------------------------------------------------- IF(facsp.eq.1)Nnsedf=Nnsedf+ndf IF(facsp.eq.Sp.and.Sp.gt.1)Nseadf=Nseadf+ndf c----------------------------------------------------------------------- c Check that the number of coefficients for the new differencing c operator is not too large so it won't exceed the temporary storage c when it is inserted. c----------------------------------------------------------------------- IF(ndcoef.gt.PDIFOR)THEN CALL inpter(PERROR,dferr, & 'Order of the differencing operator is too large.') Locok=F ELSE CALL iscrfn(MULT,facsp,dflag,ndcoef,PDIFOR,dflag) CALL mkoprt(DIFF,facsp,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(DIFF,dfcoef,dflag,dffix,ndcoef, & facsp,str(1:nchr),argok,Locok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check the of maximum lag of all the differencing operators added c so far does not exceed the maximum order otherwise is will exceed c temporary storage in the filtering operations where the operators c are expanded/multiplied into just the coefficients of one full c operator. This is only going to be a problem for seasonal and missing c lag models. c----------------------------------------------------------------------- CALL maxlag(Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1,Mxdflg) IF(Mxdflg.gt.PDIFOR)THEN CALL inpter(PERROR,dferr, & 'Order of the full differencing operator is too large.') Locok=F END IF END IF ELSE IF(ndf.lt.0)THEN CALL inpter(PERROR,dferr,'Order of the differencing operator c &annot be less than zero.') Locok=F END IF c----------------------------------------------------------------------- c Check that the number of coefficients for the new MA operator is c not too large so it won't exceed the temporary storage when it is c inserted. c----------------------------------------------------------------------- IF(nma.gt.PORDER)THEN CALL inpter(PERROR,maerr, & 'Order of the MA operator is too large') Locok=F ELSE IF(nma.gt.0)THEN numopr=numopr+1 IF(numopr.gt.POPR)THEN CALL inpter(PERROR,maerr, & 'Too many operators in specified ARIMA model') Locok=F GO TO 20 END IF CALL iscrfn(MULT,facsp,malag,nma,PORDER,malag) CALL mkoprt(MA,facsp,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(MA,macoef,malag,mafix,nma,facsp, & str(1:nchr),argok,Locok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check the of maximum lag of all the MA operators added so far c does not exceed the maximum order otherwise is will exceed temporary c storage in the filtering operations where the operators are c expanded/multiplied into just the coefficients of one full operator. c This is only going to be a problem for seasonal and missing lag c models. c----------------------------------------------------------------------- CALL maxlag(Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,Mxmalg) IF(Mxmalg.gt.PORDER)THEN CALL inpter(PERROR,Errpos, & 'Order of the MA operator is too large.') Locok=F END IF ELSE IF(nma.lt.0)THEN CALL inpter(PERROR,Errpos, & 'Order of the MA operator cannot be less than zero.') Locok=F END IF c----------------------------------------------------------------------- c If there is another factor, process it. I don't know that the c error below the END DO will ever be used. c----------------------------------------------------------------------- IF(Nxtktp.eq.LPAREN)GO TO 10 END IF END IF c----------------------------------------------------------------------- c We processed the last factor so break out of the factor processing c while loop. Increment NMDL, indicating we have an ARIMA model. If c there is an error, skip the rest of the ARIMA model description to c process the rest of the input file for errors. c----------------------------------------------------------------------- GO TO 20 10 CONTINUE END DO CALL inpter(PERROR,Lstpos,'Expected "(" in (AR DIFF MA)') Locok=F c ------------------------------------------------------------------ 20 IF(Locok)THEN Nmdl=Nmdl+1 ELSE CALL skparm(Lauto) END IF c ------------------------------------------------------------------ Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END getmtd.f0000664006604000003110000001254114521201504011621 0ustar sun00315stepsC Last change: BCM 16 Sep 2005 11:15 am SUBROUTINE getmtd(Tdgrp,Begxy,Nrxy,Fcntyp,Lam) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine sets up a variable which tells which regARIMA c trading day factor is associated with which type of month. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'tdtyp.cmn' c----------------------------------------------------------------------- INTEGER Begxy,clrngs,i,icol,Tdgrp,Nrxy,bdif,ib,Fcntyp,ndif,nn,n1, & clend,igrp,lpyrgp DOUBLE PRECISION ttd,Lam,fac,tlpyr DIMENSION Begxy(2),ttd(PLEN),tlpyr(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c Initialize ttd to zero c----------------------------------------------------------------------- CALL setdp(0.0D0,Nrxy,ttd) CALL setdp(0.0D0,Nrxy,tlpyr) c----------------------------------------------------------------------- c Generate trading day factor for first 6 trading day regression c variables (the "pure td"), and transform back to original scale. c----------------------------------------------------------------------- IF(Tdgrp.gt.0)THEN clrngs=Grp(Tdgrp-1) clend=MIN((Grp(Tdgrp)-1),(clrngs+5)) DO icol=clrngs,clend CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,ttd,1) END DO ELSE Tdtbl=0 RETURN END IF IF((Fulltd.or.Tdzero.eq.2).and.Lrgmtd)THEN clrngs=0 igrp=Tdgrp+1 DO WHILE (clrngs.eq.0) IF(Rgvrtp(Grp(igrp-1)).eq.PRRTTD.or. & Rgvrtp(Grp(igrp-1)).eq.PRRTST.or. & Rgvrtp(Grp(igrp-1)).eq.PRATTD.or. & Rgvrtp(Grp(igrp-1)).eq.PRATST.or. & Rgvrtp(Grp(igrp-1)).eq.PRR1TD.or. & Rgvrtp(Grp(igrp-1)).eq.PRA1TD)THEN clrngs=Grp(igrp-1) clend=MIN((Grp(igrp)-1),(clrngs+5)) DO icol=clrngs,clend CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,ttd,1) END DO END IF igrp=igrp+1 END DO END IF c----------------------------------------------------------------------- c Convert ttd so that the variable is indexed properly for the c seasonal adjustment routines. c----------------------------------------------------------------------- CALL invfcn(ttd,Nrxy,Fcntyp,Lam,ttd) fac=1D0 IF(Muladd.ne.1)fac=100D0 c----------------------------------------------------------------------- c see if there are leapyear regression factors c----------------------------------------------------------------------- lpyrgp=0 IF(.not.Picktd)THEN DO igrp=1,Ngrp IF(Rgvrtp(Grp(igrp-1)).eq.PRGTLY.or. & Rgvrtp(Grp(igrp-1)).eq.PRRTLY.or. & Rgvrtp(Grp(igrp-1)).eq.PRATLY)THEN clrngs=Grp(igrp-1) CALL daxpy(Nrxy,B(clrngs),Xy(clrngs),Ncxy,tlpyr,1) IF(lpyrgp.eq.0)lpyrgp=igrp END IF END DO IF(lpyrgp.gt.0)CALL invfcn(tlpyr,Nrxy,Fcntyp,Lam,tlpyr) END IF c----------------------------------------------------------------------- c Copy regARIMA trading day factors for the given type-of-month. c----------------------------------------------------------------------- * CALL dfdate(Begxy,Begtdy,Sp,ndif) n1=1 nn=Nrxy bdif=Nbcst2-Nbcst IF(Lrgmtd)THEN CALL dfdate(Tddate,Begxy,Sp,ndif) IF(Tdzero.lt.0)THEN n1=ndif+n1 ELSE nn=ndif END IF END IF DO i=n1,nn ib=i+bdif IF(dpeq(Tdmdl(Tday(ib)),DNOTST))Tdmdl(Tday(ib))=ttd(i)*fac IF(lpyrgp.gt.0)THEN IF(Tday(ib).gt.21)THEN IF(dpeq(Lpmdl(1),DNOTST))Lpmdl(1)=tlpyr(i)*fac ELSE IF(Tday(ib).ge.15)THEN IF(dpeq(Lpmdl(2),DNOTST))Lpmdl(2)=tlpyr(i)*fac END IF END IF END DO IF((Fulltd.or.Tdzero.eq.2).and.Lrgmtd)THEN IF(Tdzero.ge.0)THEN DO i=nn+1,Nrxy ib=i+bdif IF(dpeq(Tdmdl1(Tday(ib)),DNOTST))Tdmdl1(Tday(ib))=ttd(i)*fac IF(lpyrgp.gt.0.AND.(dpeq(Lpmdl1(1),DNOTST).or. & dpeq(Lpmdl1(2),DNOTST)).and.Tday(ib).ge.15)THEN IF(Tday(ib).gt.21)THEN IF(dpeq(Lpmdl1(1),DNOTST))Lpmdl1(1)=tlpyr(i)*fac ELSE IF(Tday(ib).ge.15)THEN IF(dpeq(Lpmdl1(2),DNOTST))Lpmdl1(2)=tlpyr(i)*fac END IF END IF END DO ELSE DO i=1,n1 ib=i+bdif IF(dpeq(Tdmdl1(Tday(ib)),DNOTST))Tdmdl1(Tday(ib))=ttd(i)*fac IF(lpyrgp.gt.0.AND.(dpeq(Lpmdl1(1),DNOTST).or. & dpeq(Lpmdl1(2),DNOTST)).and.Tday(ib).ge.15)THEN IF(Tday(ib).gt.21)THEN IF(dpeq(Lpmdl1(1),DNOTST))Lpmdl1(1)=tlpyr(i)*fac ELSE IF(Tday(ib).ge.15)THEN IF(dpeq(Lpmdl1(2),DNOTST))Lpmdl1(2)=tlpyr(i)*fac END IF END IF END DO END IF END IF c----------------------------------------------------------------------- RETURN END getopr.f0000664006604000003110000002465614521201504011647 0ustar sun00315stepsC Last change: Mar. 2021, change a content of a message C previous change: BCM 25 Nov 97 9:25 am SUBROUTINE getopr(Optype,Coef,Lag,Fix,Ncoef,Nd,Naimcf,Locok, & Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Check the input for MA and AR parameters and add the coefficients c and lags to the model. c----------------------------------------------------------------------- c Changed: c Determine if the lags are not specified from smallest to c largest, print a warning message if this is so and sort the lags c into the correct order by BCM on 05 Feb 2004. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c coef d Input pcoef ncoef used long vector of nonzero coefficients c to be added to arimap c fixvec l Input array to determine what parameters are fixed and c not estimated. c i i Local do loop index and temporary scalar c lag i Input pcoef ncoef used long vector of the lags of the nonzero c coefficients to be added to arimal. c ncoef i Input number of non zero coefficients in coef and lag c Nd i Ouput number of differences. c optitl c Output 20 character scalar for the title of the current c operator. c optypn c Local 20 character 3 long vector of names of the types of c operators. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER str*(LINLEN) LOGICAL Fix,getint,hvcmma,Inptok,Locok,mislag,opngrp,resort INTEGER i,ipos,Lag,mxord,Naimcf,nchr,Ncoef,Nd,Optype,tmp,ivec, & lastlg DOUBLE PRECISION Coef,dpvec DIMENSION Coef(*),Fix(*),Lag(*),dpvec(1),ivec(1) EXTERNAL getint c ------------------------------------------------------------------ CHARACTER OPRDIC*8 INTEGER oprptr,POPDIC PARAMETER(POPDIC=3) DIMENSION oprptr(0:POPDIC) PARAMETER(OPRDIC='DIFFARMA') DATA oprptr/1,5,7,9/ c----------------------------------------------------------------------- c Get the number of differences, number of lags, or the lags c themselves for one of the AR, differencing, or MA operators within c an ARIMA, (AR DIFF MA)Period, factor. Called from GETMDL. c----------------------------------------------------------------------- Locok=T resort=F Nd=0 IF(Optype.eq.DIFF)THEN mxord=PDIFOR ELSE mxord=PORDER END IF c ----------------------------------------------------------------- IF(Nxtktp.eq.EOF)THEN Locok=F c----------------------------------------------------------------------- c Look for an integer, which will indicate the order of an operator c with no missing lags. c----------------------------------------------------------------------- ELSE IF(getint(tmp))THEN Ncoef=tmp mislag=F c----------------------------------------------------------------------- c Otherwise the lags with possibly missing lags with specified c explicitly within braces, e.g., [1,4]. Anything else is an error. c----------------------------------------------------------------------- ELSE IF(Nxtktp.ne.LBRAKT)THEN CALL inpter(PERROR,Lstpos,'Expected an INTEGER or "[" not "'// & Nxttok(1:Nxtkln)//'"') Locok=F c ----------------------------------------------------------------- ELSE Ncoef=0 mislag=T opngrp=T hvcmma=F CALL lex() c----------------------------------------------------------------------- c Get each of the lags, which maybe separated by commas. No NULL c lags are allowed, so `[,', `,,', and `,]' are not allowed. c----------------------------------------------------------------------- DO WHILE (T) IF(Nxtktp.ne.RBRAKT)THEN c----------------------------------------------------------------------- c Checking for `[,' or `,,' error. c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL lag; check your commas.') Locok=F END IF c ----------------------------------------------------------------- CALL lex() hvcmma=T opngrp=F GO TO 10 c----------------------------------------------------------------------- c Check for something other than LAGs or COMMAs. c----------------------------------------------------------------------- ELSE IF(.not.(getint(tmp)))THEN CALL inpter(PERROR,Lstpos,'Expected an integer not "' & //Nxttok(1:Nxtkln)//'"') Locok=F GO TO 10 c----------------------------------------------------------------------- c Check that the number of lags does not exceed the order of the c operator. Missing lag models could still cause problems, but those c are checked in GETMDL when we have the periodicity of the factor. c----------------------------------------------------------------------- ELSE IF(Ncoef.ge.mxord)THEN CALL getstr(OPRDIC,oprptr,POPDIC,Optype,str,nchr) IF(Lfatal)RETURN ipos=nchr+17 str((nchr+1):(ipos-1))=' vector exceeds ' CALL itoc(mxord,str,ipos) IF(Lfatal)RETURN str(ipos:ipos+7)=' lag[s].' ipos=ipos+8 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F ELSE IF(tmp.lt.0)THEN CALL inpter(PERROR,Lstpos, & 'Lags specified in model must be positive integers.') Locok=F c----------------------------------------------------------------------- c No errors, add the lag. c----------------------------------------------------------------------- ELSE Ncoef=Ncoef+1 c ----------------------------------------------------------------- IF(Naimcf+Ncoef-1.gt.PARIMA)THEN CALL inpter(PERROR,Lstpos, & 'No room to add more ARIMA coefficients. Reduce the model order.' & ) Locok=F END IF c ----------------------------------------------------------------- IF(Ncoef.eq.1)THEN lastlg=tmp ELSE IF(.not.resort)THEN IF(tmp.lt.lastlg)THEN resort=T CALL inpter(PWARN,Lstpos,'Lags must be specified from smalle &st to largest; lags will be sorted.') ELSE lastlg=tmp END IF END IF Lag(Ncoef)=tmp hvcmma=F opngrp=F GO TO 10 c ----------------------------------------------------------------- END IF c---------------------------------------------------------------------- c Check for a comma after the last lag and before the close of c the list. This indicates a NULL lag, for example, [1,3,]. c---------------------------------------------------------------------- ELSE IF(hvcmma)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL lag; check your commas.') Locok=F END IF c ----------------------------------------------------------------- IF(Locok)THEN CALL lex() ELSE CALL skplst(RBRAKT) END IF GO TO 20 10 CONTINUE END DO END IF c----------------------------------------------------------------------- c If only the number of differences or lags are specified then c fill then in. c----------------------------------------------------------------------- 20 IF(.not.mislag)THEN IF(Ncoef.gt.mxord)THEN ipos=19 str(1:(ipos-1))='Maximum number of ' CALL getstr(OPRDIC,oprptr,POPDIC,Optype,str(ipos:),nchr) IF(Lfatal)RETURN ipos=ipos+nchr str(ipos:(ipos+6))=' lags, ' ipos=ipos+7 c ------------------------------------------------------------------ CALL itoc(mxord,str,ipos) IF(Lfatal)RETURN str(ipos:(ipos+10))=', exceeded.' ipos=ipos+11 CALL inpter(PERROR,Errpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE IF(Naimcf+Ncoef-1.gt.PARIMA)THEN ipos=39 str(1:(ipos-1))='Maximum number of ARIMA coefficients, ' CALL itoc(PARIMA,str,ipos) IF(Lfatal)RETURN str(ipos:(ipos+35))=', exceeded. Reduce the model order.' ipos=ipos+36 CALL inpter(PERROR,Errpos,str(1:ipos-1)) Locok=F c----------------------------------------------------------------------- c Set up the (1-B)^nd difference operator c----------------------------------------------------------------------- ELSE IF(Optype.eq.DIFF)THEN Nd=Ncoef IF(Nd.gt.0)THEN Ncoef=0 ivec(1)=1 dpvec(1)=1D0 DO i=1,Nd CALL polyml(dpvec,ivec,1,Coef,Lag,Ncoef,PDIFOR,Coef,Lag,Ncoef) END DO END IF c----------------------------------------------------------------------- c Fill in the lags for the AR or MA operator and put in default c starting values of 0.1. Note, AR and MA operators are not fixed c by default. c----------------------------------------------------------------------- ELSE IF(Ncoef.gt.0)THEN DO i=1,Ncoef Lag(i)=i END DO END IF END IF c----------------------------------------------------------------------- c Set the coefficient and fix vector if it hasn't been done. c----------------------------------------------------------------------- IF(mislag.or.Optype.ne.DIFF)CALL setdp(DNOTST,Ncoef,Coef) IF(mislag.and.resort)CALL intsrt(Ncoef,Lag) CALL setlg(Optype.eq.DIFF,Ncoef,Fix) c ------------------------------------------------------------------ Naimcf=Naimcf+Ncoef Inptok=Inptok.and.Locok RETURN END getprt.f0000664006604000003110000002073714521201504011650 0ustar sun00315stepsC Last change: BCM 8 Dec 1998 2:24 pm SUBROUTINE getprt(Spcdsp,Nspctb,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Parses the input for the print argument in each of the specs c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- INTEGER NLVL PARAMETER(NLVL=5) c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'table.prm' INCLUDE 'level.prm' INCLUDE 'hiddn.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL addtbl,argok,hvcmma,Inptok,opngrp INTEGER i,itmp,Nspctb,Spcdsp,tblidx c----------------------------------------------------------------------- CHARACTER LVLDIC*28 INTEGER lvlidx,lvlptr,PLVL PARAMETER(PLVL=5) DIMENSION lvlptr(0:PLVL) PARAMETER(LVLDIC='defaultnonebriefalltablesall') c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) LOGICAL tblmsk(NTBL) c----------------------------------------------------------------------- DATA lvlptr/1,8,12,17,26,29/ c----------------------------------------------------------------------- INCLUDE 'table.var' INCLUDE 'level.var' c----------------------------------------------------------------------- c Table argument c----------------------------------------------------------------------- hvcmma=F lvlidx=1 IF(Lnoprt)lvlidx=2 CALL setlg(T,Nspctb,tblmsk(Spcdsp+1)) c----------------------------------------------------------------------- c Check for an unexpected EOF c----------------------------------------------------------------------- IF(Nxtktp.eq.EOF)THEN Inptok=F c----------------------------------------------------------------------- c Check for a single item, a level, or a table with an optional +/- c----------------------------------------------------------------------- ELSE IF(Nxtktp.ne.LPAREN)THEN CALL gtdcnm(LVLDIC,lvlptr,NLVL,itmp,argok) IF(argok.and.itmp.gt.0)THEN lvlidx=itmp c ----------------------------------------------------------------- ELSE addtbl=T c ----------------------------------------------------------------- IF(.not.argok)THEN IF(Nxtktp.eq.MINUS.or.Nxtktp.eq.PLUS)THEN IF(Nxtktp.eq.MINUS)addtbl=F CALL lex() c ----------------------------------------------------------------- ELSE CALL inpter(PERROR,Lstpos, & 'Prefix must be "+", "-", or nothing.') CALL lex() Inptok=F END IF END IF c----------------------------------------------------------------------- c Check for a table c----------------------------------------------------------------------- IF(Spcdsp.lt.BRKDSP)THEN CALL gtdcnm(TB1DIC,tb1ptr(2*Spcdsp),2*Nspctb,tblidx,argok) ELSE IF(Spcdsp.lt.BRKDS2)THEN CALL gtdcnm(TB2DIC,tb2ptr(2*(Spcdsp-BRKDSP)),2*Nspctb,tblidx, & argok) ELSE IF(Spcdsp.lt.BRKDS3)THEN CALL gtdcnm(TB3DIC,tb3ptr(2*(Spcdsp-BRKDS2)),2*Nspctb,tblidx, & argok) ELSE CALL gtdcnm(TB4DIC,tb4ptr(2*(Spcdsp-BRKDS3)),2*Nspctb,tblidx, & argok) END IF IF(tblidx.eq.0)THEN CALL inpter(PERROR,Lstpos, & 'Print or level argument is not defined.') CALL writln(' Check the available table names and levels & for this spec.',STDERR,Mt2,F) CALL lex() Inptok=F c ------------------------------------------------------------------ ELSE tblidx=Spcdsp+(tblidx+1)/2 tblmsk(tblidx)=F Prttab(tblidx)=addtbl END IF END IF c----------------------------------------------------------------------- c Process a list (Could be a null list.) c----------------------------------------------------------------------- ELSE opngrp=T CALL lex() c ----------------------------------------------------------------- DO WHILE (T) IF(Nxtktp.eq.EOF)THEN CALL inpter(PERROR,Lstpos,'Unexpected EOF') Inptok=F GO TO 20 ELSE IF(Nxtktp.ne.RPAREN)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,acf) c or (6,,10.2,-8.3). Check for multiple NULLs. c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Inptok=F END IF c ----------------------------------------------------------------- CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a level, or a table with an optional +/- c----------------------------------------------------------------------- CALL gtdcnm(LVLDIC,lvlptr,NLVL,itmp,argok) IF(argok.and.itmp.gt.0)THEN lvlidx=itmp c ----------------------------------------------------------------- ELSE addtbl=T c ----------------------------------------------------------------- IF(.not.argok)THEN IF(Nxtktp.eq.MINUS.or.Nxtktp.eq.PLUS)THEN IF(Nxtktp.eq.MINUS)addtbl=F CALL lex() c ----------------------------------------------------------------- ELSE CALL inpter(PERROR,Lstpos, & 'Prefix must be "+", "-", or nothing') CALL lex() Inptok=F GO TO 10 END IF END IF c----------------------------------------------------------------------- c Check for a table. c----------------------------------------------------------------------- IF(Spcdsp.lt.BRKDSP)THEN CALL gtdcnm(TB1DIC,tb1ptr(2*Spcdsp),2*Nspctb,tblidx,argok) ELSE IF(Spcdsp.lt.BRKDS2)THEN CALL gtdcnm(TB2DIC,tb2ptr(2*(Spcdsp-BRKDSP)),2*Nspctb,tblidx, & argok) ELSE IF(Spcdsp.lt.BRKDS3)THEN CALL gtdcnm(TB3DIC,tb3ptr(2*(Spcdsp-BRKDS2)),2*Nspctb,tblidx, & argok) ELSE CALL gtdcnm(TB4DIC,tb4ptr(2*(Spcdsp-BRKDS3)),2*Nspctb,tblidx, & argok) END IF IF(tblidx.eq.0)THEN CALL inpter(PERROR,Lstpos, & 'Print or level argument is not defined.') CALL writln(' Check the available table names and leve &ls for this spec.',STDERR,Mt2,F) CALL lex() Inptok=F c ----------------------------------------------------------------- ELSE tblidx=Spcdsp+(tblidx+1)/2 tblmsk(tblidx)=F Prttab(tblidx)=addtbl END IF END IF c ----------------------------------------------------------------- hvcmma=F opngrp=F c----------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. This indicates a NULL value, for example, (acf,pacf,). c----------------------------------------------------------------------- ELSE IF(hvcmma)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Inptok=F END IF CALL lex() GO TO 20 END IF 10 CONTINUE END DO END IF c---------------------------------------------------------------------- c Construct the print tables for the spec c---------------------------------------------------------------------- 20 IF(Inptok)THEN DO i=Spcdsp+1,Spcdsp+Nspctb IF(tblmsk(i))Prttab(i)=level(i,lvlidx) END DO END IF c ----------------------------------------------------------------- RETURN END getreg.f0000664006604000003110000010766614521201504011627 0ustar sun00315stepsC Last change: Otc, 2021 - add trendtc argument in regression C previous change:Mar. 2021 C previous change: BCM 28 Sep 99 2:46 pm SUBROUTINE getreg(Begsrs,Endmdl,Nobs,Havsrs,Havesp,Userx,Nrusrx, & Bgusrx,Itdtst,Leastr,Eastst,Luser,Lttc,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----------------------------------------------------------------------- c Add Endmdl as argument to getreg, gtpdrg for a new format of the c end of the series for sequence outliers such as c AOSdate-0.0/LSSdate-0.0 c Mar. 2021 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, & hvaicd,hvpva,locok,Lttc INTEGER Bgusrx,Begsrs,Endmdl,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),Endmdl(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*158 INTEGER argidx,argptr,PARG,arglog PARAMETER(PARG=23) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='variablesuserdatastartfileformatbprintsaveaictes &teastermeansnoapplyusertypetcrateaicdiffsavelogcenteruserchi2testc &hi2testcvtlimitpvaictesttestalleastertrendtc') 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,159/ 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 hvaicd=F hvpva=F locok=T 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,199)argidx c----------------------------------------------------------------------- c variables argument c Add Endmdl as an argument to gtpdrg c----------------------------------------------------------------------- 10 CALL gtpdrg(Begsrs,Endmdl,Nobs,Havsrs,Havesp,F,havtd,Havhol, & havln,havlp,argok,locok) 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, & locok) 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,locok) 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,locok) 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,locok) 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,locok) 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,locok) IF(Lfatal)RETURN GO TO 200 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 80 CALL getprt(LSPREG,NSPREG,locok) GO TO 200 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 90 CALL getsav(LSPREG,NSPREG,locok) 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,locok) 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.') locok=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.') locok=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.') locok=F END IF END IF END DO IF(locok)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,locok) 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,locok) 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,locok) 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,locok) 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,locok) 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.') locok=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 (aicdiff) c----------------------------------------------------------------------- 160 IF(hvpva)THEN CALL inpter(PERROR,Errpos, & 'Use either aicdiff or pvaictest, not both') locok=F END IF CALL gtdpvc(LPAREN,F,PAICT,daicdf,nelt,argok,locok) IF(Lfatal)RETURN IF(argok)THEN hvaicd=T 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,locok) 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,locok) 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,locok) 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.') locok=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,locok) 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.') locok=F ELSE Tlimit=dvec(1) END IF END IF GO TO 200 c----------------------------------------------------------------------- c pvaictest argument c----------------------------------------------------------------------- 192 IF(hvaicd)THEN CALL inpter(PERROR,Errpos, & 'Use either aicdiff or pvaictest, not both') locok=F END IF CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,locok) 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.') locok=F ELSE IF(dvec(1).ge.ONE)THEN CALL inpter(PERROR,Errpos, & 'Value of pvaictest must be less than 1.') locok=F ELSE Pvaic=ONE-dvec(1) hvpva=T 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,locok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lceaic=ivec(1).eq.1 GO TO 200 c----------------------------------------------------------------------- c trendtc argument c----------------------------------------------------------------------- 199 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN, & 'Choices for trendtc are yes and no.', & ivec,nelt,argok,locok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lttc=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(locok.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,locok) ELSE WRITE(STDERR,1010) WRITE(Mt2,1010) END IF END IF c----------------------------------------------------------------------- c Check for the required arguments c----------------------------------------------------------------------- IF(locok.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.') locok=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).') locok=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,'.',/) locok=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 locok=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.') locok=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 locok=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 locok=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 locok=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----------------------------------------------------------------------- Inptok =Inptok.and.locok RETURN 200 CONTINUE END DO c ----------------------------------------------------------------- END getrevdec.f0000664006604000003110000014313714521201504012313 0ustar sun00315steps SUBROUTINE getRevDecomp( vPhiN, pn, vPhiS, ps, vThetaN, qn, & vThetaS, qs, vTheta, q, nPer, tbl53Lag, & sVarM, sVarN, sVarS, mMin, mMax, & vInfMSE, vInfMSE1, vInfMSE2, vInfMSE3, & pd1, pd2, pd3, pd4, pd5, pd6, pd7 ) c----------------------------------------------------------------------- c getRevDec.f, Release 1, Subroutine Version 1.0, Created 14 Nov 2005. c----------------------------------------------------------------------- c This performs the Revision Decomposition in order to calculate c the desired MSEs using m in [mMin, mMax] past observations and c infinite future observations, as described in McElroy and Findley c paper "Model-Based Analysis of Signal Extraction Revision Errors". c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c vInfMSE d Semi-infinite MSE based on m observations in the past c and infinite observations in the future. c mMax i Maximum number of past observations in revision c mMin i Minimum number of past observations in revision c pn i Order of vPhiN AR polynomial for noise process c ps i Order of vPhiS AR polynomial for signal process c q i Order of vTheta MA polynomial for model process c qn i Order of vThetaN MA polynomial for noise process c qs i Order of vThetaS MA polynomial for signal process c sVarM d Innovation variance for the model process c sVarN d Innovation variance for the noise process c sVarS d Innovation variance for the signal process c vPhiN d Vector containing AR polynomial for noise process c vPhiS d Vector containing AR polynomial for signal process c vTheta d Vector containing MA polynomial for model process c vThetaN d Vector containing MA polynomial for noise process c vThetaS d Vector containing MA polynomial for signal process c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c mIndex i Index variable used in do loop that ranges over c [1,...,mMax-mMin+1]. c ishift i Used to calculate how much to shift vThetaS and vThetaN c ONE d Parameter constant. c sdum i Dummy variable used in call to cpyVec() c sTP1 i Size of vTP1 polynomial vector. c sTP2 i Size of vTP2 polynomial vector. c vTP1 d Temporary polynomial vector used to calculate new c partial fraction decomposition for m+1 observation using c existing partial fraction decomposition for m observations. c vTP2 d Temporary polynomial vector used like vTP1. c ZERO d Parameter constant. c----------------------------------------------------------------------- c The following local variables are associated with developing the c partial fraction decomposition of the signal filter. c----------------------------------------------------------------------- c indS i indicator variable passed to GTWACF() c sDmS0 d First coefficient in vDmS0 c sDmS i Size of vDmS vector c sDmSN i Size of vDmSN vector c sHS i Size of vHS vector c sNumP1S i Size of vNumP1S vector c sNumP2S i Size of vNumP2S vector c sPSMA i Size of vPSMA vector c sVarPS d Innovation variance input to GTWACF() c vCorS d Dummy argument for GTWACF() c vCovS d Lag 0 autocovariance output by GTWACF() c vDmS0R d Reciprocal of sDmS0 c vDmS d Combination polynomial: vKS x vThetaS + vGS c vDmSN d Normalized vDmS c vHS d One of the numerator polynomials output by getPFrac() c vNumP1S d vPhiN x vThetaS polynomial c vNumP2S d vThetaS x F^m polynomial c vPSMA d MA polynomial input to GTWACF() c----------------------------------------------------------------------- c The following local variables are associated with developing the c partial fraction decomposition of the noise filter. c----------------------------------------------------------------------- c indN i indicator variable passed to GTWACF() c sDmN0 d First coefficient in vDmN0 c sDmN i Size of vDmN vector c sDmNN i Size of vDmNN vector c sHN i Size of vHN vector c sNumP1N i Size of vNumP1N vector c sNumP2N i Size of vNumP2N vector c sPNMA i Size of vPNMA vector c sVarPN d Innovation variance input to GTWACF() c vCorN d Dummy argument for GTWACF() c vCovN d Lag 0 autocovariance output by GTWACF() c vDmNOR d Reciprocal of sDmN0 c vDmN d Combination polynomial: vKN x vThetaN + vGN c vDmNN d Normalized vDmN c vHN d One of the numerator polynomials output by getPFrac() c vNumP1N d vPhiS x vThetaN polynomial c vNumP2N d vThetaN x F^m polynomial input to getPFrac() c vPNMA d MA polynomial input to GTWACF() c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER mMin, mMax, nPer, pn, ps, qn, qs, q, tbl53Lag DOUBLE PRECISION vPhiN(0:pn), vPhiS(0:ps), vThetaN(0:qn), & vThetaS(0:qs), vTheta(0:q) DOUBLE PRECISION sVarM, sVarN, sVarS DOUBLE PRECISION vInfMSE(72), vInfMSE1(72), & vInfMSE2(72), vInfMSE3(72) c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pd1, pd2, pd3, pd4, pd5, pd6, pd7, pshift, psC, pp1, pp2, & pp3, pp4, ppqa c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER ishift, mIndex, sdum, sTP1, sTP2 DOUBLE PRECISION ONE, ZERO, vTP1(pd1+1), vTP2(0:0) PARAMETER (ONE=1.0D0, ZERO=0.0D0) LOGICAL dpeq c ------------------------------------------------------------------ INTEGER indS, sDmS, sDmSN, sHS, sNumP1S, sNumP2S, sPSMA DOUBLE PRECISION vNumP1S(0:pn+qs), vNumP2S(0:mMin+qs) DOUBLE PRECISION vHS(0:pd2) DOUBLE PRECISION vDmS(0:pd3) DOUBLE PRECISION sDmS0, vDmS0R(0:0) DOUBLE PRECISION vDmSN(0:pd3) DOUBLE PRECISION vPSMA(0:pd3+qn), sVarPS DOUBLE PRECISION vCovS(0:nPer), vCorS(nPer) c ------------------------------------------------------------------ INTEGER indN, sDmN, sDmNN, sHN, sNumP1N, sNumP2N, sPNMA DOUBLE PRECISION vNumP1N(0:ps+qn), vNumP2N(0:mMin+qn) DOUBLE PRECISION vHN(0:pd4) DOUBLE PRECISION vDmN(0:pd5) DOUBLE PRECISION sDmN0, vDmN0R(0:0) DOUBLE PRECISION vDmNN(0:pd5) DOUBLE PRECISION vPNMA(0:pd5+qs), sVarPN DOUBLE PRECISION vCovN(0:nPer), vCorN(nPer) c ------------------------------------------------------------------ c Declare debug variables. c ------------------------------------------------------------------ INTEGER maxI, nNum1(2), nNum2(2), nP1(2), nP2(2), sFP1, sFP2, & sNum1, sNum2, sNum3, sP1, sP2, sRP1, sRP2, sRTheta DOUBLE PRECISION maxDif DOUBLE PRECISION vFP1(0:pn+qs), vFP2(0:ps+qn), & vRP1(0:pn+qs), vRP2(0:ps+qn) DOUBLE PRECISION vP1(0:2*pd6), & vP2(0:2*pd6) DOUBLE PRECISION vNum1(0:2*pd7), & vNum2(0:2*pd7), & vNum3(0:2*pd7) DOUBLE PRECISION vRTheta(0:q) c----------------------------------------------------------------------- c Debug output and processing. c----------------------------------------------------------------------- c WRITE(6,1000)pn,ps,qn,qs,q,m c WRITE(6,1000) c WRITE(6,1000)(vPhiN(i),i=0,pn) c WRITE(6,1000) c WRITE(6,1000)(vPhiS(i),i=0,ps) c WRITE(6,1000) c WRITE(6,1000)(vThetaN(i),i=0,qn) c WRITE(6,1000) c WRITE(6,1000)(vThetaS(i),i=0,qs) c WRITE(6,1000) c WRITE(6,1000)(vTheta(i),i=0,q) c WRITE(6,1000) c ------------------------------------------------------------------ c Calculate numerator of the pseudo AGF for the ARIMA model. c ------------------------------------------------------------------ c CALL polyRev( vTheta, q+1, vRTheta, sRTheta ) c CALL CONV( vTheta, q+1, vRTheta, sRTheta, vNum1, sNum1 ) c nNum1(1)=sNum1 c nNum1(2)=1 c CALL mulSca( sVarM, vNum1, nNum1 ) c ------------------------------------------------------------------ c Calculate numerator of the pseudo AGF for the S + N decomposition. c ------------------------------------------------------------------ c CALL CONV( vPhiN, pn+1, vThetaS, qs+1, vFP1, sFP1 ) c CALL polyRev( vFP1, sFP1, vRP1, sRP1 ) c CALL CONV( vFP1, sFP1, vRP1, sRP1, vP1, sP1 ) c nP1(1)=sP1 c nP1(2)=1 c CALL mulSca( sVarS, vP1, nP1 ) c CALL CONV( vPhiS, ps+1, vThetaN, qn+1, vFP2, sFP2 ) c CALL polyRev( vFP2, sFP2, vRP2, sRP2 ) c CALL CONV( vFP2, sFP2, vRP2, sRP2, vP2, sP2 ) c nP2(1)=sP2 c nP2(2)=1 c CALL mulSca( sVarN, vP2, nP2 ) c IF ( sP1 .gt. sP2 ) THEN c CALL polyShft( vP2, sP2, (pn+qs)-(ps+qn), vP2, sP2 ) c ELSE IF ( sP1 .lt. sP2 ) THEN c CALL polyShft( vP1, sP1, (ps+qn)-(pn+qs), vP1, sP1 ) c END IF c CALL polyAdd( vP1, sP1, vP2, sP2, vNum2, sNum2 ) c ------------------------------------------------------------------ c Compare numerators of the two AGFs above. Should be nearly equal. c ------------------------------------------------------------------ c IF ( sNum1 .gt. sNum2 ) THEN c CALL polyShft( vNum2, sNum2, q-max(pn+qs,ps+qn), vNum2, sNum2 ) c ELSE IF (sNum1 .lt. sNum2 ) THEN c CALL polyShft( vNum1, sNum1, max(pn+qs,ps+qn)-q, vNum1, sNum1 ) c END IF c nNum2(1) = sNum2 c nNum2(2) = 1 c CALL mulSca( -1.0d0, vNum2, nNum2 ) c CALL polyAdd( vNum1, sNum1, vNum2, sNum2, vNum3, sNum3 ) c maxDif = DABS( vNum3(0) ) c maxI = 0 c DO i=1,sNum3-1 c IF ( DABS( vNum3(i) ) .gt. maxDif ) THEN c maxDif = DABS( vNum3(i) ) c maxI = i c END IF c END DO c ------------------------------------------------------------------ c Debug output c ------------------------------------------------------------------ c WRITE(6,1000)(vP1(i),i=0,sP1-1) c WRITE(6,1000) c WRITE(6,1000)(vP2(i),i=0,sP2-1) c WRITE(6,1000) c WRITE(6,1000)(vNum2(i),i=0,sNum2-1) c WRITE(6,1000) c WRITE(6,1000)(vNum1(i),i=0,sNum1-1) c WRITE(6,1000) c WRITE(6,500)maxDif,maxI c WRITE(6,1000) c 500 FORMAT(' MaxDif in Num is: ', G12.5, 1x, I4 ) c----------------------------------------------------------------------- c Calculate d(m) for signal. c First calculate the numerator polynomials in powers of F and B. c----------------------------------------------------------------------- CALL CONV( vPhiN, pn+1, vThetaS, qs+1, vNumP1S, sNumP1S ) pshift = max(qs+1+mMin,1) CALL polyShft( vThetaS, qs+1, mMin, vNumP2S, sNumP2S, pshift ) c ------------------------------------------------------------------ c Perform partial fraction decomposition to get the d(m) polynomial. c ------------------------------------------------------------------ IF ( mMin .ge. (pn+qs) ) THEN pp1 = max(sNumP2S,ps+1,q) pp2 = max(sNumP1S,q+1) pp3 = max(q,ps+1) pp4 = max(sNumP2S-q,1) CALL getPFrac( vNumP2S, sNumP2S, vNumP1S, sNumP1S, & vPhiS, ps+1, vTheta, q+1, & vDmS, sDmS, vHS, sHS, pp1, pp2, pp3, pp4 ) ELSE pp1 = max(sNumP2S,ps+1,q) pp2 = max(sNumP1S,q+1) pp3 = max(sNumP2S,ps+1) CALL getSPFrac( vNumP2S, sNumP2S, vNumP1S, sNumP1S, & vPhiS, ps+1, vTheta, q+1, & vDmS, sDmS, vHS, sHS, pp1, pp2, pp3 ) END IF c----------------------------------------------------------------------- c Debug output c----------------------------------------------------------------------- c WRITE(6,1000)(vHS(i),i=0,sHS-1) c WRITE(6,1000) c WRITE(6,1000)(vDmS(i),i=0,sDmS-1) c WRITE(6,1000) c----------------------------------------------------------------------- c Calculate d(m) for noise. c First calculate the numerator polynomials in powers of F and B. c----------------------------------------------------------------------- CALL CONV( vPhiS, ps+1, vThetaN, qn+1, vNumP1N, sNumP1N ) pshift = max(qn+1+mMin,1) CALL polyShft( vThetaN, qn+1, mMin, vNumP2N, sNumP2N, pshift ) c ------------------------------------------------------------------ c Perform partial fraction decomposition to get the d(m) polynomial. c ------------------------------------------------------------------ IF ( mMin .ge. (ps+qn) ) THEN pp1 = max(sNumP2N,pn+1,q) pp2 = max(sNumP1N,q+1) pp3 = max(q,pn+1) pp4 = max(sNumP2N-q,1) CALL getPFrac( vNumP2N, sNumP2N, vNumP1N, sNumP1N, & vPhiN, pn+1, vTheta, q+1, & vDmN, sDmN, vHN, sHN, pp1, pp2, pp3, pp4 ) ELSE pp1 = max(sNumP2N,pn+1,q) pp2 = max(sNumP1N,q+1) pp3 = max(sNumP2N,pn+1) CALL getSPFrac( vNumP2N, sNumP2N, vNumP1N, sNumP1N, & vPhiN, pn+1, vTheta, q+1, & vDmN, sDmN, vHN, sHN, pp1, pp2, pp3 ) END IF c----------------------------------------------------------------------- c Debug output c----------------------------------------------------------------------- c WRITE(6,1000)(vHN(i),i=0,sHN-1) c WRITE(6,1000) c WRITE(6,1000)(vDmN(i),i=0,sDmN-1) c WRITE(6,1000) c----------------------------------------------------------------------- c No need to normalize the d(m) for signal and noise since the c GTWACF() routine can handle this and then calculate the innovation c variances for the two processes that together provide the MSE. c Note that (VarS, VarN) are already calulated relative to VarM c and (VarPS, VarPN) are calculated relative to VarM so that c (CovS, CovN) are calculated by GTWACF() relative to VarM. c----------------------------------------------------------------------- DO mIndex=1, mMax-mMin+1 IF ( .not. dpeq(vDmS(0),ZERO) ) THEN sDmS0 = vDmS(0) ELSE sDmS0 = ONE END IF vDmS0R(0) = DBLE(ONE/sDmS0) CALL CONV( vDmS0R, 1, vDmS, sDmS, vDmSN, sDmSN ) CALL CONV( vDmSN, sDmSN, vThetaN, qn+1, vPSMA, sPSMA ) c sVarPS = ((sDmS0*sVarS/sVarM)**2)*sVarN sVarPS = ((sDmS0*sVarS)**2)*sVarN ppqa = max( q, sPSMA-1, nPer+1 ) pp1 = max( q, 1 ) CALL GTWACF( q, sPSMA-1, nPer+1, vTheta, vPSMA, sVarPS, & vCovS, vCorS, indS, ppqa, pp1 ) c ------------------------------------------------------------------ IF ( .not. dpeq(vDmN(0),ZERO) ) THEN sDmN0 = vDmN(0) ELSE sDmN0 = ONE END IF vDmN0R(0) = DBLE(ONE/sDmN0) CALL CONV( vDmN0R, 1, vDmN, sDmN, vDmNN, sDmNN ) CALL CONV( vDmNN, sDmNN, vThetaS, qs+1, vPNMA, sPNMA ) c sVarPN = ((sDmN0*sVarN/sVarM)**2)*sVarS sVarPN = ((sDmN0*sVarN)**2)*sVarS ppqa = max( q, sPNMA-1, nPer+1 ) pp1 = max( q, 1 ) CALL GTWACF( q, sPNMA-1, nPer+1, vTheta, vPNMA, sVarPN, & vCovN, vCorN, indN, ppqa, pp1 ) c----------------------------------------------------------------------- c Calculate the MSE relative to VarM. c----------------------------------------------------------------------- IF (( indS .eq. 0 ) .and. ( indN .eq. 0 )) THEN c sInfMSE = (vCovS(0)+vCovN(0))/sVarM vInfMSE(mIndex) = (vCovS(0)+vCovN(0)) vInfMSE1(mIndex) = (vCovS(1)+vCovN(1)) vInfMSE2(mIndex) = (vCovS(nPer)+vCovN(nPer)) vInfMSE3(mIndex) = (vCovS(tbl53Lag)+vCovN(tbl53Lag)) ELSE vInfMSE(mIndex) = ZERO vInfMSE1(mIndex) = ZERO vInfMSE2(mIndex) = ZERO vInfMSE3(mIndex) = ZERO END IF c----------------------------------------------------------------------- c Debug output c----------------------------------------------------------------------- c WRITE(6,1000)DBLE(q),DBLE(sPSMA-1),sVarPS c WRITE(6,1000)sDmS0,sVarN,sVarS,sVarM c WRITE(6,1000)sDmN0,sVarN,sVarS,sVarM c WRITE(6,1000)DBLE(q),DBLE(sPNMA-1),sVarPN c WRITE(6,1000) sVarM, sVarS, sVarN c WRITE(6,1000) vCovS(0), vCovN(0), DBLE(indS), DBLE(indN), sInfMse c1000 FORMAT( 100(6(G12.5,1x),/) ) c----------------------------------------------------------------------- c Calculate partial fraction decomposition that gives d(m+1) c polynomial from partial fraction decomposition that gave c d(m) polynomial. c----------------------------------------------------------------------- IF ( mIndex .lt. mMax-mMin+1 ) THEN pshift = max(1+sDmS,1) CALL polyShft( vDmS, sDmS, 1, vDmS, sDmS, pshift ) vTP2(0) = vHS(1) sTP2=1 CALL CONV( vTP2, sTP2, vPhiS, ps+1, vTP1, sTP1 ) psC = max(sDmS,sTP1) CALL polyAdd( vDmS, sDmS, vTP1, sTP1, vDmS, sDmS, psC ) c ------------------------------------------------------------------ pshift = max(sHS-1,1) CALL polyShft( vHS, sHS, -1, vHS, sHS, pshift ) vTP2(0) = -vTP2(0) CALL CONV( vTP2, sTP2, vTheta, q+1, vTP1, sTP1 ) psC = max(sHS,sTP1) CALL polyAdd( vHS, sHS, vTP1, sTP1, vHS, sHS, psC ) c ------------------------------------------------------------------ pshift = max(1+sDmN,1) CALL polyShft( vDmN, sDmN, 1, vDmN, sDmN, pshift ) vTP2(0) = vHN(1) c sTP2=1 CALL CONV( vTP2, sTP2, vPhiN, pn+1, vTP1, sTP1 ) psC = max(sDmN,sTP1) CALL polyAdd( vDmN, sDmN, vTP1, sTP1, vDmN, sDmN, psC ) c ------------------------------------------------------------------ pshift = max(sHN-1,1) CALL polyShft( vHN, sHN, -1, vHN, sHN, pshift ) vTP2(0) = -vTP2(0) CALL CONV( vTP2, sTP2, vTheta, q+1, vTP1, sTP1 ) psC = max(sHN,sTP1) CALL polyAdd( vHN, sHN, vTP1, sTP1, vHN, sHN, psC ) END IF END DO RETURN END c----------------------------------------------------------------------- SUBROUTINE getPFrac( vA1, sA1, vA2, sA2, vB1, sB1, vB2, sB2, & vCD, sCD, vE, sE, pp1, pp2, pp3, pp4 ) c----------------------------------------------------------------------- c This subroutine performs a partial fraction decomposition of the c rational function represented by the numerator polynomial A divided c by the denominator polynomial B where the denominator polynomial B c consists of the product of two subpolynomials B1(F) and B2(B) c with subpolynomial B2 is invertible and where the numerator c polynomial A consists of the product of two subpolynomials c A1(F) and A2(B). c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c sA1 i Size of numerator product term 1 polynomial c sA2 i Size of numerator product term 2 polynomial c sB1 i Size of denominator product term 1 polynomial c sB2 i Size of denominator product term 2 polynomial c sCD i Size of numerator polynomial for first partial fraction c sE i Size of numerator polynomial for second partial fraction c vA d Vector of numerator polynomial c vB1 d Vector of denominator polynomial product term 1 c vB2 d Vector of denominator polynomial product term 2 c vCD d Vector of numerator polynomial for first partial fraction c vE d Vector of numerator polynomial for second partial fraction c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i,j i Index variables for do loops c jindex i Index used to navigate mS matrix c k c ONE d Parameter c sA i Size of sA polynomial. c sA12 i Size of vA12 polynomial. c sD i Size of vD polynomial. c sdum i Dummy size variable. c sQuot i Size of vQuot polynomial. c sRA2 i Size of vRA2 polynomial. c sRB2 i Size of vRB2 polynomial. c sRem i Size of vRem polynomial. c s1 i Size of v1 polynomial. c vA d Shifted version of A12 that accounts for no powers of B. c vA12 d Polynomial product of A1 and A2 polynomials. c vD d Partial fraction numerator returned by getSPFrac(). c vQuot d Quotient polynomial returned by polyQuot(). c vRA2 d Reversed version of vA2 polynomial. c vRB2 d Reversed version of vB2 polynomial. c vRem d Vector of remainder polynomial from polynomial division c for A/B. c v1 d Order 0 polynomial equal to 1. c ZERO d Parameter c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- c BCM added input variables pp1, pp2, pp3, pp4 to eliminate max c statements in dimension arguments that were causing Unix to bomb, c and added local variable ppp1, ppp2, and ppp3 to dimension c variables in getSPFrac c----------------------------------------------------------------------- INTEGER sA1, sA2, sB1, sB2, sCD, sE INTEGER pp1, pp2, pp3, pp4, ppp1, ppp2, ppp3 DOUBLE PRECISION vA1(sA1), vA2(sA2), vB1(sB1), vB2(sB2), & vCD(pp1), vE(pp2) INTEGER pshift, psC c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, jindex, k, sA, sA12, sD, sdum, sQuot, sRA2, sRB2, & sRem, s1 DOUBLE PRECISION vA(sA1), vA12(sA1+sA2-1), vD(pp3), & vQuot(pp4), vRA2(sA2), & vRB2(sB2), vRem(sB2-1), v1(1) DOUBLE PRECISION ONE, ZERO PARAMETER (ONE=1.0D0, ZERO=0.0D0) c ------------------------------------------------------------------ c Declare debug variables. c ------------------------------------------------------------------ INTEGER maxI, sP1, sP2, sP3, sP4, sP5, sRE DOUBLE PRECISION vP1(2*(sA1+sA2-1)), vP2(2*(sA1+sA2-1)), & vP3(2*(sA1+sA2-1)), vRE(pp2) DOUBLE PRECISION maxDif, newDif c----------------------------------------------------------------------- c Combine the A1 and A2 polynomials. c----------------------------------------------------------------------- CALL polyRev( vA2, sA2, vRA2, sRA2 ) CALL CONV( vA1, sA1, vRA2, sRA2, vA12, sA12 ) CALL cpyVec( vA12(sA2), sA1, vA, sA ) c----------------------------------------------------------------------- c Reverse the B2 subpolynomial c----------------------------------------------------------------------- CALL polyRev( vB2, sB2, vRB2, sRB2 ) c----------------------------------------------------------------------- c Divide polynomial A by polynomial B, c resulting in a quotient and remainder polynomials. c----------------------------------------------------------------------- IF ( sRB2 .le. sA ) THEN CALL polyQuot( vA, sA, vRB2, sRB2, vQuot, sQuot, vRem, sRem ) ELSE sQuot = 1 vQuot(1) = ZERO CALL cpyVec( vQuot(1), max(sA-sB2,0), vQuot(2), sdum ) CALL cpyVec( vA, sA, vRem, sRem ) END IF c----------------------------------------------------------------------- c Perform the small partial fraction decomposition. c----------------------------------------------------------------------- s1 = 1 v1(1) = ONE ppp1 = max(sRem,sB1,sB2-1) ppp2 = max(s1,sB2) ppp3 = max(sRem,sB1) CALL getSPFrac( vRem, sRem, v1, s1, vB1, sB1, vB2, sB2, & vD, sD, vE, sE, ppp1, ppp2, ppp3 ) c----------------------------------------------------------------------- c Combine the Quot and D polynomials. c----------------------------------------------------------------------- pshift = max(sQuot+sB2-1,1) CALL polyShft( vQuot, sQuot, sB2-1, vCD, sCD, pshift ) psC = max(sCD,sD) CALL polyAdd( vCD, sCD, vD, sD, vCD, sCD, psC ) c----------------------------------------------------------------------- c Debug code. c----------------------------------------------------------------------- c CALL CONV( vCD, sCD, vRB2, sRB2, vP1, sP1 ) c CALL polyRev( vE, sE, vRE, sRE ) c CALL CONV( vRE, sRE, vB1, sB1, vP2, sP2 ) c CALL polyAdd( vP1(sB2), sP1-sB2+1, vP2(sE), sP2-sE+1, vP3, sP3 ) c maxDif = DABS( vA(1)-vP3(1) ) c maxI = 1 c DO i = 2, sA c newDif = DABS( vA(i)-vP3(i) ) c IF ( newDif .gt. maxDif ) THEN c maxDif = newDif c maxI = i c END IF c END DO c WRITE(6,1001)maxDif, maxI c WRITE(6,1000)(vQuot(i),i=1,sQuot) c WRITE(6,1000) c WRITE(6,1000)(vRem(i),i=1,sRem) c WRITE(6,1000) c WRITE(6,1000)(vD(i),i=1,sD) c WRITE(6,1000) c WRITE(6,1000)(vE(i),i=1,sE) c WRITE(6,1000) c WRITE(6,1000)(vA(i),i=1,sA) c WRITE(6,1000) c WRITE(6,1000)(vP1(sB2+i-1),i=1,sA) c WRITE(6,1000) c WRITE(6,1000)(vP2(sE+i-1),i=1,sA) c WRITE(6,1000) c WRITE(6,1000)(vP3(i),i=1,sP3) c WRITE(6,1000) c1000 FORMAT( 100(6(G12.5,1x),/) ) c1001 FORMAT( ' getPfrac maxDif: ', G12.5, 1x, I4 ) RETURN END c----------------------------------------------------------------------- SUBROUTINE polyQuot( vA, sA, vB, sB, vQuot, sQuot, vRem, sRem ) c----------------------------------------------------------------------- c polyQuot, Release 1, Subroutine Version 1.0, Created 14 Nov 2005. c----------------------------------------------------------------------- c This subroutine performs polynomial division of vA by vB c resulting in a quotient vQuot and a remainder vRem. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c sA i Size of numerator polynomial vector c sB i Size of denominator polynomial vector c sQuot i Size of quotient polynomial vector c sRem i Size of remainder polynomial vector c vA d Vector of numerator polynomial c vB d Vector of denominator polynomial c vQuot d Vector of quotient polynomial c vRem d Vector of remainder polynomial c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i,j i Index variables for do loops c ONE d Parameter c sAN i Size of vAN polynomial c sBN i Size of vBN polynomial c sdum i Dummy size variable c sW i Size of vW polynomial c v1 d Normalizing constant equal to vB(1) c v2 d Normalizing constant equal to 1/vB(1) c v3 d Constant used to facilitate polynomial subtraction c vAN d vA normalized by vB(1). c vBN d vB normalized by vB(1). c vW d Working polynomial used to determine vQuot and vRem. c ZERO d Parameter c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER sA, sB, sQuot, sRem DOUBLE PRECISION vA(sA), vB(sB), vQuot(*), vRem(*) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, sdum, sAN, sBN, sW, psC DOUBLE PRECISION v1(1), v2(1), v3(1), vAN(sA), vBN(sB), vW(sA) DOUBLE PRECISION ONE, ZERO PARAMETER (ONE=1.0D0, ZERO=0.0D0) LOGICAL dpeq c ------------------------------------------------------------------ c Declare debug variables. c ------------------------------------------------------------------ INTEGER sP1, sP2 DOUBLE PRECISION vP1(sA), vP2(sA) c----------------------------------------------------------------------- c Normalize the vA and vB polynomials per vB(1) c----------------------------------------------------------------------- v1(1) = vB(1) v2(1) = ONE/v1(1) CALL CONV( v2, 1, vA, sA, vAN, sAN ) CALL CONV( v2, 1, vB, sB, vBN, sBN ) c----------------------------------------------------------------------- c If the size of the numerator vA is greater or equal c to the size of the denominator vB then c----------------------------------------------------------------------- IF ( sA .ge. sB ) THEN sQuot = sA-sB+1 CALL cpyVec( vAN, sAN, vW, sW ) vQuot(1)=ZERO CALL cpyVec( vQuot(1), sQuot-1, vQuot(2), sdum ) c----------------------------------------------------------------------- c Calculate the quotient coefficients by using the leading c coefficients in the denominator and the working polynomials c and adjust the working polynomial by subtracting the denomiator c polynomial as weighted by the quotient. The end result in the c working polynomial is the remainder. c----------------------------------------------------------------------- v3(1) = -ONE DO i = sQuot, 1, -1 vQuot(i) = vW( sW-(sQuot-i) ) / vBN( sB ) c ------------------------------------------------------------------ c DO j = 0, sBN-1 c vW( sW-j ) = vW( sW-j ) - vBN( sBN-j )*vQuot(i) c END DO c sW = sW-1 c ------------------------------------------------------------------ CALL CONV( vQuot, sQuot, vBN, sBN, vW, sW ) CALL CONV( v3, 1, vW, sW, vW, sW ) psC = max(sAN,sW) CALL polyAdd( vAN, sAN, vW, sW, vW, sW, psC ) END DO CALL CONV( v1, 1, vW, sW, vW, sW ) CALL cpyVec( vW, sW-sQuot, vRem, sRem ) c----------------------------------------------------------------------- c Else the size of the numerator vA is less than c the size of the denominator vB then c----------------------------------------------------------------------- ELSE sQuot = 1 vQuot(1) = ZERO CALL cpyVec( vQuot(1), sB-1, vQuot(2), sdum ) CALL cpyVec( vA, sA, vRem, sRem ) END IF c----------------------------------------------------------------------- c Debug code. c----------------------------------------------------------------------- c CALL CONV( vB, sB, vQuot, sQuot, vP1, sP1 ) c CALL polyAdd( vRem, sRem, vP1, sP1, vP2, sP2 ) c v3(1) = -ONE c CALL CONV( v3, 1, vP1, sP1, vP1, sP1 ) c CALL polyAdd( vA, sA, vP1, sP1, vP1, sP1 ) c WRITE(6,1000)(vA(i),i=1,sA) c WRITE(6,1000) c WRITE(6,1000)(vB(i),i=1,sB) c WRITE(6,1000) c WRITE(6,1000)(vQuot(i),i=1,sQuot) c WRITE(6,1000) c WRITE(6,1000)(vRem(i),i=1,sRem) c WRITE(6,1000) c WRITE(6,1000)(vP2(i),i=1,sP2) c WRITE(6,1000) c WRITE(6,1000)(vP1(i),i=1,sP1) c WRITE(6,1000) c1000 FORMAT( 100(6(G12.5,1x),/) ) RETURN END c----------------------------------------------------------------------- SUBROUTINE cpyVec( vA, sA, vB, sB ) c----------------------------------------------------------------------- c cpyVec, Release 1, Subroutine Version 1.0, Created 14 Nov 2005. c----------------------------------------------------------------------- c This subroutine copies a vector from vA to vB of size sA. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c sA i Size of the vA source vector c sB i Size of the vB destination vector c vA d Source vector of coefficients c vB d Destination vector of coefficients c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER sA, sB DOUBLE PRECISION vA(*), vB(*) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i c----------------------------------------------------------------------- c Establish the size of output vector. c----------------------------------------------------------------------- sB = sA c----------------------------------------------------------------------- c Copy the vector vA to vB, c----------------------------------------------------------------------- DO i = 1, sA vB(i) = vA(i) END DO RETURN END c----------------------------------------------------------------------- SUBROUTINE polyRev( vA, sA, vB, sB ) c----------------------------------------------------------------------- c This subroutine reverses the order of the coefficients c in a polynomial. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c sA i Size of input polynomial vA. c sB i Size of output polynomial vB. c vA d Input polynomial to be reversed. c vB d Output polynomial after reversing vA. c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i i Index variable used in doo loops. c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER sA, sB DOUBLE PRECISION vA(sA), vB(sA) c----------------------------------------------------------------------- c Declare Local variables. c----------------------------------------------------------------------- INTEGER i c----------------------------------------------------------------------- c Establish size of output polynomial vB. c----------------------------------------------------------------------- sB = sA c----------------------------------------------------------------------- c Move vA to vB in reverse order. c----------------------------------------------------------------------- DO i = 1, sB vB( sB+1-i ) = vA(i) END DO RETURN END c----------------------------------------------------------------------- SUBROUTINE polyAdd( vA, sA, vB, sB, vC, sC, psC ) c----------------------------------------------------------------------- c This subroutine adds to polynomials together. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c sA i Size of vA polynomial. c sB i Size of vB polynomial. c sC i Size of vB polynomial. c vA d First input polynomial to add together. c vB d Second input polynomial to add together. c vC d Result of adding polynomials vA and vB together. c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c i i Index variable for do loops. c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER sA, sB, sC, psC DOUBLE PRECISION vA(sA), vB(sB), vC(psC) c----------------------------------------------------------------------- c Declare Local variables. c----------------------------------------------------------------------- INTEGER i c----------------------------------------------------------------------- c Add polynomial coefficients together that exist c for both polynomials. c----------------------------------------------------------------------- DO i=1,min(sA,sB) vC(i) = vA(i) + vB(i) END DO c----------------------------------------------------------------------- c If vA larger than vB the move the remainder of vA to the result. c----------------------------------------------------------------------- IF ( sA .gt. sB ) THEN DO i=sB+1,sA vC(i) = vA(i) END DO c----------------------------------------------------------------------- c If vA smaller than vB the move the remainder of vB to the result. c----------------------------------------------------------------------- ELSE IF ( sB .gt. sA ) THEN DO i=sA+1,sB vC(i) = vB(i) END DO END IF c----------------------------------------------------------------------- c Establish the size of the result polynomial. c----------------------------------------------------------------------- sC=max(sA,sB) RETURN END c----------------------------------------------------------------------- SUBROUTINE polyShft( vA, sA, ishift, vB, sB, pshift ) c----------------------------------------------------------------------- c This subroutine for ishift>0 multiplies the polynomial in vA (in F) c by F^ishift by shifting the vector polynomial ishift positions c to the left and shifting in zeros for the lowest order coefficients. c For ishift<0 the polynomial in vA (in F) is multiplied c by F^ishift=B^(-ishift) by shifting the vector poynomial ishift c positions to the right and truncating the negative powers of F. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c ishift i Size of shift to perform. c sA i Size of vA polynomial. c sB i Size of vB polynomial. c vA d Input polynomial to be shifted. c vB d Output polynomial after shift operation. c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c sC i Size of vC polynomial. c vC d Temporary storage for vA polynomial in case vA and vB c have the same memory address. c ZERO d Parameter. c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER ishift, sA, sB, sdum, pshift DOUBLE PRECISION vA(sA), vB(pshift) c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER sC DOUBLE PRECISION vC(sA), ZERO PARAMETER (ZERO=0.0d0) c----------------------------------------------------------------------- c Shift the polynomial left if ishift larger than zero, c by first copying the the input polynomial vA to vC c then initializing the first ishift locations in vB to zero c and then moving the vC polynomial to the correct location in vB. c----------------------------------------------------------------------- IF ( ishift .gt. 0 ) THEN CALL cpyVec( vA, sA, vC, sC ) vB(1) = ZERO CALL cpyVec( vB(1), ishift-1, vB(2), sdum ) CALL cpyVec( vC, sC, vB(ishift+1), sdum ) sB = sA+ishift c----------------------------------------------------------------------- c Shift the polynomial right if ishift smaller than zero c and eliminate lower order coefficients. c----------------------------------------------------------------------- ELSE IF ( ishift .lt. 0 ) THEN IF ( -ishift .lt. sA ) THEN CALL cpyVec( vA, sA, vC, sC ) CALL cpyVec( vC(1-ishift), sC+ishift, vB(1), sB ) ELSE vB(1)=0 sB=0 END IF c----------------------------------------------------------------------- c Else copy the input polynomial to the output polynomial. c----------------------------------------------------------------------- ELSE CALL cpyVec( vA, sA, vB, sB ) END IF RETURN END c----------------------------------------------------------------------- SUBROUTINE getSPFrac( vA1, sA1, vA2, sA2, vB1, sB1, vB2, sB2, & vD, sD, vE, sE, ppp1, ppp2, ppp3 ) c----------------------------------------------------------------------- c This subroutine performs partial fraction decomposition by c setting up h+k+1 system equations that are satisfied by the c D and E polynomials where h and k are defined in the code c and where E has h+1 coefficients, the first being 0, c and where D has k+1 coefficients. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c sA1 i Size of vA1 polynomial. c sA2 i Size of vA2 polynomial. c sB1 i Size of vB1 polynomial. c sB2 i Size of vB2 polynomial. c sD i Size of vD polynomial. c sE i Size of vE polynomial. c vA1 i First numerator polynomial in powers of F. c vA2 i Second numerator polynomial in powers of B. c vB1 i First denominator polynomial in powers of F. c vB2 i Second denominator polynomial in powers of B. c vD i Partial fraction numerator associated with sB1. c vE i Partial fraction numerator associated with sB2. c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i Index variables for do loops c jindex i Index used to navigate mS matrix c mInvStrS d Matrix containing inverse of S'S c mS d Matrix containing coeffieient matrix c mStrS d Matrix containing S'S c nF1 i Size (rows,columns) of vF1 vector c nF2 i Size (rows,columns) of vF2 vector c nInvStrS i Size (rows,columns) of mInvStrS matrix c nRem i Size (rows,columns) of vRem vector c nS i Size (rows,columns) of mS matrix c nStrS i Size (rows,columns) of mStrS matrix c nSave i Memory allocation size for some local matrices c sB i Size of vB polynomial c sdum i Dummy size variable c sRem i Size of vRem polynomial c vB d Vector of combined denominator polynomials c vF1 d Temporary vector c vF2 d Vector of combined D and E polynomials c vRem d Vector of remainder polynomial from polynomial division c for A/B c ZERO d Parameter c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER sA1, sA2, sB1, sB2, sD, sE INTEGER ppp1, ppp2, ppp3 DOUBLE PRECISION vA1(sA1), vA2(sA2), vB1(sB1), vB2(sB2), & vD(ppp1), vE(ppp2) INTEGER pshift c----------------------------------------------------------------------- c Declare Local variables. c----------------------------------------------------------------------- INTEGER i, j, jindex, h, k, nSave, sdum, sRA2, sRB2, sRE, sRes INTEGER nF1(2), nF2(2), nRes(2), nS(2), nStrS(2), nInvStrS(2) PARAMETER (nSave=500*500) DOUBLE PRECISION mInvStrS(nSave), mS(nSave), mStrS(nSave), & vF1(ppp3+ppp2-1), & vF2(ppp3+ppp2-1), & vRes(ppp3+ppp2-1), & vRA2(sA2), vRB2(sB2), vRE(ppp2), ZERO PARAMETER (ZERO=0.0d0) SAVE mS, mStrS EQUIVALENCE (mS, mInvStrS) c----------------------------------------------------------------------- c Reverse the B2 subpolynomial. c----------------------------------------------------------------------- CALL polyRev( vB2, sB2, vRB2, sRB2 ) c----------------------------------------------------------------------- c Set up the system of equations that the numerator polynomials c for the partial fractions satisfy. c----------------------------------------------------------------------- h = max(sA2,sB2)-1 k = max(sA1,sB1)-1 nS(1) = h + k + 1 nS(2) = nS(1) c ------------------------------------------------------------------ c Zero out the matrix representation. c ------------------------------------------------------------------ DO j = 1, nS(2) jindex = (j-1)*nS(1)+1 mS( jindex ) = ZERO CALL cpyVec( mS( jindex ), nS(1)-1, mS( jindex+1 ), sdum ) END DO c ------------------------------------------------------------------ c Fill in the matrix associated with the B1 polynomial. c ------------------------------------------------------------------ IF ( h .gt. 0 ) THEN DO j = 1, h jindex = (j-1)*nS(1) + j CALL cpyVec( vB1, sB1, mS( jindex ), sdum ) END DO END IF c ------------------------------------------------------------------ c Fill in the matrix associated with the B2 polynomial. c ------------------------------------------------------------------ DO j = h+1, nS(2) jindex = (j-1)*nS(1) + j - (sB2-1) CALL cpyVec( vRB2, sRB2, mS( jindex ), sdum ) END DO c----------------------------------------------------------------------- c Set up the result vector vRes where vRes represents A1(F)xA2(B). c----------------------------------------------------------------------- CALL polyRev( vA2, sA2, vRA2, sRA2 ) CALL CONV( vRA2, sRA2, vA1, sA1, vRes, sRes ) IF ( h .gt. (sA2-1) ) THEN pshift = max(sRes+h-(sA2-1),1) CALL polyShft( vRes, sRes, h-(sA2-1), vRes, sRes, pshift ) END IF IF ( k .gt. (sA1-1) ) THEN DO i=sRes+1,h+k+1 vRes(i)=ZERO END DO sRes = h + k + 1 END IF c----------------------------------------------------------------------- c Solve the system of equations: SxG = vRes where G = (D' E')' c using G = (S'S)^(-1) x S'vRes where X' denotes transpose c of matrix X. c----------------------------------------------------------------------- nRes(1) = sRes nRes(2) = 1 CALL mulTrMat( mS, nS, vRes, nRes, vF1, nF1 ) CALL mulTrMat( mS, nS, mS, nS, mStrS, nStrS ) CALL invMat( mStrS, nStrS, mInvStrS, nInvStrS ) CALL mulMat( mInvStrS, nInvStrS, vF1, nF1, vF2, nF2 ) c----------------------------------------------------------------------- c Move the result from combined polynomial F for (D' E')' to the c output polynomials for D and E, then add polynomials Quot and D. c----------------------------------------------------------------------- c First check for D polynomial and move to output vector. c ------------------------------------------------------------------ IF ( k .ge. 0 ) THEN CALL cpyVec( vF2(h+1), k+1, vD, sD ) ELSE sD=1 vD(1)=ZERO END IF c ------------------------------------------------------------------ c Second check for E polynomial and move to output vector. c ------------------------------------------------------------------ IF ( h .gt. 0 ) THEN vRE(h+1) = ZERO CALL cpyVec( vF2, h, vRE, sdum ) sRE = h+1 CALL polyRev( vRE, sRE, vE, sE ) ELSE sRE=1 vRE(1)=ZERO sE=1 vE(1)=ZERO END IF RETURN ENDgetrev.f0000664006604000003110000001437714521201504011642 0ustar sun00315stepsC Last change: BCM 29 Sep 1998 10:48 am **==getrev.f processed by SPAG 4.03F at 10:39 on 20 Oct 1994 SUBROUTINE getrev(Srs,Lstobs,Muladd,Itype,Ny,Iag,Iagr) IMPLICIT NONE c----------------------------------------------------------------------- c This routine gets the concurrent and final values for the c seasonal factors and seasonally adjusted series to be used in the c revisions analysis. c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'model.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revtrg.cmn' INCLUDE 'revsrs.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER MONE PARAMETER(MONE=-1) c----------------------------------------------------------------------- DOUBLE PRECISION Srs,tmp LOGICAL ltemp INTEGER i,i1,i2,Lstobs,Itype,Muladd,Ny,pptr,lli,rvd,Iag,Iagr DIMENSION Srs(*) c----------------------------------------------------------------------- c Store concurrent value c----------------------------------------------------------------------- ltemp=F rvd=Rvdiff IF(Itype.eq.0)THEN IF(Revptr.gt.0)CALL putrev(Srs,Cncsf(Revptr),tmp,tmp,Lstobs, & Lrvsf,ltemp,Muladd,Itype,rvd,Indrev) c----------------------------------------------------------------------- c Store value of projected seasonal factors c----------------------------------------------------------------------- IF(mod(Lstobs,Ny).eq.0)THEN DO i=1,Ny pptr=Revptr+i IF(pptr.gt.0)CALL putrev(Srs,Cncsfp(pptr),tmp,tmp,Lstobs+i, & Lrvsf,ltemp,Muladd,Itype,rvd,Indrev) END DO END IF c----------------------------------------------------------------------- c Save concurrent seasonal adjustment and changes c----------------------------------------------------------------------- ELSE IF(Revptr.gt.0)THEN IF(Itype.eq.1)THEN CALL putrev(Srs,Cncsa(Revptr),Cncch(Revptr),Cncisa(Revptr), & Lstobs,Lrvsa,Lrvch,Muladd,Itype,rvd,Indrev) c----------------------------------------------------------------------- c If alternate targets were also specified, store the final values c for each target now, if available. c----------------------------------------------------------------------- IF(Ntarsa.gt.0)THEN i=1 DO WHILE(i.le.Ntarsa) IF(Revptr.gt.Targsa(i))THEN i1=Revptr-Targsa(i) i2=Lstobs-Revptr+i1 CALL putrev(Srs,Finsa(i,i1),Finch(i,i1),Finisa(i,i1),i2, & Lrvsa,Lrvch,Muladd,Itype,rvd,Indrev) i=i+1 ELSE i=Ntarsa+1 END IF END DO END IF IF(rvd.lt.0)THEN CALL writln('WARNING: Revisions history analysis of the percent & changes of the',STDERR,Mt2,T) CALL writln(' seasonally adjusted series has ceased due & to negative values',STDERR,Mt2,F) CALL writln(' in the seasonally adjusted series.', & STDERR,Mt2,F) END IF c----------------------------------------------------------------------- c Save concurrent trend and changes c----------------------------------------------------------------------- ELSE CALL putrev(Srs,Cnctrn(Revptr),Cnctch(Revptr),tmp,Lstobs,Lrvtrn, & Lrvtch,Muladd,Itype,rvd,Indrev) c----------------------------------------------------------------------- c If alternate targets were also specified, store the final values c for each target now, if available. c----------------------------------------------------------------------- IF(Ntartr.gt.0)THEN i=1 DO WHILE(i.le.Ntartr) IF(Revptr.gt.Targtr(i))THEN i1=Revptr-Targtr(i) i2=Lstobs-Revptr+i1 CALL putrev(Srs,Fintrn(i,i1),Fintch(i,i1),tmp,i2,Lrvtrn, & Lrvtch,Muladd,Itype,rvd,Indrev) i=i+1 ELSE i=Ntartr+1 END IF END DO END IF IF(rvd.lt.0)THEN CALL writln('WARNING: Revisions history analysis of the percent & changes of the',STDERR,Mt2,T) CALL writln(' trend has ceased due to negative values i &n the trend.',STDERR,Mt2,F) END IF END IF END IF c----------------------------------------------------------------------- c If this is the original seasonal adjustment, store the final c values now. c----------------------------------------------------------------------- IF(Revptr.lt.(Endrev-Begrev+1).or.rvd.lt.0)RETURN IF(Itype.eq.1.and.Iagr.eq.2.and.Iag.ge.0)Nrcomp=Nrcomp+1 DO i=1,Revptr lli=Lstobs-Revptr+i IF(Itype.eq.0)THEN CALL putrev(Srs,Finsf(i),tmp,tmp,lli,Lrvsf,ltemp,Muladd,Itype, & rvd,Indrev) ELSE IF(Itype.eq.1)THEN CALL putrev(Srs,Finsa(0,i),Finch(0,i),Finisa(0,i),lli,Lrvsa, & Lrvch,Muladd,Itype,rvd,Indrev) IF(rvd.eq.MONE)THEN CALL writln('WARNING: Revisions history analysis of the percent & changes of the',STDERR,Mt2,T) CALL writln(' seasonally adjusted series has ceased due & to negative values',STDERR,Mt2,F) CALL writln(' in the seasonally adjusted series.', & STDERR,Mt2,F) rvd=rvd-1 END IF ELSE CALL putrev(Srs,Fintrn(0,i),Fintch(0,i),tmp,lli,Lrvtrn, & Lrvtch,Muladd,Itype,rvd,Indrev) IF(rvd.eq.MONE)THEN CALL writln('WARNING: Revisions history analysis of the percent & changes of the',STDERR,Mt2,T) CALL writln(' trend has ceased due to negative values i &n the trend.',STDERR,Mt2,F) rvd=rvd-1 END IF END IF END DO c----------------------------------------------------------------------- RETURN END getsav.f0000664006604000003110000001337214521201504011631 0ustar sun00315stepsC Last change: BCM 8 Dec 1998 2:24 pm **==getsav.f processed by SPAG 4.03F at 11:17 on 14 Sep 1994 SUBROUTINE getsav(Spcdsp,Nspctb,Inptok) c----------------------------------------------------------------------- c Parses the input for the print argument in each of the specs c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- IMPLICIT NONE LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'stable.prm' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL hvcmma,Inptok,argok,opngrp INTEGER Nspctb,Spcdsp,tblidx c----------------------------------------------------------------------- INCLUDE 'stable.var' c----------------------------------------------------------------------- hvcmma=F IF(Nxtktp.eq.EOF)THEN Inptok=F c----------------------------------------------------------------------- c Check for a list (, and possibly a null list). c----------------------------------------------------------------------- ELSE IF(Nxtktp.ne.LPAREN)THEN c----------------------------------------------------------------------- c Check for a table c----------------------------------------------------------------------- IF(Spcdsp.lt.BRKDSP)THEN CALL gtdcnm(TB1DIC,tb1ptr(2*Spcdsp),2*Nspctb,tblidx,argok) ELSE IF(Spcdsp.lt.BRKDS2)THEN CALL gtdcnm(TB2DIC,tb2ptr(2*(Spcdsp-BRKDSP)),2*Nspctb,tblidx, & argok) ELSE IF(Spcdsp.lt.BRKDS3)THEN CALL gtdcnm(TB3DIC,tb3ptr(2*(Spcdsp-BRKDS2)),2*Nspctb,tblidx, & argok) ELSE CALL gtdcnm(TB4DIC,tb4ptr(2*(Spcdsp-BRKDS3)),2*Nspctb,tblidx, & argok) END IF IF(tblidx.eq.0)THEN CALL inpter(PERROR,Lstpos,'Save argument is not defined.') CALL writln( & ' Check the available table names for this spec.', & STDERR,Mt2,F) CALL lex() Inptok=F c ------------------------------------------------------------------ ELSE tblidx=Spcdsp+(tblidx+1)/2 Savtab(tblidx)=T END IF c----------------------------------------------------------------------- c Process a list (Could be a null list.) c----------------------------------------------------------------------- ELSE opngrp=T CALL lex() c ----------------------------------------------------------------- DO WHILE (T) IF(Nxtktp.eq.EOF)THEN CALL inpter(PERROR,Lstpos,'Unexpected EOF') Inptok=F GO TO 20 ELSE IF(Nxtktp.ne.RPAREN)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,acf) c or (acf,,pacf). Check for multiple NULLs. c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Inptok=F END IF c ----------------------------------------------------------------- CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a table. c----------------------------------------------------------------------- IF(Spcdsp.lt.BRKDSP)THEN CALL gtdcnm(TB1DIC,tb1ptr(2*Spcdsp),2*Nspctb,tblidx,argok) ELSE IF(Spcdsp.lt.BRKDS2)THEN CALL gtdcnm(TB2DIC,tb2ptr(2*(Spcdsp-BRKDSP)),2*Nspctb,tblidx, & argok) ELSE IF(Spcdsp.lt.BRKDS3)THEN CALL gtdcnm(TB3DIC,tb3ptr(2*(Spcdsp-BRKDS2)),2*Nspctb,tblidx, & argok) ELSE CALL gtdcnm(TB4DIC,tb4ptr(2*(Spcdsp-BRKDS3)),2*Nspctb,tblidx, & argok) END IF IF(tblidx.eq.0)THEN CALL inpter(PERROR,Lstpos,'Save argument is not defined.') CALL writln(' Check the available table names for this &spec.',STDERR,Mt2,F) CALL lex() Inptok=F c----------------------------------------------------------------------- c Tables have long and short names so there are double the c number of entries in the dictionary and so entry 2i-1 and 2i c map to table i. c----------------------------------------------------------------------- ELSE tblidx=Spcdsp+(tblidx+1)/2 Savtab(tblidx)=T END IF c ----------------------------------------------------------------- hvcmma=F opngrp=F c----------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. This indicates a NULL value, for example, (acf,pacf,). c----------------------------------------------------------------------- ELSE IF(hvcmma)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Inptok=F END IF c ------------------------------------------------------------------ CALL lex() GO TO 20 END IF 10 CONTINUE END DO END IF c ------------------------------------------------------------------ 20 RETURN END getsma.f0000664006604000003110000000270514521201505011617 0ustar sun00315steps DOUBLE PRECISION FUNCTION getsma() IMPLICIT NONE c ------------------------------------------------------------------ c Function that returns value of first order seasonal moving c term in ARIMA model - will return 0.0 if not found. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO PARAMETER(ZERO=0d0) c ------------------------------------------------------------------ CHARACTER tmpttl*(PGRPCR) INTEGER begopr,endopr,iopr,beglag,endlag,ilag,ntmpcr c ------------------------------------------------------------------ getsma=ZERO begopr=Mdl(MA-1) endopr=Mdl(MA)-1 IF(begopr.le.endopr)THEN DO iopr=begopr,endopr CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(tmpttl(1:ntmpcr).eq.'Seasonal MA')THEN beglag=Opr(iopr-1) endlag=Opr(iopr)-1 DO ilag=beglag,endlag IF(Arimal(ilag).eq.Sp)THEN getsma=Arimap(beglag) RETURN END IF END DO END IF END DO END IF c ------------------------------------------------------------------ RETURN END getsmat.f0000664006604000003110000001143214521201505012000 0ustar sun00315steps SUBROUTINE getSMat( mA, nA, nStart, nEnd, mB, nB ) c----------------------------------------------------------------------- c getSMat.f, Release 1, Subroutine Version 1.0, Created 18 Apr 2005. c----------------------------------------------------------------------- c This subroutine extracts the submatrix of c mA(nStart:nEnd,nStart:nEnd). c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d input matrix to extract submatrix from c mB d output matrix to contain submatrix of mA c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nEnd i ending row/column index of submatrix in mA c nStart i starting row/column index of submatrix in mA c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nStart, nEnd, nB(2) DOUBLE PRECISION mA(nA(1),nA(2)), mB(nEnd-nStart+1,nEnd-nStart+1) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i,j c----------------------------------------------------------------------- c Extract the submatrix. c----------------------------------------------------------------------- IF (( nA(1) .gt. 0 ) .and. (nA(2) .gt. 0)) THEN nB(1) = nEnd - nStart + 1 nB(2) = nEnd - nStart + 1 DO i = nStart, nEnd DO j = nStart, nEnd mB(i-nStart+1, j-nStart+1) = mA(i,j) END DO END DO ELSE nB(1) = 0 nB(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE getSRMat( mA, nA, nStartR, nEndR, nStartC, nEndC, & mB, nB ) c----------------------------------------------------------------------- c Release 1, Subroutine Version 1.0, Created 20 Mar 2006. c----------------------------------------------------------------------- c This subroutine extracts the submatrix of c mA(nStartR:nEndR,nStartC:nEndC). c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d input matrix to extract submatrix from c mB d output matrix to contain submatrix of mA c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nEnd i ending row/column index of submatrix in mA c nStart i starting row/column index of submatrix in mA c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nEndC, nEndR, nStartC, nStartR DOUBLE PRECISION mA(nA(1),nA(2)), & mB(nEndR-nStartR+1,nEndC-nStartC+1) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i,j c----------------------------------------------------------------------- c Extract the submatrix. c----------------------------------------------------------------------- IF (( nA(1) .gt. 0 ) .and. (nA(2) .gt. 0)) THEN nB(1) = nEndR - nStartR + 1 nB(2) = nEndC - nStartC + 1 DO j = nStartC, nEndC DO i = nStartR, nEndR mB(i-nStartR+1, j-nStartC+1) = mA(i,j) END DO END DO ELSE nB(1) = 0 nB(2) = 0 END IF c ------------------------------------------------------------------ RETURN ENDgetsrs.f0000664006604000003110000005525314521201505011654 0ustar sun00315stepsC Last change: BCM 16 Sep 2005 1:25 pm SUBROUTINE getsrs(Sp,Y,Nobs,Start,Nspobs,Begspn,Srsttl,Nttlcr, & Srsnam,Nser,Havsrs,Havesp,Kdec,Begmdl,Endmdl, & Ldata,Dtafil,Iag,Iagr,Lagr,W,Mvcode,Mvval, & Fixper,Svprec,Yr2000,Divpwr,Isrflw,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Get the time series, y, including the number of observations, c nobs, start date, start, and seasonal period, Sp. c----------------------------------------------------------------------- c Add appendfcst and appendbcst arguments, october 2006, bcm c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL F,T INTEGER YR,MO,MINNIN,NINE DOUBLE PRECISION ZERO PARAMETER(T=.true.,F=.false.,YR=1,MO=2,MINNIN=-9,NINE=9,ZERO=0D0) C----------------------------------------------------------------------- DOUBLE PRECISION Mvcode,Mvval,Y,W,dvec CHARACTER Dtafil*(PFILCR),file*(PFILCR),fmt*(PFILCR),Srsttl*(*), & Srsnam*(64) LOGICAL argok,havfil,havfmt,Havesp,Havsrs,Ldata,hvstrt,locok, & Inptok,hvnam,Lagr,hvmdsp,Yr2000,havttl INTEGER Begspn,endspn,Sp,spnvec,ivec,nflchr,nfmtch,nelt,Nobs, & Nspobs,Nttlcr,Start,tmpptr,numdec,nspec,Kdec,Begmdl, & Endmdl,spnmdl,nmdl,Nser,Iag,Iagr,Fixper,Svprec,Divpwr, & Isrflw,ltrim DIMENSION Begspn(2),endspn(2),spnvec(2,2),Start(2),tmpptr(0:1), & Begmdl(2),Endmdl(2),spnmdl(2,2),Y(PLEN),dvec(1),ivec(1) c----------------------------------------------------------------------- INTEGER nblank LOGICAL chkcvr,gtarg,isdate EXTERNAL nblank,chkcvr,gtarg,isdate c----------------------------------------------------------------------- c This dictionary was made with this command c ../../dictionary/strary < ../../dictionary/series.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*167 INTEGER argidx,argptr,PARG,arglog PARAMETER(PARG=24) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='datastartperiodspantitlefileformatprintsavenamep &recisiondecimalsmodelspancomptypecompwtmissingcodemissingvalsavepr &ecisionyr2000trimzerodivpowerappendfcstappendbcsttype') c----------------------------------------------------------------------- c type of compositing data dictionary c----------------------------------------------------------------------- CHARACTER CMPDIC*17 INTEGER cmpptr,PCMP PARAMETER(PCMP=5) DIMENSION cmpptr(0:PCMP) PARAMETER(CMPDIC='noneaddsubmultdiv') c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- CHARACTER ZRODIC*9 INTEGER zroptr,PZRO PARAMETER(PZRO=3) DIMENSION zroptr(0:PZRO) PARAMETER(ZRODIC='yesspanno') c ------------------------------------------------------------------ CHARACTER TYPDIC*9 INTEGER typptr,PTYP PARAMETER(PTYP=2) DIMENSION typptr(0:PTYP) PARAMETER(TYPDIC='flowstock') c----------------------------------------------------------------------- DATA argptr/1,5,10,16,20,25,29,35,40,44,48,57,65,74,82,88,99,109, & 122,128,136,144,154,164,168/ DATA ysnptr/1,4,6/ DATA zroptr/1,4,8,10/ DATA cmpptr/1,5,8,11,15,18/ DATA typptr/1,5,10/ c----------------------------------------------------------------------- c Assume the input is OK and we don't have any of the arguments c----------------------------------------------------------------------- locok=T Havsrs=F havfil=F havttl=F havfmt=F hvstrt=F Havesp=F hvnam=F hvmdsp=F ltrim=0 nfmtch=1 CALL setint(NOTSET,4,spnvec) CALL setint(NOTSET,4,spnmdl) CALL setint(NOTSET,2*PARG,arglog) CALL setint(NOTSET,2,endspn) numdec=0 c----------------------------------------------------------------------- c Initialize the format and file c----------------------------------------------------------------------- CALL setchr(' ',PFILCR,file) CALL setchr(' ',PFILCR,fmt) IF(Ldata)THEN file=Dtafil nflchr=nblank(Dtafil) havfil=T END IF 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,140,150,160, & 170,180,190,200,210,220,230,240),argidx c----------------------------------------------------------------------- c Data argument c----------------------------------------------------------------------- 10 IF(Ldata)THEN CALL inpter(PERROR,Errpos, & 'Cannot use data argument when a data metafile is used.') locok=F ELSE IF(havfil)THEN CALL inpter(PERROR,Errpos,'Use either data or file, not both') locok=F END IF c ------------------------------------------------------------------ CALL gtdpvc(LPAREN,T,PLEN,Y,Nobs,argok,locok) IF(Lfatal)RETURN IF(argok.and.Nobs.gt.0)THEN Havsrs=T ELSE Nobs=0 END IF GO TO 250 c----------------------------------------------------------------------- c Start argument c----------------------------------------------------------------------- 20 CALL gtdtvc(Havesp,Sp,LPAREN,F,1,Start,nelt,argok,locok) IF(Lfatal)RETURN hvstrt=argok.and.nelt.gt.0 c IF(hvstrt.and.Sp.eq.1)THEN c CALL inpter(PERROR,Errpos, c & 'Starting date entered here is for an annual series.') c locok=F c END IF c ------------------------------------------------------------------ GO TO 250 c----------------------------------------------------------------------- c Period argument c----------------------------------------------------------------------- 30 CALL getivc(LPAREN,T,1,ivec,nelt,argok,locok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Invalid seasonal period') locok=F c ------------------------------------------------------------------ ELSE IF(ivec(1).gt.PSP)THEN CALL inpter(PERROR,Errpos,'Seasonal period too large.') CALL writln(' See '//LIMSEC//' of the '//DOCNAM// & ' on program limits',STDERR,Mt2,F) locok=F c ------------------------------------------------------------------ ELSE IF(Havesp.and.ivec(1).ne.Sp)THEN CALL inpter(PERROR,Errpos,'Assumed seasonal period of 12') locok=F c ------------------------------------------------------------------ ELSE Havesp=T Sp=ivec(1) END IF END IF GO TO 250 c----------------------------------------------------------------------- c Span argument c----------------------------------------------------------------------- 40 CALL gtdtvc(Havesp,Sp,LPAREN,F,2,spnvec,nelt,argok,locok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos, & 'Need two dates for the span or use a comma as place holder.' & ) locok=F END IF GO TO 250 c----------------------------------------------------------------------- c Title argument c----------------------------------------------------------------------- 50 CALL getttl(LPAREN,T,1,Srsttl,tmpptr,nelt,argok,locok) IF(.not.Lfatal.and.argok.and.nelt.eq.1)THEN CALL eltlen(1,tmpptr,nelt,Nttlcr) havttl=T END IF IF(Lfatal)RETURN GO TO 250 c----------------------------------------------------------------------- c File argument c----------------------------------------------------------------------- 60 IF(Havsrs)THEN CALL inpter(PERROR,Errpos,'Use either data or file, not both') locok=F END IF IF(Ldata)THEN CALL inpter(PERROR,Errpos, & 'Cannot use file argument when a data metafile is used.') locok=F END IF c ------------------------------------------------------------------ CALL gtnmvc(LPAREN,T,1,file,tmpptr,nelt,PFILCR,argok,locok) IF(Lfatal)RETURN IF(argok.and.nelt.eq.1)THEN CALL eltlen(1,tmpptr,nelt,nflchr) IF(Lfatal)RETURN havfil=T END IF GO TO 250 c----------------------------------------------------------------------- c Format argument c----------------------------------------------------------------------- 70 CALL gtnmvc(LPAREN,T,1,fmt,tmpptr,nelt,PFILCR,argok,locok) IF(Lfatal)RETURN IF(argok.and.nelt.eq.1)THEN CALL eltlen(1,tmpptr,nelt,nfmtch) IF(Lfatal)RETURN havfmt=T END IF GO TO 250 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 80 CALL getprt(LSPSRS,NSPSRS,locok) GO TO 250 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 90 CALL getsav(LSPSRS,NSPSRS,locok) GO TO 250 c----------------------------------------------------------------------- c Series name argument c----------------------------------------------------------------------- 100 CALL gtnmvc(LPAREN,T,1,Srsnam,tmpptr,nelt,64,argok,locok) IF(Lfatal)RETURN IF(argok)THEN hvnam=T CALL eltlen(1,tmpptr,nelt,Nser) END IF GO TO 250 c----------------------------------------------------------------------- c precision argument c----------------------------------------------------------------------- 110 CALL getivc(LPAREN,T,1,ivec,nelt,argok,locok) IF(Lfatal)RETURN IF(argok)THEN IF(ivec(1).lt.0.or.ivec(1).gt.5)THEN CALL inpter(PERROR,Errpos, & 'Number of input decimals must be between 0 and 5, inclusive') locok=F ELSE numdec=ivec(1) END IF END IF GO TO 250 c----------------------------------------------------------------------- c decimals argument c----------------------------------------------------------------------- 120 CALL getivc(LPAREN,T,1,ivec,nelt,argok,locok) IF(Lfatal)RETURN IF(argok)THEN IF(ivec(1).lt.0.or.ivec(1).gt.5)THEN CALL inpter(PERROR,Errpos, & 'Number of output decimals must be between 0 and 5, inclusive') locok=F ELSE Kdec=ivec(1) END IF END IF GO TO 250 c----------------------------------------------------------------------- c Span for the model estimation. c----------------------------------------------------------------------- 130 CALL gtdtvc(Havesp,Sp,LPAREN,F,2,spnmdl,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos,'Need two dates for the model span or & use a comma as place holder.') Inptok=F ELSE IF(argok)THEN hvmdsp=T END IF GO TO 250 c----------------------------------------------------------------------- c Composite type argument c----------------------------------------------------------------------- 140 CALL gtdcvc(LPAREN,T,1,CMPDIC,cmpptr,PCMP, & 'Available composite types are none, add, sub, mult, div.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN Iag=ivec(1)-2 IF(Iagr.eq.0.and.Iag.ge.0)Lagr=T END IF GO TO 250 c----------------------------------------------------------------------- c Composite adjustment weight argument c----------------------------------------------------------------------- 150 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c--------*--------------------------------------------------------------- c Error Checking for composite adjustment weight c----------------------------------------------------------------------- IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.0D0)THEN CALL inpter(PERROR,Errpos,'Value of composite weight must be g &reater than zero.') Inptok=F ELSE W=dvec(1) END IF END IF GO TO 250 c----------------------------------------------------------------------- c missingcode argument c----------------------------------------------------------------------- 160 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN Mvcode=dvec(1) GO TO 250 c----------------------------------------------------------------------- c missingval argument c----------------------------------------------------------------------- 170 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN Mvval=dvec(1) GO TO 250 c----------------------------------------------------------------------- c saveprecision argument c----------------------------------------------------------------------- 180 CALL getivc(LPAREN,T,1,ivec,nelt,argok,locok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(ivec(1).le.0.and.ivec(1).gt.15)THEN CALL inpter(PERROR,Errpos,'Value of saveprecision must be grea &ter than zero and less than 15.') Inptok=F ELSE Svprec=ivec(1) END IF END IF GO TO 250 c----------------------------------------------------------------------- c yr2000 argument c----------------------------------------------------------------------- 190 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for yr2000 are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Yr2000=ivec(1).eq.1 GO TO 250 c----------------------------------------------------------------------- c trimzero argument c----------------------------------------------------------------------- 200 CALL gtdcvc(LPAREN,T,1,ZRODIC,zroptr,PZRO, & 'Available options for trimzero are yes, span or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)ltrim=ivec(1)-1 GO TO 250 c----------------------------------------------------------------------- c divpower argument c----------------------------------------------------------------------- 210 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(ivec(1).lt.MINNIN.or.ivec(1).gt.NINE)THEN CALL inpter(PERROR,Errpos,'Value entered for divpower must be &between -9 and 9, inclusive.') Inptok=F ELSE Divpwr=ivec(1) END IF END IF GO TO 250 c----------------------------------------------------------------------- c appendfcst argument c----------------------------------------------------------------------- 220 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for appending forecasts are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Savfct=ivec(1).eq.1 GO TO 250 c----------------------------------------------------------------------- c appendbcst argument c----------------------------------------------------------------------- 230 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for appending backcasts are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Savbct=ivec(1).eq.1 GO TO 250 c----------------------------------------------------------------------- c type argument c----------------------------------------------------------------------- 240 CALL gtdcvc(LPAREN,T,1,TYPDIC,typptr,PTYP, & 'Available options for type are flow or stock.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Isrflw=ivec(1) GO TO 250 END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check to see if c----------------------------------------------------------------------- IF(.not.Havesp.and.hvstrt)THEN Sp=12 Havesp=T END IF IF(.not.Havesp.and.Sp.gt.12)Sp=12 c ------------------------------------------------------------------ IF(.not.isdate(Start,Sp))THEN CALL inpter(PERRNP,Pos,'Start date not valid') Havesp=F locok=F END IF c----------------------------------------------------------------------- c copy span starting and ending dates into proper variables, and c check to see if they are valid dates (BCM, Nov 2004) c----------------------------------------------------------------------- IF(spnvec(YR,1).ne.NOTSET)THEN CALL cpyint(spnvec,2,1,Begspn) IF(.not.isdate(Begspn,Sp))THEN CALL inpter(PERRNP,Pos,'Span starting date not valid') Havesp=F locok=F END IF END IF IF(spnvec(YR,2).ne.NOTSET)THEN CALL cpyint(spnvec(1,2),2,1,endspn) IF(.not.isdate(endspn,Sp))THEN CALL inpter(PERRNP,Pos,'Span ending date not valid') Havesp=F locok=F END IF END IF IF((spnvec(YR,1).eq.NOTSET.or.spnvec(YR,2).eq.NOTSET).and. & ltrim.eq.1)THEN CALL inpter(PERRNP,Errpos, & 'Must specify starting and ending span when trimzero=span.') locok=F END IF c----------------------------------------------------------------------- c If the data are from the file get the data c----------------------------------------------------------------------- IF(locok.and.havfil.and.(.not.Havsrs))THEN CALL gtfldt(PLEN,file,nflchr,havfmt,fmt(1:nfmtch),ltrim,Y, & Nobs,Havesp,Sp,hvnam,Srsnam,Nser,havttl,Srsttl, & Nttlcr,numdec,hvstrt,Start,1,Begspn,endspn,F,argok, & locok) IF(argok)Havsrs=T END IF c----------------------------------------------------------------------- c Check for the required arguments c----------------------------------------------------------------------- IF(.not.Havsrs)THEN IF(locok)THEN CALL inpter(PERRNP,Errpos,'No time series specified') locok=F ELSE IF(havfil)THEN CALL inpter(PERRNP,Errpos,'Time series could not be read due to & previously found errors') END IF ELSE c----------------------------------------------------------------------- c If beginning or ending date in span is undefined, set equal to c beginning date of series. c----------------------------------------------------------------------- IF(spnvec(YR,1).eq.NOTSET)CALL cpyint(Start,2,1,Begspn) IF(spnvec(YR,2).eq.NOTSET)CALL addate(Start,Sp,Nobs-1,endspn) c----------------------------------------------------------------------- c Check that the span is within the series c----------------------------------------------------------------------- CALL dfdate(endspn,Begspn,Sp,Nspobs) Nspobs=Nspobs+1 IF(.not.chkcvr(Start,Nobs,Begspn,Nspobs,Sp))THEN CALL inpter(PERRNP,Errpos,'Span not within the series') CALL cvrerr('series',Start,Nobs,'span',Begspn,Nspobs,Sp) IF(Lfatal)RETURN locok=F END IF c----------------------------------------------------------------------- c If beginning or ending date in the model span is undefined, set c equal to beginning date of the span. c----------------------------------------------------------------------- IF(spnmdl(YR,1).eq.NOTSET)THEN CALL cpyint(Begspn,2,1,Begmdl) ELSE CALL cpyint(spnmdl,2,1,Begmdl) IF(.not.isdate(Begmdl,Sp))THEN CALL inpter(PERRNP,Pos,'Model span starting date not valid') Havesp=F locok=F END IF END IF IF(spnmdl(YR,2).eq.NOTSET.or.spnmdl(YR,2).eq.0)THEN CALL addate(Begspn,Sp,Nspobs-1,Endmdl) IF(spnmdl(YR,2).eq.0)THEN Endmdl(MO)=spnmdl(MO,2) IF(Endmdl(MO).gt.Endspn(MO))Endmdl(YR)=Endmdl(YR)-1 Fixper=Endmdl(MO) END IF ELSE CALL cpyint(spnmdl(1,2),2,1,Endmdl) IF(.not.isdate(Endmdl,Sp))THEN CALL inpter(PERRNP,Pos,'Model span ending date not valid') Havesp=F locok=F END IF END IF c----------------------------------------------------------------------- c Check that the span is within the series c----------------------------------------------------------------------- IF(hvmdsp)THEN CALL dfdate(Endmdl,Begmdl,Sp,nmdl) nmdl=nmdl+1 IF(.not.chkcvr(Begspn,Nspobs,Begmdl,nmdl,Sp))THEN CALL inpter(PERRNP,Errpos, & 'Model span not within the span of available data.') CALL cvrerr('span',Begspn,Nspobs,'model span',Begmdl,nmdl,Sp) Inptok=F IF(Lfatal)RETURN END IF END IF END IF c ------------------------------------------------------------------ IF(Iag.eq.NOTSET)Iag=-1 IF(Isrflw.eq.NOTSET)Isrflw=0 c ------------------------------------------------------------------ Inptok=Inptok.and.locok RETURN 250 CONTINUE END DO c ------------------------------------------------------------------ END getssp.f0000664006604000003110000002646614521201505011656 0ustar sun00315stepsC Last change: BCM 26 Feb 1999 9:47 am **==getssp.f processed by SPAG 4.03F at 10:14 on 23 Aug 1994 SUBROUTINE getssp(Havesp,Sp,Issap,Otlidx,Intidx,Strtss,Sscut,Nlen, & Ncol,Sstran,Ssfxrg,Nssfxr,Ssdiff,Ssxotl,Ssxint, & Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Read options which control X-13A-S output format c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------ INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'svllog.i' INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'ssap.prm' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER str*(10) LOGICAL Havesp,Inptok,argok,Ssxotl,Sstran,Ssdiff,Ssxint INTEGER nelt,Strtss,Issap,Sp,Nlen,ivec,Ncol,ipos DOUBLE PRECISION Sscut,dvec DIMENSION Sscut(5),Strtss(2),ivec(1),dvec(1) c----------------------------------------------------------------------- LOGICAL gtarg EXTERNAL gtarg c----------------------------------------------------------------------- CHARACTER ARGDIC*113 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=16) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='startcutseascutchngcuttdoutlierfixmdlprintsavele &ngthtransparentsavelogfixregadditivesanumspansx11outlierfixx11reg' &) c----------------------------------------------------------------------- CHARACTER OTLDIC*13 INTEGER Otlidx,otlptr,POTLSS PARAMETER(POTLSS=3) DIMENSION otlptr(0:POTLSS) PARAMETER(OTLDIC='removekeepyes') c----------------------------------------------------------------------- CHARACTER INTDIC*10 INTEGER Intidx,intptr,PINT PARAMETER(PINT=3) DIMENSION intptr(0:PINT) PARAMETER(INTDIC='noyesclear') c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- CHARACTER FXRDIC*20 INTEGER Ssfxrg,fxrptr,PFXR,Nssfxr PARAMETER(PFXR=4) DIMENSION fxrptr(0:PFXR),Ssfxrg(PFXR) PARAMETER(FXRDIC='tdholidayuseroutlier') c----------------------------------------------------------------------- CHARACTER ADDDIC*17 INTEGER addptr,PADD PARAMETER(PADD=2) DIMENSION addptr(0:PADD) PARAMETER(ADDDIC='differencepercent') c----------------------------------------------------------------------- DATA otlptr/1,7,11,14/ DATA intptr/1,3,6,11/ DATA argptr/1,6,13,20,25,32,38,43,47,53,64,71,77,87,95,105,114/ DATA ysnptr/1,4,6/ DATA fxrptr/1,3,10,14,21/ DATA addptr/1,11,18/ c----------------------------------------------------------------------- argok=T CALL setint(NOTSET,2*PARG,arglog) DO WHILE (T) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,Inptok))THEN IF(Lfatal)RETURN GO TO(10,20,30,40,50,60,70,80,90,110,120,130,140,150,100,160), & argidx c ------------------------------------------------------------------ c start argument c ------------------------------------------------------------------ 10 CALL gtdtvc(Havesp,Sp,LPAREN,F,1,Strtss,nelt,argok,Inptok) IF(Lfatal)RETURN GO TO 170 c ------------------------------------------------------------------ c cutseas argument c ------------------------------------------------------------------ 20 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.0)THEN CALL inpter(PERROR,Errpos, & 'Value of cutseas must be greater than zero.') Inptok=F ELSE Sscut(1)=dvec(1) Sscut(3)=dvec(1) END IF END IF GO TO 170 c ----------------------------------------------------------------- c cutchng argument c ----------------------------------------------------------------- 30 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.0)THEN CALL inpter(PERROR,Errpos, & 'Value of cutchng must be greater than zero.') Inptok=F ELSE Sscut(4)=dvec(1) Sscut(5)=dvec(1) END IF END IF GO TO 170 c ----------------------------------------------------------------- c cuttd argument c ----------------------------------------------------------------- 40 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.0)THEN CALL inpter(PERROR,Errpos, & 'Value of cuttd must be greater than zero.') Inptok=F ELSE Sscut(2)=dvec(1) END IF END IF GO TO 170 c ------------------------------------------------------------------ c Outlier Identification argument c----------------------------------------------------------------------- 50 CALL gtdcvc(LPAREN,T,1,OTLDIC,otlptr,POTLSS, & 'Available options for outlier are no, keep, or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Otlidx=ivec(1)-1 GO TO 170 c ------------------------------------------------------------------ c regARIMA model parameter starting value argument c----------------------------------------------------------------------- 60 CALL gtdcvc(LPAREN,T,1,INTDIC,intptr,PINT, & 'Available options for fixmdl are no, clear, or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Intidx=ivec(1)-1 GO TO 170 c ----------------------------------------------------------------- c Print argument c ----------------------------------------------------------------- 70 CALL getprt(LSPSSP,NSPSSP,Inptok) GO TO 170 c ----------------------------------------------------------------- c Save argument c ----------------------------------------------------------------- 80 CALL getsav(LSPSSP,NSPSSP,Inptok) GO TO 170 c----------------------------------------------------------------------- c length argument c----------------------------------------------------------------------- 90 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(ivec(1).lt.3*Sp)THEN CALL inpter(PERROR,Errpos,'Length of sliding spans must be grea &ter than or equal to 3 years.') Inptok=F ELSE IF(ivec(1).gt.MXYR*Sp)THEN CALL itoc(MXYR,str,ipos) IF(Lfatal)RETURN CALL inpter(PERROR,Errpos, & 'Length of sliding spans must be less than or equal to '// & str(1:(ipos-1))//' years.') Inptok=F ELSE IF(argok)THEN Nlen=ivec(1) END IF GO TO 170 c ------------------------------------------------------------------ c x11outlier argument c----------------------------------------------------------------------- 100 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for x11outlier are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Ssxotl=ivec(1).eq.1 GO TO 170 c ------------------------------------------------------------------ c transparent argument c----------------------------------------------------------------------- 110 CALL gtdcvc(LPAREN,.true.,1,YSNDIC,ysnptr,PYSN, & 'Available options for transparent are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Sstran=ivec(1).eq.1 GO TO 170 c ----------------------------------------------------------------- c Savelog argument c ----------------------------------------------------------------- 120 CALL getsvl(LSLSSP,NSLSSP,Inptok) GO TO 170 c ------------------------------------------------------------------ c regression parameter fixing argument c----------------------------------------------------------------------- 130 CALL gtdcvc(LPAREN,T,PFXR,FXRDIC,fxrptr,PFXR, & 'Available options for fixreg are td, holiday, or user.', & Ssfxrg,Nssfxr,argok,Inptok) IF(Lfatal)RETURN GO TO 170 c ------------------------------------------------------------------ c additivesa argument c----------------------------------------------------------------------- 140 CALL gtdcvc(LPAREN,T,1,ADDDIC,addptr,PADD, & 'Available options for additivesa are difference or percent.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Ssdiff=ivec(1).eq.1 GO TO 170 c----------------------------------------------------------------------- c spans argument c----------------------------------------------------------------------- 150 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(ivec(1).le.1)THEN CALL inpter(PERROR,Errpos, & 'Value of spans must be greater than one.') Inptok=F ELSE IF(ivec(1).gt.MXCOL)THEN CALL itoc(MXCOL,str,ipos) IF(Lfatal)RETURN CALL inpter(PERROR,Errpos, & 'Value of spans must be less than or equal to '// & str(1:(ipos-1))//'.') Inptok=F ELSE IF(argok)THEN Ncol=ivec(1) END IF GO TO 170 c ------------------------------------------------------------------ c fixx11reg argument c----------------------------------------------------------------------- 160 CALL gtdcvc(LPAREN,.true.,1,YSNDIC,ysnptr,PYSN, & 'Available options for fixx11reg are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Ssxint=ivec(1).eq.1 GO TO 170 END IF IF(Lfatal)RETURN c---------------------------------------------------------------------- Inptok=Inptok.and.argok IF(Inptok)Issap=1 c---------------------------------------------------------------------- RETURN 170 CONTINUE END DO c ----------------------------------------------------------------- END getstr.f0000664006604000003110000000317114521201505011645 0ustar sun00315stepsC Last change: SRD 18 Nov 99 6:29 am SUBROUTINE getstr(Chrvec,Ptrvec,Nstr,Istr,Str,Nchr) IMPLICIT NONE c---------------------------------------------------------------------- c Gets the istr string if possible c---------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T PARAMETER(T=.true.) c ----------------------------------------------------------------- CHARACTER Chrvec*(*),Str*(*) INTEGER begstr,Istr,Nchr,Nstr,Ptrvec DIMENSION Ptrvec(0:Nstr) c ----------------------------------------------------------------- IF(Istr.gt.Nstr.or.Istr.lt.1)THEN CALL writln('Index out of range vector',STDERR,Mt2,T) * CALL writln('Index out of range vector (getstr)',STDERR,Mt2,T) CALL abend RETURN END IF c ----------------------------------------------------------------- CALL eltlen(Istr,Ptrvec,Nstr,Nchr) IF(Lfatal)RETURN begstr=Ptrvec(Istr-1) c ----------------------------------------------------------------- IF(Nchr.gt.len(Str))THEN CALL writln('Character string too long for target.', & STDERR,Mt2,T) CALL abend RETURN c ----------------------------------------------------------------- ELSE IF(Nchr.gt.0)THEN Str(1:Nchr)=Chrvec(begstr:begstr+Nchr-1) END IF c ----------------------------------------------------------------- RETURN END getsvec.f0000664006604000003110000000426714521201505012004 0ustar sun00315steps SUBROUTINE getSVec( vA, nA, nStart, nEnd, vB, nB ) c----------------------------------------------------------------------- c getSVec.f, Release 1, Subroutine Version 1.0, Created 22 Jul 2005. c----------------------------------------------------------------------- c This subroutine extracts the subvector of c vB = vA(nStart:nEnd). c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c nA i size (rows,columns) of vA vector c nB i size (rows,columns) of vB vector c nEnd i ending index of subvector in vA c nStart i starting index of subvector in vA c vA d input vector to extract subvector from c vB d output vector to contain subvector of vA c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i i index variable for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nStart, nEnd, nB(2) DOUBLE PRECISION vA(nA(1)), vB(nEnd-nStart+1) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i c----------------------------------------------------------------------- c Extract the submatrix. c----------------------------------------------------------------------- IF (( nA(1) .gt. 0 ) .and. ( nA(2) .eq. 1 )) THEN nB(1) = nEnd - nStart + 1 nB(2) = 1 DO i = nStart, nEnd vB(i-nStart+1) = vA(i) END DO ELSE nB(1) = 0 nB(2) = 0 END IF c ------------------------------------------------------------------ RETURN ENDgetsvl.f0000664006604000003110000001163314521201505011643 0ustar sun00315stepsC Last change: BCM 8 Dec 1998 2:26 pm **==getsav.f processed by SPAG 4.03F at 11:17 on 14 Sep 1994 SUBROUTINE getsvl(Spcdsp,Nspctb,Inptok) c----------------------------------------------------------------------- c Parses the input for the print argument in each of the specs c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- IMPLICIT NONE LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'svltbl.prm' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL hvcmma,Inptok,argok,opngrp INTEGER Nspctb,Spcdsp,tblidx c----------------------------------------------------------------------- INCLUDE 'svltbl.var' c----------------------------------------------------------------------- IF(Nxtktp.eq.EOF)THEN Inptok=F c----------------------------------------------------------------------- c Check for a list (, and possibly a null list). c----------------------------------------------------------------------- ELSE IF(Nxtktp.ne.LPAREN)THEN c----------------------------------------------------------------------- c Check for a table c----------------------------------------------------------------------- CALL gtdcnm(SVLDIC,svlptr(2*Spcdsp),2*Nspctb,tblidx,argok) IF(tblidx.eq.0)THEN CALL inpter(PERROR,Lstpos,'Savelog argument is not defined.') CALL writln( & ' Check the available diagnostics for this spec.', & STDERR,Mt2,F) CALL lex() Inptok=F c ------------------------------------------------------------------ ELSE tblidx=Spcdsp+(tblidx+1)/2 Svltab(tblidx)=T END IF c----------------------------------------------------------------------- c Process a list (Could be a null list.) c----------------------------------------------------------------------- ELSE opngrp=T hvcmma=F CALL lex() c ----------------------------------------------------------------- DO WHILE (T) IF(Nxtktp.eq.EOF)THEN CALL inpter(PERROR,Lstpos,'Unexpected EOF') Inptok=F GO TO 20 ELSE IF(Nxtktp.ne.RPAREN)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,acf) c or (acf,,pacf). Check for multiple NULLs. c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Inptok=F END IF c ----------------------------------------------------------------- CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a table. c----------------------------------------------------------------------- CALL gtdcnm(SVLDIC,svlptr(2*Spcdsp),2*Nspctb,tblidx,argok) IF(tblidx.eq.0)THEN CALL inpter(PERROR,Lstpos,'Savelog argument is not defined.') CALL writln( & ' Check the available diagnostics for this spec.', & STDERR,Mt2,F) CALL lex() Inptok=F c----------------------------------------------------------------------- c Tables have long and short names so there are double the c number of entries in the dictionary and so entry 2i-1 and 2i c map to table i. c----------------------------------------------------------------------- ELSE tblidx=Spcdsp+(tblidx+1)/2 Svltab(tblidx)=T END IF c ----------------------------------------------------------------- hvcmma=F opngrp=F c----------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. This indicates a NULL value, for example, (acf,pacf,). c----------------------------------------------------------------------- ELSE IF(hvcmma)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Inptok=F END IF c ------------------------------------------------------------------ CALL lex() GO TO 20 END IF 10 CONTINUE END DO END IF c ------------------------------------------------------------------ 20 RETURN END gettpltz.f0000664006604000003110000000713314521201505012214 0ustar sun00315steps SUBROUTINE getTpltz( vA, rA, rcB, mB, nB ) c----------------------------------------------------------------------- c getTpltz.f, Release 1, Subroutine Version 1.0, Created 11 Apr 2005. c----------------------------------------------------------------------- c This subroutine calculates the Toeplitz matrix mB given the vector c vA of diagonal entries. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mB d output Toeplitz square matrix c nB i size (rows,columns) of Toeplitz matrix mB c rA i length of vector vA c rcB i row/column size of output Toeplitz matrix mB c vA d input vector of Toeplitz diagonal entries c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER rA, rcB, nB(2) DOUBLE PRECISION vA( rA ), mB( rcB, rcB ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j c----------------------------------------------------------------------- c Check for valid Toeplitz matrix size. c----------------------------------------------------------------------- IF ( rcB .gt. 0 ) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nB(1) = rcB nB(2) = rcB c----------------------------------------------------------------------- c Zero out mB if rcB > rA c----------------------------------------------------------------------- IF ( rcB .gt. rA ) THEN DO i = 1, rcB DO j = 1, rcB mB(i,j) = 0.0D0 END DO END DO END IF c----------------------------------------------------------------------- c Create constant diagonals in Toeplitz matrix based on vA. c----------------------------------------------------------------------- DO i = 1, min( rA, rcB ) c ------------------------------------------------------------------ c Process main diagonal. c ------------------------------------------------------------------ IF ( i .eq. 1 ) THEN DO j = 1, rcB mB(j,j) = vA(1) END DO c ------------------------------------------------------------------ c Process off diagonals. c ------------------------------------------------------------------ ELSE IF ( i .le. rcB ) THEN DO j = 1, rcB+1-i mB(j,i-1+j) = vA(i) mB(i-1+j,j) = vA(i) END DO END IF END DO c----------------------------------------------------------------------- c Invalid Toeplitz matrix size. c----------------------------------------------------------------------- ELSE nB(1) = 0 nB(2) = 0 END IF c ------------------------------------------------------------------ RETURN ENDgettrc.f0000664006604000003110000000446214521201506011632 0ustar sun00315steps DOUBLE PRECISION FUNCTION getTrc( mA, nA ) c----------------------------------------------------------------------- c getTrc.f, Release 1, Subroutine Version 1.0, Created 18 Apr 2005. c----------------------------------------------------------------------- c This subroutine the trace of the square matrix mA with size nA. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d input matrix to calculate trace of c nA i size (rows,columns) of mA matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i i index variable for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2) DOUBLE PRECISION mA(nA(1),nA(2)) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i c----------------------------------------------------------------------- c Extract the submatrix. c----------------------------------------------------------------------- getTrc = 0.0D0 IF ( nA(1) .eq. nA(2) ) THEN DO i = 1,nA(1) getTrc = getTrc + mA(i,i) END DO END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION getTrcAB( mA, nA, mB, nB ) IMPLICIT NONE INTEGER nA(2), nB(2) DOUBLE PRECISION mA(nA(1),nA(2)), mB(nB(1),nB(2)) INTEGER i, j DOUBLE PRECISION diag, ZERO PARAMETER (ZERO=0.0D0) getTrcAB = ZERO IF (( nA(1) .eq. nB(2) ) .and. ( nA(2) .eq. nB(1) )) THEN DO i = 1,nA(1) diag = ZERO DO j = 1, nA(2) diag = diag + mA(i,j)*mB(j,i) END DO getTrcAB = getTrcAB + diag END DO END IF RETURN ENDgettr.f0000664006604000003110000000457714521201505011475 0ustar sun00315steps SUBROUTINE getTr( mA, nA, mATr, nATr ) c----------------------------------------------------------------------- c getTr.f, Release 1, Subroutine Version 1.0, Created 11 Apr 2005. c----------------------------------------------------------------------- c This subroutine calculates the transpose matrix mAT of a matrix mA c mATr = mA'. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d input matrix to perform transpose on c mATr d output matrix to contain transpose of mA c nA i size (rows,columns) of mA matrix c nATr i size (rows,columns) of mATr matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nATr(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mATr( nA(2), nA(1) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j c----------------------------------------------------------------------- c Calculate the dimensions of mAT. c----------------------------------------------------------------------- nATr(1) = nA(2) nATr(2) = nA(1) c----------------------------------------------------------------------- c Compute the matrix transpose of mATr = mA'. c----------------------------------------------------------------------- DO i = 1, nATr(1) c ------------------------------------------------------------------ c Get mAT row i from mA column i. c ------------------------------------------------------------------ DO j = 1, nATr(2) mATr(i,j) = mA(j,i) END DO END DO c ------------------------------------------------------------------ RETURN ENDgetttl.f0000664006604000003110000001547014521201506011646 0ustar sun00315stepsC Last change: BCM 23 Jul 1998 3:38 pm SUBROUTINE getttl(Grpchr,Flgnul,Pelt,Chrvec,Ptrvec,Nelt,Locok, & Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gtnmvc.f, Release 1, Subroutine Version 1.7, Modified 14 Feb 1995. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER Chrvec*(*),str*(LINLEN),str1*(5) LOGICAL Flgnul,hvcmma,Inptok,Locok,opngrp INTEGER clsgtp,clsgrp,Grpchr,ipos,Nelt,Pelt,Ptrvec,nstr1 DIMENSION Ptrvec(0:Pelt) EXTERNAL clsgrp c ------------------------------------------------------------------ Locok=T CALL intlst(Pelt,Ptrvec,Nelt) c ------------------------------------------------------------------ IF(Nxtktp.eq.EOF)THEN Locok=F c----------------------------------------------------------------------- c Get just one name or quote c----------------------------------------------------------------------- ELSE IF(Nxtktp.eq.NAME.or.Nxtktp.eq.QUOTE)THEN IF(Nxtkln.eq.0)THEN IF(Nxtktp.eq.NAME) & CALL inpter(PERROR,Lstpos,'Expected a NAME, QUOTE, or '// & 'list of either, not an empty string.') Locok=F ELSE IF(Pelt.eq.1.and.Nxtkln.gt.len(Chrvec))THEN nstr1=1 CALL itoc(len(Chrvec),str1,nstr1) CALL inpter(PWARN,Lstpos, & 'This title will be truncated at the first '// & str1(1:nstr1-1)//' characters.') CALL putstr(Nxttok(1:len(Chrvec)),Pelt,Chrvec,Ptrvec,Nelt) ELSE CALL putstr(Nxttok(1:Nxtkln),Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF END IF CALL lex() c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.Grpchr)THEN CALL inpter(PERROR,Lstpos, & 'Expected a NAME or a QUOTE or a list of either, not "'// & Nxttok(1:Nxtkln)//'"') Locok=F opngrp=F CALL lex() c----------------------------------------------------------------------- c Get a list of names or quotes c----------------------------------------------------------------------- ELSE opngrp=T hvcmma=F clsgtp=clsgrp(Grpchr) DO WHILE (T) c ------------------------------------------------------------------ CALL lex() c ------------------------------------------------------------------ IF(Nxtktp.ne.clsgtp)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,td,lom) c or (const,,td,lom). This section is repeated because there may be c multiple NULLs c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE CALL putstr(CNOTST,Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c There is not a close group or comma here so there must be a NAME c or a QUOTE. c----------------------------------------------------------------------- IF(Nxtktp.ne.NAME.and.Nxtktp.ne.QUOTE)THEN CALL inpter(PERROR,Lstpos,'Expected a NAME or QUOTE not "'// & Nxttok(1:Nxtkln)//'"') Locok=F ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE IF(Nxtkln.eq.0)THEN IF(Nxtktp.eq.NAME) & CALL inpter(PERROR,Lstpos,'Expected a NAME, QUOTE, or '// & 'list of either, not an empty string.') Locok=F ELSE CALL putstr(Nxttok(1:Nxtkln),Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF hvcmma=F opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a NULL after the last element but before the close of c the list. This indicates a NULL value, for example, (td,lom,). c These default values may exceed the length of the list. c----------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE CALL putstr(CNOTST,Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ IF(Locok)THEN CALL lex() ELSE CALL skplst(clsgtp) END IF GO TO 20 10 CONTINUE END DO c ------------------------------------------------------------------ END IF 20 Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END getx11.f0000664006604000003110000006143014521201506011451 0ustar sun00315stepsC Last change: BCM 13 May 2003 9:10 am SUBROUTINE getx11(Havesp,Sp,Muladd,Kfulsm,Sigml,Sigmu,Lterm, & Ktcopt,Lter,Notc,Imad,Ttlvec,Tic,Ksdev,Csigvc, & Keastr,Thtapr,Finhol,Finao,Finls,Fintc,Finusr, & Shrtsf,Psuadd,Prt1ps,Noxfct,Tru7hn, & Lcentr,Ishrnk,Inptok) c & Lcentr,Ishrnk,Kexopt,Iwt,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Get the X-11 seasonal adjustment options for X-13ARIMA-SEATS. c---------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- c Add appendbcst argument, october 2006, bcm c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'tbllog.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.i' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO LOGICAL T,F INTEGER PCHR,PTIT PARAMETER(PCHR=1000,PTIT=10,T=.true.,F=.false.,ONE=1D0,ZERO=0D0) c ------------------------------------------------------------------ CHARACTER cny*2,chrstr*(PCHR),Ttlvec*(*) LOGICAL Inptok,argok,gtarg,Csigvc,Havesp,Finhol,Finao,Finls,Fintc, & Finusr,Shrtsf,Psuadd,dpeq,Prt1ps,Noxfct, & Lcentr,Tru7hn INTEGER i,isf,nelt,Imad,Muladd,Kfulsm,Lterm,Ktcopt,isvc,Ishrnk, & Lter,Notc,Ksdev,Sp,ivec,Keastr,ptrstr,calidx DOUBLE PRECISION Sigml,Sigmu,sigl,Tic,Thtapr,dvec DIMENSION Csigvc(*),Lter(*),Ttlvec(*),isf(PSP),calidx(PSP), & sigl(2),ptrstr(0:PTIT),ivec(1),dvec(1) c ------------------------------------------------------------------ c INTEGER Kexopt,Iwt EXTERNAL gtarg,dpeq c ------------------------------------------------------------------ c Define the data dictionaries for the X11 arguments and other c function declarations. c ------------------------------------------------------------------ c x11 arguments data dictionary c ------------------------------------------------------------------ CHARACTER X11DIC*201 c CHARACTER X11DIC*215 INTEGER x11log,x11idx,x11ptr,PX11 PARAMETER(PX11=25) c PARAMETER(PX11=27) DIMENSION x11ptr(0:PX11),x11log(2,PX11) PARAMETER(X11DIC='modesigmalimseasonalmatrendmatitleextremeadjtype &appendfcsttrendiccalendarsigmasigmavecx11eastertaperkeepholidayfin &alsfshortprintsavesavelogprint1stpassexcludefcsttrue7termshrinkcen &terseasonalappendbcst') c &terseasonalappendbcststrikeitrendma') c ------------------------------------------------------------------ c seasonal adjustment mode data dictionary c ------------------------------------------------------------------ CHARACTER MODDIC*22 INTEGER modptr,PMODE PARAMETER(PMODE=4) DIMENSION modptr(0:PMODE) PARAMETER(MODDIC='multaddlogaddpseudoadd') c ------------------------------------------------------------------ c seasonal filter data dictionary c ------------------------------------------------------------------ CHARACTER SFDIC*40 INTEGER sfptr,PSF PARAMETER(PSF=8) DIMENSION sfptr(0:PSF) PARAMETER(SFDIC='x11defaults3x3s3x5s3x9s3x15stablemsrs3x1') c ------------------------------------------------------------------ c seasonal adjustment type data dictionary c ------------------------------------------------------------------ CHARACTER TYPDIC*14 INTEGER typptr,PSATYP PARAMETER(PSATYP=3) DIMENSION typptr(0:PSATYP) PARAMETER(TYPDIC='sasummarytrend') c ------------------------------------------------------------------ c X-11 extreme variance data dictionary c ------------------------------------------------------------------ CHARACTER OTLDIC*23 INTEGER otlptr,POTLXV PARAMETER(POTLXV=5) DIMENSION otlptr(0:POTLXV) PARAMETER(OTLDIC='stdwmadwmadlogtautaulog') c----------------------------------------------------------------------- c calendar sigma data dictionary c----------------------------------------------------------------------- CHARACTER BNDDIC*19 INTEGER bndptr,PBND PARAMETER(PBND=4) DIMENSION bndptr(0:PBND) PARAMETER(BNDDIC='nonesignifallselect') c----------------------------------------------------------------------- c data dictionary of yes/no choice c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c ------------------------------------------------------------------ c data dictionary for final argument c ------------------------------------------------------------------ CHARACTER FINDIC*10 INTEGER finind,finptr,PFIN PARAMETER(PFIN=4) DIMENSION finind(PFIN),finptr(0:PFIN) PARAMETER(FINDIC='aolsusertc') c ------------------------------------------------------------------ c data dictionary for initial trend moving average c ------------------------------------------------------------------ * CHARACTER ITRDIC*22 * INTEGER itrptr,PITR * PARAMETER(PITR=2) * DIMENSION itrptr(0:PITR) * PARAMETER(ITRDIC='centered1yrcholette2yr') c----------------------------------------------------------------------- c sigmavec data dictionary c----------------------------------------------------------------------- CHARACTER SUMDIC*118 INTEGER sumptr,PSUM PARAMETER(PSUM=28) DIMENSION sumptr(0:PSUM) PARAMETER(SUMDIC= &'janfebmaraprmayjunjulaugsepoctnovdecjanuaryfebruarymarchaprilmayj &unejulyaugustseptemberoctobernovemberdecemberq1q2q3q4') c ------------------------------------------------------------------ c data dictionary for shrinkage estimators c ------------------------------------------------------------------ CHARACTER SHKDIC*15 INTEGER shkptr,PSHK PARAMETER(PSHK=3) DIMENSION shkptr(0:PSHK) PARAMETER(SHKDIC='nonegloballocal') c ------------------------------------------------------------------ c Define data dictionary pointers c ------------------------------------------------------------------ DATA x11ptr / 1,5,13,23,30,35,45,49,59,66,79,87,96,101,112,117, & 124,129,133,140,152,163,172,178,192,202/ c & 124,129,133,140,152,163,172,178,192,202,208,216/ DATA modptr/1,5,8,14,23/ DATA sfptr/1,11,15,19,23,28,34,37,41/ DATA sumptr/1,4,7,10,13,16,19,22,25,28,31,34,37,44,52,57,62,65,69, & 73,79,88,95,103,111,113,115,117,119/ DATA typptr/1,3,10,15/ DATA otlptr/1,4,8,15,18,24/ DATA bndptr/1,5,11,14,20/ DATA ysnptr/1,4,6/ DATA finptr/1,3,5,9,11/ * DATA itrptr/1,12,23/ DATA shkptr/1,5,11,16/ c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- argok=T CALL setdp(DNOTST,2,sigl) CALL setint(NOTSET,PSP,isf) CALL setint(NOTSET,2*PX11,x11log) c----------------------------------------------------------------------- DO WHILE (T) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- IF(gtarg(X11DIC,x11ptr,PX11,x11idx,x11log,Inptok))THEN IF(Lfatal)RETURN GO TO(10,20,30,40,60,70,80,90,120,130,140,210,250,260,290,265, & 270,280,300,100,310,320,200,160,170),x11idx c & 270,280,300,100,310,320,200,160,170,150,50),x11idx c----------------------------------------------------------------------- c mode argument c----------------------------------------------------------------------- 10 CALL gtdcvc(LPAREN,T,1,MODDIC,modptr,PMODE, & 'Improper seasonal adjustment mode: valid choices for mode are', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.le.0)THEN CALL writln(' mult, add, logadd or pseudoadd.',STDERR, & Mt2,F) ELSE Muladd=ivec(1) IF(argok)THEN IF(Muladd.eq.4)THEN Muladd=0 Psuadd=T ELSE Muladd=Muladd-1 END IF END IF END IF GO TO 330 c----------------------------------------------------------------------- c sigmalim argument c----------------------------------------------------------------------- 20 CALL gtdpvc(LPAREN,F,2,sigl,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos, & 'Two sigma limits needed (or use a comma as place holder).') Inptok=F ELSE IF(nelt.gt.0)THEN IF(dpeq(sigl(1),DNOTST))sigl(1)=1.5D0 IF(dpeq(sigl(2),DNOTST))sigl(2)=2.5D0 IF(sigl(1).le.ZERO.or.sigl(2).le.ZERO)THEN CALL inpter(PERROR,Errpos,'Sigma limits must be greater than z &ero.') Inptok=F c----------------------------------------------------------------------- ELSE IF(sigl(1).gt.sigl(2))THEN CALL inpter(PERROR,Errpos,'Lower sigma limit must be less than & upper sigma limit.') Inptok=F c----------------------------------------------------------------------- ELSE Sigml=sigl(1) Sigmu=sigl(2) END IF END IF GO TO 330 c----------------------------------------------------------------------- c seasonalma argument c----------------------------------------------------------------------- 30 CALL gtdcvc(LPAREN,F,PSP,SFDIC,sfptr,PSF, & 'Improper value(s) entered for seasonalma.', & isf,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.0)THEN CALL writln(' Valid choices of seasonal filter are s3x1, &s3x3, s3x5, s3x9,',STDERR,Mt2,F) CALL writln(' s3x15, stable, msr, or x11default.', & STDERR,Mt2,F) END IF IF(argok.and.nelt.gt.0)THEN c----------------------------------------------------------------------- IF(.not.Havesp)THEN CALL inpter(PERROR,Errpos, & 'No seasonal period specified in series spec.') Inptok=F c----------------------------------------------------------------------- c If only one filter given, use it all year c----------------------------------------------------------------------- ELSE IF(nelt.eq.1)THEN Lterm=isf(1)-1 DO i=1,Sp Lter(i)=Lterm END DO c----------------------------------------------------------------------- c If filters are given for every month (or quarter) of the year, c reset those periods not set to be the same as the first period. c----------------------------------------------------------------------- ELSE IF(nelt.eq.Sp)THEN IF(isf(1).eq.NOTSET)isf(1)=6 Lterm=isf(1)-1 Lter(1)=Lterm DO i=2,Sp IF(isf(i).eq.NOTSET)THEN Lter(i)=Lterm ELSE Lter(i)=isf(i)-1 END IF END DO c----------------------------------------------------------------------- c Else, print out an error message. c----------------------------------------------------------------------- ELSE i=1 CALL itoc(Sp,cny,i) CALL inpter(PERROR,Errpos,'Specify either 1 or '// & cny(1:(i-1))//' seasonal filters (or use a comma as a') CALL writln(' place holder).',STDERR,Mt2,F) Inptok=F END IF END IF GO TO 330 c----------------------------------------------------------------------- c trendma argument c----------------------------------------------------------------------- 40 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(mod(ivec(1),2).eq.0.or.ivec(1).le.0)THEN CALL inpter(PERROR,Errpos,'Length of Henderson trend filter mu &st be a positive odd integer.') Inptok=F ELSE Ktcopt=ivec(1) END IF END IF GO TO 330 c----------------------------------------------------------------------- c itrendma argument c----------------------------------------------------------------------- c 50 CALL gtdcvc(LPAREN,F,1,ITRDIC,itrptr,PSF,'Available options for c &itrendma are centered1yr and chollette2yr.', c & ivec,nelt,argok,Inptok) c IF(Lfatal)RETURN c ------------------------------------------------------------------ c IF(argok.and.nelt.gt.0)Iwt=ivec(1)-1 c GO TO 330 c----------------------------------------------------------------------- c Title argument c----------------------------------------------------------------------- 60 CALL getttl(LPAREN,T,PTIT,chrstr,ptrstr,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN DO i=1,nelt CALL getstr(chrstr,ptrstr,nelt,i,Ttlvec(i),Notc) IF(Lfatal)RETURN END DO Notc=nelt END IF CALL setchr(' ',PCHR,chrstr) GO TO 330 c----------------------------------------------------------------------- c X-11 Extreme value detection argument c----------------------------------------------------------------------- 70 CALL gtdcvc(LPAREN,T,1,OTLDIC,otlptr,POTLXV,'Improper X-11 outli &er option: valid choices for extremeadj are', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.le.0)THEN CALL writln(' std, wmad, wmadlog, tau, taulog.',STDERR, & Mt2,F) ELSE IF(argok)Imad=ivec(1)-1 END IF GO TO 330 c----------------------------------------------------------------------- c type argument c----------------------------------------------------------------------- 80 CALL gtdcvc(LPAREN,T,1,TYPDIC,typptr,PSATYP, & 'The available adjustment types are sa, summary, or trend.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Kfulsm=ivec(1)-1 GO TO 330 c----------------------------------------------------------------------- c appendfcst argument c----------------------------------------------------------------------- 90 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for appending forecasts are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Savfct=ivec(1).eq.1 GO TO 330 c----------------------------------------------------------------------- c print1stpass argument c----------------------------------------------------------------------- 100 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for print1stpass are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Prt1ps=ivec(1).eq.1 GO TO 330 c----------------------------------------------------------------------- c trendic argument c----------------------------------------------------------------------- 120 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Specified I/C ratio must be greater than zero.') Inptok=F ELSE Tic=dvec(1) END IF END IF GO TO 330 c----------------------------------------------------------------------- c Bundesbank outlier adjustment argument c----------------------------------------------------------------------- 130 CALL gtdcvc(LPAREN,T,1,BNDDIC,bndptr,PBND,'Available options for & calendarsigma are none, signif, all or select.',ivec,nelt,argok, & Inptok) IF(Lfatal)RETURN Ksdev=ivec(1) GO TO 330 c----------------------------------------------------------------------- c Periods to be grouped together for CALENDARSIGMA=SELECT option c----------------------------------------------------------------------- 140 CALL gtdcvc(LPAREN,T,PSP,SUMDIC,sumptr,PSUM, & 'Improper value(s) entered for sigmavec.', & calidx,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.0)THEN CALL writln(' Valid choices for sigmavec are the name(s) &of a month or',STDERR,Mt2,F) CALL writln(' quarter.',STDERR,Mt2,F) END IF c----------------------------------------------------------------------- IF(argok.and.nelt.gt.0)THEN IF(.not.Havesp)THEN CALL inpter(PERROR,Errpos, & 'No seasonal period specified in series spec.') Inptok=F c----------------------------------------------------------------------- ELSE DO i=1,nelt isvc=calidx(i) IF(isvc.ge.13.and.isvc.le.24.and.Sp.eq.12)THEN isvc=isvc-12 ELSE IF(isvc.ge.25.and.Sp.eq.4)THEN isvc=isvc-24 ELSE IF(Sp.eq.12.and.isvc.ge.25)THEN CALL inpter(PERROR,Errpos,'Entry for sigmavec not valid for & monthly data.') Inptok=F isvc=NOTSET ELSE IF(Sp.eq.4.and.isvc.lt.25)THEN CALL inpter(PERROR,Errpos,'Entry for sigmavec not valid for & quarterly data.') Inptok=F isvc=NOTSET END IF END IF IF(isvc.gt.0)Csigvc(isvc)=T END DO END IF END IF GO TO 330 c----------------------------------------------------------------------- c strike argument c----------------------------------------------------------------------- c 150 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, c & 'Available options for strike are yes or no.', c & ivec,nelt,argok,Inptok) c IF(Lfatal)RETURN c IF(argok.and.nelt.gt.0)Kexopt=2-ivec(1) c GO TO 330 c----------------------------------------------------------------------- c centerseasonal argument c----------------------------------------------------------------------- 160 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for centerseasonal are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lcentr=ivec(1).eq.1 GO TO 330 c----------------------------------------------------------------------- c appendbcst argument c----------------------------------------------------------------------- 170 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for appending backcasts are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Savbct=ivec(1).eq.1 GO TO 330 c----------------------------------------------------------------------- c shrink argument c----------------------------------------------------------------------- 200 CALL gtdcvc(LPAREN,T,1,SHKDIC,shkptr,PSHK, & 'Entry for shrink argument must be none, global or local.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Ishrnk=ivec(1)-1 GO TO 330 c----------------------------------------------------------------------- c x11easter argument c----------------------------------------------------------------------- 210 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for x11easter are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Keastr=2-ivec(1) GO TO 330 c----------------------------------------------------------------------- c Taper argument c----------------------------------------------------------------------- 250 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Error Checking for taper c----------------------------------------------------------------------- IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO.or.dvec(1).gt.ONE)THEN CALL inpter(PERROR,Errpos, & 'Value of taper must be between zero and 1.') Inptok=F ELSE Thtapr=dvec(1) END IF END IF GO TO 330 c----------------------------------------------------------------------- c keepholiday argument c----------------------------------------------------------------------- 260 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for keepholiday are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)Finhol=ivec(1).eq.2 GO TO 330 c----------------------------------------------------------------------- c final argument c----------------------------------------------------------------------- 290 CALL gtdcvc(LPAREN,T,PFIN,FINDIC,finptr,PFIN, & 'Choices for final argument are ao, ls, tc, or user.', & finind,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN DO i=1,nelt IF(finind(i).eq.1)THEN Finao=T ELSE IF(finind(i).eq.2)THEN Finls=T ELSE IF(finind(i).eq.3)THEN Finusr=T ELSE IF(finind(i).eq.4)THEN Fintc=T END IF END DO END IF GO TO 330 c----------------------------------------------------------------------- c sfshort argument c----------------------------------------------------------------------- 265 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for sfshort are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Shrtsf=ivec(1).eq.1 GO TO 330 c----------------------------------------------------------------------- c print argument c----------------------------------------------------------------------- 270 CALL getprt(LSPX11,NSPX11,Inptok) GO TO 330 c----------------------------------------------------------------------- c save argument c----------------------------------------------------------------------- 280 CALL getsav(LSPX11,NSPX11,Inptok) GO TO 330 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 300 CALL getsvl(LSLX11,NSLX11,Inptok) GO TO 330 c----------------------------------------------------------------------- c excludefcst argument c----------------------------------------------------------------------- 310 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for excludefcst are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Noxfct=ivec(1).eq.1 GO TO 330 c----------------------------------------------------------------------- c true7term argument c----------------------------------------------------------------------- 320 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for true7term are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Tru7hn=ivec(1).eq.1 GO TO 330 c ------------------------------------------------------------------ END IF IF(Lfatal)RETURN Inptok=Inptok.and.argok RETURN 330 CONTINUE END DO c ------------------------------------------------------------------ END getxop.f0000664006604000003110000002436614521201506011655 0ustar sun00315stepsC Last Change: Mar. 2021 - update Messages on program flags C previous change: BCM 14 May 1998 9:00 am SUBROUTINE getxop(Lmeta,Lchkin,Lcomp,Lsumm,Lmdsum,Lnoprt,Lwdprt, & Lpage,Ldata,Dtafil,Lgraf,Grfdir,Lcmpaq,Ltimer) IMPLICIT NONE C----------------------------------------------------------------------- c Get program options entered on the command line. This is the c PC version of this routine, compiled with Lahey FORTRAN. C----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'error.cmn' C----------------------------------------------------------------------- LOGICAL F,T PARAMETER(T=.true.,F=.false.) C----------------------------------------------------------------------- LOGICAL gtifil,gtofil,Lnoprt,Lmeta,Lchkin,Lcomp,Lwdprt,lok,Lpage, & Ldata,Lgraf,Lcmpaq,Lmdsum,Ltimer INTEGER Lsumm,numopt,narg CHARACTER arg*(PFILCR),Dtafil*(PFILCR),Grfdir*(PFILCR) C----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank C----------------------------------------------------------------------- C Initialize program execution options C----------------------------------------------------------------------- Lmeta=F Ldata=F Lchkin=F Lcomp=F Lsumm=0 Lmdsum=T Lnoprt=F Lpage=T gtifil=F gtofil=F Lgraf=F Lcmpaq=F Lquiet=F Ltimer=F lok=T C----------------------------------------------------------------------- C Initialize argument counter and start processing program arguments C----------------------------------------------------------------------- numopt=1 CALL setchr(' ',PFILCR,arg) CALL getarg(numopt,arg) IF(Lfatal)RETURN DO WHILE (arg(1:1).ne.' ') IF(arg(1:1).eq.'-')THEN IF(arg.eq.'-M'.or.arg.eq.'-m')THEN IF(Ldata)THEN WRITE(STDERR,1010)' ERROR: Cannot specify data (-d) and input &(-m) metafiles in the same run.' 1010 FORMAT(/,a) CALL abend RETURN ELSE Lmeta=T END IF numopt=numopt+1 CALL getarg(numopt,Infile) IF(Infile(1:1).eq.' '.or.Infile(1:1).eq.'-')THEN WRITE(STDERR,1010)' ERROR: An input metafile name must immedia &tely follow the -m flag.' CALL abend RETURN END IF ELSE IF(arg.eq.'-D'.or.arg.eq.'-d')THEN IF(Lmeta)THEN WRITE(STDERR,1010)' ERROR: Cannot specify data (-d) and input &(-m) metafiles in the same run.' CALL abend RETURN ELSE Lmeta=T END IF Ldata=T numopt=numopt+1 CALL getarg(numopt,Dtafil) IF(Dtafil(1:1).eq.' '.or.Dtafil(1:1).eq.'-')THEN WRITE(STDERR,1010)' ERROR: A data metafile name must immediate &ly follow the -d flag.' CALL abend RETURN END IF ELSE IF(arg.eq.'-I'.or.arg.eq.'-i')THEN gtifil=T numopt=numopt+1 CALL getarg(numopt,Infile) IF(Infile(1:1).eq.' '.or.Infile(1:1).eq.'-')THEN WRITE(STDERR,1010)' ERROR: An input spec file name must immedi &ately follow the -i flag.' CALL abend RETURN END IF ELSE IF(arg.eq.'-O'.or.arg.eq.'-o')THEN gtofil=T numopt=numopt+1 CALL getarg(numopt,Cursrs) IF(Cursrs(1:1).eq.' '.or.Cursrs(1:1).eq.'-')THEN WRITE(STDERR,1010)' ERROR: An output file name must immediatel &y follow the -o flag.' CALL abend RETURN END IF ELSE IF(arg.eq.'-G'.or.arg.eq.'-g')THEN Lgraf=T numopt=numopt+1 CALL getarg(numopt,Grfdir) IF(Grfdir(1:1).eq.' '.or.Grfdir(1:1).eq.'-')THEN WRITE(STDERR,1010)' ERROR: A graphics file directory name must & immediately follow the -g flag.' CALL abend RETURN END IF ELSE IF(arg.eq.'-V'.or.arg.eq.'-v')THEN Lchkin=T ELSE IF(arg.eq.'-C'.or.arg.eq.'-c')THEN Lcomp=T ELSE IF(arg.eq.'-S'.or.arg.eq.'-s')THEN Lsumm=2 Lmdsum=T ELSE IF(arg.eq.'-N'.or.arg.eq.'-n')THEN Lnoprt=T ELSE IF(arg.eq.'-W'.or.arg.eq.'-w')THEN Lwdprt=T ELSE IF(arg.eq.'-P'.or.arg.eq.'-p')THEN Lpage=F ELSE IF(arg.eq.'-R'.or.arg.eq.'-r')THEN Lcmpaq=T ELSE IF(arg.eq.'-Q'.or.arg.eq.'-q')THEN Lquiet=T ELSE IF(arg.eq.'-T'.or.arg.eq.'-t')THEN Ltimer=T ELSE IF(arg.eq.'-')THEN WRITE(STDERR,1010)' ERROR: No program option specified after th &e dash (-).' CALL abend RETURN ELSE narg=nblank(arg) WRITE(STDERR,1020)arg(1:narg) 1020 FORMAT(/,' ERROR: Program option ',a,' not defined. ', & 'Valid program options are ',/,' -I, -O, -M, ', & '-D, -C, -S, -N, -V, -P, -R, -Q, -W, -G, -T.') CALL abend RETURN END IF ELSE IF(numopt.eq.1)THEN gtifil=T Infile=arg ELSE IF(numopt.eq.2.and.gtifil)THEN gtofil=T Cursrs=arg ELSE narg=nblank(arg) WRITE(STDERR,1030)arg(1:narg) 1030 FORMAT(/,' ERROR: Program option ',a,' not defined; valid ', & 'options must be preceded',/,' by a dash (-): ', & '-I, -O, -M, -D, -C, -S, -N, -V, -P, -R, -Q, -W, ', & '-G, -T.') CALL abend RETURN END IF C----------------------------------------------------------------------- numopt=numopt+1 CALL getarg(numopt,arg) END DO C----------------------------------------------------------------------- c If compositing option is selected, check to see if metafile input c is specified; if no, print error message. C----------------------------------------------------------------------- IF(Lcomp.and.(.not.Lmeta))THEN WRITE(STDERR,1040) 1040 FORMAT(/,' ERROR: Must specify metafile input (-m metafile)', & ' when using composite',/,' option (-c).') lok=F END IF IF(Lcomp.and.Ldata)THEN WRITE(STDERR,1050) 1050 FORMAT(/,' ERROR: Cannot specify data metafile input (-d ', & 'datametafile) when using',/, & ' composite option (-c).') lok=F END IF C----------------------------------------------------------------------- c If input verification option is selected, check to see if the -s, c -c or -n options are present; if so, print an error message. C----------------------------------------------------------------------- IF((Lchkin.and.(Lcomp.OR.(Lsumm.gt.0).or.Lnoprt.or.Lwdprt.or. & (.not.Lpage))).and.(.not.Lquiet))WRITE(STDERR,1060) 1060 FORMAT(/,' NOTE: Input verification option (-v) is specified ', & 'in the same run as',/, & ' the composite (-c), diagnostic storage (-s),', & ' no print (-n),',/, & ' wide printout (-w), or page suppress (-p) ', & 'options. These',/, & ' other flags have been ignored.') C----------------------------------------------------------------------- c If graphics option is specified in a run without the diagnostic c option specified in same run, diagnostic option to true. C----------------------------------------------------------------------- IF(Lgraf.and.Lsumm.eq.0)THEN Lsumm=1 Lmdsum=T END IF C----------------------------------------------------------------------- c If timer option is specified in a run without the diagnostic c option specified in same run, diagnostic option to true. C----------------------------------------------------------------------- IF(Ltimer.and.Lsumm.eq.0)THEN Lsumm=1 Lmdsum=T END IF C----------------------------------------------------------------------- c If compact output is specified in a run with a wide printout c option, the wide printout option to set to false. C----------------------------------------------------------------------- IF(Lcmpaq.and.Lwdprt)Lwdprt=F C----------------------------------------------------------------------- c Ensure that metafile input and an alternate output filename are c not selected in the same run. C----------------------------------------------------------------------- IF(Lmeta)THEN IF(gtofil)THEN WRITE(STDERR,1070) 1070 FORMAT(/,' ERROR: Cannot specify metafile input (-m metafile)', & ' when using an ',/,' alternate output file ', & 'name (-o outfile).') lok=F END IF C----------------------------------------------------------------------- IF(.not.Ldata.and.gtifil)THEN WRITE(STDERR,1080) 1080 FORMAT(/,' ERROR: Cannot specify metafile input (-m metafile)', & ' and single file input',/,' (-i infile or ', & 'infile) in the same run.') lok=F END IF ELSE C----------------------------------------------------------------------- c If this is not a metafile run, set values for the Input and Output c file names to default values if they have not already been set. C----------------------------------------------------------------------- IF(.not.gtifil)THEN WRITE(STDERR,1090)RUNSEC,PRGNAM,DOCNAM,PRGNAM 1090 FORMAT(/,' ERROR: Must specify either an input specification ', & 'file name', & /,' (-i infile or infile) or an input metafile ', & 'name (-m metafile).',/, & /,' See ',a,' of the ',a,' ',a,' for more', & /,' information on how to run ',a,'.') lok=F END IF IF(.not.gtofil)Cursrs=Infile END IF C----------------------------------------------------------------------- IF(.not.lok)CALL abend RETURN END getxtd.f0000664006604000003110000000721714521201506011642 0ustar sun00315stepsC Last change: BCM 28 Sep 1998 10:27 am **==getxtd.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 SUBROUTINE getxtd(Tdx,Begtd,Ll1,Lld,Muladd) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine sets up a variable which tells which X-11 trading c day factor is associated with which type of month. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'picktd.cmn' INCLUDE 'tdtyp.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- LOGICAL T PARAMETER(T=.true.) c----------------------------------------------------------------------- INTEGER i,i1,i2,Begtd,LL1,Lld,Muladd,ndif,n1,nn,tdgrp DOUBLE PRECISION lom,fac,Tdx DIMENSION Begtd(2),Tdx(*) c----------------------------------------------------------------------- LOGICAL dpeq INTEGER strinx EXTERNAL dpeq,strinx c----------------------------------------------------------------------- c First, check to see if there are trading day or stock trading day c regressors, not user defined regressors. If not, return. c----------------------------------------------------------------------- tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(tdgrp.eq.0)tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'Stock Trading Day') IF(tdgrp.eq.0)THEN Tdtbl=0 RETURN END IF c----------------------------------------------------------------------- c determine starting and ending points of trading day c change of regimes, if necessary. c----------------------------------------------------------------------- IF(Lrgmtd)CALL dfdate(Tddate,Begtd,Sp,ndif) n1=Ll1 nn=Lld IF(Tdzero.lt.0)THEN n1=ndif+1 ELSE IF(Lrgmtd)THEN nn=ndif END IF c----------------------------------------------------------------------- c For each observation, test to see if a factor has been associated c with this type of month. c----------------------------------------------------------------------- fac=1D0 IF(Muladd.ne.1)fac=100D0 DO i=n1,nn IF(dpeq(Tdx11(Tday(i)),DNOTST))THEN c----------------------------------------------------------------------- c Generate a factor for the leap year effect inherent in the X-11 c trading day factor. c----------------------------------------------------------------------- IF(Muladd.eq.1)THEN lom=1D0 ELSE c lom=Xn(i)/Xnstar(i) lom=Xnstar(i)/Xn(i) END IF c----------------------------------------------------------------------- c Copy X-11 trading day factors for the given type-of-month. c----------------------------------------------------------------------- Tdx11(Tday(i))=Tdx(i)*lom*fac END IF END DO c----------------------------------------------------------------------- IF((Fulltd.or.Tdzero.eq.2).and.Lrgmtd)THEN IF(Tdzero.gt.0)THEN i1=nn+1 i2=Lld ELSE i1=Ll1 i2=n1 END IF DO i=i1,i2 IF(dpeq(Tdx11b(Tday(i)),DNOTST))THEN IF(Muladd.eq.1)THEN lom=1D0 ELSE c lom=Xn(i)/Xnstar(i) lom=Xnstar(i)/Xn(i) END IF Tdx11b(Tday(i))=Tdx(i)*lom*fac END IF END DO END IF c----------------------------------------------------------------------- RETURN END glbshk.f0000664006604000003110000000741414521201506011614 0ustar sun00315stepsC Last change: BCM 7 May 2003 2:24 pm SUBROUTINE glbshk(Sts,V,Ny,Muladd) IMPLICIT NONE C----------------------------------------------------------------------- c Generate seasonal factors based on the global shrinkage method c given in the paper "Shrinkage Est. of Time Series Seasonal Factors c and their Effect on Forecasting Accuracy", c Miller & Williams (2003) C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11ptr.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE PARAMETER (ZERO=0D0,ONE=1D0) C----------------------------------------------------------------------- INTEGER i,i1,i2,iend,imi,ipi,it1,it2,j,Ny,nt,Muladd,k,kyr DOUBLE PRECISION avec,corr,Sts,wvec,sfmu,temps,V,dny DIMENSION avec(PYRS),Sts(PLEN),wvec(PYRS),temps(PLEN) C----------------------------------------------------------------------- CALL setdp(ZERO,PYRS,avec) CALL setdp(ZERO,PYRS,wvec) IF(Muladd.eq.1)THEN sfmu=ZERO ELSE sfmu=ONE END IF C----------------------------------------------------------------------- C Copy seasonal factors into double precision variable. C----------------------------------------------------------------------- it1 = mod(Pos1ob,Ny) IF (it1.eq.0) it1 = Ny nt = Posfob-Pos1ob+1 CALL copy(Sts(Pos1ob),nt,1,temps(it1)) C----------------------------------------------------------------------- C Fill incomplete years at the beginning and end of the array with C backcasts/forecasts or the nearest values for the same C month/quarter (if necessary). C----------------------------------------------------------------------- IF(it1.gt.1)THEN DO i=1,it1-1 ipi=Pos1ob-i imi=it1-i IF(ipi.ge.Pos1bk)THEN temps(imi)=Sts(ipi) ELSE temps(imi)=Sts(ipi+Ny) END IF END DO END IF iend=it1+(Posfob-Pos1ob) it2=mod(Posfob,Ny) IF(it2.gt.0)THEN DO i=1,(Ny-it2) ipi=Posfob+i imi=iend+i IF(ipi.le.Posffc)THEN temps(imi)=Sts(ipi) ELSE temps(imi)=Sts(ipi-Ny) END IF END DO iend=iend+Ny-it2 END IF C----------------------------------------------------------------------- C Set kyr to be the number of years given in temps C----------------------------------------------------------------------- kyr=iend/Ny dny=DBLE(Ny) C----------------------------------------------------------------------- DO k=1,kyr i1=(k-1)*Ny+1 i2=k*Ny DO i=i1,i2 avec(k)=avec(k)+(Sts(i)-sfmu)*(Sts(i)-sfmu) END DO avec(k)=(avec(k)/(dny-ONE))-V if (avec(k).lt.ZERO) avec(k)=ZERO END DO C----------------------------------------------------------------------- c compute global shrinkage estimator for each year C----------------------------------------------------------------------- corr=DBLE(Ny-3)/DBLE(Ny-1) DO j=1,kyr wvec(j)=corr*V/(V + avec(j)) END DO C----------------------------------------------------------------------- C compute seasonal factors with global shrinkage estimator applied C----------------------------------------------------------------------- IF(it2.gt.0)iend=iend-Ny+it2 DO k=1,kyr i1=(k-1)*Ny+1 IF(i1.lt.it1)i1=it1 i2=k*Ny if (i2.gt.iend)i2=iend DO i=i1,i2 j=i+(Pos1ob-it1) Sts(j)=temps(i)*(ONE-wvec(k))+wvec(k) END DO END DO C----------------------------------------------------------------------- RETURN END global.cmn0000664006604000003110000000114314521201506012123 0ustar sun00315steps DOUBLE PRECISION P0,Qp,K,Qk,Svk,Snr,Sni,U,V0,A0,B0,C,D0,A1,A3, & A7,E,F,G,H,Szr,Szi,Lzr,Lzi,Eta,Are,Mre INTEGER N,N0 C----------------------------------------------------------------------- DIMENSION P0(PORDER+1),Qp(PORDER+1),K(PORDER+1),Qk(PORDER+1), & Svk(PORDER+1) C----------------------------------------------------------------------- COMMON /global/ P0,Qp,K,Qk,Svk,Snr,Sni,U,V0,A0,B0,C,D0,A1,A3, & A7,E,F,G,H,Szr,Szi,Lzr,Lzi,Eta,Are,Mre,N,N0 C----------------------------------------------------------------------- gmeta.prm0000664006604000003110000000273414521201506012010 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c graphics meta files. See gmeta.var for pointers. c----------------------------------------------------------------------- CHARACTER GMTDIC*901 INTEGER gmtptr,PGMT PARAMETER(PGMT=395) DIMENSION gmtptr(0:PGMT) c----------------------------------------------------------------------- PARAMETER(GMTDIC='orimvadjcadoadadororicntpriorppriortpriorpadjppr &adjpadjtppradjtotlaolstcsortdrholusrdefrgseastrancmpidacfidpacfmdl &estregrsdfintstacfpacfacf2ftrfctbtrbctsporsprsdspsaspirspcssaspcsi &rspexrsdindspsaindspircmpsporsptukorsptukrsdsptuksasptukirspctukss &aspctuksirsptukexrsdindsptuksaindsptukircmpsptukormorimsamirrsisio &xrsisfsfrsfshnksasactrnirrirrwtxtrmxeastrcholcafcalarattadjsatsarf &rfcptdxtdctdxholxcalccalahstcsahstindahsttrnhstctrhstsfhstaichstfc &thstcfchstarmahsttdhstsfssindsfsschssindchsssassindsassyyssindyyss &tdsscmporicmppadjadjcoricmpcadcmpoadindsiindrsiindsfindsaindtrnind &irrindmoriindmsaindmirrindaratindtadjindsatindsarindlsindaoindcali &ndcafindfrfcseattrnsettrcseatsfseatirrseatsasetsacsettrnsseataftrn &fctdsffctdorifctdsafctdtranfcdsetaratsettadjsgsafsgsacsgtrnfsgtrnc &tssactstrncfltsaffltsacflttrnfflttrncseatdoriseatdsaseatdtrseatssm &seatcycseatlttseatsseseataseseattseseatcseseatsaotlseatirrotl') gmeta.var0000664006604000003110000000512414521201510011771 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c graphics meta files. See gmeta.prm for data dictionaries. c----------------------------------------------------------------------- DATA gmtptr / & 1, 1, 4, 4, 4, 4, 9, 12, 15, 19, & 19, 25, 25, 30, 36, 42, 46, 52, 57, 64, & 64, 64, 64, 64, 67, 69, 71, 73, 75, 78, & 82, 88, 94, 101, 101, 101, 106, 106, 112, 112, & 112, 112, 112, 112, 112, 112, 112, 112, 112, 112, & 112, 112, 112, 112, 112, 112, 112, 112, 112, 112, & 112, 112, 112, 118, 118, 118, 118, 118, 118, 118, & 124, 124, 124, 124, 124, 124, 130, 133, 133, 137, & 137, 141, 141, 141, 141, 141, 141, 141, 144, 144, & 147, 150, 153, 157, 162, 166, 170, 176, 182, 189, & 196, 203, 210, 217, 225, 232, 239, 248, 257, 267, & 277, 287, 297, 297, 297, 297, 297, 297, 297, 297, & 297, 301, 301, 301, 301, 301, 304, 304, 308, 308, & 308, 308, 308, 308, 308, 308, 308, 308, 308, 308, & 308, 308, 308, 308, 308, 308, 308, 308, 310, 314, & 314, 314, 314, 314, 317, 317, 317, 319, 319, 319, & 322, 328, 328, 328, 330, 333, 333, 336, 336, 336, & 336, 336, 336, 339, 339, 339, 339, 344, 344, 348, & 354, 358, 361, 361, 361, 364, 368, 372, 372, 372, & 372, 372, 372, 372, 372, 372, 372, 372, 372, 372, & 372, 372, 372, 372, 372, 372, 372, 372, 372, 375, & 378, 378, 378, 378, 378, 378, 378, 382, 385, 385, & 385, 385, 385, 385, 388, 388, 391, 391, 395, 395, & 399, 399, 403, 403, 403, 403, 403, 403, 403, 403, & 403, 403, 403, 403, 403, 407, 407, 407, 413, 413, & 413, 420, 420, 420, 426, 426, 426, 432, 432, 432, & 437, 443, 449, 455, 455, 455, 462, 467, 467, 467, & 467, 467, 467, 467, 467, 467, 467, 467, 467, 467, & 471, 478, 482, 489, 493, 500, 504, 511, 515, 521, & 528, 535, 535, 541, 547, 547, 547, 552, 558, 563, & 563, 563, 568, 574, 580, 580, 587, 593, 600, 600, & 600, 600, 600, 600, 600, 600, 600, 600, 600, 600, & 600, 600, 607, 614, 614, 614, 614, 614, 614, 614, & 614, 620, 626, 626, 626, 626, 626, 626, 626, 626, & 626, 631, 636, 642, 648, 648, 648, 648, 655, 662, & 668, 674, 674, 681, 681, 687, 693, 700, 700, 706, & 706, 713, 719, 726, 732, 739, 746, 753, 753, 753, & 753, 753, 753, 753, 758, 763, 769, 775, 780, 786, & 792, 798, 805, 812, 820, 827, 834, 841, 848, 855, & 862, 869, 876, 883, 892, 902 / gnfcrv.f0000664006604000003110000000340314521201511011615 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 11:17 am **==prfcrv.f processed by SPAG 4.03F at 16:46 on 14 Nov 1994 SUBROUTINE gnfcrv(Fcter,Fctss,Orig) C----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Generate revisions history of forecast errors for all lags c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revsrs.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION Orig,Fcter,Fctss INTEGER i,j,k DIMENSION Fcter(PFCLAG,PREV),Fctss(PFCLAG,PREV),Orig(PLEN) c----------------------------------------------------------------------- CALL setdp(0D0,PFCLAG*PREV,Fcter) CALL setdp(0D0,PFCLAG*PREV,Fctss) c----------------------------------------------------------------------- c Start loop to print/save forecast error information. c----------------------------------------------------------------------- j=0 DO i=Begrev+Rfctlg(1),Endrev Revptr=i-Begrev+1 j=j+1 c----------------------------------------------------------------------- c Calculate forcast errors, accumulated sum of squares. c----------------------------------------------------------------------- DO k=1,Nfctlg IF(Nfctlg.eq.1.or.(Nfctlg.gt.1.and.Rfctlg(k).le.j))THEN Fcter(k,j)=Orig(i)-Cncfct(k,Revptr) Fctss(k,j)=fctss(k,j)+(fcter(k,j)*fcter(k,j)) END IF END DO END DO c----------------------------------------------------------------------- RETURN END goodob.cmn0000664006604000003110000000072214521201511012132 0ustar sun00315stepsc ------------------------------------------------------------------ c Common block contains a variable that indicates whether an c individual observation is "good" for multiplicative seasonal c adjustment (ie, > 0) c ------------------------------------------------------------------ LOGICAL Gudval DIMENSION Gudval(PLEN) c ------------------------------------------------------------------ COMMON /goodob/ Gudval grzlst.f0000664006604000003110000000332614521201511011661 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:01 pm **==grzlst.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 SUBROUTINE grzlst(Ibeg,Iend,Lyr,A,B,Nmon,Nyc,Ifac) IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION BIG PARAMETER(BIG=10D16) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'chrt.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION A,B INTEGER i,Ibeg,Iend,Ifac,k,l,Lyr,Nmon,Nyc DIMENSION A(*),B(*) c----------------------------------------------------------------------- Ienda=Iend Ymin=BIG Ymax=0D0-BIG Ibeg2=Iend-Nmon+1 IF(Ibeg2.lt.Ibeg.or.Nmon.eq.0)Ibeg2=Ibeg l=0 Ifrst=mod(Ibeg2-1,Nyc)+1 Last=mod(Iend-1,Nyc)+1 c----------------------------------------------------------------------- DO k=Ibeg2,Iend Npts=Npts+1 l=l+1 Y1(l)=A(k) Y2(l)=B(k) IF(Ifac.eq.1)Y1(l)=A(k)*100.0D0 IF(Ifac.eq.1)Y2(l)=B(k)*100.0D0 Ymin=dmin1(Ymin,Y1(l),Y2(l)) Ymax=dmax1(Ymax,Y1(l),Y2(l)) END DO c----------------------------------------------------------------------- Llyr=Lyr+(Ibeg2-1)/Nyc Lastyr=Lyr+(Iend+Nyc-1)/Nyc-1 Nyr=Lastyr-Llyr+1 N1=Iend-Ibeg2+1 c----------------------------------------------------------------------- DO i=1,61 IF(Lyr.eq.0)THEN Xdata3(i)=0.D0 ELSE Xdata3(i)=dble(float(Llyr+i-1)) END IF END DO c----------------------------------------------------------------------- RETURN END grzmth.f0000664006604000003110000000306214521201512011645 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 3:29 pm **==grzmth.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 SUBROUTINE grzmth(Ibeg,Iend) IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION BIG PARAMETER(BIG=10D16) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'chrt.cmn' c----------------------------------------------------------------------- INTEGER i,Ibeg,Iend,iyr,j,imonth,nfreq c----------------------------------------------------------------------- c DOUBLE PRECISION Ser2 c DIMENSION Ser2(61,12) c COMMON /grzmon/ Ser1,Ser2 c----------------------------------------------------------------------- C---- INITIALIZE THE ARRAYS c----------------------------------------------------------------------- DO i=1,61 DO j=1,12 Ser1(i,j)=BIG c Ser2(i,j)=BIG END DO END DO c----------------------------------------------------------------------- C---PUT THE PROPER DATA VALUES TO BE PLOTTED INTO THE ARRAYS c----------------------------------------------------------------------- nfreq=12 IF(Nseas.eq.4)nfreq=4 c i = 0 i=(Ibeg/nfreq)*nfreq j=0 DO iyr=1,61 DO imonth=1,nfreq i=i+1 IF(i.ge.Ibeg)THEN IF(i.gt.Iend)GO TO 10 j=j+1 Ser1(iyr,imonth)=Y1(j) c Ser2(iyr,imonth)=Y2(j) END IF END DO END DO 10 RETURN END grzmyr.f0000664006604000003110000000210514521201512011661 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 3:34 pm **==grzmyr.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 SUBROUTINE grzmyr(L) IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION BIG PARAMETER(BIG=10D16) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'chrt.cmn' c----------------------------------------------------------------------- INTEGER i,iyr,L c DOUBLE PRECISION Ab2(61),Ser2(61,12) c----------------------------------------------------------------------- c COMMON /grzg2 / Ab1,Ab2 c COMMON /grzmon/ Ser1,Ser2 c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- i=0 DO iyr=1,61 IF(.not.dpeq(Ser1(iyr,L),BIG))THEN i=i+1 Ab1(i)=Ser1(iyr,L) c Ab2(i)=Ser2(iyr,L) END IF END DO RETURN END gtarg.f0000664006604000003110000000640514521201512011442 0ustar sun00315steps**==gtarg.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 LOGICAL FUNCTION gtarg(Args,Argptr,Nargs,Argidx,Arglog,Inptok) c----------------------------------------------------------------------- c Gets a valid argument and the ='s from the input stream and c positions the stream at the next argument, after the }. If the c argument is invalid (ie not in the dictionary) then the error is c reported and an attempt is made to return the next argument. This c is done for checking purposes. c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER argnm*(LINLEN),Args*(*),colnum*(5),linnum*(5) LOGICAL argok,Inptok INTEGER argpos,Argptr,nargcr,Nargs,Argidx,Arglog,icol,ilin DIMENSION argpos(2),Argptr(0:Nargs),Arglog(2,Nargs) c ------------------------------------------------------------------ gtarg=T DO WHILE (T) CALL cpyint(Lstpos,2,1,argpos) nargcr=Nxtkln argnm=Nxttok(1:nargcr) CALL gtdcnm(Args,Argptr,Nargs,Argidx,argok) IF(Nxtktp.eq.EOF)THEN gtarg=F ELSE IF(Nxtktp.eq.RBRACE)THEN CALL lex() gtarg=F c ------------------------------------------------------------------ ELSE IF(.not.argok)THEN CALL inpter(PERROR,argpos, & 'Expected argument name or "}" but found "'// & argnm(1:nargcr)//'"') Inptok=F CALL lex() gtarg=F c ------------------------------------------------------------------ ELSE IF(Argidx.eq.0)THEN CALL inpter(PERROR,argpos,'Argument name "'//argnm(1:nargcr)// & '" not found') Inptok=F CALL lex() CALL skparg() IF(Lfatal)RETURN GO TO 10 c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.EQUALS)THEN CALL inpter(PERROR,Lstpos,' Expected "=" but found "'// & Nxttok(1:Nxtkln)//'"') Inptok=F CALL skparg() IF(Lfatal)RETURN GO TO 10 c ------------------------------------------------------------------ ELSE IF(Arglog(PLINE,Argidx).ne.NOTSET)THEN ilin=1 CALL itoc(Arglog(PLINE,Argidx),linnum,ilin) icol=1 CALL itoc(Arglog(PCHAR,Argidx),colnum,icol) CALL inpter(PERROR,argpos,'Argument name "'//argnm(1:nargcr)// & '" also found on line '//linnum(1:(ilin-1))// & ' position '//colnum(1:(icol-1))// & ' of the input file.') Inptok=F CALL lex() CALL skparg() IF(Lfatal)RETURN GO TO 10 ELSE Arglog(PLINE,Argidx)=argpos(PLINE) Arglog(PCHAR,Argidx)=argpos(PCHAR) CALL lex() END IF END IF c ------------------------------------------------------------------ RETURN 10 CONTINUE END DO END gtarma.f0000664006604000003110000000772114521201512011613 0ustar sun00315stepsC Last change: Nov 2, 2023 Add error message If there is an arima C spec with no model argument C previous change: BCM 4 Sep 1998 1:47 pm SUBROUTINE gtarma(Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Specify the regression and time series parts of the model c----------------------------------------------------------------------- INCLUDE 'lex.i' c INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ LOGICAL argok,Inptok,havmdl INTEGER itmpvc,nelt DIMENSION itmpvc(0:1) c----------------------------------------------------------------------- LOGICAL gtarg EXTERNAL gtarg c----------------------------------------------------------------------- c This dictionary was created with c ../../dictionary/strary < ../../dictionary/arima.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*18 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=5) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='titlemodeldiffarma') c----------------------------------------------------------------------- DATA argptr/1,6,11,15,17,19/ c----------------------------------------------------------------------- CALL setint(NOTSET,2*PARG,arglog) havmdl = F 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,30,30),argidx c----------------------------------------------------------------------- c Title argument c----------------------------------------------------------------------- 10 CALL getttl(LPAREN,T,1,Mdlttl,itmpvc,nelt,argok,Inptok) IF(.not.Lfatal.and.argok.and.nelt.gt.0) & CALL eltlen(nelt,itmpvc,nelt,Nmdlcr) IF(Lfatal)RETURN GO TO 40 c----------------------------------------------------------------------- c Get the orders and lags of the ARIMA model c----------------------------------------------------------------------- 20 CALL getmdl(argok,Inptok,F) havmdl = T IF(Lfatal)RETURN GO TO 40 c----------------------------------------------------------------------- c ARIMA initial and/or fixed values. Argidx-2, 2 is c the displacement or number of arguments before diff in the c argument dictionary. c----------------------------------------------------------------------- 30 CALL gtinvl(argidx-2,Inptok) IF(Lfatal)RETURN IF(argidx.eq.3)Lprtdf=T GO TO 40 END IF IF(Lfatal)RETURN c---------------------------------------------------------------------- c Check if arima models are specified. c---------------------------------------------------------------------- IF (.not.havmdl) then call inpter(PERROR,Errpos,'An ARIMA spec was found with no '// & 'specified model. If an ARIMA model of (0 0 0) was intended,'// & 'please specify it using the model argument.') Inptok = F END IF c---------------------------------------------------------------------- c Check if the Regression and arima models are fixed (sets imdlfx). c---------------------------------------------------------------------- CALL mdlfix() c ------------------------------------------------------------------ RETURN 40 CONTINUE END DO c ------------------------------------------------------------------ END gtauto.f0000664006604000003110000005410114521201512011635 0ustar sun00315stepsC Last change: SRD 2 Feb 2006 1:33 pm SUBROUTINE gtauto(Lautom,Lautod,Ub1lim,Ub2lim,Cancel,Maxord, & Diffam,Exdiff,Lbalmd,Hrinit,Tsig,Pcr, & Fct,Predcv,Laccdf,Lotmod,Ubfin,Frstar,Lchkmu, & Lmixmd,Lrejfc,Fctlm2,Lsovdf,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Specify settings for the automatic modelling procedure c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'svllog.i' INCLUDE 'notset.prm' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'mdltbl.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ONEHUN,ZERO LOGICAL T,F PARAMETER(T=.true.,F=.false.,ONE=1D0,ONEHUN=100D0,ZERO=0D0) c----------------------------------------------------------------------- LOGICAL argok,Inptok,Lautom,Lautod,Lbalmd,Hrinit,Lrejfc, & Laccdf,Lotmod,hvdiff,Lchkmu,Lmixmd,Lsovdf DOUBLE PRECISION Predcv,Ub1lim,Ub2lim,Ubfin,Cancel,dvec,Tsig,Fct, & Pcr,Fctlm2 INTEGER nelt,ivec,omax,Maxord,adif,Diffam,Frstar,i,Exdiff DIMENSION dvec(1),ivec(1),omax(2),Maxord(2),adif(2),Diffam(2) c----------------------------------------------------------------------- LOGICAL gtarg,istrue EXTERNAL gtarg,istrue c----------------------------------------------------------------------- CHARACTER ARGDIC*194 INTEGER argidx,argptr,PARG,arglog PARAMETER(PARG=24) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='maxdiffub1ub2cancelmaxorderdiffprintsavelogbalan &cedexactdiffhrinitialarmalimitpercentrsereducecvljungboxlimitaccep &tdefaultnoautooutlierurfinalfirstarcheckmumixedrejectfcstfcstlimse &asonaloverdiff') c----------------------------------------------------------------------- CHARACTER NOTDIC*9 INTEGER notptr,PNOT PARAMETER(PNOT=2) DIMENSION notptr(0:PNOT) PARAMETER(NOTDIC='sametramo') c----------------------------------------------------------------------- c data dictionary of yes/no choice c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- c data dictionary of exactdiff c----------------------------------------------------------------------- CHARACTER EXDDIC*10 INTEGER exdptr,PEXD PARAMETER(PEXD=3) DIMENSION exdptr(0:PEXD) PARAMETER(EXDDIC='noyesfirst') c----------------------------------------------------------------------- DATA argptr/1,8,11,14,20,28,32,37,44,52,61,70,79,89,97,110,123, & 136,143,150,157,162,172,179,195/ DATA notptr/1,5,10/ DATA ysnptr/1,4,6/ DATA exdptr/1,3,6,11/ c----------------------------------------------------------------------- c Set automatic ARIMA modelling option c----------------------------------------------------------------------- CALL setint(NOTSET,2*PARG,arglog) CALL setint(NOTSET,2,omax) CALL setint(NOTSET,2,adif) hvdiff=F 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,60,70,80,90,100,110,120,130,140,150,160,170, & 180,190,50,200,210,220,230,235),argidx c----------------------------------------------------------------------- c Specify if only automatic modelling will be done. c ------------------------------------------------------------------ 10 CALL getivc(LPAREN,T,2,adif,nelt,argok,Inptok) IF(Lfatal)RETURN IF(hvdiff)THEN IF(.not.Lquiet)WRITE(STDERR,1010) WRITE(Mt2,1010) 1010 FORMAT(' NOTE: Arguments diff and maxdiff are both specified;', & /,' only maxdiff will be used.') END IF IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos,'Two values are needed.') Inptok=F ELSE IF(nelt.gt.0)THEN IF(adif(1).gt.2)THEN CALL inpter(PERROR,Errpos,'Maximum order of regular differenci &ng must be less than or equal to 2.') Inptok=F END IF c----------------------------------------------------------------------- IF(adif(2).GT.1)THEN CALL inpter(PERROR,Errpos,'Maximum order of seasonal differenc &ing must be less than or equal to 1.') Inptok=F END IF c----------------------------------------------------------------------- IF(adif(1).lt.0.or.adif(2).lt.0)THEN CALL inpter(PERROR,Errpos,'Maximum order of differencing speci &fied must be greater than zero.') Inptok=F END IF c----------------------------------------------------------------------- IF(Inptok)THEN CALL cpyint(adif,2,1,Diffam) hvdiff=T Lautod=T END IF END IF GO TO 240 c ------------------------------------------------------------------ c Ub1lim argument c ------------------------------------------------------------------ 20 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Ub1lim c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ONE)THEN CALL inpter(PERROR,Errpos,'Initial unit root limit must be gre &ater than one.') Inptok=F ELSE Ub1lim=dvec(1) END IF END IF GO TO 240 c ------------------------------------------------------------------ c Ub2lim argument c ------------------------------------------------------------------ 30 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Ub2lim c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos,'Final unit root limit must be great &er than zero.') Inptok=F ELSE IF(dvec(1).ge.ONE)THEN CALL inpter(PERROR,Errpos,'Final unit root limit must be less &than one.') Inptok=F ELSE Ub2lim=dvec(1) END IF END IF GO TO 240 c ------------------------------------------------------------------ c Cancel argument c ------------------------------------------------------------------ 40 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Cancel c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Cancelation limit must be greater than zero.') Inptok=F ELSE Cancel=dvec(1) END IF END IF GO TO 240 c----------------------------------------------------------------------- c firstar argument c----------------------------------------------------------------------- 50 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(.not.(ivec(1).eq.2.or.ivec(1).eq.3.or.ivec(1).eq.4))THEN CALL inpter(PERROR,Errpos, & 'Value of firstar must be 2, 3 or 4.') Inptok=F ELSE Frstar=ivec(1) END IF END IF GO TO 240 c----------------------------------------------------------------------- c maxorder argument c----------------------------------------------------------------------- 60 CALL getivc(LPAREN,F,2,omax,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos, & 'Two values are needed (or use a comma as place holder).') Inptok=F ELSE IF(nelt.gt.0)THEN IF(omax(1).eq.NOTSET)omax(1)=2 IF(omax(2).eq.NOTSET)omax(2)=1 * IF(omax(1).le.0.or.omax(2).le.0)THEN IF(omax(1).lt.0.or.omax(2).lt.0)THEN CALL inpter(PERROR,Errpos,'AR and MA orders must be greater th &an or equal to zero.') * &an zero.') Inptok=F c----------------------------------------------------------------------- ELSE IF(omax(1).gt.4)THEN CALL inpter(PERROR,Errpos, & 'Regular orders must be less than or equal to 4.') Inptok=F END IF c----------------------------------------------------------------------- IF(omax(2).gt.2)THEN CALL inpter(PERROR,Errpos, & 'Seasonal orders must be less than or equal to 2.') Inptok=F END IF c----------------------------------------------------------------------- IF(Inptok)CALL cpyint(omax,2,1,Maxord) END IF END IF GO TO 240 c----------------------------------------------------------------------- c diff argument c----------------------------------------------------------------------- 70 CALL getivc(LPAREN,T,2,adif,nelt,argok,Inptok) IF(Lfatal)RETURN IF(hvdiff)THEN IF(.not.Lquiet)WRITE(STDERR,1010) WRITE(Mt2,1010) GO TO 240 END IF IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos,'Two values are needed.') Inptok=F ELSE IF(nelt.gt.0)THEN IF(adif(1).gt.2)THEN CALL inpter(PERROR,Errpos,'Order of regular differencing must &be less than or equal to 2.') Inptok=F END IF c----------------------------------------------------------------------- IF(adif(2).GT.1)THEN CALL inpter(PERROR,Errpos,'Order of seasonal differencing must & be less than or equal to 1.') Inptok=F END IF c----------------------------------------------------------------------- IF(adif(1).lt.0.or.adif(2).lt.0)THEN CALL inpter(PERROR,Errpos,'Order of differencing specified mus &t be greater than zero.') Inptok=F END IF c----------------------------------------------------------------------- IF(Inptok)THEN CALL cpyint(adif,2,1,Diffam) hvdiff=T END IF END IF GO TO 240 c ------------------------------------------------------------------ c Print argument c----------------------------------------------------------------------- 80 CALL getprt(LSPAUM,NSPAUM,Inptok) GO TO 240 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 90 CALL getsvl(LSLAUM,NSLAUM,Inptok) GO TO 240 c----------------------------------------------------------------------- c balanced argument c----------------------------------------------------------------------- 100 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for balanced are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lbalmd=ivec(1).eq.1 GO TO 240 c----------------------------------------------------------------------- c exactdiff argument c----------------------------------------------------------------------- 110 CALL gtdcvc(LPAREN,T,1,EXDDIC,exdptr,PEXD, & 'Available options for exactdiff are yes, first or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Exdiff=ivec(1)-1 GO TO 240 c----------------------------------------------------------------------- c hrinitial argument c----------------------------------------------------------------------- 120 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for hrinitial are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Hrinit=ivec(1).eq.1 GO TO 240 c ------------------------------------------------------------------ c armalimit argument c ------------------------------------------------------------------ 130 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Tsig c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos,'Final limit for ARMA t-value must b &e greater than zero.') Inptok=F ELSE Tsig=dvec(1) END IF END IF GO TO 240 c ------------------------------------------------------------------ c percentrse argument c ------------------------------------------------------------------ 140 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for percentrse c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Percentrse must be greater than zero.') Inptok=F ELSE Fct=dvec(1) END IF END IF GO TO 240 c ------------------------------------------------------------------ c reducecv argument c ------------------------------------------------------------------ 150 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for reducecv c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos,'Percent reduction in critical value & must be greater than zero.') Inptok=F ELSE IF(dvec(1).ge.ONE)THEN CALL inpter(PERROR,Errpos,'Percent reduction in critical value & cannot be greater than 1.') Inptok=F ELSE Predcv=dvec(1) END IF END IF GO TO 240 c ------------------------------------------------------------------ c ljungboxlimit argument c ------------------------------------------------------------------ 160 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for ljungboxlimit c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Ljung-Box Q probability limit cannot be less than zero.') Inptok=F ELSE IF(dvec(1).ge.ONE)THEN CALL inpter(PERROR,Errpos,'Ljung-Box Q probability limit must &be less than one.') Inptok=F ELSE Pcr=dvec(1) END IF END IF GO TO 240 c----------------------------------------------------------------------- c acceptdefault argument c----------------------------------------------------------------------- 170 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for acceptdefault are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Laccdf=ivec(1).eq.1 GO TO 240 c----------------------------------------------------------------------- c noautooutlier argument c----------------------------------------------------------------------- 180 CALL gtdcvc(LPAREN,T,1,NOTDIC,notptr,PNOT, & 'Available options for noautooutlier are same or tramo.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lotmod=ivec(1).eq.1 GO TO 240 c----------------------------------------------------------------------- c Ub1lim argument c ------------------------------------------------------------------ 190 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Ub1lim c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ONE)THEN CALL inpter(PERROR,Errpos, & 'Unit root limit for final model must be greater than one.') Inptok=F ELSE Ubfin=dvec(1) END IF END IF GO TO 240 c----------------------------------------------------------------------- c checkmu argument (may be added later) c----------------------------------------------------------------------- 200 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for checkmu are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lchkmu=ivec(1).eq.1 GO TO 240 c----------------------------------------------------------------------- c mixed argument c----------------------------------------------------------------------- 210 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for mixed are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lmixmd=ivec(1).eq.1 GO TO 240 c----------------------------------------------------------------------- c rejectfcst argument c----------------------------------------------------------------------- 220 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for rejectfcst are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lrejfc=ivec(1).eq.1 GO TO 240 c ------------------------------------------------------------------ c Fcstlim argument c ------------------------------------------------------------------ 230 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Fcstlim c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Forecast error limit cannot be less than zero.') Inptok=F ELSE IF(dvec(1).gt.ONEHUN)THEN CALL inpter(PERROR,Errpos, & 'Forecast error limit cannot be greater than 100.') Inptok=F ELSE Fctlm2=dvec(1) END IF END IF GO TO 240 c----------------------------------------------------------------------- c seasonaloverdiff argument c----------------------------------------------------------------------- 235 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for seasonaloverdiff are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lsovdf=ivec(1).eq.1 GO TO 240 c----------------------------------------------------------------------- END IF IF(Lfatal)RETURN c ------------------------------------------------------------------ c IF automatic model selection not selected, set to both, unless c orders of differencing are specified. c ------------------------------------------------------------------ IF((.not.Lautom))Lautom=T IF((.not.Lautod).and.(.not.hvdiff))Lautod=T IF(omax(1).eq.NOTSET)THEN Maxord(1)=2 Maxord(2)=1 END IF IF(adif(1).eq.NOTSET)THEN Diffam(1)=2 Diffam(2)=1 c ------------------------------------------------------------------ c Remove check to see if maxdiff = 0 (BCM 10-14-2008) c ------------------------------------------------------------------ * ELSE IF(Lautod)THEN * IF(Diffam(1).eq.0.or.Diffam(2).eq.0)THEN * CALL writln('ERROR: Maximum order for automatic difference sele * &ction procedure cannot',STDERR,Mt2,T) * CALL writln(' be set to zero.',STDERR,Mt2,F) * Inptok=F * END IF END IF c ------------------------------------------------------------------ c Ensure that automatic outlier identification output is turned off c during automatic model selection (can remove later when debugging) c BCM 02-02-2006 c ------------------------------------------------------------------ IF(istrue(Prttab,LAUOTH,LAUOFT))THEN DO i=LAUOTH,LAUOFT IF(Prttab(i))Prttab(i)=F END DO END IF IF(istrue(Savtab,LAUOTH,LAUOFT))THEN DO i=LAUOTH,LAUOFT IF(Savtab(i))Savtab(i)=F END DO END IF c ------------------------------------------------------------------ RETURN 240 CONTINUE END DO c ------------------------------------------------------------------ END gtautx.f0000664006604000003110000002366014521201512011654 0ustar sun00315stepsC Last change: BCM 28 Jul 1998 8:28 am SUBROUTINE gtautx(Iautom,Autofl,Fctlim,Bcklim,Qlim,Ovrdif,Pck1st, & Id1st,Outamd,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Specify settings for X-11-ARIMA's automatic modelling procedure c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'svllog.i' INCLUDE 'notset.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ONEHUN,ZERO LOGICAL T,F PARAMETER(T=.true.,F=.false.,ONE=1D0,ONEHUN=100D0,ZERO=0D0) c----------------------------------------------------------------------- LOGICAL havfil,argok,Inptok,Pck1st,Id1st DOUBLE PRECISION Fctlim,Bcklim,Qlim,Ovrdif,dvec CHARACTER Autofl*(PFILMD) INTEGER Iautom,nelt,itmpvc,ivec,Outamd DIMENSION itmpvc(0:1),dvec(1),ivec(1) c----------------------------------------------------------------------- LOGICAL gtarg EXTERNAL gtarg c----------------------------------------------------------------------- CHARACTER ARGDIC*71 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=11) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='modefileqlimfcstlimbcstlimoverdiffprintmethodout &ofsampleidentifysavelog') c----------------------------------------------------------------------- CHARACTER AUTDIC*8 INTEGER autptr,PAUT PARAMETER(PAUT=2) DIMENSION autptr(0:PAUT) PARAMETER(AUTDIC='bothfcst') c----------------------------------------------------------------------- CHARACTER MTHDIC*9 INTEGER mthptr,PMTH PARAMETER(PMTH=2) DIMENSION mthptr(0:PMTH) PARAMETER(MTHDIC='bestfirst') c----------------------------------------------------------------------- CHARACTER IDDIC*8 INTEGER idptr,PID PARAMETER(PID=2) DIMENSION idptr(0:PID) PARAMETER(IDDIC='firstall') c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- DATA argptr/1,5,9,13,20,27,35,40,46,57,65,72/ DATA mthptr/1,5,10/ DATA autptr/1,5,9/ DATA idptr/1,6,9/ DATA ysnptr/1,4,6/ c----------------------------------------------------------------------- c Set automatic ARIMA modelling option c----------------------------------------------------------------------- havfil=F CALL setint(NOTSET,2*PARG,arglog) 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),argidx c----------------------------------------------------------------------- c set mode for automatic model identification procedure c ------------------------------------------------------------------ 10 CALL gtdcvc(LPAREN,T,1,AUTDIC,autptr,PAUT, & 'The automatic modelling options are fcst or both.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN Iautom=2 IF(ivec(1).gt.1)Iautom=1 END IF GO TO 120 c ------------------------------------------------------------------ 20 CALL gtnmvc(LPAREN,T,1,Autofl,itmpvc,nelt,PFILMD,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)havfil=T GO TO 120 c ------------------------------------------------------------------ c Qlim argument c ------------------------------------------------------------------ 30 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Qlim c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Ljung-Box Q limit cannot be less than zero.') Inptok=F ELSE IF(dvec(1).gt.ONEHUN)THEN CALL inpter(PERROR,Errpos, & 'Ljung-Box Q limit cannot be greater than 100.') Inptok=F ELSE Qlim=dvec(1) END IF END IF GO TO 120 c ------------------------------------------------------------------ c Fcstlim argument c ------------------------------------------------------------------ 40 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Fcstlim c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Forecast error limit cannot be less than zero.') Inptok=F ELSE IF(dvec(1).gt.ONEHUN)THEN CALL inpter(PERROR,Errpos, & 'Forecast error limit cannot be greater than 100.') Inptok=F ELSE Fctlim=dvec(1) END IF END IF GO TO 120 c ------------------------------------------------------------------ c Bcstlim argument c ------------------------------------------------------------------ 50 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Bcstlim c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Backcast error limit cannot be less than zero.') Inptok=F ELSE IF(dvec(1).gt.ONEHUN)THEN CALL inpter(PERROR,Errpos, & 'Backcast error limit cannot be greater than 100.') Inptok=F ELSE Bcklim=dvec(1) END IF END IF GO TO 120 c ------------------------------------------------------------------ c Overdiff argument c ------------------------------------------------------------------ 60 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for Overdiff c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Overdifferencing limit cannot be less than zero.') Inptok=F ELSE IF(dvec(1).gt.ONE)THEN CALL inpter(PERROR,Errpos, & 'Overdifferencing limit cannot be greater than one.') Inptok=F ELSE Ovrdif=dvec(1) END IF END IF GO TO 120 c ------------------------------------------------------------------ c Print argument c----------------------------------------------------------------------- 70 CALL getprt(LSPAXM,NSPAXM,Inptok) GO TO 120 c----------------------------------------------------------------------- c method argument c----------------------------------------------------------------------- 80 CALL gtdcvc(LPAREN,T,1,MTHDIC,mthptr,PMTH, & 'Choices are BEST or FIRST.',ivec,nelt,argok, & Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Pck1st=ivec(1).eq.2 GO TO 120 c----------------------------------------------------------------------- c outofsample argument c----------------------------------------------------------------------- 90 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for outofsample are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Outamd=ivec(1) GO TO 120 c----------------------------------------------------------------------- c identify argument c----------------------------------------------------------------------- 100 CALL gtdcvc(LPAREN,T,1,IDDIC,idptr,PID, & 'Choices are ALL or FIRST.',ivec,nelt,argok, & Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Id1st=ivec(1).eq.1 GO TO 120 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 110 CALL getsvl(LSLAXM,NSLAXM,Inptok) GO TO 120 c----------------------------------------------------------------------- END IF IF(Lfatal)RETURN c ------------------------------------------------------------------ c If no filename selected for automatic model selection set to c x12a.mdl c ------------------------------------------------------------------ IF(.not.havfil)Autofl(1:1)=CNOTST c ------------------------------------------------------------------ c IF automatic model not selected, set to forecast only. c ------------------------------------------------------------------ IF(Iautom.eq.0)Iautom=1 c ------------------------------------------------------------------ RETURN 120 CONTINUE END DO c ------------------------------------------------------------------ END gtdcnm.f0000664006604000003110000000246714521201512011616 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 1:52 pm **==gtdcnm.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 SUBROUTINE gtdcnm(Args,Argptr,Nargs,Argidx,Argok) IMPLICIT NONE c----------------------------------------------------------------------- c Returns the dictionary index if the name is found, 0 if the name c is not found, and argOK is false if the token is not a name and the c index, argidx, is 0. If the name is not in the dictionary the c next token isn't input. c----------------------------------------------------------------------- INCLUDE 'lex.i' c ------------------------------------------------------------------ CHARACTER Args*(*) INTEGER Argptr,Nargs,Argidx,strinx LOGICAL Argok DIMENSION Argptr(0:Nargs) EXTERNAL lex,strinx c ------------------------------------------------------------------ Argidx=0 Argok=.true. IF(Nxtktp.ne.EOF)THEN IF(Nxtktp.ne.NAME)THEN Argok=.false. c ------------------------------------------------------------------ ELSE Argidx=strinx(.false.,Args,Argptr,1,Nargs,Nxttok(1:Nxtkln)) IF(Argidx.gt.0)CALL lex() END IF END IF c ------------------------------------------------------------------ RETURN END gtdcvc.f0000664006604000003110000001662114521201512011611 0ustar sun00315stepsC Last change: BCM 1 Feb 98 1:11 pm SUBROUTINE gtdcvc(Grpchr,Flgnul,Pelt,Args,Argptr,Nargs,Errmsg, & Idxvec,Nelt,Locok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gtdcvc.f, Release 1, Subroutine Version 1.3, Modified 1/3/95. c----------------------------------------------------------------------- c Given a dictionary of choices (Args, Argptr, and Nargs) it returns c an integer index vector. Entries not found in the dictionary would c result in a element of 0. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER Args*(*),Errmsg*(*),str*(LINLEN) LOGICAL argok,Flgnul,hvcmma,Inptok,Locok,opngrp INTEGER Argptr,argidx,clsgtp,Grpchr,Idxvec,ipos,Nargs,Nelt,Pelt DIMENSION Argptr(0:Nargs),Idxvec(Pelt) c----------------------------------------------------------------------- INTEGER clsgrp EXTERNAL clsgrp c ------------------------------------------------------------------ Locok=T Nelt=0 hvcmma=F c ------------------------------------------------------------------ IF(Nxtktp.eq.EOF)THEN Locok=F c----------------------------------------------------------------------- c Get just one name or quote c----------------------------------------------------------------------- ELSE IF(Nxtktp.eq.NAME.or.Nxtktp.eq.QUOTE)THEN CALL gtdcnm(Args,Argptr,Nargs,argidx,argok) IF(.not.argok.or.argidx.eq.0)THEN CALL inpter(PERROR,Lstpos,Errmsg) Locok=F ELSE Nelt=1 Idxvec(Nelt)=argidx END IF c ------------------------------------------------------------------ Locok=Locok.and.argok c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.Grpchr)THEN CALL inpter(PERROR,Lstpos, & 'Expected a name or a quote or a list of names or quotes, not "' & //Nxttok(1:Nxtkln)//'"') Locok=F opngrp=F CALL lex() c----------------------------------------------------------------------- c Get a list of names or quotes c----------------------------------------------------------------------- ELSE opngrp=T clsgtp=clsgrp(Grpchr) CALL lex() c ------------------------------------------------------------------ DO WHILE (T) IF(Nxtktp.ne.clsgtp)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,td,lom) c or (const,,td,lom). This section is repeated because there may be c multiple NULLs c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(.not.(hvcmma.or.opngrp))THEN CALL lex() ELSE IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') CALL lex() Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE CALL gtdcnm(Args,Argptr,Nargs,argidx,argok) IF(.not.argok.or.argidx.eq.0)THEN CALL inpter(PERROR,Lstpos,Errmsg) CALL lex() Locok=F END IF c ------------------------------------------------------------------ Nelt=Nelt+1 Idxvec(Nelt)=argidx Locok=Locok.and.argok c ------------------------------------------------------------------ END IF c ------------------------------------------------------------------ hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c There is not a close group or comma here so there must be a NAME c or a QUOTE. c----------------------------------------------------------------------- IF(Nxtktp.ne.NAME.and.Nxtktp.ne.QUOTE)THEN CALL inpter(PERROR,Lstpos,'Expected a NAME or QUOTE not "'// & Nxttok(1:Nxtkln)//'"') Locok=F ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE CALL gtdcnm(Args,Argptr,Nargs,argidx,argok) IF(.not.argok.or.argidx.eq.0)THEN CALL inpter(PERROR,Lstpos,Errmsg) CALL lex() Locok=F END IF c ------------------------------------------------------------------ Nelt=Nelt+1 Idxvec(Nelt)=argidx Locok=Locok.and.argok hvcmma=F opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a NULL after the last element but before the close of c the list. This indicates a NULL value, for example, (td,lom,). c These default values may exceed the length of the list. c----------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE CALL gtdcnm(Args,Argptr,Nargs,argidx,argok) IF(.not.argok.or.argidx.eq.0)THEN CALL inpter(PERROR,Lstpos,Errmsg) CALL lex() Locok=F END IF c ------------------------------------------------------------------ Nelt=Nelt+1 Idxvec(Nelt)=argidx Locok=Locok.and.argok END IF END IF c ------------------------------------------------------------------ IF(Locok)THEN CALL lex() ELSE CALL skplst(clsgtp) END IF GO TO 20 10 CONTINUE END DO c ------------------------------------------------------------------ END IF 20 Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END gtdpvc.f0000664006604000003110000001357714521201512011635 0ustar sun00315stepsC Last change: BCM 1 Feb 98 2:01 pm **==gtdpvc.f processed by SPAG 4.03F at 09:49 on 1 Mar 1994 SUBROUTINE gtdpvc(Grpchr,Flgnul,Pelt,Avec,Nelt,Locok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gtdpvc.f, Release 1, Subroutine Version 1.6, Modified 1/3/95. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER str*(LINLEN) LOGICAL Flgnul,hvcmma,Inptok,Locok,opngrp INTEGER clsgtp,Grpchr,ipos,Nelt,Pelt DOUBLE PRECISION Avec,tmp DIMENSION Avec(Pelt) c ------------------------------------------------------------------ LOGICAL getdbl INTEGER clsgrp EXTERNAL clsgrp,getdbl c ------------------------------------------------------------------ Locok=T c ------------------------------------------------------------------ IF(Nxtktp.eq.EOF)THEN Locok=F c ------------------------------------------------------------------ ELSE IF(getdbl(Avec(1)))THEN Nelt=1 c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.Grpchr)THEN CALL inpter(PERROR,Lstpos, & 'Expected a real number or a list of real numbers, not "' & //Nxttok(1:Nxtkln)//'"') Locok=F opngrp=F CALL lex() c ------------------------------------------------------------------ ELSE Nelt=0 opngrp=T hvcmma=F clsgtp=clsgrp(Grpchr) c ------------------------------------------------------------------ CALL lex() c----------------------------------------------------------------------- c Process the list of doubles c----------------------------------------------------------------------- DO WHILE (T) IF(Nxtktp.ne.clsgtp)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,10.2, -8.3) c or (6,,10.2,-8.3). This section is repeated because there may be c multiple NULLs c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='Real Vector exceeds ' ipos=21 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE Nelt=Nelt+1 Avec(Nelt)=DNOTST END IF END IF c ------------------------------------------------------------------ CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c There is not a close group or comma here so there must be a real. c----------------------------------------------------------------------- IF(.not.(getdbl(tmp)))THEN CALL inpter(PERROR,Lstpos,'Expected an real number not "'// & Nxttok(1:Nxtkln)//'"') Locok=F ELSE IF(Nelt.ge.Pelt)THEN str='Real vector exceeds ' ipos=21 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE Nelt=Nelt+1 Avec(Nelt)=tmp hvcmma=F opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. This indicates a NULL value, for example, c (6.2,10.2, -8.3,). These default values may exceed the length c of the list. c----------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='Real vector exceeds ' ipos=21 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE Nelt=Nelt+1 Avec(Nelt)=DNOTST END IF END IF c ------------------------------------------------------------------ IF(Locok)THEN CALL lex() c ------------------------------------------------------------------ ELSE CALL skplst(clsgtp) END IF GO TO 20 10 CONTINUE END DO c ------------------------------------------------------------------ END IF 20 Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END gtdtvc.f0000664006604000003110000001331414521201513011627 0ustar sun00315steps SUBROUTINE gtdtvc(Havesp,Sp,Grpchr,Flgnul,Pelt,Datvec,Nelt,Locok, & Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gtdtvc.f, Release 1, Subroutine Version 1.4, Modified 05 Oct 1994. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL F,T PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------ CHARACTER str*(LINLEN) LOGICAL argok,Flgnul,Havesp,hvcmma,Inptok,Locok,opngrp INTEGER clsgtp,clsgrp,Datvec,defval,Grpchr,ipos,Nelt,Pelt,Sp, & tmpdat DIMENSION Datvec(2,Pelt),defval(2),tmpdat(2) EXTERNAL clsgrp DATA defval/NOTSET,NOTSET/ c----------------------------------------------------------------------- Locok=T c ------------------------------------------------------------------ IF(Nxtktp.eq.EOF)THEN Locok=F c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.Grpchr)THEN CALL getdat(Havesp,Sp,Datvec,argok,Locok) IF(argok)THEN Nelt=1 c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.Grpchr)THEN CALL inpter(PERROR,Errpos,'Expected a date or a list of dates') Locok=F END IF c ------------------------------------------------------------------ ELSE Nelt=0 opngrp=T hvcmma=T clsgtp=clsgrp(Grpchr) c ------------------------------------------------------------------ CALL lex() c----------------------------------------------------------------------- c Process the date list c----------------------------------------------------------------------- DO WHILE (T) IF(Nxtktp.ne.clsgtp)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,1992.feb) c or (1967.jan,,1992.mar). This section is repeated because there may c be multiple NULLs c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Errpos, & 'Found a NULL date; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='Date vector exceeds ' ipos=21 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Errpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE Nelt=Nelt+1 CALL cpyint(defval,2,1,Datvec(1,Nelt)) END IF END IF c ------------------------------------------------------------------ CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c There is not a close group or comma here so there must be a date. c----------------------------------------------------------------------- CALL getdat(Havesp,Sp,tmpdat,argok,Locok) IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Expected a date not "'// & Nxttok(1:Nxtkln)//'"') Locok=F ELSE IF(Nelt.ge.Pelt)THEN str='Date vector exceeds ' ipos=21 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Errpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE Nelt=Nelt+1 CALL cpyint(tmpdat,2,1,Datvec(1,Nelt)) hvcmma=F opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. This indicates a NULL value, for example, (1967.jan,). c----------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Errpos, & 'Found a NULL date; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='Date vector exceeds ' ipos=21 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Errpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE Nelt=Nelt+1 CALL cpyint(defval,2,1,Datvec(1,Nelt)) END IF END IF c ------------------------------------------------------------------ IF(Locok)THEN CALL lex() ELSE CALL skplst(clsgtp) END IF GO TO 20 10 CONTINUE END DO c ------------------------------------------------------------------ END IF 20 Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END gtedit.f0000664006604000003110000001002314521201513011606 0ustar sun00315stepsC Last change: BCM 14 May 1998 7:54 am SUBROUTINE gtedit(Plen,File,Y,Start,Chnl,Nobs,Ncol,Freq,Srsnam, & Lcomma,Argok) IMPLICIT NONE c----------------------------------------------------------------------- c Read the Edit data file format c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'x11msc.cmn' c----------------------------------------------------------------------- LOGICAL F INTEGER PCUT2K,YR,MO,DATLEN PARAMETER(F=.false.,YR=1,MO=2,PCUT2K=45,DATLEN=1000) c----------------------------------------------------------------------- CHARACTER File*(*),Srsnam*(*),chrstr*(DATLEN) DOUBLE PRECISION Y LOGICAL Argok,Lcomma INTEGER Freq,i,i1,i2,itmp,itmp1,itmp2,Plen,Start,Chnl,Nobs,Ncol, & nyy,npr,ncomma DIMENSION Y(Plen),Start(2) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- i=1 i1=i+Ncol-1 DO WHILE (i1.le.Plen) c----------------------------------------------------------------------- c Read the month and year as integers, and the observations as c characters c----------------------------------------------------------------------- IF(Lcomma)THEN READ(Chnl,1000,END=20,ERR=10)chrstr 1000 FORMAT(a) c----------------------------------------------------------------------- c For each column, convert the commas to periods, and internally c read the observations into the data vector. c----------------------------------------------------------------------- CALL cvcmma(chrstr,ncomma) READ(chrstr,*,ERR=10)itmp1,itmp2,(Y(i2),i2=i,i1) c----------------------------------------------------------------------- c Else, read the month, year, observation from file c----------------------------------------------------------------------- ELSE READ(Chnl,*,END=20,ERR=10)itmp1,itmp2,(Y(i2),i2=i,i1) END IF IF(itmp1.lt.100)THEN IF(Yr2000.and.(yr.le.PCUT2K))THEN itmp1=itmp1+2000 ELSE itmp1=itmp1+1900 END IF END IF c----------------------------------------------------------------------- c If this is the first observation, set the starting date. c----------------------------------------------------------------------- IF(i.eq.1)THEN Start(YR)=itmp1 Start(MO)=itmp2 itmp=itmp1*Freq+itmp2 ELSE itmp=itmp+1 nyy=itmp/Freq npr=mod(itmp,Freq) IF(npr.eq.0)THEN nyy=nyy-1 npr=Freq END IF IF(.not.((itmp1.eq.nyy).and.(itmp2.eq.npr)))THEN WRITE(STDERR,1120)nyy,npr,Srsnam,itmp1,itmp2 WRITE(Mt2,1120)nyy,npr,Srsnam,itmp1,itmp2 1120 FORMAT(' ERROR: Expected to find observation ',i4,':',i2, & ' of series ',a,/, & ' not ',i4,':',i2,'. Check input file and ', & 'format.',/) Argok=F Nobs=0 RETURN END IF END IF c----------------------------------------------------------------------- i=i+Ncol i1=i+Ncol-1 END DO c----------------------------------------------------------------------- IF(i1.gt.Plen)THEN WRITE(STDERR,1010)File WRITE(Mt2,1010)File 1010 FORMAT(/,' ERROR: Problem reading ',a,'.'/, & ' Too many observations in file.',/) Argok=F Nobs=0 END IF c----------------------------------------------------------------------- 10 WRITE(STDERR,1020)File WRITE(Mt2,1020)File 1020 FORMAT(/,' ERROR: Problem reading ',a,'.'/, & ' Check your input file and format.',/) Argok=F Nobs=0 c----------------------------------------------------------------------- 20 RETURN END gtestm.f0000664006604000003110000003014114521201513011634 0ustar sun00315stepsC Last change: BCM 19 May 1998 1:31 pm SUBROUTINE gtestm(Havreg,Hvarma,Nspobs,Mxitr,Mxnlit,Lestim,Outest, & Mdlfil,Hvmfil,Eick,Rmcnst,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gtestm.f, Release 1, Subroutine Version 1.7, Modified 14 Feb 1995. c----------------------------------------------------------------------- c Get a function c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdltbl.i' INCLUDE 'tbllog.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- CHARACTER Mdlfil*(PFILCR) LOGICAL argok,hvnltl,hvtol,Lestim,Hvarma,Hvmfil,Havreg,Inptok, & Rmcnst INTEGER Mxitr,Mxnlit,nelt,Nspobs,ivec,Outest,itmpvc DOUBLE PRECISION dvec,mprec,Eick DIMENSION dvec(1),ivec(1),itmpvc(0:1) c----------------------------------------------------------------------- LOGICAL gtarg DOUBLE PRECISION dpmpar EXTERNAL dpmpar,gtarg c----------------------------------------------------------------------- c Argument dictionary c----------------------------------------------------------------------- CHARACTER ARGDIC*87 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=15) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='maxitermaxnlitertolnltolparmsexactoutofsamplepri &ntsavesavelogfilefixstepkremoveconstant') c----------------------------------------------------------------------- CHARACTER EXTDIC*10 INTEGER extptr,PEXT PARAMETER(PEXT=3) DIMENSION extptr(0:PEXT) PARAMETER(EXTDIC='armamanone') c----------------------------------------------------------------------- CHARACTER ESTDIC*14 INTEGER estptr,PEST PARAMETER(PEST=2) DIMENSION estptr(0:PEST) PARAMETER(ESTDIC='fixedestimated') c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- CHARACTER FIXDIC*22 INTEGER fixptr,PRMFIX PARAMETER(PRMFIX=5) DIMENSION fixptr(0:PRMFIX) PARAMETER(FIXDIC='nochangenonearmaregall') c----------------------------------------------------------------------- DATA argptr/1,8,17,20,25,30,35,46,51,55,62,66,69,73,74,88/ DATA extptr/1,5,7,11/ DATA estptr/1,6,15/ DATA ysnptr/1,4,6/ DATA fixptr/1,9,13,17,20,23/ c----------------------------------------------------------------------- mprec=dpmpar(1) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- hvtol=F hvnltl=F CALL setint(NOTSET,2*PARG,arglog) c----------------------------------------------------------------------- DO WHILE (T) IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,Inptok))THEN IF(Lfatal)RETURN GO TO(10,20,30,40,50,60,65,70,80,90,100,110,115,116,117),argidx c----------------------------------------------------------------------- c Maximum overall iterations c----------------------------------------------------------------------- 10 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN Mxitr=ivec(1) GO TO 120 c----------------------------------------------------------------------- c Maximum nonlinear iterations c----------------------------------------------------------------------- 20 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN Mxnlit=ivec(1) GO TO 120 c----------------------------------------------------------------------- c Overall convergence tolerance, The actual tolerance is for the c reletive deviance of the objective function which is 2/nefobs * the c tolerance of the log likelihood. c----------------------------------------------------------------------- 30 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN Tol=dvec(1) IF(nelt.gt.0)THEN IF(1D0/Nspobs*Tol.lt.mprec)THEN CALL inpter(PERROR,Errpos, & 'Overall tolerance is smaller than machine precision' & ) WRITE(STDERR,1010)mprec*Nspobs WRITE(Mt2,1010)mprec*Nspobs 1010 FORMAT(' Make larger than ',e10.3) hvtol=F Inptok=F c----------------------------------------------------------------------- ELSE hvtol=T END IF END IF GO TO 120 c----------------------------------------------------------------------- c Nonlinear convergence tolerance c----------------------------------------------------------------------- 40 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN Nltol=dvec(1) IF(Nltol.lt.1D2*mprec)THEN CALL inpter(PERROR,Errpos, & 'Nonlinear tolerance is smaller than machine precision' & ) WRITE(STDERR,1010)mprec*Nspobs WRITE(Mt2,1010)mprec*Nspobs Inptok=F hvnltl=F c----------------------------------------------------------------------- ELSE hvnltl=T END IF END IF GO TO 120 c----------------------------------------------------------------------- c Specify whether the parameters are fixed and the likelihood c and the parameters are estimated or the parameters and the likelihood c are estimated c----------------------------------------------------------------------- 50 CALL gtdcvc(LPAREN,T,1,ESTDIC,estptr,PEST, & 'Choices are fixed or estimated',ivec,nelt,argok, & Inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(nelt.gt.0)THEN IF(ivec(1).ne.1)THEN Lestim=T ELSE IF(Imdlfx.ge.1)THEN Lestim=F c----------------------------------------------------------------------- ELSE CALL inpter(PERROR,Errpos, & 'Must specify all ARMA parameters to evaluate') Inptok=F c----------------------------------------------------------------------- END IF END IF GO TO 120 c----------------------------------------------------------------------- c Method of estimation exact MA only or ARMA, or conditional c----------------------------------------------------------------------- 60 CALL gtdcvc(LPAREN,T,1,EXTDIC,extptr,PEXT, & 'Choices are ARMA, MA, or NONE (conditional)', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(nelt.gt.0)THEN IF(ivec(1).eq.1)THEN Lextar=T Lextma=T ELSE IF(ivec(1).eq.2)THEN Lextar=F Lextma=T ELSE IF(ivec(1).eq.3)THEN Lextar=F Lextma=F END IF END IF GO TO 120 c----------------------------------------------------------------------- c outofsample argument c----------------------------------------------------------------------- 65 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for outofsample are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Outest=ivec(1) GO TO 120 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 70 CALL getprt(LSPEST,NSPEST,Inptok) Lprier=Prttab(LESTIE) GO TO 120 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 80 CALL getsav(LSPEST,NSPEST,Inptok) GO TO 120 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 90 CALL getsvl(LSLEST,NSLEST,Inptok) GO TO 120 c----------------------------------------------------------------------- c file argument c----------------------------------------------------------------------- 100 IF(Hvarma.or.Havreg)THEN CALL inpter(PERROR,Errpos,'Cannot specify a model file when a r &egARIMA model is specified in') CALL writln('the arima and/or regression specs.',Mt2,STDERR,F) Inptok=F END IF CALL gtnmvc(LPAREN,T,1,Mdlfil,itmpvc,nelt,PFILCR,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.eq.1)Hvmfil=T GO TO 120 c----------------------------------------------------------------------- c fix argument c----------------------------------------------------------------------- 110 CALL gtdcvc(LPAREN,T,1,FIXDIC,fixptr,PRMFIX, & 'Acceptable entries are nochange, none, arma, reg or all.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.eq.1)Fixmdl=ivec(1)-2 GO TO 120 c----------------------------------------------------------------------- c Step size of numerical derivatives c----------------------------------------------------------------------- 115 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN Stepln=dvec(1) IF(Stepln.lt.0D0)THEN CALL inpter(PERROR,Errpos,'Step size of numerical derivatives &cannot be less than zero.') Inptok=F END IF END IF GO TO 120 c----------------------------------------------------------------------- c Penalty term for EIC c----------------------------------------------------------------------- 116 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN Eick=dvec(1) IF(Eick.le.0D0)THEN CALL inpter(PERROR,Errpos,'Penalty term for EIC cannot be less &than or equal to zero.') Inptok=F END IF END IF GO TO 120 c----------------------------------------------------------------------- c removeconstant argument c----------------------------------------------------------------------- 117 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN, & 'Choices for removeconstant are yes and no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Rmcnst=ivec(1).eq.1 GO TO 120 END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Set the ARMA and initial ARMA convergence tolerances depending c on which tolerances have been input. c----------------------------------------------------------------------- IF(hvtol.and..not.hvnltl)THEN Nltol=Tol Nltol0=100D0*Tol c---------------------------------------------------------------------- ELSE IF(hvnltl)THEN Nltol0=Nltol END IF c---------------------------------------------------------------------- RETURN 120 CONTINUE END DO c---------------------------------------------------------------------- END gtfcst.f0000664006604000003110000001231614521201513011627 0ustar sun00315stepsC Last change: BCM 28 Jan 98 3:29 pm c SUBROUTINE gtfcst(Sp,Fctdrp,Nfcst,Nbcst,Ciprob,Inptok) SUBROUTINE gtfcst(Fctdrp,Nfcst,Nbcst,Ciprob,Lognrm,Inptok) c ------------------------------------------------------------------ IMPLICIT NONE INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'tbllog.i' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ LOGICAL argok,Lognrm,Inptok c INTEGER Fctdrp,nelt,Nbcst,Nfcst,Sp,ivec INTEGER Fctdrp,nelt,Nbcst,Nfcst,ivec DOUBLE PRECISION Ciprob,dvec DIMENSION ivec(1),dvec(1) c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- LOGICAL gtarg EXTERNAL gtarg c----------------------------------------------------------------------- c Argument dictionary was made with the following command c ../../dictionary/strary < ../../dictionary/forecast.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*50 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=7) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='excludemaxleadprobabilityprintsavemaxbacklognorm &al') c----------------------------------------------------------------------- DATA ysnptr/1,4,6/ DATA argptr/1,8,15,26,31,35,42,51/ c----------------------------------------------------------------------- c Default number of forecasts by specifying the forecast spec. c----------------------------------------------------------------------- c Nfcst=Sp CALL setint(NOTSET,2*PARG,arglog) 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),argidx c----------------------------------------------------------------------- c Drop data in the forecast origin c----------------------------------------------------------------------- 10 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN Fctdrp=ivec(1) GO TO 80 c----------------------------------------------------------------------- c Nfcst of forecasts c----------------------------------------------------------------------- 20 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(ivec(1).gt.PFCST)THEN CALL inpter(PERROR,Errpos,'Too many forecasts specified') Inptok=F ELSE Nfcst=ivec(1) END IF END IF GO TO 80 c----------------------------------------------------------------------- c Width of the confidense intervals in standard errors c----------------------------------------------------------------------- 30 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(dvec(1).le.0D0.or.dvec(1).ge.1D0)THEN CALL inpter(PERROR,Errpos, & 'Coverage probability must be strictly between 0 and 1.') Inptok=F ELSE Ciprob=dvec(1) END IF END IF GO TO 80 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 40 CALL getprt(LSPFOR,NSPFOR,Inptok) GO TO 80 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 50 CALL getsav(LSPFOR,NSPFOR,Inptok) GO TO 80 c----------------------------------------------------------------------- c backcasts argument c----------------------------------------------------------------------- 60 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN Nbcst=ivec(1) IF(Nbcst.gt.PFCST)THEN CALL inpter(PERROR,Errpos,'Too many backcasts specified') Inptok=F END IF GO TO 80 c----------------------------------------------------------------------- c lognormal argument c----------------------------------------------------------------------- 70 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for lognormal are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lognrm=ivec(1).eq.1 GO TO 80 END IF c ----------------------------------------------------------------- RETURN 80 CONTINUE END DO c ----------------------------------------------------------------- END gtfldt.f0000664006604000003110000002407314521201513011624 0ustar sun00315stepsC Last change: BCM 29 Jan 1999 11:01 am SUBROUTINE gtfldt(Plen,Datfil,Ndfl,Havfmt,Datfmt,Ltrim,Y,Nobs, & Hvfreq,Freq,Hvname,Srsnam,Nser,Havttl,Title, & Nttlcr,Indec,Hvstrt,Start,Ncol,Begzro,Endzro, & Lreg,Argok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Inputs the series, y, number of observations, nobs, from file c Datfil and returns the series as best it can. Assumes y(i)=0 are to c be trimmed off the end of the series if the input is formatted. c----------------------------------------------------------------------- c Input Arguments c Name Type Description c----------------------------------------------------------------------- c Datfil c Name of the file including the path c Datfmt c FORTRAN format of the input including the parentheses c Plen i Maximum length of the series c----------------------------------------------------------------------- c Local Arguments c Name Type Description c----------------------------------------------------------------------- c chnl i channel number c i i Do loop index c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) * INTEGER YR * PARAMETER(YR=1) c ------------------------------------------------------------------ CHARACTER Datfil*(PFILCR),Datfmt*(*),Srsnam*(*),Title*(*) LOGICAL Argok,Havfmt,Hvname,Inptok,Hvstrt,Hvfreq,Lreg,Havttl INTEGER chnl,i,Nobs,Plen,Freq,Start,Indec,tstrt,tdiff,Ncol,tmpfrq, & Nser,Nttlcr,Begzro,Endzro,tend,nz,Ndfl,Ltrim DOUBLE PRECISION Y DIMENSION Y(Plen),Start(2),tstrt(2),Begzro(2),Endzro(2),tend(2) c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL dpeq,strinx c----------------------------------------------------------------------- CHARACTER X12FMT*84 INTEGER xfmind,x12ptr,PX12F PARAMETER(PX12F=16) DIMENSION x12ptr(0:PX12F) PARAMETER(X12FMT='1r2r1l2lcansimdatevaluex12savecstramocansim2cs22 &l2freecommadatevaluecommafreex13save') DATA x12ptr/1,3,5,7,9,15,24,31,33,38,45,48,51,60,74,78,85/ c----------------------------------------------------------------------- c Set notset values for the input parameters so we know what has c been input. c----------------------------------------------------------------------- Argok=T chnl=NOTSET CALL setdp(DNOTST,Plen,Y) xfmind=0 c----------------------------------------------------------------------- c read the series if it is read from a file, formatted or not. c Note that if y has been input through the namelist and a file is c specified the file will be read. We might want to print a warning. c----------------------------------------------------------------------- CALL fopen(Datfil(1:Ndfl),'data','OLD',chnl,Argok) IF(Argok)THEN c----------------------------------------------------------------------- c If there is no format assume free format c----------------------------------------------------------------------- IF(Havfmt)THEN xfmind=strinx(F,X12FMT,x12ptr,1,PX12F,Datfmt) IF(.not.Hvfreq.and.Hvstrt.and.xfmind.ne.9)THEN Freq=12 Hvfreq=T END IF c ------------------------------------------------------------------ IF(xfmind.le.0)THEN READ(chnl,Datfmt,END=30,ERR=10)(Y(i),i=1,Plen) GO TO 30 c ------------------------------------------------------------------ 10 WRITE(STDERR,1010)Datfil(1:Ndfl),Datfmt WRITE(Mt2,1010)Datfil(1:Ndfl),Datfmt 1010 FORMAT(/,' ERROR: Problem reading ',a,' using format=',a,';', & /,' the program expects a Fortran format.', & /,' Check your input file and format.',/) Argok=F Nobs=0 c ------------------------------------------------------------------ ELSE IF(xfmind.eq.6.or.xfmind.eq.14)THEN CALL gtedit(Plen,Datfil(1:Ndfl),Y,tstrt,chnl,Nobs,Ncol,Freq, & Srsnam,xfmind.eq.14,Argok) c ------------------------------------------------------------------ ELSE IF(xfmind.eq.7.or.xfmind.eq.16)THEN CALL gtx12s(Plen,Datfil(1:Ndfl),Y,tstrt,chnl,Nobs,Ncol,Freq, & Srsnam,Argok) c ------------------------------------------------------------------ ELSE IF(xfmind.eq.9)THEN IF(Lreg)THEN Argok=F CALL inpter(PERRNP,Pos,'Cannot use the tramo format to read in & user-defined regressors.') ELSE CALL gttrmo(Plen,Datfil(1:Ndfl),Y,tstrt,chnl,Nobs,tmpfrq, & Havttl,Title,Nttlcr,Hvname,Srsnam,Nser,Argok) IF(.not.Hvfreq)THEN Freq=tmpfrq Hvfreq=T ELSE IF(Freq.ne.tmpfrq)THEN Argok=F CALL inpter(PERRNP,Pos,'Seasonal period given in series spec &does not match seasonal period') CALL writln(' of series as defined in '// & Datfil(1:Ndfl)//'.',STDERR,Mt2,F) END IF END IF c ------------------------------------------------------------------ ELSE IF(xfmind.eq.13)THEN CALL gtfrcm(Plen,Datfil(1:Ndfl),Y,chnl,Nobs,Argok) ELSE IF(xfmind.eq.15)THEN CALL gtfree(Plen,Datfil(1:Ndfl),Y,chnl,Freq,Nobs,Hvfreq,Hvstrt, & Argok) ELSE IF(Hvname)THEN IF(Lreg)THEN Argok=F CALL inpter(PERRNP,Pos,'Cannot use X-11 formats to read in use &r-defined regressors.') ELSE IF(.not.(Freq.eq.12.or.Freq.eq.4))THEN Argok=F CALL inpter(PERRNP,Pos,'Can only use X-11 formats to read mont &hly or quarterly data.') ELSE CALL gtx11d(Plen,Freq,Indec,xfmind,chnl,tstrt,tend,Nobs,Y, & Srsnam,Datfil(1:Ndfl),Argok) END IF c ------------------------------------------------------------------ ELSE Argok=F CALL inpter(PERRNP,Pos, & ' ***Must have series name to use X-11 format***') END IF c ------------------------------------------------------------------ ELSE CALL gtfree(Plen,Datfil(1:Ndfl),Y,chnl,Freq,Nobs,Hvfreq,Hvstrt, & Argok) END IF END IF c----------------------------------------------------------------------- c Find the number of input values (nobs). c----------------------------------------------------------------------- 30 IF(Argok)THEN CALL lendp(Y,Plen,Nobs) IF(Havfmt.AND.(xfmind.ne.6.and.xfmind.ne.7.and.xfmind.ne.9.and. & xfmind.lt.13))THEN IF(xfmind.eq.0)CALL addate(Start,Freq,Nobs,tend) IF(Ltrim.le.1)THEN IF(Ltrim.eq.0)THEN IF(Freq.eq.4.and.(xfmind.eq.5.or.xfmind.eq.8.or.xfmind.eq.10 & .or.xfmind.eq.11))THEN nz=4*Freq ELSE nz=2*Freq END IF ELSE CALL dfdate(tend,Endzro,Freq,nz) END IF IF(nz.gt.0)THEN nz=(nz-1)*Ncol IF(nz.gt.Nobs)nz=1 DO i=Nobs,Nobs-nz,-1 IF(.not.dpeq(Y(i),0D0))GO TO 40 END DO 40 Nobs=i END IF END IF c ------------------------------------------------------------------ IF(Ltrim.le.1)THEN IF(Ltrim.eq.0)THEN IF(Freq.eq.4.and.(xfmind.eq.5.or.xfmind.eq.8.or.xfmind.eq.10 & .or.xfmind.eq.11))THEN nz=4*Freq ELSE nz=2*Freq END IF ELSE IF(Hvstrt)THEN CALL dfdate(Start,Begzro,Freq,nz) ELSE CALL dfdate(tstrt,Begzro,Freq,nz) END IF IF(nz.gt.0)THEN IF((nz*Ncol).gt.Ncol)nz=Nobs DO i=1,nz*Ncol IF(.not.dpeq(Y(i),0D0))GO TO 50 END DO 50 Nobs=Nobs-i+1 IF(i.gt.1)THEN CALL copy(Y(i),Nobs,1,Y) IF((xfmind.lt.6.and.xfmind.gt.0).or.(xfmind.eq.8).or. & (xfmind.ge.10.and.xfmind.le.12)) & CALL addate(tstrt,Freq,i-1,tstrt) END IF END IF END IF END IF c ------------------------------------------------------------------ IF(Havfmt.and.xfmind.gt.0.and.xfmind.ne.13.and.xfmind.ne.15)THEN IF(Hvstrt)THEN c----------------------------------------------------------------------- c Check if starting date given in series spec is the same as in the c series. c----------------------------------------------------------------------- CALL dfdate(tstrt,Start,Freq,tdiff) IF(tdiff.ne.0)THEN Argok=F CALL inpter(PERRNP,Pos, &'Starting date in series spec does not match starting date of seri &es') CALL writln(' as defined in '//Datfil(1:Ndfl)//'.', & STDERR,Mt2,F) END IF c----------------------------------------------------------------------- c If no starting date, set Hvstrt variable to true. c----------------------------------------------------------------------- ELSE Hvstrt=T END IF c ------------------------------------------------------------------ CALL cpyint(tstrt,2,1,Start) IF(.not.Hvfreq)Hvfreq=T END IF c ------------------------------------------------------------------ IF(Nobs.eq.0)THEN WRITE(STDERR,1030) WRITE(Mt2,1030) 1030 FORMAT(/,' ERROR: Input series is empty.',/) Argok=F END IF END IF c ------------------------------------------------------------------ Inptok=Inptok.and.Argok IF(chnl.ne.NOTSET)CALL fclose(chnl) RETURN END gtfrcm.f0000664006604000003110000000554414521201513011624 0ustar sun00315stepsC Last change: BCM 14 May 1998 7:54 am SUBROUTINE gtfrcm(Plen,File,Y,Chnl,Nobs,Argok) IMPLICIT NONE c----------------------------------------------------------------------- c Read the free formatted data with commas instead of periods for c decimal places c Created by : BCMonsell, April 2003 c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- CHARACTER File*(*),Chrstr*(LINLEN) DOUBLE PRECISION Y LOGICAL Argok INTEGER i,i1,i2,ncomma,Plen,Chnl,Nobs,itmp DIMENSION Y(Plen) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- i=1 itmp=1 DO WHILE (i.le.Plen) c----------------------------------------------------------------------- c Read the data into a character vector c----------------------------------------------------------------------- READ(Chnl,'(a)',END=20,ERR=10)chrstr c----------------------------------------------------------------------- c convert commas in character string to periods. c----------------------------------------------------------------------- CALL cvcmma(chrstr,ncomma) IF(ncomma.eq.0)THEN WRITE(STDERR,1010)File,itmp WRITE(Mt2,1010)File,itmp 1010 FORMAT(/,' ERROR: Problem reading ',a,'.'/, & ' No observations found in line ',i3,'.',/, & ' Only use format="freecomma" when there are ', & 'commas in data file.',/) Argok=F Nobs=0 RETURN END IF i1=i+ncomma-1 IF(i1.gt.Plen)THEN i=i1 GO TO 30 END IF read(chrstr,*)(Y(i2),i2=i,i1) c----------------------------------------------------------------------- i=i+ncomma itmp=itmp+1 END DO c----------------------------------------------------------------------- 30 IF(i.gt.Plen)THEN WRITE(STDERR,1020)File WRITE(Mt2,1020)File 1020 FORMAT(/,' ERROR: Problem reading ',a,'.'/, & ' Too many observations in file.',/) Argok=F Nobs=0 END IF c----------------------------------------------------------------------- 10 WRITE(STDERR,1030)File WRITE(Mt2,1030)File 1030 FORMAT(/,' ERROR: Problem reading ',a,'.'/, & ' Check your input file and format.',/) Argok=F Nobs=0 c----------------------------------------------------------------------- 20 RETURN END gtfree.f0000664006604000003110000000250414521201513011607 0ustar sun00315steps SUBROUTINE gtfree(Plen,Datfil,Y,Chnl,Freq,Nobs,Hvfreq,Hvstrt, & Argok) IMPLICIT NONE c ------------------------------------------------------------------ c Reads in free formatted data. c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER Datfil*(*) DOUBLE PRECISION Y LOGICAL Hvfreq,Hvstrt,Argok INTEGER Freq,Nobs,Chnl,Plen,i DIMENSION Y(Plen) c ------------------------------------------------------------------ IF(.not.Hvfreq.and.Hvstrt)THEN Freq=12 Hvfreq=T END IF READ(Chnl,*,END=30,ERR=20)(Y(i),i=1,Plen) GO TO 30 c ------------------------------------------------------------------ 20 WRITE(STDERR,1020)Datfil WRITE(Mt2,1020)Datfil 1020 FORMAT(/,' ERROR: Problem reading, ',a,'.'/, &' Check that file has only correctly formatted real numbers &.',/) Argok=F Nobs=0 c ------------------------------------------------------------------ 30 RETURN END gtinpt.f0000664006604000003110000014052314521201513011644 0ustar sun00315stepsc Last change:Nov,2023,check to see if A spec that requires modeling c was found,but no provision for an ARIMA model was found. C Last change: Nov,2021, if there is a composite spec, set l1stcomp C True c previous change: Oct, 2021 C previous change: March. 2021 change the format of AOS and LSS C such as AOSdate-0.0/date-0.0 in regression variables to set C sequence outliers with a convention for the end of the series C previous change: SRD 25 Jan 100 2:09 pm SUBROUTINE gtinpt(Sscut,Srsttl,Nsrscr,Ttlvec,Notc,Lx11,X11agr, & Lseats,Lmodel,Ldata,Dtafil,l1stcomp,Hvmfil, & Mdlfil,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gtinpt.f, Release 1, Subroutine Version 1.13, Modified 14 Feb 1995. c----------------------------------------------------------------------- c Gets input for all specs from input files. c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ONE,ZERO,PT5 PARAMETER(F=.false.,T=.true.,ONE=1D0,ZERO=0D0,PT5=0.05D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'rev.prm' INCLUDE 'arima.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'prittl.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'title.cmn' INCLUDE 'extend.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'seatop.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11log.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'xrgfct.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'metadata.prm' INCLUDE 'metadata.cmn' INCLUDE 'fxreg.cmn' INCLUDE 'error.cmn' INCLUDE 'rho.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'rev.cmn' INCLUDE 'agr.cmn' INCLUDE 'adj.cmn' INCLUDE 'force.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'xclude.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'missng.cmn' INCLUDE 'tukey.cmn' INCLUDE 'savcmn.cmn' INCLUDE 'xrgum.cmn' INCLUDE 'xtrm.cmn' INCLUDE 'revtrg.cmn' INCLUDE 'deftab.prm' INCLUDE 'sumtab.prm' c----------------------------------------------------------------------- CHARACTER Ttlvec*(*),Srsttl*(PSRSCR),Mdlfil*(PFILCR),perstr*(7), & Dtafil*(PFILCR) DOUBLE PRECISION Sscut LOGICAL havotl,havesp,havsrs,Inptok,Lx11,X11agr,lagr,Lmodel, & Hvmfil,havreg,Ldata,larma,x11reg,hvx12f,havtca,havhol, & Lseats,hvfcst,hvspec,l1stcomp,havmdl,havreq INTEGER Notc,icol,i,Nsrscr,iautom,outamd,outest,fhnote,igrp, & numcol,iper,nspec DIMENSION Ttlvec(*),Sscut(*),hvx12f(PNAD) c----------------------------------------------------------------------- c INTEGER Iwt,Kexopt c COMMON /oldopt/ Iwt,Kexopt LOGICAL dpeq,getfcn INTEGER strinx EXTERNAL dpeq,getfcn,strinx c----------------------------------------------------------------------- CHARACTER SPCDIC*150 INTEGER spcidx,spcptr,PSPC,spclog PARAMETER(PSPC=20) DIMENSION spcptr(0:PSPC),spclog(2,PSPC) PARAMETER(SPCDIC='seriestransformidentifyregressionarimaautomdlest &imateoutliercheckforecastx11historyslidingspanscompositex11regress &ionseatspickmdlforcemetadataspectrum') c----------------------------------------------------------------------- DATA spcptr /1,7,16,24,34,39,46,54,61,66,74,77,84,96,105,118,123, & 130,135,143,151/ c----------------------------------------------------------------------- INCLUDE 'deftab.var' INCLUDE 'sumtab.var' c----------------------------------------------------------------------- c Initialize parser input c----------------------------------------------------------------------- * call profiler(1,'entering gtinpt') CALL intinp(Mt) IF(Lfatal)RETURN CALL setint(NOTSET,2*PSPC,spclog) c----------------------------------------------------------------------- c Set default values for print table, print plot, and save variables c----------------------------------------------------------------------- IF(Lnoprt)THEN CALL setlg(F,NTBL,Prttab) ELSE CALL copylg(deftab,NTBL,1,Prttab) END IF IF(Lsumm.gt.0)THEN CALL copylg(sumtab,NTBL,1,Savtab) ELSE CALL setlg(F,NTBL,Savtab) END IF CALL setlg(F,NSVLOG,Svltab) c----------------------------------------------------------------------- c Set the default values c----------------------------------------------------------------------- havsrs=F havesp=F havotl=F Inptok=T Picktd=F havreg=F x11reg=F larma=F havhol=F hvfcst=F hvspec=F havmdl=F havreq=F c----------------------------------------------------------------------- Begsrs(YR)=1 Begsrs(MO)=1 Nobs=0 Sp=12 Hvmfil=F Svprec=15 Svsize=Svprec+7 Yr2000=T Divpwr=NOTSET Isrflw=NOTSET CALL setdp(ZERO,PLEN,Y) c----------------------------------------------------------------------- CALL setdp(DNOTST,PB,B) Priadj=0 Reglom=0 Fcntyp=NOTSET Lam=ONE Nustad=0 Nuspad=0 CALL setchr(' ',PSRSCR,Adjttl) Nadjcr=12 Adjttl(1:Nadjcr)='User-defined' CALL setint(NOTSET,PNAD,Percnt) CALL setint(NOTSET,PNAD,Prtype) Nprtyp=0 Lprntr=F Cnstnt=DNOTST c----------------------------------------------------------------------- Niddf=0 Nidsdf=0 Mxidlg=NOTSET Lidsdf=F Lprtdf=F c----------------------------------------------------------------------- c Initialize the parmeters and lag vectors. Rewind the input file c because we are only going go through the input once. c----------------------------------------------------------------------- Lseff=F Lrgmse=F Lrgmtd=F Lrgmln=F Fulltd=F Fullln=F Fulllp=F CALL intlst(PB,Colptr,Ncoltl) Nb=Ncoltl Ncxy=1 CALL intlst(PGRP,Grpptr,Ngrptl) CALL intlst(PGRP,Grp,Ngrp) CALL intlst(POPR,Opr,Nopr) CALL intlst(PMDL,Mdl,Nmdl) CALL intlst(PGRP,Grpfix,Ngrpfx) CALL intlst(PB,Gfxptr,Nfxttl) CALL setchr(' ',PCOLCR*PB,Colttl) CALL setchr(' ',PGRPCR*PGRP,Grpttl) CALL setlg(F,PB,Regfx) CALL intlst(PUREG,Usrptr,Ncusrx) CALL setchr(' ',PCOLCR*PUREG,Usrttl) c----------------------------------------------------------------------- Lseadf=F CALL setchr(' ',PFILCR,Mdlfil) Fixmdl=0 Mdl(AR)=1 Mdl(MA)=1 CALL setlg(F,PARIMA,Arimaf) CALL setint(0,PARIMA,Arimal) CALL setdp(ZERO,PARIMA,Arimap) CALL setchr(' ',POPRCR,Mdlttl) Nmdlcr=11 Mdlttl(1:Nmdlcr)='ARIMA Model' CALL setchr(' ',132,Mdldsn) Nmddcr=7 Mdldsn(1:Nmddcr)='(0,0,0)' Mxarlg=0 Mxdflg=0 Mxmalg=0 c----------------------------------------------------------------------- Lautom=F Lautod=F Exdiff=2 Hrinit=F CALL setchr(' ',132,Bstdsn) Bstdsn(1:1)=CNOTST Nbstds=0 Ub1lim=ONE/0.96D0 Ub2lim=0.88D0 ! increase to 0.91 Ubfin=1.05D0 Tsig=ONE Fct=ONE/(ONE-.0125D0) Predcv=.14286D0 Cancel=0.1D0 Pcr=.95D0 Lbalmd=F Laccdf=F Lotmod=T CALL setint(0,2,Maxord) CALL setint(NOTSET,2,Diffam) Frstar=2 Lchkmu=T Lmixmd=T Lrejfc=F Fctlm2=15D0 Lsovdf=F c----------------------------------------------------------------------- Lautox=F Pck1st=T Id1st=T outamd=NOTSET iautom=0 CALL setchr(' ',PFILMD,Autofl) Fctlim=15D0 Bcklim=18D0 Qlim=5D0 Ovrdif=0.9D0 c----------------------------------------------------------------------- Nintvl=0 Nextvl=0 Var=ZERO Lndtcv=ZERO CALL setint(0,PUREG,Usrtyp) c----------------------------------------------------------------------- c Set the default values for the options c----------------------------------------------------------------------- Armaer=0 Convrg=T Iregfx=1 Imdlfx=1 Mxiter=1500 Mxnlit=40 Stepln=ZERO Tol=DFTOL Nltol0=DFNLT0 Nltol=DFNLTL Lextar=T Lextma=T Lestim=T Ldestm=F Lcalcm=F Itdtst=0 Leastr=F Lceaic=F Eastst=0 Luser=F Lttc=F Lomtst=0 Elong=T Rmcnst=F Aicstk=31 Easidx=0 Traicd=DNOTST CALL setdp(ZERO,PAICT,Rgaicd) Acflim=1.6D0 Qcheck=PT5 Eick=DNOTST Ch2tst=F Chi2cv=0.01D0 Tlimit=DNOTST Pvaic=DNOTST Iqtype=0 c----------------------------------------------------------------------- Ltstao=F Ltstls=F Ltsttc=F * Ltstso=F Ladd1=T CALL setdp(DNOTST,POTLR,Critvl) Lsrun=0 Lindot=T c----------------------------------------------------------------------- Fctdrp=0 Ciprob=.95D0 Nfcst=NOTSET Nbcst=NOTSET Lognrm=F c----------------------------------------------------------------------- Kdec=0 Mxcklg=0 outest=NOTSET c----------------------------------------------------------------------- Muladd=NOTSET Kfulsm=0 Sigml=1.5D0 Sigmu=2.5D0 Lterm=NOTSET Ktcopt=0 Ksdev=1 CALL setlg(F,PSP,Csigvc) Tic=0.0D0 * Iwt=0 CALL setint(0,12,Lter) Notc=0 Imad=0 Thtapr=0.0D0 Nspeak=0 Ntpeak=0 CALL setchr(' ',35,Cspeak) CALL setchr(' ',35,Ctpeak) DO i=1,8 CALL setchr(' ',80,Ttlvec(i)) END DO Iag=NOTSET lagr=F W=ONE CALL setchr(' ',64,Serno) CALL setchr(' ',64,Tmpser) CALL setchr(' ',64,Prmser) Nser=0 Ntser=0 Npser=0 Shrtsf=F Spcdff=T Spdfor=NOTSET Lstdff=F Lfqalt=F Llogqs=F Lrbstsa=T Lqchk=F Lprsfq=F Svallf=F Ldecbl=T Spctyp=0 Spcsrs=2 Mxarsp=NOTSET Ltk120=T Spclim=6D0 Peakwd=NOTSET Plocal=0.002D0 CALL setint(NOTSET,2,Bgspec) Mvcode=-99999D0 Mvval=1000000000D0 Missng=F Psuadd=F Savfct=F Savbct=F Prt1ps=F Axsame=F Noxfct=F Tru7hn=F Lcentr=F Ishrnk=0 c----------------------------------------------------------------------- CALL setdp(DNOTST,6,Ptsr) CALL setdp(DNOTST,6,Ptso) CALL setdp(DNOTST,6,Ptsa) CALL setdp(DNOTST,6,Ptsi) Pttdr=NOTSET Pttdo=NOTSET Pttda=NOTSET Pttdi=NOTSET Ntukey=0 CALL setint(NOTSET,4,Itukey) c----------------------------------------------------------------------- c Initialize model adjustment parameters c----------------------------------------------------------------------- Adjtd=1 Adjhol=1 Adjao=1 Adjls=1 Adjtc=1 Adjso=1 Adjsea=1 Adjcyc=1 Adjusr=1 Finhol=T Finao=F Finls=F Fintc=F Finusr=F Nusrrg=0 Tdzero=0 Lnzero=0 CALL setint(NOTSET,2,Tddate) CALL setint(NOTSET,2,Lndate) Tcalfa=DNOTST havtca=F Cvalfa=PT5 Cvtype=F Cvrduc=0.5D0 c----------------------------------------------------------------------- Iyrt=NOTSET Begyrt=NOTSET Lrndsa=F Lindfr=T Lfctfr=T Iftrgt=NOTSET Mid=NOTSET Lamda=DNOTST Rol=DNOTST c----------------------------------------------------------------------- c Kexopt=0 c Kdwopt=0 c Lcyr=0 c Layr=0 c Sigm=2.5D0 c Lopt=0 Keastr=0 c----------------------------------------------------------------------- Ixreg=0 Nbx=0 Begum(YR)=0 Begum(MO)=0 Haveum=F Noxfac=F Ixrgtd=1 Ixrghl=1 Havxtd=F Havxhl=F Axrgtd=F Axrghl=F Axruhl=F CALL setint(0,PUREG,Usxtyp) CALL intlst(PUREG,Usrxpt,Ncxusx) Ncxusx=0 Sigxrg=DNOTST Critxr=DNOTST Otlxrg=F Ladd1x=T Xtdtst=0 Xeastr=F Xuser=F Xhlnln=F Lxrneg=F Xelong=T Calfrc=F CALL setint(NOTSET,2,Xaicrg) Xaicst=31 CALL setdp(DNOTST,7,Dwt) Fxprxr=0 Xdsp=0 Nfcstx=0 Nbcstx=0 CALL setlg(F,PLEN,Rgxcld) Nxcld=0 Xraicd=ZERO Cvxalf=PT5 Cvxrdc=0.5D0 Cvxtyp=F c----------------------------------------------------------------------- Issap=0 Nlen=0 Ncol=0 Irev=0 Irevsa=0 Fixper=0 Cnctar=F CALL setint(NOTSET,PTARGT,Targsa) Ntarsa=0 CALL setint(NOTSET,PTARGT,Targtr) Ntartr=0 CALL setint(NOTSET,PFCLAG,Rfctlg) Nfctlg=0 Rvstrt(YR)=0 Rvstrt(MO)=0 Rvend(YR)=0 Rvend(MO)=0 Lrvsa=F Lrvsf=F Lrvch=F Lrvtrn=F Lrvtch=F Lrvaic=F Lrvfct=F Lrvarma=F Lrvtdrg=F Revfix=F Lrfrsh=F Otlrev=0 Otlwin=NOTSET Rvtran=T Revfxx=F Rvtrfc=F Rvxotl=T CALL setint(NOTSET,4,Rvfxrg) Nrvfxr=0 Rvdiff=2 c----------------------------------------------------------------------- Ssotl=1 Ssinit=1 Sstran=T CALL setdp(3D0,5,Sscut) Sscut(2)=2D0 CALL setint(NOTSET,2,Strtss) CALL setint(NOTSET,4,Ssfxrg) Nssfxr=0 Ssdiff=T Ssidif=T Ssxotl=T Ssxint=T c----------------------------------------------------------------------- Lnoadm=F Kmean=NOTSET Lstsea=F Lhp=T Lfinit=F Lhprmls=F Qmax2=NOTSET Out2=NOTSET Maxit2=NOTSET Epsph2=DNOTST Xl2=DNOTST Rmod2=DNOTST Epsiv2=DNOTST Hplan2=DNOTST Bias2=NOTSET Iphtrf=NOTSET Hptrgt=NOTSET CALL setchr(' ',100,Tabtbl) Tabtbl(1:1)=CNOTST c----------------------------------------------------------------------- CALL intlst(PMTDAT,Keyptr,Nkey) CALL intlst(PMTDAT,Valptr,Nval) CALL setchr(' ',PLMETA,Keystr) CALL setchr(' ',PLMETA,Valstr) Hvmtdt=F c----------------------------------------------------------------------- Lx11=F Lseats=F Lmodel=F c----------------------------------------------------------------------- c Get the series, prior adjustments, regression and ARIMA model, c and options. c----------------------------------------------------------------------- DO WHILE (T) IF(getfcn(SPCDIC,spcptr,PSPC,spcidx,spclog,Inptok))THEN GO TO(10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160, & 170,180,190,200),spcidx c----------------------------------------------------------------------- 10 Endspn(YR)=0 Endspn(MO)=0 CALL getsrs(Sp,Y,Nobs,Begsrs,Nspobs,Begspn,Srsttl,Nsrscr,Serno, & Nser,havsrs,havesp,Kdec,Begmdl,Endmdl,Ldata,Dtafil, & Iag,Iagr,lagr,W,Mvcode,Mvval,Fixper,Svprec,Yr2000, & Divpwr,Isrflw,Inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Initialize outlier span variable c----------------------------------------------------------------------- IF(havsrs)THEN IF(.not.havotl)THEN CALL cpyint(Begmdl,2,1,Begtst) CALL cpyint(Endmdl,2,1,Endtst) c CALL addate(Begspn,Sp,Nobs-1,Endtst) END IF CALL addate(Begspn,Sp,Nspobs-1,Endspn) END IF c----------------------------------------------------------------------- c Set up composite adjusment. c----------------------------------------------------------------------- IF(lagr)THEN CALL agr1(Y,Nobs) X11agr=T END IF GO TO 210 c----------------------------------------------------------------------- 20 CALL getadj(Begsrs,havsrs,havesp,Sp,Begspn,Nspobs,Endspn,Usrtad, & Nustad,Bgutad,Tmpser,Ntser,Usrpad,Nuspad,Bgupad, & Prmser,Npser,Adjttl,Nadjcr,Priadj,Reglom,Fcntyp,Lam, & Prtype,Nprtyp,Percnt,Traicd,Lprntr,hvx12f,Cnstnt, & Inptok) IF(Lfatal)RETURN GO TO 210 c----------------------------------------------------------------------- 30 CALL getid(Dflist,Niddf,Nidsdf,Mxidlg,Inptok) IF(Lfatal)RETURN IF(.not.Lmodel)Lmodel=T GO TO 210 c----------------------------------------------------------------------- c Specify Regression portion of model if requested c----------------------------------------------------------------------- 40 IF(Hvmfil)THEN CALL inpter(PERROR,Pos,'Cannot specify regression variables whe &n a model file is given.') Inptok=F END IF CALL getreg(Begsrs,Endmdl,Nobs,havsrs,havesp,Userx,Nrusrx, & Bgusrx,Itdtst,Leastr,Eastst,Luser,Lttc,Elong,Adjtd, & Adjao,Adjls,Adjtc,Adjso,Adjhol,Adjsea,Adjcyc,Adjusr, & Nusrrg,havtca,Rgaicd,Lam,Fcntyp,havhol,Lomtst, & Ch2tst,Chi2cv,Tlimit,Pvaic,Lceaic,Inptok) IF(Lfatal)RETURN IF(.not.Lmodel)Lmodel=T IF(.not.havreg)havreg=T IF(.not.havreq)havreq=T GO TO 210 c----------------------------------------------------------------------- c Specify ARIMA portion of model if requested c----------------------------------------------------------------------- 50 IF(Lautom)THEN CALL inpter(PERROR,Pos,'Cannot specify arima and automdl spec i &n the same input file.') Inptok=F ELSE IF(Lautox)THEN CALL inpter(PERROR,Pos,'Cannot specify arima and pickmdl spec i &n the same input file.') Inptok=F END IF IF(Hvmfil)THEN CALL inpter(PERROR,Pos,'Cannot specify arima spec if model is r &ead in from the file argument') CALL writln(' of the estimate spec.',Mt2,STDERR,F) Inptok=F END IF Imdlfx=1 CALL gtarma(Inptok) IF(Lfatal)RETURN IF(.not.Lmodel)Lmodel=T IF(.not.havmdl)havmdl=T larma=T GO TO 210 c----------------------------------------------------------------------- c Specify automatic ARIMA modeling options c----------------------------------------------------------------------- 60 IF(larma)THEN CALL inpter(PERROR,Pos, & 'Cannot specify arima and automdl spec in the same input file.') Inptok=F ELSE IF(Lautox)THEN CALL inpter(PERROR,Pos,'Cannot specify automdl and pickmdl spec & in the same input file.') Inptok=F END IF IF(Hvmfil)THEN CALL inpter(PERROR,Pos,'Cannot specify automdl spec if model is & read in from the file argument') CALL writln(' of the estimate spec.',Mt2,STDERR,F) Inptok=F END IF Imdlfx=1 CALL gtauto(Lautom,Lautod,Ub1lim,Ub2lim,Cancel,Maxord,Diffam, & Exdiff,Lbalmd,Hrinit,Tsig,Pcr,Fct,Predcv,Laccdf, & Lotmod,Ubfin,Frstar,Lchkmu,Lmixmd,Lrejfc,Fctlm2, & Lsovdf,Inptok) IF(Lfatal)RETURN IF(.not.Lmodel)Lmodel=T IF(.not.havmdl)havmdl=T IF(Lautom)Ldestm=T GO TO 210 c----------------------------------------------------------------------- c estimate model if requested c----------------------------------------------------------------------- 70 CALL gtestm(havreg,larma,Nspobs,Mxiter,Mxnlit,Lestim,outest, & Mdlfil,Hvmfil,Eick,Rmcnst,Inptok) IF(Lfatal)RETURN Ldestm=T IF(.not.Lmodel)Lmodel=T IF(.not.havreq)havreq=T GO TO 210 c----------------------------------------------------------------------- c identify outliers and level changes if requested c----------------------------------------------------------------------- 80 IF(.not.havsrs)THEN CALL inpter(PERROR,Pos, & 'Need to specify a series to identify outliers') Inptok=F END IF CALL gtotlr(Begsrs,Nobs,Begmdl,Endmdl,Sp,Ltstao,Ltstls,Ltsttc, * & Ltstso,Ladd1,Critvl,Begtst,Endtst,Lsrun,Tcalfa, & Ladd1,Critvl,Begtst,Endtst,Lsrun,Tcalfa, & havtca,Cvalfa,Cvtype,Cvrduc,havotl,Inptok) IF(Lfatal)RETURN Ldestm=T IF(.not.havreq)havreq=T GO TO 210 c----------------------------------------------------------------------- c Produce model diagnostics if requested c----------------------------------------------------------------------- 90 CALL getchk(Mxcklg,Acflim,Qcheck,Iqtype,Sp,Inptok) IF(Lfatal)RETURN Ldestm=T IF(.not.Lmodel)Lmodel=T IF(.not.havreq)havreq=T GO TO 210 c----------------------------------------------------------------------- c Calculate the forecasts if requested. c----------------------------------------------------------------------- 100 CALL gtfcst(Fctdrp,Nfcst,Nbcst,Ciprob,Lognrm,Inptok) IF(Lfatal)RETURN IF(Nfcst.gt.0.or.Nbcst.gt.0.or.hvfcst)Ldestm=T IF(.not.Lmodel)Lmodel=T IF(.not.havreq)havreq=T hvfcst=T GO TO 210 c----------------------------------------------------------------------- c Perform X-11 seasonal adjustment if requested. c----------------------------------------------------------------------- 110 IF(Lseats)THEN CALL inpter(PERROR,Pos, & 'Cannot specify x11 and seats spec in the '// & 'same input file.') Inptok=F END IF CALL getx11(havesp,Sp,Muladd,Kfulsm,Sigml,Sigmu,Lterm,Ktcopt, & Lter,Notc,Imad,Ttlvec,Tic,Ksdev,Csigvc,Keastr, & Thtapr,Finhol,Finao,Finls,Fintc,Finusr,Shrtsf, & Psuadd,Prt1ps,Noxfct,Tru7hn,Lcentr,Ishrnk,Inptok) c & Kexopt,Iwt,Inptok) IF(Lfatal)RETURN IF(.not.Lx11)Lx11=T GO TO 210 c----------------------------------------------------------------------- c Generate revisions diagnostics if specified c----------------------------------------------------------------------- 120 CALL gtrvst(havesp,Sp,Irev,Irevsa,Rfctlg,Nfctlg,Rvstrt,Rvend, & Otlrev,Otlwin,Lrvsa,Lrvch,Lrvtrn,Lrvaic,Lrvfct, & Lrvtch,Lrvsf,Lrvarma,Lrvtdrg,Revfix,Cnctar,Targsa, & Ntarsa,Targtr,Ntartr,Lrfrsh,Rvtran,Rvfxrg,Nrvfxr, & Rvxotl,Rvdiff,Revfxx,Rvtrfc,Indrev,Indrvs,Iagr, & Inptok) IF(Lfatal)RETURN IF(Lrvfct.or.Lrvaic)Ldestm=T GO TO 210 c----------------------------------------------------------------------- c Generate sliding spans seasonal adjustment diagnostics c if specified c----------------------------------------------------------------------- 130 CALL getssp(havesp,Sp,Issap,Ssotl,Ssinit,Strtss,Sscut,Nlen,Ncol, & Sstran,Ssfxrg,Nssfxr,Ssdiff,Ssxotl,Ssxint,Inptok) IF(Lfatal)RETURN IF(.not.Ssdiff)Ssidif=Ssdiff GO TO 210 c----------------------------------------------------------------------- c Set up direct and indirect composite adjustment, if specified c----------------------------------------------------------------------- 140 IF (Iagr.le.0)THEN c----------------------------------------------------------------------- c Test to see if component series have been specified. c----------------------------------------------------------------------- IF(Iagr.eq.0)THEN CALL inpter(PERROR,Pos,'No component series were specified for & composite adjustment.') ELSE CALL inpter(PERROR,Errpos,'Error(s) were found while executing & the spec file(s) of component') CALL writln(' series used for this composite adjustmen &t. The direct and indirect',STDERR,Mt2,F) CALL writln(' seasonal adjustment of the total series &will not be performed.',STDERR,Mt2,F) Iagr=NOTSET END IF Inptok=F END IF CALL getcmp(PLEN,havesp,Sp,Y,Nobs,Begsrs,Nspobs,Begspn,Srsttl, & Nsrscr,Serno,Nser,Itest,Kdec,Begmdl,Endmdl,Svprec, & lagr,Yr2000,Lindot,Isrflw,Inptok) IF(Lfatal)RETURN l1stcomp=T IF(lagr)THEN havsrs=T IF(.not.havotl)THEN CALL cpyint(Begmdl,2,1,Begtst) CALL cpyint(Endmdl,2,1,Endtst) END IF END IF GO TO 210 c----------------------------------------------------------------------- c Specify X-11 Regression model if requested c----------------------------------------------------------------------- c Store model parameters into temporary storage and delete c regressors (if they exist) c----------------------------------------------------------------------- 150 CALL ssprep(T,F,F) IF(Nb.gt.0)THEN DO igrp=Ngrp,1,-1 icol=Grp(igrp-1) numcol=Grp(igrp)-Grp(igrp-1) CALL dlrgef(icol,Nrxy,numcol) END DO CALL intlst(PGRP,Grpptr,Ngrptl) CALL intlst(PGRP,Grp,Ngrp) CALL setchr(' ',PCOLCR*PB,Colttl) Ncoltl=0 IF(Fulltd)Fulltd=F END IF c----------------------------------------------------------------------- CALL gtxreg(Begsrs,Nobs,Endmdl,havsrs,havesp,Priadj,Xuserx, & Bgusrx,Ixreg,Nusxrg,Sigxrg,Critxr,Otlxrg,Umean, & Begum,Haveum,Noxfac,Ladd1x,Xtdtst,Xeastr,Xuser, & Dwt,Ixrgtd,Ixrghl,Xhlnln,Xelong,Calfrc,Begxrg, & Endxrg,Fxprxr,Begxot,Endxot,Havxhl,Havxtd,Axrghl, & Axrgtd,Lxrneg,Cvxalf,Cvxtyp,Cvxrdc,Xraicd,Inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c store regression options into X-11 regression variables and c restore previous values. c----------------------------------------------------------------------- * call profiler(3,'before loadxr') CALL loadxr(T) * call profiler(3,'after loadxr') CALL restor(T,F,F) * call profiler(3,'after restor') IF(.not.x11reg.and.Ixreg.gt.0)x11reg=T IF(.not.Lx11)Lx11=T GO TO 210 c----------------------------------------------------------------------- c Seats spec c----------------------------------------------------------------------- 160 IF(Lx11)THEN CALL inpter(PERROR,Pos, & 'Cannot specify x11 and seats spec in the '// & 'same input file.') Inptok=F END IF CALL gtseat(Qmax2,Out2,Maxit2,Epsph2,Xl2,Rmod2,Epsiv2,Hplan2, & Lseats,Lnoadm,Kmean,Lhp,Lstsea,Bias2,Lfinit,Iphtrf, & Tabtbl,Hptrgt,Lhprmls,Inptok) IF(Lfatal)RETURN Ldestm=T IF(.not.Lmodel)Lmodel=T IF(.not.havreq)havreq=T GO TO 210 c----------------------------------------------------------------------- c Specify automatic ARIMA modeling options c----------------------------------------------------------------------- 170 IF(larma)THEN CALL inpter(PERROR,Pos,'Cannot specify arima and pickmdl spec i &n the same input file.') Inptok=F ELSE IF(Lautom)THEN CALL inpter(PERROR,Pos,'Cannot specify automdl and pickmdl spec & in the same input file.') Inptok=F END IF IF(Hvmfil)THEN CALL inpter(PERROR,Pos,'Cannot specify pickmdl spec if model is & read in from the file argument') CALL writln(' of the estimate spec.',Mt2,STDERR,F) Inptok=F END IF Imdlfx=1 CALL gtautx(iautom,Autofl,Fctlim,Bcklim,Qlim,Ovrdif,Pck1st, & Id1st,outamd,Inptok) IF(Lfatal)RETURN IF(.not.Lmodel)Lmodel=T IF(.not.havmdl)havmdl=T IF(iautom.gt.0)THEN Lautox=T Ldestm=T END IF GO TO 210 c----------------------------------------------------------------------- c Specify forcing options c----------------------------------------------------------------------- 180 CALL getfrc(havesp,Iyrt,Lrndsa,Iftrgt,Begyrt,Mid,Lamda,Rol,Sp, & Lindfr,Lfctfr,Inptok) IF(Lfatal)RETURN GO TO 210 c----------------------------------------------------------------------- c Specify metadata options c----------------------------------------------------------------------- 190 CALL gtmtdt(Inptok) IF(Lfatal)RETURN GO TO 210 c----------------------------------------------------------------------- c Specify spectrum options c----------------------------------------------------------------------- 200 CALL gtspec(Sp,Begspn,Endspn,Havesp,Bgspec,Spcdff,Spctyp,Spcsrs, & Mxarsp,Spclim,Peakwd,Lfqalt,Axsame,Svallf,Ldecbl, & Plocal,Spdfor,Lstdff,Lprsfq,Ltk120,Llogqs,Lqchk, & Lrbstsa,Inptok) IF(Lfatal)RETURN IF(Inptok)hvspec=T GO TO 210 END IF IF(.not.Inptok)RETURN c----------------------------------------------------------------------- c check to see if series or composite spec has been specified c----------------------------------------------------------------------- IF(.not.havsrs)THEN CALL writln('ERROR: Series for analysis not specifed; a valid se &ries or composite',Mt2,STDERR,T) CALL writln(' spec is required.',Mt2,STDERR,F) Inptok=F RETURN END IF c----------------------------------------------------------------------- c check to see if A spec that requires modeling was found c (regression, check, estimate, forecast, outlier, or seats), c but no provision for an ARIMA model was found. c----------------------------------------------------------------------- IF (.not.havmdl.and.havreq) then CALL writln('ERROR: A spec that requires modeling was found ', & Mt2,STDERR,T) CALL writln(' (regression, check, estimate, forecast, '// & 'outlier or seats),',Mt2,STDERR,F) CALL writln(' but no provision for an ARIMA model was '// & 'found.',Mt2,STDERR,F) CALL writln(' If modeling was intended, please provide '// & 'an ARIMA model ',Mt2,STDERR,F) CALL writln(' using the arima spec or allow for '// & 'automatic ARIMA',Mt2,STDERR,F) CALL writln(' model selection using an automdl or '// & 'pickmdl spec. ',Mt2,STDERR,F) Inptok=F RETURN END IF c----------------------------------------------------------------------- c set up seasonal adjustment indicator variables c----------------------------------------------------------------------- Havesa=Lx11.OR.Lseats IF(.not.Havesa)THEN IF(Lrvsa.or.Lrvch.or.Lrvtrn.or.Lrvtch.or.Lrvsf)Lx11=T IF(Issap.eq.1)Lx11=T IF(Lx11)Havesa=T END IF c----------------------------------------------------------------------- c Set Muladd and Fcntyp to appropriate values. c----------------------------------------------------------------------- IF(Muladd.eq.NOTSET)THEN IF(Fcntyp.eq.0.or.Fcntyp.eq.4.or. & (Fcntyp.eq.5.and.dpeq(Lam,ONE)))THEN Muladd=1 ELSE Muladd=0 IF(Fcntyp.eq.NOTSET)Fcntyp=4 END IF ELSE IF(Fcntyp.eq.0)THEN CALL writln('ERROR: Cannot set seasonal adjustment mode when au &tomatic transformation',Mt2,STDERR,T) CALL writln(' selection is done.',Mt2,STDERR,F) Inptok=F RETURN ELSE IF(Fcntyp.eq.NOTSET)THEN Fcntyp=4 END IF END IF Tmpma=Muladd c----------------------------------------------------------------------- c Read in a previously stored model file, if requested c----------------------------------------------------------------------- IF(Hvmfil)THEN IF(Inptok)THEN CALL gtmdfl(Mdlfil,Mtm,Begsrs,Endmdl,Nobs,havsrs,havesp,Userx, & Nrusrx,Bgusrx,Itdtst,Lmodel,Lestim,havreg,Leastr, & Eastst,Luser,Elong,havtca,havhol,Rgaicd,Lam,Fcntyp, & Lomtst,Ch2tst,Chi2cv,Tlimit,Pvaic,Lceaic,Inptok) IF(Lfatal)RETURN ELSE c----------------------------------------------------------------------- c If there are errors in the spec file, do not read model file. c----------------------------------------------------------------------- CALL inpter(PERROR,Pos,'Program will not read model file until &input errors are corrected.') END IF END IF c----------------------------------------------------------------------- c Setup the TD, lom adjust the series and the regression variables c (if there is no boxcox transformation). c The additive case, td6+lom, is already setup in the regresssion spec. c For other transformations the series must be prior adjusted for lom c if it is not already adjusted by the leap year adjustment c (priadj=2 or 3) and the seventh trading day variable needs to be c removed. c----------------------------------------------------------------------- IF(Picktd)THEN IF(dpeq(Lam,ZERO))THEN IF(Priadj.gt.1)THEN IF(Kfulsm.lt.2)THEN IF(Priadj.eq.2)THEN WRITE(STDERR,1000)'Length-of-month','lom' WRITE(Mt2,1000)'Length-of-month','lom' ELSE IF(Priadj.eq.3)THEN WRITE(STDERR,1000)'Length-of-quarter','loq' WRITE(Mt2,1000)'Length-of-quarter','loq' ELSE IF(Priadj.eq.4)THEN WRITE(STDERR,1000)'Leap year','lpyear' WRITE(Mt2,1000)'Leap year','lpyear' END IF ELSE perstr='month ' iper=5 IF(Sp.eq.4)then perstr='quarter' iper=7 END IF IF(Priadj.eq.2)THEN WRITE(STDERR,1001)'Length-of-month',perstr(1:iper),'lom' WRITE(Mt2,1001)'Length-of-month',perstr(1:iper),'lom' ELSE IF(Priadj.eq.3)THEN WRITE(STDERR,1001)'Length-of-quarter',perstr(1:iper),'loq' WRITE(Mt2,1001)'Length-of-quarter',perstr(1:iper),'loq' ELSE IF(Priadj.eq.4)THEN WRITE(STDERR,1001)'Leap year',perstr(1:iper),'lpyear' WRITE(Mt2,1001)'Leap year',perstr(1:iper),'lpyear' END IF END IF Inptok=F ELSE CALL rmlnvr(Priadj,Kfulsm,Nspobs) IF(Lfatal)RETURN END IF ELSE IF(Priadj.gt.1)THEN IF(Kfulsm.lt.2)THEN IF(Priadj.eq.2)THEN WRITE(STDERR,1010)'Length-of-month','lom' WRITE(Mt2,1010)'Length-of-month','lom' ELSE IF(Priadj.eq.3)THEN WRITE(STDERR,1010)'Length-of-quarter','loq' WRITE(Mt2,1010)'Length-of-quarter','loq' ELSE IF(Priadj.eq.4)THEN WRITE(STDERR,1010)'Leap year','lpyear' WRITE(Mt2,1010)'Leap year','lpyear' END IF ELSE perstr='lom ' IF(Sp.eq.4)perstr='loq ' iper=3 IF(Priadj.eq.2)THEN WRITE(STDERR,1011)'Length-of-month',perstr(1:iper),'lom' WRITE(Mt2,1011)'Length-of-month',perstr(1:iper),'lom' ELSE IF(Priadj.eq.3)THEN WRITE(STDERR,1011)'Length-of-quarter',perstr(1:iper),'loq' WRITE(Mt2,1011)'Length-of-quarter',perstr(1:iper),'loq' ELSE IF(Priadj.eq.4)THEN WRITE(STDERR,1011)'Leap year',perstr(1:iper),'lpyear' WRITE(Mt2,1011)'Leap year',perstr(1:iper),'lpyear' END IF END IF Inptok=F ELSE IF(Kfulsm.eq.2)THEN CALL replyf() END IF END IF END IF c----------------------------------------------------------------------- c Check for lom in the regression and in the prior adjustment. c----------------------------------------------------------------------- IF(Priadj.gt.1.and.Nb.gt.0)THEN DO icol=1,Nb IF(Rgvrtp(icol).eq.PRGTLM.or.Rgvrtp(icol).eq.PRGTLQ.or. & Rgvrtp(icol).eq.PRGTLY.or.Rgvrtp(icol).eq.PRGTSL.or. & Rgvrtp(icol).eq.PRGULM.or.Rgvrtp(icol).eq.PRGULQ.or. & Rgvrtp(icol).eq.PRGULY)THEN WRITE(STDERR,1020) WRITE(Mt2,1020) Inptok=F GO TO 220 END IF END DO END IF c----------------------------------------------------------------------- c Compute the number of effective observations and initialize |G'G| c----------------------------------------------------------------------- 220 Lar=Lextar.and.Mxarlg.gt.0 Lma=Lextma.and.Mxmalg.gt.0 c----------------------------------------------------------------------- IF(Lextar)THEN Nintvl=Mxdflg Nextvl=Mxarlg+Mxmalg c----------------------------------------------------------------------- ELSE Nintvl=Mxdflg+Mxarlg c----------------------------------------------------------------------- Nextvl=0 IF(Lextma)Nextvl=Mxmalg END IF c----------------------------------------------------------------------- IF((.not.Hvmfil).and.Fixmdl.eq.0.AND.Lmodel)THEN IF(Iregfx.eq.3)Fixmdl=2 IF(Imdlfx.eq.3)Fixmdl=Fixmdl+1 END IF c----------------------------------------------------------------------- c If X-11 seasonal adjustment to be done, print a warning message c set number of forecasts dropped to zero c----------------------------------------------------------------------- IF(Lx11.and.Fctdrp.gt.0)THEN fhnote=STDERR IF(Lquiet)fhnote=0 CALL writln('WARNING: No observations should be excluded from fo &recasting when a',Mt2,fhnote,T) CALL writln(' seasonal adjustment is done.',Mt2,fhnote, & F) Fctdrp=0 END IF c----------------------------------------------------------------------- c If X-11 seasonal adjustment to be done, check to see if seasonal c period is either 4 or 12. If not, print error message. c----------------------------------------------------------------------- * IF((.NOT.(Sp.eq.4.or.Sp.eq.12.or.Sp.eq.24.or.Sp.eq.36)).and. * & Lx11)THEN * CALL writln('ERROR: Seasonal period must be 4, 12, 24 or 36 if * &a seasonal adjustment is done.',Mt2,STDERR,T) IF((.NOT.(Sp.eq.4.or.Sp.eq.12)).and.Lx11)THEN CALL writln('ERROR: Seasonal period must be 4 or 12 if a seasona &l adjustment is done.',Mt2,STDERR,T) Inptok=F RETURN END IF c----------------------------------------------------------------------- c Set ssotl=0 if outlier identification not performed c----------------------------------------------------------------------- * IF((.not.Ltstao).AND.(.not.Ltstls).AND.(.not.Ltsttc).AND. * & (.not.Ltstso))Ssotl=0 IF((.not.Ltstao).AND.(.not.Ltstls).AND.(.not.Ltsttc))Ssotl=0 c----------------------------------------------------------------------- c If backcasts not set, set number of backcasts equal to 0 c----------------------------------------------------------------------- IF(Nbcst.eq.NOTSET)Nbcst=0 c----------------------------------------------------------------------- c If seasonal adjustment and model estimation are to be done, reset c the number of forecasts to one year if a number of forecasts c hasn't been specified by the user. c----------------------------------------------------------------------- IF(Nfcst.eq.NOTSET)THEN IF(Lmodel)THEN IF(Lx11.or.Lseats)THEN IF(.not.Ldestm)Ldestm=T IF(Lseats)THEN Nfcst=MAX(12,3*Sp) ELSE Nfcst=Sp END IF ELSE IF(hvfcst)THEN Nfcst=Sp ELSE Nfcst=0 END IF ELSE c----------------------------------------------------------------------- c Else, set the number of forecasts equal to zero c----------------------------------------------------------------------- Nfcst=0 END IF END IF IF(Lseats.and.Mxcklg.eq.0)Mxcklg=3*Sp IF(Iagr.gt.0.and.Iagr.lt.3)X11agr=X11agr.and.Lx11 c----------------------------------------------------------------------- c If X-11 regression done, set # of forecasts for X-11 regressions c----------------------------------------------------------------------- IF(Ixreg.gt.0)THEN Nfcstx=Nfcst Nbcstx=Nbcst c----------------------------------------------------------------------- c Set number of X-11 forecasts to be at least one year c----------------------------------------------------------------------- IF(Nfcst.lt.Sp)Nfcstx=Sp END IF c----------------------------------------------------------------------- c Set up format for table saves c----------------------------------------------------------------------- IF(Svprec.lt.15)Svsize=Svprec+7 WRITE(Svfmt,1040)Svsize,Svprec 1040 FORMAT('(sp,e',i2.2,'.',i2.2,')') c----------------------------------------------------------------------- c Reset default prior adjustment factor mode to ratio if c multiplicative adjustment and format of prior factors = fsave c----------------------------------------------------------------------- IF(Muladd.ne.1.or.Fcntyp.eq.1)THEN DO i=1,Nprtyp IF(hvx12f(i).and.Percnt(i).eq.NOTSET)Percnt(i)=1 END DO END IF c----------------------------------------------------------------------- c If model estimated and irregular regression performed, set Ixreg c to indicate a prior adjustment. c----------------------------------------------------------------------- IF(Lmodel.and.Ixreg.eq.1)Ixreg=2 c----------------------------------------------------------------------- IF(Lmodel)THEN IF(outest.eq.NOTSET.and.outamd.eq.NOTSET)THEN Outfct=F Outfer=F ELSE IF(outest.eq.NOTSET)THEN Outfer=outamd.eq.1 Outfct=Outfer ELSE IF(outamd.eq.NOTSET)THEN Outfct=outest.eq.1 Outfer=Outfct ELSE Outfer=outamd.eq.1 Outfct=outest.eq.1 END IF IF(dpeq(Tcalfa,DNOTST))THEN IF(Sp.ge.4)THEN Tcalfa=0.7D0**(12D0/DBLE(Sp)) ELSE ntc=0 IF(Nb.gt.0)THEN DO i=1,Nb IF(Rgvrtp(i).eq.PRGTTC)ntc=ntc+1 END DO END IF IF(ntc.gt.0.or.Ltsttc)THEN CALL writln('ERROR: If the seasonal period is less than 4, th &e user must specify the ',Mt2,STDERR,T) CALL writln(' decay rate for TC outliers.',Mt2,STDERR, & F) Inptok=F RETURN END IF END IF END IF END IF c----------------------------------------------------------------------- Khol=Keastr IF((.NOT.(havhol.or.Axrghl.or.Axruhl.or.Khol.eq.1)).and.Finhol) & Finhol=F IF((.not.havreg))THEN Adjtd=0 Adjhol=0 Adjao=0 Adjls=0 Adjtc=0 Adjso=0 Adjsea=0 Adjcyc=0 Adjusr=0 ELSE IF((.not.Ldestm).and.Lx11)THEN IF(Adjtd.gt.0.or.Adjhol.gt.0.or.Adjao.gt.0.or.Adjls.gt.0.or. & Adjtc.gt.0.or.Adjso.gt.0.or.Adjsea.gt.0.or.Adjcyc.gt.0.or. & Adjusr.gt.0.OR.Finusr.or.Finao.or.Finls.or.Fintc.or. & ((.NOT.(Axrghl.or.Axruhl)).and.Finhol).or.Khol.eq.1)Ldestm=T END IF c----------------------------------------------------------------------- IF(Issap.eq.1.and.(.not.(Lx11.or.Lseats)))Lx11=T IF(.not.(Lx11.or.Lseats))THEN IF((Lrvsa.or.Lrvch.or.Lrvtrn.or.Lrvtch.or.Lrvsf).or. & (Issap.eq.1))Lx11=T IF(Iyrt.gt.0)THEN CALL writln('WARNING: Must specify either the x11 or seats spec & when the force spec is specified.',Mt2,STDERR,T) CALL writln(' Options from force spec ignored.',Mt2, & STDERR,F) Iyrt=0 END IF END IF c----------------------------------------------------------------------- IF(hvspec)THEN IF(.not.(Sp.eq.12))THEN CALL writln('WARNING: Spectrums are only generated for monthly &series.',Mt2,STDERR,T) * CALL writln(' Options from spectrum spec ignored.',Mt2, * & STDERR,F) END IF ELSE IF(Bgspec(YR).eq.NOTSET)THEN CALL addate(Endspn,Sp,-95,Bgspec) CALL dfdate(Bgspec,Begspn,Sp,nspec) IF(nspec.lt.0)CALL cpyint(Begspn,2,1,Bgspec) END IF IF(Peakwd.eq.NOTSET)THEN Peakwd=1 IF(Sp.eq.4)Peakwd=3 END IF END IF c----------------------------------------------------------------------- RETURN 210 CONTINUE END DO c----------------------------------------------------------------------- 1000 FORMAT(/,' ERROR: ',a,' prior adustment requested in ', & 'transform spec',/, & ' which conflicts with inclusion of leap year ', & 'prior adjustment implied ',/, & ' from variable=td in regression spec (with log ', & 'transformation). ',/, & ' Take out adjust=',a,' in the transform spec ', & 'or change td in the',/, & ' variables argument of the regression spec.',/) 1001 FORMAT(/,' ERROR: ',a,' prior adustment requested in transform ', & 'spec',/, & ' which conflicts with inclusion of length-of-',a, & ' prior adjustment',/, & ' implied from variable=td in regression spec ', & '(with log transformation',/, & ' and type=trend in x11 spec). Take out adjust=', & a,' in the transform',/, & ' spec or change td in the variables argument of', & ' the regression spec.') 1010 FORMAT(/,' ERROR: ',a,' prior adustment requested in transform', & ' spec',/, & ' which conflicts with inclusion of lpyear ', & 'regression variable from ',/, & ' variable=td in regression spec (with no ', & 'transformation). ',/, & ' Take out adjust=',a,' in the transform spec ', & 'or change td in the',/, & ' variables argument of the regression spec.',/) 1011 FORMAT(/,' ERROR: ',a,' prior adustment requested in', & 'transform spec',/, & ' which conflicts with inclusion of ',a, & 'regression variable from',/, & ' variable=td in regression spec (with no ', & 'transformation and',/, & ' type=trend in x11 spec). Take out adjust=',a, & ' in the transform spec or',/, & ' change td in the variables argument of the', & ' regression spec.',/) 1020 FORMAT(' ERROR: Cannot include a length-of-month type variable ', & 'as both a',/, & ' regression variable and a prior adjustment.',/, & ' Drop at least one from the model.',/) END gtinvl.f0000664006604000003110000001727414521201513011650 0ustar sun00315stepsC Last change: BCM 15 May 1998 1:11 pm SUBROUTINE gtinvl(Optype,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Add initial value to the ARIMA model c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER str*(LINLEN) LOGICAL argok,getdbl,hvcmma,Inptok,locok,opngrp INTEGER beglag,begopr,endlag,endopr,FIXVAL,ielt,ipos,nchr,Optype DOUBLE PRECISION tmp PARAMETER(FIXVAL=1) EXTERNAL getdbl c ------------------------------------------------------------------ CHARACTER FIXDIC*2 INTEGER fixidx,fixptr,PFIX PARAMETER(PFIX=2) DIMENSION fixptr(0:PFIX) PARAMETER(FIXDIC='fe') c ------------------------------------------------------------------ CHARACTER OPDIC*8 INTEGER opptr,POP PARAMETER(POP=3) DIMENSION opptr(0:POP) PARAMETER(OPDIC='diffarma') DATA opptr/1,5,7,9/ c----------------------------------------------------------------------- DATA fixptr/1,2,3/ c----------------------------------------------------------------------- c Find the lags to initialize c----------------------------------------------------------------------- begopr=Mdl(Optype-1) endopr=Mdl(Optype)-1 beglag=Opr(begopr-1) endlag=Opr(endopr)-1 ielt=beglag-1 c---------------------------------------------------------------------- locok=T hvcmma=F c ----------------------------------------------------------------- IF(Nxtktp.eq.EOF)THEN locok=F c----------------------------------------------------------------------- c Only a single value c----------------------------------------------------------------------- ELSE IF(getdbl(tmp))THEN ielt=ielt+1 Arimap(ielt)=tmp c ----------------------------------------------------------------- CALL gtdcnm(FIXDIC,fixptr,PFIX,fixidx,argok) IF(argok)Arimaf(ielt)=fixidx.eq.FIXVAL c----------------------------------------------------------------------- c Is a list. c----------------------------------------------------------------------- ELSE IF(Nxtktp.ne.LPAREN)THEN CALL inpter(PERROR,Lstpos, & 'Expected a real number or a list of real numbers, not "'// & Nxttok(1:Nxtkln)//'"') locok=F opngrp=F c ----------------------------------------------------------------- ELSE opngrp=T c ----------------------------------------------------------------- CALL lex() c---------------------------------------------------------------------- c Process the list of doubles c---------------------------------------------------------------------- DO WHILE (T) DO WHILE (T) IF(Nxtktp.ne.RPAREN)THEN c---------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,10.2, -8.3) c or (6,,10.2,-8.3). This section is repeated because there may be c multiple NULLs c---------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN IF(ielt.ge.endlag)THEN str='Number of initial values must equal sum of all the ' ipos=52 CALL getstr(OPDIC,opptr,POP,Optype,str(ipos:),nchr) IF(Lfatal)RETURN ipos=ipos+nchr str(ipos:)=' parameters in all the factors.' ipos=ipos+31 CALL inpter(PERROR,Errpos,str(1:ipos)) locok=F c ----------------------------------------------------------------- ELSE ielt=ielt+1 c Arimap(ielt)=PTONE END IF END IF c ----------------------------------------------------------------- CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c---------------------------------------------------------------------- c There is not a close group or comma here so there must be a real. c---------------------------------------------------------------------- IF(.not.(getdbl(tmp)))THEN CALL inpter(PERROR,Lstpos,'Expected an real number not "'// & Nxttok(1:Nxtkln)//'"') locok=F ELSE IF(ielt.ge.endlag)THEN str='Number of initial values must equal sum of all the ' ipos=52 CALL getstr(OPDIC,opptr,POP,Optype,str(ipos:),nchr) IF(Lfatal)RETURN ipos=ipos+nchr str(ipos:)=' parameters in all the factors.' ipos=ipos+31 CALL inpter(PERROR,Errpos,str(1:ipos)) locok=F c ----------------------------------------------------------------- ELSE ielt=ielt+1 Arimap(ielt)=tmp c----------------------------------------------------------------------- c Find out if the value is fixed or estimated. c----------------------------------------------------------------------- CALL gtdcnm(FIXDIC,fixptr,PFIX,fixidx,argok) IF(argok)Arimaf(ielt)=fixidx.eq.FIXVAL c ----------------------------------------------------------------- hvcmma=F opngrp=F GO TO 20 END IF c---------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. c---------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN IF(ielt.ge.endlag)THEN str='Number of initial values must equal sum of all the ' ipos=52 CALL getstr(OPDIC,opptr,POP,Optype,str(ipos:),nchr) IF(Lfatal)RETURN ipos=ipos+nchr str(ipos:)=' parameters in all the factors.' ipos=ipos+31 CALL inpter(PERROR,Errpos,str(1:ipos)) locok=F c ----------------------------------------------------------------- ELSE ielt=ielt+1 c Arimap(ielt)=PTONE END IF END IF c ----------------------------------------------------------------- IF(locok)THEN CALL lex() c ----------------------------------------------------------------- ELSE CALL skplst(RPAREN) END IF GO TO 30 10 CONTINUE END DO 20 CONTINUE END DO END IF c----------------------------------------------------------------------- c Allow empty lists ma=(), ielt=0 to be as if the argument has c not been called. c----------------------------------------------------------------------- 30 IF(ielt.gt.beglag-1.and.ielt.ne.endlag)THEN str='Number of initial values must equal sum of all the ' ipos=52 CALL getstr(OPDIC,opptr,POP,Optype,str(ipos:),nchr) IF(Lfatal)RETURN ipos=ipos+nchr str(ipos:)=' parameters in all the factors.' ipos=ipos+31 CALL inpter(PERROR,Errpos,str(1:ipos)) locok=F END IF c ----------------------------------------------------------------- Inptok=Inptok.and.locok c ----------------------------------------------------------------- RETURN END gtmdfl.f0000664006604000003110000001327714521201514011622 0ustar sun00315stepsC Last Change: March,2021,pass Endmdl into getreg.f in order to c allow AOSdate-0.0 or LOSdate-0.0 format C Last change: BCM 8 Dec 1998 4:04 pm SUBROUTINE gtmdfl(Mdlfil,Mtm,Begsrs,Endmdl,Nobs,Havsrs,Havesp, & Userx,Nrusrx,Bgusrx,Itdtst,Lmodel,Lestim,Havreg, & Leastr,Eastst,Luser,Elong,Havtca,Havhol,Rgaicd, & Lam,Fcntyp,Lomtst,Ch2tst,Chi2cv,Tlimit,Pvaic, & Lceaic,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c read regression and/or arima specs from saved model file c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'notset.prm' c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- DOUBLE PRECISION Userx,Rgaicd,Lam,Chi2cv,Tlimit,Pvaic CHARACTER Mdlfil*(PFILCR) LOGICAL Inptok,Havsrs,Havesp,Lmodel,Lestim,Havhol,Havreg,Leastr, & Ch2tst,Luser,Elong,Lceaic,Havtca INTEGER Begsrs,Endmdl,Nobs,Itdtst,Nrusrx,Bgusrx,nfil,Mtm,iflt, & begopr,endopr,iopr,beglag,endlag,begcol,endcol,ilag,icol, & Lomtst,Eastst,Fcntyp,igrp DIMENSION Begsrs(2),Bgusrx(2),Endmdl(2),Userx(*),Rgaicd(PAICT) c----------------------------------------------------------------------- INTEGER nblank,strinx LOGICAL getfcn,istrue EXTERNAL getfcn,nblank,istrue,strinx c----------------------------------------------------------------------- CHARACTER SPCDIC*15 INTEGER spcidx,spcptr,PMDSPC,spclog PARAMETER(PMDSPC=2) DIMENSION spcptr(0:PMDSPC),spclog(2,PMDSPC) PARAMETER(SPCDIC='regressionarima') DATA spcptr/1,11,16/ c----------------------------------------------------------------------- c Open model file c----------------------------------------------------------------------- nfil=nblank(Mdlfil) CALL fopen(Mdlfil(1:nfil),'saved model file','OLD',Mtm,Inptok) IF(.not.Inptok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Initialize parser input c----------------------------------------------------------------------- CALL intinp(Mtm) IF(Lfatal)RETURN CALL setint(NOTSET,2*PMDSPC,spclog) c----------------------------------------------------------------------- c Get the regression and ARIMA model. c----------------------------------------------------------------------- DO WHILE (T) IF(getfcn(SPCDIC,spcptr,PMDSPC,spcidx,spclog,Inptok))THEN GO TO(10,20),spcidx c ------------------------------------------------------------------ c Read Regression portion of model from saved file. c ------------------------------------------------------------------ 10 Iregfx=0 CALL getreg(Begsrs,Endmdl,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) IF(Lfatal)RETURN IF(.not.Lmodel)Lmodel=T IF(.not.Havreg)Havreg=T GO TO 30 c ------------------------------------------------------------------ c Read ARIMA portion of model from saved file. c ------------------------------------------------------------------ 20 Imdlfx=1 CALL gtarma(Inptok) IF(Lfatal)RETURN Lmodel=T GO TO 30 END IF c----------------------------------------------------------------------- c Set variables for fixing estimation according to value of Fixmdl c----------------------------------------------------------------------- c Lestim=F c IF(Fixmdl.eq.0)Lestim=T Lestim=T IF(Fixmdl.ge.0)THEN IF(Nb.eq.0)THEN Iregfx=0 ELSE Iregfx=1 IF(Fixmdl.ge.2)Iregfx=3 DO icol=1,Nb IF(Fixmdl.ge.2)THEN Regfx(icol)=T ELSE Regfx(icol)=F END IF END DO c ------------------------------------------------------------------ c set indicator variable for fixed user defined regressors. c ------------------------------------------------------------------ IF((.not.Userfx).and.Ncusrx.gt.0.and.Iregfx.ge.2)THEN IF(Iregfx.eq.3)THEN Userfx=T ELSE igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,'User-defined') begcol=Grp(igrp-1) endcol=Grp(igrp)-1 Userfx=istrue(Regfx,begcol,endcol) END IF END IF END IF Imdlfx=1 IF(MOD(Fixmdl,2).eq.1)Imdlfx=3 DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ DO ilag=beglag,endlag IF(MOD(Fixmdl,2).eq.1)THEN Arimaf(ilag)=T ELSE Arimaf(ilag)=F END IF END DO END DO END DO END IF RETURN 30 CONTINUE END DO END gtmtdt.f0000664006604000003110000001514714521201514011646 0ustar sun00315steps SUBROUTINE gtmtdt(Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Get user defined metadata for X-13ARIMA-SEATS diagnostic output. c---------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'metadata.prm' INCLUDE 'metadata.cmn' INCLUDE 'error.cmn' c---------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER ckey*(5),cval*(5),thisky*(LINLEN),thatky*(LINLEN) LOGICAL argok,Inptok INTEGER i,ikey,j,jkey,ival c ------------------------------------------------------------------ c metadata arguments data dictionary c ------------------------------------------------------------------ CHARACTER MDTDIC*10,ikeystr*10 INTEGER mdtidx,mdtptr,mdtlog,PMETA,ipos PARAMETER(PMETA=2) DIMENSION mdtptr(0:PMETA),mdtlog(2,PMETA) PARAMETER(MDTDIC='keysvalues') c ------------------------------------------------------------------ LOGICAL gtarg EXTERNAL gtarg c ------------------------------------------------------------------ DATA mdtptr/1,5,11/ c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- argok=T CALL setint(NOTSET,2*PMETA,mdtlog) c----------------------------------------------------------------------- DO WHILE (T) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- IF(gtarg(MDTDIC,mdtptr,PMETA,mdtidx,mdtlog,Inptok))THEN IF(Lfatal)RETURN GO TO(10,20),mdtidx c----------------------------------------------------------------------- c key argument c----------------------------------------------------------------------- 10 CALL getttl(LPAREN,T,PMTDAT,Keystr,Keyptr,Nkey,argok,Inptok) IF(Lfatal)RETURN GO TO 30 c----------------------------------------------------------------------- c value argument c----------------------------------------------------------------------- 20 CALL getttl(LPAREN,T,PMTDAT,Valstr,Valptr,Nval,argok,Inptok) IF(Lfatal)RETURN GO TO 30 c ------------------------------------------------------------------ END IF IF(Lfatal)RETURN IF(argok)Hvmtdt=T c ------------------------------------------------------------------ c Check to see if keys have any prohibited characters c ------------------------------------------------------------------ IF(Nkey.gt.0)THEN DO i=1,Nkey IF(argok)THEN CALL getstr(Keystr,Keyptr,Nkey,i,thisky,ikey) IF(Lfatal)RETURN ipos=index(thisky(1:ikey),' ') IF (ipos.gt.0) THEN CALL inpter(PERRNP,Pos, & 'Keys specified in metadata spec cannot contain spaces.') Hvmtdt=F argok=F END IF IF(argok)THEN ipos=index(thisky(1:ikey),':') IF (ipos.gt.0) THEN CALL inpter(PERRNP,Pos, & 'Keys specified in metadata spec cannot contain colons.') Hvmtdt=F argok=F END IF END IF END IF END DO END IF c ------------------------------------------------------------------ c if no keys specified, create a set of keys for the values using c the template 'keyn' c ------------------------------------------------------------------ IF(Nkey.eq.0.and.Nval.gt.0)THEN Keyptr(0)=1 DO i=1,Nval ikeystr(1:3)='key' ikey=4 CALL itoc(i,ikeystr,ikey) IF(Lfatal)RETURN CALL insstr(ikeystr(1:(ikey-1)),i,PMTDAT,Keystr,Keyptr,Nkey) END DO c ------------------------------------------------------------------ c if not enough keys specified, print out warning message and c create a set of keys for the values using the template 'keyn' c ------------------------------------------------------------------ ELSE IF(Nval.gt.Nkey)THEN ikey=1 CALL itoc(Nkey,ckey,ikey) IF(Lfatal)RETURN ival=1 CALL itoc(Nval,cval,ival) IF(Lfatal)RETURN CALL inpter(PWRNNP,Pos,'Fewer keys ('//ckey(1:(ikey-1))// & ') than values ('//cval(1:(ival-1))// & ') specified in metadata spec.') DO i=Nkey+1,Nval thisky(1:3)='key' ikey=4 CALL itoc(i,thisky,ikey) IF(Lfatal)RETURN CALL insstr(thisky(1:(ikey-1)),i,PMTDAT,Keystr,Keyptr,Nkey) END DO c ------------------------------------------------------------------ c if not enough values specified, print out an error message c ------------------------------------------------------------------ ELSE IF(Nval.lt.Nkey)THEN ikey=1 CALL itoc(Nkey,ckey,ikey) IF(Lfatal)RETURN ival=1 CALL itoc(Nval,cval,ival) IF(Lfatal)RETURN CALL inpter(PERRNP,Pos,'Fewer values ('//ckey(1:(ikey-1))// & ') than keys ('//cval(1:(ival-1))// & ') specified in metadata spec.') Hvmtdt=F argok=F c ------------------------------------------------------------------ ELSE IF(Nval.eq.0.and.Nkey.eq.0)THEN Hvmtdt=F c ------------------------------------------------------------------ END IF c ------------------------------------------------------------------ c Check if key values are unique c ------------------------------------------------------------------ IF(argok.and.Hvmtdt)THEN DO i=1,Nval-1 CALL getstr(Keystr,Keyptr,Nkey,i,thisky,ikey) IF(Lfatal)RETURN DO j=i+1,Nval CALL getstr(Keystr,Keyptr,Nkey,j,thatky,jkey) IF(Lfatal)RETURN IF(ikey.eq.jkey)THEN IF(thisky(1:ikey).eq.thatky(1:jkey))THEN CALL inpter(PERRNP,Pos,'Key values must be unique.') Hvmtdt=F argok=F END IF END IF END DO END DO END IF c ------------------------------------------------------------------ Inptok=Inptok.and.argok RETURN 30 CONTINUE END DO END gtmtfl.f0000664006604000003110000002405114521201514011632 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 11:15 am SUBROUTINE gtmtfl(Insrs,Outsrs,Datsrs,Mtafil,Ldata,Dtafil) IMPLICIT NONE C----------------------------------------------------------------------- c Process metafile. Get a list of the input filenames, and set c the output filenames. C----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' C----------------------------------------------------------------------- CHARACTER Insrs*(PFILCR),Outsrs*(PFILCR),Datsrs*(PFILCR),blnk*1, & mtalin*(PFILCR),Dtafil*(PFILCR),ext*4,Mtafil*(PFILCR), & quot*1 LOGICAL ok,Ldata INTEGER i,i2,meta,j,n,nmeta,nfil,ichr,nchr,n1,n2 DIMENSION Insrs(PSRS),Outsrs(PSRS),Datsrs(PSRS) C----------------------------------------------------------------------- INTEGER nblank,lstpth EXTERNAL nblank,lstpth c----------------------------------------------------------------------- blnk=' ' quot='"' meta=NOTSET ok=.true. C----------------------------------------------------------------------- c First, attempt to open metafile C----------------------------------------------------------------------- IF(Ldata)THEN nfil=nblank(Dtafil) IF(nfil.gt.3)THEN ext=Dtafil((nfil-3):nfil) IF((ext(1:2).eq.'.d'.or.ext(1:2).eq.'.D').and. & (ext(3:3).eq.'t'.or.ext(3:3).eq.'T').and. & (ext(4:4).eq.'a'.or.ext(4:4).eq.'A'))THEN WRITE(STDERR,1010)'data',ext ok=.false. END IF END IF IF(ok)THEN Mtafil=Dtafil(1:nfil)//'.dta' nfil=nfil+4 WRITE(STDOUT,1000) CALL fopen(Mtafil(1:nfil),'data metafile','OLD',meta,ok) END IF ELSE nfil=nblank(Infile) IF(nfil.gt.3)THEN ext=Infile((nfil-3):nfil) IF((ext(1:2).eq.'.m'.or.ext(1:2).eq.'.M').and. & (ext(3:3).eq.'t'.or.ext(3:3).eq.'T').and. & (ext(4:4).eq.'a'.or.ext(4:4).eq.'A'))THEN WRITE(STDERR,1010)'input',ext ok=.false. END IF END IF IF(ok)THEN Mtafil=Infile(1:nfil)//'.mta' nfil=nfil+4 WRITE(STDOUT,1000) CALL fopen(Mtafil(1:nfil),'input metafile','OLD',meta,ok) END IF END IF IF(.not.ok)THEN CALL abend RETURN END IF C----------------------------------------------------------------------- c Read each line of the metafile C----------------------------------------------------------------------- Imeta=0 DO WHILE (.true.) READ(meta,'(a)',END=10,ERR=20)mtalin nmeta=nblank(mtalin) IF(Imeta.lt.PSRS)THEN Imeta=Imeta+1 ELSE IF(nmeta.gt.0)THEN IF(Ldata)THEN WRITE(STDERR,1040)PSRS ELSE WRITE(STDERR,1050)PSRS END IF GO TO 10 END IF END IF Outsrs(Imeta)=blnk C----------------------------------------------------------------------- c If this is a blank line (line of length zero), decrement the c series counter and process the next line. C----------------------------------------------------------------------- IF(nmeta.eq.0)THEN Imeta=Imeta-1 ELSE C----------------------------------------------------------------------- c If the first character of the line is a quotation mark, c Find the next quotation mark. c November 2005 - BCM C----------------------------------------------------------------------- IF(mtalin(1:1).eq.quot)THEN i=2 DO WHILE (mtalin(i:i).ne.quot.and.i.le.nmeta) i=i+1 END DO IF (i.eq.nmeta.and.mtalin(nmeta:nmeta).ne.quot)THEN IF(Ldata)THEN WRITE(STDERR,1021)'data',Mtafil(1:nfil) ELSE WRITE(STDERR,1021)'input',Mtafil(1:nfil) END IF CALL abend RETURN END IF C----------------------------------------------------------------------- c Set the length of the first string. C----------------------------------------------------------------------- n=i n1=2 n2=n-1 ELSE C----------------------------------------------------------------------- c Find the first blank or not set character C----------------------------------------------------------------------- i=1 DO WHILE (mtalin(i:i).ne.blnk.and.i.le.nmeta) i=i+1 END DO C----------------------------------------------------------------------- c If the first character of a line is a blank character, print an c error message C----------------------------------------------------------------------- IF(i.eq.1)THEN IF(Ldata)THEN WRITE(STDERR,1020)' data',Mtafil(1:nfil) ELSE WRITE(STDERR,1020)'n input',Mtafil(1:nfil) END IF CALL abend RETURN END IF C----------------------------------------------------------------------- c Set the length of the first string. C----------------------------------------------------------------------- n=i-1 n1=1 n2=n END IF C----------------------------------------------------------------------- c If this is an input metafile, store the series name in the c variable series. Else, store as an element of Dtasrs C----------------------------------------------------------------------- IF(Ldata)THEN Datsrs(Imeta)=mtalin(n1:n2) Insrs(Imeta)=Infile ELSE Insrs(Imeta)=mtalin(n1:n2) END IF C----------------------------------------------------------------------- c Is the end of the first string the end of the line? If so, c set output names. C----------------------------------------------------------------------- IF(nmeta.eq.n)THEN c ------------------------------------------------------------------ c If data metafile is used, get the path and filename from the c datafile to use as the output file name. c ------------------------------------------------------------------ IF(Ldata)THEN ichr=lstpth(mtalin,n)+1 DO i2=n2,ichr,-1 IF(mtalin(i2:i2).eq.'.')THEN nchr=i2-1 GO TO 30 END IF END DO nchr=n2 30 Outsrs(Imeta)=mtalin(n1:nchr) ELSE c ------------------------------------------------------------------ c If an input metafile is used, set the output file to be the same c as the spec file. c ------------------------------------------------------------------ Outsrs(Imeta)=mtalin(n1:n2) END IF C----------------------------------------------------------------------- c If not, find the position of the next non-blank character C----------------------------------------------------------------------- ELSE IF(mtalin(i:i).eq.quot)i=i+1 DO WHILE (mtalin(i:i).eq.blnk) i=i+1 END DO C----------------------------------------------------------------------- C Check to see if there are any more blanks in the line C----------------------------------------------------------------------- j=i IF(mtalin(j:j).eq.quot)THEN j=j+1 DO WHILE (mtalin(j:j).ne.quot.and.j.le.nmeta) j=j+1 END DO IF (i.eq.nmeta.and.mtalin(nmeta:nmeta).ne.quot)THEN IF(Ldata)THEN WRITE(STDERR,1021)'data',Mtafil(1:nfil) ELSE WRITE(STDERR,1021)'input',Mtafil(1:nfil) END IF CALL abend RETURN END IF C----------------------------------------------------------------------- c Store the output file name in the array Outsrs C----------------------------------------------------------------------- Outsrs(Imeta)=mtalin((i+1):(j-1)) ELSE C----------------------------------------------------------------------- DO WHILE (mtalin(j:j).ne.blnk.and.j.le.nmeta) j=j+1 END DO C----------------------------------------------------------------------- c Store the output file name in the array Outsrs C----------------------------------------------------------------------- Outsrs(Imeta)=mtalin(i:(j-1)) END IF END IF END IF END DO C----------------------------------------------------------------------- c Close metafile and return to main driver C----------------------------------------------------------------------- 10 CALL fclose(meta) RETURN C----------------------------------------------------------------------- c print error message for read error C----------------------------------------------------------------------- 20 IF(Ldata)THEN WRITE(STDERR,1030)'a data ',Mtafil(1:nfil) ELSE WRITE(STDERR,1030)'an input ',Mtafil(1:nfil) END IF CALL abend RETURN C----------------------------------------------------------------------- 1000 FORMAT(' ') 1010 FORMAT(/,' ERROR: Enter ',a,' metafile name without "',a, & '" file extension.') 1020 FORMAT(/,' ERROR: The first entry in each line of a',a, & ' metafile must be left ', & /,' justified. Correct the metafile and rerun ',a, & '.') 1021 FORMAT(/,' ERROR: Closing quotation mark not found in this ',a, & ' metafile.', & /,' Correct the metafile and rerun ',a,'.') 1030 FORMAT(/,' ERROR: Read error encountered in ',a,'metafile ',a,'.') 1040 FORMAT(' WARNING: Number of series in data metafile exceeds ', & 'program limit.',/ & ' Only the first ',i5,' series will be processed.') 1050 FORMAT(' WARNING: Number of spec files in metafile exceeds ', & 'program limit.',/ & ' Only the first ',i5,' series will be processed.') END gtnmvc.f0000664006604000003110000001622314521201514011635 0ustar sun00315stepsC Last change: BCM 23 Jul 1998 3:38 pm SUBROUTINE gtnmvc(Grpchr,Flgnul,Pelt,Chrvec,Ptrvec,Nelt,Eltlen, & Locok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gtnmvc.f, Release 1, Subroutine Version 1.7, Modified 14 Feb 1995. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER Chrvec*(*),str*(LINLEN),str1*(5) LOGICAL Flgnul,hvcmma,Inptok,Locok,opngrp INTEGER clsgtp,clsgrp,Grpchr,ipos,Nelt,Pelt,Ptrvec,Eltlen,nstr1 DIMENSION Ptrvec(0:Pelt) EXTERNAL clsgrp c ------------------------------------------------------------------ Locok=T CALL intlst(Pelt,Ptrvec,Nelt) c ------------------------------------------------------------------ IF(Nxtktp.eq.EOF)THEN Locok=F c----------------------------------------------------------------------- c Get just one name or quote c----------------------------------------------------------------------- ELSE IF(Nxtktp.eq.NAME.or.Nxtktp.eq.QUOTE)THEN IF(Nxtkln.eq.0)THEN IF(Nxtktp.eq.NAME) & CALL inpter(PERROR,Lstpos,'Expected a NAME, QUOTE, or '// & 'list of either, not an empty string.') Locok=F ELSE IF(Pelt.eq.1.and.Nxtkln.gt.len(Chrvec))THEN nstr1=1 CALL itoc(len(Chrvec),str1,nstr1) CALL inpter(PERROR,Lstpos, & 'Values for this argument cannot be longer than '// & str1(1:nstr1-1)//' characters.') Locok=F ELSE CALL putstr(Nxttok(1:Nxtkln),Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF END IF CALL lex() c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.Grpchr)THEN CALL inpter(PERROR,Lstpos, & 'Expected a NAME or a QUOTE or a list of either, not "'// & Nxttok(1:Nxtkln)//'"') Locok=F opngrp=F CALL lex() c----------------------------------------------------------------------- c Get a list of names or quotes c----------------------------------------------------------------------- ELSE opngrp=T hvcmma=F clsgtp=clsgrp(Grpchr) DO WHILE (T) c ------------------------------------------------------------------ CALL lex() c ------------------------------------------------------------------ IF(Nxtktp.ne.clsgtp)THEN c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,td,lom) c or (const,,td,lom). This section is repeated because there may be c multiple NULLs c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) IF(Lfatal)RETURN str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE CALL putstr(CNOTST,Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c There is not a close group or comma here so there must be a NAME c or a QUOTE. c----------------------------------------------------------------------- IF(Nxtktp.ne.NAME.and.Nxtktp.ne.QUOTE)THEN CALL inpter(PERROR,Lstpos,'Expected a NAME or QUOTE not "'// & Nxttok(1:Nxtkln)//'"') Locok=F ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE IF(Nxtkln.eq.0)THEN IF(Nxtktp.eq.NAME) & CALL inpter(PERROR,Lstpos,'Expected a NAME, QUOTE, or '// & 'list of either, not an empty string.') Locok=F c ------------------------------------------------------------------ ELSE IF(Pelt.gt.1.and.Nxtkln.gt.Eltlen)THEN nstr1=1 CALL itoc(Eltlen,str1,nstr1) CALL inpter(PERROR,Lstpos, & 'Values for this argument cannot be longer than '// & str1(1:nstr1-1)//' characters.') Locok=F ELSE CALL putstr(Nxttok(1:Nxtkln),Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF hvcmma=F opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c Check for a NULL after the last element but before the close of c the list. This indicates a NULL value, for example, (td,lom,). c These default values may exceed the length of the list. c----------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN IF(Flgnul)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F c ------------------------------------------------------------------ ELSE IF(Nelt.ge.Pelt)THEN str='List of names exceeds ' ipos=23 CALL itoc(Pelt,str,ipos) str(ipos:)=', the maximum number of elements.' ipos=ipos+33 CALL inpter(PERROR,Lstpos,str(1:ipos-1)) Locok=F c ------------------------------------------------------------------ ELSE CALL putstr(CNOTST,Pelt,Chrvec,Ptrvec,Nelt) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ IF(Locok)THEN CALL lex() ELSE CALL skplst(clsgtp) END IF GO TO 20 10 CONTINUE END DO c ------------------------------------------------------------------ END IF 20 Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END gtotlr.f0000664006604000003110000003071714521201514011656 0ustar sun00315stepsC Last change: BCM 16 Jul 2003 5:26 pm SUBROUTINE gtotlr(Begsrs,Nobs,Begmdl,Endmdl,Sp,Ltstao,Ltstls, * & Ltsttc,Ltstso,Ladd1,Critvl,Begtst,Endtst,Lsrun, & Ltsttc,Ladd1,Critvl,Begtst,Endtst,Lsrun, & Tcalfa,Havtca,Cvalfa,Cvtype,Cvrduc,Locok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'svllog.i' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE,PTONE INTEGER YR,PNOTL LOGICAL F,T * PARAMETER(YR=1,PNOTL=4,F=.false.,T=.true.,ZERO=0D0,ONE=1D0, PARAMETER(YR=1,PNOTL=3,F=.false.,T=.true.,ZERO=0D0,ONE=1D0, & PTONE=0.1D0) c----------------------------------------------------------------------- * LOGICAL Ladd1,argok,Inptok,Locok,Ltstao,Ltstls,Ltsttc,Ltstso, LOGICAL Ladd1,argok,Inptok,Locok,Ltstao,Ltstls,Ltsttc, & Havtca,Cvtype INTEGER Begmdl,Begsrs,Begtst,Endmdl,Endtst,ielt,Lsrun,nelt,Nobs, & Sp,spnvec,nmdl,ivec DOUBLE PRECISION Critvl,critmp,dvec,Tcalfa,Cvalfa,Cvrduc DIMENSION Begmdl(2),Begsrs(2),Begtst(2),Endmdl(2),Endtst(2), & spnvec(2,2),Critvl(PNOTL),critmp(PNOTL), & ivec(1),dvec(1) c----------------------------------------------------------------------- LOGICAL chkcvr,gtarg,dpeq EXTERNAL chkcvr,gtarg,dpeq c----------------------------------------------------------------------- c Argument dictionary was made with the following command c ../../dictionary/strary < ../../dictionary/outlier.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*84 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=12) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='typesmethodcriticallsrunspanprintsavetcratecriti &calalphadefaultcriticalalmostsavelog') c----------------------------------------------------------------------- c Identification method dictionary was made with the following c command, c ../../dictionary/strary mtd < ../../dictionary/outlier.method.dic c----------------------------------------------------------------------- CHARACTER MTDDIC*12 INTEGER mtdptr,PMTD PARAMETER(PMTD=2) DIMENSION mtdptr(0:PMTD) PARAMETER(MTDDIC='addoneaddall') c----------------------------------------------------------------------- c Outlier types dictionary was made with the following command, c ../../dictionary/strary typ < ../../dictionary/outlier.types.dic c----------------------------------------------------------------------- * CHARACTER TYPDIC*15 CHARACTER TYPDIC*13 INTEGER typptr,PTYP,typidx * PARAMETER(PTYP=6) PARAMETER(PTYP=5) DIMENSION typptr(0:PTYP),typidx(PTYP) * PARAMETER(TYPDIC='noneaolstcsoall') PARAMETER(TYPDIC='noneaolstcall') c----------------------------------------------------------------------- c default critical value types dictionary c----------------------------------------------------------------------- CHARACTER DEFDIC*14 INTEGER defptr,PDEF PARAMETER(PDEF=2) DIMENSION defptr(0:PDEF) PARAMETER(DEFDIC='ljungcorrected') c----------------------------------------------------------------------- DATA argptr/1,6,12,20,25,29,34,38,44,57,72,78,85/ DATA mtdptr/1,7,13/ * DATA typptr/1,5,7,9,11,13,16/ DATA typptr/1,5,7,9,11,14/ DATA defptr/1,6,15/ c----------------------------------------------------------------------- c Just by asking for outlier identification w/o any arguments c will give identification. Initialize the test period too. c----------------------------------------------------------------------- Locok=T Ltstao=T Ltstls=T Ltsttc=F * Ltstso=F CALL setdp(DNOTST,PNOTL,critmp) CALL setint(NOTSET,2*PARG,arglog) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- DO WHILE (T) IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,Locok))THEN IF(Lfatal)RETURN GO TO(10,20,30,40,50,60,70,80,90,100,110,120),argidx c----------------------------------------------------------------------- c Argument to specify types of outliers to identify c----------------------------------------------------------------------- 10 CALL gtdcvc(LPAREN,T,PTYP,TYPDIC,typptr,PTYP, & 'Choices of outlier types to identify are NONE, '// & 'AO, LS, TC, and ALL',typidx,nelt,argok,Locok) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(nelt.gt.0)THEN Ltstao=F Ltstls=F Ltsttc=F * Ltstso=F DO ielt=1,nelt IF(typidx(ielt).eq.1)THEN Ltstao=F Ltstls=F Ltsttc=F * Ltstso=F ELSE IF(typidx(ielt).eq.2)THEN Ltstao=T ELSE IF(typidx(ielt).eq.3)THEN Ltstls=T ELSE IF(typidx(ielt).eq.4)THEN Ltsttc=T ELSE IF(typidx(ielt).eq.5)THEN * Ltstso=T * ELSE IF(typidx(ielt).eq.6)THEN Ltstao=T Ltstls=T IF(Sp.ge.4)Ltsttc=T * IF(Sp.eq.4.or.Sp.eq.12)Ltstso=T END IF END DO END IF GO TO 130 c----------------------------------------------------------------------- c Identification method specification c----------------------------------------------------------------------- 20 CALL gtdcvc(LPAREN,T,1,MTDDIC,mtdptr,PMTD, & 'Choices are ADDONE or ADDALL',ivec,nelt,argok, & Locok) IF(Lfatal)RETURN c---------------------------------------------------------------------- IF(nelt.gt.0.and.argok)Ladd1=ivec(1).eq.1 GO TO 130 c----------------------------------------------------------------------- c Critical t value specification c----------------------------------------------------------------------- 30 CALL gtdpvc(LPAREN,F,PNOTL,critmp,nelt,argok,Locok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN DO ielt=1,PNOTL Critvl(ielt)=critmp(1) END DO ELSE IF(nelt.gt.0)THEN DO ielt=1,PNOTL IF(.not.dpeq(critmp(ielt),DNOTST))Critvl(ielt)=critmp(ielt) END DO END IF GO TO 130 c----------------------------------------------------------------------- c Lsrun, maximum number of ls's to test for c----------------------------------------------------------------------- 40 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Locok) IF(nelt.gt.0.and.ivec(1).gt.7)THEN CALL inpter(PERROR,Errpos,'Lsrun must be less than or equal '// & 'to seven.') Locok=F ELSE Lsrun=ivec(1) END IF GO TO 130 c----------------------------------------------------------------------- c Span argument c----------------------------------------------------------------------- 50 CALL gtdtvc(T,Sp,LPAREN,F,2,spnvec,nelt,argok,Locok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos, & 'Need two dates for the span or use a comma as a place holder.' & ) Locok=F END IF c----------------------------------------------------------------------- c set span for outlier test c----------------------------------------------------------------------- IF(Locok) THEN IF(spnvec(YR,1).eq.NOTSET)THEN CALL cpyint(Begmdl,2,1,Begtst) ELSE CALL cpyint(spnvec,2,1,Begtst) END IF IF(spnvec(YR,2).eq.NOTSET)THEN CALL cpyint(Endmdl,2,1,Endtst) ELSE CALL cpyint(spnvec(1,2),2,1,Endtst) END IF c---------------------------------------------------------------------- c Check that the span is within the series c---------------------------------------------------------------------- CALL dfdate(Endtst,Begtst,Sp,nelt) nelt=nelt+1 CALL dfdate(Endmdl,Begmdl,Sp,nmdl) nmdl=nmdl+1 IF(.not.chkcvr(Begsrs,Nobs,Begtst,nelt,Sp))THEN CALL inpter(PERROR,Errpos,'Span not within the series') CALL cvrerr('Series',Begsrs,Nobs,'outlier test span',Begtst, & nelt,Sp) Locok=F ELSE IF(.not.chkcvr(Begmdl,nmdl,Begtst,nelt,Sp))THEN CALL inpter(PERROR,Errpos,'Span not within the model span') CALL cvrerr('Model span',Begmdl,nmdl,'outlier test span', & Begtst,nelt,Sp) Locok=F END IF IF(Lfatal)RETURN END IF GO TO 130 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 60 CALL getprt(LSPOTL,NSPOTL,Locok) GO TO 130 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 70 CALL getsav(LSPOTL,NSPOTL,Locok) GO TO 130 c----------------------------------------------------------------------- c tcrate - alpha value for all TC outliers c----------------------------------------------------------------------- 80 IF(Havtca)THEN CALL inpter(PERROR,Errpos,'Cannot specify tcrate in both '// & 'the regression 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 130 c----------------------------------------------------------------------- c criticalalpha - alpha value for outlier critical value c----------------------------------------------------------------------- 90 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).gt.PTONE)THEN CALL inpter(PERROR,Errpos, & 'Value of criticalalpha must be between 0 and 0.10.') Inptok=F ELSE Cvalfa=dvec(1) END IF END IF GO TO 130 c----------------------------------------------------------------------- c Default critical value generation method specification c----------------------------------------------------------------------- 100 CALL gtdcvc(LPAREN,T,1,DEFDIC,defptr,PDEF, & 'Choices are ljung or corrected',ivec,nelt,argok, & Locok) IF(Lfatal)RETURN c---------------------------------------------------------------------- IF(nelt.gt.0.and.argok)Cvtype=ivec(1).eq.1 GO TO 130 c----------------------------------------------------------------------- c almost - amount to reduce outlier critical value to identify c "almost" outliers c----------------------------------------------------------------------- 110 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Value of almost must be greater than 0.') Inptok=F ELSE Cvrduc=dvec(1) END IF END IF GO TO 130 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 120 CALL getsvl(LSLOTL,NSLOTL,Inptok) GO TO 130 END IF IF(Lfatal)RETURN c---------------------------------------------------------------------- Inptok=Locok.and.Inptok RETURN 130 CONTINUE END DO c---------------------------------------------------------------------- END gtpdrg.f0000664006604000003110000001136614521201514011631 0ustar sun00315stepsc Add Endmdl as argument to getreg, gtpdrg for a new format of the c end of the series for sequence outliers such as c AOSdate-0.0/LSSdate-0.0, March, 2021 C Last change: BCM 12 May 1998 11:19 am **==gtpdrg.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE gtpdrg(Begsrs,Endmdl,Nobs,Havsrs,Havesp,X11reg,Havtd, & Havhol,Havln,Havlp,Locok,Inptok) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'lex.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ LOGICAL argok,Havesp,Havsrs,hvcmma,Inptok,Locok,opngrp,X11reg, & Havtd,Havhol,Havln,Havlp INTEGER Begsrs,Endmdl,Nobs DIMENSION Begsrs(2),Endmdl(2) c----------------------------------------------------------------------- c Assume the input is OK and we don't have any of the arguments c----------------------------------------------------------------------- Locok=T c ----------------------------------------------------------------- IF(Nxtktp.ne.EOF)THEN c ----------------------------------------------------------------- IF(Nxtktp.eq.NAME.or.Nxtktp.eq.QUOTE)THEN CALL adpdrg(Begsrs,Endmdl,Nobs,Havsrs,Havesp,Nxttok,Nxtkln, & X11reg,Havtd,Havhol,Havln,Havlp,argok,Locok) IF(Lfatal)RETURN c ----------------------------------------------------------------- ELSE IF(Nxtktp.ne.LPAREN)THEN CALL inpter(PERROR,Lstpos, & 'Expected regression variable name or "(" but found "' & //Nxttok(1:Nxtkln)//'"') CALL lex() Locok=F c----------------------------------------------------------------------- c Get the list of regression variables c----------------------------------------------------------------------- ELSE hvcmma=F opngrp=T CALL lex() c ----------------------------------------------------------------- DO WHILE (T) DO WHILE (T) IF(Nxtktp.ne.RPAREN.and.Nxtktp.ne.EOF)THEN c---------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,td,lom) c or (const,,td,lom). This section is repeated because there may be c multiple NULLs c---------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN IF(hvcmma.or.opngrp)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F END IF c ----------------------------------------------------------------- CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c There is not a close group or comma here so there must be a NAME c or a QUOTE. c----------------------------------------------------------------------- IF(Nxtktp.ne.NAME.and.Nxtktp.ne.QUOTE)THEN CALL inpter(PERROR,Lstpos, & 'Expected regression variable name or ")" but found "' & //Nxttok(1:Nxtkln)//'"') Locok=F CALL skplst(RPAREN) c ------------------------------------------------------------------ ELSE CALL adpdrg(Begsrs,Endmdl,Nobs,Havsrs,Havesp,Nxttok,Nxtkln, & X11reg,Havtd,Havhol,Havln,Havlp,argok,Locok) IF(Lfatal)RETURN hvcmma=F opngrp=F GO TO 20 END IF c----------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,td,lom) c or (const,,td,lom). This section is repeated because there may be c multiple NULLs c----------------------------------------------------------------------- ELSE IF(hvcmma)THEN CALL inpter(PERROR,Lstpos, & 'Found a NULL value; check your commas.') Locok=F END IF c ------------------------------------------------------------------ CALL lex() GO TO 30 10 CONTINUE END DO 20 CONTINUE END DO END IF END IF c----------------------------------------------------------------------- c Overall error checks c----------------------------------------------------------------------- 30 Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END gtrgdt.f0000664006604000003110000000446114521201514011633 0ustar sun00315stepsC Last change: BCM 28 Sep 1998 8:54 am SUBROUTINE gtrgdt(Havesp,Sp,Regdat,Zeroz,Locok,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c gets the date for a change of regime regressor c----------------------------------------------------------------------- INCLUDE 'lex.i' c ------------------------------------------------------------------ LOGICAL F,T PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------ LOGICAL argok,Havesp,Inptok,Locok INTEGER Regdat,Sp,Zeroz DIMENSION Regdat(2) c ------------------------------------------------------------------ Locok=T Zeroz=0 c ------------------------------------------------------------------ IF(Nxtktp.eq.EOF)THEN Locok=F c ------------------------------------------------------------------ ELSE c ------------------------------------------------------------------ c IF double slash found at beginning, get the next character and c set Zeroz to indicate zeros before the regime date. c ------------------------------------------------------------------ CALL lex() IF(Nxtktp.eq.SLASH)THEN Zeroz=-1 CALL lex() END IF c ------------------------------------------------------------------ c Get regime date. c ------------------------------------------------------------------ CALL getdat(Havesp,Sp,Regdat,argok,Locok) IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Expected a date not "'// & Nxttok(1:Nxtkln)//'"') Locok=F ELSE c ------------------------------------------------------------------ c IF double slash found at end, get the next character and set Zeroz c to indicate zeros after the regime date. c ------------------------------------------------------------------ CALL lex() IF(Nxtktp.eq.SLASH)THEN Zeroz=1-Zeroz CALL lex() END IF END IF c ------------------------------------------------------------------ END IF Inptok=Inptok.and.Locok c ------------------------------------------------------------------ RETURN END gtrgpt.f0000664006604000003110000000314514521201514011645 0ustar sun00315stepsC Last change: BCM 28 Sep 1998 8:55 am SUBROUTINE gtrgpt(Begdat,Rgdate,Rgzero,Rgdtvc,Nobs) IMPLICIT NONE c----------------------------------------------------------------------- c Generate a pointer to the change of regime date of a change-of- c regime regressor c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' c----------------------------------------------------------------------- LOGICAL Rgdtvc INTEGER Begdat,i,Nobs,Rgzero,rgmidx,Rgdate DIMENSION Begdat(2),Rgdate(2),Rgdtvc(PLEN) c----------------------------------------------------------------------- CALL setlg(F,PLEN,Rgdtvc) CALL dfdate(Rgdate,Begdat,Sp,rgmidx) rgmidx=rgmidx+1 c----------------------------------------------------------------------- IF(Rgzero.eq.1)THEN c----------------------------------------------------------------------- IF(rgmidx.gt.0)THEN DO i=1,rgmidx-1 IF(.not.Rgdtvc(i))Rgdtvc(i)=T END DO END IF ELSE c----------------------------------------------------------------------- IF(rgmidx.le.0)rgmidx=1 c----------------------------------------------------------------------- DO i=rgmidx,Nobs IF(.not.Rgdtvc(i))Rgdtvc(i)=T END DO END IF c----------------------------------------------------------------------- RETURN END gtrgvl.f0000664006604000003110000001345414521201514011647 0ustar sun00315stepsC Last change: BCM 1 Dec 1998 10:23 am SUBROUTINE gtrgvl(Ielt,Fixvec,Bvec,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Add initial value of the regression coefficients to the regARIMA c model c----------------------------------------------------------------------- INCLUDE 'lex.i' c INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' c INCLUDE 'model.cmn' c INCLUDE 'mdldat.cmn' c INCLUDE 'usrreg.cmn' c INCLUDE 'units.cmn' c INCLUDE 'error.cmn' c ------------------------------------------------------------------ c DOUBLE PRECISION ONE INTEGER FIXVAL LOGICAL T,F PARAMETER(T=.true.,F=.FALSE.,FIXVAL=1) c PARAMETER(ONE=1D0,T=.true.,F=.FALSE.,FIXVAL=1) c ------------------------------------------------------------------ DOUBLE PRECISION Bvec,tmp LOGICAL argok,Fixvec,hvcmma,Inptok,locok,opngrp INTEGER Ielt DIMENSION Bvec(PB),Fixvec(PB) c----------------------------------------------------------------------- c DOUBLE PRECISION Lam c INTEGER Fcntyp c COMMON /armalm/ Lam,Fcntyp c ------------------------------------------------------------------ LOGICAL getdbl,dpeq INTEGER strinx EXTERNAL dpeq,getdbl,strinx c ------------------------------------------------------------------ CHARACTER FIXDIC*2 INTEGER fixidx,fixptr,PFIX PARAMETER(PFIX=2) DIMENSION fixptr(0:PFIX) PARAMETER(FIXDIC='fe') c ------------------------------------------------------------------ DATA fixptr/1,2,3/ c----------------------------------------------------------------------- c Find the lags to initialize c----------------------------------------------------------------------- ielt=0 c----------------------------------------------------------------------- locok=T hvcmma=F c ------------------------------------------------------------------ IF(Nxtktp.eq.EOF)THEN locok=F c----------------------------------------------------------------------- c Only a single value c----------------------------------------------------------------------- ELSE IF(getdbl(tmp))THEN ielt=ielt+1 Bvec(ielt)=tmp c ------------------------------------------------------------------ CALL gtdcnm(FIXDIC,fixptr,PFIX,fixidx,argok) IF(argok)Fixvec(ielt)=fixidx.eq.FIXVAL c----------------------------------------------------------------------- c Is a list. c----------------------------------------------------------------------- ELSE IF(Nxtktp.ne.LPAREN)THEN CALL inpter(PERROR,Lstpos, & 'Expected a real number or a list of real numbers, not "'// & Nxttok(1:Nxtkln)//'"') locok=F opngrp=F c ----------------------------------------------------------------- ELSE opngrp=T c ----------------------------------------------------------------- CALL lex() c---------------------------------------------------------------------- c Process the list of doubles c---------------------------------------------------------------------- DO WHILE (T) DO WHILE (T) IF(Nxtktp.ne.RPAREN)THEN c---------------------------------------------------------------------- c Check for a NULL in the first place, for example, (,10.2, -8.3) c or (6,,10.2,-8.3). This section is repeated because there may be c multiple NULLs c----------------------------------------------------------------------- IF(Nxtktp.eq.COMMA)THEN c ------------------------------------------------------------------ IF(hvcmma.or.opngrp)THEN ielt=ielt+1 c Bvec(ielt)=PTONE END IF c ------------------------------------------------------------------ CALL lex() hvcmma=T opngrp=F GO TO 10 END IF c----------------------------------------------------------------------- c There is not a close group or comma here so there must be a real. c----------------------------------------------------------------------- IF(.not.(getdbl(tmp)))THEN CALL inpter(PERROR,Lstpos,'Expected an real number not "'// & Nxttok(1:Nxtkln)//'"') locok=F ELSE ielt=ielt+1 Bvec(ielt)=tmp c----------------------------------------------------------------------- c Find out if the value is fixed or estimated. c----------------------------------------------------------------------- CALL gtdcnm(FIXDIC,fixptr,PFIX,fixidx,argok) IF(argok)Fixvec(ielt)=fixidx.eq.FIXVAL c ------------------------------------------------------------------ hvcmma=F opngrp=F GO TO 20 END IF c----------------------------------------------------------------------- c Check for a comma after the last element and before the close of c the list. c----------------------------------------------------------------------- ELSE IF(hvcmma.and..not.opngrp)THEN ielt=ielt+1 c Bvec(ielt)=PTONE END IF c ------------------------------------------------------------------ IF(locok)THEN CALL lex() c ------------------------------------------------------------------ ELSE CALL skplst(RPAREN) END IF GO TO 30 10 CONTINUE END DO 20 CONTINUE END DO END IF c----------------------------------------------------------------------- 30 Inptok=Inptok.and.locok c ------------------------------------------------------------------ RETURN END gtrvst.f0000664006604000003110000004720214524452052011701 0ustar sun00315stepsC Last change: Nov. 13, 2023 roll back to Build 58 to set the C estimate defaut to adj C previous change: Mar.2021 allow oltwin equals to 0 C Last change: BCM 23 Mar 2005 3:07 pm **==gtrvst.f processed by SPAG 4.03F at 10:40 on 20 Oct 1994 SUBROUTINE gtrvst(Havesp,Sp,Irev,Irevsa,Rfctlg,Nfctlg,Rvstrt, & Rvend,Otlrev,Otlwin,Lrvsa,Lrvch,Lrvtrn,Lrvaic, & Lrvfct,Lrvtch,Lrvsf,Lrvarma,Lrvtdrg,Revfix, & Cnctar,Targsa,Ntarsa,Targtr,Ntartr,Lrfrsh, & Rvtran,Rvfxrg,Nrvfxr,Rvxotl,Rvdiff,Revfxx, & Rvtrfc,Indrev,Indrvs,Iagr,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Read options which control revisions history analysis c----------------------------------------------------------------------- c Variable typing and parameters initialization c----------------------------------------------------------------------- LOGICAL T,F INTEGER MO,YR PARAMETER(T=.true.,F=.false.,MO=2,YR=1) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'svllog.i' INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'rev.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL Lrvsa,Lrvch,Lrvtrn,Lrvaic,Lrvfct,Lrvtch,Lrvsf,Lrvarma, & Lrvtdrg,Inptok,argok,Rvtran,Havesp,Revfix,Lrfrsh,Cnctar, & Rvxotl,Revfxx,Rvtrfc,lprt2 INTEGER nelt,i,Irev,Rfctlg,Sp,Rvstrt,Rvend,Nfctlg,Otlwin,Rvdiff, & ivec2,ivec,Targsa,Ntarsa,Targtr,Ntartr,Rvfxrg,Nrvfxr, & Iagr,Irevsa,Indrev,Indrvs DIMENSION ivec(1),ivec2(2),Rfctlg(PFCLAG),Rvstrt(2),Rvend(2), & Targsa(PTARGT),Targtr(PTARGT),Indrvs(2) c----------------------------------------------------------------------- LOGICAL gtarg EXTERNAL gtarg c----------------------------------------------------------------------- CHARACTER ARGDIC*155 INTEGER argidx,arglog,argptr,PARG PARAMETER(PARG=20) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='estimatessadjlagstrendlagsfstepstartendtablefixm &dltransparentrefreshoutlieroutlierwintargetprintsavesavelogfixregx &11outlierfixx11regadditivesatransformfcst') c----------------------------------------------------------------------- CHARACTER ESTDIC*47 INTEGER estidx,estptr,PRVEST PARAMETER(PRVEST=9) DIMENSION estptr(0:PRVEST),estidx(PRVEST) PARAMETER(ESTDIC= & 'sadjseasonalsadjchngaicfcsttrendtrendchngarmatd') c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER PYSN,ysnptr PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- CHARACTER OTLDIC*14 INTEGER Otlrev,otlptr,POTLRV PARAMETER(POTLRV=3) DIMENSION otlptr(0:POTLRV) PARAMETER(OTLDIC='keepremoveauto') c----------------------------------------------------------------------- CHARACTER TRGDIC*15 INTEGER trgptr,PTRG PARAMETER(PTRG=2) DIMENSION trgptr(0:PTRG) PARAMETER(TRGDIC='concurrentfinal') c----------------------------------------------------------------------- CHARACTER FXRDIC*20 INTEGER fxrptr,PFXR PARAMETER(PFXR=4) DIMENSION fxrptr(0:PFXR),Rvfxrg(PFXR) PARAMETER(FXRDIC='tdholidayuseroutlier') c----------------------------------------------------------------------- CHARACTER ADDDIC*17 INTEGER addptr,PADD PARAMETER(PADD=2) DIMENSION addptr(0:PADD) PARAMETER(ADDDIC='differencepercent') c----------------------------------------------------------------------- DATA argptr/1,10,18,27,32,37,45,51,62,69,76,86,92,97,101,108,114, & 124,133,143,156 / DATA estptr/1,5,13,21,24,28,33,42,46,48/ DATA ysnptr/1,4,6/ DATA otlptr/1,5,11,15/ DATA trgptr/1,11,16/ DATA fxrptr/1,3,10,14,21/ DATA addptr/1,11,18/ c----------------------------------------------------------------------- argok=T CALL setint(NOTSET,2*PARG,arglog) DO WHILE (T) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- 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,150,170,180,190,200, & 160,120,130,140),argidx c ------------------------------------------------------------------ c estimates variable c ------------------------------------------------------------------ 10 CALL gtdcvc(LPAREN,F,PRVEST,ESTDIC,estptr,PRVEST,'Choices of est &imates are sadj, seasonal, sadjchng, trend, trendchng,', & estidx,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok)THEN DO i=1,nelt IF(estidx(i).eq.1)THEN Lrvsa=T ELSE IF(estidx(i).eq.2)THEN Lrvsf=T ELSE IF(estidx(i).eq.3)THEN Lrvch=T ELSE IF(estidx(i).eq.4)THEN Lrvaic=T ELSE IF(estidx(i).eq.5)THEN Lrvfct=T ELSE IF(estidx(i).eq.6)THEN Lrvtrn=T ELSE IF(estidx(i).eq.7)THEN Lrvtch=T ELSE IF(estidx(i).eq.8)THEN Lrvarma=T ELSE IF(estidx(i).eq.9)THEN Lrvtdrg=T END IF END DO ELSE CALL writln(' aic, fcst, arma, and td.',STDERR,Mt2,F) END IF GO TO 210 c----------------------------------------------------------------------- c sadjlags variable c----------------------------------------------------------------------- 20 CALL getivc(LPAREN,T,PTARGT,Targsa,Ntarsa,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.Ntarsa.gt.0)THEN c ------------------------------------------------------------------ c Check individual forecast lags for errors c ------------------------------------------------------------------ DO i=1,Ntarsa IF(Targsa(i).le.0)THEN CALL inpter(PERROR,Lstpos, & 'Entries for sadjlags must be greater than zero.') Inptok=F END IF END DO c ------------------------------------------------------------------ END IF GO TO 210 c----------------------------------------------------------------------- c trendlags lag variable c----------------------------------------------------------------------- 30 CALL getivc(LPAREN,T,PTARGT,Targtr,Ntartr,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.Ntartr.gt.0)THEN c ------------------------------------------------------------------ c Check individual forecast lags for errors c ------------------------------------------------------------------ DO i=1,Ntartr IF(Targtr(i).le.0)THEN CALL inpter(PERROR,Lstpos, & 'Entries for trendlags must be greater than zero.') Inptok=F END IF END DO c ------------------------------------------------------------------ END IF GO TO 210 c----------------------------------------------------------------------- c forecast lag variable c----------------------------------------------------------------------- 40 CALL getivc(LPAREN,T,PFCLAG,Rfctlg,Nfctlg,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.Nfctlg.gt.0)THEN c ------------------------------------------------------------------ c Check individual forecast lags for errors c ------------------------------------------------------------------ DO i=1,Nfctlg IF(Rfctlg(i).le.0)THEN CALL inpter(PERROR,Lstpos, & 'Entries for fstep must be greater than zero.') Inptok=F END IF c ------------------------------------------------------------------ IF(Rfctlg(i).gt.PFCST)THEN CALL inpter(PERROR,Lstpos,'Entries for fstep cannot exceed th &e maximum value specified for maxlead.') Inptok=F END IF END DO c ------------------------------------------------------------------ END IF GO TO 210 c ------------------------------------------------------------------ c Start argument c ------------------------------------------------------------------ 50 CALL gtdtvc(Havesp,Sp,LPAREN,F,1,Rvstrt,nelt,argok,Inptok) IF(Lfatal)RETURN GO TO 210 c ------------------------------------------------------------------ c endtable argument c ------------------------------------------------------------------ 60 CALL gtdtvc(Havesp,Sp,LPAREN,F,1,Rvend,nelt,argok,Inptok) IF(Lfatal)RETURN GO TO 210 c ------------------------------------------------------------------ c fixmdl argument c----------------------------------------------------------------------- 70 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for fixmdl are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Revfix=ivec(1).eq.1 GO TO 210 c ------------------------------------------------------------------ c transparent argument c----------------------------------------------------------------------- 80 CALL gtdcvc(LPAREN,.true.,1,YSNDIC,ysnptr,PYSN, & 'Available options for transparent are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Rvtran=ivec(1).eq.1 GO TO 210 c ------------------------------------------------------------------ c refresh argument c----------------------------------------------------------------------- 90 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for refresh are no or yes', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lrfrsh=ivec(1).eq.1 GO TO 210 c ------------------------------------------------------------------ c outlier argument c ------------------------------------------------------------------ 100 CALL gtdcvc(LPAREN,T,2,OTLDIC,otlptr,POTLRV, & 'Available options for outlier are remove, keep or auto.', & ivec2,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok)THEN Otlrev=0 DO i=1,nelt Otlrev=Otlrev+(ivec2(i)-1) END DO IF(nelt.eq.2.and.Otlrev.eq.1)THEN CALL inpter(PERROR,Errpos,'Cannot specify both remove and keep & for the outlier argument.') Inptok=F END IF END IF GO TO 210 c----------------------------------------------------------------------- c outlierwin variable c----------------------------------------------------------------------- 110 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN Otlwin=ivec(1) IF(argok.and.Otlwin.lt.0)THEN CALL inpter(PERROR,Errpos,'Value of outlierwin must be an integ &er greater than or equal to zero.') Inptok=F END IF GO TO 210 c ------------------------------------------------------------------ c fixx11reg argument c----------------------------------------------------------------------- 120 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for fixx11reg are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Revfxx=ivec(1).eq.1 GO TO 210 c ------------------------------------------------------------------ c additive seasonal adjustment argument c----------------------------------------------------------------------- 130 CALL gtdcvc(LPAREN,T,1,ADDDIC,addptr,PADD, & 'Available options for additivesa are difference or percent.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Rvdiff=ivec(1) GO TO 210 c ------------------------------------------------------------------ c transformfcst argument c----------------------------------------------------------------------- 140 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for transformfcst are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Rvtrfc=ivec(1).eq.1 GO TO 210 c ------------------------------------------------------------------ c target argument c----------------------------------------------------------------------- 150 CALL gtdcvc(LPAREN,T,1,TRGDIC,trgptr,PTRG, & 'Available options for target are concurrent or final', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Cnctar=ivec(1).eq.1 GO TO 210 c ------------------------------------------------------------------ c x11outlier argument c----------------------------------------------------------------------- 160 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for x11outlier are no or yes.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Rvxotl=ivec(1).eq.1 GO TO 210 c ------------------------------------------------------------------ c Print argument c ------------------------------------------------------------------ 170 CALL getprt(LSPREV,NSPREV,Inptok) GO TO 210 c ------------------------------------------------------------------ c Save argument c ------------------------------------------------------------------ 180 CALL getsav(LSPREV,NSPREV,Inptok) GO TO 210 c ------------------------------------------------------------------ c Savelog argument c ------------------------------------------------------------------ 190 CALL getsvl(LSLREV,NSLREV,Inptok) GO TO 210 c ------------------------------------------------------------------ c regression parameter fixing argument c----------------------------------------------------------------------- 200 CALL gtdcvc(LPAREN,T,PFXR,FXRDIC,fxrptr,PFXR, & 'Available options for fixreg are td, holiday, or user.', & Rvfxrg,Nrvfxr,argok,Inptok) IF(Lfatal)RETURN GO TO 210 END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check arguments set by user c----------------------------------------------------------------------- IF(Irev.eq.0)Irev=1 c----------------------------------------------------------------------- c roll back to Build 58 to set the estimate defaut to adj c----------------------------------------------------------------------- IF(.not.Lrvsa.and.Ntarsa.gt.0)Lrvsa=T IF(.not.Lrvtrn.and.Ntartr.gt.0)Lrvtrn=T IF((.not.Lrvsa).and.(.not.Lrvsf).and.(.not.Lrvch).and. & (.not.Lrvtrn).and.(.not.Lrvaic).and.(.not.Lrvfct).and. & (.not.Lrvtch).and.(.not.Lrvarma).and.(.not.Lrvtdrg))Lrvsa=T IF(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvtrn.or.Lrvtch)Irevsa=1 c----------------------------------------------------------------------- IF(Otlwin.eq.NOTSET)Otlwin=Sp c----------------------------------------------------------------------- IF(Iagr.gt.0)THEN IF(Indrev.eq.NOTSET)THEN IF(Lrvsa)THEN Indrev=1 ELSE Indrev=0 END IF END IF lprt2=F IF(Indrev.eq.1)THEN c----------------------------------------------------------------------- c check to see if seasonal adjustment is specified - if not, then c print out message and turn off revision history of indirect c seasonal adjustment c----------------------------------------------------------------------- IF(.not.Lrvsa)THEN Indrev=0 WRITE(STDERR,1010) WRITE(Mt2,1010) 1010 FORMAT(/,' WARNING: Need to specify revisons history for ', & 'seasonal adjustments in all ',/, & ' components of a composite adjustment to ', & 'get a revisions history of the',/, & ' indirect seasonally adjusted series.') lprt2=T c----------------------------------------------------------------------- c if start date specified, check to see if start date of indirect c revisions analysis is set. If not, set this date to be the same as c the revisions starting date. c----------------------------------------------------------------------- ELSE IF(Rvstrt(YR).gt.0)THEN IF(Indrvs(YR).eq.0)THEN Indrvs(YR)=Rvstrt(YR) Indrvs(MO)=Rvstrt(MO) c----------------------------------------------------------------------- c If the date has been set previously, check to see if the starting c date for this component matches the date for the indirect revisions c history. If it does not, print out message and turn off revision c history of indirect seasonal adjustment. c----------------------------------------------------------------------- ELSE IF(.not.(Indrvs(YR).eq.Rvstrt(YR).and. & Indrvs(MO).eq.Rvstrt(MO)))THEN Indrev=0 WRITE(STDERR,1020) WRITE(Mt2,1020) 1020 FORMAT(/,' WARNING: Starting date of revisons history ', & 'analysis must be the same for all',/, & ' components of a composite adjustment to', & ' get a revisions history of the',/, & ' indirect seasonally adjusted series.') lprt2=T END IF c----------------------------------------------------------------------- c if start date is not specified, check to see if start date of c indirect revisions analysis is set. If so, print out message and c turn off revision history of indirect seasonal adjustment. c----------------------------------------------------------------------- ELSE IF(Rvstrt(YR).eq.0.and.Indrev.gt.0)THEN Indrev=0 WRITE(STDERR,1030) WRITE(Mt2,1030) 1030 FORMAT(/,' WARNING: Starting date of revisons history ', & 'analysis must be specified for all',/, & ' components of a composite adjustment to', & ' get a revisions history of the',/, & ' indirect seasonally adjusted series.') lprt2=T END IF END IF IF(lprt2)THEN WRITE(STDERR,1040) WRITE(Mt2,1040) 1040 FORMAT(/,' Edit all input specification files ', & 'to correct this and rerun the ',/, & ' metafile.') END IF END IF c----------------------------------------------------------------------- Inptok=Inptok.and.argok RETURN 210 CONTINUE END DO c ------------------------------------------------------------------ END gtseat.f0000664006604000003110000003447414521201515011637 0ustar sun00315steps SUBROUTINE GTSEAT(Qmax2,Out2,Maxit2,Epsph2,Xl2,Rmod2,Epsiv2, & Hplan2,Lseats,Lnoadm,Kmean,Lhpc,Lstsea,Bias2, & Lfinit,Iphtrf,Tabtbl,Hptrgt,Lhprmls,InptOK) IMPLICIT NONE c----------------------------------------------------------------------- c Input routine for seats adjustment. This routine is basically c empty now - we will add other options (such as print, save, and c savelog) later when list of tables and diagnostics have been c developed, and we see what other options will need to be c incorporated. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'tbllog.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.i' * INCLUDE 'mdltbl.i' * INCLUDE 'hiddn.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE,PT5 LOGICAL F,T PARAMETER (F=.false.,T=.true.,ZERO=0D0,ONE=1D0,PT5=0.5D0) c----------------------------------------------------------------------- CHARACTER Tabtbl*(100) DOUBLE PRECISION Epsph2,Xl2,Rmod2,Epsiv2,Hplan2 LOGICAL Lseats,Lnoadm,Lhpc,Lstsea,Inptok,Lfinit,Lmdsum,Lhprmls INTEGER Qmax2,Out2,Maxit2,Kmean,Bias2,Iphtrf,Hptrgt c----------------------------------------------------------------------- DOUBLE PRECISION dvec LOGICAL argok INTEGER nelt,ivec,tmpptr DIMENSION dvec(1),ivec(1),tmpptr(0:1) c----------------------------------------------------------------------- LOGICAL dpeq,gtarg EXTERNAL dpeq,gtarg c----------------------------------------------------------------------- c Argument dictionary was made with the following command c ../../dictionary/strary < ../../dictionary/check.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*131 INTEGER arglog,argidx,argptr,PARG PARAMETER(PARG=22) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='printsavesavelogappendfcstnoadmissimeanqmaxoutep &sphixlrmodepsivmaxithplanhpcyclestatseastabtablesbiasfiniteprintph &trfhptargethprmls') c----------------------------------------------------------------------- c data dictionary of yes/no choice c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- c data dictionary of hptarget choice c----------------------------------------------------------------------- CHARACTER HPTDIC*13 INTEGER hptptr,PHPT PARAMETER(PHPT=3) DIMENSION hptptr(0:PHPT) PARAMETER(HPTDIC='trendsadjorig') c----------------------------------------------------------------------- DATA argptr/1,6,10,17,27,35,40,44,47,53,55,59,64,69,74,81,89,98, & 102,108,118,126,132 / DATA ysnptr/1,4,6 / DATA hptptr/1,6,10,14 / c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- argok=T CALL setint(NOTSET,2*PARG,arglog) c----------------------------------------------------------------------- c Argument get loop c----------------------------------------------------------------------- DO WHILE (T) IF(gtarg(ARGDIC,argptr,PARG,argidx,arglog,argok))THEN IF(Lfatal)RETURN GO TO(20,30,40,50,60,70,90,100,110,120,130,140,150,160,170, & 190,200,240,260,270,280,290),argidx c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 20 CALL getprt(LSPSET,NSPSET,Inptok) GO TO 300 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 30 CALL getsav(LSPSET,NSPSET,Inptok) GO TO 300 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 40 CALL getsvl(LSLSET,NSLSET,Inptok) GO TO 300 c----------------------------------------------------------------------- c appendfcst argument c----------------------------------------------------------------------- 50 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for appending forecasts are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Savfct=ivec(1).eq.1 GO TO 300 c----------------------------------------------------------------------- c noadmiss argument c----------------------------------------------------------------------- 60 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for noadmiss are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lnoadm=ivec(1).eq.1 GO TO 300 c----------------------------------------------------------------------- c imean argument c----------------------------------------------------------------------- 70 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for imean are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Kmean=2-ivec(1) GO TO 300 c----------------------------------------------------------------------- c qmax argument c----------------------------------------------------------------------- 90 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Invalid limit for Ljung-Box Q.') ELSE IF(ivec(1).lt.0)THEN CALL inpter(PERROR,Errpos, & 'Limit for Ljung-Box Q must be > 0.') argok=F ELSE Qmax2=ivec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c Out argument c----------------------------------------------------------------------- 100 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Invalid limit for out.') argok=F ELSE IF(ivec(1).lt.0.or.ivec(1).gt.2)THEN CALL inpter(PERROR,Errpos, & 'Out must be either 0, 1, or 2.') argok=F ELSE Out2=ivec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c epsphi argument c----------------------------------------------------------------------- 110 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO)THEN CALL inpter(PERROR,Errpos,'Epsphi must be greater than or equa &l to zero.') Inptok=F ELSE Epsph2=dvec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c xl argument c----------------------------------------------------------------------- 120 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.PT5.or.dvec(1).gt.ONE)THEN CALL inpter(PERROR,Errpos,'Xl must be greater than or equal to & 0.5 and less than or ') CALL writln(' equal to one.',STDERR,Mt2,F) Inptok=F ELSE Xl2=dvec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c rmod argument c----------------------------------------------------------------------- 130 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).lt.ZERO.or.dvec(1).gt.ONE)THEN CALL inpter(PERROR,Errpos,'Rmod must be greater than or equal &to zero and less than or ') CALL writln(' equal to one.',STDERR,Mt2,F) Inptok=F ELSE Rmod2=dvec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c Epsiv argument c----------------------------------------------------------------------- 140 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos,'Epsiv must be greater than zero.') Inptok=F ELSE Epsiv2=dvec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c maxit argument c----------------------------------------------------------------------- 150 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Invalid value for maxit.') ELSE IF(ivec(1).le.0)THEN CALL inpter(PERROR,Errpos, & 'Value for maxit must be > 0.') argok=F ELSE Maxit2=ivec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c Hplan argument c----------------------------------------------------------------------- 160 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos,'Hplan must be greater than zero.') Inptok=F ELSE Hplan2=dvec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c hpcycle argument c----------------------------------------------------------------------- 170 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for hpcycle are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lhpc=ivec(1).eq.1 GO TO 300 c----------------------------------------------------------------------- c statseas argument c----------------------------------------------------------------------- 190 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for statseas are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lstsea=ivec(1).eq.1 GO TO 300 c----------------------------------------------------------------------- c tabtables argument c----------------------------------------------------------------------- 200 CALL gtnmvc(LPAREN,T,1,Tabtbl,tmpptr,nelt,100,argok,Inptok) IF(Lfatal)RETURN GO TO 300 c----------------------------------------------------------------------- c bias argument c----------------------------------------------------------------------- 240 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Invalid limit for bias.') argok=F ELSE IF(ivec(1).lt.-1.or.ivec(1).gt.1)THEN CALL inpter(PERROR,Errpos, & 'Bias must be either -1, 0, or 1.') argok=F ELSE Bias2=ivec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c finite argument c----------------------------------------------------------------------- 260 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for finite are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lfinit=ivec(1).eq.1 GO TO 300 c----------------------------------------------------------------------- c printphtrf argument c----------------------------------------------------------------------- 270 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0)THEN IF(.not.argok)THEN CALL inpter(PERROR,Errpos,'Invalid limit for printphtrf.') argok=F ELSE IF(ivec(1).lt.0.or.ivec(1).gt.1)THEN CALL inpter(PERROR,Errpos, & 'printphtrf must be either 0 or 1.') argok=F ELSE Iphtrf=ivec(1) END IF END IF GO TO 300 c----------------------------------------------------------------------- c hptarget argument c----------------------------------------------------------------------- 280 CALL gtdcvc(LPAREN,T,1,HPTDIC,hptptr,PHPT, & 'Available options for hptarget are trend, sadj or orig.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Hptrgt=ivec(1) GO TO 300 c----------------------------------------------------------------------- c hprmls argument c----------------------------------------------------------------------- 290 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for hprmls are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lhprmls=ivec(1).eq.1 GO TO 300 END IF c ----------------------------------------------------------------- Inptok=Inptok.and.argok IF(Inptok)Lseats=T RETURN 300 CONTINUE END DO c----------------------------------------------------------------------- RETURN END gtspec.f0000664006604000003110000003723014521201515011626 0ustar sun00315stepsC Last change: BCM 5 Feb 2008 10:05 am SUBROUTINE gtspec(Sp,Begspn,Endspn,Havesp,Bgspec,Spcdff,Spctyp, & Spcsrs,Mxarsp,Spclim,Peakwd,Lfqalt,Axsame, & Svallf,Ldecbl,Plocal,Spdfor,Lstdff,Lprsfq, & Ltk120,Llogqs,Lqchk,Lrbstsa,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Get options related to the spectrum. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'tbllog.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL F,T INTEGER YR,MO,MINNIN,NINE DOUBLE PRECISION ZERO PARAMETER(T=.true.,F=.false.,YR=1,MO=2,MINNIN=-9,NINE=9,ZERO=0D0) C----------------------------------------------------------------------- DOUBLE PRECISION Spclim,dvec,Plocal LOGICAL argok,Havesp,Spcdff,Lfqalt,Axsame,Svallf,Ldecbl,Lprsfq, & Inptok,Lstdff,locok,Llogqs,Ltk120,Lqchk,Lrbstsa INTEGER Sp,Begspn,Endspn,Bgspec,nspec,Kdec,Spctyp,Spcsrs,Mxarsp, & Peakwd,nelt,ivec,Spdfor DIMENSION Begspn(2),Endspn(2),Bgspec(2),dvec(1),ivec(1) c----------------------------------------------------------------------- LOGICAL gtarg,isdate EXTERNAL gtarg,isdate c----------------------------------------------------------------------- c This dictionary was made with this command c ../../dictionary/strary < ../../dictionary/series.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*153 INTEGER argidx,argptr,PARG,arglog PARAMETER(PARG=21) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='startdifferencetypeseriessiglevelpeakwidthmaxara <freqaxisprintsavesavelogsaveallfreqdecibellocalpeakstartdiffshow &seasonalfreqtukey120logqsqcheckrobustsa') c----------------------------------------------------------------------- c type of compositing data dictionary c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c ------------------------------------------------------------------ CHARACTER DFFDIC*10 INTEGER dffptr,PDFF PARAMETER(PDFF=3) DIMENSION dffptr(0:PDFF) PARAMETER(DFFDIC='yesfirstno') c ------------------------------------------------------------------ CHARACTER STPDIC*17 INTEGER stpptr,PSTP PARAMETER(PSTP=2) DIMENSION stpptr(0:PSTP) PARAMETER(STPDIC='arspecperiodogram') c----------------------------------------------------------------------- c series used in spectrum data dictionary c----------------------------------------------------------------------- CHARACTER SPSDIC*57 INTEGER spsptr,PSPS PARAMETER(PSPS=8) DIMENSION spsptr(0:PSPS) PARAMETER(SPSDIC='originaloutlieradjoriginaladjoriginalmodoriginal &a1a19b1e1') c ------------------------------------------------------------------ c data dictionary for spectral axis c ------------------------------------------------------------------ CHARACTER AXSDIC*17 INTEGER axsptr,PAXS PARAMETER(PAXS=3) DIMENSION axsptr(0:PAXS) PARAMETER(AXSDIC='samedifferentdiff') c ------------------------------------------------------------------ DATA argptr/1,6,16,20,26,34,43,48,55,59,64,68,75,86,93,102,111, & 127,135,140,146,154/ DATA ysnptr/1,4,6/ DATA dffptr/1,4,9,11/ DATA stpptr/1,7,18/ DATA spsptr/1,9,27,38,49,51,54,56,58/ DATA axsptr/1,5,14,18/ c----------------------------------------------------------------------- c Assume the input is OK and we don't have any of the arguments c----------------------------------------------------------------------- locok=T CALL setint(NOTSET,2*PARG,arglog) 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,60,70,50,90,130,100,110,120,140,150,160,170, & 80,180,175,190,200),argidx c----------------------------------------------------------------------- c start argument c----------------------------------------------------------------------- 10 CALL gtdtvc(Havesp,Sp,LPAREN,F,1,Bgspec,nelt,argok,locok) IF(Lfatal)RETURN GO TO 210 c----------------------------------------------------------------------- c difference argument c----------------------------------------------------------------------- 20 CALL gtdcvc(LPAREN,T,1,DFFDIC,dffptr,PDFF, & 'Available options for difference are yes, no or first.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN Spcdff=ivec(1).lt.3 IF(ivec(1).eq.2)THEN Spdfor=1 ELSE IF(ivec(1).eq.3)THEN Spdfor=0 END IF END IF GO TO 210 c----------------------------------------------------------------------- c type argument c----------------------------------------------------------------------- 30 CALL gtdcvc(LPAREN,T,1,STPDIC,stpptr,PSTP, & 'Available options for spectrumtype are periodogram or arspec.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Spctyp=ivec(1)-1 GO TO 210 c----------------------------------------------------------------------- c series argument c----------------------------------------------------------------------- 40 CALL gtdcvc(LPAREN,T,1,SPSDIC,spsptr,PSPS, & 'Improper entry found for the spectrumseries argument.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.0)THEN CALL writln(' Valid entries for spectrumseries are a1, a &19, b1, e1, original,',STDERR,Mt2,F) CALL writln(' outlieradjoriginal, adjoriginal, or modori &ginal.',STDERR,Mt2,F) ELSE IF(argok.and.nelt.gt.0)THEN Spcsrs=ivec(1)-1 IF(Spcsrs.gt.3)Spcsrs=Spcsrs-4 END IF GO TO 210 c----------------------------------------------------------------------- c maxar argument c----------------------------------------------------------------------- 50 CALL getivc(LPAREN,T,1,ivec,nelt,argok,locok) IF(Lfatal)RETURN IF(argok)THEN IF(ivec(1).lt.1.or.ivec(1).gt.30)THEN CALL inpter(PERROR,Errpos, & 'Max order for AR spectrum must be between 1 and 30, inclusive') locok=F ELSE Mxarsp=ivec(1) END IF END IF GO TO 210 c----------------------------------------------------------------------- c siglevel argument c----------------------------------------------------------------------- 60 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Visual signifcance criteria must be greater than zero.') locok=F ELSE Spclim=dvec(1) END IF END IF GO TO 210 c----------------------------------------------------------------------- c peakwidth argument c----------------------------------------------------------------------- 70 CALL getivc(LPAREN,T,1,ivec,nelt,argok,locok) IF(Lfatal)RETURN IF(argok)THEN IF(ivec(1).lt.1.or.ivec(1).gt.4)THEN CALL inpter(PERROR,Errpos, & 'Spectral peak width must be between 1 and 4, inclusive') locok=F ELSE Peakwd=ivec(1) END IF END IF GO TO 210 c----------------------------------------------------------------------- c showseasonalfreq argument c----------------------------------------------------------------------- 80 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for showseasonalfreq are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lprsfq=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c altfreq argument c----------------------------------------------------------------------- 90 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for altfreq are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lfqalt=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 100 CALL getprt(LSPSPC,NSPSPC,locok) GO TO 210 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 110 CALL getsav(LSPSPC,NSPSPC,locok) GO TO 210 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 120 CALL getsvl(LSLSPC,NSLSPC,Inptok) GO TO 210 c----------------------------------------------------------------------- c axis argument c----------------------------------------------------------------------- 130 CALL gtdcvc(LPAREN,T,1,AXSDIC,axsptr,PAXS, & 'Available options for axis are same, diff or difference.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Axsame=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c saveallfreq argument c----------------------------------------------------------------------- 140 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for saveallfreq are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Svallf=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c decibel argument c----------------------------------------------------------------------- 150 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for decibel are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Ldecbl=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c localpeak argument c----------------------------------------------------------------------- 160 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok)THEN IF(dvec(1).lt.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Localpeak must be greater than or equal to zero.') locok=F ELSE Plocal=dvec(1) END IF END IF GO TO 210 c----------------------------------------------------------------------- c startdiff argument c----------------------------------------------------------------------- 170 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for startdiff are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lstdff=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c logqs argument c----------------------------------------------------------------------- 175 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for logqs are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Llogqs=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c tukey120 argument c----------------------------------------------------------------------- 180 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for tukey120 are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Ltk120=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c qcheck argument c----------------------------------------------------------------------- 190 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for qcheck are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lqchk=ivec(1).eq.1 GO TO 210 c----------------------------------------------------------------------- c robustsa argument c----------------------------------------------------------------------- 200 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Available options for robustsa are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lrbstsa=ivec(1).eq.1 GO TO 210 END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c If beginning date of spectral plot is undefined, set equal to c either the beginning date of series, or the date eight years from c the end of the span. c----------------------------------------------------------------------- IF(Bgspec(YR).eq.NOTSET)THEN CALL addate(Endspn,Sp,-95,Bgspec) CALL dfdate(Bgspec,Begspn,Sp,nspec) IF(nspec.lt.0)CALL cpyint(Begspn,2,1,Bgspec) ELSE c----------------------------------------------------------------------- c Else, check that the span is within the series c----------------------------------------------------------------------- IF(.not.isdate(Bgspec,Sp))THEN CALL inpter(PERRNP,Pos,'Spectrum starting date not valid') Havesp=F locok=F ELSE CALL dfdate(Bgspec,Begspn,Sp,nspec) IF(nspec.lt.0)THEN CALL inpter(PERRNP,Errpos, & 'Starting date of spectral plots is before start of series.') locok=F END IF CALL dfdate(Bgspec,Endspn,Sp,nspec) IF(nspec.ge.0)THEN CALL inpter(PERRNP,Errpos, & 'Starting date of spectral plots is after end of series.') locok=F END IF END IF END IF c ------------------------------------------------------------------ c Set Peakwd according to the seasonal period, if it is not already c set (BCM May 2007) c ------------------------------------------------------------------ IF(Peakwd.eq.NOTSET)Peakwd=1 IF(Mxarsp.eq.NOTSET)Mxarsp=30*Sp/12 c IF(Sp.eq.4)Peakwd=3 c END IF c ------------------------------------------------------------------ Inptok=Inptok.and.locok RETURN 210 CONTINUE END DO c ------------------------------------------------------------------ END gttrmo.f0000664006604000003110000000715314521201515011656 0ustar sun00315stepsC Last change: BCM 11 Jun 1998 4:20 pm SUBROUTINE gttrmo(Plen,Trfile,Y,Start,Chnl,Nobs,Freq,Havttl,Title, & Nttlcr,Havnam,Srsnam,Nser,Argok) IMPLICIT NONE c----------------------------------------------------------------------- c Read the Edit data file format c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'x11msc.cmn' c----------------------------------------------------------------------- LOGICAL T INTEGER PCUT2K,YR,MO PARAMETER(YR=1,MO=2,PCUT2K=45,T=.true.) c----------------------------------------------------------------------- CHARACTER Trfile*(*),Title*(*),Srsnam*(*),tmpttl*80 DOUBLE PRECISION Y LOGICAL Argok,Havnam,Havttl INTEGER Freq,i,itmp1,itmp2,Plen,Start,Chnl,Nobs,Nttlcr,Nser,isp DIMENSION Y(Plen),Start(2) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- c Read the series name, title from file (only use if series name c and title are not already given). c----------------------------------------------------------------------- READ(Chnl,*,END=20,ERR=10)tmpttl IF(.not.Havttl)THEN Nttlcr=nblank(tmpttl) Title(1:Nttlcr)=tmpttl(1:Nttlcr) Havttl=T END IF IF(.not.Havnam)THEN isp = index(tmpttl,' ') - 1 IF (isp.gt.0) THEN Nser=MIN(isp,16) Srsnam(1:Nser)=tmpttl(1:Nser) Havnam=T END IF END IF c----------------------------------------------------------------------- c Read number of observations, starting day, frequency c----------------------------------------------------------------------- READ(Chnl,*,END=20,ERR=10)Nobs,itmp1,itmp2,Freq IF(itmp1.lt.100)THEN IF(Yr2000.and.(yr.le.PCUT2K))THEN itmp1=itmp1+2000 ELSE itmp1=itmp1+1900 END IF END IF c----------------------------------------------------------------------- c Set the starting date. c----------------------------------------------------------------------- Start(YR)=itmp1 Start(MO)=itmp2 c----------------------------------------------------------------------- c Check to see if number of observations exceeds program limit c----------------------------------------------------------------------- IF(Nobs.gt.Plen)THEN WRITE(STDERR,1010)Trfile WRITE(Mt2,1010)Trfile 1010 FORMAT(/,' ERROR: Problem reading , ',a,'.'/, & ' Too many observations in file.',/) Argok=.false. Nobs=0 c----------------------------------------------------------------------- c Else, read in observations c----------------------------------------------------------------------- ELSE READ(Chnl,*,END=20,ERR=10)(Y(i),i=1,Nobs) END IF RETURN c----------------------------------------------------------------------- 10 WRITE(STDERR,1020)Trfile WRITE(Mt2,1020)Trfile 1020 FORMAT(/,' ERROR: Problem reading ',a,'.', & /,' Check your input file and format.',/) Argok=.false. Nobs=0 RETURN c----------------------------------------------------------------------- 20 WRITE(STDERR,1030)Trfile WRITE(Mt2,1030)Trfile 1030 FORMAT(/,' ERROR: End of file encountered while reading ',a,'.', & /,' Check your input file and format.',/) Argok=.false. Nobs=0 RETURN END gtwacf.f0000664006604000003110000001120214521201515011603 0ustar sun00315steps SUBROUTINE GTWACF (P,Q,acvlength,PHI,THETA,SIG,ACV,ACF,IND,Ppqa, & Pp) * SUBROUTINE GTWACF (P,Q,acvlength,PHI,THETA,SIG,ACV,ACF,IND,Ppqa, * & Pp,G) c c This is Granville Tunnicliffe-Wilson's program for computing c autocovariances for an ARMA(p,q) model. Input is from file c tmp.in, and output is to the screen. Some changes were made to c also produce autocorrelations. c---------------------------------------------------------------------- c Changes made: 3/3/92, Bill Bell c 1. Some code added to compute and print out autocorrelations c 2. Integer declarations put before double precision declarations as needed c 3. Input file name changed to "tmp.in" c Changes made: 9/21/92, Bill Bell c 1. IMPLICIT DOUBLE PRECISION (a-h,o-z) statement added c 2. REAL type statements changed to DOUBLE PRECISION c Change made: 9/23/92, Bill Bell c An initial call to subroutine xpand and associated print statements c were removed. Granville Wilson informed me that this was inserted c in the code only for initial testing. c CHANGE MADE: 3/2/95, Matt Kramer c Removed all read and write statements so subroutine can be used in Splus c Removed integer ICHAN, NEXT c char DATCOM c Made driver program into a subroutine c Added variables dim1 (for PHI) and dim2 (for THETA), now passed into c subroutines euclid.f, xpand.f, and uconv.f c T renamed acvlength c CHANGE MADE: 7/25/95, Bill Bell c Removed variables dim1 (for PHI) and dim2 (for THETA), and dropped c them from the argument lists in the calls to subroutines euclid, c xpand, and uconv. This undoes a change Matt Kramer made. c CHANGE MADE: 8/4/95, Bill Bell c Dimensions of arrays phi, theta, acv, and acf (subroutine arguments) c changed to max(p,1), max(q,1), acvlength, and acvlength, c respectively (permits bounds checking) c CHANGE MODE: 6/1/2005, Rich Gagnon c Changed dimensions of phi and theta to (0:max(P,1)) and (0:max(Q,1)) c in order to handle X-13A-S versions of UCONV(), XPAND(), c and EUCLID() c CHANGE MADE: 9/15/2005, Rich Gagnon c Dimension of acf changed to acvlength-1 and dimensions of phi and c theta changed to 0:p and 0:q. Also modified call to XPAND() c by adding new argument for size of G array. c c---------------------------------------------------------------------- c Note: The AR and MA operators are expressed as c AR: phi(0) + phi(1)*B + ... + phi(p)*B^p c MA: theta(0) + theta(1)*B + ... + theta(q)*B^q c---------------------------------------------------------------------- c c Tests input routines and matrix Euclid algorithm. c IMPLICIT NONE c----------------------------------------------------------------------- c Input/Output Variables c----------------------------------------------------------------------- INTEGER P,Q,IND,acvlength DOUBLE PRECISION PHI(0:P),THETA(0:Q) DOUBLE PRECISION ACV(acvlength),ACF(acvlength-1), SIG c additional variables added by BCM INTEGER Pp, Ppqa c----------------------------------------------------------------------- c Local Variables c----------------------------------------------------------------------- c INTEGER kmax c PARAMETER (kmax=1000) * DOUBLE PRECISION G(0:max(P,Q,acvlength)),B(max(P,1)),A(max(P,1)) DOUBLE PRECISION G(0:Ppqa),B(Pp),A(Pp) c INTEGER ONE,k,PQ DOUBLE PRECISION ZERO PARAMETER (ONE=1, ZERO=0D0) c----------------------------------------------------------------------- CALL UCONV(THETA,Q,G) * CALL UCONV(THETA,Q,G,Ppqa) DO k = 0, Q G(k) = SIG*G(k) END DO c----------------------------------------------------------------------- PQ=MAX(P,Q) CALL EUCLID(PHI,B,A,PQ,P,Q,G,IND) c----------------------------------------------------------------------- CALL XPAND(PHI,P,PQ,acvlength,G,max(P,Q,acvlength)) DO k = 1, acvlength ACV(k) = G(k-1) END DO c----------------------------------------------------------------------- ACV(1)=2.0D0*ACV(1) c----------------------------------------------------------------------- c Compute and print out autocorrelation coefficients c----------------------------------------------------------------------- IF (acvlength.gt.1) THEN IF(Acv(1).gt.ZERO)THEN DO k = 2, acvlength ACF(k-1) = ACV(k)/ACV(1) END DO ELSE DO k = 2, acvlength ACF(k-1) = ZERO END DO END IF END IF c RETURN END gtx11d.f0000664006604000003110000001266414521201515011455 0ustar sun00315stepsC Last change: BCM 12 Mar 98 10:10 am **==gtx11d.f processed by SPAG 4.03F at 11:37 on 10 Jun 1994 SUBROUTINE gtx11d(Probs,Freq,Indec,Xfmind,Chnl,Start,Last,Nobs,Y, & Srsnam,File,Argok) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'x11msc.cmn' c----------------------------------------------------------------------- LOGICAL T,F INTEGER PCUT2K,YR,MO PARAMETER(PCUT2K=45,T=.true.,F=.false.,YR=1,MO=2) c----------------------------------------------------------------------- CHARACTER File*(*),Srsnam*(*),fmtdat*(PFILCR),lab*8 LOGICAL havsrs,Argok INTEGER Freq,Nobs,Start,Chnl,year,Probs,ind,Indec,i,j,n,lenx11, & nyy,Last,ic1,ny1 DOUBLE PRECISION Y DIMENSION Y(Probs),Start(2),Last(2) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- INTEGER Xfmind,xfmptr,PXFM,PX11F PARAMETER(PXFM=12,PX11F=7) DIMENSION xfmptr(0:PXFM) DATA xfmptr / 1,15,38,52,78,111,135,159,178,196,215,229,262 / c----------------------------------------------------------------------- c Derive format from input code c----------------------------------------------------------------------- ind=Xfmind IF(ind.eq.5)ind=6 IF(ind.eq.8)ind=6 IF(ind.eq.12)ind=5 IF(ind.eq.10.or.ind.eq.11)ind=7 IF(Freq.eq.4.and.ind.lt.6)ind=ind+PX11F IF(ind.eq.1)THEN WRITE(fmtdat,1010)Indec ELSE IF(ind.eq.2)THEN WRITE(fmtdat,1020)Indec,Indec ELSE IF(ind.eq.3)THEN WRITE(fmtdat,1030)Indec ELSE IF(ind.eq.4)THEN WRITE(fmtdat,1040)Indec,Indec ELSE IF(ind.eq.5)THEN WRITE(fmtdat,1050)Indec,Indec ELSE IF(ind.eq.6)THEN WRITE(fmtdat,1060) ELSE IF(ind.eq.7)THEN WRITE(fmtdat,1070) ELSE IF(ind.eq.8)THEN WRITE(fmtdat,1080)Indec ELSE IF(ind.eq.9)THEN WRITE(fmtdat,1090)Indec ELSE IF(ind.eq.10)THEN WRITE(fmtdat,1100)Indec ELSE IF(ind.eq.11)THEN WRITE(fmtdat,1110)Indec ELSE IF(ind.eq.12)THEN WRITE(fmtdat,1120)Indec END IF lenx11=xfmptr(Xfmind)-xfmptr(Xfmind-1) c----------------------------------------------------------------------- lab=' ' havsrs=F i=1 n=6 IF(ind.eq.5.or.ind.eq.6.or.ind.eq.7.or.ind.eq.12)n=8 Last(MO)=Freq c----------------------------------------------------------------------- IF(ind.eq.6.or.ind.eq.7)THEN ic1=12/Freq ny1=12 ELSE ic1=1 ny1=Freq END IF c----------------------------------------------------------------------- DO WHILE (T) IF((ind.ge.3.and.ind.le.7).or.ind.ge.10) & THEN READ(Chnl,fmtdat(1:lenx11),END=20,ERR=10)lab(1:n),year, & (Y(j),j=i,i+ny1-1) ELSE READ(Chnl,fmtdat(1:lenx11),END=20,ERR=10)(Y(j),j=i,i+ny1-1), & year,lab(1:n) END IF IF(ind.lt.5.or.ind.eq.6.or.(ind.gt.7.and.ind.lt.12))THEN IF(Yr2000.and.(year.le.PCUT2K))THEN year=year+2000 ELSE year=year+1900 END IF END IF IF(lab(1:n).eq.Srsnam(1:n))THEN havsrs=T IF(i.eq.1)THEN Start(YR)=year Start(MO)=1 Nobs=ny1 nyy=year ELSE Last(YR)=year Nobs=Nobs+ny1 nyy=nyy+ic1 IF(year.ne.nyy)THEN WRITE(STDERR,1150)nyy,Srsnam(1:n),year WRITE(Mt2,1150)nyy,Srsnam(1:n),year Argok=F Nobs=0 RETURN END IF END IF i=i+ny1 ELSE IF(havsrs)THEN DO j=Nobs+1,Nobs+ny1 Y(j)=DNOTST END DO RETURN END IF END DO 10 WRITE(STDERR,1130)File WRITE(Mt2,1130)File Argok=F Nobs=0 RETURN 20 IF(.not.havsrs)THEN WRITE(STDERR,1140)Srsnam(1:n),File WRITE(Mt2,1140)Srsnam(1:n),File Argok=F Nobs=0 ELSE DO WHILE((.not.dpeq(Y(i),DNOTST)).and.i.le.Probs) Y(i)=DNOTST i=i+1 END DO END IF c----------------------------------------------------------------------- 1010 FORMAT('(12f6.',i1,',i2,a6)') 1020 FORMAT('(6f12.',i1,',/,6f12.',i1,',i2,a6)') 1030 FORMAT('(a6,i2,12f6.',i1,')') 1040 FORMAT('(a6,i2,6f12.',i1,',/,8x,6f12.',i1,')') 1050 FORMAT('(a8,i4,6f11.',i1,',2x,/,12x,6f11.',i1,',2x)') 1060 FORMAT('(a8,i2,10x,12e16.10,18x)') 1070 FORMAT('(a8,i4,12x,12e16.10,13x)') 1080 FORMAT('(4(12x,f6.',i1,'),i2,a6)') 1090 FORMAT('(4f12.',i1,',24x,i2,a6)') 1100 FORMAT('(a6,i2,4(12x,f6.',i1,'))') 1110 FORMAT('(a6,i2,4f12.',i1,')') 1120 FORMAT('(a8,i4,4f11.',i1,',2x)') 1130 FORMAT(/,' ERROR: Problem reading ',a,'.',/, & ' Check input file and format.',/) 1140 FORMAT(/,' ERROR: Cannot find series ',a,' in file ',a,'.',/, & ' Check series name, input file, and format.',/) 1150 FORMAT(' ERROR: Expected to find year ',i4,' of series ',a, & ' not ',i4,'.',/,' Check input file and format.',/) c----------------------------------------------------------------------- RETURN END gtx12s.f0000664006604000003110000000624614521201515011474 0ustar sun00315stepsC Last change: BCM 14 May 1998 7:56 am SUBROUTINE gtx12s(Plen,File,Y,Start,Chnl,Nobs,Ncol,Freq,Srsnam, & Argok) IMPLICIT NONE c----------------------------------------------------------------------- c Read the X12SAVE data file format c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F INTEGER YR,MO PARAMETER(YR=1,MO=2,F=.false.) c----------------------------------------------------------------------- CHARACTER File*(*),Srsnam*(*) DOUBLE PRECISION Y LOGICAL Argok INTEGER i,i2,itmp1,Plen,Start,Chnl,Nobs,Ncol,Freq,itmp,year,per, & nyy,npr DIMENSION Y(Plen),Start(2) c----------------------------------------------------------------------- c Read header lines c----------------------------------------------------------------------- READ(Chnl,1000) 1000 FORMAT(/) c----------------------------------------------------------------------- i=1 DO WHILE (i.le.Plen) c----------------------------------------------------------------------- c Read the date, observation from file c----------------------------------------------------------------------- READ(Chnl,*,END=20,ERR=10)itmp1,(Y(i2),i2=i,i+Ncol-1) c----------------------------------------------------------------------- c If this is the first observation, set the starting date. c----------------------------------------------------------------------- year=itmp1/100 per=mod(itmp1,100) IF(i.eq.1)THEN Start(YR)=itmp1/100 Start(MO)=mod(itmp1,100) itmp=Start(YR)*Freq+Start(MO) ELSE itmp=itmp+1 nyy=itmp/Freq npr=mod(itmp,Freq) IF(npr.eq.0)THEN nyy=nyy-1 npr=Freq END IF IF(.not.((nyy.eq.year).and.(npr.eq.per)))THEN WRITE(STDERR,1001)nyy,npr,Srsnam,year,per WRITE(Mt2,1001)nyy,npr,Srsnam,year,per 1001 FORMAT(' ERROR: Expected to find observation ',i4,':',i2, & ' of series ',a,/, & ' not ',i4,':',i2,'. Check input file and ', & 'format.',/) Argok=F Nobs=0 RETURN END IF END IF c----------------------------------------------------------------------- i=i+Ncol END DO c----------------------------------------------------------------------- IF(i.gt.Plen)THEN WRITE(STDERR,1010)File WRITE(Mt2,1010)File 1010 FORMAT(/,' ERROR: Problem reading , ',a,'.',/, & ' Too many observations in file.',/) Argok=.false. Nobs=0 END IF c----------------------------------------------------------------------- 10 WRITE(STDERR,1020)File WRITE(Mt2,1020)File 1020 FORMAT(/,' ERROR: Problem reading , ',a,'.'/, & ' Check your input file and format.',/) Argok=.false. Nobs=0 c----------------------------------------------------------------------- 20 RETURN END gtxreg.f0000664006604000003110000011344614521201515011645 0ustar sun00315stepsC Last change: Mar.2021, add a pass parameter Endspn to call gtpdrg C Last change: BCM 28 Sep 99 3:17 pm SUBROUTINE gtxreg(Begsrs,Nobs,Endspn,Havsrs,Havesp,Muladd,Xuserx, & Bgusrx,Ixreg,Nusxrg,Sigxrg,Critxr,Otlxrg,Umean, & Begum,Haveum,Noxfac,Ladd1x,Xtdtst,Xeastr,Xuser, & Dwt,Ixrgtd,Ixrghl,Xhlnln,Xelong,Calfrc,Begxrg, & Endxrg,Fxprxr,Begxot,Endxot,Havxhl,Havxtd, & Axrghl,Axrgtd,Lxrneg,Cvxalf,Cvxtyp,Cvxrdc, & Xraicd,Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Specify the X-11 regression on the irregular 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 'usrxrg.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO,PTONE LOGICAL F,T PARAMETER(F=.false.,T=.true.,ONE=1D0,ZERO=0D0,PTONE=0.1D0) c ------------------------------------------------------------------ CHARACTER effttl*(PCOLCR),xrfile*(PFILCR),xrfmt*(PFILCR), & umname*(64),umfile*(PFILCR),umfmt*(PFILCR),umtit*(80) LOGICAL argok,Havesp,havfmt,Havsrs,haveux,hvfile,hvstrt,hvuttl, & Inptok,Otlxrg,Haveum,hvumfl,hvumst,hvumft,Havxtd,Havxhl, & hvumnm,Ladd1x,Xeastr,Xhlnln,Xelong,Calfrc,hvmdsp,hvotsp, & Noxfac,Xuser,Axrghl,Axrgtd,havlp,havln,lumean,lprior, & luseas,fixvec,Lxrneg,Cvxtyp INTEGER Bgusrx,Begsrs,i,j,k,idisp,itmpvc,nchr,nelt,nflchr,nfmtch, & neltux,Nobs,peltux,Muladd,Ixreg,Nusxrg,igrp,numfch, & neltum,numnam,Begum,numftc,Xtdtst,ivec,spnxrg,Begxrg, & Endxrg,nxrg,spnotl,Begxot,Endxot,Ixrgtd,Ixrghl,Fxprxr, & neltdw,Endspn,numdec,numtit,tmppa,i2,n2,k2,ispn,nbvec, & begcol,endcol,ltrim DOUBLE PRECISION Xuserx,Sigxrg,Critxr,Umean,Dwt,dvec,Xraicd, & urmean,urnum,bvec,Cvxalf,Cvxrdc DIMENSION Bgusrx(2),Begsrs(2),itmpvc(0:1),Xuserx(*),spnotl(2,2), & Begxot(2),Endxot(2),Umean(PLEN),Begum(2),Dwt(7),ivec(1), & dvec(1),spnxrg(2,2),Begxrg(2),Endxrg(2),Endspn(2), & urmean(PB),urnum(PB),ispn(2),fixvec(PB),bvec(PB) c----------------------------------------------------------------------- INTEGER strinx LOGICAL chkcvr,gtarg,dpeq,istrue EXTERNAL chkcvr,gtarg,dpeq,strinx,istrue c----------------------------------------------------------------------- c The spec dictionary was made with this command c ../../dictionary/strary < ../../dictionary/regression.dic c----------------------------------------------------------------------- CHARACTER ARGDIC*271 INTEGER argidx,argptr,PARG,arglog PARAMETER(PARG=36) DIMENSION argptr(0:PARG),arglog(2,PARG) PARAMETER(ARGDIC='variablesuserdatastartfileformatbprintsaveuserty &pesigmacriticalumdataumstartumfileumformatumnameoutliermethodaicte &sttdpriornoapplyholidaynonlineastermeansforcecalspanoutlierspanump &recisionaicdiffsavelogumtrimzerocenteruserreweightcriticalalphadef &aultcriticalprioralmost') c----------------------------------------------------------------------- CHARACTER USXDIC*15 INTEGER usxidx,usxptr,PUSX PARAMETER(PUSX=4) DIMENSION usxptr(0:PUSX),usxidx(PUREG) PARAMETER(USXDIC='tdaoholidayuser') c----------------------------------------------------------------------- CHARACTER MTDDIC*12 INTEGER mtdptr,PMTD PARAMETER(PMTD=2) DIMENSION mtdptr(0:PMTD) PARAMETER(MTDDIC='addoneaddall') c----------------------------------------------------------------------- CHARACTER NAPDIC*9 INTEGER napidx,napptr,PNAP PARAMETER(PNAP=2) DIMENSION napptr(0:PNAP),napidx(2) PARAMETER(NAPDIC='tdholiday') c ------------------------------------------------------------------ CHARACTER XAICDC*38 INTEGER xaicid,xaicpt,PXAIC PARAMETER(PXAIC=6) DIMENSION xaicpt(0:PXAIC),xaicid(3) PARAMETER(XAICDC='tdtdstocktd1coeftdstock1coefeasteruser') c----------------------------------------------------------------------- c data dictionary of yes/no choice c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='yesno') c----------------------------------------------------------------------- CHARACTER ZRODIC*9 INTEGER zroptr,PZRO PARAMETER(PZRO=3) DIMENSION zroptr(0:PZRO) PARAMETER(ZRODIC='yesspanno') c ------------------------------------------------------------------ CHARACTER URRDIC*12 INTEGER urrptr,PURR PARAMETER(PURR=2) DIMENSION urrptr(0:PURR) PARAMETER(URRDIC='meanseasonal') c----------------------------------------------------------------------- c default critical value types dictionary c----------------------------------------------------------------------- CHARACTER DEFDIC*14 INTEGER defptr,PDEF PARAMETER(PDEF=2) DIMENSION defptr(0:PDEF) PARAMETER(DEFDIC='ljungcorrected') c----------------------------------------------------------------------- DATA argptr/1,10,14,18,23,27,33,34,39,43,51,56,64,70,77,83,91,97, & 110,117,124,131,144,155,163,167,178,189,196,203,213, & 223,231,244,259,264,272/ DATA usxptr/1,3,5,12,16/ DATA mtdptr/1,7,13/ DATA napptr/1,3,10/ DATA xaicpt/1,3,10,17,29,35,39/ DATA ysnptr/1,4,6/ DATA zroptr/1,4,8,10/ DATA urrptr/1,5,13/ DATA defptr/1,6,15/ c----------------------------------------------------------------------- c Assume the input is OK and we don't have any of the arguments c----------------------------------------------------------------------- argok=T peltux=PLEN*PUREG haveux=F hvuttl=F hvfile=F havfmt=F hvstrt=F hvumnm=F hvumfl=F hvumft=F hvumst=F nfmtch=1 numdec=0 numftc=1 hvmdsp=F hvotsp=F havlp=F havln=F ltrim=0 lumean=F luseas=F neltdw=0 nbvec=NOTSET CALL setlg(F,PB,fixvec) lprior=F c----------------------------------------------------------------------- CALL setint(NOTSET,2*PARG,arglog) CALL setint(NOTSET,4,spnxrg) CALL setint(NOTSET,4,spnotl) CALL setint(NOTSET,2,ispn) CALL setint(0,PUREG,Usxtyp) c----------------------------------------------------------------------- c Initialize the format and file c----------------------------------------------------------------------- CALL setchr(' ',PFILCR,xrfile) CALL setchr(' ',PFILCR,xrfmt) 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,140,150,160, & 170,180,190,200,210,220,230,240,250,260,270,280,290,300, & 310,320,330,340,345,346),argidx c----------------------------------------------------------------------- c Regression argument c----------------------------------------------------------------------- 10 CALL gtpdrg(Begsrs,Endspn,Nobs,Havsrs,Havesp,T,Havxtd,Havxhl, & havln,havlp,argok,Inptok) IF(Lfatal)RETURN IF((.not.Lfatal).and.Picktd)THEN IF(Muladd.eq.NOTSET)THEN ELSE IF(Muladd.ne.1)THEN tmppa=NOTSET CALL rmlnvr(tmppa,0,Nspobs) IF(Lfatal)RETURN END IF END IF GO TO 350 c----------------------------------------------------------------------- c Names and number of columns for the user regression variables c----------------------------------------------------------------------- 20 CALL gtnmvc(LPAREN,T,PUREG,Usrxtt,Usrxpt,Ncxusx,PCOLCR,argok, & Inptok) IF(Lfatal)RETURN hvuttl=argok.and.Ncxusx.gt.0 GO TO 350 c----------------------------------------------------------------------- c Data argument c----------------------------------------------------------------------- 30 IF(hvfile)CALL inpter(PERROR,Errpos,'Getting data from a file') c ------------------------------------------------------------------ CALL gtdpvc(LPAREN,T,peltux,Xuserx,neltux,argok,Inptok) IF(Lfatal)RETURN haveux=argok.and.neltux.gt.0 GO TO 350 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 350 c----------------------------------------------------------------------- c File argument c----------------------------------------------------------------------- 50 IF(haveux)CALL inpter(PERROR,Errpos, & 'Already have user regression') CALL gtnmvc(LPAREN,T,1,xrfile,itmpvc,neltux,PFILCR,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok.and.neltux.gt.0)THEN nflchr=itmpvc(1)-1 hvfile=T END IF GO TO 350 c----------------------------------------------------------------------- c Format argument c----------------------------------------------------------------------- 60 CALL gtnmvc(LPAREN,T,1,xrfmt,itmpvc,nelt,PFILCR,argok,Inptok) IF(Lfatal)RETURN IF(argok)THEN nfmtch=itmpvc(1)-1 havfmt=T END IF GO TO 350 c----------------------------------------------------------------------- c Initial values for the irregular regression. May want to change c this later so that the betas only need take some initial values c instead of all or none. c----------------------------------------------------------------------- 70 CALL gtrgvl(nbvec,fixvec,bvec,Inptok) IF(Lfatal)RETURN GO TO 350 c----------------------------------------------------------------------- c Print argument c----------------------------------------------------------------------- 80 CALL getprt(LSPXRG,NSPXRG,Inptok) GO TO 350 c----------------------------------------------------------------------- c Save argument c----------------------------------------------------------------------- 90 CALL getsav(LSPXRG,NSPXRG,Inptok) GO TO 350 c----------------------------------------------------------------------- c usertype argument c----------------------------------------------------------------------- 100 CALL gtdcvc(LPAREN,F,PUREG,USXDIC,usxptr,PUSX, & 'Improper entry for usertype. See '//SPCSEC// & ' of '//DOCNAM//'.',usxidx,Nusxrg,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok.and.Nusxrg.gt.0)THEN DO i=1,Nusxrg IF(usxidx(i).eq.1)THEN Usxtyp(i)=PRGUTD Havxtd=T ELSE IF(usxidx(i).eq.2)THEN Usxtyp(i)=PRGTAO Havxtd=T ELSE IF(usxidx(i).eq.3)THEN Usxtyp(i)=PRGTUH Havxhl=T ELSE IF(usxidx(i).eq.4.or.usxidx(i).eq.NOTSET)THEN Usxtyp(i)=PRGTUD END IF END DO END IF GO TO 350 c ------------------------------------------------------------------ c sigma argument c ------------------------------------------------------------------ 110 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for tdsigma c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.0)THEN CALL inpter(PERROR,Errpos,'Trading day sigma limit must be gre &ater than zero.') Inptok=F ELSE Sigxrg=dvec(1) END IF END IF GO TO 350 c ------------------------------------------------------------------ c critical argument c ------------------------------------------------------------------ 120 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Error Checking for tdsigma c ------------------------------------------------------------------ IF(argok.and.nelt.gt.0)THEN IF(dpeq(dvec(1),ZERO))THEN Critxr=DNOTST Otlxrg=T ELSE IF(dvec(1).lt.0)THEN CALL inpter(PERROR,Errpos,'Critical value for outlier detectio &n must be greater than zero.') Inptok=F ELSE Critxr=dvec(1) Otlxrg=T END IF END IF GO TO 350 c----------------------------------------------------------------------- c usermean argument c----------------------------------------------------------------------- 130 IF(hvumfl)CALL inpter(PERROR,Errpos,'Getting mean from a file.') c ------------------------------------------------------------------ CALL gtdpvc(LPAREN,T,PLEN,Umean,neltum,argok,Inptok) IF(Lfatal)RETURN Haveum=argok.and.neltum.gt.0 GO TO 350 c----------------------------------------------------------------------- c umstart argument c----------------------------------------------------------------------- 140 CALL gtdtvc(Havesp,Sp,LPAREN,F,1,Begum,nelt,argok,Inptok) IF(Lfatal)RETURN hvumst=argok.and.nelt.gt.0 GO TO 350 c----------------------------------------------------------------------- c umfile argument c----------------------------------------------------------------------- 150 IF(Haveum)CALL inpter(PERROR,Errpos, & 'Already have user effect mean.') CALL gtnmvc(LPAREN,T,1,umfile,itmpvc,neltum,PFILCR,argok,Inptok) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(argok.and.neltum.gt.0)THEN numfch=itmpvc(1)-1 hvumfl=T END IF GO TO 350 c----------------------------------------------------------------------- c umformat argument c----------------------------------------------------------------------- 160 CALL gtnmvc(LPAREN,T,1,umfmt,itmpvc,nelt,PFILCR,argok,Inptok) IF(Lfatal)RETURN IF(argok)THEN numftc=itmpvc(1)-1 hvumft=T END IF GO TO 350 c----------------------------------------------------------------------- c mean name argument c----------------------------------------------------------------------- 170 CALL gtnmvc(LPAREN,T,1,umname,itmpvc,nelt,64,argok,Inptok) IF(Lfatal)RETURN IF(argok)THEN numnam=itmpvc(1)-1 hvumnm=T END IF GO TO 350 c----------------------------------------------------------------------- c outliermethod argument c----------------------------------------------------------------------- 180 CALL gtdcvc(LPAREN,T,1,MTDDIC,mtdptr,PMTD, & 'Choices are ADDONE or ADDALL',ivec,nelt,argok, & Inptok) IF(Lfatal)RETURN c---------------------------------------------------------------------- IF(nelt.gt.0)Ladd1x=ivec(1).eq.1 GO TO 350 c----------------------------------------------------------------------- c aictest argument c----------------------------------------------------------------------- 190 CALL gtdcvc(LPAREN,F,3,XAICDC,xaicpt,PXAIC, & 'Choices for aictest are td, tdstock, td1coef, tdstock1coef,', & xaicid,nelt,argok,Inptok) IF(Lfatal)RETURN IF(.not.argok)CALL writln(' user, and easter.', & STDERR,Mt2,F) IF(argok)THEN DO i=1,nelt IF(xaicid(i).eq.5)THEN Xeastr=T Havxhl=T ELSE IF(xaicid(i).eq.6)THEN Xuser=T ELSE IF(Xtdtst.eq.0)THEN Xtdtst=xaicid(i) Havxtd=T ELSE CALL inpter(PERROR,Errpos, & 'Can only specify one type of trading day in aictest.') Inptok=F END IF END IF END DO END IF GO TO 350 c----------------------------------------------------------------------- c tdprior argument c----------------------------------------------------------------------- 200 CALL gtdpvc(LPAREN,T,7,Dwt,neltdw,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.neltdw.ne.7)THEN CALL inpter(PERROR,Errpos,'Must have seven prior trading day we &ights.') Inptok=F END IF GO TO 350 c----------------------------------------------------------------------- c noapply argument c----------------------------------------------------------------------- 210 CALL gtdcvc(LPAREN,T,3,NAPDIC,napptr,PNAP, & 'Choices are TD or HOLIDAY.',napidx,nelt,argok, & Inptok) IF(Lfatal)RETURN c---------------------------------------------------------------------- IF(nelt.gt.0)THEN DO i=1,nelt IF(napidx(i).eq.1)THEN Ixrgtd=0 ELSE Ixrghl=0 END IF END DO END IF GO TO 350 c----------------------------------------------------------------------- c holidaynonlin argument c----------------------------------------------------------------------- 220 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN, & 'Choices for holidaynonlin are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Xhlnln=ivec(1).eq.1 GO TO 350 c----------------------------------------------------------------------- c eastermeans argument c----------------------------------------------------------------------- 230 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN, & 'Choices for eastermeans are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Xelong=ivec(1).eq.1 GO TO 350 c----------------------------------------------------------------------- c forcecal argument c----------------------------------------------------------------------- 240 CALL gtdcvc(LPAREN,T,1,YSNDIC,ysnptr,PYSN, & 'Choices for forcecal are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Calfrc=ivec(1).eq.1 GO TO 350 c----------------------------------------------------------------------- c Span for the irregular regression estimation. c----------------------------------------------------------------------- 250 CALL gtdtvc(Havesp,Sp,LPAREN,F,2,spnxrg,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos,'Need two dates for the irregular com &ponent regression span or') CALL writln(' use a comma as a place holder.',STDERR,Mt2, & F) Inptok=F ELSE IF(argok)THEN hvmdsp=T END IF GO TO 350 c----------------------------------------------------------------------- c Span argument for outlier identification c----------------------------------------------------------------------- 260 CALL gtdtvc(T,Sp,LPAREN,F,2,spnotl,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.eq.1)THEN CALL inpter(PERROR,Errpos, & 'Need two dates for the span or use a comma as a place holder.' & ) Inptok=F ELSE hvotsp=T END IF GO TO 350 c----------------------------------------------------------------------- c umprecision argument c----------------------------------------------------------------------- 270 CALL getivc(LPAREN,T,1,ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok)THEN IF(ivec(1).lt.0.or.ivec(1).gt.5)THEN CALL inpter(PERROR,Errpos, & 'Number of input decimals must be between 0 and 5, inclusive') Inptok=F ELSE numdec=ivec(1) END IF END IF GO TO 350 c----------------------------------------------------------------------- c AIC test difference for the regression-based AIC test c----------------------------------------------------------------------- 280 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(nelt.gt.0.and.argok)Xraicd=dvec(1) GO TO 350 c----------------------------------------------------------------------- c savelog argument c----------------------------------------------------------------------- 290 CALL getsvl(LSLXRG,NSLXRG,Inptok) GO TO 350 c----------------------------------------------------------------------- c umtrimzero argument c----------------------------------------------------------------------- 300 CALL gtdcvc(LPAREN,F,1,ZRODIC,zroptr,PZRO, & 'Choices for umtrimzero are yes, span or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)ltrim=ivec(1)-1 GO TO 350 c----------------------------------------------------------------------- c centeruser argument c----------------------------------------------------------------------- 310 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 350 c----------------------------------------------------------------------- c reweight argument c----------------------------------------------------------------------- 320 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN, & 'Choices for reweight are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)Lxrneg=ivec(1).eq.1 GO TO 350 c----------------------------------------------------------------------- c criticalalpha - alpha value for outlier critical value c----------------------------------------------------------------------- 330 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).gt.PTONE)THEN CALL inpter(PERROR,Errpos, & 'Value of criticalalpha must be between 0 and 0.10.') Inptok=F ELSE Cvxalf=dvec(1) END IF END IF GO TO 350 c----------------------------------------------------------------------- c Default critical value generation method specification c----------------------------------------------------------------------- 340 CALL gtdcvc(LPAREN,T,1,DEFDIC,defptr,PDEF, & 'Choices are ljung or corrected.',ivec,nelt,argok, & Inptok) IF(Lfatal)RETURN c---------------------------------------------------------------------- IF(nelt.gt.0.and.argok)Cvxtyp=ivec(1).eq.1 GO TO 350 c----------------------------------------------------------------------- c holidaynonlin argument c----------------------------------------------------------------------- 345 CALL gtdcvc(LPAREN,F,1,YSNDIC,ysnptr,PYSN, & 'Choices for prior are yes or no.', & ivec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)lprior=ivec(1).eq.1 GO TO 350 c----------------------------------------------------------------------- c almost - amount to reduce outlier critical value to identify c "almost" outliers c----------------------------------------------------------------------- 346 CALL gtdpvc(LPAREN,T,1,dvec,nelt,argok,Inptok) IF(Lfatal)RETURN IF(argok.and.nelt.gt.0)THEN IF(dvec(1).le.ZERO)THEN CALL inpter(PERROR,Errpos, & 'Value of almost must be greater than 0.') Inptok=F ELSE Cvxrdc=dvec(1) END IF END IF GO TO 350 END IF c----------------------------------------------------------------------- IF(nbvec.ne.NOTSET)THEN IF(nbvec.gt.0.and.nbvec.NE.(Nb+Ncxusx))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+Ncxusx 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) & CALL gtfldt(peltux,xrfile,nflchr,havfmt,xrfmt(1:nfmtch),2, & Xuserx,neltux,Havesp,Sp,F,' ',0,F,' ',0,0,hvstrt, & Bgusrx,Ncxusx,ispn,ispn,T,haveux,Inptok) c----------------------------------------------------------------------- c If beginning or ending date in the model span is undefined, set c equal to beginning date of the span. c----------------------------------------------------------------------- IF(spnxrg(YR,1).eq.NOTSET)THEN CALL cpyint(Begspn,2,1,Begxrg) ELSE CALL cpyint(spnxrg,2,1,Begxrg) END IF IF(spnxrg(YR,2).eq.NOTSET.or.spnxrg(YR,2).eq.0)THEN CALL addate(Begspn,Sp,Nspobs-1,Endxrg) IF(spnxrg(YR,2).eq.0)THEN Endxrg(MO)=spnxrg(MO,2) IF(Endxrg(MO).gt.Endspn(MO))Endxrg(YR)=Endxrg(YR)-1 Fxprxr=Endxrg(MO) END IF ELSE CALL cpyint(spnxrg(1,2),2,1,Endxrg) END IF c----------------------------------------------------------------------- c Check that the span is within the series c----------------------------------------------------------------------- IF(hvmdsp)THEN CALL dfdate(Endxrg,Begxrg,Sp,nxrg) nxrg=nxrg+1 IF(.not.chkcvr(Begspn,Nspobs,Begxrg,nxrg,Sp))THEN CALL inpter(PERRNP,Errpos,'Irregular component regression span ¬ within the span of available data.') CALL cvrerr('span',Begspn,Nspobs, & 'irregular component regression span',Begxrg,nxrg, & Sp) IF(Lfatal)RETURN Inptok=F END IF END IF c----------------------------------------------------------------------- c set span for outlier test c----------------------------------------------------------------------- IF(spnotl(YR,1).eq.NOTSET)THEN CALL cpyint(Begspn,2,1,Begxot) ELSE CALL cpyint(spnotl,2,1,Begxot) END IF IF(spnotl(YR,2).eq.NOTSET)THEN CALL addate(Begsrs,Sp,Nobs-1,Endxot) ELSE CALL cpyint(spnotl(1,2),2,1,Endxot) END IF c---------------------------------------------------------------------- c Check that the span is within the series c---------------------------------------------------------------------- IF(hvotsp)THEN CALL dfdate(Endxot,Begxot,Sp,nelt) nelt=nelt+1 CALL dfdate(Endxrg,Begxrg,Sp,nmdl) nmdl=nmdl+1 IF(.not.chkcvr(Begsrs,Nobs,Begxot,nelt,Sp))THEN CALL inpter(PERROR,Errpos,'Span not within the series') CALL cvrerr('Series',Begsrs,Nobs,'outlier test span',Begxot, & nelt,Sp) Inptok=F ELSE IF(.not.chkcvr(Begxrg,nmdl,Begxot,nelt,Sp))THEN CALL inpter(PERROR,Errpos,'Span not within the model span') CALL cvrerr('Model span',Begxrg,nmdl,'outlier test span', & Begxot,nelt,Sp) Inptok=F END IF IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Check for the required arguments c----------------------------------------------------------------------- IF(Inptok.and.(hvuttl.or.haveux))THEN IF(.not.(hvuttl.eqv.haveux))THEN WRITE(STDERR,1010) WRITE(Mt2,1010) 1010 FORMAT(/,' ERROR: Need to specify both user-defined ', & 'irregular component',/, & ' regression variables and X-matrix.') Inptok=F c ------------------------------------------------------------------ ELSE IF(mod(neltux,Ncxusx).ne.0)THEN WRITE(STDERR,1020)neltux,Ncxusx WRITE(Mt2,1020)neltux,Ncxusx 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) Nrxusx=neltux/Ncxusx IF(.not.chkcvr(Bgusrx,Nrxusx,Begspn,Nspobs,Sp))THEN CALL cvrerr('user-defined regression variables',Bgusrx,Nrxusx, & 'span of the data',Begspn,Nspobs,Sp) IF(Lfatal)RETURN Inptok=F c ------------------------------------------------------------------ ELSE idisp=Grp(Ngrp)-1 * call profiler(2,'adding user defined regressors') DO i=1,Ncxusx idisp=idisp+1 CALL getstr(Usrxtt,Usrxpt,Ncxusx,i,effttl,nchr) IF(.not.Lfatal)THEN IF(Usxtyp(i).eq.PRGTUH)THEN CALL adrgef(B(idisp),effttl(1:nchr),'User-defined Holiday', & Usxtyp(i),Regfx(idisp),T) ELSE IF(Usxtyp(i).eq.PRGUTD)THEN CALL adrgef(B(idisp),effttl(1:nchr), & 'User-defined Trading Day', & Usxtyp(i),Regfx(idisp),T) ELSE IF(Usxtyp(i).eq.PRGUAO)THEN CALL adrgef(B(idisp),effttl(1:nchr),'User-defined AO', & Usxtyp(i),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,Ncxusx) IF(i2.eq.0)i2=Ncxusx urmean(i2)=urmean(i2)+Xuserx(i) END DO DO i=1,Ncxusx urmean(i)=urmean(i)/DBLE(Nrxusx) END DO DO i=1,neltux i2=MOD(i,Ncxusx) IF(i2.eq.0)i2=Ncxusx Xuserx(i)=Xuserx(i)-urmean(i2) END DO ELSE IF(luseas)THEN n2=Sp*Ncxusx DO i=1,Sp CALL setdp(ZERO,PB,urmean) CALL setdp(ZERO,PB,urnum) i2=(i-1)*Ncxusx+1 DO j=i2,neltux,n2 DO k=j,Ncxusx+j-1 k2=MOD(k,Ncxusx) IF(k2.eq.0)k2=Ncxusx urmean(k2)=urmean(k2)+Xuserx(k) urnum(k2)=urnum(k2)+ONE END DO END DO DO j=1,Ncxusx urmean(j)=urmean(j) / urnum(j) END DO DO j=i2,neltux,n2 DO k=j,Ncxusx+j-1 k2=MOD(k,Ncxusx) IF(k2.eq.0)k2=Ncxusx Xuserx(k)=Xuserx(k)-urmean(k2) END DO END DO END DO END IF c ------------------------------------------------------------------ END IF END IF END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Read in and check the means for the user-defined regression c effects c----------------------------------------------------------------------- IF(Inptok.and.(hvumfl.or.Haveum))THEN IF(Ncxusx.eq.0)THEN WRITE(STDERR,1025)neltux,Ncxusx WRITE(Mt2,1025)neltux,Ncxusx 1025 FORMAT(/,' ERROR: User-defined mean can only be specified if ', & /,' user defined regressors are also present.',/) Inptok=F ELSE IF(hvumfl.and..not.Haveum)THEN CALL gtfldt(PLEN,umfile,numfch,hvumft,umfmt(1:numftc),ltrim, & Umean,neltum,Havesp,Sp,hvumnm,umname,numnam,hvuttl, & umtit,numtit,numdec,hvumst,Begum,1,Begspn,Endspn,F, & Haveum,Inptok) END IF IF(Inptok.and.Haveum)THEN IF(.not.hvumst)CALL cpyint(Begsrs,2,1,Begum) IF(.not.chkcvr(Begum,neltum,Begspn,Nspobs,Sp))THEN CALL cvrerr('user-defined mean effects',Begum,neltum, & 'span of the data',Begspn,Nspobs,Sp) IF(Lfatal)RETURN Inptok=F END IF END IF END IF c----------------------------------------------------------------------- c Check if the regression model parameters are fixed. Sets iregfx. c----------------------------------------------------------------------- IF(Nb.gt.0)THEN c----------------------------------------------------------------------- c check user-defined X-11 regression type selection. First, check c to see if user-defined X-11 regression variables are defined. c----------------------------------------------------------------------- IF(Nusxrg.gt.0)THEN igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,'User-defined') IF(igrp.eq.0) & igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,'User-defined Holiday') IF(igrp.eq.0)THEN WRITE(STDERR,1030) WRITE(Mt2,1030) 1030 FORMAT(' ERROR: Cannot specify group types for user-defined ', & 'irregular component',/, & ' regression variables if user-defined ', & 'irregular component',/, & ' regression variables are not defined in the ', & ' x11regression spec.') Inptok=F END IF c---------------------------------------------------------------------- c If only one type given, use it for all user-defined regression c variables. c----------------------------------------------------------------------- IF(Nusxrg.eq.1)THEN DO i=2,Ncxusx Usxtyp(i)=Usxtyp(1) END DO END IF END IF 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(Nusxrg.gt.0.and.Iregfx.ge.2)THEN IF(Iregfx.eq.3)THEN Userfx=T ELSE igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,'User-defined') begcol=Grp(igrp-1) endcol=Grp(igrp)-1 Userfx=istrue(Regfx,begcol,endcol) END IF END IF c----------------------------------------------------------------------- c sort outlier regressors specified by the user, if any. c----------------------------------------------------------------------- CALL otsort() END IF c----------------------------------------------------------------------- Inptok=Inptok.and.argok IF(Inptok)THEN IF(Nb.gt.0.or.Xeastr.or.Xtdtst.gt.0)Ixreg=1 IF(Ixreg.gt.0.and.lprior)Ixreg=2 IF(.not.Havxtd)Ixrgtd=0 IF(Ixrgtd.gt.0)Axrgtd=T IF(.not.Havxhl)Ixrghl=0 IF(Ixrghl.gt.0)Axrghl=T c IF(dpeq(Sigxrg,DNOTST))Sigxrg=2.5D0 IF(.not.(Axrgtd.or.Axrghl.or.neltdw.gt.0))THEN WRITE(STDERR,1040) WRITE(Mt2,1040) 1040 FORMAT(' ERROR: Must adjust for either trading day or ', & 'holiday in the x11regression spec.') Inptok=F END IF c----------------------------------------------------------------------- Noxfac=Haveum.and.Havxtd.and.Havxhl IF(Noxfac.and.(Ixrgtd.eq.0.or.Ixrghl.eq.0))THEN WRITE(STDERR,1050) WRITE(Mt2,1050) 1050 FORMAT(' ERROR: Cannot specify noapply when user-defined ', & 'mean is also present.') Inptok=F END IF END IF c---------------------------------------------------------------------- RETURN 350 CONTINUE END DO c ----------------------------------------------------------------- END hdflag.i0000664006604000003110000000016014521201515011561 0ustar sun00315stepsC C... Variables in Common Block /handle_flag/ ... integer HANDLE common /handle_flag/ HANDLE hender.f0000664006604000003110000000165214521201515011605 0ustar sun00315steps**==hender.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE hender(W,N) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION ONE,THREE,FOUR,NINE PARAMETER(NINE=9D0,THREE=3D0,FOUR=4D0,ONE=1D0) DOUBLE PRECISION denomi,W,x,y,y1,y2,y3,y4,y5 INTEGER i,m,N C*** End of declarations inserted by SPAG C C THIS SUBROUTINE GENERATES THE WEIGHTS FOR AN N-TERM HENDERSON C MOVING AVERAGE. THE WEIGHTS ARE STORED IN W. ONLY HALF THE WEIGHTS C ARE GENERATED SINCE W IS SYMMETRIC. C DIMENSION W(*) y=dble((N+3)/2) m=(N+1)/2 y1=(y-ONE)*(y-ONE) y2=y*y y3=(y+ONE)*(y+ONE) y4=THREE*y2-16D0 y5=FOUR*y2 denomi=8D0*y*(y2-ONE)*(y5-ONE)*(y5-NINE)*(y5-25D0)/315D0 DO i=1,m x=dble((i-1)*(i-1)) W(i)=(y1-x)*(y2-x)*(y3-x)*(y4-11D0*x)/denomi END DO RETURN END hender.prm0000664006604000003110000000046114521201516012154 0ustar sun00315stepsc----------------------------------------------------------------------- c PMXHND : Maximum length of a Henderson filter c----------------------------------------------------------------------- INTEGER PMXHND,PMXHN1,PMXHN2 PARAMETER(PMXHND=101,PMXHN1=PMXHND-1,PMXHN2=(PMXHND+1)/2) hiddn.cmn0000664006604000003110000000276314521201516011763 0ustar sun00315stepsc----------------------------------------------------------------------- c Issap : Indicator variable for the sliding spans analysis c (0=no sliding spans, 1=sliding spans analysis to be done, c 2=hidden adjustments for sliding spans being done) c Irev : Indicator variable for the revisions history analyis c (0=no revisions history, 1=revisions history to be done, c 2=revisions history for a given period to be done, c 4=hidden adjustments for revisions history done) c Ixreg - indicates that a regression will be performed on the c X-11 irregular c (0=no irregular regression, 1=irregular regression done as c part of regular seasonal adjustment, 2=irregular c regression done as prior adjustment, 3=irregular c regression already done as prior adjustment) c Lnoprt : Logical variable which indicates when output should be c suppressed c Lhiddn : Logical variable which indicates when output should be c turned off during special runs c Lsumm : Indicator variable for saving the diagnosics file c----------------------------------------------------------------------- CHARACTER Crvend*(10) INTEGER Issap,Irev,Irevsa,Ixreg,Ierhdr,Lsumm,Nrvend LOGICAL Lhiddn,Lnoprt,Ltimer COMMON /hiddn / Issap,Irev,Irevsa,Ixreg,Ierhdr,Lsumm,Nrvend, & Lhiddn,Lnoprt,Ltimer,Crvend hinge.f0000664006604000003110000000415414521201516011433 0ustar sun00315stepsC Last change: BCM 21 Nov 97 10:11 pm **==hinge.f processed by SPAG 4.03F at 17:22 on 11 Mar 1994 SUBROUTINE hinge(Xo,N,Ts,Tsxtra,Ic) IMPLICIT NONE c---------------------------------------------------------------------- DOUBLE PRECISION Xo,Ts,Tsxtra INTEGER Ic,lxtra,N,n1,n2,n3 DIMENSION Ts(5),Xo(*) c---------------------------------------------------------------------- c Sort the series c----------------------------------------------------------------------- CALL shlsrt(N,Xo) c----------------------------------------------------------------------- c Store the maximum and the minimum of the series. c---------------------------------------------------------------------- Ts(1)=Xo(1) Ts(5)=Xo(N) c---------------------------------------------------------------------- c Compute the median c---------------------------------------------------------------------- IF(mod(N,2).eq.1)THEN Ts(3)=Xo((N+1)/2) ELSE Ts(3)=(Xo(N/2)+Xo((N/2)+1))/2 END IF c---------------------------------------------------------------------- c Compute the 25th and 75th Pecentiles c---------------------------------------------------------------------- n2=(N+1)/2 IF(mod(n2,2).eq.1)THEN n1=(n2+1)/2 n3=N-n1+1 Ts(2)=Xo(n1) Ts(4)=Xo(n3) ELSE n1=n2/2 n3=n1+1 Ts(2)=(Xo(n1)+Xo(n3))/2 n1=N-n1+1 n3=N-n3+1 Ts(4)=(Xo(n1)+Xo(n3))/2 END IF c---------------------------------------------------------------------- c For the sliding spans analysis, compute the 60th and 85th c percentiles. c---------------------------------------------------------------------- IF(Ic.gt.0)THEN IF(Ic.le.3)THEN lxtra=N-int(dble(N)*0.15D0+0.5D0) ELSE IF(Ic.eq.4)THEN lxtra=N-int(dble(N)*0.40D0+0.5D0) ELSE lxtra=N-int(dble(N)*0.10D0+0.5D0) END IF Tsxtra=Xo(lxtra) END IF c---------------------------------------------------------------------- RETURN END hist.f0000664006604000003110000002112214521201516011302 0ustar sun00315stepsC Last change: Mar. 21, - add Tabular Histogram of the Standardized C and Mean-Centered Residuals C previous change: BCM 25 Nov 97 11:58 am SUBROUTINE hist(Y,Begspn,Sp,Nobs,D,Muladd) IMPLICIT NONE c----------------------------------------------------------------------- c hist.f, Release 1, Subroutine Version 1.5, Modified 03 Nov 1994. c----------------------------------------------------------------------- c Calculates the histogram of the ny long data vector, y. c----------------------------------------------------------------------- c bin i Local vector of counts of observations between cut points c i.e. bins c cutpnt d Local vector of cut points where observations counted in c bin(i) are cutpnt(i-1) < y <= cutpnt(i) c d i Input diffence between the number of observations in the c series and number of effective observations in the series, c nobs-nefobs c i i Local do loop index c ibin i Local index for the current bin, or column of the c histogram c irow i Local index for the current row of the output c lowbnd d Local scalar for the low bound of the observations c median d Local median of the y's c nbin i Local number of bins or columns in the histogram c notlr i Local number of outliers (in otlr) c nobs i Input number of observations c nrow i Local number of rows in the histogram c otlr i Local notlr long list of the values of residuals c greater than 3.25 c otlrt0 i Local notlr long list of residuals greater than 3.25 c standard deviations from the median c scale d Local scale factor to make the number of rows be 40 c stddev d Local standard deviation of the y's c sum d Local scalar sum of y c sumsq d Local scalar sum of squares of y c tmp d Local temporary scalar c width d Local width between cut points c y d Input nobs long vector of observations c ymax d Local scalar maximum of the y's c ymin d Local scalar minimum of the y's c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ INTEGER PA,POTLEN DOUBLE PRECISION ONE PARAMETER(PA=PLEN+2*PORDER,ONE=1D0,POTLEN=PLEN/4) c ------------------------------------------------------------------ CHARACTER str*(10) INTEGER Begspn,bin,D,i,ibin,idate,irow,midpt,nbin,nchr,Nobs,notlr, & nrow,otlrt0,Sp,Muladd DOUBLE PRECISION cutpnt,lowbnd,median,otlr,srtdy,stddev,tmp,width, & Y,ymax,ymin,ceilng,scale DIMENSION Begspn(2),bin(15),cutpnt(15),idate(2),otlr(POTLEN), & otlrt0(POTLEN),srtdy(PA),Y(Nobs) EXTERNAL ceilng c----------------------------------------------------------------------- c Find the minimum, maximum, median, and standard deviation of the c observations. c----------------------------------------------------------------------- CALL copy(Y,Nobs,1,srtdy) CALL shlsrt(Nobs,srtdy) c ------------------------------------------------------------------ ymin=srtdy(1) ymax=srtdy(Nobs) c ------------------------------------------------------------------ midpt=Nobs/2 IF(mod(Nobs,2).eq.0)THEN median=(srtdy(midpt)+srtdy(midpt+1))/2D0 ELSE median=srtdy(midpt+1) END IF c ------------------------------------------------------------------ CALL medabs(Y,Nobs,stddev) IF(Lfatal)RETURN stddev=1.49D0*stddev c----------------------------------------------------------------------- c Find the range and lower bound of the histogram. c----------------------------------------------------------------------- width=.5D0 lowbnd=-3.25D0 c----------------------------------------------------------------------- c Calculate the cut points. c----------------------------------------------------------------------- tmp=lowbnd nbin=15 c ------------------------------------------------------------------ DO i=1,nbin cutpnt(i)=tmp tmp=tmp+width END DO c----------------------------------------------------------------------- c Sort the observations into bins. c----------------------------------------------------------------------- nrow=0 notlr=0 CALL setint(0,nbin,bin) c ------------------------------------------------------------------ DO i=1,Nobs tmp=(Y(i)-median)/stddev c ------------------------------------------------------------------ IF(tmp.lt.lowbnd)THEN notlr=notlr+1 IF(notlr.le.POTLEN)THEN otlrt0(notlr)=i+D otlr(notlr)=tmp END IF bin(1)=bin(1)+1 nrow=max(nrow,bin(1)) c ------------------------------------------------------------------ ELSE DO ibin=2,nbin-1 IF(tmp.lt.cutpnt(ibin))THEN bin(ibin)=bin(ibin)+1 nrow=max(nrow,bin(ibin)) GO TO 10 END IF END DO c ------------------------------------------------------------------ notlr=notlr+1 IF(notlr.le.POTLEN)THEN otlrt0(notlr)=i+D otlr(notlr)=tmp END IF bin(nbin)=bin(nbin)+1 nrow=max(nrow,bin(nbin)) END IF 10 CONTINUE END DO c ------------------------------------------------------------------ scale=ceilng(dble(nrow)/69D0) IF(scale.gt.ONE)THEN DO ibin=1,nbin bin(ibin)=int(bin(ibin)/scale) END DO END IF c----------------------------------------------------------------------- c Print the histogram sideways with negative values on top. c----------------------------------------------------------------------- WRITE(Mt1,1010) 1010 FORMAT(' Standard',/,' Deviations Frequency') c ------------------------------------------------------------------ IF(bin(1).gt.0)THEN WRITE(Mt1,1020)('#',i=1,bin(1)) 1020 FORMAT(/,' Outlier [',69A1) WRITE(Mt1,'(1x)') END IF c ------------------------------------------------------------------ DO irow=2,nbin-2,2 WRITE(Mt1,1030)(irow-8)/2,('#',i=1,bin(irow)) 1030 FORMAT(i9,' +',69A1) WRITE(Mt1,1040)('#',i=1,bin(irow+1)) 1040 FORMAT(9x,' |',69A1) END DO WRITE(Mt1,1030)(nbin-9)/2,('#',i=1,bin(nbin-1)) c ------------------------------------------------------------------ IF(bin(nbin).gt.0)WRITE(Mt1,1020)('#',i=1,bin(nbin)) c ------------------------------------------------------------------ WRITE(Mt1,1050)int(scale) 1050 FORMAT(/,' One ''#''=',i2,' observation[s]') c ------------------------------------------------------------------ WRITE(Mt1,1000) 1000 FORMAT(/,' Tabular Histogram of the Standardized and ' $'Mean-Centered Residuals',/) WRITE(Mt1,1010) IF(bin(1).gt.0)THEN WRITE(Mt1,1010) 1001 FORMAT(/,'Outlier',' ',t21,i4) END IF DO irow=2,nbin-1 IF(Muladd.eq.1)THEN WRITE(Mt1,1002)(cutpnt(irow)+cutpnt(irow-1))/2,bin(irow) 1002 FORMAT(/,f7.1,t21,i4) ELSE WRITE(Mt1,1003)(cutpnt(irow)+cutpnt(irow-1))/2,bin(irow) 1003 FORMAT(/,f6.2,t21,i4) END IF END DO c ------------------------------------------------------------------ IF(notlr.gt.0)THEN WRITE(Mt1,1060) 1060 FORMAT(/,' Residuals with |t|>3.25') IF(notlr.gt.POTLEN)THEN WRITE(Mt1,1090)POTLEN,notlr 1090 FORMAT(/,' Only the first ',i3,' of the ',i3, & ' extreme residuals are shown.',/) END IF WRITE(Mt1,1061) 1061 FORMAT(/,' Obs t-value',/,' -----------------') DO i=1,notlr IF(i.le.POTLEN)THEN CALL addate(Begspn,Sp,otlrt0(i)-(D+1),idate) CALL wrtdat(idate,Sp,str,nchr) IF(Lfatal)RETURN WRITE(Mt1,1070)str(1:nchr),otlr(i) 1070 FORMAT(' ',a,t12,f8.2) END IF END DO END IF c ------------------------------------------------------------------ WRITE(Mt1,1080)ymin,ymax,median,stddev 1080 FORMAT(/,' Summary Statistics for the Unstandardized Residuals',/, & ' Minimum',t21,f15.3,/,' Maximum',t21,f15.3,/,' Median', & t21,f15.3,/,' Robust Std Dev',t21,f15.3) c ------------------------------------------------------------------ RETURN END histx.f0000664006604000003110000003010514521201516011473 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 11:16 am **==histx.f processed by SPAG 4.03F at 14:08 on 24 Aug 1994 SUBROUTINE histx(Y,Nobs,Muladd,Ny,Lyr,Begsrs,Itbl,Ldiff,Lprt,Lsav, & Label) IMPLICIT NONE c----------------------------------------------------------------------- c Calculates the histogram of the ny long revisions vector, y. c----------------------------------------------------------------------- c bin i Local vector of counts of observations between cut points c i.e. bins c cutpnt d Local vector of cut points where observations counted in c bin(i) are cutpnt(i-1) < y <= cutpnt(i) c d i Input diffence between the number of observations in the c series and number of effective observations in the series, c nobs-nefobs c i i Local do loop index c ibin i Local index for the current bin, or column of the c histogram c irow i Local index for the current row of the output c lowbnd d Local scalar for the low bound of the observations c nbin i Local number of bins or columns in the histogram c notlr i Local number of outliers (in otlr) c nobs i Input number of observations c nrow i Local number of rows in the histogram c otlr i Local notlr long list of the values of residuals c greater than 3.25 c otlrt0 i Local notlr long list of residuals greater than 3.25 c standard deviations from the median c xscale d Local scale factor to make the number of rows be 40 c stddev d Local standard deviation of the y's c sum d Local scalar sum of y c sumsq d Local scalar sum of squares of y c tmp d Local temporary scalar c width d Local width between cut points c y d Input nobs long vector of revisions c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'tfmts.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ONE PARAMETER(ONE=1D0) INTEGER MO,YR PARAMETER(MO=2,YR=1) c----------------------------------------------------------------------- LOGICAL Lprt,Lsav,Ldiff CHARACTER Label*(*),dash*50,ex*(2) INTEGER bin,i,ibin,irow,nbin,Nobs,notlr,nrow,otlrt0,Muladd, & otlobs,Ny,Lyr,Begsrs,iobs,Itbl,i2,ic DOUBLE PRECISION cutpnt,lowbnd,otlr,stddev,tmp,width,Y,ts,tsxtra, & temp,ceilng,xscale DIMENSION bin(15),cutpnt(15),otlr(50),otlrt0(50),ts(5),Y(*), & otlobs(2),temp(PLEN),ex(2*NEST) EXTERNAL ceilng c----------------------------------------------------------------------- DATA dash/' ------------------------------------------------'/ DATA ex/'a ','ai','b ','bi','c ','ci','d ','di','e ','ei'/ c----------------------------------------------------------------------- CALL copy(Y,Nobs,1,temp) ic=(Itbl-1)/2+1 CALL hinge(temp,Nobs,ts,tsxtra,ic) c----------------------------------------------------------------------- c Find standard deviation of the observations. c----------------------------------------------------------------------- CALL medabs(Y,Nobs,stddev) IF(Lfatal)RETURN stddev=stddev/0.6745D0 c IF(stddev.eq.0)RETURN c ------------------------------------------------------------------ c Print Summary statistics c ------------------------------------------------------------------ IF(Lprt)THEN WRITE(Mt1,1110)Label 1110 FORMAT(//,' Summary Statistics for the ',a,/) IF(Ldiff)THEN IF(Tblwid.gt.7)THEN WRITE(Mt1,1121)(ts(i),i=1,5),stddev ELSE WRITE(Mt1,1120)(ts(i),i=1,5),stddev END IF 1121 FORMAT(5x,'Minimum',t27,': ',5x,g17.10,/,5x,'25th Percentile', & t27,': ',5x,g17.10,/,5x,'Median',t27,': ',5x,g17.10,/,5x, & '75th Percentile',t27,': ',5x,g17.10,/,5x,'Maximum',t27, & ': ',5x,g17.10,//,5x,'Standard Deviation',t27,': ',5x, & g17.10,//) 1120 FORMAT(5x,'Minimum',t27,': ',5x,f10.1,/,5x,'25th Percentile', & t27,': ',5x,f10.1,/,5x,'Median',t27,': ',5x,f10.1,/,5x, & '75th Percentile',t27,': ',5x,f10.1,/,5x,'Maximum',t27, & ': ',5x,f10.1,//,5x,'Standard Deviation',t27,': ',5x, & f10.1,//) ELSE c ------------------------------------------------------------------ c Print hinge values for sliding spans analysis. c ------------------------------------------------------------------ WRITE(Mt1,1130)(ts(i),i=1,3) 1130 FORMAT(5x,'Minimum',t27,': ',f10.2,/,5x,'25th Percentile',t27, & ': ',f10.2,/,5x,'Median',t27,': ',f10.2) IF(ic.le.3)THEN WRITE(Mt1,1131)ts(4),85,tsxtra,ts(5),stddev 1131 FORMAT(5x,'75th Percentile',t27,': ',f10.2,/,3x,'->',i2, & 'th Percentile',t27,': ',f10.2,'<-',/,5x,'Maximum', & t27,': ',f10.2//,5x,'Standard Deviation',t27,': ',5x, & f10.2,//) ELSE IF(ic.eq.4)THEN WRITE(Mt1,1132)tsxtra,(ts(i),i=4,5),stddev 1132 FORMAT(3x,'->60th Percentile',t27,': ',f10.2,'<-',/,5x, & '75th Percentile',t27,': ',f10.2,/,5x,'Maximum', & t27,': ',f10.2//,5x,'Standard Deviation',t27,': ',5x, & f10.2,//) ELSE WRITE(Mt1,1131)ts(4),90,tsxtra,ts(5),stddev END IF END IF END IF c----------------------------------------------------------------------- c Find the range and lower bound of the histogram. c----------------------------------------------------------------------- width=.25D0*stddev lowbnd=0 IF(Ldiff)THEN nbin=15 ELSE nbin=12 END IF c----------------------------------------------------------------------- c Calculate the cut points. c----------------------------------------------------------------------- tmp=lowbnd DO i=1,nbin cutpnt(i)=tmp tmp=tmp+width END DO c----------------------------------------------------------------------- c Sort the observations into bins. c----------------------------------------------------------------------- nrow=0 notlr=0 CALL setint(0,nbin,bin) c ------------------------------------------------------------------ DO i=1,Nobs tmp=Y(i) c ------------------------------------------------------------------ IF(tmp.lt.lowbnd)THEN notlr=notlr+1 IF (notlr.le.50) THEN otlrt0(notlr)=i otlr(notlr)=tmp END IF bin(1)=bin(1)+1 nrow=max(nrow,bin(1)) c ------------------------------------------------------------------ ELSE DO ibin=2,nbin-1 IF(tmp.lt.cutpnt(ibin))THEN bin(ibin)=bin(ibin)+1 nrow=max(nrow,bin(ibin)) GO TO 10 END IF END DO c ------------------------------------------------------------------ notlr=notlr+1 IF(notlr.le.50)THEN otlrt0(notlr)=i otlr(notlr)=tmp END IF bin(nbin)=bin(nbin)+1 nrow=max(nrow,bin(nbin)) END IF 10 CONTINUE END DO c ------------------------------------------------------------------ xscale=ceilng(dble(nrow)/69D0) IF(xscale.gt.ONE)THEN DO ibin=1,nbin bin(ibin)=int(bin(ibin)/xscale) END DO END IF c----------------------------------------------------------------------- c Print the histogram sideways with negative values on top. c----------------------------------------------------------------------- IF(Lprt)THEN WRITE(Mt1,1010)Label 1010 FORMAT(//,' Histogram of the ',a,/) IF(Ldiff)THEN IF(Tblwid.gt.5)THEN WRITE(Mt1,1021) ELSE WRITE(Mt1,1020) END IF 1021 FORMAT(' Absolute Differences Frequency') 1020 FORMAT(' Absolute',/,' Differences Frequency') ELSE WRITE(Mt1,1030) 1030 FORMAT(' Percent',/,' Differences Frequency') END IF c ------------------------------------------------------------------ IF(bin(1).gt.0)THEN IF(Ldiff.and.Tblwid.gt.5)THEN WRITE(Mt1,1040)' Outlier [',('#',i=1,bin(1)) ELSE WRITE(Mt1,1040)' Outlier [',('#',i=1,bin(1)) END IF 1040 FORMAT(/,A,69A1) WRITE(Mt1,'(1x)') END IF c ------------------------------------------------------------------ DO irow=2,nbin-2,2 IF(Muladd.eq.1)THEN IF(Ldiff.and.Tblwid.gt.5)THEN WRITE(Mt1,1051)(cutpnt(irow)+cutpnt(irow-1))/2, & ('#',i=1,bin(irow)) WRITE(Mt1,1070)' |',('#',i=1,bin(irow+1)) ELSE WRITE(Mt1,1050)(cutpnt(irow)+cutpnt(irow-1))/2, & ('#',i=1,bin(irow)) WRITE(Mt1,1070)' |',('#',i=1,bin(irow+1)) END IF 1051 FORMAT(3x,G17.10,' +',69A1) 1050 FORMAT(3x,f7.1,' +',69A1) ELSE WRITE(Mt1,1060)(cutpnt(irow)+cutpnt(irow-1))/2, & ('#',i=1,bin(irow)) WRITE(Mt1,1070)' |',('#',i=1,bin(irow+1)) 1060 FORMAT(4x,f6.2,' +',69A1) END IF 1070 FORMAT(10x,a,69A1) END DO IF(Muladd.eq.1)THEN IF(Ldiff.and.Tblwid.gt.5)THEN WRITE(Mt1,1051)(cutpnt(nbin-1)+cutpnt(nbin-2))/2, & ('#',i=1,bin(nbin-1)) ELSE WRITE(Mt1,1050)(cutpnt(nbin-1)+cutpnt(nbin-2))/2, & ('#',i=1,bin(nbin-1)) END IF ELSE WRITE(Mt1,1060)(cutpnt(nbin-1)+cutpnt(nbin-2))/2, & ('#',i=1,bin(nbin-1)) END IF c ------------------------------------------------------------------ IF(bin(nbin).gt.0)WRITE(Mt1,1040)('#',i=1,bin(nbin)) c ------------------------------------------------------------------ WRITE(Mt1,1080)int(xscale) 1080 FORMAT(/,' One ''#''=',i2,' observation[s]') c ------------------------------------------------------------------ IF(notlr.gt.0)THEN WRITE(Mt1,1090)Label,Label,dash(1:len(Label)+9) 1090 FORMAT(/,2x,a,' considered to be outliers',/,' Time ',a,/,a) DO i=1,MIN(notlr,50) iobs=otlrt0(i)+Begsrs-1 otlobs(MO)=mod(iobs,Ny) IF(otlobs(MO).eq.0)otlobs(MO)=Ny otlobs(YR)=Lyr+(iobs-1)/Ny IF(Tblwid.gt.5)THEN WRITE(Mt1,1101)otlobs(MO),otlobs(YR),otlr(i) ELSE WRITE(Mt1,1100)otlobs(MO),otlobs(YR),otlr(i) END IF 1101 FORMAT(1x,i2,':',i4,G17.10) 1100 FORMAT(1x,i2,':',i4,f8.2) END DO IF(notlr.gt.50)WRITE(Mt1,1160)notlr 1160 FORMAT(//, & ' Number of observations considered to be outliers = ',i3,/, & ' (only the first 50 were listed above)') END IF END IF c ------------------------------------------------------------------ c Save hinge values c ------------------------------------------------------------------ IF(Lsav.and.Nform.gt.0)THEN i2=2-mod(Itbl,2) IF(Ldiff)THEN IF(ic.eq.4)THEN WRITE(Nform,1151)ex(Itbl)(1:i2),(ts(i),i=1,3),tsxtra,(ts(i), & i=4,5),stddev ELSE WRITE(Nform,1151)ex(Itbl)(1:i2),(ts(i),i=1,4),tsxtra,ts(5), & stddev END IF ELSE IF(ic.eq.4)THEN WRITE(Nform,1150)ex(Itbl)(1:i2),(ts(i),i=1,3),tsxtra,(ts(i), & i=4,5),stddev ELSE WRITE(Nform,1150)ex(Itbl)(1:i2),(ts(i),i=1,4),tsxtra,ts(5), & stddev END IF END IF 1151 FORMAT('s3.',a,'.hinge:',8(2x,g17.10)) 1150 FORMAT('s3.',a,'.hinge:',8(2x,f8.3)) END IF c ------------------------------------------------------------------ RETURN c ------------------------------------------------------------------ END hndend.f0000664006604000003110000000277214521201516011605 0ustar sun00315steps**==hndend.f processed by SPAG 4.03F at 17:01 on 16 May 1994 SUBROUTINE hndend(M,Nterm,W,Endwt,R) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine uses the algorithm given in Doherty (1993) to c generate end filters of length m for an nterm Henderson filter. c----------------------------------------------------------------------- INCLUDE 'hender.prm' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,TWO PARAMETER(ZERO=0D0,TWO=2D0) c----------------------------------------------------------------------- INTEGER M,Nterm,n,i,j DOUBLE PRECISION W(*),cw(PMXHND),Endwt(*),u1,u2,c1,c2,R c----------------------------------------------------------------------- n=(Nterm+1)/2 j=1 DO i=n,2,-1 cw(j)=W(i) j=j+1 END DO j=1 DO i=n,Nterm cw(i)=W(j) j=j+1 END DO c----------------------------------------------------------------------- u1=ZERO u2=ZERO DO j=M+1,Nterm u1=u1+cw(j) u2=u2+(j-dble(M+1)/TWO)*cw(j) END DO c----------------------------------------------------------------------- DO i=1,M c1=(i-(dble(M+1)/TWO))*R c2=1+(dble(M*(M-1)*(M+1))/12D0)*R Endwt(i)=cw(i)+(u1/dble(M))+(u2*(c1/c2)) END DO c----------------------------------------------------------------------- RETURN END hndtrn.f0000664006604000003110000000446614521201516011644 0ustar sun00315stepsC Last change: SRD 25 Jan 100 2:14 pm **==hndtrn.f processed by SPAG 4.03F at 15:38 on 18 May 1994 SUBROUTINE hndtrn(Stc,Stci,Lfda,Lldaf,Nterm,Tic,Lend,Lsame) IMPLICIT NONE c----------------------------------------------------------------------- c This routine applys a henderson filter of length Nterm to a c series (Stci), returning the trend (Stc). c----------------------------------------------------------------------- INCLUDE 'hender.prm' INCLUDE 'x11msc.cmn' c----------------------------------------------------------------------- LOGICAL Lend,Lsame DOUBLE PRECISION apply,Stc,Stci,W,Tic,rbeta INTEGER Lfda,Lldaf,Nterm,i,ib,ie DIMENSION Stc(*),Stci(*),W(PMXHN2) c----------------------------------------------------------------------- DOUBLE PRECISION PI PARAMETER(PI=3.14159265358979D0) c----------------------------------------------------------------------- IF(.not.Lsame)THEN c----------------------------------------------------------------------- c Apply symmetric henderson filter to series c----------------------------------------------------------------------- CALL hender(W,Nterm) ib=Lfda+Nterm/2 ie=Lldaf-Nterm/2 DO i=ib,ie Stc(i)=apply(Stci,i,W,Nterm) END DO c----------------------------------------------------------------------- c If end filters not applied, exit c----------------------------------------------------------------------- IF(.not.Lend)RETURN END IF i=Nterm DO WHILE (i.eq.7.and.(.not.Tru7hn)) c----------------------------------------------------------------------- C --- REDUCE SPAN OF HENDERSON AT THE ENDS OF THE SERIES FOR 7 TERM. c----------------------------------------------------------------------- i=i-2 CALL hender(W,i) ib=ib-1 ie=ie+1 Stc(ib)=apply(Stci,ib,W,i) Stc(ie)=apply(Stci,ie,W,i) Tic=0.001D0 END DO c----------------------------------------------------------------------- c Set value of rbeta depending on what the length of the trend c filter is. c----------------------------------------------------------------------- rbeta=4/(Tic*Tic*PI) CALL ends(Stc,Stci,Lfda,Lldaf,i,rbeta) RETURN END holday.f0000664006604000003110000001123214521201516011614 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 11:46 am **==holday.f processed by SPAG 4.03F at 15:12 on 1 Aug 1994 SUBROUTINE holday(Sti,Mt1,Lgraf,Iforc,Xdsp) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'lzero.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'x11tbl.i' INCLUDE 'x11ptr.cmn' INCLUDE 'error.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'xeastr.cmn' INCLUDE 'extend.cmn' c----------------------------------------------------------------------- LOGICAL F DOUBLE PRECISION ZERO,ONEHUN INTEGER YR PARAMETER(ZERO=0D0,ONEHUN=100D0,F=.false.,YR=1) c----------------------------------------------------------------------- LOGICAL Lgraf INTEGER i,iend,l3,Mt1,numfct,nyear,ndfl,ndft,lasthl,Iforc,Xdsp DOUBLE PRECISION fstatl,fstatt,plevl,plevt,dvec,Sti DIMENSION dvec(1),Sti(PLEN) c----------------------------------------------------------------------- C--- INITIALIZE PRIOR FACTORS TO 100, INCLUDING ONE YEAR AHEAD FACTORS c----------------------------------------------------------------------- dvec(1)=ZERO numfct=Iforc IF(Iforc.eq.0)numfct=12 iend=Posfob+numfct+Xdsp DO i=Pos1bk,iend IF(i.le.Posfob)Yhol(i)=Sti(i)*ONEHUN X11hol(i)=ONEHUN END DO c----------------------------------------------------------------------- C--- CALCULATE NUMBER OF YEARS USED IN HOLIDAY ADJUSTMENT c----------------------------------------------------------------------- l3=iend-Pos1bk+1 nyear=l3/12 IF(mod(l3,12).ne.0)nyear=nyear+1 c----------------------------------------------------------------------- c Compute X-11 holiday factors. c----------------------------------------------------------------------- CALL holidy(X11hol,nyear,Pos1ob,Pos1bk,Begbak(YR),Posfob,numfct+ & Xdsp,fstatl,fstatt,ndfl,ndft,plevl,plevt,Keastr,Khol) c----------------------------------------------------------------------- c Convert holiday factors to ratios c----------------------------------------------------------------------- DO i=1,iend X11hol(i)=X11hol(i)/ONEHUN END DO c----------------------------------------------------------------------- c Print holiday factors c----------------------------------------------------------------------- IF(.not.Lhiddn)THEN IF(Prttab(LX11H1))THEN Kpart=0 c----------------------------------------------------------------------- c Print error message c----------------------------------------------------------------------- IF((Ieast(1)*Ieast(2)*Ieast(3)*Ieast(4)).eq.0)THEN IF(Ieast(1).eq.0)WRITE(Mt1,1010) 1010 FORMAT(/,10X,'NO YEARS WITH EASTER BEFORE APRIL 1ST.') IF(Ieast(2).eq.0)WRITE(Mt1,1020) 1020 FORMAT(/,10X,'NO YEARS WITH EASTER AFTER APRIL 16TH.') IF(Ieast(3).eq.0)WRITE(Mt1,1030) 1030 FORMAT(/,10X,'NO YEARS WITH EASTER BETWEEN APRIL 2ND ', & 'AND APRIL 8TH.') IF(Ieast(4).eq.0)WRITE(Mt1,1040) 1040 FORMAT(/,10X,'NO YEARS WITH EASTER BETWEEN APRIL 8TH ', & 'AND APRIL 15TH.') WRITE(Mt1,1050) 1050 FORMAT(/,10X,'NO EASTER ADJUSTMENT PERFORMED.') ELSE CALL table(X11hol,Pos1ob,Posfob+Xdsp,1,1,1,dvec,LX11H1) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Save holiday factors. Check if forecasts are to be printed out. c----------------------------------------------------------------------- IF(Savtab(LX11H1).or.Lgraf)THEN IF(Savfct)THEN lasthl=iend ELSE lasthl=Posfob+Xdsp END IF IF(Savtab(LX11H1))CALL punch(X11hol,Pos1ob,lasthl,LX11H1,F,F) IF(Lgraf)CALL punch(X11hol,Pos1ob,lasthl,LX11H1,Lgraf,F) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c put holiday factors into Fachol. If X-11 Regress performed, c combine with previous value of Fachol. c----------------------------------------------------------------------- c DO i=1,iend c IF(Ixreg.gt.0.and.Axrghl)THEN c Fachol(i)=Fachol(i)*fhol(i) c ELSE c Fachol(i)=fhol(i) c END IF c END DO c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END holidy.f0000664006604000003110000000576614521201516011643 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 12:12 pm **==holidy.f processed by SPAG 4.03F at 10:07 on 4 Oct 1994 SUBROUTINE holidy(Yhat,Nyear,Lfda,Lfbk,Lyr,Llda,Numfct,Fstatl, & Fstatt,Ndfl,Ndft,Plevl,Plevt,Keastr,Khol) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'xeastr.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c----------------------------------------------------------------------- DOUBLE PRECISION Fstatl,Fstatt,Plevl,Plevt,Yhat INTEGER i,j,k,l,l2,Lfda,lfdam,Llda,Lyr,m,mar,Ndfl,Ndft,Nyear, & Numfct,apr,Keastr,Khol,Lfbk,lfdam2,marbk DIMENSION Yhat(PLEN) c----------------------------------------------------------------------- INCLUDE 'kdate.prm' c----------------------------------------------------------------------- m=(Lfbk/12)*12+1 IF(mod(Lfbk,12).eq.0)m=m-12 c----------------------------------------------------------------------- c Generate X indicator vector c----------------------------------------------------------------------- IF(Lgenx)THEN l=Lyr-1900 l2=l+Nyear-1 DO i=l,l2 DO j=1,3 DO k=1,4 Xhol((m+(i-l)*12)+4*j-4+k)=dble(float((kdate(i,j)))) END DO END DO END DO END IF c----------------------------------------------------------------------- C --- LOCATE FIRST MARCH,AUGUST AND NOVEMBER IN X AND Y. SUBTRACT 100 C FROM FIRST MONTH. SUBTRACT SECOND MONTH FROM 100. c----------------------------------------------------------------------- c MAR = 15+M-1 c AUG = 20+M-1 c NOV = 23+M-1 lfdam=mod(Lfda,12) IF(lfdam.eq.0)lfdam=12 IF(Lfda.eq.Lfbk)THEN mar=3+m-1 IF(lfdam.gt.3)mar=mar+12 marbk=mar ELSE lfdam2=mod(Lfbk,12) IF(lfdam2.eq.0)lfdam2=12 marbk=3+m-1 IF(lfdam2.gt.3)mar=mar+12 m=(Lfda/12)*12+1 IF(mod(Lfda,12).eq.0)m=m-12 mar=3+m-1 IF(lfdam.gt.3)mar=mar+12 END IF apr=0 IF(lfdam.eq.4)apr=3 Fstatl=ZERO Ndfl=0 Plevl=ZERO Fstatt=ZERO Ndft=0 Plevt=ZERO c----------------------------------------------------------------------- c Generate Easter factors c----------------------------------------------------------------------- IF(Keastr.ge.1)THEN CALL easter(Yhat,mar,marbk,apr,Llda,Keastr,Numfct) ELSE CALL setint(-99,4,Ieast) END IF c----------------------------------------------------------------------- c Set holiday adjustment variable so that holiday factors will c be treated like prior adjustment factors c----------------------------------------------------------------------- Khol=2 c----------------------------------------------------------------------- RETURN END hrest.f0000664006604000003110000001646114521201517011473 0ustar sun00315stepsC Last change: BCM 5 Mar 1999 1:36 pm SUBROUTINE hrest(Iar,X,R,Hrp,Ipr,Ips,Iqr,Iqs,Iq,Iprs,Sp,Ndfobs, & Nefobs,Lprt,Info) IMPLICIT NONE c ------------------------------------------------------------------ c Hannen/Riesen estimation of ARMA models is performed as in c TRAMO/SEATS program by Gomez/Maravall. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO INTEGER PR PARAMETER(PR=PLEN/4,ONE=1D0,ZERO=0D0) c ------------------------------------------------------------------ DOUBLE PRECISION X,R,Hrp,a1,a2,ahat,phat,pcf,psum,psum1,psum2,pv, & tmp,xmat,tmpchl,ptmp LOGICAL Lprt INTEGER i,j,jj,j2,k,kk,Iar,Ipr,Ips,Iqr,Iqs,Iq,Iprs, & Nefobs,Sp,ncol,mxlg,Info,nc1,Ndfobs,i2 DIMENSION X(PLEN),R(PR),Hrp(PARIMA),ahat(PLEN),phat(PR),pcf(PR), & tmp(PLEN),xmat((PR+1)*PLEN),tmpchl(PXPX),ptmp(PARIMA), & a1(PLEN),a2(PLEN) c ------------------------------------------------------------------ INCLUDE 'autoq.cmn' c ------------------------------------------------------------------ CALL setdp(ZERO,PXPX,tmpchl) c ------------------------------------------------------------------ c If Ma terms in model, compute estimates of innovations c ------------------------------------------------------------------ IF (Iq.gt.0) THEN c ------------------------------------------------------------------ c Compute partial correlation coefficients c ------------------------------------------------------------------ c pcf(1)=R(1)/C0 pcf(1)=R(1) pv=C0*(ONE-pcf(1)*pcf(1)) phat(1)=pcf(1) DO i=2,Iar psum=ZERO DO j=1,i-1 psum=psum+phat(j)*(R(i-j)*C0) tmp(j)=phat(i-j) END DO pcf(i)=((R(i)*C0)-psum)/pv pv=pv*(ONE-pcf(i)*pcf(i)) phat(i)=pcf(i) DO j=1,i-1 phat(j)=phat(j)-pcf(i)*tmp(j) END DO END DO c ------------------------------------------------------------------ c Create estimates of innovations ahat c ------------------------------------------------------------------ DO i=1,Iar ahat(i)=X(i) DO j=1,Iar IF((i-j).GT.0)ahat(i)=ahat(i)-phat(j)*X(i-j) END DO END DO DO i=Iar+1,Ndfobs ahat(i)=X(i) DO j=1,Iar ahat(i)=ahat(i)-phat(j)*X(i-j) END DO END DO END IF c ------------------------------------------------------------------ ncol=Ipr+Ips*(Ipr+1)+Iqr+Iqs*(Iqr+1) nc1=ncol+1 mxlg=MAX0(Ipr+Sp*Ips,Iqr+Sp*Iqs) DO i=1+mxlg,Ndfobs i2=(i-mxlg-1)*nc1 DO j=1,Ipr xmat(j+i2)=-X(i-j) END DO DO j=1,Ips jj=(Ipr+1)*j xmat(jj+i2)=-X(i-j*Sp) DO k=1,Ipr xmat(jj+k+i2)=-X(i-j*Sp-k) END DO END DO kk=Ipr+(Ipr+1)*Ips jj=0 DO j=1,Iqr xmat(kk+j+i2)=ahat(i-j) END DO DO j=1,Iqs jj=kk+(Iqr+1)*j xmat(jj+i2)=ahat(i-j*Sp) DO k=1,Iqr xmat(jj+k+i2)=ahat(i-j*Sp-k) END DO END DO xmat(nc1+i2)=X(i) END DO c ------------------------------------------------------------------ Nefobs=Ndfobs-mxlg CALL olsreg(xmat,Nefobs,nc1,nc1,ptmp,tmpchl,PXPX,Info) IF(Lfatal)RETURN IF(Info.gt.0)THEN Info=PSNGER RETURN END IF c ------------------------------------------------------------------ DO i=1,Ipr Hrp(i)=ptmp(i) END DO DO i=1,Ips Hrp(Ipr+i)=ptmp((Ipr+1)*i) END DO DO i=1,Iqr Hrp(Iprs+i)=ptmp(Ipr+Ips*(Ipr+1)+i) END DO DO i=1,Iqs Hrp(Iprs+Iqr+i)=ptmp(Ipr+Ips*(Ipr+1)+(Iqr+1)*i) END DO c ------------------------------------------------------------------ c Removing third stage of HR, refers to X13tech_6-5-19.pdf c ------------------------------------------------------------------ c IF (Iq.GT.0) THEN c DO i=1,Ndfobs c tmp(i)=ZERO c END DO c DO i=1,Ndfobs c psum=X(i) c psum1=ZERO c psum2=ZERO c j2=(i-1)*nc1 c DO j=1,Ipr c IF ((i-j).GT.0) THEN c psum=psum+ptmp(j)*X(i-j) c psum1=psum1-ptmp(j)*A1(i-j) c xmat(j+j2)=-A1(i-j) c ELSE c xmat(j+j2)=ZERO c END IF c END DO c DO j=1,Ips c jj=(Ipr+1)*j c IF ((i-j*Sp).GT.0) THEN c psum=psum+ptmp(jj)*X(i-j*Sp) c psum1=psum1-ptmp(jj)*A1(i-j*Sp) c xmat(jj+j2)=-A1(i-j*Sp) c ELSE c xmat(jj+j2)=ZERO c END IF c DO k=1,Ipr c IF ((i-j*Sp-k).GT.0) THEN c psum=psum+ptmp(jj+k)*x(i-j*Sp-k) c psum1=psum1-ptmp(jj+k)*A1(i-j*Sp-k) c xmat(j2+jj+k)=-A1(i-j*Sp-k) c ELSE c xmat(j2+jj+k)=ZERO c END IF c END DO c END DO c kk=Ipr+(Ipr+1)*Ips c DO j=1,Iqr c IF ((i-j).GT.0) THEN c psum=psum-ptmp(kk+j)*tmp(i-j) c psum2=psum2-ptmp(kk+j)*A2(i-j) c xmat(kk+j+j2)=A2(i-j) c ELSE c xmat(kk+j+j2)=ZERO c END IF c END DO c DO j=1,Iqs c jj=kk+(Iqr+1)*j c IF ((i-j*Sp).GT.0) THEN c psum=psum-ptmp(jj)*tmp(i-j*Sp) c psum2=psum2-ptmp(jj)*A2(i-j*Sp) c xmat(jj+j2)=A2(i-j*Sp) c ELSE c xmat(jj+j2)=ZERO c END IF c DO k=1,Iqr c IF ((i-j*Sp-k).GT.0) THEN c psum=psum-ptmp(jj+k)*tmp(i-j*Sp-k) c psum2=psum2-ptmp(jj+k)*A2(i-j*Sp-k) c xmat(jj+k+j2)=A2(i-j*Sp-k) c ELSE c xmat(jj+k+j2)=ZERO c END IF c END DO c END DO c tmp(i)=psum c xmat(i*nc1)=psum c A1(i)=psum1+tmp(i) c A2(i)=psum2+tmp(i) c ------------------------------------------------------------------ c IF (DABS(psum).GT.1.D+10) THEN c IF (Lprt) THEN c CALL mkPOneLine(Mt1,'@', c & 'Some initial estimates cannot be obtained for HR estimation') c CALL mkPOneLine(Mt1,'center','Default values used.') c END IF c Info=-1 c RETURN c END IF c END DO c ------------------------------------------------------------------ c CALL olsreg(xmat,Ndfobs,nc1,nc1,ptmp,tmpchl,PXPX,Info) c IF(Lfatal)RETURN c IF(Info.gt.0)THEN c Info=PSNGER c RETURN c END IF c DO i=1,Ipr c Hrp(i)=Hrp(i)+ptmp(i) c END DO c DO i=1,Ips c Hrp(Ipr+i)=Hrp(Ipr+i)+ptmp((Ipr+1)*i) c END DO c DO i=1,Iqr c Hrp(Iprs+i)=Hrp(Iprs+i)+ptmp(Ipr+Ips*(Ipr+1)+i) c END DO c DO i=1,Iqs c Hrp(Iprs+Iqr+i)=Hrp(Iprs+Iqr+i)+ptmp(Ipr+Ips*(Ipr+1)+(Iqr+1)*i) c END DO c END IF c ------------------------------------------------------------------ RETURN END hspect.i0000664006604000003110000000022014521201517011621 0ustar sun00315stepsC C... Variables in Common Block /hspect/ ... integer NCHINS,NCYCNS,NPSINS,NADJNS common /hspect/ NCHINS,NCYCNS,NPSINS,NADJNS htmlfile.cmn0000664006604000003110000000050114521201517012466 0ustar sun00315stepsC----------------------------------------------------------------------- CHARACTER LogfHTML*(PFILCR),CsrsHTML*(PFILCR) INTEGER NlfHTML,NcsHTML,Nlflast,Ncslast C----------------------------------------------------------------------- COMMON /cfhtml/ NlfHTML,NcsHTML,Nlflast,Ncslast,LogfHTML,CsrsHTML htmlfortable.f0000664006604000003110000002106514521201517013025 0ustar sun00315steps subroutine htmlfortbl(fo,freg,ftr,fsa,fs,fcyc,fir,tse,siepf, $ siepfl,sieaf,sieafl,neff,mq,nouir,noutr,npatd, $ neast,nchi,npsi,ncyc,ncycth,lamd,nper,nyer,nz,lfor, $ isCloseToTD,varwnc) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer neff(0:7),mq,nouir,noutr,npatd,neast,nchi,npsi,ncyc, $ ncycth,lamd,nper,nyer,nz, lfor real*8 fo(-kp:kp),freg(-kp:kp),ftr(-kp:kp),fsa(-kp:kp),fs(-kp:kp), $ fcyc(-kp:kp),fir(-kp:kp),tse(kl),siepf(kl),siepfl(kl), $ sieaf(kl),sieafl(kl),varwnc logical isCloseToTD C C.. Local Scalars .. integer i,j,jnlastper,jnlastyear,ncols,nf,nlastper,nlastyear,nse C C.. Local Arrays .. character mth(12)*34,srt(11)*4 real*8 formatrix(kp,14),tmp(kp) C C.. External Calls .. external USRENTRY C C.. Intrinsic Functions .. intrinsic MAX, MOD include 'stream.i' C C.. Data Declarations .. data mth/ $ 'JAN ', $ 'FEB ', $ 'MAR ', $ 'APR ', $ 'MAY', $ 'JUN ', $ 'JUL ', $ 'AUG ', $ 'SEP', $ 'OCT ', $ 'NOV ', $ 'DEC '/ data srt/ $ '1ST','2ND','3RD','4TH','5TH','6TH','7TH','8TH','9TH','10TH', $ '11TH'/ C C ... Executable Statements ... C CALL mkTableTag(Nio,'w90','FORECAST OF FINAL COMPONENT') CALL writTag(Nio,'') CALL writTag(Nio,'') CALL mkTableCellSpan(Nio,'row',2,'head',' ') ncols = 1 nse = 1 nf = MAX(lfor,MAX(8,2*mq)) do i = 1,nf formatrix(i,ncols) = fo(i) formatrix(i,ncols+1) = tse(i) end do ncols = ncols + 1 CALL mkHeaderCellScope(Nio,0,2,'colgroup','@', & 'ORIGINAL (UNCORRECTED)') if ((nchi.gt.1) .or. (noutr.eq.1) .or. (neff(1).eq.1) .or. $ (neff(7).eq.1)) then nse = nse + 1 ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = ftr(i) tmp(i) = ftr(i) end do ncols = ncols + 1 if (lamd .eq. 0) then do i = 1,nf formatrix(i,ncols) = siepfl(i) end do else do i = 1,nf formatrix(i,ncols) = siepf(i) end do end if call USRENTRY(tmp,1,nf,1,kp,1410) CALL mkHeaderCellScope(Nio,0,2,'colgroup','@','TREND-CYCLE') end if if ((npsi.gt.1) .or. (neast.eq.1) .or. (neff(2).eq.1) .or. $ (npatd.eq.1)) then nse = nse + 1 ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = fsa(i) tmp(i) = fsa(i) end do ncols = ncols + 1 if (lamd .eq. 0) then do i = 1,nf formatrix(i,ncols) = sieafl(i) end do else do i = 1,nf formatrix(i,ncols) = sieaf(i) end do end if call USRENTRY(tmp,1,nf,1,kp,1409) CALL mkHeaderCellScope(Nio,0,2,'colgroup', & 'SEASONALLY ADJUSTED SERIES','SA SERIES') elseif (neff(0) .eq. 1) then nse = nse + 1 ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = fsa(i) tmp(i) = fsa(i) end do ncols = ncols + 1 if (lamd .eq. 0) then do i = 1,nf formatrix(i,ncols) = sieafl(i) end do else do i = 1,nf formatrix(i,ncols) = sieaf(i) end do end if call USRENTRY(tmp,1,nf,1,kp,1409) CALL mkHeaderCellScope(Nio,0,2,'colgroup', & 'SEASONALLY ADJUSTED SERIES','SA SERIES') end if if (neff(0) .eq. 1) then ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = freg(i) end do CALL mkHeaderCellScope(Nio,2,0,'col','@', & 'SEPARATE REGRESSION EFFECT') end if if ((npsi.gt.1) .or. (neast.eq.1) .or. (neff(2).eq.1) .or. $ (npatd.eq.1)) then ncols = ncols + 1 do i = 1,nf formatrix(i,ncols) = fs(i) tmp(i) = fs(i) end do call USRENTRY(tmp,1,nf,1,kp,1411) if (lamd .eq. 0) then CALL mkHeaderCellScope(Nio,2,0,'col','@','SEASONAL FACTORS') else CALL mkHeaderCellScope(Nio,2,0,'col','@','SEASONAL COMPONENT') end if end if if ((neff(3).eq.1) .or. (nouir.eq.1) .or. $ (varwnc.gt.1.0D-10 .and.(ncycth.eq.1 .or.ncyc.gt.1)) $ .or. (neff(5).eq.1)) then ncols = ncols + 1 if (lamd .eq. 1) then do i = 1,nf formatrix(i,ncols) = fir(i) + fcyc(i) tmp(i) = fir(i) end do else do i = 1,nf formatrix(i,ncols) = (fir(i)*fcyc(i)) / 100.0d0 tmp(i) = fir(i) end do end if call USRENTRY(tmp,1,nf,1,kp,1412) if (IsCloseToTD) then if (lamd .eq. 0) then CALL mkHeaderCellScope(Nio,2,0,'col', & 'Trading Day final - IRREGULAR FACTORS', & 'TDfinal.-IRREG.') else CALL mkHeaderCellScope(Nio,2,0,'col', & 'Trading Day final - IRREGULAR', & 'TDfinal.-IRREG.') end if else if (lamd .eq. 0) then CALL mkHeaderCellScope(Nio,2,0,'col', & 'TRANSITORY IRREGULAR FACTORS', & 'TRANS.-IRREG. FACTORS') else CALL mkHeaderCellScope(Nio,2,0,'col','TRANSITORY IRREGULAR', & 'TRANS.-IRREG.') end if end if end if CALL writTag(Nio,'') CALL writTag(Nio,'') CALL mkHeaderCellScope(Nio,0,0,'col','@','FORECAST') CALL mkHeaderCellScope(Nio,0,0,'col','standard error','SE') do i=1,nse-1 CALL mkHeaderCellScope(Nio,0,0,'col','@','FORECAST') CALL mkHeaderCellScope(Nio,0,0,'col', & 'standard error of the revision','SER') end do CALL writTag(Nio,'') CALL writTag(Nio,'') nlastper = nper nlastyear = nyer do i = 2,nz if (MOD(nlastper,mq) .eq. 0) then nlastyear = nlastyear + 1 nlastper = 0 end if nlastper = nlastper + 1 end do nlastper = nlastper + 1 if (nlastper .gt. mq) then nlastper = 1 nlastyear = nlastyear + 1 end if jnlastper = nlastper jnlastyear = nlastyear CALL writTag(Nio,'') do i = 1,nf if (mq .eq. 12) then write (Nio,1010) mth(nlastper), nlastyear else write (Nio,1010) srt(nlastper), nlastyear end if 1010 format('',a,1x,i4,'') do j = 1, nse*2, 2 write (Nio,1020) formatrix(i,j), formatrix(i,j+1) 1020 format(2('',f16.4,'')) end do if (nlastper .eq. mq) then nlastper = 1 nlastyear = nlastyear + 1 else nlastper = nlastper + 1 end if if (nse*2 .lt. ncols) then do j=nse*2+1,ncols write (Nio,1030) formatrix(i,j) 1030 format('',f16.4,'') end do end if CALL writTag(Nio,'') end do CALL writTag(Nio,'') write (Nio,'("")') CALL mkPOneLine(Nio,'@',' ') CALL mkPOneLine(Nio,'em','SE : standard error of the '// $ 'observation series forecast.') CALL mkPOneLine(Nio,'em','SER : standard error of the revision.') CALL mkPOneLine(Nio,'ub','Note 1 :') CALL mkPOneLine(Nio,'em', & 'Since the component is never observed, '// & 'the forecast error is of little applied interest. '// & 'What is of interest is the se of the revision the '// $ 'forecast of the component will undergo (until it '// $ 'becomes the final or historical estimator).') CALL mkPOneLine(Nio,'ub','Note 2 :') CALL mkPOneLine(Nio,'em','SER(Seasonal) = SER (SA Series)') end cc c cc html.i0000664006604000003110000000020714521201517011304 0ustar sun00315stepsC... Variables in Common Block /html/ ... character Toutfilename*180 integer nul common /html/ Toutfilename,nul htmlout.cmn0000664006604000003110000000173614521201517012371 0ustar sun00315stepsC----------------------------------------------------------------------- INTEGER PNINDX,PNFOOT PARAMETER(PNINDX=5000,PNFOOT=1000) C----------------------------------------------------------------------- INTEGER Inpe,Inse,Intv,Ingr,Invl,Inss,Indf,Inms,Infv,Inbt,Inrs, & Intl,Inrl,Inim,Infq,Inmd,Inmu,Insd,Indy,Inssp,Inmq, & Infoot,VFoot,Idxtab,Idxlog,Vindx,Inpmdl,Inplkh,Inpacf, & indCoef,indMdp,indMdl CHARACTER Cbr*6,Charhr*6 DIMENSION VFoot(PNFOOT),Vindx(PNINDX),Indy(7),Inssp(6) C----------------------------------------------------------------------- COMMON /chtml/ Inpe,Inse,Intv,Ingr,Invl,Inss,Indf,Inms,Infv,Inbt, & Inrs,Intl,Inrl,Inim,Infq,Inmd,Inmu,Insd,Inmq, & Idxtab,Idxlog,Infoot,Indy,Vfoot,Vindx,Inssp,Inpmdl, & Inplkh,Inpacf,Cbr,Charhr,indCoef,indMdp,indMdl C----------------------------------------------------------------------- htmlout.f0000664006604000003110000031605314521201517012042 0ustar sun00315stepsc c cc subroutine STRCAP(String) C C.. Implicits .. implicit none C C.. Formal Arguments .. character*(*) String C C.. Local Scalars .. integer I,Iasc,J C C.. External Functions .. integer ISTRLEN external ISTRLEN C C.. Intrinsic Functions .. intrinsic CHAR, ICHAR C C ... Executable Statements ... C J = ISTRLEN(String) Iasc = ICHAR(String(1:1)) if ((Iasc.gt.96) .and. (Iasc.lt.123)) then String(1:1) = CHAR(Iasc-32) end if do I = 2,J Iasc = ICHAR(String(I:I)) if ((Iasc.gt.64) .and. (Iasc.lt.91)) then String(I:I) = CHAR(Iasc+32) end if end do end cc c cc c Subroutine Introduc(nio,Lwidpr) c INPUT variables integer nio logical Lwidpr c integer istrlen external istrlen c include 'build.i' c if (Lwidpr) then write(nio,4001) compdate else write(nio,4003) compdate end if c 4001 format(/,58x,'PROGRAM SEATS+',//, & 42x,'(based on program SEATS,', & ' Victor Gomez and Agustin Maravall©, 1996)',//, & 38x,'Developed at the Bank of Spain ', & 'by Gianluca Caporello and Agustin Maravall,',/, & 38x,'with programming support from', & ' Domingo Pérez Cañete and Roberto López Pavón.',//, & 36x,'Help from Gabriele Fiorentini (1990 - 1991)', & ' and Christophe Planas (1992 - 1994) ',/, & 36x,'is also acknowleged.',//, c & 4x,'(Parts of the program are based as an experimental', c & ' program developed by J.P. Burman',//, c & 16x,' at the Bank of England, 1982 version.)',//,//, & 46x,'VERSION: 1.0 (',A,')',//) write(nio,4003) compdate(1:istrlen(compdate)) 4003 format(/,38x,'PROGRAM SEATS+',//, & 12x,'(based on program SEATS,', & ' Victor Gomez and Agustin Maravall©, 1996)',//, & 8x,'Developed at the Bank of Spain ', & 'by Gianluca Caporello and Agustin Maravall,',/, & 8x,'with programming support from', & ' Domingo Pérez Cañete and Roberto López Pavón.',//, & 6x,'Help from Gabriele Fiorentini (1990 - 1991)', & ' and Christophe Planas (1992 - 1994) ',/, & 6x,'is also acknowleged.',//, & 16x,'VERSION: 1.0 (',A,')',//) write(nio,4003) compdate(1:istrlen(compdate)) c return end cc c cc subroutine OpenFilePsie(ireturn) c.. Implicits .. implicit none c c.. Formal Argument In/Out integer ireturn include 'dirs.i' include 'stream.i' include 'stdio.i' c integer ISTRLEN external ISTRLEN c character fname*180 fname = Cursrs(1:Nfilcr)// '.psie' call OPENDEVICE(fname,37,0,ireturn) end cc c cc subroutine OpenFileTables(ireturn,iter,niter,title,numser) c.. Implicits .. implicit none c c.. Formal Argument In/Out integer ireturn,niter,iter,numser character nombreser*180,title*80 include 'dirs.i' include 'stream.i' include 'stdio.i' c integer ISTRLEN external ISTRLEN c character fname*180 c ireturn=0 if (niter.eq.1) then fname = Cursrs(1:Nfilcr)// '.tbs' call OPENDEVICE(fname,36,0,ireturn) end if end cc c cc subroutine OpenSummary(io,fname,ireturn) c.. Implicits .. implicit none c c.. Formal Argument In/Out character fname*180 integer ireturn,io c----- call OPENDEVICE(fname,io,0,ireturn) end c--- cc c cc subroutine OpenCompMatrix(ireturn,mq) C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Not Read, Overwritten .. integer ireturn,mq include 'dirs.i' include 'stream.i' c character filename*180 c integer ISTRLEN external ISTRLEN c integer j character AuxString*350 c filename=Outdir(1:ISTRLEN(Outdir)) // '\trendmod.m' call OPENDEVICE (filename,61,0,ireturn) write(61 ,'(3x,"n",8x,"Title",12x,"D",x,"PHIP(1)",x,"PHIP(2)",x, $ "PHIP(3)",x,"PHIP(4)",2x,"THP(1)",2x,"THP(2)",2x,"THP(3)", $ 2x,"THP(4)",2x,"THP(5)",2x,"THP(6)",2x,"THP(7)",2x, $ "Stand.Innov.Var")') cdos cdos filename=Outdir(1:ISTRLEN(Outdir)) // '\\samod.m' cunix filename=Outdir(1:ISTRLEN(Outdir)) // '/samod.m' call OPENDEVICE (filename,63,0,ireturn) auxString='' do j=1,9 write (auxString,'(A,2x,"PHIN(",i1,")")') $ auxString(1:istrlen(auxString)),j end do do j=10,16 write (auxString,'(A,x,"PHIN(",i2,")")') $ auxString(1:istrlen(auxString)),j end do do j=1,9 write (auxString,'(A,2x,"THN(",i1,")")') $ auxString(1:istrlen(auxString)),j end do do j=10,17 write (auxString,'(A,x,"THN(",i2,")")') $ auxString(1:istrlen(auxString)),j end do write (auxString,'(A,2x,"Stand.Innov.Var")') $ auxString(1:istrlen(auxString)) write (63,'(3x,"n",8x,"Title",12x,"D",A)') $ auxString(1:istrlen(auxString)) c cdos cdos filename=Outdir(1:ISTRLEN(Outdir)) // '\\seasmod.m' cunix filename=Outdir(1:ISTRLEN(Outdir)) // '/seasmod.m' call OPENDEVICE (filename,62,0,ireturn) auxString=' ' if (mq .eq. 12) then do j=1,9 write (auxString,'(A,x,"PHIS(",i1,")")') $ auxString(1:istrlen(auxString)),j end do do j=10,14 write (auxString,'(A,x,"PHIS(",i2,")")') $ auxString(1:istrlen(auxString)),j end do else do j=1,mq+2 write (auxString,'(A,x,"PHIS(",i1,")")') $ auxString(1:istrlen(auxString)),j end do end if if (mq.ge.6) then do j=1,9 write (auxString,'(A,2x,"THS(",i1,")")') $ auxString(1:istrlen(auxString)),j end do do j=10,2*mq+1 write (auxString,'(A,x,"THS(",i2,")")') $ auxString(1:istrlen(auxString)),j end do else do j=1,2*mq+1 write (auxString,'(A,2x,"THS(",i1,")")') $ auxString(1:istrlen(auxString)),j end do end if write (62,'(3x,"n",8x,"Title",12x,"S",A,2x, $ "Stand.Innov.Var")') auxString(1:istrlen(auxString)) c c filename=Outdir(1:ISTRLEN(Outdir)) // '\transmod.m' call OPENDEVICE (filename,64,0,ireturn) write (auxString,'(" PHIC(1)")') do j=2,9 write (auxString,'(A,2x,"PHIC(",i1,")")') $ auxString(1:istrlen(auxString)),j end do do j=10,15 write (auxString,'(A,x,"PHIC(",i2,")")') $ auxString(1:istrlen(auxString)),j end do if (mq.eq.12) then do j=1,9 write (auxString,'(A,2x,"THC(",i1,")")') $ auxString(1:istrlen(auxString)),j end do do j=10,15 write (auxString,'(A,x,"THC(",i2,")")') $ auxString(1:istrlen(auxString)),j end do else do j=1,mq+3 write (auxString,'(A,2x,"THC(",i1,")")') $ auxString(1:istrlen(auxString)),j end do end if write(64,'(3x,"n",8x,"Title",11x,A,2x,"Trans.Innov.Var",3x, $ "Irreg.innov.Var")') $ auxString(1:istrlen(auxString)) return end cc c cc subroutine CloseCompMatrix() C.. Implicits .. implicit none close(61) close(62) close(63) close(64) return end cc c cc subroutine CloseOldMatrix() C.. Implicits .. implicit none include 'seatserr.i' close(65) close(66) close(67) close(74) close(76) return end C C C subroutine HPparOUT(HPper,HPlan,HPpar) implicit none include 'stream.i' integer HPpar real*8 HPlan,HPper C C TXT C if (HPPAR .eq. 0) then write(Nio,'(6X,''Period'', $ '' associated with a 50% gain of filter:'', $ F10.1,'' (Default value)'')')HPper else write(Nio,'(6X,''Period'', $ '' associated with a 50% gain of filter:'', $ F10.1)')HPper end if write(Nio,'(6X,''Implied value for HP LAMBDA='', $ F15.4)') HPlan end c c c subroutine OutHPcycle(HPcycle) IMPLICIT NONE include 'stream.i' integer HPCYCLE if (HPcycle.eq.1) then write(Nio,1001)'(1) DECOMPOSITION OF THE TREND-CYCLE'// $ ' COMPONENT INTO : ' write(Nio,1002)' LONG-TERM TREND + CYCLE' else if (HPcycle.eq.2) then write(Nio,1001)'CYCLE EXTRACTED FROM SA SERIES' else write(Nio,1001)'CYCLE EXTRACTED FROM ORIGINAL SERIES' end if 1001 format(6X,a) 1002 format(10X,a) end c c c subroutine OutHeadHP(MoStrCt,MoStrMt,HPth,Km, $ HPper,HPlam,HPpar,HPcycle,VfcBc, $ VfcM,VfBc,WithoutVf,MQ,DBD,Vcomp) IMPLICIT NONE include 'stream.i' include 'spectra.i' include 'sig.i' character MoStrCt*(MaxStrLength),MoStrMt*(MaxStrLength), $ LongTermCad*22 real*8 HPth(3),Km,HPper,HPlam,Vcomp integer HPpar,HPcycle,MQ,DBD real*8 VfcBc,VfcM,VfBc integer WithoutVf c External external ISTRLEN integer ISTRLEN intrinsic SQRT c LOCAL PARAMETERS character StrFicMo*120 integer lmoStrMt real*8 Stdc,Stdm c Stdc=SQRT(Km*HPlam*Vcomp)*SQF Stdm=SQRT(Km*Vcomp)*SQF If (HPcycle.eq.1) then LongTermCad='LONG TERM TREND' else if (HPcycle.eq.2) then LongTermCad='SA series without BC' else LongTermCad='Series without BC' end if call strFicModel(HPth,StrFicMo) write(Nio,*)' PART 6 : ESTIMATION OF THE CYCLE' write(Nio,*)' --------------------------------' write(Nio,*)' MODIFIED HODRICK-PRESCOTT FILTER' write(Nio,1000) 1000 format(/) call OutHPcycle(HPcycle) write(Nio,1000) call HPparOUT(HPper,HPlam,HPpar) write(Nio,1000) write(Nio,1001)'"FICTICIOUS" MODEL FOR WK IMPLEMENTATION'// $ ' OF FILTER' 1001 format(6x,a) write(Nio,1001)StrFicMo(1:ISTRLEN(StrFicMo)) write(Nio,1000) write(Nio,1001)'(2) ARIMA Models' write(Nio,*)' ' write(Nio,1001)'Stochastic '// $ LongTermCad(1:istrlen(LongTermCad))//' m(t):' lMoStrMt=ISTRLEN(MoStrMt) write(Nio,1001)MoStrMt(1:lMoStrMt) write(Nio,*)' ' write(Nio,1001)'Stochastic Cycle c(t):' write(Nio,1001)MoStrCt(1:ISTRLEN(MoStrCt)) write(Nio,1000) write(Nio,1001)'(3) Std of innovations' write(Nio,*)' ' write(Nio,1002)'Long Term Trend: ',Stdm 1002 format(6X,A,G15.4) write(Nio,1002)'Business Cycle: ',Stdc write(Nio,1000) write(Nio,1001)'(4) FINAL ERRORS' if (withoutVf.eq.1) then write(Nio,*)' The business Cycle Component got unit roots', $ ' in the AR part, so the variance of final error of ', $ 'Business Cycle and ',LongTermCad(1:istrlen(LongTermCad)), $ ' is infinite.' else if (withoutVf.eq.2) then Write(Nio,*)' The AR part of Business Cycle component ', $ 'got roots too close to unity to proper calculate', $ ' the final error variance' else if ((withoutVf.eq.0).or.(withoutVf.eq.3)) then write(Nio,1003)'Business Cycle',VfcBc write(Nio,1003)LongTermCad(1:istrlen(LongTermCad)),VfcM 1003 format(' Var(final error of ',A,' Component)= ',t55, $ G15.4,' in units of Va') c write(Nio,'( c $ "Var(final error of Business Cycle)= ", c $ G15.4," in units of Va")')VfBc end if call AreaStat(spectBC,Lspect,MQ,'SPECTRUM OF CYCLE',DBD) end cc c cc * subroutine WrTabHtmPol(wData,longDat,nio,icode) * IMPLICIT NONE *c Parameters * real*8 wData(32) * integer longDat,icode,nio *c local * integer i,lsSum,lsH * character sSummary*80,sH*10,wformat*65 *c * select case (icode) * case(4) * sSummary='coefficients of the autoregressive seasonal'// * $ ' component' * lsSum=53 * sH='PHIST' * lsH=5 * Case(3) * sSummary='coefficients of the non stationary '// * $ 'autoregressive seasonal component' * lsSum=68 * sH='DELS' * lsH=4 * Case(2) * sSummary='coeffients of the stationary seasonal component' * lsSum=47 * sH='PHIS' * lsH=4 * Case(1) * sSummary='Coefficients of total moving average polynomial' * lsSum=47 * sH='THT' * lsH=3 * Case(5) * sSummary='coefficients of the stationary '// * $ 'autoregressive seasonally adjusted component' * lsSum=74 * sH='PHIN' * lsH=4 * case(6) * sSummary='coefficients of the non stationary autoregressive'// * $ 'seasonally adjusted component' * lsSum=77 * sH='DELN' * lsH=4 * Case(7) * sSummary='Coefficients of the autoregressive seasonally '// * $ 'adjusted component' * lsSum=65 * sH='PHINT' * lsH=5 * Case(8) * sSummary='Total Denominator.Coefficients of the total '// * $ 'autoregressive polynomial' * lsSum=70 * sH='PHIT' * lsH=4 * endselect *c * if (longDat.le.12) then * write (nio,'('''')') sSummary(1:lsSum) * write (nio,'("")') * if (longDat.le.10) then * do i=1,longDat * write (nio,'('''')') * $ sH(1:lsH),i-1 * end do * else * do i=1,10 * write (nio,'('''')') * $ sH(1:lsH),i-1 * end do * do i=11,longDat * write (nio,'('''')') * $ sH(1:lsH),i-1 * end do * end if * write (nio,'("")') * write (wformat,'(''("",'',i2,''("")'', * $ '',"")'')') longDat * write (nio,wformat) (wData(i), i = 1,longDat) * write (Nio,'("
'',A,''('',i1,'')'',A,''('',i1,'')'',A,''('',i2,'')
",f8.4,"
")') * else * if (longDat.le.24) then * write(nio,'('''')') * $ sSummary(1:lsSum) * write(nio,'('''',10(''''))') (sH(1:lsH),i-1,i=1,10) * write(nio,'(2(''''),'''')') (sH(1:lsH),i-1,i=11,12) * write (nio,'('''',12(''''),'''')') * $ (wData(i), i = 1,12) * write (Nio,'("
'',A,''('',i1,'')'', * $ '''',A,''('',i2,'')'', * $ ''
'',f8.4,''
")') * write(nio,'('''')') * $ sSummary(1:lsSum) * write (nio,'("")') * do i=13,longDat * write (nio,'('''')') * $ sH(1:lsH),i-1 * end do * write (nio,'("")') * write (wformat,'(''("",'',i2,''("")'', * $ '',"")'')') longDat-12 * write (nio,wformat) (wData(i), i = 13,longDat) * write (Nio,'("
'',A,''('',i2,'')
",f8.4,"
")') * else * write(nio,'('''')') * $ sSummary(1:lsSum) * write(nio,'('''',10(''''))') (sH(1:lsH),i-1,i=1,10) * write(nio,'(2(''''),'''')') (sH(1:lsH),i-1,i=11,12) * write (nio,'('''',12(''''),'''')') * $ (wData(i), i = 1,12) * write (Nio,'("
'',A,''('',i1,'')'', * $ '''',A,''('',i2,'')'', * $ ''
'',f8.4,''
")') * write(nio,'('''')') * $ sSummary(1:lsSum) * write(nio,'('''',12(''''),'''')') (sH(1:lsH),i-1,i=13,24) * write (nio,'('''',12(''''),'''')') * $ (wData(i), i = 13,24) * write (Nio,'("
'',A,''('',i2,'')'', * $ ''
'',f8.4,''
")') * write(nio,'('''')') * $ sSummary(1:lsSum) * write (nio,'("")') * do i=25,longDat * write (nio,'('''')') * $ sH(1:lsH),i-1 * end do * write (nio,'("")') * write (wformat,'(''("",'',i2,''("")'', * $ '',"")'')') longDat-24 * write (nio,wformat) (wData(i), i = 25,longDat) * write (Nio,'("
'',A,''('',i2,'')
",f8.4,"
")') * end if * end if * end c c subroutine writeF69Note(fileUnit) integer htm,fileUnit c write (fileUnit,*) write (fileUnit,*) write (fileUnit,*) write (fileUnit,*) write (fileUnit, c $ '('' mq=12: *(1)= 2.1878 rad , *(2)= 2.7143 rad'')') $ '('' mq=12: TD= 2.1878 rad '')') write (fileUnit, c $ '('' mq=4 : *(1)= 0.2802 rad , *(2)= 0.5611 rad'')') $ '('' mq=4 : TD= 0.2802 rad '')') write (fileUnit,*) write (fileUnit, $ '(" AT : peaks detected in AR(30)", $ " and using Tukey spectrum estimator")') write (fileUnit, $ '(" A- : only peaks detected in AR(30) spectrum estimator")') write (fileUnit, $ '(" -T : only peaks detected ", $ "using Tukey estimator spectrum")') write (fileUnit, $ '(" -- : No peaks detected in AR(30)", $ " nor using Tukey spectrum estimator")') end cc c cc subroutine ClosePeaksMatrix(fileUnit) implicit none integer htm,fileUnit logical bool inquire (unit=fileUnit,opened=bool) if (bool) then call writeF69Note(fileUnit) close(fileUnit) end if return end c c c subroutine wrLnTabPeaks(fileUnit,niter,matTitle,picos, $ IsTable) implicit none C INPUT PARAMETERS integer fileUnit,niter,IsTable character matTitle*180,picos(7)*2 c LOCAL VARIABLES integer i,tmp c EXTERNAL character cadTablePeaks*180,cadSummPeaks*180 c--------------------- tmp= 6 if (IsTable.gt.0) then write(cadTablePeaks,'(A,I1,A)') "(i4,3x,a,x,",tmp+1,"(A,5x))" write(fileUnit,cadTablePeaks) $ niter,mattitle(1:22),(picos(i),i=1,7) else write(cadSummPeaks,'(A,I1,A)') "(7x,",tmp+1,"(A,5x))" write(fileUnit,cadSummPeaks) (picos(i),i=1,7) end if end subroutine c c c rober: Esta rutina queda por modificar! La salida no ajusta bien y no estaba bien parametrizada c faltan en las cabeceras para peaks*.m n y nser c c tableHeadPeaks: write the head of peaks tables in peaks*.m or in summary*.txt subroutine tableHeadPeaks(io,MQ,CompName,isTable) implicit none integer io,MQ,isTable character CompName*(*) c LOCAL VARIABLES character*80 cadTableHead character*6 cad(6) integer i,skipPos,tmp data cad /'one ','two ','three ', $ 'four ' ,'five ','six '/ c ------------------- if (isTable.eq.1) then skipPos=25 tmp=6 else skipPos=2 tmp=MQ/2 end if write(cadTableHead,'("(",I2,"X,''Stochastic Component: ", $ A,"'')")') skipPos,CompName write(io,cadTableHead) if (tmp.eq.6) then write (cadTableHead,'(A,I2,A,A)') $ '(',skipPos,'x,5x,', $ '''Seasonal frequencies(cycles per year and TD freq.(rad.)'')' write(io,cadTableHead) else write (cadTableHead,'(A,I2,A)') $ '(',skipPos,'x,5x,e''SEAS. freq. TD(rad.)'')' write(io,cadTableHead) end if c write (cadTableHead,'(A,I2,A,I2,A)') '(',skipPos, $ 'x,4x,',tmp*6,'(''-''),2x,7(''-''))' write (io,cadTableHead) write(cadTableHead,'(A,I2,A,I1,A)') $ "(",skipPos+5,"x,",tmp+1,"(A,x))" write (io,cadTableHead) (cad(i),i=1,tmp)," TD " end subroutine c--------------------------------------- subroutine warnPeaks(nio,picos,nameType,mq) implicit none integer nio,mq character picos(7)*2,nameType*20 character auxwrPeak*5,lnPeak*40 integer ipeaks integer ISTRLEN external ISTRLEN c LOCAL PARAMETERS integer i c--------------------------------------- if ((picos(7)(1:1).eq.'A') .or. (picos(7)(2:2).eq.'T')) then write (nio,'(4x,''Detected a Spectral peak in '',A $ '' for the TD frequency '')') $ nameType(1:ISTRLEN(nameType)) end if ipeaks=0 auxwrPeak=' ' lnpeak=' ' do i = 1,6 if ((picos(i)(1:1).eq.'A').or.(picos(i)(2:2).eq.'T')) then ipeaks=ipeaks+1 write(auxwrPeak,'(I1,"PI/6")') i*12/MQ lnPeak=lnpeak(1:ISTRLEN(lnpeak))//' '//auxwrpeak c if (HTML .eq. 1) then c write (nio,'(''

There is a Spectral peak in '',A, c $ '' for the Seasonal frequency : '',I1, c $ ''PI/6

'')') c $ nameType(1:ISTRLEN(nameType)) , i*12/MQ c else c write (nio,'(4x,''There is a Spectral peak in '',A, c $ '' for the Seasonal frequency : '',I1, c $ ''PI/6'')') nameType(1:ISTRLEN(nameType)) , i*12/MQ c end if end if end do if (ipeaks.gt.0) then if (ipeaks.eq.1) then write(nio,*) write (nio,'(4x,''There is a Spectral peak in '',A, $ '' for the Seasonal frequency : '',A6)') $ nameType(1:ISTRLEN(nameType)) ,LnPeak(1:6) else write(nio,*) write (nio,'(4x,''There is a Spectral peak in '',A, $ '' for the Seasonal frequencies : '',A40)') $ nameType(1:ISTRLEN(nameType)) , LnPeak end if end if end c subroutine wrHeadTGenSumS(nio) integer nio c write (nio,'(3x,''Decomposition : General'')') write (nio,*) write (nio,*) write (nio ,'(5x,''Pread.'',x,''Model'',3x, $ ''Approx.'',15x,''Model'',17x,''SD(a)'',4x, $ ''SEAS_NP(a)'',5x,''Spectr.'',x,''Check'',2x, $ ''Check'',5x,''Determ.'')') write (nio,'(12x,''Changed'',x,''to NA'',63x,''Factor'', $ 2x,''on ACF'',x,''on CCF'',2x,''Comp. Modif.'')') write (nio,'(28x,''m'',4x,''p'',4x,''d'',4x, $ ''q'',4x,''bp'',4x,''bd'',4x,''bq'', $ 48x,''TC'',x,''S'',x,''U'',x, $ ''TRANS'',x,''SA'')') end c c c subroutine wrHeadTparIISumS(nio) integer nio write (nio,'(3x,''Decomposition : Properties'')') write (nio,*) write (nio ,'(17x,''Convergence'', $ 23x,''Signif. Stoch.'',21x,''DAA'')') write (nio,'(19x,''(in %)'',26x,''Season. (95%)'')') write (nio,'(11x,''1Y'',17x,''5Y'')') write (nio ,'(8x,''TC'',8x,''SA'',8x,''TC'',8x,''SA'', $ 8x,''Hist.'',5x,''Prel.'',5x,''Fore.'',11x,''TC'', $ 8x,''SA'')') end cc c cc subroutine tablaPicos(u,SA,TR,IR,mq,totalSeasTR, $ totalSeasSA,totalSeasIR) implicit none integer u,mq,totalSeasTR,totalSeasSA,totalSeasIR integer istrlen character SA(7)*2,TR(7)*2,IR(7)*2,srad*6 logical SeasSpectCrit2,TDSpectCrit external SeasSpectCrit2,TDSpectCrit c LOCAL VARIABLES character*7 cad(7) character*1 wchar integer i data cad /' One ',' Two ',' Three ', $ ' Four ' ,' Five ',' Six ',' TD '/ c c * if ((mq.ne.4) .and. (mq.ne.12)) return if (mq.ne.12) return if (mq.eq.12) then sRad='2.1878' else sRad='0.2802' end if write(u,*) write(u,*) write(u,*) if (u.eq.16) then write(u,*) 'SPECTRAL DIAGNOSTICS' write(u,*) '--------------------' write(u,*) write(u,1010) 1010 format('A. STOCHASTIC SEASONAL AND TRADING DAY SPECTRAL PEAKS') else write(u,1020) 1020 format(3x,'Stochastic seaonal and trading day spectral peaks') end if write(u,*) if (mq.eq.12) then write(u,1030) 1030 format(36x,'Frequency (cycles per yer)',14x,'TD') write(u,1040) (cad(i), i=1,6),sRad 1040 format(29x,6(A7),2x,'(',A6,' rad)') write(u,1050)'Seasonally adjusted series',(SA(i), i=1,7) write(u,1050)'Trend-Cycle component ',(TR(i), i=1,7) write(u,1050)'Irregular component ',(IR(i), i=1,7) 1050 format(1x,a,4x,6(A2,5x),3x,A2) * else if (mq.eq.4)then * write(u,'(28x,''Frequency (cycles per yer)'',8x,''TD'')') * write(u,'(30x,2(A7,6x),x,"(",A6," rad)")') (cad(i), i=1,2),sRad * write(u,'(x,"Seasonally adjusted series",7x,2(A2,11x),2x,A2)') * $ (SA(i), i=1,2),SA(7) * write(u,'(x,"Trend-Cycle component ",7x,2(A2,11x),2x,A2)') * $ (TR(i),i=1,2),TR(7) * write(u,'(x,"Irregular component ",7x,2(A2,11x),2x,A2)') * $ (IR(i), i=1,2), IR(7) end if write(u,*) write (u,1060)'AT','peaks detected in AR(30) and using Tukey '// $ 'spectrum estimator' write (u,1060)'A-','only peaks detected in AR(30) spectrum '// $ 'estimator' write (u,1060)'-T','only peaks detected using Tukey estimator '// $ 'spectrum' write (u,1060)'--','No peaks detected in AR(30) nor using '// $ 'Tukey spectrum estimator' 1060 format(1x,a,' : ',a) write(u,*) if (u.eq.16) then write(u,*) write(u,*) write(u,*) 'B. STOCHASTIC SEASONALITY: SPECTRAL EVIDENCE' write(u,*) write(u,*) ' 1 : EVIDENCE OF RESIDUAL SEASONALITY.' write(u,*) ' 0 : NO EVIDENCE OF RESIDUAL SEASONALITY OR '// $ 'EVIDENCE IS TOO WEAK.' write(u,*) if ((MQ.ne.12.and.SeasSpectCrit2(SA,mq)).or. $ (MQ.eq.12.and.totalSeasSA.ge.5)) then wchar='1' else wchar='0' end if write(u,1070)'IN SEASONALLY ADJUSTED SERIES :',wchar if ((MQ.ne.12.and.SeasSpectCrit2(TR,mq)).or. $ (MQ.eq.12.and.totalSeasTR.ge.5)) then wchar='1' else wchar='0' end if write(u,1070)'IN TREND-CYCLE COMPONENT : ',wchar if ((MQ.ne.12.and.SeasSpectCrit2(IR,mq)).or. $ (MQ.eq.12.and.totalSeasIR.ge.5)) then wchar='1' else wchar='0' end if write(u,1070)'IN IRREGULAR COMPONENT : ',wchar 1070 format(x,a,1x,A1) c tabla trading day effect write(u,*) write(u,*) write(u,*) write(u,*)'C. TRADING DAY EFFECT: SPECTRAL EVIDENCE' write(u,*) write(u,*)' 1 : EVIDENCE OF RESIDUAL TRADING DAY EFFECT' write(u,*)' 0 : NO EVIDENCE OF RESIDUAL TRADING DAY EFFECT '// & 'OR EVIDENCE IS TOO WEAK.' write(u,*) if (TDSpectCrit(SA)) then wchar='1' else wchar='0' end if write(u,1070)'IN SEASONALLY ADJUSTED SERIES :', wchar if (TDSpectCrit(TR)) then wchar='1' else wchar='0' end if write(u,1070)'IN TREND-CYCLE COMPONENT : ', wchar if (TDSpectCrit(IR)) then wchar='1' else wchar='0' end if write(u,1070)'IN IRREGULAR COMPONENT : ', wchar end if write(u,*) * write(u,*) * write(u,*) ' Note: With rsa=3, trading day effect can be'// * $ ' imposed by enterinwg itrad=1,2,6 or 7.' end cc c cc subroutine wrTablaTestSeas(u,saS,trendS,irS) integer u,saS,trendS,irS write(u,*) write(u,*) write(u,'(''OVERALL TEST FOR IDENTIFIABLE SEASONALITY'')') write(u,'(''(Convination of significance of autocorrelation '', $ ''for seasonal lags, '')') write(u,'(''non parametric, and spectral test)'')') write(u,*) write(u,'(" 1 : IDENTIFIABLE SEASONALITY DETECTED.")') write(u,'(" 0 : NO IDENTIFIABLE SEASONALITY IS DETECTED.")') write(u,*) write(u,'(x,"IN SEASONALLY ADJUSTED SERIES :",x,I1)') saS write(u,'(x,"IN TREND-CYCLE COMPONENT : ",x,I1)') trendS write(u,'(x,"IN IRREGULAR COMPONENT : ",x,i1)') irS write(u,*) write(u,*) write(u,*) end c c OutDenC1: escribe en la salida y en USRENTRY los denominadores de los componentes subroutine OutDenC1(Out,Nio,Titleg, $ p,d,q,bp,bd,bq,theta,nTh,Btheta,nBth, $ phi,nPhi,Bphi,nBphi,noserie) implicit none c INPUT PARAMETERS integer Out,Nio,p,d,q,bp,bd,bq,nTh,nBth,nPhi,nBphi,noserie character Titleg*80 real*8 theta(4),Btheta(25),phi(4),Bphi(13) c LOCAL PARAMETERS integer i character wformat*65 * include 'indhtml.i' include 'transcad.i' c --------------- if (Out .eq. 0) then 7000 format ( $ /,' PART 2 : DERIVATION OF THE MODELS ', $ 'FOR THE COMPONENTS AND ESTIMATORS',/ $ ' ----------------------------------', $ '---------------------------------',//) write (Nio,7000) 7001 format (/,' SERIES TITLE: ',a) write (Nio,7001) Titleg 7002 format ( $ /,' MODEL PARAMETERS'/' (',i1,',',i1,',',i1,')(',i1,',',i1,',' $ ,i1,')'//' PARAMETER VALUES : COEFFIC. OF POLYNOMIALS IN B', $ ' OF THE MODEL (TRUE SIGNS)') write (Nio,7002) p, d, q, bp, bd, bq 7003 format (/,' THETA PARAMETERS') write (Nio,7003) 7004 format (' ',16(f5.2,2x)) write (Nio,7004) (theta(i), i = 1,nth) 7005 format (/,' BTHETA PARAMETERS') write (Nio,7005) write (Nio,7004) (btheta(i), i = 1,nbth) 7006 format (/,' PHI PARAMETERS') write (Nio,7006) write (Nio,7004) (phi(i), i = 1,nphi) 7007 format (/,' BPHI PARAMETERS') write (Nio,7007) write (Nio,7004) (bphi(i), i = 1,nbphi) end if end c c c subroutine OutDenCN(Out, c $ Nidx, $ Nio, c $ Titleg, $ init,pstar, c $ p,d,q,bp,bd,bq,theta,nTh,Btheta,nBth, c $ phi,nPhi,Bphi,nBphi, $ ThStar,Qstar, $ Chis,nChis,Chins,nChins,Chi,nChi, $ Cycs,nCycs,Cycns,nCycns,Cyc,nCyc, $ Psis,nPsis,Psins,nPsins,Psi,nPsi, $ Adjs,nAdjs,Adjns,nAdjns,Chcyc,nChcyc, $ Totden,nTot) implicit none INCLUDE 'srslen.prm' include 'dimensions.i' c INPUT PARAMETERS integer Out,Nio,init,pstar, c $ Nidx, c $ p,d,q,bp,bd,bq,nTh,nBth, c $ nPhi,nBphi, $ Qstar,nChis,nChins,nChi, $ nCycs,nCycns,nCyc, $ nPsis,nPsins,nPsi, $ nAdjs,nAdjns,nChcyc, $ nTot c character Titleg*80 real*8 ThStar(maxTH), c $ theta(4),Btheta(25),phi(4),Bphi(13), $ Chis(5),Chins(8),Chi(8), $ Cycs(17),Cycns(5),Cyc(17),Psis(16),Psins(27),Psi(27), $ Adjs(17),Adjns(8),Chcyc(20),Totden(40) c LOCAL PARAMETERS integer i character wformat*65 * include 'indhtml.i' include 'transcad.i' c --------------- C C PRINTOUT OF THE DENOMINATORS C if (Out .eq. 0) then 7008 format ( $ /,' ','NUMERATOR OF THE MODEL (TOTAL MOVING AVERAGE ', $ 'POLYNOMIAL)') write (Nio,7008) 7009 format ( $ ' ','---------------------------------------------', $ '-----------') write (Nio,7009) 7010 format (12f8.4) write (Nio,7010) (Thstar(i), i = 1,Qstar) write (Nio, $ '(///,'' FACTORIZATION OF THE TOTAL AUTOREGRESSIVE POLYNOMIAL'' $ ,/,'' -----------------------------------------------------'',/ $ )') 7011 format (/,' ','STATIONARY AUTOREGRESSIVE TREND-CYCLE') write (Nio,7011) write (Nio,7010) (Chis(i), i = 1,Nchis) call USRENTRY(Chis,1,Nchis,1,5,1059) if ((init.ne.2) .and. (ABS(Chis(Nchis+1)-99.99).lt.1.d-12)) then 7012 format ( $ 'WARNING:',/,'Stationary Autoregressive ',a, $ ' MAY HAVE UNIT ROOT') write (Nio,7012) 'Trend-Cycle' end if 7013 format (/,' ','NON-STATIONARY AUTOREGRESSIVE TREND-CYCLE') write (Nio,7013) write (Nio,7010) (Chins(i), i = 1,Nchins) call USRENTRY(Chins,1,Nchins,1,8,1058) if ((init.ne.2) .and. (ABS(Chins(Nchins+1)-99.99).lt.1.d-12)) $ then 7014 format ( $ 'WARNING:',/,'Non-Stationary Autoregressive ',a, $ ' Component MAY HAVE UNIT ROOT') write (Nio,7014) 'Trend' end if 7015 format (/,' ','AUTOREGRESSIVE TREND-CYCLE') write (Nio,7015) 7016 format (' ','--------------------------') write (Nio,7016) write (Nio,7010) (Chi(i), i = 1,Nchi) 7017 format (/,' ','STATIONARY AUTOREGRESSIVE ',A,' COMPONENT') write (Nio,7017) TransLcad(1:nTransLcad) write (Nio,7010) (Cycs(i), i = 1,Ncycs) call USRENTRY(Cycs,1,Ncycs,1,17,1060) if ((init.ne.2) .and. (ABS(Cycs(Ncycs+1)-99.99).lt.1.d-12)) then write (Nio,7012) TransLCad(1:nTransLcad) end if 7018 format (/,' NON-STATIONARY AUTOREGRESSIVE ',A,' COMP') write (Nio,7018) transLcad(1:ntransLcad) write (Nio,7010) (Cycns(i), i = 1,Ncycns) call USRENTRY(Cycns,1,Ncycns,1,5,1061) if ((init.ne.2) .and. (ABS(Cycns(Ncycns+1)-99.99).lt.1.d-12)) $ then write (Nio,7014) transLcad(1:ntransLcad) end if 7019 format (/,' ','AUTOREGRESSIVE ',A,' COMP.') write (Nio,7019) transLcad(1:nTransLcad) 7020 format (' ','------------------------------') write (Nio,7020) write (Nio,7010) (Cyc(i), i = 1,Ncyc) 7021 format (/,' ','STATIONARY AUTOREGRESSIVE SEASONAL COMPONENT') write (Nio,7021) write (Nio,7010) (Psis(i), i = 1,Npsis) call USRENTRY(Psis,1,Npsis,1,16,1151) if ((init.ne.2) .and. (ABS(Psis(Npsis+1)-99.99).lt.1.d-12)) then write (Nio,7012) 'Seasonal' end if 7022 format (/,' ','NON-STATIONARY AUTOREGRESSIVE SEASONAL', $ ' COMPONENT') write (Nio,7022) write (Nio,7010) (Psins(i), i = 1,Npsins) call USRENTRY(Psins,1,Npsins,1,27,1150) if ((init.ne.2) .and. (ABS(Psins(Npsins+1)-99.99).lt.1.d-12)) $ then write (Nio,7014) 'Seasonal' end if 7023 format (/,' ','AUTOREGRESSIVE SEASONAL COMPONENT') write (Nio,7023) 7024 format (' ','---------------------------------') write (Nio,7024) write (Nio,7010) (Psi(i), i = 1,Npsi) 7025 format ( $ /,' ','STATIONARY AUTOREGRESSIVE ', $ 'SEASONALLY ADJUSTED COMPONENT') write (Nio,7025) write (Nio,7010) (Adjs(i), i = 1,Nadjs) call USRENTRY(Adjs,1,Nadjs,1,17,1152) 7026 format ( $ /,' ','NON-STATIONARY AUTOREGRESSIVE ', $ 'SEASONALLY ADJUSTED COMPONENT') write (Nio,7026) write (Nio,7010) (Adjns(i), i = 1,Nadjns) call USRENTRY(Adjns,1,Nadjns,1,8,1153) 7027 format (/,' ','AUTOREGRESSIVE SEASONALLY ADJUSTED COMPONENT') write (Nio,7027) 7028 format (' ','--------------------------------------------') write (Nio,7028) write (Nio,7010) (Chcyc(i), i = 1,Nchcyc) 7029 format ( $ /,' ','TOTAL DENOMINATOR (TOTAL AUTOREGRESSIVE ','POLYOMIAL)') write (Nio,7029) 7030 format ( $ ' ','----------------------------------------','----------') write (Nio,7030) write (Nio,7010) (Totden(i), i = 1,Ntot) end if c------------------ if (pstar .ne. Ntot) then write (Nio,*) 'WARNING: DIMENSION PROBLEM' end if end c c subroutine OutAuto(OUT,Nio,Qstat,df,r,se,M,caption,sId) c QSTAT<0 if we do not write Qstat Test implicit none c INPUT PARAMETERS integer OUT,Nio,df,M real*8 Qstat,r(50),se(50) character*(*) caption,sId c i/o * include 'indhtml.i' c c LOCAL PARAMETERS integer mr,mp,i,ie,k character*100 auxstr c c external function integer ISTRLEN external ISTRLEN c --------------------------------- if (out .eq. 0) then mr = 1 mp = m / 12 if (MOD(m,12) .eq. 0) then mr = 0 end if mp = mp*12 + mr do i = 1,mp,12 ie = i + 11 7000 format (/,' ',12f9.4) write (Nio,7000) (r(k), k = i,ie) 7001 format (' SE',12f9.4) write (Nio,7001) (se(k), k = i,ie) end do c ------------------------------- if (QStat.gt.0.0) then 7002 format ( $ //,' THE LJUNG-BOX Q VALUE IS ',f10.2,' AND IF RESIDUALS ', $ 'ARE RANDOM IT SHOULD BE DISTRIBUTED AS CHI-SQUARE (',i2,')') write (Nio,7002) qstat, df end if end if end c c OutSeas: escribe en el fichero de salida: c los residuos extendidos, c Los residuos studentized (que distan mucho de 0) c los test sobre residuos extendidos c Las autocorrelaciones de los residuos extendidos c Si algun test salio mal c El test de RUNS c Las autocorrelaciones de los residuos al cuadrado c Escribe si hay evidencia de no linearidad c Escribe los backward residuals Subroutine OutSeats(IOUT,Nio,Ndevice, $ printBack,ba,sr,SQSTAT,SDF,SSE,m,MQ, $ n_1,n0,tvalRUNS, $ Qstat,DF,Pstat1,spstat1, $ wnormtes,wsk,skewne,test1,wkk,rkurt,test,r,SEa, $ resid,flagTstu,it,iper,iyear, $ rmean,rstd,DW,KEN,RTVAL,SumSres,F,Nyer1,Nper1, $ Pstar,Qstar,D,BD) implicit none INCLUDE 'srslen.prm' include 'dimensions.i' include 'peaks.i' include 'sig.i' include 'sform.i' * include 'indhtml.i' c INPUT PARAMETERS logical printBack integer IOUT,Nio,m,mq,DF,SDF real*8 resid(MPKp),ba(MpKp),Qstat,Pstat1,spstat1 real*8 sr(50),SQstat,SSE(50),tvalRUNS integer n_1,n0 real*8 wnormtes,wsk,skewne,test1,wkk,rkurt,test,r(50),SEa(50) integer flagTstu,NDEVICE,IPER,IYEAR,it,Nper1,nYer1 integer Pstar,Qstar,D,BD real*8 Rmean,Rstd,DW,KEN,RTVAL,F,SumSres c EXTERNAL integer ISTRLEN real*8 KENDALLS external ISTRLEN,KENDALLS intrinsic MOD c LOCAL PARAMETERS real*8 sigq character buff*180,fname*30,subtitle*50 integer i,ITT integer saveNZ,saveNper,saveNyer C C.. Local Arrays .. real*8 chi299(50)/6.6349,9.2103,11.3449,13.2767,15.0863,16.8119, & 18.4753,20.0902,21.666,23.2093,24.725,26.217, & 27.6882,29.1412,30.5779,31.9999,33.4087,34.8053, & 36.1909,37.5662,38.9322,40.2894,41.6384,42.9798, & 44.3141,45.6417,46.9629,48.2782,49.5879,50.8922, & 52.1914,53.4858,54.7755,56.0609,57.3421,58.6192, & 59.8925,61.1621,62.4281,63.6907,64.9501,66.2062, & 67.4593,68.7095,69.9568,71.2014,72.4433,73.6826, & 74.9195,76.1539/ real*8 chi295(50)/3.8415,5.9915,7.8147,9.4877,11.0705, & 12.5916,14.0671,15.5073,16.919,18.307,19.6751, & 21.0261,22.362,23.6848,24.9958,26.2962, & 27.5871,28.8693,30.1435,31.4104,32.6706, & 33.9244,35.1725,36.415,37.6525,38.8851, & 40.1133,41.3371,42.557,43.773,44.9853,46.1943, & 47.3999,48.6024,49.8018,50.9985,52.1923, & 53.3835,54.5722,55.7585,56.9424,58.124, & 59.3035,60.4809,61.6562,62.8296,64.0011, & 65.1708,66.3386,67.5048/ real*8 a(kp+mp),dvec(1) c -------------------- saveNZ = Nz saveNper=Nper saveNyer=Nyer Nz = Na Nyer = nyer1 Nper = nper1 if (Out .eq. 0) then 7041 format (/,' '//' EXTENDED RESIDUALS') write (Nio,7041) call TABLE2(resid) end if Nz=saveNz Nper=saveNper Nyer=saveNyer c -------------------- Do i=1,NA a(i) = Resid(i) / Sqf it = i + Pstar - Qstar + D + Bd*Mq itt = it + Nper - 1 iper = MOD(itt,Nfreq) iyear = itt / Nfreq iyear = Nyer + iyear if (iper .eq. 0) then iper = Nfreq iyear = iyear - 1 end if if ((Out.eq.0) .and. (a(i).lt.-Sek.or.a(i).gt.Sek)) then 7043 format (/,' ','STUDENTIZED EXTENDED RESIDUAL OF',f8.4, $ ' AT T=',i3,4x,'(',i2,1x,i4,')') write (Nio,7043) a(i), it, iper, iyear end if end do if (Nio .eq. ndevice) then dvec(1)=rmean call USRENTRY(dvec,1,1,1,1,1040) dvec(1)=rstd call USRENTRY(dvec,1,1,1,1,1041) dvec(1)=skewne call USRENTRY(dvec,1,1,1,1,1045) dvec(1)=test1 call USRENTRY(dvec,1,1,1,1,1046) dvec(1)=rkurt call USRENTRY(dvec,1,1,1,1,1042) dvec(1)=test call USRENTRY(dvec,1,1,1,1,1043) dvec(1)=wnormtes call USRENTRY(dvec,1,1,1,1,1044) dvec(1)=Sqf call USRENTRY(dvec,1,1,1,1,1047) dvec(1)=dw call USRENTRY(dvec,1,1,1,1,1048) if (MQ.gt.1) then dvec(1)=ken call USRENTRY(dvec,1,1,1,1,1049) end if end if if (Out .eq. 0) then 7045 format ( ///,' ',' TEST-STATISTICS ON EXTENDED RESIDUALS',/ $ ' -------------------------------------',///, $ ' MEAN=' $ ,d12.4,/' ST.DEV.=',d12.4,/' OF MEAN',/ $ ' T-VALUE=',f8.4,//' NORMALITY TEST=',g14.4, $ 4x,'( CHI-SQUARE(2) )',/' SKEWNESS=',f8.4, $ 10x,'( SE =',f8.4,' )'/' KURTOSIS=',f8.4,10x, $ '( SE =',f8.4,' )'//' SUM OF SQUARES=',d12.4// $ ' DURBIN-WATSON=',f8.4,//' STANDARD DEVI.=',d12.4/ $ ' OF RESID.',/' VARIANCE=',d12.4,/ $ ' OF RESID.') write (Nio,7045) rmean, rstd, rtval, wnormtes, skewne, test1, $ rkurt, test, sumSres, dw, Sqf, f if (MQ.gt.1) then 7146 format(//,2x,'NON-PARAMETRIC TEST FOR RESIDUAL ', & 'SEASONALITY (FRIEDMAN) SEAS_NP = ',f9.2,/,2x, & ' ASYMP. DISTRIBUTED AS CHI-SQUARE(',i2,')') write(Nio,7146) ken,MQ-1 write(Nio,'(''Critical value 99%: '',f9.2)')chi299(MQ-1) write(Nio,'(''Critical value 95%: '',f9.2)')chi295(MQ-1) end if 7046 format ( $ ///' AUTOCORRELATIONS OF EXTENDED RESIDUALS'/ $ ' --------------------------------------') write (Nio,7046) Call OutAuto(IOUT,Nio,Qstat,df,r,sea,M, $ 'EXTENDED RESIDUALS','ACF Residuals') c ---------------------------------------------------- sigq = SQRT(2.0d0*DF) if (Qstat .gt. DF+6*sigq) then write (Nio,'(6x, $ ''EVIDENCE OF EXTENDED RESIDUALS CORRELATION :'',2x,a)') $ 'LARGE' end if if ((Qstat.gt.DF+3*sigq) .and.(Qstat.le.DF+6*sigq)) then write (Nio,'(6x, $ ''EVIDENCE OF EXTENDED RESIDUALS CORRELATION :'',2x,a)') $ 'MODERATE' end if if (wnormtes .gt. 9.0d0) then write (Nio,'(6X,''EVIDENCE OF NON-NORMALITY'')') end if wsk = skewne / test1 if (wsk .gt. 3.0d0) then write (Nio,'(6X,''EVIDENCE OF ASYMETRY POSITIVE'')') end if if (wsk .lt. -3.0d0) then write (Nio,'(6X,''EVIDENCE OF ASYMETRY NEGATIVE'')') end if wkk = (rkurt-3) / test if (wkk .gt. 3.0d0) then write (Nio,'(6X,''EVIDENCE OF EXCESS KURTOSIS'')') end if * if ((Pg.eq.0) .and. (iter.eq.0)) then * fname = 'AUTORES.T2' * subtitle = 'ACF OF EXTENDED RESIDUALS' * call PLOTACF(fname,subtitle,r,M,1,Na) * end if 7047 format (/,' APPROXIMATE TEST OF RUNS ON EXTENDED RESIDUALS',/, $ ' ----------------------------------------------') write (Nio,7047) 7000 format (/,' NUM.DATA=',i4,/' NUM.(+)=',i4,/' NUM.(-)=',i4) write (Nio,7000) na, n_1, n0 7001 format (' T-VALUE=',g16.3) write (Nio,7001) tvalRUNS c ---------------------------------------------------- if ((mq.eq.4).or.(mq.eq.12)) then call warnPeaks(nio,picosRes,'Residuals ',mq) end if 7048 format (///,' AUTOCORRELATIONS OF SQUARED EXTENDED RESIDUALS',/ $ ' ---------------------------------------------') write (Nio,7048) end if c ---------------------------------------------------- Call OutAuto(OUT,Nio,sQstat,sDF,sr,sSE,M, $ 'SQUARED EXTENDED RESIDUALS','ACF sqd Residuals') if (Out .eq. 0) then sigq = SQRT(2.0d0*sDF) buff = ' ' if (sQstat .gt. Qstat+2.0d0) then if (sQstat .gt. sDF+6*sigq) then buff = 'LARGE' end if if ((sQstat.lt.sDF+6*sigq) .and. $ (sQstat.gt.sDF+3*sigq)) then buff = 'MODERATE' end if else if (sQstat .gt. sDF+6*sigq) then buff = 'YES' end if if (ISTRLEN(buff) .gt. 1) then write (Nio,'(6X,''EVIDENCE OF NON-LINEARITY :'', $ 2X,A)') buff end if buff = ' ' if (Pstat1 .gt. spstat1) then if (Pstat1 .ge. 9.5d0) then buff = 'LARGE' end if if ((Pstat1.ge.7.5d0) .and. (Pstat1.lt.9.5d0)) then buff = 'MODERATE' end if else if (Pstat1 .gt. 9.5d0) then buff = 'YES' end if if (ISTRLEN(buff) .gt. 1) then write (Nio,'(6x, $ ''EVIDENCE OF SEASONAL NON-LINEARITY :'',2x,a)') buff end if end if C C Comment the next 5 lines for TSW C CUNX#ifdef DOS !DEC$ IF DEFINED (DOS) * if ((Pg.eq.0) .and. (Out.eq.0).and.(iter.eq.0)) then * fname = 'AUTOSRES.T2' * subtitle = 'ACF OF SQD EXTENDED RESIDUALS' * call PLOTACF(fname,subtitle,sr,M,0,0) * end if CUNX#end if !DEC$ end if c ---------------------------------------------------- if (printBack) then NZ=Na c Nper=Nper1 c Nyer=Nyer1 if (Out.eq.0) then 7049 format (/,' BACKWARD RESIDUALS') write (Nio,7049) call TABLE2(ba) end if NZ=saveNZ c Nper=saveNper c Nyer=SaveNyer end if end c c c subroutine OutPara(nio,niter,mattitle,NAiter,mean, $ p,d,q,bp,bd,bq,phi,bphi,nbphi, $ theta,btheta,nbth,qstat,wm,inicio) implicit none c INPUT PARAMETERS INCLUDE 'srslen.prm' include 'dimensions.i' integer nio,niter,NAiter,p,d,q,bp,bd,bq,nbphi,nbth,mean,inicio character mattitle*180 real*8 qstat,wm real*8 phi(*),bphi(*),theta(*),btheta(*) integer nOutPar common /outPar/ nOutPar c LOCAL PARAMETERS character PHIo(3)*7,bphio*7,tho(3)*7,btho*7 integer i c -------------------------------- if (nOutPar.eq.niter) then return else nOutPar=niter end if c -------------------------------- do i=1,p write(phio(i),'(f7.4)') phi(i+inicio) enddo do i=p+1,3 write(phio(i),'(3x,"0",3x)') enddo if (bp.gt.0) then write(bphio,'(f7.4)') bphi(nbphi) else write(bphio,'(3x,"0",3x)') end if if (q.le.3) then do i=1,q write(tho(i),'(f7.4)') theta(i+inicio) enddo do i=q+1,3 write(tho(i),'(3x,"0",3x)') enddo if (bq.gt.0) then write(btho,'(f7.4)') Btheta(nbth) else write(btho,'(3x,"0",3x)') end if else do i=1,3 write(tho(i),*) '*' enddo write(btho,'(3x,"0",3x)') end if write(nio,1001) $ niter,mattitle(1:22),NAiter,qstat, $ phio(1)(1:7),phio(2)(1:7),phio(3)(1:7),bphio(1:7), $ mean,p,d,q,bp,bd,bq, $ tho(1)(1:7),tho(2)(1:7),tho(3)(1:7),btho(1:7),wm 1001 format(i4,3x,a,x,i2,x,f9.2,x,4(a,x),2x,i1,2x,2(i1,x),i2, $ 2x,3(i1,2x),x,4(a,x),g12.4) end c c OutNoPar c subroutine OutNoPar(nio,niter,mattitle) implicit none c INPUT PARAMETERS integer nio,niter character mattitle*180 integer nOutPar common /outPar/ nOutPar c -------------------------------- if (nOutPar.eq.niter) then return else nOutPar=niter end if write(nio,1001) $ niter,mattitle(1:22),-1,-1,0,0,0,0, $ -1,-1,-1,-1,-1,-1,-1,0,0,0,0,-1 1001 format(i4,3x,a,x,i2,8x,i2,x,4(i4,4x),x,i2,x,3(i2), $ 2x,3(i2,x),2x,4(i4,4x),8x,i2) end cc c cc cc c cc character*60 function PeriodH(idx,freq) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer idx,freq C C.. Local Variables .. character*4 null C C.. Local Arrays .. character*60 Month(12),Per(12) data Month/ & 'Jan', & 'Feb', & 'Mar', & 'Apr', & 'May', & 'Jun', & 'Jul', & 'Aug', & 'Sep', & 'Oct', & 'Nov', & 'Dec'/ data Per/ & '1st', & '2nd', & '3th', & '4th', & '5th', & '6th', & '7th', & '8th', & '9th', & '10th', & '11th', & '12th'/ null=' ' if ((idx.le.0).or.(idx.gt.12)) then PeriodH = null end if if ((idx .gt. freq).or.(freq.gt.12)) then PeriodH=null end if if (freq.eq.12) then PeriodH = Month(idx) else PeriodH = Per(idx) end if return end c c c subroutine OutRoots(nio,nroots,rez,imz,modul,ar,pr,cad) implicit none c c.. FORMAL PARAMETERS integer nio,nRoots real*8 rez(*),imz(*),modul(*),ar(*),pr(*) character cad*5 c 7039 format (///,27x,'ROOTS OF ',A,' POLYNOMIAL') write (Nio,7039)cad call OutRPQ(Nio,nroots,rez,imz,modul,ar,pr) end c c c subroutine OutARIMA(Nio,init,p,bp,q,bq,wm, $ PHI,TH,BPHI,BTH,sePHI,seBPHI,seTH,seBTH) implicit none integer n10,n1 parameter (n10=10,n1=1) INCLUDE 'srslen.prm' include 'dimensions.i' c c.. INPUT PARAMETERS integer Nio,init,p,bp,q,bq real*8 wm real*8 PHI(3*N1),TH(3*N1),BPHI(3*N1),BTH(3*N1) real*8 sePHI(n10),seBPHI(n10),seTH(n10),seBTH(n10) C ..INPUT/OUTPUT * include 'indhtml.i' c c.. Local parameters integer i c if (Init .eq. 2) then 7018 format (/,' ',9x,'MEAN =',g16.6,/,/,' ',9x, $ 'SE = *******'//) write (Nio,7018) wm end if 7022 format (//17x,'ARIMA PARAMETERS ',/) write (Nio,7022) c if ((p.gt.0) .or. (bp.gt.0)) then if (P .ne. 0) then if (Init .eq. 2) then select case (P) case (3) 7023 format (11x,'PHI =',3f10.4,/,11x,'SE =', $ 4x,3('*****',6x)) write (Nio,7023) (-Phi(i), i = 1,P) case (2) 7024 format (11x,'PHI =',2f10.4,/,11x,'SE =', $ 4x,2('*****',6x)) write (Nio,7024) (-Phi(i), i = 1,P) case (1) 7025 format (11x,'PHI =',f10.4,/,11x,'SE =', $ 4x,1('*****',6x)) write (Nio,7025) (-Phi(i), i = 1,P) end select else !.....Init<>2 7026 format (/,' ',11x,'PHI =',3f10.4) write (Nio,7026) (-Phi(i), i = 1,P) 7027 format (' ',11x,'SE =',3(3x,f7.4)) write (Nio,7027) (sePHI(i), i = 1,P) end if ! of init =2 end if ! of p<>0 c if (Bp .ne. 0) then if (Init .eq. 2) then write(Nio,'(11x,''BPHI ='',f10.4,/,11x,''SE ='', $ 4x,''*****'',6x)') -Bphi(1) else 7030 format (/,' ',11x,'BPHI =',3f10.4) write (Nio,7030) -Bphi(1) write (nio,'('' '',11x,''SE ='',3x,f7.4)') seBPHI(1) end if end if end if c if ((q.gt.0) .or. (bq.gt.0)) then if (Q .ne. 0) then if (Init .eq. 2) then select case (Q) case (3) 7031 format (11x,'TH =',3f10.4,/,11x,'SE =', $ 4x,3('*****',6x)) write (Nio,7031) (-Th(i), i = 1,Q) case (2) 7032 format (11x,'TH =',2f10.4,/,11x,'SE =', $ 4x,2('*****',6x)) write (Nio,7032) (-Th(i), i = 1,Q) case (1) 7033 format (11x,'TH =',f10.4,/,11x,'SE =', $ 4x,('*****')) write (Nio,7033) (-Th(i), i = 1,Q) end select else !.....Init<>2 write (Nio,'(/," ",11x,"TH =",3f10.4)') $ (-th(i), i = 1,Q) write (Nio,'(" ",11x,"SE =",3(3x,f7.4))') $ (seTH(i), i = 1,Q) end if ! of init =2 end if ! of p<>0 c if (Bq .ne. 0) then if (Init .eq. 2) then write(Nio,'(11x,''BTH ='',f10.4,/,11x,''SE ='', $ 4x,''*****'',6x)') -Bth(1) else write(Nio,'(/," ",11x,"BTHETA = ",3f10.4)') -Bth(1) write(nio,'('' '',11x,''SE = '',3x,f7.4)') seBTH(1) end if end if end if end c c c subroutine showFirstNA(nio,InputModel,p,d,q,bp,bd,bq,theta, $ Btheta,nbth,phi,Bphi,nbphi,imeanout,tramo) implicit none c INPUT PARAMETERS integer nio,InputModel, p,d,q,bp,bd,bq,nbth,nbphi, $ imeanout,tramo real*8 theta(*),Btheta(*),phi(*),Bphi(*) c integer i c EXTERNAL character gettmcs EXTERNAL gettmcs c c include 'indHtml.i' c --------------------------------------------------------------- if (InputModel.eq.1) then if ((getTmcs().eq.'Y').or.(getTmcs().eq.'y' )) then write(nio,'(//," FIRST MODEL THAT ENTERS ", $ "THE DECOMPOSITION: ")') else if (tramo.ne.0) then write(nio,'(//," ARIMA MODEL SELECTED BY regARIMA: ")') else write(nio,'(//," ARIMA MODEL SELECTED: ")') end if end if write(nio,'("(",i1,",",i1,",",i1,")(",i1,",",i1,",",i1, $ ")")') p,d,q,bp,bd,bq if (imeanout.eq.0) then write(nio,*) 'with mean' else write(nio,*) 'without mean' endif write(nio,'(/," ARMA Parameters")') if (p .ne. 0) then select case (p) case (3) write(Nio,'(11x,"PHI =",3f10.4)') (Phi(i), i = 2,p+1) case (2) write(Nio,'(11x,"PHI =",2f10.4)') (Phi(i), i = 2,p+1) case (1) write(Nio,'(11x,"PHI =",f10.4)') (Phi(i), i = 2,p+1) end select end if if (bp .eq. 1) then write(Nio,'(11x,''BPHI ='',f10.4,/)') bphi(nbphi) end if if (q .ne. 0) then select case (q) case (3) write(Nio,'(11x,"THETA =",3f10.4)') (theta(i), i = 2,q+1) case (2) write(Nio,'(11x,"THETA =",2f10.4)') (theta(i), i = 2,q+1) case (1) write(Nio,'(11x,"THETA =",f10.4)') (theta(i), i = 2,q+1) end select end if if (Bq .eq. 1) then write(Nio,'(11x,"BTHETA= ",f10.4,/)') btheta(nbth) end if end if end cc c cc subroutine OutCorr(nio,nx,cMatrix) implicit none C integer n10 parameter(n10=10) c c.. INPUT PARAMETERS integer nio,nx real*8 cMatrix(n10,n10) c.. LOcal PARAMETERS integer i,j c 7020 format (/,' ',11x,'CORRELATION MATRIX'//) write (Nio,7020) do i = 1,nx 7021 format (12(5x,f6.3)) write (Nio,7021) (cMatrix(i,j), j = 1,i) end do end c c c subroutine OutMean(nio,tst,Wm,seMEan) implicit none c c.. Input Parameters integer nio,tst real*8 Wm,seMEan c if (tst .gt. 0) then 7018 format (/,' ',9x,'MEAN =',g16.6,/,/,' ',9x, $ 'SE = *******'//) write (Nio,7018) wm else 7019 format (/,' ',9x,'MEAN =',g16.6,/,/,' ',9x,'SE =' $ ,g16.6,//) write (Nio,7019) wm, seMEan end if end c c c * Subroutine OutModel(nio,nidx,noserie,p,d,q,bp,bd,bq,mq,model) Subroutine OutModel(nio,noserie,p,d,q,bp,bd,bq,mq,model) implicit none c c.. INPUT PARAMETERS integer nio,noserie,p,d,q,bp,bd,bq,mq,model C ..INPUT/OUTPUT * include 'indhtml.i' c if ((noserie.eq.0)) then 7013 format ( $ /////,' MODEL FITTED'//' NONSEASONAL P=',i2, $ ' D=',i2,' Q=',i2) write (Nio,7013) P, D, Q else if ((noserie.eq.1)) then 7014 format(/////,' MODEL'//' NONSEASONAL P=',i2, $ ' D=',i2,' Q=',i2) write (Nio,7014) P, D, Q end if if (Bp+Bd+Bq.ne.0) then 7015 format(' SEASONAL BP=',i2,' BD=',i2, $ ' BQ=',i2) write (Nio,7015) Bp, Bd, Bq end if 7016 format (' PERIODICITY MQ=',i3) write (Nio,7016) Mq C C INITIALIZE DETPRI C if (model .eq. 1) then call setTmcs('Y') write (Nio,'(//,8x,''ARIMA MODEL FROM regARIMA HAS BEEN'', $ /,5x,''MODIFIED TO SATISFY SEATS CONSTRAINTS'',/)') end if end c c c subroutine OutPart(nio,nAutocorr,serie,Partial,sePart) implicit none c integer n10 parameter(n10=10) c c.. Input Parameters integer nio,nAutocorr real*8 sePart,Partial(5*n10) character*(*) serie c c.. Input/Output * include 'indhtml.i' c c.. External functions integer istrlen external istrlen c c.. Local Parameters integer mr,ml,i,ie,k c 7000 format (///, $ ' PARTIAL AUTOCORRELATIONS'/' ------------------------') write (Nio,7000) mr = 1 ml = nAutocorr / 12 if (MOD(nAutocorr,12) .eq. 0) then mr = 0 end if ml = ml*12 + mr do i = 1,ml,12 ie = i + 11 7001 format (/,' ',12(2x,f7.4)) write (Nio,7001) (Partial(k), k = i,ie) c call FLUSH(NIO) 7002 format (' SE',12(2x,f7.4)) write (Nio,7002) (sePart, k = i,ie) c call FLUSH(NIO) end do end c c c OutSerAc: Output of transformed series and autocorrelations subroutine OutSerAc(nio,z,nz,ILam,Imean,noserie,Pg,Out,iter, * $ Itab,Iid,D,BD,Nper,Nyer,mq,Wdif, $ D,BD,Nper,Nyer,mq,Wdif, $ WdifCen,nwDif,WmDifXL,Zvar,VdifXL, $ QstatXL,df,rXL,seRxl,M,partACF,sePartACF) implicit none integer n10 parameter(n10=10) INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' c INPUT integer nio,nz,ILam,Imean,noserie,Pg,Out,iter, $ D,BD,Nper,Nyer,mq,nwDif real*8 z(*),Wdif(*),WdifCen(*),WmDifXL,Zvar,VdifXL real*8 QstatXL,rXL(5*n10),seRxl(5*n10),partACF(5*n10),sePartACF integer df,M C OUTPUT * integer Itab,Iid c LOCAL integer nz1,nyer2,nper2 character fname*30,subtitle*50 c * if ((ILam.ne.1).and. (noserie.eq.0)) then * if ((Pg.eq.0) .and. (Out.lt.2).and.(iter.eq.0)) then * fname = 'TSERIE.T' * subtitle = 'LINEARIZED SERIES (LOGS)' * call PLOTLSERIES(fname,subtitle,z,Nz,1,0.0d0) * end if * end if * if ((ILam.eq.1) .and. (noserie.eq.0) .and. * $ (iter.eq.0).and.(Pg.eq.0) .and. (Out.lt.2)) then ** call profiler(3,'Pre grSerie') * call grSerie(z,nz,Nper,nYer,mq) * end if c if ((ILam.ne.1).and. (noserie.eq.0)) then if (Out .eq. 0) then * call profiler(3,'Pre TRANSFORMED SERIES') write (Nio,'(/,'' TRANSFORMED SERIES'')') call TABLE2(z) end if end if c if (Out .eq. 0) then 7006 format (/,' NONSEASONAL DIFFERENCING D=',i2,/, $ ' SEASONAL DIFFERENCING BD=',i2) write (Nio,7006) D, Bd end if c if ((D.ne.0.or.Imean.ne.0) .and. (D+Bd).ne.0) then nz1 = Nz nyer2 = Nyer nper2 = Nper Nz = NwDif Nper = Nper + Bd*Mq + D do while (Nper.gt.mq .and. mq.ne.0) Nper = Nper - mq Nyer = Nyer + 1 end do if (Out .eq. 0) then * call profiler(3,'Pre DIFFERENCED SERIES') 7007 format (//,' DIFFERENCED SERIES') write (Nio,7007) call TABLE2(Wdif) end if call USRENTRY(Wdif,1,NwDif,1,mpkp,3001) end if c if (Imean.ne.0 .or. D.ne.0) then if (Imean .ne. 0) then if (Out .eq. 0) then write (Nio,'(/,'' SERIES HAS BEEN MEAN CORRECTED'')') end if if ((D+Bd) .ne. 0) then if (Out .eq. 0) then if (ILam .eq. 1) then write (Nio, $ '(/,'' DIFFERENCED AND CENTERED SERIES'')') else write (Nio,'(/, $ '' DIFFERENCED AND CENTERED TRANSFORMED SERIES'')') end if * call profiler(3,'Pre TABLE(WdifCen)') call TABLE2(WdifCen) end if end if end if * if ((Pg.eq.0) .and. (Out.lt.2).and.(iter.eq.0)) then * if ((d+bd).ne.0.or.Imean.eq.0) then * fname = 'DIFFER.T' * subtitle = 'DIFFERENCED SERIES' * if ((Imean.ne.0).and.((D+BD).ne.0))then * call PLOTSERIES(fname,subtitle,WdifCen,NwDif,1,0.0d0) * else * call PLOTSERIES(fname,subtitle,Wdif,NwDif,1,0.0d0) * end if * end if * end if end if if ((D.ne.0.or.Imean.ne.0) .and. (D+Bd).ne.0) then Nyer = nyer2 Nz = nz1 !restauramos antiguo valor de nz Nper = nper2 end if c if (Out .eq. 0) then 7008 format (/,1x,'MEAN OF DIFFERENCED SERIES=',d12.4) write (Nio,7008) wmDifXL end if if (Imean .eq. 0) then if (Out .eq. 0) then write (Nio,'(/,'' MEAN SET EQUAL TO ZERO'')') end if end if if (Out .eq. 0) then 7009 format (//,' VARIANCE OF Z SERIES = ',d14.4) write (Nio,7009) Zvar end if if (((D+Bd).ne.0) .and. (Out.eq.0)) then 7010 format (/,1x,'VARIANCE OF DIFFERENCED SERIES = ', $ d14.4) write (Nio,7010) VdifXL end if c if (Out.eq.0) then 7012 format (///, $ ' AUTOCORRELATIONS OF STATIONARY SERIES',/, $ ' -------------------------------------') write (Nio,7012) end if * call profiler(3,'Pre OutAuto') Call OutAuto(OUT,Nio,QstatXL,df,rXL,seRxl,M, $ 'AUTOCORRELATIONS OF STATIONARY SERIES','') CUNX#ifdef DOS !DEC$ IF DEFINED (DOS) * if ((Pg.eq.0) .and. (Out.eq.0).and.(iter.eq.0)) then * fname = 'DAUTO.T2' * subtitle = 'ACF OF DIFFERENCED SERIES' * call PLOTACF(fname,subtitle,rXL,M,0,0) * end if CUNX#end if !DEC$ end if if (out .eq. 0) then * call profiler(3,'Pre OutPart') call OutPart(nio,m,'STATIONARY SERIES',partAcf,SEpartAcf) end if end c c c * subroutine grSerie(z,nz,Nper,nYer,mq) * implicit none * INCLUDE 'srslen.prm' * integer mp,kp * parameter(Mp=POBS,kp=PYR1) *c INPUT * real*8 z(*) * integer nz,nPer,nYer,mq *c Local * real*8 bz(mp+2*kp) * integer Nper2,nyer2,i * character fname*30,subtitle*50 *c * fname = 'GSERIE.T' * subtitle = 'PERIOD-TO-PERIOD SERIES GROWTH' * do i = 2,Nz * bz(i-1) = z(i) - z(i-1) * end do * nyer2 = Nyer * nper2 = Nper * Nper=Nper+1 * if (Nper .gt. Mq) then * Nper = 1 * Nyer = Nyer + 1 * end if * call PLOTRSERIES(fname,subtitle,bz,Nz-1,1,0.0d0) * Nyer = nyer2 * Nper = nper2 * end c c c * Subroutine OutPart2(nio,nidx,z,nz,Lam,Imean,noserie,Pg,Out, * $ iter,Itab,Iid,p,D,q,bp,BD,bq,Nper,Nyer,mq, Subroutine OutPart2(nio,z,nz,ILam,Imean,noserie,Pg,Out, $ iter,p,D,q,bp,BD,bq,Nper,Nyer,mq, $ Wdif,WdifCen,nwDif,WmDifXL,Zvar,VdifXL, $ QstatXL,df,rXL,seRxl,M,partACF,sePartACF,model, $ PicosXL,init,tstmean,Wm,seMean,nx,Cmatrix, $ PHI,TH,BPHI,BTH,sePHI,seTH,seBPHI,seBTH, $ MArez,MAimz,MAmodul,MAar,MApr, $ rez,imz,modul,ar,pr,THstar,isVa0) implicit none integer n10,n1,n12 parameter(n1=1,n10=10,n12=12) c INPUT integer nio,nz,ILam,Imean,noserie,Pg,Out,iter, $ p,D,q,bp,BD,bq,Nper,Nyer,mq,nwDif,model real*8 z(*),Wdif(*),WdifCen(*),WmDifXL,Zvar,VdifXL real*8 QstatXL,rXL(5*n10),seRxl(5*n10),partACF(5*n10),sePartACF integer df,M character PicosXL(7)*2 integer init,tstmean,nx logical isVa0 real*8 Wm,seMean,Cmatrix(n10,n10),THstar(27), $ PHI(3*n1),TH(3*n1),BPHI(3*n1),BTH(3*n1), $ sePHI(n10),seTH(n10),seBPHI(n10),seBTH(n10), $ MArez(5*n12+n12/3),MAimz(5*n12+n12/3),MAmodul(5*n12+n12/3), $ MAar(5*n12+n12/3),MApr(5*n12+n12/3), $ rez(5*n12+n12/3),imz(5*n12+n12/3),modul(5*n12+n12/3), $ ar(5*n12+n12/3),pr(5*n12+n12/3) c OUTPUT * integer Itab,Iid C if (noserie.ne.1) then * call profiler(3,'Pre OutSerAc') call OutSerAc(nio,z,nz,ILam,Imean,noserie,Pg, * $ Out,iter,Itab,Iid,D,BD,Nper,Nyer,mq,Wdif, $ Out,iter,D,BD,Nper,Nyer,mq,Wdif, $ WdifCen,nwDif,wmDifXL,Zvar,VdifXL, $ QstatXL,df,rXL,seRxl,M,partACF,sePartACF) end if C C WRITE DESCRIPTION OF MODEL C if ((Out.eq.0)) then * call profiler(3,'Pre OutModel') call OutModel(nio,noserie,p,d,q,bp,bd,bq,mq,model) c if (noserie.ne.1) then if (init.ne.2) then * call profiler(3,'Pre PARAMETER ESTIMATES') 7017 format (//,/,' ',11x,'PARAMETER ESTIMATES'/) write (Nio,7017) call OutMean(nio,tstMean,Wm,seMEan) c call OutCorr(nio,nx,cMatrix) end if end if c if (isVa0) then call OutARIMAva0(Nio,init,p,bp,wm,PHI,BPHI) else * call profiler(3,'Pre PARAMETER ESTIMATES') call OutARIMA(Nio,init,p,bp,q,bq,wm,PHI,TH,BPHI,BTH, $ sePHI,seBPHI,seTH,seBTH) if (Q.gt.1) then * call profiler(3,'Pre OutRoots MA(Q)') call OutRoots(nio,q,MArez,MAimz,MAmodul,MAar,MApr,'MA(Q)') end if if (p.gt.1) then * call profiler(3,'Pre OutRoots AR(P)') call OutRoots(nio,p,rez,imz,modul,ar,pr,'AR(P)') end if end if if ((noserie.ne.1).and.((mq.eq.4).or.(mq.eq.12))) then call warnPeaks(nio,picosXl,'Linealized Series ',mq) endif end if end c c c c ErrorLog: añade una línea indicando para cada serie el error o warning encontrado. subroutine ErrorLog(Description,onlyFirst) c parámetros entrada: c Description: descripción del error encontrado, c Cuidado: si el parámetro de entrada es de diferente longitud, puede escribir basura al final de la línea. c onlyFirst=1 solo escribirá el error si es la primera llamada a ErrorLog que se ha hecho en la serie actual, c para eso usa la variable global haveErrors que cada vez que se empieza a ejecutar una nueva c serie se pone a 0, y se pone a 1 cuando se llama a ErrorLog. c OnlyFirst=0 escribirá el error siempre, las columnas de número de serie y nombre de serie se dejaran en c blanco si ya se reportaron errores para esa serie(haveErrors>0). c Otras variables globales: c haveError: si ya se ha escrito en ErrorLog un error asociado con la serie y modelo actual. c countError: indica cuantas series con error se han encontrado previo a llamar a ErrorLog, c si countError=0 =>Errorlog crea el fichero ErrorLog.{txt ó htm} y escribe la cabecera. c OutDir:directorio de salida. c Iserie: numero de serie que estamos procesando. c mattitle(1:matlen):nombre de serie que estamos procesando. implicit none c INPUT PARAMETERS include 'sername.i' include 'seatserr.i' include 'dirs.i' integer onlyFirst character description*(*) c EXTERNAL integer ISTRLEN external ISTRLEN c LOCAL character*180 filename integer Ifail,lDescription c --------------------------------------------------------- if (haveError.ne.0.and.onlyFirst.ne.0) then return end if if (CountError.eq.0) then filename=OutDir(1:ISTRLEN(OUTDIR)) //'\ErrorLog.txt' call openDevice(filename,76,0,Ifail) write(76,'(4x,"n",5x,"TITLE",23x,"Description")') end if countError=countError+1 lDescription=ISTRLEN(description) if (haveError.ne.0) then write(76,'(33x,a)') description(1:ldescription) else write(76,'(i7,2x,a22,4x,a)') niter,mattitle(1:22), $ description(1:ldescription) end if haveError=1 end c c c subroutine shCloseTD(nio,InputModel,p,d,q,bp,bd,bq) implicit none c INPUT PARAMETERS integer nio,InputModel,p,d,q,bp,bd,bq c EXTERNAL character*7 OrderName external OrderName c --------------------------------------------------------------- if (InputModel.gt.5) then return end if if (InputModel.gt.1) then write(nio,1001) orderName(InputModel), $ p,d,q,bp,bd,bq 1001 format(//,a," model has changed.",/, $ " The model is approximated to (",i1,",",i1,",",i1, $ ")(",i1,",",i1,",",i1,")",//) else write(nio,1002) p,d,q,bp,bd,bq 1002 format(" Model changed to (",i1,",",i1,",",i1,")(",i1, $ ",",i1,",",i1,")") end if end c c c subroutine ShowFirstModel(nio,p,d,q,bp,bd,bq,th, $ Bth,phi,Bphi,imean,tramo,init) implicit none c INPUT PARAMETERS integer nio,p,d,q,bp,bd,bq,imean,tramo,init real*8 th(*),Bth(*),phi(*),Bphi(*) c integer i c EXTERNAL character*7 OrderName external OrderName c * include 'indHtml.i' c --------------------------------------------------------------- if (tramo.eq.0) then write(nio,'(//," ARIMA MODEL SELECTED BY REGARIMA: ", $ "(",i1,",",i1,",",i1,")(",i1,",",i1,",",i1, $ ")")')p,d,q,bp,bd,bq else write(nio,'(//,"SEATS ARIMA MODEL INPUT: ", $ "(",i1,",",i1,",",i1,")(",i1,",",i1,",",i1, $ ")")')p,d,q,bp,bd,bq end if if (imean.eq.0) then write(nio,*) 'with mean' else write(nio,*) 'without mean' end if if (init.eq.2) then write(nio,'(/," ARMA Parameters")') if (p .ne. 0) then select case (p) case (3) write(Nio,'(11x,"PHI =",3f10.4)') (-phi(i), i=1,p) case (2) write(Nio,'(11x,"PHI =",2f10.4)') (-phi(i), i=1,p) case (1) write(Nio,'(11x,"PHI =",f10.4)') (-phi(i), i=1,p) end select end if if (bp .eq. 1) then write(Nio,'(11x,''BPHI ='',f10.4,/)') -Bphi(1) end if if (q .ne. 0) then select case (q) case (3) write(Nio,'(11x,"THETA =",3f10.4)') (-th(i), i=1,q) case (2) write(Nio,'(11x,"THETA =",2f10.4)') (-th(i), i=1,q) case (1) write(Nio,'(11x,"THETA =",f10.4)') (-th(i), i=1,q) end select end if if (Bq .eq. 1) then write(Nio,'(11x,"BTHETA= ",f10.4,/)') -bth(1) end if end if end cc c cc subroutine showNA(nio,InputModel) implicit none c INPUT PARAMETERS integer nio,InputModel c integer i c EXTERNAL character*7 OrderName external OrderName c --------------------------------------------------------------- if ((InputModel.ne.1).and.(InputModel.le.5)) then write(nio,1001)orderName(InputModel) 1001 format(//,a," model has no admissible decomposition",//) endif end c c c character*7 function orderName(Index) implicit none c INPUT PARAMETERS integer Index c LOCAL ARRAYS character ordenes(10)*7,masOrdenes*7 data ordenes /'First ','Second ','Third ','Fourth ','Fifth ', $ 'Sixth ','Seventh','Eighth','ninth','tenth'/ c -------------------------------------------------------------- if (Index.le.10) then masOrdenes=ordenes(Index) else write(masOrdenes,'(I5,"TH")')Index end if orderName=masOrdenes return end c c c OutSearch: escribe la salida de Search cuando todo va bien. subroutine OutSearch(nio,out,itn,ifn,fi,x,nx,e) implicit none c INPUT PARAMETERS integer nio,itn,out,ifn,nx,e(*) real*8 fi,x(*) c LOCAL PARAMETERS integer j,fixed c ----------------------------------------------------------------- include 'units.cmn' c ----------------------------------------------------------------- * call profiler(3,'OutSearch') if (itn.eq.0) then return end if * if (out.eq.0) then * 7019 format ( * $ /,' ',' CONVERGED AFTER ',i2,' ITERATIONS AND ',i3, * $ ' FUNCTION VALUES F =',e17.8/(6e20.6)) * write (Nio,7019) itn, Ifn, fi, (x(j), j = 1,nx) * end if fixed=0 do j = 1,nx if (e(j) .eq. 1) then fixed=fixed+1 end if enddo if ((fixed.gt.0).and.(out.eq.0)) then 7020 format (/,' ',i1,'PARAMETERS FIXED ') write (Nio,7020) fixed end if end cc c cc subroutine m_statSA(nio) implicit none integer nio c write(nio,*) 'SEASONALITY IS STATIONARY(EVERY PERIOD HAS', $ ' ZERO MEAN)' WRITE(nio,*)'AND MODEL MAY YIELD AN ERRATIC SEASONAL ', $ 'COMPONENT.' WRITE(nio,*)'SEASONAL ADJUSTMENT MAY BE IMPROVED BY SETTING', $ ' "STATSEAS=1".' end cc c cc subroutine m_statSB(nio) implicit none integer nio c write(nio,*) $ 'THE MODEL EVIDENCES VERY WEAK SEASONALITY. ITS ESTIMATION', $ ' WOULD BE ERRATIC ' write(nio,*) $ 'AND THE EFFECT IS CAPTURED AS A TRANSITORY COMPONENTS.' end cc c cc subroutine m_statSC(nio) implicit none integer nio c write(nio,*) $ 'IN AN ATTEMPT TO IMPROVE SEASONAL ADJUSTMENT, ' write(nio,*) $ 'NON-STATIONARITY HAS BEEN IMPOSED ON THE SEASONAL COMPONENT.' end cc c m_statO:antiguo mensaje (hasta rel 433) que se sacaba con STATSEAS=0 cuando BP=1 cc subroutine m_statO(nio) implicit none integer nio c write (nio,'(//,4x,''INPUT MODEL HAS A STATIONARY '', $ ''SEASONAL STRUCTURE'',/,4x, $ ''INAPPROPRIATE FOR SEASONAL ADJUSTMENT.'',/,4x, $ ''SEATS HAS CHANGED THE SEASONAL ORDERS TO :'',/,47x, $ ''(0, 1, 1)'',/,4x,''This may affect forecasting.'',//)') end cc c cc subroutine m_vc_is0(nio) implicit none integer nio c write(nio,*) write(nio,*) 'Transitory innovation variance is very small. ' write(nio,*) 'Transitory component can be ignored' end cc c cc subroutine writeSumS(baseName,nBase,numser,noTratadas,wSposBphi, $ wSstochTD,wSstatseas,wSrmod,wSxl) implicit none include 'stdio.i' include 'sums.i' include 'dirs.i' integer nBase,numser,noTratadas,wSposBphi,wSstochTD,wSstatseas real*8 wSrmod,wSxl character baseName*(PFILCR) c integer wio,ireturn integer date_time (8) character*12 real_clock (3) character fname*180 character sposBphi*2,sstochTD*2,sstatseas*2,srmod*8,sxl*8 integer NTratadas c integer ISTRLEN external ISTRLEN include 'build.i' c c abrir fichero c c nTratadas=NumSer-noTratadas if (nTratadas.le.0) then nTratadas=1 endif wio=2 ireturn=0 fname = baseName(1:nBase)// '.sms' call OPENDEVICE(fname,wio,0,ireturn) if (ireturn .ne. 0) then return end if call DATE_AND_TIME (REAL_CLOCK(1),REAL_CLOCK(2),REAL_CLOCK(3), & DATE_TIME) * write (wio,1001) infil(1:ISTRLEN(infil)) * 1001 format(2x,'Input File: ',A) write (wio,1002) & real_clock(1)(1:4) // '-' // real_clock(1)(5:6) // '-' // & real_clock(1)(7:8) // ' ' //real_clock(2)(1:2) // ':' // & real_clock(2)(3:4) // ':' // real_clock(2)(5:6) 1002 format(2x,'Date : ',A) write (wio, 1003) "Series in file : ",numser IF(tSeats.gt.0) & write (wio, 1003) "Series processed with SEATS : ",tSeats IF(tX11.gt.0) & write (wio, 1003) "Series processed with X-11 : ",tX11 IF(tNSA.gt.0) & write (wio, 1003) "Series not seasonally adjusted : ",tNSA write (wio, 1003) "Series processed :",numser-noTratadas 1003 format(2x,a,i7) if (wSrmod.eq.-9.99) then write(Srmod,1004)" *" else write(Srmod,1005) wSrmod end if if (wSxl.eq.-9.99) then write (sxl,1004)" *" else write(sxl,1005) wSxl end if if (wSposbphi.eq.-9) then write(sposbphi,1004)" *" else write(sposbphi,1006) wSposbphi end if if (wSstochtd.eq.-9) then write(sstochtd,1004)" *" else write(sstochtd,1006) wSstochtd end if if (wSstatseas.eq.-9) then write(sstatseas,1004)" *" else write(sstatseas,1006) wSstatseas end if 1004 format(a) 1005 format(f6.3) 1006 format(i2) write(wio,1007) 1007 format(/,2x,'Input Parameters:') write(wio,1008)srmod,sxl 1008 format(2x,"rmod=",A6,2x,"xl=",2x,A6,2x) write(wio,1009) sposbphi,sstochtd,sstatseas 1009 format(2x,"posbphi= ",A2,2x,"stochtd= ",A2,2x,"statseas= ",A2) write (wio,1010)'TABLE A : GENERAL ' 1010 format(/,/,4x,a) write (wio,1004)' --------------------------' write (wio,1011) 1011 format(34x,'# of series',4x,'%') write (wio,1012) 1012 format(2x,50("-")) write (wio,1013) 'Model changed by SEATS ', & tTMCS, DBLE(tTMCS)/DBLE(nTratadas)*100.0d0 1013 format(2x,a,i7,4x,f6.2) write (wio,1012) write (wio,1013) 'Approximate (NA decomposition) ', & tANA, DBLE(tANA)/DBLE(nTratadas)*100.0d0 write (wio,1012) write (wio,1013) 'With seasonal component ', & tScomp, DBLE(tScomp)/DBLE(nTratadas)*100.0d0 write (wio,1012) write (wio,1013)'With Transitory Component ', & tCycComp,DBLE(tCycComp)/DBLE(nTratadas)*100.0d0 write (wio,1012) write (wio,1013)'With Stochastic TD ', & tStocTD,DBLE(tStocTD)/DBLE(nTratadas)*100.0d0 write (wio,1012) c write(wio,1010)'TABLE B: CHECKS' write (wio,1004)' --------------------------' write (wio,1014) 1014 format(42x,"# of series",4x,"%") write (wio,1015) 1015 format(2x,58("-")) write(wio,1013)"Fail Spectral factorization ", & tSpecFac, DBLE(tSpecFac)/DBLE(nTratadas)*100.0d0 write (wio,1015) write(wio,1013)"Fail check on ACF ", & tACF, DBLE(tACF)/DBLE(nTratadas)*100.0d0 write (wio,1015) write(wio,1013)"Fail check on CCF ", & tCCF, DBLE(tCCF)/DBLE(nTratadas)*100.0d0 write (wio,1015) write(wio,1016) "Unstable seasonality ", & "(too large innovation variance) ", & tUnstSa,DBLE(tUnstSa)/DBLE(nTratadas)*100.0d0 1016 format(2x,a,/,2x,a,i7,4x,f6.2) write (wio,1015) write(wio,1016)"Unreliable estimation of seasonality", & "(too large estimation variance) ", & tUnrSa,DBLE(tUnrSa)/DBLE(nTratadas)*100.0d0 write (wio,1015) write(wio,1013)"Revisions in SA series are too large ", & tRevSa,DBLE(tRevSa)/DBLE(Numser)*100.0d0 write (wio,1015) write(wio,1013)"Seasonality detected but not significant ", & tSeasNoSig,DBLE(tSeasNoSig)/DBLE(nTratadas)*100.0d0 write (wio,1015) write(wio,1013)"Bias in level of SA series is too large ", & tBias,DBLE(tBias)/DBLE(nTratadas)*100.0d0 write (wio,1015) c if (tCrQs.ne.-1) then write(wio,1010)"TABLE C: RESIDUAL SEASONALITY IN SA SERIES" write(wio,1004)" ------------------------------------------" write(wio,1017) 1017 format(35x,"# of series",4x,"%") write (wio,1018) 1018 format(2x,51("-")) write(wio,1013)"Autocorrelation function evidence ", & tCrQs,DBLE(tCrQs)/DBLE(nTratadas)*100.0d0 write (wio,1018) write(wio,1013)"Non-Parametric evidence ", & tCrSNP,DBLE(tCrSNP)/DBLE(nTratadas)*100.0d0 write (wio,1018) write(wio,1013)"Espectral evidence ", & tCrPeaks,DBLE(tCrPeaks)/DBLE(nTratadas)*100.0d0 write (wio,1018) end if close(wio) return end C c PhaseDia writes the Concurrent estimator:phase Diagram subroutine PhaseDia(nio,phaseDp,phaseDs,mq) implicit none integer mw parameter (mw=1200) c INPUT PARAMETERS integer nio,mq real*8 phaseDp(0:mw),phaseDs(0:mw) c LOCAL PARAMETERS integer i intrinsic INT c ------------------------------------------------------------- write(nio,1000) if (MQ.eq.12) then write(nio,1010)'months' else write(nio,1010)'time periods' end if write(nio,1020) write(nio,1030)' INF ',phaseDs(0),phaseDp(0) write(nio,1030)'20 years cycle', $ phaseDs(INT(2*mw/(20*MQ))),phaseDp(INT(2*mw/(20*MQ))) write(nio,1030)'10 years cycle', $ phaseDs(INT(2*mw/(10*MQ))),phaseDp(INT(2*mw/(10*MQ))) write(nio,1030)' 5 years cycle', $ phaseDs(INT(2*mw/(5*MQ))),phaseDp(INT(2*mw/(5*MQ))) write(nio,1030)' 2 years cycle', $ phaseDs(INT(2*mw/(2*MQ))),phaseDp(INT(2*mw/(2*MQ))) 1000 format(//,9x,'CONCURRENT ESTIMATOR:PHASE DIAGRAM',/) 1010 format(6x,'period of cycle',4x,'Delay(in ',a,')') 1020 format(23x,'SA series',3x,'trend-cycle') 1030 format(7x,a,2x,F6.1,7x,F6.1) end C c PhaseDia writes the Concurrent estimator:phase Diagram subroutine Phas2Dia(nio,phaseDp,phaseDs,FDelayp,FDelaySA,mq) implicit none integer mw parameter (mw=1200) c INPUT PARAMETERS integer nio,mq real*8 phaseDp(0:mw),phaseDs(0:mw),FDelayp(0:mw),FDelaySA(0:mw) c LOCAL PARAMETERS integer i intrinsic INT c ------------------------------------------------------------- write(nio,1000) if (MQ.eq.12) then write(nio,1010)' ','months' else write(nio,1010)' ','time periods' end if write(nio,1020) write(nio,1025) write(nio,1030)' INF ', $ phaseDs(0),FdelaySA(0),phaseDp(0),FdelayP(0) write(nio,1030)'20 years cycle', $ phaseDs(INT(2*mw/(20*MQ))),FdelaySA(INT(2*mw/(20*MQ))), $ phaseDp(INT(2*mw/(20*MQ))),FdelayP(INT(2*mw/(20*MQ))) write(nio,1030)'10 years cycle', $ phaseDs(INT(2*mw/(10*MQ))),FdelaySA(INT(2*mw/(10*MQ))), $ phaseDp(INT(2*mw/(10*MQ))),FdelayP(INT(2*mw/(10*MQ))) write(nio,1030)' 5 years cycle', $ phaseDs(INT(2*mw/(5*MQ))),FdelaySA(INT(2*mw/(5*MQ))), $ phaseDp(INT(2*mw/(5*MQ))),FdelayP(INT(2*mw/(5*MQ))) write(nio,1030)' 2 years cycle', $ phaseDs(INT(2*mw/(2*MQ))),FdelaySA(INT(2*mw/(2*MQ))), $ phaseDp(INT(2*mw/(2*MQ))),FdelayP(INT(2*mw/(2*MQ))) 1000 format(//,9x,'CONCURRENT ESTIMATOR:PHASE DIAGRAM',/) 1010 format(6x,'period of cycle',a,'Delay(in ',a,')') 1020 format(23x,'SA series',20x,'trend-cycle') 1025 format(23x,'Semi-infinite',3x,'finite',3x, $ 'semi-infinite',3x,'finite') 1030 format(7x,a,2x,F6.1,7x,F6.1,7x,F6.1,7x,F6.1) end c c ModelEst: writes the table "ARIMA MODEL FOR ESTIMATOR" c subroutine ModelEst(MQ,d,bd,isCloseToTD,varwnp,Hp,lHp,Vrp,Ep,lEp, $ varwns,Hs,lHs,Vrs,Es,lEs,varwnc,Hc,lHc,Vrc,Ec,lEc, $ varwna,Ha,lHa,Vra,Ea,lEa,Qt1,Hu,lHu,Vru,Eu,lEu) implicit none real*8 diffInt parameter (diffInt=1.0D-6) INCLUDE 'srslen.prm' include 'dimensions.i' include 'stream.i' include 'polynom.i' include 'models.i' c INPUT PARAMETERS logical isCloseToTD integer MQ,d,bd,lHp,lEp,lHs,lEs,lHc,lEc, $ lHa,lEa,lHu,lEu real*8 varwnp,Hp(60-1),Ep(0:60-1),varwns,Hs(60-1),Es(0:60-1), $ varwnc,Hc(60-1),Ec(0:60-1),varwna,Ha(60-1),Ea(0:60-1), $ Qt1,Hu(60-1),Eu(0:60-1),Vrp,Vrs,Vrc,Vra,Vru c LOCAL VARIABLES integer i,j,cont real*8 eTHstar(maxTH),ePHI(40) character strPol*(MaxStrLength),line*(maxLineLength), $ strTH*(maxStrLength),lineTH*(maxLineLength), $ cadEstimator*(4),nameComp*(20) integer nAR,ARdim(maxPolDim),nMA,MAdim(maxPolDim),il,iL2 real*8 AR(maxPol,maxPolDim),MA(maxPol,maxPolDim) integer istrlen external istrlen c ----------------------------------------------------------------------- c Initialize c ----------------------------------------------------------------------- DO i=1,maxPolDim ARdim(i)=0 MAdim(i)=0 DO j=1,maxPol AR(j,i)=0D0 MA(j,i)=0D0 END DO END DO c ----------------------------------------------------------------------- write(nio,'(//,4x,''ARIMA MODEL FOR ESTIMATORS'',/)') write(nio,'(4x, $ ''Innovation are these in observed series (a(t))'')') eTHstar(1)=1.0d0; do i=1,qstar0 eTHstar(i+1)=-THstr0(i); enddo call strPolyn('F ',eTHstar,qstar0+1,diffInt,strTH,lineTH) cont=0 c SA Estimator cont=cont+1 write(Nio,'(//,6x,I1,''. SA SERIES [n(t)]'',/)')cont nAR=0 nMA=0 call AddBJpols(MA,MAdim,nMA,thadj,nthadj) call AddBJpols(MA,MAdim,nMA,Psis,nPsis) call AddBJpols(AR,ARdim,nAR,chis,nchis) if (isCloseToTD) then call AddBJpols(MA,MAdim,nMA,Cycs,nCycs) else call AddBJpols(AR,ARdim,nAR,Cycs,nCycs) end if call tableEstM(MQ,strTH,lineTH,AR,ARdim,nAR,d+bd,0,0,'N', $ thadj,nthadj,MA,MAdim,nMA,0,0,bd,varwna,Ha,lHa,Vra,Ea,lEa) c Estimator of Trend if ((d+bd).gt.0 .or. nChis.gt.0) then cont=cont+1 write(Nio,'(//,6x,I1,''. TREND-CYCLE COMPONENT [P(t)]'',/)')cont nAR=0 nMA=0 call AddBJpols(MA,MAdim,nMA,thetp,nthetp) call AddBJpols(MA,MAdim,nMA,Psis,nPsis) call AddBJpols(MA,MAdim,nMA,Cycs,nCycs) call AddBJpols(AR,ARdim,nAR,chis,nchis) call tableEstM(MQ,strTH,lineTH,AR,ARdim,nAR,d+bd,0,0,'P', $ thetp,nthetp,MA,MAdim,nMA,0,0,bd,varwnp,Hp,lHp,Vrp,Ep,lEp) end if c Estimator of Seasonal if (bd.gt.0 .or. nPsis.gt.0) then cont=cont+1 write(Nio,'(//,6x,I1,''. SEASONAL COMPONENT [S(t)]'',/)')cont nAR=0 nMA=0 call AddBJpols(MA,MAdim,nMA,thets,nthets) call AddBJpols(MA,MAdim,nMA,chis,nChis) call AddBJpols(MA,MAdim,nMA,Cycs,nCycs) call AddBJpols(AR,ARdim,nAR,Psis,nPsis) call tableEstM(MQ,strTH,lineTH,AR,ARdim,nAR,0,0,bd,'S', $ thets,nthets,MA,MAdim,nMA,d+bd,0,0,varwns,Hs,lHs,Vrs,Es,lEs) end if c Estimator of Transitory o TD.stochastic if ((nthetc.gt.0) .or. (ncycs.gt.0)) then cont=cont+1 if (isCloseToTD) then CadEstimator='TDs' NameComp='TD.stochastic' else CadEstimator='C' NameComp='TRANSITORY' end if il=ISTRLEN(NameComp) iL2=ISTRLEN(CadEstimator) write(Nio,'(//,6x,I1,''. '',A,'' ['',A,''(t)]'',/)') $ cont,NameComp(1:il),CadEstimator(1:il2) nAR=0 nMA=0 call AddBJpols(MA,MAdim,nMA,thetc,nthetc) call AddBJpols(MA,MAdim,nMA,chis,nChis) call AddBJpols(MA,MAdim,nMA,Psis,nPsis) call AddBJpols(AR,ARdim,nAR,Cycs,nCycs) call tableEstM(MQ,strTH,lineTH,AR,ARdim,nAR,0,0,0, $ cadEstimator,thetc,nthetc, $ MA,MAdim,nMA,d,bd,0,varwnc,Hc,lHc,Vrc,Ec,lEc) end if c Irregular Estimator if (qt1.ne.0.d0) then cont=cont+1 write(Nio,'(//,6x,I1,''. IRREGULAR COMPONENT [U(t)]'',/)')cont nAR=0 nMA=0 call AddBJpols(MA,MAdim,nMA,chis,nChis) call AddBJpols(MA,MAdim,nMA,Psis,nPsis) call AddBJpols(MA,MAdim,nMA,Cycs,nCycs) call tableEstM(MQ,strTH,lineTH,AR,ARdim,nAR,0,0,0,'U', $ thetc,0,MA,MAdim,nMA,d,bd,0,Qt1,Hu,lHu,Vru,Eu,lEu) end if end subroutine c c TableEstM: escribe los modelos de cada ARIMA MODEL ESTIMATOR c subroutine tableEstM(MQ,strTH,lineTH,AR,ARdim,nAR,dc,bdc,NSc, $ CadEstimator,THc,lTHc,MA,MAdim,nMA,dnc,bdnc,NSnc, $ Vc,Hc,lHc,Vrc,Ec,lEc) implicit none real*8 diffInt parameter (diffInt=1.0D-6) include 'stream.i' include 'polynom.i' c INPUT PARAMETERS integer MQ,ARdim(MaxPol),nAR,MAdim(maxPol),nMA,dc,BDc,NSc,lTHc, $ Dnc,BDnc,NSnc,lHc,lEc real*8 AR(maxPol,MaxPolDim),MA(maxPol,maxPolDim),Vc,Hc(60-1), $ Ec(0:60-1),THc(*),Vrc character strTH*(maxStrLength),lineTH*(maxLineLength), $ CadEstimator*(*) c LOCAL PARAMETERS character strPol*(maxStrLength),line*(maxLineLength), $ strPHI*(maxStrlength),linePHI*(maxLineLength), $ strTmp*(maxStrLength),lineTmp*(maxLineLength) integer i,il,dummInt real*8 ePol(maxPolDim),Kcc,rRoots(60),iRoots(60), $ mRoots(60),arRoots(60),pRoots(60) integer IstrLen external IstrLen c -------------------------------------------------------------------- call getStrPols('B ',AR,ARdim,nAR,Dc,MQ,BDc,NSc,strPHI,linePHI) strPol='' line='' dummInt=3 il=istrlen(CadEstimator) call appendStr(strPHI,linePHI,strPol,line) call appendStrRight(strTH,lineTH,strPol,line) strTmp='' write(linetmp,'(A,''(t)=K'',A)') $ CadEstimator(1:il),CadEstimator(1:il) call AppendStr(strTmp,lineTmp,strPol,line) if (lTHc.gt.0) then ePol(1)=1.0d0 do i=1,lTHc ePol(i+1)=-THc(i) enddo call strPolyn('B ',ePol,lTHc+1,diffInt,strTmp,lineTmp) call appendStr(strTmp,lineTmp,strPol,line) end if call getStrPols('F ',MA,MAdim,nMA,Dnc,MQ,BDnc,NSnc,strTmp, & LineTmp) call AppendStr(strtmp,lineTmp,strPol,line) strTmp='' lineTmp='a(t)' call appendStr(strTmp,lineTmp,strPol,line) call appendLine(strPol,line) write(nio,'(//,8x,''(1) HISTORICAL ESTIMATOR'')') write(NIO,'(/,8x,A)')strPol(1:istrlen(strPol)) write(NIO,'(/,8x,''K'',A,''= '',F9.6)')CadEstimator(1:il),Vc kcc=Ec(0)*Vc; ePol(1)=1.0d0 do i=1,lEc ePol(i+1)=Ec(i)/Ec(0) enddo nMA=0 call AddPols(MA,MAdim,nMA,ePol,lEc+1) strPol='' write(line,'(A,''(t|t)=Kc'',A)') $ CadEstimator(1:il),CadEstimator(1:il) call getStrPols('B ',MA,MAdim,nMA,0,MQ,0,0,strtmp,lineTmp) call AppendStr(strTmp,LineTmp,strPol,line) strTmp='' lineTmp='a(t)' call AppendStr(strTmp,lineTmp,strPol,line) call AppendStrRight(strPHI,linePHI,strPol,line) call AppendLine(strPol,line) write(NIO,'(//,8x,''(2) CONCURRENT ESTIMATOR['',A,''(t|t)]'')') $ CadEstimator(1:il) write(NIO,'(/,8x,A)')strPol(1:istrlen(strPol)) write(NIO,'(/,8x,''Kc'',A,''= '',F9.6)') $ CadEstimator(1:il),Kcc call RPQ(ePol,lEc+1,Rroots,iRoots,mRoots,arRoots,pRoots,1,dummInt) if (lEc.gt.0) then call showRoots(Rroots,iRoots,mRoots,arRoots,lEc, $ 'MA ROOTS of concurrent estimator') end if strPol='' write(line,'(''R(t|t)=Kr'',A,'' F'')')CadEstimator(1:il) call AppendStrRight(strTH,lineTH,strPol,line) if (lHc.gt.0) then nMA=0 call AddBJPols(MA,MAdim,nMA,Hc,lHc) call getStrPols('F ',MA,MAdim,nMA,0,MQ,0,0,StrTmp,lineTmp) call AppendStr(strTmp,lineTmp,strPol,line) end if strTmp='' lineTmp='a(t)' call AppendStr(strTmp,lineTmp,strPol,line) call AppendLine(strPol,line) write(NIO,'(//,8x,''(3) REVISION IN CONCURRENT ESTIMATOR'', $ '' [R(t|t)]'')') write(NIO,'(/,8x,A)')strPol(1:istrlen(strPol)) write(NIO,'(/,8x,''Kr'',A,''= '',F9.6)') CadEstimator(1:il),Vrc end subroutine c c c subroutine showRoots(Rroots,iRoots,mRoots,arRoots,nRoots, $ Caption) implicit none character blan*4,two*4 real*8 tol,pi parameter (tol=1.0d-5,pi = 3.14159265358979D0, $ blan=' - ',two='2.0 ') include 'stream.i' * include 'indhtml.i' c INPUT PARAMETERS real*8 rRoots(60),iRoots(60),mRoots(60) integer nRoots character caption*(*) c INPUT/OUTPUT c arRoots(In radians)=>arRoots(In degrees) real*8 arRoots(60) c LOCAL PARAMETERS real*8 pRoots(60) character per(64)*4 integer i,lenCaption,contR integer istrlen external istrlen c-------------------------------------------------------------------- do i = 1,nroots arRoots(i)=arRoots(i)*pi/180.0d0 if ((iRoots(i).gt.tol) .or. (iRoots(i).lt.-tol)) then pRoots(i) = 2.0d0 * pi / arRoots(i) per(i)=blan else pRoots(i) = 999.99 per(i) = blan if (rRoots(i) .lt. 0.0d0) then per(i) = two end if end if arRoots(i) = 180.0d0 * arRoots(i) / pi end do lenCaption=istrlen(Caption) 7036 format (//,5x,A,/,4x, $ ' ---------------------------------------------------------') write (Nio,7036) caption(1:lenCaption) 7000 format ( $ 3x,' REAL PART ',' IMAGINARY PART',' MODULUS ', $ ' ARGUMENT',' PERIOD') write (Nio,7000) do i = 1,nRoots if (iRoots(i) .ge. -tol) then if (ABS(pRoots(i)-999.99) .lt. 1.d-12) then 7001 format (2x,f11.3,4x,f11.3,5x,f11.3,4x,f11.3,5x,a4) write (Nio,7001) rRoots(i), iRoots(i), mRoots(i), $ arRoots(i), per(i) else 7002 format (2x,f11.3,4x,f11.3,5x,f11.3,4x,f11.3,1x,f11.3) write (Nio,7002) rRoots(i), iRoots(i), mRoots(i), $ arRoots(i),pRoots(i) end if end if end do end subroutine cc c cc subroutine OutARIMAva0(Nio,init,p,bp,wm,PHI,BPHI) implicit none integer n10,n1 parameter (n10=10,n1=1) c c.. INPUT PARAMETERS integer Nio,init,p,bp,q real*8 wm real*8 PHI(3*N1),BPHI(3*N1) c.. Local parameters integer i c if (Init .eq. 2) then write(Nio,'(/,10x,"MEAN =",g16.6,/)') wm end if if ((p.gt.0) .or. (bp.gt.0)) then write(Nio,'(//17x,"AR PARAMETERS ",/)') if (P .ne. 0) then select case (P) case (3) write(Nio,'(11x,"PHI =",3f10.4)') (-Phi(i), i = 1,P) case (2) write(Nio,'(11x,"PHI =",2f10.4)') (-Phi(i), i = 1,P) case (1) write(Nio,'(11x,"PHI =",f10.4)') (-Phi(i), i = 1,P) end select end if ! of p<>0 c if (Bp .ne. 0) then write(Nio,'(11x,''BPHI ='',f10.4,/)') -Bphi(1) end if end if end C----------------------------------------------------------------------- SUBROUTINE OutNP(Nio,NPsadj,NPsadj2,chdr,nhdr,Lplog) implicit none C----------------------------------------------------------------------- INCLUDE 'notset.prm' C----------------------------------------------------------------------- CHARACTER chdr*(30),str*(3) INTEGER Nio,nhdr,NPsadj,NPsadj2,nchr LOGICAL Lplog c----------------------------------------------------------------------- CHARACTER YSNDIC*5 INTEGER ysnptr,PYSN PARAMETER(PYSN=2) DIMENSION ysnptr(0:PYSN) PARAMETER(YSNDIC='noyes') c----------------------------------------------------------------------- DATA ysnptr/1,3,6/ C----------------------------------------------------------------------- WRITE(Nio,1010)' NP statistic for residual seasonality '// & chdr(1:nhdr) WRITE(Nio,1020) IF(.not.(NPsadj.eq.NOTSET))THEN CALL getstr(YSNDIC,ysnptr,PYSN,NPsadj+1,str,nchr) IF(lplog)THEN WRITE(Nio,1030)' log(Seasonally Adjusted Series) ', & str(1:nchr) ELSE WRITE(Nio,1030)' Seasonally Adjusted Series ', & str(1:nchr) END IF END IF IF(.not.(NPsadj2.eq.NOTSET))THEN CALL getstr(YSNDIC,ysnptr,PYSN,NPsadj2+1,str,nchr) IF(lplog)THEN WRITE(Nio,1030)' log(Seasonally Adjusted Series (EV adj)) ', & str(1:nchr) ELSE WRITE(Nio,1030)' Seasonally Adjusted Series (EV adj) ', & str(1:nchr) END IF END IF C----------------------------------------------------------------------- 1010 FORMAT(/,a) 1020 FORMAT(50x,'Residual Seasonality?') 1030 FORMAT(a,14x,a) C----------------------------------------------------------------------- RETURN END htmlout.prm0000664006604000003110000000227714521201517012413 0ustar sun00315steps INTEGER PSTAR1F, PSTAR2F, PAMP1F, PAMP2F, PATSG1F, PATSG2F, & PNOTINC, PSIGNCH, PINCON, PTURNP, PSSPCT1, PSSPCT2, & PSSPCT3, PSSPCT4, PSSPLS1, PSSPLS2, PSSPLS3, PSSPLS4, & PSSHSH1, PSSHSH2, PSSHSH3, PSSHSH4, PSSDLR1, PSSDLR2, & PSSDLR3, PSSDLR4, PSSAT1, PSSAT2, PSSAT3, PSSAT4, & PSTRD8, PHSHD8, PATSD8, PAMPD8, PLSHD8, PMINTR1, & PMINTR2, PMINTR3, PMINTR4, PMINTR5, PMINTR6, PLGLNK, & PSTR1TP, PSTR2TP PARAMETER(PSTAR1F=1, PSTAR2F=2, PAMP1F=3, PAMP2F=4, PATSG1F=5, & PATSG2F=6, PNOTINC=7, PSIGNCH=100, PINCON=200, & PTURNP=400, & PSSPCT1=11, PSSPCT2=12, PSSPCT3=13, PSSPCT4=14, & PSSPLS1=15, PSSPLS2=16, PSSPLS3=17, PSSPLS4=18, & PSSHSH1=19, PSSHSH2=20, PSSHSH3=21, PSSHSH4=22, & PSSDLR1=23, PSSDLR2=24, PSSDLR3=25, PSSDLR4=26, & PSSAT1=27, PSSAT2=28, PSSAT3=29, PSSAT4=30, & PSTRD8=31, PHSHD8=32, PATSD8=33, PAMPD8=34, & PMINTR1=35, PMINTR2=36, PMINTR3=37, PMINTR4=38, & PMINTR5=39, PMINTR6=40, PLSHD8=10, PLGLNK=45, & PSTR1TP=46, PSTR2TP=47) htmlutil.f0000664006604000003110000007471714521201517012220 0ustar sun00315steps subroutine mkHead(Fh,outName,outDesc,cssFull,iDoc,icss,Lindx) c----------------------------------------------------------------------- c Generate top of HTML output c----------------------------------------------------------------------- INCLUDE 'stdio.i' c----------------------------------------------------------------------- INTEGER Fh,iDoc,icss LOGICAL cssFull,Lindx CHARACTER outName*(*),outDesc*(*) c----------------------------------------------------------------------- IF(Lxhtml)THEN CALL WriteDoctype(Fh,0) WRITE(Fh,1010)'' else CALL WriteDoctype(Fh,iDoc) WRITE(Fh,1010)'' END IF WRITE(Fh,1010)'' WRITE(Fh,1020)outName c----------------------------------------------------------------------- CALL mkMetaTag(Fh,'keywords','@', & 'seasonal adjustment, '//PRGNAM//', regARIMA modeling', & Lxhtml) CALL mkMetaTag(Fh,'description','@',outDesc,Lxhtml) CALL mkMetaTag(Fh,'generator','@',PRGNAM,Lxhtml) CALL mkMetaTag(Fh,'author','@', & 'Time Series Research Staff, CSRM, US Census Bureau', & Lxhtml) CALL mkMetaTag(Fh,'@','Content-Type', & 'text/html; charset=ISO-8859-1',Lxhtml) c----------------------------------------------------------------------- c Create CSS information c----------------------------------------------------------------------- IF(icss.ge.0)THEN call writeCSS(Fh,icss,Lxhtml) c----------------------------------------------------------------------- c End head section of file c----------------------------------------------------------------------- WRITE(Fh,1010)'' WRITE(Fh,1010)'' c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END IF WRITE(Fh,1010)'' WRITE(Fh,1010)'' WRITE(Fh,1010)'' c----------------------------------------------------------------------- 1010 FORMAT(a) 1020 FORMAT('',a,'') 1030 FORMAT(' .',a,' { margin-left : ',a,'; margin-right : ',a, & '; width : ',a,' }') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE mkMetaTag(Fh,thisName,thisHttp,thisContent,Lxhtml) c----------------------------------------------------------------------- INTEGER Fh LOGICAL Lxhtml CHARACTER thisName*(*),thisHttp*(*),thisContent*(*),endtag*(3) c----------------------------------------------------------------------- IF(Lxhtml)THEN endtag=' />' ELSE endtag='> ' END IF c----------------------------------------------------------------------- IF(thisHttp(1:1).eq.'@')THEN WRITE(Fh,1000)'name',thisName,thisContent,endtag ELSE WRITE(Fh,1000)'http-equiv',thisHttp,thisContent,endtag END IF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') 1020 FORMAT('
') 1030 FORMAT('
') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkCaption(Fh,thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate caption tag of a given CSS class with given text c----------------------------------------------------------------------- INTEGER Fh CHARACTER thisText*(*) c----------------------------------------------------------------------- WRITE(Fh,1000)thisText 1000 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkHeaderCell(Fh,NrSpan,NcSpan,thisAbb,thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate header cell tag for a given scope with given text and an c abbreviation. c----------------------------------------------------------------------- INTEGER Fh,NrSpan,NcSpan CHARACTER thisAbb*(*),thisText*(*) c----------------------------------------------------------------------- IF(Nrspan.gt.0)THEN IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1000)'row',Nrspan,thisText ELSE WRITE(Fh,1010)'row',Nrspan,thisAbb,thisText END IF ELSE IF(Ncspan.gt.0)THEN IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1000)'col',Ncspan,thisText ELSE WRITE(Fh,1010)'col',Ncspan,thisAbb,thisText END IF ELSE IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1020)thisText ELSE WRITE(Fh,1030)thisAbb,thisText END IF END IF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') 1020 FORMAT('') 1030 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkHeaderCellId(Fh,Nrspan,Ncspan,thisId,thisClass, & thisAbb,thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate header cell tag for a given scope with given text and an c abbreviation. c----------------------------------------------------------------------- INTEGER Fh,NrSpan,NcSpan,i1 CHARACTER thisId*(*),thisClass*(*),thisAbb*(*),thisText*(*) c----------------------------------------------------------------------- IF(thisClass(1:1).eq.'@')THEN IF(Nrspan.gt.0)then IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1000)'row',Nrspan,thisId,thisText ELSE WRITE(Fh,1010)'row',Nrspan,thisId,thisAbb,thisText END IF ELSE IF (Ncspan.gt.0) then IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1000)'col',Ncspan,thisId,thisText ELSE WRITE(Fh,1010)'col',Ncspan,thisId,thisAbb,thisText END IF ELSE IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1020)thisId,thisText ELSE WRITE(Fh,1030)thisId,thisAbb,thisText END IF END IF ELSE IF(Nrspan.gt.0)then IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1100)'row',Nrspan,thisId,thisClass,thisText ELSE WRITE(Fh,1110)'row',Nrspan,thisId,thisClass,thisAbb,thisText END IF ELSE IF (Ncspan.gt.0) then IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1100)'col',Ncspan,thisId,thisClass,thisText ELSE WRITE(Fh,1110)'col',Ncspan,thisId,thisClass,thisAbb,thisText END IF ELSE IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1120)thisId,thisClass,thisText ELSE WRITE(Fh,1130)thisId,thisClass,thisAbb,thisText END IF END IF END IF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') 1020 FORMAT('') 1030 FORMAT('') 1100 FORMAT('') 1110 FORMAT('') 1120 FORMAT('') 1130 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkHeaderCellScope(Fh,Nrspan,Ncspan,thisScope,thisAbb, & thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate header cell tag for a given scope with given text and an c abbreviation. c----------------------------------------------------------------------- INTEGER Fh,NrSpan,NcSpan,i1 CHARACTER thisScope*(*),thisAbb*(*),thisText*(*) c----------------------------------------------------------------------- IF(Nrspan.gt.0)then IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1000)'row',Nrspan,thisScope,thisText ELSE WRITE(Fh,1010)'row',Nrspan,thisScope,thisAbb,thisText END IF ELSE IF (Ncspan.gt.0) then IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1000)'col',Ncspan,thisScope,thisText ELSE WRITE(Fh,1010)'col',Ncspan,thisScope,thisAbb,thisText END IF ELSE IF(thisAbb(1:1).eq.'@')THEN WRITE(Fh,1020)thisScope,thisText ELSE WRITE(Fh,1030)thisScope,thisAbb,thisText END IF END IF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') 1020 FORMAT('') 1030 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkTableCell(Fh,thisClass,thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate cell tag for a given class with given text c----------------------------------------------------------------------- INTEGER Fh CHARACTER thisClass*(*),thisText*(*) c----------------------------------------------------------------------- IF(thisClass(1:1).eq.'@')THEN WRITE(Fh,1000)thisText ELSE WRITE(Fh,1010)thisClass,thisText ENDIF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkTableCellSpan(Fh,thisSpan,nSpan,thisClass,thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate cell tag for a given class with given text c----------------------------------------------------------------------- INTEGER Fh,nSpan CHARACTER thisSpan*(*),thisClass*(*),thisText*(*) c----------------------------------------------------------------------- IF(thisSpan(1:1).eq.'@')THEN IF(thisClass(1:1).eq.'@')THEN WRITE(Fh,1000)thisText ELSE WRITE(Fh,1010)thisClass,thisText ENDIF ELSE IF(thisClass(1:1).eq.'@')THEN WRITE(Fh,1020)thisSpan,nSpan,thisText ELSE WRITE(Fh,1030)thisSpan,nSpan,thisClass,thisText ENDIF END IF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') 1020 FORMAT('') 1030 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkTableCellHeader(Fh,thisHeader,thisClass,thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate cell tag for a given class with given text c----------------------------------------------------------------------- INTEGER Fh CHARACTER thisHeader*(*),thisClass*(*),thisText*(*) c----------------------------------------------------------------------- IF(thisClass(1:1).eq.'@')THEN WRITE(Fh,1000)thisHeader,thisText ELSE WRITE(Fh,1010)thisHeader,thisClass,thisText ENDIF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- subroutine mkTableCellHeaderSpan(Fh,thisSpan,nSpan,thisHeader, & thisClass,thisText) IMPLICIT NONE c----------------------------------------------------------------------- c Generate cell tag for a given class with given text c----------------------------------------------------------------------- INTEGER Fh,nSpan CHARACTER thisSpan*(*),thisHeader*(*),thisClass*(*),thisText*(*) c----------------------------------------------------------------------- IF(thisClass(1:1).eq.'@')THEN WRITE(Fh,1020)thisSpan,nSpan,thisHeader,thisText ELSE WRITE(Fh,1030)thisSpan,nSpan,thisClass,thisHeader,thisText ENDIF c----------------------------------------------------------------------- 1020 FORMAT('') 1030 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE writTag(Flhdnl,Otag) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Flhdnl CHARACTER Otag*(*) c ----------------------------------------------------------------- WRITE(Flhdnl,1010)Otag c----------------------------------------------------------------------- 1010 FORMAT(a) c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE mkPClass(Flhdnl,thisClass) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Flhdnl,Flhdn2 CHARACTER thisClass*(*) c ----------------------------------------------------------------- WRITE(Flhdnl,1010)thisClass c----------------------------------------------------------------------- 1010 FORMAT(/,'

') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE writTagClass(Flhdnl,Otag,thisClass) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Flhdnl CHARACTER Otag*(*),thisClass*(*) c ----------------------------------------------------------------- WRITE(Flhdnl,1010)Otag,thisClass c----------------------------------------------------------------------- 1010 FORMAT('<',a,' class="',a,'">') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE mkPOneLine(Flhdnl,thisClass,thisText) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Flhdnl,Flhdn2 CHARACTER thisClass*(*),thisText*(*) c ----------------------------------------------------------------- IF(thisClass(1:1).eq.'@')THEN WRITE(Flhdnl,1000)thisText ELSE WRITE(Flhdnl,1010)thisClass,thisText END IF c----------------------------------------------------------------------- 1000 FORMAT(/,'

',a,'

') 1010 FORMAT(/,'

',a,'

') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE writTagOneLine(Flhdnl,Otag,thisClass,thisText) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Flhdnl CHARACTER Otag*(*),thisClass*(*),thisText*(*) c ----------------------------------------------------------------- IF(thisClass(1:1).eq.'@')THEN WRITE(Flhdnl,1000)Otag,thisText,Otag ELSE WRITE(Flhdnl,1010)Otag,thisClass,thisText,Otag END IF c----------------------------------------------------------------------- 1000 FORMAT(/,'<',a,'>',a,'') 1010 FORMAT(/,'<',a,' class="',a,'">',a,'') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE makeAnchor(Flhdnl,Itab,Abase) IMPLICIT NONE c----------------------------------------------------------------------- CHARACTER Abase*(*) INTEGER Flhdnl,Itab c----------------------------------------------------------------------- IF(Itab.lt.0)THEN WRITE(Flhdnl,1010)Abase ELSE WRITE(Flhdnl,1000)Abase,Itab END IF c----------------------------------------------------------------------- 1000 FORMAT(/,'') 1010 FORMAT(/,'') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE makeSkipLink(Flhdnl,Itab,thisText,plotSkip) IMPLICIT NONE c----------------------------------------------------------------------- CHARACTER thisText*(*) INTEGER Flhdnl,Itab LOGICAL plotSkip c----------------------------------------------------------------------- IF(plotSkip)THEN WRITE(Flhdnl,1000)'pos',Itab,thisText,'

' ELSE WRITE(Flhdnl,1000)'skip',Itab,'navagation link',' ' IF(Itab.eq.0)THEN WRITE(Flhdnl,1010)Itab+1,thisText ELSE WRITE(Flhdnl,1020)Itab-1,thisText,Itab,Itab+1,thisText END IF END IF c----------------------------------------------------------------------- 1000 FORMAT(/,'

', & ' ',a) 1010 FORMAT('Next ',a,'

') 1020 FORMAT('Previous ',a,' | ', & 'Index | ', & 'Next ',a,'

') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE makeIndexLink(Flhdnl,Itab,thisFile,thisTable,upTab, & useFile) IMPLICIT NONE c----------------------------------------------------------------------- CHARACTER thisFile*(*),thisTable*(*) INTEGER Flhdnl,Itab LOGICAL upTab,useFile c----------------------------------------------------------------------- IF(Itab.lt.0)THEN WRITE(Flhdnl,1020)thisFile,thisTable ELSE IF(useFile)THEN WRITE(Flhdnl,1000)thisFile,Itab,thisTable ELSE WRITE(Flhdnl,1010)Itab,Itab,thisTable END IF IF(upTab)Itab=Itab+1 END IF c----------------------------------------------------------------------- 1000 FORMAT('
  • ',a,'
    • ') 1010 FORMAT('
  • ',a, & '
    • ') 1020 FORMAT('
  • ',a,'
    • ') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE makColgroup(Flhdnl,thisSpan) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'stdio.i' c ------------------------------------------------------------------ INTEGER Flhdnl,thisSpan c ------------------------------------------------------------------ IF(thisSpan.gt.0)THEN IF (Lxhtml) THEN WRITE(Flhdnl,1000)thisSpan ELSE WRITE(Flhdnl,1010)thisSpan END IF ELSE WRITE(Flhdnl,1020) END IF c----------------------------------------------------------------------- 1000 FORMAT('') 1010 FORMAT('') 1020 FORMAT('') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- SUBROUTINE makDivId(Flhdnl,thisId,thisClass) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Flhdnl CHARACTER thisId*(*),thisClass*(*) c ------------------------------------------------------------------ IF(thisClass(1:1).eq.'@')THEN WRITE(Flhdnl,1000)thisId ELSE WRITE(Flhdnl,1010)thisClass,thisId END IF c----------------------------------------------------------------------- 1000 FORMAT(/,'
    ') 1010 FORMAT(/,'
    ') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- c SUBROUTINE prtwkf(Nio,wkf,nwkf,Chdr,Nhdr,thisId,nid) c----------------------------------------------------------------------- implicit none c----------------------------------------------------------------------- CHARACTER Chdr*(32),thisId*(24) INTEGER Nio,nwkf,j,i,i2,Nhdr,nid DOUBLE PRECISION wkf DIMENSION wkf(*) c----------------------------------------------------------------------- CALL makDivId(Nio,thisId(1:nId),'@') CALL mkTableTag(Nio,'w80', & 'WIENER-KOLMOGOROV FILTER, '//Chdr(1:Nhdr)) CALL mkCaption(Nio,Chdr(1:Nhdr)) DO i=1,nwkf,12 i2=i+11 if (i2.gt.nwkf) THEN CALL writTag(Nio,'
    ') DO j=i,nwkf WRITE(Nio,6999)wkf(j) END DO DO j=nwkf+1,i2 CALL mkTableCell(Nio,'@',' ') END DO CALL writTag(Nio,'') ELSE write (Nio,7000) (wkf(j), j = i,i2) END IF END DO c----------------------------------------------------------------------- CALL writTag(Nio,'
    ',a,'
    ',a,'',a, & '',a,'',a,'',a,'',a, & '',a,'',a,'',a, & '',a,'',a,'',a, & '',a,'',a,'',a,'',a,'',a,'',a,'',a,'',a,'',a,'',a,'',a,'',a,'',a,'',a, & '
    ') CALL mkPOneLine(Nio,'@',' ') c----------------------------------------------------------------------- 6999 FORMAT('',F7.4,'') 7000 FORMAT('',12('',F7.4,''),'') c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- idamax.f0000664006604000003110000000171314521201517011603 0ustar sun00315steps integer function idamax(n,dx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dmax integer i,incx,ix,n c idamax = 0 if( n.lt.1 .or. incx.le.0 ) return idamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 dmax = dabs(dx(1)) ix = ix + incx do 10 i = 2,n if(dabs(dx(ix)).le.dmax) go to 5 idamax = i dmax = dabs(dx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 dmax = dabs(dx(1)) do 30 i = 2,n if(dabs(dx(i)).le.dmax) go to 30 idamax = i dmax = dabs(dx(i)) 30 continue return end iddiff.f0000664006604000003110000005004114521201520011555 0ustar sun00315stepsC Last change: BCM 1 Dec 2004 10:00 am SUBROUTINE iddiff(Idr,Ids,Trnsrs,Nefobs,Frstry,A,Na,Imu,Lmu, & Svldif,Lsumm) IMPLICIT NONE c ------------------------------------------------------------------ c Unit root identification procedure outlined in the paper by Gomez c and Maravall (1998) and implemented in TRAMO modeling package c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO,PONE,PTWO,PT9 INTEGER TWOHND LOGICAL T,F PARAMETER(T=.true.,F=.FALSE.,ONE=1D0,ZERO=0D0,PONE=1.D-1, & PTWO=2.D-1,PT9=9.D-1,TWOHND=200) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'prior.prm' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'units.cmn' INCLUDE 'prior.cmn' INCLUDE 'extend.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' c ------------------------------------------------------------------ DOUBLE PRECISION Trnsrs,A,rmaxr,rmaxs,tval,vct,din,rmse, & xpxinv,tmp,seb,xmu,txy LOGICAL inptok,Svldif,linv,lxar,Lmu,lchks,lchks2 INTEGER i,i2,ardsp,Frstry,Idr,Ids,idrf,idsf,Na,ar1r,nparma, & ar1s,ma1r,ma1s,icon,irm1,Nefobs,iround,Id,i3,nelt,info, & nelta,Imu,limrd,limsd,mxitbk,Lsumm DIMENSION Trnsrs(PLEN),xpxinv(PB*(PB+1)/2),tmp(2),txy(PLEN),a(*) DOUBLE PRECISION tolbak,PTOL,nltbak PARAMETER(PTOL=1.0D-3) c ------------------------------------------------------------------ DOUBLE PRECISION dpmpar,totals,sdev,wd,wm LOGICAL dpeq EXTERNAL strinx,dpmpar,totals,sdev,dpeq c ------------------------------------------------------------------ irm1=0 inptok=T mxitbk=Mxiter c ------------------------------------------------------------------ iround=1 Id=0 idrf=0 idsf=0 limrd=Idr limsd=Ids rmaxr=ZERO rmaxs=ZERO c ------------------------------------------------------------------ c Set up first model for unit root identification c ------------------------------------------------------------------ DO WHILE(T) IF(Prttab(LAUURM))WRITE(Mt1,1070)'(H-R)','Unit Root',iround CALL mdlint() IF(Id.gt.0.or.iround.GT.1)THEN IF(Lseff.or.Sp.eq.1)THEN CALL mdlset(1,idrf,1,0,0,0,inptok) ELSE CALL mdlset(1,idrf,1,1,idsf,1,inptok) END IF IF(Lfatal)RETURN ardsp=Nnsedf+Nseadf Nefobs=Nspobs-Nintvl i3=3 IF (Sp.eq.1) i3=2 ar1r=ardsp+1 ma1r=ardsp+i3 ar1s=0 ma1s=0 IF (Sp.gt.1) THEN ar1s=ar1r+1 ma1s=ma1r+1 END IF ELSE IF(Lseff.or.Sp.eq.1)THEN ar1r=Frstar ar1s=0 ELSE IF (Sp.eq.2) THEN ar1r=1 ar1s=1 ELSE IF (Sp.eq.3.and.Frstar.ge.3) THEN ar1r=2 ar1s=1 ELSE IF (Sp.eq.4.and.Frstar.eq.4) THEN ar1r=3 ar1s=1 ELSE ar1r=Frstar ar1s=1 END IF CALL mdlset(ar1r,0,0,ar1s,0,0,inptok) IF(Lfatal)RETURN ardsp=0 Nefobs=Nspobs-Nintvl END IF c ------------------------------------------------------------------ IF((.not.inptok).or.Lfatal)THEN WRITE(STDERR,1010) WRITE(Mt2,1010) IF (.not.Lfatal) CALL abend() RETURN END IF c ------------------------------------------------------------------ c Difference data, if necessary c ------------------------------------------------------------------ nelta=Nspobs CALL copy(Trnsrs,nelta,1,txy) IF(id.gt.0)CALL arflt(nelta,Arimap,Arimal,Opr,Mdl(DIFF-1), & Mdl(DIFF)-1,txy,nelta) CALL smeadl(txy,1,nelta,nelta,xmu) c----------------------------------------------------------------------- c Estimate the regression and ARMA parameters c----------------------------------------------------------------------- CALL amdest(txy,nelta,Nefobs,ardsp,T,Prttab(LAUURT),info) IF(Lfatal)RETURN IF(Prttab(LAUURM).and.info.eq.0)CALL amdprt(ardsp,T,F) c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PSNGER)THEN WRITE(STDERR,1020) WRITE(Mt2,1020) CALL abend() RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c If first round, check to see if roots are inside the unit circle c----------------------------------------------------------------------- IF(iround.eq.1.and.info.eq.0)THEN linv=T CALL chkrt1(Idr,Ids,rmaxr,rmaxs,linv,Ub1lim) IF(Lfatal)RETURN IF(.not.linv)THEN IF(ar1r.EQ.1.AND.DABS(Arimap(1)).GT.1.02D0)THEN info=1 ELSE IF(ar1r.GT.1)THEN info=1 END IF IF (ar1s.EQ.1.AND.DABS(Arimap(ar1r+1)).GT.1.02D0) info=1 END IF IF(info.gt.0)THEN DO i=1,ar1r+ar1s Arimap(i)=PONE END DO END IF ELSE IF (info.ne.0) THEN IF(iround.eq.1)ma1r=ar1r+ar1s+1 DO i=ar1r,ma1r-1 Arimap(i)=PONE END DO IF(iround.gt.1)THEN DO i=ma1r,ma1s Arimap(i)=PTWO END DO END IF END IF IF (irm1.EQ.1) THEN info=1 DO i=ar1r,ma1s Arimap(i)=PONE END DO END IF IF (idrf.EQ.0.AND.idsf.EQ.0.AND.iround.GT.2) info=1 IF (info.ne.0) THEN lxar=Lextar Lextar=Exdiff.gt.0 Lar=Lextar.and.Mxarlg.gt.0 c ------------------------------------------------------------------ IF(Lextar)THEN Nintvl=Mxdflg Nextvl=Mxarlg+Mxmalg IF(Exdiff.eq.2)Mxiter=TWOHND c ------------------------------------------------------------------ ELSE Nintvl=Mxdflg+Mxarlg Nextvl=0 END IF c ------------------------------------------------------------------ IF(Prttab(LAUURM))THEN IF(Exdiff.gt.0)THEN WRITE(Mt1,1070)'(exact mle)','Unit Root',iround ELSE WRITE(Mt1,1070)'(conditional)','Unit Root',iround END IF END IF c ------------------------------------------------------------------ c Loosen tolerance for Exact likelihood model estimation c ------------------------------------------------------------------ * IF(Exdiff)THEN IF(Tol.lt.PTOL)THEN nltbak=Nltol tolbak=Tol Tol=PTOL Nltol=PTOL Nltol0=100D0*Tol END IF * END IF c ------------------------------------------------------------------ CALL regvar(Trnsrs,Nspobs,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) * CALL rgarma(Lestim,Mxiter,Mxnlit,T,a,na,nefobs,inptok) CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,inptok) IF(.not.Lfatal)THEN IF((.not.Convrg).and.Exdiff.eq.2)THEN Nintvl=Mxdflg+Mxarlg Nextvl=0 Lextar=F Lar=F Mxiter=mxitbk IF(Prttab(LAUURM)) & WRITE(Mt1,1070)'(conditional)','Unit Root',iround CALL regvar(Trnsrs,Nspobs,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) * CALL rgarma(Lestim,Mxiter,Mxnlit,T,a,na,nefobs,inptok) CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,inptok) IF(Lfatal)RETURN END IF CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.inptok)THEN CALL abend() END IF * IF(Exdiff)THEN IF(dpeq(Tol,PTOL))THEN Tol=tolbak Nltol=nltbak Nltol0=Tol*100D0 END IF * END IF END IF IF(Lfatal)RETURN IF(Prttab(LAUURM))CALL amdprt(ardsp,inptok,F) c ------------------------------------------------------------------ c Reset estimation variables to what they were before c ------------------------------------------------------------------ Lextar=lxar Lar=Lextar.and.Mxarlg.gt.0 IF(Lextar)THEN Nintvl=Mxdflg Nextvl=Mxarlg+Mxmalg ELSE Nintvl=Mxdflg+Mxarlg Nextvl=0 END IF c----------------------------------------------------------------------- if(iround.eq.1)THEN linv=T CALL chkrt1(Idr,Ids,rmaxr,rmaxs,linv,Ub1lim) IF(Lfatal)RETURN * IF(.not.linv)THEN * WRITE(STDERR,1020) * WRITE(Mt2,1020) * CALL abend() * RETURN * END IF END IF END IF c----------------------------------------------------------------------- c Check roots and update difference counters c----------------------------------------------------------------------- icon=0 irm1=0 IF(iround.eq.1)THEN idrf=idrf+Idr idsf=idsf+Ids c----------------------------------------------------------------------- ELSE din=1.005D0-Ub2lim Cancel=Cancel-0.002D0 IF (Armaer.EQ.0.AND.Ub2lim.GE.0.869D0) din=din+Ub2lim-0.869D0 IF (DABS(ONE-Arimap(ar1r)).LE.DIN) THEN IF (Arimap(ar1r).GT.1.02D0) THEN irm1=1 icon=1 ELSE IF (DABS(Arimap(ar1r)-Arimap(ma1r)).GT.Cancel) THEN icon=icon+1 idrf=idrf+1 Id=idrf+idsf*Sp END IF ELSE IF (DABS(Arimap(ar1r)).GT.1.12D0) THEN irm1=1 icon=1 END IF IF (Sp.GT.1) THEN IF (DABS(ONE-Arimap(ar1s)).LE.0.19D0) THEN IF (Arimap(ar1s).GT.1.02D0) THEN irm1=1 icon=1 ELSE IF ((DABS(Arimap(ar1s)-Arimap(ma1s)).GT.Cancel).AND. & (idsf.EQ.0)) THEN icon=icon+1 idsf=idsf+1 Id=idrf+idsf*Sp IF (irm1.EQ.1) THEN irm1=0 icon=icon-1 END IF END IF ELSE IF (DABS(Arimap(ar1s)).GT.1.12D0) THEN irm1=1 icon=1 END IF END IF lchks=ar1s.gt.0 IF(lchks)lchks=DABS(Arimap(ar1s)-Arimap(ma1s)).LE.Cancel IF (((DABS(Arimap(ar1r)-Arimap(ma1r)).LE.Cancel).OR.lchks) & .AND.iround.EQ.2) THEN IF (idrf.EQ.0.AND.idsf.EQ.0.AND. & (rmaxr.GE.PT9.OR.rmaxs.GE.PT9))THEN IF (irm1.EQ.1.AND.icon.EQ.1) THEN irm1=0 icon=0 END IF icon=icon+1 IF (rmaxr.GT.rmaxs) THEN idrf=idrf+1 ELSE idsf=idsf+1 END IF END IF END IF lchks=ar1s.gt.0 IF(lchks)lchks=DABS(ONE-Arimap(ar1s)).LE.0.16D0 lchks2=ar1s.gt.0 IF(lchks)lchks2=DABS(ONE-Arimap(ar1s)).LE.0.17D0 IF ((iround.EQ.2.AND.idrf.EQ.0.AND.idsf.EQ.0.AND. & (DABS(ONE-Arimap(ar1r)).LE.0.15D0.OR.lchks).AND. & (rmaxr.GE.PT9.OR.rmaxs.GE.0.88D0)).OR. & (iround.EQ.2.AND.idrf.EQ.0.AND.idsf.EQ.0.AND. & (DABS(ONE-Arimap(ar1r)).LE.0.16D0.OR.lchks2).AND. & (rmaxr.GE.0.91D0.OR.rmaxs.GE.0.89D0))) THEN IF (irm1.EQ.1.AND.icon.EQ.1) THEN irm1=0 icon=0 END IF icon=icon+1 IF (rmaxr.GT.rmaxs) THEN idrf=idrf+1 ELSE idsf=idsf+1 END IF END IF lchks=ar1s.gt.0 IF(lchks)lchks=DABS(ONE-Arimap(ar1s)).LE.0.25D0 IF (iround.GE.2.AND.idrf.EQ.0.AND.idsf.EQ.0.AND. & (DABS(ONE-Arimap(ar1r)).LE.0.15D0.OR.lchks)) THEN IF (Sp.EQ.1) THEN idrf=idrf+1 ELSE rmaxr=Arimap(ar1r) rmaxs=Arimap(ar1s) IF (rmaxr.GT.rmaxs) THEN idrf=idrf+1 ELSE idsf=idsf+1 END IF END IF END IF c----------------------------------------------------------------------- C INCREASE ONE BY ONE ONLY. POSSIBLE OVERDIFFERENCING c----------------------------------------------------------------------- IF (icon.EQ.2) THEN idrf=idrf-1 idsf=idsf-1 IF (iround.GE.2.AND.Armaer.gt.0) THEN IF (DABS(Arimap(ar1r)).GT.DABS(Arimap(ar1s))) THEN idrf=idrf+1 ELSE idsf=idsf+1 END IF ELSE IF (rmaxr.GT.rmaxs) THEN IF (rmaxr.GT.-9999.D0) idrf=idrf+1 ELSE IF (rmaxs.GT.-9999.D0) THEN idsf=idsf+1 END IF END IF END IF IF (iround.GE.1) THEN iround=iround+1 c----------------------------------------------------------------------- c Check to see if too much differencing is allowed c----------------------------------------------------------------------- IF (idrf.EQ.3) THEN idrf=2 icon=0 END IF IF (idsf.EQ.2) THEN idsf=1 icon=0 END IF c----------------------------------------------------------------------- c Update Id and see if we can leave c----------------------------------------------------------------------- Id=idrf+idsf*Sp IF(idrf.gt.limrd)THEN idrf=limrd WRITE(Mt1,1080)'Regular',idrf GO TO 30 END IF IF(idsf.gt.limsd)THEN idsf=limsd WRITE(Mt1,1080)'Seasonal',idsf GO TO 30 END IF IF ((icon.GE.1.AND.iround.LE.7).OR.iround.EQ.2) GO TO 10 END IF 30 IF(Prttab(LAUURT))THEN WRITE(Mt1,1030) WRITE(Mt1,1040)'Regular',idrf IF(Sp.gt.1)WRITE(Mt1,1040)'Seasonal',idsf END IF IF(Svldif)THEN WRITE(Ng,1030) WRITE(Ng,1040)'Regular',idrf IF(Sp.gt.1)WRITE(Ng,1040)'Seasonal',idsf END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1050)'idnonseasonaldiff.first',idrf IF(Sp.gt.1)WRITE(Nform,1050)'idseasonaldiff.first',idsf END IF c----------------------------------------------------------------------- c Check to see if mean regressor is significant by creating c t-value of residuals if no differencing found c----------------------------------------------------------------------- IF(Imu.eq.0.and.Lchkmu)THEN Lmu=T IF(id.eq.0)THEN wm=totals(Trnsrs,1,Nspobs,1,1) wd=sdev(Trnsrs,1,Nspobs,1,1) tval=dsqrt(dble(Nspobs))*wm/wd IF (Nspobs.LE.80) THEN vct=1.96D0 ELSE IF (Nspobs.GT.80.AND.Nspobs.LE.200) THEN vct=2.0D0 ELSE vct=2.55D0 END IF IF(DABS(tval).lt.vct)Lmu=F ELSE c----------------------------------------------------------------------- c Else, check to see if mean regressor is significant by adding a c constant regressor and generating a t statistic c----------------------------------------------------------------------- CALL adrgef(DNOTST,'Constant','Constant',PRGTCN,F,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Generate regression matrix c ------------------------------------------------------------------ * CALL mdlint() * CALL mdlset(0,idrf,0,0,idsf,0,inptok) * IF(Lfatal)RETURN nelta=Nspobs CALL copy(Trnsrs,nelta,1,txy) CALL regvar(txy,nelta,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN c ------------------------------------------------------------------ ** CALL setdp(ZERO,PARIMA,Arimap) c ------------------------------------------------------------------ c Initialize ARIMA parameters to 0.1 rather than 0 - c BCM January 2007, Revised July 2008 c ------------------------------------------------------------------ i=1 nparma=Mdl(MA) DO WHILE (i.le.nparma) IF(.not.Arimaf(i))Arimap(i)=0.1D0 i=i+1 END DO IF(Tol.lt.PTOL)THEN nltbak=Nltol tolbak=Tol Tol=PTOL Nltol=PTOL Nltol0=100D0*Tol END IF * CALL rgarma(Lestim,Mxiter,Mxnlit,T,a,na,nefobs,inptok) CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,inptok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.inptok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN IF(dpeq(Tol,PTOL))THEN Tol=tolbak Nltol=nltbak Nltol0=Tol*100D0 END IF nelt=Ncxy*(Ncxy+1)/2 IF(Var.gt.2D0*dpmpar(1))THEN rmse=sqrt(Var) CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,Nb,tmp,1) ELSE rmse=ZERO END IF c----------------------------------------------------------------------- c compute standard error and t-value c----------------------------------------------------------------------- seb=sqrt(xpxinv(1))*rmse tval=ZERO IF(seb.gt.ZERO)tval=B(1)/seb IF (Nspobs.LE.80) THEN vct=1.96D0 ELSE IF (Nspobs.GT.80.AND.Nspobs.LE.155) THEN vct=1.98D0 ELSE IF (Nspobs.GT.155.AND.Nspobs.LE.230) THEN vct=2.1D0 ELSE IF (Nspobs.GT.230.AND.Nspobs.LE.350) THEN vct=2.3D0 ELSE vct=2.5D0 END IF IF (DABS(tval).LT.vct) THEN IF(Prttab(LAUURT))WRITE(Mt1,1060)'is not' Lmu=F ELSE IF(Prttab(LAUURT)) THEN WRITE(Mt1,1060)'is' END IF i2=1 CALL dlrgef(i2,Nrxy,1) IF(Lfatal)RETURN END IF END IF GO TO 20 10 CONTINUE END DO 20 Idr=idrf Ids=idsf Mxiter=mxitbk c----------------------------------------------------------------------- 1010 FORMAT(/,' ERROR: Unable to set up ARIMA model for unit root ', & 'testing procedure',/, & ' for the reason(s) given above.') 1020 FORMAT(/,' Estimation error found during unit root testing ', & /,' procedure while fitting inital regARIMA model to the', & ' series.') 1030 FORMAT(/,' Results of Unit Root Test for identifying orders', & ' of differencing:') 1040 FORMAT( ' ',a,' difference order : ',i3) 1050 FORMAT(a,': ',i3) 1060 FORMAT(/,' Mean ',a,' significant.') 1070 FORMAT(/,' ARIMA Estimates ',a,' for ',a,' Identification : ', & 'Model No. ',i2,/) c Change format of warning message (BCM 10-14-2008) 1080 FORMAT(/,' ',a,' difference order reset to ',i1,', the limit ', & 'specified in the',/,' maxdiff argument.') 1090 FORMAT(/,' ERROR: Estimation failed to converge during the ', & 'automatic model',/ & ' identification procedure.') c----------------------------------------------------------------------- END idmdl.f0000664006604000003110000001550114521201520011423 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 11:16 am SUBROUTINE idmdl(Dflist,Niddf,Nidsdf,Mxidlg,Lgraf) IMPLICIT NONE c ------------------------------------------------------------------ LOGICAL F,T DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0,F=.false.,T=.true.) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'acfptr.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'tbllog.i' INCLUDE 'mdltbl.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' c ------------------------------------------------------------------ INTEGER PXY PARAMETER(PXY=PLEN*(PB+1)) c ------------------------------------------------------------------ INTEGER cnstcl,Dflist,endopr,idf,igrp,isdf,itmp,Mxidlg,mxndf, & mxnsdf,na,ndf,nefobs,Niddf,Nidsdf,nsdf DOUBLE PRECISION a,txy LOGICAL Lgraf,locok DIMENSION a(PLEN+2*PORDER),Dflist(PDFLG,2),txy(PXY) c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- INTEGER Fhacf,Fhpcf,Fhacfg,Fhpcfg COMMON /cfhacf/ Fhacf,Fhpcf,Fhacfg,Fhpcfg c----------------------------------------------------------------------- c Do a regression a regression on the series and variables c differenced by the maximum order of differencing found in the c difference lists. c----------------------------------------------------------------------- IF(Nb.gt.0)THEN CALL maxidx(Dflist,Niddf,itmp,mxndf) CALL maxidx(Dflist(1,2),Nidsdf,itmp,mxnsdf) CALL copy(Xy,Nspobs*Ncxy,1,txy) CALL difflt(Nspobs,Ncxy,mxndf,mxnsdf,Sp,txy,nefobs) c----------------------------------------------------------------------- c check to see if there are enough observations to perform ols c regression/acfs (BCM 2-2000) c----------------------------------------------------------------------- IF(nefobs.le.0)THEN CALL writln('ERROR: Not enough data to perform maximum order of &differencing',STDERR,Mt2,T) CALL writln(' specified in the diff and sdiff arguments of & the identify spec.',STDERR,Mt2,F) CALL abend() RETURN END IF c----------------------------------------------------------------------- igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(igrp.gt.0)THEN IF(.not.Lquiet)WRITE(STDERR,1010) WRITE(Mt1,1010) CALL errhdr WRITE(Mt2,1010) 1010 FORMAT(/,' WARNING: For calculating the ACF''s and PACF''s ', & 'requested from the identify',/, & ' spec, a sample mean adjustment has been ', & 'used in place of the',/, & ' effect of the constant regressor ', & 'specified in the regression spec.',/) CALL setdp(ONE,nefobs,a) cnstcl=Grp(igrp-1) CALL copycl(a,nefobs,1,1,Ncxy,cnstcl,txy) ELSE cnstcl=0 END IF c ------------------------------------------------------------------ CALL olsreg(txy,nefobs,Ncxy,Ncxy,B,Chlxpx,PXPX,Sngcol) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Sngcol.gt.0)THEN Convrg=F Armaer=PISNER CALL prterr(nefobs,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(cnstcl.gt.0)B(cnstcl)=ZERO END IF itmp=0 CALL resid(Xy,Nspobs,Ncxy,Ncxy,1,Nb,-ONE,B,a) IF(Lfatal)RETURN CALL yprmy(a,Nspobs,Var) Var=Var/Nspobs c----------------------------------------------------------------------- c Print the regression estimates. Trick prtmdl in thinking that c there is no ARMA model. c----------------------------------------------------------------------- IF(Nb.gt.0)THEN endopr=Mdl(MA) Mdl(MA)=1 IF(Prttab(LIDRGC))THEN CALL prtmdl(F,T,F,F,F,F,F,F,F,itmp,F,F,F) IF(Lfatal)RETURN END IF Mdl(MA)=endopr END IF c----------------------------------------------------------------------- c Set up file handles needed to save acfs and pacfs generated by the c identify spec c----------------------------------------------------------------------- locok=T IF(Savtab(LSPIDN+LACF)) & CALL opnfil(.true.,F,LSPIDN+LACF,Fhacf,locok) IF(Savtab(LSPIDN+LPCF).and.locok) & CALL opnfil(.true.,F,LSPIDN+LPCF,Fhpcf,locok) IF(Lgraf.and.locok)THEN CALL opnfil(.true.,Lgraf,LSPIDN+LACF,Fhacfg,locok) IF(locok) & CALL opnfil(.true.,Lgraf,LSPIDN+LPCF,Fhpcfg,locok) END IF IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print the acf and pacf for all the orders of differencing c requested. c----------------------------------------------------------------------- DO idf=1,Niddf ndf=Dflist(idf,1) c ------------------------------------------------------------------ DO isdf=1,Nidsdf nsdf=Dflist(isdf,2) c ------------------------------------------------------------------ IF(ndf.eq.0)THEN IF(nsdf.eq.0)THEN WRITE(Mt1,1020) 1020 FORMAT(/,' Differencing: none') c ------------------------------------------------------------------ ELSE WRITE(Mt1,1030)nsdf 1030 FORMAT(/,' Differencing: Seasonal Order=',i1) END IF c ------------------------------------------------------------------ ELSE IF(nsdf.eq.0)THEN WRITE(Mt1,1040)ndf 1040 FORMAT(/,' Differencing: Nonseasonal Order=',i1) c ------------------------------------------------------------------ ELSE WRITE(Mt1,1050)ndf,nsdf 1050 FORMAT(/,' Differencing: Nonseasonal Order=',i1, & ', Seasonal Order=',i1) END IF c ------------------------------------------------------------------ CALL copy(a,Nspobs,1,txy) CALL difflt(Nspobs,1,ndf,nsdf,Sp,txy,na) CALL prtacf(LSPIDN,na,txy,na,Mxidlg,Lgraf,F,ndf,nsdf) IF(Lfatal)RETURN END DO END DO c ------------------------------------------------------------------ IF(Savtab(LSPIDN+LACF))CALL fclose(Fhacf) IF(Savtab(LSPIDN+LPCF))CALL fclose(Fhpcf) IF(Lgraf)THEN CALL fclose(Fhacfg) CALL fclose(Fhpcfg) END IF c ------------------------------------------------------------------ RETURN END idotlr.f0000664006604000003110000015600414521201520011633 0ustar sun00315stepsC Last Change: the almost outlier table won't be printed if the C header is not specified in the print argument. C previous Change: Mar. 2021, add a logical variable to avoid print C duplicate messages of label 1020 C Last change: SRD 25 Jan 100 2:35 pm SUBROUTINE idotlr(Ltstao,Ltstls,Ltsttc,Ladd1,Critvl,Cvrduc, & Begtst,Endtst,Nefobs,Lestim,Mxiter,Mxnlit,Lauto, & A,Trnsrs,Nobspf,Nfcst,Outfct,Fctok,Lxreg,Nbeg, & Prx11r,Prttst,Priter,Sviter,Prftt,Svftt,Lgraf, & Ldiag) IMPLICIT NONE c----------------------------------------------------------------------- c idotlr.f, Release 1, Subroutine Version 1.12, Modified 13 Mar 1995. c----------------------------------------------------------------------- c Idotlr identifies the largest AO and LS outliers in a time series c and returns and XY matrix augmented with the outlier variables and c starting values in the coefficient matrix. Note that the Xy matrix c is assumed to start at the same point as the data so if you are going c to backcast and forecasting the outliers need to be added to the c extended matrix. This could be done using addcol and addotl. c Note that begspn and nspobs are based on the span not the full series c now so they are actually begspn and nspobs. c----------------------------------------------------------------------- c Routine revised to include TC outliers in outlier identification c by BCM July 1997 c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c a d Output a/na long vector of innovation errors c AO i Local PARAMETER for the index for AO type outliers c aotltl c Local 33 character PARAMETER title for the automatically c identified outlier regression group, as distingished c from the user defined regression group. c begtst i Input 2 long vector for the begining data to start testing c for outliers c critt d Local crtical t-value*sqrt(mse) to be compared with the c same outlier statistic for each time point c endtst i Input 2 long vector for the begining data to end testing c for outliers c i i Local do loop index c ibgtst i Local index to the row in [X:y] to begin testing outliers c iedtst i Local index to the row in [X:y] to end testing outliers c itmp i Local temporary scalar c ladd1 l Local switch to add only the most significant outlier c at a time as opposed to adding all that pass the critical c value c lestim l Input switch to estimate the ARIMA parts of the model c lprint l Input logical whether to print out the iteration and c convergence information c LS i Local PARAMETER for the index for LS type outliers c ltstls l Input switch to test for level shifts. Test AO's only c when set to false c markmx c Local length 2 character by one that stars the type of c outlier with the largest absolute t-value at a given c time point. c mini i Local index to the outlier with the smallest absolute c t-value c mint d Local smallest t-value of the identified outliers c mxiter i Input for number of nonlinear sub-iterations for each c overall IGLS iteration. c mxtype i Local type of outlier that had the largest absolute c t statistic c nefobs i Input number of effective observations c npstar i Local order of the differencing and AR polynomials c ntype i Local number of types of outliers being tested (1=just AO, c 2=AO and LS) c oldotl i Local number of outliers found on the last pass c otlrb d Local pb long vector to input initial values to the c b vector. Note, these values maybe notset values. c critvl d Input critical limit (t value > critvl) which an outlier is c identified. c otlgrp i Local index to the automatically indentified outliers c regression group c otlvar d Local pa*2 nspobs*2 vector to store the ith AO and LS c outlier variables c otltyp i Output outlier type, either AO, LS, or RO, for additive, c level shift, or ramp outlier respectively. c pxa i Local PARAMETER for the number of elements in the temporary c x matrix otlrx c rbmse d Local robust root mean square error, c 1.49*median(absolute(e)). c rmse d Local root mean square error c singlr l Local 2 long array which is true if [X:o]'[X:o] is singular c t0 i Local index or time point of the outlier being tested c tmpttl c Local pcolcr character string to hold a outlier c identification string temporarily c tstpt i Local pobs, nspobs used, by 3 array of integers the first c column indicates the AO tests, the second the LS tests, c and the third column the TC tests. c tvalt0 d Local length 2 array of the t-values of the AO and LS c outlier at t0. c txa d Local pxa, nspobs*ncotlr used, long vector, a copy of [X:y] c with the automatic outliers included. c----------------------------------------------------------------------- c Variable typing and initialization c----------------------------------------------------------------------- CHARACTER AOTLTL*33 DOUBLE PRECISION ZERO,LOWCV LOGICAL F,T PARAMETER(AOTLTL='Automatically Identified Outliers',ZERO=0D0, & F=.false.,T=.true.,LOWCV=2.8D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'cchars.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'fxreg.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'xrgtbl.i' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER PA,PXA,PXY,POA LOGICAL LWRITE,LCLOSE PARAMETER(PA=PLEN+2*PORDER,PXA=PA*(PB+1),PXY=PLEN*(PB+1), & POA=PA*POTLR,LWRITE=F,LCLOSE=T) c----------------------------------------------------------------------- CHARACTER markmx*1,tmpttl*(PCOLCR),outstr*(16),cdash*(69), & hdrstr*(15),savstr*(100),calmst*(105) LOGICAL lalmst,Lestim,locok,lprthd,Ltstao,Ltstls,Ltsttc,L1020, & singlr,delno,otlrno,Lxreg,Prx11r,lautmp,Lauto,Outfct, & Fctok,Prttst,Priter,Sviter,Prftt,Svftt,lnootl,Lgraf,Ldiag INTEGER begcol,Begtst,endcol,Endtst,i,icol,ibgtst,iedtst,info,n0, & ipass,itmp,mini,Mxiter,Mxnlit,mxtype,na,Nefobs,newotl, & nmxocr,ntmpcr,ntst,ntype,oldnc,oldotl,otlgrp,nstr,otltyp, & t0,iptr,iptr2,minptr,itype,Nbeg,Nobspf,fh,fh2,tstpt,Nfcst, & ldash,idash,oldrfx,delnum,i2,rdbdat,ipos,idate,nalmst, & mxcode,addnum,ibgls,ibgir,nlstst,ntctst,nirtst,ipassa DOUBLE PRECISION A,almost,critt,mint,otlb,Critvl,Cvrduc,otlvar, & rbmse,rmse,ttst,tvalt0,txa,oldcvl,Trnsrs,mape, & mxabso,valmst DIMENSION A(*),Begtst(2),Endtst(2),markmx(POTLR),otlvar(POA), & singlr(POTLR),ttst(PLEN,POTLR),tstpt(POTLR,PLEN), & tvalt0(POTLR),txa(PXA),mxtype(POTLR),Critvl(POTLR), & critt(POTLR),oldcvl(POTLR),mini(POTLR),mint(POTLR), & minptr(POTLR),Trnsrs(*),mape(4),outstr(POTLR),idate(2), & hdrstr(POTLR),ldash(POTLR),almost(POTLR),calmst(PB), & valmst(POTLR),mxcode(POTLR) c----------------------------------------------------------------------- LOGICAL dpeq INTEGER strinx EXTERNAL dpeq,strinx c----------------------------------------------------------------------- c Variables added for add 1 at a time c----------------------------------------------------------------------- CHARACTER mxotl*(PCOLCR) LOGICAL Ladd1 INTEGER mxottp,mxott0 DOUBLE PRECISION mxotlb,mxotlt DOUBLE PRECISION amint c----------------------------------------------------------------------- CHARACTER OTTDIC*57 INTEGER ottind,ottptr,POTT PARAMETER(POTT=7) DIMENSION ottptr(0:POTT) PARAMETER(OTTDIC= & 'AO onlyLS onlyAO and LSTC onlyAO and TCLS and TCAll types') DATA ottptr/1,8,15,24,31,40,49,58/ c----------------------------------------------------------------------- DATA ldash/37,53,69/ DATA mxcode/PRGTAA,PRGTAL,PRGTAT/ c----------------------------------------------------------------------- lautmp=Lauto oldrfx=Iregfx L1020 = F addnum=0 delnum=0 nalmst=0 c----------------------------------------------------------------------- n0=0 IF(Ltstao)n0=n0+1 IF(Ltstls)n0=n0+1 IF(Ltsttc)n0=n0+1 CALL setchr('-',69,cdash) DO i=1,POTLR CALL setchr(' ',15,hdrstr(i)) END DO IF(Ltstao)hdrstr(AO)(11:15)='t(AO)' IF(Ltstls)hdrstr(LS)(11:15)='t(LS)' IF(Ltsttc)hdrstr(TC)(11:15)='t(TC)' c----------------------------------------------------------------------- c Set the outlier counter. Set the outlier test c vector to true for the points to test and false otherwise. Do not c test user defined outliers. c Note that the test span is base on the full series so we have to c adjust it if only a span of the series is used. c----------------------------------------------------------------------- otlgrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,AOTLTL) IF(otlgrp.gt.0)THEN CALL eltlen(otlgrp,Grp,Ngrp,oldotl) IF(Lfatal)RETURN ELSE oldotl=0 END IF CALL setdp(DNOTST,POTLR,almost) IF(Ltstao)almost(AO)=Critvl(AO)-Cvrduc IF(Ltstls)almost(LS)=Critvl(LS)-Cvrduc IF(Ltsttc)almost(TC)=Critvl(TC)-Cvrduc c----------------------------------------------------------------------- CALL setint(0,POTLR*Nspobs,tstpt) CALL dfdate(Begtst,Begspn,Sp,itmp) ibgtst=itmp+1 ibgtst=max(ibgtst,1) CALL dfdate(Endtst,Begspn,Sp,itmp) iedtst=itmp+1 iedtst=min(iedtst,Nspobs) ntst=iedtst-ibgtst+1 c----------------------------------------------------------------------- c Initialize the indicator variable for the set of 'almost' outliers c----------------------------------------------------------------------- lalmst=F c----------------------------------------------------------------------- 5 DO t0=ibgtst,iedtst IF(Ltstao)tstpt(AO,t0)=1 IF(Ltstls)tstpt(LS,t0)=1 IF(Ltsttc)tstpt(TC,t0)=1 END DO c----------------------------------------------------------------------- c An LS at the beginning of the span is a column of 0s; An LS at c the second point is equivalent to an AO at the first time point c and an LS at the last time point is equivalent to an AO at the last c time point so if testing for both AOs and LSs just test for the AOs. c Also note that LS[t]+LS[t+1] is equilvalent to LS[t]+AO[t+1]. c They are also equivalent to AO[t]+LS[t+1] but these are not orthogonal c to each other. Actually, with ARIMA correlations none are orthogonal. c----------------------------------------------------------------------- IF(Ltstls)THEN tstpt(LS,1)=0 c----------------------------------------------------------------------- IF(Ltstao)THEN tstpt(LS,2)=0 tstpt(LS,Nspobs)=0 END IF END IF c----------------------------------------------------------------------- c a TC at the last time point is equivalent to an AO at the last c time point so if testing for both AOs and TCs just test for the AOs. c (BCM July 1997) c----------------------------------------------------------------------- IF(Ltsttc.and.Ltstao)tstpt(TC,Nspobs)=0 c----------------------------------------------------------------------- c Search and omit each of the user-defined outliers from the c testing. c----------------------------------------------------------------------- DO icol=1,Ncxy-1 IF(Rgvrtp(icol).eq.PRGTAO.or.Rgvrtp(icol).eq.PRGTLS.or. & Rgvrtp(icol).eq.PRGTTC.or.Rgvrtp(icol).eq.PRGTSO.or. & Rgvrtp(icol).eq.PRSQAO.or.Rgvrtp(icol).eq.PRSQLS.or. & Rgvrtp(icol).eq.PRGTMV)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,tmpttl,ntmpcr) IF(.not.Lfatal)THEN CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0,itmp,locok) IF(.not.locok)CALL abend() END IF IF(Lfatal)RETURN IF(otltyp.eq.AO.or.Rgvrtp(icol).eq.PRSQAO.or.otltyp.eq.MV) & tstpt(AO,t0)=0 IF(otltyp.eq.LS.or.Rgvrtp(icol).eq.PRSQLS.or.otltyp.eq.MV) & tstpt(LS,t0)=0 IF(otltyp.eq.TC.or.otltyp.eq.MV)tstpt(TC,t0)=0 c----------------------------------------------------------------------- c Also, if X-11 irregular regression, check how many automatic c outliers are in regression model and omit . c----------------------------------------------------------------------- ELSE IF(Lxreg.and.Rgvrtp(icol).eq.PRGTAA)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,tmpttl,ntmpcr) IF(.not.Lfatal)THEN CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0,itmp,locok) IF(.not.locok)CALL abend() END IF IF(Lfatal)RETURN tstpt(AO,t0)=0 c oldotl=oldotl+1 c----------------------------------------------------------------------- c Also, if (automatic model idenfication changed on 8/19/19) not c X-11 irregular regrssion is used, check how many c automatic outliers are in regression model and omit . c----------------------------------------------------------------------- ELSE IF(.not.Lxreg.and.(Rgvrtp(icol).eq.PRGTAA.or. & Rgvrtp(icol).eq.PRGTAL.or.Rgvrtp(icol).eq.PRGTAT).or. & Rgvrtp(icol).eq.PRGTSO)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,tmpttl,ntmpcr) IF(.not.Lfatal)THEN CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0,itmp,locok) IF(.not.locok)CALL abend() END IF IF(Lfatal)RETURN tstpt(otltyp,t0)=0 END IF END DO c----------------------------------------------------------------------- c If outliers have been fixed, search and omit each of the fixed c outliers from the testing. c----------------------------------------------------------------------- IF(Iregfx.ge.2)THEN DO icol=1,Nfxttl IF(Fxtype(icol).eq.PRGTAO.or.Fxtype(icol).eq.PRGTLS.or. & Fxtype(icol).eq.PRGTTC.or.Fxtype(icol).eq.PRGTMV.or. & Fxtype(icol).eq.PRGTAA.or.Fxtype(icol).eq.PRGTAL.or. & Fxtype(icol).eq.PRGTAT.or.Fxtype(icol).eq.PRGTQI.or. & Fxtype(icol).eq.PRSQAO.or.Fxtype(icol).eq.PRSQLS.or. & Fxtype(icol).eq.PRGTQD)THEN CALL getstr(Cfxttl,Cfxptr,Nfxttl,icol,tmpttl,ntmpcr) IF(.not.Lfatal)THEN CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0,itmp,locok) IF(.not.locok)CALL abend() END IF IF(Lfatal)RETURN IF(otltyp.eq.AO.or.otltyp.eq.MV)tstpt(AO,t0)=0 IF(otltyp.eq.LS.or.otltyp.eq.MV)tstpt(LS,t0)=0 IF(otltyp.eq.TC.or.otltyp.eq.MV)tstpt(TC,t0)=0 END IF END DO END IF c----------------------------------------------------------------------- c FORWARD ADDITION LOOP. Make a copy of [X:y] and filter the copy, c then test, flag, and add outliers to the regression. c----------------------------------------------------------------------- ipass=0 c----------------------------------------------------------------------- 10 DO WHILE (T) ipass=ipass+1 ipassa=0 lprthd=T c----------------------------------------------------------------------- IF((Prttst.or.Prftt).and.(.not.lalmst))THEN IF(Ltstao)CALL setdp(ZERO,ntst,ttst(ibgtst,AO)) IF(Ltstls)CALL setdp(ZERO,ntst,ttst(ibgtst,LS)) IF(Ltsttc)CALL setdp(ZERO,ntst,ttst(ibgtst,TC)) END IF c----------------------------------------------------------------------- CALL copy(Xy,Nspobs*Ncxy,1,txa) IF(Lxreg)THEN info=0 na=Nspobs ELSE CALL armafl(Nspobs,Ncxy,F,F,txa,na,PXA,info) END IF c----------------------------------------------------------------------- IF(info.gt.0)THEN IF(.not.Lhiddn)WRITE(STDERR,1010) CALL errhdr WRITE(Mt2,1010) 1010 FORMAT(/,' ERROR: ARMA parameter roots maybe inside of the ', & 'unit circle.', & /,' Use conditional estimates as starting ', & 'values.') CALL abend IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Calculate the robust root mean square error and the cutoff to c define outliers c----------------------------------------------------------------------- c CALL medabs(A(Nextvl+1),Nefobs,rbmse) IF((Lar.or.Lma).and.(.not.Lxreg))THEN CALL medabs(A(Mxmalg+1),Nefobs,rbmse) ELSE CALL medabs(A(1),Nefobs,rbmse) END IF IF(Lfatal)RETURN rbmse=rbmse/.6745D0 CALL yprmy(A,na,rmse) rmse=sqrt(rmse/Nefobs) IF(dpeq(rbmse,ZERO))THEN IF(.not.Lhiddn)THEN WRITE(STDERR,1011) IF(.not.Lnoprt)WRITE(Mt1,1011) IF(Lxreg)THEN WRITE(STDERR,1012) IF(.not.Lnoprt)WRITE(Mt1,1012) ELSE WRITE(STDERR,1013) IF(.not.Lnoprt)WRITE(Mt1,1013) END IF END IF CALL errhdr WRITE(Mt2,1011) 1011 FORMAT(/,' ERROR: Cannot perform automatic outlier ', & 'identification if the robust ', & /,' mean square error of the residuals is zero.') IF(Lxreg)THEN WRITE(Mt2,1012) 1012 FORMAT(/,' Check the x11regression options specified', & ' in the input specification',/,' file.',/) ELSE WRITE(Mt2,1013) 1013 FORMAT(/,' Check the regARIMA model specified in the', & ' input specification',/,' file.',/) END IF CALL abend RETURN END IF c----------------------------------------------------------------------- critt(AO)=Critvl(AO)*rbmse critt(LS)=Critvl(LS)*rbmse critt(TC)=Critvl(TC)*rbmse mxotlt=ZERO oldnc=Ncxy c----------------------------------------------------------------------- c Find AO's, LS's and TC's over the threshold. c----------------------------------------------------------------------- DO t0=ibgtst,iedtst IF((tstpt(AO,t0).eq.1).or.(tstpt(LS,t0).eq.1).or. & (tstpt(TC,t0).eq.1))THEN CALL makotl(t0,Nspobs,tstpt(AO,t0),otlvar,ntype,Tcalfa,Sp) c----------------------------------------------------------------------- IF(Lxreg)THEN info=0 na=Nspobs ELSE CALL armafl(Nspobs,ntype,F,F,otlvar,na,POA,info) END IF IF(info.gt.0)THEN IF(.not.Lhiddn)WRITE(STDERR,1010) CALL errhdr WRITE(Mt2,1010) CALL abend IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- CALL setint(NOTSET,POTLR,mxtype) CALL ttest(txa,na,oldnc,Chlxpx,otlvar,tstpt(AO,t0),mxtype, & tvalt0,singlr) c----------------------------------------------------------------------- DO i=1,POTLR IF(singlr(i).and.(tstpt(i,t0).eq.1))THEN CALL wrtotl(i,t0,itmp,Begspn,Sp,tmpttl,ntmpcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print out the table heading before reporting the error c----------------------------------------------------------------------- IF(lprthd)THEN IF(lalmst)THEN IF(.NOT.(Lhiddn.or.Lnoprt).and.Prttab(LOTLHD))THEN IF (.NOT.L1020) THEN WRITE(Mt1,1020) L1020 = T END IF 1020 FORMAT(//,' The following time series values might ', & 'later be identified as outliers',/' when data ', & 'are added or revised. They were not identified ', & 'as outliers',/,' in this run either because ', & 'their test t-statistics were slightly below',/, & ' the critical value or because they were ', & 'eliminated during the backward',/,' deletion ', & 'step of the identification procedure, when a non', & '-robust ',/,' t-statistic is used.') WRITE(Mt1,1041)cdash(1:ldash(n0)) WRITE(Mt1,1043)(hdrstr(idash),idash=1,n0) WRITE(Mt1,1041)cdash(1:ldash(n0)) END IF ELSE IF(Priter.or.Prttst)THEN WRITE(Mt1,1030)ipass,rbmse,rmse 1030 FORMAT(//,' Forward addition pass',i3,/,' ',26('-'),/, & ' Robust root mse ',1p,e10.2,/, & ' Normal root mse ',e10.2) c----------------------------------------------------------------------- IF(Priter)THEN WRITE(Mt1,1041)cdash(1:ldash(n0)) WRITE(Mt1,1043)(hdrstr(idash),idash=1,n0) WRITE(Mt1,1041)cdash(1:ldash(n0)) 1041 FORMAT(' ',a) 1043 FORMAT(' Outlier ',a:,' ',a:,' ',a:,' ',a) END IF END IF lprthd=F END IF c----------------------------------------------------------------------- c Report any singularity problems testing an outlier at the time c point. Mark the point so it won't be tested again c----------------------------------------------------------------------- IF (Priter.and.(.not.lalmst)) THEN IF((.not.Lhiddn).and.(.not.Lnoprt)) & WRITE(Mt1,1050)tmpttl(1:ntmpcr) CALL errhdr WRITE(Mt2,1050)tmpttl(1:ntmpcr) 1050 FORMAT(/,' NOTE: Unable to test ',a, & ' due to regression matrix singularity.',/, & ' The effect of this outlier is already ', & 'accounted for by other regressors ',/, & ' (usually user-specified or ', & 'previously identified outliers).') END IF c----------------------------------------------------------------------- c changed by BCM Dec 1995 c outlier printed out in tmpttl corresponds to i, not mxtype c----------------------------------------------------------------------- tstpt(i,t0)=0 ttst(t0,i)=ZERO END IF END DO c----------------------------------------------------------------------- c Calculate the t-statistics to print out c----------------------------------------------------------------------- c IF(Prttst)THEN IF(tstpt(AO,t0).eq.1)ttst(t0,AO)=tvalt0(AO)/rbmse IF(tstpt(LS,t0).eq.1.and.Ltstls)ttst(t0,LS)=tvalt0(LS)/rbmse IF(tstpt(TC,t0).eq.1.and.Ltsttc)ttst(t0,TC)=tvalt0(TC)/rbmse c END IF c----------------------------------------------------------------------- c If the tested outlier is greater than the critical value c Save its coefficient value to put in the regression. c----------------------------------------------------------------------- otlrno=T itype=1 DO WHILE (otlrno.and.itype.le.POTLR) IF(mxtype(itype).ne.NOTSET)THEN IF(abs(tvalt0(mxtype(itype))).gt.critt(mxtype(itype)).and. & (tstpt(mxtype(itype),t0).eq.1))THEN CALL wrtotl(mxtype(itype),t0,itmp,Begspn,Sp,tmpttl,ntmpcr) IF(Lfatal)RETURN otlb=tvalt0(mxtype(itype)) otlb=sign(otlb**2,otlb) c----------------------------------------------------------------------- c For ADDALL, add each outlier over the critical value. c----------------------------------------------------------------------- IF(.not.(Ladd1))THEN otltyp=mxcode(mxtype(itype)) c----------------------------------------------------------------------- IF(.not.lalmst)THEN CALL adrgef(otlb,tmpttl(1:ntmpcr),AOTLTL,otltyp,F,F) IF(Lfatal)RETURN IF(Iregfx.eq.3)Iregfx=2 addnum=addnum+1 END IF c----------------------------------------------------------------------- c For ADDONE, keep track of the maximum values. c----------------------------------------------------------------------- ELSE IF(abs(tvalt0(mxtype(itype))).gt.abs(mxotlt))THEN mxotl=tmpttl nmxocr=ntmpcr mxotlb=otlb mxotlt=tvalt0(mxtype(itype)) mxott0=t0 mxottp=mxtype(itype) END IF c----------------------------------------------------------------------- c For both methods, calculate the t-statistics and mark the c outlier with the greatest statistic. c----------------------------------------------------------------------- IF(tstpt(AO,t0).eq.1)tvalt0(AO)=tvalt0(AO)/rbmse IF(tstpt(LS,t0).eq.1)tvalt0(LS)=tvalt0(LS)/rbmse IF(tstpt(TC,t0).eq.1)tvalt0(TC)=tvalt0(TC)/rbmse c----------------------------------------------------------------------- markmx(AO)=' ' markmx(LS)=' ' markmx(TC)=' ' IF(.not.lalmst)markmx(mxtype(itype))='*' c----------------------------------------------------------------------- c Print out the statistics. The print outs are different depending c on what type to outliers are being tested for. Print out the header c first if it hasn't been already c----------------------------------------------------------------------- IF(Priter.or.lalmst)THEN IF((tstpt(AO,t0).eq.1).or.(tstpt(LS,t0).eq.1).or. & (tstpt(TC,t0).eq.1))THEN c----------------------------------------------------------------------- IF(lprthd)THEN IF(lalmst)THEN IF(.NOT.(Lhiddn.or.Lnoprt).and.Prttab(LOTLHD))THEN IF (.NOT.L1020) THEN WRITE(Mt1,1020) L1020 = T END IF WRITE(Mt1,1041)cdash(1:ldash(n0)) WRITE(Mt1,1043)(hdrstr(idash),idash=1,n0) WRITE(Mt1,1041)cdash(1:ldash(n0)) END IF ELSE WRITE(Mt1,1030)ipass,rbmse,rmse WRITE(Mt1,1041)cdash(1:ldash(n0)) WRITE(Mt1,1043)(hdrstr(idash),idash=1,n0) WRITE(Mt1,1041)cdash(1:ldash(n0)) END IF lprthd=F END IF END IF c----------------------------------------------------------------------- c Initialize outstr to blanks, then create t-test entry for table c----------------------------------------------------------------------- DO i=1,POTLR CALL setchr(' ',15,outstr(i)) END DO IF(tstpt(AO,t0).eq.1) & WRITE(outstr(AO),1060)tvalt0(AO),markmx(AO) IF(tstpt(LS,t0).eq.1) & WRITE(outstr(LS),1060)tvalt0(LS),markmx(LS) IF(tstpt(TC,t0).eq.1) & WRITE(outstr(TC),1060)tvalt0(TC),markmx(TC) 1060 FORMAT(f14.2,a1) c----------------------------------------------------------------------- c Print out t-test statistics c----------------------------------------------------------------------- IF(.not.Lhiddn)THEN IF(lalmst)THEN IF(.not.Lnoprt.and.Prttab(LOTLHD)) & WRITE(Mt1,1070)tmpttl(1:ntmpcr),(outstr(i),i=1,n0) ELSE WRITE(Mt1,1070)tmpttl(1:ntmpcr),(outstr(i),i=1,n0) END IF END IF 1070 FORMAT(' ',a,t24,4(' ',a15)) c----------------------------------------------------------------------- c Save t-test statistics for almost outliers into diagnostics file, c if requested. c----------------------------------------------------------------------- IF(Ldiag.and.lalmst)THEN nalmst=nalmst+1 CALL setdp(ZERO,POTLR,valmst) IF(tstpt(AO,t0).eq.1)valmst(AO)=tvalt0(AO) IF(tstpt(LS,t0).eq.1)valmst(LS)=tvalt0(LS) IF(tstpt(TC,t0).eq.1)valmst(TC)=tvalt0(TC) CALL setchr(' ',105,calmst(nalmst)) WRITE(calmst(nalmst),1071)tmpttl(1:ntmpcr), & (valmst(idash),idash=1,POTLR) 1071 FORMAT(a,':',4(1x,e22.15)) END IF END IF c----------------------------------------------------------------------- c For ADDALL, each significant outlier is added so it is not tested c for in later passes. Save the outlier information in the save file. c For ADDONE this is only done for the most significant outlier at the c end of each pass. c----------------------------------------------------------------------- IF(.not.Ladd1)THEN IF(.not.lalmst)THEN tstpt(mxtype(itype),t0)=0 ipassa = ipassa + 1 IF(Sviter)THEN CALL svolit(LWRITE,ipass,ipassa,'+',tmpttl,ntmpcr, & tvalt0(mxtype(itype)),rbmse,rmse,Sviter,Lxreg) IF(Lfatal)RETURN END IF IF(Ldiag)THEN CALL svolit(LWRITE,ipass,ipassa,'+',tmpttl,ntmpcr, & tvalt0(mxtype(itype)),rbmse,rmse,F,Lxreg) IF(Lfatal)RETURN END IF END IF END IF otlrno=F END IF END IF itype=itype+1 END DO END IF c----------------------------------------------------------------------- c If almost outliers are being printed out, check to see if this c outlier was dropped in the backwards deletion phase. c----------------------------------------------------------------------- IF(lalmst.and.delnum.gt.0.and.(.NOT.Lhiddn))THEN IF(lprthd)THEN IF(.not.Lnoprt.and.Prttab(LOTLHD))THEN IF (.NOT.L1020) THEN WRITE(Mt1,1020) L1020 = T END IF WRITE(Mt1,1041)cdash(1:ldash(n0)) WRITE(Mt1,1043)(hdrstr(idash),idash=1,n0) WRITE(Mt1,1041)cdash(1:ldash(n0)) END IF lprthd=F END IF delno=(tstpt(AO,t0).ge.0).and.(tstpt(LS,t0).ge.0).and. & (tstpt(TC,t0).ge.0) IF(.not.delno)THEN c----------------------------------------------------------------------- c Initialize outstr to blanks, then create t-test entry for table c----------------------------------------------------------------------- DO i=1,POTLR IF(tstpt(i,t0).eq.-1)THEN CALL wrtotl(i,t0,itmp,Begspn,Sp,tmpttl,ntmpcr) DO i2=1,POTLR CALL setchr(' ',15,outstr(i2)) END DO IF(tstpt(AO,t0).ne.0) & WRITE(outstr(1),1060)ttst(t0,AO),' ' IF(tstpt(LS,t0).ne.0) & WRITE(outstr(2),1060)ttst(t0,LS),' ' IF(tstpt(TC,t0).ne.0) & WRITE(outstr(3),1060)ttst(t0,TC),' ' c----------------------------------------------------------------------- c Print out t-test statistics c----------------------------------------------------------------------- IF(.not.Lnoprt.and.Prttab(LOTLHD)) & WRITE(Mt1,1070)tmpttl(1:ntmpcr),(outstr(idash),idash=1,n0) c----------------------------------------------------------------------- c Save t-test statistics for almost outliers into diagnostics file, c if requested. c----------------------------------------------------------------------- IF(Ldiag.and.lalmst)THEN nalmst=nalmst+1 CALL setdp(ZERO,POTLR,valmst) IF(tstpt(AO,t0).ne.0)valmst(AO)=ttst(t0,AO) IF(tstpt(LS,t0).ne.0)valmst(LS)=ttst(t0,LS) IF(tstpt(TC,t0).ne.0)valmst(TC)=ttst(t0,TC) WRITE(calmst(nalmst),1071)tmpttl(1:ntmpcr), & (valmst(idash),idash=1,POTLR) END IF END IF END DO END IF END IF END DO c----------------------------------------------------------------------- c After we have printed out the 'almost' outliers, get out of loop c----------------------------------------------------------------------- IF(lalmst)THEN IF(((.not.Lhiddn).and.(.not.Lnoprt)).and.(.not.lprthd).and. & Prttab(LOTLHD)) & WRITE(Mt1,1080)cdash(1:ldash(n0)) 1080 FORMAT(' ',a,//) GO TO 50 END IF c----------------------------------------------------------------------- c The forward addition pass is over so for ADDONE, add only the most c significant outlier to the regression matrix and print out which has c been added. We know the header has been printed out because at least c one significant outlier was found on the pass. c----------------------------------------------------------------------- IF(Ladd1.and.abs(mxotlt).gt.ZERO)THEN otltyp=mxcode(mxottp) c----------------------------------------------------------------------- CALL adrgef(mxotlb,mxotl(1:nmxocr),AOTLTL,otltyp,F,F) addnum=addnum+1 IF(Iregfx.eq.3)Iregfx=2 IF(Lfatal)RETURN c----------------------------------------------------------------------- c For ADDONE, print out the information for the most significant c outlier. and save the outlier iteration information in the save file. c----------------------------------------------------------------------- IF(Priter)THEN DO i=1,POTLR outstr(i)=' ' IF(mxottp.eq.i)WRITE(outstr(i),1060)mxotlt/rbmse,' ' END DO WRITE(Mt1,1090)mxotl,(outstr(i),i=1,POTLR) 1090 FORMAT(/,' Add',/,' +',a22,a15,3(' ',a15)) END IF c----------------------------------------------------------------------- IF(Sviter)THEN CALL svolit(LWRITE,ipass,ipassa,'+',mxotl,nmxocr,mxotlt/rbmse, & rbmse,rmse,Sviter,Lxreg) IF(Lfatal)RETURN END IF IF(Ldiag)THEN CALL svolit(LWRITE,ipass,ipassa,'+',mxotl,nmxocr,mxotlt/rbmse, & rbmse,rmse,F,Lxreg) IF(Lfatal)RETURN END IF tstpt(mxottp,mxott0)=0 END IF c----------------------------------------------------------------------- c For both methods, print out the AO and LS test statistics if c requested. c----------------------------------------------------------------------- IF(lprthd.and.(Priter.or.Prttst))THEN WRITE(Mt1,1030)ipass,rbmse,rmse WRITE(Mt1,1041)cdash(1:ldash(n0)) WRITE(Mt1,1043)(hdrstr(idash),idash=1,n0) WRITE(Mt1,1041)cdash(1:ldash(n0)) lprthd=F END IF c----------------------------------------------------------------------- IF(Prttst)THEN IF(Ltstao)THEN CALL prttbl(Begtst,Sp,ttst(ibgtst,AO),ntst, & 'AO Outlier t-values',1) CALL mkotky(ibgtst,iedtst,AO,ttst) IF(Lfatal)RETURN END IF IF(Ltstls)THEN IF(Ltstao.and.ibgtst.le.2)THEN CALL addate(Begtst,Sp,3-ibgtst,idate) ibgls=3 nlstst=ntst-(3-ibgtst) ELSE IF(ibgtst.eq.1)THEN CALL addate(Begtst,Sp,1,idate) ibgls=2 nlstst=ntst-1 ELSE CALL cpyint(Begtst,2,1,idate) ibgls=ibgtst nlstst=ntst END IF IF(Ltstao.and.iedtst.eq.Nspobs)nlstst=nlstst-1 CALL prttbl(idate,Sp,ttst(ibgls,LS),nlstst, & 'LS Outlier t-values',1) CALL mkotky(ibgls,ibgls+nlstst-1,LS,ttst) IF(Lfatal)RETURN END IF IF(Ltsttc)THEN IF(Ltstao.and.iedtst.eq.Nspobs)THEN ntctst=ntst-1 ELSE ntctst=ntst END IF CALL prttbl(Begtst,Sp,ttst(ibgtst,TC),ntctst, & 'TC Outlier t-values',1) CALL mkotky(ibgtst,ibgtst+ntctst-1,TC,ttst) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Add the outliers to the regression matrix and re-estimate the c model c----------------------------------------------------------------------- otlgrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,AOTLTL) IF(otlgrp.gt.0)THEN CALL eltlen(otlgrp,Grp,Ngrp,Natotl) IF(Lfatal)RETURN ELSE Natotl=0 END IF c----------------------------------------------------------------------- c If there are no automatically identified outliers at the end of c a pass than the backward deletion step can be skiped. If no new c outliers have been identified jump to the backward deletion. c----------------------------------------------------------------------- IF(Natotl.le.0)THEN c----------------------------------------------------------------------- c If critical values for outlier testing less than Critvl-Cvrduc, c X-11 regression or automatic model identification being performed, c break out of loop c----------------------------------------------------------------------- * IF(Lauto.or.Lhiddn.or.Lxreg.or. * & (Lnoprt.and.(.not.(Prttst.or.Priter))))GO TO 50 IF(Lauto.or.Lhiddn.or.Lxreg)GO TO 50 c----------------------------------------------------------------------- c Reset critical value to test if any t-tests of unchosen outliers c are above 3/25 c----------------------------------------------------------------------- C write(*,*)' lalmst=T, line 807' lalmst=T nalmst=0 CALL copy(Critvl,POTLR,1,oldcvl) Critvl(AO)=almost(AO) Critvl(LS)=almost(LS) Critvl(TC)=almost(TC) GO TO 10 END IF newotl=Natotl-oldotl c----------------------------------------------------------------------- IF(newotl.le.0)THEN IF(Priter)WRITE(Mt1,1110) 1110 FORMAT(' No more outliers identified') GO TO 20 c----------------------------------------------------------------------- c If there are automatically identified outliers make space in Xy, c add the outlier effect to the matrix (no need to run all of regvar), c then do a full regARIMA re-estimatimation. Note that while only space c is added for the outlier identified on the most recent pass, all the c outliers variables are reconstucted. Since AI outliers are arranged c in order of time, the same variable may be in another column if an c outlier at an earlier time point has been added. Newotl is the number c of new outliers and Natotl is the number of AI outliers. c----------------------------------------------------------------------- ELSE begcol=Grp(otlgrp-1) endcol=begcol+newotl-1 CALL coladd(begcol,endcol,Nspobs,PXY,Xy,oldnc) IF(Lfatal)RETURN c----------------------------------------------------------------------- endcol=Grp(otlgrp)-1 CALL addotl(Begspn,Nspobs,0,begcol,endcol) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(Lxreg)THEN CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(A,Nbeg) IF(.not.Lfatal.and.Priter) & CALL prtxrg(Lestim,Prx11r,F,F,F,0,0,F) ELSE CALL rgarma(Lestim,Mxiter,Mxnlit,F,A,na,Nefobs,lautmp) IF(((.not.lautmp).or.(.not.Convrg)).and.(.not.Lfatal).and. & Lauto)THEN c----------------------------------------------------------------------- c print out more details if estimation error occurs in outlier c identification phase of the procedure c BCM February 2007 c----------------------------------------------------------------------- IF(.not.Lfatal.and.(Armaer.eq.POBFN0.or.Armaer.eq.PSNGER.or. & (.not.Convrg)))CALL prterr(Nefobs,Lauto) Lauto=F RETURN END IF IF(Lfatal)RETURN IF(.not.Convrg)THEN WRITE(STDERR,1200) IF(Lnoprt)WRITE(Mt1,1200) CALL errhdr WRITE(Mt2,1200) 1200 FORMAT(/,' ERROR: regARIMA model estimation in outlier ', & 'identification procedure did',/, & ' not converge.') RETURN END IF IF(Priter)THEN IF(Prttab(LESAFC).and.Var.gt.ZERO)THEN CALL amdfct(Trnsrs,mape,Nobspf,Nfcst,F,Fctok,Lauto) IF(Lfatal)RETURN IF(Fctok)CALL prafce(Mt1,mape,Outfct,T) END IF itmp=0 CALL prtmdl(Lestim,T,T,F,F,F,F,F,F,itmp,T,F,F) ELSE CALL prterr(Nefobs,Lauto) END IF END IF c----------------------------------------------------------------------- IF(.not.Lfatal)CALL eltlen(otlgrp,Grp,Ngrp,oldotl) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(Priter)THEN IF(lprthd)THEN WRITE(Mt1,1030)ipass,rbmse,rmse WRITE(Mt1,1041)cdash(1:ldash(n0)) WRITE(Mt1,1043)(hdrstr(idash),idash=1,n0) WRITE(Mt1,1041)cdash(1:ldash(n0)) lprthd=F END IF END IF END IF END DO c----------------------------------------------------------------------- c BACKWARD DELETION LOOP. No more outliers have been found on the c last pass through the data so do backward elimination stepwise c regression to make sure all the outliers still are over the threshold. c----------------------------------------------------------------------- 20 ipass=0 c----------------------------------------------------------------------- DO WHILE (T) ipass=ipass+1 IF(.not.Ladd1) ipassa=0 begcol=Grp(otlgrp-1) endcol=Grp(otlgrp)-1 CALL deltst(Nefobs,begcol,endcol,mint,mini,minptr,Lauto,Lxreg) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If the outlier with the smallest t-statistic is under the c critical value then report it, save the iteration information, c delete it from the regression, and re-estimate. c----------------------------------------------------------------------- iptr=1 delno=T DO WHILE(iptr.le.POTLR.and.delno) IF(minptr(iptr).ne.NOTSET)THEN iptr2=minptr(iptr) amint=abs(mint(iptr2)) IF(amint.lt.Critvl(iptr2))THEN CALL getstr(Colttl,Colptr,Ncoltl,mini(iptr2),tmpttl,ntmpcr) IF(Lfatal)RETURN IF(Priter)THEN WRITE(Mt1,1120)ipass 1120 FORMAT(//,' Backward deletion pass',i3,/,' ',66('-'),/,t30, & 'Parameter',t47,'Standard',/,' Variable',t31,'Estimate', & t50,'Error',t61,'t-value',/,' ',66('-')) WRITE(Mt1,1130)tmpttl(1:ntmpcr),B(mini(iptr2)), & B(mini(iptr2))/mint(iptr2),mint(iptr2) 1130 FORMAT(' -',a,t23,f16.4,f16.5,f13.2) END IF c----------------------------------------------------------------------- CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0,itmp,locok) ttst(t0,otltyp)=mint(iptr2) tstpt(otltyp,t0)=-1 delnum=delnum+1 c----------------------------------------------------------------------- c Save the iteration infomation c----------------------------------------------------------------------- IF(Sviter)THEN CALL svolit(LWRITE,ipass,ipassa,'-',tmpttl,ntmpcr,mint(iptr2), & ZERO,sqrt(Var*Nefobs/(Nefobs-Ncxy+1)),Sviter,Lxreg) IF(Lfatal)RETURN END IF IF(Ldiag)THEN CALL svolit(LWRITE,ipass,ipassa,'-',tmpttl,ntmpcr,mint(iptr2), & ZERO,sqrt(Var*Nefobs/(Nefobs-Ncxy+1)),F,Lxreg) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Delete the outlier from the regression and re-estimate c----------------------------------------------------------------------- CALL dlrgef(mini(iptr2),Nspobs,1) IF(Lxreg)THEN CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(A,Nbeg) IF(.not.Lfatal.and.Priter) & CALL prtxrg(Lestim,Prx11r,F,F,F,0,0,F) ELSE CALL rgarma(Lestim,Mxiter,Mxnlit,F,A,na,Nefobs,lautmp) IF(((.not.lautmp).or.(.not.Convrg)).and.(.not.Lfatal).and. & Lauto)THEN c----------------------------------------------------------------------- c print out more details if estimation error occurs in outlier c identification phase of the procedure c BCM February 2007 c----------------------------------------------------------------------- IF(.not.Lfatal.and.(Armaer.eq.POBFN0.or.Armaer.eq.PSNGER.or. & (.not.Convrg)))CALL prterr(Nefobs,Lauto) Lauto=F RETURN END IF IF(Lfatal)RETURN IF(Priter)THEN itmp=0 c IF(Prttab(LESAFC).and.Var.gt.ZERO)THEN c CALL amdfct(Trnsrs,mape,Nobspf,Nfcst,F,Fctok,Lauto) c IF(Lfatal)RETURN c IF(Fctok)CALL prafce(Mt1,mape,Outfct,T) c END IF CALL prtmdl(Lestim,T,T,F,F,F,F,F,F,itmp,T,F,F) ELSE CALL prterr(Nefobs,Lauto) END IF END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c If we deleted the last outlier we are done. c----------------------------------------------------------------------- otlgrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,AOTLTL) IF(otlgrp.gt.0)GO TO 30 delno=F END IF END IF iptr=iptr+1 END DO IF(delnum.gt.0)Natotl=Natotl-delnum c----------------------------------------------------------------------- c If critical values for outlier testing less than Critvl-Cvrduc, c X-11 regression or automatic model identification being performed, c break out of loop c----------------------------------------------------------------------- C IF((Critvl(AO).lt.almost(AO).and.Critvl(LS).lt.almost(LS).and. C & Critvl(TC).lt.almost(TC)).or.Lauto.or.Lhiddn.or.Lxreg.or. C & (Lnoprt.and.(.not.(Prttst.or.Priter))))GO TO 50 IF((Critvl(AO).lt.almost(AO).and.Critvl(LS).lt.almost(LS).and. & Critvl(TC).lt.almost(TC)).or.Lauto.or.Lhiddn.or.Lxreg) & GO TO 50 c----------------------------------------------------------------------- c Reset critical value to test if any t-tests of unchosen outliers c are above Critvl-Cvrduc. First, test if any revised critical c value is less than 2.8. If so, do not check for "almost" c outliers. c----------------------------------------------------------------------- IF((Ltstao.and.almost(AO).lt.LOWCV).OR. & (Ltstls.and.almost(LS).lt.LOWCV).OR. & (Ltsttc.and.almost(TC).lt.LOWCV))GO TO 50 C write(*,*)' lalmst=T, line 1018' lalmst=T nalmst=0 CALL copy(Critvl,POTLR,1,oldcvl) Critvl(AO)=almost(AO) Critvl(LS)=almost(LS) Critvl(TC)=almost(TC) GO TO 5 30 CONTINUE END DO c----------------------------------------------------------------------- c END OF THE IDENTIFICATION. Report if no outliers were found c----------------------------------------------------------------------- 50 IF(otlgrp.eq.0)THEN lnootl=(.not.Lhiddn).AND.(.not.Lauto) IF(Lxreg)THEN lnootl=lnootl.and.(Prx11r.or.Prttst.or.Prftt.or.Priter) ELSE lnootl=lnootl.and.((.not.Lnoprt).or.(Prttst.or.Prftt.or.Priter)) END IF IF(lnootl)THEN ottind=0 IF(Ltstao)ottind=ottind+1 IF(Ltstls)ottind=ottind+2 IF(Ltsttc)ottind=ottind+4 CALL getstr(OTTDIC,ottptr,POTT,ottind,outstr(1),nstr) IF(Lfatal)RETURN WRITE(Mt1,1140)outstr(1)(1:nstr) 1140 FORMAT(/,' No ',a,' outliers identified',/) mxotlt=ZERO mxabso=ZERO mxott0=NOTSET DO t0=ibgtst,iedtst DO i=1,POTLR IF(tstpt(i,t0).ne.0.and.mxabso.lt.ABS(ttst(t0,i)))THEN mxotlt=ttst(t0,i) mxabso=ABS(ttst(t0,i)) mxottp=i mxott0=t0 END IF END DO END DO IF(mxott0.ne.NOTSET)THEN CALL wrtotl(mxottp,mxott0,itmp,Begspn,Sp,tmpttl,ntmpcr) IF(Lfatal)RETURN WRITE(Mt1,1141)mxotlt,tmpttl(1:ntmpcr) 1141 FORMAT(' Largest outlier t-value : ',f10.5,' (',a,')') END IF END IF IF(oldrfx.eq.3.and.Iregfx.lt.3)Iregfx=oldrfx END IF c----------------------------------------------------------------------- c Print out and save final outlier t-tests c----------------------------------------------------------------------- IF(.not.Lxreg)THEN c----------------------------------------------------------------------- c Print out the final outlier t-statistics c----------------------------------------------------------------------- IF(Prftt)THEN IF(Ltstao)THEN CALL prttbl(Begtst,Sp,ttst(ibgtst,AO),ntst, & 'Final AO Outlier t-values',1) CALL mkotky(ibgtst,iedtst,AO,ttst) IF(Lfatal)RETURN END IF IF(Ltstls)THEN IF(Ltstao.and.ibgtst.le.2)THEN CALL addate(Begtst,Sp,3-ibgtst,idate) ibgls=3 nlstst=ntst-(3-ibgtst) ELSE IF(ibgtst.eq.1)THEN CALL addate(Begtst,Sp,1,idate) ibgls=2 nlstst=ntst-1 ELSE CALL cpyint(Begtst,2,1,idate) ibgls=ibgtst nlstst=ntst END IF IF(Ltstao.and.iedtst.eq.Nspobs)nlstst=nlstst-1 CALL prttbl(idate,Sp,ttst(ibgls,LS),nlstst, & 'Final LS Outlier t-values',1) CALL mkotky(ibgls,ibgls-nlstst+1,LS,ttst) IF(Lfatal)RETURN END IF IF(Ltsttc)THEN IF(Ltstao.and.iedtst.eq.Nspobs)THEN ntctst=ntst-1 ELSE ntctst=ntst END IF CALL prttbl(Begtst,Sp,ttst(ibgtst,TC),ntctst, & 'Final TC Outlier t-values',1) CALL mkotky(ibgtst,ibgtst+ntctst-1,TC,ttst) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Save the final outlier t-statistics c----------------------------------------------------------------------- IF(Svftt.or.Lgraf)THEN locok=T IF(Lxreg)THEN IF(Svftt)CALL opnfil(T,F,LXROFT,fh,locok) ELSE IF(Svftt)CALL opnfil(T,F,LOTLFT,fh,locok) IF(Lgraf.and.locok)CALL opnfil(T,Lgraf,LOTLFT,fh2,locok) END IF IF(.not.locok)THEN CALL abend() RETURN END IF c----------------------------------------------------------------------- CALL setchr(' ',15,hdrstr(1)) CALL setchr(' ',15,hdrstr(2)) CALL setchr(' ',15,hdrstr(3)) n0=0 IF(Ltstao)THEN n0=n0+1 hdrstr(n0)(1:5)='t(AO)' END IF IF(Ltstls)THEN n0=n0+1 hdrstr(n0)(1:5)='t(LS)' END IF IF(Ltsttc)THEN n0=n0+1 hdrstr(n0)(1:5)='t(TC)' END IF IF(Savtab(LOTLFT))THEN WRITE(fh,1100)'date',(TABCHR,hdrstr(icol)(1:5),icol=1,n0) WRITE(fh,1100)'----',(TABCHR,'-----------------------', & icol=1,n0) END IF IF(Lgraf)THEN WRITE(fh2,1100)'date',(TABCHR,hdrstr(icol)(1:5),icol=1,n0) WRITE(fh2,1100)'----',(TABCHR,'-----------------------', & icol=1,n0) END IF c----------------------------------------------------------------------- DO t0=ibgtst,iedtst c----------------------------------------------------------------------- c Set date for outlier t-test c----------------------------------------------------------------------- CALL setchr(' ',100,savstr) CALL addate(Begtst,Sp,t0-ibgtst,idate) rdbdat=100*idate(YR)+idate(MO) ipos=1 CALL itoc(rdbdat,savstr,ipos) IF(Lfatal)RETURN savstr(ipos:ipos)=TABCHR ipos=ipos+1 c----------------------------------------------------------------------- IF(Ltstao)THEN IF(tstpt(AO,t0).eq.0)THEN CALL dtoc(ZERO,savstr,ipos) ELSE CALL dtoc(ttst(t0,AO),savstr,ipos) END IF IF(Lfatal)RETURN savstr(ipos:ipos)=TABCHR ipos=ipos+1 END IF IF(Ltstls)THEN IF(tstpt(LS,t0).eq.0)THEN CALL dtoc(ZERO,savstr,ipos) ELSE CALL dtoc(ttst(t0,LS),savstr,ipos) END IF IF(Lfatal)RETURN savstr(ipos:ipos)=TABCHR ipos=ipos+1 END IF IF(Ltsttc)THEN IF(tstpt(TC,t0).eq.0)THEN CALL dtoc(ZERO,savstr,ipos) ELSE CALL dtoc(ttst(t0,TC),savstr,ipos) END IF IF(Lfatal)RETURN savstr(ipos:ipos)=TABCHR ipos=ipos+1 END IF c----------------------------------------------------------------------- IF(Savtab(LOTLFT))WRITE(fh,1100)savstr(1:ipos-1) IF(Lgraf)WRITE(fh2,1100)savstr(1:ipos-1) END DO IF(Savtab(LOTLFT))CALL fclose(fh) IF(Lgraf)CALL fclose(fh2) END IF c----------------------------------------------------------------------- c Close the outlier iteration save file c----------------------------------------------------------------------- IF(Sviter) & CALL svolit(LCLOSE,ipass,ipassa,'*',tmpttl,1,ZERO,ZERO,ZERO, & Sviter,Lxreg) IF(Ldiag)THEN WRITE(Nform,1101)'addoutlier: ',addnum WRITE(Nform,1101)'deloutlier: ',delnum WRITE(Nform,1102)'almost: ',Cvrduc WRITE(Nform,1101)'nalmostout: ',nalmst IF(nalmst.gt.0)THEN DO i=1,nalmst WRITE(Nform,1100)'almostoutlier$',calmst(i) END DO END IF END IF END IF IF(.not.Lfatal.and.lalmst)CALL copy(oldcvl,POTLR,1,Critvl) c----------------------------------------------------------------------- 1100 FORMAT(1000a) 1101 FORMAT(a,i5) 1102 FORMAT(a,f15.7) c----------------------------------------------------------------------- RETURN END idpeak.f0000664006604000003110000000357514521201520011577 0ustar sun00315stepsC Last change: BCM 4 Mar 2008 3:46 pm SUBROUTINE idpeak(Sxx,Sxx2,Spclim,Ny,Tpeak,Tlow,Tup,Ntfreq,Speak, & Slow,Sup,Nsfreq,Ltdpk,Lsapk,Freq,Plocal,Ldecbl, & Ltdfrq) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION FIVETO PARAMETER(F=.false.,T=.true.,FIVETO=52D0) c----------------------------------------------------------------------- DOUBLE PRECISION Sxx,Sxx2,tmpsxx,domfqt,domfqs,medsxx,pklim, & Spclim,Freq,Plocal,star1 INTEGER nspstr,Tpeak,Tlow,Tup,Ntfreq,Speak,Slow,Sup,Nsfreq,Ny, & Ltdpk,Lsapk,i LOGICAL Ldecbl,Ltdfrq,Lignr0 CHARACTER spcstr*(10) DIMENSION Sxx(61),Sxx2(*),Tpeak(*),Tlow(*),Tup(*),Speak(*), & Slow(*),Sup(*),Freq(*),tmpsxx(61) c----------------------------------------------------------------------- INTEGER ispeak DOUBLE PRECISION mkmdsx EXTERNAL ispeak,mkmdsx c----------------------------------------------------------------------- CALL copy(Sxx,61,1,tmpsxx) CALL shlsrt(61,tmpsxx) medsxx=mkmdsx(tmpsxx,61,Ldecbl) c----------------------------------------------------------------------- IF(Ldecbl)THEN pklim=(tmpsxx(61)-tmpsxx(1))*(Spclim/FIVETO) ELSE pklim=(tmpsxx(61)/tmpsxx(1))**(Spclim/FIVETO) END IF IF(Ltdfrq)Ltdpk=ispeak(Sxx2,F,Tpeak,Tlow,Tup,Ntfreq,pklim,medsxx, & Ny,Freq,Plocal,Ldecbl) Lsapk=ispeak(Sxx2,T,Speak,Slow,Sup,Nsfreq,pklim,medsxx,Ny,Freq, & Plocal,Ldecbl) c----------------------------------------------------------------------- RETURN END inbtwn.f0000664006604000003110000000364314521201520011637 0ustar sun00315steps**==inbtwn.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE inbtwn(Tcoef,Lagt,In,Ncoef,Coef,Lag) IMPLICIT NONE c----------------------------------------------------------------------- c Puts the current coefficent, t, between the in and in+1 coefficients c by moving everything above in over (up) one place. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c after i Local index for the coeffiecents and lags to be moved in+1 c coef r In/out ncoef long vector of polymonial coefficients c i i Local do loop index c in i Input scalar to indicate that the current coefficient c t will go just after the inth coefficient c lag i In/out ncoef long vector of lag corresponding to the c coefficients c lagt i Input scalar for the current lag c ncoef i In/out scalar for the number of coefficients c tcoef r Input scalar for the current coefficient value c----------------------------------------------------------------------- INTEGER i,In,after,Lagt,Lag(*),Ncoef DOUBLE PRECISION Tcoef,Coef(*) c----------------------------------------------------------------------- c Move over the coefficients of the higher lags c----------------------------------------------------------------------- after=In+1 DO i=Ncoef,after,-1 Coef(i+1)=Coef(i) Lag(i+1)=Lag(i) END DO c----------------------------------------------------------------------- c Add the current coefficient value and update the number of coefficient c counter c----------------------------------------------------------------------- Coef(after)=Tcoef Lag(after)=Lagt Ncoef=Ncoef+1 c ------------------------------------------------------------------ RETURN END indhtml.i0000664006604000003110000000016614521201520011775 0ustar sun00315stepsC C... Variables in Common Block /indHtml/ ... integer iTab,iId,iAKey common /indHtml/ iTab,iId,iAKeyindx.f0000664006604000003110000000075614521201520011302 0ustar sun00315steps**==indx.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 INTEGER FUNCTION indx(Str,Chr) IMPLICIT NONE c ----------------------------------------------------------------- CHARACTER Chr*1,Str*(*) c ----------------------------------------------------------------- DO indx=1,len(Str) IF(Chr.eq.Str(indx:indx))GO TO 10 END DO indx=0 c ----------------------------------------------------------------- 10 RETURN END initdg.f0000664006604000003110000000655214521201520011616 0ustar sun00315stepsC Last change: BCM 6 Aug 2004 2:29 pm SUBROUTINE initdg(Lsumm,Irev,Issap,Muladd) IMPLICIT NONE c ------------------------------------------------------------------ c Initial variables used to store SEATS diagnostics to NULL value c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'seatdg.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'setsvl.i' c ------------------------------------------------------------------ INTEGER ipr,ips,idr,ids,iqr,iqs,id,ip,iq,iprs,iqrs,Lsumm,Irev,n, & Issap,Muladd LOGICAL istrue EXTERNAL istrue c ------------------------------------------------------------------ CALL initst c----------------------------------------------------------------------- c Convert X-13A-S model variables into variables compatable with c TRAMO/SEATS model data structure c ------------------------------------------------------------------ CALL cnvmdl(ipr,ips,idr,ids,iqr,iqs,id,ip,iq,iprs,iqrs,n) IF(Lfatal)RETURN CALL mkmdsn(ipr,idr,iqr,ips,ids,iqs,X13mdl,Nxmdl) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF (Issap.eq.2.or.Irev.eq.4) RETURN IF ((.not.istrue(Svltab,LSLSMD,LSLAAD)).and.Lsumm.eq.0) RETURN c ------------------------------------------------------------------ IF(Svltab(LSLSNR).or.Lsumm.gt.0)THEN Kurt=DNOTST Kurtse=DNOTST Testnm=DNOTST Skew=DNOTST Skewse=DNOTST Sdres=DNOTST END IF IF(Svltab(LSLCEE).or.Lsumm.gt.0)THEN Ceetrn=DNOTST Ceesad=DNOTST END IF IF(Svltab(LSLAAD).or.Lsumm.gt.0)THEN Aadasa=DNOTST Aadatr=DNOTST END IF IF(Svltab(LSLTSE).or.Lsumm.gt.0)THEN Tsetrn=DNOTST Tsesea=DNOTST Tsetcm=DNOTST Tsesad=DNOTST END IF IF(Svltab(LSLSSG).or.Lsumm.gt.0)THEN Ssghst=NOTSET Ssgcnc=NOTSET Ssgfct=NOTSET END IF c----------------------------------------------------------------------- IF(Svltab(LSLPRS).or.Lsumm.gt.0)THEN CALL setdp(DNOTST,5,Prsetr) CALL setdp(DNOTST,5,Prsesa) END IF IF(Svltab(LSLCVR).or.Lsumm.gt.0)THEN CALL setdp(DNOTST,3,Vartrn) CALL setdp(DNOTST,3,Varsad) CALL setdp(DNOTST,3,Varirr) CALL setdp(DNOTST,3,Varsea) END IF c----------------------------------------------------------------------- IF(Svltab(LSLSMD).or.Lsumm.gt.0)THEN Iprsm=NOTSET Iqrsm=NOTSET Ipssm=NOTSET Iqssm=NOTSET Idrsm=NOTSET Idssm=NOTSET END IF c----------------------------------------------------------------------- IF(Svltab(LSLXMD)) & WRITE(Ng,1000)' X-13A-S model ',X13mdl(1:Nxmdl) IF(Lsumm.gt.0)THEN IF(Muladd.eq.0)THEN WRITE(Nform,1000)'samodeseats','logarithmic seasonal adjustment' ELSE WRITE(Nform,1000)'samodeseats','additive seasonal adjustment' END IF WRITE(Nform,1000)'x13mdl',X13mdl(1:Nxmdl) END IF 1000 FORMAT(a,': ',a) c----------------------------------------------------------------------- RETURN END initst.f0000664006604000003110000000336114521201520011645 0ustar sun00315stepsC Last change: BCM 23 Mar 2005 10:26 am SUBROUTINE initst IMPLICIT NONE c ------------------------------------------------------------------ c Initial variables used to store SEATS diagnostics to NULL value c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'seatlg.cmn' INCLUDE 'seatmd.cmn' INCLUDE 'stcfcm.cmn' c ------------------------------------------------------------------ Havetr = .false. Havesf = .false. Haveir = .false. Havesa = .false. Havecy = .false. Havftr = .false. Havfsf = .false. Havfir = .false. Havfsa = .false. Havfcy = .false. Hvfttr = .false. Hvftsf = .false. Hvftor = .false. Hvftsa = .false. Hvftcy = .false. Hseftr = .false. Hsefsf = .false. Hsefor = .false. Hsefsa = .false. Hsefcy = .false. Hsrftr = .false. Hsrfsf = .false. Hsrfsa = .false. Hsrfcy = .false. Hvstsa = .false. Hvstir = .false. Hvstft = .false. Hvstfs = .false. Hvstfo = .false. Hvstfa = .false. Hvstfc = .false. Ntcnum = NOTSET Ntcden = NOTSET Nsnum = NOTSET Nsden = NOTSET Nsanum = NOTSET Nsaden = NOTSET Ntrnum = NOTSET Ntrden = NOTSET Ntcwkf = NOTSET Nsawkf = NOTSET Nswkf = NOTSET Ntrwkf = NOTSET Nirwkf = NOTSET Tcvar = DNOTST Svar = DNOTST Savar = DNOTST Trvar = DNOTST Irrvar = DNOTST c ------------------------------------------------------------------ RETURN END inpt2.cmn0000664006604000003110000000232614521201521011720 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Adrc,Adrci,Adri,Adrmcd,Cbar,Cbar2,Cibar,Cibar2, & Cimbar,Cisd,Csd,Csq,Ibar,Ibar2,Isq,Isd,Imbar, & Obar,Obar2,Ombar,Osd,Osq,Osq2,Rv,Sbar,Sbar2, & Smbar,Smbar2,Smic,Smsd,Ssd,Ssq,Tdbar,Tdsq,Vc,Vi, & Vp,Vs,Vtd c----------------------------------------------------------------------- DIMENSION Tdbar(PSP),Tdsq(PSP),Sbar(PSP),Sbar2(PSP),Ssq(PSP), & Ssd(PSP),Ibar(PSP),Ibar2(PSP),Isq(PSP),Isd(PSP), & Imbar(PSP),Cbar(PSP),Cbar2(PSP),Csq(PSP),Csd(PSP), & Obar(PSP),Obar2(PSP),Osq(PSP),Osd(PSP),Osq2(PSP), & Smbar(PSP),Smbar2(PSP),Smsd(PSP),Ombar(PSP),Cimbar(PSP), & Cibar(PSP),Cibar2(PSP),Cisd(PSP),Smic(PSP) c----------------------------------------------------------------------- COMMON /inpt2 / Tdbar,Tdsq,Sbar,Sbar2,Ssq,Ssd,Ibar,Ibar2,Isq,Isd, & Imbar,Cbar,Cbar2,Csq,Csd,Obar,Obar2,Osq,Osd,Osq2, & Smbar,Smbar2,Smsd,Ombar,Cimbar,Cibar,Cibar2,Cisd, & Smic,Vi,Vc,Vs,Vp,Vtd,Rv,Adrci,Adri,Adrc,Adrmcd inpt.cmn0000664006604000003110000000107214521201521011633 0ustar sun00315stepsc----------------------------------------------------------------------- c Series - copy of original series c Orig - original series c Orig2 - copy of original series with backcasts and forecasts c Sprior - prior adjustment factors c----------------------------------------------------------------------- DOUBLE PRECISION Orig,Series,Sprior,Orig2 DIMENSION Orig(PLEN),Series(PLEN),Sprior(PLEN),Orig2(PLEN) c----------------------------------------------------------------------- COMMON /inpt1 / Series,Orig,Orig2,Sprior inpter.f0000664006604000003110000000766114521201521011644 0ustar sun00315stepsC Last change: BCM 1 Feb 98 11:11 pm SUBROUTINE inpter(Errtyp,Ptr,Errmsg) IMPLICIT NONE c----------------------------------------------------------------------- c inpter.f, Release 1, Subroutine Version 1.3, Modified 20 Oct 1994. c----------------------------------------------------------------------- c Errtyp=1 input error, 2 input warning, 3 execution error, 4 execution c warning. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'title.cmn' c----------------------------------------------------------------------- CHARACTER Errmsg*(*),errstr*7,blnkln*(LINLEN),prglin*(LINLEN) LOGICAL lprtln,rngbuf INTEGER displc,Errtyp,nerrcr,Ptr(2),prgln,llim,llim2 EXTERNAL rngbuf SAVE blnkln DATA blnkln/ &' & & '/ c----------------------------------------------------------------------- c For input errors and warnings print out the input line and carrot. c----------------------------------------------------------------------- lprtln=.false. llim=70 IF(Lwdprt)llim=121 c ------------------------------------------------------------------ IF(Errtyp.eq.PERROR.or.Errtyp.eq.PWARN)THEN lprtln=rngbuf(4,Ptr(PLINE),prglin,prgln) IF(lprtln)THEN IF(prgln-1.gt.llim)THEN WRITE(STDERR,1010)Ptr(PLINE),prglin(1:min((llim+10),prgln-1)) WRITE(Mt2,1010)Ptr(PLINE),prglin(1:min((llim+10),prgln-1)) 1010 FORMAT(/,' Line',i5,': ',/,' ',a) displc=0 ELSE WRITE(STDERR,1020)Ptr(PLINE),prglin(1:prgln-1) WRITE(Mt2,1020)Ptr(PLINE),prglin(1:prgln-1) 1020 FORMAT(/,' Line',i5,': ',a) displc=12 END IF c----------------------------------------------------------------------- c Put the carrot on the input error c----------------------------------------------------------------------- WRITE(STDERR,1030)blnkln(1:Ptr(PCHAR)+displc)//'^' WRITE(Mt2,1030)blnkln(1:Ptr(PCHAR)+displc)//'^' 1030 FORMAT(a) END IF END IF c----------------------------------------------------------------------- c Print out the error message c----------------------------------------------------------------------- IF(mod(Errtyp,2).eq.0)THEN nerrcr=7 errstr(1:nerrcr)='WARNING' ELSE nerrcr=5 errstr(1:nerrcr)='ERROR' END IF c ------------------------------------------------------------------ IF(.not.lprtln.or.(Errtyp.ne.PERROR.and.Errtyp.ne.PWARN))THEN WRITE(STDERR,'()') WRITE(Mt2,'()') END IF c ------------------------------------------------------------------ IF(len(Errmsg).le.llim)THEN WRITE(STDERR,1040)errstr(1:nerrcr),Errmsg WRITE(Mt2,1040)errstr(1:nerrcr),Errmsg 1040 FORMAT(' ',a,': ',a) ELSE llim2=llim 10 IF(Errmsg(llim2:llim2).eq.' ')GO TO 20 llim2=llim2-1 GO TO 10 20 WRITE(STDERR,1050)errstr(1:nerrcr),Errmsg(1:llim2), & blnkln(1:nerrcr),Errmsg((llim2+1):) WRITE(Mt2,1050)errstr(1:nerrcr),Errmsg(1:llim2), & blnkln(1:nerrcr),Errmsg((llim2+1):) 1050 FORMAT(' ',a,': ',a,/,' ',a,' ',a) END IF c ------------------------------------------------------------------ IF(.not.lprtln.and.(Errtyp.eq.PERROR.or.Errtyp.eq.PWARN))THEN WRITE(STDERR,1060)blnkln(1:nerrcr+3),Ptr WRITE(Mt2,1060)blnkln(1:nerrcr+3),Ptr 1060 FORMAT(a,' Problem was discovered on line',i5,', column ',i4,'.') c ELSE c WRITE(STDERR,'()') c WRITE(Mt2,'()') END IF c ----------------------------------------------------------------- RETURN END insdbl.f0000664006604000003110000000221314521201521011602 0ustar sun00315steps**==insdbl.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE insdbl(Subvec,Ielt,Ptrvec,Nelt,Vec) IMPLICIT NONE c---------------------------------------------------------------------- c Inserts the character string elt into position ielt to vec c using the pointers that are assumed to be updated in insptr. c ptrvec is used to determine the length of vec. c---------------------------------------------------------------------- INCLUDE 'error.cmn' c---------------------------------------------------------------------- INTEGER nielt,Ielt,Nelt,nrest,Ptrvec DOUBLE PRECISION Subvec,Vec DIMENSION Ptrvec(0:Nelt),Subvec(*),Vec(*) c ----------------------------------------------------------------- CALL eltlen(Ielt,Ptrvec,Nelt,nielt) IF(Lfatal)RETURN nrest=Ptrvec(Nelt)-Ptrvec(Ielt) CALL copy(Vec(Ptrvec(Ielt-1)),nrest,-1,Vec(Ptrvec(Ielt))) c ----------------------------------------------------------------- CALL copy(Subvec,nielt,1,Vec(Ptrvec(Ielt-1))) c ----------------------------------------------------------------- RETURN END insint.f0000664006604000003110000000220714521201521011636 0ustar sun00315steps**==insint.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE insint(Subvec,Ielt,Ptrvec,Nelt,Vec) IMPLICIT NONE c---------------------------------------------------------------------- c Inserts the integer vector subvec into position ielt to vec c using the pointers that are assumed to be updated in insptr. c ptrvec is used to determine the length of vec. c---------------------------------------------------------------------- INCLUDE 'error.cmn' c---------------------------------------------------------------------- INTEGER nielt,Ielt,Nelt,nrest,Ptrvec INTEGER Subvec,Vec DIMENSION Ptrvec(0:Nelt),Subvec(*),Vec(*) c ----------------------------------------------------------------- CALL eltlen(Ielt,Ptrvec,Nelt,nielt) IF(Lfatal)RETURN nrest=Ptrvec(Nelt)-Ptrvec(Ielt) CALL cpyint(Vec(Ptrvec(Ielt-1)),nrest,-1,Vec(Ptrvec(Ielt))) c ----------------------------------------------------------------- CALL cpyint(Subvec,nielt,1,Vec(Ptrvec(Ielt-1))) c ----------------------------------------------------------------- RETURN END inslg.f0000664006604000003110000000226414521201521011451 0ustar sun00315stepsC Last change: BCM 25 Nov 97 10:33 am **==inslg.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE inslg(Subvec,Ielt,Ptrvec,Nelt,Vec) IMPLICIT NONE c---------------------------------------------------------------------- c Inserts the character string elt into position ielt to vec c using the pointers that are assumed to be updated in insptr. c ptrvec is used to determine the length of vec. c---------------------------------------------------------------------- INCLUDE 'error.cmn' c ------------------------------------------------------------------ INTEGER nielt,Ielt,Nelt,nrest,Ptrvec LOGICAL Subvec,Vec DIMENSION Ptrvec(0:Nelt),Subvec(*),Vec(*) c ----------------------------------------------------------------- CALL eltlen(Ielt,Ptrvec,Nelt,nielt) IF(Lfatal)RETURN nrest=Ptrvec(Nelt)-Ptrvec(Ielt) CALL copylg(Vec(Ptrvec(Ielt-1)),nrest,-1,Vec(Ptrvec(Ielt))) c ----------------------------------------------------------------- CALL copylg(Subvec,nielt,1,Vec(Ptrvec(Ielt-1))) c ----------------------------------------------------------------- RETURN END insopr.f0000664006604000003110000000630414521201521011646 0ustar sun00315stepsC Last change: BCM 25 Nov 97 9:05 am SUBROUTINE insopr(Optype,Coef,Lag,Fix,Ncoef,Facsp,Ioprtl,Locok, & Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Check the input for MA and AR parameters and add the coefficients c and lags to the model. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c coef d Input pcoef ncoef used long vector of nonzero coefficients c to be added to arimap c fix l Input array to determine what parameters are fixed and c not estimated. c lag i Input pcoef ncoef used long vector of the lags of the nonzero c coefficients to be added to arimal. c ncoef i Input number of non zero coefficients in coef and lag c oprttl i Local number of characters in the optitl c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER Ioprtl*(*) LOGICAL Fix,Locok,Inptok INTEGER Facsp,i,iopr,Lag,Ncoef,Optype DOUBLE PRECISION Coef DIMENSION Coef(Ncoef),Fix(Ncoef),Lag(Ncoef) c----------------------------------------------------------------------- c Insert the title, coefficients, lags, and fix vectors in the c ARIMA model and update the model and operator pointers. c Later we may want to rewrite ins* to do error checking at a higher c level to give more understandable error messages. Here the error c is reported in GETOPR. c----------------------------------------------------------------------- Locok=T i=3 CALL insptr(F,1,Optype,3,POPR,Mdl,i) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Opr(Nopr)+Ncoef-1.gt.PARIMA)Locok=F c ------------------------------------------------------------------ IF(Locok)THEN iopr=Mdl(Optype)-1 CALL insptr(T,Ncoef,iopr,POPR,PARIMA,Opr,Nopr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Add the factor of the operator. Assume if it can be added to c Opr it can be added to Oprfac. c----------------------------------------------------------------------- DO i=Nopr,iopr+1,-1 Oprfac(i)=Oprfac(i-1) END DO Oprfac(iopr)=Facsp c ------------------------------------------------------------------ CALL insdbl(Coef,iopr,Opr,Nopr,Arimap) IF(.not.Lfatal)CALL insint(Lag,iopr,Opr,Nopr,Arimal) IF(.not.Lfatal)CALL inslg(Fix,iopr,Opr,Nopr,Arimaf) IF(.not.Lfatal)CALL insstr(Ioprtl,iopr,POPR,Oprttl,Oprptr,Noprtl) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ Inptok=Inptok.and.Locok RETURN END insort.f0000664006604000003110000000447514521201521011661 0ustar sun00315steps**==insort.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE insort(Tcoef,Lagt,Ncoef,Coef,Lag) IMPLICIT NONE c----------------------------------------------------------------------- c Puts the coefficient in order of the power of its lag by checking c backwards through the orders lag powers. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c coef r In/out ncoef long vector of polymonial coefficients c i i Local do loop index c lag i In/out ncoef long vector of lag corresponding to the c coefficients c lagt i Input scalar for the current lag c ncoef i In/out scalar for the number of coefficients c tcoef r Input scalar for the current coefficient value c----------------------------------------------------------------------- INTEGER i,Lagt,Lag(*),Ncoef DOUBLE PRECISION Tcoef,Coef(*) c----------------------------------------------------------------------- c Go back to a lag the is equal to or smaller than the current lag c----------------------------------------------------------------------- DO i=Ncoef,1,-1 c----------------------------------------------------------------------- c Found a lag less than the current lag so insert the new coeffient c in a space between k and k+1 by moving the higher powered coefficients c over. c----------------------------------------------------------------------- IF(Lagt.gt.Lag(i))THEN CALL inbtwn(Tcoef,Lagt,i,Ncoef,Coef,Lag) GO TO 10 c----------------------------------------------------------------------- c Found a lag equal to the current lag so add the coefficients. c----------------------------------------------------------------------- ELSE IF(Lagt.eq.Lag(i))THEN Coef(i)=Coef(i)+Tcoef GO TO 10 END IF END DO c----------------------------------------------------------------------- c The current lag is the smallest so place the new coefficient at c the begining. c----------------------------------------------------------------------- CALL inbtwn(Tcoef,Lagt,0,Ncoef,Coef,Lag) c ------------------------------------------------------------------ 10 RETURN END insptr.f0000664006604000003110000000462614521201521011660 0ustar sun00315stepsC Last change: BCM 14 May 1998 9:00 am **==insptr.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE insptr(Addcat,Niunit,Ielt,Pelt,Nunit,Ptrvec,Nelt) IMPLICIT NONE c---------------------------------------------------------------------- c Adds elt to the end of the chrvec if there are not to many c elements (nelt>pelt) or chrvec is to small (+len(elt)>len(chrvec)). c chrvec is a flat character string and ptrvec(i) points to the c begining of the i-1 character string and the 1st string begins at c one. The total length of chrvec is ptrvec(nelt)-1 and the length c of each string is ptrvec(i)-ptrvec(i-1) where ptrvec(0) is 1. c---------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ----------------------------------------------------------------- LOGICAL Addcat INTEGER disp,i,Ielt,Niunit,Nelt,Nunit,Pelt,Ptrvec DIMENSION Ptrvec(0:Pelt) c ----------------------------------------------------------------- Ptrvec(0)=1 IF(Addcat)THEN disp=1 ELSE disp=0 END IF c ----------------------------------------------------------------- IF(Nelt+disp.gt.Pelt)THEN WRITE(STDERR,1010) CALL errhdr WRITE(Mt2,1010) 1010 FORMAT(/,' ERROR: Too many elements for vector.',/) CALL abend RETURN c ----------------------------------------------------------------- ELSE IF(Ptrvec(Nelt)+Niunit-1.gt.Nunit)THEN WRITE(STDERR,1020) CALL errhdr WRITE(Mt2,1020) 1020 FORMAT(/,' ERROR: No room to add new element to vector.',/) CALL abend RETURN c ----------------------------------------------------------------- ELSE IF(Ielt.gt.Nelt+disp.or.Ielt.lt.1)THEN WRITE(STDERR,1030)Ielt,Nelt CALL errhdr WRITE(Mt2,1030)Ielt,Nelt 1030 FORMAT(/,' ERROR: Not able to insert element in position',i4,/, & ' of a',i3,' long vector.',/) CALL abend IF(Lfatal)RETURN c ----------------------------------------------------------------- ELSE DO i=Nelt,Ielt-disp,-1 Ptrvec(i+disp)=Ptrvec(i)+Niunit END DO END IF IF(Addcat)Nelt=Nelt+disp c ----------------------------------------------------------------- RETURN END insstr.f0000664006604000003110000000333514521201521011657 0ustar sun00315stepsC Last change: BCM 2 Apr 98 12:59 pm **==insstr.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE insstr(Str,Istr,Pstr,Chrvec,Ptrvec,Nstr) c---------------------------------------------------------------------- IMPLICIT NONE c---------------------------------------------------------------------- INCLUDE 'error.cmn' c---------------------------------------------------------------------- CHARACTER Chrvec*(*),Str*(*) INTEGER begchr,endchr,ichr,Istr,nwmold,Nstr,Pstr,Ptrvec DIMENSION Ptrvec(0:Pstr) c----------------------------------------------------------------------- c Insert the pointers before copying the strings. c----------------------------------------------------------------------- CALL insptr(.true.,len(Str),Istr,Pstr,len(Chrvec),Ptrvec,Nstr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Copy from last character to the first since the substring is c being push down and maybe copying over itself. c----------------------------------------------------------------------- begchr=Ptrvec(Istr) endchr=Ptrvec(Nstr)-1 nwmold=Ptrvec(Istr)-Ptrvec(Istr-1) c---------------------------------------------------------------------- DO ichr=endchr,begchr,-1 Chrvec(ichr:ichr)=Chrvec(ichr-nwmold:ichr-nwmold) END DO c----------------------------------------------------------------------- c Now there is room to insert the new substring. c----------------------------------------------------------------------- Chrvec(Ptrvec(Istr-1):Ptrvec(Istr)-1)=Str c---------------------------------------------------------------------- RETURN END intfmt.f0000664006604000003110000000201514521201522011631 0ustar sun00315steps**==intfmt.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE intfmt(Vec,Nelt,Clwdth) IMPLICIT NONE c----------------------------------------------------------------------- c Figures out the minimum number of columns needed to print out c a vector of integers c----------------------------------------------------------------------- INTEGER Clwdth,ielt,ival,iwdth,Nelt,Vec DIMENSION Vec(Nelt) c ------------------------------------------------------------------ Clwdth=0 DO ielt=1,Nelt ival=Vec(ielt) c ------------------------------------------------------------------ IF(ival.eq.0)THEN iwdth=1 ELSE iwdth=max(0,int(log10(float(abs(ival))))+1) END IF c ------------------------------------------------------------------ IF(Vec(ielt).lt.0)iwdth=iwdth+1 Clwdth=max(Clwdth,iwdth) END DO c ------------------------------------------------------------------ RETURN END intgpg.f0000664006604000003110000000557014521201522011631 0ustar sun00315stepsC Last change: BCM 25 Nov 97 11:59 am SUBROUTINE intgpg(Nextma,Info) IMPLICIT NONE c----------------------------------------------------------------------- c Initializes the G'G matrix c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ONE INTEGER PA PARAMETER(PA=PLEN+2*PORDER,ONE=1D0) c LOGICAL T,F c PARAMETER(T=.true.,F=.false.,PA=PLEN+PORDER,ONE=1D0) c ------------------------------------------------------------------ INTEGER i,ielt,Info,j,Nextma,nap2,ntmp DOUBLE PRECISION piwght,ssqpwt DIMENSION piwght(PA),ssqpwt(PA) c----------------------------------------------------------------------- c Calculate the cholesky decomposition of G'G and |G'G| by first c by calculating the pi weights in piwght and the cross products c of the pi weights in ssqpwt. c----------------------------------------------------------------------- IF(Lma)THEN piwght(1)=ONE ntmp=1 CALL ratpos(ntmp,Arimap,Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,Nextma, & piwght) c ------------------------------------------------------------------ CALL copy(piwght,Nextma,1,ssqpwt) CALL ratneg(Nextma,Arimap,Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,ssqpwt) c----------------------------------------------------------------------- c The first row of G'G is stored in ssqpwt(1:mxmalg) c----------------------------------------------------------------------- nap2=Nextma+2 ielt=1 Chlgpg(ielt)=ssqpwt(ielt) c ------------------------------------------------------------------ c CALL under0(T) c ------------------------------------------------------------------ DO j=2,Mxmalg ielt=ielt+1 Chlgpg(ielt)=ssqpwt(j) c ------------------------------------------------------------------ DO i=2,j ielt=ielt+1 Chlgpg(ielt)=Chlgpg(ielt-j)-piwght(nap2-i)*piwght(nap2-j) END DO END DO c----------------------------------------------------------------------- c Calculate the cholesky decomposition and determinate of G'G. c----------------------------------------------------------------------- CALL dppfa(Chlgpg,Mxmalg,Info) c ------------------------------------------------------------------ c CALL under0(F) c ------------------------------------------------------------------ IF(Info.le.0)CALL logdet(Chlgpg,Mxmalg,Lndtcv) c ------------------------------------------------------------------ ELSE Lndtcv=0D0 END IF c ------------------------------------------------------------------ RETURN END intinp.f0000664006604000003110000000214514521201522011635 0ustar sun00315stepsC Last change: BCM 15 Jan 98 11:08 am **==intinp.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE intinp(Instr) IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'error.cmn' c ----------------------------------------------------------------- INTEGER Instr LOGICAL ldmy,rngbuf EXTERNAL rngbuf c ----------------------------------------------------------------- Inputx=Instr Lineno=0 Lineln=0 ldmy=rngbuf(1,Lineno,Linex,Lineln) IF(.not.ldmy.or.Lfatal)RETURN Pos(PLINE)=0 Pos(PCHAR)=1 Lstpos(PLINE)=0 Lstpos(PCHAR)=1 Errpos(PLINE)=0 Errpos(PCHAR)=1 c ----------------------------------------------------------------- CALL lex() IF(Nxtktp.eq.EOF)THEN CALL inpter(PERROR,Pos, & 'Cannot process empty input specifications file.') CALL abend() END IF c ----------------------------------------------------------------- RETURN END intlst.f0000664006604000003110000000075514521201522011656 0ustar sun00315steps**==intlst.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE intlst(Pelt,Ptrvec,Nstr) IMPLICIT NONE c ----------------------------------------------------------------- INTEGER Nstr,Pelt,Ptrvec DIMENSION Ptrvec(0:Pelt) c ----------------------------------------------------------------- Nstr=0 Ptrvec(Nstr)=1 Ptrvec(1)=1 c ----------------------------------------------------------------- RETURN END intrpp.f0000664006604000003110000000323314521201522011647 0ustar sun00315stepsC Last change: BCM 1 Sep 1998 1:07 pm DOUBLE PRECISION FUNCTION intrpp(Ppvec,Ppnum,Nobs,Ppi,Plen,Dif2nd) IMPLICIT NONE c----------------------------------------------------------------------- c This routine gets the 1 percent points for the distributions c of the normality statistics. c----------------------------------------------------------------------- DOUBLE PRECISION ONE,TWO PARAMETER(ONE=1D0,TWO=2D0) c----------------------------------------------------------------------- DOUBLE PRECISION Ppvec,theta INTEGER Ppnum,Nobs,Ppi,Plen LOGICAL Dif2nd DIMENSION Ppvec(Plen),Ppnum(Plen) c----------------------------------------------------------------------- c If length match is exact, return percentage point c----------------------------------------------------------------------- intrpp=Ppvec(Ppi) IF(Ppnum(Ppi).eq.Nobs)RETURN c----------------------------------------------------------------------- c Perform interpolation based on first differences c----------------------------------------------------------------------- theta=dble(Nobs-Ppnum(Ppi))/dble(Ppnum(2)-Ppnum(1)) intrpp=intrpp+theta*(Ppvec(Ppi+1)-Ppvec(Ppi)) c----------------------------------------------------------------------- c Refine with interpolation based on second differences, if c requested c----------------------------------------------------------------------- IF(Dif2nd)intrpp=intrpp+((theta*(theta-ONE))/TWO)* & (Ppvec(Ppi+2)-2*Ppvec(Ppi+1)+Ppvec(Ppi)) c----------------------------------------------------------------------- RETURN END intsrt.f0000664006604000003110000000637214521201522011665 0ustar sun00315steps SUBROUTINE intsrt(Nr,Vecx) c----------------------------------------------------------------------- c Returns sorted Vecx. Uses a shell sort. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c abss d Work pa long nr used vector to hold the sorted absolute c values c bot i Local index to the element at the bottom of the gap, i.e. c index with the lower value. c gap i Local distance between the records that are being compared. c gap starts out at half the number of records and is halved c until it reaches 1. c i i Local do loop c median d Output median of the absolute differences c nabss i Work PARAMETER for the length of abss c nr i Input row dimension of s c nsrt i Local number of comparisons to make on one pass through the c records c pa i Local PARAMETER for the maximum number of innovation errors c s d Input nr long vector to be sorted. c tmp d Local temporary scalar c top i Local index to the element at the top of the gap, i.e. c index with the higher value and gap higher than bot. c----------------------------------------------------------------------- c Type the variables c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ INTEGER bot,gap,Nr,nsrt,top,Vecx,tmp DIMENSION Vecx(Nr) c----------------------------------------------------------------------- c Use a Shell sort the nr records of Vecx. Compares records half c the number of records apart, then keep halving the gap size until c records next to eachother are compared. c----------------------------------------------------------------------- gap=Nr DO WHILE (.true.) gap=gap/2 IF(gap.gt.0)THEN nsrt=Nr-gap c----------------------------------------------------------------------- c Compare and sort nsrt records that are gap records apart. c----------------------------------------------------------------------- bot=0 DO WHILE (.true.) bot=bot+1 IF(bot.le.nsrt)THEN DO WHILE (.true.) c ------------------------------------------------------------------ top=bot+gap c----------------------------------------------------------------------- c See if Vecx(top) and Vecx(bot) need to be exchanged and switch c them if they do. c----------------------------------------------------------------------- IF(Vecx(bot).le.Vecx(top))GO TO 10 tmp=Vecx(top) Vecx(top)=Vecx(bot) Vecx(bot)=tmp c ------------------------------------------------------------------ IF(bot.le.gap)GO TO 10 bot=bot-gap END DO END IF GO TO 20 10 CONTINUE END DO END IF c ------------------------------------------------------------------ bot=Nr/2 c ------------------------------------------------------------------ RETURN 20 CONTINUE END DO END invfcn.f0000664006604000003110000000622014521201522011615 0ustar sun00315stepsC Last change: BCM 14 May 1998 7:57 am SUBROUTINE invfcn(Trny,Nsrs,Fcntyp,Lam,Y) IMPLICIT NONE c----------------------------------------------------------------------- c invfcn.f, Release 1, Subroutine Version 1.5, Modified 07 Nov 1994. c----------------------------------------------------------------------- c Inverse Box-Cox Transformation, of trny, 1 to nsrs, putting the c result in y. Transformation is: c y=trny , lam=1 c y=exp(trny) , lam=0, y>0 c trny=lam+(y**lam-1)/lam, lam<>0 or 1, y>0 c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c lam d Box-Cox transformation parameter c nsrs i Length of the vectors c trny d Transformed vector of length nsrs c y d Vector to be untransformed length nsrs c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZO,ONE PARAMETER(ZO=0.0D0,ONE=1.0D0) c ------------------------------------------------------------------ LOGICAL dpeq INTEGER Fcntyp,i,Nsrs DOUBLE PRECISION fact,Lam,invlam,tmp,Trny(*),Y(*) EXTERNAL dpeq c----------------------------------------------------------------------- c Inverse of the logit c----------------------------------------------------------------------- IF(Fcntyp.eq.3)THEN DO i=1,Nsrs tmp=exp(Trny(i)) Y(i)=tmp/(ONE+tmp) END DO c----------------------------------------------------------------------- c Lam=1, no transformation, just copy the vector c----------------------------------------------------------------------- ELSE IF(dpeq(Lam,ONE).or.Fcntyp.eq.4)THEN CALL copy(Trny,Nsrs,1,Y) c----------------------------------------------------------------------- c Lam=0, log transformation if y>0 c----------------------------------------------------------------------- ELSE IF(dpeq(Lam,ZO).or.Fcntyp.eq.1)THEN DO i=1,Nsrs Y(i)=exp(Trny(i)) END DO c----------------------------------------------------------------------- c Lam not equal to 1 or 0 c----------------------------------------------------------------------- ELSE invlam=ONE/Lam c ------------------------------------------------------------------ DO i=1,Nsrs fact=Lam*(Trny(i)-Lam**2)+ONE c ------------------------------------------------------------------ IF(fact.gt.ZO)THEN Y(i)=fact**invlam c ------------------------------------------------------------------ ELSE WRITE(STDERR,1010)i,Y(i),invlam WRITE(Mt2,1010)i,Y(i),invlam 1010 FORMAT(' ERROR: Cox-Box routine-y(',i5,')=',f16.8,'and 1/lam=', & f5.2,'.') END IF END DO END IF c ------------------------------------------------------------------ RETURN END invmat.f0000664006604000003110000002723414521201522011640 0ustar sun00315steps SUBROUTINE invMat( mA, nA, mB, nB ) c----------------------------------------------------------------------- c invMat.f, Release 1, Subroutine Version 1.1, Modified 15 Sep 2005. c----------------------------------------------------------------------- c Changes: c Created by REG, on 11 Apr 2005. c Modified by REG, on 15 Sep 2005, to change size of dummy argument, c dtrmnt, passed to dppdi(). c----------------------------------------------------------------------- c This subroutine calculates the inverse mB of a symmetric matrix mA c mB = mA^(-1) where nA and nB contain the dimensions of mA and mB. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d input matrix to be inverted c mB d output matrix to contain inverted mA c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c dtrmnt d determinate of matrix mp (=mA) c i,j i index variables for do loops c info i errors returned by dppfa() c JOB i constant parameter passed to dppdi() c k i index into matrix mp c mp d upper triangle of symetric matrix mA in vector form c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nA(1), nA(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, k, info, JOB DOUBLE PRECISION dtrmnt(2), mp( nA(1)*(nA(1)+1)/2 ) PARAMETER (JOB=1) c----------------------------------------------------------------------- c Check for valid matrix inversion. c----------------------------------------------------------------------- IF (( nA(1) .eq. nA(2) ) .and. ( nA(1) .gt. 0)) THEN c ------------------------------------------------------------------ c Move lower triangular part of mA to mp for processing c by dppfa and dppfi. c ------------------------------------------------------------------ k=0 DO j=1,nA(1) DO i=1,j k=k+1 mp(k)=mA(i,j) END DO END DO c ------------------------------------------------------------------ c Check that mp (=mA) is positive definite and invert. c ------------------------------------------------------------------ CALL dppfa( mp, nA(1), info ) IF ( info .eq. 0 ) THEN CALL dppdi( mp, nA(1), dtrmnt, JOB ) c ------------------------------------------------------------------ c Move the inverted matrix to mB. c ------------------------------------------------------------------ k=0 DO j=1,nA(1) DO i=1,j k=k+1 mB(i,j)=mp(k) mB(j,i)=mp(k) END DO END DO c ------------------------------------------------------------------ c Create dimensions of inverted matrix mB. c ------------------------------------------------------------------ nB(1) = nA(1) nB(2) = nA(2) c----------------------------------------------------------------------- C mA matrix is not positive definite. c----------------------------------------------------------------------- ELSE nB(1) = 0 nB(2) = 0 END IF c----------------------------------------------------------------------- c Invalid matrix inversion. c----------------------------------------------------------------------- ELSE nB(1) = 0 nB(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE getInvDia( mA, nA, iDiag, sDiag, nDiag ) c----------------------------------------------------------------------- c getInvDia, Release 1, Subroutine Version 1.0, Created 21 Feb 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 21 Feb 2006. c----------------------------------------------------------------------- c This subroutine calculates a diagonal entry (index of iDiag) c in the inverse of a symmetric matrix mA where nA and nDiag c contain the dimensions of mA and sDiag. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c iDiag i index of diagonal element in inverse of mA to be calculated c mA d input matrix to be inverted c nA i size (rows,columns) of mA matrix c nDiag i size (rows,columns) of sDiag scallar c sDiag d output matrix to contain inverted mA c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c info i errors returned by dppfa() c k i index into matrix mp c mp d upper triangle of symetric matrix mA in vector form c ONE d constant parameter c vB d vector containing e_iDiag and passed dppsl() in order c to solve for column of inverse(mA) that contains desired c diagonal entry c ZERO d constant parameter c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), iDiag, nDiag(2) DOUBLE PRECISION mA( nA(1), nA(2) ), sDiag c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, k, info DOUBLE PRECISION mp( nA(1)*(nA(1)+1)/2 ), vB( nA(1) ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE=1.0d0, ZERO=0.0d0 ) c----------------------------------------------------------------------- c Check for valid matrix inversion. c----------------------------------------------------------------------- IF (( nA(1) .eq. nA(2) ) .and. ( nA(1) .gt. 0) .and. & ( iDiag .ge. 1 ) .and. ( iDiag .le. nA(1) )) THEN c ------------------------------------------------------------------ c Move lower triangular part of mA to mp for processing c by dppfa and dppfi. c ------------------------------------------------------------------ k=0 DO j=1,nA(1) DO i=1,j k=k+1 mp(k)=mA(i,j) END DO END DO c ------------------------------------------------------------------ c Check that mp (=mA) is positive definite c and solve for diagonal element. c ------------------------------------------------------------------ CALL dppfa( mp, nA(1), info ) IF ( info .eq. 0 ) THEN c ------------------------------------------------------------------ c Initialize vB to e_iDiag. c ------------------------------------------------------------------ DO j=1,nA(1) vB(j)=ZERO END DO vB( iDiag ) = ONE c ------------------------------------------------------------------ c Call dppsl using vB to e_iDiag in order to solve for iDiag column c in inverse of mA. c ------------------------------------------------------------------ CALL dppsl( mp, nA(1), vB, .false. ) c ------------------------------------------------------------------ c Retrieve the desired diagonal entry. c ------------------------------------------------------------------ sDiag = vB( iDiag ) nDiag(1) = 1 nDiag(2) = 1 ELSE nDiag(1) = 0 nDiag(2) = 0 END IF END IF RETURN END c----------------------------------------------------------------------- SUBROUTINE invLTMat( mLMat, nLMat, mInvLMat, nInvLMat ) c----------------------------------------------------------------------- c invLMat.f, Release 1, Subroutine Version 1.0, Created 14 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 11 Apr 2005. c----------------------------------------------------------------------- c This subroutine calculates the inverse mInvLMAT of a lower c diagonal matrix mLMat using the following equation c mInvLMat = mLmat' x (mLMat*mLMat')^(-1) where nLMat and nInvLMat c contain the dimensions of mLMat and mInvLMat. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mInvLMat d output matrix to containing inverted mLMat c mLMat d input matrix to be inverted c nInvLMat i size (rows,columns) of mInvLMat matrix c nLMat i size (rows,columns) of mLMat matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c mTemp1 d working matrix to contain mLMat x mLMat' c mTemp2 d working matrix to contain inverse of mTemp1 c nTemp1 i size (rows,columns) of mTemp1 matrix c nTemp2 i size (rows,columns) of mTemp2 matrix c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nLMat(2), nInvLMat(2) DOUBLE PRECISION mLMat( nLMat(1), nLMat(2) ) DOUBLE PRECISION mInvLMat( nLMat(1), nLMat(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER nTemp1(2), nTemp2(2) DOUBLE PRECISION mTemp1( nLMat(1), nLMat(1) ) DOUBLE PRECISION mTemp2( nLMat(1), nLMat(1) ) c----------------------------------------------------------------------- c Calculate positive definite matrix to be inverted mLMat x mLMat' c----------------------------------------------------------------------- CALL mulMatTr( mLMat, nLMat, mLMat, nLMat, mTemp1, nTemp1 ) c----------------------------------------------------------------------- c Invert positive definite matrix c----------------------------------------------------------------------- CALL invMat( mTemp1, nTemp1 , mTemp2, nTemp2 ) c----------------------------------------------------------------------- c Calculate inverse of lower diagonal input matrix c----------------------------------------------------------------------- CALL mulTrMat( mLMat, nLMat, mTemp2, nTemp2, mInvLMat, nInvLMat ) RETURN ENDipmpar.f0000664006604000003110000003104314521201522011623 0ustar sun00315steps**==ipmpar.f processed by SPAG 4.03F at 14:31 on 28 Jul 1994 INTEGER FUNCTION ipmpar(I) IMPLICIT NONE C----------------------------------------------------------------------- C C IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER C THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER C HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ... C C INTEGERS. C C ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM C C SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) C C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. C C IPMPAR(1) = A, THE BASE. C C IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS. C C IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE. C C FLOATING-POINT NUMBERS. C C IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING C POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE C NONZERO NUMBERS ARE REPRESENTED IN THE FORM C C SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) C C WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, C X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. C C IPMPAR(4) = B, THE BASE. C C SINGLE-PRECISION C C IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS. C C IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E. C C IPMPAR(7) = EMAX, THE LARGEST EXPONENT E. C C DOUBLE-PRECISION C C IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS. C C IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E. C C IPMPAR(10) = EMAX, THE LARGEST EXPONENT E. C C----------------------------------------------------------------------- C C TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED, ACTIVATE C THE DATA STATMENTS FOR THE COMPUTER BY REMOVING THE C FROM C COLUMN 1. (ALL THE OTHER DATA STATEMENTS SHOULD HAVE C IN C COLUMN 1.) C C----------------------------------------------------------------------- C C IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY C P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES). C IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE C FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES. C C----------------------------------------------------------------------- C .. Scalar Arguments .. INTEGER I C .. C .. Local Arrays .. INTEGER imach(10) C .. C .. Data statements .. C C MACHINE CONSTANTS FOR AMDAHL MACHINES. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 16 / C DATA IMACH( 5) / 6 / C DATA IMACH( 6) / -64 / C DATA IMACH( 7) / 63 / C DATA IMACH( 8) / 14 / C DATA IMACH( 9) / -64 / C DATA IMACH(10) / 63 / C C MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T C PC 7300, AND AT&T 6300. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 33 / C DATA IMACH( 3) / 8589934591 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -256 / C DATA IMACH( 7) / 255 / C DATA IMACH( 8) / 60 / C DATA IMACH( 9) / -256 / C DATA IMACH(10) / 255 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 39 / C DATA IMACH( 3) / 549755813887 / C DATA IMACH( 4) / 8 / C DATA IMACH( 5) / 13 / C DATA IMACH( 6) / -50 / C DATA IMACH( 7) / 76 / C DATA IMACH( 8) / 26 / C DATA IMACH( 9) / -50 / C DATA IMACH(10) / 76 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 39 / C DATA IMACH( 3) / 549755813887 / C DATA IMACH( 4) / 8 / C DATA IMACH( 5) / 13 / C DATA IMACH( 6) / -50 / C DATA IMACH( 7) / 76 / C DATA IMACH( 8) / 26 / C DATA IMACH( 9) / -32754 / C DATA IMACH(10) / 32780 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT C ARITHMETIC (NOS OPERATING SYSTEM). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 48 / C DATA IMACH( 3) / 281474976710655 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / -974 / C DATA IMACH( 7) / 1070 / C DATA IMACH( 8) / 95 / C DATA IMACH( 9) / -926 / C DATA IMACH(10) / 1070 / C C MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT C ARITHMETIC (NOS/VE OPERATING SYSTEM). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 63 / C DATA IMACH( 3) / 9223372036854775807 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / -4096 / C DATA IMACH( 7) / 4095 / C DATA IMACH( 8) / 96 / C DATA IMACH( 9) / -4096 / C DATA IMACH(10) / 4095 / C C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 63 / C DATA IMACH( 3) / 9223372036854775807 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 47 / C DATA IMACH( 6) / -8189 / C DATA IMACH( 7) / 8190 / C DATA IMACH( 8) / 94 / C DATA IMACH( 9) / -8099 / C DATA IMACH(10) / 8190 / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 15 / C DATA IMACH( 3) / 32767 / C DATA IMACH( 4) / 16 / C DATA IMACH( 5) / 6 / C DATA IMACH( 6) / -64 / C DATA IMACH( 7) / 63 / C DATA IMACH( 8) / 14 / C DATA IMACH( 9) / -64 / C DATA IMACH(10) / 63 / C C MACHINE CONSTANTS FOR THE HARRIS 220. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 23 / C DATA IMACH( 3) / 8388607 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 23 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 38 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 C AND DPS 8/70 SERIES. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 35 / C DATA IMACH( 3) / 34359738367 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 27 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE HP 2100 C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 15 / C DATA IMACH( 3) / 32767 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 23 / C DATA IMACH( 6) / -128 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / -128 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 15 / C DATA IMACH( 3) / 32767 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 23 / C DATA IMACH( 6) / -128 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 55 / C DATA IMACH( 9) / -128 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE HP 9000. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -126 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA C 5/7/9 AND THE SEL SYSTEMS 85/86. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 16 / C DATA IMACH( 5) / 6 / C DATA IMACH( 6) / -64 / C DATA IMACH( 7) / 63 / C DATA IMACH( 8) / 14 / C DATA IMACH( 9) / -64 / C DATA IMACH(10) / 63 / C C MACHINE CONSTANTS FOR THE IBM PC. C C DATA imach(1)/2/ C DATA imach(2)/31/ C DATA imach(3)/2147483647/ C DATA imach(4)/2/ C DATA imach(5)/24/ C DATA imach(6)/-125/ C DATA imach(7)/128/ C DATA imach(8)/53/ C DATA imach(9)/-1021/ C DATA imach(10)/1024/ C C MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT C MACFORTRAN II. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 56 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 35 / C DATA IMACH( 3) / 34359738367 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 27 / C DATA IMACH( 6) / -128 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 54 / C DATA IMACH( 9) / -101 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 35 / C DATA IMACH( 3) / 34359738367 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 27 / C DATA IMACH( 6) / -128 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 62 / C DATA IMACH( 9) / -128 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 56 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D C SERIES (MIPS R3000 PROCESSOR). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T C PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). C DATA imach(1)/2/ DATA imach(2)/31/ DATA imach(3)/2147483647/ DATA imach(4)/2/ DATA imach(5)/24/ DATA imach(6)/-125/ DATA imach(7)/128/ DATA imach(8)/53/ DATA imach(9)/-1021/ DATA imach(10)/1024/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 35 / C DATA IMACH( 3) / 34359738367 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 27 / C DATA IMACH( 6) / -128 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 60 / C DATA IMACH( 9) /-1024 / C DATA IMACH(10) / 1023 / C C MACHINE CONSTANTS FOR THE VAX 11/780. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 56 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C ipmpar=imach(I) RETURN END iscrfn.f0000664006604000003110000000217214521201522011620 0ustar sun00315steps**==iscrfn.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE iscrfn(Oprn,Scr,Avec,Nelt,Pc,Cvec) IMPLICIT NONE c ------------------------------------------------------------------ INTEGER ADD,SUB,MULT,DIV PARAMETER(ADD=1,SUB=2,MULT=3,DIV=4) INTEGER Avec,Cvec,Oprn,Nelt,Pc,Scr DIMENSION Avec(Nelt),Cvec(Pc) c ------------------------------------------------------------------ INTEGER i c ------------------------------------------------------------------ DO i=1,Nelt IF(Oprn.eq.ADD)THEN Cvec(i)=Scr+Avec(i) c ------------------------------------------------------------------ ELSE IF(Oprn.eq.SUB)THEN Cvec(i)=Avec(i)-Scr c ------------------------------------------------------------------ ELSE IF(Oprn.eq.MULT)THEN Cvec(i)=Scr*Avec(i) c ------------------------------------------------------------------ ELSE IF(Oprn.eq.DIV)THEN Cvec(i)=Avec(i)/Scr END IF END DO c ------------------------------------------------------------------ RETURN END isdate.f0000664006604000003110000000143614521201523011610 0ustar sun00315steps**==isdate.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 LOGICAL FUNCTION isdate(Dat,Sp) IMPLICIT NONE c----------------------------------------------------------------------- c Check the date c----------------------------------------------------------------------- INTEGER Dat,Sp DIMENSION Dat(2) c ------------------------------------------------------------------ c BCM changed routine Oct 31, 1995 to allow for year zero. c ------------------------------------------------------------------ IF((Sp.gt.1.and.(Dat(2).lt.1.or.Dat(2).gt.Sp)).or.Dat(1).lt.0)THEN isdate=.false. ELSE isdate=.true. END IF c ------------------------------------------------------------------ RETURN END isfals.f0000664006604000003110000000134514521201523011617 0ustar sun00315steps**==istrue.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 LOGICAL FUNCTION isfals(Lsrs,L1,L2) c----------------------------------------------------------------------- c Check to see if there is at least one true element in an array c of logicals between two positions of the array. c----------------------------------------------------------------------- IMPLICIT NONE LOGICAL Lsrs(*) INTEGER i,L1,L2 c----------------------------------------------------------------------- isfals=.false. DO i=L1,L2 isfals=isfals.or.(.not.Lsrs(i)) IF(isfals)RETURN END DO c----------------------------------------------------------------------- RETURN END isfixd.f0000664006604000003110000000547114521201523011630 0ustar sun00315steps**==isfixd.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE isfixd(Level,Arimaf,Beglag,Endlag,Cfix) IMPLICIT NONE c----------------------------------------------------------------------- c Reports "(fixed)" for a component, operator, lag, or variance c depending on what level it is fixed at. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c arimaf l Input parima long vector to tell if a parameter is c fixed or not c beglag i Input begining lag of the current set of lags and c estimate/parameters in arimal and arimap c cfix c Output 7 long character string reporting whether a c component, operator, lag, or variance is fixed or c estimated c cpntfx l Local saved switch for a fixed component c endlag i Input end lag of the current set of lags and c estimate/parameters in arimal and arimap c fixed l Local switch for a fixed or estimated lag set c ilag i Local index to the current lag c LAGS i Local PARAMETER defining the lag level c level i Input indicator if the routine is working with something c fixed at the component, operator, or lag level c MODEL i Local PARAMETER defining the component level c oprfix l Local saved switch for a not fixed component but fixed c operator withing the component c OPRS i Local PARAMETER defining the operator level c----------------------------------------------------------------------- INTEGER MODEL,LAGS,OPRS PARAMETER(MODEL=1,LAGS=3,OPRS=2) c ------------------------------------------------------------------ CHARACTER Cfix*7 LOGICAL Arimaf,cpntfx,fixed,oprfix INTEGER Beglag,Endlag,ilag,Level DIMENSION Arimaf(*) SAVE cpntfx,oprfix c ------------------------------------------------------------------ fixed=.true. DO ilag=Beglag,Endlag fixed=fixed.and.Arimaf(ilag) END DO c ------------------------------------------------------------------ IF(Level.eq.MODEL)THEN cpntfx=fixed c ------------------------------------------------------------------ ELSE IF(Level.eq.OPRS)THEN oprfix=.not.cpntfx.and.fixed.and.(Endlag.gt.Beglag) fixed=oprfix c ------------------------------------------------------------------ ELSE IF(Level.eq.LAGS)THEN fixed=.not.cpntfx.and..not.oprfix.and.fixed END IF c ------------------------------------------------------------------ IF(fixed)THEN Cfix='(fixed)' ELSE Cfix=' ' END IF c ------------------------------------------------------------------ RETURN END ispeak.f0000664006604000003110000001223314521201523011610 0ustar sun00315stepsC Last change: BCM 12 Nov 1998 10:53 am **==ispeak.f processed by SPAG 4.03F at 14:16 on 28 Sep 1994 INTEGER FUNCTION ispeak(Sxx,Lsa,Peaks,Lowlim,Uplim,Npeaks,Plimit, & Mlimit,Ny,Freq,Plocal,Ldecbl) IMPLICIT NONE c----------------------------------------------------------------------- c Function that flags possible trading day or seasonal peaks in a c given set of spectral estimates. Peak must be greater than the c median of the spectral estimates computed (Mlimit). The peaks of c interest are defined in the vector pkvec. c----------------------------------------------------------------------- DOUBLE PRECISION Mlimit,Sxx,slimit,Plimit,Freq,f0,f1,f2,Plocal LOGICAL Lsa,Ldecbl INTEGER i,ifreq,Peaks,Lowlim,Uplim,Peakwd,Npeaks,i2,Ny,k,k0,k1,k2 DIMENSION Sxx(*),Freq(*),Peaks(*),Lowlim(*),Uplim(*) c----------------------------------------------------------------------- c Initialize number of peaks found c----------------------------------------------------------------------- ispeak=0 c----------------------------------------------------------------------- c Set number of frequencies tested (i2) - c If looking for seasonal peaks, don't test for peak at the c final frequency. c----------------------------------------------------------------------- i2=Npeaks IF(Lsa.and.Ny.eq.12)i2=i2-1 c----------------------------------------------------------------------- c Loop through the i2 frequencies being tested for being a peak. c Store the frequency of the ith peak in ifreq c----------------------------------------------------------------------- DO i=1,i2 ifreq=Peaks(i) c----------------------------------------------------------------------- c Only test for a peak if the spectrum at this frequency is larger c than the median of all spectrum values. c----------------------------------------------------------------------- IF(Sxx(ifreq).gt.Mlimit)THEN c----------------------------------------------------------------------- c This section looks for frequencies around the tested frequency to c see if there are frequencies outside Plocal frequencies from the c tested frequency but between the frequencies being used to define c the limits of the peak that have a spectral estimate higher than c the tested frequency. If so, add 1 to k, and do not test the c frequency for a peak if k > 0 c----------------------------------------------------------------------- k=0 k1=Lowlim(i)+1 IF(Lsa.and.Ny.eq.12)THEN k2=ifreq-1 ELSE k2=Uplim(i)-1 END IF IF(k2.gt.k1)THEN f1=Freq(ifreq)-Plocal f2=Freq(ifreq)+Plocal DO k0=k1,k2 IF(k0.ne.ifreq)THEN f0=Freq(k0) IF((f0.lt.f1.or.f0.gt.f2).and.(Sxx(k0).gt.Sxx(ifreq)))k=k+1 END IF END DO END IF c----------------------------------------------------------------------- c If k = 0, try to find a peak. c----------------------------------------------------------------------- IF(k.eq.0)THEN IF(Ldecbl)THEN c----------------------------------------------------------------------- c If the spectral estimates are expressed as decibels, create slimit c as the number that the spectral estimates for the frequencies c defined as the limits of the peak must be less than. c----------------------------------------------------------------------- slimit=Sxx(ifreq)-Plimit IF(Sxx(Lowlim(i)).lt.slimit)THEN c----------------------------------------------------------------------- c If this is a seasonal frequency, and that this frequency is the c final frequency, there is no upper frequency so this is marked as c a peak. (this is intended only for quarterly series, but now c spectrums aren't generated for quarterly series, and i never c equals Npeaks for monthly series.) c----------------------------------------------------------------------- IF(Lsa.and.(i.eq.Npeaks))THEN ispeak=ispeak+1 ELSE c----------------------------------------------------------------------- c If spectral estimate for the upper limit is less than slimit, c increase number of peaks. c----------------------------------------------------------------------- IF(Sxx(Uplim(i)).lt.slimit)ispeak=ispeak+1 END IF END IF ELSE c----------------------------------------------------------------------- c Basically the same except slimit is formed differently c----------------------------------------------------------------------- slimit=Sxx(ifreq)/Sxx(Lowlim(i)) IF(slimit.ge.Plimit)THEN IF(Lsa.and.(i.eq.Npeaks))THEN ispeak=ispeak+1 ELSE slimit=Sxx(ifreq)/Sxx(Uplim(i)) IF(slimit.ge.Plimit)ispeak=ispeak+1 END IF END IF END IF END IF END IF END DO c----------------------------------------------------------------------- RETURN END ispos.f0000664006604000003110000000137514521201523011476 0ustar sun00315steps**==issame.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 LOGICAL FUNCTION ispos(Lsrs,L1,L2) c----------------------------------------------------------------------- c Check to see if all the values of a double precision array c between pointers L1 and L2 are greater than zero. c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION Lsrs(*) INTEGER i,L1,L2 c----------------------------------------------------------------------- ispos=.true. DO i=L1,L2 IF(Lsrs(i).le.0D0)THEN ispos=.false. RETURN END IF END DO c----------------------------------------------------------------------- RETURN END issame.f0000664006604000003110000000226114521201523011615 0ustar sun00315steps**==issame.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 LOGICAL FUNCTION issame(Lsrs,L1,L2) c----------------------------------------------------------------------- c Check to see if all the values of a double precision array c between pointers L1 and L2 are the same. c----------------------------------------------------------------------- c Revised March 2006 BCM - only test "good" observations. c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION Lsrs(*),base INTEGER i,L1,L2 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'goodob.cmn' c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- issame=.true. base=Lsrs(L1) DO i=L1+1,L2 IF(Gudval(i))THEN issame=issame.and.dpeq(Lsrs(i),base) IF(.not.issame)RETURN END IF END DO c----------------------------------------------------------------------- RETURN END istrue.f0000664006604000003110000000133614521201523011651 0ustar sun00315steps**==istrue.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 LOGICAL FUNCTION istrue(Lsrs,L1,L2) c----------------------------------------------------------------------- c Check to see if there is at least one true element in an array c of logicals between two positions of the array. c----------------------------------------------------------------------- IMPLICIT NONE LOGICAL Lsrs(*) INTEGER i,L1,L2 c----------------------------------------------------------------------- istrue=.false. DO i=L1,L2 istrue=istrue.or.Lsrs(i) IF(istrue)RETURN END DO c----------------------------------------------------------------------- RETURN END itoc.f0000664006604000003110000000363414521201523011277 0ustar sun00315stepsC Last change: BCM 27 Jan 98 10:54 am **==itoc.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE itoc(Inum,Str,Ipos) IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c ----------------------------------------------------------------- CHARACTER digits*(10),Str*(*) INTEGER begchr,d,intval,Inum,Ipos,nchr,nleft DOUBLE PRECISION tmp DATA digits/'0123456789'/ c ----------------------------------------------------------------- nleft=len(Str(Ipos:)) c ----------------------------------------------------------------- begchr=Ipos IF(Inum.lt.0)THEN Str(begchr:begchr)='-' begchr=begchr+1 END IF c ----------------------------------------------------------------- intval=abs(Inum) c ----------------------------------------------------------------- IF(intval.eq.0)THEN nchr=1 c ----------------------------------------------------------------- ELSE tmp=dble(float(intval)) tmp=log10(tmp) tmp=tmp+1D0 nchr=ifix(sngl(tmp))+begchr-Ipos END IF c ----------------------------------------------------------------- IF(nchr.gt.nleft)THEN WRITE(STDERR,*)' Error: Can''t write ',Inum,' in ',len(Str), & ' spaces' CALL errhdr WRITE(Mt2,*)' Error: Can''t write ',Inum,' in ',len(Str), & ' spaces' CALL abend RETURN END IF c ----------------------------------------------------------------- nchr=Ipos-1+nchr DO Ipos=nchr,begchr,-1 d=mod(intval,10)+1 Str(Ipos:Ipos)=digits(d:d) intval=intval/10 END DO Ipos=nchr+1 c ----------------------------------------------------------------- RETURN END itrerr.f0000664006604000003110000000704514521201523011650 0ustar sun00315stepsC Last change: BCM 10 Feb 1999 4:06 pm SUBROUTINE itrerr(Errstr,Lauto,Issap,Irev) IMPLICIT NONE c ------------------------------------------------------------------ c This subroutine prints out an error message if the number of c iterations or function evaluations is too large. c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'units.cmn' INCLUDE 'stdio.i' c ------------------------------------------------------------------ CHARACTER Errstr*(*) LOGICAL Lauto,lparma INTEGER Issap,Irev c ------------------------------------------------------------------ lparma=F IF(.not.Lauto)WRITE(Mt1,1010) WRITE(Mt2,1010) 1010 FORMAT(/, &' **************************************************************** &*******') IF(Issap.eq.2)THEN IF(.not.Lauto)THEN WRITE(STDERR,1020)Errstr WRITE(Mt1,1020)Errstr END IF WRITE(Mt2,1020)Errstr 1020 FORMAT(/,' ERROR: Estimation failed to converge -- maximum ',a, & ' reached',/,' during sliding spans analysis.') ELSE IF(Irev.eq.4)THEN IF(.not.Lauto)THEN WRITE(STDERR,1030)Errstr WRITE(Mt1,1030)Errstr END IF WRITE(Mt2,1030)Errstr 1030 FORMAT(/,' ERROR: Estimation failed to converge -- maximum ',a, & ' reached',/,' during history analysis.') ELSE IF(.not.Lauto)THEN WRITE(STDERR,1040)Errstr WRITE(Mt1,1040)Errstr END IF WRITE(Mt2,1040)Errstr 1040 FORMAT(/,' ERROR: Estimation failed to converge -- maximum ',a, & ' reached.') END IF IF(.not.Lauto.and.Issap.lt.2.and.Irev.lt.4)WRITE(Mt1,1050) 1050 FORMAT(/,' Parameter values and log likelihood at ', & 'last iteration follow.',//) IF(.not.Lauto)WRITE(Mt1,1060) WRITE(Mt2,1060) 1060 FORMAT(' Rerun program trying one of the following:',/, & 10x,'(1) Allow more iterations (set a larger value of ', & 'maxiter).') IF(Lauto)THEN WRITE(Mt2,1070)MDLSEC,PRGNAM,DOCNAM 1070 FORMAT(10x,'(2) Try a different model.',//,1x,'See ',a, & ' of the ',a,' ',a,' for more discussion.') WRITE(Mt2,1010) ELSE IF(Issap.eq.2.or.Irev.eq.4)THEN WRITE(Mt1,1080) WRITE(Mt2,1080) 1080 FORMAT(10x,'(2) Fix the values of the ARMA coefficients to ', & 'those obtained',/,14x, & 'while estimating the full series (set fixmdl=yes)') ELSE WRITE(Mt1,1090)'in the log file' WRITE(Mt2,1090)'below' 1090 FORMAT(10x,'(2) Use initial values for ARMA parameters as ', & 'given ',a,'.') lparma=T END IF WRITE(Mt1,1100)MDLSEC,PRGNAM,DOCNAM WRITE(Mt2,1100)MDLSEC,PRGNAM,DOCNAM 1100 FORMAT(10x,'(3) Try a different model.',//,1x,'See ',a, & ' of the ',a,' ',a,' for more discussion.') c ------------------------------------------------------------------ IF(lparma)THEN WRITE(Mt2,*)' ' CALL prARMA(Mt2) WRITE(Mt2,*)' ' END IF c ------------------------------------------------------------------ WRITE(Mt1,1010) WRITE(Mt2,1010) END IF c ------------------------------------------------------------------ RETURN END kdate.prm0000664006604000003110000000536514521201524012006 0ustar sun00315steps INTEGER kdate DIMENSION kdate(200,3) c----------------------------------------------------------------------- c The date of Easter = March 22 + kdate(year,1) c for year = 1901 to 2100, inclusive c----------------------------------------------------------------------- DATA(kdate(i,1),i=1,50)/16,8,21,12,32,24,9,28,20,5,25,16,1,21,13, & 32,17,9,29,13,5,25,10,29,21,13,26,17,9,29,14,5,25,10,30,21,6, & 26,18,2,22,14,34,18,10,30,15,6,26,18/ DATA(kdate(i,1),i=51,100)/3,22,14,27,19,10,30,15,7,26,11,31,23,7, & 27,19,4,23,15,7,20,11,31,23,8,27,19,4,24,15,28,20,12,31,16,8, & 28,12,4,24,9,28,20,12,25,16,8,21,13,32/ DATA(kdate(i,1),i=101,150)/24,9,29,20,5,25,17,1,21,13,33,17,9,29, & 14,5,25,10,30,21,13,26,18,9,29,14,6,25,10,30,22,6,26,18,3,22, & 14,34,19,10,30,15,7,26,18,3,23,14,27,19/ DATA(kdate(i,1),i=151,200)/11,30,15,7,27,11,31,23,8,27,19,4,24,15, & 7,20,12,31,23,8,28,19,4,24,16,28,20,12,32,16,8,28,13,4,24,9, & 29,20,12,25,17,8,21,13,33,24,9,29,21,6/ c----------------------------------------------------------------------- c The date of Labor Day = August 31 + kdate(year,2) c for year = 1901 to 2100, inclusive c----------------------------------------------------------------------- DATA(kdate(i,2),i=1,50)/2,1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5, & 4,3,1,7,6,5,3,2,1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4/ DATA(kdate(i,2),i=51,100)/3,1,7,6,5,3,2,1,7,5,4,3,2,7,6,5,4,2,1,7, & 6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2,7,6,5,4,2,1,7,6,4/ DATA(kdate(i,2),i=101,150)/3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2, & 7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2,7,6, & 5/ DATA(kdate(i,2),i=151,200)/4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2, & 1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7, & 5/ c----------------------------------------------------------------------- c The date of Thanksgiving = November 21 + kdate(year,3) c for year = 1901 to 2100, inclusive c----------------------------------------------------------------------- DATA(kdate(i,3),i=1,50)/7,6,5,3,2,1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3, & 2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2,0,-1,5,4,2,1,7,6,4,3,2/ DATA(kdate(i,3),i=51,100)/1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2,7,6,5, & 4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4,3,2,7,6,5,4,2/ DATA(kdate(i,3),i=101,150)/1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7, & 5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5,3,2,1,7,5,4, & 3/ DATA(kdate(i,3),i=151,200)/2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7, & 6,5,3,2,1,7,5,4,3,2,7,6,5,4,2,1,7,6,4,3,2,1,6,5,4,3,1,7,6,5, & 3/ kfcn.f0000664006604000003110000001071414521201524011260 0ustar sun00315stepsC Last change: BCM 24 Nov 97 12:48 pm SUBROUTINE kfcn(Begdat,Nrxy,Xdev,Xelong) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine computes a function that removes the easter mean c effect from combined calendar runs. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- CHARACTER icoltl*(PCOLCR) LOGICAL Xelong INTEGER Begdat,ndays,predat,Nrxy,i,ipos,Xdev,irow,ctoi,nchr,ir2,m, & mnindx,idate DOUBLE PRECISION xemean,lmeans,tmeans DIMENSION Begdat(2),predat(2),idate(2),xemean(PSP),lmeans(25,8:9), & tmeans(25,11:12) EXTERNAL ctoi c----------------------------------------------------------------------- DATA(lmeans(i,8),i=1,25)/ & .8800D0,.8750D0,.8696D0,.8636D0,.8571D0,.8500D0,.8421D0,.8333D0, & .8235D0,.8125D0,.8000D0,.7857D0,.7692D0,.7500D0,.7273D0,.7000D0, & .6667D0,.6250D0,.5714D0,.5000D0,.4286D0,.3571D0,.2857D0,.2143D0, & .1429D0/ DATA(lmeans(i,9),i=1,25)/ & .1200D0,.1250D0,.1304D0,.1364D0,.1429D0,.1500D0,.1579D0,.1667D0, & .1765D0,.1875D0,.2000D0,.2143D0,.2308D0,.2500D0,.2727D0,.3000D0, & .3333D0,.3750D0,.4286D0,.5000D0,.5714D0,.6429D0,.7143D0,.7857D0, & .8571D0/ DATA(tmeans(i,11),i=1,25)/ & .4884D0,.4773D0,.4656D0,.4534D0,.4406D0,.4273D0,.4132D0,.3985D0, & .3830D0,.3667D0,.3494D0,.3313D0,.3120D0,.2917D0,.2700D0,.2471D0, & .2226D0,.1684D0,.1384D0,.1062D0,.0776D0,.0530D0,.0326D0,.0167D0, & .0057D0/ DATA(tmeans(i,12),i=1,25)/ & .5116D0,.5227D0,.5344D0,.5466D0,.5594D0,.5727D0,.5868D0,.6015D0, & .6170D0,.6333D0,.6506D0,.6687D0,.6880D0,.7083D0,.7300D0,.7529D0, & .7774D0,.8316D0,.8616D0,.8938D0,.9224D0,.9470D0,.9674D0,.9833D0, & .9943D0/ c----------------------------------------------------------------------- DO i=1,Nb IF(Rgvrtp(i).eq.PRGTEA.or.Rgvrtp(i).eq.PRGTLD.or. & Rgvrtp(i).eq.PRGTTH)THEN c----------------------------------------------------------------------- c Get holiday window length c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,i,icoltl,nchr) IF(Lfatal)RETURN ipos=index(icoltl(1:nchr),'[')+1 ndays=ctoi(icoltl(1:nchr),ipos) IF(Rgvrtp(i).eq.PRGTEA) & CALL estrmu(Begdat,Nrxy,Sp,ndays,Xelong,xemean,.false.) c----------------------------------------------------------------------- c Set index for holiday means c----------------------------------------------------------------------- mnindx=25-ndays+1 IF(Rgvrtp(i).eq.PRGTTH)THEN mnindx=17+ndays IF(ndays.lt.0)mnindx=mnindx+1 END IF c----------------------------------------------------------------------- c For each observation, compute K c----------------------------------------------------------------------- CALL addate(Begdat,Sp,-1,predat) DO irow=1,Nrxy CALL addate(predat,Sp,irow,idate) Kvec(irow)=1D0 ir2=irow+Xdev-1 m=idate(MO) IF(Rgvrtp(i).eq.PRGTEA.and.Sp.eq.4)THEN c----------------------------------------------------------------------- c Compute K for special case of Quarterly easter adjustment c----------------------------------------------------------------------- IF(m.le.2)Kvec(irow)=(B(i)*xemean(m))*(Daybar/Xnstar(ir2))+ & Kvec(irow) c----------------------------------------------------------------------- ELSE IF(Rgvrtp(i).eq.PRGTEA.and.m.ge.2.and.m.le.4)THEN Kvec(irow)=(B(i)*xemean(m))*(Daybar/Xnstar(ir2))+Kvec(irow) ELSE IF(Rgvrtp(i).eq.PRGTLD.and.(m.eq.8.or.m.eq.9))THEN Kvec(irow)=(B(i)*lmeans(mnindx,m))*(Daybar/Xnstar(ir2))+ & Kvec(irow) ELSE IF(Rgvrtp(i).eq.PRGTTH.and.(m.eq.11.or.m.eq.12))THEN Kvec(irow)=(B(i)*tmeans(mnindx,m))*(Daybar/Xnstar(ir2))+ & Kvec(irow) END IF END IF END DO END IF END DO c----------------------------------------------------------------------- RETURN END kwtest.f0000664006604000003110000000703314521201524011660 0ustar sun00315stepsC Last change: BCM 25 Nov 97 11:48 am **==kwtest.f processed by SPAG 4.03F at 15:12 on 1 Aug 1994 SUBROUTINE kwtest(X,Ib,Ie,Nyr,Lprt) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE APPLIES THE KRUSKAL-WALLIS TEST TO X. THE K-W TEST C --- IS THE NONPARAMETRIC EQUIVALENT OF THE F-TEST. C --- THE ARRAY X IS DESTROYED IN THE CALCULATION PROCEDURE. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'tests.cmn' c----------------------------------------------------------------------- LOGICAL Lprt CHARACTER xb*50 DOUBLE PRECISION ck,X,chisq,xval INTEGER i,Ib,Ie,j,k,kolr,kval,l,n,ndf,ns,Nyr,sp1 DIMENSION X(Ie),ns(PSP),kolr(PSP),k(PLEN) EXTERNAL chisq c----------------------------------------------------------------------- C --- INITIALIZE. c----------------------------------------------------------------------- DO i=1,Nyr kolr(i)=0 ns(i)=0 END DO DO i=Ib,Ie k(i)=i END DO c----------------------------------------------------------------------- C --- RANK THE ARRAY X. c----------------------------------------------------------------------- DO i=Ib,Ie xval=X(i) kval=k(i) DO j=i,Ie IF(xval.gt.X(j))THEN X(i)=X(j) k(i)=k(j) X(j)=xval k(j)=kval xval=X(i) kval=k(i) END IF END DO END DO c----------------------------------------------------------------------- C --- CALCULATE THE COLUMN SUM OF RANKS. c----------------------------------------------------------------------- DO i=Ib,Ie l=k(i)-(k(i)-1)/Nyr*Nyr ns(l)=ns(l)+1 kolr(l)=i-Ib+1+kolr(l) END DO c----------------------------------------------------------------------- C --- CALCULATE THE K-W STATISTIC. c----------------------------------------------------------------------- ck=0D0 DO i=1,Nyr ck=ck+kolr(i)*kolr(i)/dble(ns(i)) END DO n=Ie-Ib+1 Chikw=12D0*ck/(n*(n+1))-3*(n+1) ndf=Nyr-1 P5=chisq(Chikw,ndf)*100D0 IF(.not.Lprt.or.Lhiddn)RETURN sp1=0 IF(Lwdprt)sp1=18 xb=' ' IF(Lcmpaq)THEN WRITE(Mt1,1011) 1011 FORMAT(/,' Nonparametric Test for the Presence of Seasonality ', & 'Assuming Stability') WRITE(Mt1,1021)xb(1:(sp1+11)) 1021 FORMAT(/,a,'Kruskal-Wallis statistic',2x,'Dgrs.freedom',2x, & 'Probability level') WRITE(Mt1,1031)xb(1:(sp1+24)),Chikw,ndf,P5 1031 FORMAT(a,F11.4,6X,I3,7X,F9.3,'%',/) ELSE WRITE(Mt1,1010)xb(1:(sp1+2)) 1010 FORMAT(//,a,'Nonparametric Test for the Presence of Seasonality', & ' Assuming Stability') WRITE(Mt1,1020)xb(1:(sp1+17)),xb(1:(sp1+19)) 1020 FORMAT(/,a,'Kruskal-Wallis',6x,'Degrees of',4x,'Probability',/, & a,'Statistic',8x,'Freedom',9x,'Level') WRITE(Mt1,1030)xb(1:(sp1+18)),Chikw,ndf,P5 1030 FORMAT(/,a,F11.4,9X,I3,8X,F9.3,'%',/) END IF IF(P5.le.1D0)THEN WRITE(Mt1,1040)xb(1:(sp1+12)) 1040 FORMAT(a,'Seasonality present at the one percent level.') RETURN END IF WRITE(Mt1,1050)xb(1:(sp1+12)) 1050 FORMAT(a,'No evidence of seasonality at the one percent level.') RETURN END lassol.f0000664006604000003110000000705314521201524011636 0ustar sun00315steps**==lassol.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE lassol(N,A,B,M,X,Iflag) IMPLICIT NONE c----------------------------------------------------------------------- c lassol solves a system of n linear equations in n unkowns, AX = B, c using gaussian elimination with parital pivoting and row c equilibration. c c taken from NUMERICAL COMPUTING: AN INTRODUCTION by shampine and c allen. adapted by brian monsell, 12-6-88. c----------------------------------------------------------------------- INTEGER i,ib,idxpiv,Iflag,ip1,j,k,kp1,M,N,nm1,np1 DOUBLE PRECISION A(M,M),B(N),X(N),ab(3,4),rowmax,big,quot, & sum,tempb,tempi,scale,one,zero EQUIVALENCE(big,quot,sum,scale),(rowmax,tempb,tempi) DATA one,zero/1.0D0,0D0/ c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- np1=N+1 nm1=N-1 c----------------------------------------------------------------------- c form the n by (n+1) matrix AB, the first n columns of which are c A and the remaining column B. calculate scale factors and scale c AB. c----------------------------------------------------------------------- DO i=1,N rowmax=zero DO j=1,N rowmax=dmax1(rowmax,abs(A(i,j))) END DO scale=one/rowmax DO j=1,N ab(i,j)=A(i,j)*scale END DO ab(i,np1)=B(i)*scale END DO c----------------------------------------------------------------------- c begin basic elimination loop. rows of ab are physically c interchanged in order to bring element of largest magnitude c into pivotal position c----------------------------------------------------------------------- DO k=1,nm1 big=zero DO i=k,N tempb=abs(ab(i,k)) IF(big.lt.tempb)THEN big=tempb idxpiv=i END IF END DO IF(dpeq(big,zero))GO TO 10 IF(idxpiv.ne.k)THEN c----------------------------------------------------------------------- c pivot is in row idxpiv. interchange rouw idxpiv with row k. c----------------------------------------------------------------------- DO i=k,np1 tempi=ab(k,i) ab(k,i)=ab(idxpiv,i) ab(idxpiv,i)=tempi END DO END IF kp1=k+1 c----------------------------------------------------------------------- c eliminate x(k) from equations k+1,k+2,...,k+n. c----------------------------------------------------------------------- DO i=kp1,N quot=ab(i,k)/ab(k,k) DO j=kp1,np1 ab(i,j)=ab(i,j)-(quot*ab(k,j)) END DO END DO END DO c----------------------------------------------------------------------- c begin calculation of solution x using back substitution. c----------------------------------------------------------------------- IF(.not.dpeq(ab(N,N),zero))THEN X(N)=ab(N,np1)/ab(N,N) DO ib=2,N i=np1-ib ip1=i+1 sum=zero DO j=ip1,N sum=sum+ab(i,j)*X(j) END DO X(i)=(ab(i,np1)-sum)/ab(i,i) END DO c----------------------------------------------------------------------- c set iflag = 1 for normal return c = 2 if matrix appears singular to the code. c----------------------------------------------------------------------- Iflag=1 RETURN END IF 10 Iflag=2 RETURN END lendp.f0000664006604000003110000000176014521201524011442 0ustar sun00315stepsC Last change: BCM 29 Sep 97 9:48 am **==lendp.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE lendp(X,Nx,Lenx) IMPLICIT NONE c----------------------------------------------------------------------- c Finds how many values have been input into x by finding the first c dnotst value working back through the array. Array must be initialized c with notset values (dnotst for double precision) using a c call setdp(dnotst,nx,x) call. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INTEGER Nx,Lenx DOUBLE PRECISION X(*) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ DO Lenx=Nx,1,-1 IF(.not.dpeq(X(Lenx),DNOTST))GO TO 10 END DO c ------------------------------------------------------------------ 10 RETURN END level.prm0000664006604000003110000000062214521201524012014 0ustar sun00315stepsc----------------------------------------------------------------------- c level - logical variable which defines those tables to be printed c for an X-13 run when a specific print level (none,brief, c default,alltables,all) is specified c----------------------------------------------------------------------- LOGICAL level DIMENSION level(NTBL,NLVL) level.var0000664006604000003110000001316514521201526012016 0ustar sun00315stepscLast change-Mar 2021:change level(i,4) the several last element to T c----------------------------------------------------------------------- c level - logical variable which defines those tables to be printed c for an X-13 run when a specific print level (none,brief, c default,alltables,all) is specified c----------------------------------------------------------------------- DATA(level(i,1),i=1,NTBL)/ & T,T,F,T,T,T,F,F,T,F, T,F,T,F,F,F,F,F,F,F, T,F,T,T,T,T,T,T,T,T, & T,T,T,T,F,T,T,T,T,F, T,T,T,F,F,F,F,F,F,F, F,F,T,T,T,T,T,T,F,F, & T,F,T,F,T,F,F,F,F,F, T,T,F,F,T,F,T,T,F,F, T,T,T,T,T,T,T,T,F,T, & F,F,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,T,f,F,F,F,T, F,F,F,F,T,F,F,T,T,T, & F,F,F,T,F,F,T,T,T,T, T,F,F,T,T,F,T,F,F,F, F,F,T,T,F,F,T,F,F,T, & T,T,T,T,T,T,T,F,F,F, F,F,T,F,T,F,F,T,F,F, F,F,F,F,F,F,F,F,T,T, & T,F,T,F,T,T,T,T,F,T, F,T,F,T,F,T,F,T,F,T, F,T,T,F,F,F,F,F,T,T, & T,F,T,T,F,T,T,F,T,T, F,T,T,F,T,T,F,T,T,F, T,T,F,T,F,T,T,T,F,T, & T,T,T,F,F,T,T,F,F,F, F,F,F,F,F,F,F,F,T,F, T,F,F,F,T,T,T,T,T,T, & T,T,T,T,T,F,F,F,T,F, T,F,T,F,T,F,T,F,T,F, F,F,F,F,F,F,F,F,T,T, & T,T,F,F,F,F,F,F,F,F, T,T,T,T,T,T,T,T,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F/ c----------------------------------------------------------------------- DATA(level(i,2),i=1,NTBL)/ & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F/ c----------------------------------------------------------------------- DATA(level(i,3),i=1,NTBL)/ & T,T,F,T,T,T,F,F,T,F, T,F,T,F,F,F,F,F,F,F, T,F,T,T,T,T,T,T,T,T, & T,T,T,T,F,T,F,T,F,F, T,T,T,F,F,F,F,F,F,F, F,F,T,T,T,T,T,F,F,F, & T,F,T,F,T,F,F,F,F,F, F,F,F,F,T,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,T,T,T,T, T,F,F,T,T,F,F,F,F,F, F,F,F,F,F,F,F,F,F,T, & T,T,T,T,T,F,F,F,F,F, F,F,F,F,F,F,F,T,F,F, F,F,F,F,F,F,F,F,T,T, & F,F,F,F,F,F,T,T,F,F, F,F,F,T,F,T,F,T,F,T, F,T,F,F,F,F,F,F,T,T, & T,F,F,T,F,F,T,F,F,T, F,F,T,F,F,T,F,F,T,F, T,T,F,T,F,T,T,T,F,F, & T,T,T,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,T,F, T,F,F,F,T,T,F,F,T,T, & T,T,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & T,T,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,T,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F/ c----------------------------------------------------------------------- DATA(level(i,4),i=1,NTBL)/ & T,T,F,T,T,T,T,T,T,F, T,F,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,F,T,F,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,F,T,F, T,F,F,T,T,T,T,T,T,T, & T,T,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,F,F, F,F,F,F,F,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,F,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,F,F,F,F,F,F,F,F, T,T,T,T,T,T,T,T,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,T,T,T,T,F,F,F, & F,F,F,T,F,F/ c----------------------------------------------------------------------- DATA(level(i,5),i=1,NTBL)/ & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,T,T,T,T,T,T,T,T, & T,T,T,T,T,T/ lex.f0000664006604000003110000000375114521201526011134 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:20 pm **==lex.f processed by SPAG 4.03F at 09:50 on 1 Mar 1994 SUBROUTINE lex() IMPLICIT NONE c----------------------------------------------------------------------- c Lex returns the token in Nxtktp, its length in Nxtkln, and its c type in Nxtktp. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'cchars.i' c ------------------------------------------------------------------ LOGICAL alsoin,qcmmnt,qdoble,qname,qquote INTEGER whitsp EXTERNAL qcmmnt,qdoble,qname,qquote,whitsp c ------------------------------------------------------------------ DO WHILE (whitsp().ne.EOF) IF(qcmmnt(Nxttok,Nxtkln))THEN Nxtktp=COMMNT c ------------------------------------------------------------------ ELSE IF(qquote(Nxttok,Nxtkln))THEN Nxtktp=QUOTE c ------------------------------------------------------------------ ELSE IF(qname(Nxttok,Nxtkln))THEN Nxtktp=NAME c ------------------------------------------------------------------ ELSE IF(qdoble(Nxttok,Nxtkln,alsoin))THEN IF(alsoin)THEN Nxtktp=INTGR c ------------------------------------------------------------------ ELSE Nxtktp=DBL END IF ELSE CALL qtoken() END IF c ------------------------------------------------------------------ IF(Nxtktp.ne.COMMNT)GO TO 10 END DO c ------------------------------------------------------------------ Nxtktp=EOF Nxttok(1:1)=CHREOF Nxtkln=1 c ------------------------------------------------------------------ 10 CALL cpyint(Lstpos,2,1,Errpos) Lstpos(PLINE)=Pos(PLINE) Lstpos(PCHAR)=Pos(PCHAR)-Nxtkln IF(Nxtktp.eq.QUOTE)Lstpos(PCHAR)=Lstpos(PCHAR)-2 c ------------------------------------------------------------------ RETURN END lex.i0000664006604000003110000000555614521201526011144 0ustar sun00315stepsc----------------------------------------------------------------------- c lex.i, Release 1, Parm File Version 1.3, Modified 03 Feb 1995. c----------------------------------------------------------------------- c BIGA c p Uppercase A c BIGZ c p Uppercase Z c CNINE c p The character 9 c CZERO c p The character 0 c dmychr c l Dummy character variable c dmydbl d l Dummy double precision number c dmyint i l Dummy integer c EOF i c End-of-file c Input i c Input channel number This should remain constant c unless the channel is initialized c Line c c Linlen long string of the current input line c Lineln i c Length of the current line, <=LINLEN+1 including c NEWLIN c Lineno i c Line number of the current input line c LITTLA c p Lower case a c LITTLZ c p Lower case z c LINLEN i c Parameter for the maximum length of the current line c NEWLIN c p ASCII character for a new line c Pos i c Position of the pointer on the current line c NAME c p Code for token type variable name c QUOTE c p Code for token type quoted string c INTGR c p Code for integer token type c DBL c p Code for double precision token type c TAB c p ASCII code for horizontal tab c---------------------------------------------------------------------- INTEGER PERROR,PWARN,PERRNP,PWRNNP PARAMETER(PERROR=1,PWARN=2,PERRNP=3,PWRNNP=4) c---------------------------------------------------------------------- CHARACTER*1 BIGA,BIGZ,CNINE,CZERO,LITTLA,LITTLZ CHARACTER DIGITS*10,LCASE*26,UCASE*26 INTEGER LINLEN,PBUFSZ,PCHAR,PLINE PARAMETER (BIGA='A',BIGZ='Z',CNINE='9',CZERO='0', & LITTLA='a',LITTLZ='z') PARAMETER(LINLEN=133,PBUFSZ=3,PCHAR=2,PLINE=1) C ------------------------------------------------------------------ PARAMETER(DIGITS='0123456789', & LCASE='abcdefghijklmnopqrstuvwxyz', & UCASE='ABCDEFGHIJKLMNOPQRSTUVWXYZ') c ----------------------------------------------------------------- INTEGER BADTOK,COMMA,COMMNT,NAME,QUOTE,INTGR,DBL,LBRACE,RBRACE, & LPAREN,RPAREN,LBRAKT,RBRAKT,NULL,PERIOD,PLUS,MINUS, & EQUALS,EOF,SLASH,STAR,COLON,BSLASH PARAMETER(COMMA=12,COMMNT=35,NAME=31,QUOTE=34,INTGR=48,DBL=101, & LBRACE=123,RBRACE=125,LPAREN=40,RPAREN=41,LBRAKT=91, & RBRAKT=93,NULL=0,PERIOD=46,PLUS=43,MINUS=45,EQUALS=61, & EOF=26,BADTOK=21,SLASH=47,STAR=42,COLON=58,BSLASH=92) C C COMMON variables C c INCLUDE 'cchars.i' LOGICAL Lexok CHARACTER Linex*(LINLEN+1),Nxttok*(LINLEN) INTEGER Errpos(2),Inputx,Lineln,Lineno,Lstpos(2),Nxtkln,Nxtktp, & Pos(2) COMMON /clex / Pos,Lineln,Lineno,Inputx,Errpos, & Lstpos,Nxtkln,Nxtktp,Lexok,Linex,Nxttok lgnrmc.f0000664006604000003110000000210114521201526011612 0ustar sun00315steps SUBROUTINE lgnrmc(Nfcst,Fctunc,Fctse,Fctcor,Ltrans) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to perform lognormal correction of forcasts/backcasts c Ltrans controls if forecast is to be transformed to original scale c----------------------------------------------------------------------- DOUBLE PRECISION PT5 PARAMETER(PT5=0.5D0) c----------------------------------------------------------------------- INTEGER i,Nfcst DOUBLE PRECISION Fctunc(*),Fctse(*),Fctcor(*),corfac LOGICAL Ltrans c ------------------------------------------------------------------ c Compute correction factor c ------------------------------------------------------------------ DO i=1,Nfcst corfac=Fctse(i)*Fctse(i)*PT5 IF(Ltrans)THEN Fctcor(i)=DEXP(corfac+Fctunc(i)) ELSE Fctcor(i)=corfac+Fctunc(i) END IF END DO c ------------------------------------------------------------------ RETURN END lkhd.cmn0000664006604000003110000000057714521201526011621 0ustar sun00315stepsc----------------------------------------------------------------------- c Allow aicc, bic and likelihood to be passed to other routines c BCM - January 1994, revised November 2000 c----------------------------------------------------------------------- DOUBLE PRECISION Aic,Aicc,Bic,Bic2,Hnquin,Olkhd,Eic COMMON /lkhd / Aic,Aicc,Bic,Bic2,Hnquin,Olkhd,Eic lkshnk.f0000664006604000003110000000203414521201526011627 0ustar sun00315stepsC Last change: BCM 6 May 2003 10:28 am DOUBLE PRECISION FUNCTION lkshnk(S1,S2,Sig) IMPLICIT NONE C----------------------------------------------------------------------- c Compute estimator of likelihood associated with S1 given that the c true mean is S2, with variance estimated by Sig. c This is used in the "local" method of generating shrinkage c estimates developed in the paper "Shrinkage Est. of Time Series c Seasonal Factors and their Effect on Forecasting Accuracy", c Miller & Williams (2003) C----------------------------------------------------------------------- DOUBLE PRECISION PI,ONE,TWO,MONE PARAMETER(PI=3.14159265358979D0,ONE=1D0,TWO=2D0,MONE=-1D0) C----------------------------------------------------------------------- DOUBLE PRECISION S1,S2,Sig C----------------------------------------------------------------------- lkshnk = (ONE/dsqrt(Sig*TWO*PI))* & dexp((MONE/TWO)*(((S1-S2)*(S1-S2))/Sig)) RETURN END lmdif.f0000664006604000003110000004571114521201526011441 0ustar sun00315stepsC Last change: BCM 29 Sep 97 8:55 am c----------------------------------------------------------------------- c lmdif.f, Release 1, Subroutine Version 1.9, Modified 17 Feb 1995. c----------------------------------------------------------------------- C C SUBROUTINE LMDIF C C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MXiter,EPSFCN, C DIAG,MODE,FACTOR,NPRINT,INFO,nliter,NFEV,FJAC, C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. c lckinv is added to constrain the estimation inside the c invertibility and stationarity regions. C C SUBROUTINE FCN(M,N,X,FVEC,IFLAG,lchkinv) C INTEGER M,N,IFLAG C DOUBLE PRECISION X(N),FVEC(M) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C ---------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF VARIABLES. N MUST NOT EXCEED M. C C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. C C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS C THE FUNCTIONS EVALUATED AT THE OUTPUT X. C C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED C IN THE SUM OF SQUARES. C C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. C C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS C OF THE JACOBIAN. C C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST C MAXFEV BY THE END OF AN ITERATION. Is equal to C max(Mxiter,200)*(n+1). C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. C C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. C C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. C C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS C OF FCN WITH IFLAG = 0 ARE MADE. C C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, C INFO IS SET AS FOLLOWS. C C INFO = 0 IMPROPER INPUT PARAMETERS. C C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS C IN THE SUM OF SQUARES ARE AT MOST FTOL. C C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES C IS AT MOST XTOL. C C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. C C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN C ABSOLUTE VALUE. C C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR C EXCEEDED MAXFEV or mxiter iterations have been c reached. C C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN C THE SUM OF SQUARES IS POSSIBLE. C C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN C THE APPROXIMATE SOLUTION X IS POSSIBLE. C C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. C C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF C cumulative function evaluations. C C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT C C T T T C P *(JAC *JAC)*P = R *R, C C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL C PART OF FJAC CONTAINS INFORMATION GENERATED DURING C THE COMPUTATION OF R. C C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. C C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. C C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. C C WA4 IS A WORK ARRAY OF LENGTH M. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC C C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** SUBROUTINE lmdif(fcn,M,N,X,Fvec,Lauto,Gudrun,Ftol,Xtol,Gtol, & Mxiter,Epsfcn,Diag,Mode,Factor,Nprint,Info, & Nliter,Nfev,Fjac,Ldfjac,Ipvt,Qtf,Wa1,Wa2,Wa3, & Wa4) IMPLICIT NONE INCLUDE 'error.cmn' INTEGER begitr,Nliter,Mxiter,oldfev INTEGER M,N,maxfev,Mode,Nprint,Info,Nfev,Ldfjac INTEGER Ipvt(N) LOGICAL Lauto,Gudrun,T,F,dpeq DOUBLE PRECISION Ftol,Xtol,Gtol,Epsfcn,Factor DOUBLE PRECISION X(N),Fvec(M),Diag(N),Fjac(Ldfjac,N),Qtf(N),Wa1(N) & ,Wa2(N),Wa3(N),Wa4(M) EXTERNAL fcn,dpeq INTEGER i,iflag,j,l DOUBLE PRECISION actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, & ONE,par,pnorm,prered,P1,P5,P25,P75,P0001,ratio, & sum,temp,temp1,temp2,xnorm,MONE,ZERO DOUBLE PRECISION dpmpar,enorm PARAMETER(ONE=1.0D0,P1=.1D0,P5=.5D0,P25=.25D0,P75=.75D0, & P0001=.0001D0,MONE=-1.0D0,ZERO=0.0D0,T=.true.,F=.false.) C C EPSMCH IS THE MACHINE PRECISION. C epsmch=dpmpar(1) C Info=0 iflag=0 c NFEV=0 oldfev=Nfev C C CHECK THE INPUT PARAMETERS FOR ERRORS. C IF(N.gt.0.and.M.ge.N.and.Ldfjac.ge.M.and.Ftol.ge.ZERO.and. & Xtol.ge.ZERO.and.Gtol.ge.ZERO.and.Mxiter.ge.0.and. & Factor.gt.ZERO)THEN c c Set the maximum number of function calls c maxfev=max(Mxiter,200)*(N+1) c IF(Mode.eq.2)THEN DO j=1,N IF(Diag(j).le.ZERO)GO TO 20 END DO END IF C C EVALUATE THE FUNCTION AT THE STARTING POINT C AND CALCULATE ITS NORM. C iflag=1 CALL fcn(M,N,X,Fvec,Lauto,Gudrun,iflag,F) c NFEV=1 Nfev=Nfev+1 IF(iflag.ge.0)THEN fnorm=enorm(M,Fvec) C C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. C begitr=Nliter par=ZERO DO WHILE (T) C C BEGINNING OF THE OUTER LOOP. C C C CALCULATE THE JACOBIAN MATRIX. C iflag=2 CALL fdjac2(fcn,M,N,X,Fvec,Lauto,Gudrun,Fjac,Ldfjac,iflag, & Epsfcn,Wa4,F) Nfev=Nfev+N c----------------------------------------------------------------------- c Update the parameters in the kalman filter routine to match the c original parameter estimates, not the last displacement in the c jacobian calculation. c----------------------------------------------------------------------- CALL upespm(X) c ------------------------------------------------------------------ IF(iflag.lt.0)GO TO 20 C C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. C IF(Nprint.gt.0.and.Nliter.gt.begitr)THEN CALL prtitr(Fvec,M,X,N,'ARMA ',Nliter,Nfev) IF(Lfatal)RETURN END IF C C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. C CALL qrfac(M,N,Fjac,Ldfjac,T,Ipvt,N,Wa1,Wa2,Wa3) C C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. C IF(Nliter.eq.begitr)THEN IF(Mode.ne.2)THEN DO j=1,N Diag(j)=Wa2(j) IF(dpeq(Wa2(j),ZERO))Diag(j)=ONE END DO END IF C C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X C AND INITIALIZE THE STEP BOUND DELTA. C DO j=1,N Wa3(j)=Diag(j)*X(j) END DO xnorm=enorm(N,Wa3) delta=Factor*xnorm IF(dpeq(delta,ZERO))delta=Factor END IF C C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN C QTF. C DO i=1,M Wa4(i)=Fvec(i) END DO DO j=1,N IF(.not.dpeq(Fjac(j,j),ZERO))THEN sum=ZERO DO i=j,M sum=sum+Fjac(i,j)*Wa4(i) END DO temp=-sum/Fjac(j,j) DO i=j,M Wa4(i)=Wa4(i)+Fjac(i,j)*temp END DO END IF Fjac(j,j)=Wa1(j) Qtf(j)=Wa4(j) END DO C C COMPUTE THE NORM OF THE SCALED GRADIENT. C gnorm=ZERO IF(.not.dpeq(fnorm,ZERO))THEN DO j=1,N l=Ipvt(j) IF(.not.dpeq(Wa2(l),ZERO))THEN sum=ZERO DO i=1,j sum=sum+Fjac(i,j)*(Qtf(i)/fnorm) END DO gnorm=dmax1(gnorm,dabs(sum/Wa2(l))) END IF END DO END IF C C TEST FOR CONVERGENCE OF THE GRADIENT NORM. C IF(gnorm.le.Gtol)Info=4 * write(ng,9004)' within lmdif (4):',gnorm,Gtol IF(Info.ne.0)GO TO 20 C C RESCALE IF NECESSARY. C IF(Mode.ne.2)THEN DO j=1,N Diag(j)=dmax1(Diag(j),Wa2(j)) END DO END IF DO WHILE (T) C C BEGINNING OF THE INNER LOOP. C C C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. C CALL lmpar(N,Fjac,Ldfjac,Ipvt,Diag,Qtf,delta,par,Wa1,Wa2,Wa3, & Wa4) C C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. C DO j=1,N Wa1(j)=-Wa1(j) Wa2(j)=X(j)+Wa1(j) Wa3(j)=Diag(j)*Wa1(j) END DO pnorm=enorm(N,Wa3) C C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. C IF(Nliter.eq.begitr)delta=dmin1(delta,pnorm) C C EVALUATE THE FUNCTION AT X+P AND CALCULATE ITS NORM. C iflag=1 CALL fcn(M,N,Wa2,Wa4,Lauto,Gudrun,iflag,T) Nfev=Nfev+1 IF(iflag.lt.0)GO TO 20 fnorm1=enorm(M,Wa4) C C COMPUTE THE SCALED ACTUAL REDUCTION. C actred=MONE IF(P1*fnorm1.lt.fnorm)actred=ONE-(fnorm1/fnorm)**2 C C COMPUTE THE SCALED PREDICTED REDUCTION AND C THE SCALED DIRECTIONAL DERIVATIVE. C DO j=1,N Wa3(j)=ZERO l=Ipvt(j) temp=Wa1(l) DO i=1,j Wa3(i)=Wa3(i)+Fjac(i,j)*temp END DO END DO temp1=enorm(N,Wa3)/fnorm temp2=(dsqrt(par)*pnorm)/fnorm prered=temp1**2+temp2**2/P5 dirder=-(temp1**2+temp2**2) C C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED C REDUCTION. C ratio=ZERO IF(.not.dpeq(prered,ZERO))ratio=actred/prered C C UPDATE THE STEP BOUND. C IF(ratio.le.P25)THEN IF(actred.ge.ZERO)temp=P5 IF(actred.lt.ZERO)temp=P5*dirder/(dirder+P5*actred) IF(P1*fnorm1.ge.fnorm.or.temp.lt.P1)temp=P1 delta=temp*dmin1(delta,pnorm/P1) par=par/temp ELSE IF(dpeq(par,ZERO).or.ratio.ge.P75)THEN delta=pnorm/P5 par=P5*par END IF C C TEST FOR SUCCESSFUL ITERATION. C IF(ratio.ge.P0001)THEN C C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. C DO j=1,N X(j)=Wa2(j) Wa2(j)=Diag(j)*X(j) END DO DO i=1,M Fvec(i)=Wa4(i) END DO xnorm=enorm(N,Wa2) fnorm=fnorm1 Nliter=Nliter+1 c----------------------------------------------------------------------- c Update the parameters in the kalman filter routine to match the c original parameter estimates before the unsuccessful step was taken. c----------------------------------------------------------------------- ELSE CALL upespm(X) END IF C C TESTS FOR CONVERGENCE. C IF(dabs(actred).le.Ftol.and.prered.le.Ftol.and. & P5*ratio.le.ONE)Info=1 * write(ng,9001)' within lmdif (1):',dabs(actred),Ftol,prered, * & Ftol,P5,ratio,ONE IF(delta.le.Xtol*xnorm)Info=2 * write(ng,9002)' within lmdif (2):',delta,Xtol,xnorm IF(dabs(actred).le.Ftol.and.prered.le.Ftol.and. & P5*ratio.le.ONE.and.Info.eq.2)Info=3 IF(Info.ne.0)GO TO 20 C C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. C IF(Mxiter.gt.0.and.Nliter.ge.Mxiter)Info=5 * write(ng,9005)' within lmdif (5a):',Mxiter,Nliter IF(Nfev-oldfev.ge.maxfev)Info=5 * write(ng,9006)' within lmdif (5b):',Nfev,oldfev,maxfev IF(dabs(actred).le.epsmch.and.prered.le.epsmch.and. & P5*ratio.le.ONE)Info=6 * write(ng,9007)' within lmdif (6):',dabs(actred),epsmch, * & prered,epsmch,P5,ratio,ONE IF(delta.le.epsmch*xnorm)Info=7 * write(ng,9008)' within lmdif (7):',delta,epsmch,xnorm IF(gnorm.le.epsmch)Info=8 * write(ng,9009)' within lmdif (8):',gnorm,epsmch * write(ng,9000) * write(ng,8000)Nliter,dabs(actred),prered,Ftol IF(Info.ne.0)GO TO 20 C C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. C IF(ratio.ge.P0001)GO TO 10 END DO C C END OF THE OUTER LOOP. C 10 CONTINUE END DO END IF END IF C C TERMINATION, EITHER NORMAL OR USER IMPOSED. C 20 IF(iflag.lt.0)Info=iflag iflag=0 c----------------------------------------------------------------------- c Print out the final parameter estimates if the estimation has gone c through at least one iteration and the last was successful. c----------------------------------------------------------------------- IF(Nprint.gt.0.and.Nliter.gt.begitr.and.ratio.ge.P0001) & CALL prtitr(Fvec,M,X,N,'ARMA',Nliter,Nfev) c ------------------------------------------------------------------ RETURN C C LAST CARD OF SUBROUTINE LMDIF. C * 9000 FORMAT(' -----') * 9001 FORMAT(a,' dabs(actred).le.Ftol - dabs(actred) = ',e18.12, * & ' Ftol = ',e18.12,' - ',/, * & 20x,'.and.prered.le.Ftol - prered = ',e18.12, * & ' Ftol = ',e18.12,' - ',/, * & 20x,' .and.P5*ratio.le.ONE - P5 = ',e18.12, * & ' ratio = ',e18.12,' ONE = ',e18.12) * 9002 FORMAT(a,' delta.le.Xtol*xnorm - delta = ',e18.12, * & ' Xtol = ',e18.12,' xnorm = ',e18.12) * 9004 FORMAT(a,' gnorm.le.Gtol - gnorm = ',e18.12,' Gtol = ',e18.12) * 9005 FORMAT(a,' Mxiter.gt.0.and.Nliter.ge.Mxiter - Mxiter = ',i10, * & ' Nliter = ',i10) * 9006 FORMAT(a,' Nfev-oldfev.ge.maxfev - Nfev = ',i10,' oldfev = ', * & i10,' maxfev = ',i10) * 9007 FORMAT(a,' dabs(actred).le.epsmch - dabs(actred) = ',e18.12, * & ' epsmch = ',e18.12,' - ',/, * & 20x,'.and.prered.le.epsmch.and. - prered = ',e18.12, * & ' epsmch = ',e18.12,' - ',/, * & 20x,' .and.P5*ratio.le.ONE - P5 = ',e18.12, * & ' ratio = ',e18.12,' ONE = ',e18.12) * 9008 FORMAT(a,' delta.le.epsmch*xnorm - delta = ',e18.12,' epsmch = ', * & e18.12,' xnorm = ',e18.12) * 9009 FORMAT(a,' gnorm.le.epsmch - gnorm = ',e18.12,' epsmch = ', * & e18.12) * 8000 FORMAT(i10,3(2x,e18.12)) END lmpar.f0000664006604000003110000001774514521201526011467 0ustar sun00315stepsC Last change: BCM 29 Sep 97 10:29 am **==lmpar.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE lmpar(N,R,Ldr,Ipvt,Diag,Qtb,Delta,Par,X,Sdiag,Wa1,Wa2) IMPLICIT NONE INTEGER N,Ldr INTEGER Ipvt(N) DOUBLE PRECISION Delta,Par DOUBLE PRECISION R(Ldr,N),Diag(N),Qtb(N),X(N),Sdiag(N),Wa1(N), & Wa2(N) C ********** C C SUBROUTINE LMPAR C C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER C PAR SUCH THAT IF X SOLVES THE SYSTEM C C A*X = B , SQRT(PAR)*D*X = 0 , C C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN C NORM OF D*X, THEN EITHER PAR IS ZERO AND C C (DXNORM-DELTA) .LE. 0.1*DELTA , C C OR PAR IS POSITIVE AND C C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . C C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT C C T T T C P *(A *A + PAR*D*D)*P = S *S . C C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. C C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST C VALUE OBTAINED SO FAR. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, C WA1,WA2) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. C C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. C C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. C C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE C DIAGONAL ELEMENTS OF THE MATRIX D. C C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. C C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER C BOUND ON THE EUCLIDEAN NORM OF D*X. C C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. C C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, C FOR THE OUTPUT PAR. C C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. C C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... DPMPAR,ENORM,QRSOLV C C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** LOGICAL dpeq INTEGER i,iter,j,jm1,jp1,k,l,nsing DOUBLE PRECISION dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001,sum, & temp,zero DOUBLE PRECISION dpmpar,enorm DATA p1,p001,zero/1.0D-1,1.0D-3,0.0D0/ EXTERNAL dpeq C C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. C dwarf=dpmpar(2) C C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. C nsing=N DO j=1,N Wa1(j)=Qtb(j) IF(dpeq(R(j,j),zero).and.nsing.eq.N)nsing=j-1 IF(nsing.lt.N)Wa1(j)=zero END DO IF(nsing.ge.1)THEN DO k=1,nsing j=nsing-k+1 Wa1(j)=Wa1(j)/R(j,j) temp=Wa1(j) jm1=j-1 IF(jm1.ge.1)THEN DO i=1,jm1 Wa1(i)=Wa1(i)-R(i,j)*temp END DO END IF END DO END IF DO j=1,N l=Ipvt(j) X(l)=Wa1(j) END DO C C INITIALIZE THE ITERATION COUNTER. C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. C iter=0 DO j=1,N Wa2(j)=Diag(j)*X(j) END DO dxnorm=enorm(N,Wa2) fp=dxnorm-Delta IF(fp.gt.p1*Delta)THEN C C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. C parl=zero IF(nsing.ge.N)THEN DO j=1,N l=Ipvt(j) Wa1(j)=Diag(l)*(Wa2(l)/dxnorm) END DO DO j=1,N sum=zero jm1=j-1 IF(jm1.ge.1)THEN DO i=1,jm1 sum=sum+R(i,j)*Wa1(i) END DO END IF Wa1(j)=(Wa1(j)-sum)/R(j,j) END DO temp=enorm(N,Wa1) parl=((fp/Delta)/temp)/temp END IF C C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. C DO j=1,N sum=zero DO i=1,j sum=sum+R(i,j)*Qtb(i) END DO l=Ipvt(j) Wa1(j)=sum/Diag(l) END DO gnorm=enorm(N,Wa1) paru=gnorm/Delta IF(dpeq(paru,zero))paru=dwarf/dmin1(Delta,p1) C C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), C SET PAR TO THE CLOSER ENDPOINT. C Par=dmax1(Par,parl) Par=dmin1(Par,paru) IF(dpeq(Par,zero))Par=gnorm/dxnorm DO WHILE (.true.) C C BEGINNING OF AN ITERATION. C iter=iter+1 C C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. C IF(dpeq(Par,zero))Par=dmax1(dwarf,p001*paru) temp=dsqrt(Par) DO j=1,N Wa1(j)=temp*Diag(j) END DO CALL qrsolv(N,R,Ldr,Ipvt,Wa1,Qtb,X,Sdiag,Wa2) DO j=1,N Wa2(j)=Diag(j)*X(j) END DO dxnorm=enorm(N,Wa2) temp=fp fp=dxnorm-Delta C C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. C IF(dabs(fp).le.p1*Delta.or.dpeq(parl,zero).and.fp.le.temp.and. & temp.lt.zero.or.iter.eq.10)GO TO 10 C C COMPUTE THE NEWTON CORRECTION. C DO j=1,N l=Ipvt(j) Wa1(j)=Diag(l)*(Wa2(l)/dxnorm) END DO DO j=1,N Wa1(j)=Wa1(j)/Sdiag(j) temp=Wa1(j) jp1=j+1 IF(N.ge.jp1)THEN DO i=jp1,N Wa1(i)=Wa1(i)-R(i,j)*temp END DO END IF END DO temp=enorm(N,Wa1) parc=((fp/Delta)/temp)/temp C C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. C IF(fp.gt.zero)parl=dmax1(parl,Par) IF(fp.lt.zero)paru=dmin1(paru,Par) C C COMPUTE AN IMPROVED ESTIMATE FOR PAR. C C C END OF AN ITERATION. C Par=dmax1(parl,Par+parc) END DO END IF C C TERMINATION. C 10 IF(iter.eq.0)Par=zero RETURN C C LAST CARD OF SUBROUTINE LMPAR. C END loadxr.f0000664006604000003110000000703614521201526011635 0ustar sun00315stepsC Last change: BCM 2 Dec 1998 11:20 am SUBROUTINE loadxr(Toxreg) IMPLICIT NONE c----------------------------------------------------------------------- c Load values of the regARIMA regression variables into the X-11 c regression variable (Toxreg=.true.) or load X-11 regression c variables into regARIMA regression variables (Toxreg=.false.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'arima.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' * INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL Toxreg * INTEGER i c----------------------------------------------------------------------- c Load values of the regARIMA regression variables into the X-11 c regression variable c----------------------------------------------------------------------- IF(Toxreg)THEN Nxgrp=Ngrp Ngrptx=Ngrptl Nxcxy=Ncxy Nbx=Nb Priadx=Priadj Ncoltx=Ncoltl Colttx=Colttl Grpttx=Grpttl CALL cpyint(Colptr(0),PB+1,1,Clxptr(0)) CALL cpyint(Grp(0),PGRP+1,1,Grpx(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Gpxptr(0)) CALL cpyint(Rgvrtp,PB,1,Rgxvtp) CALL copy(B,PB,1,Bx) c CALL copy(Userx,PUSERX,1,Xuserx) c Nrxusx=Nrusrx c Ncxusx=Ncusrx CALL cpyint(Bgusrx,2,1,Bgxusx) Nxrxy=Nrxy CALL cpyint(Begxy,2,1,Xbegxy) Irgxfx=Iregfx CALL copylg(Regfx,PB,1,Regfxx) Usrxfx=Userfx Xeasid=Easidx Pckxtd=Picktd CALL cpyint(Tddate,2,1,Xtddat) Xtdzro=Tdzero Xrgmtd=Lrgmtd Fulxtd=Fulltd c----------------------------------------------------------------------- c Else load X-11 regression variables into regARIMA regression c variables (Toxreg=.false.) c----------------------------------------------------------------------- ELSE Ngrp=Nxgrp Ngrptl=Ngrptx Ncxy=Nxcxy Nb=Nbx Priadj=Priadx Ncoltl=Ncoltx Colttl=Colttx Grpttl=Grpttx Nusrrg=Nusxrg CALL cpyint(Clxptr(0),PB+1,1,Colptr(0)) CALL cpyint(Grpx(0),PGRP+1,1,Grp(0)) CALL cpyint(Gpxptr(0),PGRP+1,1,Grpptr(0)) CALL cpyint(Rgxvtp,PB,1,Rgvrtp) CALL cpyint(Usxtyp,PUREG,1,Usrtyp) CALL cpyint(Usrxpt(0),PUREG+1,1,Usrptr(0)) Usrttl=Usrxtt CALL copy(Bx,PB,1,B) CALL copy(Xuserx,PUSERX,1,Userx) Nrusrx=Nrxusx Ncusrx=Ncxusx CALL cpyint(Bgxusx,2,1,Bgusrx) Nrxy=Nxrxy CALL cpyint(Xbegxy,2,1,Begxy) Iregfx=Irgxfx CALL copylg(Regfxx,PB,1,Regfx) Userfx=Usrxfx Picktd=Pckxtd Easidx=Xeasid CALL cpyint(Xtddat,2,1,Tddate) Tdzero=Xtdzro Lrgmtd=Xrgmtd Fulltd=Fulxtd c----------------------------------------------------------------------- c Set variables associated with Arima models c----------------------------------------------------------------------- Lma=.false. Lar=.false. Nintvl=0 Nextvl=0 Mxdflg=0 Mxarlg=0 Mxmalg=0 END IF c----------------------------------------------------------------------- RETURN END locshk.f0000664006604000003110000001004514521201526011621 0ustar sun00315stepsC Last change: BCM 7 May 2003 2:24 pm SUBROUTINE locshk(Sts,V,Ny) IMPLICIT NONE C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11ptr.cmn' * INCLUDE 'error.cmn' INCLUDE 'units.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE PARAMETER (ZERO=0D0,ONE=1D0) C----------------------------------------------------------------------- DOUBLE PRECISION dny,lmat,lsum,Sts,temps,V,w INTEGER i,i1,iend,ij,it1,j,k,Ny,ny2,j2,i2 DIMENSION lmat(PLEN,PSP),Sts(PLEN),temps(PLEN),w(PSP,PSP) C----------------------------------------------------------------------- DOUBLE PRECISION lkshnk EXTERNAL lkshnk C----------------------------------------------------------------------- c initialize variables C----------------------------------------------------------------------- ny2 = Ny/2 i1 = Pos1ob + ny2 * iend = Posffc - ny2 + 1 iend = Posfob * if (iend.gt.(Posffc-ny2+1))THEN * CALL writln( * END IF C----------------------------------------------------------------------- C Copy seasonal factors into double precision variable. C----------------------------------------------------------------------- CALL copy(Sts,Posffc,1,temps) C----------------------------------------------------------------------- C compute the moving likelihoods for observations i2 to iend, and c normalize for the sum of the moving likelihoods. C----------------------------------------------------------------------- DO i = i1, iend lsum = ZERO DO j = 1, Ny j2 = i + j - (Ny2 + 1) lmat(i,j) = lkshnk(temps(i),temps(j2),V) lsum = lsum + lmat(i,j) END DO DO j = 1, Ny lmat(i,j) = lmat(i,j) / lsum END DO END DO C----------------------------------------------------------------------- C initialize W matrix C----------------------------------------------------------------------- CALL setdp(ZERO,PSP*PSP,w) C----------------------------------------------------------------------- c compute shrinkage weights by adding the weighted likelihoods c for each calendar month/quarter, and dividing by the number of c years for each month/quarter. C----------------------------------------------------------------------- DO i=i1,i1+Ny-1 it1 = mod(i,Ny) IF (it1.eq.0) it1 = Ny dny = ZERO DO i2 = i, iend, Ny dny = dny + ONE DO k = 1, Ny W(it1,k) = W(it1,k) + lmat(i2,k) END DO END DO DO k = 1, Ny W(it1,k) = W(it1,k) / dny END DO END DO C----------------------------------------------------------------------- C initialize temps to zero C----------------------------------------------------------------------- CALL setdp(ZERO,PLEN,temps) C----------------------------------------------------------------------- c compute local seasonals C----------------------------------------------------------------------- it1 = mod(Pos1ob,Ny) IF (it1.eq.0) it1 = Ny DO i=Pos1ob,Posfob DO j = -ny2,ny2-1 ij=i+j write(ng,*)i,j,ij if(ij.lt.Pos1ob)ij=Ny+ij write(ng,*)i,j,ij temps(i)=temps(i)+Sts(ij)*w(it1,j+ny2+1) * if(i.lt.Pos1ob+ny2) * & write(ng,1)"i,j,ij,Sts(ij),w(",it1,",",j+ny2+1,"),temps(i)=", * & i,j,ij,Sts(ij),w(it1,j+ny2+1),temps(i) END DO it1 = it1 + 1 IF (it1.gt.Ny) it1 = it1 - Ny END DO C----------------------------------------------------------------------- C copy seasonals into Sts C----------------------------------------------------------------------- DO i=Pos1ob,Posfob Sts(i)=temps(i) END DO C----------------------------------------------------------------------- * 1 FORMAT(a,i3,a,i3,a,3i4,f12.4,e20.6,f12.4) RETURN END logar.f0000664006604000003110000000065014521201527011444 0ustar sun00315stepsC Last change: BCM 26 Apr 1998 2:46 pm **==logar.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE logar(X,I,J) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION tmp,X INTEGER I,J,k C*** End of declarations inserted by SPAG DIMENSION X(J) DO k=I,J tmp=X(k) X(k)=dlog(tmp) END DO RETURN END logdet.f0000664006604000003110000000137514521201527011623 0ustar sun00315steps**==logdet.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE logdet(Ap,N,Lgdt) c----------------------------------------------------------------------- c Returns the log of the determinate of a packed triangular matrix c----------------------------------------------------------------------- IMPLICIT NONE INTEGER i,ielt,N DOUBLE PRECISION Ap(*),Lgdt c ------------------------------------------------------------------ Lgdt=0D0 ielt=0 c ------------------------------------------------------------------ DO i=1,N ielt=ielt+i Lgdt=Lgdt+2D0*log(Ap(ielt)) END DO c ------------------------------------------------------------------ RETURN END logtrace.i0000664006604000003110000000027014521201527012141 0ustar sun00315stepsC C... Variables in Common Block /LogTrace/ ... integer ntrace character*80 TrTitle(50000) real*8 Dstdres(50000) common /logtrace/ Dstdres,TrTitle,ntrace lomaic.f0000664006604000003110000002547014521201527011613 0ustar sun00315stepsC Last change: BCM 23 Mar 2005 9:23 am SUBROUTINE lomaic(Trnsrs,A,Nefobs,Na,Frstry,Lester,Lprtit,Lprt, & Lprtfm,Lsavlg,Lsumm,Lhiddn) IMPLICIT NONE c----------------------------------------------------------------------- c Estimate two regARIMA models, one with user-defined regressors and c one without. This routine chooses the model with the lowest value c of AICC and prints out the resulting model. c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ZERO,ONE PARAMETER(F=.false.,T=.true.,ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'adj.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c----------------------------------------------------------------------- CHARACTER lnstr*(30),effttl*(PCOLCR),creg2*(6) LOGICAL Lprt,Lprtit,Lester,argok,lhide,Lprtfm,Lsavlg,Lhiddn,lreest DOUBLE PRECISION A,aicnol,aiclom,Trnsrs,thiscv INTEGER Frstry,i,Na,Nefobs,nchr,klm,nlnchr,ncreg2,ilom,Lsumm DIMENSION A(PA),Trnsrs(PLEN) c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL strinx,dpeq c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- IF(.not.Lprt)THEN lhide=Lhiddn Lhiddn=T END IF CALL mklnlb(lnstr,nlnchr,creg2,ncreg2,Lomtst,Lndate,Lnzero,Sp) IF(Lomtst.eq.1)THEN klm=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Length-of-Month') ELSE IF(Lomtst.eq.2)THEN klm=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Length-of-Quarter') ELSE IF(Lomtst.eq.3)THEN klm=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Leap Year') END IF lreest=F c----------------------------------------------------------------------- c Estimate model with lom/loq/lpyear regressors c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN argok=Lautom.or.Lautox CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & CALL abend() IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0.or. & ((Lautom.or.Lautox).and..not.argok))THEN Lester=T RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- IF(Lprt)THEN IF(klm.gt.0)THEN WRITE(Mt1,1010)lnstr(1:nlnchr) ELSE WRITE(Mt1,1020)lnstr(1:nlnchr) END IF END IF CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,F) IF(Lfatal)RETURN IF(klm.gt.0)THEN aiclom=Aicc IF(Lsavlg)WRITE(Ng,1011)lnstr(1:nlnchr),Aicc IF(Lsumm.gt.0) & WRITE(Nform,1012)creg2(1:ncreg2),creg2(1:ncreg2),Aicc ELSE aicnol=Aicc IF(Lsavlg)WRITE(Ng,1021)creg2(1:ncreg2),Aicc IF(Lsumm.gt.0) & WRITE(Nform,1012)creg2(1:ncreg2),'no'//creg2(1:ncreg2),Aicc END IF c----------------------------------------------------------------------- c If lom/loq/lpyear regressor is not in model, add it to model c----------------------------------------------------------------------- IF(klm.eq.0)THEN CALL addlom(Lndate,Lnzero,Sp,Lomtst) IF(Lfatal)RETURN IF(Lomtst.eq.1)THEN klm=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Length-of-Month') ELSE IF(Lomtst.eq.2) THEN klm=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Length-of-Quarter') ELSE klm=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Leap Year') END IF ELSE c----------------------------------------------------------------------- c remove all lom/loq/lpyear regressors from the regression matrix. c----------------------------------------------------------------------- ilom=1 DO WHILE (ilom.gt.0) ilom=strinx(T,Colttl,Colptr,1,Ncoltl,'Length-of-') IF(ilom.eq.0)ilom=strinx(T,Colttl,Colptr,1,Ncoltl,'Leap Year') IF(ilom.gt.0)THEN CALL dlrgef(ilom,Nrxy,1) IF(Lfatal)RETURN END IF END DO klm=0 END IF c----------------------------------------------------------------------- c Re-estimate the updated model c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & CALL abend() IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0.or.((Lautom.or.Lautox).and. & .not.argok))THEN Lester=T RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- IF(Lprt)THEN IF(klm.gt.0)THEN WRITE(Mt1,1010)lnstr(1:nlnchr) ELSE WRITE(Mt1,1020)lnstr(1:nlnchr) END IF END IF CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,Lprtfm) IF(klm.gt.0)THEN aiclom=Aicc IF(Lsavlg)WRITE(Ng,1011)creg2(1:ncreg2),Aicc IF(Lsumm.gt.0) & WRITE(Nform,1012)creg2(1:ncreg2),creg2(1:ncreg2),Aicc ELSE aicnol=Aicc IF(Lsavlg)WRITE(Ng,1021)creg2(1:ncreg2),Aicc IF(Lsumm.gt.0) & WRITE(Nform,1012)creg2(1:ncreg2),'no'//creg2(1:ncreg2),Aicc END IF IF(.not.Lprt)Lhiddn=lhide c----------------------------------------------------------------------- c Show the regression model AICC prefers c----------------------------------------------------------------------- Dfaicl=aicnol-aiclom IF(.not.dpeq(Pvaic,DNOTST))THEN CALL chsppf(Pvaic,1,thiscv,Mt1) Rgaicd(PLAIC)=thiscv-2D0 END IF IF(Dfaicl.gt.Rgaicd(PLAIC))THEN IF(Lprt)THEN IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1030)Rgaicd(PLAIC),'with',lnstr(1:nlnchr) ELSE WRITE(Mt1,1040)ONE-Pvaic,Rgaicd(PLAIC),'with',lnstr(1:nlnchr) END IF END IF c----------------------------------------------------------------------- c If no lom/loq/lpyear regressors, add them back to model c----------------------------------------------------------------------- IF(klm.eq.0)THEN CALL restor(T,F,F) CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF((.not.Lfatal).and.Iregfx.ge.2)THEN CALL rmfix(trnsrs,Nbcst,Nrxy,1) IF(.not.Lfatal) & CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) END IF lreest=T END IF ELSE IF(Lprt)THEN IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1030)Rgaicd(PLAIC),'without',lnstr(1:nlnchr) ELSE WRITE(Mt1,1040) & ONE-Pvaic,Rgaicd(PLAIC),'without',lnstr(1:nlnchr) END IF END IF IF(klm.gt.0)THEN ilom=1 DO WHILE (ilom.gt.0) ilom=strinx(T,Colttl,Colptr,1,Ncoltl,'Length-of-') IF(ilom.eq.0)ilom=strinx(T,Colttl,Colptr,1,Ncoltl,'Leap Year') IF(ilom.gt.0)THEN CALL dlrgef(ilom,Nrxy,1) IF(Lfatal)RETURN END IF END DO lreest=T END IF END IF c----------------------------------------------------------------------- c Estimate model c----------------------------------------------------------------------- IF(lreest)THEN CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,Lprtit,A,Na,Nefobs, & argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok))Lester=T END IF c----------------------------------------------------------------------- 1010 FORMAT(//,' Likelihood statistics for model with ',a, & ' regressors') 1011 FORMAT(' AICC(',a,')',t27,': ',f15.4) 1012 FORMAT('aictest.',a,'.aicc.',a,': ',e29.15) 1020 FORMAT(//,' Likelihood statistics for model without ',a, & ' regressors') 1021 FORMAT(' AICC(no ',a,')',t27,': ',f15.4) 1030 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model ',a,1x,a,' regressor *****') 1040 FORMAT(//,' ***** AICC (with p-value=',F7.5,' and aicdiff=', & F7.4,') prefers model ',a,1x,a,' regressor *****') RETURN END lstpth.f0000664006604000003110000000162314521201527011657 0ustar sun00315stepsC Last change: BCM 18 Nov 97 1:49 pm INTEGER FUNCTION lstpth(Filnam,Nfil) IMPLICIT NONE c----------------------------------------------------------------------- c Returns the position of the last character in the path of the file c name given in Filnam (returns 0 if there is no file name). c----------------------------------------------------------------------- INCLUDE 'lex.i' CHARACTER Filnam*(*) INTEGER jchr,Nfil c----------------------------------------------------------------------- DO lstpth=Nfil,1,-1 jchr=ichar(Filnam(lstpth:lstpth)) cdos backslash for directory cdos IF(jchr.eq.COLON.or.jchr.eq.BSLASH)GO TO 10 cunix forward slash for directory IF(jchr.eq.SLASH.or.jchr.eq.COLON)GO TO 10 END DO c ------------------------------------------------------------------ lstpth=0 10 RETURN END lzero.cmn0000664006604000003110000000131114521201527012016 0ustar sun00315stepsc----------------------------------------------------------------------- c Kh2 - duplicate of holiday adjustment indicator variable c L0 - pointer to first observation of the first span in a sliding c spans, revisions history analysis c Lsp - pointer to first observation of the current span in a c sliding spans, revisions history analysis c Ly0 - first year of original span c Axhol - Logical variable which determines if X-11 holiday c adjustment was used to adjust the series c----------------------------------------------------------------------- INTEGER Kh2,L0,Ly0,Lsp LOGICAL Axhol COMMON /lzero / L0,Ly0,Lsp,Kh2,Axhol m2q.f0000664006604000003110000000403614521201527011041 0ustar sun00315steps SUBROUTINE m2q(Y,Yq,N1,N2,N1q,N2q,Start,Startq,Isrflw) IMPLICIT NONE c----------------------------------------------------------------------- c subroutine that converts a monthly series to a quarterly series c----------------------------------------------------------------------- INTEGER YR,MO PARAMETER(YR=1,MO=2) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- DOUBLE PRECISION Y,Yq INTEGER N1,N2,N1q,N2q,Start,Startq,Isrflw,i,iq,iq2,im,nq DIMENSION Y(PLEN),Yq(PLEN),Start(2),Startq(2) c----------------------------------------------------------------------- Startq(YR)=Start(YR) IF(Start(MO).eq.1)THEN c iq=1 im=N1 Startq(MO)=1 ELSE IF(Start(MO).le.4)THEN c iq=2 im=N1+(4-Start(MO)) Startq(MO)=2 ELSE IF(Start(MO).le.7)THEN c iq=3 im=N1+(7-Start(MO)) Startq(MO)=3 ELSE IF(Start(MO).le.10)THEN c iq=4 im=N1+(10-Start(MO)) Startq(MO)=4 ELSE c iq=5 im=N1+(13-Start(MO)) Startq(MO)=1 Startq(YR)=Startq(YR)+1 END IF c----------------------------------------------------------------------- nq=0 iq = 1 DO i=im,N2,3 c----------------------------------------------------------------------- c-----update on 6/27, truncate the months at the end of span which is c-----full quarter. c----------------------------------------------------------------------- IF (i+2.le.N2) THEN nq=nq+1 iq2=iq+nq-1 Yq(iq2)=Y(i+2) IF(Isrflw.le.1)THEN Yq(iq2)=Yq(iq2)+Y(i) Yq(iq2)=Yq(iq2)+Y(i+1) END IF END IF END DO c----------------------------------------------------------------------- N1q=iq N2q=iq2 c----------------------------------------------------------------------- RETURN END makadj.f0000664006604000003110000000277314521201527011577 0ustar sun00315steps SUBROUTINE makadj(Adjtmp,Muladd) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'adj.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION Adjtmp(PLEN) INTEGER Muladd c ------------------------------------------------------------------ c Copy prior adjustment factors read in by user into a temporary c variable. c ------------------------------------------------------------------ IF(Nustad.gt.0.or.Nuspad.gt.0)THEN IF(Nustad.gt.0)THEN CALL copy(Usrtad(Frstat),Nadj,1,Adjtmp(Setpri)) IF(Nuspad.gt.0) & CALL addmul(Adjtmp(Setpri),Usrpad(Frstap),Adjtmp(Setpri),1,Nadj) ELSE IF(Nuspad.gt.0)THEN CALL copy(Usrpad(Frstap),Nadj,1,Adjtmp(Setpri)) END IF IF(Muladd.ne.1.and.Adjmod.eq.0) & CALL invfcn(Adjtmp(Setpri),Nadj,1,0d0,Adjtmp(Setpri)) c ------------------------------------------------------------------ c IF no prior adjustments, set Adjtmp to unity c ------------------------------------------------------------------ ELSE IF(Adjmod.eq.2)THEN CALL setdp(0D0,PLEN,Adjtmp) ELSE CALL setdp(1D0,PLEN,Adjtmp) END IF c ------------------------------------------------------------------ RETURN END makefile.g770000664006604000003110000020516114521201527012300 0ustar sun00315steps# MKMF template makefile for protected mode executables. FC = gfortran LINKER = gfortran PROGRAM = x13as DEST = . EXTHDRS = FFLAGS = -O2 HDRS = LDFLAGS = -s LDMAP = LIBS = MAKEFILE = Makefile OBJS = aaamain.o abend.o acf.o acfar.o acfdgn.o \ acfhdr.o addadj.o addate.o addeas.o \ addfix.o addlom.o addmat.o addmul.o addotl.o \ addsef.o addsub.o addtd.o addusr.o adestr.o \ adjreg.o adjsrs.o adlabr.o adotss.o adpdrg.o \ adrgef.o adrgim.o adsncs.o adthnk.o aggmea.o \ agr.o agr1.o agr2.o agr3.o agr3s.o agrxpt.o \ amdest.o amdfct.o amdid.o amdid2.o amdprt.o \ amidot.o analts.o ansub1.o ansub10.o ansub11.o \ ansub2.o ansub3.o ansub4.o ansub5.o ansub7.o \ ansub8.o ansub9.o antilg.o apply.o ar30rg.o \ arfit.o arflt.o arima.o armacr.o armafl.o \ armats.o arspc.o autoer.o automd.o automx.o avedur.o \ aver.o averag.o bakusr.o bench.o bestmd.o \ bkdfmd.o bldcov.o blddif.o bstget.o bstmdl.o \ btrit.o calcqs.o calcqs2.o calcsc.o ceilng.o \ change.o chisq.o chitst.o chkadj.o chkchi.o \ chkcvr.o chkeas.o chkmu.o chkorv.o chkrt1.o \ chkrt2.o chkrts.o chksmd.o chktrn.o chkuhg.o \ chkurt.o chkzro.o chrt.o chsppf.o chusrg.o \ clrotl.o clsgrp.o cmpchi.o cmpstr.o cncrnt.o \ cnvfmt.o cnvmdl.o coladd.o combft.o compb.o \ compdiag.o compmse.o comprevs.o constant.o \ copy.o copycl.o copylg.o cormtx.o cornom.o \ corplt.o covar.o cpyint.o cpymat.o crosco.o \ ctod.o ctodat.o ctoi.o cumnor.o cvcmma.o \ cvdttm.o cvrerr.o daxpy.o dcopy.o ddot.o \ decibl.o delstr.o deltst.o desreg.o devlpl.o \ dfdate.o dgefa.o dgesl.o difflt.o dinvnr.o \ divgud.o divsub.o dlrgef.o dlrgrw.o dlusrg.o \ dot.o dpeq.o dpmpar.o dppdi.o dppfa.o dppsl.o \ dsarma.o dscal.o dsolve.o dtoc.o easaic.o \ easter.o editor.o eltfcn.o eltlen.o emcomp.o \ ends.o endsf.o enorm.o entsch.o errhdr.o \ estrmu.o euclid.o exctma.o extend.o extsgnl.o \ f3cal.o f3gen.o fclose.o fcnar.o fcstxy.o \ fdjac2.o fgen.o fis.o fopen.o forcst.o \ fouger.o fstop.o ftest.o fvalue.o fxshfr.o \ gauss.o gendff.o genfor.o genqs.o genrtt.o \ genssm.o getadj.o getchk.o getchr.o \ getcmp.o getdat.o getdbl.o getdes.o getdiag.o \ getfcn.o getfrc.o getgr.o getid.o getidm.o \ getint.o getivc.o getmdl.o getmtd.o getopr.o \ getprt.o getreg.o getrev.o getsav.o getsma.o \ getsmat.o getsrs.o getssp.o getstr.o getsvec.o \ getsvl.o gettpltz.o gettr.o gettrc.o \ getttl.o getx11.o getxop.o getxtd.o glbshk.o \ gnfcrv.o grzlst.o grzmth.o grzmyr.o gtarg.o \ gtarma.o gtauto.o gtautx.o gtdcnm.o gtdcvc.o \ gtdpvc.o gtdtvc.o gtedit.o gtestm.o gtfcst.o \ gtfldt.o gtfrcm.o gtfree.o gtinpt.o gtinvl.o \ gtmdfl.o gtmtdt.o gtmtfl.o gtnmvc.o gtotlr.o \ gtpdrg.o gtrgdt.o gtrgpt.o gtrgvl.o gtrvst.o \ gtseat.o gtspec.o gttrmo.o gtwacf.o gtx11d.o \ gtx12s.o gtxreg.o hender.o hinge.o hist.o \ histx.o hndend.o hndtrn.o holday.o holidy.o \ hrest.o htmlout.o idamax.o iddiff.o idmdl.o \ idotlr.o idpeak.o inbtwn.o indx.o initdg.o \ initst.o inpter.o insdbl.o insint.o inslg.o \ insopr.o insort.o insptr.o insstr.o intfmt.o \ intgpg.o intinp.o intlst.o intrpp.o intsrt.o \ invfcn.o invmat.o ipmpar.o iscrfn.o isdate.o \ isfals.o isfixd.o ispeak.o ispos.o issame.o \ istrue.o itoc.o itrerr.o kfcn.o kwtest.o \ lassol.o lendp.o lex.o lgnrmc.o lkshnk.o \ lmdif.o lmpar.o loadxr.o locshk.o logar.o \ logdet.o lomaic.o lstpth.o makadj.o makotl.o \ makttl.o map.o matrix.o maxidx.o maxlag.o \ maxvec.o mdlchk.o mdlfix.o mdlinp.o mdlint.o \ mdlmch.o mdlset.o mdssln.o meancra.o medabs.o \ mflag.o minim2.o mkback.o mkealb.o mkfreq.o \ mklnlb.o mkmdsn.o mkmdsx.o mkoprt.o mkotky.o \ mkpeak.o mkshdr.o mkspky.o mksplb.o mkspst.o \ mkssky.o mkstlb.o mktdlb.o mlist.o mltpos.o month.o \ mstest.o mulmat.o mulqmat.o mulref.o mulsca.o \ mult.o mult0.o mult1.o mult2.o mxpeak.o \ nblank.o newest.o nextk.o nmlmdl.o nofcst.o \ nrmtst.o numaff.o numfmt.o olsreg.o opnfil.o \ otsort.o outchr.o pacf.o pass0.o pass2.o \ pctrit.o polyml.o polynom.o ppnd.o pracf2.o \ prafce.o pragr2.o prfcrv.o pritd.o prlkhd.o \ procflts.o prothd.o prprad.o prrvob.o \ prshd2.o prtacf.o prtadj.o prtagr.o prtamd.o \ prtchi.o prtcol.o prtd8b.o prtd9a.o prtdtb.o \ prtdwr.o prterr.o prterx.o prtf2.o prtf2w.o \ prtfct.o prtft.o prtitr.o prtlog.o prtmdl.o \ prtmsp.o prtmsr.o prtmtx.o prtnfn.o prtopt.o \ prtref.o prtrev.o prtrts.o prtrv2.o prtsft.o \ prtshd.o prttbl.o prttd.o prttrn.o prtukp.o \ prtxrg.o punch.o putbak.o putrev.o putstr.o \ qcmmnt.o qcontr.o qdoble.o qintgr.o qmap.o \ qmap2.o qname.o qquote.o qrfac.o qrsolv.o \ qsdiff.o qtoken.o quad.o quadit.o quadsd.o \ ratneg.o ratpos.o rdotlr.o rdotls.o rdregm.o \ realit.o regfix.o reglbl.o regvar.o regx11.o \ replac.o replyf.o resid.o resid2.o restor.o \ revchk.o revdrv.o revhdr.o revrse.o rgarma.o \ rgtdhl.o rho2.o rmatot.o rmfix.o rmlnvr.o \ rmlpyr.o rmotrv.o rmotss.o rmpadj.o rmtadj.o \ rndsa.o rngbuf.o roots.o round.o rplus.o \ rpoly.o rv2ss.o rvarma.o rvfixd.o rvrghd.o rvtdrg.o \ sautco.o savacf.o savchi.o savd8b.o savitr.o \ savmdc.o savmdl.o savmtx.o savotl.o savpk.o \ savspp.o savstp.o savtbl.o savtpk.o savwkf.o sceast.o \ scrmlt.o sdev.o sdxtrm.o seatad.o seatdg.o \ seatfc.o seatpr.o serates.o setadj.o setamx.o \ setapt.o setchr.o setcv.o setcvl.o \ setdp.o setint.o setlg.o setmdl.o setmv.o \ setopr.o setpt.o setrvp.o setspn.o setssp.o \ setup.o setwrt.o setxpt.o sfmax.o sfmsr.o \ sftest.o shlsrt.o shrink.o si.o sicp2.o \ sigex.o sigsub.o simul.o skparg.o skparm.o \ skpfcn.o skplst.o smeadl.o smpeak.o snrasp.o \ spcdrv.o spcrsd.o special.o specpeak.o \ spectrum.o spgrh.o spgrh2.o spmpar.o ss2rv.o \ ssap.o ssfnot.o ssftst.o sshist.o ssmdl.o \ ssort.o sspdrv.o ssphdr.o ssprep.o ssrit.o \ ssrng.o ssx11a.o ssxmdl.o stpitr.o strinx.o \ strtvl.o stvaln.o subset.o sumf.o sumry.o \ sumsqr.o svaict.o svamcm.o svchsd.o svdttm.o \ svf2f3.o svflt.o svfltd.o svfnrg.o svfreq.o \ svolit.o svoudg.o svpeak.o svrgcm.o svrvhd.o \ svspan.o svtukp.o table.o taper.o tblhdr.o \ td6var.o td7var.o tdaic.o tdftest.o tdlom.o \ tdset.o tdxtrm.o templs.o tfmts.o tfmts3.o \ totals.o transc.o trbias.o trnaic.o trnfcn.o \ tstdrv.o tstmd1.o tstmd2.o ttest.o uconv.o \ upespm.o usraic.o value.o varian.o varlog.o \ vars.o vsfa.o vsfb.o vsfc.o vtc.o vtest.o \ weight.o whitsp.o wr.o writln.o wrtdat.o \ wrtmss.o wrtotl.o wrttb2.o wrttbl.o wtxtrm.o \ x11aic.o x11ari.o x11int.o x11mdl.o x11plt.o \ x11pt1.o x11pt2.o x11pt3.o x11pt4.o x11ref.o \ x12hdr.o x12run.o xchng.o xpand.o xprmx.o \ xrgdiv.o xrgdrv.o xrghol.o xrgtrn.o xrlkhd.o \ xtrm.o yprmy.o yrly.o component.o complagdiag.o \ compcrodiag.o phasegain.o altundovrtst.o \ getrevdec.o m2q.o chqsea.o npsa.o gennpsa.o prarma.o \ testodf.o SRCS = aaamain.f abend.f acf.f acfar.f acfdgn.f \ acfhdr.f addadj.f addate.f addeas.f \ addfix.f addlom.f addmat.f addmul.f addotl.f \ addsef.f addsub.f addtd.f addusr.f adestr.f \ adjreg.f adjsrs.f adlabr.f adotss.f adpdrg.f \ adrgef.f adrgim.f adsncs.f adthnk.f aggmea.f \ agr.f agr1.f agr2.f agr3.f agr3s.f agrxpt.f \ amdest.f amdfct.f amdid.f amdid2.f amdprt.f \ amidot.f analts.f ansub1.f ansub10.f ansub11.f \ ansub2.f ansub3.f ansub4.f ansub5.f ansub7.f \ ansub8.f ansub9.f antilg.f apply.f ar30rg.f \ arfit.f arflt.f arima.f armacr.f armafl.f \ armats.f arspc.f autoer.f automd.f automx.f avedur.f \ aver.f averag.f bakusr.f bench.f bestmd.f \ bkdfmd.f bldcov.f blddif.f bstget.f bstmdl.f \ btrit.f calcqs.f calcqs2.f calcsc.f ceilng.f \ change.f chisq.f chitst.f chkadj.f chkchi.f \ chkcvr.f chkeas.f chkmu.f chkorv.f chkrt1.f \ chkrt2.f chkrts.f chksmd.f chktrn.f chkuhg.f \ chkurt.f chkzro.f chrt.f chsppf.f chusrg.f \ clrotl.f clsgrp.f cmpchi.f cmpstr.f cncrnt.f \ cnvfmt.f cnvmdl.f coladd.f combft.f compb.f \ compdiag.f compmse.f comprevs.f constant.f \ copy.f copycl.f copylg.f cormtx.f cornom.f \ corplt.f covar.f cpyint.f cpymat.f crosco.f \ ctod.f ctodat.f ctoi.f cumnor.f cvcmma.f \ cvdttm.f cvrerr.f daxpy.f dcopy.f ddot.f \ decibl.f delstr.f deltst.f desreg.f devlpl.f \ dfdate.f dgefa.f dgesl.f difflt.f dinvnr.f \ divgud.f divsub.f dlrgef.f dlrgrw.f dlusrg.f \ dot.f dpeq.f dpmpar.f dppdi.f dppfa.f dppsl.f \ dsarma.f dscal.f dsolve.f dtoc.f easaic.f \ easter.f editor.f eltfcn.f eltlen.f emcomp.f \ ends.f endsf.f enorm.f entsch.f errhdr.f \ estrmu.f euclid.f exctma.f extend.f extsgnl.f \ f3cal.f f3gen.f fclose.f fcnar.f fcstxy.f \ fdjac2.f fgen.f fis.f fopen.f forcst.f \ fouger.f fstop.f ftest.f fvalue.f fxshfr.f \ gauss.f gendff.f genfor.f genqs.f genrtt.f \ genssm.f getadj.f getchk.f getchr.f \ getcmp.f getdat.f getdbl.f getdes.f getdiag.f \ getfcn.f getfrc.f getgr.f getid.f getidm.f \ getint.f getivc.f getmdl.f getmtd.f getopr.f \ getprt.f getreg.f getrev.f getsav.f getsma.f \ getsmat.f getsrs.f getssp.f getstr.f getsvec.f \ getsvl.f gettpltz.f gettr.f gettrc.f \ getttl.f getx11.f getxop.f getxtd.f glbshk.f \ gnfcrv.f grzlst.f grzmth.f grzmyr.f gtarg.f \ gtarma.f gtauto.f gtautx.f gtdcnm.f gtdcvc.f \ gtdpvc.f gtdtvc.f gtedit.f gtestm.f gtfcst.f \ gtfldt.f gtfrcm.f gtfree.f gtinpt.f gtinvl.f \ gtmdfl.f gtmtdt.f gtmtfl.f gtnmvc.f gtotlr.f \ gtpdrg.f gtrgdt.f gtrgpt.f gtrgvl.f gtrvst.f \ gtseat.f gtspec.f gttrmo.f gtwacf.f gtx11d.f \ gtx12s.f gtxreg.f hender.f hinge.f hist.f \ histx.f hndend.f hndtrn.f holday.f holidy.f \ hrest.f htmlout.f idamax.f iddiff.f idmdl.f \ idotlr.f idpeak.f inbtwn.f indx.f initdg.f \ initst.f inpter.f insdbl.f insint.f inslg.f \ insopr.f insort.f insptr.f insstr.f intfmt.f \ intgpg.f intinp.f intlst.f intrpp.f intsrt.f \ invfcn.f invmat.f ipmpar.f iscrfn.f isdate.f \ isfals.f isfixd.f ispeak.f ispos.f issame.f \ istrue.f itoc.f itrerr.f kfcn.f kwtest.f \ lassol.f lendp.f lex.f lgnrmc.f lkshnk.f \ lmdif.f lmpar.f loadxr.f locshk.f logar.f \ logdet.f lomaic.f lstpth.f makadj.f makotl.f \ makttl.f map.f matrix.f maxidx.f maxlag.f \ maxvec.f mdlchk.f mdlfix.f mdlinp.f mdlint.f \ mdlmch.f mdlset.f mdssln.f meancra.f medabs.f \ mflag.f minim2.f mkback.f mkealb.f mkfreq.f \ mklnlb.f mkmdsn.f mkmdsx.f mkoprt.f mkotky.f \ mkpeak.f mkshdr.f mkspky.f mksplb.f mkspst.f \ mkssky.f mkstlb.f mktdlb.f mlist.f mltpos.f month.f \ mstest.f mulmat.f mulqmat.f mulref.f mulsca.f \ mult.f mult0.f mult1.f mult2.f mxpeak.f \ nblank.f newest.f nextk.f nmlmdl.f nofcst.f \ nrmtst.f numaff.f numfmt.f olsreg.f opnfil.f \ otsort.f outchr.f pacf.f pass0.f pass2.f \ pctrit.f polyml.f polynom.f ppnd.f pracf2.f \ prafce.f pragr2.f prfcrv.f pritd.f prlkhd.f \ procflts.f prothd.f prprad.f prrvob.f \ prshd2.f prtacf.f prtadj.f prtagr.f prtamd.f \ prtchi.f prtcol.f prtd8b.f prtd9a.f prtdtb.f \ prtdwr.f prterr.f prterx.f prtf2.f prtf2w.f \ prtfct.f prtft.f prtitr.f prtlog.f prtmdl.f \ prtmsp.f prtmsr.f prtmtx.f prtnfn.f prtopt.f \ prtref.f prtrev.f prtrts.f prtrv2.f prtsft.f \ prtshd.f prttbl.f prttd.f prttrn.f prtukp.f \ prtxrg.f punch.f putbak.f putrev.f putstr.f \ qcmmnt.f qcontr.f qdoble.f qintgr.f qmap.f \ qmap2.f qname.f qquote.f qrfac.f qrsolv.f \ qsdiff.f qtoken.f quad.f quadit.f quadsd.f \ ratneg.f ratpos.f rdotlr.f rdotls.f rdregm.f \ realit.f regfix.f reglbl.f regvar.f regx11.f \ replac.f replyf.f resid.f resid2.f restor.f \ revchk.f revdrv.f revhdr.f revrse.f rgarma.f \ rgtdhl.f rho2.f rmatot.f rmfix.f rmlnvr.f \ rmlpyr.f rmotrv.f rmotss.f rmpadj.f rmtadj.f \ rndsa.f rngbuf.f roots.f round.f rplus.f \ rpoly.f rv2ss.f rvarma.f rvfixd.f rvrghd.f rvtdrg.f \ rvtdrg.f sautco.f savacf.f savchi.f savd8b.f \ savitr.f savmdc.f savmdl.f savmtx.f savotl.f \ savpk.f savspp.f savstp.f savtbl.f savtpk.f savwkf.f \ sceast.f scrmlt.f sdev.f sdxtrm.f seatad.f seatdg.f \ seatfc.f seatpr.f serates.f setadj.f setamx.f \ setapt.f setchr.f setcv.f setcvl.f \ setdp.f setint.f setlg.f setmdl.f setmv.f \ setopr.f setpt.f setrvp.f setspn.f setssp.f \ setup.f setwrt.f setxpt.f sfmax.f sfmsr.f \ sftest.f shlsrt.f shrink.f si.f sicp2.f \ sigex.f sigsub.f simul.f skparg.f skparm.f \ skpfcn.f skplst.f smeadl.f smpeak.f snrasp.f \ spcdrv.f spcrsd.f special.f specpeak.f \ spectrum.f spgrh.f spgrh2.f spmpar.f ss2rv.f \ ssap.f ssfnot.f ssftst.f sshist.f ssmdl.f \ ssort.f sspdrv.f ssphdr.f ssprep.f ssrit.f \ ssrng.f ssx11a.f ssxmdl.f stpitr.f strinx.f \ strtvl.f stvaln.f subset.f sumf.f sumry.f \ sumsqr.f svaict.f svamcm.f svchsd.f svdttm.f \ svf2f3.f svflt.f svfltd.f svfnrg.f svfreq.f \ svolit.f svoudg.f svpeak.f svrgcm.f svrvhd.f \ svspan.f svtukp.f table.f taper.f tblhdr.f \ td6var.f td7var.f tdaic.f tdftest.f tdlom.f \ tdset.f tdxtrm.f templs.f tfmts.f tfmts3.f \ totals.f transc.f trbias.f trnaic.f trnfcn.f \ tstdrv.f tstmd1.f tstmd2.f ttest.f uconv.f \ upespm.f usraic.f value.f varian.f varlog.f \ vars.f vsfa.f vsfb.f vsfc.f vtc.f vtest.f \ weight.f whitsp.f wr.f writln.f wrtdat.f \ wrtmss.f wrtotl.f wrttb2.f wrttbl.f wtxtrm.f \ x11aic.f x11ari.f x11int.f x11mdl.f x11plt.f \ x11pt1.f x11pt2.f x11pt3.f x11pt4.f x11ref.f \ x12hdr.f x12run.f xchng.f xpand.f xprmx.f \ xrgdiv.f xrgdrv.f xrghol.f xrgtrn.f xrlkhd.f \ xtrm.f yprmy.f yrly.f component.f complagdiag.f \ compcrodiag.f phasegain.f altundovrtst.f \ getrevdec.f m2q.f chqsea.f npsa.f gennpsa.f prarma.f \ testodf.f $(PROGRAM): $(OBJS) $(LIBS) $(LINKER) -static -o $@ $(OBJS) $(LDMAP) $(LIBS) $(LDFLAGS) clean:; @rm -f $(OBJS) install: $(PROGRAM) @echo Installing $(PROGRAM) in $(DEST) @if not $(DEST)x==.x copy $(PROGRAM) $(DEST) ### OPUS MKMF: Do not remove this line! Automatic dependencies follow. aaamain.o: build.prm cchars.i chrt.cmn error.cmn hiddn.cmn lex.i \ notset.prm nsums.i seatop.cmn srslen.prm ssap.cmn ssap.prm stdio.i \ title.cmn units.cmn abend.o: dgnsvl.i error.cmn hiddn.cmn stdio.i svllog.cmn svllog.prm \ units.cmn acf.o: autoq.cmn notset.prm srslen.prm stdio.i units.cmn acfar.o: autoq.cmn srslen.prm acfdgn.o: autoq.cmn error.cmn mdldat.cmn mdlsvl.i model.cmn model.prm \ srslen.prm svllog.cmn svllog.prm units.cmn acfhdr.o: model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm addadj.o: error.cmn stdio.i units.cmn addeas.o: error.cmn model.prm notset.prm srslen.prm addfix.o: error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm srslen.prm addlom.o: error.cmn model.prm notset.prm srslen.prm addmul.o: srslen.prm x11opt.cmn addotl.o: error.cmn hiddn.cmn mdldat.cmn model.cmn model.prm srslen.prm \ stdio.i units.cmn addsef.o: error.cmn model.cmn model.prm notset.prm srslen.prm stdio.i \ units.cmn addtd.o: error.cmn model.prm notset.prm srslen.prm addusr.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ urgbak.cmn usrreg.cmn adestr.o: model.prm srslen.prm adjreg.o: extend.cmn inpt.cmn model.cmn model.prm orisrs.cmn prior.cmn \ prior.prm srslen.prm units.cmn x11adj.cmn x11fac.cmn x11log.cmn \ x11ptr.cmn adjsrs.o: adj.cmn error.cmn picktd.cmn priadj.cmn prior.cmn prior.prm \ priusr.cmn srslen.prm adlabr.o: model.prm srslen.prm adotss.o: arima.cmn error.cmn model.cmn model.prm srslen.prm adpdrg.o: error.cmn lex.i model.cmn model.prm notset.prm picktd.cmn \ srslen.prm stdio.i units.cmn adrgef.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn adrgim.o: error.cmn lex.i model.cmn model.prm notset.prm picktd.cmn \ srslen.prm adsncs.o: error.cmn model.prm srslen.prm stdio.i units.cmn adthnk.o: model.prm srslen.prm aggmea.o: srslen.prm agr.o: srslen.prm agr1.o: agr.cmn agrsrs.cmn model.prm notset.prm rev.cmn rev.prm \ revsrs.cmn srslen.prm ssap.cmn ssap.prm sspdat.cmn agr2.o: adxser.cmn agr.cmn agrsrs.cmn cmpsvl.i cmptbl.i extend.cmn \ inpt.cmn lzero.cmn orisrs.cmn priadj.cmn prior.cmn prior.prm \ priusr.cmn seatcm.cmn seatlg.cmn srslen.prm stdio.i svllog.cmn \ svllog.prm tbllog.cmn tbllog.prm title.cmn units.cmn x11adj.cmn \ x11fac.cmn x11opt.cmn x11ptr.cmn x11srs.cmn agr3.o: adxser.cmn agr.cmn agrsrs.cmn build.prm cmptbl.i error.cmn \ extend.cmn force.cmn hiddn.cmn inpt.cmn lex.i notset.prm \ seatcm.cmn srslen.prm stdio.i tbllog.cmn tbllog.prm title.cmn \ units.cmn x11adj.cmn x11fac.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11srs.cmn agr3s.o: adxser.cmn agr.cmn agrsrs.cmn build.prm cmptbl.i error.cmn \ extend.cmn force.cmn hiddn.cmn inpt.cmn lex.i notset.prm \ seatcm.cmn srslen.prm stdio.i tbllog.cmn tbllog.prm title.cmn \ units.cmn x11adj.cmn x11fac.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11srs.cmn agrxpt.o: agr.cmn agrsrs.cmn extend.cmn srslen.prm x11ptr.cmn amdest.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm amdfct.o: arima.cmn error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm \ prior.cmn prior.prm srslen.prm units.cmn usrreg.cmn amdid.o: arima.cmn error.cmn extend.cmn mdldat.cmn mdlsvl.i mdltbl.i \ model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm \ stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm units.cmn amdid2.o: adj.cmn arima.cmn error.cmn mdldat.cmn mdltbl.i model.cmn \ model.prm srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn amdprt.o: error.cmn lkhd.cmn mdldat.cmn model.prm srslen.prm units.cmn amidot.o: arima.cmn error.cmn extend.cmn mdltbl.i model.cmn model.prm \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn analts.o: bench.i buffers.i build.i calc.i calfor.i calshr.i count.i \ date.i dets.i dimensions.i dirs.i eee.i error.cmn hdflag.i \ hiddn.cmn logtrace.i nsums.i peaks.i pinno.i preadtr.i seastest.i \ seatserr.i sername.i sesfcast.i sfcast.i sform.i sig.i sig1.i \ srslen.prm stdio.i stream.i strmodel.i titl.i title.cmn unitmak.i \ units.cmn xarr.i ansub1.o: calc.i calfor.i calshr.i count.i cse.i dets.i dimensions.i eee.i \ sesfcast.i srslen.prm stream.i units.cmn ansub10.o: calc.i calfor.i date.i dimensions.i dirs.i estb.i logtrace.i \ models.i polynom.i prtous.i revs.i seatop.cmn sesfcast.i sform.i \ srslen.prm stdio.i stream.i tbl5x.i units.cmn xarr.i ansub11.o: calc.i calfor.i dimensions.i estgc.i fft.i models.i srslen.prm \ units.cmn xarr.i ansub2.o: ac02ae.i dimensions.i error.cmn func.i func2.i func3.i func4.i \ func5.i min.i sform.i srslen.prm stdio.i stream.i test.i unitmak.i \ units.cmn ansub3.o: dimensions.i estb.i estgc.i preadtr.i sform.i sig.i srslen.prm \ units.cmn ansub4.o: acfast.i acfst.i bartlett.i bench.i cross.i cxfinal.i dimensions.i \ estb.i force.cmn hspect.i lzero.cmn models.i preadtr.i priadj.cmn \ priusr.cmn serrlev.i sesfcast.i sfcast.i sform.i srslen.prm \ stdio.i stream.i titl.i transcad.i units.cmn ansub5.o: bench.i dimensions.i error.cmn fitmod.i func5f1.i hspect.i \ preadtr.i prtous.i rtestm.i sform.i spe.i spectra.i spectrum.i \ srslen.prm stream.i testf1.i transcad.i units.cmn ansub7.o: amic.i dimensions.i error.cmn func.i func2.i func3.i func4.i \ min.i srslen.prm test.i ansub8.o: build.i dirs.i stream.i ansub9.o: autoq.cmn dimensions.i error.cmn extend.cmn hiddn.cmn mdldat.cmn \ model.cmn model.prm notset.prm orisrs.cmn rev.cmn rev.prm \ seatad.cmn seatcm.cmn seatdg.cmn seatlg.cmn seatmd.cmn seatop.cmn \ seattb.i srslen.prm sspinp.cmn stdio.i tbllog.cmn tbllog.prm \ title.cmn units.cmn x11adj.cmn x11fac.cmn x11ptr.cmn ar30rg.o: srslen.prm arima.o: adj.cmn arima.cmn autoq.cmn error.cmn extend.cmn filext.prm \ fxreg.cmn hiddn.cmn inpt.cmn lkhd.cmn lzero.cmn mdldat.cmn mdlsvl.i \ mdltbl.i missng.cmn model.cmn model.prm mq3.cmn notset.prm \ orisrs.cmn picktd.cmn priadj.cmn prior.cmn prior.prm prittl.cmn \ priusr.cmn rev.cmn rev.prm rho.cmn seatad.cmn spcsvl.i spctbl.i \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.i \ tbllog.prm tdtyp.cmn title.cmn tukey.cmn units.cmn usrreg.cmn \ x11adj.cmn x11fac.cmn x11log.cmn x11opt.cmn x11ptr.cmn armacr.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn armafl.o: mdldat.cmn model.cmn model.prm srslen.prm armats.o: mdldat.cmn model.cmn model.prm srslen.prm stdio.i units.cmn autoer.o: model.prm srslen.prm stdio.i units.cmn automd.o: adj.cmn arima.cmn error.cmn extend.cmn mdldat.cmn mdlsvl.i \ mdltbl.i model.cmn model.prm notset.prm picktd.cmn prior.cmn \ prior.prm srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm title.cmn units.cmn usrreg.cmn automx.o: adj.cmn arima.cmn autoq.cmn error.cmn extend.cmn lex.i \ mdldat.cmn mdltbl.i model.cmn model.prm notset.prm picktd.cmn \ priadj.cmn prior.cmn prior.prm prittl.cmn priusr.cmn srslen.prm \ stdio.i tbllog.cmn tbllog.prm title.cmn units.cmn usrreg.cmn \ x11adj.cmn x11ptr.cmn aver.o: chrt.cmn srslen.prm units.cmn bakusr.o: model.prm srslen.prm urgbak.cmn bench.o: calfor.i dirs.i sform.i titl.i bestmd.o: lkhd.cmn notset.prm bkdfmd.o: arima.cmn mdldat.cmn model.cmn model.prm picktd.cmn prior.cmn \ prior.prm srslen.prm ss2rv.cmn tbllog.prm usrreg.cmn x11adj.cmn bldcov.o: srslen.prm bstget.o: bstmdl.cmn mdldat.cmn model.cmn model.prm notset.prm srslen.prm bstmdl.o: bstmdl.cmn mdldat.cmn model.cmn model.prm picktd.cmn srslen.prm btrit.o: srslen.prm ssap.cmn ssap.prm sspvec.cmn title.cmn units.cmn calcsc.o: global.cmn model.prm srslen.prm change.o: goodob.cmn notset.prm srslen.prm x11opt.cmn chitst.o: mdldat.cmn model.prm notset.prm srslen.prm chkadj.o: model.cmn model.prm srslen.prm stdio.i units.cmn usrreg.cmn \ x11adj.cmn x11log.cmn chkchi.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ notset.prm prior.cmn prior.prm srslen.prm units.cmn usrreg.cmn chkeas.o: srslen.prm xeastr.cmn chkmu.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ notset.prm prior.cmn prior.prm srslen.prm stdio.i units.cmn chkorv.o: cchars.i error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ ssprep.cmn units.cmn chkrt1.o: error.cmn mdldat.cmn model.cmn model.prm notset.prm srslen.prm chkrt2.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn chkrts.o: mdldat.cmn model.cmn model.prm srslen.prm chksmd.o: error.cmn model.cmn model.prm srslen.prm stdio.i units.cmn chktrn.o: extend.cmn hiddn.cmn notset.prm stdio.i units.cmn x11ptr.cmn chkuhg.o: model.prm srslen.prm chkurt.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm chkzro.o: force.cmn goodob.cmn srslen.prm chrt.o: chrt.cmn error.cmn srslen.prm tbltitle.prm x11opt.cmn chusrg.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ usrreg.cmn clrotl.o: error.cmn model.cmn model.prm srslen.prm cmpchi.o: error.cmn model.cmn model.prm notset.prm picktd.cmn srslen.prm \ units.cmn usrreg.cmn usrxrg.cmn cmpstr.o: lex.i cncrnt.o: cchars.i error.cmn notset.prm seattb.i tbllog.cmn tbllog.prm cnvmdl.o: error.cmn model.cmn model.prm srslen.prm coladd.o: stdio.i units.cmn combft.o: hiddn.cmn srslen.prm ssap.prm ssft.cmn tests.cmn title.cmn \ units.cmn compb.o: srslen.prm ssap.cmn ssap.prm compdiag.o: srslen.prm compmse.o: srslen.prm cormtx.o: error.cmn model.cmn model.prm notset.prm srslen.prm units.cmn corplt.o: stdio.i units.cmn covar.o: model.prm notset.prm srslen.prm ctodat.o: model.prm srslen.prm cvrerr.o: error.cmn stdio.i units.cmn delstr.o: error.cmn stdio.i units.cmn deltst.o: error.cmn hiddn.cmn mdldat.cmn model.cmn model.prm notset.prm \ srslen.prm stdio.i units.cmn desreg.o: error.cmn model.prm srslen.prm title.cmn units.cmn divgud.o: goodob.cmn notset.prm srslen.prm divsub.o: srslen.prm x11opt.cmn dlrgef.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn dlusrg.o: arima.cmn model.prm srslen.prm stdio.i units.cmn usrreg.cmn dot.o: chrt.cmn srslen.prm dsarma.o: model.cmn model.prm srslen.prm units.cmn dtoc.o: savcmn.cmn stdio.i units.cmn easaic.o: adj.cmn arima.cmn error.cmn extend.cmn lkhd.cmn mdldat.cmn \ model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm \ units.cmn x11adj.cmn easter.o: srslen.prm xeastr.cmn editor.o: adj.cmn agr.cmn agrsrs.cmn arima.cmn cmpsvl.i cmptbl.i dgnsvl.i \ error.cmn extend.cmn filetb.cmn force.cmn frctbl.i goodob.cmn \ hender.prm hiddn.cmn inpt.cmn lzero.cmn mdldat.cmn mdlsvl.i \ mdltbl.i metadata.cmn metadata.prm missng.cmn model.cmn model.prm \ notset.prm picktd.cmn prior.cmn prior.prm priusr.cmn rho.cmn \ setsvl.i spcsvl.i spctbl.i srslen.prm ssap.cmn ssap.prm sspinp.cmn \ stdio.i sums.i sumtab.prm sumtab.var svllog.cmn svllog.prm \ tbllog.cmn tbllog.prm title.cmn units.cmn usrreg.cmn usrxrg.cmn \ work2.cmn x11adj.cmn x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11reg.cmn x11svl.i xeastr.cmn xrgfct.cmn xrgmdl.cmn xrgum.cmn \ xtrm.cmn eltlen.o: stdio.i units.cmn ends.o: hender.prm errhdr.o: hiddn.cmn notset.prm rev.cmn rev.prm srslen.prm ssap.prm \ ssft.cmn units.cmn estrmu.o: srslen.prm exctma.o: mdldat.cmn model.cmn model.prm srslen.prm extend.o: extend.cmn mdldat.cmn model.prm srslen.prm stdio.i units.cmn \ x11msc.cmn x11opt.cmn x11ptr.cmn extsgnl.o: srslen.prm f3cal.o: inpt2.cmn srslen.prm tests.cmn work2.cmn x11opt.cmn x11ptr.cmn f3gen.o: mq3.cmn srslen.prm work2.cmn fclose.o: stdio.i fcnar.o: error.cmn mdldat.cmn model.cmn model.prm notset.prm series.cmn \ srslen.prm stdio.i units.cmn fcstxy.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm fgen.o: mq3.cmn srslen.prm title.cmn x11opt.cmn fopen.o: stdio.i units.cmn fstop.o: stdio.i ftest.o: agr.cmn hiddn.cmn srslen.prm ssap.prm ssft.cmn tests.cmn \ title.cmn units.cmn x11msc.cmn x11opt.cmn fxshfr.o: global.cmn model.prm srslen.prm gendff.o: srslen.prm genfor.o: agr.cmn filetb.cmn stdio.i title.cmn units.cmn genqs.o: adxser.cmn arima.cmn extend.cmn inpt.cmn model.cmn model.prm \ notset.prm orisrs.cmn rho.cmn seatcm.cmn seatlg.cmn spctbl.i \ srslen.prm tbllog.cmn tbllog.prm units.cmn x11adj.cmn x11fac.cmn \ x11ptr.cmn x11srs.cmn genrtt.o: mdldat.cmn model.cmn model.prm srslen.prm genssm.o: calc.i dimensions.i notset.prm seatdg.cmn srslen.prm getadj.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i tbllog.i \ units.cmn getchk.o: error.cmn hiddn.cmn lex.i mdltbl.i notset.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn getchr.o: lex.i getcmp.o: error.cmn lex.i notset.prm stdio.i svllog.i tbllog.cmn tbllog.i \ tbllog.prm units.cmn getdat.o: lex.i srslen.prm getdbl.o: lex.i getdes.o: desadj.prm desadj.var descm2.prm descm2.var descmp.prm \ descmp.var desdgn.prm desdgn.var desdg2.prm desdg2.var \ desfsa.prm desfsa.var desmdl.prm desmdl.var desset.prm desset.var \ desst2.prm desst2.var desspc.prm desspc.var dessrs.prm dessrs.var \ desx11.prm desx11.var desxrg.prm desxrg.var tbltitle.prm getdiag.o: acfast.i across.i hiddn.cmn mdldat.cmn model.prm revs.i \ srslen.prm stdio.i tbl5x.i units.cmn getfcn.o: lex.i notset.prm getfrc.o: error.cmn lex.i notset.prm stdio.i tbllog.i units.cmn getgr.o: sform.i srslen.prm getid.o: error.cmn lex.i model.cmn model.prm notset.prm srslen.prm \ tbllog.i getint.o: lex.i getivc.o: lex.i notset.prm getmdl.o: error.cmn lex.i model.cmn model.prm srslen.prm getmtd.o: extend.cmn mdldat.cmn model.cmn model.prm notset.prm picktd.cmn \ srslen.prm tdtyp.cmn x11opt.cmn getopr.o: error.cmn lex.i model.prm notset.prm srslen.prm getprt.o: hiddn.cmn level.prm level.var lex.i stdio.i table.prm table.var \ tbllog.cmn tbllog.prm units.cmn getreg.o: error.cmn lex.i mdldat.cmn model.cmn model.prm notset.prm \ picktd.cmn srslen.prm stdio.i svllog.i tbllog.i units.cmn \ usrreg.cmn getrev.o: model.prm rev.cmn rev.prm revsrs.cmn revtrg.cmn srslen.prm \ stdio.i units.cmn getsav.o: lex.i stable.prm stable.var stdio.i tbllog.cmn tbllog.prm \ units.cmn getsma.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm getsrs.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn getssp.o: error.cmn lex.i notset.prm srslen.prm ssap.prm svllog.i \ tbllog.i getstr.o: error.cmn stdio.i units.cmn getsvl.o: lex.i stdio.i svllog.cmn svllog.prm svltbl.prm svltbl.var \ units.cmn getttl.o: error.cmn lex.i notset.prm getx11.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn getxop.o: error.cmn stdio.i getxtd.o: model.cmn model.prm notset.prm picktd.cmn srslen.prm \ tdtyp.cmn xtdtyp.cmn glbshk.o: srslen.prm x11ptr.cmn gnfcrv.o: model.prm rev.cmn rev.prm revsrs.cmn srslen.prm grzlst.o: chrt.cmn srslen.prm grzmth.o: chrt.cmn srslen.prm grzmyr.o: chrt.cmn srslen.prm gtarg.o: error.cmn lex.i notset.prm gtarma.o: error.cmn lex.i model.cmn model.prm notset.prm srslen.prm gtauto.o: error.cmn lex.i mdltbl.i notset.prm stdio.i svllog.i tbllog.cmn \ tbllog.i tbllog.prm units.cmn gtautx.o: error.cmn lex.i model.prm notset.prm srslen.prm svllog.i \ tbllog.i gtdcnm.o: lex.i gtdcvc.o: error.cmn lex.i gtdpvc.o: error.cmn lex.i notset.prm gtdtvc.o: error.cmn lex.i notset.prm gtedit.o: stdio.i units.cmn x11msc.cmn gtestm.o: error.cmn lex.i mdltbl.i model.cmn model.prm notset.prm \ srslen.prm stdio.i svllog.i tbllog.cmn tbllog.i tbllog.prm \ units.cmn gtfcst.o: error.cmn lex.i notset.prm srslen.prm tbllog.i gtfldt.o: lex.i notset.prm stdio.i units.cmn gtfrcm.o: lex.i stdio.i units.cmn gtfree.o: stdio.i units.cmn gtinpt.o: adj.cmn agr.cmn arima.cmn deftab.prm deftab.var error.cmn \ extend.cmn force.cmn fxreg.cmn hiddn.cmn lex.i mdldat.cmn \ metadata.cmn metadata.prm missng.cmn model.cmn model.prm \ notset.prm picktd.cmn priadj.cmn prior.cmn prior.prm prittl.cmn \ priusr.cmn rev.cmn rev.prm revtrg.cmn rho.cmn savcmn.cmn \ seatlg.cmn seatop.cmn srslen.prm sspinp.cmn stdio.i sumtab.prm \ sumtab.var svllog.cmn svllog.prm tbllog.cmn tbllog.prm title.cmn \ tukey.cmn units.cmn usrreg.cmn usrxrg.cmn x11adj.cmn x11log.cmn \ x11msc.cmn x11opt.cmn x11reg.cmn xclude.cmn xrgfct.cmn xrgmdl.cmn \ xrgum.cmn xtrm.cmn gtinvl.o: error.cmn lex.i mdldat.cmn model.cmn model.prm srslen.prm gtmdfl.o: error.cmn model.cmn model.prm notset.prm srslen.prm stdio.i \ usrreg.cmn x11adj.cmn gtmtdt.o: error.cmn lex.i metadata.cmn metadata.prm notset.prm stdio.i gtmtfl.o: notset.prm stdio.i gtnmvc.o: error.cmn lex.i notset.prm gtotlr.o: error.cmn lex.i notset.prm svllog.i tbllog.i gtpdrg.o: error.cmn lex.i gtrgdt.o: lex.i gtrgpt.o: model.cmn model.prm srslen.prm gtrgvl.o: lex.i model.prm srslen.prm gtrvst.o: error.cmn lex.i notset.prm rev.prm srslen.prm stdio.i svllog.i \ tbllog.i units.cmn gtseat.o: error.cmn lex.i notset.prm stdio.i svllog.i tbllog.cmn tbllog.i \ tbllog.prm units.cmn gtspec.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn gttrmo.o: stdio.i units.cmn x11msc.cmn gtx11d.o: notset.prm stdio.i units.cmn x11msc.cmn gtx12s.o: stdio.i units.cmn gtxreg.o: error.cmn lex.i mdldat.cmn model.cmn model.prm notset.prm \ picktd.cmn srslen.prm stdio.i svllog.i tbllog.i units.cmn \ usrxrg.cmn hist.o: error.cmn model.prm srslen.prm units.cmn histx.o: error.cmn srslen.prm ssap.prm tfmts.cmn units.cmn hndend.o: hender.prm hndtrn.o: hender.prm x11msc.cmn holday.o: error.cmn extend.cmn hiddn.cmn lzero.cmn srslen.prm tbllog.cmn \ tbllog.prm x11adj.cmn x11fac.cmn x11opt.cmn x11ptr.cmn x11tbl.i \ xeastr.cmn holidy.o: kdate.prm srslen.prm xeastr.cmn hrest.o: autoq.cmn error.cmn model.prm srslen.prm units.cmn htmlout.o: build.i dimensions.i dirs.i models.i peaks.i polynom.i seatserr.i \ sername.i sform.i sig.i spectra.i spectrum.i srslen.prm stdio.i \ stream.i sums.i transcad.i units.cmn iddiff.o: arima.cmn error.cmn extend.cmn mdldat.cmn mdltbl.i model.cmn \ model.prm notset.prm prior.cmn prior.prm srslen.prm stdio.i \ tbllog.cmn tbllog.prm units.cmn idmdl.o: acfptr.prm error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ srslen.prm stdio.i tbllog.cmn tbllog.i tbllog.prm units.cmn idotlr.o: cchars.i error.cmn fxreg.cmn hiddn.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm notset.prm srslen.prm stdio.i tbllog.cmn \ tbllog.prm units.cmn xrgtbl.i idpeak.o: notset.prm units.cmn initdg.o: error.cmn notset.prm seatdg.cmn setsvl.i svllog.cmn svllog.prm \ units.cmn initst.o: notset.prm seatlg.cmn seatmd.cmn srslen.prm stcfcm.cmn inpter.o: lex.i stdio.i title.cmn units.cmn insdbl.o: error.cmn insint.o: error.cmn inslg.o: error.cmn insopr.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm insptr.o: error.cmn stdio.i units.cmn insstr.o: error.cmn intgpg.o: mdldat.cmn model.cmn model.prm srslen.prm intinp.o: error.cmn lex.i invfcn.o: stdio.i units.cmn issame.o: goodob.cmn srslen.prm itoc.o: stdio.i units.cmn itrerr.o: stdio.i units.cmn kfcn.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm xtdtyp.cmn kwtest.o: hiddn.cmn srslen.prm tests.cmn title.cmn units.cmn lendp.o: notset.prm lex.o: cchars.i lex.i lmdif.o: error.cmn loadxr.o: arima.cmn mdldat.cmn model.cmn model.prm picktd.cmn prior.cmn \ prior.prm srslen.prm usrreg.cmn usrxrg.cmn x11adj.cmn xrgmdl.cmn locshk.o: srslen.prm units.cmn x11ptr.cmn lomaic.o: adj.cmn arima.cmn error.cmn extend.cmn lkhd.cmn mdldat.cmn \ model.cmn model.prm notset.prm picktd.cmn prior.cmn prior.prm \ srslen.prm units.cmn lstpth.o: lex.i makadj.o: adj.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm makotl.o: model.prm srslen.prm makttl.o: cmptbl.i error.cmn fctlbl.prm fctlbl.var force.cmn frctbl.i \ mq3.cmn stdio.i tbllbl.prm tbllbl.var tbltitle.prm units.cmn \ x11tbl.i map.o: lex.i matrix.o: matrix1.i matrix2.i sums.i mdlchk.o: autoq.cmn mdldat.cmn model.cmn model.prm srslen.prm mdlfix.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm mdlinp.o: error.cmn lex.i mdlint.o: mdldat.cmn model.cmn model.prm srslen.prm mdlmch.o: notset.prm mdlset.o: error.cmn model.cmn model.prm srslen.prm stdio.i units.cmn medabs.o: model.prm srslen.prm stdio.i units.cmn mflag.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn mkback.o: adj.cmn arima.cmn cchars.i error.cmn extend.cmn hiddn.cmn \ mdldat.cmn mdltbl.i model.cmn model.prm priusr.cmn savcmn.cmn \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn x11adj.cmn \ x11fac.cmn x11log.cmn x11opt.cmn mkealb.o: error.cmn notset.prm mkfreq.o: notset.prm spcidx.cmn mklnlb.o: error.cmn notset.prm mkmdsn.o: error.cmn mkoprt.o: error.cmn model.prm srslen.prm mkotky.o: error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm srslen.prm \ units.cmn mkpeak.o: spcidx.cmn mkshdr.o: force.cmn hiddn.cmn picktd.cmn prior.cmn prior.prm srslen.prm \ x11adj.cmn x11log.cmn x11opt.cmn mksplb.o: spctbl.i mkspst.o: hiddn.cmn prior.cmn prior.prm srslen.prm x11adj.cmn x11log.cmn \ x11opt.cmn mkssky.o: srslen.prm ssap.cmn ssap.prm title.cmn units.cmn mktdlb.o: error.cmn notset.prm mlist.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn title.cmn \ units.cmn mltpos.o: model.prm srslen.prm month.o: chrt.cmn error.cmn srslen.prm mstest.o: hiddn.cmn srslen.prm ssap.prm ssft.cmn tests.cmn title.cmn \ units.cmn x11opt.cmn mulqmat.o: srslen.prm mxpeak.o: notset.prm newest.o: global.cmn model.prm srslen.prm nextk.o: global.cmn model.prm srslen.prm nmlmdl.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn nofcst.o: arima.cmn extend.cmn model.prm prior.cmn prior.prm srslen.prm nrmtst.o: nrmtst.var stdio.i units.cmn olsreg.o: stdio.i units.cmn opnfil.o: error.cmn filetb.cmn filext.prm filext.var gmeta.prm gmeta.var \ notset.prm stdio.i tbllog.prm tbltitle.prm otsort.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm outchr.o: chrt.cmn srslen.prm tbltitle.prm units.cmn pacf.o: srslen.prm units.cmn pass0.o: arima.cmn error.cmn extend.cmn model.cmn model.prm picktd.cmn \ prior.cmn prior.prm srslen.prm units.cmn pass2.o: adj.cmn arima.cmn error.cmn extend.cmn inpt.cmn mdldat.cmn \ model.cmn model.prm picktd.cmn prior.cmn prior.prm priusr.cmn \ series.cmn srslen.prm units.cmn pctrit.o: dgnsvl.i notset.prm srslen.prm ssap.prm svllog.cmn svllog.prm \ units.cmn polynom.o: dimensions.i hspect.i models.i polynom.i srslen.prm stream.i pracf2.o: error.cmn mdldat.cmn mdltbl.i model.cmn model.prm notset.prm \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn prafce.o: title.cmn pragr2.o: error.cmn tbllog.cmn tbllog.prm prfcrv.o: cchars.i error.cmn model.prm rev.cmn rev.prm revsrs.cmn \ srslen.prm svllog.cmn svllog.prm tbllog.cmn tbllog.prm title.cmn \ units.cmn pritd.o: error.cmn model.prm srslen.prm prlkhd.o: extend.cmn hiddn.cmn lkhd.cmn lzero.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm notset.prm srslen.prm units.cmn x11adj.cmn \ x11fac.cmn x11log.cmn x11opt.cmn procflts.o: cmpflts.i prothd.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn prprad.o: units.cmn prrvob.o: srslen.prm tfmts.cmn title.cmn units.cmn prshd2.o: error.cmn title.cmn units.cmn prtacf.o: acfptr.prm error.cmn mdldat.cmn mdlsvl.i model.cmn model.prm \ notset.prm srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm units.cmn prtadj.o: error.cmn lzero.cmn mdltbl.i orisrs.cmn priadj.cmn priusr.cmn \ srslen.prm tbllog.cmn tbllog.prm prtagr.o: error.cmn tbllog.cmn tbllog.prm prtamd.o: error.cmn fxreg.cmn model.cmn model.prm notset.prm srslen.prm \ title.cmn units.cmn prtchi.o: model.prm notset.prm srslen.prm title.cmn prtcol.o: srslen.prm prtd8b.o: arima.cmn error.cmn extend.cmn hiddn.cmn mdldat.cmn model.cmn \ model.prm notset.prm srslen.prm stdio.i tbltitle.prm tfmts.cmn \ tfmts.prm tfmts.var tfmts2.prm tfmts2.var title.cmn units.cmn \ x11adj.cmn x11opt.cmn prtd9a.o: error.cmn hiddn.cmn srslen.prm tfmts.cmn tfmts.prm tfmts.var \ units.cmn x11opt.cmn prtdtb.o: mq3.cmn notset.prm picktd.cmn prior.cmn prior.prm srslen.prm \ title.cmn units.cmn x11opt.cmn prtdwr.o: arima.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn prterr.o: error.cmn hiddn.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn prterx.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ stdio.i tbllog.cmn tbllog.prm units.cmn xrgtbl.i prtf2.o: inpt2.cmn mq3.cmn srslen.prm tests.cmn title.cmn work2.cmn \ x11opt.cmn prtf2w.o: inpt2.cmn mq3.cmn srslen.prm tests.cmn title.cmn work2.cmn \ x11opt.cmn prtfct.o: adj.cmn cchars.i error.cmn hiddn.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm prior.cmn prior.prm priusr.cmn rev.cmn rev.prm \ revsrs.cmn savcmn.cmn seatad.cmn srslen.prm stdio.i tbllog.cmn \ tbllog.prm units.cmn x11fac.cmn x11log.cmn prtft.o: hiddn.cmn model.prm notset.prm srslen.prm title.cmn units.cmn prtitr.o: error.cmn mdltbl.i model.cmn model.prm notset.prm series.cmn \ srslen.prm tbllog.cmn tbllog.prm units.cmn prtlog.o: stdio.i prtmdl.o: cchars.i cogreg.prm cogreg.var error.cmn hiddn.cmn mdldat.cmn \ mdldg.cmn mdlsvl.i mdltbl.i model.cmn model.prm notset.prm \ picktd.cmn rev.cmn rev.prm srslen.prm sspinp.cmn svllog.cmn \ svllog.prm title.cmn units.cmn prtmsp.o: error.cmn title.cmn units.cmn prtmsr.o: cchars.i desadj.prm desadj.var error.cmn rev.cmn rev.prm \ srslen.prm tbllog.cmn tbllog.prm tbltitle.prm tfmts.cmn tfmts.prm \ tfmts.var units.cmn prtmtx.o: error.cmn title.cmn units.cmn prtnfn.o: title.cmn units.cmn prtopt.o: model.cmn model.prm srslen.prm units.cmn prtref.o: error.cmn mdldat.cmn mdltbl.i model.cmn model.prm srslen.prm \ title.cmn usrreg.cmn prtrev.o: cchars.i desdgn.prm desdgn.var dgnsvl.i error.cmn notset.prm \ rev.cmn rev.prm srslen.prm svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm tbltitle.prm tfmts.cmn units.cmn x11msc.cmn x11opt.cmn prtrts.o: cchars.i error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ srslen.prm units.cmn prtrv2.o: cchars.i desdgn.prm desdgn.var dgnsvl.i error.cmn notset.prm \ rev.cmn rev.prm srslen.prm svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm tbltitle.prm tfmts.cmn units.cmn x11msc.cmn x11opt.cmn prtsft.o: model.prm notset.prm srslen.prm title.cmn units.cmn prtshd.o: error.cmn title.cmn units.cmn prttbl.o: model.prm srslen.prm title.cmn units.cmn prttd.o: units.cmn prttrn.o: error.cmn hiddn.cmn model.prm notset.prm srslen.prm stdio.i \ tbltitle.prm tfmts.cmn tfmts.prm tfmts.var tfmts2.prm tfmts2.var \ title.cmn units.cmn x11opt.cmn x11ptr.cmn prtukp.o: arima.cmn error.cmn model.prm rho.cmn spctbl.i srslen.prm \ title.cmn tukey.cmn prtxrg.o: cchars.i cogreg.prm cogreg.var error.cmn hiddn.cmn mdldat.cmn \ model.cmn model.prm notset.prm picktd.cmn srslen.prm units.cmn \ x11reg.cmn punch.o: extend.cmn hiddn.cmn srslen.prm title.cmn x11opt.cmn putbak.o: lex.i putrev.o: agr.cmn putstr.o: error.cmn qcmmnt.o: cchars.i lex.i qcontr.o: agr.cmn title.cmn units.cmn qintgr.o: lex.i qmap2.o: cmptbl.i error.cmn force.cmn frctbl.i srslen.prm tbllog.cmn \ tbllog.prm qname.o: lex.i qquote.o: cchars.i lex.i qsdiff.o: srslen.prm qtoken.o: cchars.i lex.i quadit.o: global.cmn model.prm srslen.prm ratneg.o: model.prm srslen.prm ratpos.o: model.prm srslen.prm rdotlr.o: lex.i model.prm srslen.prm rdotls.o: lex.i model.prm srslen.prm realit.o: global.cmn model.prm srslen.prm regfix.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm reglbl.o: model.prm srslen.prm regvar.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn usrreg.cmn regx11.o: error.cmn mdldat.cmn model.cmn model.prm series.cmn srslen.prm \ stdio.i units.cmn xclude.cmn replyf.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm resid.o: stdio.i units.cmn resid2.o: srslen.prm xtdtyp.cmn restor.o: arima.cmn lzero.cmn mdldat.cmn model.cmn model.prm picktd.cmn \ prior.cmn prior.prm srslen.prm ssprep.cmn usrreg.cmn x11adj.cmn \ x11opt.cmn revchk.o: error.cmn extend.cmn model.cmn model.prm rev.cmn rev.prm \ revtbl.i revtrg.cmn seatlg.cmn srslen.prm stdio.i tbllog.cmn \ tbllog.prm units.cmn usrreg.cmn x11adj.cmn x11log.cmn x11reg.cmn revdrv.o: arima.cmn cchars.i dgnsvl.i error.cmn extend.cmn hiddn.cmn \ inpt.cmn lkhd.cmn mdldat.cmn mdltbl.i missng.cmn model.cmn \ model.prm notset.prm orisrs.cmn otlrev.cmn otxrev.cmn picktd.cmn \ rev.cmn rev.prm revsrs.cmn revtbl.i revtrg.cmn seatdg.cmn \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ title.cmn units.cmn usrreg.cmn usrxrg.cmn x11adj.cmn x11log.cmn \ x11opt.cmn x11ptr.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn xrgtbl.i revhdr.o: error.cmn rev.cmn rev.prm revtrg.cmn srslen.prm units.cmn rgarma.o: error.cmn hiddn.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ series.cmn srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn rgtdhl.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ prior.cmn prior.prm srslen.prm x11log.cmn x11msc.cmn x11opt.cmn \ x11ptr.cmn x11reg.cmn x11srs.cmn xtdtyp.cmn rmatot.o: cchars.i error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ ssprep.cmn title.cmn units.cmn rmfix.o: error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm srslen.prm rmlnvr.o: error.cmn model.cmn model.prm notset.prm picktd.cmn srslen.prm rmlpyr.o: adj.cmn arima.cmn error.cmn inpt.cmn mdldat.cmn model.cmn \ model.prm picktd.cmn prior.cmn prior.prm priusr.cmn srslen.prm rmotrv.o: cchars.i error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ title.cmn units.cmn rmotss.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm rmpadj.o: lzero.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm rmtadj.o: lzero.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm rndsa.o: srslen.prm stdio.i units.cmn x11opt.cmn rngbuf.o: cchars.i lex.i stdio.i roots.o: model.prm srslen.prm stdio.i units.cmn rplus.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn rpoly.o: global.cmn model.prm srslen.prm rv2ss.o: adj.cmn agr.cmn arima.cmn extend.cmn hiddn.cmn inpt.cmn \ lzero.cmn mdldat.cmn model.prm orisrs.cmn seatlg.cmn seatmd.cmn \ srslen.prm ss2rv.cmn ssprep.cmn stcfcm.cmn tbllog.cmn tbllog.prm \ usrxrg.cmn x11opt.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn rvarma.o: error.cmn mdldat.cmn model.cmn model.prm rev.prm srslen.prm rvfixd.o: model.prm srslen.prm rvrghd.o: cchars.i revtbl.i title.cmn rvtdrg.o: error.cmn mdldat.cmn model.cmn model.prm picktd.cmn rev.prm \ srslen.prm usrreg.cmn savacf.o: autoq.cmn cchars.i error.cmn mdltbl.i notset.prm srslen.prm savchi.o: model.prm notset.prm srslen.prm units.cmn savd8b.o: cchars.i error.cmn filext.prm filext.var tbllog.prm savitr.o: cchars.i mdldat.cmn mdltbl.i model.cmn model.prm savcmn.cmn \ srslen.prm savmdc.o: notset.prm seatmd.cmn srslen.prm savmdl.o: error.cmn mdldat.cmn mdltbl.i model.cmn model.prm picktd.cmn \ savcmn.cmn srslen.prm usrreg.cmn x11adj.cmn savmtx.o: cchars.i error.cmn model.prm savcmn.cmn srslen.prm savotl.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn \ usrreg.cmn savpk.o: rho.cmn spcsvl.i svllog.cmn svllog.prm units.cmn savspp.o: cchars.i error.cmn savtbl.o: cchars.i error.cmn filext.prm filext.var tbllog.prm savtpk.o: spcsvl.i svllog.cmn svllog.prm units.cmn savwkf.o: cchars.i error.cmn notset.prm seatmd.cmn srslen.prm sdev.o: notset.prm sdxtrm.o: srslen.prm xtrm.cmn seatad.o: seatcm.cmn seatlg.cmn srslen.prm x11adj.cmn x11fac.cmn \ x11ptr.cmn seatdg.o: calc.i cmpflts.i dimensions.i error.cmn force.cmn inpt.cmn \ mdldat.cmn model.cmn model.prm notset.prm orisrs.cmn rev.cmn rev.prm \ revtbl.i seatcm.cmn seatdg.cmn seatlg.cmn seattb.i setsvl.i sig.i \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ units.cmn x11ptr.cmn seatfc.o: force.cmn inpt.cmn orisrs.cmn seatcm.cmn srslen.prm x11adj.cmn \ x11fac.cmn x11ptr.cmn seatpr.o: adj.cmn calc.i desset.prm desset.var dimensions.i error.cmn \ extend.cmn force.cmn frctbl.i inpt.cmn mdltbl.i notset.prm \ priusr.cmn seatcm.cmn seatdg.cmn seatlg.cmn seatmd.cmn seattb.i \ sig.i spctbl.i srslen.prm tbllog.cmn tbllog.prm tbltitle.prm \ title.cmn x11adj.cmn x11fac.cmn x11ptr.cmn serates.o: units.cmn setamx.o: error.cmn stdio.i units.cmn setapt.o: agr.cmn extend.cmn notset.prm x11ptr.cmn setcv.o: notset.prm stdio.i units.cmn setcvl.o: notset.prm stdio.i units.cmn setmdl.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn setopr.o: error.cmn model.prm notset.prm srslen.prm stdio.i units.cmn setpt.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm setrvp.o: rev.cmn rev.prm revtrg.cmn srslen.prm setssp.o: agr.cmn error.cmn extend.cmn lzero.cmn model.prm notset.prm \ srslen.prm ssap.cmn ssap.prm sspinp.cmn stdio.i units.cmn \ x11adj.cmn x11log.cmn x11opt.cmn xrgmdl.cmn setup.o: chrt.cmn rho.cmn srslen.prm setxpt.o: extend.cmn lzero.cmn x11ptr.cmn sfmax.o: srslen.prm sfmsr.o: srslen.prm units.cmn work2.cmn x11opt.cmn sftest.o: error.cmn mdldat.cmn mdldg.cmn model.cmn model.prm notset.prm \ srslen.prm units.cmn usrreg.cmn usrxrg.cmn shrink.o: srslen.prm x11ptr.cmn si.o: error.cmn srslen.prm tbllog.cmn tbllog.prm x11msc.cmn x11srs.cmn \ x11tbl.i xtrm.cmn sigex.o: acfst.i across.i bench.i buffers.i cmpflts.i cross.i date.i \ dimensions.i dirs.i error.cmn estb.i force.cmn func2.i func4.i func5.i \ hdflag.i hiddn.cmn hspect.i models.i notset.prm peaks.i pinno.i \ preadtr.i rtestm.i seastest.i seatop.cmn serrlev.i sesfcast.i \ sfcast.i sform.i sig.i sig1.i spe.i spectra.i spectrum.i srslen.prm \ stdio.i stream.i strmodel.i titl.i transcad.i units.cmn sigsub.o: dimensions.i revs.i seatop.cmn serrlev.i sesfcast.i sfcast.i \ srslen.prm stream.i transcad.i simul.o: srslen.prm skparg.o: lex.i skparm.o: lex.i skpfcn.o: lex.i skplst.o: lex.i smpeak.o: notset.prm spcdrv.o: adxser.cmn error.cmn extend.cmn hiddn.cmn inpt.cmn mdltbl.i \ model.cmn model.prm notset.prm orisrs.cmn prior.cmn prior.prm \ rho.cmn seatcm.cmn seatlg.cmn spcidx.cmn spcsvl.i spctbl.i \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ tbltitle.prm title.cmn tukey.cmn units.cmn x11adj.cmn x11fac.cmn \ x11log.cmn x11ptr.cmn x11srs.cmn spcrsd.o: error.cmn model.prm notset.prm rho.cmn spcidx.cmn spcsvl.i \ spctbl.i srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm tbltitle.prm tukey.cmn units.cmn special.o: spectrum.i stream.i specpeak.o: dimensions.i rho.cmn spectrum.i srslen.prm spectrum.o: buffers.i dimensions.i dirs.i error.cmn func.i func2.i func3.i \ func4.i func5.i hspect.i min.i pinno.i polynom.i seattb.i \ spectra.i spectrum.i srslen.prm stdio.i stream.i strmodel.i \ tbllog.cmn tbllog.prm test.i transcad.i units.cmn spgrh.o: notset.prm srslen.prm ss2rv.o: adj.cmn agr.cmn arima.cmn extend.cmn hiddn.cmn lzero.cmn \ mdldat.cmn model.cmn model.prm picktd.cmn seatlg.cmn seatmd.cmn \ srslen.prm ss2rv.cmn ssprep.cmn tbllog.cmn tbllog.prm usrreg.cmn \ usrxrg.cmn x11adj.cmn x11opt.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn ssap.o: dgnsvl.i error.cmn force.cmn mq3.cmn notset.prm srslen.prm \ ssap.cmn ssap.prm ssptbl.i stdio.i svllog.cmn svllog.prm \ tbllog.cmn tbllog.prm title.cmn units.cmn x11opt.cmn ssfnot.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn ssftst.o: srslen.prm ssap.prm ssft.cmn units.cmn sshist.o: error.cmn mq3.cmn notset.prm srslen.prm ssap.cmn ssap.prm \ units.cmn x11opt.cmn ssmdl.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm otlrev.cmn \ picktd.cmn srslen.prm sspinp.cmn ssprep.cmn stdio.i units.cmn \ usrreg.cmn x11adj.cmn sspdrv.o: arima.cmn dgnsvl.i error.cmn hiddn.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm notset.prm otlrev.cmn revtbl.i srslen.prm \ ssap.cmn ssap.prm sspdat.cmn sspinp.cmn ssptbl.i svllog.cmn \ svllog.prm tbllog.cmn tbllog.prm title.cmn units.cmn usrreg.cmn \ usrxrg.cmn x11opt.cmn x11ptr.cmn xrgmdl.cmn xrgtbl.i ssphdr.o: force.cmn srslen.prm ssap.cmn ssap.prm units.cmn x11opt.cmn ssprep.o: arima.cmn mdldat.cmn model.cmn model.prm picktd.cmn prior.cmn \ prior.prm srslen.prm ssprep.cmn usrreg.cmn x11adj.cmn x11opt.cmn ssrit.o: agr.cmn agrsrs.cmn lzero.cmn notset.prm srslen.prm ssap.cmn \ ssap.prm ssft.cmn sspdat.cmn sspinp.cmn x11opt.cmn ssrng.o: notset.prm srslen.prm ssap.cmn ssap.prm ssptbl.i tbllog.cmn \ tbllog.prm units.cmn ssx11a.o: arima.cmn error.cmn extend.cmn inpt.cmn lzero.cmn mdldat.cmn \ missng.cmn model.cmn model.prm orisrs.cmn otlrev.cmn otxrev.cmn \ srslen.prm ssap.cmn ssap.prm ssft.cmn stdio.i units.cmn x11opt.cmn \ x11ptr.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn ssxmdl.o: arima.cmn error.cmn model.cmn model.prm otxrev.cmn srslen.prm \ sspinp.cmn stdio.i units.cmn usrxrg.cmn x11log.cmn x11reg.cmn \ xrgmdl.cmn stpitr.o: model.prm srslen.prm stdio.i units.cmn strinx.o: lex.i strtvl.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm sumry.o: goodob.cmn notset.prm srslen.prm x11opt.cmn svaict.o: arima.cmn error.cmn model.cmn model.prm picktd.cmn srslen.prm \ units.cmn svamcm.o: cchars.i error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ savcmn.cmn srslen.prm svchsd.o: srslen.prm units.cmn svf2f3.o: cmpsvl.i inpt2.cmn srslen.prm svllog.cmn svllog.prm tests.cmn \ work2.cmn x11opt.cmn x11svl.i svflt.o: cchars.i error.cmn svfltd.o: cchars.i error.cmn svfnrg.o: error.cmn model.prm srslen.prm units.cmn svfreq.o: notset.prm spcidx.cmn units.cmn svolit.o: cchars.i error.cmn mdltbl.i model.prm savcmn.cmn srslen.prm \ units.cmn xrgtbl.i svoudg.o: acfast.i across.i units.cmn svpeak.o: error.cmn notset.prm units.cmn svrgcm.o: cchars.i error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ notset.prm savcmn.cmn srslen.prm svrvhd.o: mq3.cmn rev.cmn rev.prm revtrg.cmn srslen.prm units.cmn svspan.o: cchars.i error.cmn srslen.prm ssap.cmn ssap.prm svtukp.o: notset.prm spctbl.i tukey.cmn units.cmn table.o: agr.cmn desfct.prm desfct.var desfc2.prm desfc2.var error.cmn \ extend.cmn force.cmn goodob.cmn hiddn.cmn missng.cmn notset.prm \ srslen.prm tbltitle.prm tfmts.cmn tfmts.prm tfmts.var title.cmn \ units.cmn x11opt.cmn x11ptr.cmn xtrm.cmn tblhdr.o: error.cmn extend.cmn force.cmn mq3.cmn notset.prm priusr.cmn \ srslen.prm title.cmn units.cmn x11adj.cmn x11msc.cmn x11opt.cmn \ x11reg.cmn td6var.o: error.cmn model.cmn model.prm srslen.prm td7var.o: model.prm srslen.prm tdaic.o: adj.cmn arima.cmn error.cmn extend.cmn inpt.cmn lkhd.cmn \ mdldat.cmn model.cmn model.prm notset.prm picktd.cmn priadj.cmn \ prior.cmn prior.prm priusr.cmn srslen.prm units.cmn tdftest.o: error.cmn mdldat.cmn mdldg.cmn model.cmn model.prm notset.prm \ picktd.cmn srslen.prm units.cmn usrreg.cmn usrxrg.cmn tdlom.o: adj.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm tdset.o: notset.prm srslen.prm tdtyp.cmn xtdtyp.cmn tdxtrm.o: notset.prm srslen.prm tbllog.cmn tbllog.prm x11ptr.cmn \ xclude.cmn templs.o: error.cmn lex.i mdldat.cmn model.cmn model.prm srslen.prm \ units.cmn tfmts.o: error.cmn srslen.prm stdio.i tfmts.cmn tfmts.prm tfmts.var \ units.cmn tfmts3.o: error.cmn totals.o: notset.prm trbias.o: srslen.prm trnaic.o: adj.cmn arima.cmn error.cmn extend.cmn hiddn.cmn inpt.cmn \ lkhd.cmn mdldat.cmn mdlsvl.i model.cmn model.prm mq3.cmn \ notset.prm picktd.cmn prior.cmn prior.prm priusr.cmn srslen.prm \ stdio.i svllog.cmn svllog.prm title.cmn units.cmn x11adj.cmn \ x11fac.cmn x11opt.cmn x11ptr.cmn x11srs.cmn trnfcn.o: stdio.i units.cmn tstdrv.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm tstmd1.o: adj.cmn arima.cmn error.cmn extend.cmn inpt.cmn mdldat.cmn \ model.cmn model.prm notset.prm picktd.cmn prior.cmn prior.prm \ priusr.cmn srslen.prm units.cmn tstmd2.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm notset.prm \ srslen.prm ttest.o: model.prm srslen.prm upespm.o: mdldat.cmn model.cmn model.prm srslen.prm usraic.o: adj.cmn arima.cmn error.cmn extend.cmn lkhd.cmn mdldat.cmn \ model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm \ units.cmn usrreg.cmn value.o: chrt.cmn srslen.prm varlog.o: goodob.cmn notset.prm srslen.prm vsfa.o: srslen.prm x11msc.cmn x11opt.cmn vsfb.o: srslen.prm x11msc.cmn x11opt.cmn vsfc.o: srslen.prm vtc.o: srslen.prm x11opt.cmn x11ptr.cmn vtest.o: srslen.prm x11opt.cmn weight.o: srslen.prm whitsp.o: cchars.i lex.i wr.o: titl.i transcad.i xxxs.i writln.o: units.cmn wrtdat.o: error.cmn model.prm srslen.prm wrtmss.o: notset.prm srslen.prm ssap.cmn ssap.prm units.cmn wrtotl.o: error.cmn stdio.i units.cmn wrttb2.o: error.cmn notset.prm srslen.prm wrttbl.o: error.cmn notset.prm srslen.prm x11aic.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ notset.prm srslen.prm units.cmn usrreg.cmn usrxrg.cmn x11adj.cmn \ x11log.cmn x11reg.cmn xclude.cmn xrgmdl.cmn xrgum.cmn xtdtyp.cmn x11ari.o: agr.cmn arima.cmn error.cmn extend.cmn lzero.cmn mdldat.cmn \ mdltbl.i model.prm notset.prm nsums.i priusr.cmn rho.cmn spcsvl.i \ spctbl.i srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm title.cmn tukey.cmn units.cmn x11adj.cmn x11log.cmn \ x11msc.cmn x11opt.cmn x11int.o: adj.cmn inpt.cmn srslen.prm x11fac.cmn x11opt.cmn x11srs.cmn \ xtrm.cmn x11mdl.o: adj.cmn arima.cmn desxrg.prm desxrg.var error.cmn extend.cmn \ hiddn.cmn inpt.cmn mdldat.cmn model.cmn model.prm notset.prm \ prior.cmn prior.prm rev.cmn rev.prm srslen.prm ssap.cmn ssap.prm \ sspinp.cmn stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ tbltitle.prm tdtyp.cmn title.cmn units.cmn usrreg.cmn x11adj.cmn \ x11fac.cmn x11log.cmn x11ptr.cmn x11reg.cmn x11svl.i xrgfct.cmn \ xrgmdl.cmn xrgtbl.i xrgum.cmn xtdtyp.cmn x11plt.o: error.cmn hiddn.cmn srslen.prm tbltitle.prm title.cmn units.cmn \ x11adj.cmn x11log.cmn x11opt.cmn x11tbl.i x11pt1.o: adj.cmn agr.cmn arima.cmn cmptbl.i error.cmn extend.cmn \ hiddn.cmn inpt.cmn mdldat.cmn mdltbl.i missng.cmn model.cmn \ model.prm notset.prm orisrs.cmn prior.cmn prior.prm priusr.cmn \ srslen.prm tbllog.cmn tbllog.prm units.cmn x11adj.cmn x11fac.cmn \ x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn x11reg.cmn xrgtbl.i x11pt2.o: agr.cmn cmptbl.i error.cmn extend.cmn hiddn.cmn inpt.cmn \ mdltbl.i orisrs.cmn prior.cmn prior.prm srslen.prm ssap.cmn \ ssap.prm stdio.i tbllog.cmn tbllog.prm tdtyp.cmn units.cmn \ x11adj.cmn x11fac.cmn x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11reg.cmn x11srs.cmn x11tbl.i xrgtbl.i xrgum.cmn xtrm.cmn x11pt3.o: adj.cmn adxser.cmn agr.cmn error.cmn extend.cmn force.cmn \ frctbl.i goodob.cmn hiddn.cmn inpt.cmn notset.prm orisrs.cmn \ priadj.cmn prior.cmn prior.prm priusr.cmn rev.cmn rev.prm revtbl.i \ srslen.prm tbllog.cmn tbllog.prm units.cmn x11adj.cmn x11fac.cmn \ x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn x11srs.cmn x11tbl.i \ xrgum.cmn xtrm.cmn x11pt4.o: adj.cmn adxser.cmn agr.cmn agrsrs.cmn cmptbl.i error.cmn \ force.cmn frctbl.i goodob.cmn hiddn.cmn inpt.cmn inpt2.cmn \ notset.prm orisrs.cmn prior.cmn prior.prm priusr.cmn srslen.prm \ stdio.i tbllog.cmn tbllog.prm tdtyp.cmn units.cmn work2.cmn \ x11adj.cmn x11fac.cmn x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11srs.cmn x11tbl.i x11ref.o: model.prm notset.prm srslen.prm xrgum.cmn xtdtyp.cmn x12hdr.o: agr.cmn build.prm cmptbl.i error.cmn force.cmn hiddn.cmn lex.i \ mdldat.cmn mdltbl.i metadata.cmn metadata.prm missng.cmn model.prm \ mq3.cmn notset.prm prior.cmn prior.prm rho.cmn spctbl.i srslen.prm \ stdio.i tbllog.cmn tbllog.prm title.cmn units.cmn x11adj.cmn \ x11log.cmn x11msc.cmn x11opt.cmn x11reg.cmn x11tbl.i x12run.o: agr.cmn dgnsvl.i hiddn.cmn lex.i notset.prm srslen.prm stdio.i \ svllog.cmn svllog.prm title.cmn units.cmn x11opt.cmn xchng.o: notset.prm srslen.prm ssap.prm xrgdiv.o: arima.cmn mdldat.cmn model.cmn model.prm srslen.prm usrreg.cmn xrgdrv.o: arima.cmn error.cmn extend.cmn hiddn.cmn inpt.cmn lzero.cmn \ mdldat.cmn model.cmn model.prm picktd.cmn priadj.cmn prior.cmn \ prior.prm priusr.cmn srslen.prm units.cmn usrreg.cmn x11adj.cmn \ x11opt.cmn x11ptr.cmn x11reg.cmn x11srs.cmn xrgmdl.cmn xrghol.o: arima.cmn mdldat.cmn model.cmn model.prm srslen.prm usrreg.cmn xrgtrn.o: srslen.prm tdtyp.cmn xtdtyp.cmn xrlkhd.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm xtrm.o: lzero.cmn notset.prm srslen.prm x11opt.cmn xtrm.cmn yrly.o: chrt.cmn srslen.prm component.o: component.i complagdiag.o: srslen.prm compcrodiag.o: srslen.prm phasegain.o: notset.prm altundovrtst.o: acfast.i across.i models.i stream.i m2q.o: srslen.prm chqsea.o: arima.cmn inpt.cmn mdldat.cmn model.cmn model.prm notset.prm \ orisrs.cmn rho.cmn srslen.prm units.cmn x11msc.cmn x11opt.cmn \ x11ptr.cmn x11srs.cmn npsa.o: dimensions.i srslen.prm gennpsa.o: adxser.cmn extend.cmn model.prm model.cmn notset.prm seatcm.cmn \ seatlg.cmn tbllog.cmn tbllog.prm srslen.prm rho.cmn \ units.cmn x11adj.cmn x11ptr.cmn x11srs.cmn prarma.o: mdldat.cmn model.prm model.cmn srslen.prm testodf.o: arima.cmn error.cmn extend.cmn mdldat.cmn mdldg.cmn mdlsvl.i \ mdltbl.i model.cmn model.prm notset.prm prior.cmn prior.prm \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ units.cmn makefile.gf0000664006604000003110000020516714521201530012270 0ustar sun00315steps# MKMF template makefile for protected mode executables. FC = gfortran LINKER = gfortran PROGRAM = x13as_ascii DEST = . EXTHDRS = FFLAGS = -O2 HDRS = LDFLAGS = -s LDMAP = LIBS = MAKEFILE = Makefile OBJS = aaamain.o abend.o acf.o acfar.o acfdgn.o \ acfhdr.o addadj.o addate.o addeas.o \ addfix.o addlom.o addmat.o addmul.o addotl.o \ addsef.o addsub.o addtd.o addusr.o adestr.o \ adjreg.o adjsrs.o adlabr.o adotss.o adpdrg.o \ adrgef.o adrgim.o adsncs.o adthnk.o aggmea.o \ agr.o agr1.o agr2.o agr3.o agr3s.o agrxpt.o \ amdest.o amdfct.o amdid.o amdid2.o amdprt.o \ amidot.o analts.o ansub1.o ansub10.o ansub11.o \ ansub2.o ansub3.o ansub4.o ansub5.o ansub7.o \ ansub8.o ansub9.o antilg.o apply.o ar30rg.o \ arfit.o arflt.o arima.o armacr.o armafl.o \ armats.o arspc.o autoer.o automd.o automx.o avedur.o \ aver.o averag.o bakusr.o bench.o bestmd.o \ bkdfmd.o bldcov.o blddif.o bstget.o bstmdl.o \ btrit.o calcqs.o calcqs2.o calcsc.o ceilng.o \ change.o chisq.o chitst.o chkadj.o chkchi.o \ chkcvr.o chkeas.o chkmu.o chkorv.o chkrt1.o \ chkrt2.o chkrts.o chksmd.o chktrn.o chkuhg.o \ chkurt.o chkzro.o chrt.o chsppf.o chusrg.o \ clrotl.o clsgrp.o cmpchi.o cmpstr.o cncrnt.o \ cnvfmt.o cnvmdl.o coladd.o combft.o compb.o \ compdiag.o compmse.o comprevs.o constant.o \ copy.o copycl.o copylg.o cormtx.o cornom.o \ corplt.o covar.o cpyint.o cpymat.o crosco.o \ ctod.o ctodat.o ctoi.o cumnor.o cvcmma.o \ cvdttm.o cvrerr.o daxpy.o dcopy.o ddot.o \ decibl.o delstr.o deltst.o desreg.o devlpl.o \ dfdate.o dgefa.o dgesl.o difflt.o dinvnr.o \ divgud.o divsub.o dlrgef.o dlrgrw.o dlusrg.o \ dot.o dpeq.o dpmpar.o dppdi.o dppfa.o dppsl.o \ dsarma.o dscal.o dsolve.o dtoc.o easaic.o \ easter.o editor.o eltfcn.o eltlen.o emcomp.o \ ends.o endsf.o enorm.o entsch.o errhdr.o \ estrmu.o euclid.o exctma.o extend.o extsgnl.o \ f3cal.o f3gen.o fclose.o fcnar.o fcstxy.o \ fdjac2.o fgen.o fis.o fopen.o forcst.o \ fouger.o fstop.o ftest.o fvalue.o fxshfr.o \ gauss.o gendff.o genfor.o genqs.o genrtt.o \ genssm.o getadj.o getchk.o getchr.o \ getcmp.o getdat.o getdbl.o getdes.o getdiag.o \ getfcn.o getfrc.o getgr.o getid.o getidm.o \ getint.o getivc.o getmdl.o getmtd.o getopr.o \ getprt.o getreg.o getrev.o getsav.o getsma.o \ getsmat.o getsrs.o getssp.o getstr.o getsvec.o \ getsvl.o gettpltz.o gettr.o gettrc.o \ getttl.o getx11.o getxop.o getxtd.o glbshk.o \ gnfcrv.o grzlst.o grzmth.o grzmyr.o gtarg.o \ gtarma.o gtauto.o gtautx.o gtdcnm.o gtdcvc.o \ gtdpvc.o gtdtvc.o gtedit.o gtestm.o gtfcst.o \ gtfldt.o gtfrcm.o gtfree.o gtinpt.o gtinvl.o \ gtmdfl.o gtmtdt.o gtmtfl.o gtnmvc.o gtotlr.o \ gtpdrg.o gtrgdt.o gtrgpt.o gtrgvl.o gtrvst.o \ gtseat.o gtspec.o gttrmo.o gtwacf.o gtx11d.o \ gtx12s.o gtxreg.o hender.o hinge.o hist.o \ histx.o hndend.o hndtrn.o holday.o holidy.o \ hrest.o htmlout.o idamax.o iddiff.o idmdl.o \ idotlr.o idpeak.o inbtwn.o indx.o initdg.o \ initst.o inpter.o insdbl.o insint.o inslg.o \ insopr.o insort.o insptr.o insstr.o intfmt.o \ intgpg.o intinp.o intlst.o intrpp.o intsrt.o \ invfcn.o invmat.o ipmpar.o iscrfn.o isdate.o \ isfals.o isfixd.o ispeak.o ispos.o issame.o \ istrue.o itoc.o itrerr.o kfcn.o kwtest.o \ lassol.o lendp.o lex.o lgnrmc.o lkshnk.o \ lmdif.o lmpar.o loadxr.o locshk.o logar.o \ logdet.o lomaic.o lstpth.o makadj.o makotl.o \ makttl.o map.o matrix.o maxidx.o maxlag.o \ maxvec.o mdlchk.o mdlfix.o mdlinp.o mdlint.o \ mdlmch.o mdlset.o mdssln.o meancra.o medabs.o \ mflag.o minim2.o mkback.o mkealb.o mkfreq.o \ mklnlb.o mkmdsn.o mkmdsx.o mkoprt.o mkotky.o \ mkpeak.o mkshdr.o mkspky.o mksplb.o mkspst.o \ mkssky.o mkstlb.o mktdlb.o mlist.o mltpos.o month.o \ mstest.o mulmat.o mulqmat.o mulref.o mulsca.o \ mult.o mult0.o mult1.o mult2.o mxpeak.o \ nblank.o newest.o nextk.o nmlmdl.o nofcst.o \ nrmtst.o numaff.o numfmt.o olsreg.o opnfil.o \ otsort.o outchr.o pacf.o pass0.o pass2.o \ pctrit.o polyml.o polynom.o ppnd.o pracf2.o \ prafce.o pragr2.o prfcrv.o pritd.o prlkhd.o \ procflts.o prothd.o prprad.o prrvob.o \ prshd2.o prtacf.o prtadj.o prtagr.o prtamd.o \ prtchi.o prtcol.o prtd8b.o prtd9a.o prtdtb.o \ prtdwr.o prterr.o prterx.o prtf2.o prtf2w.o \ prtfct.o prtft.o prtitr.o prtlog.o prtmdl.o \ prtmsp.o prtmsr.o prtmtx.o prtnfn.o prtopt.o \ prtref.o prtrev.o prtrts.o prtrv2.o prtsft.o \ prtshd.o prttbl.o prttd.o prttrn.o prtukp.o \ prtxrg.o punch.o putbak.o putrev.o putstr.o \ qcmmnt.o qcontr.o qdoble.o qintgr.o qmap.o \ qmap2.o qname.o qquote.o qrfac.o qrsolv.o \ qsdiff.o qtoken.o quad.o quadit.o quadsd.o \ ratneg.o ratpos.o rdotlr.o rdotls.o rdregm.o \ realit.o regfix.o reglbl.o regvar.o regx11.o \ replac.o replyf.o resid.o resid2.o restor.o \ revchk.o revdrv.o revhdr.o revrse.o rgarma.o \ rgtdhl.o rho2.o rmatot.o rmfix.o rmlnvr.o \ rmlpyr.o rmotrv.o rmotss.o rmpadj.o rmtadj.o \ rndsa.o rngbuf.o roots.o round.o rplus.o \ rpoly.o rv2ss.o rvarma.o rvfixd.o rvrghd.o rvtdrg.o \ sautco.o savacf.o savchi.o savd8b.o savitr.o \ savmdc.o savmdl.o savmtx.o savotl.o savpk.o \ savspp.o savstp.o savtbl.o savtpk.o savwkf.o \ sceast.o scrmlt.o sdev.o sdxtrm.o seatad.o seatdg.o \ seatfc.o seatpr.o serates.o setadj.o setamx.o \ setapt.o setchr.o setcv.o setcvl.o \ setdp.o setint.o setlg.o setmdl.o setmv.o \ setopr.o setpt.o setrvp.o setspn.o setssp.o \ setup.o setwrt.o setxpt.o sfmax.o sfmsr.o \ sftest.o shlsrt.o shrink.o si.o sicp2.o \ sigex.o sigsub.o simul.o skparg.o skparm.o \ skpfcn.o skplst.o smeadl.o smpeak.o snrasp.o \ spcdrv.o spcrsd.o special.o specpeak.o \ spectrum.o spgrh.o spgrh2.o spmpar.o ss2rv.o \ ssap.o ssfnot.o ssftst.o sshist.o ssmdl.o \ ssort.o sspdrv.o ssphdr.o ssprep.o ssrit.o \ ssrng.o ssx11a.o ssxmdl.o stpitr.o strinx.o \ strtvl.o stvaln.o subset.o sumf.o sumry.o \ sumsqr.o svaict.o svamcm.o svchsd.o svdttm.o \ svf2f3.o svflt.o svfltd.o svfnrg.o svfreq.o \ svolit.o svoudg.o svpeak.o svrgcm.o svrvhd.o \ svspan.o svtukp.o table.o taper.o tblhdr.o \ td6var.o td7var.o tdaic.o tdftest.o tdlom.o \ tdset.o tdxtrm.o templs.o tfmts.o tfmts3.o \ totals.o transc.o trbias.o trnaic.o trnfcn.o \ tstdrv.o tstmd1.o tstmd2.o ttest.o uconv.o \ upespm.o usraic.o value.o varian.o varlog.o \ vars.o vsfa.o vsfb.o vsfc.o vtc.o vtest.o \ weight.o whitsp.o wr.o writln.o wrtdat.o \ wrtmss.o wrtotl.o wrttb2.o wrttbl.o wtxtrm.o \ x11aic.o x11ari.o x11int.o x11mdl.o x11plt.o \ x11pt1.o x11pt2.o x11pt3.o x11pt4.o x11ref.o \ x12hdr.o x12run.o xchng.o xpand.o xprmx.o \ xrgdiv.o xrgdrv.o xrghol.o xrgtrn.o xrlkhd.o \ xtrm.o yprmy.o yrly.o component.o complagdiag.o \ compcrodiag.o phasegain.o altundovrtst.o \ getrevdec.o m2q.o chqsea.o npsa.o gennpsa.o prarma.o \ testodf.o SRCS = aaamain.f abend.f acf.f acfar.f acfdgn.f \ acfhdr.f addadj.f addate.f addeas.f \ addfix.f addlom.f addmat.f addmul.f addotl.f \ addsef.f addsub.f addtd.f addusr.f adestr.f \ adjreg.f adjsrs.f adlabr.f adotss.f adpdrg.f \ adrgef.f adrgim.f adsncs.f adthnk.f aggmea.f \ agr.f agr1.f agr2.f agr3.f agr3s.f agrxpt.f \ amdest.f amdfct.f amdid.f amdid2.f amdprt.f \ amidot.f analts.f ansub1.f ansub10.f ansub11.f \ ansub2.f ansub3.f ansub4.f ansub5.f ansub7.f \ ansub8.f ansub9.f antilg.f apply.f ar30rg.f \ arfit.f arflt.f arima.f armacr.f armafl.f \ armats.f arspc.f autoer.f automd.f automx.f avedur.f \ aver.f averag.f bakusr.f bench.f bestmd.f \ bkdfmd.f bldcov.f blddif.f bstget.f bstmdl.f \ btrit.f calcqs.f calcqs2.f calcsc.f ceilng.f \ change.f chisq.f chitst.f chkadj.f chkchi.f \ chkcvr.f chkeas.f chkmu.f chkorv.f chkrt1.f \ chkrt2.f chkrts.f chksmd.f chktrn.f chkuhg.f \ chkurt.f chkzro.f chrt.f chsppf.f chusrg.f \ clrotl.f clsgrp.f cmpchi.f cmpstr.f cncrnt.f \ cnvfmt.f cnvmdl.f coladd.f combft.f compb.f \ compdiag.f compmse.f comprevs.f constant.f \ copy.f copycl.f copylg.f cormtx.f cornom.f \ corplt.f covar.f cpyint.f cpymat.f crosco.f \ ctod.f ctodat.f ctoi.f cumnor.f cvcmma.f \ cvdttm.f cvrerr.f daxpy.f dcopy.f ddot.f \ decibl.f delstr.f deltst.f desreg.f devlpl.f \ dfdate.f dgefa.f dgesl.f difflt.f dinvnr.f \ divgud.f divsub.f dlrgef.f dlrgrw.f dlusrg.f \ dot.f dpeq.f dpmpar.f dppdi.f dppfa.f dppsl.f \ dsarma.f dscal.f dsolve.f dtoc.f easaic.f \ easter.f editor.f eltfcn.f eltlen.f emcomp.f \ ends.f endsf.f enorm.f entsch.f errhdr.f \ estrmu.f euclid.f exctma.f extend.f extsgnl.f \ f3cal.f f3gen.f fclose.f fcnar.f fcstxy.f \ fdjac2.f fgen.f fis.f fopen.f forcst.f \ fouger.f fstop.f ftest.f fvalue.f fxshfr.f \ gauss.f gendff.f genfor.f genqs.f genrtt.f \ genssm.f getadj.f getchk.f getchr.f \ getcmp.f getdat.f getdbl.f getdes.f getdiag.f \ getfcn.f getfrc.f getgr.f getid.f getidm.f \ getint.f getivc.f getmdl.f getmtd.f getopr.f \ getprt.f getreg.f getrev.f getsav.f getsma.f \ getsmat.f getsrs.f getssp.f getstr.f getsvec.f \ getsvl.f gettpltz.f gettr.f gettrc.f \ getttl.f getx11.f getxop.f getxtd.f glbshk.f \ gnfcrv.f grzlst.f grzmth.f grzmyr.f gtarg.f \ gtarma.f gtauto.f gtautx.f gtdcnm.f gtdcvc.f \ gtdpvc.f gtdtvc.f gtedit.f gtestm.f gtfcst.f \ gtfldt.f gtfrcm.f gtfree.f gtinpt.f gtinvl.f \ gtmdfl.f gtmtdt.f gtmtfl.f gtnmvc.f gtotlr.f \ gtpdrg.f gtrgdt.f gtrgpt.f gtrgvl.f gtrvst.f \ gtseat.f gtspec.f gttrmo.f gtwacf.f gtx11d.f \ gtx12s.f gtxreg.f hender.f hinge.f hist.f \ histx.f hndend.f hndtrn.f holday.f holidy.f \ hrest.f htmlout.f idamax.f iddiff.f idmdl.f \ idotlr.f idpeak.f inbtwn.f indx.f initdg.f \ initst.f inpter.f insdbl.f insint.f inslg.f \ insopr.f insort.f insptr.f insstr.f intfmt.f \ intgpg.f intinp.f intlst.f intrpp.f intsrt.f \ invfcn.f invmat.f ipmpar.f iscrfn.f isdate.f \ isfals.f isfixd.f ispeak.f ispos.f issame.f \ istrue.f itoc.f itrerr.f kfcn.f kwtest.f \ lassol.f lendp.f lex.f lgnrmc.f lkshnk.f \ lmdif.f lmpar.f loadxr.f locshk.f logar.f \ logdet.f lomaic.f lstpth.f makadj.f makotl.f \ makttl.f map.f matrix.f maxidx.f maxlag.f \ maxvec.f mdlchk.f mdlfix.f mdlinp.f mdlint.f \ mdlmch.f mdlset.f mdssln.f meancra.f medabs.f \ mflag.f minim2.f mkback.f mkealb.f mkfreq.f \ mklnlb.f mkmdsn.f mkmdsx.f mkoprt.f mkotky.f \ mkpeak.f mkshdr.f mkspky.f mksplb.f mkspst.f \ mkssky.f mkstlb.f mktdlb.f mlist.f mltpos.f month.f \ mstest.f mulmat.f mulqmat.f mulref.f mulsca.f \ mult.f mult0.f mult1.f mult2.f mxpeak.f \ nblank.f newest.f nextk.f nmlmdl.f nofcst.f \ nrmtst.f numaff.f numfmt.f olsreg.f opnfil.f \ otsort.f outchr.f pacf.f pass0.f pass2.f \ pctrit.f polyml.f polynom.f ppnd.f pracf2.f \ prafce.f pragr2.f prfcrv.f pritd.f prlkhd.f \ procflts.f prothd.f prprad.f prrvob.f \ prshd2.f prtacf.f prtadj.f prtagr.f prtamd.f \ prtchi.f prtcol.f prtd8b.f prtd9a.f prtdtb.f \ prtdwr.f prterr.f prterx.f prtf2.f prtf2w.f \ prtfct.f prtft.f prtitr.f prtlog.f prtmdl.f \ prtmsp.f prtmsr.f prtmtx.f prtnfn.f prtopt.f \ prtref.f prtrev.f prtrts.f prtrv2.f prtsft.f \ prtshd.f prttbl.f prttd.f prttrn.f prtukp.f \ prtxrg.f punch.f putbak.f putrev.f putstr.f \ qcmmnt.f qcontr.f qdoble.f qintgr.f qmap.f \ qmap2.f qname.f qquote.f qrfac.f qrsolv.f \ qsdiff.f qtoken.f quad.f quadit.f quadsd.f \ ratneg.f ratpos.f rdotlr.f rdotls.f rdregm.f \ realit.f regfix.f reglbl.f regvar.f regx11.f \ replac.f replyf.f resid.f resid2.f restor.f \ revchk.f revdrv.f revhdr.f revrse.f rgarma.f \ rgtdhl.f rho2.f rmatot.f rmfix.f rmlnvr.f \ rmlpyr.f rmotrv.f rmotss.f rmpadj.f rmtadj.f \ rndsa.f rngbuf.f roots.f round.f rplus.f \ rpoly.f rv2ss.f rvarma.f rvfixd.f rvrghd.f rvtdrg.f \ rvtdrg.f sautco.f savacf.f savchi.f savd8b.f \ savitr.f savmdc.f savmdl.f savmtx.f savotl.f \ savpk.f savspp.f savstp.f savtbl.f savtpk.f savwkf.f \ sceast.f scrmlt.f sdev.f sdxtrm.f seatad.f seatdg.f \ seatfc.f seatpr.f serates.f setadj.f setamx.f \ setapt.f setchr.f setcv.f setcvl.f \ setdp.f setint.f setlg.f setmdl.f setmv.f \ setopr.f setpt.f setrvp.f setspn.f setssp.f \ setup.f setwrt.f setxpt.f sfmax.f sfmsr.f \ sftest.f shlsrt.f shrink.f si.f sicp2.f \ sigex.f sigsub.f simul.f skparg.f skparm.f \ skpfcn.f skplst.f smeadl.f smpeak.f snrasp.f \ spcdrv.f spcrsd.f special.f specpeak.f \ spectrum.f spgrh.f spgrh2.f spmpar.f ss2rv.f \ ssap.f ssfnot.f ssftst.f sshist.f ssmdl.f \ ssort.f sspdrv.f ssphdr.f ssprep.f ssrit.f \ ssrng.f ssx11a.f ssxmdl.f stpitr.f strinx.f \ strtvl.f stvaln.f subset.f sumf.f sumry.f \ sumsqr.f svaict.f svamcm.f svchsd.f svdttm.f \ svf2f3.f svflt.f svfltd.f svfnrg.f svfreq.f \ svolit.f svoudg.f svpeak.f svrgcm.f svrvhd.f \ svspan.f svtukp.f table.f taper.f tblhdr.f \ td6var.f td7var.f tdaic.f tdftest.f tdlom.f \ tdset.f tdxtrm.f templs.f tfmts.f tfmts3.f \ totals.f transc.f trbias.f trnaic.f trnfcn.f \ tstdrv.f tstmd1.f tstmd2.f ttest.f uconv.f \ upespm.f usraic.f value.f varian.f varlog.f \ vars.f vsfa.f vsfb.f vsfc.f vtc.f vtest.f \ weight.f whitsp.f wr.f writln.f wrtdat.f \ wrtmss.f wrtotl.f wrttb2.f wrttbl.f wtxtrm.f \ x11aic.f x11ari.f x11int.f x11mdl.f x11plt.f \ x11pt1.f x11pt2.f x11pt3.f x11pt4.f x11ref.f \ x12hdr.f x12run.f xchng.f xpand.f xprmx.f \ xrgdiv.f xrgdrv.f xrghol.f xrgtrn.f xrlkhd.f \ xtrm.f yprmy.f yrly.f component.f complagdiag.f \ compcrodiag.f phasegain.f altundovrtst.f \ getrevdec.f m2q.f chqsea.f npsa.f gennpsa.f prarma.f \ testodf.f $(PROGRAM): $(OBJS) $(LIBS) $(LINKER) -static -o $@ $(OBJS) $(LDMAP) $(LIBS) $(LDFLAGS) clean:; @rm -f $(OBJS) install: $(PROGRAM) @echo Installing $(PROGRAM) in $(DEST) @if not $(DEST)x==.x copy $(PROGRAM) $(DEST) ### OPUS MKMF: Do not remove this line! Automatic dependencies follow. aaamain.o: build.prm cchars.i chrt.cmn error.cmn hiddn.cmn lex.i \ notset.prm nsums.i seatop.cmn srslen.prm ssap.cmn ssap.prm stdio.i \ title.cmn units.cmn abend.o: dgnsvl.i error.cmn hiddn.cmn stdio.i svllog.cmn svllog.prm \ units.cmn acf.o: autoq.cmn notset.prm srslen.prm stdio.i units.cmn acfar.o: autoq.cmn srslen.prm acfdgn.o: autoq.cmn error.cmn mdldat.cmn mdlsvl.i model.cmn model.prm \ srslen.prm svllog.cmn svllog.prm units.cmn acfhdr.o: model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm addadj.o: error.cmn stdio.i units.cmn addeas.o: error.cmn model.prm notset.prm srslen.prm addfix.o: error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm srslen.prm addlom.o: error.cmn model.prm notset.prm srslen.prm addmul.o: srslen.prm x11opt.cmn addotl.o: error.cmn hiddn.cmn mdldat.cmn model.cmn model.prm srslen.prm \ stdio.i units.cmn addsef.o: error.cmn model.cmn model.prm notset.prm srslen.prm stdio.i \ units.cmn addtd.o: error.cmn model.prm notset.prm srslen.prm addusr.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ urgbak.cmn usrreg.cmn adestr.o: model.prm srslen.prm adjreg.o: extend.cmn inpt.cmn model.cmn model.prm orisrs.cmn prior.cmn \ prior.prm srslen.prm units.cmn x11adj.cmn x11fac.cmn x11log.cmn \ x11ptr.cmn adjsrs.o: adj.cmn error.cmn picktd.cmn priadj.cmn prior.cmn prior.prm \ priusr.cmn srslen.prm adlabr.o: model.prm srslen.prm adotss.o: arima.cmn error.cmn model.cmn model.prm srslen.prm adpdrg.o: error.cmn lex.i model.cmn model.prm notset.prm picktd.cmn \ srslen.prm stdio.i units.cmn adrgef.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn adrgim.o: error.cmn lex.i model.cmn model.prm notset.prm picktd.cmn \ srslen.prm adsncs.o: error.cmn model.prm srslen.prm stdio.i units.cmn adthnk.o: model.prm srslen.prm aggmea.o: srslen.prm agr.o: srslen.prm agr1.o: agr.cmn agrsrs.cmn model.prm notset.prm rev.cmn rev.prm \ revsrs.cmn srslen.prm ssap.cmn ssap.prm sspdat.cmn agr2.o: adxser.cmn agr.cmn agrsrs.cmn cmpsvl.i cmptbl.i extend.cmn \ inpt.cmn lzero.cmn orisrs.cmn priadj.cmn prior.cmn prior.prm \ priusr.cmn seatcm.cmn seatlg.cmn srslen.prm stdio.i svllog.cmn \ svllog.prm tbllog.cmn tbllog.prm title.cmn units.cmn x11adj.cmn \ x11fac.cmn x11opt.cmn x11ptr.cmn x11srs.cmn agr3.o: adxser.cmn agr.cmn agrsrs.cmn build.prm cmptbl.i error.cmn \ extend.cmn force.cmn hiddn.cmn inpt.cmn lex.i notset.prm \ seatcm.cmn srslen.prm stdio.i tbllog.cmn tbllog.prm title.cmn \ units.cmn x11adj.cmn x11fac.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11srs.cmn agr3s.o: adxser.cmn agr.cmn agrsrs.cmn build.prm cmptbl.i error.cmn \ extend.cmn force.cmn hiddn.cmn inpt.cmn lex.i notset.prm \ seatcm.cmn srslen.prm stdio.i tbllog.cmn tbllog.prm title.cmn \ units.cmn x11adj.cmn x11fac.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11srs.cmn agrxpt.o: agr.cmn agrsrs.cmn extend.cmn srslen.prm x11ptr.cmn amdest.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm amdfct.o: arima.cmn error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm \ prior.cmn prior.prm srslen.prm units.cmn usrreg.cmn amdid.o: arima.cmn error.cmn extend.cmn mdldat.cmn mdlsvl.i mdltbl.i \ model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm \ stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm units.cmn amdid2.o: adj.cmn arima.cmn error.cmn mdldat.cmn mdltbl.i model.cmn \ model.prm srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn amdprt.o: error.cmn lkhd.cmn mdldat.cmn model.prm srslen.prm units.cmn amidot.o: arima.cmn error.cmn extend.cmn mdltbl.i model.cmn model.prm \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn analts.o: bench.i buffers.i build.i calc.i calfor.i calshr.i count.i \ date.i dets.i dimensions.i dirs.i eee.i error.cmn hdflag.i \ hiddn.cmn logtrace.i nsums.i peaks.i pinno.i preadtr.i seastest.i \ seatserr.i sername.i sesfcast.i sfcast.i sform.i sig.i sig1.i \ srslen.prm stdio.i stream.i strmodel.i titl.i title.cmn unitmak.i \ units.cmn xarr.i ansub1.o: calc.i calfor.i calshr.i count.i cse.i dets.i dimensions.i eee.i \ sesfcast.i srslen.prm stream.i units.cmn ansub10.o: calc.i calfor.i date.i dimensions.i dirs.i estb.i logtrace.i \ models.i polynom.i prtous.i revs.i seatop.cmn sesfcast.i sform.i \ srslen.prm stdio.i stream.i tbl5x.i units.cmn xarr.i ansub11.o: calc.i calfor.i dimensions.i estgc.i fft.i models.i srslen.prm \ units.cmn xarr.i ansub2.o: ac02ae.i dimensions.i error.cmn func.i func2.i func3.i func4.i \ func5.i min.i sform.i srslen.prm stdio.i stream.i test.i unitmak.i \ units.cmn ansub3.o: dimensions.i estb.i estgc.i preadtr.i sform.i sig.i srslen.prm \ units.cmn ansub4.o: acfast.i acfst.i bartlett.i bench.i cross.i cxfinal.i dimensions.i \ estb.i force.cmn hspect.i lzero.cmn models.i preadtr.i priadj.cmn \ priusr.cmn serrlev.i sesfcast.i sfcast.i sform.i srslen.prm \ stdio.i stream.i titl.i transcad.i units.cmn ansub5.o: bench.i dimensions.i error.cmn fitmod.i func5f1.i hspect.i \ preadtr.i prtous.i rtestm.i sform.i spe.i spectra.i spectrum.i \ srslen.prm stream.i testf1.i transcad.i units.cmn ansub7.o: amic.i dimensions.i error.cmn func.i func2.i func3.i func4.i \ min.i srslen.prm test.i ansub8.o: build.i dirs.i stream.i ansub9.o: autoq.cmn dimensions.i error.cmn extend.cmn hiddn.cmn mdldat.cmn \ model.cmn model.prm notset.prm orisrs.cmn rev.cmn rev.prm \ seatad.cmn seatcm.cmn seatdg.cmn seatlg.cmn seatmd.cmn seatop.cmn \ seattb.i srslen.prm sspinp.cmn stdio.i tbllog.cmn tbllog.prm \ title.cmn units.cmn x11adj.cmn x11fac.cmn x11ptr.cmn ar30rg.o: srslen.prm arima.o: adj.cmn arima.cmn autoq.cmn error.cmn extend.cmn filext.prm \ fxreg.cmn hiddn.cmn inpt.cmn lkhd.cmn lzero.cmn mdldat.cmn mdlsvl.i \ mdltbl.i missng.cmn model.cmn model.prm mq3.cmn notset.prm \ orisrs.cmn picktd.cmn priadj.cmn prior.cmn prior.prm prittl.cmn \ priusr.cmn rev.cmn rev.prm rho.cmn seatad.cmn spcsvl.i spctbl.i \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.i \ tbllog.prm tdtyp.cmn title.cmn tukey.cmn units.cmn usrreg.cmn \ x11adj.cmn x11fac.cmn x11log.cmn x11opt.cmn x11ptr.cmn armacr.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn armafl.o: mdldat.cmn model.cmn model.prm srslen.prm armats.o: mdldat.cmn model.cmn model.prm srslen.prm stdio.i units.cmn autoer.o: model.prm srslen.prm stdio.i units.cmn automd.o: adj.cmn arima.cmn error.cmn extend.cmn mdldat.cmn mdlsvl.i \ mdltbl.i model.cmn model.prm notset.prm picktd.cmn prior.cmn \ prior.prm srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm title.cmn units.cmn usrreg.cmn automx.o: adj.cmn arima.cmn autoq.cmn error.cmn extend.cmn lex.i \ mdldat.cmn mdltbl.i model.cmn model.prm notset.prm picktd.cmn \ priadj.cmn prior.cmn prior.prm prittl.cmn priusr.cmn srslen.prm \ stdio.i tbllog.cmn tbllog.prm title.cmn units.cmn usrreg.cmn \ x11adj.cmn x11ptr.cmn aver.o: chrt.cmn srslen.prm units.cmn bakusr.o: model.prm srslen.prm urgbak.cmn bench.o: calfor.i dirs.i sform.i titl.i bestmd.o: lkhd.cmn notset.prm bkdfmd.o: arima.cmn mdldat.cmn model.cmn model.prm picktd.cmn prior.cmn \ prior.prm srslen.prm ss2rv.cmn tbllog.prm usrreg.cmn x11adj.cmn bldcov.o: srslen.prm bstget.o: bstmdl.cmn mdldat.cmn model.cmn model.prm notset.prm srslen.prm bstmdl.o: bstmdl.cmn mdldat.cmn model.cmn model.prm picktd.cmn srslen.prm btrit.o: srslen.prm ssap.cmn ssap.prm sspvec.cmn title.cmn units.cmn calcsc.o: global.cmn model.prm srslen.prm change.o: goodob.cmn notset.prm srslen.prm x11opt.cmn chitst.o: mdldat.cmn model.prm notset.prm srslen.prm chkadj.o: model.cmn model.prm srslen.prm stdio.i units.cmn usrreg.cmn \ x11adj.cmn x11log.cmn chkchi.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ notset.prm prior.cmn prior.prm srslen.prm units.cmn usrreg.cmn chkeas.o: srslen.prm xeastr.cmn chkmu.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ notset.prm prior.cmn prior.prm srslen.prm stdio.i units.cmn chkorv.o: cchars.i error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ ssprep.cmn units.cmn chkrt1.o: error.cmn mdldat.cmn model.cmn model.prm notset.prm srslen.prm chkrt2.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn chkrts.o: mdldat.cmn model.cmn model.prm srslen.prm chksmd.o: error.cmn model.cmn model.prm srslen.prm stdio.i units.cmn chktrn.o: extend.cmn hiddn.cmn notset.prm stdio.i units.cmn x11ptr.cmn chkuhg.o: model.prm srslen.prm chkurt.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm chkzro.o: force.cmn goodob.cmn srslen.prm chrt.o: chrt.cmn error.cmn srslen.prm tbltitle.prm x11opt.cmn chusrg.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ usrreg.cmn clrotl.o: error.cmn model.cmn model.prm srslen.prm cmpchi.o: error.cmn model.cmn model.prm notset.prm picktd.cmn srslen.prm \ units.cmn usrreg.cmn usrxrg.cmn cmpstr.o: lex.i cncrnt.o: cchars.i error.cmn notset.prm seattb.i tbllog.cmn tbllog.prm cnvmdl.o: error.cmn model.cmn model.prm srslen.prm coladd.o: stdio.i units.cmn combft.o: hiddn.cmn srslen.prm ssap.prm ssft.cmn tests.cmn title.cmn \ units.cmn compb.o: srslen.prm ssap.cmn ssap.prm compdiag.o: srslen.prm compmse.o: srslen.prm cormtx.o: error.cmn model.cmn model.prm notset.prm srslen.prm units.cmn corplt.o: stdio.i units.cmn covar.o: model.prm notset.prm srslen.prm ctodat.o: model.prm srslen.prm cvrerr.o: error.cmn stdio.i units.cmn delstr.o: error.cmn stdio.i units.cmn deltst.o: error.cmn hiddn.cmn mdldat.cmn model.cmn model.prm notset.prm \ srslen.prm stdio.i units.cmn desreg.o: error.cmn model.prm srslen.prm title.cmn units.cmn divgud.o: goodob.cmn notset.prm srslen.prm divsub.o: srslen.prm x11opt.cmn dlrgef.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn dlusrg.o: arima.cmn model.prm srslen.prm stdio.i units.cmn usrreg.cmn dot.o: chrt.cmn srslen.prm dsarma.o: model.cmn model.prm srslen.prm units.cmn dtoc.o: savcmn.cmn stdio.i units.cmn easaic.o: adj.cmn arima.cmn error.cmn extend.cmn lkhd.cmn mdldat.cmn \ model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm \ units.cmn x11adj.cmn easter.o: srslen.prm xeastr.cmn editor.o: adj.cmn agr.cmn agrsrs.cmn arima.cmn cmpsvl.i cmptbl.i dgnsvl.i \ error.cmn extend.cmn filetb.cmn force.cmn frctbl.i goodob.cmn \ hender.prm hiddn.cmn inpt.cmn lzero.cmn mdldat.cmn mdlsvl.i \ mdltbl.i metadata.cmn metadata.prm missng.cmn model.cmn model.prm \ notset.prm picktd.cmn prior.cmn prior.prm priusr.cmn rho.cmn \ setsvl.i spcsvl.i spctbl.i srslen.prm ssap.cmn ssap.prm sspinp.cmn \ stdio.i sums.i sumtab.prm sumtab.var svllog.cmn svllog.prm \ tbllog.cmn tbllog.prm title.cmn units.cmn usrreg.cmn usrxrg.cmn \ work2.cmn x11adj.cmn x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11reg.cmn x11svl.i xeastr.cmn xrgfct.cmn xrgmdl.cmn xrgum.cmn \ xtrm.cmn eltlen.o: stdio.i units.cmn ends.o: hender.prm errhdr.o: hiddn.cmn notset.prm rev.cmn rev.prm srslen.prm ssap.prm \ ssft.cmn units.cmn estrmu.o: srslen.prm exctma.o: mdldat.cmn model.cmn model.prm srslen.prm extend.o: extend.cmn mdldat.cmn model.prm srslen.prm stdio.i units.cmn \ x11msc.cmn x11opt.cmn x11ptr.cmn extsgnl.o: srslen.prm f3cal.o: inpt2.cmn srslen.prm tests.cmn work2.cmn x11opt.cmn x11ptr.cmn f3gen.o: mq3.cmn srslen.prm work2.cmn fclose.o: stdio.i fcnar.o: error.cmn mdldat.cmn model.cmn model.prm notset.prm series.cmn \ srslen.prm stdio.i units.cmn fcstxy.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm fgen.o: mq3.cmn srslen.prm title.cmn x11opt.cmn fopen.o: stdio.i units.cmn fstop.o: stdio.i ftest.o: agr.cmn hiddn.cmn srslen.prm ssap.prm ssft.cmn tests.cmn \ title.cmn units.cmn x11msc.cmn x11opt.cmn fxshfr.o: global.cmn model.prm srslen.prm gendff.o: srslen.prm genfor.o: agr.cmn filetb.cmn stdio.i title.cmn units.cmn genqs.o: adxser.cmn arima.cmn extend.cmn inpt.cmn model.cmn model.prm \ notset.prm orisrs.cmn rho.cmn seatcm.cmn seatlg.cmn spctbl.i \ srslen.prm tbllog.cmn tbllog.prm units.cmn x11adj.cmn x11fac.cmn \ x11ptr.cmn x11srs.cmn genrtt.o: mdldat.cmn model.cmn model.prm srslen.prm genssm.o: calc.i dimensions.i notset.prm seatdg.cmn srslen.prm getadj.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i tbllog.i \ units.cmn getchk.o: error.cmn hiddn.cmn lex.i mdltbl.i notset.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn getchr.o: lex.i getcmp.o: error.cmn lex.i notset.prm stdio.i svllog.i tbllog.cmn tbllog.i \ tbllog.prm units.cmn getdat.o: lex.i srslen.prm getdbl.o: lex.i getdes.o: desadj.prm desadj.var descm2.prm descm2.var descmp.prm \ descmp.var desdgn.prm desdgn.var desdg2.prm desdg2.var \ desfsa.prm desfsa.var desmdl.prm desmdl.var desset.prm desset.var \ desst2.prm desst2.var desspc.prm desspc.var dessrs.prm dessrs.var \ desx11.prm desx11.var desxrg.prm desxrg.var tbltitle.prm getdiag.o: acfast.i across.i hiddn.cmn mdldat.cmn model.prm revs.i \ srslen.prm stdio.i tbl5x.i units.cmn getfcn.o: lex.i notset.prm getfrc.o: error.cmn lex.i notset.prm stdio.i tbllog.i units.cmn getgr.o: sform.i srslen.prm getid.o: error.cmn lex.i model.cmn model.prm notset.prm srslen.prm \ tbllog.i getint.o: lex.i getivc.o: lex.i notset.prm getmdl.o: error.cmn lex.i model.cmn model.prm srslen.prm getmtd.o: extend.cmn mdldat.cmn model.cmn model.prm notset.prm picktd.cmn \ srslen.prm tdtyp.cmn x11opt.cmn getopr.o: error.cmn lex.i model.prm notset.prm srslen.prm getprt.o: hiddn.cmn level.prm level.var lex.i stdio.i table.prm table.var \ tbllog.cmn tbllog.prm units.cmn getreg.o: error.cmn lex.i mdldat.cmn model.cmn model.prm notset.prm \ picktd.cmn srslen.prm stdio.i svllog.i tbllog.i units.cmn \ usrreg.cmn getrev.o: model.prm rev.cmn rev.prm revsrs.cmn revtrg.cmn srslen.prm \ stdio.i units.cmn getsav.o: lex.i stable.prm stable.var stdio.i tbllog.cmn tbllog.prm \ units.cmn getsma.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm getsrs.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn getssp.o: error.cmn lex.i notset.prm srslen.prm ssap.prm svllog.i \ tbllog.i getstr.o: error.cmn stdio.i units.cmn getsvl.o: lex.i stdio.i svllog.cmn svllog.prm svltbl.prm svltbl.var \ units.cmn getttl.o: error.cmn lex.i notset.prm getx11.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn getxop.o: error.cmn stdio.i getxtd.o: model.cmn model.prm notset.prm picktd.cmn srslen.prm \ tdtyp.cmn xtdtyp.cmn glbshk.o: srslen.prm x11ptr.cmn gnfcrv.o: model.prm rev.cmn rev.prm revsrs.cmn srslen.prm grzlst.o: chrt.cmn srslen.prm grzmth.o: chrt.cmn srslen.prm grzmyr.o: chrt.cmn srslen.prm gtarg.o: error.cmn lex.i notset.prm gtarma.o: error.cmn lex.i model.cmn model.prm notset.prm srslen.prm gtauto.o: error.cmn lex.i mdltbl.i notset.prm stdio.i svllog.i tbllog.cmn \ tbllog.i tbllog.prm units.cmn gtautx.o: error.cmn lex.i model.prm notset.prm srslen.prm svllog.i \ tbllog.i gtdcnm.o: lex.i gtdcvc.o: error.cmn lex.i gtdpvc.o: error.cmn lex.i notset.prm gtdtvc.o: error.cmn lex.i notset.prm gtedit.o: stdio.i units.cmn x11msc.cmn gtestm.o: error.cmn lex.i mdltbl.i model.cmn model.prm notset.prm \ srslen.prm stdio.i svllog.i tbllog.cmn tbllog.i tbllog.prm \ units.cmn gtfcst.o: error.cmn lex.i notset.prm srslen.prm tbllog.i gtfldt.o: lex.i notset.prm stdio.i units.cmn gtfrcm.o: lex.i stdio.i units.cmn gtfree.o: stdio.i units.cmn gtinpt.o: adj.cmn agr.cmn arima.cmn deftab.prm deftab.var error.cmn \ extend.cmn force.cmn fxreg.cmn hiddn.cmn lex.i mdldat.cmn \ metadata.cmn metadata.prm missng.cmn model.cmn model.prm \ notset.prm picktd.cmn priadj.cmn prior.cmn prior.prm prittl.cmn \ priusr.cmn rev.cmn rev.prm revtrg.cmn rho.cmn savcmn.cmn \ seatlg.cmn seatop.cmn srslen.prm sspinp.cmn stdio.i sumtab.prm \ sumtab.var svllog.cmn svllog.prm tbllog.cmn tbllog.prm title.cmn \ tukey.cmn units.cmn usrreg.cmn usrxrg.cmn x11adj.cmn x11log.cmn \ x11msc.cmn x11opt.cmn x11reg.cmn xclude.cmn xrgfct.cmn xrgmdl.cmn \ xrgum.cmn xtrm.cmn gtinvl.o: error.cmn lex.i mdldat.cmn model.cmn model.prm srslen.prm gtmdfl.o: error.cmn model.cmn model.prm notset.prm srslen.prm stdio.i \ usrreg.cmn x11adj.cmn gtmtdt.o: error.cmn lex.i metadata.cmn metadata.prm notset.prm stdio.i gtmtfl.o: notset.prm stdio.i gtnmvc.o: error.cmn lex.i notset.prm gtotlr.o: error.cmn lex.i notset.prm svllog.i tbllog.i gtpdrg.o: error.cmn lex.i gtrgdt.o: lex.i gtrgpt.o: model.cmn model.prm srslen.prm gtrgvl.o: lex.i model.prm srslen.prm gtrvst.o: error.cmn lex.i notset.prm rev.prm srslen.prm stdio.i svllog.i \ tbllog.i units.cmn gtseat.o: error.cmn lex.i notset.prm stdio.i svllog.i tbllog.cmn tbllog.i \ tbllog.prm units.cmn gtspec.o: error.cmn lex.i notset.prm srslen.prm stdio.i svllog.i \ tbllog.cmn tbllog.i tbllog.prm units.cmn gttrmo.o: stdio.i units.cmn x11msc.cmn gtx11d.o: notset.prm stdio.i units.cmn x11msc.cmn gtx12s.o: stdio.i units.cmn gtxreg.o: error.cmn lex.i mdldat.cmn model.cmn model.prm notset.prm \ picktd.cmn srslen.prm stdio.i svllog.i tbllog.i units.cmn \ usrxrg.cmn hist.o: error.cmn model.prm srslen.prm units.cmn histx.o: error.cmn srslen.prm ssap.prm tfmts.cmn units.cmn hndend.o: hender.prm hndtrn.o: hender.prm x11msc.cmn holday.o: error.cmn extend.cmn hiddn.cmn lzero.cmn srslen.prm tbllog.cmn \ tbllog.prm x11adj.cmn x11fac.cmn x11opt.cmn x11ptr.cmn x11tbl.i \ xeastr.cmn holidy.o: kdate.prm srslen.prm xeastr.cmn hrest.o: autoq.cmn error.cmn model.prm srslen.prm units.cmn htmlout.o: build.i dimensions.i dirs.i models.i peaks.i polynom.i seatserr.i \ sername.i sform.i sig.i spectra.i spectrum.i srslen.prm stdio.i \ stream.i sums.i transcad.i units.cmn iddiff.o: arima.cmn error.cmn extend.cmn mdldat.cmn mdltbl.i model.cmn \ model.prm notset.prm prior.cmn prior.prm srslen.prm stdio.i \ tbllog.cmn tbllog.prm units.cmn idmdl.o: acfptr.prm error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ srslen.prm stdio.i tbllog.cmn tbllog.i tbllog.prm units.cmn idotlr.o: cchars.i error.cmn fxreg.cmn hiddn.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm notset.prm srslen.prm stdio.i tbllog.cmn \ tbllog.prm units.cmn xrgtbl.i idpeak.o: notset.prm units.cmn initdg.o: error.cmn notset.prm seatdg.cmn setsvl.i svllog.cmn svllog.prm \ units.cmn initst.o: notset.prm seatlg.cmn seatmd.cmn srslen.prm stcfcm.cmn inpter.o: lex.i stdio.i title.cmn units.cmn insdbl.o: error.cmn insint.o: error.cmn inslg.o: error.cmn insopr.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm insptr.o: error.cmn stdio.i units.cmn insstr.o: error.cmn intgpg.o: mdldat.cmn model.cmn model.prm srslen.prm intinp.o: error.cmn lex.i invfcn.o: stdio.i units.cmn issame.o: goodob.cmn srslen.prm itoc.o: stdio.i units.cmn itrerr.o: stdio.i units.cmn kfcn.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm xtdtyp.cmn kwtest.o: hiddn.cmn srslen.prm tests.cmn title.cmn units.cmn lendp.o: notset.prm lex.o: cchars.i lex.i lmdif.o: error.cmn loadxr.o: arima.cmn mdldat.cmn model.cmn model.prm picktd.cmn prior.cmn \ prior.prm srslen.prm usrreg.cmn usrxrg.cmn x11adj.cmn xrgmdl.cmn locshk.o: srslen.prm units.cmn x11ptr.cmn lomaic.o: adj.cmn arima.cmn error.cmn extend.cmn lkhd.cmn mdldat.cmn \ model.cmn model.prm notset.prm picktd.cmn prior.cmn prior.prm \ srslen.prm units.cmn lstpth.o: lex.i makadj.o: adj.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm makotl.o: model.prm srslen.prm makttl.o: cmptbl.i error.cmn fctlbl.prm fctlbl.var force.cmn frctbl.i \ mq3.cmn stdio.i tbllbl.prm tbllbl.var tbltitle.prm units.cmn \ x11tbl.i map.o: lex.i matrix.o: matrix1.i matrix2.i sums.i mdlchk.o: autoq.cmn mdldat.cmn model.cmn model.prm srslen.prm mdlfix.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm mdlinp.o: error.cmn lex.i mdlint.o: mdldat.cmn model.cmn model.prm srslen.prm mdlmch.o: notset.prm mdlset.o: error.cmn model.cmn model.prm srslen.prm stdio.i units.cmn medabs.o: model.prm srslen.prm stdio.i units.cmn mflag.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn mkback.o: adj.cmn arima.cmn cchars.i error.cmn extend.cmn hiddn.cmn \ mdldat.cmn mdltbl.i model.cmn model.prm priusr.cmn savcmn.cmn \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn x11adj.cmn \ x11fac.cmn x11log.cmn x11opt.cmn mkealb.o: error.cmn notset.prm mkfreq.o: notset.prm spcidx.cmn mklnlb.o: error.cmn notset.prm mkmdsn.o: error.cmn mkoprt.o: error.cmn model.prm srslen.prm mkotky.o: error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm srslen.prm \ units.cmn mkpeak.o: spcidx.cmn mkshdr.o: force.cmn hiddn.cmn picktd.cmn prior.cmn prior.prm srslen.prm \ x11adj.cmn x11log.cmn x11opt.cmn mksplb.o: spctbl.i mkspst.o: hiddn.cmn prior.cmn prior.prm srslen.prm x11adj.cmn x11log.cmn \ x11opt.cmn mkssky.o: srslen.prm ssap.cmn ssap.prm title.cmn units.cmn mktdlb.o: error.cmn notset.prm mlist.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn title.cmn \ units.cmn mltpos.o: model.prm srslen.prm month.o: chrt.cmn error.cmn srslen.prm mstest.o: hiddn.cmn srslen.prm ssap.prm ssft.cmn tests.cmn title.cmn \ units.cmn x11opt.cmn mulqmat.o: srslen.prm mxpeak.o: notset.prm newest.o: global.cmn model.prm srslen.prm nextk.o: global.cmn model.prm srslen.prm nmlmdl.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn nofcst.o: arima.cmn extend.cmn model.prm prior.cmn prior.prm srslen.prm nrmtst.o: nrmtst.var stdio.i units.cmn olsreg.o: stdio.i units.cmn opnfil.o: error.cmn filetb.cmn filext.prm filext.var gmeta.prm gmeta.var \ notset.prm stdio.i tbllog.prm tbltitle.prm otsort.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm outchr.o: chrt.cmn srslen.prm tbltitle.prm units.cmn pacf.o: srslen.prm units.cmn pass0.o: arima.cmn error.cmn extend.cmn model.cmn model.prm picktd.cmn \ prior.cmn prior.prm srslen.prm units.cmn pass2.o: adj.cmn arima.cmn error.cmn extend.cmn inpt.cmn mdldat.cmn \ model.cmn model.prm picktd.cmn prior.cmn prior.prm priusr.cmn \ series.cmn srslen.prm units.cmn pctrit.o: dgnsvl.i notset.prm srslen.prm ssap.prm svllog.cmn svllog.prm \ units.cmn polynom.o: dimensions.i hspect.i models.i polynom.i srslen.prm stream.i pracf2.o: error.cmn mdldat.cmn mdltbl.i model.cmn model.prm notset.prm \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn prafce.o: title.cmn pragr2.o: error.cmn tbllog.cmn tbllog.prm prfcrv.o: cchars.i error.cmn model.prm rev.cmn rev.prm revsrs.cmn \ srslen.prm svllog.cmn svllog.prm tbllog.cmn tbllog.prm title.cmn \ units.cmn pritd.o: error.cmn model.prm srslen.prm prlkhd.o: extend.cmn hiddn.cmn lkhd.cmn lzero.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm notset.prm srslen.prm units.cmn x11adj.cmn \ x11fac.cmn x11log.cmn x11opt.cmn procflts.o: cmpflts.i prothd.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn prprad.o: units.cmn prrvob.o: srslen.prm tfmts.cmn title.cmn units.cmn prshd2.o: error.cmn title.cmn units.cmn prtacf.o: acfptr.prm error.cmn mdldat.cmn mdlsvl.i model.cmn model.prm \ notset.prm srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm units.cmn prtadj.o: error.cmn lzero.cmn mdltbl.i orisrs.cmn priadj.cmn priusr.cmn \ srslen.prm tbllog.cmn tbllog.prm prtagr.o: error.cmn tbllog.cmn tbllog.prm prtamd.o: error.cmn fxreg.cmn model.cmn model.prm notset.prm srslen.prm \ title.cmn units.cmn prtchi.o: model.prm notset.prm srslen.prm title.cmn prtcol.o: srslen.prm prtd8b.o: arima.cmn error.cmn extend.cmn hiddn.cmn mdldat.cmn model.cmn \ model.prm notset.prm srslen.prm stdio.i tbltitle.prm tfmts.cmn \ tfmts.prm tfmts.var tfmts2.prm tfmts2.var title.cmn units.cmn \ x11adj.cmn x11opt.cmn prtd9a.o: error.cmn hiddn.cmn srslen.prm tfmts.cmn tfmts.prm tfmts.var \ units.cmn x11opt.cmn prtdtb.o: mq3.cmn notset.prm picktd.cmn prior.cmn prior.prm srslen.prm \ title.cmn units.cmn x11opt.cmn prtdwr.o: arima.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn prterr.o: error.cmn hiddn.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn prterx.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ stdio.i tbllog.cmn tbllog.prm units.cmn xrgtbl.i prtf2.o: inpt2.cmn mq3.cmn srslen.prm tests.cmn title.cmn work2.cmn \ x11opt.cmn prtf2w.o: inpt2.cmn mq3.cmn srslen.prm tests.cmn title.cmn work2.cmn \ x11opt.cmn prtfct.o: adj.cmn cchars.i error.cmn hiddn.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm prior.cmn prior.prm priusr.cmn rev.cmn rev.prm \ revsrs.cmn savcmn.cmn seatad.cmn srslen.prm stdio.i tbllog.cmn \ tbllog.prm units.cmn x11fac.cmn x11log.cmn prtft.o: hiddn.cmn model.prm notset.prm srslen.prm title.cmn units.cmn prtitr.o: error.cmn mdltbl.i model.cmn model.prm notset.prm series.cmn \ srslen.prm tbllog.cmn tbllog.prm units.cmn prtlog.o: stdio.i prtmdl.o: cchars.i cogreg.prm cogreg.var error.cmn hiddn.cmn mdldat.cmn \ mdldg.cmn mdlsvl.i mdltbl.i model.cmn model.prm notset.prm \ picktd.cmn rev.cmn rev.prm srslen.prm sspinp.cmn svllog.cmn \ svllog.prm title.cmn units.cmn prtmsp.o: error.cmn title.cmn units.cmn prtmsr.o: cchars.i desadj.prm desadj.var error.cmn rev.cmn rev.prm \ srslen.prm tbllog.cmn tbllog.prm tbltitle.prm tfmts.cmn tfmts.prm \ tfmts.var units.cmn prtmtx.o: error.cmn title.cmn units.cmn prtnfn.o: title.cmn units.cmn prtopt.o: model.cmn model.prm srslen.prm units.cmn prtref.o: error.cmn mdldat.cmn mdltbl.i model.cmn model.prm srslen.prm \ title.cmn usrreg.cmn prtrev.o: cchars.i desdgn.prm desdgn.var dgnsvl.i error.cmn notset.prm \ rev.cmn rev.prm srslen.prm svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm tbltitle.prm tfmts.cmn units.cmn x11msc.cmn x11opt.cmn prtrts.o: cchars.i error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ srslen.prm units.cmn prtrv2.o: cchars.i desdgn.prm desdgn.var dgnsvl.i error.cmn notset.prm \ rev.cmn rev.prm srslen.prm svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm tbltitle.prm tfmts.cmn units.cmn x11msc.cmn x11opt.cmn prtsft.o: model.prm notset.prm srslen.prm title.cmn units.cmn prtshd.o: error.cmn title.cmn units.cmn prttbl.o: model.prm srslen.prm title.cmn units.cmn prttd.o: units.cmn prttrn.o: error.cmn hiddn.cmn model.prm notset.prm srslen.prm stdio.i \ tbltitle.prm tfmts.cmn tfmts.prm tfmts.var tfmts2.prm tfmts2.var \ title.cmn units.cmn x11opt.cmn x11ptr.cmn prtukp.o: arima.cmn error.cmn model.prm rho.cmn spctbl.i srslen.prm \ title.cmn tukey.cmn prtxrg.o: cchars.i cogreg.prm cogreg.var error.cmn hiddn.cmn mdldat.cmn \ model.cmn model.prm notset.prm picktd.cmn srslen.prm units.cmn \ x11reg.cmn punch.o: extend.cmn hiddn.cmn srslen.prm title.cmn x11opt.cmn putbak.o: lex.i putrev.o: agr.cmn putstr.o: error.cmn qcmmnt.o: cchars.i lex.i qcontr.o: agr.cmn title.cmn units.cmn qintgr.o: lex.i qmap2.o: cmptbl.i error.cmn force.cmn frctbl.i srslen.prm tbllog.cmn \ tbllog.prm qname.o: lex.i qquote.o: cchars.i lex.i qsdiff.o: srslen.prm qtoken.o: cchars.i lex.i quadit.o: global.cmn model.prm srslen.prm ratneg.o: model.prm srslen.prm ratpos.o: model.prm srslen.prm rdotlr.o: lex.i model.prm srslen.prm rdotls.o: lex.i model.prm srslen.prm realit.o: global.cmn model.prm srslen.prm regfix.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm reglbl.o: model.prm srslen.prm regvar.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn usrreg.cmn regx11.o: error.cmn mdldat.cmn model.cmn model.prm series.cmn srslen.prm \ stdio.i units.cmn xclude.cmn replyf.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm resid.o: stdio.i units.cmn resid2.o: srslen.prm xtdtyp.cmn restor.o: arima.cmn lzero.cmn mdldat.cmn model.cmn model.prm picktd.cmn \ prior.cmn prior.prm srslen.prm ssprep.cmn usrreg.cmn x11adj.cmn \ x11opt.cmn revchk.o: error.cmn extend.cmn model.cmn model.prm rev.cmn rev.prm \ revtbl.i revtrg.cmn seatlg.cmn srslen.prm stdio.i tbllog.cmn \ tbllog.prm units.cmn usrreg.cmn x11adj.cmn x11log.cmn x11reg.cmn revdrv.o: arima.cmn cchars.i dgnsvl.i error.cmn extend.cmn hiddn.cmn \ inpt.cmn lkhd.cmn mdldat.cmn mdltbl.i missng.cmn model.cmn \ model.prm notset.prm orisrs.cmn otlrev.cmn otxrev.cmn picktd.cmn \ rev.cmn rev.prm revsrs.cmn revtbl.i revtrg.cmn seatdg.cmn \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ title.cmn units.cmn usrreg.cmn usrxrg.cmn x11adj.cmn x11log.cmn \ x11opt.cmn x11ptr.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn xrgtbl.i revhdr.o: error.cmn rev.cmn rev.prm revtrg.cmn srslen.prm units.cmn rgarma.o: error.cmn hiddn.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ series.cmn srslen.prm stdio.i tbllog.cmn tbllog.prm units.cmn rgtdhl.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ prior.cmn prior.prm srslen.prm x11log.cmn x11msc.cmn x11opt.cmn \ x11ptr.cmn x11reg.cmn x11srs.cmn xtdtyp.cmn rmatot.o: cchars.i error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ ssprep.cmn title.cmn units.cmn rmfix.o: error.cmn fxreg.cmn mdldat.cmn model.cmn model.prm srslen.prm rmlnvr.o: error.cmn model.cmn model.prm notset.prm picktd.cmn srslen.prm rmlpyr.o: adj.cmn arima.cmn error.cmn inpt.cmn mdldat.cmn model.cmn \ model.prm picktd.cmn prior.cmn prior.prm priusr.cmn srslen.prm rmotrv.o: cchars.i error.cmn mdldat.cmn model.cmn model.prm srslen.prm \ title.cmn units.cmn rmotss.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm rmpadj.o: lzero.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm rmtadj.o: lzero.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm rndsa.o: srslen.prm stdio.i units.cmn x11opt.cmn rngbuf.o: cchars.i lex.i stdio.i roots.o: model.prm srslen.prm stdio.i units.cmn rplus.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn rpoly.o: global.cmn model.prm srslen.prm rv2ss.o: adj.cmn agr.cmn arima.cmn extend.cmn hiddn.cmn inpt.cmn \ lzero.cmn mdldat.cmn model.prm orisrs.cmn seatlg.cmn seatmd.cmn \ srslen.prm ss2rv.cmn ssprep.cmn stcfcm.cmn tbllog.cmn tbllog.prm \ usrxrg.cmn x11opt.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn rvarma.o: error.cmn mdldat.cmn model.cmn model.prm rev.prm srslen.prm rvfixd.o: model.prm srslen.prm rvrghd.o: cchars.i revtbl.i title.cmn rvtdrg.o: error.cmn mdldat.cmn model.cmn model.prm picktd.cmn rev.prm \ srslen.prm usrreg.cmn savacf.o: autoq.cmn cchars.i error.cmn mdltbl.i notset.prm srslen.prm savchi.o: model.prm notset.prm srslen.prm units.cmn savd8b.o: cchars.i error.cmn filext.prm filext.var tbllog.prm savitr.o: cchars.i mdldat.cmn mdltbl.i model.cmn model.prm savcmn.cmn \ srslen.prm savmdc.o: notset.prm seatmd.cmn srslen.prm savmdl.o: error.cmn mdldat.cmn mdltbl.i model.cmn model.prm picktd.cmn \ savcmn.cmn srslen.prm usrreg.cmn x11adj.cmn savmtx.o: cchars.i error.cmn model.prm savcmn.cmn srslen.prm savotl.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm units.cmn \ usrreg.cmn savpk.o: rho.cmn spcsvl.i svllog.cmn svllog.prm units.cmn savspp.o: cchars.i error.cmn savtbl.o: cchars.i error.cmn filext.prm filext.var tbllog.prm savtpk.o: spcsvl.i svllog.cmn svllog.prm units.cmn savwkf.o: cchars.i error.cmn notset.prm seatmd.cmn srslen.prm sdev.o: notset.prm sdxtrm.o: srslen.prm xtrm.cmn seatad.o: seatcm.cmn seatlg.cmn srslen.prm x11adj.cmn x11fac.cmn \ x11ptr.cmn seatdg.o: calc.i cmpflts.i dimensions.i error.cmn force.cmn inpt.cmn \ mdldat.cmn model.cmn model.prm notset.prm orisrs.cmn rev.cmn rev.prm \ revtbl.i seatcm.cmn seatdg.cmn seatlg.cmn seattb.i setsvl.i sig.i \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ units.cmn x11ptr.cmn seatfc.o: force.cmn inpt.cmn orisrs.cmn seatcm.cmn srslen.prm x11adj.cmn \ x11fac.cmn x11ptr.cmn seatpr.o: adj.cmn calc.i desset.prm desset.var dimensions.i error.cmn \ extend.cmn force.cmn frctbl.i inpt.cmn mdltbl.i notset.prm \ priusr.cmn seatcm.cmn seatdg.cmn seatlg.cmn seatmd.cmn seattb.i \ sig.i spctbl.i srslen.prm tbllog.cmn tbllog.prm tbltitle.prm \ title.cmn x11adj.cmn x11fac.cmn x11ptr.cmn serates.o: units.cmn setamx.o: error.cmn stdio.i units.cmn setapt.o: agr.cmn extend.cmn notset.prm x11ptr.cmn setcv.o: notset.prm stdio.i units.cmn setcvl.o: notset.prm stdio.i units.cmn setmdl.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm stdio.i \ units.cmn setopr.o: error.cmn model.prm notset.prm srslen.prm stdio.i units.cmn setpt.o: error.cmn mdldat.cmn model.cmn model.prm srslen.prm setrvp.o: rev.cmn rev.prm revtrg.cmn srslen.prm setssp.o: agr.cmn error.cmn extend.cmn lzero.cmn model.prm notset.prm \ srslen.prm ssap.cmn ssap.prm sspinp.cmn stdio.i units.cmn \ x11adj.cmn x11log.cmn x11opt.cmn xrgmdl.cmn setup.o: chrt.cmn rho.cmn srslen.prm setxpt.o: extend.cmn lzero.cmn x11ptr.cmn sfmax.o: srslen.prm sfmsr.o: srslen.prm units.cmn work2.cmn x11opt.cmn sftest.o: error.cmn mdldat.cmn mdldg.cmn model.cmn model.prm notset.prm \ srslen.prm units.cmn usrreg.cmn usrxrg.cmn shrink.o: srslen.prm x11ptr.cmn si.o: error.cmn srslen.prm tbllog.cmn tbllog.prm x11msc.cmn x11srs.cmn \ x11tbl.i xtrm.cmn sigex.o: acfst.i across.i bench.i buffers.i cmpflts.i cross.i date.i \ dimensions.i dirs.i error.cmn estb.i force.cmn func2.i func4.i func5.i \ hdflag.i hiddn.cmn hspect.i models.i notset.prm peaks.i pinno.i \ preadtr.i rtestm.i seastest.i seatop.cmn serrlev.i sesfcast.i \ sfcast.i sform.i sig.i sig1.i spe.i spectra.i spectrum.i srslen.prm \ stdio.i stream.i strmodel.i titl.i transcad.i units.cmn sigsub.o: dimensions.i revs.i seatop.cmn serrlev.i sesfcast.i sfcast.i \ srslen.prm stream.i transcad.i simul.o: srslen.prm skparg.o: lex.i skparm.o: lex.i skpfcn.o: lex.i skplst.o: lex.i smpeak.o: notset.prm spcdrv.o: adxser.cmn error.cmn extend.cmn hiddn.cmn inpt.cmn mdltbl.i \ model.cmn model.prm notset.prm orisrs.cmn prior.cmn prior.prm \ rho.cmn seatcm.cmn seatlg.cmn spcidx.cmn spcsvl.i spctbl.i \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ tbltitle.prm title.cmn tukey.cmn units.cmn x11adj.cmn x11fac.cmn \ x11log.cmn x11ptr.cmn x11srs.cmn spcrsd.o: error.cmn model.prm notset.prm rho.cmn spcidx.cmn spcsvl.i \ spctbl.i srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm tbltitle.prm tukey.cmn units.cmn special.o: spectrum.i stream.i specpeak.o: dimensions.i rho.cmn spectrum.i srslen.prm spectrum.o: buffers.i dimensions.i dirs.i error.cmn func.i func2.i func3.i \ func4.i func5.i hspect.i min.i pinno.i polynom.i seattb.i \ spectra.i spectrum.i srslen.prm stdio.i stream.i strmodel.i \ tbllog.cmn tbllog.prm test.i transcad.i units.cmn spgrh.o: notset.prm srslen.prm ss2rv.o: adj.cmn agr.cmn arima.cmn extend.cmn hiddn.cmn lzero.cmn \ mdldat.cmn model.cmn model.prm picktd.cmn seatlg.cmn seatmd.cmn \ srslen.prm ss2rv.cmn ssprep.cmn tbllog.cmn tbllog.prm usrreg.cmn \ usrxrg.cmn x11adj.cmn x11opt.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn ssap.o: dgnsvl.i error.cmn force.cmn mq3.cmn notset.prm srslen.prm \ ssap.cmn ssap.prm ssptbl.i stdio.i svllog.cmn svllog.prm \ tbllog.cmn tbllog.prm title.cmn units.cmn x11opt.cmn ssfnot.o: notset.prm srslen.prm ssap.cmn ssap.prm sspvec.cmn ssftst.o: srslen.prm ssap.prm ssft.cmn units.cmn sshist.o: error.cmn mq3.cmn notset.prm srslen.prm ssap.cmn ssap.prm \ units.cmn x11opt.cmn ssmdl.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm otlrev.cmn \ picktd.cmn srslen.prm sspinp.cmn ssprep.cmn stdio.i units.cmn \ usrreg.cmn x11adj.cmn sspdrv.o: arima.cmn dgnsvl.i error.cmn hiddn.cmn mdldat.cmn mdltbl.i \ model.cmn model.prm notset.prm otlrev.cmn revtbl.i srslen.prm \ ssap.cmn ssap.prm sspdat.cmn sspinp.cmn ssptbl.i svllog.cmn \ svllog.prm tbllog.cmn tbllog.prm title.cmn units.cmn usrreg.cmn \ usrxrg.cmn x11opt.cmn x11ptr.cmn xrgmdl.cmn xrgtbl.i ssphdr.o: force.cmn srslen.prm ssap.cmn ssap.prm units.cmn x11opt.cmn ssprep.o: arima.cmn mdldat.cmn model.cmn model.prm picktd.cmn prior.cmn \ prior.prm srslen.prm ssprep.cmn usrreg.cmn x11adj.cmn x11opt.cmn ssrit.o: agr.cmn agrsrs.cmn lzero.cmn notset.prm srslen.prm ssap.cmn \ ssap.prm ssft.cmn sspdat.cmn sspinp.cmn x11opt.cmn ssrng.o: notset.prm srslen.prm ssap.cmn ssap.prm ssptbl.i tbllog.cmn \ tbllog.prm units.cmn ssx11a.o: arima.cmn error.cmn extend.cmn inpt.cmn lzero.cmn mdldat.cmn \ missng.cmn model.cmn model.prm orisrs.cmn otlrev.cmn otxrev.cmn \ srslen.prm ssap.cmn ssap.prm ssft.cmn stdio.i units.cmn x11opt.cmn \ x11ptr.cmn x11reg.cmn xeastr.cmn xrgmdl.cmn ssxmdl.o: arima.cmn error.cmn model.cmn model.prm otxrev.cmn srslen.prm \ sspinp.cmn stdio.i units.cmn usrxrg.cmn x11log.cmn x11reg.cmn \ xrgmdl.cmn stpitr.o: model.prm srslen.prm stdio.i units.cmn strinx.o: lex.i strtvl.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm sumry.o: goodob.cmn notset.prm srslen.prm x11opt.cmn svaict.o: arima.cmn error.cmn model.cmn model.prm picktd.cmn srslen.prm \ units.cmn svamcm.o: cchars.i error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ savcmn.cmn srslen.prm svchsd.o: srslen.prm units.cmn svf2f3.o: cmpsvl.i inpt2.cmn srslen.prm svllog.cmn svllog.prm tests.cmn \ work2.cmn x11opt.cmn x11svl.i svflt.o: cchars.i error.cmn svfltd.o: cchars.i error.cmn svfnrg.o: error.cmn model.prm srslen.prm units.cmn svfreq.o: notset.prm spcidx.cmn units.cmn svolit.o: cchars.i error.cmn mdltbl.i model.prm savcmn.cmn srslen.prm \ units.cmn xrgtbl.i svoudg.o: acfast.i across.i units.cmn svpeak.o: error.cmn notset.prm units.cmn svrgcm.o: cchars.i error.cmn mdldat.cmn mdltbl.i model.cmn model.prm \ notset.prm savcmn.cmn srslen.prm svrvhd.o: mq3.cmn rev.cmn rev.prm revtrg.cmn srslen.prm units.cmn svspan.o: cchars.i error.cmn srslen.prm ssap.cmn ssap.prm svtukp.o: notset.prm spctbl.i tukey.cmn units.cmn table.o: agr.cmn desfct.prm desfct.var desfc2.prm desfc2.var error.cmn \ extend.cmn force.cmn goodob.cmn hiddn.cmn missng.cmn notset.prm \ srslen.prm tbltitle.prm tfmts.cmn tfmts.prm tfmts.var title.cmn \ units.cmn x11opt.cmn x11ptr.cmn xtrm.cmn tblhdr.o: error.cmn extend.cmn force.cmn mq3.cmn notset.prm priusr.cmn \ srslen.prm title.cmn units.cmn x11adj.cmn x11msc.cmn x11opt.cmn \ x11reg.cmn td6var.o: error.cmn model.cmn model.prm srslen.prm td7var.o: model.prm srslen.prm tdaic.o: adj.cmn arima.cmn error.cmn extend.cmn inpt.cmn lkhd.cmn \ mdldat.cmn model.cmn model.prm notset.prm picktd.cmn priadj.cmn \ prior.cmn prior.prm priusr.cmn srslen.prm units.cmn tdftest.o: error.cmn mdldat.cmn mdldg.cmn model.cmn model.prm notset.prm \ picktd.cmn srslen.prm units.cmn usrreg.cmn usrxrg.cmn tdlom.o: adj.cmn priadj.cmn prior.cmn prior.prm priusr.cmn srslen.prm tdset.o: notset.prm srslen.prm tdtyp.cmn xtdtyp.cmn tdxtrm.o: notset.prm srslen.prm tbllog.cmn tbllog.prm x11ptr.cmn \ xclude.cmn templs.o: error.cmn lex.i mdldat.cmn model.cmn model.prm srslen.prm \ units.cmn tfmts.o: error.cmn srslen.prm stdio.i tfmts.cmn tfmts.prm tfmts.var \ units.cmn tfmts3.o: error.cmn totals.o: notset.prm trbias.o: srslen.prm trnaic.o: adj.cmn arima.cmn error.cmn extend.cmn hiddn.cmn inpt.cmn \ lkhd.cmn mdldat.cmn mdlsvl.i model.cmn model.prm mq3.cmn \ notset.prm picktd.cmn prior.cmn prior.prm priusr.cmn srslen.prm \ stdio.i svllog.cmn svllog.prm title.cmn units.cmn x11adj.cmn \ x11fac.cmn x11opt.cmn x11ptr.cmn x11srs.cmn trnfcn.o: stdio.i units.cmn tstdrv.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm tstmd1.o: adj.cmn arima.cmn error.cmn extend.cmn inpt.cmn mdldat.cmn \ model.cmn model.prm notset.prm picktd.cmn prior.cmn prior.prm \ priusr.cmn srslen.prm units.cmn tstmd2.o: arima.cmn error.cmn mdldat.cmn model.cmn model.prm notset.prm \ srslen.prm ttest.o: model.prm srslen.prm upespm.o: mdldat.cmn model.cmn model.prm srslen.prm usraic.o: adj.cmn arima.cmn error.cmn extend.cmn lkhd.cmn mdldat.cmn \ model.cmn model.prm notset.prm prior.cmn prior.prm srslen.prm \ units.cmn usrreg.cmn value.o: chrt.cmn srslen.prm varlog.o: goodob.cmn notset.prm srslen.prm vsfa.o: srslen.prm x11msc.cmn x11opt.cmn vsfb.o: srslen.prm x11msc.cmn x11opt.cmn vsfc.o: srslen.prm vtc.o: srslen.prm x11opt.cmn x11ptr.cmn vtest.o: srslen.prm x11opt.cmn weight.o: srslen.prm whitsp.o: cchars.i lex.i wr.o: titl.i transcad.i xxxs.i writln.o: units.cmn wrtdat.o: error.cmn model.prm srslen.prm wrtmss.o: notset.prm srslen.prm ssap.cmn ssap.prm units.cmn wrtotl.o: error.cmn stdio.i units.cmn wrttb2.o: error.cmn notset.prm srslen.prm wrttbl.o: error.cmn notset.prm srslen.prm x11aic.o: arima.cmn error.cmn extend.cmn mdldat.cmn model.cmn model.prm \ notset.prm srslen.prm units.cmn usrreg.cmn usrxrg.cmn x11adj.cmn \ x11log.cmn x11reg.cmn xclude.cmn xrgmdl.cmn xrgum.cmn xtdtyp.cmn x11ari.o: agr.cmn arima.cmn error.cmn extend.cmn lzero.cmn mdldat.cmn \ mdltbl.i model.prm notset.prm nsums.i priusr.cmn rho.cmn spcsvl.i \ spctbl.i srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn \ tbllog.prm title.cmn tukey.cmn units.cmn x11adj.cmn x11log.cmn \ x11msc.cmn x11opt.cmn x11int.o: adj.cmn inpt.cmn srslen.prm x11fac.cmn x11opt.cmn x11srs.cmn \ xtrm.cmn x11mdl.o: adj.cmn arima.cmn desxrg.prm desxrg.var error.cmn extend.cmn \ hiddn.cmn inpt.cmn mdldat.cmn model.cmn model.prm notset.prm \ prior.cmn prior.prm rev.cmn rev.prm srslen.prm ssap.cmn ssap.prm \ sspinp.cmn stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ tbltitle.prm tdtyp.cmn title.cmn units.cmn usrreg.cmn x11adj.cmn \ x11fac.cmn x11log.cmn x11ptr.cmn x11reg.cmn x11svl.i xrgfct.cmn \ xrgmdl.cmn xrgtbl.i xrgum.cmn xtdtyp.cmn x11plt.o: error.cmn hiddn.cmn srslen.prm tbltitle.prm title.cmn units.cmn \ x11adj.cmn x11log.cmn x11opt.cmn x11tbl.i x11pt1.o: adj.cmn agr.cmn arima.cmn cmptbl.i error.cmn extend.cmn \ hiddn.cmn inpt.cmn mdldat.cmn mdltbl.i missng.cmn model.cmn \ model.prm notset.prm orisrs.cmn prior.cmn prior.prm priusr.cmn \ srslen.prm tbllog.cmn tbllog.prm units.cmn x11adj.cmn x11fac.cmn \ x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn x11reg.cmn xrgtbl.i x11pt2.o: agr.cmn cmptbl.i error.cmn extend.cmn hiddn.cmn inpt.cmn \ mdltbl.i orisrs.cmn prior.cmn prior.prm srslen.prm ssap.cmn \ ssap.prm stdio.i tbllog.cmn tbllog.prm tdtyp.cmn units.cmn \ x11adj.cmn x11fac.cmn x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11reg.cmn x11srs.cmn x11tbl.i xrgtbl.i xrgum.cmn xtrm.cmn x11pt3.o: adj.cmn adxser.cmn agr.cmn error.cmn extend.cmn force.cmn \ frctbl.i goodob.cmn hiddn.cmn inpt.cmn notset.prm orisrs.cmn \ priadj.cmn prior.cmn prior.prm priusr.cmn rev.cmn rev.prm revtbl.i \ srslen.prm tbllog.cmn tbllog.prm units.cmn x11adj.cmn x11fac.cmn \ x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn x11srs.cmn x11tbl.i \ xrgum.cmn xtrm.cmn x11pt4.o: adj.cmn adxser.cmn agr.cmn agrsrs.cmn cmptbl.i error.cmn \ force.cmn frctbl.i goodob.cmn hiddn.cmn inpt.cmn inpt2.cmn \ notset.prm orisrs.cmn prior.cmn prior.prm priusr.cmn srslen.prm \ stdio.i tbllog.cmn tbllog.prm tdtyp.cmn units.cmn work2.cmn \ x11adj.cmn x11fac.cmn x11log.cmn x11msc.cmn x11opt.cmn x11ptr.cmn \ x11srs.cmn x11tbl.i x11ref.o: model.prm notset.prm srslen.prm xrgum.cmn xtdtyp.cmn x12hdr.o: agr.cmn build.prm cmptbl.i error.cmn force.cmn hiddn.cmn lex.i \ mdldat.cmn mdltbl.i metadata.cmn metadata.prm missng.cmn model.prm \ mq3.cmn notset.prm prior.cmn prior.prm rho.cmn spctbl.i srslen.prm \ stdio.i tbllog.cmn tbllog.prm title.cmn units.cmn x11adj.cmn \ x11log.cmn x11msc.cmn x11opt.cmn x11reg.cmn x11tbl.i x12run.o: agr.cmn dgnsvl.i hiddn.cmn lex.i notset.prm srslen.prm stdio.i \ svllog.cmn svllog.prm title.cmn units.cmn x11opt.cmn xchng.o: notset.prm srslen.prm ssap.prm xrgdiv.o: arima.cmn mdldat.cmn model.cmn model.prm srslen.prm usrreg.cmn xrgdrv.o: arima.cmn error.cmn extend.cmn hiddn.cmn inpt.cmn lzero.cmn \ mdldat.cmn model.cmn model.prm picktd.cmn priadj.cmn prior.cmn \ prior.prm priusr.cmn srslen.prm units.cmn usrreg.cmn x11adj.cmn \ x11opt.cmn x11ptr.cmn x11reg.cmn x11srs.cmn xrgmdl.cmn xrghol.o: arima.cmn mdldat.cmn model.cmn model.prm srslen.prm usrreg.cmn xrgtrn.o: srslen.prm tdtyp.cmn xtdtyp.cmn xrlkhd.o: mdldat.cmn model.cmn model.prm notset.prm srslen.prm xtrm.o: lzero.cmn notset.prm srslen.prm x11opt.cmn xtrm.cmn yrly.o: chrt.cmn srslen.prm component.o: component.i complagdiag.o: srslen.prm compcrodiag.o: srslen.prm phasegain.o: notset.prm altundovrtst.o: acfast.i across.i models.i stream.i m2q.o: srslen.prm chqsea.o: arima.cmn inpt.cmn mdldat.cmn model.cmn model.prm notset.prm \ orisrs.cmn rho.cmn srslen.prm units.cmn x11msc.cmn x11opt.cmn \ x11ptr.cmn x11srs.cmn npsa.o: dimensions.i srslen.prm gennpsa.o: adxser.cmn extend.cmn model.prm model.cmn notset.prm seatcm.cmn \ seatlg.cmn tbllog.cmn tbllog.prm srslen.prm rho.cmn \ units.cmn x11adj.cmn x11ptr.cmn x11srs.cmn prarma.o: mdldat.cmn model.prm model.cmn srslen.prm testodf.o: arima.cmn error.cmn extend.cmn mdldat.cmn mdldg.cmn mdlsvl.i \ mdltbl.i model.cmn model.prm notset.prm prior.cmn prior.prm \ srslen.prm stdio.i svllog.cmn svllog.prm tbllog.cmn tbllog.prm \ units.cmn makotl.f0000664006604000003110000001023314521201530011617 0ustar sun00315stepsC Last change: BCM 17 Jul 2003 8:57 pm **==makotl.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE makotl(T0,Nr,Ltest,Otlvar,Notlr,Tcalfa,Sp) IMPLICIT NONE c----------------------------------------------------------------------- c Makes AO and LS outlier variables for effects at time t0. c Variables are nr long. If notlr is 1 only and AO outlier is made c and if notlr is 2 then the AO is in column 1 and the LS in column 2. c AO is 1 and time t0 and 0 otherwise. LS is -1 if t=t0. c Note that the array in the calling program is otlvar(2,nr) and is c referenced by otlvar(outlier type,time). c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c ltest l Input logical array ltest(1)=true means creat an AO c variable and ltest(2)=true creat an LS variable c mone d Local PARAMETER for a double precision -1 c notlr i Output number of outlier types 1 to make just AO or LS, c and 2 for both AO and LS c nr i Input number of rows in the outlier variable matrix c one d Local PARAMETER for a double precision 1 c otlvar d Output nr by notlr outlier array variable c t0 i Input index for the time point the outlier occured at c zero d Local PARAMETER for a double precision 0 c----------------------------------------------------------------------- c Data typing and definition c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ DOUBLE PRECISION MONE,ONE,ZERO PARAMETER(ONE=1D0,MONE=-ONE,ZERO=0D0) c ------------------------------------------------------------------ INTEGER Ltest(POTLR) INTEGER i,Notlr,Nr,T0,dsp,Sp,imod0,t1 DOUBLE PRECISION Otlvar,Tcalfa,drmp DIMENSION Otlvar(Nr*POTLR),dsp(POTLR-1) c----------------------------------------------------------------------- c Set up the dispensation variable for AO and LS and Notlr. c----------------------------------------------------------------------- CALL setint(0,POTLR-1,dsp) IF(Ltest(TC).eq.1)THEN dsp(AO)=dsp(AO)+1 dsp(LS)=dsp(LS)+1 END IF IF(Ltest(LS).eq.1)dsp(AO)=dsp(AO)+1 Notlr=dsp(AO) IF(Ltest(AO).eq.1)Notlr=Notlr+1 c----------------------------------------------------------------------- c Begin generating matrix of outliers by generating observations c before T0 c----------------------------------------------------------------------- DO i=Notlr,Notlr*(T0-1),Notlr IF(Ltest(AO).eq.1)Otlvar(i-dsp(AO))=ZERO IF(Ltest(LS).eq.1)Otlvar(i-dsp(LS))=MONE * IF(Ltest(TC).eq.1)Otlvar(i-dsp(TC))=ZERO * IF(Ltest(SO).eq.1)Otlvar(i)=ZERO IF(Ltest(TC).eq.1)Otlvar(i)=ZERO END DO c ------------------------------------------------------------------ c Now geneate values of observation T0 c ------------------------------------------------------------------ i=T0*Notlr IF(Ltest(AO).eq.1)Otlvar(i-dsp(AO))=ONE IF(Ltest(LS).eq.1)Otlvar(i-dsp(LS))=ZERO * IF(Ltest(TC).eq.1)Otlvar(i-dsp(TC))=ONE * IF(Ltest(SO).eq.1)THEN * Otlvar(i)=ONE * imod0=mod(T0,Sp) * t1=T0 * drmp=MONE/DBLE(Sp-1) * END IF IF(Ltest(TC).eq.1)Otlvar(i)=ONE c ------------------------------------------------------------------ DO i=i+Notlr,Nr*Notlr,Notlr IF(Ltest(AO).eq.1)Otlvar(i-dsp(AO))=ZERO IF(Ltest(LS).eq.1)Otlvar(i-dsp(LS))=ZERO * IF(Ltest(TC).eq.1) * & Otlvar(i-dsp(TC))=Otlvar(i-dsp(TC)-Notlr)*Tcalfa * IF(Ltest(SO).eq.1)THEN * t1=t1+1 * IF(imod0.eq.mod(t1,Sp))THEN * Otlvar(i)=ONE * ELSE * Otlvar(i)=drmp * END IF * END IF IF(Ltest(TC).eq.1)Otlvar(i)=Otlvar(i-Notlr)*Tcalfa END DO c ------------------------------------------------------------------ RETURN END makttl.f0000664006604000003110000001331214521201530011625 0ustar sun00315stepsC Last change: BCM 11 Jun 1998 4:07 pm SUBROUTINE makttl(Ttldic,Ttlptr,Pttl,Tblptr,Dsptr,Tblttl,Ntbttl, & Label,Fcst) IMPLICIT NONE c----------------------------------------------------------------------- c Create table title used in TABLE subroutine c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'fctlbl.prm' INCLUDE 'tbllbl.prm' INCLUDE 'x11tbl.i' INCLUDE 'cmptbl.i' INCLUDE 'frctbl.i' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'tbltitle.prm' INCLUDE 'force.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- LOGICAL Label,Fcst CHARACTER Ttldic*(*),Tblttl*(PTTLEN),upper*(1),clbl*(10),ctbl*(3), & tmpttl*(PTTLEN) INTEGER Ttlptr,Pttl,Tblptr,Ntbttl,nclbl,Dsptr,i1,i2,ntmp,ntmp2,n2, & n3,ipos DIMENSION Ttlptr(0:Pttl) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- INCLUDE 'fctlbl.var' INCLUDE 'tbllbl.var' c----------------------------------------------------------------------- c Get the table description from one of the data dictionaries C----------------------------------------------------------------------- CALL getstr(Ttldic,Ttlptr,Pttl,Tblptr-Dsptr,Tblttl,Ntbttl) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Convert codes to correct labels and make the first character c upper case, if labels are produced c----------------------------------------------------------------------- IF(Ntbttl.eq.0)THEN ipos=1 CALL itoc(Tblptr,ctbl,ipos) IF(Lfatal)RETURN CALL writln('ERROR: '//PRGNAM//' could not generate a table '// & 'title (internal code #'//ctbl(1:(ipos-1))//').', & STDERR,Mt2,T) CALL writln(' Please send the input spec file that '// & 'generated this error message,',STDERR,Mt2,F) CALL writln(' along with any data files used, to '// & 'x12@census.gov.',STDERR,Mt2,F) CALL abend RETURN ELSE i1=index(Tblttl(1:Ntbttl),'%') upper=Tblttl(1:1) IF(i1.gt.0)THEN ntmp=nblank(Moqu) ntmp2=nblank(Pcdif) IF(i1.eq.1)upper=Moqu(1:1) IF(Label)THEN i2=ichar(upper) IF(i2.ge.97.and.i2.le.122)upper=char(i2-32) END IF n2=Ntbttl+2*ntmp+ntmp2+4 IF(i1.eq.1)THEN n3=Ntbttl-1 tmpttl(1:n3)=Tblttl(2:Ntbttl) Tblttl(1:n2)=upper//Moqu(2:ntmp)//'-to-'//Moqu(1:ntmp)//' '// & Pcdif(1:ntmp2)//tmpttl(1:n3) ELSE n3=Ntbttl-i1 tmpttl(1:n3)=Tblttl((i1+1):Ntbttl) Tblttl(1:n2)=upper//Tblttl(2:(i1-1))//Moqu(1:ntmp)//'-to-'// & Moqu(1:ntmp)//' '//Pcdif(1:ntmp2)//tmpttl(1:n3) END IF Ntbttl=n2 ELSE i1=index(Tblttl(1:Ntbttl),'^') IF(i1.gt.0)THEN IF(Tblptr.eq.LXERA1.or.Tblptr.eq.LXERA2.or.Tblptr.eq.LCMPR1.or. & Tblptr.eq.LCMPR2)THEN ntmp=nblank(Moqu) upper=char(ichar(Moqu(1:1))-32) ntmp2=nblank(Rad) IF(ntmp2.gt.6)ntmp2=4 n2=Ntbttl+2*ntmp+ntmp2+4 n3=Ntbttl-i1 tmpttl(1:n3)=Tblttl((i1+1):Ntbttl) Tblttl(1:n2)=upper//Moqu(2:ntmp)//'-to-'//Moqu(1:ntmp)//' '// & Rad(1:ntmp2)//tmpttl(1:n3) Ntbttl=n2 ELSE ntmp=nblank(Rad) IF(i1.eq.1)upper=Rad(1:1) IF(Label)THEN i2=ichar(upper) IF(i2.ge.97.and.i2.le.122)upper=char(i2-32) END IF n2=Ntbttl+ntmp-1 IF(i1.eq.1)THEN n3=Ntbttl-1 tmpttl(1:n3)=Tblttl(2:Ntbttl) Tblttl(1:n2)=upper//Rad(2:ntmp)//tmpttl(1:n3) ELSE n3=Ntbttl-i1 tmpttl(1:n3)=Tblttl((i1+1):Ntbttl) Tblttl(1:n2)=upper//Tblttl(2:(i1-1))//Rad(1:ntmp)// & tmpttl(1:n3) END IF Ntbttl=n2 END IF ELSE IF(Label)THEN i2=ichar(Tblttl(1:1)) IF(i2.ge.97.and.i2.le.122)upper=char(i2-32) n3=Ntbttl-1 tmpttl(1:n3)=Tblttl(2:Ntbttl) Tblttl(1:Ntbttl)=upper//tmpttl(1:n3) END IF END IF END IF c----------------------------------------------------------------------- c If table label produced as well, get label c----------------------------------------------------------------------- IF(Label)THEN IF(Fcst)THEN CALL getstr(LBFDIC,lbfptr,PLBF,Tblptr,clbl,nclbl) ELSE CALL getstr(LBLDIC,lblptr,PLBL,Tblptr,clbl,nclbl) END IF IF(Lfatal)RETURN IF(nclbl.gt.0)THEN n2=Ntbttl+nclbl+2 tmpttl(1:Ntbttl)=Tblttl(1:Ntbttl) Tblttl(1:n2)=clbl(1:nclbl)//' '//tmpttl(1:Ntbttl) Ntbttl=n2 END IF END IF c----------------------------------------------------------------------- IF((Tblptr.eq.LFCRND.or.Tblptr.eq.LCPRND).and.Iyrt.gt.0)THEN Tblttl((Ntbttl+1):(Ntbttl+25))='with forced yearly totals' Ntbttl=Ntbttl+25 END IF c----------------------------------------------------------------------- RETURN END c----------------------------------------------------------------------- map.f0000664006604000003110000000256214521201530011113 0ustar sun00315steps**==map.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE map(Frcset,Tocset,Str1,Str2) IMPLICIT NONE c---------------------------------------------------------------------- c Maps fromcset characters to tocset characters within the domain c of fromcset and copies otherwise. c---------------------------------------------------------------------- INCLUDE 'lex.i' c ----------------------------------------------------------------- CHARACTER Frcset*(*),Tocset*(*),Str1*(*),Str2*(*) INTEGER ichr,indx,mapind EXTERNAL indx c ----------------------------------------------------------------- IF(len(Frcset).ne.len(Tocset))THEN CALL inpter(PERROR,Pos,'Map cset''s not the same length') c ----------------------------------------------------------------- ELSE IF(len(Str2).lt.len(Str1))THEN CALL inpter(PERROR,Pos,'Map output string not long enough') c ----------------------------------------------------------------- ELSE Str2=Str1 c ----------------------------------------------------------------- DO ichr=1,len(Str1) mapind=indx(Frcset,Str1(ichr:ichr)) IF(mapind.gt.0)Str2(ichr:ichr)=Tocset(mapind:mapind) END DO END IF c ----------------------------------------------------------------- RETURN END matrix1.i0000664006604000003110000000055314521201530011724 0ustar sun00315stepsC C... Variables in Common Block /matrix1/ ... character Pat,Tmcs,Ana,Sf,Cvar,Ccc, $ CmtTc,CmtS,CmtIR,CmtTs,CmtSA integer Nmmu,Nmp,Nmd,Nmq,Nmbp,Nmbd,Nmbq real*8 Sd common /matrix1/ Sd,Nmmu,Nmp,Nmd,Nmq,Nmbp,Nmbd,Nmbq, $ Cvar,Ccc,CmtTc,CmtS,CmtIR,CmtTs,CmtSA, $ Pat,Tmcs,Ana,Sf matrix2.i0000664006604000003110000000315314521201530011724 0ustar sun00315stepsC C... Variables in Common Block /matrix2/ ... C C Sdt Standard Deviation of Trend Innovation C Sds Standard Deviation of Seasonal Innovation C Sdc Standard Deviation of Transitory Innovation C Sdi Standard Deviation of Irregular Innovation C Sdsa Standard Deviation of SA Innovation C SeCect Standard Error Trend Concurrent Estimator C SeCecsa Standard Error SA Concurrent Estimator C RSeCect Revision Standard Error Trend Concurrent Estimator C RSeCecsa Revision Standard Error SA Concurrent Estimator C Covt1 Convergence Trend after 1 year C Covsa1 Convergence SA after 1 year C Covt5 Convergence Trend after 5 year C Covsa5 Convergence SA after 5 year C Ssh Significance of seasonality Historical Estimator C Ssp Significance of seasonality Preliminary Estimator C Ssf Significance of seasonality Forecast Estimator C ESS Enough significance of Seasonality C T11t total SE Period-to-Period Trend rate of growth C T11sa total SE Period-to-Period SA rate of growth C T112t total SE Annual Trend rate of growth C T112sa total SE Annual SA rate of growth C T112x total SE Annual Series rate of growth C Daat Difference in Annuaol Average Trend C Daasa Difference in Annuaol Average SA C integer Ssh,SSp,SSf,ESS real*8 Sdt,Sds,Sdc,Sdi,Sdsa,SeCect,SeCecSa,RseCect,RseCecSa, $ Covt1,Covsa1,Covt5,Covsa5,T11t,T11sa,T112t, $ T112sa,T112x,Daat,Daasa common /matrix2/ Sdt,Sds,Sdc,Sdi,Sdsa,SeCect, $ SeCecSa,RseCect,RseCecSa,Covt1,Covsa1, $ Covt5,Covsa5,T11t,T11sa,T112t,T112sa, $ T112x,Daat,Daasa,Ssh,SSp,SSf,ESS matrix.f0000664006604000003110000003704114521201530011642 0ustar sun00315steps subroutine setPat(avalue) character avalue include 'matrix1.i' Pat=avalue return end subroutine setTmcs(avalue) character avalue include 'matrix1.i' Tmcs=avalue * if ((value .eq. 'Y') .or. (value .eq. 'y')) then * call usrentry(1.0d0,1,1,1,1,1020) * else * call usrentry(0.0d0,1,1,1,1,1020) * end if return end subroutine setAna(avalue) character avalue double precision dvec(1) include 'matrix1.i' Ana=avalue if ((avalue .eq. 'Y').or.(avalue .eq. 'y')) then dvec(1)=1.0d0 else dvec(1)=0.0d0 endif call usrentry(dvec,1,1,1,1,1019) return end subroutine setNmmu(avalue) Integer avalue include 'matrix1.i' Nmmu=avalue return end subroutine setNmp(avalue) Integer avalue include 'matrix1.i' Nmp=avalue return end subroutine setNmd(avalue) Integer avalue include 'matrix1.i' Nmd=avalue return end subroutine setNmq(avalue) Integer avalue include 'matrix1.i' Nmq=avalue return end subroutine setNmBp(avalue) Integer avalue include 'matrix1.i' NmBp=avalue return end subroutine setNmBd(avalue) Integer avalue include 'matrix1.i' NmBd=avalue return end subroutine setNmBq(avalue) Integer avalue include 'matrix1.i' NmBq=avalue return end subroutine setSf(avalue) character avalue include 'matrix1.i' Sf=avalue * if ((value .eq. 'E').or.(value .eq. 'e')) then * call usrentry(1.0d0,1,1,1,1,1021) * else * call usrentry(0.0d0,1,1,1,1,1021) * end if return end subroutine setCvar(avalue) character avalue include 'matrix1.i' Cvar=avalue * if ((value .eq. 'E').or.(value .eq. 'e')) then * call usrentry(1.0d0,1,1,1,1,1022) * else * call usrentry(0.0d0,1,1,1,1,1022) * end if return end subroutine setCcc(avalue) character avalue include 'matrix1.i' Ccc=avalue * if ((value .eq. 'E').or.(value .eq. 'e')) then * call usrentry(1.0d0,1,1,1,1,1039) * else * call usrentry(0.0d0,1,1,1,1,1039) * end if return end subroutine setCmtTc(avalue) character avalue include 'matrix1.i' CmtTc=avalue return end subroutine setCmtS(avalue) character avalue include 'matrix1.i' CmtS=avalue return end subroutine setCmtIR(avalue) character avalue include 'matrix1.i' CmtIR=avalue return end subroutine setCmtTs(avalue) character avalue include 'matrix1.i' CmtTs=avalue return end subroutine setCmtSA(avalue) character avalue include 'matrix1.i' CmtSA=avalue return end subroutine setSd(avalue) real*8 avalue include 'matrix1.i' Sd=avalue return end character Function getPat() include 'matrix1.i' getPat=Pat return end character Function getTmcs() include 'matrix1.i' getTmcs=Tmcs return end character Function getAna() include 'matrix1.i' getAna=Ana return end Integer Function getNmmu() include 'matrix1.i' getNmmu=Nmmu return end Integer Function getNmp() include 'matrix1.i' getNmp=Nmp return end Integer Function getNmd() include 'matrix1.i' getNmd=Nmd return end Integer Function getNmq() include 'matrix1.i' getNmq=Nmq return end Integer Function getNmBp() include 'matrix1.i' getNmBp=NmBp return end Integer Function getNmBd() include 'matrix1.i' getNmBd=NmBd return end Integer Function getNmBq() include 'matrix1.i' getNmBq=NmBq return end character Function getSf() include 'matrix1.i' getSf=Sf return end character Function getCvar() include 'matrix1.i' getCvar=Cvar return end character Function getCcc() include 'matrix1.i' getCcc=Ccc return end character Function getCmtTc() include 'matrix1.i' getCmtTc=CmtTc return end character Function getCmtS() include 'matrix1.i' getCmtS=CmtS return end character Function getCmtIR() include 'matrix1.i' getCmtIR=CmtIR return end character Function getCmtTs() include 'matrix1.i' getCmtTs=CmtTs return end character Function getCmtSA() include 'matrix1.i' getCmtSA=CmtSA return end real*8 Function getSd() include 'matrix1.i' getSd=Sd return end subroutine Mtx1Reset() include 'matrix1.i' Pat='N' Tmcs='N' Ana='N' Nmmu=0 Nmp=0 Nmd=0 Nmq=0 Nmbp=0 Nmbd=0 Nmbq=0 Sf='0' Cvar='0' Ccc='0' CmtTc='N' CmtS='N' CmtIR='N' CmtTs='N' CmtSA='N' Sd=0.0d0 return end C C Matrix2 C subroutine setSdt(avalue) include 'matrix2.i' real*8 avalue Sdt=avalue return end real*8 function getSdt() include 'matrix2.i' getSdt=Sdt return end subroutine setSds(avalue) include 'matrix2.i' real*8 avalue Sds=avalue return end real*8 function getSds() include 'matrix2.i' getSds=Sds return end subroutine setSdc(avalue) include 'matrix2.i' real*8 avalue Sdc=avalue return end real*8 function getSdc() include 'matrix2.i' getSdc=Sdc return end subroutine setSdi(avalue) include 'matrix2.i' real*8 avalue Sdi=avalue return end real*8 function getSdi() include 'matrix2.i' getSdi=Sdi return end subroutine setSdsa(avalue) include 'matrix2.i' real*8 avalue Sdsa=avalue return end real*8 function getSdsa() include 'matrix2.i' getSdsa=Sdsa return end subroutine setSeCect(avalue) include 'matrix2.i' real*8 avalue SeCect=avalue return end real*8 function getSeCect() include 'matrix2.i' getSeCect=SeCect return end subroutine setSeCecSa(avalue) include 'matrix2.i' real*8 avalue SeCecSa=avalue return end real*8 function getSeCecSa() include 'matrix2.i' getSeCecSa=SeCecSa return end subroutine setRseCect(avalue) include 'matrix2.i' real*8 avalue RseCect=avalue return end real*8 function getRseCect() include 'matrix2.i' getRseCect=RseCect return end subroutine setRseCecSa(avalue) include 'matrix2.i' real*8 avalue RseCecSa=avalue return end real*8 function getRseCecSa() include 'matrix2.i' getRseCecSa=RseCecSa return end subroutine setCovt1(avalue) include 'matrix2.i' real*8 avalue Covt1=avalue return end real*8 function getCovt1() include 'matrix2.i' getCovt1=Covt1 return end subroutine setCovsa1(avalue) include 'matrix2.i' real*8 avalue Covsa1=avalue return end real*8 function getCovsa1() include 'matrix2.i' getCovsa1=Covsa1 return end subroutine setCovt5(avalue) include 'matrix2.i' real*8 avalue Covt5=avalue return end real*8 function getCovt5() include 'matrix2.i' getCovt5=Covt5 return end subroutine setCovsa5(avalue) include 'matrix2.i' real*8 avalue Covsa5=avalue return end real*8 function getCovsa5() include 'matrix2.i' getCovsa5=Covsa5 return end subroutine setSsh(avalue) include 'matrix2.i' integer avalue Ssh=avalue return end integer function getSsh() include 'matrix2.i' getSsh=Ssh return end subroutine setESS(nTh95,nTh3,MQ) integer nTh95,nTh3,MQ include 'matrix2.i' if (nTh3.ge.1 .or. nTh95.ge.2 .or. (MQ.lt.12.and.nTh95.ge.1))then ESS=1 else ESS=0 endif return end integer function getESS() include 'matrix2.i' getESS=ESS return end C LINES OF CODE COMMENTED FOR X-13A-S : 1 C subroutine setSSp(avalue) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 subroutine setSSp2(avalue) C END OF CODE BLOCK include 'matrix2.i' integer avalue SSp=avalue return end C LINES OF CODE COMMENTED FOR X-13A-S : 3 C integer function getSSp() C include 'matrix2.i' C getSSp=SSp C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 3 integer function getSSp2() include 'matrix2.i' getSSp2=SSp C END OF CODE BLOCK return end subroutine setSSf(avalue) include 'matrix2.i' integer avalue SSf=avalue return end integer function getSSf() include 'matrix2.i' getSSf=SSf return end subroutine setT11t(avalue) include 'matrix2.i' real*8 avalue T11t=avalue return end real*8 function getT11t() include 'matrix2.i' getT11t=T11t return end subroutine setT11sa(avalue) include 'matrix2.i' real*8 avalue T11sa=avalue return end real*8 function getT11sa() include 'matrix2.i' getT11sa=T11sa return end subroutine setT112t(avalue) include 'matrix2.i' real*8 avalue T112t=avalue return end real*8 function getT112t() include 'matrix2.i' getT112t=T112t return end subroutine setT112sa(avalue) include 'matrix2.i' real*8 avalue T112sa=avalue return end real*8 function getT112sa() include 'matrix2.i' getT112sa=T112sa return end subroutine setT112x(avalue) include 'matrix2.i' real*8 avalue T112x=avalue return end real*8 function getT112x() include 'matrix2.i' getT112x=T112x return end subroutine setDaat(avalue) include 'matrix2.i' real*8 avalue Daat=avalue return end real*8 function getDaat() include 'matrix2.i' getDaat=Daat return end subroutine setDaasa(avalue) include 'matrix2.i' real*8 avalue Daasa=avalue * call usrentry(daasa,1,1,1,1,1038) return end real*8 function getDaasa() include 'matrix2.i' getDaasa=Daasa return end subroutine Mtx2Reset() include 'matrix2.i' Sdt = 0.0d0 Sds = 0.0d0 Sdc = 0.0d0 Sdi = 0.0d0 Sdsa = 0.0d0 SeCect = 0.0d0 SeCecSa = 0.0d0 RseCect = 0.0d0 RseCecSa = 0.0d0 Covt1 = 0.0d0 Covsa1 = 100.0d0 Covt5 = 0.0d0 Covsa5 = 100.0d0 Ssh = 0.0d0 SSp = 0.0d0 SSf = 0.0d0 T11t = 0.0d0 T11sa = 0.0d0 T112t = 0.0d0 T112sa = 0.0d0 T112x = 0.0d0 Daat = 0.0d0 Daasa = 0.0d0 return end c subroutine inicSumS() include 'sums.i' tTMCS=0 tANA=0 tScomp=0 tCycComp=0 tStocTD=0 tSpecFac=0 tACF=0 tCCF=0 tUnstSa=0 tUnrSa=0 tRevSa=0 tSeasNoSig=0 tBias=0 tCrQs=0 tCrSNP=0 tCrPeaks=0 tX11=0 tSeats=0 tNSA=0 return end c subroutine addToSumS(mq,IsCloseToTD,crQs,crSNP,crPeaks,IsPureMA) include 'sums.i' character wStr c real*8 getSdS,getSdc,getSdSa,getSeCecSa,getRSeCecSa,getSd, & getDaaSa,tmpreal,dvec(1) logical isPureMA character gettmcs,getANA,getSf,getCvar,getCcc integer getssh,crQs,crSNP,crPeaks,mq,getESS logical IsCloseToTD EXTERNAL getSdS,getSdc,getSdSa,getSeCecSa,getRSeCecSa,getSd, & getDaaSa,gettmcs,getANA,getSf,getCvar,getCcc,getssh, & getESS c wStr=getTmcs() if ((wStr.eq.'Y') .or.(wStr.eq.'y')) then tTMCS=tTMCS+1 end if if ((getANA().eq.'Y').or.(getANA().eq.'y')) then tANA=tANA+1 end if if (isPureMA .eqv. .false.) then tmpreal=0.0d0 if (getSdS().gt.0) then tScomp=tScomp+1 if (getSdS().gt.(0.75d0*getSd())) then tUnstSa=tUnstSa+1 tmpreal=1.0d0 end if if (getSeCecSa().gt.(0.95d0*getSd())) then tUnrSa=tUnrSa+1 end if dvec(1)=tmpreal call usrentry(dvec,1,1,1,1,1601) tmpreal=0.0d0 if (getRSeCecSa().gt.(0.80d0*getSd())) then tRevSa=tRevSa+1 tmpreal=1.0d0 end if dvec(1)=tmpreal call usrentry(dvec,1,1,1,1,1603) if (getESS().lt.1) then c if (getSSh().lt.2) then tSeasNosig=tSeasNosig+1 end if end if if (.not.IsCloseToTD) then if (getSdc().gt.0) then tCycComp=tCycComp+1 end if else if (getSdc().gt.0) then tStocTD=tStocTD+1 end if end if if ((getSf().eq.'E').or.(getSf().eq.'e')) then tSpecFac=tSpecFac+1 end if if ((getCvar().eq.'E').or.(getCvar().eq.'e')) then tACF=tACF+1 end if if ((getCcc().eq.'E').or.(getCcc().eq.'e')) then tCCF=tCCF+1 end if if (getDaaSa().gt.1.0d0) then tBias=tBias+1 end if if ((mq.eq.4).or.(mq.eq.12)) then if (tCrQs.ne.-1) then tCrQs=tCrQs+CrQs end if if (tCrSNP.ne.-1) then tCrSNP=tCrSNP+tCrSNP end if if (tCrPeaks.ne.-1) then tCrPeaks=tCrPeaks+tCrPeaks end if else tCrQs=-1 tCrSNP=-1 tCrPeaks=-1 end if end if return end maxidx.f0000664006604000003110000000247314521201530011631 0ustar sun00315steps SUBROUTINE maxidx(Dx,N,Imxidx,Imxval) IMPLICIT NONE c----------------------------------------------------------------------- c maxidx.f, Release 1, Subroutine Version 1.3, Modified 22 Sep 1994. c----------------------------------------------------------------------- c Find smallest index of maximum magnitude of double precision dx. c imxidx = first i, i = 1 to n, to minimize abs(dx(1-incx+i*incx)) c----------------------------------------------------------------------- INTEGER i,Imxidx,Imxval,N INTEGER Dx(*),xmag c ----------------------------------------------------------------- IF(N.le.0)THEN Imxidx=0 RETURN END IF Imxidx=1 c----------------------------------------------------------------------- c Code for increments equal to 1. c----------------------------------------------------------------------- Imxval=abs(Dx(1)) IF(N.le.1)RETURN c ----------------------------------------------------------------- DO i=2,N xmag=abs(Dx(i)) c ----------------------------------------------------------------- IF(xmag.gt.Imxval)THEN Imxidx=i Imxval=xmag END IF END DO c ----------------------------------------------------------------- RETURN END maxlag.f0000664006604000003110000000466214521201530011612 0ustar sun00315steps**==maxlag.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE maxlag(Arimal,Opr,Begopr,Endopr,Mxlag) IMPLICIT NONE c----------------------------------------------------------------------- c Calculates the maximum lag of the product of nopr polynomials. c----------------------------------------------------------------------- c Changed: c To find the degree of a polynomial by searching the associated lags c of the polynomial for the highest lag, by BCM based on changes made c to regCMPNT by REG on 04 Feb 2004. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c arimal i Input, parima long array containing the nonzero lags of the c arima error structure. The structure is specified by opr c begopr i Input, begining operator in the opr array to find the maximum c lag of c endopr i Local, last operator in the opr array to figure in the c order of the polynomial order calculations c iopr i Local index for the current lag operator c mxlag i Output scalar for maximum lag. c nlag i Local number of lags in a given operator c opr i Input * array of operator specifications, The first element c in the specification is the pointer to its place in the coef c and lag vectors, second is the number of lags in the operator, c and third is the type of operator (this information is also c specified in the mdl matrix. c----------------------------------------------------------------------- c Date types c----------------------------------------------------------------------- INTEGER Arimal,Begopr,Endopr,iopr,Mxlag,Opr INTEGER imax,i1,i2,i DIMENSION Arimal(*),Opr(0:*) c ------------------------------------------------------------------ Mxlag=0 c ------------------------------------------------------------------ DO iopr=Begopr,Endopr imax=0 i1=Opr(iopr-1) i2=Opr(iopr)-1 IF(i2.ge.i1)THEN imax=Arimal(i2) if (i2.gt.i1) then DO i=i2-1,i1,-1 if(imax.lt.Arimal(i))imax=Arimal(i) END DO END IF Mxlag=imax+Mxlag END IF END DO c ------------------------------------------------------------------ RETURN END maxvec.f0000664006604000003110000000170014521201530011612 0ustar sun00315steps SUBROUTINE maxvec(Dx,N,Mxabvl) c----------------------------------------------------------------------- c maxvec.f, Release 1, Subroutine Version 1.1, Modified 09 Feb 1995. c----------------------------------------------------------------------- c Find maximum magnitude of double precision dx. c----------------------------------------------------------------------- IMPLICIT NONE INTEGER i,N DOUBLE PRECISION Dx(*),Mxabvl,xmag c ----------------------------------------------------------------- Mxabvl=0 IF(N.le.0)RETURN c----------------------------------------------------------------------- c Code for increments equal to 1. c----------------------------------------------------------------------- DO i=1,N xmag=abs(Dx(i)) IF(xmag.gt.Mxabvl)Mxabvl=xmag END DO c ----------------------------------------------------------------- RETURN END mdlchk.f0000664006604000003110000000535714521201531011606 0ustar sun00315stepsC Last change: SRD 31 Jan 2000 6:58 am SUBROUTINE mdlchk(A,Na,Nefobs,Blpct,Blq,Bldf,Rvr,Rtval) IMPLICIT NONE c----------------------------------------------------------------------- * INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' * INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER PR LOGICAL F,T PARAMETER(PR=PLEN/4,F=.false.,T=.true.) c ------------------------------------------------------------------ DOUBLE PRECISION A,smpac,seacf,Blpct,Blq,Rvr,Rtval,rm,rv,an,rstd INTEGER Bldf,i,i1,Na,Nefobs,np,endlag,ilag DIMENSION A(PLEN+2*PORDER),seacf(PR),smpac(PR) c----------------------------------------------------------------------- INCLUDE 'autoq.cmn' c----------------------------------------------------------------------- c Get Ljung-Box Chi-Square results - first derive number of ACFs c to generate c----------------------------------------------------------------------- IF(Sp.eq.12)THEN Bldf=24 ELSE IF(Sp.eq.1)THEN Bldf=8 ELSE Bldf=4*Sp IF(Sp.eq.4.and.Nefobs.le.22.and.Nefobs.ge.18)Bldf=6 END IF c----------------------------------------------------------------------- c check to see if there are enough observations to compute c LB Chi-Square results c----------------------------------------------------------------------- IF(Bldf.ge.Nefobs)THEN * CALL writln('ERROR: Not enough observations to perform automatic * &model identification:',STDERR,Mt2,T) * CALL writln(' unable to compute Ljung-Box statistic.', * & STDERR,Mt2,F) * CALL abend() * RETURN Bldf = Nefobs / 2 END IF c----------------------------------------------------------------------- i1=Na-Nefobs+1 np=0 endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))np=np+1 END DO CALL acf(A(i1),Nefobs,Nefobs,smpac,seacf,Bldf,np,Sp,0,T,F) Blpct=1D0 - Qpv(Bldf) Blq=Qs(Bldf) c----------------------------------------------------------------------- c Compute t-value of the residuals c----------------------------------------------------------------------- rm=0.D0 rv=0.D0 DO i=i1,Na rm=rm+A(i) rv=rv+A(i)*A(i) END DO an=DBLE(Na-i1+1) rm=rm/an rv=rv/an-rm**2 rstd=DSQRT(rv/an) Rtval=rm/rstd c----------------------------------------------------------------------- Rvr=DSQRT(Var) c----------------------------------------------------------------------- RETURN END mdldat.cmn0000664006604000003110000000504414521201531012132 0ustar sun00315stepsc----------------------------------------------------------------------- c Common for data dependant part of the model description. c----------------------------------------------------------------------- c Convrg - Logical variable which indicates if the model estimation c procedure converged c----------------------------------------------------------------------- LOGICAL Convrg c----------------------------------------------------------------------- c Armaer - type of error in the ARIMA estimation procedure c Armaer = 0 means no error c Begspn - starting date of analysis span c Nliter - number of ARMA iterations c Nfev - number of function evaluations in model estimation c Nlwrk - size of Non linear work array c Nspobs - number of observations in the span c Prbfac - integer scalar which keeps track of which ARMA operator c causes an error in the roots checking procedure c Sngcol - column of the regression matrix that causes the matrix to c be singular c----------------------------------------------------------------------- INTEGER Armaer,Begspn,Nliter,Nfev,Nlwrk,Nspobs,Prbfac,Sngcol c----------------------------------------------------------------------- c Arimap - vector of ARMA parameter estimates c Arimcm - ARMA parameter correlation matrix c B - vector of regression parameter estimates c Chlgpg - cholesky decomposition of G'G c Chlvwp - cholesky decomposition of w_p|z c Chlxpx - cholesky decomposition of X-prime-X matrix c Lndtcv - determinate of G'G c Lnlkhd - log likelihood c Matd - D matrix used in ARMA filtering c Xy - regression matrix + y c Var - maximum likelihood variance c Eick - penalty term for the Empiracle Information Criterion c----------------------------------------------------------------------- DOUBLE PRECISION Arimap,Armacm,B,Chlgpg,Chlvwp,Chlxpx,Eick,Lndtcv, & Lnlkhd,Matd,Xy,Var c----------------------------------------------------------------------- DIMENSION Arimap(PARIMA),Armacm(PLEN+2*PORDER,PARIMA),B(PB), & Begspn(2),Chlgpg(PGPG),Chlvwp(PGPG),Chlxpx(PXPX), & Matd((PLEN+PORDER)*PORDER),Xy(PLEN*(PB+1)) C ------------------------------------------------------------------ COMMON /cmdldt/ Arimap,Armacm,B,Chlgpg,Chlvwp,Chlxpx,Eick,Lndtcv, & Lnlkhd,Matd,Xy,Var,Armaer,Begspn,Nliter,Nfev, & Nlwrk,Nspobs,Prbfac,Sngcol,Convrg mdldg.cmn0000664006604000003110000000055014521201531011751 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Sfpv,Sfval,Usfpv,Usfval,Tdfpv,Tdfval,Utdfpv, & Utdfvl,Treg(PB) c----------------------------------------------------------------------- COMMON /cmdldg/ Treg,Sfpv,Sfval,Usfpv,Usfval,Tdfpv,Tdfval,Utdfpv, & Utdfvl mdlfix.f0000664006604000003110000000325514521201531011622 0ustar sun00315stepsC Last change: BCM 13 Oct 1998 3:31 pm SUBROUTINE mdlfix() IMPLICIT NONE c----------------------------------------------------------------------- c Test whether all the fixed parameters have values c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER (T=.TRUE.,F=.FALSE.) c ------------------------------------------------------------------ INTEGER beglag,begopr,endlag,endopr,iflt,ilag,iopr LOGICAL lmdlfx c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ lmdlfx=T Imdlfx=0 DO iflt=DIFF,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ DO ilag=beglag,endlag IF(dpeq(Arimap(ilag),DNOTST))THEN IF(lmdlfx)lmdlfx=F ELSE lmdlfx=lmdlfx.and.Arimaf(ilag) IF(Imdlfx.eq.0)Imdlfx=1 IF(Arimaf(ilag).and.Imdlfx.eq.1)Imdlfx=2 END IF END DO END DO END DO IF(lmdlfx.and.Imdlfx.gt.0)Imdlfx=3 c ------------------------------------------------------------------ RETURN END mdlinp.f0000664006604000003110000000202214521201531011611 0ustar sun00315stepsC Last change: BCM 10 Feb 1999 4:19 pm **==mdlinp.f processed by SPAG 4.03F at 15:51 on 14 Apr 1994 SUBROUTINE mdlinp(File,Inptok) IMPLICIT NONE c ----------------------------------------------------------------- CHARACTER File*(*) LOGICAL Inptok,ldmy,rngbuf EXTERNAL rngbuf c ----------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'error.cmn' c ----------------------------------------------------------------- CALL fopen(File,'model file for automatic model selection','OLD', & Inputx,Inptok) IF(.not.Inptok)RETURN REWIND(Inputx) Lineno=0 Lineln=0 ldmy=rngbuf(1,Lineno,Linex,Lineln) IF(.not.ldmy.or.Lfatal)RETURN Pos(PLINE)=0 Pos(PCHAR)=1 Lstpos(PLINE)=0 Lstpos(PCHAR)=1 Errpos(PLINE)=0 Errpos(PCHAR)=1 CALL lex() c ----------------------------------------------------------------- RETURN END mdlint.f0000664006604000003110000000217314521201531011624 0ustar sun00315steps SUBROUTINE mdlint() IMPLICIT NONE c----------------------------------------------------------------------- c Initialize the parameters and lag vectors. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ INTEGER PACM DOUBLE PRECISION ZERO PARAMETER(PACM=(PLEN+2*PORDER)*PARIMA,ZERO=0D0) c ------------------------------------------------------------------ CALL intlst(POPR,Opr,Nopr) CALL intlst(POPR,Oprptr,Noprtl) CALL setchr(' ',POPRCR*POPR,Oprttl) CALL intlst(PMDL,Mdl,Nmdl) Mdl(AR)=1 Mdl(MA)=1 CALL setlg(.false.,PARIMA,Arimaf) CALL setint(0,PARIMA,Arimal) CALL setdp(ZERO,PARIMA,Arimap) CALL setdp(ZERO,PACM,Armacm) Lndtcv=ZERO Mxarlg=0 Mxdflg=0 Mxmalg=0 Nseadf=0 Lseadf=.false. c----------------------------------------------------------------------- RETURN END mdlmch.f0000664006604000003110000000225414521201531011601 0ustar sun00315steps LOGICAL FUNCTION mdlmch(Nrar,Nrdiff,Nrma,Nsar,Nsdiff,Nsma,Bstrar, & Bstrdf,Bstrma,Bstsar,Bstsdf,Bstsma,Bstbic) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'notset.prm' c ------------------------------------------------------------------ DOUBLE PRECISION Bstbic INTEGER i,Nrar,Nrdiff,Nrma,Nsar,Nsdiff,Nsma,Bstrar,Bstrdf,Bstrma, & Bstsar,Bstsdf,Bstsma DIMENSION Bstrar(5),Bstrdf(5),Bstrma(5),Bstsar(5),Bstsdf(5), & Bstsma(5),Bstbic(5) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ mdlmch=.false. DO i=1,5 IF(dpeq(Bstbic(i),DNOTST))RETURN IF(Nrar.eq.Bstrar(i).and.Nrdiff.eq.Bstrdf(i).and. & Nrma.eq.Bstrma(i).and.Nsar.eq.Bstsar(i).and. & Nsdiff.eq.Bstsdf(i).and.Nsma.eq.Bstsma(i))THEN mdlmch=.true. RETURN END IF END DO c ------------------------------------------------------------------ RETURN END mdlset.f0000664006604000003110000002244414521201531011630 0ustar sun00315stepsC Last change: BCM 22 Feb 1999 3:02 pm SUBROUTINE mdlset(Nrar,Nrdiff,Nrma,Nsar,Nsdiff,Nsma,Locok) IMPLICIT NONE c----------------------------------------------------------------------- c INCLUDE 'lex.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' INCLUDE 'stdio.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER str*(POPRCR) LOGICAL arfix,argok,dffix,Locok,mafix INTEGER arlag,dflag,itmp,malag,MULT,naimcf,nchr,ndcoef,Nrar, & Nrdiff,Nrma,Nsar,Nsdiff,Nsma DOUBLE PRECISION arcoef,dfcoef,macoef PARAMETER(MULT=3) DIMENSION arcoef(PORDER),arfix(PORDER),arlag(PORDER), & dfcoef(PDIFOR),dffix(PDIFOR),dflag(PDIFOR), & macoef(PORDER),mafix(PORDER),malag(PORDER) c----------------------------------------------------------------------- c Get factors (AR DIFF MA)SP until the next name. c----------------------------------------------------------------------- Locok=T Nseadf=Nsdiff Nnsedf=Nrdiff naimcf=0 c----------------------------------------------------------------------- CALL mkmdsn(Nrar,Nrdiff,Nrma,Nsar,Nsdiff,Nsma,Mdldsn,Nmddcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c set up model operators based on values input... c nonseasonal AR c----------------------------------------------------------------------- IF(Nrar.gt.0)THEN CALL setopr(AR,arcoef,arlag,arfix,Nrar,itmp,naimcf,argok,Locok) IF(Lfatal)RETURN IF(Locok)THEN CALL iscrfn(MULT,1,arlag,Nrar,PORDER,arlag) CALL mkoprt(AR,1,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(AR,arcoef,arlag,arfix,Nrar,1, & str(1:nchr),argok,Locok) IF(Lfatal)RETURN CALL maxlag(Arimal,Opr,Mdl(AR-1),Mdl(AR)-1,Mxarlg) END IF END IF c----------------------------------------------------------------------- c nonseasonal differencing c----------------------------------------------------------------------- IF(Nrdiff.gt.0)THEN ndcoef=Nrdiff CALL setopr(DIFF,dfcoef,dflag,dffix,ndcoef,Nrdiff,naimcf,argok, & Locok) IF(Lfatal)RETURN IF(ndcoef.gt.PDIFOR)THEN CALL writln('ERROR: Order of the differencing operator is '// & 'too large.',STDERR,Mt2,T) Locok=F ELSE CALL iscrfn(MULT,1,dflag,ndcoef,PDIFOR,dflag) CALL mkoprt(DIFF,1,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(DIFF,dfcoef,dflag,dffix,ndcoef, & 1,str(1:nchr),argok,Locok) IF(Lfatal)RETURN END IF CALL maxlag(Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1,Mxdflg) END IF c----------------------------------------------------------------------- c nonseasonal MA c----------------------------------------------------------------------- IF(Nrma.gt.0)THEN CALL setopr(MA,macoef,malag,mafix,Nrma,itmp,naimcf,argok,Locok) IF(Lfatal)RETURN IF(Locok)THEN CALL iscrfn(MULT,1,malag,Nrma,PORDER,malag) CALL mkoprt(MA,1,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(MA,macoef,malag,mafix,Nrma,1, & str(1:nchr),argok,Locok) IF(Lfatal)RETURN CALL maxlag(Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,Mxmalg) END IF END IF c----------------------------------------------------------------------- c seasonal AR c----------------------------------------------------------------------- IF(Nsar.gt.0)THEN CALL setopr(AR,arcoef,arlag,arfix,Nsar,itmp,naimcf,argok,Locok) IF(Lfatal)RETURN IF(Locok)THEN CALL iscrfn(MULT,Sp,arlag,Nsar,PORDER,arlag) CALL mkoprt(AR,Sp,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(AR,arcoef,arlag,arfix,Nsar,Sp, & str(1:nchr),argok,Locok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check the of maximum lag of all the AR operators added so far c does not exceed the maximum order otherwise is will exceed temporary c storage in the filtering operations where the operators are c expanded/multiplied into just the coefficients of one full operator. c This is only going to be a problem for seasonal models. c----------------------------------------------------------------------- CALL maxlag(Arimal,Opr,Mdl(AR-1),Mdl(AR)-1,Mxarlg) IF(Mxarlg.gt.PORDER)THEN CALL writln('ERROR: Order of the AR operator is too large.', & STDERR,Mt2,T) Locok=F END IF END IF END IF c----------------------------------------------------------------------- c seasonal differencing c----------------------------------------------------------------------- IF(Nsdiff.gt.0)THEN ndcoef=Nsdiff CALL setopr(DIFF,dfcoef,dflag,dffix,ndcoef,Nsdiff,naimcf,argok, & Locok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check that we don't have a seasonal difference and a seasonal c effect variables or a U(B) operator. c----------------------------------------------------------------------- Lseadf=(Sp.gt.1).or.(Sp.eq.1.and.ndcoef.eq.Sp-1) IF(Lseadf.and.Lseff)THEN CALL writln('ERROR: Cannot have a seasonal difference with'// & ' seasonal regression effects.',STDERR,Mt2,T) Locok=F END IF c ------------------------------------------------------------------ IF(ndcoef.gt.PDIFOR)THEN CALL writln('ERROR: Order of the differencing operator is '// & 'too large.',STDERR,Mt2,T) Locok=F ELSE CALL iscrfn(MULT,Sp,dflag,ndcoef,PDIFOR,dflag) CALL mkoprt(DIFF,Sp,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(DIFF,dfcoef,dflag,dffix,ndcoef, & Sp,str(1:nchr),argok,Locok) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Check the maximum lag of all the differencing operators added c does not exceed the maximum order otherwise it will exceed c temporary storage in the filtering operations where the operators c are expanded/multiplied into the coefficients of one full c operator. This is only a problem for seasonal models. c----------------------------------------------------------------------- CALL maxlag(Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1,Mxdflg) IF(Mxdflg.gt.PDIFOR)THEN CALL writln('ERROR: Order of the full differencing operator '// & 'is too large.',STDERR,Mt2,T) Locok=F END IF END IF c----------------------------------------------------------------------- c seasonal MA c----------------------------------------------------------------------- IF(Nsma.gt.0)THEN CALL setopr(MA,macoef,malag,mafix,Nsma,itmp,naimcf,argok,Locok) IF(Lfatal)RETURN IF(Locok)THEN CALL iscrfn(MULT,Sp,malag,Nsma,PORDER,malag) CALL mkoprt(MA,Sp,Sp,str,nchr) IF(.not.Lfatal)CALL insopr(MA,macoef,malag,mafix,Nsma,Sp, & str(1:nchr),argok,Locok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check the maximum lag of all the MA operators added does not c exceed the maximum order otherwise it will exceed temporary storage c in the filtering operations where the operators are expanded/ c multiplied into one full operator. This is only going to be a problem c for seasonal models. c----------------------------------------------------------------------- CALL maxlag(Arimal,Opr,Mdl(MA-1),Mdl(MA)-1,Mxmalg) IF(Mxmalg.gt.PORDER)THEN CALL writln('ERROR: Order of the MA operator is too large.', & STDERR,Mt2,T) Locok=F END IF END IF END IF c----------------------------------------------------------------------- c Compute the number of effective observations and initialize |G'G| c----------------------------------------------------------------------- Lar=Lextar.and.Mxarlg.gt.0 Lma=Lextma.and.Mxmalg.gt.0 c ------------------------------------------------------------------ IF(Lextar)THEN Nintvl=Mxdflg Nextvl=Mxarlg+Mxmalg c ------------------------------------------------------------------ ELSE Nintvl=Mxdflg+Mxarlg c ------------------------------------------------------------------ Nextvl=0 IF(Lextma)Nextvl=Mxmalg END IF c----------------------------------------------------------------------- c We processed the last operator so start wrapping up. c Increment NMDL, indicating we have an ARIMA model. c----------------------------------------------------------------------- IF(Locok)Nmdl=Nmdl+1 c ------------------------------------------------------------------ RETURN END mdlsvl.i0000664006604000003110000000225314521201531011640 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for svltbl are of the form LSL c where the types are c----------------------------------------------------------------------- c aic tests ATS c automatic model selected AMD c AIC AIC c BIC BIC c Forecast error diagnostic AFC c----------------------------------------------------------------------- INTEGER LSLTRN,LSLAMD,LSLADF,LSLB5M,LSLMU,LSLFUR,LSLALA,LSLAMX, & LSLAIC,LSLACC,LSLBIC,LSLHQ,LSLEIC,LSLAFC,LSLRTS,LSLALE, & LSLTST,LSLCTS,LSLAOT,LSLNRM,LSLSAC,LSLLBQ,LSLSFT,LSLTFT, & LSLCDW,LSLCFR,LSLALC PARAMETER( & LSLTRN= 1,LSLAMD= 2,LSLADF= 3,LSLB5M= 4,LSLMU= 5, & LSLFUR= 6,LSLALA= 7,LSLAMX= 8,LSLAIC= 9,LSLACC= 10, & LSLBIC= 11,LSLHQ= 12,LSLEIC= 13,LSLAFC= 14,LSLRTS= 15, & LSLALE= 16,LSLTST= 17,LSLCTS= 18,LSLAOT= 19,LSLNRM= 20, & LSLSAC= 21,LSLLBQ= 22,LSLSFT= 24,LSLTFT= 25,LSLCDW= 26, & LSLCFR= 27,LSLALC= 28) mdltbl.i0000664006604000003110000001053114521201532011614 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c series SER c span SPN c transform TRN c regression REG c identification IDN or ID c arima ARM c automdl AU c estimate EST c outlier OTL c check CHK or CK c forecast FOR c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c header HD c span SP c plot of original series A1P c spec file IN c spectrum of original series S0 c files to be stored/saved SV c prior adjustment PA c prior adjusted series, untrans A3 c transformed series DT c trend of prior adjusted series A10 c regression matrix DT c regression aic test for td ATD c acf ACF c acf plot ACP c pacf PCF c pacf plot PCP c automatic model header HDR c automatic model test MDL c automatic model choice MCH c options OP c iterations IT c iteration errors IE c model MD c reg correlation matrix CM c estimates ES c arma corr matrix AM c statistics ST c formulae FM c arma roots RT c regression effects RE c model residuals RS c outlier header HD c outlier iterations IT c outlier t-tests TS c temporary ls tests TL c acf ACF c acf plot ACP c pacf PCF c pacf plot PCP c histogram HST c transformed scale TS # or tests c variances VR c original scale OS c----------------------------------------------------------------------- INTEGER LSRSHD,LSRSSP,LSRA1P,LSRSIN,LSRSSV,LSRSMV,LSRA18,LSRA19, & LSRSB1,LSRB1P,LTRSCN,LTRACP,LTRNPA,LTRA2P,LTRA2T,LTRNA3, & LTRA3P,LTRA4D,LTRA4P,LTRNDT,LTRAIC,LREGDT,LRGATS,LRGOTL, & LREGAO,LREGLC,LREGTC,LREGSO,LREGTD,LRGHOL,LRGUSR,LRGA10, & LRGA13,LRGCTS,LRGTDW,LIDACF,LIDACP,LIDPCF,LIDPCP,LIDRGC, & LAUHDR,LAUURT,LAUMCH,LAUURM,LAUMDL,LAUB5M,LAUOTH,LAUOTI, & LAUOTT,LAUOFT,LAUDFT,LAUFLB,LAUFNT,LAXHDR,LAXHDB,LAXMDL, & LAXMCH,LESTOP,LESTIT,LESTIE,LESTMD,LESTCM,LESTES,LESTAM, & LESTST,LESTFM,LESTRT,LESTRE,LESTRS,LESRRS,LESAFC,LOTLHD, & LOTLIT,LOTLTS,LOTLTL,LOTLFT,LCKACF,LCKPCF,LCKAC2,LCKHST, & LCKNRM,LCKDW,LCKFRT,LCKIPC,LFORTS,LFORVR,LFOROS,LFORTB, & LFORBC PARAMETER( & LSRSHD=1,LSRSSP=2,LSRA1P=3,LSRSIN=4,LSRSSV=5,LSRSMV=6, & LSRA18=7,LSRA19=8,LSRSB1=9,LSRB1P=10,LTRSCN=11, & LTRACP=12,LTRNPA=13,LTRA2P=14,LTRA2T=15,LTRNA3=16, & LTRA3P=17,LTRA4D=18,LTRA4P=19,LTRNDT=20,LTRAIC=21, & LREGDT=22,LRGATS=23,LRGOTL=24,LREGAO=25,LREGLC=26, & LREGTC=27,LREGSO=28,LREGTD=29,LRGHOL=30,LRGUSR=31, & LRGA10=32,LRGA13=33,LRGCTS=34,LRGTDW=35,LIDACF=36, & LIDACP=37,LIDPCF=38,LIDPCP=39,LIDRGC=40,LAUHDR=41, & LAUURT=42,LAUMCH=43,LAUURM=44,LAUMDL=45,LAUB5M=46, & LAUOTH=47,LAUOTI=48,LAUOTT=49,LAUOFT=50,LAUDFT=51, & LAUFLB=52,LAUFNT=53,LAXHDR=54,LAXHDB=55,LAXMDL=56, & LAXMCH=57,LESTOP=58,LESTIT=59,LESTIE=60,LESTMD=61, & LESTCM=62,LESTES=63,LESTAM=64,LESTST=65,LESTFM=66, & LESTRT=67,LESTRE=68,LESTRS=69,LESRRS=70,LESAFC=71, & LOTLHD=72,LOTLIT=73,LOTLTS=74,LOTLTL=75,LOTLFT=76, & LCKACF=77,LCKPCF=79,LCKAC2=81,LCKHST=83,LCKNRM=84, & LCKDW=85,LCKFRT=86,LCKIPC=87,LFORTS=88,LFORVR=89, & LFOROS=90,LFORTB=91,LFORBC=92) mdssln.f0000664006604000003110000000227214521201532011636 0ustar sun00315stepsC Last change: BCM 19 May 2003 2:28 pm INTEGER FUNCTION mdssln(Sp) IMPLICIT NONE c ------------------------------------------------------------------ c Function that returns length of sliding span based on the value of c the first order seasonal moving term in ARIMA model - from c Findley (2003) c ------------------------------------------------------------------ DOUBLE PRECISION getsma EXTERNAL getsma c ------------------------------------------------------------------ DOUBLE PRECISION sma,smalim INTEGER i,Sp DIMENSION smalim(15) c ------------------------------------------------------------------ DATA smalim /0.16D0,0.325D0,0.49D0,0.535D0,0.62D0,0.64D0,0.695D0, & 0.71D0,0.75D0,0.76D0,0.795D0,0.805D0,0.84D0,0.85D0, & 0.91D0/ c ------------------------------------------------------------------ sma=getsma() DO i=1,15 IF(sma.lt.smalim(i))THEN mdssln=(i+3)*Sp RETURN END IF END DO mdssln=19*Sp c ------------------------------------------------------------------ RETURN END meancra.f0000664006604000003110000000154314521201532011744 0ustar sun00315steps**==meancra.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 SUBROUTINE MEANCRA(A1x,Aty,Rtz,Modlid,Mq,Ny) IMPLICIT NONE **--MEANCRA5 C C*** Start of declarations rewritten by SPAG C C Dummy arguments C INTEGER Modlid,Mq,Ny REAL*8 A1x(*),Aty(*),Rtz(*) C C Local variables C INTEGER i,j,k REAL*8 tt C C*** End of declarations rewritten by SPAG C C ----------- ATY IS D11 c **** Start of Executable Program IF (Modlid.EQ.0) THEN DO i=1,Ny tt=A1x(i)/Aty(i)-1D0 k=Mq*(i-1) DO j=1,Mq Rtz(k+j)=tt END DO END DO ELSE DO i=1,Ny tt=A1x(i)-Aty(i) k=Mq*(i-1) DO j=1,Mq Rtz(k+j)=tt/Mq END DO END DO END IF END medabs.f0000664006604000003110000000601614521201532011571 0ustar sun00315stepsC Last change: BCM 26 Jan 98 1:12 pm SUBROUTINE medabs(S,Nr,Median) IMPLICIT NONE c----------------------------------------------------------------------- c Takes the median of the absolute values of x. Sorts them first c using a shell sort. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c abss d Work pa long nr used vector to hold the sorted absolute c values c midpt i Local mid point of the series c gap i Local distance between the records that are being compared. c gap starts out at half the number of records and is halved c until it reaches 1. c i i Local do loop c median d Output median of the absolute differences c nabss i Work PARAMETER for the length of abss c nr i Input row dimension of s c pa i Local PARAMETER for the maximum number of innovation errors c s d Input nr long vector to be sorted. c tmp d Local temporary scalar c----------------------------------------------------------------------- c Type the variables c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c ------------------------------------------------------------------ INTEGER midpt,i,Nr DOUBLE PRECISION abss,S,Median DIMENSION abss(PA),S(Nr) c----------------------------------------------------------------------- c Check that the work vector is large enough c----------------------------------------------------------------------- IF(PA.lt.Nr)THEN CALL errhdr WRITE(STDERR,1010)PA,Nr WRITE(Mt2,1010)PA,Nr 1010 FORMAT(/,' Work array too small',i6,' <',i6) CALL abend RETURN END IF c----------------------------------------------------------------------- c Make a vector of absolute values c----------------------------------------------------------------------- DO i=1,Nr abss(i)=abs(S(i)) END DO c----------------------------------------------------------------------- c Use a Shell sort the nr records of abss. Compares records half c the number of records apart, then keep halving the gap size until c records next to each other are compared. c----------------------------------------------------------------------- CALL shlsrt(Nr,abss) c ------------------------------------------------------------------ midpt=Nr/2 c ------------------------------------------------------------------ IF(mod(Nr,2).eq.0)THEN Median=(abss(midpt)+abss(midpt+1))/2D0 ELSE Median=abss(midpt+1) END IF c ------------------------------------------------------------------ RETURN END metadata.cmn0000664006604000003110000000111114521201532012435 0ustar sun00315stepsc----------------------------------------------------------------------- c common block for user defined metadata c----------------------------------------------------------------------- CHARACTER Keystr*(PLMETA),Valstr*(PLMETA) LOGICAL Hvmtdt INTEGER Keyptr,Nkey,Valptr,Nval DIMENSION Keyptr(0:PMTDAT),Valptr(0:PMTDAT) c----------------------------------------------------------------------- COMMON /cmtdat/ Keyptr,Nkey,Valptr,Nval,Hvmtdt COMMON /cmtdic/ Keystr,Valstr c----------------------------------------------------------------------- metadata.prm0000664006604000003110000000071214521201532012464 0ustar sun00315stepsc----------------------------------------------------------------------- c parameters for user defined metadata c----------------------------------------------------------------------- c PMTDAT - maximum number of metadata values c PLMETA - maximum length of characters in metadata data dictionary c----------------------------------------------------------------------- INTEGER PMTDAT,PLMETA PARAMETER(PMTDAT=20,PLMETA=2000) mflag.f0000664006604000003110000001046414521201532011426 0ustar sun00315stepsC Last change: BCM 26 Feb 1999 3:41 pm **==mflag.f processed by SPAG 4.03F at 12:23 on 21 Jun 1994 SUBROUTINE mflag(X,Iopt,Iop2,Km,Dmax,Ncol,Ssdiff) IMPLICIT NONE c----------------------------------------------------------------------- C ***** THIS SUBROUTINE CONTROLS THE FLAGGING OF INDIVIDUAL MONTHS C ***** FOR A GIVEN SET OF SEASONALLY ADJUSTED ESTIMATES. IN C ***** ADDITION, THE VALUES FOR THE SLIDING SPANS HISTOGRAM (KOUNT) C ***** ARE GENERATED HERE. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'notset.prm' INCLUDE 'ssap.cmn' INCLUDE 'sspvec.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c----------------------------------------------------------------------- LOGICAL Ssdiff DOUBLE PRECISION Dmax,X INTEGER i,Iop2,Iopt,j,k,Km,t2,numyr,numpr,Ncol DIMENSION X(MXLEN,MXCOL),Dmax(MXLEN,NEST),numyr(MXYR),numpr(PSP) c----------------------------------------------------------------------- c Initialize counter variables c----------------------------------------------------------------------- Ntot(Iopt)=0 Chsgn(Iopt)=0 c Iscf(Iopt)=0 Iturn(Iopt)=0 c Itf(Iopt)=0 DO j=1,MXYR SSnyr(j,Iopt)=0 Ayr(j,Iopt)=ZERO Ayrmx(Iopt)=ZERO numyr(j)=0 END DO DO j=1,PSP SSnobs(j,Iopt)=0 Aobs(j,Iopt)=ZERO Aobsmx(Iopt)=ZERO numpr(j)=0 END DO DO k=1,4 Kount(Iopt,k)=0 END DO c----------------------------------------------------------------------- c Set up character flags for each observation in sliding spans c----------------------------------------------------------------------- DO i=1,Sslen+Im-1 Per(i,Iopt)=0 Csign(i,Iopt)=0 Cturn(i,Iopt)=0 c----------------------------------------------------------------------- c If observation is common to less than two spans, set the c maximum percent difference to null c----------------------------------------------------------------------- IF(i.le.Km.or.i.ge.Sslen2)THEN Dmax(i,Iopt)=DNOTST ELSE c----------------------------------------------------------------------- c Else, check if observation is flagged as extreme, has a turning c point or a change of sign. c----------------------------------------------------------------------- CALL rplus(X,i,Iopt,Iop2,Dmax(i,Iopt),numyr,numpr,Ncol,Ssdiff) END IF END DO c----------------------------------------------------------------------- c Set histogram counts. c----------------------------------------------------------------------- IF(.not.Ssdiff)THEN DO k=1,3 Kount(Iopt,k)=Kount(Iopt,k)-Kount(Iopt,(k+1)) END DO END IF c----------------------------------------------------------------------- c Set time index c----------------------------------------------------------------------- t2=(Sslen2-2)/Nsea c----------------------------------------------------------------------- C ***** COMPUTE MONTHLY (AOBS) AND YEARLY (AYR) AVERAGES OF THE C ***** MAXIMUM PERCENTAGE DIFFERENCE. c----------------------------------------------------------------------- DO j=1,t2 IF(numyr(j).eq.0)THEN Ayr(j,Iopt)=ZERO ELSE Ayr(j,Iopt)=Ayr(j,Iopt)/numyr(j) IF(Ayr(j,Iopt).gt.Ayrmx(Iopt))Ayrmx(Iopt)=Ayr(j,Iopt) END IF END DO DO j=1,Nsea Aobs(j,Iopt)=Aobs(j,Iopt)/numpr(j) IF(Aobs(j,Iopt).gt.Aobsmx(Iopt))Aobsmx(Iopt)=Aobs(j,Iopt) END DO c----------------------------------------------------------------------- c Count number of sign changes, turning points in unstable months. c Commented out by BCM Jan-1998 c----------------------------------------------------------------------- c j1=Nsea+1 c IF(Iop2.eq.3)j1=j1+Nsea c DO j=j1,Sslen2 c IF(Per(j,Iopt).ne.' '.and.Csign(j,Iopt).eq.'*'.and.Iopt.ne.3) c & Iscf(Iopt)=Iscf(Iopt)+1 c & Itf(Iopt)=Itf(Iopt)+1 c END DO c----------------------------------------------------------------------- RETURN END min.i0000664006604000003110000000016414521201532011122 0ustar sun00315stepsC C... Variables in Common Block /min/ ... real*8 START,STEP,DSTOP common /cmin/ START,STEP,DSTOP minim2.f0000664006604000003110000000266714521201532011541 0ustar sun00315stepsC C GRID SEARCH MINIMISATION OF A FUNCTION IN ONE DIMENSION C C ALSO REQUIRED IS THE FUNCTION SUBPROGRAM WHICH DEFINES THE FUNCTION C FUNC0(X) TO BE MINIMISED C C INPUT PARAMETER : C FMIN : THE MINIMUM OF THE FUNCTION C XMIN : THE POINT AT WHICH IT OCCURS C C C subroutine MINIM2(fmin,xmin) C This subroutine will computes minima by searching over a grid C Written by Donald Martin, July 2002 C ------------------------------------------------------------------- C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Not Read, Overwritten .. double precision fmin C.. In/Out Status: Not Read, Overwritten .. integer xmin C.. In/Out Status: Not Read, Overwritten .. C C.. Local vector.. double precision fx(0:100000), pi, freq(0:100000) integer i C C.. External Functions .. double precision FUNC0 external FUNC0 C C.. Intrinsic Functions .. * include 'min.i' C --------------------------------------------------------------------------- C C ... Executable Statements ... C C C STEP 1: SET UP STARTING VALUES C pi = 3.14159265358979D0 C fmin=120.0D0 xmin=-1 do 10 i=0,100000 freq(i)=(1.0D0/100000.0d0)*dble(i)*pi fx(i)=FUNC0(freq(i)) c write(6,11) fx(i) if (fmin .gt. fx(i)) then fmin=fx(i) xmin=i end if 10 continue 11 format(1x, f20.6) return end missng.cmn0000664006604000003110000000150014521201532012157 0ustar sun00315stepsc----------------------------------------------------------------------- c Missng - Logical variable which indicates if a missing value has c been found in the series c Misind - Logical vector of length PLEN which indicates if c observation t is a missing value c----------------------------------------------------------------------- LOGICAL Missng c----------------------------------------------------------------------- c Mvcode - code for missing values (default -99999D0) c Mvval - replacement value for missing values (default 1000000000) c---------------------------------------------------------------------- DOUBLE PRECISION Mvcode,Mvval c---------------------------------------------------------------------- COMMON /missvl/ Mvcode,Mvval,Missng mkback.f0000664006604000003110000004043214521201533011567 0ustar sun00315stepsC Last change: BCM 29 Sep 97 10:13 am SUBROUTINE mkback(Trnsrs,Priadj,Bcst,Ubcst,Pos2,Outdec,Lgraf) IMPLICIT NONE c ------------------------------------------------------------------ c Generate Backcasts c Added November 2006 - print and save tables of backcasts c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'x11log.cmn' INCLUDE 'extend.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'adj.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'priusr.cmn' INCLUDE 'error.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'savcmn.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'stdio.i' INCLUDE 'cchars.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL F,T INTEGER BTWNCL,DIV,INCOL,MNSGFG,ADD,MULT,SUB DOUBLE PRECISION ZERO,ONE,TWO PARAMETER(F=.false.,T=.true.,ADD=1,SUB=2,MULT=3,DIV=4,BTWNCL=3, & INCOL=2,MNSGFG=3,ZERO=0D0,ONE=1D0,TWO=2D0) c ------------------------------------------------------------------ CHARACTER blnk*80,fmt*80,ttlfct*80,ttlfc2*100,str*10,outstr*75, & dash*(22) LOGICAL Lgraf,ltrns,lpria,lprix,locok INTEGER Priadj,fctori,frstry,i,Pos2,ff,endbak,ndtchr, & Outdec,ndec,rdbdat,npos,fh,fh2,nttlcr,ntl2cr,mindec,idate, & tmp1,tmp2,clwdth,mxdtcr DOUBLE PRECISION rgvar,fcstse,Trnsrs,Bcst,Ubcst,bkxy,pval,nstder, & lwrci,uprci,revfse DIMENSION Bcst(PFCST),Ubcst(PFCST),rgvar(PFCST),fcstse(PFCST), & Trnsrs(PLEN),endbak(2),lwrci(PFCST),uprci(PFCST), & bkxy(PLEN*(PB+1)),idate(2),revfse(PFCST) c----------------------------------------------------------------------- DOUBLE PRECISION dinvnr LOGICAL chkcvr,dpeq EXTERNAL chkcvr,dinvnr,dpeq c----------------------------------------------------------------------- DATA dash /'----------------------'/ DATA blnk/ &' & '/ c----------------------------------------------------------------------- c Generate backcasts c----------------------------------------------------------------------- locok=T CALL regvar(Trnsrs,Nspobs,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Elong) IF(Lfatal)RETURN fctori=Nspobs CALL copy(Xy,Nrxy*Ncxy,1,bkxy) CALL revrse(bkxy,Nrxy-Nfcst,Ncxy,Xy) CALL fcstxy(fctori,Nbcst,Bcst,fcstse,rgvar) IF(Lfatal)RETURN c----------------------------------------------------------------------- CALL copy(bkxy,Nrxy*Ncxy,1,Xy) c CALL revrse(Xy,Nrxy-Nfcst,Ncxy,Xy) c----------------------------------------------------------------------- c Create versions of the backcasts that are on the original scale c----------------------------------------------------------------------- ff=ADD IF(Adjmod.lt.2)ff=MULT DO i=1,Nbcst Ubcst(Nbcst-i+1)=Bcst(i) END DO c----------------------------------------------------------------------- IF(Lognrm.and.dpeq(Lam,ZERO))CALL lgnrmc(Nbcst,Bcst,fcstse,Bcst,F) c----------------------------------------------------------------------- CALL wrtdat(Begbak,Sp,str,ndtchr) IF(Lfatal)RETURN mxdtcr=max(4,ndtchr) IF(.not.Lhiddn.and.(Prttab(LFORBC).or.Prttab(LFORTB))) & WRITE(Mt1,1010)str(1:ndtchr),Nbcst 1010 FORMAT(//,' BACKCASTING',/,' Origin',a10,/,' Number',i10) c----------------------------------------------------------------------- c Format the transformed backcasts and their standard errors c----------------------------------------------------------------------- CALL numfmt(Ubcst,Nbcst,Outdec,clwdth,mindec) mindec=mindec+MNSGFG-1 c----------------------------------------------------------------------- IF(mindec.gt.Outdec)THEN ndec=min(mindec,11) clwdth=clwdth-Outdec+ndec ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 clwdth=min(max(clwdth,8),21) c----------------------------------------------------------------------- ltrns=(.not.dpeq(Lam,ONE)).or.Fcntyp.ne.4 lpria=(Nustad.gt.0.and.chkcvr(Bgutad,Nustad,Begbak,Nbcst,Sp)).or. & (Nuspad.gt.0.and.chkcvr(Bgupad,Nuspad,Begbak,Nbcst,Sp)).or. & (Priadj.gt.0.and.chkcvr(Begadj,Nadj,Begbak,Nbcst,Sp)) lprix=(Axrghl.or.Axrgtd.and.Ixreg.eq.3).or.Khol.eq.2.or.Kswv.eq.1 c----------------------------------------------------------------------- IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN IF(Prttab(LFORBC))THEN IF((lpria.or.lprix).and.ltrns)THEN WRITE(Mt1,1020) &'Backcasts and Standard Errors of the Prior Adjusted and Transform &ed Data' ELSE IF(ltrns)THEN WRITE(Mt1,1020) & 'Backcasts and Standard Errors of the Transformed Data' ELSE IF(lpria)THEN WRITE(Mt1,1020) & 'Backcasts and Standard Errors of the Prior Adjusted Data' ELSE WRITE(Mt1,1020)'Backcasts and Standard Errors' END IF END IF 1020 FORMAT(/,' ',a) c----------------------------------------------------------------------- IF(Savtab(LFORTB).OR.(Lgraf.and.ltrns))THEN IF(Savtab(LFORTB))CALL opnfil(T,F,LFORTB,fh,locok) IF((Lgraf.and.ltrns).and.locok) & CALL opnfil(T,Lgraf,LFORTB,fh2,locok) IF(.not.locok)THEN CALL abend() RETURN END IF IF(Savtab(LFORTB))THEN WRITE(fh,1030)'date',TABCHR,'backcast',TABCHR,'standarderror' WRITE(fh,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize) END IF IF(Lgraf.and.ltrns)THEN WRITE(fh2,1030)'date',TABCHR,'backcast',TABCHR, & 'standarderror' WRITE(fh2,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize) END IF 1030 FORMAT(a:,a,a,a,a:,a,a) END IF c----------------------------------------------------------------------- IF(Prttab(LFORTB))THEN WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+INCOL+2*clwdth+1) 1040 FORMAT(' ',77(a)) WRITE(Mt1,1050)blnk(1:mxdtcr+BTWNCL+INCOL+2*clwdth-6), & blnk(1:mxdtcr-3),blnk(1:BTWNCL+clwdth-8), & blnk(1:INCOL+clwdth+1-5) 1050 FORMAT(' ',a,'Standard',/,' ',a,'Date',a,'Backcast',a, & 'Error') WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+INCOL+2*clwdth+1) c ------------------------------------------------------------------ WRITE(fmt,1060)mxdtcr+3,BTWNCL+clwdth,ndec,INCOL+clwdth+1, & ndec+1 1060 FORMAT('(a',i2.2,',f',i2.2,'.',i2.2,',f',i2.2,'.',i2.2,')') END IF c ------------------------------------------------------------------ DO i=1,Nbcst CALL addate(Begbak,Sp,i-1,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Prttab(LFORTB)) & WRITE(Mt1,fmt)str(1:ndtchr),Ubcst(i),fcstse(Nbcst-i+1) c ------------------------------------------------------------------ IF(Savtab(LFORTB).OR.(Lgraf.and.ltrns))THEN npos=1 rdbdat=100*idate(YR)+idate(MO) c ------------------------------------------------------------------ CALL itoc(rdbdat,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(Ubcst(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(fcstse(Nbcst-i+1),outstr,npos) IF(Lfatal)RETURN IF(Savtab(LFORTB))WRITE(fh,1030)outstr(1:npos-1) IF(Lgraf.and.ltrns)WRITE(fh2,1030)outstr(1:npos-1) END IF END DO c ------------------------------------------------------------------ IF(Prttab(LFORTB)) & WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+INCOL+2*clwdth+1) IF(Savtab(LFORTS).and.locok)CALL fclose(fh) IF(Lgraf.and.ltrns.and.locok)CALL fclose(fh2) END IF c----------------------------------------------------------------------- IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN pval=(Ciprob+ONE)/TWO nstder=dinvnr(pval,ONE-pval) DO i=1,Nbcst revfse(i)=fcstse(Nbcst-i+1) END DO CALL scrmlt(nstder,Nbcst,revfse) CALL eltfcn(SUB,Ubcst,revfse,Nbcst,PFCST,lwrci) CALL eltfcn(ADD,Ubcst,revfse,Nbcst,PFCST,uprci) END IF c----------------------------------------------------------------------- IF(ltrns)THEN IF(Lognrm.and.dpeq(Lam,ZERO))THEN CALL lgnrmc(Nbcst,Ubcst,revfse,Ubcst,T) ELSE CALL invfcn(Ubcst,Nbcst,Fcntyp,Lam,Ubcst) END IF IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN CALL invfcn(lwrci,Nbcst,Fcntyp,Lam,lwrci) CALL invfcn(uprci,Nbcst,Fcntyp,Lam,uprci) END IF END IF IF(lpria)THEN CALL eltfcn(ff,Ubcst,Adj(Adj1st-Nbcst),Nbcst,PFCST,Ubcst) IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN CALL eltfcn(ff,lwrci,Adj(Adj1st-Nbcst),Nbcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Adj(Adj1st-Nbcst),Nbcst,PFCST,uprci) END IF END IF IF(Khol.eq.2)THEN CALL eltfcn(ff,Ubcst,X11hol(Pos2),Nbcst,PFCST,Ubcst) IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN CALL eltfcn(ff,lwrci,X11hol(Pos2),Nbcst,PFCST,lwrci) CALL eltfcn(ff,uprci,X11hol(Pos2),Nbcst,PFCST,uprci) END IF END IF IF(Axrghl.and.Ixreg.eq.3)THEN CALL eltfcn(ff,Ubcst,Facxhl(Pos2),Nbcst,PFCST,Ubcst) IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN CALL eltfcn(ff,lwrci,Facxhl(Pos2),Nbcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Facxhl(Pos2),Nbcst,PFCST,uprci) END IF END IF IF(Kswv.eq.1.or.(Axrgtd.and.Ixreg.eq.3))THEN CALL eltfcn(ff,Ubcst,Stptd(Pos2),Nbcst,PFCST,Ubcst) IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN CALL eltfcn(ff,lwrci,Stptd(Pos2),Nbcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Stptd(Pos2),Nbcst,PFCST,uprci) END IF END IF c----------------------------------------------------------------------- IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN ttlfct='Confidence intervals with coverage probability (' nttlcr=48 ntl2cr=0 IF(Prttab(LFORBC))WRITE(ttlfct(nttlcr+1:),1110)Ciprob 1110 FORMAT(f8.5,')') IF(Savtab(LFORBC))CALL opnfil(T,F,LFORBC,fh,locok) IF(Lgraf.and.locok)CALL opnfil(T,Lgraf,LFORBC,fh2,locok) IF(.not.locok)THEN CALL abend() RETURN END IF nttlcr=nttlcr+8 c ------------------------------------------------------------------ IF(ltrns)THEN ttlfc2='On the Original Scale' ntl2cr=21 END IF c----------------------------------------------------------------------- IF(Nustad.gt.0.or.Nuspad.gt.0.or.Priadj.gt.1)THEN IF(lpria)THEN IF(ltrns)THEN ttlfc2=ttlfc2(1:ntl2cr)//' Before Prior Adjustments' ntl2cr=ntl2cr+25 ELSE ttlfc2='Before Prior Adjustments' ntl2cr=24 END IF c ------------------------------------------------------------------ ELSE IF(ltrns)THEN ttlfc2=ttlfc2(1:ntl2cr)//' After Prior Adjustments' ntl2cr=ntl2cr+25 ELSE ttlfc2='After Prior Adjustments' ntl2cr=23 END IF IF(Prttab(LFORBC).or.Savtab(LFORBC).or.Lgraf)THEN IF(.not.Lquiet)WRITE(STDERR,1120) CALL errhdr WRITE(Mt2,1120) END IF 1120 FORMAT(/, & ' WARNING: User-defined prior adjustment factor not provided' & ,/,' for the backcast period.',/) END IF ELSE IF(lprix)THEN IF(ltrns)THEN ttlfc2=ttlfc2(1:ntl2cr)//' Before Prior Adjustments' ntl2cr=ntl2cr+25 ELSE ttlfc2='Before Prior Adjustments' ntl2cr=24 END IF END IF c----------------------------------------------------------------------- CALL numfmt(lwrci,Nbcst,Outdec,tmp1,tmp2) CALL numfmt(uprci,Nbcst,Outdec,clwdth,mindec) clwdth=max(tmp1,clwdth) mindec=max(tmp2,mindec)+MNSGFG-1 IF(mindec.gt.Outdec)THEN ndec=min(mindec,11) clwdth=clwdth-Outdec+ndec ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 clwdth=min(max(clwdth,8),21) c ------------------------------------------------------------------ IF(Prttab(LFORBC))THEN WRITE(Mt1,1020)ttlfct(1:nttlcr) IF(ntl2cr.gt.0)THEN WRITE(Mt1,1130)ttlfc2(1:ntl2cr) 1130 FORMAT(' ',a) END IF IF(Lognrm.and.dpeq(Lam,ZERO)) & WRITE(Mt1,1130)'with LogNormal correction' c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL-INCOL+3*(INCOL+clwdth)) c ------------------------------------------------------------------ WRITE(Mt1,1140)blnk(1:mxdtcr-3),blnk(1:BTWNCL+clwdth-5), & blnk(1:INCOL+clwdth-8),blnk(1:INCOL+clwdth-5) 1140 FORMAT(' ',a,'Date',a,'Lower',a,'Backcast',a,'Upper') c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL-INCOL+3*(INCOL+clwdth)) c ------------------------------------------------------------------ WRITE(fmt,1150)mxdtcr+3,BTWNCL+clwdth,ndec,INCOL+clwdth,ndec 1150 FORMAT('(a',i2.2,',f',i2.2,'.',i2.2,',2f',i2.2,'.',i2.2,')') END IF c ------------------------------------------------------------------ IF(Savtab(LFORBC))THEN WRITE(fh,1030)'date',TABCHR,'backcast',TABCHR,'lowerci',TABCHR, & 'upperci' WRITE(fh,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize),TABCHR,dash(1:Svsize) END IF IF(Lgraf)THEN WRITE(fh2,1030)'date',TABCHR,'backcast',TABCHR,'lowerci',TABCHR, & 'upperci' WRITE(fh2,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize),TABCHR,dash(1:Svsize) END IF c ------------------------------------------------------------------ DO i=1,Nbcst CALL addate(Begbak,Sp,i-1,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN IF(Prttab(LFORBC))WRITE(Mt1,fmt)str(1:ndtchr),lwrci(i),Ubcst(i), & uprci(i) IF(Savtab(LFORBC).or.Lgraf)THEN npos=1 rdbdat=100*idate(YR)+idate(MO) c ------------------------------------------------------------------ CALL itoc(rdbdat,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(Ubcst(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(lwrci(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(uprci(i),outstr,npos) IF(Lfatal)RETURN IF(Savtab(LFORBC))WRITE(fh,1030)outstr(1:npos-1) IF(Lgraf)WRITE(fh2,1030)outstr(1:npos-1) END IF c ------------------------------------------------------------------ END DO c ------------------------------------------------------------------ IF(Prttab(LFORBC)) & WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL-INCOL+3*(INCOL+clwdth)) c ------------------------------------------------------------------ IF(Savtab(LFORBC).and.locok)CALL fclose(fh) IF(Lgraf.and.locok)CALL fclose(fh2) c ------------------------------------------------------------------ END IF c----------------------------------------------------------------------- RETURN END mkealb.f0000664006604000003110000000263714521201533011577 0ustar sun00315steps SUBROUTINE mkealb(Eastr,Neachr,Eastst,Easidx,Easwin,Lbase) IMPLICIT NONE c ------------------------------------------------------------------ c Generate string for label of easter effect within AIC test c for trading day c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER Eastr*(30),cwin*2 INTEGER Eastst,Easidx,Easwin,Neachr,nwin LOGICAL Lbase c----------------------------------------------------------------------- CALL setchr(' ',30,eastr) IF(Easidx.eq.0)THEN IF(Eastst.eq.1)THEN eastr(1:7)='easter[' Neachr=7 ELSE eastr(1:12)='easterstock[' Neachr=12 END IF ELSE eastr(1:14)='statcaneaster[' Neachr=14 END IF c----------------------------------------------------------------------- nwin=1 CALL setchr(' ',2,cwin) CALL itoc(Easwin,cwin,nwin) IF(Lfatal)RETURN eastr((Neachr+1):(Neachr+nwin))=cwin(1:(nwin-1))//']' c----------------------------------------------------------------------- IF(Lbase)THEN Neachr=Neachr-1 ELSE Neachr=Neachr+nwin END IF c----------------------------------------------------------------------- RETURN ENDmkfreq.f0000664006604000003110000001076014521201533011625 0ustar sun00315stepsC Last change: BCM 29 Feb 2008 9:46 am * SUBROUTINE mkfreq(Ny,Peakwd,Lfqalt,Lprsfq) SUBROUTINE mkfreq(Peakwd,Lfqalt,Lprsfq) IMPLICIT NONE c----------------------------------------------------------------------- C Generate two sets of frequencies to generate the spectral c estimates - one to determine peaks (Frqpk), the other to provide c frequencies for the line printer spectral plots (Frq) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'spcidx.cmn' c----------------------------------------------------------------------- LOGICAL Lfqalt,Lprsfq * INTEGER Ny,Peakwd,i,i2 INTEGER Peakwd,i,i2 c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c Generate base frequencies over which the spectrum will be computed c----------------------------------------------------------------------- DO i=1,61 Frq(i)=dble(i-1)/120D0 END DO c----------------------------------------------------------------------- c Create set of frequencies to be used to find spectral peaks. c----------------------------------------------------------------------- c Initialize frequencies to DNOTST c----------------------------------------------------------------------- CALL setdp(DNOTST,76,Frqpk) c----------------------------------------------------------------------- c Insert trading day peak, upper and lower limits into Frqpk c----------------------------------------------------------------------- DO i=1,nTfreq Frqpk(Tpeak(i)) = Tfreq(i) Frqpk(Tlow(i)) = Tfreq(i) - dble(Peakwd)*Frq(2) Frqpk(Tup(i)) = Tfreq(i) + dble(Peakwd)*Frq(2) END DO c----------------------------------------------------------------------- c Insert Seasonal Frequencies into Frqpk c----------------------------------------------------------------------- i2=1 DO i=1,nFreq IF(dpeq(Frqpk(i),DNOTST))THEN Frqpk(i)=Frq(i2) i2=i2+1 END IF END DO c----------------------------------------------------------------------- c Create set of frequencies to be plotted. c----------------------------------------------------------------------- c Include frequencies for trading day peak limits, except where they c would overwrite seasonal frequencies. c----------------------------------------------------------------------- IF(.not.Lprsfq)THEN * IF(Ny.eq.12)THEN IF(Lfqalt)THEN Frq(37-Peakwd)=.3036D0-Frq(2)*dble(Peakwd) Frq(37)=.3036D0 IF(Peakwd.lt.4)Frq(37+Peakwd)=.3036D0+Frq(2)*dble(Peakwd) END IF c----------------------------------------------------------------------- IF(Peakwd.ne.2)Frq(43-Peakwd)=.3482D0-Frq(2)*dble(Peakwd) Frq(43)=.3482D0 Frq(43+Peakwd)=.3482D0+Frq(2)*dble(Peakwd) c----------------------------------------------------------------------- IF(Peakwd.ne.2)Frq(53-Peakwd)=.432D0-Frq(2)*dble(Peakwd) Frq(53)=.432D0 Frq(53+Peakwd)=.432D0+Frq(2)*dble(Peakwd) c----------------------------------------------------------------------- * ELSE * IF(Lfqalt)THEN * Frq(36-Peakwd)=.294375D0-Frq(2)*dble(Peakwd) * Frq(36)=.294375D0 * Frq(36+Peakwd)=.294375D0+Frq(2)*dble(Peakwd) *c----------------------------------------------------------------------- * Frq(42-Peakwd)=.33875D0-Frq(2)*dble(Peakwd) * Frq(42)=.33875D0 * Frq(42+Peakwd)=.33875D0+Frq(2)*dble(Peakwd) *c----------------------------------------------------------------------- * Frq(47-Peakwd)=.383125D0-Frq(2)*dble(Peakwd) * Frq(47)=.383125D0 * Frq(47+Peakwd)=.383125D0+Frq(2)*dble(Peakwd) * END IF *c----------------------------------------------------------------------- * Frq(6-Peakwd)=.0446D0-Frq(2)*dble(Peakwd) * Frq(6)=.0446D0 * Frq(6+Peakwd)=.0446D0+Frq(2)*dble(Peakwd) *c----------------------------------------------------------------------- * Frq(12-Peakwd)=.0893D0-Frq(2)*dble(Peakwd) * Frq(12)=.0893D0 * Frq(12+Peakwd)=.0893D0+Frq(2)*dble(Peakwd) * END IF END IF c----------------------------------------------------------------------- RETURN ENDmklnlb.f0000664006604000003110000000457414521201533011625 0ustar sun00315steps SUBROUTINE mklnlb(Lnstr,Nlnchr,Lnabb,Nlnabb,Lomtst,Aicrgm,Lnzero, & Sp) IMPLICIT NONE c ------------------------------------------------------------------ c Generate string for label of lom/loq/lpyear effect within AIC test c for lom/loq/lpyear regressors (BCM March 2008) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER Lnstr*(30),Lnabb*(6),datstr*(10) INTEGER Lomtst,Aicrgm,Nlnchr,Nlnabb,nchdat,Lnzero,Sp DIMENSION Aicrgm(2) c----------------------------------------------------------------------- c Initialize Lnstr with blanks c----------------------------------------------------------------------- CALL setchr(' ',30,Lnstr) CALL setchr(' ',6,Lnabb) c----------------------------------------------------------------------- c Set base of Lnstr c----------------------------------------------------------------------- IF(Lomtst.eq.1)THEN Nlnchr=3 Lnstr(1:Nlnchr)='lom' ELSE IF(Lomtst.eq.2)THEN Nlnchr=3 Lnstr(1:Nlnchr)='loq' ELSE IF(Lomtst.eq.3)THEN Nlnchr=6 Lnstr(1:Nlnchr)='lpyear' END IF c----------------------------------------------------------------------- Lnabb(1:Nlnchr)=Lnstr(1:Nlnchr) Nlnabb=Nlnchr c----------------------------------------------------------------------- c Add change of regime date, if necessary c----------------------------------------------------------------------- IF(Aicrgm(1).ne.NOTSET)THEN CALL wrtdat(Aicrgm,Sp,datstr,nchdat) IF(Lfatal)RETURN IF(Lnzero.eq.0)THEN Lnstr((Nlnchr+1):(Nlnchr+nchdat+2))='/'//datstr(1:nchdat)//'/' Nlnchr=Nlnchr+nchdat+2 ELSE IF(Lnzero.eq.1)THEN Lnstr((Nlnchr+1):(Nlnchr+nchdat+3))='/'//datstr(1:nchdat)//'//' Nlnchr=Nlnchr+nchdat+3 ELSE IF(Lnzero.eq.2)THEN Lnstr((Nlnchr+1):(Nlnchr+nchdat+4))='//'//datstr(1:nchdat)//'//' Nlnchr=Nlnchr+nchdat+4 ELSE Lnstr((Nlnchr+1):(Nlnchr+nchdat+3))='//'//datstr(1:nchdat)//'/' Nlnchr=Nlnchr+nchdat+3 END IF END IF c----------------------------------------------------------------------- RETURN END mkmdsn.f0000664006604000003110000000273514521201533011634 0ustar sun00315steps SUBROUTINE mkmdsn(Nrar,Nrdiff,Nrma,Nsar,Nsdiff,Nsma,Mdldsn,Nmddcr) IMPLICIT NONE c----------------------------------------------------------------------- c Set up model description text c----------------------------------------------------------------------- INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER Mdldsn*(132) INTEGER Nrar,Nrdiff,Nrma,Nsar,Nsdiff,Nsma,Nmddcr c----------------------------------------------------------------------- Mdldsn(1:1)="(" Nmddcr=2 CALL itoc(Nrar,Mdldsn,Nmddcr) IF(Lfatal)RETURN Mdldsn(Nmddcr:Nmddcr)=" " Nmddcr=Nmddcr+1 CALL itoc(Nrdiff,Mdldsn,Nmddcr) IF(Lfatal)RETURN Mdldsn(Nmddcr:Nmddcr)=" " Nmddcr=Nmddcr+1 CALL itoc(Nrma,Mdldsn,Nmddcr) IF(Lfatal)RETURN Mdldsn(Nmddcr:Nmddcr)=")" IF(Nsar.gt.0.or.Nsma.gt.0.or.Nsdiff.gt.0)THEN Nmddcr=Nmddcr+1 Mdldsn(Nmddcr:Nmddcr)="(" Nmddcr=Nmddcr+1 CALL itoc(Nsar,Mdldsn,Nmddcr) IF(Lfatal)RETURN Mdldsn(Nmddcr:Nmddcr)=" " Nmddcr=Nmddcr+1 CALL itoc(Nsdiff,Mdldsn,Nmddcr) IF(Lfatal)RETURN Mdldsn(Nmddcr:Nmddcr)=" " Nmddcr=Nmddcr+1 CALL itoc(Nsma,Mdldsn,Nmddcr) IF(Lfatal)RETURN Mdldsn(Nmddcr:Nmddcr)=")" END IF c ------------------------------------------------------------------ RETURN END mkmdsx.f0000664006604000003110000000135314521201533011641 0ustar sun00315stepsC Last change: BCM 4 Mar 2008 3:46 pm DOUBLE PRECISION FUNCTION mkmdsx(Sxx,Nfreq,Ldecbl) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Nfreq,n1 DOUBLE PRECISION Sxx LOGICAL Ldecbl DIMENSION Sxx(*) c----------------------------------------------------------------------- IF(mod(Nfreq,2).eq.0)THEN n1=Nfreq/2 IF(Ldecbl)THEN mkmdsx=(Sxx(n1)+Sxx(n1+1))/2D0 ELSE mkmdsx=10D0**((log10(Sxx(n1))+log10(Sxx(n1+1)))/2D0) END IF ELSE n1=(Nfreq+1)/2 mkmdsx=Sxx(n1) END IF c----------------------------------------------------------------------- RETURN ENDmkmetahtmlfile.f0000664006604000003110000001443114521201533013342 0ustar sun00315steps SUBROUTINE mkMetaHTMLFile(fh0,insrs,outsrs,datsrs,nopen, & unopnd,Ldata,mtafil,nmfil) IMPLICIT NONE C----------------------------------------------------------------------- INCLUDE 'stdio.i' LOGICAL T,F PARAMETER(T=.true.,F=.false.) C----------------------------------------------------------------------- CHARACTER Mtafil*(PFILCR),Outsrs*(PFILCR),Insrs*(PFILCR), & Datsrs*(PFILCR),thisExt*(3),thisFile*(PFILCR), & newoutf*(PFILCR) LOGICAL Ldata,iOK INTEGER fh0,nopen,unopnd,i,iopen,n1,n2,n3,n4,nmfil,nmfile,nnewf, & nnewflst DIMENSION Outsrs(PSRS),Insrs(PSRS),Datsrs(PSRS),unopnd(PSRS) C----------------------------------------------------------------------- INTEGER nblank,lstpth EXTERNAL nblank,lstpth C----------------------------------------------------------------------- IF (Ldata) THEN thisExt='dta' ELSE thisExt='mta' END IF thisFile=Mtafil(1:nmfil)//'_'//thisExt//'.html' nmfile=nmfil+9 OPEN(UNIT=fh0,FILE=thisFile(1:nmfile),STATUS='UNKNOWN',ERR=20) IF (Ldata) THEN CALL mkHead(fh0,thisFile(1:nmfile),'Index of '//PRGNAM// & ' Data Meta File ('//Mtafil(1:nmfil)//'.dta)', & F,2,-1,F) CALL writTagOneLine(fh0,'h1','center', & 'Index for Data Meta File '//Mtafil(1:nmfil)//'.dta') ELSE CALL mkHead(fh0,thisFile(1:nmfile),'Index of '//PRGNAM// & ' Meta File ('//Mtafil(1:nmfil)//'.mta)',F,2,-1,F) CALL writTagOneLine(fh0,'h1','center', & 'Index for Meta File '//Mtafil(1:nmfil)//'.mta') END IF CALL mkPOneLine(fh0,'@',' ') WRITE(fh0,1000)0 1000 FORMAT(/,'

    ', & ' 

    ') CALL writTagClass(fh0,'ul','indent') WRITE(fh0,1010)'#out',PRGNAM//' Output files generated by '// & Mtafil(1:nmfil)//'.'//thisExt WRITE(fh0,1010)'#err',PRGNAM//' Error files generated by '// & Mtafil(1:nmfil)//'.'//thisExt WRITE(fh0,1010)'#log','Log file entries for '//Mtafil(1:nmfil)// & '_log.html' CALL writTag(fh0,'') CALL mkPOneLine(fh0,'@',' ') 1010 FORMAT('
  • ',a,'
    • ') CALL makeAnchor(fh0,0,'skip') C----------------------------------------------------------------------- CALL makeAnchor(fh0,-1,'out') CALL writTagOneLine(fh0,'h2','@', & 'Output files generated by '//Mtafil(1:nmfil)//'.'//thisExt) CALL writTagClass(fh0,'ul','indent') iopen=1 DO i=1,Imeta iOK=T IF(nopen.gt.0)THEN IF(unopnd(iopen).eq.i)THEN iOK=F IF(iopen.lt.nopen)iopen=i+1 END IF END IF IF(iOK)THEN n1=nblank(outsrs(i)) n4=lstpth(outsrs(i),n1)+1 CALL cnvfil(outsrs(i),n1,newoutf,nnewf,nnewflst) IF(Ldata)THEN n2=nblank(datsrs(i)) n3=lstpth(datsrs(i),n2)+1 WRITE(fh0,1020)newoutf(1:nnewf)//'.html','Output', & datsrs(i)(n3:n2) ELSE n2=nblank(insrs(i)) n3=lstpth(insrs(i),n2)+1 WRITE(fh0,1020)newoutf(1:nnewf)//'.html','Output', & insrs(i)(n3:n2)//'.spc' END IF END IF END DO 1020 FORMAT('
  • ',a,' file for ',a,'
    • ') CALL writTag(fh0,'') CALL mkPOneLine(fh0,'@',' ') C----------------------------------------------------------------------- CALL makeAnchor(fh0,-1,'err') CALL writTagOneLine(fh0,'h2','@', & 'Error files generated by '//Mtafil(1:nmfil)//'.'//thisExt) CALL writTagClass(fh0,'ul','indent') iopen=1 DO i=1,Imeta iOK=T IF(nopen.gt.0)THEN IF(unopnd(iopen).eq.i)THEN iOK=F IF(iopen.lt.nopen)iopen=i+1 END IF END IF IF(iOK)THEN n1=nblank(outsrs(i)) CALL cnvfil(outsrs(i),n1,newoutf,nnewf,nnewflst) IF(Ldata)THEN n2=nblank(datsrs(i)) n3=lstpth(datsrs(i),n2)+1 WRITE(fh0,1030)newoutf(1:nnewf)//'_err.html','Error', & datsrs(i)(n3:n2) ELSE n2=nblank(insrs(i)) n3=lstpth(insrs(i),n2)+1 WRITE(fh0,1030)newoutf(1:nnewf)//'_err.html','Error', & insrs(i)(n3:n2)//'.spc' END IF END IF END DO 1030 FORMAT('
  • ',a,' file for ',a,'
    • ') CALL writTag(fh0,'') CALL mkPOneLine(fh0,'@',' ') C----------------------------------------------------------------------- CALL makeAnchor(fh0,-1,'log') CALL writTagOneLine(fh0,'h2','@', & 'Log file entries for '//Mtafil(1:nmfil)//'_log.html') CALL writTagClass(fh0,'ul','indent') iopen=1 DO i=1,Imeta iOK=T IF(nopen.gt.0)THEN IF(unopnd(iopen).eq.i)THEN iOK=F IF(iopen.lt.nopen)iopen=i+1 END IF END IF IF(iOK)THEN CALL cnvfil(Mtafil,nmfil,newoutf,nnewf,nnewflst) IF(Ldata)THEN n2=nblank(datsrs(i)) n3=lstpth(datsrs(i),n2)+1 WRITE(fh0,1040)newoutf(1:nnewf),'#pos',i,datsrs(i)(n3:n2) ELSE n2=nblank(insrs(i)) n3=lstpth(insrs(i),n2)+1 WRITE(fh0,1040)newoutf(1:nnewf),'#pos',i,insrs(i)(n3:n2) END IF END IF END DO CALL writTag(fh0,'') CALL mkPOneLine(fh0,'@',' ') 1040 FORMAT('
  • Log Entry for ', & a,'
    • ') C----------------------------------------------------------------------- CALL writTag(fh0,'') CALL writTag(fh0,'') RETURN C----------------------------------------------------------------------- 20 WRITE(STDERR,1025)' Unable to open '//Mtafil(1:nmfil)//'_'// & thisExt//'.html' CALL abend 1025 FORMAT(/,a) C----------------------------------------------------------------------- END mkoprt.f0000664006604000003110000000256114521201533011654 0ustar sun00315stepsC Last change: SRD 19 Nov 99 5:57 am SUBROUTINE mkoprt(Optype,Period,Sp,Oprnam,Noprcr) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER armatl*(2),Oprnam*(*) INTEGER ipos,Noprcr,Optype,Period,Sp DIMENSION armatl(2:3) SAVE armatl DATA armatl/'AR','MA'/ c ------------------------------------------------------------------ IF(Period.eq.1)THEN Oprnam(1:11)='Nonseasonal' ipos=12 c ------------------------------------------------------------------ ELSE IF(Period.eq.Sp)THEN Oprnam(1:8)='Seasonal' ipos=9 c ------------------------------------------------------------------ ELSE Oprnam(1:7)='Period ' ipos=8 CALL itoc(Period,Oprnam,ipos) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(Optype.eq.DIFF)THEN Noprcr=ipos+10 Oprnam(ipos:Noprcr)=' Difference' ELSE Noprcr=ipos+2 Oprnam(ipos:Noprcr)=' '//armatl(Optype) END IF c ------------------------------------------------------------------ RETURN END mkotky.f0000664006604000003110000001010414521201533011646 0ustar sun00315steps SUBROUTINE mkotky(Ibeg,Iend,Otlidx,Ttst) IMPLICIT NONE c----------------------------------------------------------------------- c Create key of observations for whom the t-statistic in the c outlier tables have been set to zero (BCM March 2008) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'fxreg.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c----------------------------------------------------------------------- CHARACTER tmpttl*(PCOLCR),thisot*(2),thisdt*(10),outstr*(80) DOUBLE PRECISION Ttst LOGICAL locok INTEGER Ibeg,Iend,Otlidx,ityp1,ityp2,ndates,icol,ntmpcr, & otltyp,t0,itmp,zrodat,idate,i,i1,i2,i3,ndt,nout DIMENSION Ttst(PLEN,POTLR),zrodat(PB),idate(2) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- IF(Nb.eq.0)RETURN ndates=0 c----------------------------------------------------------------------- IF(Otlidx.eq.AO)THEN ityp1=PRGTAO ityp2=PRGTAA thisot='AO' ELSE IF(Otlidx.eq.LS)THEN ityp1=PRGTLS ityp2=PRGTAL thisot='LS' ELSE IF(Otlidx.eq.TC)THEN ityp1=PRGTTC ityp2=PRGTAT thisot='TC' END IF c----------------------------------------------------------------------- DO icol=1,Nb IF(Rgvrtp(icol).eq.ityp1.or.Rgvrtp(icol).eq.ityp2)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,tmpttl,ntmpcr) IF(.not.Lfatal)THEN CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0,itmp,locok) IF(.not.locok)CALL abend() END IF IF(Lfatal)RETURN IF(dpeq(Ttst(t0,Otlidx),ZERO).and.(t0.ge.Ibeg.and. & t0.le.Iend))THEN ndates=ndates+1 zrodat(ndates)=t0 END IF END IF END DO c----------------------------------------------------------------------- c If some outliers are being held fixed, need to search fixed c outliers to determine if they are within testing range c----------------------------------------------------------------------- IF(Iregfx.ge.2)THEN DO icol=1,Nfxttl IF(Fxtype(icol).eq.ityp1.or.Fxtype(icol).eq.ityp2)THEN CALL getstr(Cfxttl,Cfxptr,Nfxttl,icol,tmpttl,ntmpcr) IF(.not.Lfatal)THEN CALL rdotlr(tmpttl(1:ntmpcr),Begspn,Sp,otltyp,t0,itmp,locok) IF(.not.locok)CALL abend() END IF IF(Lfatal)RETURN IF(t0.ge.Ibeg.and.t0.le.Iend)THEN ndates=ndates+1 zrodat(ndates)=t0 END IF END IF END DO END IF c----------------------------------------------------------------------- c Print out dates c----------------------------------------------------------------------- IF(ndates.gt.0)THEN WRITE(Mt1,1010)thisot i1=1 i2=min(ndates,7) DO WHILE (i2.le.ndates) nout=6 CALL setchr(' ',80,outstr) do i=i1,i2 CALL setchr(' ',10,thisdt) CALL addate(Begspn,Sp,zrodat(i)-1,idate) CALL wrtdat(idate,Sp,thisdt,ndt) i3=((i-i1)*10)+8 outstr(i3:(i3+ndt-1))=thisdt(1:ndt) nout=nout+10 END DO write(Mt1,1020)outstr(1:nout) if (i2.eq.ndates) then i2=i2+1 ELSE i1=i2+1 i2=min(i2+7,ndates) nout=6 END IF END DO END IF c----------------------------------------------------------------------- 1010 FORMAT(/,5x,a,1x,'Outlier t-values have been set to zero for ', & 'the following observations:') 1020 FORMAT(a) c----------------------------------------------------------------------- RETURN END mkpeak.f0000664006604000003110000007430614521201533011616 0ustar sun00315stepsC Last change: BCM 29 Feb 2008 9:46 am * SUBROUTINE mkpeak(Ny,Peakwd,Lfqalt) SUBROUTINE mkpeak(Peakwd,Lfqalt) IMPLICIT NONE c----------------------------------------------------------------------- C Generate pointers and arrays to indentify peaks in spectral plots c generated by X-13A-S c----------------------------------------------------------------------- INCLUDE 'spcidx.cmn' c----------------------------------------------------------------------- LOGICAL Lfqalt * INTEGER Ny,Peakwd INTEGER Peakwd c----------------------------------------------------------------------- C Set Pointers for Monthly Series, Alternate frequencies c----------------------------------------------------------------------- * IF (Ny.eq.12) THEN IF (Lfqalt) THEN c ------------------------------------------------------------------ IF (Peakwd.eq.1) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 1 c ------------------------------------------------------------------ Slow(1) = 10 Slow(2) = 20 Slow(3) = 30 Slow(4) = 43 Slow(5) = 56 Sup(1) = 12 Sup(2) = 22 Sup(3) = 32 Sup(4) = 46 Sup(5) = 59 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 1 c ------------------------------------------------------------------ Tlow(1) = 37 Tlow(2) = 45 Tlow(3) = 58 Tup(1) = 41 Tup(2) = 49 Tup(3) = 62 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 1 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 44 Speak(5) = 57 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 1 c ------------------------------------------------------------------ Tpeak(1) = 39 Tpeak(2) = 47 Tpeak(3) = 60 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 1 c----------------------------------------------------------------------- Nfreq = 70 c ------------------------------------------------------------------ ELSE IF (Peakwd.eq.2) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 2 c ------------------------------------------------------------------ Slow(1) = 9 Slow(2) = 19 Slow(3) = 29 Slow(4) = 41 Slow(5) = 55 Sup(1) = 13 Sup(2) = 23 Sup(3) = 33 Sup(4) = 48 Sup(5) = 61 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 2 c ------------------------------------------------------------------ Tlow(1) = 36 Tlow(2) = 44 Tlow(3) = 57 Tup(1) = 42 Tup(2) = 50 Tup(3) = 63 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 2 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 45 Speak(5) = 58 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 2 c ------------------------------------------------------------------ Tpeak(1) = 47 Tpeak(2) = 60 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 2 c----------------------------------------------------------------------- Nfreq = 70 c ------------------------------------------------------------------ ELSE IF (Peakwd.eq.3) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 3 c ------------------------------------------------------------------ Slow(1) = 8 Slow(2) = 18 Slow(3) = 28 Slow(4) = 40 Slow(5) = 54 Sup(1) = 14 Sup(2) = 24 Sup(3) = 34 Sup(4) = 49 Sup(5) = 62 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 3 c ------------------------------------------------------------------ Tlow(1) = 35 Tlow(2) = 42 Tlow(3) = 56 Tup(1) = 51 Tup(2) = 64 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 3 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 45 Speak(5) = 58 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 3 c ------------------------------------------------------------------ Tpeak(1) = 47 Tpeak(2) = 60 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 3 c----------------------------------------------------------------------- Nfreq = 70 c ------------------------------------------------------------------ ELSE IF (Peakwd.eq.4) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 4 c ------------------------------------------------------------------ Slow(1) = 7 Slow(2) = 17 Slow(3) = 27 Slow(4) = 38 Slow(5) = 53 Sup(1) = 15 Sup(2) = 25 Sup(3) = 36 Sup(4) = 50 Sup(5) = 63 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 4 c ------------------------------------------------------------------ Tlow(1) = 34 Tlow(2) = 41 Tlow(3) = 55 Tup(1) = 52 Tup(2) = 65 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 4 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 44 Speak(5) = 58 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 4 c ------------------------------------------------------------------ Tpeak(1) = 47 Tpeak(2) = 60 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 4 c----------------------------------------------------------------------- Nfreq = 70 END IF c ------------------------------------------------------------------ C Set seasonal frequency array, number of seasonal frequencies c ------------------------------------------------------------------ Sfreq(1) = 0.083333333D0 Sfreq(2) = 0.166666667D0 Sfreq(3) = 0.250000000D0 Sfreq(4) = 0.333333333D0 Sfreq(5) = 0.416666667D0 nSfreq = 5 c ------------------------------------------------------------------ C Set TD frequency array, number of trading day frequencies c ------------------------------------------------------------------ Tfreq(1) = 0.303600000D0 Tfreq(2) = 0.348200000D0 Tfreq(3) = 0.432000000D0 nTfreq = 3 c----------------------------------------------------------------------- C Set Pointers for Monthly Series, Default frequencies c----------------------------------------------------------------------- ELSE c ------------------------------------------------------------------ IF (Peakwd.eq.1) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 1 c ------------------------------------------------------------------ Slow(1) = 10 Slow(2) = 20 Slow(3) = 30 Slow(4) = 40 Slow(5) = 53 Sup(1) = 12 Sup(2) = 22 Sup(3) = 32 Sup(4) = 43 Sup(5) = 56 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 1 c ------------------------------------------------------------------ Tlow(1) = 42 Tlow(2) = 55 Tup(1) = 46 Tup(2) = 59 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 1 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 41 Speak(5) = 54 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 1 c ------------------------------------------------------------------ Tpeak(1) = 44 Tpeak(2) = 57 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 1 c----------------------------------------------------------------------- Nfreq = 67 c ------------------------------------------------------------------ ELSE IF (Peakwd.eq.2) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 2 c ------------------------------------------------------------------ Slow(1) = 9 Slow(2) = 19 Slow(3) = 29 Slow(4) = 39 Slow(5) = 52 Sup(1) = 13 Sup(2) = 23 Sup(3) = 33 Sup(4) = 45 Sup(5) = 58 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 2 c ------------------------------------------------------------------ Tlow(1) = 41 Tlow(2) = 54 Tup(1) = 47 Tup(2) = 60 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 2 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 42 Speak(5) = 55 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 2 c ------------------------------------------------------------------ Tpeak(1) = 44 Tpeak(2) = 57 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 2 c----------------------------------------------------------------------- Nfreq = 67 c ------------------------------------------------------------------ ELSE IF (Peakwd.eq.3) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 3 c ------------------------------------------------------------------ Slow(1) = 8 Slow(2) = 18 Slow(3) = 28 Slow(4) = 38 Slow(5) = 51 Sup(1) = 14 Sup(2) = 24 Sup(3) = 34 Sup(4) = 46 Sup(5) = 59 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 3 c ------------------------------------------------------------------ Tlow(1) = 40 Tlow(2) = 53 Tup(1) = 48 Tup(2) = 61 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 3 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 42 Speak(5) = 55 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 3 c ------------------------------------------------------------------ Tpeak(1) = 44 Tpeak(2) = 57 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 3 c----------------------------------------------------------------------- Nfreq = 67 c ------------------------------------------------------------------ ELSE IF (Peakwd.eq.4) THEN c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C seasonal peaks, Peakwd = 4 c ------------------------------------------------------------------ Slow(1) = 7 Slow(2) = 17 Slow(3) = 27 Slow(4) = 37 Slow(5) = 50 Sup(1) = 15 Sup(2) = 25 Sup(3) = 35 Sup(4) = 47 Sup(5) = 60 c ------------------------------------------------------------------ C Set index arrays for the lower and upper limits of the C trading day peaks, Peakwd = 4 c ------------------------------------------------------------------ Tlow(1) = 39 Tlow(2) = 52 Tup(1) = 49 Tup(2) = 61 Tup(3) = 62 c ------------------------------------------------------------------ C Set seasonal index array, Peakwd = 4 c ------------------------------------------------------------------ Speak(1) = 11 Speak(2) = 21 Speak(3) = 31 Speak(4) = 42 Speak(5) = 55 c ------------------------------------------------------------------ C Set trading day index array, Peakwd = 4 c ------------------------------------------------------------------ Tpeak(1) = 44 Tpeak(2) = 57 c----------------------------------------------------------------------- C Set Number of spectral frequencies, with enhancements, Peakwd = 4 c----------------------------------------------------------------------- Nfreq = 67 END IF c ------------------------------------------------------------------ C Set seasonal frequency array, number of seasonal frequencies c ------------------------------------------------------------------ Sfreq(1) = 0.083333333D0 Sfreq(2) = 0.166666667D0 Sfreq(3) = 0.250000000D0 Sfreq(4) = 0.333333333D0 Sfreq(5) = 0.416666667D0 nSfreq = 5 c ------------------------------------------------------------------ C Set TD frequency array, number of trading day frequencies c ------------------------------------------------------------------ Tfreq(1) = 0.348200000D0 Tfreq(2) = 0.432000000D0 nTfreq = 2 END IF c----------------------------------------------------------------------- C Set Pointers for Quarterly Series, Alternate frequencies c----------------------------------------------------------------------- * ELSE IF (Ny.eq.4) THEN * IF (Lfqalt) THEN *c ------------------------------------------------------------------ * IF (Peakwd.eq.1) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 1 *c ------------------------------------------------------------------ * Slow(1) = 36 * Sup(1) = 38 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 1 *c ------------------------------------------------------------------ * Tlow(1) = 6 * Tlow(2) = 14 * Tlow(3) = 42 * Tlow(4) = 50 * Tlow(5) = 58 * Tup(1) = 10 * Tup(2) = 18 * Tup(3) = 46 * Tup(4) = 54 * Tup(5) = 62 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 1 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 1 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 * Tpeak(3) = 44 * Tpeak(4) = 52 * Tpeak(5) = 60 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 1 *c----------------------------------------------------------------------- * Nfreq = 76 *c ------------------------------------------------------------------ * ELSE IF (Peakwd.eq.2) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 2 *c ------------------------------------------------------------------ * Slow(1) = 35 * Sup(1) = 39 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 2 *c ------------------------------------------------------------------ * Tlow(1) = 5 * Tlow(2) = 13 * Tlow(3) = 41 * Tlow(4) = 49 * Tlow(5) = 57 * Tup(1) = 11 * Tup(2) = 19 * Tup(3) = 47 * Tup(4) = 55 * Tup(5) = 63 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 2 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 2 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 * Tpeak(3) = 44 * Tpeak(4) = 52 * Tpeak(5) = 60 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 2 *c----------------------------------------------------------------------- * Nfreq = 76 *c ------------------------------------------------------------------ * ELSE IF (Peakwd.eq.3) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 3 *c ------------------------------------------------------------------ * Slow(1) = 34 * Sup(1) = 41 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 3 *c ------------------------------------------------------------------ * Tlow(1) = 4 * Tlow(2) = 11 * Tlow(3) = 40 * Tlow(4) = 47 * Tlow(5) = 55 * Tup(1) = 13 * Tup(2) = 20 * Tup(3) = 49 * Tup(4) = 57 * Tup(5) = 64 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 3 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 3 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 * Tpeak(3) = 44 * Tpeak(4) = 52 * Tpeak(5) = 60 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 3 *c----------------------------------------------------------------------- * Nfreq = 76 *c ------------------------------------------------------------------ * ELSE IF (Peakwd.eq.4) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 4 *c ------------------------------------------------------------------ * Slow(1) = 33 * Sup(1) = 41 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 4 *c ------------------------------------------------------------------ * Tlow(1) = 3 * Tlow(2) = 10 * Tlow(3) = 39 * Tlow(4) = 46 * Tlow(5) = 54 * Tup(1) = 14 * Tup(2) = 21 * Tup(3) = 50 * Tup(4) = 58 * Tup(5) = 65 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 4 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 4 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 * Tpeak(3) = 44 * Tpeak(4) = 52 * Tpeak(5) = 60 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 4 *c----------------------------------------------------------------------- * Nfreq = 76 * END IF *c ------------------------------------------------------------------ *C Set seasonal frequency array, number of seasonal frequencies *c ------------------------------------------------------------------ * Sfreq(1) = 0.250000000D0 * nSfreq = 1 *c ------------------------------------------------------------------ *C Set TD frequency array, number of trading day frequencies *c ------------------------------------------------------------------ * Tfreq(1) = 0.044600000D0 * Tfreq(2) = 0.089300000D0 * Tfreq(3) = 0.294375000D0 * Tfreq(4) = 0.338750000D0 * Tfreq(5) = 0.383125000D0 * nTfreq = 5 *c----------------------------------------------------------------------- *C Set Pointers for Quarterly Series, Default frequencies *c----------------------------------------------------------------------- * ELSE *c ------------------------------------------------------------------ * IF (Peakwd.eq.1) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 1 *c ------------------------------------------------------------------ * Slow(1) = 36 * Sup(1) = 38 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 1 *c ------------------------------------------------------------------ * Tlow(1) = 6 * Tlow(2) = 14 * Tup(1) = 10 * Tup(2) = 18 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 1 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 1 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 1 *c----------------------------------------------------------------------- * Nfreq = 67 *c ------------------------------------------------------------------ * ELSE IF (Peakwd.eq.2) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 2 *c ------------------------------------------------------------------ * Slow(1) = 35 * Sup(1) = 39 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 2 *c ------------------------------------------------------------------ * Tlow(1) = 5 * Tlow(2) = 13 * Tup(1) = 11 * Tup(2) = 19 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 2 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 2 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 2 *c----------------------------------------------------------------------- * Nfreq = 67 *c ------------------------------------------------------------------ * ELSE IF (Peakwd.eq.3) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 3 *c ------------------------------------------------------------------ * Slow(1) = 34 * Sup(1) = 40 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 3 *c ------------------------------------------------------------------ * Tlow(1) = 4 * Tlow(2) = 11 * Tup(1) = 13 * Tup(2) = 20 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 3 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 3 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 3 *c----------------------------------------------------------------------- * Nfreq = 67 *c ------------------------------------------------------------------ * ELSE IF (Peakwd.eq.4) THEN *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C seasonal peaks, Peakwd = 4 *c ------------------------------------------------------------------ * Slow(1) = 33 * Sup(1) = 41 *c ------------------------------------------------------------------ *C Set index arrays for the lower and upper limits of the *C trading day peaks, Peakwd = 4 *c ------------------------------------------------------------------ * Tlow(1) = 3 * Tlow(2) = 10 * Tup(1) = 14 * Tup(2) = 21 *c ------------------------------------------------------------------ *C Set seasonal index array, Peakwd = 4 *c ------------------------------------------------------------------ * Speak(1) = 37 *c ------------------------------------------------------------------ *C Set trading day index array, Peakwd = 4 *c ------------------------------------------------------------------ * Tpeak(1) = 8 * Tpeak(2) = 16 *c----------------------------------------------------------------------- *C Set Number of spectral frequencies, with enhancements, Peakwd = 4 *c----------------------------------------------------------------------- * Nfreq = 67 * END IF *c ------------------------------------------------------------------ *C Set seasonal frequency array, number of seasonal frequencies *c ------------------------------------------------------------------ * Sfreq(1) = 0.250000000D0 * nSfreq = 1 *c ------------------------------------------------------------------ *C Set TD frequency array, number of trading day frequencies *c ------------------------------------------------------------------ * Tfreq(1) = 0.044600000D0 * Tfreq(2) = 0.089300000D0 * nTfreq = 2 * END IF * END IF c----------------------------------------------------------------------- RETURN END mkshdr.f0000664006604000003110000004127314521201534011634 0ustar sun00315stepsC Last change: BCM 8 Dec 1998 4:22 pm SUBROUTINE mkshdr(Subttl,Nsttl,Ktabl,Itype,Subhdr) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'prior.prm' INCLUDE 'x11adj.cmn' INCLUDE 'x11log.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'prior.cmn' INCLUDE 'force.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'picktd.cmn' c----------------------------------------------------------------------- CHARACTER Subttl*(*) INTEGER Nsttl,Ktabl,Itype,nnls LOGICAL Subhdr,ltd,lhol,lreg,lxreg,lpri c----------------------------------------------------------------------- Subhdr=F nnls=Nls-Nramp IF(Kpart.eq.4.and.Ktabl.eq.11.and.(Kfulsm.eq.0.or.Kfulsm.eq.2)) & THEN ltd=Adjtd.eq.1.or.(Ixreg.gt.0.and.Axrghl) lhol=Finhol.and.(Khol.eq.2.or.(Ixreg.gt.0.and.Axrghl).or. & Adjhol.eq.1) IF(ltd.or.lhol.OR.Finao.or.Finls.or.Finusr)THEN IF(Itype.gt.1)THEN Nsttl=26 Subttl(1:Nsttl)=' (also adjusted for' ELSE Nsttl=24 Subttl(1:Nsttl)=' (also adjusted for' END IF IF(ltd)THEN IF(Kswv.gt.0)THEN Subttl((Nsttl+1):(Nsttl+21))=' combined trading day' Nsttl=Nsttl+21 ELSE Subttl((Nsttl+1):(Nsttl+12))=' trading day' Nsttl=Nsttl+12 END IF Subhdr=T ELSE IF(Kswv.gt.0)THEN Subttl((Nsttl+1):(Nsttl+18))=' prior trading day' Nsttl=Nsttl+18 Subhdr=T END IF IF(lhol)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+8))=' holiday' Nsttl=Nsttl+8 END IF IF(Finao.or.Fintc.or.Finls)THEN IF(Finls)THEN IF(nnls.gt.0)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+3))=' LS' Nsttl=Nsttl+3 END IF IF(Nramp.gt.0)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+5))=' ramp' Nsttl=Nsttl+5 END IF END IF IF(Fintc)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+3))=' TC' Nsttl=Nsttl+3 END IF IF(Finao)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+5))=' AO' Nsttl=Nsttl+3 END IF Subttl((Nsttl+1):(Nsttl+8))=' outlier' Nsttl=Nsttl+8 END IF IF(Finusr)THEN IF(Subhdr)THEN Subttl(Nsttl+1:Nsttl+1)=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+21))=' user-defined effects' Nsttl=Nsttl+21 END IF Subttl(Nsttl+1:Nsttl+1)=')' Nsttl=Nsttl+1 END IF c ------------------------------------------------------------------ ELSE IF(Kpart.eq.2.and.Ktabl.eq.1)THEN lreg=Adjtd.eq.1.or.Adjao.eq.1.or.Adjls.eq.1.or.Adjtc.eq.1.or. & Adjso.eq.1.or.Adjhol.eq.1.or.Adjusr.eq.1.or.Adjsea.eq.1 lxreg=Ixreg.gt.0.AND.(Axrghl.or.Axrgtd) lpri=Priadj.gt.1.OR.Nprtyp.gt.0 IF(lpri.OR.lreg.or.lxreg.or.Khol.eq.2)THEN Nsttl=18 Subttl(1:Nsttl)=' (adjusted for' IF(lpri)THEN Subhdr=T Subttl((Nsttl+1):(Nsttl+6))=' prior' Nsttl=Nsttl+6 END IF IF(lreg)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+9))=' regARIMA' Nsttl=Nsttl+9 END IF IF(lxreg)THEN IF(Subhdr)THEN Subttl(Nsttl+1:Nsttl+1)=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+21))=' irregular regression' Nsttl=Nsttl+21 END IF IF(Khol.eq.2)THEN IF(Subhdr)THEN Subttl(Nsttl+1:Nsttl+1)=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+12))=' X-11 Easter' Nsttl=Nsttl+12 END IF IF(Kswv.gt.0)THEN IF(Subhdr)THEN Subttl(Nsttl+1:Nsttl+1)=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+18))=' prior trading day' Nsttl=Nsttl+18 END IF Subttl(Nsttl+1:Nsttl+9)=' factors)' Nsttl=Nsttl+9 END IF c ------------------------------------------------------------------ ELSE IF(Kpart.eq.4.and.(Ktabl.eq.16.or.Ktabl.eq.18))THEN ltd=Adjtd.eq.1.or.(Ixreg.gt.0.and.Axrghl) lhol=Finhol.and.(Khol.eq.2.or.(Ixreg.gt.0.and.Axrghl).or. & Adjhol.eq.1) IF(ltd.or.lhol)THEN IF(Ktabl.eq.16)THEN Nsttl=25 Subttl(1:Nsttl)=' (includes seasonal,' ELSE Nsttl=15 Subttl(1:Nsttl)=' (includes' END IF IF(ltd)THEN IF(Kswv.gt.0)THEN Subttl((Nsttl+1):(Nsttl+21))=' combined trading day' Nsttl=Nsttl+21 ELSE Subttl((Nsttl+1):(Nsttl+12))=' trading day' Nsttl=Nsttl+12 END IF Subhdr=T ELSE IF(Kswv.gt.0)THEN Subttl((Nsttl+1):(Nsttl+18))=' prior trading day' Nsttl=Nsttl+18 Subhdr=T END IF IF(lhol)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+8))=' holiday' Nsttl=Nsttl+8 END IF Subttl(Nsttl+1:Nsttl+9)=' factors)' Nsttl=Nsttl+9 END IF c----------------------------------------------------------------------- ELSE IF(((Kpart.eq.2.or.Kpart.eq.3).and.Ktabl.eq.15).AND. & ((Khol.eq.1.OR.(Kpart.eq.0.and.Ktabl.eq.1)).OR. & Ixreg.eq.2))THEN Nsttl=26 Subttl(1:Nsttl)=' First pass - Estimating ' IF(Ixreg.eq.2.AND.(Khol.eq.1.OR.(Kpart.eq.0.and.Ktabl.eq.1)))THEN Subttl((Nsttl+1):(Nsttl+44))= & 'irregular regression and X-11 Easter effects' Nsttl=Nsttl+44 ELSE IF(Ixreg.eq.2)THEN Subttl((Nsttl+1):(Nsttl+28))='irregular regression effects' Nsttl=Nsttl+28 ELSE Subttl((Nsttl+1):(Nsttl+19))='X-11 Easter effects' Nsttl=Nsttl+19 END IF Subhdr=T c ------------------------------------------------------------------ ELSE IF(Kpart.eq.1.and.Ktabl.eq.2.and.Priadj.gt.1)THEN Nsttl=5 Subttl(1:Nsttl)=' ' IF(Priadj.eq.2)THEN Subttl((Nsttl+1):(Nsttl+16))='Length of month ' Nsttl=Nsttl+16 ELSE IF(Priadj.eq.3)THEN Subttl((Nsttl+1):(Nsttl+18))='Length of quarter ' Nsttl=Nsttl+18 ELSE IF(Priadj.eq.4)THEN Subttl((Nsttl+1):(Nsttl+10))='Leap year ' Nsttl=Nsttl+10 END IF Subhdr=T IF(Picktd)THEN Subttl((Nsttl+1):(Nsttl+30))='(from trading day regression) ' Nsttl=Nsttl+30 END IF IF(Nprtyp.gt.0)THEN Subttl((Nsttl+1):(Nsttl+11))=' and prior ' Nsttl=Nsttl+11 END IF Subttl((Nsttl+1):(Nsttl+12))='adjustments.' Nsttl=Nsttl+12 c ------------------------------------------------------------------ ELSE IF(Kpart.eq.1.and.Ktabl.eq.6.and.Priadj.lt.0)THEN Nsttl=5 Subttl(1:Nsttl)=' ' IF(Priadj.eq.-2)THEN Subttl((Nsttl+1):(Nsttl+16))='Length of month ' Nsttl=Nsttl+16 ELSE IF(Priadj.eq.-3)THEN Subttl((Nsttl+1):(Nsttl+18))='Length of quarter ' Nsttl=Nsttl+18 ELSE IF(Priadj.eq.-4)THEN Subttl((Nsttl+1):(Nsttl+10))='Leap year ' Nsttl=Nsttl+10 END IF Subhdr=T Subttl((Nsttl+1):(Nsttl+41))= & 'prior adjustments included from Table A2.' Nsttl=Nsttl+41 c ------------------------------------------------------------------ ELSE IF(Kpart.eq.1.and.Ktabl.eq.3.and.Itype.eq.1)THEN lxreg=Ixreg.gt.0.AND.(Axrghl.or.Axrgtd) lpri=Priadj.gt.1.OR.Nprtyp.gt.0 IF(lpri.or.lxreg.or.Khol.eq.2)THEN Nsttl=6 Subttl(1:Nsttl)=' (' IF(lpri)THEN Subhdr=T Subttl((Nsttl+1):(Nsttl+5))='Prior' Nsttl=Nsttl+5 END IF IF(lxreg)THEN IF(Subhdr)THEN Subttl(Nsttl+1:Nsttl+22)=', irregular regression' Nsttl=Nsttl+22 ELSE Subttl((Nsttl+1):(Nsttl+20))='Irregular regression' Nsttl=Nsttl+20 Subhdr=T END IF END IF IF(Khol.eq.2)THEN IF(Subhdr)THEN Subttl(Nsttl+1:Nsttl+2)=', ' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+12))=' X-11 Easter' Nsttl=Nsttl+12 END IF Subttl((Nsttl+1):(Nsttl+27))=' adjustments applied to A1)' Nsttl=Nsttl+27 END IF c ------------------------------------------------------------------ ELSE IF(Kpart.eq.1.and.Ktabl.eq.3.and.Itype.eq.2)THEN Nsttl=50 Subttl(1:Nsttl)= & ' (Permanent prior adjustments applied to A1)' Subhdr=T c ------------------------------------------------------------------ ELSE IF(Kpart.eq.1.and.Ktabl.eq.18)THEN Nsttl=16 Subttl(1:Nsttl)=' (regARIMA ' IF(Adjtd.eq.1)THEN IF(Adjhol.eq.1)THEN Subttl((Nsttl+1):(Nsttl+23))='trading day and holiday' Nsttl=Nsttl+23 ELSE Subttl((Nsttl+1):(Nsttl+11))='trading day' Nsttl=Nsttl+11 END IF ELSE Subttl((Nsttl+1):(Nsttl+7))='holiday' Nsttl=Nsttl+7 END IF Subttl((Nsttl+1):(Nsttl+23))=' factors applied to A1)' Nsttl=Nsttl+23 Subhdr=T c ------------------------------------------------------------------ ELSE IF((Kpart.eq.5.and.Ktabl.eq.6.and.Itype.ge.2).and. & Iyrt.gt.0)THEN Nsttl=32 Subttl(1:Nsttl)=' with forced yearly totals' Subhdr=T ELSE IF(Kpart.eq.5.and.Ktabl.eq.1)THEN Nsttl=44 Subttl(1:Nsttl)=' (A1 adjusted by C20 whenever C17 = 0)' Subhdr=T c ------------------------------------------------------------------ ELSE IF(Kpart.eq.5.and.Ktabl.eq.2)THEN Nsttl=54 Subttl(1:Nsttl)=' (D11 with D12 trend substituted whenever C1 &7 = 0)' Subhdr=T c ------------------------------------------------------------------ ELSE IF(Kpart.eq.5.and.Ktabl.eq.3)THEN Nsttl=48 IF(Muladd.eq.1)THEN Subttl(1:Nsttl)= & ' (D13 with 0.0 substituted whenever C17 = 0)' ELSE Subttl(1:Nsttl)= & ' (D13 with 1.0 substituted whenever C17 = 0)' END IF Subhdr=T c ------------------------------------------------------------------ ELSE IF(Kpart.eq.5.and.Ktabl.eq.11)THEN Nsttl=62 Subttl(1:Nsttl)=' (E2 with D12+(A1-E1) value substituted whe &never C17 = 0)' Subhdr=T c ------------------------------------------------------------------ c ELSE IF((Kpart.eq.4.and.Ktabl.eq.12.AND.((.not.Finls).and. c & Adjls.eq.1)).or. ELSE IF (Kpart.eq.1.and.Ktabl.eq.12)THEN Nsttl=7 Subttl(1:Nsttl)=' (' IF(nnls.gt.0)THEN Subttl((Nsttl+1):(Nsttl+2))='LS' Nsttl=Nsttl+2 Subhdr=T END IF IF(Nramp.gt.0)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+5))=' ramp' Nsttl=Nsttl+5 END IF Subttl((Nsttl+1):(Nsttl+19))=' outliers included)' Nsttl=Nsttl+19 c ------------------------------------------------------------------ ELSE IF(Kpart.eq.1.and.Ktabl.eq.16)THEN Nsttl=15 Subttl(1:Nsttl)=' (includes' IF(Khol.eq.2)THEN Subttl((Nsttl+1):(Nsttl+12))=' X-11 Easter' Nsttl=Nsttl+12 Subhdr=T END IF IF(Adjhol.gt.0)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+9))=' regARIMA' Nsttl=Nsttl+9 END IF IF(Ixreg.gt.2.and.Axrghl)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+1))=',' Nsttl=Nsttl+1 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+21))=' irregular regression' Nsttl=Nsttl+21 END IF Subttl((Nsttl+1):(Nsttl+9))=' holiday)' Nsttl=Nsttl+9 c ------------------------------------------------------------------ ELSE IF(Kpart.eq.1.and.Ktabl.eq.5)THEN Nsttl=14 Subttl(1:Nsttl)=' (includes' IF(Nlp.gt.0)THEN Subttl((Nsttl+1):(Nsttl+21))=' leap year regressor)' Nsttl=Nsttl+21 Subhdr=T ELSE IF(Nln.gt.0)THEN Subhdr=T IF(Ny.eq.12)THEN Subttl((Nsttl+1):(Nsttl+27))=' length of month regressor)' Nsttl=Nsttl+27 ELSE Subttl((Nsttl+1):(Nsttl+29))=' length of quarter regressor)' Nsttl=Nsttl+29 END IF ELSE IF(Nsln.gt.0)THEN Subhdr=T Subttl((Nsttl+1):(Nsttl+33))='stock length of month regressor)' Nsttl=Nsttl+33 ELSE IF(Picktd)THEN Subhdr=T Subttl((Nsttl+1):(Nsttl+25))=' leap year preadjustment)' Nsttl=Nsttl+25 ELSE IF(Priadj.gt.0) THEN Subhdr=T IF(Priadj.eq.2)THEN Subttl((Nsttl+1):(Nsttl+31))=' length of month preadjustment)' Nsttl=Nsttl+31 ELSE IF(Priadj.eq.3)THEN Subttl((Nsttl+1):(Nsttl+33))= & ' length of quarter preadjustment)' Nsttl=Nsttl+33 ELSE IF(Priadj.eq.4)THEN Subttl((Nsttl+1):(Nsttl+25))=' leap year preadjustment)' Nsttl=Nsttl+25 END IF END IF c ------------------------------------------------------------------ ELSE IF((Kpart.eq.2.or.Kpart.eq.3).and.Ktabl.eq.22)THEN Subhdr=T IF(Itype.eq.1)THEN Subttl(1:31)=' (trading day and holiday)' Nsttl=31 ELSE Subttl(1:62)=' (prior and irregular regression trading day &and holiday)' Nsttl=62 END IF c ------------------------------------------------------------------ ELSE IF((Kpart.eq.1.and.Ktabl.eq.8.and.Itype.eq.1).AND. & ((Adjls.eq.1.or.Finls).OR.(Adjao.eq.1.or.Finao).OR. & (Adjtc.eq.1.or.Fintc)))THEN Nsttl=6 Subttl(1:Nsttl)=' (' IF(Adjao.eq.1.or.Finao)THEN Subttl((Nsttl+1):(Nsttl+2))='AO' Nsttl=Nsttl+2 Subhdr=T END IF IF(Adjls.eq.1.or.Finls)THEN IF(nnls.gt.0)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+2))=', ' Nsttl=Nsttl+2 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+2))='LS' Nsttl=Nsttl+2 END IF IF(Nramp.gt.0)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+2))=', ' Nsttl=Nsttl+2 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+4))='ramp' Nsttl=Nsttl+4 END IF END IF IF(Adjtc.eq.1.or.Fintc)THEN IF(Subhdr)THEN Subttl((Nsttl+1):(Nsttl+2))=', ' Nsttl=Nsttl+2 ELSE Subhdr=T END IF Subttl((Nsttl+1):(Nsttl+2))='TC' Nsttl=Nsttl+2 END IF Subttl((Nsttl+1):(Nsttl+19))=' outliers included)' Nsttl=Nsttl+19 END IF c ------------------------------------------------------------------ RETURN END mkspky.f0000664006604000003110000000223214521201534011652 0ustar sun00315steps SUBROUTINE mkspky(Itbl,Spcstr,Nspstr,Iagr,Lseats) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Itbl,Nspstr,Iagr,Lsumm LOGICAL Lseats CHARACTER Spcstr*(10) c----------------------------------------------------------------------- IF(Itbl.eq.1)THEN IF(Iagr.lt.4)THEN Nspstr=6 Spcstr(1:Nspstr)='spcori' ELSE Nspstr=7 Spcstr(1:Nspstr)='spccomp' END IF ELSE IF (Itbl.eq.2)THEN IF(Iagr.lt.4)THEN Nspstr=5 Spcstr(1:Nspstr)='spcsa' ELSE Nspstr=8 Spcstr(1:Nspstr)='spcindsa' END IF ELSE IF (Itbl.eq.3)THEN IF(Iagr.lt.4)THEN Nspstr=6 Spcstr(1:Nspstr)='spcirr' ELSE Nspstr=9 Spcstr(1:Nspstr)='spcindirr' END IF ELSE IF(Lseats)THEN Nspstr=9 Spcstr(1:Nspstr)='spcextrsd' ELSE Nspstr=6 Spcstr(1:Nspstr)='spcrsd' END IF END IF c----------------------------------------------------------------------- RETURN END mksplb.f0000664006604000003110000001003314521201534011622 0ustar sun00315steps SUBROUTINE mksplb(Itbl,Spcstr,Nspstr,Spcsrs,Ldecbl) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Itbl,Nspstr,Spcsrs,Lsumm LOGICAL Ldecbl CHARACTER Spcstr*(36) c----------------------------------------------------------------------- INCLUDE 'spctbl.i' c----------------------------------------------------------------------- IF(Ldecbl)THEN IF(Itbl.eq.LSPCS0)THEN IF(Spcsrs.eq.0)THEN Nspstr=20 Spcstr(1:Nspstr)='10*Log(Spectrum_Ori)' ELSE IF(Spcsrs.eq.1)THEN Nspstr=26 Spcstr(1:Nspstr)='10*Log(Spectrum_OtlAdjOri)' ELSE IF(Spcsrs.eq.2)THEN Nspstr=23 Spcstr(1:Nspstr)='10*Log(Spectrum_AdjOri)' ELSE IF(Spcsrs.eq.3)THEN Nspstr=23 Spcstr(1:Nspstr)='10*Log(Spectrum_ModOri)' END IF ELSE IF(Itbl.eq.LSPS0C)THEN IF(Spcsrs.eq.0)THEN Nspstr=21 Spcstr(1:Nspstr)='10*Log(Spectrum_Comp)' ELSE IF(Spcsrs.eq.1)THEN Nspstr=27 Spcstr(1:Nspstr)='10*Log(Spectrum_OtlAdjComp)' ELSE IF(Spcsrs.eq.2)THEN Nspstr=24 Spcstr(1:Nspstr)='10*Log(Spectrum_AdjComp)' ELSE IF(Spcsrs.eq.3)THEN Nspstr=24 Spcstr(1:Nspstr)='10*Log(Spectrum_ModComp)' END IF ELSE IF(Itbl.eq.LSPERS)THEN Nspstr=23 Spcstr(1:Nspstr)='10*Log(Spectrum_ExtRsd)' ELSE IF(Itbl.eq.LSPCRS)THEN Nspstr=20 Spcstr(1:Nspstr)='10*Log(Spectrum_Rsd)' ELSE IF(Itbl.eq.LSPS1I)THEN Nspstr=22 Spcstr(1:Nspstr)='10*Log(Spectrum_IndSA)' ELSE IF(Itbl.eq.LSPS1S)THEN Nspstr=25 Spcstr(1:Nspstr)='10*Log(Spectrum_SA_SEATS)' ELSE IF(Itbl.eq.LSPCS1)THEN Nspstr=19 Spcstr(1:Nspstr)='10*Log(Spectrum_SA)' ELSE IF(Itbl.eq.LSPS2I)THEN Nspstr=23 Spcstr(1:Nspstr)='10*Log(Spectrum_IndIrr)' ELSE IF(Itbl.eq.LSPS2S)THEN Nspstr=26 Spcstr(1:Nspstr)='10*Log(Spectrum_Irr_SEATS)' ELSE IF(Itbl.eq.LSPCS2)THEN Nspstr=20 Spcstr(1:Nspstr)='10*Log(Spectrum_Irr)' ELSE Nspstr=16 Spcstr(1:Nspstr)='10*Log(Spectrum)' END IF ELSE IF(Itbl.eq.LSPCS0)THEN IF(Spcsrs.eq.0)THEN Nspstr=12 Spcstr(1:Nspstr)='Spectrum_Ori' ELSE IF(Spcsrs.eq.1)THEN Nspstr=18 Spcstr(1:Nspstr)='Spectrum_OtlAdjOri' ELSE IF(Spcsrs.eq.2)THEN Nspstr=15 Spcstr(1:Nspstr)='Spectrum_AdjOri' ELSE IF(Spcsrs.eq.3)THEN Nspstr=15 Spcstr(1:Nspstr)='Spectrum_ModOri' END IF ELSE IF(Itbl.eq.LSPS0C)THEN IF(Spcsrs.eq.0)THEN Nspstr=13 Spcstr(1:Nspstr)='Spectrum_Comp' ELSE IF(Spcsrs.eq.1)THEN Nspstr=19 Spcstr(1:Nspstr)='Spectrum_OtlAdjComp' ELSE IF(Spcsrs.eq.2)THEN Nspstr=16 Spcstr(1:Nspstr)='Spectrum_AdjComp' ELSE IF(Spcsrs.eq.3)THEN Nspstr=16 Spcstr(1:Nspstr)='Spectrum_ModComp' END IF ELSE IF(Itbl.eq.LSPERS)THEN Spcstr='Spectrum_ExtRsd' Nspstr=15 ELSE IF(Itbl.eq.LSPCRS)THEN Spcstr='Spectrum_Rsd' Nspstr=12 ELSE IF(Itbl.eq.LSPS1I)THEN Nspstr=14 Spcstr(1:Nspstr)='Spectrum_IndSA' ELSE IF(Itbl.eq.LSPS1S)THEN Nspstr=17 Spcstr(1:Nspstr)='Spectrum_SA_SEATS' ELSE IF(Itbl.eq.LSPCS1)THEN Nspstr=11 Spcstr(1:Nspstr)='Spectrum_SA' ELSE IF(Itbl.eq.LSPS2I)THEN Nspstr=15 Spcstr(1:Nspstr)='Spectrum_IndIrr' ELSE IF(Itbl.eq.LSPS2S)THEN Nspstr=18 Spcstr(1:Nspstr)='Spectrum_Irr_SEATS' ELSE IF(Itbl.eq.LSPCS2)THEN Nspstr=12 Spcstr(1:Nspstr)='Spectrum_Irr' ELSE Nspstr=8 Spcstr(1:Nspstr)='Spectrum' END IF END IF RETURN END mkspst.f0000664006604000003110000000455414521201534011666 0ustar sun00315steps SUBROUTINE mkspst(Spcsrs,Spcstr,Numchr,Numch2,Lcap) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'hiddn.cmn' c----------------------------------------------------------------------- CHARACTER Spcstr*(36) INTEGER Spcsrs,Numchr,Numch2 LOGICAL Lcap c----------------------------------------------------------------------- Numch2=0 IF(Spcsrs.eq.0)THEN Numchr=27 IF(Lcap)THEN Spcstr(1:Numchr)=' Original Series (Table A1)' Numch2=16 ELSE Spcstr(1:Numchr)=' original series (Table A1)' END IF ELSE IF(Spcsrs.eq.1)THEN IF(Adjls.eq.1.or.Adjao.eq.1.or.Adjtc.eq.1)THEN Numchr=36 IF(Lcap)THEN Spcstr(1:Numchr)=' Outlier Adjusted Series (Table A19)' Numch2=24 ELSE Spcstr(1:Numchr)=' outlier adjusted series (Table A19)' END IF ELSE Numchr=34 IF(Lcap)THEN Spcstr(1:Numchr)=' Original Series (Table A1 or A19)' Numch2=16 ELSE Spcstr(1:Numchr)=' original series (Table A1 or A19)' END IF END IF ELSE IF(Spcsrs.eq.2)THEN Numchr=33 IF(Adjls.eq.1.or.Adjao.eq.1.or.Adjtc.eq.1.or.Adjtd.eq.1.or. & Adjhol.eq.1.or.Adjsea.eq.1.or.Adjusr.eq.1.or.Nprtyp.gt.0.or. & Kswv.ne.0.or.(Ixreg.ge.2.and.Axrgtd))THEN IF(Lcap)THEN Spcstr(1:Numchr)=' Prior Adjusted Series (Table B1)' Numch2=22 ELSE Spcstr(1:Numchr)=' prior adjusted series (Table B1)' END IF ELSE IF(Lcap)THEN Spcstr(1:Numchr)=' Original Series (Table A1 or B1)' Numch2=16 ELSE Spcstr(1:Numchr)=' original series (Table A1 or B1)' END IF END IF ELSE IF(Spcsrs.eq.3)THEN Numchr=36 IF(Lcap)THEN Spcstr(1:Numchr)=' Modified Original Series (Table E1)' Numch2=25 ELSE Spcstr(1:Numchr)=' modified original series (Table E1)' END IF END IF c----------------------------------------------------------------------- RETURN END mkssky.f0000664006604000003110000000545614521201534011670 0ustar sun00315steps SUBROUTINE mkssky(Fnotky,Nssky,Nopt,Nop2) IMPLICIT NONE c----------------------------------------------------------------------- c Generate key for sliding spans table c----------------------------------------------------------------------- INTEGER PSSFL1,PSSFL3,PSSFL4,PSSTP,PSSSC,PSSNT PARAMETER(PSSFL1=1,PSSFL3=3,PSSFL4=4,PSSTP=5,PSSSC=6,PSSNT=7) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' c----------------------------------------------------------------------- INTEGER Fnotky,Nssky,Nopt,Nop2,i DIMENSION Fnotky(7) c----------------------------------------------------------------------- c Print an explanation for each footnote c----------------------------------------------------------------------- IF(Fnotky(PSSNT).eq.1)THEN WRITE(Mt1,1010) 1010 FORMAT(' NT - Observation not included in sliding spans ', & 'comparisons.',/) END IF c----------------------------------------------------------------------- IF(Fnotky(PSSSC).eq.1)THEN IF(Nop2.gt.0)THEN WRITE(Mt1,1070) 1070 FORMAT(' SC - A sign change can be found for this ', & 'observation.',/) ELSE WRITE(Mt1,1071) 1071 FORMAT(' IE - The estimates of this effect are ', & 'inconsistent for this observation;', & /,' one span indicates that the effect causes ', & 'an increase in the ', & /,' observed value, another that it causes a ', & 'decrease.',/) END IF END IF c----------------------------------------------------------------------- IF(Fnotky(PSSTP).eq.1)THEN WRITE(Mt1,1100) 1100 FORMAT(' TP - Span values for this observation have a ', & 'turning point.',/) END IF c----------------------------------------------------------------------- DO i=PSSFL1,PSSFL3 IF(Fnotky(i).gt.0)THEN WRITE(Mt1,1020)i,Ch(Nopt),Cut(Nopt,i),Cut(Nopt,i+1) 1020 FORMAT(' ',i1,a1,' - The maximum percentage difference is ', & 'greater than or equal to ',f4.1,'%',/, & ' but less than ',f4.1,'%.',/) END IF END DO IF(Fnotky(PSSFL4).eq.1)THEN WRITE(Mt1,1030)PSSFL4,Ch(Nopt),Cut(Nopt,PSSFL4) 1030 FORMAT(' ',i1,a1,' - The maximum percentage difference is ', & 'greater than or equal to ',f4.1,'%.',/) END IF c----------------------------------------------------------------------- WRITE(Mt1,1110) 1110 FORMAT(' ') c----------------------------------------------------------------------- RETURN END mkstlb.f0000664006604000003110000000447114521201534011637 0ustar sun00315steps SUBROUTINE mkstlb(Itbl,Spcstr,Nspstr,Spcsrs) IMPLICIT NONE c----------------------------------------------------------------------- INTEGER Itbl,Nspstr,Spcsrs,Lsumm CHARACTER Spcstr*(36) c----------------------------------------------------------------------- INCLUDE 'spctbl.i' c----------------------------------------------------------------------- IF(Itbl.eq.LSPTS0)THEN IF(Spcsrs.eq.0)THEN Nspstr=19 Spcstr(1:Nspstr)='Tukey(Spectrum_Ori)' ELSE IF(Spcsrs.eq.1)THEN Nspstr=25 Spcstr(1:Nspstr)='Tukey(Spectrum_OtlAdjOri)' ELSE IF(Spcsrs.eq.2)THEN Nspstr=22 Spcstr(1:Nspstr)='Tukey(Spectrum_AdjOri)' ELSE IF(Spcsrs.eq.3)THEN Nspstr=22 Spcstr(1:Nspstr)='Tukey(Spectrum_ModOri)' END IF ELSE IF(Itbl.eq.LSPT0C)THEN IF(Spcsrs.eq.0)THEN Nspstr=20 Spcstr(1:Nspstr)='Tukey(Spectrum_Comp)' ELSE IF(Spcsrs.eq.1)THEN Nspstr=26 Spcstr(1:Nspstr)='Tukey(Spectrum_OtlAdjComp)' ELSE IF(Spcsrs.eq.2)THEN Nspstr=23 Spcstr(1:Nspstr)='Tukey(Spectrum_AdjComp)' ELSE IF(Spcsrs.eq.3)THEN Nspstr=23 Spcstr(1:Nspstr)='Tukey(Spectrum_ModComp)' END IF ELSE IF(Itbl.eq.LSPTER)THEN Nspstr=22 Spcstr(1:Nspstr)='Tukey(Spectrum_ExtRsd)' ELSE IF(Itbl.eq.LSPTRS)THEN Nspstr=19 Spcstr(1:Nspstr)='Tukey(Spectrum_Rsd)' ELSE IF(Itbl.eq.LSPT1I)THEN Nspstr=21 Spcstr(1:Nspstr)='Tukey(Spectrum_IndSA)' ELSE IF(Itbl.eq.LSPT1S)THEN Nspstr=24 Spcstr(1:Nspstr)='Tukey(Spectrum_SA_SEATS)' ELSE IF(Itbl.eq.LSPTS1)THEN Nspstr=18 Spcstr(1:Nspstr)='Tukey(Spectrum_SA)' ELSE IF(Itbl.eq.LSPT2I)THEN Nspstr=22 Spcstr(1:Nspstr)='Tukey(Spectrum_IndIrr)' ELSE IF(Itbl.eq.LSPT2S)THEN Nspstr=25 Spcstr(1:Nspstr)='Tukey(Spectrum_Irr_SEATS)' ELSE IF(Itbl.eq.LSPTS2)THEN Nspstr=19 Spcstr(1:Nspstr)='Tukey(Spectrum_Irr)' ELSE Nspstr=15 Spcstr(1:Nspstr)='Tukey(Spectrum)' END IF c----------------------------------------------------------------------- RETURN ENDmktdlb.f0000664006604000003110000000407614521201534011621 0ustar sun00315steps SUBROUTINE mktdlb(Tdstr,Ntdchr,Itdtst,Aicstk,Aicrgm,Tdzero,Sp) IMPLICIT NONE c ------------------------------------------------------------------ c Generate string for label of trading day effect within AIC test c for trading day c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER tdstr*(30),datstr*(10) INTEGER Itdtst,Aicrgm,Aicstk,Ntdchr,nchdat,Tdzero,Sp DIMENSION Aicrgm(2) c----------------------------------------------------------------------- CALL setchr(' ',30,tdstr) IF(Itdtst.eq.1)THEN ntdchr=2 tdstr(1:ntdchr)='td' ELSE IF(Itdtst.eq.2)THEN ntdchr=10 tdstr(1:ntdchr)='tdnolpyear' ELSE IF(Itdtst.eq.4)THEN ntdchr=7 tdstr(1:ntdchr)='td1coef' ELSE IF(Itdtst.eq.5)THEN ntdchr=11 tdstr(1:ntdchr)='td1nolpyear' ELSE IF(Itdtst.eq.6)THEN ntdchr=13 tdstr(1:ntdchr)='tdstock1coef[' ELSE ntdchr=8 tdstr(1:ntdchr)='tdstock[' END IF ntdchr=ntdchr+1 CALL itoc(Aicstk,tdstr,ntdchr) IF(Lfatal)RETURN tdstr(ntdchr:ntdchr)=']' END IF IF(Aicrgm(1).ne.NOTSET)THEN CALL wrtdat(Aicrgm,Sp,datstr,nchdat) IF(Lfatal)RETURN IF(Tdzero.eq.0)THEN tdstr((ntdchr+1):(ntdchr+nchdat+2))='/'//datstr(1:nchdat)//'/' ntdchr=ntdchr+nchdat+2 ELSE IF(Tdzero.eq.1)THEN tdstr((ntdchr+1):(ntdchr+nchdat+3))='/'//datstr(1:nchdat)//'//' ntdchr=ntdchr+nchdat+3 ELSE IF(Tdzero.eq.2)THEN tdstr((ntdchr+1):(ntdchr+nchdat+4))='//'//datstr(1:nchdat)//'//' ntdchr=ntdchr+nchdat+4 ELSE tdstr((ntdchr+1):(ntdchr+nchdat+3))='//'//datstr(1:nchdat)//'/' ntdchr=ntdchr+nchdat+3 END IF END IF c----------------------------------------------------------------------- RETURN END mlist.f0000664006604000003110000001177214521201534011475 0ustar sun00315stepsC Last change: BCM 26 Feb 1999 3:40 pm **==mlist.f processed by SPAG 4.03F at 12:23 on 21 Jun 1994 SUBROUTINE mlist(X,Nopt,Nop2,Dmax,N48,Iagr,Ext,Eststr,Nstr,Ncol,Y, & Period,Ssdiff) IMPLICIT NONE c----------------------------------------------------------------------- C ***** PRINTS OUT EACH OBSERVATION IN SLIDING SPANS ANALYSIS, WITH C ***** DATE, ESTIMATES (EXAMPLE, SEASONAL FACTORS) FOR EACH SPAN, C ***** MAXIMUM PERCENTAGE DIFFERENCE (DMAX), AND AN INDICATION OF C ***** WHETHER THE OBSERVATION WAS FLAGGED AS AN EXTREME (PER) C ***** OR CHANGED DIRECTION (CSIGN). c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'sspvec.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION Dmax,X LOGICAL Ssdiff,l2Big CHARACTER cagr*(31),dash*(1),Eststr*(45),Ext*(2),f*(7),blank8*(8), & cfirst*(11),fnotvc*(10) INTEGER i,Iagr,iy,l,l0,l1,l2,Nstr,m,N48,Nop2,Nopt,Y,Period,nagr, & Ncol,nfirst,nc,nt,fnotky,nssky DIMENSION dash(3),X(MXLEN,MXCOL),Dmax(MXLEN,NEST),f(3),Y(2*MXCOL), & Period(2*MXCOL),nfirst(2),cfirst(2),fnotvc(MXLEN), & fnotky(7) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- DATA dash/'-','/',' '/ DATA f/'MAXIMUM',' % DIFF',' DIFF'/ DATA cfirst/'seasonal','trading day'/ DATA nfirst/8,11/ c----------------------------------------------------------------------- iy=Iyr m=Im-1 IF(Iagr.eq.5)THEN cagr=': Direct seasonal adjustment.' nagr=29 ELSE IF(Iagr.eq.6)THEN cagr=': Indirect seasonal adjustment.' nagr=31 ELSE cagr='.' nagr=1 END IF blank8=' ' c----------------------------------------------------------------------- c Check to see if series is too large to be printed - if so, c switch to scientific format. c added by BCM Dec 2005 c----------------------------------------------------------------------- l2Big=.false. IF(Nopt.ge.3.or.Ssdiff)THEN DO l1=1,Ncol DO l2=Im,Sslen+Im-1 IF(.not.dpeq(X(l2,l1),DNOTST))THEN IF(X(l2,l1).gt.999999.99 .or. X(l2,l1).lt.-99999.99) & l2Big=.true. IF(l2Big)GO TO 1000 END IF END DO END DO END IF 1000 CONTINUE c----------------------------------------------------------------------- c Generate footnotes for table (BCM, December 2006) c----------------------------------------------------------------------- CALL ssfnot(Nopt,Nop2,fnotvc,fnotky,nssky) c----------------------------------------------------------------------- c Print out complete sliding spans information, with up to 48 c observations on a page. c----------------------------------------------------------------------- DO l0=1,N48 l1=(l0-1)*48+Im l2=l0*48+Im-1 IF(l0.eq.N48)l2=Sslen+Im-1 IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1020)Ext,Eststr(1:Nstr),Serno(1:Nser),cagr(1:nagr) 1020 FORMAT(' S 7.',a2,' Sliding spans analysis of ',a,' for ',a,a) WRITE(Mt1,1030) WRITE(Mt1,F2)(Period(i),dash(2),Y(i),dash(1),i=1,Ncol),f(1), & blank8 IF(Nop2.eq.0.AND.(.not.Ssdiff))THEN WRITE(Mt1,F2)(Period(Ncol+i),dash(2),Y(Ncol+i),dash(3), & i=1,Ncol),f(2),'Footnote' ELSE WRITE(Mt1,F2)(Period(Ncol+i),dash(2),Y(Ncol+i),dash(3), & i=1,Ncol),f(3),'Footnote' END IF WRITE(Mt1,1030) 1030 FORMAT(' ') nc=0 nt=0 DO l=l1,l2 m=m+1 IF(m.gt.Nsea)THEN m=1 iy=iy+1 END IF CALL wrtmss(m,iy,X,Dmax,Ncol,Nopt,l,fnotvc(l),l2big) END DO END DO c----------------------------------------------------------------------- IF(nssky.gt.0)THEN c----------------------------------------------------------------------- c Print header for footnotes on separate page c----------------------------------------------------------------------- IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1040)Ext,Eststr(1:Nstr),Serno(1:Nser),cagr(1:nagr) 1040 FORMAT(' Footnotes for Table S7.',a2,':',/, & ' Sliding spans analysis of ',a,' for ',a,a,/) CALL mkssky(fnotky,nssky,Nopt,Nop2) WRITE(Mt1,1030) END IF c----------------------------------------------------------------------- RETURN END mltpos.f0000664006604000003110000000514714521201534011662 0ustar sun00315stepsC Last change: BCM 25 Nov 97 12:17 pm SUBROUTINE mltpos(Nelta,Arimap,Arimal,Opr,Begopr,Endopr,Neltc,C) IMPLICIT NONE c---------------------------------------------------------------------- c Filters the matrix, a, using the Difference, AR, and MA operators c a=[Diff(B)*phi(B)/th(B)]*z, c where the MA is filtered exactly or conditionally depending on exctMA. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ INTEGER PXA PARAMETER(PXA=(PB+1)*(PLEN+2*PORDER)) c ------------------------------------------------------------------ LOGICAL secpas INTEGER Arimal,beglag,Begopr,endlag,Endopr,i,ilag,iopr,itmp,Nelta, & Neltc,Opr DOUBLE PRECISION C,Arimap,tmp,work DIMENSION Arimal(*),Arimap(*),C(*),Opr(0:*),work(PXA) c----------------------------------------------------------------------- c Note c is the a matrix on input. First c calculate the number of elements in the c/a matrices c----------------------------------------------------------------------- secpas=.false. DO iopr=Begopr,Endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c----------------------------------------------------------------------- c Calculate the c(i)'s, i=lagb(nlag)+1,lag(nlag+1) c----------------------------------------------------------------------- DO i=1,Neltc IF(secpas.or.i.le.Nelta)THEN tmp=C(i) c ------------------------------------------------------------------ ELSE tmp=ZERO END IF c----------------------------------------------------------------------- c Calculate c(i) c----------------------------------------------------------------------- DO ilag=beglag,endlag itmp=i-Arimal(ilag) IF(itmp.gt.0.and.(secpas.or.itmp.le.Nelta))tmp=tmp-Arimap(ilag) & *C(itmp) END DO c ------------------------------------------------------------------ work(i)=tmp END DO c ------------------------------------------------------------------ secpas=.true. CALL copy(work,Neltc,1,C) END DO c ------------------------------------------------------------------ RETURN END model.cmn0000664006604000003110000001604614521201535011775 0ustar sun00315stepsc----------------------------------------------------------------------- c Common for model description that is independant of the data. c----------------------------------------------------------------------- c Colttl - data dictionary for the names of the regression variables c Grpttl - data dictionary for the names of groups of regression c variables c Mdlttl - title for ARIMA model c Mdldsn - description of the ARIMA model (ie, (0 1 1)(0 1 1)) c Oprttl - data dictionary for the names of the ARIMA parameters c----------------------------------------------------------------------- CHARACTER Colttl*(PCOLCR*PB),Grpttl*(PGRPCR*PGRP),Mdlttl*(PMDLCR), & Mdldsn*(132),Oprttl*(POPRCR*POPR) c----------------------------------------------------------------------- c Arimaf - logical array which indicates which of the ARIMA c parameters are to be held fixed c Lar - logical scalar which indicates that exact ML estimation c will be done for the AR parameters and that a model c with AR terms has been specified c Lcalcm - logical scalar which indicates whether errors have c occured during the model estimation c Lextar - logical scalar which indicates that exact ML estimation c will be done for the AR parameters c Lextma - logical scalar which indicates that exact ML estimation c will be done for the MA parameters c Lma - logical scalar which indicates that exact ML estimation c will be done for the MA parameters and that a model c with MA terms has been specified c Lsidsf - logical scalar which indicates that a seasonal difference c was selected in the identify spec c Lseadf - logical scalar which indicates that a seasonal difference c is contained in the current model being processed c Lseff - logical scalar which indicates that stable seasonal c regressors are contained in the current model being c processed c Lrgmse - logical scalar which indicates that seasonal change of c regime regressors are contained in the current model being c processed c Lprier - logical scalar which indicates that iteration errors c are to be printed out c Regfx - logical array which indicates which of the regression c parameters are to be held fixed c----------------------------------------------------------------------- LOGICAL Arimaf,Lar,Lcalcm,Lextar,Lextma,Lma,Lidsdf,Lprtdf, & Lseadf,Lseff,Lprier,Lrgmse,Regfx,Userfx,Lmvaft,Ln0aft c----------------------------------------------------------------------- c Arimal - lags of the ARIMA model parameters c Colptr - pointers for the regression variable data dictionary c Grp - pointers for regression groups c Grpptr - pointers for regression groups names data dictionary c Mdl - pointers for types of ARIMA model parameters (AR, Diff, MA) c Nb - number of regression variables c Ncoltl - length of Colttl c Ncxy - number of columns in Xy regression matrix c Nestpm - Number of estimated ARIMA model parameters c Nextvl - Number of observations to be excluded from the c number of effective observations c Ngrp - number of regression variable groups c Ngrptl - length of Grpttl c Nintvl - sum of the maximum differencing lag and maximum AR lag c Nmdl - number of types of ARIMA operators in Mdl c Nmdlcr - length of Mdlttl c Nmddcr - length of Mdldsn c Nnsedf - number of non-seasonal differences c Nopr - number of pointers in Opr c Noptrl - length of Oprttl c Nseadf - number of seasonal differences c Opr - pointers for ARIMA model parameters c Oprfac - ARIMA model parameters factors c Oprptr - pointers for the data dictionary Oprttl c Mxarlg - maximum AR lag c Mxdflg - maximum differencing lag c Mxmalg - maximum MA lag c Rgvrtp - indicator variable denoting regression variable type - c see model.prm for more details c Sp - length of seasonal period (monthly=12, quarterly=4) c Easidx : Integer indicator variable for type of Easter regressor c (0=default,1=sunday,2=monday,3=statcan) c Iregfx - Integer indicator variable for fixed regressors c (0=default,1=initial values specified for regressors, c 2=regressors fixed for some initial values, c 3=regressors fixed at initial values.) c Imdlfx - Integer scalar which indicates that the ARIMA model c parameters are fixed c (0=default,1=initial values specified for ARIMA model c parameters,2=model parameters fixed for some initial c values, 3=model parameters fixed at initial values.) c Fixmdl - Integer scalar which controls what regARIMA model c coefficients read in from Mdlfil are fixed (-1=no change, c 0=none,1=arma,2=regression,3=all) c Natotl - Integer scalar which indicates how many automatic c outliers are identified in the regARIMA model c----------------------------------------------------------------------- INTEGER Arimal,Colptr,Grp,Grpptr,Mdl,Nb,Ncoltl,Ncxy,Nestpm,Fixmdl, & Nextvl,Ngrp,Ngrptl,Nintvl,Nmdl,Nmdlcr,Nmddcr,Nnsedf,Nopr, & Noprtl,Nseadf,Opr,Oprfac,Oprptr,Mxarlg,Mxdflg,Mxmalg, & Rgvrtp,Sp,Easidx,Iregfx,Imdlfx,Natotl,Iqtype,Isrflw c----------------------------------------------------------------------- c Nltol - convergance tolerance for non-linear estimation c Nltol0 - initial ARMA convergance tolerance c Tol - global convergance tolerance c Tcalfa - alpha that controls the shape of temporary change c outliers c Acflim - limit of acf/se or pacf/se c Qcheck - p-value limit for ACF Q c----------------------------------------------------------------------- DOUBLE PRECISION Nltol,Nltol0,Tol,Tcalfa,Stepln,Acflim,Ap1,Qcheck c----------------------------------------------------------------------- DIMENSION Arimaf(PARIMA),Arimal(PARIMA),Colptr(0:PB),Regfx(PB), & Grp(0:PGRP),Grpptr(0:PGRP),Mdl(0:3*PMDL),Opr(0:POPR), & Oprfac(POPR),Oprptr(0:POPR),Rgvrtp(PB),Ap1(PARIMA) c ------------------------------------------------------------------ COMMON /cmdl / Nltol0,Nltol,Tol,Tcalfa,Acflim,Qcheck,Stepln,Ap1, & Arimal,Colptr,Easidx,Grp,Grpptr,Mdl,Natotl,Nb, & Ncoltl,Ncxy,Nestpm,Nextvl,Ngrp,Ngrptl,Nintvl,Nmdl, & Nmdlcr,Nmddcr,Nnsedf,Nopr,Noprtl,Nseadf,Opr, & Oprfac,Oprptr,Mxarlg,Mxdflg,Mxmalg,Rgvrtp,Sp, & Isrflw,Iqtype,Iregfx,Imdlfx,Fixmdl,Arimaf,Lmvaft, & Ln0aft,Regfx,Userfx,Lar,Lcalcm,Lextar,Lextma,Lma, & Lidsdf,Lprtdf,Lseadf,Lseff,Lprier,Lrgmse,Colttl, & Grpttl,Mdlttl,Mdldsn,Oprttl model.prm0000664006604000003110000002346614521201535012022 0ustar sun00315stepsc----------------------------------------------------------------------- c Change these parameters as needed c----------------------------------------------------------------------- c PB - maximum number of regressors c PUREG - maximum number of user-defined regressors c PUHLGP - maximum number of groups of user-defined holiday C regressors c PEASTR - maximum number of Easter regressors c PORDER - maximum order of ARMA parameters c PDFLG - maximum number of differencing lags c----------------------------------------------------------------------- INTEGER PB,PUREG,PDFLG,PORDER,PDIFOR,PEASTR,PUHLGP PARAMETER(PB=80, & PUREG=52, & PORDER=3*PSP, & PDIFOR=4*PORDER, & PDFLG=3, & PEASTR=3, & PUHLGP=5) c----------------------------------------------------------------------- c Do not change parameters below this line (or change at your own c risk. c----------------------------------------------------------------------- c Codes for the different type of regression variables c Name Code c----------------------------------------------------------------------- c Constant PRGTCN c Seasonal PRGTSE c Trigonometric Seasonal PRGTTS c Trading Day PRGTTD c Length-of-Month PRGTLM c Length-of-Quarter PRGTLQ c Leap Year PRGTLY c Stock Trading Day PRGTST c Stock Length-of-Month PRGTSL c Easter PRGTEA c Labor Day PRGTLD c Thanksgiving PRGTTH c AO PRGTAO c LS PRGTLS c Rp PRGTRP c Automatically Identified AO PRGTAA c Automatically Identified LS PRGTAL c User Defined PRGTUD c Change-of-Regime Seasonal PRRTSE c Change-of-Regime Trigonometric Seasonal PRRTTS c Change-of-Regime Trading Day PRRTTD c Change-of-Regime Length-of-Month PRRTLM c Change-of-Regime Length-of-Quarter PRRTLQ c Change-of-Regime Leap Year PRRTLY c Change-of-Regime Stock Trading Day PRRTST c Change-of-Regime Stock Length-of-Month PRRTSL c User Defined Holiday PRGTUH c User Defined Holiday Group 2 PRGUH2 c User Defined Holiday Group 3 PRGUH3 c User Defined Holiday Group 4 PRGUH4 c User Defined Holiday Group 5 PRGUH5 c Missing Value Regressor PRGTMV c Statistics Canada Easter PRGTEC c Change-of-Regime Seasonal (reg after) PRATSE c Change-of-Regime Trigonometric Seasonal (reg after) PRATTS c Change-of-Regime Trading Day (reg after) PRATTD c Change-of-Regime Length-of-Month (reg after) PRATLM c Change-of-Regime Length-of-Quarter (reg after) PRATLQ c Change-of-Regime Leap Year (reg after) PRATLY c Change-of-Regime Stock Trading Day (reg after) PRATST c Change-of-Regime Stock Length-of-Month (reg after) PRATSL c User Defined Seasonal PRGTUS c TC PRGTTC c Automatically Identified TC PRGTAT c Trading Day (1 coef) PRG1TD c Change-of-Regime Trading Day (1 coef) PRR1TD c Change-of-Regime Trading Day (1 coef, reg after) PRA1TD c seasonal outlier PRGTSO c Stock Trading Day (1 coef) PRG1ST c Change-of-Regime Stock Trading Day (1 coef) PRR1ST c Change-of-Regime Stock Trading Day c (1 coef, reg after) PRA1ST c user-defined assigned to the transitory PRGCYC c End of Month Stock Easter PRGTES c Temporary Level Shift PRGTTL c Quadratic Ramp, Increasing PRGTQI c Quadratic Ramp, Decreasing PRGTQD c AO Sequence PRSQAO c LS Sequence PRSQLS c----------------------------------------------------------------------- INTEGER PRGTCN,PRGTSE,PRGTTS,PRGTTD,PRGTLM,PRGTLQ,PRGTLY,PRGTST, & PRGTSL,PRGTEA,PRGTLD,PRGTTH,PRGTAO,PRGTLS,PRGTRP,PRGTAA, & PRGTAL,PRGTUD,PRRTSE,PRRTTS,PRRTTD,PRRTLM,PRRTLQ,PRRTLY, & PRRTST,PRRTSL,PRGTUH,PRGTMV,PRGTEC,PRATSE,PRATTS,PRATTD, & PRATLM,PRATLQ,PRATLY,PRATST,PRATSL,PRGTUS,PRGTTC,PRGTAT, & PRG1TD,PRR1TD,PRA1TD,PRGTSO,PRG1ST,PRR1ST,PRA1ST,PRGUH2, & PRGUH3,PRGUH4,PRGUH5,PRGCYC,PRGTES,PRGTTL,PRGTQI,PRGTQD, & PRSQAO,PRSQLS,PRGUTD,PRGULM,PRGULQ,PRGULY,PRGUAO,PRGULS, & PRGUSO,PRGUCN,PRGUCY PARAMETER(PRGTCN=1,PRGTSE=2,PRGTTS=3,PRGTTD=4,PRGTLM=5, & PRGTLQ=6,PRGTLY=7,PRGTST=8,PRGTSL=9,PRGTEA=10, & PRGTLD=11,PRGTTH=12,PRGTAO=13,PRGTLS=14,PRGTRP=15, & PRGTAA=16,PRGTAL=17,PRGTUD=18,PRRTSE=19,PRRTTS=20, & PRRTTD=21,PRRTLM=22,PRRTLQ=23,PRRTLY=24,PRRTST=25, & PRRTSL=26,PRGTES=27,PRGTMV=28,PRGTEC=29,PRATSE=30, & PRATTS=31,PRATTD=32,PRATLM=33,PRATLQ=34,PRATLY=35, & PRATST=36,PRATSL=37,PRGTUS=38,PRGTTC=39,PRGTAT=40, & PRG1TD=41,PRR1TD=42,PRA1TD=43,PRGTQI=44,PRGTQD=45, & PRG1ST=46,PRR1ST=47,PRA1ST=48,PRGTUH=49,PRGUH2=50, & PRGUH3=51,PRGUH4=52,PRGUH5=53,PRGTTL=54,PRGTSO=55, & PRGCYC=56,PRGUTD=57,PRGULM=58,PRGULQ=59,PRGULY=60, & PRGUAO=61,PRGULS=62,PRGUSO=63,PRGUCN=64,PRGUCY=65, & PRSQAO=113,PRSQLS=114) c----------------------------------------------------------------------- c Estimation error codes c----------------------------------------------------------------------- c PUNKER=1 Estimation error with unknown cause c PSNGER=2 Xy is singular in rgarma c PISNER=3 Xy is singular in the identify spec c PINPER=4 Imporper input parameters (should never occur) c PMXIER=5 Exceeded the maximum iterations c PSCTER=6 Too strict convergence tolerance c PSPMER=7 Relative difference in the parameter estimates too strict c PCOSER=8 Cosine between the espected values and any column of the c jacobian is too small c PNIMER=9 Can't invert the operator because of missing lags c PNIFER=10 Can't invert the operator because of fixed lags c PGPGER=11 Can't invert the G'G matrix c PACFER=12 Can't calculate the ARMA ACFs c PVWPER=13 Can't calculate var(w_p|z) c PCNTER=14 Convergence tolerance is less than machine precision c PDVTER=15 Deviance is less than machine precision c PINVER=16 MA operator is not invertibile c PMXFER=17 Exceeded the maximum function evaluations c PACSER=18 Covariance matrix of the ARMA parameters singular c POBFN0=19 Objective function = 0 c----------------------------------------------------------------------- INTEGER PUNKER,PSNGER,PISNER,PINPER,PMXIER,PSCTER,PSPMER,PCOSER, & PNIMER,PNIFER,PGPGER,PACFER,PVWPER,PCNTER,PDVTER,PINVER, & PMXFER,PACSER,POBFN0 PARAMETER(PUNKER=1,PSNGER=2,PISNER=3,PINPER=4,PMXIER=5,PSCTER=6, & PSPMER=7,PCOSER=8,PNIMER=9,PNIFER=10,PGPGER=11, & PACFER=12,PVWPER=13,PCNTER=14,PDVTER=15,PINVER=16, & PMXFER=17,PACSER=18,POBFN0=19) c----------------------------------------------------------------------- c Parameters for the regression and ARIMA model data structure c----------------------------------------------------------------------- INTEGER AR,DIFF,MA,MO,YR,AO,LS,RP,MV,TC,SO,TLS,POTLR,PAICT,PTDAIC, & PLAIC,PEAIC,PUAIC,QI,QD,PAICEA PARAMETER(AR=2,DIFF=1,MA=3,MO=2,YR=1,AO=1,LS=2,TC=3,RP=4, & MV=5,TLS=6,SO=7,QI=8,QD=9,POTLR=3,PAICEA=PEASTR+2, & PAICT=4,PTDAIC=1,PLAIC=2,PEAIC=3,PUAIC=4) c ------------------------------------------------------------------ INTEGER PARIMA,PCOLCR,PGRP,PGRPCR,PMDL,PMDLCR,POPRCR,PUSERX c* Increased to handle the multi-step-ahead-forecast psi-weight operator c PARAMETER(PARIMA=25,PCOLCR=25,PGRP=PB,PGRPCR=60,PMDL=1,PMDLCR=60, c & POPRCR=60) PARAMETER(PARIMA=(2*PSP)+PDIFOR-PORDER+1,PCOLCR=23,PGRP=PB, & PGRPCR=72,PMDL=1,PMDLCR=72,POPRCR=72,PUSERX=PLEN*PUREG) C ------------------------------------------------------------------ INTEGER POPR,PGPG,PXPX PARAMETER (PGPG=PORDER*(PORDER+1)/2,PXPX=(PB+2)*(PB+3)/2, & POPR=9*PMDL) c----------------------------------------------------------------------- c Default convergence parameters for the IGLS, initial nonlinear c estimation(s), the rest of the nonlinear estimations. c----------------------------------------------------------------------- DOUBLE PRECISION DFTOL,DFNLT0,DFNLTL PARAMETER(DFTOL=1D-5,DFNLT0=100D0*DFTOL,DFNLTL=DFTOL) c----------------------------------------------------------------------- INTEGER PFILMD PARAMETER(PFILMD=127) c----------------------------------------------------------------------- models.i0000664006604000003110000000120114521201535011616 0ustar sun00315stepsC C... Variables in Common Block /models/ ... integer NADJS,NCHCYC,NCYCS,NTHETC,NTOTD,NTHETP,QSTAR0,NCHIS,NPSI, $ NPSIS,NTHETS,NTHADJ real*8 CHI(8),CHIS(17),CHINS(8),THSTR0(40),THETP(8),PSI(27), $ PSIS(16),PSINS(27),THETS(27),THADJ(32),ADJS(17),ADJNS(8), $ CHCYC(20),CYCS(17),CYC(17),CYCNS(5),THETC(32),TOTDEN(40) common /models/ CHI,CHIS,CHINS,THSTR0,THETP,PSI,PSIS,PSINS,THETS, $ THADJ,ADJS,ADJNS,CHCYC,CYCS,CYC,CYCNS,THETC, $ TOTDEN,NADJS,NCHCYC,NCYCS,NTHETC,NTOTD,NTHETP, $ QSTAR0,NCHIS,NPSI,NPSIS,NTHETS,NTHADJ month.f0000664006604000003110000000205214521201535011462 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:30 pm **==month.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE month(Icode,Jx) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'error.cmn' INCLUDE 'chrt.cmn' c----------------------------------------------------------------------- INTEGER Icode,Jx,l,nyr2 CHARACTER itype*1 c DOUBLE PRECISION Ab2(61) c----------------------------------------------------------------------- C PLOT CHART TYPES 7 AND 8 (MONTHLY CHARTS) c----------------------------------------------------------------------- CALL grzmth(Ibeg2,Ienda) DO l=1,Nseas nyr2=Nyr IF((l.lt.Ifrst).or.(l.gt.Last))nyr2=Nyr-1 CALL grzmyr(l) itype=Ialpha(l) IF(Nseas.eq.4)itype=Ialphq(l) CALL aver(Ab1,nyr2,itype,Icode,0,Jx) IF(Lfatal)RETURN END DO c----------------------------------------------------------------------- RETURN END mq3.cmn0000664006604000003110000000137214521201535011371 0ustar sun00315stepsc----------------------------------------------------------------------- c Pcdif - label text : "differences" if additive adjustment, else c "percent change" c Rad - label text : "differences" if additive adjustment, else c "ratios" c Moqu - label text : "month" if monthly data, "quarter" if not c Qm - label text : "monthly" if monthly data, "quarterly" if not c Mqcd - label text : "mcd" if monthly data, "qcd" if not c----------------------------------------------------------------------- CHARACTER Pcdif*(15),Rad*(11),Moqu*(7),Qm*(9),Mqcd*(3) c----------------------------------------------------------------------- COMMON /mq3 / Pcdif,Rad,Moqu,Qm,Mqcd mstest.f0000664006604000003110000001312314521201535011655 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 11:09 pm SUBROUTINE mstest(Array,Jfda,Jlda,Nyr,Lprt) IMPLICIT NONE c----------------------------------------------------------------------- C --- AN F TEST FOR MOVING SEASONALITY c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssft.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'tests.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- DOUBLE PRECISION Array,Temp,fvalue,suma1,xbar,colss,colmn,rowss, & rowmn,fnyr,totss,errss,degfre,fnoyrs,rowssn, & errssn,c CHARACTER bk*2,s1*2,s2*2,fstar*2,xb*50 INTEGER i,i1,ifmo,j,j1,Jfda,Jlda,k,k1,l,l1,lmo,m,n,n1,ndgfre, & nmin1,noyrs,Nyr,sp1 LOGICAL Lprt DIMENSION Temp(PLEN) c----------------------------------------------------------------------- COMMON /work / Temp c----------------------------------------------------------------------- DIMENSION Array(Jlda) c Bob Fay moved EXTERNAL up LOGICAL dpeq EXTERNAL dpeq,fvalue c----------------------------------------------------------------------- DATA s1,s2,bk/'* ','**',' '/ c ------------------------------------------------------------------ c=ONE sp1=0 IF(Lwdprt)sp1=18 xb=' ' ifmo=(Jfda+Nyr-2)/Nyr*Nyr+1 lmo=Jlda/Nyr*Nyr noyrs=(lmo-ifmo)/Nyr+1 fnoyrs=noyrs IF(Muladd.eq.0)THEN c----------------------------------------------------------------------- C -- MULTIPLICATIVE MODEL c----------------------------------------------------------------------- c=10000.0D0 DO j=ifmo,lmo Temp(j)=abs(Array(j)-ONE) END DO ELSE c----------------------------------------------------------------------- C --- ADDITIVE MODEL c----------------------------------------------------------------------- DO i=ifmo,lmo Temp(i)=abs(Array(i)) END DO END IF c----------------------------------------------------------------------- C --- ANALYSIS OF VARIANCE TEST c----------------------------------------------------------------------- suma1=ZERO DO k=ifmo,lmo suma1=suma1+Temp(k) END DO fnyr=Nyr xbar=suma1/(fnyr*fnoyrs) colss=ZERO DO l=1,Nyr colmn=ZERO k1=ifmo+l-1 DO m=k1,lmo,Nyr colmn=colmn+Temp(m) END DO colmn=colmn/fnoyrs colss=colss+(colmn-xbar)*(colmn-xbar) END DO colss=colss*fnoyrs*c rowss=ZERO DO n=ifmo,lmo,Nyr rowmn=ZERO l1=n+Nyr-1 DO i1=n,l1 rowmn=rowmn+Temp(i1) END DO rowmn=rowmn/fnyr rowss=rowss+(rowmn-xbar)*(rowmn-xbar) END DO rowss=rowss*fnyr*c totss=ZERO DO j1=ifmo,lmo totss=totss+(Temp(j1)-xbar)*(Temp(j1)-xbar) END DO errss=totss*c-colss-rowss degfre=fnoyrs-ONE rowssn=rowss/degfre errssn=errss/((fnyr-ONE)*degfre) ndgfre=(Nyr-1)*(noyrs-1) IF(dpeq(errssn,ZERO))THEN CALL errhdr WRITE(Mt1,1001)xb(1:(sp1+12)),xb(1:(sp1+12)) WRITE(Mt2,1001)' WARNING: ',xb(1:10) 1001 FORMAT(/,a,'Cannot compute moving F-statistic since residual ', & 'mean square', & /,a,'error is equal to zero for this series.') RETURN END IF Fmove=rowssn/errssn n1=noyrs-1 P2=fvalue(Fmove,n1,ndgfre)*100D0 IF(Issap.eq.2)Ssmf(Icol)=Fmove c----------------------------------------------------------------------- IF(.not.Lprt.or.Lhiddn)RETURN c----------------------------------------------------------------------- IF(P2.le.0.1D0)THEN fstar=s2 ELSE IF(P2.gt.ONE)THEN fstar=bk ELSE fstar=s1 END IF nmin1=noyrs-1 IF(Lcmpaq)THEN WRITE(Mt1,1011) 1011 FORMAT(/,' Moving Seasonality Test'/) WRITE(Mt1,1021)xb(1:(sp1+21)),xb(1:(sp1+5)),rowss, & nmin1,rowssn,Fmove,fstar,xb(1:(sp1+13)),errss, & ndgfre,errssn 1021 FORMAT(a,'Sum of squares',2x,'Dgrs.freedom',2x,'Mean square',5x, & 'F-value',/,a,'Between Years', & f17.4,i9,f17.6,f12.3,a2,/,a,'Error',f17.4,i9,f17.6,/) ELSE WRITE(Mt1,1010)xb(1:(sp1+2)) 1010 FORMAT(//,a,'Moving Seasonality Test') WRITE(Mt1,1020)xb(1:(sp1+25)),xb(1:(sp1+24)),xb(1:(sp1+3)),rowss, & nmin1,rowssn,Fmove,fstar,xb(1:(sp1+11)),errss, & ndgfre,errssn 1020 FORMAT(a,'Sum of',5x,'Dgrs.of',9x,'Mean',/,a,'Squares',5x, & 'Freedom',8x,'Square',7x,'F-value',/,a,'Between Years', & f17.4,i9,f17.6,f12.3,a2,/,a,'Error',f17.4,i9,f17.6,/) END IF IF(fstar.ne.bk)THEN WRITE(Mt1,1030)xb(1:(sp1+10)),fstar 1030 FORMAT(a,A2, & 'Moving seasonality present at the one percent level.') RETURN ELSE IF(P2.ge.5D0)THEN WRITE(Mt1,1040)xb(1:(sp1+10)),fstar 1040 FORMAT(a,A2, & 'No evidence of moving seasonality at the five percent level.') RETURN END IF WRITE(Mt1,1050)xb(1:(sp1+12)) 1050 FORMAT(a,'Moving seasonality present at the five percent level.') RETURN END mulmat.f0000664006604000003110000006662714521201535011656 0ustar sun00315stepsc----------------------------------------------------------------------- c mulMat.f, Release 1, Subroutine Version 1.1, Modified 13 Jan 2006. c----------------------------------------------------------------------- SUBROUTINE mulMat( mA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 04 Apr 2005. c Modified by REG, on 13 Jan 2006, to combine with other matrix c multiplication utilities mulMatTr() and mulTrMat(). c----------------------------------------------------------------------- c This subroutine calculates the matrix product of mC = mA x mB c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to be multiplied c mB d second input matrix to be multiplied c mC d matrix output result of mA x mB c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c ddot d external function reference c i,j i index variables for do loops c vD d used as temporary storage for a row of mA c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nB(1), nB(2) ), & mC( nA(1), nB(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j DOUBLE PRECISION vD( nA(2) ), ddot c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF ( nA(2) .eq. nB(1) ) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(1) nC(2) = nB(2) c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA x mB. c----------------------------------------------------------------------- DO i = 1, nC(1) c ------------------------------------------------------------------ c Move row i of A to temporary vector vD. c ------------------------------------------------------------------ DO j = 1, nA(2) vD(j) = mA( i, j ) END DO c ------------------------------------------------------------------ c Compute dot product of mA row i (from vD) x mB column j. c ------------------------------------------------------------------ DO j = 1, nC(2) mC(i,j) = ddot( nA(2), vD(1), 1, mB(1,j), 1 ) END DO END DO c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulMatTr( mA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 09 Jun 2005. c----------------------------------------------------------------------- c This subroutine calculates the matrix product of mC = mA x mB' c where mB' represents the transpose of mB and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to be multiplied c mB d second input matrix to be multiplied after transpose c mC d matrix output result of mA x mB' c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c ddot d external function reference c i,j i index variables for do loops c vD d used as temporary storage for a row of mA c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nB(1), nB(2) ), & mC( nA(1), nB(1) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j DOUBLE PRECISION vD( nA(2) ), ddot c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF ( nA(2) .eq. nB(2) ) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(1) nC(2) = nB(1) c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA x mB'. c----------------------------------------------------------------------- DO i = 1, nC(1) c ------------------------------------------------------------------ c Move row i of A to temporary vector vD. c ------------------------------------------------------------------ DO j = 1, nA(2) vD(j) = mA( i, j ) END DO c ------------------------------------------------------------------ c Compute dot product of mA row i (from vD) x mB row j. c ------------------------------------------------------------------ DO j = 1, nC(2) mC(i,j) = ddot( nA(2), vD(1), 1, mB(j,1), nB(1) ) END DO END DO c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulTrMat( mA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c Changes: c Created by REG, 23 Aug 2005. c----------------------------------------------------------------------- c This subroutine calculates the matrix product of mC = mA' x mB c where mA' represents the transpose of mA and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to be multiplied c mB d second input matrix to be multiplied after transpose c mC d matrix output result of mA' x mB c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c ddot d external function reference c i,j i index variables for do loops c vD d used as temporary storage for a row of mA c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nB(1), nB(2) ), & mC( nA(2), nB(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j DOUBLE PRECISION vD( nA(1) ), ddot c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF ( nA(1) .eq. nB(1) ) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(2) nC(2) = nB(2) c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA' x mB. c----------------------------------------------------------------------- DO i = 1, nC(1) c ------------------------------------------------------------------ c Move column i of A to temporary vector vD. c ------------------------------------------------------------------ DO j = 1, nA(1) vD(j) = mA(j,i) END DO c ------------------------------------------------------------------ c Compute dot product of mA column i (from vD) x mB column j. c ------------------------------------------------------------------ DO j = 1, nC(2) mC(i,j) = ddot( nA(1), vD(1), 1, mB(1,j), 1 ) END DO END DO c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulDMat( dA, nA, mB, nB, mC, nC, pdA ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 13 Jan 2006. c----------------------------------------------------------------------- c This subroutine calculates the matrix product of mC = mA x mB c where mA has a constant diagonal form as represented by dA and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dA d diagonal form of first input matrix to be multiplied c where dA = [ mA[1,1], ... mA[1,sA] ], sA = nA(2)-nA(1)+1 c mB d second input matrix to be multiplied c mC d matrix output result of mA x mB c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c ddot d external function reference c i,j i index variables for do loops c sA i size of dA vector c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION dA( pdA ), mB( nB(1), nB(2) ), & mC( nA(1), nB(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, sA DOUBLE PRECISION ddot c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(2) .eq. nB(1) ).and.( nA(2)-nA(1) .ge. 0 )) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(1) nC(2) = nB(2) sA = nA(2)-nA(1)+1 c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA' x mB. c----------------------------------------------------------------------- DO i=1, nC(1) c ------------------------------------------------------------------ c Compute dot product of mA row i (from dA) x mB column j. c ------------------------------------------------------------------ DO j=1, nC(2) mC(i,j) = ddot( sA, dA(1), 1, mB(i,j), 1 ) END DO END DO c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulMatDTr( mA, nA, dB, nB, mC, nC, pdB ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 13 Jan 2006. c----------------------------------------------------------------------- c This subroutine calculates the matrix product of mC = mA x mB' c where mB' represents the transpose of mB and c where mB has a constant diagonal form as represented by dB and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to be multiplied c dB d diagonal form of second input matrix to be multiplied c where dB = [ mB[1,1], ... mB[1,sB] ], sB = nB(2)-nB(1)+1 c mC d matrix output result of mA x mB' c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c ddot d external function reference c i,j i index variables for do loops c sB i size of dB vector c vA d used as temporary storage for a row of mA c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdB c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), dB( pdB ), mC( nA(1), nB(1) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, sB DOUBLE PRECISION vA( nA(2) ), ddot c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(2) .eq. nB(2) ).and.( nB(2)-nB(1) .ge. 0 )) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(1) nC(2) = nB(1) sB = nB(2)-nB(1)+1 c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA x mB'. c----------------------------------------------------------------------- DO i=1, nC(1) c ------------------------------------------------------------------ c Move row i of A to temporary vector vA. c ------------------------------------------------------------------ DO j = 1, nA(2) vA(j) = mA( i, j ) END DO c ------------------------------------------------------------------ c Compute dot product of mA row i (from vA) x mB row j (from dB). c ------------------------------------------------------------------ DO j=1, nC(2) mC(i,j) = ddot( sB, vA(j), 1, dB(1), 1 ) END DO END DO c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulDTrMat( dA, nA, mB, nB, mC, nC, pdA ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 13 Jan 2006. c----------------------------------------------------------------------- c This subroutine calculates the matrix product of mC = mA' x mB c where mA' represents the transpose of mA and c where mA has a constant diagonal form as represented by dA and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dA d diagonal form of first input matrix to be multiplied c where dA = [ mA[1,1], ... mA[1,sA] ], sA = nA(2)-nA(1)+1 c mB d second input matrix to be multiplied c mC d matrix output result of mA' x mB c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c ddot d external function reference c i,j i index variables for do loops c nn i count variable c sA i size of dA vector c dRA d reversed version of dA c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION dA( pdA ), mB( nB(1), nB(2) ), & mC( nA(2), nB(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, nn, sA DOUBLE PRECISION dRA( nA(2)-nA(1)+1 ), ddot c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(1) .eq. nB(1) ).and.( nA(2)-nA(1) .ge. 0 )) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(2) nC(2) = nB(2) c ------------------------------------------------------------------ c Create reversed version of dA. c ------------------------------------------------------------------ sA = nA(2)-nA(1)+1 DO j=1,sA dRA( sA-j+1 )=dA( j ) END DO c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA' x mB. c----------------------------------------------------------------------- DO i=1, nC(1) c ------------------------------------------------------------------ c Compute dot product of mA column i (from dRA) x mB column j. c ------------------------------------------------------------------ DO j=1, nC(2) IF ( i .le. nA(1) ) THEN nn = min(i,sA) c mC(i,j) = ddot( nn, dA(1), 1, mB(i,j), -1 ) mC(i,j) = ddot( nn, dRA(sA-nn+1), 1, mB(i-nn+1,j), 1 ) ELSE nn = nA(2)-i+1 c mC(i,j) = ddot( nn, dA(i-nA(1)+1), 1, mB(nB(1),j), -1 ) mC(i,j) = ddot( nn, dRA(1), 1, mB(nB(1)-nn+1,j), 1 ) END IF END DO END DO c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulMatD( mA, nA, dB, nB, mC, nC, pdB ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 13 Jan 2006. c----------------------------------------------------------------------- c This subroutine calculates the matrix product of mC = mA x mB c where mB has a constant diagonal form as represented by dB and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to be multiplied c dB d diagonal form of second input matrix to be multiplied c where dB = [ mB[1,1], ... mB[1,sB] ], sB = nB(2)-nB(1)+1 c mC d matrix output result of mA x mB c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c ddot d external function reference c i,j i index variables for do loops c nn i count variable c sB i size of dB vector c dRA d reversed version of a row in mA c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdB c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), dB( pdB ), mC( nA(1), nB(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, nn, sB DOUBLE PRECISION vRA( nA(2) ), ddot c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(2) .eq. nB(1) ).and.( nB(2)-nB(1) .ge. 0 )) THEN c----------------------------------------------------------------------- c Establish dimensions of mC matrix. c----------------------------------------------------------------------- nC(1) = nA(1) nC(2) = nB(2) sB = nB(2)-nB(1)+1 c----------------------------------------------------------------------- c Perform matrix multiply of mC = mA x mB. c----------------------------------------------------------------------- DO i=1, nC(1) c ------------------------------------------------------------------ c Create reversed version of a row in mA. c ------------------------------------------------------------------ DO j = 1, nA(2) vRA( nA(2)-j+1 ) = mA( i, j ) END DO c ------------------------------------------------------------------ c Compute dot product of mA row i (from dRA) x mB column j (from dB). c ------------------------------------------------------------------ DO j=1, nC(2) IF ( j .le. nB(1) ) THEN nn = min(j,sB) c mC(i,j) = ddot( nn, mA(i,j), -nA(1), dB(1), 1 ) mC(i,j) = ddot( nn, vRA(nA(2)-j+1), 1, dB(1), 1 ) ELSE nn = nB(2)-j+1 c mC(i,j) = ddot( nn, mA(i,nA(2)), -nA(1), dB(j-nB(1)+1), 1 ) mC(i,j) = ddot( nn, vRA(1), 1, dB(j-nB(1)+1), 1 ) END IF END DO END DO c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN ENDmulqmat.f0000664006604000003110000003501714521201535012024 0ustar sun00315stepsc----------------------------------------------------------------------- c mulQMat.f, Release 1, Subroutine Version 1.1, Modified 13 Jan 2006. c----------------------------------------------------------------------- SUBROUTINE mulQMat( mA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 09 Jun 2005. c Modified by REG, on 13 Jan 2006, to combine with other quadratic c matrix multiplication utility mulQMatTr(). c----------------------------------------------------------------------- c This subroutine calculates the matrix quadratic product of c mC = mA x mB x mA' where mA' represents the transpose of mA and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to pre/post multipy mB by c mB d second input matrix c mC d matrix output result of mA x mB x mA' c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c mTemp d temporary result of mA x mB c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp i size (rows,columns) of mTemp matrix c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nB(1), nB(2) ), * & mC( nA(2) ,nA(2) ) & mC( nA(1) ,nA(1) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER nSave, nTemp(2) PARAMETER (nSave=POBS*POBS) c DOUBLE PRECISION, SAVE :: mTemp( nSave ) DOUBLE PRECISION mTemp( nSave ) COMMON /QMATPROC/ mTemp c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(2) .eq. nB(1) ) .and. ( nB(1) .eq. nB(2) )) THEN c----------------------------------------------------------------------- c Perform matrix multiply of mTemp = mA x mB. c----------------------------------------------------------------------- CALL mulMat( mA, nA, mB, nB, mTemp, nTemp ) c----------------------------------------------------------------------- c Perform matrix transpose multiply of mC = mTemp x mA'. c----------------------------------------------------------------------- CALL mulMatTr( mTemp, nTemp, mA, nA, mC, nC ) c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulQMatTr( mA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 09 Jun 2005. c Modified by REG, on 15 Sep 2005, to correct mC dimensions. c----------------------------------------------------------------------- c This subroutine calculates the matrix quadratic product of c mC = mA' x mB x mA where mA' represents the transpose of mA and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c mA d first input matrix to pre/post multipy mB by c mB d second input matrix c mC d matrix output result of mA' x mB x mA c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c mTemp d temporary result of mA' x mB c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp i size (rows,columns) of mTemp matrix c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION mA( nA(1), nA(2) ), mB( nB(1), nB(2) ), & mC( nA(2), nA(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j, nSave, nTemp(2) PARAMETER (nSave=POBS*POBS) c DOUBLE PRECISION, SAVE :: mTemp( nSave ) DOUBLE PRECISION mTemp( nSave ) COMMON /QMATPROC/ mTemp c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(1) .eq. nB(1) ) .and. ( nB(1) .eq. nB(2) )) THEN c----------------------------------------------------------------------- c Perform matrix multiply of mTemp = mA' x mB. c----------------------------------------------------------------------- CALL mulTrMat( mA, nA, mB, nB, mTemp, nTemp ) c----------------------------------------------------------------------- c Perform matrix multiply of mC = mTemp x mA. c----------------------------------------------------------------------- CALL mulMat( mTemp, nTemp, mA, nA, mC, nC ) c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1) = 0 nC(2) = 0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulQdMat( dA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 13 Jan 2006. c----------------------------------------------------------------------- c This subroutine calculates the matrix quadratic product of c mC = mA x mB x mA' where mA' represents the transpose of mA, c where dA represents the constant diagonal form of mA, and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dA d first input matrix to pre/post multipy mB by where c dA = [ mA(1,1), ..., mA(1,sA) ], sA = nA(2)-nA(1)+1 c mB d second input matrix c mC d matrix output result of mA x mB x mA' c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c mTemp d temporary result of mA x mB c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp i size (rows,columns) of mTemp matrix c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION dA(nA(2)-nA(1)+1), mB( nB(1), nB(2) ), & mC( nA(1) ,nA(1) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER nSave, nTemp(2) PARAMETER (nSave=POBS*POBS) c DOUBLE PRECISION, SAVE :: mTemp( nSave ) DOUBLE PRECISION mTemp( nSave ) COMMON /QMATPROC/ mTemp c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(2) .eq. nB(1) ) .and. ( nB(1) .eq. nB(2) )) THEN c----------------------------------------------------------------------- c Perform matrix multiply of mTemp = mA x mB using dA. c----------------------------------------------------------------------- pdA = max(nA(2)-nA(1)+1, 1) CALL mulDMat( dA, nA, mB, nB, mTemp, nTemp, pdA ) c----------------------------------------------------------------------- c Perform matrix transpose multiply of mC = mTemp x mA' using dA. c----------------------------------------------------------------------- CALL mulMatDTr( mTemp, nTemp, dA, nA, mC, nC, pdA ) c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1)=0 nC(2)=0 END IF c ------------------------------------------------------------------ RETURN END c----------------------------------------------------------------------- SUBROUTINE mulQdMatTr( dA, nA, mB, nB, mC, nC ) c----------------------------------------------------------------------- c Changes: c Created by REG, on 13 Jan 2006. c----------------------------------------------------------------------- c This subroutine calculates the matrix quadratic product of c mC = mA' x mB x mA where mA' represents the transpose of mA, c where dA represents the constant diagonal form of mA, and c where nA, nB, and nC contain the dimensions of mA, mB, and mC. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c dA d first input matrix to pre/post multipy mB by where c dA = [ mA(1,1), ..., mA(1,sA) ], sA = nA(2)-nA(1)+1 c mB d second input matrix c mC d matrix output result of mA' x mB x mA c nA i size (rows,columns) of mA matrix c nB i size (rows,columns) of mB matrix c nC i size (rows,columns) of mC matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c mTemp d temporary result of mA' x mB c nSave i identifies default size of large matrices c that are saved (not dynamic) c nTemp i size (rows,columns) of mTemp matrix c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'srslen.prm' c ------------------------------------------------------------------ c added by BCM to correctly dimension variables c ------------------------------------------------------------------ INTEGER pdA c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nA(2), nB(2), nC(2) DOUBLE PRECISION dA(nA(2)-nA(1)+1), mB( nB(1), nB(2) ), * & mC( nA(1) ,nA(1) ) & mC( nA(2) ,nA(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER nSave, nTemp(2) PARAMETER (nSave=POBS*POBS) c DOUBLE PRECISION, SAVE :: mTemp( nSave ) DOUBLE PRECISION mTemp( nSave ) COMMON /QMATPROC/ mTemp c----------------------------------------------------------------------- c Check for valid matrix multiplication. c----------------------------------------------------------------------- IF (( nA(1) .eq. nB(1) ) .and. ( nB(1) .eq. nB(2) )) THEN c----------------------------------------------------------------------- c Perform matrix transpose multiply of mTemp = mA' x mB using dA. c----------------------------------------------------------------------- pdA = max(nA(2)-nA(1)+1, 1) CALL mulDTrMat( dA, nA, mB, nB, mTemp, nTemp, pdA ) c----------------------------------------------------------------------- c Perform matrix multiply of mC = mTemp x mA using dA. c----------------------------------------------------------------------- * write(6,*) ' nTemp = ',nTemp(1),nTemp(2) * write(6,*) ' na = ',na(1),na(2) CALL mulMatD( mTemp, nTemp, dA, nA, mC, nC, pdA ) c----------------------------------------------------------------------- c Invalid matrix multiplication. c----------------------------------------------------------------------- ELSE nC(1)=0 nC(2)=0 END IF c ------------------------------------------------------------------ RETURN ENDmulref.f0000664006604000003110000000204214521201535011626 0ustar sun00315steps SUBROUTINE mulref(Nrxy,Fac,Tmp,Xdev,Xvec,Xval,Same) IMPLICIT NONE c----------------------------------------------------------------------- c adjusts X-11 Regression factors by dividing either by the c scalar Xval or the array Xvec. c----------------------------------------------------------------------- DOUBLE PRECISION Fac,Tmp,Xvec,Xval LOGICAL Same INTEGER irow,Nrxy,j,Xdev DIMENSION Fac(*),Tmp(*),Xvec(*) c----------------------------------------------------------------------- IF(Xval.gt.0)THEN DO irow=1,Nrxy IF(Same)THEN Fac(irow)=Tmp(irow)/Xval ELSE Fac(irow)=Fac(irow)+Tmp(irow)/Xval END IF END DO ELSE DO irow=1,Nrxy j=irow+Xdev-1 IF(Same)THEN Fac(irow)=Tmp(irow)/Xvec(j) ELSE Fac(irow)=Fac(irow)+Tmp(irow)/Xvec(j) END IF END DO END IF c----------------------------------------------------------------------- RETURN END mulsca.f0000664006604000003110000000416514521201535011630 0ustar sun00315steps SUBROUTINE mulSca( sA, mB, nB ) c----------------------------------------------------------------------- c mulSca.f, Release 1, Subroutine Version 1.0, Created 11 Apr 2005. c----------------------------------------------------------------------- c This subroutine calculates the product of a scalar times a matrix c mB = sA x mB where nB contains the dimensions of mB. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c sA d input scalar to multiply mB by c mB d input matrix to be multiplied by scalar sA c nB i size (rows,columns) of mB matrix c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i,j i index variables for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nB(2) DOUBLE PRECISION sA, mB( nB(1), nB(2) ) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i, j c----------------------------------------------------------------------- c Perform scalar times matrix multiply of mB = sA x mB. c----------------------------------------------------------------------- DO i = 1, nB(1) c ------------------------------------------------------------------ c Compute product of sA x mB( row i, column j). c ------------------------------------------------------------------ DO j = 1, nB(2) mB(i,j) = sA*mB(i,j) END DO END DO c ------------------------------------------------------------------ RETURN ENDmult0.f0000664006604000003110000000313414521201536011401 0ustar sun00315steps subroutine mult0(A,la,na,B,llb,lub,nb,nnb,C,llc,luc) c This subroutine multiplies together two polynomials a(x) and b(x): c (for multiplying a polynomial in F times a polynomial of F and B) c (if 2nd polynomial is a polynomial in B, set first dimension equal to 0) c note that dimensions of matrices A,B from original program (la,llb) c may be different than the dimension used in subroutine c c a(x) = a0 + a1*x^(-1) + a2*x^(-2) + ... + a(na)*x^(-na) c c b(x) = b(-nb)*x^(-nb) + b(-nb+1)*x^(-nb+1) + b0... + b(nnb)*x^(nnb). c c Note that the general form used here has positive signs for the c coefficients. The coefficients are stored in elements 0 to na of c array A and -nb to nc of array B in the order of increasing (in absolute value) powers of x, i.e. c c A(0:na) = [a0, a1, ... , a(na)]'. c c B(-nb:nnb) = [b(-nb), b(-nb+1), ..b(0). , b(nnb)]'. c c The product c(x) = a(x)b(x), its coefficients are c stored in the array C = [c(-na-nb), ... , c(nc)]'. c Note, llc and luc are the dimensions of the vector c, but all of the vector may not be used double precision A(0:la),B(-llb:lub),C(-llc:luc) do 1 j = -llc,luc C(j) = 0.0D0 1 continue do 3 j = 0,na do 4 k = -nb,nnb C(k-j) = C(k-j) + A(j)*B(k) 4 continue 3 continue c do 2 i = -(na+nb),nnb c do 3 j = 0,na c do 4 k = -nb,nnb c if (k-j .eq. i) then c C(i) = C(i) + A(j)*B(k) c end if c4 continue c3 continue c2 continue return end mult1.f0000664006604000003110000000264014521201536011403 0ustar sun00315steps subroutine mult1(A,la,na,B,lb,nb,C,nc) c This subroutine multiplies together two polynomials a(x) and b(x): c (for multiplying two polynomials in B) c Note that la and lb, the dimensions of A and B from the main program c may be greater than na and na, the dimensions used in the subroutine c c a(x) = a0 + a1*x^(1) + a2*x^(2) + ... + a(na)*x^(na) c c b(x) = b0 + b1*x^(1) + b2*x^(2) + ... + b(nb)*x^(nb) c c c Note that the general form used here has positive signs for the c coefficients. The coefficients are stored in elements 0 to na of c array A and -nb to nc of array B in the order of increasing powers of x, i.e. c c A(0:na) = [a0, a1, ... , a(na)]'. c c B(0:nb) = [b0, b1, ... , b(nb)]'. c c The product c(x) = a(x)b(x), its coefficients are c stored in the array C = [c0, ... , c(nc)]'. c Note, nc is the dimensions of the vector c, but all of the vector may not be used double precision A(0:la),B(0:lb),C(0:nc) do 1 j = 0,nc C(j) = 0.0D0 1 continue do 3 j = 0,na do 4 k = 0,nb C(k+j) = C(k+j) + A(j)*B(k) 4 continue 3 continue c do 2 i = -(na+nb),nnb c do 3 j = 0,na c do 4 k = -nb,nnb c if (k-j .eq. i) then c C(i) = C(i) + A(j)*B(k) c end if c4 continue c3 continue c2 continue return end mult2.f0000664006604000003110000000303114521201536011377 0ustar sun00315steps subroutine mult2(A,lla,lua, na, nna, B,llb,lub,nb,nnb,C,nc,nnc) c This subroutine multiplies together two polynomials a(x) and b(x): c (for multiplying two polynomials, both in F an B) c Note that la and lb, the dimensions of A and B from the main program c may be different from that used in the subroutine c c a(x) = a(-na)x^(-na) + ...+ a0 + a1*x^(1) + a2*x^(2) + ... + a(nna)*x^(nna) c c b(x) = b(-nb)x^(-nb) + ...+ b0 + b1*x^(1) + b2*x^(2) + ... + b(nnb)*x^(nnb) c c Note that the general form used here has positive signs for the c coefficients. The coefficients are stored in elements -na to nna of c array A and -nb to nnb of array B in the order of increasing powers of x, i.e. c c A(-na:na) = [a(-na), ...a0, a1, ... , a(nna)]'. c c B(-nb:nb) = [b(-nb), ...b0, b1, ... , b(nnb)]'. c c The product c(x) = a(x)b(x), its coefficients are c stored in the array C = [c0, ... , c(nc)]'. c Note, nc is the dimensions of the vector c, but all of the vector may not be used double precision A(-lla:lua),B(-llb:lub),C(-nc:nnc) do 1 j = -nc,nnc C(j) = 0.0D0 1 continue do 3 j = -na,nna do 4 k = -nb,nnb C(k+j) = C(k+j) + A(j)*B(k) 4 continue 3 continue c do 2 i = -(na+nb),nna+nnb c do 3 j = -na,nna c do 4 k = -nb,nnb c if (k+j .eq. i) then c C(i) = C(i) + A(j)*B(k) c end if c4 continue c3 continue c2 continue return end mult.f0000664006604000003110000000131214521201536011315 0ustar sun00315steps**==mult.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 SUBROUTINE MATMLT(A,B,C,M,Ip,Iq,Ia,Ib,Ic) IMPLICIT NONE **--MULT5 C C*** Start of declarations rewritten by SPAG C C Dummy arguments C INTEGER*4 Ia,Ib,Ic,Ip,Iq,M REAL*8 A(Ia,*),B(Ib,*),C(Ic,*) C C Local variables C INTEGER*4 i,ir,is REAL*8 sum C C*** End of declarations rewritten by SPAG C c **** Start of Executable Program C a(m,p)*b(p,q) = c(m,q) DO ir=1,M DO is=1,Iq sum=0.0D0 DO i=1,Ip sum=sum+(A(ir,i)*B(i,is)) END DO C(ir,is)=sum END DO END DO END mxpeak.f0000664006604000003110000000424314521201536011627 0ustar sun00315steps SUBROUTINE mxpeak(Sxx,Tpeak,Domfqt,Ntfreq,Speak,Domfqs,Nsfreq, & Maxsxx,Nform,Spclab) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' c----------------------------------------------------------------------- CHARACTER labvec*(2),domfrq*(2),Spclab*(*) DOUBLE PRECISION Sxx,Maxsxx INTEGER i,i2,Domfqt,Domfqs,Nform,Pkidx,frq1,Tpeak,Ntfreq,Speak, & Nsfreq DIMENSION Sxx(*),Tpeak(*),Speak(*),labvec(11) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- DATA labvec/'t1','t2','t3','t4','t5','s1','s2','s3','s4','s5', & 's6'/ c----------------------------------------------------------------------- domfrq = 'no' i2 = 0 c----------------------------------------------------------------------- IF(Domfqt.eq.NOTSET.and.Domfqs.eq.NOTSET)THEN WRITE(Nform,1010)Spclab,domfrq RETURN ELSE IF(Domfqt.eq.NOTSET)THEN frq1=Domfqs i2=5 ELSE IF(Domfqs.eq.NOTSET)THEN frq1=Domfqt ELSE IF(Sxx(Domfqt).gt.Sxx(Domfqs))THEN frq1=Domfqt ELSE frq1=Domfqs i2=5 END IF c----------------------------------------------------------------------- IF(dpeq(Maxsxx,Sxx(frq1)))THEN IF(i2.eq.0)THEN i=1 DO WHILE (i.le.Ntfreq) IF(Tpeak(i).eq.frq1)THEN i2=i i=Ntfreq END IF i=i+1 END DO ELSE i=1 DO WHILE (i.le.Nsfreq) IF(Speak(i).eq.frq1)THEN i2=i+i2 i=Nsfreq END IF i=i+1 END DO END IF domfrq=labvec(i2) END IF c----------------------------------------------------------------------- WRITE(Nform,1010)Spclab,domfrq c----------------------------------------------------------------------- 1010 FORMAT(a,'.dom: ',a) RETURN END nblank.f0000664006604000003110000000245714521201536011614 0ustar sun00315stepsC Last change: BCM 22 Dec 97 1:57 pm **==nblank.f processed by SPAG 3.10FA at 13:18 on 4 Aug 1992 INTEGER FUNCTION nblank(Str) IMPLICIT NONE c----------------------------------------------------------------------- c Returns nblank, the index of the last non blank in the string c----------------------------------------------------------------------- c Input arguments c Name Type Description c----------------------------------------------------------------------- c str c String with 0 or more trailing blanks c----------------------------------------------------------------------- CHARACTER Str*(*) INTEGER nb c ------------------------------------------------------------------ c nblank=lnblnk(str) c----------------------------------------------------------------------- c For non Sun systems, work backwards through the string until c something other than a blank. c----------------------------------------------------------------------- nblank=0 c nb = LEN_TRIM(Str) nb = LEN(Str) if (nb.gt.0) then DO nblank = nb , 1 , -1 IF(.NOT.(Str(nblank:nblank).eq.' '))GO TO 10 END DO end if c ------------------------------------------------------------------ 10 RETURN END newest.f0000664006604000003110000000417214521201536011650 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 12:40 pm SUBROUTINE newest(Type,Uu,Vv) IMPLICIT NONE C ********************************************************************** C * * C * COMPUTE NEW ESTIMATES OF THE QUADRATIC COEFFICIENTS USING THE * C * SCALARS COMPUTED IN CALCSC. * C * * C ********************************************************************** INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'global.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) C----------------------------------------------------------------------- DOUBLE PRECISION a4,a5,b1,b2,c2,c3,c4,temp,Uu,Vv,c1 INTEGER Type C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- C USE FORMULAS APPROPRIATE TO SETTING OF TYPE. C----------------------------------------------------------------------- IF(Type.ne.3)THEN IF(Type.eq.2)THEN a4=(A0+G)*F+H a5=(F+U)*C+V0*D0 ELSE a4=A0+U*B0+H*F a5=C+(U+V0*F)*D0 END IF C----------------------------------------------------------------------- C EVALUATE NEW QUADRATIC COEFFICIENTS. C----------------------------------------------------------------------- b1=-K(N)/P0(N0) b2=-(K(N-1)+b1*P0(N))/P0(N0) c1=V0*b2*A1 c2=b1*A7 c3=b1*b1*A3 c4=c1-c2-c3 temp=a5+b1*a4-c4 IF(.not.dpeq(temp,ZERO))THEN Uu=U-(U*(c3+c2)+V0*(b1*A1+b2*A7))/temp Vv=V0*(ONE+c4/temp) RETURN END IF END IF C----------------------------------------------------------------------- C IF TYPE=3 THE QUADRATIC IS ZEROED C----------------------------------------------------------------------- Uu=ZERO Vv=ZERO RETURN END newmdl.cmn0000664006604000003110000000061514521201536012157 0ustar sun00315stepsC----------------------------------------------------------------------- c Variables for generalized versions of the airline model C----------------------------------------------------------------------- DOUBLE PRECISION Aparm,Bparm,Cparm INTEGER Newmdl COMMON /newcmn/ Aparm,Bparm,Cparm,Newmdl C----------------------------------------------------------------------- nextk.f0000664006604000003110000000373014521201536011473 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 12:12 pm SUBROUTINE nextk(Type) IMPLICIT NONE C ********************************************************************** C * * C * COMPUTES THE NEXT K POLYNOMIALS USING SCALARS COMPUTED IN CALCSC * C * * C ********************************************************************** C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'global.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION temp,dabs INTEGER i,Type C----------------------------------------------------------------------- IF(Type.ne.3)THEN temp=A0 IF(Type.eq.1)temp=B0 IF(dabs(A1).gt.dabs(temp)*Eta*10D0)THEN C----------------------------------------------------------------------- C USE SCALED FORM OF THE RECURRENCE C----------------------------------------------------------------------- A7=A7/A1 A3=A3/A1 K(1)=Qp(1) K(2)=Qp(2)-A7*Qp(1) DO i=3,N K(i)=A3*Qk(i-2)-A7*Qp(i-1)+Qp(i) END DO RETURN ELSE C----------------------------------------------------------------------- C IF A1 IS NEARLY ZERO THEN USE A SPECIAL FORM OF THE RECURRENCE C----------------------------------------------------------------------- K(1)=0.D0 K(2)=-A7*Qp(1) DO i=3,N K(i)=A3*Qk(i-2)-A7*Qp(i-1) END DO RETURN END IF END IF C----------------------------------------------------------------------- C USE UNSCALED FORM OF THE RECURRENCE IF TYPE IS 3 C----------------------------------------------------------------------- K(1)=0.D0 K(2)=0.D0 DO i=3,N K(i)=Qk(i-2) END DO RETURN END nmlmdl.f0000664006604000003110000001467314521201536011635 0ustar sun00315stepsC Last change: BCM 30 Sep 2005 3:39 pm SUBROUTINE nmlmdl(Nn,Ipr,Ips,Idr,Ids,Iqr,Iqs,Th,Bth,Phi,BPhi, & Xl,Nfixed) IMPLICIT NONE c ------------------------------------------------------------------ c Converts X-13ARIMA-SEATS ARIMA modeling data structures to c variables used by TRAMO/SEATS program. c ------------------------------------------------------------------ c Changed by REG, on 2 Jun 2005, to add Nfixed output variable c that identifies the number of parameters fixed by the user. c ------------------------------------------------------------------ INTEGER N10 PARAMETER(N10=64) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER tmpttl*(PGRPCR) DOUBLE PRECISION Ur,Xl,Th,Bth,Phi,BPhi,xmin,xmax c Modified by REG on 2 Jun 2005 to add Nfixed output variable INTEGER ardsp,Ipr,Ips,Idr,Ids,Iqr,Iqs,iparma,iflt,Nn, & begopr,endopr,nlag,iopr,ntmpcr,i,iprs,iqrs,Nfixed DIMENSION Th(Nn),Bth(Nn),Phi(Nn),BPhi(Nn),xmin(N10),xmax(N10) DOUBLE PRECISION x,x2 c INTEGER id,ip,iq,pbp,ps,qbq DIMENSION x(N10),x2(N10) c ------------------------------------------------------------------ c Set up values for difference orders from variables on hand. c ------------------------------------------------------------------ CALL setdp(Xl,N10,xmax) CALL setdp(-Xl,N10,xmin) Idr=Nnsedf Ids=Nseadf ardsp=Nnsedf+Nseadf Ur=1D0 c ------------------------------------------------------------------ c Initialize terms for nonseasonal and seasonal AR, MA c ------------------------------------------------------------------ Ipr=0 Ips=0 Iqr=0 Iqs=0 c----------------------------------------------------------------------- c Loop through other operators, getting number of lags in each c ------------------------------------------------------------------ iparma=ardsp+1 c Added by REG on 2 Jun 2005 to initialize Nfixed Nfixed=0 DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 DO iopr=begopr,endopr nlag=Opr(iopr)-Opr(iopr-1) CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) c Added by BCM on 29 Sep 2005 to allow program to exit when c limit of ARMA parameters reached by program. IF((.not.Lfatal).and.nlag.gt.Nn)THEN WRITE(Mt1,1010)Nn,tmpttl(1:ntmpcr) WRITE(Mt2,1010)Nn,tmpttl(1:ntmpcr) WRITE(STDERR,1010)Nn,tmpttl(1:ntmpcr) 1010 FORMAT(' NOTE: The SEATS signal extraction routines cannot', & ' process more than ',i3,/,' ',a,' terms.',/, & ' The program will stop executing; try ', & 'specifying another ARIMA model.',/) CALL abend END IF IF(Lfatal)RETURN IF(tmpttl(1:ntmpcr).eq.'Nonseasonal AR')THEN Ipr=nlag DO i=1,nlag IF(Arimal(iparma).ne.i)THEN WRITE(Mt1,1011) WRITE(Mt2,1011) WRITE(STDERR,1011) 1011 FORMAT(' NOTE: The SEATS signal extraction routines cannot', & ' process missing lag models.',/, & ' The program will stop executing; try ', & 'specifying another ARIMA model.',/) CALL abend END IF IF(Lfatal)RETURN Phi(i)=0D0-Arimap(iparma) x2(iparma-ardsp)=Phi(i) c Added by REG on 2 Jun 2005 to increment Nfixed IF(Arimaf(iparma))Nfixed=Nfixed+1 iparma=iparma+1 END DO ELSE IF(tmpttl(1:ntmpcr).eq.'Seasonal AR')THEN Ips=nlag DO i=1,nlag IF(Arimal(iparma).ne.i*Sp)THEN WRITE(Mt1,1011) WRITE(Mt2,1011) WRITE(STDERR,1011) CALL abend END IF IF(Lfatal)RETURN BPhi(i)=0D0-Arimap(iparma) x2(iparma-ardsp)=Bphi(i) c Added by REG on 2 Jun 2005 to increment Nfixed IF(Arimaf(iparma))Nfixed=Nfixed+1 iparma=iparma+1 END DO ELSE IF(tmpttl(1:ntmpcr).eq.'Nonseasonal MA')THEN Iqr=nlag DO i=1,nlag IF(Arimal(iparma).ne.i)THEN WRITE(Mt1,1011) WRITE(Mt2,1011) WRITE(STDERR,1011) CALL abend END IF IF(Lfatal)RETURN Th(i)=0D0-Arimap(iparma) x2(iparma-ardsp)=Th(i) c Added by REG on 2 Jun 2005 to increment Nfixed IF(Arimaf(iparma))Nfixed=Nfixed+1 iparma=iparma+1 END DO ELSE IF(tmpttl(1:ntmpcr).eq.'Seasonal MA')THEN Iqs=nlag DO i=1,nlag IF(Arimal(iparma).ne.i*Sp)THEN WRITE(Mt1,1011) WRITE(Mt2,1011) WRITE(STDERR,1011) CALL abend END IF IF(Lfatal)RETURN BTh(i)=0D0-Arimap(iparma) x2(iparma-ardsp)=Bth(i) c Added by REG on 2 Jun 2005 to increment Nfixed IF(Arimaf(iparma))Nfixed=Nfixed+1 iparma=iparma+1 END DO c IF(nlag.eq.1.and.Bth(1).lt.-0.995)Bth(1)=-0.995 END IF END DO END DO Iprs=Ipr+Ips IQRS=IQR+IQS c pq=Ipr+Ips+Iqr c qbq=pq+iqs IF(Ipr.gt.0)THEN CALL TRANS0(x2,N10,x,1,Ipr,Iprs,Ur,Xl) CALL TRANS2(x2,N10,x,0,Ipr) DO i=1,Ipr Phi(i)=x2(i) END DO END IF IF(Ips.gt.0)THEN CALL TRANS0(x2,N10,X,Ipr+1,Iprs,Iprs,Ur,Xl) CALL TRANS2(x2,N10,x,Ipr,Iprs) DO i=1,Ips BPhi(i)=x2(i+Ipr) END DO END IF IF(Iqr.gt.0)THEN CALL TRANS0(x2,N10,X,Iprs+1,Iprs+Iqr,Iprs,Ur,Xl) CALL TRANS2(x2,N10,x,Iprs,Iprs+Iqr) DO i=1,Iqr Th(i)=x2(IPRS+I) END DO END IF IF(Iqs.gt.0)THEN CALL TRANS0(x2,N10,X,Iprs+Iqr+1,IPRS+IQRS,Iprs,Ur,Xl) CALL TRANS2(x2,N10,x,Iprs+Iqr,IPRS+IQRS) DO i=1,Iqs BTh(i)=x2(IPRS+IQR+I) END DO END IF c ------------------------------------------------------------------ RETURN END nofcst.f0000664006604000003110000000240614521201537011636 0ustar sun00315steps SUBROUTINE nofcst(Trnsrs,Frstry,Lx11) IMPLICIT NONE c ------------------------------------------------------------------ c This subroutine sets the number of forecasts and backcasts to 0, c resets data pointers to take this into account, and regenerates c the regression matrix. c Written by BCM (July 2007) c----------------------------------------------------------------------- LOGICAL T PARAMETER(T=.true.) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'arima.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'extend.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION Trnsrs(PLEN) LOGICAL Lx11 INTEGER Frstry,nf2 c ------------------------------------------------------------------ nf2=Nfcst Nfcst=0 IF(Nbcst.gt.0)Nbcst=0 IF(Nfdrp.gt.0)Nfdrp=0 CALL setxpt(nf2,Lx11,Fctdrp) CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) c ------------------------------------------------------------------ RETURN ENDnotset.prm0000664006604000003110000000155714521201537012235 0ustar sun00315stepsc----------------------------------------------------------------------- c Parameter file for all the notset values. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c CNOTST c Parameter, '?', signifies character variable not input c to namelist c DNOTST d Parameter -999.0d-0, signifies value not input c NOTSET i Parameter signifies integer variable not input to namelist c SNOTST r Parameter -999.0, signifies single precision value not c input c----------------------------------------------------------------------- CHARACTER CNOTST*1 INTEGER NOTSET c REAL SNOTST DOUBLE PRECISION DNOTST PARAMETER (CNOTST='?',NOTSET=-32767,DNOTST=-999.0d0) c PARAMETER (SNOTST=-999.0) nprint.f0000664006604000003110000000201614521201537011651 0ustar sun00315steps SUBROUTINE nprint(Fh,S) c----------------------------------------------------------------------- c eprint.f, Release 1, Subroutine Version 1.3, Modified 24 Jan 1995. c----------------------------------------------------------------------- c eprint - print error, Lahey pc version c----------------------------------------------------------------------- c Author - Larry Bobbitt c Statistical Research Division c U.S. Census Bureau c Room 3000-4 c Washington, D.C. 20233 c (301) 763-3957 c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ CHARACTER*(*) S INTEGER Fh c ------------------------------------------------------------------ WRITE(Fh,*)'

    NOTE: ',S,'

    ' c ------------------------------------------------------------------ RETURN END npsa.f0000664006604000003110000000321514521201537011302 0ustar sun00315steps integer function NPsa(sa,n1,nz,lmodel,d,bd,mq,llog) implicit none c----------------------------------------------------------------------- INCLUDE 'srslen.prm' include 'dimensions.i' c----------------------------------------------------------------------- DOUBLE PRECISION sa(*),media,aux(mpkp),SNP INTEGER ndif,d,bd,nz,k,i,n1,mq,j LOGICAL lmodel,llog c----------------------------------------------------------------------- real*8 KENDALLS external KENDALLS c----------------------------------------------------------------------- IF(lmodel)THEN ndif=max(min(2,d+bd),1) ELSE ndif=1 END IF if(llog)then do i=n1,nz aux(i-n1+1)=log(sa(i)) end do ELSE do i=n1,nz aux(i-n1+1)=sa(i) end do END IF c----------------------------------------------------------------------- k=nz-n1+1 do j=1,ndif k=k-1 do i=1,k aux(i)=aux(i+1)-aux(i) end do end do c----------------------------------------------------------------------- media=0 do i=1,k media=media+aux(i) end do media=media/k do i=1,k aux(i)=aux(i)-media end do c----------------------------------------------------------------------- SNP=kendalls(aux,k,mq) if (SNP.gt.24.73d0.and.mq.eq.12.or. $ SNP.gt.11.35d0.and.mq.eq.4) then NPsa=1 else NPsa=0 end if c----------------------------------------------------------------------- return end nrmtst.f0000664006604000003110000002475114521201537011700 0ustar sun00315stepsC Last change: BCM 2 Oct 1998 8:58 am SUBROUTINE nrmtst(Y,Nobs,Lprt,Lsav,Lsavlg) IMPLICIT NONE c----------------------------------------------------------------------- c This routine generates the kurtosis and skewness of the residuals c to test the normality of the residuals. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL T,F DOUBLE PRECISION ZERO,SIX PARAMETER(ZERO=0D0,SIX=6D0,T=.TRUE.,F=.false.) c----------------------------------------------------------------------- DOUBLE PRECISION Y,ga,m2,m3,m4,ymu,ymymu,ppu,ppl,ykurt,dnobs, & yskew,seskew INTEGER i,ppi,Nobs LOGICAL Lprt,Lsav,Lsavlg,sig,sigskw DIMENSION Y(*) c----------------------------------------------------------------------- DOUBLE PRECISION intrpp,totals EXTERNAL intrpp,totals c----------------------------------------------------------------------- INCLUDE 'nrmtst.var' c----------------------------------------------------------------------- c Compute Geary's a, Kurtosis statistic c----------------------------------------------------------------------- sig=F sigskw=F ymu = totals(Y,1,Nobs,1,1) ga=ZERO m2=ZERO m3=ZERO m4=ZERO dnobs=DBLE(NOBS) ppu=ZERO DO i = 1, Nobs ymymu = (Y(i) - ymu) ga = ga + (ABS(ymymu) / dnobs) m2 = m2 + ((ymymu * ymymu) / dnobs) m3 = m3 + ((ymymu * ymymu* ymymu) / dnobs) m4 = m4 + ((ymymu * ymymu * ymymu * ymymu) / dnobs) END DO ga = ga / SQRT(m2) ykurt = (m4 / (m2*m2)) yskew = m3 / (m2 * SQRT(m2)) c----------------------------------------------------------------------- c Begin print out of normality diagnostics c----------------------------------------------------------------------- IF(Lprt)WRITE(Mt1,1010)Nobs c----------------------------------------------------------------------- c Compute percentage points for skewness statistic c----------------------------------------------------------------------- IF(Nobs.lt.25)THEN CALL writln('NOTE: The program cannot compute the significance of & skewness statistic',Mt1,Mt2,T) CALL writln(' on less than 25 observations.',Mt1,Mt2,F) RETURN ELSE IF(Nobs.ge.25.and.Nobs.lt.50)THEN ppi = ((Nobs - 25) / 5) + 1 ppu = intrpp(spp1,ns1,Nobs,ppi,PSKW1,F) ELSE IF(Nobs.ge.50.and.Nobs.lt.100)THEN ppi = ((Nobs - 50) / 10) + 1 ppu = intrpp(spp2,ns2,Nobs,ppi,PSKW2,F) ELSE IF(Nobs.ge.100.and.Nobs.lt.200)THEN ppi = ((Nobs - 100) / 25) + 1 ppu = intrpp(spp3,ns3,Nobs,ppi,PSKW3,F) ELSE IF(Nobs.ge.200.and.Nobs.lt.500)THEN ppi = ((Nobs - 200) / 50) + 1 ppu = intrpp(spp4,ns4,Nobs,ppi,PSKW4,F) ELSE IF(Nobs.ge.500)THEN seskew = sqrt(SIX/dnobs) ppu = 2.326D0 * seskew END IF ppl = ZERO-ppu c----------------------------------------------------------------------- c Print out and save (if necessary) skewness c----------------------------------------------------------------------- IF(yskew.lt.ppl)THEN sigskw=T IF(Lprt)WRITE(Mt1,1020)'Skewness coefficient',yskew, & '(significant negative skewness at one percent level)' IF(Lsav)WRITE(Nform,1030)'skewness',yskew,'-' IF(Lsavlg)WRITE(Ng,1030)' Skewness coefficient',yskew, & ' (significant negative skewness)' ELSE IF(yskew.gt.ppu)THEN sigskw=T IF(Lprt)WRITE(Mt1,1020)'Skewness coefficient',yskew, & '(significant positive skewness at one percent level)' IF(Lsav)WRITE(Nform,1030)'skewness',yskew,'+' IF(Lsavlg)WRITE(Ng,1030)' Skewness coefficient',yskew, & ' (significant positive skewness)' ELSE IF(Lprt)WRITE(Mt1,1020)'Skewness coefficient',yskew,' ' IF(Lsav)WRITE(Nform,1030)'skewness',yskew,' ' IF(Lsavlg)WRITE(Ng,1030)' Skewness coefficient',yskew,' ' END IF c----------------------------------------------------------------------- c Compute percentage points for Geary's a statistic c----------------------------------------------------------------------- IF(Nobs.lt.11)THEN CALL writln('NOTE: The program cannot compute the significance of & Geary''s a statistic',Mt1,Mt2,T) CALL writln(' on less than 11 observations.',Mt1,Mt2,F) RETURN ELSE IF(Nobs.ge.11.and.Nobs.lt.41)THEN ppi = ((Nobs - 11) / 5) + 1 ppu = intrpp(app1u,na1,Nobs,ppi,PAPP1,T) ppl = intrpp(app1l,na1,Nobs,ppi,PAPP1,T) ELSE IF(Nobs.ge.41.and.Nobs.lt.101)THEN IF(Nobs.eq.46)THEN ppu = app1u(8) ppl = app1l(8) ELSE ppi = ((Nobs - 41) / 10) + 1 ppu = intrpp(app2u,na2,Nobs,ppi,PAPP2,Nobs.lt.81) ppl = intrpp(app2l,na2,Nobs,ppi,PAPP2,Nobs.lt.81) END IF ELSE IF(Nobs.ge.101.and.Nobs.le.1001)THEN ppi = ((Nobs - 101) / 100) + 1 ppu = intrpp(app3u,na3,Nobs,ppi,PAPP3,Nobs.lt.801) ppl = intrpp(app3l,na3,Nobs,ppi,PAPP3,Nobs.lt.801) ELSE IF(Nobs.gt.1001)THEN CALL writln('NOTE: The program cannot compute the significance of & Geary''s a statistic',Mt1,Mt2,T) CALL writln(' on more than 1001 observations.',Mt1,Mt2,F) RETURN END IF c----------------------------------------------------------------------- c Print out and save (if necessary) Geary's a statistic c----------------------------------------------------------------------- IF(ga.lt.ppl.or.ga.gt.ppu)THEN sig=T IF(Lprt)WRITE(Mt1,1020)'Geary''s a',ga, & '(significant at one percent level)' IF(Lsav)WRITE(Nform,1030)'a',ga,'*' IF(Lsavlg)WRITE(Ng,1030)' Geary''s a statistic',ga, & ' (significant)' ELSE IF(Lprt)WRITE(Mt1,1020)'Geary''s a',ga,' ' IF(Lsav)WRITE(Nform,1030)'a',ga,' ' IF(Lsavlg)WRITE(Ng,1030)' Geary''s a statistic',ga,' ' END IF c----------------------------------------------------------------------- c Compute percentage points for Kurtosis statistic c----------------------------------------------------------------------- IF(Nobs.lt.50)THEN CALL writln('NOTE: The program cannot perform hypothesis tests fo &r kurtosis on',Mt1,Mt2,T) CALL writln(' less than 50 observations.',Mt1,Mt2,F) RETURN ELSE IF(Nobs.ge.50.and.Nobs.lt.100)THEN ppi = ((Nobs - 50) / 25) + 1 ppu = intrpp(kpp1u,nk1,Nobs,ppi,PKPP1,T) ppl = intrpp(kpp1l,nk1,Nobs,ppi,PKPP1,T) ELSE IF(Nobs.ge.100.and.Nobs.le.1000)THEN IF(Nobs.eq.125)THEN ppu = kpp1u(5) ppl = kpp1l(5) ELSE ppi = ((Nobs - 100) / 50) + 1 ppu = intrpp(kpp2u,nk2,Nobs,ppi,PKPP2,Nobs.lt.900) ppl = intrpp(kpp2l,nk2,Nobs,ppi,PKPP2,Nobs.lt.900) END IF ELSE IF(Nobs.ge.1001)THEN CALL writln('NOTE: The program cannot perform hypothesis tests fo &r kurtosis on more',Mt1,Mt2,T) CALL writln(' than 1000 observations.',Mt1,Mt2,F) RETURN END IF c----------------------------------------------------------------------- c Print out and save (if necessary) Kurtosis c----------------------------------------------------------------------- IF(ykurt.lt.ppl.or.ykurt.gt.ppu)THEN IF(.not.sig)sig=T IF(Lprt)WRITE(Mt1,1020)'Kurtosis',ykurt, & '(significant at one percent level)' IF(Lsav)WRITE(Nform,1030)'kurtosis',ykurt,'*' IF(Lsavlg)WRITE(Ng,1030)' Kurtosis',ykurt,' (significant)' ELSE IF(Lprt)WRITE(Mt1,1020)'Kurtosis',ykurt,' ' IF(Lsav)WRITE(Nform,1030)'kurtosis',ykurt,' ' IF(Lsavlg)WRITE(Ng,1030)' Kurtosis',ykurt,' ' END IF c----------------------------------------------------------------------- c Print out normality diagnostics c----------------------------------------------------------------------- IF(Lprt)THEN IF(sigskw)THEN WRITE(Mt1,1060) ELSE IF(sig)THEN WRITE(Mt1,1050)PRGNAM ELSE WRITE(Mt1,1040) END IF END IF END IF c----------------------------------------------------------------------- 1010 FORMAT(/,' Number of residuals : ',i5,/) 1020 FORMAT(' ',a,t26,':',f10.4,t40,a) 1030 FORMAT(a,':',f10.4,1x,a) 1040 FORMAT(/,' No indication of lack of normality.') 1050 FORMAT(/,' A significant value of one of these statistics ', & 'indicates that the', & /,' standardized residuals do not follow a standard ', & 'normal distribution.', & /,' If the regARIMA model fits the data well, such lack ', & 'of normality', & /,' ordinarily causes no problems.',/, & /,' However, a significant value can occur because ', & 'certain data effects are', & /,' not captured well by the model. Sometimes these ', & 'effects can be captured', & /,' by additional or different regressors (e.g. trading ', & 'day, holiday or ',/,' outlier regressors).',/, & /,' There are other important effects that can cause a ', & 'significant value,', & /,' such as random variation of the coefficients or ', & 'time-varying conditional', & /,' variances, which cannot be represented by regARIMA ', & 'models. These other', & /,' effects cause the t-tests, AIC''s and forecast ', & 'coverage intervals of', & /,' ',a,' to have reduced reliability. Their ', & 'presence is often', & /,' indicated by significant (high) values of the ', & 'Ljung-Box Q-statistics of',/,' the squared residuals.') 1060 FORMAT(/,' Significant skewness has been detected in the ', & 'model residuals;', & /,' this makes the Geary''s a and Kurtosis statistics ', & 'unreliable indicators', & /,' of the normality of the residuals.') c----------------------------------------------------------------------- RETURN END nrmtst.var0000664006604000003110000000650614521201540012233 0ustar sun00315steps INTEGER PAPP1,PAPP2,PAPP3,PKPP1,PKPP2,PSKW1,PSKW2,PSKW3,PSKW4 PARAMETER(PAPP1=9,PAPP2=7,PAPP3=10,PKPP1=5,PKPP2=19,PSKW1=6, & PSKW2=6,PSKW3=5,PSKW4=7) c----------------------------------------------------------------------- DOUBLE PRECISION app1u,app2u,app3u,kpp1u,kpp2u,app1l,app2l,app3l, & kpp1l,kpp2l,spp1,spp2,spp3,spp4 INTEGER na1,na2,na3,nk1,nk2,ipp,ns1,ns2,ns3,ns4 DIMENSION app1u(PAPP1),app2u(PAPP2),app3u(PAPP3), & app1l(PAPP1),app2l(PAPP2),app3l(PAPP3), & kpp1u(PKPP1),kpp2u(PKPP2),kpp1l(PKPP1),kpp2l(PKPP2), & spp1(PSKW1),spp2(PSKW2),spp3(PSKW3),spp4(PSKW4), & na1(PAPP1),na2(PAPP2),na3(PAPP3),nk1(PKPP1),nk2(PKPP2), & ns1(PSKW1),ns2(PSKW2),ns3(PSKW3),ns4(PSKW4) c----------------------------------------------------------------------- DATA (app1u(ipp),ipp=1,PAPP1)/ & 0.9359,0.9137,0.9001,0.8901,0.8827,0.8769,0.8722,0.8682,0.8648/ DATA (app1l(ipp),ipp=1,PAPP1)/ & 0.6675,0.6829,0.6950,0.7040,0.7110,0.7167,0.7216,0.7256,0.7291/ DATA (na1(ipp),ipp=1,PAPP1)/11,16,21,26,31,36,41,46,51/ c----------------------------------------------------------------------- DATA (app2u(ipp),ipp=1,PAPP2)/ & 0.8722,0.8648,0.8592,0.8549,0.8515,0.8484,0.8460/ DATA (app2l(ipp),ipp=1,PAPP2)/ & 0.7216,0.7291,0.7347,0.7393,0.7430,0.7460,0.7487/ DATA (na2(ipp),ipp=1,PAPP2)/41,51,61,71,81,91,101/ c----------------------------------------------------------------------- DATA (app3u(ipp),ipp=1,PAPP3)/ & 0.8460,0.8322,0.8260,0.8223,0.8198,0.8179,0.8164,0.8152,0.8142, & 0.8134/ DATA (app3l(ipp),ipp=1,PAPP3)/ & 0.7487,0.7629,0.7693,0.7731,0.7757,0.7776,0.7791,0.7803,0.7814, & 0.7822/ DATA (na3(ipp),ipp=1,PAPP3)/ & 101,201,301,401,501,601,701,801,901,1001/ c----------------------------------------------------------------------- DATA (kpp1u(ipp),ipp=1,PKPP1)/4.88,4.59,4.39,4.24,4.13/ DATA (kpp1l(ipp),ipp=1,PKPP1)/1.95,2.08,2.18,2.24,2.29/ DATA (nk1(ipp),ipp=1,PKPP1)/50,75,100,125,150/ c----------------------------------------------------------------------- DATA (kpp2u(ipp),ipp=1,PKPP2)/ & 4.39,4.13,3.98,3.87,3.79,3.72,3.67,3.63,3.60,3.57,3.54,3.52, & 3.50,3.48,3.46,3.45,3.43,3.42,3.41/ DATA (kpp2l(ipp),ipp=1,PKPP2)/ & 2.18,2.29,2.37,2.42,2.46,2.50,2.52,2.55,2.57,2.58,2.60,2.61, & 2.62,2.64,2.65,2.66,2.66,2.67,2.68/ DATA (nk2(ipp),ipp=1,PKPP2)/ & 100,150,200,250,300,350,400,450,500,550,600,650,700,750,800, & 850,900,950,1000/ c----------------------------------------------------------------------- DATA (spp1(ipp),ipp=1,PSKW1)/1.061,0.986,0.923,0.870,0.825,0.787/ DATA (ns1(ipp),ipp=1,PSKW1)/25,30,35,40,45,50/ DATA (spp2(ipp),ipp=1,PSKW2)/0.787,0.723,0.673,0.631,0.596,0.567/ DATA (ns2(ipp),ipp=1,PSKW2)/50,60,70,80,90,100/ DATA (spp3(ipp),ipp=1,PSKW3)/0.567,0.508,0.464,0.430,0.403/ DATA (ns3(ipp),ipp=1,PSKW3)/100,125,150,175,200/ DATA (spp4(ipp),ipp=1,PSKW4)/0.403,0.360,0.329,0.305,0.285,0.269, & 0.255/ DATA (ns4(ipp),ipp=1,PSKW4)/200,250,300,350,400,450,500/ c----------------------------------------------------------------------- nsums.i0000664006604000003110000000031514521201540011501 0ustar sun00315steps INTEGER nSeatsSer,noTratadas,wSposBphi,wSstochTD,wSstatseas DOUBLE PRECISION wSrmod,wSxl common /cnsums/wSrmod,wSxl,nSeatsSer,noTratadas,wSposBphi, $ wSstochTD,wSstatseas numaff.f0000664006604000003110000000475014521201540011614 0ustar sun00315steps INTEGER FUNCTION numaff(Betals,Muladd,Nterm) IMPLICIT NONE c----------------------------------------------------------------------- c Determime how many SI ratios are effected by a level shift of a c given magnitude (Betals is the coefficient in the log scale). c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ONEHND PARAMETER(ONE=1D0,ONEHND=100D0) c----------------------------------------------------------------------- DOUBLE PRECISION Betals,pctchg INTEGER i,itrend,numsi,Muladd,Nterm DOUBLE PRECISION limsi DIMENSION numsi(12,5),limsi(11) c----------------------------------------------------------------------- DATA (numsi(i,1), i = 1,12) / 0,1,1,1,2,2,2,3,3,4,4,5 / DATA (numsi(i,2), i = 1,12) / 0,1,1,1,1,2,2,2,2,2,3,3 / DATA (numsi(i,3), i = 1,12) / 0,0,1,1,1,1,1,1,2,2,2,2 / DATA (numsi(i,4), i = 1,12) / 0,0,0,1,1,1,1,1,1,1,1,1 / DATA (numsi(i,5), i = 1,12) / 0,0,0,0,0,0,1,1,1,1,1,1 / DATA (limsi(i), i = 1,11) / 1.1D0,1.2D0,1.3D0,1.5D0,1.8D0,1.9D0, & 2.0D0,2.6D0,2.9D0,3.6D0,5.5D0 / c----------------------------------------------------------------------- IF(Muladd.eq.1)THEN numaff=1 RETURN END IF c----------------------------------------------------------------------- c Determine the precentage change in the level due to the level c shift outlier. c----------------------------------------------------------------------- pctchg = dabs((ONE/dexp(Betals)-ONE)*ONEHND) c----------------------------------------------------------------------- c Set trend index c----------------------------------------------------------------------- IF (Nterm.ge.23) THEN itrend=1 ELSE IF (Nterm.ge.13) THEN itrend=2 ELSE IF (Nterm.ge.9) THEN itrend=3 ELSE IF (Nterm.ge.7) THEN itrend=4 ELSE itrend=5 END IF c----------------------------------------------------------------------- c set number of observations effected based on percent change in c level due to LS c----------------------------------------------------------------------- DO i=1,11 IF(pctchg.le.limsi(i))THEN numaff=numsi(i,itrend) RETURN END IF END DO c----------------------------------------------------------------------- numaff=numsi(12,itrend) RETURN END numfmt.f0000664006604000003110000000500214521201541011636 0ustar sun00315stepsC Last change: BCM 17 Nov 97 1:18 pm **==numfmt.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE numfmt(Vec,Nelt,Outdec,Clwdth,Mindec) IMPLICIT NONE c----------------------------------------------------------------------- c Figures out the minimum number of columns needed to print out c a vector given the outdec nmber of digits are needed after the decimal c Mindec shows that every element will have at least 1 significant c digit if mindec digits are used instead of outdec. c----------------------------------------------------------------------- INTEGER Clwdth,ielt,imndec,iwdth,Mindec,Nelt,Outdec DOUBLE PRECISION absx,elti,lgabsx,lg9p5,Vec DIMENSION Vec(Nelt) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c Intialize the column width, and minimum number of necessary c decimals. c----------------------------------------------------------------------- lg9p5=log10(9.5D0) Clwdth=0 Mindec=0 c----------------------------------------------------------------------- c Max of clwdth, and mindec through the vector c----------------------------------------------------------------------- DO ielt=1,Nelt elti=Vec(ielt) IF(dpeq(elti,0D0))THEN lgabsx=1D0 ELSE lgabsx=log10(abs(elti)) END IF iwdth=max(1,int(lgabsx)+1) IF(elti.lt.0D0)iwdth=iwdth+1 IF(Outdec.gt.0)iwdth=iwdth+Outdec+1 Clwdth=max(Clwdth,iwdth) IF(dpeq(elti,0D0))THEN imndec=0 c ------------------------------------------------------------------ ELSE lgabsx=lgabsx-lg9p5 c----------------------------------------------------------------------- c ceiling(abs(x))-1 c----------------------------------------------------------------------- IF(lgabsx.lt.lg9p5)THEN absx=abs(lgabsx) IF(absx.gt.dble(int(absx)))THEN imndec=int(absx)+1 c ------------------------------------------------------------------ ELSE imndec=int(absx) END IF imndec=imndec-1 c ------------------------------------------------------------------ ELSE imndec=0 END IF END IF Mindec=max(Mindec,imndec) END DO c ------------------------------------------------------------------ RETURN END olsreg.f0000664006604000003110000001002614521201541011625 0ustar sun00315stepsC Last change: BCM 26 Jan 98 1:10 pm SUBROUTINE olsreg(Xy,Nrxy,Ncxy,Pcxy,B,Chlxpx,Pxpx,Info) IMPLICIT NONE c----------------------------------------------------------------------- c Does ordinary least squares regression by forming the normal c equations and solving them using a Cholesky decomposition. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c b d Output nc long output vector of regression estimates c i i Local do loop index c lerr l Local error for X'X not positive definite (.true.). Used in the c cholesky decomposition return c nb i Local number of b elements and the number of columns in the c X matrix c ncxy i Input number of columns in the X:y matrix and rows in the b c vector c nrxy i Input number of rows in the X:y matrix c pxpx i Input PARAMETER for the maximum number of elements in c [X:y]'[X:y] c pcxy i Input PARAMETER for the polumn dimension of [X:y]. Note c the data is always in the pcxyth column c xelt i Local index for the current element in [X:y]'[X:y]. c xy d Input nr by ncxy matrix of regression variables and data c in last, pcxyth, column of [X:y] c chlxpx d Ouput pxpx array long for the Cholesky decomposition of c the X'X matrix will be in the first (ncxy-1)ncxy/2 elements, c the z=chol(X'X)b in the (ncxy-1)ncxy/2+1 to ncxy(ncxy+1)/2-1, c and the square root of the residual sum of squares in the c ncxy(ncxy+1)/2th element. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ INTEGER i,Info,nb,Nrxy,Ncxy,xelt,Pcxy,Pxpx DOUBLE PRECISION B,Chlxpx,Xy DIMENSION B(Ncxy-1),Chlxpx(Pxpx),Xy(Pcxy,Nrxy) c----------------------------------------------------------------------- c Check that the packed chlxpx is large enough to handle [X:y]'[X:y] c----------------------------------------------------------------------- IF(Ncxy*(Ncxy+1)/2.gt.Pxpx)THEN CALL errhdr WRITE(STDERR,1010)Ncxy,Ncxy,Pxpx WRITE(Mt2,1010)Ncxy,Ncxy,Pxpx 1010 FORMAT(/,' Elements needed for [X:y]''[X:y] =',i3,' *(',i3, & ' +1)/2 >',i5) CALL abend RETURN END IF c----------------------------------------------------------------------- c Form X'X and X'y (b) of the normal equations by forming [X:y]'[X:y] c----------------------------------------------------------------------- CALL xprmx(Xy,Nrxy,Ncxy,Pcxy,Chlxpx) c----------------------------------------------------------------------- c Find the Cholesky decomposition of [X:y]'[X:y] and solve the normal c equations. DPOFA does the factorization so c [L' z ] c [0 sqrt(RRS)] c----------------------------------------------------------------------- CALL dppfa(Chlxpx,Ncxy,Info) IF(Info.le.0.or.Info.eq.Ncxy)THEN c----------------------------------------------------------------------- c Betas are L'b=z so solve the upper triangular system for them c----------------------------------------------------------------------- nb=Ncxy-1 xelt=nb*Ncxy/2 CALL copy(Chlxpx(xelt+1),nb,1,B) c ------------------------------------------------------------------ DO i=nb,1,-1 B(i)=B(i)/Chlxpx(xelt) xelt=xelt-i CALL daxpy(i-1,-B(i),Chlxpx(xelt+1),1,B,1) END DO c----------------------------------------------------------------------- c Info is reset in the case of a y is linearly dependant on X c----------------------------------------------------------------------- Info=0 END IF c ------------------------------------------------------------------ RETURN END opnfil.f0000664006604000003110000000636414521201541011633 0ustar sun00315stepsC Last change: BCM 1 Oct 1998 10:56 am SUBROUTINE opnfil(Lopen,Lgrfdr,Itbl,Fh,Locok) IMPLICIT NONE c----------------------------------------------------------------------- c opnfil.f, Release 1, Subroutine Version 1.6, Modified 03 Nov 1994. c----------------------------------------------------------------------- c Opens a file with the name of the spec file with the extension c replaced with the table extension. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'tbltitle.prm' INCLUDE 'notset.prm' INCLUDE 'error.cmn' INCLUDE 'filetb.cmn' c ------------------------------------------------------------------ LOGICAL F,T PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------ CHARACTER fil*(PFILCR),fildes*(PTTLEN),gcode*(15) LOGICAL Locok,Lopen,Lgrfdr INTEGER Fh,Itbl,nchr,ndescr,ncode c ------------------------------------------------------------------ c Added by BCM 12/29/94 - common block to control printing of c file table. c----------------------------------------------------------------------- c Generated by running strary and cutting and pasting the output. c----------------------------------------------------------------------- INCLUDE 'tbllog.prm' INCLUDE 'filext.prm' INCLUDE 'gmeta.prm' c ------------------------------------------------------------------ INCLUDE 'filext.var' INCLUDE 'gmeta.var' c ------------------------------------------------------------------ IF(Lgrfdr)THEN nchr=Ngrfcr+4 fil(1:nchr)=Curgrf(1:Ngrfcr)//'.'//tbxdic(Itbl) CALL getstr(GMTDIC,gmtptr,PGMT,Itbl,gcode,ncode) WRITE(Grfout,1000)gcode(1:ncode),fil(1:nchr) 1000 FORMAT(a,t12,a) ELSE nchr=Nfilcr+4 fil(1:nchr)=Cursrs(1:Nfilcr)//'.'//tbxdic(Itbl) END IF C ------------------------------------------------------------------ c Get the file description from one of the data dictionaries C ------------------------------------------------------------------ CALL getdes(Itbl,fildes,ndescr,F) IF(Lfatal)RETURN C ------------------------------------------------------------------ IF(Lopen)THEN Fh=NOTSET CALL fopen(fil(1:nchr),fildes(1:ndescr),'UNKNOWN',Fh,Locok) c ------------------------------------------------------------------ ELSE INQUIRE(FILE=fil(1:nchr),EXIST=lexist) IF(Fhandl.eq.0)RETURN IF(Lfrtop)THEN WRITE(Fhandl,1010) 1010 FORMAT(/, &' FILE SAVE REQUESTS (* indicates file exists and will be overwrit &ten)') Lfrtop=F END IF c ------------------------------------------------------------------ IF(lexist)THEN WRITE(Fhandl,1020)fil(1:nchr),'*',fildes(1:ndescr) 1020 FORMAT(' ',a,a,' ',a) Locok=F c ------------------------------------------------------------------ ELSE WRITE(Fhandl,1020)fil(1:nchr),' ',fildes(1:ndescr) Locok=T END IF END IF c ------------------------------------------------------------------ RETURN END orisrs.cmn0000664006604000003110000000030714521201541012204 0ustar sun00315steps DOUBLE PRECISION Stcsi,Sto,Stoap,Stopp,Stocal DIMENSION Stcsi(PLEN),Sto(PLEN),Stoap(PLEN),Stopp(PLEN), & Stocal(PLEN) COMMON /orisrs/ Stcsi,Sto,Stoap,Stopp,Stocal otlrev.cmn0000664006604000003110000000176314521201541012205 0ustar sun00315stepsc----------------------------------------------------------------------- c Otrttl - data dictionary containing the names of the outliers c deleted during the revisions/sliding spans analysis c Botr - parameter values for the outliers deleted during the c revisions/sliding spans analysis c Otrptr - pointer vector for data dictionary for outliers deleted c during the revisions/sliding spans analysis c Notrtl - number of outliers deleted during the revisions/sliding c spans analysis c----------------------------------------------------------------------- CHARACTER Otrttl*(PCOLCR*PB) LOGICAL Fixotr DOUBLE PRECISION Botr INTEGER Otrptr,Notrtl DIMENSION Otrptr(0:PB),Botr(PB),Fixotr(PB) c----------------------------------------------------------------------- COMMON /Otrev/Botr,Otrptr,Notrtl,Fixotr,Otrttl c----------------------------------------------------------------------- otsort.f0000664006604000003110000000667014521201541011676 0ustar sun00315steps SUBROUTINE otsort() IMPLICIT NONE c----------------------------------------------------------------------- c Sort outliers just read into regARIMA data dictionary, c while maintaining initial values read in from b argument. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- CHARACTER atrttl*(PCOLCR*PB),str*(PCOLCR) DOUBLE PRECISION batr LOGICAL vfix INTEGER atrptr,j,jgrp,icol,itype,nreg,natrtl,vtype,nchr,iotlr DIMENSION atrptr(0:PB),batr(PB),vtype(PB),vfix(PB) c----------------------------------------------------------------------- c check to see if there are outliers specified by the user. c if so, keep track of position of first outlier. If not, c return. c----------------------------------------------------------------------- j=0 DO jgrp=1,Ngrp icol=Grp(jgrp-1) itype=Rgvrtp(icol) IF(itype.eq.PRGTAO.or.itype.eq.PRGTLS.or.itype.eq.PRGTRP.or. & itype.eq.PRGTMV.or.itype.eq.PRGTTC.or.itype.eq.PRGTSO.or. & itype.eq.PRGTTL.or.itype.eq.PRGTQI.or.itype.eq.PRGTQD.or. & itype.eq.PRSQAO.or.itype.eq.PRSQLS)THEN j=icol GO TO 1 END IF END DO 1 IF(j.eq.0)RETURN c----------------------------------------------------------------------- c delete all outliers but the first, keeping track of the variable c type, name, initial value, and fixed indicator c----------------------------------------------------------------------- CALL intlst(PB,atrptr,natrtl) nreg=natrtl+1 j=j+1 DO icol=Nb,j,-1 itype=Rgvrtp(icol) IF(itype.eq.PRGTAO.or.itype.eq.PRGTLS.or.itype.eq.PRGTRP.or. & itype.eq.PRGTMV.or.itype.eq.PRGTTC.or.itype.eq.PRGTSO.or. & itype.eq.PRGTTL.or.itype.eq.PRGTQI.or.itype.eq.PRGTQD.or. & itype.eq.PRSQAO.or.itype.eq.PRSQLS)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(.not.Lfatal) & CALL insstr(str(1:nchr),nreg,PB,atrttl,atrptr,natrtl) IF(Lfatal)RETURN batr(natrtl)=B(icol) vtype(natrtl)=itype vfix(natrtl)=Regfx(icol) nreg=nreg+1 iotlr=icol CALL dlrgef(iotlr,Nrxy,1) IF(Lfatal)RETURN END IF END DO c----------------------------------------------------------------------- c if no outliers were deleted, return c----------------------------------------------------------------------- IF(natrtl.eq.0)RETURN c----------------------------------------------------------------------- c else, add the outliers one at a time, so that the program will c update the information appropriately. c----------------------------------------------------------------------- DO icol=1,natrtl CALL getstr(atrttl,atrptr,natrtl,icol,str,nchr) IF(.not.Lfatal)CALL adrgef(batr(icol),str(1:nchr),str(1:nchr), & vtype(icol),vfix(icol),F) IF(Lfatal)RETURN END DO c----------------------------------------------------------------------- RETURN END otxrev.cmn0000664006604000003110000000176414521201541012222 0ustar sun00315stepsc----------------------------------------------------------------------- c Otxttl - data dictionary containing the names of the outliers c deleted during the revisions/sliding spans analysis c Botx - parameter values for the outliers deleted during the c revisions/sliding spans analysis c Otxptr - pointer vector for data dictionary for outliers deleted c during the revisions/sliding spans analysis c Notxtl - number of outliers deleted during the revisions/sliding c spans analysis c----------------------------------------------------------------------- CHARACTER Otxttl*(PCOLCR*PB) LOGICAL Fixotx DOUBLE PRECISION Botx INTEGER Otxptr,Notxtl DIMENSION Otxptr(0:PB),Botx(PB),Fixotx(PB) c----------------------------------------------------------------------- COMMON /Otxrev/Botx,Otxptr,Notxtl,Fixotx,Otxttl c----------------------------------------------------------------------- outchr.f0000664006604000003110000000655414521201541011651 0ustar sun00315stepsC Last change: BCM 25 Nov 97 3:35 pm **==out.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE outchr(Title,Ntitle,Icode,Icod2) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'tbltitle.prm' INCLUDE 'units.cmn' INCLUDE 'chrt.cmn' c ------------------------------------------------------------------ CHARACTER for*(18),for1*(22),Title*(PTTLEN) DOUBLE PRECISION almn,almx INTEGER i,Icod2,Icode,iline,j,j2,Ntitle,n DIMENSION Title(2),Ntitle(2) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ C WRITE OUT THE CHART C*************** c ------------------------------------------------------------------ c Change 9/96 to handle more than one title BCM c Change 4/97 to incorporate title dictionary, print only defined c part of title (BCM) c ------------------------------------------------------------------ DO i=1,2 IF(Ntitle(i).gt.0)WRITE(Mt1,1010)Title(i)(1:Ntitle(i)) END DO 1010 FORMAT(1X,A) c ------------------------------------------------------------------ iline=Icmax+1 almn=Ymin almx=Ymax IF(Ymin.lt.0)almn=-almn IF(.not.dpeq(almn,0D0))almn=dlog10(almn) IF(Ymax.lt.0)almx=-almx IF(.not.dpeq(almx,0D0))almx=dlog10(almx) WRITE(for1,1020)iline 1020 FORMAT('(1X,F10.2,',I3,'A1,F10.2)') IF(almn.lt.-6D0.or.almx.gt.6D0)THEN for1(5:5)='E' for1(9:9)='4' for1(17:17)='E' for1(21:21)='4' END IF IF(Icod2.eq.17)THEN for1(9:9)='4' for1(21:21)='4' IF(almn.lt.-4D0.or.almx.gt.4D0)THEN for1(5:5)='E' for1(17:17)='E' END IF END IF j2=1 DO j=1,55 IF(j.eq.1.or.j.eq.55)THEN WRITE(Mt1,1030)(Ip(i),i=1,10),(Ia(i,j),i=1,iline) 1030 FORMAT(1X,120A1) ELSE IF(j.eq.Imid(j2))THEN WRITE(Mt1,for1)Ymid(j2),(Ia(i,j),i=1,iline),Ymid(j2) j2=j2+1 IF(j2.gt.14)j2=1 ELSE WRITE(Mt1,1040)(Ia(i,j),i=1,iline) 1040 FORMAT(1X,10X,110A1) END IF END DO IF(Icode.eq.7)THEN WRITE(Mt1,1050)Iyear(1),Iyear(Nyr) 1050 FORMAT(T20,I4,' TO ',I4) ELSE IF(Icode.eq.0)THEN IF(Icod2.eq.0)THEN WRITE(Mt1,1060) & 'S=SEASONAL FREQUENCIES, T=TRADING DAY FREQUENCIES' ELSE WRITE(Mt1,1060)'S=SEASONAL FREQUENCIES' END IF 1060 FORMAT(12X,A) ELSE IF(Nseas.eq.12)THEN n=min0(9,Nyr) IF(Icmax.le.61)n=min0(5,Nyr) IF(Ifrst.le.6)THEN WRITE(Mt1,1070)(Iyear(i),i=1,n) 1070 FORMAT(12X,I4,8(8X,I4)) ELSE WRITE(Mt1,1080)(Iyear(i),i=2,n) 1080 FORMAT(18X,I4,7(8X,I4)) END IF ELSE n=min0(14,Inyr) IF(Icmax.le.61)n=min0(8,Inyr) for='(12X,I4,12(4X,I4))' IF(Ifrst.eq.1)THEN for(10:10)='3' ELSE IF(Ifrst.eq.2)THEN for(3:3)='5' ELSE IF(Ifrst.eq.3)THEN for(3:3)='4' ELSE IF(Ifrst.eq.4)THEN for(3:3)='3' END IF WRITE(Mt1,for)(Iyear(i),i=1,n) END IF RETURN END pacf.f0000664006604000003110000000607314521201541011252 0ustar sun00315stepsC Last change: BCM 13 Nov 97 9:55 am **==pacf.f processed by SPAG 4.03F at 09:51 on 1 Mar 1994 SUBROUTINE pacf(Nefobs,Sp,R,Se,Nr,Lprt) IMPLICIT NONE c----------------------------------------------------------------------- c PACF computes the sample partial autocorrelation function c by solving the Yule-Walker Equations. Must first have called ACF c to get the sample autocorrelations. c----------------------------------------------------------------------- c Name type description c----------------------------------------------------------------------- c lprt l Input logical to print the table c ncol i Local number of column of autocorrelations to print c nefobs i Input of effective observations c nr i Input length of vector r, sample autocorrelations and c pacf's c r d Input vector of sample autocorrelations c fkk d Local vector of sample partial autocorrelations c se d Local vector of standard errors c sp i Input length of the seasonal period c zero d Local PARAMETER for 0.0d0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'units.cmn' c ------------------------------------------------------------------ INTEGER PR DOUBLE PRECISION ZERO PARAMETER(PR=PLEN/4,ZERO=0D0) c ------------------------------------------------------------------ LOGICAL Lprt INTEGER i,isp,j,jsp,l,mp1,ncol,Nefobs,Nr,Sp DOUBLE PRECISION dtop,dbot,fkk,p,R,Se,sep DIMENSION fkk(PR),p(PR,PR),R(PR),Se(PR) c ------------------------------------------------------------------ sep=1/sqrt(dble(Nefobs)) p(1,1)=R(1) fkk(1)=p(1,1) Se(1)=sep c ------------------------------------------------------------------ DO l=2,Nr Se(l)=sep dtop=ZERO dbot=ZERO c ------------------------------------------------------------------ DO j=1,l-1 dtop=dtop+p(l-1,j)*R(l-j) dbot=dbot+p(l-1,j)*R(j) END DO c ------------------------------------------------------------------ p(l,l)=(R(l)-dtop)/(1-dbot) fkk(l)=p(l,l) c ------------------------------------------------------------------ DO j=1,l-1 p(l,j)=p(l-1,j)-p(l,l)*p(l-1,l-j) END DO END DO c ------------------------------------------------------------------ IF(Lprt)THEN ncol=Sp IF(Sp.eq.1)ncol=10 IF(Sp.gt.12)ncol=12 c ------------------------------------------------------------------ mp1=(Nr-1)/ncol+1 DO i=1,mp1 isp=(i-1)*ncol+1 jsp=min(isp+ncol-1,Nr) WRITE(Mt1,1010)(j,j=isp,jsp) 1010 FORMAT(/,' Lag ',12I6) WRITE(Mt1,1020)(fkk(j),j=isp,jsp) 1020 FORMAT(' PACF',12F6.2) WRITE(Mt1,1030)(Se(j),j=isp,jsp) 1030 FORMAT(' SE ',12F6.2) END DO END IF CALL copy(fkk,Nr,1,R) c ------------------------------------------------------------------ RETURN END pass0.f0000664006604000003110000001661614521201541011373 0ustar sun00315steps SUBROUTINE pass0(Trnsrs,Frstry,Isig,Istep,Lprt) IMPLICIT NONE c----------------------------------------------------------------------- c Check trading day, easter, constant regressors of final model c to see if they are significant. c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION Trnsrs,tval,cval,tderiv INTEGER ktd,keastr,kmu,begcol,endcol,igrp,Isig,nsig,icol,Frstry, & Istep DIMENSION Trnsrs(PLEN),tval(PB) c ------------------------------------------------------------------ INTEGER strinx DOUBLE PRECISION tstdrv LOGICAL dpeq,Lprt EXTERNAL strinx,tstdrv,dpeq c----------------------------------------------------------------------- ktd=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(ktd.eq.0.and.(Itdtst.eq.1.or.Itdtst.eq.4.or.Itdtst.eq.5)) & ktd=strinx(F,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Trading Day') IF(ktd.eq.0.and.Itdtst.eq.3) & ktd=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Stock Trading Day') IF(ktd.eq.0.and.Itdtst.eq.6) & ktd=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Stock Trading Day') c----------------------------------------------------------------------- keastr=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(keastr.eq.0) & keastr=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StatCanEaster') IF(keastr.eq.0) & keastr=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StockEaster') c----------------------------------------------------------------------- kmu=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(ktd.eq.0.and.keastr.eq.0.and.kmu.eq.0)RETURN c----------------------------------------------------------------------- c compute t-statistics for regressors c----------------------------------------------------------------------- CALL genrtt(tval) cval=1.96D0 c----------------------------------------------------------------------- c If trading day, check the t-statistics to see if there are c any significant trading day regressors c----------------------------------------------------------------------- IF(ktd.gt.0.and.Itdtst.gt.0)THEN nsig=0 DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF(Rgvrtp(begcol).eq.PRGTST.or.Rgvrtp(begcol).eq.PRGTTD.or. & Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRATTD.or. & Rgvrtp(begcol).eq.PRGTLM.or.Rgvrtp(begcol).eq.PRGTLQ.or. & Rgvrtp(begcol).eq.PRGTLY.or.Rgvrtp(begcol).eq.PRGTSL.or. & Rgvrtp(begcol).eq.PRRTLM.or.Rgvrtp(begcol).eq.PRRTLQ.or. & Rgvrtp(begcol).eq.PRRTLY.or.Rgvrtp(begcol).eq.PRRTSL.or. & Rgvrtp(begcol).eq.PRATLM.or.Rgvrtp(begcol).eq.PRATLQ.or. & Rgvrtp(begcol).eq.PRATLY.or.Rgvrtp(begcol).eq.PRATSL.or. & Rgvrtp(begcol).eq.PRG1TD.or.Rgvrtp(begcol).eq.PRR1TD.or. & Rgvrtp(begcol).eq.PRA1TD.or.Rgvrtp(begcol).eq.PRG1ST.or. & Rgvrtp(begcol).eq.PRR1ST.or.Rgvrtp(begcol).eq.PRA1ST.or. & Rgvrtp(begcol).eq.PRGUTD.or.Rgvrtp(begcol).eq.PRGULM.or. & Rgvrtp(begcol).eq.PRGULQ.or.Rgvrtp(begcol).eq.PRGULY)THEN DO icol=begcol,endcol IF(DABS(tval(icol)).ge.cval)nsig=nsig+1 END DO END IF END DO IF(nsig.lt.1)THEN tderiv=tstdrv(ktd) if (DABS(tderiv).lt.cval) ktd=-ktd END IF END IF IF(keastr.gt.0.and.Leastr)THEN nsig=0 begcol=Grp(keastr-1) endcol=Grp(keastr)-1 DO icol=begcol,endcol IF(DABS(tval(icol)).ge.cval)nsig=nsig+1 END DO IF(nsig.lt.1)keastr=-keastr END IF IF(Istep.eq.1)cval=Tsig IF(kmu.gt.0.and.Lchkmu)THEN begcol=Grp(kmu-1) IF(DABS(tval(begcol)).lt.cval)kmu=-kmu END IF IF(ktd.lt.0)THEN DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF(Rgvrtp(begcol).eq.PRGTST.or.Rgvrtp(begcol).eq.PRGTTD.or. & Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRATTD.or. & Rgvrtp(begcol).eq.PRGTLM.or.Rgvrtp(begcol).eq.PRGTLQ.or. & Rgvrtp(begcol).eq.PRGTLY.or.Rgvrtp(begcol).eq.PRGTSL.or. & Rgvrtp(begcol).eq.PRRTLM.or.Rgvrtp(begcol).eq.PRRTLQ.or. & Rgvrtp(begcol).eq.PRRTLY.or.Rgvrtp(begcol).eq.PRRTSL.or. & Rgvrtp(begcol).eq.PRATLM.or.Rgvrtp(begcol).eq.PRATLQ.or. & Rgvrtp(begcol).eq.PRATLY.or.Rgvrtp(begcol).eq.PRATSL.or. & Rgvrtp(begcol).eq.PRG1TD.or.Rgvrtp(begcol).eq.PRR1TD.or. & Rgvrtp(begcol).eq.PRA1TD.or.Rgvrtp(begcol).eq.PRG1ST.or. & Rgvrtp(begcol).eq.PRR1ST.or.Rgvrtp(begcol).eq.PRA1ST.or. & Rgvrtp(begcol).eq.PRGUTD.or.Rgvrtp(begcol).eq.PRGULM.or. & Rgvrtp(begcol).eq.PRGULQ.or.Rgvrtp(begcol).eq.PRGULY)THEN CALL dlrgef(begcol,Nrxy,endcol-begcol+1) IF(Lfatal)RETURN END IF END DO Isig=Isig+1 IF(Lprt)WRITE(Mt1,1010)'trading day' Aicint=0 c----------------------------------------------------------------------- c If leap year or other prior adjustment done with trading day, c remove effect of prior adjustment from series c----------------------------------------------------------------------- IF(Picktd)THEN Picktd=.false. IF(.not.(Fcntyp.eq.4.OR.dpeq(Lam,1D0)))THEN CALL rmlpyr(Trnsrs,Nobspf) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- END IF IF(keastr.lt.0)THEN igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(igrp.eq.0) & igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StatCanEaster') IF(igrp.eq.0) & igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StockEaster') begcol=Grp(igrp-1) endcol=Grp(igrp)-1 CALL dlrgef(begcol,Nrxy,endcol-begcol+1) IF(Lfatal)RETURN Isig=Isig+1 IF(Lprt)WRITE(Mt1,1010)'Easter' Aicind=0 END IF IF(kmu.lt.0)THEN igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Constant') begcol=Grp(igrp-1) CALL dlrgef(begcol,Nrxy,1) IF(Lfatal)RETURN Isig=Isig+1 IF(Lprt)WRITE(Mt1,1010)'constant' END IF c ------------------------------------------------------------------ c If regressors have been deleted, regenerate regression matrix c ------------------------------------------------------------------ IF(Isig.gt.0) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) c----------------------------------------------------------------------- 1010 FORMAT(5x,'Deleted ',a,' regressor(s) due to insignificant ', & 't-value.') RETURN END pass2.f0000664006604000003110000003322514521201542011371 0ustar sun00315steps SUBROUTINE pass2(Trnsrs,Frstry,Ipr,Idr,Iqr,Ips,Ids,Iqs,Lpr, & Ldr,Lqr,Lps,Lds,Lqs,Naut,Naut0,Plbox,Plbox0, & Bldf,Bldf0,Rvr,Rvr0,Lmu,Lmu0,A,A0,Na,Na0,Aici0, & Pcktd0,Aicit0,Adj0,Trns0,Fct2,Lprt,Lprtlb,Ismd0, & Cvl0,Nefobs,Nloop,Nround,Igo) IMPLICIT NONE c----------------------------------------------------------------------- c Compares two models to determine which is the final model c selected by the automatic modeling routine. c----------------------------------------------------------------------- LOGICAL T,F DOUBLE PRECISION ONE,PI,TWO,TWOPT8 PARAMETER(T=.true.,F=.false.,ONE=1D0,PI=3.14159265358979D0, & TWO=2D0,TWOPT8=2.8D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'series.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' INCLUDE 'adj.cmn' INCLUDE 'inpt.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER ardsp,ar1p,Frstry,Igo,Ipr,Idr,Iqr,Ips,Ids,Iqs,Lpr,Ldr,Lqr, & Lps,Lds,Lqs,Naut0,Naut,Nloop,Nround,ichk,Bldf,Bldf0,Na, & Na0,Nefobs,icol,Aicit0,Aici0 DOUBLE PRECISION A,A0,Cvl0,Fct2,Plbox,Plbox0,Rvr,Rvr0,Trnsrs,Adj0, & Trns0 LOGICAL Lmu,Lmu0,Lprt,Ismd0,inptok,Pcktd0,lcv,Lprtlb DIMENSION A(*),A0(*),Cvl0(POTLR),Trnsrs(*),adj0(*),trns0(*) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- ardsp=Nnsedf+Nseadf ar1p=ardsp+1 Igo=0 ichk=0 lcv=.false. IF(Naut0.le.Naut.AND. & (Idr.NE.Ldr.OR.Ids.NE.Lds.OR.Ipr.NE.Lpr.OR.Ips.NE.Lps.OR. & Iqr.NE.Lqr.OR.Iqs.NE.Lqs.OR.(Lmu.NEQV.Lmu0)))THEN IF(Plbox.LT.0.95D0.AND.Plbox0.LT.0.75D0.AND.Rvr0.LT.Rvr)THEN c write(Mt1,991)Plbox,Rvr,Plbox0,Rvr0 c 991 format(' Plbox = ',f10.3,' Rvr = ',e15.10,/, * & ' Plbox0 = ',f10.3,' Rvr0 = ',e15.10) ichk=1 ELSE IF(Nloop.eq.1.and.Plbox.GE.0.95D0.AND.Plbox0.LT.0.95D0)THEN c write(Mt1,992)Plbox,Plbox0 c 992 format(' Plbox = ',f10.3,' Plbox0 = ',f10.3) ichk=2 ELSE IF(Plbox.LT.0.95D0.AND.Plbox0.LT.0.75D0.AND.Plbox0.LT.Plbox & .and.Rvr0.LT.Fct*Rvr)THEN c write(Mt1,993)Plbox,Rvr,Fct,Plbox0,Rvr0 c 993 format(' Plbox = ',f10.3,' Rvr = ',e15.10,' Fct = ',f5.3,/, * & ' Plbox0 = ',f10.3,' Rvr0 = ',e15.10) ichk=3 ELSE IF(Plbox.GE.0.95D0.AND.Plbox0.LT.0.95D0.AND. & Rvr0.LT.Fct2*Rvr)THEN c write(Mt1,994)Plbox,Rvr,Fct2,Plbox0,Rvr0 c 994 format(' Plbox = ',f10.3,' Rvr = ',e15.10,' Fct2 = ',f5.3, c & /,' Plbox0 = ',f10.3,' Rvr0 = ',e15.10) ichk=4 ELSE IF(Idr.EQ.0.AND.Ids.EQ.1.AND.Ipr.EQ.1.AND. & Arimap(ar1p).GE.0.82D0.AND.Ips.EQ.0.AND.Iqr.LE.1.AND. & Iqs.EQ.1)THEN c write(Mt1,995)Arimap(ar1p) c 995 format(' arimap(ar1p) = ',f10.5) ichk=5 ELSE IF(Idr.EQ.1.AND.Ids.EQ.0.AND.Ipr.EQ.0.AND. & Arimap(ar1p).GE.0.65D0.AND.Ips.EQ.1.AND.Iqr.EQ.1.AND. & Iqs.LE.1)THEN c write(Mt1,995)Arimap(ar1p) ichk=6 END IF IF(ichk.gt.0)THEN c WRITE(Mt1,1000)ichk c 1000 FORMAT(' ichk (auto versus default model) = ',i3) CALL mdlint() CALL mdlset(Lpr,Ldr,Lqr,Lps,Lds,Lqs,inptok) IF(Lfatal)RETURN Nefobs=Nspobs-Nintvl Dnefob=dble(Nefobs) Lnlkhd=-(Lndtcv+Dnefob*(log(TWO*PI*Var)+ONE))/TWO c----------------------------------------------------------------------- c If choice of trading day changed from default to chosen model, c reset adjustment factors, transformed series to what they were c for the default model (BCM May 2004) c----------------------------------------------------------------------- IF((Pcktd0.and.(.not.Picktd)).or.((.not.Pcktd0).and.Picktd))THEN CALL copy(adj0,PLEN,1,Adj) CALL copy(trns0,PLEN,1,Trnsrs) CALL copy(Adj,Nadj,-1,Sprior(Setpri)) IF(.not.(Fcntyp.eq.4.OR.dpeq(Lam,1D0)))THEN IF(Pcktd0)THEN IF(Kfmt.eq.0)Kfmt=1 IF(.not.Lpradj)Lpradj=T ELSE IF(Nustad.eq.0.and.Nuspad.eq.0)THEN Kfmt=0 IF(Lpradj)Lpradj=F END IF END IF END IF END IF c----------------------------------------------------------------------- CALL bkdfmd(F) CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,Lautom) IF(.not.Lfatal)CALL prterr(nefobs,T) IF(Lfatal)RETURN IF(Lprt)THEN WRITE(Mt1,1010)' Model changed to ' IF(Lmu.EQV.Lmu0)THEN WRITE(Mt1,1020) Lpr,Ldr,Lqr,Lps,Lds,Lqs ELSE IF(Lmu0)THEN WRITE(Mt1,1021) Lpr,Ldr,Lqr,Lps,Lds,Lqs,' with constant term' ELSE WRITE(Mt1,1021) Lpr,Ldr,Lqr,Lps,Lds,Lqs, & ' without constant term' END IF END IF Ismd0=T Plbox=Plbox0 Rvr=Rvr0 Ipr=Lpr Idr=Ldr Iqr=Lqr Ips=Lps Ids=Lds Iqs=Lqs Lmu=Lmu0 Bldf=Bldf0 Aicind=Aici0 Aicint=Aicit0 CALL mkmdsn(Ipr,Idr,Iqr,Ips,Ids,Iqs,Bstdsn,Nbstds) IF(Lfatal)RETURN Na=Na0 CALL copy(A0,Na,1,A) END IF END IF * IF(ichk.eq.0)THEN * write(Mt1,996)Plbox,Rvr,Naut,Plbox0,Rvr0,Naut0 * 996 format(' Plbox = ',f10.3,' Rvr = ',e15.10,' Naut = ',i3,/, * & ' Plbox0 = ',f10.3,' Rvr0 = ',e15.10,' Naut0 = ',i3) * END IF Plbox0=Plbox Rvr0=Rvr Naut0=Naut c----------------------------------------------------------------------- c Check to see if automatic modeling needs to be redone. c add to nloop if so c----------------------------------------------------------------------- IF(Nloop.eq.1)THEN Pcr=Pcr+.025D0 ELSE Pcr=Pcr+.015D0 END IF IF(Plbox.GT.Pcr)THEN IF(Lprtlb)WRITE(Mt1,1040)Bldf,Plbox,Pcr IF((Nloop.eq.1).and.(.not.Lotmod))THEN lcv=(Ltstao.and.Critvl(AO).gt.TWOPT8).or. & (Ltstls.and.Critvl(LS).gt.TWOPT8).or. * & (Ltsttc.and.Critvl(TC).gt.TWOPT8).or. * & (Ltstso.and.Critvl(SO).gt.TWOPT8) & (Ltsttc.and.Critvl(TC).gt.TWOPT8) IF(lcv)THEN IF(Lprtlb)WRITE(Mt1,1050) IF(Ltstao)THEN Cvl0(AO)=Critvl(AO) Critvl(AO)=DMAX1(TWOPT8,Critvl(AO)-Critvl(AO)*Predcv) IF((.not.dpeq(Cvl0(AO),Critvl(AO))).and.Lprtlb) & WRITE(Mt1,1030)'AO',Critvl(AO) END IF IF(Ltstls)THEN Cvl0(LS)=Critvl(LS) Critvl(LS)=DMAX1(TWOPT8,Critvl(LS)-Critvl(LS)*Predcv) IF((.not.dpeq(Cvl0(LS),Critvl(LS))).and.Lprtlb) & WRITE(Mt1,1030)'LS',Critvl(LS) END IF IF(Ltsttc)THEN Cvl0(TC)=Critvl(TC) Critvl(TC)=DMAX1(TWOPT8,Critvl(TC)-Critvl(TC)*Predcv) IF((.not.dpeq(Cvl0(TC),Critvl(TC))).and.Lprtlb) & WRITE(Mt1,1030)'TC',Critvl(TC) END IF * IF(Ltstso)THEN * Cvl0(SO)=Critvl(SO) * Critvl(SO)=DMAX1(TWOPT8,Critvl(SO)-Critvl(SO)*Predcv) * IF((.not.dpeq(Cvl0(SO),Critvl(SO))).and.Lprtlb) * & WRITE(Mt1,1030)'SO',Critvl(SO) * END IF END IF END IF Ldr=Idr Lds=Ids Lpr=Ipr Lps=Ips Lqr=Iqr Lqs=Iqs Lmu0=Lmu Nloop=Nloop+1 Nround=Nround+1 c----------------------------------------------------------------------- c Change automatically identified outliers into regular outliers c of the same type c----------------------------------------------------------------------- c iao=0 c DO icol=Nb,1,-1 c IF(Rgvrtp(icol).eq.PRGTAA.or.Rgvrtp(icol).eq.PRGTAL.or. c & Rgvrtp(icol).eq.PRGTAT)THEN c bcol=B(icol) c IF(Rgvrtp(icol).eq.PRGTAA.or.Rgvrtp(icol).eq.PRGTAL)THEN c rtype=Rgvrtp(icol)-3 c ELSE IF(Rgvrtp(icol).eq.PRGTAT)THEN c rtype=PRGTTC c END IF c CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) c CALL dlrgef(icol,Nrxy,1) c CALL adrgef(bcol,str(1:nchr),str(1:nchr),rtype,F) c iao=iao+1 c END IF c END DO c CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, c & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) c IF(Lfatal)RETURN IF(Nloop.le.2.and.(.not.Lotmod).or.(Nloop.eq.2.and.lcv))THEN IF(Ismd0)THEN Ismd0=F Naut=Naut0 Igo=2 ELSE IF(Lautod.and.Lautom)THEN Igo=1 ELSE Igo=3 END IF ELSE Ipr=3 IF (Ids.GT.0) Ips=0 c----------------------------------------------------------------------- c Change model of last resort to a non mixed model if Lmixmd not true c BCM May 2004 c----------------------------------------------------------------------- IF(Lmixmd)THEN Iqr=1 ELSE Iqr=0 END IF c----------------------------------------------------------------------- IF (Sp.GT.1) THEN IF(Lmixmd)THEN IF(Maxord(2).gt.0)Iqs=1 ELSE IF(Ips.eq.0.and.Maxord(2).gt.0)Iqs=1 END IF END IF CALL mkmdsn(Ipr,Idr,Iqr,Ips,Ids,Iqs,Bstdsn,Nbstds) IF(Lprtlb)WRITE(Mt1,1060)Bstdsn(1:Nbstds) IF(Lfatal)RETURN CALL mdlint() CALL mdlset(Ipr,Idr,Iqr,Ips,Ids,Iqs,inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,Lautom) * IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,T,SA,Na,Nefobs,Lautom) IF((.not.Lfatal).and.Convrg)CALL prterr(nefobs,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If the estimation did not converge, reduce the AR order until c either the estimation converges or there are no AR orders left c BCM (Nov 2008, Aug 2018) c----------------------------------------------------------------------- IF(.not.Convrg)THEN DO WHILE ((.not.Convrg).and.Ipr.gt.0) Ipr=Ipr-1 CALL mdlint() CALL mdlset(Ipr,Idr,Iqr,Ips,Ids,Iqs,inptok) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal) & CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,Lautom) END DO c----------------------------------------------------------------------- c print out error message if Convrg false and Ipr < 0 and set c lfatal = true c----------------------------------------------------------------------- IF(Ipr.le.0.and.(.not.Convrg))THEN CALL abend() RETURN END IF c----------------------------------------------------------------------- c If model is changed, change model string to new model c----------------------------------------------------------------------- IF(Ipr.lt.3)THEN CALL mkmdsn(Ipr,Idr,Iqr,Ips,Ids,Iqs,Bstdsn,Nbstds) IF(Lprtlb)WRITE(Mt1,1070)Bstdsn(1:Nbstds) IF(Lfatal)RETURN END IF END IF IF(Lotmod.or.(Nloop.eq.2.and.(.not.lcv)))THEN Nloop=3 ELSE IF(Ltstao)Critvl(AO)=cvl0(AO) IF(Ltstls)Critvl(LS)=cvl0(LS) IF(Ltsttc)Critvl(TC)=cvl0(TC) * IF(Ltstso)Critvl(SO)=cvl0(SO) c----------------------------------------------------------------------- c remove automatically identified outliers c----------------------------------------------------------------------- IF(Natotl.gt.0)THEN CALL clrotl(Nrxy) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF END IF Igo=2 END IF END IF RETURN c----------------------------------------------------------------------- 1010 FORMAT(' ',a) 1020 FORMAT(' ',2(' (',i2,',',i2,',',i2,')')) 1021 FORMAT(' ',2(' (',i2,',',i2,',',i2,')'),a) 1030 FORMAT(' Critical Value for ',a,' outlier id changed to:',1x, & F12.3) 1040 FORMAT(/,' Confidence coefficient for Ljung-Box Q at lag ',i3, & ' = ',f10.4,',' & /,' which is greater than the acceptance limit, ',f10.4, & '.') 1050 FORMAT(/,' Automatic outlier identification will be redone.',/) 1060 FORMAT(/,' Model changed to ',a, & ' due to unacceptable Ljung-Box Q statistics', & /,' for previously identified models.') 1070 FORMAT(/,' Model changed to ',a,' due to estimation errors.') END pctrit.f0000664006604000003110000001457114521201542011651 0ustar sun00315stepsC Last change: Mar. 2021, add Sliding span: in format 1060 C previous change: BCM 15 Oct 1998 1:08 pm SUBROUTINE pctrit(Ex,Tagr,Muladd,Nsea,Eststr,Nstr,Ntot,Itot,Cut, & Mqq,Chrarg,Lprt,Lsav,Lprtyy,Lsavyy) IMPLICIT NONE c----------------------------------------------------------------------- c Print out percent of observations flagged as extremes c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'dgnsvl.i' c----------------------------------------------------------------------- CHARACTER Ex*(2),Eststr*(45),Mqq*(*),Chrarg*(*) LOGICAL Lprt,Lsav,lhdr,Lprtyy,Lsavyy DOUBLE PRECISION fper,Cut INTEGER i,Ntot,Itot,iext,Nstr,Tagr,Nsea,Muladd DIMENSION Ntot(NEST),Ex(2*NEST),Itot(NEST),Eststr(NEST), & Nstr(NEST),Cut(NEST,4) c----------------------------------------------------------------------- LOGICAL istrue EXTERNAL istrue c----------------------------------------------------------------------- c For each estimate, check to see if the number of months flagged c has been reset. c----------------------------------------------------------------------- IF(.NOT.(Lprt.or.Lsav.or.Lprtyy.or.Lsavyy.or.Svltab(LSLPCT))) & RETURN lhdr=.true. DO i=1,NEST-1 IF(Ntot(i).ne.NOTSET)THEN c----------------------------------------------------------------------- c compute percent of months flagged c----------------------------------------------------------------------- fper=(dble(Ntot(i))/dble(Itot(i)))*100D0 c----------------------------------------------------------------------- c Print out percentage for a given estimate, if requested c----------------------------------------------------------------------- IF(Lprt)WRITE(Mt1,1010)Eststr(i)(1:Nstr(i)),Ntot(i),Itot(i),fper c----------------------------------------------------------------------- c Save percentage of months flagged c----------------------------------------------------------------------- IF(Lsav)THEN iext=Tagr+(2*i)-1 WRITE(Nform,1020)Ex(iext)(1:(Tagr+1)),Ntot(i),Itot(i),fper END IF c----------------------------------------------------------------------- c Save percent flagged in log, if requested c----------------------------------------------------------------------- IF(Svltab(LSLPCT))THEN IF(lhdr)THEN WRITE(Ng,1060)Mqq,Chrarg lhdr=.false. END IF WRITE(Ng,1070)Eststr(i)(1:Nstr(i)),Ntot(i),Itot(i),fper END IF END IF END DO c----------------------------------------------------------------------- c compute percent of months flagged for year-to-year changes c----------------------------------------------------------------------- IF(Lprtyy.or.Lsavyy)THEN fper=(dble(Ntot(i))/dble(Itot(i)))*100D0 c----------------------------------------------------------------------- c Print out percentage for year-to-year changes, if requested c----------------------------------------------------------------------- IF(Lprtyy)WRITE(Mt1,1010)Eststr(i)(1:Nstr(i)),Ntot(i),Itot(i), & fper c----------------------------------------------------------------------- c Save percentage of months flagged for year-to-year changes c----------------------------------------------------------------------- IF(Lsavyy)THEN iext=Tagr+(2*i)-1 WRITE(Nform,1020)Ex(iext)(1:(Tagr+1)),Ntot(i),Itot(i),fper END IF c----------------------------------------------------------------------- c Save percent flagged in log for year-to-year changes, if requested c----------------------------------------------------------------------- IF(Svltab(LSLPCT))THEN IF(lhdr)THEN WRITE(Ng,1060)Mqq,Chrarg lhdr=.false. END IF WRITE(Ng,1070)Eststr(NEST)(1:Nstr(NEST)),Ntot(NEST),Itot(NEST), & fper END IF END IF c----------------------------------------------------------------------- c Print message on suggested threshold values c----------------------------------------------------------------------- IF(.not.Lprt)RETURN IF(Muladd.eq.0)THEN IF(Ntot(1).eq.NOTSET)THEN WRITE(Mt1,1029)Eststr(4) ELSE WRITE(Mt1,1030)Eststr(1),Eststr(4) END IF IF(Lprtyy)WRITE(Mt1,1031)Eststr(5) ELSE WRITE(Mt1,1030)Eststr(3),Eststr(4) IF(Lprtyy)WRITE(Mt1,1031)Eststr(5) END IF c----------------------------------------------------------------------- c Print message on threshold values used in the analysis c----------------------------------------------------------------------- IF(Nsea.eq.12)THEN WRITE(Mt1,1040)'months' ELSE WRITE(Mt1,1040)'quarters' END IF DO i=1,NEST-1 IF(Ntot(i).ne.NOTSET)WRITE(Mt1,1050)Eststr(i)(1:Nstr(i)),Cut(i,1) END DO IF(Ntot(i).ne.NOTSET.and.Lprtyy) & WRITE(Mt1,1050)Eststr(NEST)(1:Nstr(NEST)),Cut(NEST,1) RETURN c----------------------------------------------------------------------- 1010 FORMAT(/,2x,a,t50,i3,' out of ',i3,' (',f5.1,' %)') 1020 FORMAT('s2.',a,'.per: ',i3,2x,i3,2x,f7.3) 1029 FORMAT(///,10x,'Recommended limits for percentages:',/, & 10x,'-----------------------------------',//, & 5x,a,t55,'35% is too high',/,t55,'40% is much too high',//) 1030 FORMAT(///,10x,'Recommended limits for percentages:',/, & 10x,'-----------------------------------',//,5x, & a,t55,'15% is too high',/,t55,'25% is much too high',//, & 5x,a,t55,'35% is too high',/,t55,'40% is much too high',//) 1031 FORMAT(5x,a,t55,'10% is usually too high',//) 1040 FORMAT(/,5x,'Threshold values used for Maximum Percent ', & 'Differences to flag ',a,/,5x,' as unstable',/) 1050 FORMAT(5x,a,t55,'Threshold = ',f5.1,' %') 1060 FORMAT(/,'Sliding Spans: Percentage of ',a,'s flagged as unstable' & ,a) 1070 FORMAT(2x,a,' : ',t50,i3,' out of ',i3,' (',f5.1,' %)') c----------------------------------------------------------------------- END peaks.i0000664006604000003110000000025314521201542011442 0ustar sun00315stepsC C... Variables in Common Block /peaks/ ... character picosSA(7)*2,picosTr(7)*2,picosIr(7)*2,picosRes(7)*2 common /peaks/ picosSA,picosTr,picosIr,picosRes phasegain.f0000664006604000003110000001503014521201542012272 0ustar sun00315steps SUBROUTINE phaseGain( filterIn, nFilter, startPoint, iPeriod, & fltLmbda, sqGain, phase, phaseDelay ) IMPLICIT NONE c----------------------------------------------------------------------- c phasegain.f, Release 1, Subroutine Version 1.2, Modified 20 Apr 2006. c----------------------------------------------------------------------- c Changes: c Created by REG, on 09 Sep 2005. c Modified by REG, on 19 Jan 2006, to change output fltLmbda c from frequencies to cycles/period. c Modified by REG, on 20 Apr 2006, to calculate phase delay c at lambda equal to zero using derivative of arcTangent formula c and to lengthen output vectors by 1 for case of lambda=6. c----------------------------------------------------------------------- c Modified by BCM 10 Apr 2006 - add code to handle case where c computation must take arctan of 0 c----------------------------------------------------------------------- INCLUDE 'notset.prm' c----------------------------------------------------------------------- c Given an input filter, this subroutine calculates squared gain, c phase, and phase delay associated with filter's Fourier transform. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c filterIn d vector of input filter weights c fltLmbda d vector of cycles/period set containing the following: c [0, 1, ... , (grid*iPeriod/2)]/grid c with grid = 200 currently c sqGain d filter square gain values over the frequency interval c iPeriod i seasonal period c nFilter i size of input vector c phase d filter phase values over the frequency interval c phasedelay d filter phase delay over the frequency interval c startPoint i index offset of first coefficient in input filter and c also indicates number of future values in input filter c----------------------------------------------------------------------- INTEGER nFilter, startPoint, iPeriod, grid PARAMETER ( grid=200 ) DOUBLE PRECISION filterIn( 0:nFilter-1 ) DOUBLE PRECISION fltLmbda( 0:grid*((iPeriod+1)/2) ) DOUBLE PRECISION sqGain( 0:grid*((iPeriod+1)/2) ) DOUBLE PRECISION phase( 0:grid*((iPeriod+1)/2) ) DOUBLE PRECISION phaseDelay( 0:grid*((iPeriod+1)/2) ) c----------------------------------------------------------------------- c Name Type Description (Local Variables) c----------------------------------------------------------------------- c arg d frequency argument for partial Fourier transform c grid i parameter for number of frequency points in each c interval to be evaluated c j i index variables for do loops c index i ranges over [0 ... grid*(oPeriod+1)/2] c lambda d part of working frequency c nOut i size of gain and phase vectors c sSum0 d sum of filterIn coefficients c sTau0 d used to calculate phase delay at lambda = 0.0 c TWO_PI d parameter for 2*PI c vClambda d complex value of partial Fourier transform c vSum d complex value of Fourier transform c ZERO d parameter for zero c----------------------------------------------------------------------- INTEGER j, index, nOut DOUBLE PRECISION vClambda(2), lambda, vCsum(2), ZERO, TWO_PI, arg DOUBLE PRECISION sSum0, sTau0 PARAMETER ( ZERO=0.0D0, TWO_PI=2.0D0*3.14159265358979D0 ) c----------------------------------------------------------------------- c Modified by BCM 10 Apr 2006 - add reference to dpeq c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c Zero the output vectors c----------------------------------------------------------------------- nOut = grid*((iPeriod+1)/2) DO j = 0, nOut sqGain(j) = ZERO phase(j) = ZERO phaseDelay(j) = ZERO END DO c----------------------------------------------------------------------- c Calculate the Fourier transform over the frequency set c----------------------------------------------------------------------- sSum0 = ZERO sTau0 = ZERO DO index = 0, nOut c ------------------------------------------------------------------ c Choose the Fourier frequence (arg) c Calculate the partial Fourier transform (vClambda) c Sum the partial Fourier transforms (vSum) c ------------------------------------------------------------------ lambda = DBLE(index)/DBLE(grid) vCsum(1) = ZERO vCsum(2) = ZERO DO j = 0, nFilter-1 arg = TWO_PI*lambda*DBLE(startPoint+j)/DBLE(iPeriod) vClambda(1) = filterIn(nFilter-1-j)*DCOS(arg) vClambda(2) = filterIn(nFilter-1-j)*DSIN(-arg) vCsum(1) = vCsum(1) + vClambda(1) vCsum(2) = vCsum(2) + vClambda(2) IF ( index .eq. 0 ) THEN sSum0 = sSum0 + filterIn(nFilter-1-j) sTau0 = sTau0 + DBLE(startPoint+j)*filterIn(nFilter-1-j) END IF END DO c ------------------------------------------------------------------ c Calculate squared gain, phase, and phase delay of Fourier transform c ------------------------------------------------------------------ c fltLmbda(index) = TWO_PI*lambda/DBLE(iPeriod) fltLmbda(index) = lambda sqGain(index) = vCsum(1)*vCsum(1) + vCsum(2)*vCsum(2) c ------------------------------------------------------------------ c Modified by BCM 10 Apr 2006 - if vCsum(1) or vCsum(2) = 0, set c value for phase and phaseDelay to DNOTST - otherwise, c continue with computation c ------------------------------------------------------------------ if(dpeq(vCsum(1),ZERO).and.dpeq(vCsum(2),ZERO))THEN phase(index) = DNOTST phaseDelay(index) = DNOTST ELSE phase(index) = DATAN2( vCsum(2), vCsum(1) ) & * DBLE(iPeriod)/TWO_PI IF ( index .eq. 0 ) THEN phaseDelay(index) = sTau0/sSum0 ELSE phaseDelay(index) = -phase(index)/lambda END IF END IF END DO c----------------------------------------------------------------------- RETURN ENDpicktd.cmn0000664006604000003110000000207014521201542012141 0ustar sun00315steps INTEGER Tdzero,Tddate,Lnzero,Lndate c----------------------------------------------------------------------- c Picktd - logical scalar which indicates that "td" was selected c as one of the trading day regressors c Lrgmtd - logical scalar which indicates that change of regime c trading day regressors are contained in the current c model being processed c Lrgmln - logical scalar which indicates that length of period c (length of month, quarter, or leap year) change of c regime regressor is contained in the current model being c processed c----------------------------------------------------------------------- LOGICAL Picktd,Lrgmtd,Fulltd,Lrgmln,Fullln,Fulllp c----------------------------------------------------------------------- DIMENSION Tddate(2),Lndate(2) c----------------------------------------------------------------------- COMMON /cpktd / Tdzero,Tddate,Lnzero,Lndate,Picktd,Lrgmtd,Fulltd, & Lrgmln,Fullln,Fulllp pinno.i0000664006604000003110000000014014521201542011455 0ustar sun00315stepsC C... Variables in Common Block /pinno/ ... integer M,IQ common /pinno/ M,IQ polyml.f0000664006604000003110000001262314521201542011654 0ustar sun00315steps SUBROUTINE polyml(Polya,Alag,Na,Polyb,Blag,Nb,Pc,Polyc,Clag,Nc) IMPLICIT NONE c----------------------------------------------------------------------- c Changed: c To find the degree of a polynomial by searching the associated lags c of the polynomial for the highest lag, by REG on 04 Feb 2004. c----------------------------------------------------------------------- c Calculates the coefficients of the polynomial multiplication of c a*b=c where a,b, and c have the form c c 1-a(1)*B**alag(1)-a(2)*B**alag(2)- ... -a(na)*B**alag(na). c c The method takes the outer product of the coefficients, ab' equal to c 1 -a(1) -a(2) ... -a(na) c(1)...c(na) c -b(1) a(1)b(1) a(2)b(1) ... a(na)b(1) c( na+1) ...c(2na) c -b(2) a(1)b(2) a(2)b(2) ... a(na)b(2) c(2na+1) ...c(3na) c . . . . . = . c . . . . . . c . . . . . . c -b(nb) a(1)b(nb) a(2)b(nb) ... a(na)b(nb) c(na*nb+na+1)... c c(na*nb+na+nb), and an outer sum where clag(i,j)=a(i)+b(j),i=1,na, c j=1,nb, giving a power or lag matrix. But clag(i,j) is never c calculated because the lags are sorted and the coefficients of like c powers are summed. c----------------------------------------------------------------------- c var type description c----------------------------------------------------------------------- c polya r Input vector of polynomial coefficients c alag i Input vector of the lags of the coefficients of a c polyb r Input vector of polynomial coefficients c blag i Input vector of the lags of the coefficients of b c polyc r Output vector of polynomial coefficients is copied from c t at the end so that one of the input polynomials also c be the output polynomial c clag i Output vector of the lags of the coefficients of c. Also c assigned at the end c i i Local do loop index c j i Local do loop index c lagb i Local current lag power of b c lagt i Local current lag of the temporary polynomial which will c be c c na i Input number of coefficients in the polynomial a c nb i Input number of coefficients in the polynomial b c nc i Output number of coefficients in the polynomial c c nt i Local length of temporary vector of coefficients of c c pc i 'parameter' for the number of elements the c polynomial c can have c pcoef i Local parameter for the length of the temporary polynomial c Must be larger than than nc which is greater than the c max((nd+1)(nsd+1)(nphi+1)-1,(nth+1)(nsth+1)-1) c polyt r Local temporary vector for the coefficients of polynomial c c tlag i Local temporary vector for the lags of the polynomial c c tmp r Local temporary scalar for the current coefficient value of c c c tmpb r Local temporary scalar for the current coefficient value of c b c zero d Local double precision 0 c----------------------------------------------------------------------- INTEGER PCOEF,Pc PARAMETER(PCOEF=200) INTEGER Alag(*),Blag(*),Clag(Pc),i,j,tlag(PCOEF),lagb,lagt,Na,Nb, & Nc,nt DOUBLE PRECISION Polya(*),Polyb(*),Polyc(Pc),polyt(PCOEF),tmpb,tmp c----------------------------------------------------------------------- c Copy the a polynomial into the first row or elements of the c c polynomial. c----------------------------------------------------------------------- nt=0 DO i=1,Na tmp=Polya(i) lagt=Alag(i) CALL insort(tmp,lagt,nt,polyt,tlag) END DO c----------------------------------------------------------------------- c Then for the remaining rows, first, set the first element in the c row to the coefficient value and lag of b then place it in c some the c lags are still in order. c----------------------------------------------------------------------- DO i=1,Nb tmpb=Polyb(i) lagb=Blag(i) c ------------------------------------------------------------------ tmp=tmpb lagt=lagb CALL insort(tmp,lagt,nt,polyt,tlag) c----------------------------------------------------------------------- c Set the rest of the row of c to the outer product or sum and add c them to c in order of their lag powers. Note, to maintain the sign c convention of the polynomial coefficients the sign of the outer c product must be reversed. c----------------------------------------------------------------------- DO j=1,Na tmp=-tmpb*Polya(j) lagt=lagb+Alag(j) CALL insort(tmp,lagt,nt,polyt,tlag) END DO END DO c----------------------------------------------------------------------- c After the polynomial c and its lags have been calculated copy the c nonzero lags of the temporary vector to c and the number of c coefficients to nc. c----------------------------------------------------------------------- c j=1 DO i=1,nt c if(c(i).ne.zero)then c j=j+1 c c(j)=Polyt(i) c clag(j)=tlag(i) Polyc(i)=polyt(i) Clag(i)=tlag(i) c end if END DO c nc=j Nc=nt c ------------------------------------------------------------------ RETURN END polynom.f0000664006604000003110000005377314521201542012050 0ustar sun00315steps subroutine ABORTA(str) implicit none character str*(*) stop 'function ABORTA' end Subroutine AddTramPols(Pols,PolsDim,Npols,PolToAdd,DimPolToAdd) c Add in the array Pols(MaxPol,MaxPolDim), the new polynomial [1,PolToAdd], c Add in the array PolsDim(MaxPol), the new dimension DimPolToAdd+1 of [1,PolToAdd] c Increment Npols. IMPLICIT NONE include 'polynom.i' integer Npols,PolsDim(MaxPol),DimPolToAdd real*8 Pols(MaxPol,MaxPolDim),PolToAdd(*) integer i if (DimPolToAdd .eq. 0) return if (Npols .ge. MaxPol) then call ABORTA('AddPols reach the MaxPol polynomials') end if Npols=Npols+1 Pols(Npols,1)=1 Do i=1,DimPolToAdd Pols(Npols,i+1)=PolToAdd(i) enddo PolsDim(Npols)=DimPolToAdd+1 end c c cc c Subroutine AddBJPols(Pols,PolsDim,Npols,PolToAdd,DimPolToAdd) c The inpul polynomial PolToAdd is in Box-Jenkins notation (-PolToAdd(:) to pass to Tramo notation) c Add in the array Pols(MaxPol,MaxPolDim), the new polynomial [1,PolToAdd], c Add in the array PolsDim(MaxPol), the new dimension DimPolToAdd+1 of [1,PolToAdd] c Increment Npols. IMPLICIT NONE include 'polynom.i' integer Npols,PolsDim(MaxPol),DimPolToAdd real*8 Pols(MaxPol,MaxPolDim),PolToAdd(*) integer i if (DimPolToAdd .eq. 0) return if (Npols .ge. MaxPol) then call ABORTA('AddPols reach the MaxPol polynomials') end if Npols=Npols+1 Pols(Npols,1)=1 Do i=1,DimPolToAdd Pols(Npols,i+1)=-PolToAdd(i) enddo PolsDim(Npols)=DimPolToAdd+1 end c c cc Subroutine AddPols(Pols,PolsDim,Npols,PolToAdd,DimPolToAdd) c Add in the array Pols(MaxPol,MaxPolDim), the new polynomial PolToAdd, c Add in the array PolsDim(MaxPol), the new dimension DimPolToAdd of PolToAdd c Increment Npols. IMPLICIT NONE include 'polynom.i' integer Npols,PolsDim(MaxPol),DimPolToAdd real*8 Pols(MaxPol,MaxPolDim),PolToAdd(*) integer i if (Npols .ge. MaxPol) then call ABORTA('AddPols reach the MaxPol polynomials') end if Npols=Npols+1 Do i=1,DimPolToAdd Pols(Npols,i)=PolToAdd(i) enddo PolsDim(Npols)=DimPolToAdd end c c cc Subroutine AppendStrCut(Str1,MaxStr1Length, $ Str2,MaxStr2Length) c Dada la dimension de STR2 (MaxStr2Length),mete en c Str2 los primeros MasStr2Length caracteres de Str2+Str1 c IN/OUT Str2 c IN Str1,MaxStr1Length,MaxStr2Length IMPLICIT NONE integer MaxStr1Length,MaxStr2Length character*(*) Str1,Str2 EXTERNAL ISTRLEN integer ISTRLEN integer lStr1,lStr2 lStr1=ISTRLEN(Str1) lStr2=ISTRLEN(Str2) if (lStr1.eq.0) return if ((lStr1+lStr2).ge.MAxStr1Length) then if (lSTr2.lt.MaxStr2Length-1) then if (lStr2.eq.0)then write(Str2,'(A)') $ Str1(1:MaxStr2Length-1) else Str2(1:(lStr2+MaxStr2Length-lStr2-1))=Str2(1:lStr2)// $ Str1(1:MaxStr2Length-lStr2-1) end if end if else if (lStr2.eq.0)then write(Str2,'(A)') $ Str1(1:lStr1) else Str2(1:(lStr2+lStr1))=Str2(1:lStr2)//Str1(1:lStr1) end if end if end c Subroutine AppendStrCutRight(Str1,Str2) c Dada la dimension de STR2 (MaxStr2Length),mete en c Str2 los primeros MasStr2Length caracteres de Str1+Str2 IMPLICIT NONE include 'stream.i' include 'polynom.i' character Str1*(*),Str2*(*),tstr*(MaxStrLength) EXTERNAL ISTRLEN integer ISTRLEN integer lStr1,lStr2 lStr1=ISTRLEN(Str1) lStr2=ISTRLEN(Str2) if ((lStr1+lStr2).ge.MaxStrLength) then if (lSTr1.lt.MaxStrLength) then write(tstr,'(A,A)')Str1(1:lStr1), $ Str2(1:MaxStrLength-lStr1-1) Str2=tstr else write(Str2,'(A)')Str1(1:MaxStrLength-1) end if else write(tstr,'(A,A)')Str1(1:lStr1),Str2(1:lStr2) Str2=tstr end if end subroutine AppendStrRight(Str,word,outtxt,line) c Str+word+OutTxt+Line=>OutTxt+Line (adding returns if HTML<>0 ) c Where Line is the last line of the text c IMPLICIT NONE include 'stream.i' include 'polynom.i' character Str*(MaxStrLength),word*(MaxLineLength), $ outTxt*(maxStrLength),line*(MaxLineLength), $ tTxt*(maxStrLength) external ISTRLEN,ABORTA integer ISTRLEN integer lStr,lword,lline,louttxt c lStr=ISTRLEN(Str) lword=ISTRLEN(word) lline=ISTRLEN(line) loutTxt=ISTRLEN(OutTxt) if ((lword+lLine+4+lOutTxt) .ge. MaxStrLength) then call ABORTA('AppendStr: reach MaxStrLength') end if if ((louttxt.eq.0).and.((lword+lline).le.MaxLineLength)) then call AppendStrCutRight(Word,Line) else if (loutTxt.gt.0) then write(tTxt,'(A,A,A,A)') Word(1:lword), $ Achar(13),Achar(10),OutTxt(1:loutTxt) OutTxt(1:(lOutTxt+Lword+2))=tTxt(1:(lOutTxt+Lword+2)) else OutTxt=Word end if end if if (lStr.gt.0) then lOutTxt=ISTRLEN(OutTxt) if (lOutTxt.gt.0) then write(tTxt,'(A,A,A,A)') Str(1:lStr),Achar(13), $ Achar(10),OutTxt(1:lOutTxt) OutTxt(1:(lOutTxt+Lword+2))=tTxt(1:(lOutTxt+Lword+2)) else OutTxt=Str end if end if end subroutine AppendStr(Str,word,outtxt,line) c OutTxt+Line+Str+word=>OutTxt+Line (adding returns if HTML<>0 ) c Where Line is the last line of the text c IMPLICIT NONE include 'stream.i' include 'polynom.i' character Str*(*),word*(*), $ outTxt*(maxStrLength),line*(MaxLineLength) external ISTRLEN,ABORTA integer ISTRLEN integer lStr,lword,lline,louttxt c lStr=ISTRLEN(Str) lword=ISTRLEN(word) lline=ISTRLEN(line) loutTxt=ISTRLEN(OutTxt) if ((lStr+lword+lLine+4+lOutTxt) .ge. MaxStrLength) then call ABORTA('AppendStr: reach MaxStrLength') end if if (lStr.eq.0) then if ((lline+lword).lt.MaxLineLength) then call AppendStrCut(word,MaxLineLength,Line,MaxLineLength) else OutTxt(1:(lOutTxt+2+lLine))=OutTxt(1:lOutTxt)// $ Achar(13)//ACHAR(10)//Line(1:lline) line=word end if else if (lOutTxt .gt.0)then OutTxt(1:(lOutTxt+2))=OutTxt(1:lOutTxt)// $ Achar(13)//ACHAR(10) end if if (lLine.gt.0) then OutTxt(1:(lOutTxt+2+lLine))=OutTxt(1:lOutTxt)// $ Line(1:lLine)//Achar(13)//ACHAR(10) end if lOutTxt=ISTRLEN(OutTxt) OutTxt(1:(lOutTxt+lStr))=OutTxt(1:lOutTxt)//Str(1:lStr) line=word end if end c c c Subroutine AppendLine(OutTxt,Line) c OutTxt=OutTxt+Line c Line='' IMPLICIT NONE include 'stream.i' include 'polynom.i' character Line*(MaxLineLength),OutTxt*(MaxStrLength) c external functions external ISTRLEN integer ISTRLEN c Local Variables integer lLine,lOutTxt c lLine=ISTRLEN(Line) lOutTxt=ISTRLEN(OutTxt) if ((lLine+lOutTxt+2).gt.MaxStrLength) then call ABORTA('AppendLine MaxStrLength reached') end if if (lOutTxt.ne.0) then OutTxt(1:(lOutTxt+lLine+2)) = OutTxt(1:lOutTxt)//ACHAR(13)// $ Achar(10)//Line(1:lLine) else write(OutTxt,'(A)') Line(1:lLine) end if Line=' ' end c c c subroutine StrPolyn(Bchar,Pol,PolDim,tolInteger,StrPol,Line) c Write the Pol(1:PolDim) in StrPol+Line; StrPol or Line can be empty strings Implicit None include 'stream.i' include 'polynom.i' real*8 Pol(*),tolInteger integer PolDim character Bchar*(MaxBcharLength),StrPol*(maxStrLength), $ Line*(MaxLineLength) c external functions intrinsic ABS external ISTRLEN integer ISTRLEN c LOCAL variables character ExpChar*(MaxLineLength),signChar, $ tmpWord*(MaxLineLength),tmpStr*(MaxStrLength) integer i,NumberNonZero,IntValue,lExpChar c StrPol=' ' Line=' ' NumberNonZero=0 Do i=1,PolDim if (ABS(pol(i)) .gt. tolInteger) then NumberNonZero=NumberNonZero+1 end if enddo if (NumberNonZero.gt.1) then Line='(' end if Do i=1,PolDim tmpWord=' ' tmpStr=' ' if (ABS(pol(i)) .gt. tolInteger) then if (i.eq.1) then expChar=' ' else if (i.eq.2) then expChar(1:MaxBcharLength)=Bchar else if ((i.gt.2).and. (i.le.10)) then write(expchar,'(A,"^",I1)') Bchar(1:ISTRLEN(Bchar)),i-1 else write(expchar,'(A,"^",I2)') Bchar(1:ISTRLEN(Bchar)),i-1 end if lExpChar=ISTRLEN(ExpChar) if (pol(i).gt.0) then signchar='+' else signChar='-' end if if ((abs(pol(i)-ANINT(Pol(i))) .lt. TolInteger) .and. $ abs(Pol(i)).lt. 99.5d0) then IntValue=abs(ANINT(Pol(i))) if (Intvalue.ge. 10) then write(tmpWord,'(A,I2,A)') $ SignChar,Intvalue,Expchar(1:lExpchar) else if (Intvalue .gt. 2) then write(tmpWord,'(A,I1,A)') $ SignChar,Intvalue,Expchar(1:lExpchar) else if (i.ne.1) then write(tmpWord,'(A,A)') SignChar,ExpChar(1:lExpChar) else if (Pol(i).lt.0)then write(tmpword,'(A,"1")') SignChar else if (PolDim.gt.1) then write(tmpword,'("1")') end if else if (Pol(i).ge.0.0d0) then write(tmpWord,'("+",G11.4)') Pol(i) else write(tmpWord,'(G11.4)') Pol(i) end if call AppendStr(' ',ExpChar,tmpStr,tmpWord) end if call AppendStr(tmpStr,tmpWord,strPol,line) end if enddo if (NumberNonZero.gt.1) then call AppendStr(' ',')',StrPol,line) end if end c c c return in strModel the model of "PHI(B)modelName=TH(B)at at~niid(0,V)" subroutine showModel(PHI,nPHI,TH,nTH,V,modelName,strModel) implicit none include 'polynom.i' include 'stream.i' c INPUT PARAMETERS real*8 PHI(*),TH(*),V integer nPHI,nTH character modelName*(MaxBcharLength) c OUTPUT PARAMETERS character StrModel*(MaxStrLength) c LOCAL PARAMETERS character StrPol*(MaxStrLength),Line*(MaxLineLength), $ tmpLine*(MaxLineLength) c call StrPolyn('B ',PHI,nPHI,1.0D-6,StrPol,Line) strModel=' ' tmpLine='[' call AppendStr(StrPol,Line,StrModel,tmpLine) call AppendStr(' ',']',strModel,tmpLine) call AppendStr(' ',modelName,strModel,tmpLine) call AppendStr(' ','=',strModel,tmpLine) call strPolyn('B ',TH,nTH,1.0D-6,strPol,Line) call AppendStr(strPol,Line,strModel,tmpLine) write(Line,'("at at~niid(0,",G11.4,")")')V call AppendStr(' ',Line,StrModel,tmpLine) call AppendLine(strModel,tmpLine) end c c c subroutine getDeltaMQStr(Bchar,MQ,bd,DeltaMqStr) IMPLICIT NONE include 'stream.i' include 'polynom.i' character Bchar*(MaxBcharLength),DeltaMqStr*(MaxLineLength) Integer MQ,bd c external functions external ISTRLEN,StrPolyn integer ISTRLEN c local variables character tmpStr*(MaxStrLength) real*8 DeltaMq(MaxPolDim) integer i c DeltaMQStr=' ' if (bd.gt.0) then DeltaMQ(1)=1.0d0 do i=2,MQ DeltaMQ(i)=0.0d0 end do DeltaMQ(MQ+1)=-1.0d0 call StrPolyn(Bchar,DeltaMQ,1+mq,1.0D-6,tmpStr,DeltaMQStr) call AppendStrCutRight(tmpStr,DeltaMQStr) if (bd.ge.2) then write(DeltaMQStr,'(A,"^",I1)') & DeltaMQStr(1:ISTRLEN(DeltaMQStr)),bd end if end if end c c c Subroutine getStrPols(Bchar,Pols,PolsDim,nPols,d,MQ,bd,NS, $ OutPol,Line) c Given the polynomials Pols(1:nPols,:) of order PolsDim(1:nPols) c and d regular differences, bd seasonal differences, ns annual aggregations c with frequency mq, we write the polynomial in OutPol+Line c where Bchar='B' is how we represent the equations variables(we can use 'B' or 'Xt'...) c Note: OutPol also depends on HMTL=0 or HTML=1 IMPLICIT NONE include 'stream.i' include 'polynom.i' real*8 diffInt parameter(diffInt=1.0D-6) real*8 Pols(MaxPol,MaxPolDim) integer nPols,d,bd,ns,MQ,PolsDim(*) character Bchar*(MaxBcharLength),OutPol*(MaxStrLength), $ Line*(MaxLineLength) external ISTRLEN,StrPolyn,AppendStr,getDeltaMQStr integer ISTRLEN integer i,j,value real*8 AuxPol(MaxPolDim) character StrPol*(MaxStrLength),LinePol*(MaxLineLength) c line=' ' OutPol=' ' Do i=1,nPols do j=1,MaxPolDim AuxPol(j)=Pols(i,j) enddo value=PolsDim(i) call StrPolyn(Bchar,AuxPol,value,diffInt,StrPol,LinePol) call AppendStr(strPol,LinePol,OutPol,Line) enddo call getDeltaMQstr(Bchar,1,d,LinePol) if (d.gt.1) then call AppendStr(' ','[',OutPol,Line) call AppendStr(' ',LinePol,OutPol,Line) call AppendStr(' ',']',OutPol,Line) else call AppendStr(' ',LinePol,OutPol,Line) end if call getDeltaMQstr(Bchar,MQ,bd,LinePol) call AppendStr(' ',LinePol,OutPol,Line) if (ns.eq.1) then do i=1,mq AuxPol(i)=1.0D0 enddo call StrPolyn(Bchar,AuxPol,MQ,diffInt,StrPol,LinePol) call AppendStr(StrPol,LinePol,OutPol,Line) end if end c c c subroutine StrHpModel(Bchar,PolsAR,PolsDimAR,nPolsAR,d,mq,bd, $ PolsMA,PolsDimMa,nPolsMA,Kc,Km,ModelStrCt,ModelStrMt) IMPLICIT NONE include 'stream.i' include 'polynom.i' character Bchar*(MaxBcharLength) real*8 PolsAR(MaxPol,MaxPolDim),PolsMA(MaxPol,MaxPolDim),Kc,Km integer PolsDimAR(MaxPol),nPolsAR,PolsDimMA(MaxPol),nPolsMA, $ d,mq,bd,i,j character ModelStrCt*(MaxStrLength),ModelStrMt*(MaxStrLength) c Local variables integer ns,dc,bdc,MAdc character MAstr*(MaxStrLength),MALineStr*(MaxLineLength), $ ARstr*(MaxStrLength),ARLineStr*(MaxLineLength), $ tmpLine*(MaxLineLength),tmpStr*(MaxStrLength), $ tmpLine2*(MaxLineLength) c ----------------------------------------------------------------------- c Initialize c ----------------------------------------------------------------------- DO i=1,maxPolDim DO j=1,maxPol PolsAR(j,i)=0D0 PolsMA(j,i)=0D0 IF(j.eq.1)THEN PolsDimAR(j)=0 PolsDimMA(j)=0 END IF END DO END DO c ----------------------------------------------------------------------- Madc=2 if (d.ge.MAdc) then dc=d-MAdc MAdc=0 ns=0 bdc=bd else dc=0 MADC=MADC-d-bd bdc=0 ns=bd end if call getStrPols(Bchar,PolsAR,PolsDimAR,nPolsAR,d,mq,bd,0, $ ARstr,ARlineStr) call getStrPols(Bchar,PolsMA,PolsDimMA,nPolsMA,0,mq,0,0, $ MAstr,MAlineStr) tmpStr=' ' tmpLine='[' call AppendStr(ARstr,ARLineStr,tmpStr,TmpLine) call AppendStr(' ',']m(t)=',tmpstr,tmpLine) call AppendStr(MAstr,MAlineStr,tmpStr,tmpLine) write(tmpLine2,'(" niid~(0,",G11.4)') Km call AppendStr(' ',tmpLine2,tmpStr,tmpLine) call AppendStr(' ','Va)',tmpStr,tmpLine) call AppendLine(tmpstr,tmpLine) ModelStrMt=tmpStr call getStrPols(Bchar,PolsAR,PolsDimAR,nPolsAR,dc,mq,bdc,ns, $ ARstr,ARlineStr) if (MADC.gt.0) then call getStrPols(Bchar,PolsMA,PolsDimMA,nPolsMA,MAdc,mq,0,0, $ MAstr,MAlineStr) end if tmpStr=' ' tmpLine='[' call AppendStr(ARstr,ARlineStr,tmpStr,tmpLine) call AppendStr(' ',']C(t)=',tmpStr,tmpLine) call AppendStr(MAstr,MAlineStr,tmpStr,tmpLine) write(tmpLine2,'(" niid~(0,",G11.4)') Kc call AppendStr(' ',tmpLine2,tmpStr,tmpLine) call AppendStr(' ','Va)',tmpStr,tmpLine) call AppendLine(tmpstr,tmpLine) ModelStrCt=tmpStr end c c c Subroutine PresentaHPsa(THhp,chis,nCHIS,cycs,nCYCS,cycns,nCYCNS, $ THadj,nTHADJ,Dp,varwna,Kc,Km,ModelStrCt,ModelStrMt) c Dp=d+BD IMPLICIT NONE include 'stream.i' include 'polynom.i' real*8 chis(5),cycs(5),cycns(5),THadj(5),varwna,Kc,Km,THhp(3) integer nCHIS,nCYCS,nCYCNS,nTHadj,Dp character ModelStrCt*(MaxStrLength),ModelStrMt*(maxStrLength) c Local variables integer PolsDimMA(MaxPol),PolsDimAR(MaxPol),nPolsAR,nPolsMA,i,j real*8 PolsAR(MaxPol,MaxPolDim),PolsMA(MaxPol,MaxPolDim) character Bchar*(MaxBcharLength) Bchar='B' nPolsAR=0 do i=1,MaxPol do j=1,MaxPolDim PolsAR(i,j)=0D0 PolsMA(i,j)=0D0 END DO END DO call AddPols(PolsAR,PolsDimAR,nPolsAR,THhp,3) call AddPols(PolsAR,PolsDimAR,nPolsAR,Chis,nChis) call AddPols(PolsAR,PolsDimAR,NpolsAR,Cycs,nCycs) call AddPols(PolsAR,PolsDimAR,NpolsAR,Cycns,nCycns) nPolsMA=0 call AddPols(PolsMA,PolsDimMA,nPolsMA,THadj,nTHadj) call StrHpModel(Bchar,PolsAR,PolsDimAR,nPolsAR,Dp,1,0, $ PolsMA,PolsDimMA,nPolsMA,Kc*varwna,Km*varwna, $ ModelStrCt,ModelStrMt) end c c Subroutine PresentaHPXt(THhp,PHI,p,d,TH,q,mq, $ BPHI,bp,bd,BTH,bq,Kc,Km,MoStrCt,MoStrMt) c THhp(B)*PHI(B)*(1-B^mq)^bd (1-B)^(d-2)Ct=TH(B)BTH(B)act actñiid(0,Kc) c THhp(B)*PHI(B)*(1-B^mq)^bd (1-B)^d Mt=TH(B)BTH(B)amt amtñiid(0,Km) c Los polinomios se entran en formato Tramo include 'polynom.i' include 'stream.i' Real*8 THhp(3),PHI(3),TH(3),BPHI(3),BTH(3),Kc,Km integer p,d,q,mq,bp,bd,bq character MoStrCt*(MaxStrLength),MoStrMt*(MaxStrLength) real*8 PolsAR(MaxPol,MaxPolDim),PolsMA(MaxPol,MaxPolDim), $ PolBPHI(MaxPolDim),PolBTH(MaxPolDim) character Bchar*(MaxBcharLength) integer PolsDimAR(MaxPol),PolsDimMA(MaxPol),NpolsAR,NpolsMA integer i real*8 tramoPHI(3),tramoTH(3) Bchar='B' NpolsAR=0 do i=1,MaxPol do j=1,MaxPolDim PolsAR(i,j)=0D0 PolsMA(i,j)=0D0 END DO END DO call AddPols(PolsAR,PolsDimAR,NpolsAR,THhp,3) do i=1,3 tramoPHI(i)=-PHI(i) enddo call AddTramPols(PolsAR,PolsDimAR,NpolsAR,tramoPHI,p) do i=1,MaxPolDim PolBPHI(i)=0.0d0 enddo PolBPHI(1)=1.0d0 if (bp.eq.1) then PolBPHI(mq+1)=-BPHI(1) end if call AddPols(PolsAR,PolsDimAR,NpolsAR,PolBPHI,1+mq*bp) NpolsMA=0 do i=1,3 tramoTH(i)=-TH(i) enddo call AddTramPols(PolsMA,PolsDimMA,NpolsMA,tramoTH,q) do i=1,maxPolDim PolBTH(i)=0.0d0 enddo PolBTH(1)=1.0d0 if (bq.eq.1) then PolBTH(1+mq)=-BTH(1) end if call AddPols(PolsMA,PolsDimMA,NpolsMA,PolBTH,1+mq*bq) call strHPmodel(Bchar,PolsAR,PolsDimAR,NpolsAR,d,mq,bd,PolsMA, $ PolsDimMA,NpolsMA,Kc,Km,MoStrCt,MoStrMt) end c c c subroutine PresentaHP(THhp,HPcycle,Km,HPlam,varw, $ MoStrCt,MoStrMt) IMPLICIT NONE INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n1,n12,n10 parameter (n10 = 10, n12 = 12, n1 = 1) c include 'calc.i' c include 'calfor.i' include 'stream.i' include 'models.i' include 'hspect.i' include 'polynom.i' character MoStrCt*(MaxStrLength),MoStrMt*(MaxStrLength) real*8 THhp(3),Km,HPlam,varw integer HPcycle C CalC.i but THSTAR=>THSTAT2 to use with models.i integer mTYPE,P,D,Q,BP,BD,BQ,PBP,PQ,NW,INIT,BPQ,IMEAN,IPR real*8 DETPRI real*8 W(MPKP),PHI(3*N1),TH(3*N1),BPHI(3*N1),BTH(3*N1), $ PHIST(2*N12+3*N1),THSTAR2(maxTH) common /calc/ W,PHI,TH,BPHI,BTH,PHIST,THSTAR2,DETPRI,mTYPE, $ P,D,Q,BP,BD,BQ,PBP,PQ,NW,INIT,BPQ,IMEAN,IPR c CALFOR.i but QSTAR=>QSTAR2 integer PSTAR,QSTAR2,MQ common /calfor/ PSTAR,QSTAR2,MQ c Local variables real*8 Kc Kc=Km*HPlam if (HPcycle.eq.1) then call PresentaHPSA(THhp,CHIS,NCHIS,CYCs,0,CYCNS,0, $ THETP,nTHETP,d+bd,varw,Kc,Km,MoStrCt,MoStrMt) else if (HPcycle.eq.2) then call PresentaHPSA(THhp,CHIS,NCHIS,CYCs,nCYCS,CYCNS,nCYCNS, $ THadj,nTHadj,d+bd,varw,Kc,Km,MoStrCt,MoStrMt) else if (HPcycle.eq.3) then call PresentaHPxt(THhp,PHI,p,d,TH,q,mq,BPHI,bp,bd, $ BTH,bq,Kc,Km,MoStrCt,MoStrMt) end if end c c c subroutine strFicModel(HPth,moHPstr) IMPLICIT NONE include 'stream.i' real*8 HPth(3) character moHPstr*(MaxLineLength) character line*(MaxLineLength),MAline*(MaxLineLength), $ tmpStr*(MaxStrLength),MAStr*(MaxStrLength) tmpStr=' ' call getDeltaMQstr('B ',1,2,Line) call AppendStr(' ','z(t)=',tmpStr,Line) call StrPolyn('B ',HPth,3,.1D-15,MAStr,MAline) call AppendStr(MAStr,MAline,tmpStr,line) call AppendStr(' ','b(t)',tmpStr,line) call AppendLine(tmpStr,Line) moHPstr=tmpStr(1:MaxLineLength) end polynom.i0000664006604000003110000000020114521201542012025 0ustar sun00315stepsc File Polynom.i integer MaxPol,MaxPolDim,MaxBcharLength Parameter(MaxPol=5,MaxPolDim=35,MaxBcharLength=5) ppnd.f0000664006604000003110000000255314521201542011302 0ustar sun00315steps DOUBLE PRECISION FUNCTION PPND(P,IER) C C ALGORITHM AS 111, APPL.STATIST., VOL.26, 118-121, 1977. C C PRODUCES NORMAL DEVIATE CORRESPONDING TO LOWER TAIL AREA = P. C C See also AS 241 which contains alternative routines accurate to C about 7 and 16 decimal digits. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA SPLIT/0.42D0/ DATA A0,A1,A2,A3/2.50662823884D0,-18.61500062529D0, 1 41.39119773534D0,-25.44106049637D0/, B1,B2,B3,B4/ 2 -8.47351093090D0,23.08336743743D0,-21.06224101826D0, 3 3.13082909833D0/, C0,C1,C2,C3/-2.78718931138D0,-2.29796479134D0, 4 4.85014127135D0,2.32121276858D0/, D1,D2/3.54388924762D0, 5 1.63706781897D0/ DATA ZERO/0.D0/, ONE/1.D0/, HALF/0.5D0/ C IER = 0 Q = P-HALF IF (ABS(Q).GT.SPLIT) GO TO 10 C C 0.08 < P < 0.92 C R = Q*Q PPND = Q*(((A3*R + A2)*R + A1)*R + A0)/((((B4*R + B3)*R + B2)*R 1 + B1)*R + ONE) RETURN C C P < 0.08 OR P > 0.92, SET R = MIN(P,1-P) C 10 R = P IF (Q.GT.ZERO) R = ONE-P IF (R.LE.ZERO) GO TO 20 R = SQRT(-LOG(R)) PPND = (((C3*R + C2)*R + C1)*R + C0)/((D2*R + D1)*R + ONE) IF (Q.LT.ZERO) PPND = -PPND RETURN 20 IER = 1 PPND = ZERO RETURN END pracf2.f0000664006604000003110000001320214521201542011507 0ustar sun00315stepsC Last Change: Mar. 2021- add the Ljung-Box Q and p-value for the C sample ACF of the squared residuals for all seasonal lags to the C udg file C Last change: BCM 28 Sep 1998 12:07 pm SUBROUTINE pracf2(Nefobs,A,Na,Mxlag,Lgraf,ldiag) IMPLICIT NONE c----------------------------------------------------------------------- c Calculate the ACF, PACF, and residual histogram if requested c (Replace histogram with a QQ plot when possible) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' c INCLUDE 'acfptr.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER PR PARAMETER(PR=PLEN/4) INCLUDE 'autoq.cmn' c ------------------------------------------------------------------ LOGICAL F,T PARAMETER(F=.FALSE.,T=.true.) c ------------------------------------------------------------------ LOGICAL Lgraf,ldiag,locok INTEGER i,i2,n2,Mxlag,Na,Nefobs,iacp,iacf,fhacf,fhacfg,np,endlag, & ilag DOUBLE PRECISION A,a2,a2mu,seacf,smpac DIMENSION A(PLEN),a2(PLEN),seacf(PLEN/4),smpac(PLEN/4) c----------------------------------------------------------------------- iacp=LCKAC2+1 iacf=LCKAC2 IF(.NOT.(Prttab(iacf).or.Savtab(iacf).or.Prttab(iacp).or.Lgraf)) & RETURN c ------------------------------------------------------------------ IF(Var.le.0D0)THEN IF(Prttab(iacf).or.Savtab(iacf).or.Prttab(iacp))THEN IF(.not.Lquiet)WRITE(STDERR,1010) WRITE(Mt2,1010) 1010 FORMAT(/,' NOTE: Can''t calculate an ACF of the squared ', & 'residuals for a model with no variance.') END IF RETURN END IF IF(Nefobs.le.10*Sp)THEN IF(Prttab(iacf).or.Savtab(iacf).or.Prttab(iacp))THEN WRITE(Mt1,1011)PRGNAM WRITE(Mt2,1011)PRGNAM 1011 FORMAT(/,' NOTE: ',a,' will not compute the ACF of the', & ' squared residuals for', & /,' a set of residuals that is less than ten ', & 'years long.') END IF RETURN END IF c ------------------------------------------------------------------ IF(Prttab(iacf))CALL acfhdr(Mt1,NOTSET,NOTSET,3) IF(Mxlag.eq.0)THEN IF(Sp.eq.1)THEN Mxlag=10 ELSE Mxlag=Sp END IF Mxlag=min(Mxlag,Nefobs-1) ELSE c ------------------------------------------------------------------ c Mxlag=min(Mxlag,Nefobs-1,Sp) Mxlag=min(Mxlag,Nefobs-1) END IF c ------------------------------------------------------------------ c Create a vector of the squared residuals (with mean removed) c ------------------------------------------------------------------ a2mu=0D0 DO i=Na-Nefobs+1,Na a2(i-Na+Nefobs)=A(i)*A(i) a2mu=a2mu+a2(i-Na+Nefobs) END DO a2mu=a2mu/DBLE(Nefobs) DO i=1,Nefobs a2(i)=a2(i)-a2mu END DO c ------------------------------------------------------------------ np=0 endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))np=np+1 END DO c ------------------------------------------------------------------ CALL acf(a2,Nefobs,Nefobs,smpac,seacf,Mxlag,np,Sp,Iqtype,T, & Prttab(iacf)) IF(Prttab(iacf))WRITE(Mt1,1030)PRGNAM 1030 FORMAT(/,' The P-values approximate the probability of ', & 'observing a Q-value at least', & /,' this large when the model fitted is correct in a ', & 'way that supports the', & /,' standard interpretations of the test statistics, ', & 'standard errors, and', & /,' prediction intervals output by ',a,'. When DF ', & 'is positive, small', & /,' values of P, customarily those below 0.05, suggest ', & 'that model-based', & /,' inferences about statistical significance and ', & 'uncertainty will be less', & /,' dependable than usual.',/) IF(Savtab(iacf).or.Lgraf)THEN locok=.true. IF(Savtab(iacf))CALL opnfil(T,F,iacf,fhacf,locok) IF(locok.and.Lgraf)CALL opnfil(T,Lgraf,iacf,fhacfg,locok) IF(.not.locok)THEN CALL abend RETURN END IF IF(Savtab(iacf)) & CALL savacf(fhacf,iacf,smpac,seacf,Mxlag,NOTSET,NOTSET) IF((.not.Lfatal).and.Lgraf) & CALL savacf(fhacfg,iacf,smpac,seacf,Mxlag,NOTSET,NOTSET) IF(Lfatal)RETURN IF(Savtab(iacf))CALL fclose(fhacf) IF(Lgraf)CALL fclose(fhacfg) END IF c ------------------------------------------------------------------ IF(Prttab(iacp))THEN CALL acfhdr(Mt1,NOTSET,NOTSET,5) CALL corplt(smpac,seacf,Mxlag,Sp,3) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(ldiag)THEN n2 = 2 IF(n2*Sp.gt.Mxlag)n2=1 DO i=1,n2 i2=i*Sp WRITE(Nform,1020)i2,Qs(i2),Dgf(i2),Qpv(i2) END DO END IF c ------------------------------------------------------------------ 1020 FORMAT('acf2q$',i2.2,': ',f7.3,5x,i3,5x,f6.3) c ------------------------------------------------------------------ RETURN END prafce.f0000664006604000003110000000313414521201543011576 0ustar sun00315stepsC Last change: BCM 23 Sep 1998 10:14 am SUBROUTINE prafce(Mt1,Mape,Outfer,Lfcst) IMPLICIT NONE c----------------------------------------------------------------------- c Print out average fcst std. error for the last three years c----------------------------------------------------------------------- INCLUDE 'title.cmn' c----------------------------------------------------------------------- CHARACTER cfcst*(9) DOUBLE PRECISION Mape INTEGER i,Mt1 LOGICAL Lfcst,Outfer DIMENSION Mape(4) c----------------------------------------------------------------------- IF(Lfcst)THEN cfcst='forecasts' ELSE cfcst='backcasts' END IF c----------------------------------------------------------------------- IF(.not.Lcmpaq)WRITE(Mt1,'()') IF(Outfer)THEN WRITE(Mt1,1010)'out-of-sample',cfcst ELSE WRITE(Mt1,1010)'within-sample',cfcst END IF 1010 FORMAT(' Average absolute percentage error in ',a,' ',a,':') c----------------------------------------------------------------------- IF(Lcmpaq)THEN WRITE(Mt1,1020)(Mape(i),i=1,4) ELSE WRITE(Mt1,1030)(Mape(i),i=1,4) END IF 1020 FORMAT(' Last year: ',f6.2,' Last-1 year: ',f6.2, & ' Last-2 year: ',f6.2,/,' Last three years: ',f6.2,/) 1030 FORMAT(' Last year: ',f6.2,' Last-1 year: ',f6.2, & ' Last-2 year: ',f6.2,/,' Last three years: ',f6.2,/) c----------------------------------------------------------------------- RETURN END pragr2.f0000664006604000003110000000405114521201543011532 0ustar sun00315steps SUBROUTINE pragr2(Z,Ib,Ie,Ibsav,Iesav,Ktabl,Itype,Nop,Iagr,Ext, & Extagr,Extp,Extagp,Muladd,Dvec,Lgraf) c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Add argument Ibsav, allow saving of backcasts (BCM, October 2006) c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- LOGICAL Lgraf INTEGER Ib,Ie,Ibsav,Iesav,Ktabl,Itype,Nop,Iagr,Ext,Extagr,Extp, & Extagp,Muladd,lastf,frstf DOUBLE PRECISION Z,Dvec DIMENSION Z(*),Dvec(*) c----------------------------------------------------------------------- INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- frstf=Ib IF(Savbct.and.Ibsav.lt.Ib)frstf=Ibsav lastf=Ie IF(Savfct.and.Iesav.gt.Ie)lastf=Iesav c----------------------------------------------------------------------- IF(Iagr.lt.4)THEN IF(Prttab(Ext).or.Prttab(Extp)) & CALL table(Z,Ib,Ie,Ktabl,Itype,Nop,Dvec,Ext) IF(.not.Lfatal.and.Savtab(Ext)) & CALL punch(Z,frstf,lastf,Ext,F,F) IF(.not.Lfatal.and.Savtab(Extp)) & CALL punch(Z,frstf,lastf,Extp,F,Muladd.ne.1) IF(.not.Lfatal.and.Lgraf)CALL punch(Z,frstf,lastf,Ext,Lgraf,F) ELSE IF(Iagr.eq.4)THEN IF(Prttab(Extagr).or.Prttab(Extagp)) & CALL table(Z,Ib,Ie,Ktabl,Itype,Nop,Dvec,Extagr) IF(.not.Lfatal.and.Savtab(Extagr)) & CALL punch(Z,frstf,lastf,Extagr,F,F) IF(.not.Lfatal.and.Savtab(Extagp)) & CALL punch(Z,frstf,lastf,Extagp,F,Muladd.ne.1) IF(.not.Lfatal.and.Lgraf) & CALL punch(Z,frstf,lastf,Extagr,Lgraf,F) END IF c----------------------------------------------------------------------- RETURN END prarma.f0000664006604000003110000000340214521201543011616 0ustar sun00315steps SUBROUTINE prARMA(Fh) IMPLICIT NONE c----------------------------------------------------------------------- c Prints out input file with regression, ARIMA specs c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c----------------------------------------------------------------------- CHARACTER armopr*(4) INTEGER Fh,iflt,begopr,endopr,iopr,beglag,endlag,ilag DIMENSION armopr(2:3) c----------------------------------------------------------------------- DATA armopr/'ar ','ma '/ c----------------------------------------------------------------------- c Write out the values c Probably should only the differencing if it is different c then the (1-B^sp)^d form. This would be hard. c----------------------------------------------------------------------- DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 IF(endopr.ge.begopr)THEN WRITE(fh,1070)armopr(iflt) 1070 FORMAT(' ',a,'=(') c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ DO ilag=beglag,endlag IF(Arimaf(ilag))THEN WRITE(fh,1080)Arimap(ilag),'f' 1080 FORMAT(' ',e24.10,a) ELSE WRITE(fh,1080)Arimap(ilag) END IF END DO END DO WRITE(fh,1090) 1090 FORMAT(' )') END IF END DO c ------------------------------------------------------------------ RETURN END preadtr.i0000664006604000003110000000107314521201543012002 0ustar sun00315stepsC C... Variables in Common Block /preadtr/ ... integer NOUTR,NOUIR,NEAST,NPATD,NPAREG,TRAMO,KUNITS,SUNITS integer NOUS,NDS integer NEFF(0:7) real*8 TRAM(MPKP),PAOUTR(MPKP),PAOUIR(MPKP),PAEAST(MPKP), $ PAOUS(MPKP),PATD(MPKP),PAREG(MPKP,0:7),TSE(KL), $ TramLin(MPKP) real*8 DETSEAS(12) common /preadtr/ TRAM,PAOUTR,PAOUS,PAOUIR,PAEAST, $ PATD,PAREG,TSE,DETSEAS,TramLin common /ipradtr/ NOUTR,NOUIR,NOUS,NEAST,NPATD,NPAREG,TRAMO, $ NDS,KUNITS,SUNITS,NEFF prfcrv.f0000664006604000003110000004073414521201543011647 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 11:17 am **==prfcrv.f processed by SPAG 4.03F at 16:46 on 14 Nov 1994 SUBROUTINE prfcrv(Orig,Endall,Ny,Lam,Fcntyp,Nptr,Nsvptr,Lgraf, & Lsumm) C----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Print revisions history of forecast errors for all lags c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revsrs.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'cchars.i' c----------------------------------------------------------------------- CHARACTER fctfmt*60,str*10,str2*10,outstr*(10+PFCLAG*72), & tbllbl*3,fctlbl*15,clslbl*2 LOGICAL locok,Lgraf DOUBLE PRECISION Orig,Lam,fcter,fctss,fcttrn,tmp1,tmp2 INTEGER begfct,fh,fh2,i,j,k,k2,ndef,Ny,Nptr,ndtc,ndtc2,ipos, & Endall,idate,rdbdat,Nsvptr,Fcntyp,Lsumm,ifctl,iclsl DIMENSION begfct(2),Endall(2),fcter(PFCLAG),fctss(PFCLAG), & idate(2),Orig(PLEN),fcttrn(PFCLAG) c----------------------------------------------------------------------- LOGICAL T,F DOUBLE PRECISION ONE,ZERO PARAMETER(T=.true.,F=.false.,ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- CALL setdp(ZERO,PFCLAG,fcter) CALL setdp(ZERO,PFCLAG,fctss) c----------------------------------------------------------------------- c Set date for first n-step ahead forecast c----------------------------------------------------------------------- CALL addate(Rvstrt,Ny,Rfctlg(1),begfct) c----------------------------------------------------------------------- c If forecast errors being saved, open file c----------------------------------------------------------------------- IF(Savtab(Nptr).or.Lgraf)THEN locok=T IF(Savtab(Nptr))CALL opnfil(T,F,Nptr,fh,locok) IF(locok.and.Lgraf)CALL opnfil(T,T,Nptr,fh2,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for forecast history c----------------------------------------------------------------------- WRITE(fctfmt,1010)Nfctlg 1010 FORMAT('(a,',i1,'(a,a,i2.2,a))') IF(Savtab(Nptr))WRITE(fh,fctfmt)'date', & (TABCHR,'SumSqFcstError(',Rfctlg(k),')',k=1,Nfctlg) IF(Lgraf)WRITE(fh2,fctfmt)'date', & (TABCHR,'SumSqFcstError(',Rfctlg(k),')',k=1,Nfctlg) fctfmt=' ' WRITE(fctfmt,1020)Nfctlg 1020 FORMAT('(a,',i1,'(a,a))') IF(Savtab(Nptr)) & WRITE(fh,fctfmt)'------', & (TABCHR,'----------------------',k=1,Nfctlg) IF(Lgraf) & WRITE(fh2,fctfmt)'------', & (TABCHR,'----------------------',k=1,Nfctlg) END IF c----------------------------------------------------------------------- c Start loop to print/save forecast error information. c----------------------------------------------------------------------- j=0 IF(Prttab(Nptr).or.Prttab(Nptr+1))tbllbl='R 8' DO i=Begrev+Rfctlg(1),Endrev Revptr=i-Begrev+1 j=j+1 c----------------------------------------------------------------------- c Calculate forcast errors, accumulated sum of squares. c----------------------------------------------------------------------- ndef=0 DO k=1,Nfctlg IF(Nfctlg.eq.1.or.(Nfctlg.gt.1.and.Rfctlg(k).le.j))THEN IF(Rvtrfc.and.(.not.dpeq(Lam,ONE)))THEN IF(dpeq(Lam,ZERO))THEN fcter(k)=log(Orig(i))-log(Cncfct(k,Revptr)) ELSE IF(Fcntyp.eq.3)THEN tmp1=Orig(i) tmp2=Cncfct(k,Revptr) fcter(k)=log(tmp1/(ONE-tmp1))-log(tmp2/(ONE-tmp2)) ELSE tmp1=Lam**2+(Orig(i)**Lam-ONE)/Lam tmp2=Lam**2+(Cncfct(k,Revptr)**Lam-ONE)/Lam fcter(k)=tmp1-tmp2 END IF ELSE fcter(k)=Orig(i)-Cncfct(k,Revptr) END IF fctss(k)=fctss(k)+(fcter(k)*fcter(k)) c fcter2(k)=Oriwlc(i)-Cncfct(k,Revptr) c fctss2(k)=fctss2(k)+(fcter2(k)*fcter2(k)) c fcter3(k)=Oriwlc(i)-Finfct(k,Revptr) c fctss3(k)=fctss3(k)+(fcter3(k)*fcter3(k)) ndef=ndef+1 END IF END DO c----------------------------------------------------------------------- c Print header for forecast errors c----------------------------------------------------------------------- IF(mod(j,48).eq.1.and.Prttab(Nptr))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1040)tbllbl 1040 FORMAT(/,1x,a,'. Evolving Sum of Squared Forecast Errors and', & ' evolving Mean Square Error',/, & ' of forecasts of the original data adjusted', & ' for any AO, LS, TC outliers',/, & ' or ramps at specified leads from the end of', & ' each data span.') IF(j.eq.1)THEN IF(Revfix)THEN WRITE(MT1,1041)'is not' ELSE WRITE(MT1,1041)'is' END IF 1041 FORMAT(/,' The regARIMA model ',a,' reestimated for ', & 'each span.') CALL wrtdat(begfct,Ny,str,ndtc) IF(.not.Lfatal)CALL wrtdat(Endall,Ny,str2,ndtc2) IF(Lfatal)RETURN WRITE(Mt1,1042)str(1:ndtc),str2(1:ndtc2) 1042 FORMAT(/,' Forecast dates vary from ',a,' to ',a,'.',//) END IF fctfmt=' ' WRITE(fctfmt,1050)Nfctlg 1050 FORMAT('(1x,a,',i1,'(18x,a,i2,8x))') WRITE(Mt1,fctfmt)'Date of ',('Lead ',Rfctlg(k),k=1,Nfctlg) fctfmt=' ' WRITE(fctfmt,1060)Nfctlg 1060 FORMAT('(1x,a,',i1,'(7x,a))') WRITE(Mt1,fctfmt)'Forecast', & ('SS Fct. Err. Mean S.E.',k=1,Nfctlg) WRITE(Mt1,fctfmt)'--------', & ('------------ ---------',k=1,Nfctlg) END IF c----------------------------------------------------------------------- c Print out forecast errors c----------------------------------------------------------------------- CALL addate(begfct,Ny,(j-1),idate) CALL wrtdat(idate,Ny,str,ndtc) IF(Lfatal)RETURN IF(Prttab(Nptr))THEN fctfmt=' ' IF(ndef.eq.Nfctlg)THEN WRITE(fctfmt,1070)Nfctlg 1070 FORMAT('(1x,a,',i1,'(5x,e14.8,2x,e12.6))') WRITE(Mt1,fctfmt)str(1:ndtc), & (fctss(k),fctss(k)/(Revptr-Rfctlg(k)),k=1, & Nfctlg) ELSE WRITE(fctfmt,1080)ndef,Nfctlg-ndef 1080 FORMAT('(1x,a,',i1,'(5x,e14.8,2x,e12.6),',i1,'(5x,a,2x,a))') WRITE(Mt1,fctfmt)str(1:ndtc), & (fctss(k),fctss(k)/(Revptr-Rfctlg(k)),k=1, & ndef), & ('**************','************',k2=1,Nfctlg- & ndef) END IF END IF c----------------------------------------------------------------------- IF(Savtab(Nptr).or.Lgraf)THEN c----------------------------------------------------------------------- c Set date of revision for observation Revptr c----------------------------------------------------------------------- rdbdat=100*idate(YR)+idate(MO) c----------------------------------------------------------------------- c Save forecast error revisions with date c----------------------------------------------------------------------- ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN c----------------------------------------------------------------------- DO k=1,Nfctlg outstr(ipos:ipos)=TABCHR ipos=ipos+1 IF(k.le.ndef)THEN CALL dtoc(fctss(k),outstr,ipos) ELSE CALL dtoc(ZERO,outstr,ipos) END IF IF(Lfatal)RETURN END DO IF(Savtab(Nptr))WRITE(fh,1090)outstr(1:ipos-1) IF(Lgraf)WRITE(fh2,1090)outstr(1:ipos-1) END IF IF (i.eq.Endrev) THEN IF (Lsumm.gt.0) THEN IF(Rvtrfc)THEN WRITE(Nform,1090)'transformfcst: yes' ELSE WRITE(Nform,1090)'transformfcst: no' END IF WRITE(Nform,1100)(Rfctlg(k),k=1,Nfctlg) 1100 FORMAT('rvfcstlag: ',6i3) WRITE(Nform,1110)(fctss(k)/(Revptr-Rfctlg(k)),k=1,Nfctlg) 1110 FORMAT('meanssfe:',6(2x,E17.10)) END IF IF(Svltab(Nsvptr))THEN WRITE(Ng,1111) 1111 FORMAT(/,' Average of Squared History Forecast Errors:') DO k=1,Nfctlg WRITE(Ng,1112)Rfctlg(k),Fctss(k)/(Revptr-Rfctlg(k)) END DO 1112 FORMAT(' Lead ',i3,' forecasts : ',t40,E17.10) END IF END IF END DO IF(Savtab(Nptr))CALL fclose(fh) IF(Lgraf)CALL fclose(fh2) c----------------------------------------------------------------------- c If forecast history being saved, open file c----------------------------------------------------------------------- IF(Savtab(Nptr+1).or.Lgraf)THEN locok=T IF(Savtab(Nptr+1))CALL opnfil(T,F,Nptr+1,fh,locok) IF(locok.and.Lgraf)CALL opnfil(T,T,Nptr+1,fh2,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for forecast history c----------------------------------------------------------------------- WRITE(fctfmt,1011)Nfctlg 1011 FORMAT('(a,',i1,'(a,a,i2.2,a,a,a,i2.2,a))') IF(Rvtrfc.and.(.not.dpeq(Lam,ONE)))THEN fctlbl='Trans(Forecast(' ifctl=15 clslbl='))' iclsl=2 ELSE fctlbl='Forecast(' ifctl=9 clslbl=')' iclsl=2 END IF IF(Savtab(Nptr+1)) & WRITE(fh,fctfmt)'date',(TABCHR,fctlbl(1:ifctl),Rfctlg(k), & clslbl(1:iclsl),TABCHR,'FcstError(', & Rfctlg(k),')',k=1,Nfctlg) IF(Lgraf) & WRITE(fh2,fctfmt)'date',(TABCHR,fctlbl(1:ifctl),Rfctlg(k), & clslbl(1:iclsl),TABCHR,'FcstError(', & Rfctlg(k),')',k=1,Nfctlg) fctfmt=' ' WRITE(fctfmt,1021)Nfctlg 1021 FORMAT('(a,',i1,'(a,a,a,a))') IF(Savtab(Nptr+1)) & WRITE(fh,fctfmt)'------',(TABCHR,'----------------------', & TABCHR,'----------------------',k=1,Nfctlg) IF(Lgraf) & WRITE(fh2,fctfmt)'------',(TABCHR,'----------------------', & TABCHR,'----------------------',k=1,Nfctlg) END IF c----------------------------------------------------------------------- c Start loop to print concurrent forecast information. c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Savtab(Nptr+1).or.Lgraf)THEN j=0 DO i=Begrev+Rfctlg(1),Endrev Revptr=i-Begrev+1 j=j+1 c----------------------------------------------------------------------- c Calculate forcast errors, accumulated sum of squares. c----------------------------------------------------------------------- ndef=0 DO k=1,Nfctlg IF(Nfctlg.eq.1.or.(Nfctlg.gt.1.and.Rfctlg(k).le.j))THEN IF(Rvtrfc.and.(.not.dpeq(Lam,ONE)))THEN IF(dpeq(Lam,ZERO))THEN fcter(k)=log(Orig(i))-log(Cncfct(k,Revptr)) fcttrn(k)=log(Cncfct(k,Revptr)) ELSE IF(Fcntyp.eq.3)THEN tmp1=Orig(i) tmp2=Cncfct(k,Revptr) fcter(k)=log(tmp1/(ONE-tmp1))-log(tmp2/(ONE-tmp2)) fcttrn(k)=log(tmp2/(ONE-tmp2)) ELSE tmp1=Lam**2+(Orig(i)**Lam-ONE)/Lam tmp2=Lam**2+(Cncfct(k,Revptr)**Lam-ONE)/Lam fcter(k)=tmp1-tmp2 fcttrn(k)=tmp2 END IF ELSE fcter(k)=Orig(i)-Cncfct(k,Revptr) fcttrn(k)=Cncfct(k,Revptr) END IF ndef=ndef+1 END IF END DO c----------------------------------------------------------------------- c Print header for forecast errors c----------------------------------------------------------------------- IF(mod(j,48).eq.1.and.Prttab(Nptr+1))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1043)tbllbl 1043 FORMAT(/,1x,a,'.A Forecasts of the outlier adjusted data ', & '(Table B1) at specified leads',/, & ' from the end of each data span and ', & 'associated forecast errors.') IF(Revfix)THEN WRITE(MT1,1041)'is not' ELSE WRITE(MT1,1041)'is' END IF WRITE(Mt1,1042)str(1:ndtc),str2(1:ndtc2) fctfmt=' ' WRITE(fctfmt,1051)Nfctlg 1051 FORMAT('(1x,a,',i1,'(2x,2(9x,a,i2)))') WRITE(Mt1,fctfmt)'Date of ',('Lead ',Rfctlg(k),'Lead ', & Rfctlg(k),k=1,Nfctlg) fctfmt=' ' WRITE(fctfmt,1060)Nfctlg IF(Rvtrfc.and.(.not.dpeq(Lam,ONE)))THEN WRITE(Mt1,fctfmt)'Forecast', & (' Trns(Fcst) Fcst. Error',k=1,Nfctlg) ELSE WRITE(Mt1,fctfmt)'Forecast', & (' Forecast Fcst. Error',k=1,Nfctlg) END IF WRITE(Mt1,fctfmt)'--------', & ('----------- -----------',k=1,Nfctlg) END IF c----------------------------------------------------------------------- c Print out concurrent forecast c----------------------------------------------------------------------- CALL addate(begfct,Ny,(j-1),idate) CALL wrtdat(idate,Ny,str,ndtc) IF(Lfatal)RETURN fctfmt=' ' IF(Savtab(Nptr+1).or.Lgraf)THEN ipos=1 rdbdat=100*idate(YR)+idate(MO) CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN END IF IF(Nfctlg.eq.ndef)THEN IF(Prttab(Nptr+1))THEN WRITE(fctfmt,1071)Nfctlg 1071 FORMAT('(1x,a,',i1,'(2x,2(3x,e13.7)))') WRITE(Mt1,fctfmt)str(1:ndtc),(fcttrn(k),fcter(k),k=1,Nfctlg) END IF IF(Savtab(Nptr+1).or.Lgraf)THEN DO k=1,Nfctlg outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(fcttrn(k),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(fcter(k),outstr,ipos) IF(Lfatal)RETURN END DO END IF ELSE IF(Prttab(Nptr+1))THEN WRITE(fctfmt,1081)ndef,Nfctlg-ndef 1081 FORMAT('(1x,a,',i1,'(2x,2(3x,e13.7)),',i1,'(2x,2(3x,a)))') WRITE(Mt1,fctfmt)str(1:ndtc),(fcttrn(k),fcter(k),k=1,ndef), & ('*************','*************', & k2=1,Nfctlg-ndef) END IF IF(Savtab(Nptr+1).or.Lgraf)THEN DO k=1,Nfctlg outstr(ipos:ipos)=TABCHR ipos=ipos+1 IF(k.le.ndef)THEN CALL dtoc(fcttrn(k),outstr,ipos) ELSE CALL dtoc(ZERO,outstr,ipos) END IF IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 IF(k.le.ndef)THEN CALL dtoc(fcter(k),outstr,ipos) ELSE CALL dtoc(ZERO,outstr,ipos) END IF IF(Lfatal)RETURN END DO END IF END IF IF(Savtab(Nptr+1))WRITE(fh,1090)outstr(1:ipos-1) IF(Lgraf)WRITE(fh2,1090)outstr(1:ipos-1) END DO END IF IF(Savtab(Nptr+1))CALL fclose(fh) IF(Lgraf)CALL fclose(fh2) c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1090 FORMAT(a) END priadj.cmn0000664006604000003110000000100614521201543012133 0ustar sun00315stepsc----------------------------------------------------------------------- c Usrtad : Temporary Prior adjustment factors c Usrpad : Permanent Prior adjustment factors c----------------------------------------------------------------------- DOUBLE PRECISION Usrtad,Usrpad c----------------------------------------------------------------------- DIMENSION Usrtad(PLEN),Usrpad(PLEN) c----------------------------------------------------------------------- COMMON /upradj/ Usrtad,Usrpad prior.cmn0000664006604000003110000000173714521201543012030 0ustar sun00315stepsc----------------------------------------------------------------------- c Priadj : Indicator variable indicating predefined adjustments c (0=none,1=lom,2=loq,3=lpyear) c Percnt : Indicator vector indicating the mode of the adjustment c factors (0=percent,1=ratio,2=diff) c Prtype : Vector containing type of Prior Adjustment Factor c (1=temporary, 2=permanent) c Nprtyp : Number of sets of prior adjustment factors c Kfmt : Indicator variable indicating prior adjustment is done c (0=no,1=yes) c----------------------------------------------------------------------- INTEGER Kfmt,Priadj,Percnt,Prtype,Nprtyp LOGICAL Lpradj,Lprntr c----------------------------------------------------------------------- DIMENSION Prtype(PNAD),Percnt(PNAD) c----------------------------------------------------------------------- COMMON /pradj/ Priadj,Percnt,Prtype,Nprtyp,Kfmt,Lpradj,Lprntr prior.prm0000664006604000003110000000037514521201543012046 0ustar sun00315stepsc----------------------------------------------------------------------- c PNAD : Number of types of prior adjustment factors. c----------------------------------------------------------------------- INTEGER PNAD PARAMETER(PNAD=2) pritd.f0000664006604000003110000000455414521201543011467 0ustar sun00315stepsC Last change: BCM 27 May 1998 1:17 pm SUBROUTINE pritd(Ptdwt,Ptdfac,Nrxy,Sp,Begdat,Muladd,Psuadd,Kswv, & Frstob) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine generates trading day prior adjustment factors c from a set of user-specified trading day weights c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- LOGICAL Psuadd,begrgm DOUBLE PRECISION tdxy,Ptdwt,btd,Ptdfac,tmp1,tmp2 INTEGER i,rtype,ncxy,Sp,Begdat,Nrxy,Muladd,Kswv,Frstob,Pridat DIMENSION Begdat(2),Tdxy(PLEN*6),Ptdwt(7),btd(6),rtype(6), & Pridat(2),Ptdfac(PLEN),tmp1(PLEN),tmp2(PLEN), & begrgm(PLEN) c----------------------------------------------------------------------- c Generate trading day regressors c----------------------------------------------------------------------- ncxy=6 CALL setlg(T,PLEN,begrgm) IF(Frstob.gt.1)THEN CALL addate(Begdat,Sp,Frstob-1,Pridat) ELSE CALL cpyint(Begdat,2,1,Pridat) END IF CALL td6var(Pridat,Sp,Nrxy,ncxy,1,ncxy,0,tdxy,begrgm,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c convert X-11 style td weights, set up rtype c----------------------------------------------------------------------- DO i=1,6 btd(i)=Ptdwt(i)-1D0 rtype(i)=PRGTTD END DO c----------------------------------------------------------------------- c generate factors for prior trading day c----------------------------------------------------------------------- CALL x11ref(tmp1,Ptdfac,tmp2,Frstob,Muladd,Psuadd,1,0,0,F,0,rtype, & Nrxy,ncxy,btd,tdxy,6,0,Kswv,T,F) c----------------------------------------------------------------------- IF(Frstob.gt.1)THEN DO i=Nrxy+Frstob-1,Frstob,-1 Ptdfac(i)=Ptdfac(i-Frstob+1) END DO END IF c----------------------------------------------------------------------- RETURN END prittl.cmn0000664006604000003110000000064714521201543012212 0ustar sun00315stepsc----------------------------------------------------------------------- c Adjttl : Title for the prior adjustment factors c Nadjcr : Number of character in title Adjttl c----------------------------------------------------------------------- CHARACTER Adjttl*(PSRSCR) INTEGER Nadjcr c----------------------------------------------------------------------- COMMON /prittl/ Nadjcr,Adjttl priusr.cmn0000664006604000003110000000274114521201544012216 0ustar sun00315stepsc----------------------------------------------------------------------- c Tmpser - name of temporary prior adjustment series c Prmser - name of permanent prior adjustment series c----------------------------------------------------------------------- CHARACTER Tmpser*64,Prmser*64 c----------------------------------------------------------------------- c Bgutad : Starting date for user-defined temporary prior adjustment c factors c Bgupad : Starting date for user-defined permanent prior adjustment c factors c Frstat : Position in the user defined temporary adjustment series c that corresponds to the beginning of the span c Frstap : Position in the user defined permanent adjustment series c that corresponds to the beginning of the span c Nustad : Number of user-defined temporary prior adjustment factors c Nuspad : Number of user-defined permanent prior adjustment factors c Ntser - length of name of temporary prior adjustment factors c Npser - length of name of permanent prior adjustment factors c----------------------------------------------------------------------- INTEGER Bgutad,Bgupad,Nustad,Nuspad,Frstat,Frstap,Ntser,Npser DIMENSION Bgutad(2),Bgupad(2) c----------------------------------------------------------------------- COMMON /priusr / Nustad,Nuspad,Frstat,Frstap,Bgutad,Bgupad, & Ntser,Npser,Tmpser,Prmser prlkhd.f0000664006604000003110000004113014521201544011621 0ustar sun00315stepsC Last change: BCM 29 Jan 1999 9:56 am SUBROUTINE prlkhd(Y,Adj,Adjmod,Fcntyp,Lam,Lsavst,Lprtst,Lprtfm) IMPLICIT NONE c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c adj d Pobs (nobs used) vector of preadjment factors c AIC d Local scalar for the AIC = -2*(log(L)-np) c aic d Local scalar for the F-corrected AIC c = -2*(log(L)-np/(1-(np+1)/nefobs)) c Bic d Local scalar for the BIC c dnefob d Local double precision version of nefobs c dotln c Local 60 character dotted line under the model title c Aicc d Local scalar for AIC corrected for different orders of c differencing c hnquin d Local scalar for the Hannan-Quinn c i i Do loop index c ilag i Local index for the current lag c jacadj d Jocobian of the transformation c lam d Box-Cox transformation parameter c nlag i Local number of lags in the all the components of the c structural model c np i Local number of estimated parameters including the signal c variance c one d Local PARAMETER for a double precision 1 c pi d Local PARAMETER for pi c two d Local PARAMETER for a double precision 2 c y d Pobs (nobs used) vector of original untransformed c undifferenced series c zero d Local PARAMETER for a double precision 0 c----------------------------------------------------------------------- c Data typing and initialization c----------------------------------------------------------------------- LOGICAL F INTEGER NDOTS DOUBLE PRECISION ONE,TWO,ZERO PARAMETER(ONE=1D0,NDOTS=66,TWO=2.0D0,ZERO=0D0,F=.false.) c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'lzero.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'mdltbl.i' c INCLUDE 'svllog.prm' c INCLUDE 'svllog.cmn' c INCLUDE 'mdlsvl.i' c ------------------------------------------------------------------ CHARACTER star*1 LOGICAL lclaic,Lprtfm,locok,Lsavst,Lprtst,lprt INTEGER endlag,Fcntyp,fh,i,igrp,ilag,nefobs,np,Adjmod,dsp DOUBLE PRECISION Adj,dnefob,Lam,Y,jacadj,jaci,yi DIMENSION Adj(*),Y(*) c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL dpeq,strinx c----------------------------------------------------------------------- IF(Fixmdl.eq.3)THEN igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl, & 'Automatically Identified Outliers') IF(igrp.gt.0)THEN WRITE(Mt1,1000) 1000 FORMAT(/,' NOTE: Likelihood statistics are not printed out ', & 'when the regARIMA model', & /,' is fixed and automatic outlier ', & 'identification is performed.',/) RETURN END IF END IF nefobs=Nspobs-Nintvl dnefob=dble(nefobs) CALL dfdate(Begspn,Begbk2,Sp,dsp) c----------------------------------------------------------------------- c Calculate the AIC. First find the number of estimated parameters, c including the regression and ARIMA parameters, and the variance. c----------------------------------------------------------------------- np=Ncxy IF(Nb.gt.0)THEN DO ilag=1,Nb IF(Regfx(ilag))np=np-1 END DO END IF lclaic=(Mdl(AR)-Mdl(DIFF).eq.0.or.Lar).and. & (Mdl(MA)-Mdl(AR).eq.0.or.Lma) c ------------------------------------------------------------------ IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))np=np+1 END DO END IF c ------------------------------------------------------------------ lprt=.not.Lhiddn.and.Lprtst IF(lprt)THEN WRITE(Mt1,1010) 1010 FORMAT(/,' Likelihood Statistics') WRITE(Mt1,1020)('-',i=1,NDOTS) 1020 FORMAT(' ',120(a)) c ------------------------------------------------------------------ WRITE(Mt1,1030)Nspobs,nefobs,np 1030 FORMAT(' Number of observations (nobs)',t55,i13,/, & ' Effective number of observations (nefobs)',t55,i13,/, & ' Number of parameters estimated (np)',t55,i13) END IF c----------------------------------------------------------------------- c Open a file to save the likelihood statistics c----------------------------------------------------------------------- locok=.true. IF(Lsavst)THEN CALL opnfil(.true.,.false.,LESTST,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF WRITE(fh,*) WRITE(fh,1040)'nobs',Nspobs 1040 FORMAT(a,' ',i16) WRITE(fh,1040)'nefobs',nefobs WRITE(fh,1040)'d',Nintvl WRITE(fh,1040)'np',np WRITE(fh,1050)'lndetcov',Lndtcv 1050 FORMAT(a,' ',e29.15) END IF c----------------------------------------------------------------------- c Calculate the jacobian of the transformation and print out the c AIC's if valid to do so. c----------------------------------------------------------------------- IF(Var.le.ZERO)THEN CALL errhdr WRITE(Mt2,1060) IF(lprt)WRITE(Mt1,1060) 1060 FORMAT(/,' NOTE: Can''t calculate a log likelihood for a ', & 'model with no variance') IF(Lsavst)WRITE(fh,1050)'var',ZERO c ------------------------------------------------------------------ ELSE IF(Lsavst)WRITE(fh,1050)'var',Var jacadj=ZERO IF(Adjmod.lt.2)THEN c ------------------------------------------------------------------ * DO i=1,Nspobs DO i=Nintvl+1,Nspobs IF((.not.dpeq(Y(i),0D0)).AND.(.not.dpeq(Adj(i),0D0)))THEN c----------------------------------------------------------------------- c Sometimes this equality statement doesn't work but the only way around c it is to make a FuzzyEquals(doubleA,doubleB,MachinePrecision) where c it would test if abs(A-B) ',f6.2,'%') ELSE WRITE(Mt1,1071) 1071 FORMAT(' Insufficient data to compute the average forecast ', & 'error for this model.') END IF IF(dpeq(Blchi,DNOTST))THEN WRITE(Mt1,1079) 1079 FORMAT(' Insufficient data to compute the Ljung-Box chi-', & 'square probability for this model.') ELSE IF(Blchi.le.Qlim)THEN IF(Qlim.gt.CHILIM)THEN WRITE(Mt1,1080)Qlim ELSE WRITE(Mt1,1081)Qlim END IF END IF 1080 FORMAT(' Ljung-Box Q chi-square probability < ',f6.2,' %') 1081 FORMAT(' Ljung-Box Q chi-square probability < ',e17.10,' %') END IF IF(Ovrdff)WRITE(Mt1,1090)'E','nonseasonal','.' 1090 FORMAT(' ',a,'vidence of ',a,' overdifferencing',a) END IF ELSE IF(Mape(4).gt.Bcklim)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1100)Mdlnum,Bcklim 1100 FORMAT(/,' MODEL ',i3,' REJECTED: ',/, & ' Average backcast error > ',f6.2,'%') END IF IF(Ovrsdf)WRITE(Mt1,1090)'WARNING: E','seasonal', & ' (see message below).' c----------------------------------------------------------------------- RETURN END prtchi.f0000664006604000003110000000355514521201545011640 0ustar sun00315steps SUBROUTINE prtchi(Fh,Lprhdr,Tbwdth,Baselt,Grpstr,Nchr,Info,Df, & Chi2vl,Pv,Hdrstr) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'title.cmn' c----------------------------------------------------------------------- CHARACTER Grpstr*(PGRPCR),Hdrstr*(*) LOGICAL Lprhdr INTEGER Fh,Tbwdth,Baselt,Nchr,Info,Df,i DOUBLE PRECISION Chi2vl,Pv c----------------------------------------------------------------------- IF(Lprhdr)THEN IF(.not.Lcmpaq)WRITE(Fh,'()') WRITE(Fh,1010)Hdrstr WRITE(Fh,1020)('-',i=1,tbwdth) WRITE(Fh,1030) WRITE(Fh,1020)('-',i=1,tbwdth) END IF c----------------------------------------------------------------------- IF(Info.eq.0)THEN IF(Baselt.eq.NOTSET)THEN WRITE(Fh,1080)Grpstr(1:Nchr) ELSE IF(Nchr.gt.34)THEN WRITE(Fh,1050)Grpstr(1:Nchr),Df,Chi2vl,Pv ELSE WRITE(Fh,1060)Grpstr(1:Nchr),Df,Chi2vl,Pv END IF END IF c----------------------------------------------------------------------- ELSE WRITE(Fh,1070)Grpstr(1:Nchr) END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(/,' Chi-squared Tests for Groups of ',a) 1020 FORMAT(' ',120(a)) 1030 FORMAT(' Regression Effect',t37,'df',t45,'Chi-Square',t61, & 'P-Value') 1050 FORMAT(' ',a,/,t35,i4,f16.2,f13.2) 1060 FORMAT(' ',a,t35,i4,f16.2,f13.2) 1070 FORMAT(' ',a,t52,'Not tested') 1080 FORMAT(' ',a,t41,'All coefficients fixed') c----------------------------------------------------------------------- END prtcol.f0000664006604000003110000000627414521201545011653 0ustar sun00315steps SUBROUTINE prtcol(L,Nline,Tblcol,Tblwid,Ny,Mt1,Nop,Noplbl,Disp2, & Disp3,Fmtcol,Colhdr) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine prints column headers for the table subroutine. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- CHARACTER blnk*22,dash*132,Colhdr*22,Noplbl*5,thdr*22 CHARACTER Fmtcol*110 INTEGER i,ijk,ihdr,jhdr,khdr,ndash,L,Tblcol,Tblwid,Mt1,Nop,Nline, & Ny,Disp2,Disp3 DIMENSION Colhdr(PSP+2),thdr(PSP+2) c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- CALL setchr(' ',22,blnk) CALL setchr('-',132,dash) dash(1:1)=' ' c----------------------------------------------------------------------- c Write dashes over column headers c----------------------------------------------------------------------- ndash=Tblcol*(Tblwid+Disp2)+10 IF(Nop.lt.5)THEN IF(Disp3.eq.35)THEN ndash=ndash+Tblwid+5 ELSE IF(Disp3.eq.56)THEN ndash=ndash+Tblwid+6 ELSE ndash=ndash+Tblwid+2+Disp3 END IF END IF WRITE(Mt1,1010)dash(1:ndash) c----------------------------------------------------------------------- c Set number of elements in Colhdr. Nline determines if the full c header is to be printed out (Nline=0) or some part of it. c----------------------------------------------------------------------- IF(Nline.eq.0)THEN ihdr=L+1 jhdr=L khdr=0 ELSE ihdr=Tblcol+2 jhdr=Tblcol+1 khdr=(Nline-1)*Tblcol IF((ihdr+khdr).gt.L)THEN ihdr=Ny-khdr+2 jhdr=Ny-khdr+1 END IF END IF IF(Nop.eq.5)ihdr=ihdr-1 c----------------------------------------------------------------------- c Set up headers for columns c----------------------------------------------------------------------- thdr(1)=Colhdr(1) DO ijk=2,jhdr thdr(ijk)=Colhdr(ijk+khdr) END DO c----------------------------------------------------------------------- c If a column of summary data is included with the table, enter the c label for that column at the end of Colhdr. c----------------------------------------------------------------------- IF(ihdr.gt.jhdr)THEN thdr(ihdr)=blnk(1:22) thdr(ihdr)((Tblwid-4):Tblwid)=Noplbl END IF c----------------------------------------------------------------------- c Print out column header c----------------------------------------------------------------------- WRITE(Mt1,Fmtcol)(thdr(i),i=1,ihdr) c----------------------------------------------------------------------- c Print out dashes after column header c----------------------------------------------------------------------- WRITE(Mt1,1010)dash(1:ndash) 1010 FORMAT(a) c----------------------------------------------------------------------- RETURN END prtd8b.f0000664006604000003110000003257514521201545011556 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 11:10 pm SUBROUTINE prtd8b(Stsie,Stwt,Pos1ob,Posfob,Tblptr,Lprt,Lsav,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE GENERATES a new table of SI ratios with labels for c C17 extreme values, regARIMA outliers. c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO LOGICAL F,T PARAMETER(F=.false.,T=.true.,ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'tfmts.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'title.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'notset.prm' INCLUDE 'tbltitle.prm' c----------------------------------------------------------------------- c Include data dictionary of table formats c----------------------------------------------------------------------- INCLUDE 'tfmts.prm' INCLUDE 'tfmts2.prm' c----------------------------------------------------------------------- CHARACTER extchr*(2),str*(PCOLCR),ifmt1a*(110),ifmt2a*(110), & fbase*(110),fobs*(5),fsum*(5),tblttl*(PTTLEN),ctmp*(2), & fmtcl2*(110),keylbl*(4),outstr*(400),colon*(2) DOUBLE PRECISION Stsie,Stwt,dvec,tmp LOGICAL locok,Lgraf,Lprt,Lsav,lfac INTEGER Pos1ob,Posfob,extind,i,nchr,otltyp,begotl,endotl,nmod, & ndsp,nbk,nbk2,icol,l,ipos,ifmt,ntbttl,jyr,kyr,ipow,npos, & ldec,im,ib1,ie1,idate,nfmt1a,nfmt2a,Tblptr,tw2,im0,im1, & im2,im3,numobs,j,nc DIMENSION Stsie(PLEN),Stwt(PLEN),extind(PLEN),extchr(PLEN), & tmp(PSP+1),ctmp(PSP+1),dvec(1),idate(2) c----------------------------------------------------------------------- LOGICAL dpeq INTEGER numaff EXTERNAL dpeq,numaff c----------------------------------------------------------------------- INCLUDE 'tfmts.var' INCLUDE 'tfmts2.var' c----------------------------------------------------------------------- c INITIALIZE variables c----------------------------------------------------------------------- CALL setint(0,PLEN,extind) keylbl=' ' ldec=Kdec ipow=0 IF(Muladd.ne.1)THEN IF(Kdec.eq.0)ldec=1 ipow=1 END IF DO i=Pos1ob,Posfob extchr(i)=' ' END DO nmod=5 IF(Ny.lt.5)nmod=10 c----------------------------------------------------------------------- c Determine which observations are revised as X-11 "extreme" values c----------------------------------------------------------------------- DO i = Pos1ob,Posfob IF(.not.dpeq(Stwt(i),ONE))THEN extind(i)=extind(i)+1 IF(keylbl(1:1).eq.' ')keylbl(1:1)='*' END IF END DO c----------------------------------------------------------------------- c Determine which observations are revised by regARIMA outliers c----------------------------------------------------------------------- im0=0 IF((Adjls.eq.1.and.(Nls.gt.0.or.Nramp.gt.0)).or.(Nao.gt.0.and. & Adjao.eq.1).or.(Adjtc.eq.1.and.Ntc.gt.0))THEN DO icol=1,Nb IF((Adjao.eq.1.and. & (Rgvrtp(icol).eq.PRGTAO.or.Rgvrtp(icol).eq.PRGTAA)).or. & (Adjtc.eq.1.and. & (Rgvrtp(icol).eq.PRGTTC.or.Rgvrtp(icol).eq.PRGTAT)).or. & (Adjls.eq.1.and. & (Rgvrtp(icol).eq.PRGTLS.or.Rgvrtp(icol).eq.PRGTAL.or. & Rgvrtp(icol).eq.PRGTRP.or.Rgvrtp(icol).eq.PRGTTL.or. & Rgvrtp(icol).eq.PRGTQD.or.Rgvrtp(icol).eq.PRGTQI)))THEN c----------------------------------------------------------------------- c Get regARIMA outlier information c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN CALL rdotlr(str(1:nchr),Begxy,Sp,otltyp,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Determine which observation(s) are effected by these outliers c----------------------------------------------------------------------- CALL dfdate(Begxy,Begbk2,Sp,ndsp) i=begotl+ndsp extind(i)=extind(i)+2 IF(otltyp.eq.RP)THEN DO i=begotl+ndsp+1,endotl+ndsp extind(i)=extind(i)+2 END DO ELSE IF(otltyp.eq.LS)THEN im1=numaff(B(icol),Muladd,Nterm) IF(im1.gt.0)THEN DO im2=1,im1 im3=i+im2 IF(im3.le.Posfob)extchr(im3)(1:2)=' -' im3=i-im2 IF(im3.ge.Pos1ob)extchr(im3)(1:2)=' -' END DO im0=im0+im1 END IF END IF END IF END DO END IF c----------------------------------------------------------------------- c Create a string of labels to indicate which observations are c effected by the different types of outlier adjustment c----------------------------------------------------------------------- DO i=Pos1ob,Posfob IF(extind(i).gt.0)THEN IF(extind(i).eq.1)THEN extchr(i)(1:1)='*' ELSE IF(extind(i).eq.2)THEN extchr(i)(1:1)='#' IF(keylbl(2:2).eq.' ')keylbl(2:2)='#' ELSE IF(mod(extind(i),2).eq.0)THEN extchr(i)(1:1)='@' IF(keylbl(3:3).eq.' ')keylbl(3:3)='@' ELSE extchr(i)(1:1)='&' IF(keylbl(4:4).eq.' ')keylbl(4:4)='&' END IF END IF END DO IF(Lprt)THEN c----------------------------------------------------------------------- c Create formats for printing out the table c----------------------------------------------------------------------- IF(Tblwid.gt.9)then write(fobs,1010)Tblwid,ldec 1010 FORMAT('f',i2,'.',i1) ifmt=5 ELSE write(fobs,1020)Tblwid,ldec 1020 FORMAT('f',i1,'.',i1) ifmt=4 ENDIF write(fsum,1010)Tblwid+2,ldec CALL setchr(' ',110,fbase) CALL getstr(TF2DIC,tf2ptr,PTF2,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,ifmt1a,fobs(1:ifmt),fsum,ipos,nfmt1a) CALL setchr(' ',110,fbase) CALL getstr(TF2DIC,tf2ptr,PTF2,Iptr+1,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,ifmt2a,fobs(1:ifmt),fsum,ipos,nfmt2a) c----------------------------------------------------------------------- c Construct revised format for column headings. c----------------------------------------------------------------------- tw2=Tblwid+1 if(tw2.gt.9)then write(fobs,1030)tw2 1030 FORMAT('a',i2) ifmt=3 else write(fobs,1040)tw2 1040 FORMAT('a',i1) ifmt=2 endif write(fsum,1030)tw2+2 CALL setchr(' ',110,fbase) CALL getstr(TFMDIC,tfmptr,PTFM,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,fmtcl2,fobs(1:ifmt),fsum(1:3),ipos,npos) fmtcl2(1:npos)=Ifmt2(1:6)//fmtcl2(7:npos) c----------------------------------------------------------------------- c Generate headers and subheaders for the table c----------------------------------------------------------------------- CALL getdes(Tblptr,tblttl,ntbttl,T) IF(Lfatal)RETURN numobs=Posfob-Pos1ob+1 CALL tblhdr(8,0,Ixreg,numobs,Begspn,Ny,dvec,tblttl(1:ntbttl)) IF(Lfatal)RETURN IF(Ny.eq.4)THEN l=5 ELSE l=13 END IF CALL prtcol(l,0,Tblcol,tw2,Ny,Mt1,5,' ',Disp2,Disp3,fmtcl2, & Colhdr) l=l-1 c----------------------------------------------------------------------- c print out table c----------------------------------------------------------------------- jyr=Lyr+(Pos1ob-1)/Ny kyr=(Posfob+Ny-1)/Ny+Lyr-1 c iin=iin+(jyr-Lyr) DO i=1,13 tmp(i)=DNOTST ctmp(i)=' ' END DO ib1=Pos1ob ie1=(jyr-Lyr+1)*Ny IF(ie1.gt.Posfob)ie1=Posfob im=Pos1ob-(Pos1ob-1)/Ny*Ny DO WHILE (T) im1=im DO i=ib1,ie1 IF(Muladd.eq.2)THEN tmp(im)=exp(Stsie(i)) ELSE tmp(im)=Stsie(i) END IF ctmp(im)=extchr(i) im=im+1 END DO im2=im-1 c----------------------------------------------------------------------- c Compute number of blanks for the beginning or end of the series c for observations not in the series. c----------------------------------------------------------------------- nbk=0 IF(jyr.eq.Begspn(YR).and.Begspn(MO).gt.1)nbk=Begspn(MO) nbk2=0 IF(ie1.eq.Posfob)THEN CALL addate(Begspn,Ny,numobs-1,idate) nbk2=idate(MO) IF(nbk2.eq.Ny)nbk2=0 END IF c----------------------------------------------------------------------- c Write out this year's data. c----------------------------------------------------------------------- CALL wrttb2(tmp,ctmp,jyr,'XXXXX',l,ldec,Mt1,ifmt1a(1:nfmt1a), & tw2,Tblcol,Disp1,Disp2,Disp3,nbk,nbk2,ipow,1, & l.eq.13.or.l.eq.5) IF(Lfatal)RETURN IF((.not.Lcmpaq).or. & (kyr.lt.jyr+1 .or. (mod(jyr,nmod)+1).eq.nmod))WRITE(Mt1,1050) 1050 FORMAT(' ') c----------------------------------------------------------------------- c Update year, starting and ending position of year c----------------------------------------------------------------------- jyr=jyr+1 im=1 ib1=ie1+1 ie1=ie1+Ny IF(kyr.eq.jyr)THEN DO i=1,Ny tmp(i)=DNOTST END DO ie1=Posfob ELSE IF(kyr.lt.jyr)THEN GO TO 10 END IF END DO c----------------------------------------------------------------------- 10 IF(keylbl.eq.' ')THEN WRITE(Mt1,1060) 1060 FORMAT(/,' No extreme values or regARIMA outliers.') ELSE IF(Lcmpaq)THEN WRITE(Mt1,1071) ELSE WRITE(Mt1,1070) END IF 1070 FORMAT(/,' Key to symbols:') 1071 FORMAT(' Key to symbols:') DO i=1,4 IF(keylbl(i:i).eq.'*')THEN WRITE(Mt1,1080) 1080 FORMAT(' * : extreme value as determined by X-11 extreme', & ' value procedure') ELSE IF(keylbl(i:i).eq.'#')THEN WRITE(Mt1,1090) 1090 FORMAT(' # : regARIMA outlier (either AO, LS, TC, or ', & 'Ramp)') ELSE IF(keylbl(i:i).eq.'@')THEN WRITE(Mt1,1100) 1100 FORMAT(' @ : extreme value and at least one type of ', & 'regARIMA outlier') ELSE IF(keylbl(i:i).eq.'&')THEN WRITE(Mt1,1110) 1110 FORMAT(' & : more than one type of regARIMA outlier') END IF END DO END IF IF((Adjls.eq.1.and.Nls.gt.0).and.im0.gt.0)WRITE(Mt1,1120) 1120 FORMAT(' - : values around a level shift most likely to be', & ' influenced by it') IF(.not.Lcmpaq)WRITE(Mt1,1050) END IF c----------------------------------------------------------------------- IF(Lsav.or.Lgraf)THEN IF(Lsav) & CALL savd8b(Tblptr,Begbk2,Pos1ob,Posfob,Ny,Stsie,extchr,Serno, & Nser,F) IF(.not.Lfatal.and.Lgraf) & CALL savd8b(Tblptr,Begbk2,Pos1ob,Posfob,Ny,Stsie,extchr,Serno, & Nser,Lgraf) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN DO i=Pos1ob,Pos1ob+Ny-1 ipos=1 nc=1 colon=': ' DO j=i,Posfob,Ny CALL addate(Begbk2,Ny,j-1,idate) IF(.not.(extchr(j).eq.' '))THEN CALL itoc(idate(YR),outstr,ipos) IF(Lfatal)RETURN IF(.not.(extchr(j)(1:1).eq.' '))THEN IF(extchr(j)(1:1).eq.'*')THEN IF(dpeq(Stwt(j),ZERO))THEN outstr(ipos:ipos)='z' ELSE outstr(ipos:ipos)=extchr(j)(1:1) END IF ipos=ipos+1 ELSE outstr(ipos:ipos)=extchr(j)(1:1) ipos=ipos+1 IF(dpeq(Stwt(j),ZERO))THEN outstr(ipos:ipos)='z' ipos=ipos+1 END IF END IF END IF IF(.not.(extchr(j)(2:2).eq.' '))THEN outstr(ipos:ipos)=extchr(j)(2:2) ipos=ipos+1 END IF outstr(ipos:ipos)=' ' ipos=ipos+1 IF(ipos.ge.PFILCR)THEN WRITE(Nform,2000)idate(MO),colon(1:nc),outstr(1:(ipos-1)) ipos=1 nc=2 colon='c:' END IF END IF END DO IF(ipos.gt.1)THEN WRITE(Nform,2000)idate(MO),colon(1:nc),outstr(1:(ipos-1)) ELSE WRITE(Nform,2000)idate(MO),colon(1:nc),'none' END IF 2000 FORMAT('d8b.',i2.2,a,1x,a) END DO END IF c----------------------------------------------------------------------- RETURN END prtd9a.f0000664006604000003110000001074114521201545011545 0ustar sun00315stepsC Last change: BCM 26 Apr 1998 2:48 pm SUBROUTINE prtd9a(Lprt) IMPLICIT NONE c----------------------------------------------------------------------- c Print out the D9A (Moving Seasonality Ratio) table c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'tfmts.prm' INCLUDE 'tfmts.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- CHARACTER tfmt*(110),fobs*(5),fsum*(5),fbase*(110) DOUBLE PRECISION tmp LOGICAL Lprt INTEGER l,i,nline,n1,n2,n,ifmt,ipos,n3,npos DIMENSION tmp(PSP) c----------------------------------------------------------------------- INCLUDE 'tfmts.var' c----------------------------------------------------------------------- c Return if printing is turned off for this run. c----------------------------------------------------------------------- IF(Lhiddn)RETURN c----------------------------------------------------------------------- c If summary diagnostics are stored, store Ibar, Sbar and I/S c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN DO i=1,Ny WRITE(Nform,1000)i,Rati(i),Rati(i+Ny),Rati(i+2*Ny) END DO 1000 FORMAT('d9a.',i2.2,':',3(1x,E17.10)) IF(.not.Lprt)RETURN END IF c----------------------------------------------------------------------- c Figure out how many lines are printed out for each year c----------------------------------------------------------------------- nline=Ny/Tblcol IF(mod(Ny,Tblcol).gt.0)nline=nline+1 c----------------------------------------------------------------------- c Print the complete table (column header, I, S, MSR) for each c of the sets of months used in the main printout. c----------------------------------------------------------------------- DO n=1,nline n1=(n-1)*Tblcol+1 n2=n*Tblcol IF(n2.gt.Ny)n2=Ny c----------------------------------------------------------------------- c Create column headings c----------------------------------------------------------------------- IF(Ny.eq.4)THEN l=5 ELSE l=13 END IF CALL prtcol(l,n,Tblcol,Tblwid,Ny,Mt1,5,' ',Disp2,Disp3, & Fmtcol,Colhdr) c----------------------------------------------------------------------- c Generate the output format c----------------------------------------------------------------------- if(Tblwid.gt.9)then write(fobs,1010)Tblwid 1010 format('f',i2,'.3') ifmt=5 else write(fobs,1020)Tblwid 1020 format('f',i1,'.3') ifmt=4 end if write(fsum,1010)Tblwid+2 fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr+1,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,tfmt,fobs(1:ifmt),fsum,ipos,npos) c----------------------------------------------------------------------- c Print out variance of irregular component c----------------------------------------------------------------------- n3=n2-n1+1 DO i=n1,n2 tmp(i-n1+1)=Rati(i) END DO CALL wrttbl(tmp,0,' I ',n3,3,Mt1,tfmt(1:npos),Tblwid,Disp1, & Disp2,Disp3,n3,0,0,0,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print out variance of Seasonal component c----------------------------------------------------------------------- DO i=n1,n2 tmp(i-n1+1)=Rati(i+Ny) END DO CALL wrttbl(tmp,0,' S ',n3,3,Mt1,tfmt(1:npos),Tblwid,Disp1, & Disp2,Disp3,n3,0,0,0,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print out Moving Seasonality Ratio c----------------------------------------------------------------------- DO i=n1,n2 tmp(i-n1+1)=Rati(i+2*Ny) END DO CALL wrttbl(tmp,0,'RATIO',n3,3,Mt1,tfmt(1:npos),Tblwid,Disp1, & Disp2,Disp3,n3,0,0,0,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- WRITE(Mt1,1030) 1030 FORMAT(//) END DO RETURN END prtdft.f0000664006604000003110000000550714521201545011651 0ustar sun00315steps SUBROUTINE prtdft(Lprsft,Lprhdr,Tbwdth,Lsvsft,Lsvlog,Baselt, & Grpstr,Nchr,Info,Df1,Df2,Sftvl,Pv) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'title.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER Grpstr*(PGRPCR) LOGICAL Lprsft,Lprhdr,Lsvsft,Lsvlog INTEGER Tbwdth,Baselt,Nchr,Info,Df1,Df2,i DOUBLE PRECISION Sftvl,Pv c----------------------------------------------------------------------- IF(Lprhdr)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1010)' ' WRITE(Mt1,1020)('-',i=1,tbwdth) WRITE(Mt1,1030) WRITE(Mt1,1020)('-',i=1,tbwdth) IF(Lsvlog)THEN WRITE(Ng,1010)':' WRITE(Ng,1030) WRITE(Ng,1020)'-----------------',' ', & '-------',' ','-----------',' ', & '-------' END IF Lprhdr=F END IF c----------------------------------------------------------------------- IF(Lsvsft.and.baselt.ne.NOTSET) & WRITE(Nform,1040)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv c----------------------------------------------------------------------- IF(Lprsft)THEN IF(Info.eq.0)THEN IF(Baselt.eq.NOTSET)THEN WRITE(Mt1,1080)Grpstr(1:Nchr) IF(Lsvlog)WRITE(Ng,1080)Grpstr(1:Nchr) ELSE IF(Nchr.gt.34)THEN WRITE(Mt1,1050)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv IF(Lsvlog)WRITE(Ng,1050)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv ELSE WRITE(Mt1,1060)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv IF(Lsvlog)WRITE(Ng,1060)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv END IF END IF c----------------------------------------------------------------------- ELSE WRITE(Mt1,1070)Grpstr(1:Nchr) IF(Lsvlog)WRITE(Ng,1070)Grpstr(1:Nchr) END IF END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(/,' F Tests for Trading Day Regressors',a1) 1020 FORMAT(' ',120(a)) 1030 FORMAT(' Regression Effect',t40,'df',t51,'F-statistic',t66, & 'P-Value') 1040 FORMAT('tdtest$',a,': ',2(1x,i4),2(1x,e22.15)) 1050 FORMAT(' ',a,/,t35,i4,',',i4,f16.2,f13.2) 1060 FORMAT(' ',a,t35,i4,',',i4,f16.2,f13.2) 1070 FORMAT(' ',a,t52,'Not tested') 1080 FORMAT(' ',a,t41,'All coefficients fixed') c----------------------------------------------------------------------- END prtdtb.f0000664006604000003110000001632114521201545011641 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 11:12 pm **==prtdtb.f processed by SPAG 4.03F at 08:58 on 5 Oct 1994 SUBROUTINE prtdtb(Tdtbl) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine prints out the trading day factors associated with c each type of month. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'mq3.cmn' INCLUDE 'picktd.cmn' c----------------------------------------------------------------------- c Allow leap year output when adjust = leapyr (BCM August 2007) c----------------------------------------------------------------------- DOUBLE PRECISION BIG LOGICAL F,T PARAMETER(F=.false.,T=.true.,BIG=10D16) c----------------------------------------------------------------------- CHARACTER tdfmt*(50),daylbl*(15),datstr*(10) LOGICAL Pckxtd,Xrgmtd,Fulxtd,prlpyr INTEGER i,j,Tdtbl,Xtdzro,Xtddat,nchdat,ldec DOUBLE PRECISION Tdx11,Tdx11b,Tdmdl,Tdmdl1,daynum,Lpmdl,Lpmdl1 DIMENSION daylbl(4,4),daynum(2,6),Tdmdl(PTD), & Tdmdl1(PTD),Tdx11(PTD),Tdx11b(PTD),Xtddat(2),Lpmdl(2), & Lpmdl1(2) c----------------------------------------------------------------------- LOGICAL dpeq INTEGER nblank EXTERNAL dpeq,nblank c----------------------------------------------------------------------- COMMON /cmdltd / Tdmdl,Tdmdl1,Lpmdl,Lpmdl1 COMMON /cx11td / Tdx11,Tdx11b COMMON /cxpktd / Xtdzro,Xtddat,Pckxtd,Xrgmtd,Fulxtd c----------------------------------------------------------------------- DATA (daylbl(1,j),j=1,4)/'92-day quarters','91-day quarters', & 'Leap year Q1 ','Non-Leap Q1 '/ DATA (daylbl(2,j),j=1,4)/'31-day months ','30-day months ', & 'Leap year Feb. ','Non-Leap Feb. '/ DATA (daylbl(3,j),j=1,4)/' ',' ', & '100*(91/90.25) ','100*(90/90.25) '/ DATA (daylbl(4,j),j=1,4)/' ',' ', & '100*(29/28.25) ','100*(28/28.25) '/ c----------------------------------------------------------------------- DATA (daynum(1,j),j=1,6)/92D0,91D0,91D0,90D0,90.25D0,91.25D0/ DATA (daynum(2,j),j=1,6)/31D0,30D0,29D0,28D0,28.25D0,30.4375D0/ c----------------------------------------------------------------------- c Print page header c----------------------------------------------------------------------- IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(Muladd.ne.1)THEN WRITE(Mt1,1020) 1020 FORMAT(/,' F 4. Multiplicative Trading Day Component Factors:', & /,' Day of Week and Leap Year Factors') ELSE WRITE(Mt1,1030) 1030 FORMAT(/,' F 4. Additive Day of the Week Trading Day Component', & ' Factors') END IF c----------------------------------------------------------------------- j=16 IF(Ny.eq.4)j=1 DO i=j,PTD IF(Tdtbl.eq.1.or.Tdtbl.eq.3)THEN IF(dpeq(Tdx11(i),DNOTST))Tdx11(i)=BIG IF(Xrgmtd.and.dpeq(Tdx11b(i),DNOTST))Tdx11b(i)=BIG END IF IF(Tdtbl.ge.2)THEN IF(dpeq(Tdmdl(i),DNOTST))Tdmdl(i)=BIG IF(Lrgmtd.and.dpeq(Tdmdl1(i),DNOTST))Tdmdl1(i)=BIG END IF END DO j=1 IF(Ny.eq.12)j=2 c----------------------------------------------------------------------- c Produce format for type of trading day table c----------------------------------------------------------------------- ldec=2 IF(Muladd.eq.1)ldec=Kdec WRITE(tdfmt,1040)ldec c 1040 FORMAT('(1x,a15,7(1x,f8.',i1,'))') 1040 FORMAT('(1x,a,7(1x,f8.',i1,'))') c----------------------------------------------------------------------- c Print table of trading day factors. c----------------------------------------------------------------------- IF(Tdtbl.eq.1)THEN CALL prttd(Tdx11,Tdx11b,'Irregular Component Regression',Xtdzro, & Xtddat,Xrgmtd,Fulxtd,tdfmt,Ny,Moqu) ELSE CALL prttd(Tdmdl,Tdmdl1,'regARIMA',Tdzero,Tddate,Lrgmtd,Fulltd, & tdfmt,Ny,Moqu) END IF c----------------------------------------------------------------------- c IF both regARIMA and X-11 trading day factors are printed, print c out X-11 trading day here. c----------------------------------------------------------------------- IF(Tdtbl.eq.3) & CALL prttd(Tdx11,Tdx11b,'Irregular Component Regression',Xtdzro, & Xtddat,Xrgmtd,Fulxtd,tdfmt,Ny,Moqu) IF(Muladd.eq.1)RETURN c----------------------------------------------------------------------- c Print message describing leap year effect. c----------------------------------------------------------------------- prlpyr=F IF(Picktd)THEN prlpyr=T ELSE IF (Tdtbl.eq.2) THEN IF(iabs(Priadj).eq.4)THEN prlpyr=T ELSE IF (.not.dpeq(Lpmdl(2),DNOTST))THEN prlpyr=T END IF ELSE prlpyr=T END IF IF(prlpyr)THEN IF(dpeq(Lpmdl(2),DNOTST))THEN WRITE(Mt1,1110)Moqu(1:nblank(Moqu)) 1110 FORMAT(//,6x,'Nonseasonal component of length of ',a,' effect ', & '("Leap Year" factors):',/) DO i=1,2 WRITE(Mt1,1105)daylbl(j,i),100D0,daylbl((j+2),i) END DO DO i=3,4 WRITE(Mt1,1105)daylbl(j,i),(daynum(j,i)/daynum(j,5))*100D0, & daylbl((j+2),i) END DO ELSE IF(dpeq(Lpmdl1(2),DNOTST))THEN WRITE(Mt1,1110)Moqu(1:nblank(Moqu)) ELSE CALL wrtdat(Tddate,Ny,datstr,nchdat) IF(Fulltd.or.Tdzero.gt.0)THEN WRITE(Mt1,1112)Moqu(1:nblank(Moqu)),datstr(1:nchdat) 1112 FORMAT(//,6x,'Nonseasonal component of length of ',a, & ' effect ("Leap Year" factors):',/,6x,'before ',a) ELSE WRITE(Mt1,1113)Moqu(1:nblank(Moqu)),datstr(1:nchdat) 1113 FORMAT(//,6x,'Nonseasonal component of length of ',a, & ' effect ("Leap Year" factors):',/,6x,'starting ',a) END IF END IF DO i=1,2 WRITE(Mt1,1105)daylbl(j,i),100D0,daylbl((j+2),i) END DO DO i=1,2 WRITE(Mt1,1105)daylbl(j,i+2),Lpmdl(i),daylbl((j+2),i) END DO IF(.not.dpeq(Lpmdl1(2),DNOTST))THEN IF(Tdzero.eq.1)THEN WRITE(Mt1,1112)Moqu(1:nblank(Moqu)),datstr(1:nchdat) ELSE WRITE(Mt1,1113)Moqu(1:nblank(Moqu)),datstr(1:nchdat) END IF DO i=1,2 WRITE(Mt1,1105)daylbl(j,i),100D0,daylbl((j+2),i) END DO DO i=1,2 WRITE(Mt1,1105)daylbl(j,i+2),Lpmdl1(i),daylbl((j+2),i) END DO END IF END IF END IF c----------------------------------------------------------------------- 1105 FORMAT(2x,a15,f7.2,2x,a15) RETURN END prtdwr.f0000664006604000003110000001124614521201545011665 0ustar sun00315stepsC Last change: BCM 23 Aug 2006 10:52 am SUBROUTINE prtdwr() IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1.0D0,ZERO=0.0D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER tdstr*(PGRPCR),td2str*(PGRPCR),td3str*(PGRPCR), & td4str*(PGRPCR) DOUBLE PRECISION sumb,sumcr,sumcr2,sumcr3,tdwrg,tdwcr,tdwcr2, & tdwcr3,addon INTEGER icol,imark,nrg,ncr,ncr2,ncr3,ncol,ncol2,ncol3,ncol4,igrp, & begcol,endcol,Tbcode DIMENSION tdwrg(6),tdwcr(6),tdwcr2(6),tdwcr3(6) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- IF(Nb.eq.0)RETURN nrg = 0 ncr = 0 ncr2 = 0 ncr3 = 0 sumb = ZERO sumcr = ZERO sumcr2 = ZERO sumcr3 = ZERO addon = ZERO IF(dpeq(Lam,ZERO))addon=ONE c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 imark=Rgvrtp(begcol) IF(imark.eq.PRGTTD)THEN DO icol=begcol,endcol nrg=nrg+1 tdwrg(nrg)=B(icol)+addon sumb = sumb - B(icol) IF(nrg.eq.1)CALL getstr(Grpttl,Grpptr,Ngrp,igrp,tdstr,ncol) END DO ELSE IF(imark.eq.PRRTTD)THEN DO icol=begcol,endcol ncr=ncr+1 tdwcr(ncr)=B(icol)+addon sumcr = sumcr - B(icol) IF(ncr.eq.1)CALL getstr(Grpttl,Grpptr,Ngrp,igrp,td2str,ncol2) END DO ELSE IF(imark.EQ.PRATTD)THEN DO icol=begcol,endcol ncr2=ncr2+1 tdwcr2(ncr2)=B(icol)+addon sumcr2 = sumcr2 - B(icol) IF(ncr2.eq.1)CALL getstr(Grpttl,Grpptr,Ngrp,igrp,td3str,ncol3) END DO ELSE IF(imark.EQ.PRGUTD)THEN DO icol=begcol,endcol ncr3=ncr3+1 tdwcr3(ncr3)=B(icol)+addon sumcr3 = sumcr3 - B(icol) IF(ncr3.eq.1)CALL getstr(Grpttl,Grpptr,Ngrp,igrp,td4str,ncol4) END DO END IF END DO c ------------------------------------------------------------------ IF(nrg.eq.0.and.ncr.eq.0.and.ncr2.eq.0)RETURN c ------------------------------------------------------------------ WRITE(Mt1,1000)' ' WRITE(Mt1,1000)'Regression Trading Day Weights' WRITE(Mt1,1010) WRITE(Mt1,1000) & '---------------------------------------------------------------' WRITE(Mt1,1020) WRITE(Mt1,1000) & '---------------------------------------------------------------' IF(nrg.gt.0)THEN sumb = sumb + ONE WRITE(Mt1,1000)tdstr(1:ncol) IF(dpeq(Lam,ZERO))THEN WRITE(Mt1,1030)(tdwrg(icol), icol = 1, 6), sumb ELSE WRITE(Mt1,1040)(tdwrg(icol), icol = 1, 6), sumb END IF END IF IF(ncr.gt.0)THEN sumcr = sumcr + ONE WRITE(Mt1,1000)td2str(1:ncol2) IF(dpeq(Lam,ZERO))THEN WRITE(Mt1,1030)(tdwcr(icol), icol = 1, 6), sumcr ELSE WRITE(Mt1,1040)(tdwcr(icol), icol = 1, 6), sumcr END IF END IF IF(ncr2.gt.0)THEN sumb = sumb + ONE sumcr2 = sumcr2 + ONE WRITE(Mt1,1000)td3str(1:ncol3) IF(dpeq(Lam,ZERO))THEN WRITE(Mt1,1030)(tdwcr2(icol), icol = 1, 6), sumcr2 ELSE WRITE(Mt1,1040)(tdwcr2(icol), icol = 1, 6), sumcr2 END IF END IF IF(ncr3.gt.0)THEN sumcr3 = sumcr3 + ONE WRITE(Mt1,1000)td4str(1:ncol4) IF(dpeq(Lam,ZERO))THEN WRITE(Mt1,1030)(tdwcr3(icol), icol = 1, 6), sumcr3 ELSE WRITE(Mt1,1040)(tdwcr2(icol), icol = 1, 6), sumcr3 END IF END IF WRITE(Mt1,1000) & '---------------------------------------------------------------' c----------------------------------------------------------------------- 1000 FORMAT(1x,a) 1010 FORMAT(5x,'(Regression Trading Day Coefficients expressed as ',/, & 6x,'X-11 Trading Day Weights)',/) 1020 FORMAT(' Mon Tue Wed Thu Fri Sat', & ' *Sun (derived)') 1030 FORMAT(8x,7f8.4) 1040 FORMAT(8x,7f8.1) c----------------------------------------------------------------------- RETURN END prterr.f0000664006604000003110000003151214521201546011660 0ustar sun00315stepsC Last change: SRD 19 Nov 99 6:05 am SUBROUTINE prterr(Nefobs,Lauto) IMPLICIT NONE c----------------------------------------------------------------------- c prterr.f, Release 1, Subroutine Version 1.7, Modified 14 Feb 1995. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'mdltbl.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER str*(PMDLCR) LOGICAL ltmper,Lauto INTEGER itmp,nchr,Nefobs,nfil,Begxy,Nrxy,Endspn DIMENSION Begxy(2),Endspn(2) c ------------------------------------------------------------------ DOUBLE PRECISION dpmpar INTEGER nblank EXTERNAL nblank,dpmpar c----------------------------------------------------------------------- COMMON /armaxy/ Endspn,Begxy,Nrxy c----------------------------------------------------------------------- nfil=nblank(Cursrs) c----------------------------------------------------------------------- c Unknown error c----------------------------------------------------------------------- IF(Armaer.eq.PUNKER.or.Armaer.lt.0)THEN Convrg=F Var=0D0 IF(Issap.eq.2)THEN CALL errhdr WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1030) WRITE(Mt2,1030) ELSE IF(Irev.eq.4)THEN CALL errhdr WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1040) WRITE(Mt2,1040) ELSE IF(.NOT.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1050) END IF WRITE(Mt2,1050) END IF c----------------------------------------------------------------------- c Xy is singular c----------------------------------------------------------------------- ELSE IF(Armaer.eq.PSNGER.or.Armaer.eq.PISNER)THEN IF(Sngcol.lt.Ncxy)THEN CALL getstr(Colttl,Colptr,Ncoltl,Sngcol,str,nchr) IF(Lfatal)RETURN c ------------------------------------------------------------------- ELSE nchr=4 str(1:nchr)='data' END IF c ------------------------------------------------------------------- IF(Armaer.eq.PISNER)THEN IF(.NOT.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1060)str(1:nchr) END IF CALL errhdr WRITE(Mt2,1060)str(1:nchr) c ------------------------------------------------------------------ ELSE IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1070)str(1:nchr) c----------------------------------------------------------------------- c Added printing of regression matrix (BCM 5-97) c----------------------------------------------------------------------- IF(Prttab(LREGDT))THEN CALL prtshd('Regression Matrix',Begxy,Sp,Nrxy,F) IF(.not.Lfatal)CALL prtmtx(Begxy,Sp,Xy,Nrxy,Ncxy,Colttl, & Colptr,Ncoltl) IF(Lfatal)RETURN END IF END IF CALL errhdr WRITE(Mt2,1070)str(1:nchr) END IF c ------------------------------------------------------------------- IF(.not.Lauto)CALL abend() RETURN c----------------------------------------------------------------------- c Improper input to the nonlinear routine c----------------------------------------------------------------------- ELSE IF(Armaer.eq.PINPER)THEN CALL errhdr WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1080) WRITE(Mt2,1080) c ------------------------------------------------------------------ ELSE IF(Armaer.eq.PMXIER)THEN CALL errhdr CALL itrerr('iterations',Lauto,Issap,Irev) c ------------------------------------------------------------------ ELSE IF(Armaer.eq.PMXFER)THEN CALL errhdr CALL itrerr('function evaluations',Lauto,Issap,Irev) c ------------------------------------------------------------------ ELSE IF(Armaer.eq.PSCTER.or.Armaer.eq.PSPMER.or.Armaer.eq.PCOSER) & THEN IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1090) END IF CALL errhdr WRITE(Mt2,1090) IF(.not.Lprier)THEN IF(.not.Lauto)WRITE(Mt1,1100) WRITE(Mt2,1100) ELSE IF(Armaer.eq.PSCTER)THEN IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1110) END IF WRITE(Mt2,1110) c ------------------------------------------------------------------ ELSE IF(Armaer.eq.PSPMER)THEN IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1120) END IF CALL errhdr WRITE(Mt2,1120) c ------------------------------------------------------------------ ELSE IF(Armaer.eq.PCOSER)THEN CALL errhdr IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1130) END IF WRITE(Mt2,1130) END IF IF(Issap.eq.2)THEN WRITE(Mt1,1200) ELSE IF(Irev.eq.4)THEN WRITE(Mt1,1210) END IF c----------------------------------------------------------------------- c Invertibility errors. Print the estimates, and stop. c----------------------------------------------------------------------- ELSE IF(Armaer.eq.PNIFER)THEN CALL getstr(Oprttl,Oprptr,Noprtl,Prbfac,str,nchr) IF(Lfatal)RETURN IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1140)str(1:nchr) END IF CALL errhdr WRITE(Mt2,1140)str(1:nchr) IF(Issap.eq.2)THEN WRITE(Mt1,1150) ELSE IF(Irev.eq.4)THEN WRITE(Mt1,1160) END IF ltmper=Lprier Lprier=T CALL chkrt2(F,itmp,Lhiddn) IF(Lfatal)RETURN Lprier=ltmper IF(.not.Lauto)CALL abend() RETURN c ------------------------------------------------------------------ ELSE IF(Armaer.eq.PNIMER)THEN CALL getstr(Oprttl,Oprptr,Noprtl,Prbfac,str,nchr) IF(Lfatal)RETURN IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1170)str(1:nchr) END IF CALL errhdr WRITE(Mt2,1170)str(1:nchr) IF(Issap.eq.2)THEN WRITE(Mt1,1150) ELSE IF(Irev.eq.4)THEN WRITE(Mt1,1160) END IF ltmper=Lprier Lprier=T CALL chkrt2(F,itmp,Lhiddn) IF(Lfatal)RETURN Lprier=ltmper IF(.not.Lauto)CALL abend() RETURN c----------------------------------------------------------------------- c Stpitr convergence errors c----------------------------------------------------------------------- ELSE IF(Armaer.eq.PCNTER)THEN CALL errhdr IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1180)2D0/Nefobs*dpmpar(1) END IF WRITE(Mt2,1180)2D0/Nefobs*dpmpar(1) IF(Issap.eq.2)THEN WRITE(Mt1,1150) ELSE IF(Irev.eq.4)THEN WRITE(Mt1,1160) END IF IF(.not.Lauto)CALL abend() RETURN c ------------------------------------------------------------------ ELSE IF(Armaer.eq.PDVTER)THEN CALL errhdr IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1190) END IF WRITE(Mt2,1190) IF(Issap.eq.2)THEN WRITE(Mt1,1200) ELSE IF(Irev.eq.4)THEN WRITE(Mt1,1210) END IF c----------------------------------------------------------------------- c Singular ARMA covariance matrix c----------------------------------------------------------------------- ELSE IF(Armaer.eq.PACSER)THEN CALL errhdr IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1220) END IF WRITE(Mt2,1220) IF(Issap.eq.2)THEN WRITE(Mt1,1200) ELSE IF(Irev.eq.4)THEN WRITE(Mt1,1210) END IF c ------------------------------------------------------------------ c Objective function equal to zero c ------------------------------------------------------------------ ELSE IF(Armaer.eq.POBFN0)THEN CALL errhdr IF(.not.Lauto)THEN WRITE(STDERR,1230)Cursrs(1:nfil) WRITE(Mt1,1240) END IF WRITE(Mt2,1240) IF(Issap.eq.2)THEN WRITE(Mt1,1200) ELSE IF(Irev.eq.4)THEN WRITE(Mt1,1210) END IF IF(.not.Lauto)CALL abend() END IF c ------------------------------------------------------------------ RETURN 1030 FORMAT(/,' ERROR: Nonlinear estimation error with unknown cause ', & 'during ',/,' sliding spans analysis.') 1040 FORMAT(/,' ERROR: Nonlinear estimation error with unknown cause ', & 'during ',/,' revisions analysis.') 1050 FORMAT(/,' ERROR: Nonlinear estimation error with unknown cause.', & /) 1060 FORMAT(/,' ERROR: Regression matrix singular because of ',a,'.', & /,' Remove variable(s) from regression spec and ', & 'try again.',/) 1070 FORMAT(/,' ERROR: Regression matrix singular because of ',a,'.', & /,' Check regression model or change automatic ', & 'outlier options', & /,' i.e. method to addone or types to identify AO ', & 'only.',/) 1080 FORMAT(/,' WARNING: Improper input parameters to the likelihood', & 'minimization routine.', & /,' Please send us the data and spec file that ', & 'produced this', & /,' message (x12@census.gov).') 1090 FORMAT(/,' WARNING: Estimation was terminated because no ', & 'further improvement in', & /,' the likelihood was possible. Check ', & 'iteration output to ', & /,' confirm that model estimation really ', & 'converged.') 1100 FORMAT(/) 1110 FORMAT(' Convergence tolerance on the likelihood is ', & 'too strict.',/) 1120 FORMAT(/,' WARNING: Convergence tolerance for the relative ', & 'difference in the', & /,' parameter estimates is too strict.') 1130 FORMAT(/,' Cosine of the angle between the vector of ', & 'expected values and ', & /,' any column of the jacobian is too small.',/) 1140 FORMAT(/,' ERROR: ',a,' has roots inside the unit circle but ',/, & 'some',/, & ' parameters are fixed so cannot invert the ', & 'operator.',/) 1150 FORMAT(' This error occurred during the sliding spans ', & 'analysis.',/) 1160 FORMAT(' This error occurred during the history ', & 'analysis.',/) 1170 FORMAT(/,' ERROR: ',a,' has roots inside the unit circle but ', & 'some are missing', & /,' so cannot invert the operator. Try ', & 'including all lags.',/) 1180 FORMAT(/,' ERROR: Convergence tolerance must be set larger than ', & 'machine', & /,'precision',e25.14,'.',/) 1190 FORMAT(/,' WARNING: Deviance was less than machine precision ', & 'so could not', & /,' calculate the relative deviance.',/) 1200 FORMAT(' This warning occurred during the sliding spans', & 'analysis.',/) 1210 FORMAT(' This warning occurred during the history ', & 'analysis.',/) 1220 FORMAT(/,' WARNING: The covariance matrix of the ARMA ', & 'parameters is singular,', & /,' so the standard errors and the correlation ', & 'matrix of the ARMA', & /,' parameters will not be printed out.',/) 1230 FORMAT(/,' Error(s) found while estimating the regARIMA model.',/, & ' For more details, check the error file (',a,'.err).',/) 1240 FORMAT(/,' ERROR: Differencing has annihilated the series.',/, & ' Check the model specified in the arima spec,', & ' set or change',/, & ' the possible differencing orders (if using the ', & 'automdl spec), or',/, & ' change the models specified in the automatic ', & 'model file',/, & ' (if using the pickmdl spec).') END prterx.f0000664006604000003110000000436314521201546011672 0ustar sun00315steps SUBROUTINE prterx() IMPLICIT NONE c ------------------------------------------------------------------- c If irregular regression matrix is singular, print out error c message. c ------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c ------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'xrgtbl.i' c ------------------------------------------------------------------- CHARACTER str*(PMDLCR) INTEGER nchr,nfil c ------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- IF(Sngcol.lt.Ncxy)THEN CALL getstr(Colttl,Colptr,Ncoltl,Sngcol,str,nchr) IF(Lfatal)RETURN ELSE nchr=4 str(1:nchr)='data' END IF CALL errhdr nfil=nblank(Cursrs) WRITE(STDERR,1230)Cursrs(1:nfil) 1230 FORMAT(' Error(s) found while estimating the irregular ', & 'regression model.',/, & ' For more details, check the error file (',a,'.err).') WRITE(Mt1,1270)str(1:nchr) WRITE(Mt2,1270)str(1:nchr) 1270 FORMAT(/,' ERROR: Irregular regression matrix singular ', & 'because of ',a,'.', & /,' Check irregular regression model.',/) c----------------------------------------------------------------------- c Added printing of regression matrix c----------------------------------------------------------------------- IF(Prttab(LXRXMX))THEN CALL prtshd('Irregular Component Regression Matrix',Begxy,Sp, & Nrxy,F) IF(.not.Lfatal)CALL prtmtx(Begxy,Sp,Xy,Nrxy,Ncxy,Colttl,Colptr, & Ncoltl) IF(Lfatal)RETURN END IF CALL abend() c----------------------------------------------------------------------- RETURN END prtf2.f0000664006604000003110000001417414521201546011404 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:48 pm SUBROUTINE prtf2(Nw,Mqf2,Khcfm) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE GENERATES THE F2 TABLE for standard printouts. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'title.cmn' INCLUDE 'inpt2.cmn' INCLUDE 'work2.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'tests.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- CHARACTER Mqf2*(7),aorb*(1) INTEGER i,Khcfm,n,n1,Nw DIMENSION aorb(2) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- DATA aorb/'B','A'/ c----------------------------------------------------------------------- WRITE(Nw,1010)Pcdif(1:nblank(Pcdif)),aorb(Khcfm),Mqf2,Mqcd 1010 FORMAT(3X,'F 2.A: Average ',a,' without regard to sign over the', & /,10x,'indicated span',/,6X,'Span',/,7X,'in',6X,A1,'1',5X, & 'D11',5X,'D13',5X,'D12',5X,'D10',6X,'A2',5X,'D18',6X,'F1', & /,3X,A7,'s',4X,'O',6X,'CI',7X,'I',7X,'C',7X,'S',7X,'P',5X, & 'TD&H',5X,A3) DO i=1,Ny WRITE(Nw,1020)i,Obar(i),Cibar(i),Ibar(i),Cbar(i),Sbar(i),Pbar(i), & Tdbar(i),Smbar(i) 1020 FORMAT(7X,I2,8F8.2) END DO WRITE(Nw,1030)Mqf2 1030 FORMAT(/,6X,'Span',/,7X,'in',5X,'E1',6X,'E2',6X,'E3',/,3X,A7,'s', & 2X,'Mod.O Mod.CI Mod.I') DO i=1,Ny WRITE(Nw,1040)i,Ombar(i),Cimbar(i),Imbar(i) 1040 FORMAT(7X,I2,3F8.2) END DO c----------------------------------------------------------------------- WRITE(Nw,1050)Pcdif(1:nblank(Pcdif)),Mqf2 1050 FORMAT(/,3X,'F 2.B: Relative contributions to the variance of the' & ,a15,/,10x,'in the components of the original series',/,6x, & 'Span',/,7X,'in',5X,'E3',5X,'D12',5X,'D10',6X,'A2',5X, & 'D18',12X,'RATIO',/,3X,A7,'s',3X,'I',7X,'C',7X,'S',7X,'P', & 5X,'TD&H',4X,'TOTAL (X100)') DO i=1,Ny WRITE(Nw,1060)i,Isq(i),Csq(i),Ssq(i),Psq(i),Tdsq(i),Osq2(i) 1060 FORMAT(7X,I2,5(2PF8.2),' 100.00',2PF8.2) END DO c----------------------------------------------------------------------- WRITE(Nw,1070)Pcdif(1:nblank(Pcdif)),aorb(Khcfm),Mqf2 1070 FORMAT(/,3X, & 'F 2.C: Average ',A,' with regard to sign and standard',/, & 10x,'deviation over indicated span',/,6X,'Span',8X,A1,'1', & 15X,'D13',14X,'D12',/,7X,'in',10X,'O',16X,'I',16X,'C',/, & 3X,A7,'s',3(3X,'Avg.',4X,'S.D.',2X)) DO i=1,Ny WRITE(Nw,1080)i,Obar2(i),Osd(i),Ibar2(i),Isd(i),Cbar2(i),Csd(i) 1080 FORMAT(7X,I2,3(F9.2,F8.2)) END DO WRITE(Nw,1090)Mqcd,Mqf2 1090 FORMAT(/,6X,'Span',8X,'D10',14X,'D11',15X,'F1',/,7X,'in',10X,'S', & 16X,'CI',14X,A3,/,3X,A7,'s',3(3X,'Avg.',4X,'S.D.',2X)) DO i=1,Ny WRITE(Nw,1080)i,Sbar2(i),Ssd(i),Cibar2(i),Cisd(i),Smbar2(i), & Smsd(i) END DO c----------------------------------------------------------------------- WRITE(Nw,1100)Mqcd,Adrci,Adri,Adrc,Adrmcd 1100 FORMAT(/,3X,'F 2.D: Average duration of run',8X,'CI',6X,'I',7X, & 'C',6X,A3,/,36X,4F8.2) c----------------------------------------------------------------------- IF(Ny.eq.12)Kpage=Kpage+1 c----------------------------------------------------------------------- WRITE(Nw,1110)Moqu(1:nblank(Moqu)) 1110 FORMAT(//,3X,'F 2.E: I/C Ratio for ',A,'s span') n=6 IF(Ny.eq.4)n=Ny WRITE(NW,1120)(i,i=1,n) 1120 FORMAT(/,6x,'SPAN ',7I8) WRITE(NW,1130)(Smic(i),i=1,n) 1130 FORMAT(6x,'I/C ',6F8.2) IF(n.lt.Ny)THEN WRITE(NW,1120)(i,i=n+1,Ny) WRITE(Nw,1130)(Smic(i),i=n+1,Ny) END IF c----------------------------------------------------------------------- WRITE(Nw,1140)Moqu(1:nblank(Moqu)),Mcd 1140 FORMAT(/,7X,A7,'s for cyclical dominance:',i8) c----------------------------------------------------------------------- WRITE(Nw,1150)Vi,Vc,Vs,Vp,Vtd,Rv 1150 FORMAT(//,3X,'F 2.F: Relative contribution of the components to ', & 'the stationary',/,10x,'portion of the variance in the ', & 'original series',//,19x,'I',7x,'C',7X,'S',7X,'P',5X, & 'TD&H',3X,'Total',/,14X,6F8.2,/) c----------------------------------------------------------------------- n=Ny+2 WRITE(Nw,1160)n 1160 FORMAT(/,3X,'F 2.G: The autocorrelation of the irregulars for ', & 'spans 1 to',I3) n1=n IF(Ny.eq.12)n1=7 WRITE(Nw,1120)(i,i=1,n1) WRITE(Nw,1170)(Autoc(i),i=1,n1) 1170 FORMAT(6x,'ACF ',7f8.2) IF(n1.lt.n)THEN WRITE(Nw,1120)(i,i=n1+1,n) WRITE(Nw,1170)(Autoc(i),i=n1+1,n) END IF c----------------------------------------------------------------------- WRITE(Nw,1180)Ratic 1180 FORMAT(/,3X,'F 2.H: The final I/C Ratio from Table D12:',F12.2) IF(Kfulsm.lt.2)WRITE(Nw,1181)Ratis 1181 FORMAT(9X,' The final I/S Ratio from Table D10:',F12.2) c----------------------------------------------------------------------- WRITE(Nw,1190)Fpres,P3 1190 FORMAT(/,3X,'F 2.I:',52X,'Statistic Prob.',/,73x,'level',/, & 4X,'F-test for stable seasonality from Table B 1.',8x,':', & F11.3,F8.2,'%') c IF(Kdwopt.ge.1.and.Kdwopt.lt.6)WRITE(Nw,1170)F(4),P(4) c 1170 FORMAT(4X,'F-test for the trading day regession in Table C15.', c & 2X,':',F11.3,F8.2,'%') WRITE(Nw,1200)Fstabl,P1,Chikw,P5,Fmove,P2 1200 FORMAT(4X,'F-test for stable seasonality from Table D 8.',8X,':', & F11.3,F8.2,'%',/,4X,'Kruskal-Wallis Chi Squared test',/, & 18x,'for stable seasonality from Table D 8. :',F11.3,F8.2, & '%',/,4X,'F-test for moving seasonality from Table D 8.', & 8X,':',F11.3,F8.2,'%',/) c----------------------------------------------------------------------- RETURN END prtf2w.f0000664006604000003110000001121014521201546011557 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:49 pm SUBROUTINE prtf2w(Nw,Mqf2,Khcfm) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE GENERATES THE F2 TABLE for wide printouts. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'title.cmn' INCLUDE 'inpt2.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'work2.cmn' INCLUDE 'tests.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- CHARACTER Mqf2*(7),aorb*(1) INTEGER i,Khcfm,n,Nw DIMENSION aorb(2) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- DATA aorb/'B','A'/ c----------------------------------------------------------------------- WRITE(Nw,1010)Pcdif(1:nblank(Pcdif)),aorb(Khcfm),Mqf2,Mqcd 1010 FORMAT(6X,'F 2.A: Average ',a, & ' without regard to sign over the indicated span',/,14X, & 'Span',/,15X,'in',6X,A1,'1',5X,'D11',5X,'D13',5X,'D12',5X, & 'D10',6X,'A2',5X,'D18',6X,'F1',13X,'E1',6X,'E2',6X,'E3',/, & 11X,A7,'s',4X,'O',6X,'CI',7X,'I',7X,'C',7X,'S',7X,'P',5X, & 'TD&H',5X,A3,11X,'Mod.O Mod.CI Mod.I') DO i=1,Ny WRITE(Nw,1020)i,Obar(i),Cibar(i),Ibar(i),Cbar(i),Sbar(i),Pbar(i), & Tdbar(i),Smbar(i),Ombar(i),Cimbar(i),Imbar(i) 1020 FORMAT(15X,I2,8F8.2,9X,3F8.2) END DO WRITE(Nw,1030)Pcdif(1:nblank(Pcdif)),Mqf2 1030 FORMAT(/,6X,'F 2.B: Relative contributions to the variance of the' & ,a15,' in the components of the original series',/,14x, & 'Span',/,15X,'in',5X,'E3',5X,'D12',5X,'D10',6X,'A2',5X, & 'D18',12X,'RATIO',/,11X,A7,'s',3X,'I',7X,'C',7X,'S',7X,'P', & 5X,'TD&H',4X,'TOTAL (X100)') DO i=1,Ny WRITE(Nw,1040)i,Isq(i),Csq(i),Ssq(i),Psq(i),Tdsq(i),Osq2(i) 1040 FORMAT(15X,I2,5(2PF8.2),' 100.00',2PF8.2) END DO WRITE(Nw,1050)Pcdif(1:nblank(Pcdif)),aorb(Khcfm),Mqcd,Mqf2 1050 FORMAT(/,6X,'F 2.C: Average ',A, & ' with regard to sign and standard deviation over indicated span' & ,/,14X,'Span',8X,A1,'1',15X,'D13',14X,'D12',14X,'D10',14X,'D11', & 15X,'F1',/,15X,'IN',10X,'O',16X,'I',16X,'C',16X,'S',16X,'CI',14X, & A3,/,11X,A7,'s',6(3X,'Avg.',4X,'S.D.',2X)) DO i=1,Ny WRITE(Nw,1060)i,Obar2(i),Osd(i),Ibar2(i),Isd(i),Cbar2(i),Csd(i), & Sbar2(i),Ssd(i),Cibar2(i),Cisd(i),Smbar2(i),Smsd(i) 1060 FORMAT(15X,I2,6(F9.2,F8.2)) END DO WRITE(Nw,1070)Mqcd,Adrci,Adri,Adrc,Adrmcd 1070 FORMAT(/,6X,'F 2.D: Average duration of run',8X,'CI',6X,'I',7X, & 'C',6X,A3,/,39X,4F8.2) IF(Ny.eq.12)Kpage=Kpage+1 WRITE(Nw,1080)Moqu(1:nblank(Moqu)),(i,i=1,Ny) 1080 FORMAT(//,6X,'F 2.E: I/C Ratio for ',A,'s Span',/,18X,12I8) WRITE(Nw,1090)(Smic(i),i=1,Ny) 1090 FORMAT(19X,14F8.2) WRITE(Nw,1100)Moqu(1:nblank(Moqu)),Mcd 1100 FORMAT(/,7X,A7,'s for cyclical dominance:',i8) WRITE(Nw,1110)Vi,Vc,Vs,Vp,Vtd,Rv 1110 FORMAT(//,6X, &'F 2.F: Relative contribution of the components to the stationary &portion of the variance in the original series',/,24x,'i',7x,'C', &7X,'S',7X,'P',5X,'TD&H',3X,'Total',/,19X,6F8.2,/) n=Ny+2 WRITE(Nw,1120)n,(i,i=1,n) 1120 FORMAT(/,6X, & 'F 2.G: The autocorrelation of the irregulars for spans 1 to' & ,I3,/,18X,14I8) WRITE(Nw,1090)(Autoc(i),i=1,n) WRITE(Nw,1130)Ratic 1130 FORMAT(/,6X,'F 2.H: The final I/C Ratio from Table D12:',F12.2) IF(Kfulsm.lt.2)WRITE(Nw,1131)Ratis 1131 FORMAT(12X,' The final I/S Ratio from Table D10:',F12.2) WRITE(Nw,1140)Fpres,P3 1140 FORMAT(/,6X,'F 2.I:',75X,'Statistic Probability',/,100x,'level',/, & 13X,'F-test for stable seasonality from Table B 1.',26X, & ':',F11.3,F8.2,'%') c IF(Kdwopt.ge.1.and.Kdwopt.lt.6)WRITE(Nw,1170)F(4),P(4) c 1170 FORMAT(13X,'F-test for the trading day regession in Table C15.', c & 21X,':',F11.3,F8.2,'%') WRITE(Nw,1150)Fstabl,P1,Chikw,P5,Fmove,P2 1150 FORMAT(13X,'F-test for stable seasonality from Table D 8.',26X, & ':',F11.3,F8.2,'%',/,13X, &'Kruskal-Wallis Chi Squared test for stable seasonality from Table & D 8. :',F11.3,F8.2,'%',/,13X, &'F-test for moving seasonality from Table D 8.',26X,':',F11.3, &F8.2,'%') c----------------------------------------------------------------------- RETURN END prtfct.f0000664006604000003110000007050314521201546011647 0ustar sun00315stepsC Last change: BCM 25 Nov 1998 12:42 pm **==prtfct.f processed by SPAG 4.03F at 10:36 on 16 Nov 1994 SUBROUTINE prtfct(Nobspf,Nrxy,Fcntyp,Lam,Lognrm,Fctdrp,Nfcst, & Ciprob,Fcstx,Untfct,Outdec,Pos2,Lgraf,Svdiag, & Lseats,Khol,Kswv) IMPLICIT NONE c----------------------------------------------------------------------- c Calculate and print the forecast c----------------------------------------------------------------------- LOGICAL T,F DOUBLE PRECISION ZERO,ONE INTEGER ADD,BTWNCL,DIV,INCOL,MNSGFG,MULT,SUB PARAMETER(ADD=1,BTWNCL=3,DIV=4,INCOL=2,MNSGFG=3,ZERO=0D0,ONE=1D0, & MULT=3,SUB=2,T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'cchars.i' INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'units.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'adj.cmn' INCLUDE 'revsrs.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' INCLUDE 'savcmn.cmn' C LINES OF CODE ADDED FOR X-13A-S : 2 LOGICAL Lseats INCLUDE 'seatad.cmn' C END OF CODE BLOCK c ------------------------------------------------------------------ CHARACTER blnk*80,fmt*80,str*10,ttlfct*80,ttlfc2*100,outstr*75, & dash*22 LOGICAL locok,lpria,ltrns,lprix,Lgraf,Svdiag,Lognrm INTEGER bgfcst,clwdth,endspn,Fcntyp,Fctdrp,fctori,fh,fh2,i,idate, & mindec,mxdtcr,ndec,ndtchr,Nfcst,nobsf,Nobspf,Nrxy,npos, & nttlcr,ntl2cr,Outdec,rdbdat,tmp1,tmp2,k,Pos2,Kswv,Khol,ff DOUBLE PRECISION Ciprob,fcst,fcstse,fcterr,Lam,lwrci,nstder, & pctrgv,pval,rgvar,stctvr,totvar,trnsrs,tval, & untfct,uprci,Fcstx,tempse,regvar,dlr DIMENSION bgfcst(2),endspn(2),idate(2),fcst(PFCST),fcstse(PFCST), & fcterr(PFCST),tval(PFCST),lwrci(PFCST),rgvar(PFCST), & trnsrs(PFCST),untfct(PFCST),uprci(PFCST),Fcstx(PFCST), & tempse(PFCST) c----------------------------------------------------------------------- LOGICAL chkcvr,dpeq,istrue DOUBLE PRECISION dinvnr EXTERNAL chkcvr,dinvnr,istrue,dpeq c----------------------------------------------------------------------- c----------------------------------------------------------------------- DATA dash /'----------------------'/ DATA blnk/ &' & '/ c----------------------------------------------------------------------- c Forecast options c----------------------------------------------------------------------- ff=ADD IF(Adjmod.lt.2)ff=MULT locok=T CALL addate(Begspn,Sp,Nspobs-1,endspn) ltrns=(.not.dpeq(Lam,ONE)).or.Fcntyp.ne.4 CALL addate(endspn,Sp,-Fctdrp+1,bgfcst) lpria=(Nustad.gt.0.and.chkcvr(Bgutad,Nustad,bgfcst,Nfcst,Sp)).or. & (Nuspad.gt.0.and.chkcvr(Bgupad,Nuspad,bgfcst,Nfcst,Sp)).or. & (Priadj.gt.0.and.chkcvr(Begadj,Nadj,bgfcst,Nfcst,Sp)) lprix=(Axrghl.or.Axrgtd.and.Ixreg.eq.3).or.Khol.eq.2.or.Kswv.eq.1 c ------------------------------------------------------------------ CALL addate(endspn,Sp,-Fctdrp,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN IF(.not.Lhiddn.and.istrue(Prttab,LFORTS,LFOROS))WRITE(Mt1,1010) & str(1:ndtchr),Nfcst 1010 FORMAT(//,' FORECASTING',/,' Origin',a10,/,' Number',i10) c----------------------------------------------------------------------- c Calculate the forecasts c----------------------------------------------------------------------- fctori=Nspobs-Fctdrp CALL fcstxy(fctori,Nfcst,fcst,fcstse,rgvar) IF(Lfatal)RETURN c----------------------------------------------------------------------- c apply lognormal correction to forecasts to be appended to series c prior to seasonal adjustment (BCM May 2008) c----------------------------------------------------------------------- IF(Lognrm.and.dpeq(Lam,ZERO))THEN CALL lgnrmc(Nfcst,fcst,fcstse,Fcstx,F) ELSE c----------------------------------------------------------------------- c Create forecasts to be appended to series prior to seasonal c adjustment (BCM May 2000) c----------------------------------------------------------------------- CALL copy(fcst,Nfcst,1,Fcstx) END IF c----------------------------------------------------------------------- c Format the transformed forecasts and their standard errors c----------------------------------------------------------------------- CALL numfmt(fcst,Nfcst,Outdec,clwdth,mindec) IF(Lmvaft.or.Ln0aft)THEN nobsf=0 ELSE nobsf=min(Nfcst,Nobspf-fctori) END IF IF(nobsf.gt.0)THEN CALL subset(Xy,Nrxy,Ncxy,fctori+1,fctori+nobsf,Ncxy,Ncxy,trnsrs) CALL numfmt(trnsrs,nobsf,Outdec,tmp1,tmp2) clwdth=max(tmp1,clwdth) mindec=max(tmp2,mindec)+MNSGFG-1 ELSE mindec=mindec+MNSGFG-1 END IF c----------------------------------------------------------------------- IF(mindec.gt.Outdec)THEN ndec=min(mindec,11) clwdth=clwdth-Outdec+ndec ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 clwdth=min(max(clwdth,8),21) c ------------------------------------------------------------------ CALL addate(endspn,Sp,Nfcst-Fctdrp,idate) CALL wrtdat(idate,Sp,str,mxdtcr) IF(Lfatal)RETURN mxdtcr=max(4,mxdtcr) IF(Prttab(LFORTS).or.Savtab(LFORTS).OR.(Lgraf.and.ltrns).or. & Svdiag)THEN IF(Prttab(LFORTS))THEN IF((lpria.or.lprix).and.ltrns)THEN WRITE(Mt1,1020) &'Forecasts and Standard Errors of the Prior Adjusted and Transform &ed Data' 1020 FORMAT(/,' ',a) ELSE IF(ltrns)THEN WRITE(Mt1,1020) & 'Forecasts and Standard Errors of the Transformed Data' ELSE IF(lpria)THEN WRITE(Mt1,1020) & 'Forecasts and Standard Errors of the Prior Adjusted Data' ELSE WRITE(Mt1,1020)'Forecasts and Standard Errors' END IF END IF c ------------------------------------------------------------------ IF(Savtab(LFORTS).OR.(Lgraf.and.ltrns))THEN IF(Savtab(LFORTS))CALL opnfil(T,F,LFORTS,fh,locok) IF(Lgraf.and.ltrns.and.locok) & CALL opnfil(T,Lgraf,LFORTS,fh2,locok) IF(.not.locok)THEN CALL abend() RETURN END IF IF(Savtab(LFORTS))THEN WRITE(fh,1030)'date',TABCHR,'forecast',TABCHR,'standarderror' WRITE(fh,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize) END IF IF(Lgraf.and.ltrns)THEN WRITE(fh2,1030)'date',TABCHR,'forecast',TABCHR, & 'standarderror' WRITE(fh2,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize) END IF 1030 FORMAT(a:,a,a,a,a:,a,a) END IF c----------------------------------------------------------------------- c Print or save the transformed forecasts and their standard errors c if there are no forecast errors. c----------------------------------------------------------------------- IF(Svdiag)write(Nform,1160)nobsf 1160 FORMAT('nforctval: ',i3) IF(nobsf.eq.0)THEN c ------------------------------------------------------------------ IF(Prttab(LFORTS))THEN WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+INCOL+2*clwdth+1) 1040 FORMAT(' ',77(a)) WRITE(Mt1,1050)blnk(1:mxdtcr+BTWNCL+INCOL+2*clwdth-6), & blnk(1:mxdtcr-3),blnk(1:BTWNCL+clwdth-8), & blnk(1:INCOL+clwdth+1-5) 1050 FORMAT(' ',a,'Standard',/,' ',a,'Date',a,'Forecast',a, & 'Error') WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+INCOL+2*clwdth+1) c ------------------------------------------------------------------ WRITE(fmt,1060)mxdtcr+3,BTWNCL+clwdth,ndec,INCOL+clwdth+1, & ndec+1 1060 FORMAT('(a',i2.2,',f',i2.2,'.',i2.2,',f',i2.2,'.',i2.2,')') END IF c ------------------------------------------------------------------ DO i=1,Nfcst CALL addate(endspn,Sp,i-Fctdrp,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Prttab(LFORTS))WRITE(Mt1,fmt)str(1:ndtchr),fcst(i),fcstse(i) c ------------------------------------------------------------------ IF(Savtab(LFORTS).OR.(Lgraf.and.ltrns))THEN npos=1 rdbdat=100*idate(YR)+idate(MO) c ------------------------------------------------------------------ CALL itoc(rdbdat,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(fcst(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(fcstse(i),outstr,npos) IF(Lfatal)RETURN IF(Savtab(LFORTS))WRITE(fh,1030)outstr(1:npos-1) IF(Lgraf.and.ltrns)WRITE(fh2,1030)outstr(1:npos-1) END IF END DO c ------------------------------------------------------------------ IF(Prttab(LFORTS)) & WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+INCOL+2*clwdth+1) c----------------------------------------------------------------------- c Print the forecast errors and t-values for forecasts that occur c within the span of the data c----------------------------------------------------------------------- ELSE CALL subset(Xy,Nrxy,Ncxy,fctori+1,fctori+nobsf,Ncxy,Ncxy,trnsrs) CALL eltfcn(SUB,trnsrs,fcst,nobsf,PFCST,fcterr) CALL eltfcn(DIV,fcterr,fcstse,nobsf,PFCST,tval) c ------------------------------------------------------------------ IF(Prttab(LFORTS))THEN c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+4*INCOL+4*clwdth+8) c ------------------------------------------------------------------ WRITE(Mt1,1070)blnk(1:mxdtcr+BTWNCL+2*INCOL+3*clwdth-7), & blnk(1:INCOL+clwdth+1-8),blnk(1:mxdtcr-3), & blnk(1:BTWNCL+clwdth-4),blnk(1:INCOL+clwdth-8), & blnk(1:INCOL+clwdth-6),blnk(1:INCOL+clwdth+1-5), & blnk(1:INCOL) 1070 FORMAT(' ',a,'Forecast',a,'Standard',/,' ',a,'Date',a,'Data', & a,'Forecast',a,'Error',a,'Error',a,'t-value') c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+4*INCOL+4*clwdth+8) c ------------------------------------------------------------------ WRITE(fmt,1080)mxdtcr+3,BTWNCL+clwdth,ndec,INCOL+clwdth,ndec, & INCOL+clwdth+1,ndec+1,INCOL+7,2 1080 FORMAT('(a',i2.2,',f',i2.2,'.',i2.2,',2f',i2.2,'.',i2.2,',f', & i2.2,'.',i2.2,',f',i2.2,'.',i2.2,')') END IF c ------------------------------------------------------------------ DO i=1,nobsf CALL addate(endspn,Sp,i-Fctdrp,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Prttab(LFORTS))WRITE(Mt1,fmt)str(1:ndtchr),trnsrs(i),fcst(i) & ,fcterr(i),fcstse(i),tval(i) IF(Svdiag)WRITE(Nform,1170) i,str(1:ndtchr),tval(i) 1170 FORMAT('forctval',i2.2,': ',a,2x,f12.6) c ------------------------------------------------------------------ IF(Savtab(LFORTS).OR.(Lgraf.and.ltrns))THEN npos=1 rdbdat=100*idate(YR)+idate(MO) CALL itoc(rdbdat,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(fcst(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(fcstse(i),outstr,npos) IF(Lfatal)RETURN IF(Savtab(LFORTS))WRITE(fh,1030)outstr(1:npos-1) IF(Lgraf.and.ltrns)WRITE(fh2,1030)outstr(1:npos-1) END IF c ------------------------------------------------------------------ END DO c ------------------------------------------------------------------ IF(Nfcst.gt.nobsf)THEN IF(Prttab(LFORTS))WRITE(fmt,1060)mxdtcr+3, & BTWNCL+INCOL+2*clwdth,ndec, & 2*INCOL+2*clwdth+1,ndec+1 c ------------------------------------------------------------------ DO i=nobsf+1,Nfcst CALL addate(endspn,Sp,i-Fctdrp,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN IF(Prttab(LFORTS))WRITE(Mt1,fmt)str(1:ndtchr),fcst(i), & fcstse(i) c ------------------------------------------------------------------ IF(Savtab(LFORTS).OR.(Lgraf.and.ltrns))THEN npos=1 rdbdat=100*idate(YR)+idate(MO) CALL itoc(rdbdat,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(fcst(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(fcstse(i),outstr,npos) IF(Lfatal)RETURN IF(Savtab(LFORTS))WRITE(fh,1030)outstr(1:npos-1) IF(Lgraf.and.ltrns)WRITE(fh2,1030)outstr(1:npos-1) END IF c ------------------------------------------------------------------ END DO END IF c ------------------------------------------------------------------ IF(Prttab(LFORTS)) & WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+4*INCOL+4*clwdth+8) END IF IF(Savtab(LFORTS).and.locok)CALL fclose(fh) IF(Lgraf.and.ltrns.and.locok)CALL fclose(fh2) END IF c----------------------------------------------------------------------- c Print out or save the contribution of the regression variance to c the forecast variance. c----------------------------------------------------------------------- IF((Prttab(LFORVR).or.Savtab(LFORVR)).and.Ncxy.gt.1)THEN clwdth=max(clwdth,12) c ------------------------------------------------------------------ IF(Prttab(LFORVR))THEN WRITE(Mt1,1020)'Stochastic and regression contributions '// & 'to the forecast error variances' c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+3*INCOL+4*clwdth) c ------------------------------------------------------------------ WRITE(Mt1,1090)blnk(1:mxdtcr+BTWNCL+clwdth-9), & blnk(1:INCOL+clwdth-10),blnk(1:INCOL+clwdth-5), & blnk(1:INCOL+clwdth-10),blnk(1:mxdtcr-3), & blnk(1:BTWNCL+clwdth-8),blnk(1:INCOL+clwdth-8), & blnk(1:INCOL+clwdth-8),blnk(1:INCOL+clwdth-10) 1090 FORMAT(' ',a,'Regression',a,'Stochastic',a,'Total',a, & 'Regression',/,' ',a,'Date',a,'Variance',a,'Variance',a, & 'Variance',a,'Percentage') c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+3*INCOL+4*clwdth) c ------------------------------------------------------------------ WRITE(fmt,1100)mxdtcr+3,BTWNCL+clwdth,ndec,INCOL+clwdth,ndec, & INCOL+clwdth,2 1100 FORMAT('(a',i2.2,',e',i2.2,'.',i2.2,',2e',i2.2,'.',i2.2,',f', & i2.2,'.',i2.2,')') END IF c ------------------------------------------------------------------ IF(Savtab(LFORVR))THEN CALL opnfil(T,F,LFORVR,fh,locok) IF(.not.locok)THEN CALL abend IF(Lfatal)RETURN END IF WRITE(fh,1030)'date',TABCHR,'regressionvariance',TABCHR, & 'stochasticvariance' WRITE(fh,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize) END IF c ------------------------------------------------------------------ DO i=1,Nfcst CALL addate(endspn,Sp,i-Fctdrp,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN dlr=log10(rgvar(i)) if(dlr.gt.-100d0)then regvar=rgvar(i) else regvar=0d0 end if totvar=fcstse(i)**2 stctvr=totvar-regvar pctrgv=100D0*regvar/totvar IF(Prttab(LFORVR))WRITE(Mt1,fmt)str(1:ndtchr),regvar,stctvr, & totvar,pctrgv c ------------------------------------------------------------------ IF(Savtab(LFORVR))THEN npos=1 rdbdat=100*idate(YR)+idate(MO) c ------------------------------------------------------------------ CALL itoc(rdbdat,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(regvar,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(stctvr,outstr,npos) IF(Lfatal)RETURN WRITE(fh,1030)outstr(1:npos-1) END IF c ------------------------------------------------------------------ END DO c ------------------------------------------------------------------ IF(Prttab(LFORVR)) & WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL+3*INCOL+4*clwdth) c ------------------------------------------------------------------ IF(locok.and.Savtab(LFORVR))CALL fclose(fh) END IF c----------------------------------------------------------------------- c Print or save a table of upper and lower confidence intervals c with F^{-1}(Ciprob/2+.5)*standard error on the original scale with the c prior adjustments removed. The Ciprob/2+.5 is because it is a two- c tailed probability. c----------------------------------------------------------------------- IF(Lognrm.and.dpeq(Lam,ZERO))THEN CALL lgnrmc(Nfcst,fcst,fcstse,untfct,T) ELSE CALL invfcn(fcst,Nfcst,Fcntyp,Lam,untfct) END IF IF(Nustad.gt.0.or.Nuspad.gt.0.or.Priadj.gt.1)THEN IF(lpria)THEN CALL eltfcn(ff,untfct,Adj(Adj1st+fctori),Nfcst,PFCST,untfct) IF(Khol.eq.2) & CALL eltfcn(ff,untfct,X11hol(Pos2+1),Nfcst,PFCST,untfct) IF(Axrghl.and.Ixreg.eq.3) & CALL eltfcn(ff,untfct,Facxhl(Pos2+1),Nfcst,PFCST,untfct) IF(Kswv.eq.1.or.(Axrgtd.and.Ixreg.eq.3)) & CALL eltfcn(ff,untfct,Stptd(Pos2+1),Nfcst,PFCST,untfct) END IF END IF c ------------------------------------------------------------------ IF(Prttab(LFOROS).or.Savtab(LFOROS).or.Lgraf)THEN pval=(Ciprob+ONE)/2D0 nstder=dinvnr(pval,ONE-pval) CALL scrmlt(nstder,Nfcst,fcstse) CALL eltfcn(SUB,fcst,fcstse,Nfcst,PFCST,lwrci) CALL eltfcn(ADD,fcst,fcstse,Nfcst,PFCST,uprci) ttlfct='Confidence intervals with coverage probability (' nttlcr=48 ntl2cr=0 IF(Prttab(LFOROS))WRITE(ttlfct(nttlcr+1:),1110)Ciprob 1110 FORMAT(f8.5,')') IF(Savtab(LFOROS))CALL opnfil(T,F,LFOROS,fh,locok) IF(Lgraf.and.locok)CALL opnfil(T,Lgraf,LFOROS,fh2,locok) IF(.not.locok)THEN CALL abend() RETURN END IF nttlcr=nttlcr+8 c ------------------------------------------------------------------ IF(ltrns)THEN ttlfc2='On the Original Scale' ntl2cr=21 CALL invfcn(lwrci,Nfcst,Fcntyp,Lam,lwrci) CALL invfcn(uprci,Nfcst,Fcntyp,Lam,uprci) END IF c ------------------------------------------------------------------ IF(Nustad.gt.0.or.Nuspad.gt.0.or.Priadj.gt.1)THEN IF(lpria)THEN IF(ltrns)THEN ttlfc2=ttlfc2(1:ntl2cr)//' Before Prior Adjustments' ntl2cr=ntl2cr+25 ELSE ttlfc2='Before Prior Adjustments' ntl2cr=24 END IF c ------------------------------------------------------------------ CALL eltfcn(ff,lwrci,Adj(Adj1st+fctori),Nfcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Adj(Adj1st+fctori),Nfcst,PFCST,uprci) c ------------------------------------------------------------------ IF(Khol.eq.2)THEN CALL eltfcn(ff,lwrci,X11hol(Pos2+1),Nfcst,PFCST,lwrci) CALL eltfcn(ff,uprci,X11hol(Pos2+1),Nfcst,PFCST,uprci) END IF IF(Axrghl.and.Ixreg.eq.3)THEN CALL eltfcn(ff,lwrci,Facxhl(Pos2+1),Nfcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Facxhl(Pos2+1),Nfcst,PFCST,uprci) END IF IF(Kswv.eq.1.or.(Axrgtd.and.Ixreg.eq.3))THEN CALL eltfcn(ff,lwrci,Stptd(Pos2+1),Nfcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Stptd(Pos2+1),Nfcst,PFCST,uprci) END IF c ------------------------------------------------------------------ ELSE IF(ltrns)THEN ttlfc2=ttlfc2(1:ntl2cr)//' After Prior Adjustments' ntl2cr=ntl2cr+25 ELSE ttlfc2='After Prior Adjustments' ntl2cr=23 END IF c ------------------------------------------------------------------ IF(Prttab(LFOROS).or.Savtab(LFOROS).or.Lgraf)THEN IF(.not.Lquiet)WRITE(STDERR,1120) CALL errhdr WRITE(Mt2,1120) END IF 1120 FORMAT(/, & ' WARNING: User-defined prior adjustment factor not provided' & ,/,' for the forecast period.',/) END IF ELSE IF(lprix)THEN IF(ltrns)THEN ttlfc2=ttlfc2(1:ntl2cr)//' Before Prior Adjustments' ntl2cr=ntl2cr+25 ELSE ttlfc2='Before Prior Adjustments' ntl2cr=24 END IF c ------------------------------------------------------------------ IF(Axrghl.and.Ixreg.eq.3)THEN CALL eltfcn(ff,untfct,Facxhl(Pos2+1),Nfcst,PFCST,untfct) CALL eltfcn(ff,lwrci,Facxhl(Pos2+1),Nfcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Facxhl(Pos2+1),Nfcst,PFCST,uprci) END IF IF(Khol.eq.2)THEN CALL eltfcn(ff,untfct,X11hol(Pos2+1),Nfcst,PFCST,untfct) CALL eltfcn(ff,lwrci,X11hol(Pos2+1),Nfcst,PFCST,lwrci) CALL eltfcn(ff,uprci,X11hol(Pos2+1),Nfcst,PFCST,uprci) END IF IF(Kswv.eq.1.or.(Axrgtd.and.Ixreg.eq.3))THEN CALL eltfcn(ff,untfct,Stptd(Pos2+1),Nfcst,PFCST,untfct) CALL eltfcn(ff,lwrci,Stptd(Pos2+1),Nfcst,PFCST,lwrci) CALL eltfcn(ff,uprci,Stptd(Pos2+1),Nfcst,PFCST,uprci) END IF END IF c ------------------------------------------------------------------ CALL numfmt(lwrci,Nfcst,Outdec,tmp1,tmp2) CALL numfmt(uprci,Nfcst,Outdec,clwdth,mindec) clwdth=max(tmp1,clwdth) mindec=max(tmp2,mindec)+MNSGFG-1 IF(mindec.gt.Outdec)THEN ndec=min(mindec,11) clwdth=clwdth-Outdec+ndec ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 clwdth=min(max(clwdth,8),21) c ------------------------------------------------------------------ IF(Prttab(LFOROS))THEN WRITE(Mt1,1020)ttlfct(1:nttlcr) IF(ntl2cr.gt.0)THEN WRITE(Mt1,1130)ttlfc2(1:ntl2cr) 1130 FORMAT(' ',a) END IF IF(Lognrm.and.dpeq(Lam,ZERO)) & WRITE(Mt1,1130)'with LogNormal correction' c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL-INCOL+3*(INCOL+clwdth)) c ------------------------------------------------------------------ WRITE(Mt1,1140)blnk(1:mxdtcr-3),blnk(1:BTWNCL+clwdth-5), & blnk(1:INCOL+clwdth-8),blnk(1:INCOL+clwdth-5) 1140 FORMAT(' ',a,'Date',a,'Lower',a,'Forecast',a,'Upper') c ------------------------------------------------------------------ WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL-INCOL+3*(INCOL+clwdth)) c ------------------------------------------------------------------ WRITE(fmt,1150)mxdtcr+3,BTWNCL+clwdth,ndec,INCOL+clwdth,ndec 1150 FORMAT('(a',i2.2,',f',i2.2,'.',i2.2,',2f',i2.2,'.',i2.2,')') END IF c ------------------------------------------------------------------ IF(Savtab(LFOROS))THEN WRITE(fh,1030)'date',TABCHR,'forecast',TABCHR,'lowerci',TABCHR, & 'upperci' WRITE(fh,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize),TABCHR,dash(1:Svsize) END IF IF(Lgraf)THEN WRITE(fh2,1030)'date',TABCHR,'forecast',TABCHR,'lowerci',TABCHR, & 'upperci' WRITE(fh2,1030)'------',TABCHR,dash(1:Svsize),TABCHR, & dash(1:Svsize),TABCHR,dash(1:Svsize) END IF c ------------------------------------------------------------------ DO i=1,Nfcst CALL addate(endspn,Sp,i-Fctdrp,idate) CALL wrtdat(idate,Sp,str,ndtchr) IF(Lfatal)RETURN IF(Prttab(LFOROS))WRITE(Mt1,fmt)str(1:ndtchr),lwrci(i),untfct(i) & ,uprci(i) IF(Savtab(LFOROS).or.Lgraf)THEN npos=1 rdbdat=100*idate(YR)+idate(MO) c ------------------------------------------------------------------ CALL itoc(rdbdat,outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(untfct(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(lwrci(i),outstr,npos) IF(Lfatal)RETURN outstr(npos:npos)=TABCHR npos=npos+1 CALL dtoc(uprci(i),outstr,npos) IF(Lfatal)RETURN IF(Savtab(LFOROS))WRITE(fh,1030)outstr(1:npos-1) IF(Lgraf)WRITE(fh2,1030)outstr(1:npos-1) END IF c ------------------------------------------------------------------ END DO c ------------------------------------------------------------------ IF(Prttab(LFOROS)) & WRITE(Mt1,1040)('-',i=1,mxdtcr+BTWNCL-INCOL+3*(INCOL+clwdth)) c ------------------------------------------------------------------ IF(Savtab(LFOROS).and.locok)CALL fclose(fh) IF(Lgraf.and.locok)CALL fclose(fh2) END IF C LINES OF CODE ADDED FOR X-13A-S : 2 IF(Lseats)CALL copy(fcstse,Nfcst,1,Fctses) C END OF CODE BLOCK c ------------------------------------------------------------------ c If forecast error revisions collected, store forecast. c----------------------------------------------------------------------- IF(Irev.eq.4.and.Lrvfct.and.Revptr.gt.0)THEN IF(.NOT.(Prttab(LFOROS).or.Savtab(LFOROS).or.Lgraf))THEN IF(Lognrm.and.dpeq(Lam,ZERO))THEN CALL lgnrmc(Nfcst,fcst,fcstse,untfct,T) ELSE CALL invfcn(fcst,Nfcst,Fcntyp,Lam,untfct) END IF CALL eltfcn(ff,untfct,Adj(Adj1st+fctori),Nfcst,PFCST,untfct) IF(Axrghl.and.Ixreg.eq.3) & CALL eltfcn(ff,untfct,Facxhl(Pos2+1),Nfcst,PFCST,untfct) IF(Khol.eq.2) & CALL eltfcn(ff,untfct,X11hol(Pos2+1),Nfcst,PFCST,untfct) IF(Kswv.eq.1.or.(Axrgtd.and.Ixreg.eq.3)) & CALL eltfcn(ff,untfct,Stptd(Pos2+1),Nfcst,PFCST,untfct) END IF DO k=1,Nfctlg i=Revptr+Rfctlg(k) IF(i.le.(Endrev-Begrev+1))THEN Cncfct(k,i)=untfct(Rfctlg(k)) c ELSE IF(Begrev.le.Endrev-Rfctlg(k))THEN c DO i=Begrev,Endrev-Rfctlg(k) c rptr=i-Begrev+1 c Fctdrp=Endrev-i c fctori=Nspobs-Fctdrp c CALL fcstxy(fctori,Nfcst,fcst,fcstse,rgvar) c IF(Lfatal)RETURN c CALL invfcn(fcst,Nfcst,Fcntyp,Lam,untfct) c Finfct(k,rptr+Rfctlg(k))=untfct(Rfctlg(k)) c END DO c Fctdrp=0 END IF END DO END IF RETURN END prtft.f0000664006604000003110000000561114521201546011502 0ustar sun00315steps SUBROUTINE prtft(Lprsft,Lprhdr,Tbwdth,Lsvsft,Lsvlog,Baselt, & Grpstr,Nchr,Tsttyp,Info,Df1,Df2,Sftvl,Pv) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'title.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' c----------------------------------------------------------------------- CHARACTER Grpstr*(PGRPCR),Tsttyp*(*) LOGICAL Lprsft,Lprhdr,Lsvsft,Lsvlog INTEGER Tbwdth,Baselt,Nchr,Info,Df1,Df2,i DOUBLE PRECISION Sftvl,Pv c----------------------------------------------------------------------- IF(Lprhdr.and.(.not.Lnoprt))THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1010)Tsttyp,' ' WRITE(Mt1,1020)('-',i=1,tbwdth) WRITE(Mt1,1030) WRITE(Mt1,1020)('-',i=1,tbwdth) IF(Lsvlog)THEN WRITE(Ng,1010)Tsttyp,':' WRITE(Ng,1030) WRITE(Ng,1020)'-----------------',' ', & '-------',' ','-----------',' ', & '-------' END IF Lprhdr=F END IF c----------------------------------------------------------------------- IF(Lsvsft.and.baselt.ne.NOTSET) & WRITE(Nform,1040)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv c----------------------------------------------------------------------- IF(Lprsft)THEN IF(Info.eq.0)THEN IF(Baselt.eq.NOTSET)THEN WRITE(Mt1,1080)Grpstr(1:Nchr) IF(Lsvlog)WRITE(Ng,1080)Grpstr(1:Nchr) ELSE IF(Nchr.gt.34)THEN WRITE(Mt1,1050)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv IF(Lsvlog)WRITE(Ng,1050)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv ELSE WRITE(Mt1,1060)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv IF(Lsvlog)WRITE(Ng,1060)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv END IF END IF c----------------------------------------------------------------------- ELSE WRITE(Mt1,1070)Grpstr(1:Nchr) IF(Lsvlog)WRITE(Ng,1070)Grpstr(1:Nchr) END IF END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(/,' F Tests for ',a,' Regressors',a1) 1020 FORMAT(' ',120(a)) 1030 FORMAT(' Regression Effect',t40,'df',t51,'F-statistic',t66, & 'P-Value') 1040 FORMAT('ftest$',a,': ',2(1x,i4),2(1x,e22.15)) 1050 FORMAT(' ',a,/,t35,i4,',',i4,f16.2,f13.2) 1060 FORMAT(' ',a,t35,i4,',',i4,f16.2,f13.2) 1070 FORMAT(' ',a,t52,'Not tested') 1080 FORMAT(' ',a,t41,'All coefficients fixed') c----------------------------------------------------------------------- END prtitr.f0000664006604000003110000001467314521201546011677 0ustar sun00315steps SUBROUTINE prtitr(A,Na,Parms,Nparms,Itrlbl,Iter,Nfev) IMPLICIT NONE c----------------------------------------------------------------------- c prtitr.f, Release 1, Subroutine Version 1.8, Modified 16 Feb 1995. c----------------------------------------------------------------------- c Prints out the iteration, either the nonlinear or the c overall iteration, the deviance, |G'G|**(1/nsrs)*a'a, and the c parameter estimates. Note that a'a must already have the determinate c factored in. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c a d Input either an array of exact likelihood values c a*|G'G|**(.5/nsrs) or its sum of squares c dev d Local scalar for the deviance, the log likelihood without c constants, log(detcov)+sum(e(t)^2/v(t),t=1,nefobs) c i i Local do loop index for write c iter i Input number of iterations either overall or nonlinear c iterations c itrlbl c Input label to identify whether these are regression c parameters or ARMA nonlinear parameters c na i Input number of a's to sum. If na > 1 then the routine c is called from lmdif and the non linear parameters are c to be printed. If na = 1 then the regression parmeters c are to be printed and the dev has already been summed. c nfev i Input number of function evaluations c nparms i Input number of parmeters to print c parms d Input parameters c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'series.cmn' INCLUDE 'units.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'model.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F DOUBLE PRECISION ONE,PI,TWO,ZERO PARAMETER(T=.true.,F=.false.,ZERO=0D0,ONE=1D0,TWO=2D0, & PI=3.14159265358979D0) c ------------------------------------------------------------------ c Changed by BCM Feb 1996 to ensure iteration information is printed c in multiple runs. c ------------------------------------------------------------------ LOGICAL Frstcl,Scndcl COMMON /lgiter / Frstcl,Scndcl c ------------------------------------------------------------------ CHARACTER Itrlbl*(*) INTEGER i,Iter,Na,Nfev,Nparms,ovrlit DOUBLE PRECISION A(*),dev,lnlkhd,Parms(Nparms) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- IF(Scndcl)THEN IF(Nb.eq.0)THEN WRITE(Mt1,1010) 1010 FORMAT(/,' ARMA Iterations') c ------------------------------------------------------------------ ELSE WRITE(Mt1,1020) 1020 FORMAT(/,' Iterations',/, &' IGLS: Estimate regression parameters given last values of ARMA & parameters.',/, &' ARMA: Estimate ARMA parameters using residuals from last IGLS ®ression.',/, &' NOTE: ARMA iteration counts are cumulative over IGLS iteration &s.') END IF c Frstcl=F END IF c----------------------------------------------------------------------- c Calculate the log likelihood from the deviance c----------------------------------------------------------------------- IF(Na.gt.0)THEN IF(Na.gt.1)THEN CALL yprmy(A,Na,dev) ELSE dev=A(1) END IF IF(dpeq(dev,ZERO))THEN lnlkhd=ZERO ELSE lnlkhd=-Dnefob/TWO*(log(TWO*PI*dev/Dnefob)+ONE) END IF c ------------------------------------------------------------------ END IF c----------------------------------------------------------------------- c If printing out the parameters because of an error don't print the c labels. Print out the initial values on the first call and print c the iteration headers without a trailing blank line on the second c call. Only print the initial log likelihood on pure ARMA models. c----------------------------------------------------------------------- IF(Iter.ne.NOTSET)THEN IF(Frstcl)THEN Scndcl=T c ------------------------------------------------------------------ IF(Nb.eq.0)THEN WRITE(Mt1,1030)' ARMA parameters' 1030 FORMAT(/,' Initial values for the',a) WRITE(Mt1,1040)lnlkhd 1040 FORMAT(' Log Likelihood',1p,e23.9) ELSE WRITE(Mt1,1030)' ' END IF c ------------------------------------------------------------------ ELSE IF(.not.Scndcl)THEN WRITE(Mt1,'(1x)') ELSE IF(.not.Frstcl)THEN Scndcl=F END IF c ------------------------------------------------------------------ IF(Nb.eq.0)THEN WRITE(Mt1,1050)Iter 1050 FORMAT(' ','Iteration',t30,i10) c ------------------------------------------------------------------ ELSE IF(Itrlbl.eq.'IGLS')THEN WRITE(Mt1,1060)Itrlbl,Iter 1060 FORMAT(/,' ',a,' Iteration',t30,i10) ELSE WRITE(Mt1,1070)Itrlbl,Iter 1070 FORMAT(' ',a,' Iteration',t30,i10) END IF c ------------------------------------------------------------------ WRITE(Mt1,1080)Nfev 1080 FORMAT(' Function evaluations',t30,i10) c ------------------------------------------------------------------ WRITE(Mt1,1040)lnlkhd END IF END IF c ------------------------------------------------------------------ IF(Itrlbl.eq.'IGLS')THEN WRITE(Mt1,1090)'Regression',(Parms(i),i=1,Nparms) 1090 FORMAT(' ',a,' parameters',t25,3g23.9,/,(t22,3g23.9)) ovrlit=Iter c ------------------------------------------------------------------ ELSE WRITE(Mt1,1090)'ARMA',(Parms(i),i=1,Nparms) IF(Savtab(LESTIT))THEN CALL savitr(F,ovrlit,Iter,lnlkhd,Parms,Nparms) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ Frstcl=F c ------------------------------------------------------------------ RETURN END prtlog.f0000664006604000003110000000711614521201546011654 0ustar sun00315stepsC Last change: BCM 26 Jan 98 1:50 pm SUBROUTINE prtlog(Ng,Insrs,Outsrs,Nopen,Unopnd,Nfail,Failed, & Mtafil,Logfil) IMPLICIT NONE C----------------------------------------------------------------------- c Print out summary error messages into log file. C----------------------------------------------------------------------- INCLUDE 'stdio.i' C----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) C----------------------------------------------------------------------- LOGICAL lhdr,Lexist CHARACTER Insrs*(PFILCR),Outsrs*(PFILCR),Mtafil*(*),Logfil*(*) INTEGER i,n1,n2,Ng,Nopen,Unopnd,Nfail,Failed DIMENSION Insrs(*),Outsrs(*),Unopnd(*),Failed(*) C----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- IF(Nopen.gt.0.or.Nfail.gt.0)THEN WRITE(Ng,1010)Mtafil 1010 FORMAT(' Error messages for the input files defined in ',a) WRITE(STDERR,1020)Logfil,Mtafil 1020 FORMAT(//,' Check ',a,' to see which input files defined ', & 'in ',a,/,' were terminated due to errors.') END IF C----------------------------------------------------------------------- IF(Nfail.gt.0)THEN lhdr=T C----------------------------------------------------------------------- DO i=1,Nfail n1=nblank(Insrs(Failed(i))) n2=nblank(Outsrs(Failed(i))) IF(n1.gt.0.and.n2.gt.0)THEN IF(lhdr)THEN WRITE(Ng,1030) 1030 FORMAT(///,' Input or runtime errors were found in the ', & 'following files:') lhdr=F END IF INQUIRE(FILE=Outsrs(Failed(i))(1:n2)//'.err', & EXIST=Lexist) IF(Lexist)THEN WRITE(Ng,1040)Insrs(Failed(i))(1:n1),Outsrs(Failed(i))(1:n2) 1040 FORMAT(5x,a,'.spc (Error messages stored in ',a,'.err)') ELSE WRITE(Ng,1050)Insrs(Failed(i))(1:n1) 1050 FORMAT(5x,a,'.spc') END IF END IF END DO C----------------------------------------------------------------------- END IF C----------------------------------------------------------------------- IF(Nopen.gt.0)THEN WRITE(Ng,1060)PRGNAM 1060 FORMAT(///,' ',a,' is unable to open input/output files ', & 'for the following sets of filenames:') C----------------------------------------------------------------------- DO i=1,Nopen n1=nblank(Insrs(Unopnd(i))) n2=nblank(Outsrs(Unopnd(i))) IF(n1.gt.0.and.n2.gt.0)THEN WRITE(Ng,1070)i,Insrs(Unopnd(i))(1:n1),Outsrs(Unopnd(i))(1:n2) 1070 FORMAT(2x,i3,2x,'Input filename: ',a,/, & 7x,'Output filename: ',a) ELSE IF(n1.eq.0.and.n2.eq.0)THEN WRITE(Ng,1080)i 1080 FORMAT(2x,i3,2x,'Input filename: NOT SPECIFIED',/, & 7x,'Output filename: NOT SPECIFIED') ELSE IF(n1.eq.0)THEN WRITE(Ng,1090)i,Outsrs(Unopnd(i))(1:n2) 1090 FORMAT(2x,i3,2x,'Input filename: NOT SPECIFIED',/, & 7x,'Output filename: ',a) ELSE WRITE(Ng,1100)i,Insrs(Unopnd(i))(1:n1) 1100 FORMAT(2x,i3,2x,'Input filename: ',a,/, & 7x,'Output filename: NOT SPECIFIED') END IF END DO END IF C----------------------------------------------------------------------- RETURN END prtmdl.f0000664006604000003110000013025014521201546011643 0ustar sun00315stepsC Last change: SRD 19 Nov 99 7:01 am SUBROUTINE prtmdl(Lestim,Lprtes,Prtse,Lsaves,Lgraf,Ldiag,Lprtcm, & Lsavcm,Prtch2,Tlsrun,Prtvar,Prttls,Lpritr) c----------------------------------------------------------------------- c prtmdl.f, Release 1, Subroutine Version 1.13, Modified 16 Feb 1995. c----------------------------------------------------------------------- c Prints out the regression estimates, standard errors, t-values, c and estimates of ARMA parameters for each component c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begcol i Local index for the begining column in b of the current c group of regression effects c endcol i Local index for the last column in b of the current c group of regression effects c i i Local do loop index c igrp i Local do loop index for the current group of regression c variables, suchas trading day c ndf i Local number of degrees of freedom, nefobs-nb c nefobs i Number of effective observations, nw, the length of the c differenced series is used if exact AR and MA, nwp, the c length of the AR filtered data if conditional used or only c exact MA. c nelt i Local number of elements in the packed form of c chol([X:y]'[X:y]) c rmse d Local root mean square error a'a/(nefobs-nb). Note, a'a c is the ncth diagonal element of the cholesky c decomposition of the filtered [X:y]'[X:y] matrix c seb d Local standard error of the current regression estimate, c b(i). Seb=sqrt(X'X[i,i])*rmse c tmp d Local temporary scalar c tval d Local t-value=b(i)/seb c xpxinv d Local pb(pb+1)/2, ncxy(ncxy+1)/2 used vector to hold the c packed form of the inverse of X'X c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) INTEGER LAGS,MODEL,OPRS,PDRV,TWOHUN DOUBLE PRECISION TWO,ZERO,TWOPT5 PARAMETER(LAGS=3,MODEL=1,OPRS=2,PDRV=4,TWO=2D0,TWOPT5=2.5D0, & ZERO=0D0,TWOHUN=200) c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'mdldg.cmn' INCLUDE 'picktd.cmn' INCLUDE 'mdltbl.i' INCLUDE 'title.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'cogreg.prm' c----------------------------------------------------------------------- INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'mdlsvl.i' c----------------------------------------------------------------------- INTEGER PTBLWD PARAMETER(PTBLWD=PGRPCR+6) c----------------------------------------------------------------------- CHARACTER blnk*(5),colstr*(PCOLCR),grpstr*(PGRPCR),ordend*(2), & str*(PGRPCR),cfix*(7),tmpttl*(PGRPCR),begstr*(10), & endstr*(10),starz*(2),drvttl*((PCOLCR+PGRPCR+1)*PDRV), & drvstr*(PCOLCR+PGRPCR+1),marker*(5),fixdrv*(7), & tmpstr*(PGRPCR) LOGICAL fcnok,ldrvfc,ldrvf1,Lestim,lfrtgr,linhol,linotl,lishol, & lisotl,lnewgr,lprchi,Lprtcm,Lprtes,lprthd,lprtrs,lprtse, & lprund,lprvar,Lsavcm,Lsaves,Lgraf,Prtch2,Prtse,Prtvar, & Prttls,Lpritr,Ldiag,lprrgm,lsvchi INTEGER baselt,begcol,begfac,endcol,fh1,i,icol,iestpm,igrp,info,j, & ipos,jcol,nblnk,nchr,numg,nefobs,nelt,ngrpcr,ncolcr,ntmp, & beglag,begopr,endlag,endopr,iflt,ilag,iopr,ntmpcr,spchr, & nbeg,nend,tbwdth,Tlsrun,fh2,nb2,nfix,regidx,df,drvptr, & ndrvtl,ndrv,imark,msg,imsg,tmsg DOUBLE PRECISION chi2vl,dpmpar,pv,rmse,seb,sumb,sumvar,tmp,tval, & xpxinv,searma,bdrv,sedrv,tvdrv,dnefob,seinov c DIMENSION ordend(0:9),xpxinv(PB*(PB+1)/2),tmp(2),regidx(PB) DIMENSION ordend(0:9),xpxinv(PXPX),tmp(2),regidx(PB),bdrv(PDRV), & sedrv(PDRV),drvptr(0:PDRV),msg(4),fixdrv(0:PDRV), & tvdrv(PDRV) c Bob Fay moved EXTERNAL statement up EXTERNAL dpmpar SAVE fh1 INTEGER Nobs,Nrusrx,Bgusrx,Mxiter,Mxnlit,Mxcklg,Begtst,Endtst, & Fctdrp,Begsrs,Frstsy,Begmdl,Endmdl,Nomnfy,Lsrun,Dflist, & Niddf,Nidsdf,Mxidlg DIMENSION Bgusrx(2),Begtst(2),Endtst(2),Begsrs(2),Begmdl(2), & Endmdl(2),Dflist(PDFLG,2) COMMON /armaid/ Dflist,Niddf,Nidsdf,Mxidlg COMMON /armain/ Nobs,Nrusrx,Bgusrx,Mxiter,Mxnlit,Mxcklg,Begtst, & Endtst,Fctdrp,Begsrs,Frstsy,Begmdl,Endmdl,Nomnfy, & Lsrun c----------------------------------------------------------------------- DATA ordend/'th','st','nd','rd','th','th','th','th','th','th'/ DATA blnk/' '/ c----------------------------------------------------------------------- INCLUDE 'cogreg.var' c----------------------------------------------------------------------- c Open the save file to print the estimates if necessary. c----------------------------------------------------------------------- nb2=0 ndrvtl=0 ndrv=0 seinov=ZERO cfix=' ' IF(Ldiag)THEN CALL intlst(PDRV,drvptr,ndrvtl) ndrv=ndrvtl+1 END IF IF(Lsaves.and.Irev.le.1.and.Issap.le.1)THEN CALL opnfil(T,F,LESTES,fh1,fcnok) IF(.not.fcnok)THEN CALL abend RETURN END IF END IF IF(Lgraf)THEN CALL opnfil(T,Lgraf,LESTES,fh2,fcnok) IF(.not.fcnok)THEN CALL abend RETURN END IF END IF tmsg=0 CALL setint(0,4,msg) c----------------------------------------------------------------------- c initialize xpxinv to zero c BCM February 2007 c----------------------------------------------------------------------- CALL setdp(ZERO,PXPX,xpxinv) c----------------------------------------------------------------------- c Print out the convergence error messages and determine what to c print depending on whether or not the model converged. If the model c does converge, report the number of iterations and print the estimates c and standard errors. c----------------------------------------------------------------------- nefobs=Nspobs-Nintvl c CALL prterr(nefobs,Lestim) c IF(Lfatal)RETURN c----------------------------------------------------------------------- c Report convergence c----------------------------------------------------------------------- * IF((.not.(Lautom.or.Lautox)).and.(.not.Lhiddn).and.Ldiag)THEN IF((.not.Lhiddn).and.Ldiag)THEN WRITE(Nform,1281)'steplength: ',Stepln IF(Convrg)THEN WRITE(Nform,1282)'yes' ELSE WRITE(Nform,1282)'no' END IF END IF c----------------------------------------------------------------------- * IF((.NOT.(Lautom.or.Lautox)).and.Convrg.and.(.not.Lhiddn).and. * & Lestim.and.Nestpm.gt.0)THEN IF(Convrg.and.(.not.Lhiddn).and.Lestim.and.Nestpm.gt.0)THEN IF(Lpritr)THEN WRITE(Mt1,110)Nliter,Nfev ELSE IF(Lprtes)THEN WRITE(Mt1,120)Nliter,Nfev END IF c----------------------------------------------------------------------- c print out warning message if estimation converges and maximum c iterations < 200 c----------------------------------------------------------------------- IF(Nliter.gt.TWOHUN)THEN IF(.not.Lnoprt)WRITE(Mt1,130) WRITE(Mt2,130) END IF IF(Ldiag)THEN WRITE(Nform,1000)'niter: ',Nliter WRITE(Nform,1000)'nfev: ',Nfev END IF END IF 110 FORMAT(/,' Estimation converged in',i5,' ARMA iterations,',i5, & ' function evaluations.') 120 FORMAT(' Estimation converged in',i5,' ARMA iterations,',i5, & ' function evaluations.') 130 FORMAT(' NOTE: Maximization of the AR(I)MA model likelihood', & ' has required more',/, & ' than 200 iterations. This could indicate that', & ' the model is',/, & ' inadequate for the data.') c----------------------------------------------------------------------- c Print estimates only or SE and other tests. If the model has not c converged the standard errors, t-statistics, chi^2 tests, and c MLE variance will not be printed out. c----------------------------------------------------------------------- lprchi=Prtch2 lprvar=Prtvar lprtse=Prtse lsvchi=Ldiag c----------------------------------------------------------------------- * lprtrs=Prtse lprtrs=.not.(Niddf.gt.0.or.Nidsdf.gt.0) IF(Convrg.and.Var.gt.2D0*dpmpar(1))THEN tbwdth=PTBLWD ELSE lprtrs=F tbwdth=37 lprchi=F lsvchi=F Tlsrun=0 END IF c----------------------------------------------------------------------- c Find the number of columns in [X:y] and the number of regression c variables. c----------------------------------------------------------------------- IF(Ldiag)WRITE(Nform,1000)'nreg: ',Nb 1000 FORMAT(a,i3) IF(Ngrp.gt.0)THEN c ------------------------------------------------------------------ c Generate number of unfixed regressors c ------------------------------------------------------------------ nb2=Nb IF(Iregfx.ge.2)THEN DO j=1,Nb IF(Regfx(j))nb2=nb2-1 END DO END IF c----------------------------------------------------------------------- c Get the root mean square error and X'X inverse. c----------------------------------------------------------------------- IF(nb2.gt.0)THEN c nelt=Ncxy*(Ncxy+1)/2 nelt=(nb2+1)*(nb2+2)/2 c----------------------------------------------------------------------- IF(Var.gt.2D0*dpmpar(1))THEN rmse=sqrt(Var) CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,nb2,tmp,1) c CALL dppdi(xpxinv,Nb,tmp,1) c----------------------------------------------------------------------- ELSE rmse=ZERO END IF ELSE rmse=ZERO END IF c----------------------------------------------------------------------- c Print out the regression estimates, standard errors, and t-values c for each regression group. c----------------------------------------------------------------------- IF(Lprtes)THEN WRITE(Mt1,1010) 1010 FORMAT(/,' Regression Model') WRITE(Mt1,1020)('-',i=1,tbwdth) 1020 FORMAT(' ',120(a)) c----------------------------------------------------------------------- IF(lprtrs.and.nb2.gt.0)THEN WRITE(Mt1,1030) 1030 FORMAT(t30,'Parameter',t47,'Standard',/,' Variable',t31, & 'Estimate',t50,'Error',t61,'t-value') c----------------------------------------------------------------------- ELSE WRITE(Mt1,1040) 1040 FORMAT(t30,'Parameter',/,' Variable',t34,'Value') END IF c----------------------------------------------------------------------- WRITE(Mt1,1020)('-',i=1,tbwdth) END IF c----------------------------------------------------------------------- IF(Lsaves)WRITE(fh1,1050)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR,TABCHR IF(Lgraf)WRITE(fh2,1050)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR,TABCHR 1050 FORMAT('$regression:',/,'$regression$estimates:',/,'group',a, & 'variable',a,'estimate',a,'standard error',a, & 'fixed',/,'-----',a,'--------',a,'-----------',a, & '--------------',a,'-----') c----------------------------------------------------------------------- c Foreach regression variable or group of variables find their c starting and ending columns and initialize variables indicate c whether c----------------------------------------------------------------------- ldrvfc=F ldrvf1=F lfrtgr=T linhol=F linotl=F nfix=0 c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 lnewgr=T lishol=Rgvrtp(begcol).eq.PRGTTH.or.Rgvrtp(begcol).eq.PRGTLD.or. & ((Rgvrtp(begcol).eq.PRGTEC.or.Rgvrtp(begcol).eq.PRGTEA.or. & Rgvrtp(begcol).eq.PRGTES).and.(begcol-endcol).eq.0) lisotl=Rgvrtp(begcol).eq.PRGTAO.or.Rgvrtp(begcol).eq.PRGTLS.or. & Rgvrtp(begcol).eq.PRGTRP.or.Rgvrtp(begcol).eq.PRGTTC.or. & Rgvrtp(begcol).eq.PRGTSO.or.Rgvrtp(begcol).eq.PRGTTL.or. & Rgvrtp(begcol).eq.PRGTQI.or.Rgvrtp(begcol).eq.PRGTQD.or. & Rgvrtp(begcol).eq.PRSQAO.or.Rgvrtp(begcol).eq.PRSQLS c----------------------------------------------------------------------- c Get the title of the regression group and indicate whether the c group/effect is and outlier or holiday effect. c----------------------------------------------------------------------- CALL getstr(Grpttl,Grpptr,Ngrp,igrp,grpstr,ngrpcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c For each regression variable in the group calculate the standard c error and t-value if the variance in nonzero c----------------------------------------------------------------------- DO icol=begcol,endcol IF(Regfx(icol))THEN seb=ZERO nfix=nfix+1 regidx(icol)=NOTSET ELSE regidx(icol)=icol-nfix seb=sqrt(xpxinv(regidx(icol)*(regidx(icol)+1)/2))*rmse END IF c----------------------------------------------------------------------- c compute t value, or set to zero is se is zero c----------------------------------------------------------------------- IF(seb.gt.ZERO)THEN tval=B(icol)/seb ELSE tval=ZERO END IF Treg(icol)=tval c----------------------------------------------------------------------- c Get the title of the effect c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,icol,colstr,ncolcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Set up the formatting. New groups of effects skip a line before c the title unless it is the first group which is under the title or c is an outlier effect following another outlier or a holiday effect c following another holiday effect. Effects within a group are indented c but groups of single effects are not. c----------------------------------------------------------------------- IF(Lprtes)THEN IF(.not.lfrtgr.and.lnewgr)THEN IF(.not.((lishol.and.linhol).or.(lisotl.and.linotl))) & WRITE(Mt1,'()') END IF c----------------------------------------------------------------------- IF(lnewgr)THEN linhol=lishol linotl=lisotl c----------------------------------------------------------------------- IF(grpstr(1:ngrpcr).ne.colstr(1:ncolcr))THEN WRITE(Mt1,1060)grpstr(1:ngrpcr) 1060 FORMAT(' ',a) nblnk=3 ELSE nblnk=1 END IF END IF c----------------------------------------------------------------------- c Now that the group title has been printed it is nolonger a new c or first group. c----------------------------------------------------------------------- lnewgr=F lfrtgr=F c----------------------------------------------------------------------- c If the regressor is a change of regime regressor, ensure that the c proper label is printed next to the regressor name. c----------------------------------------------------------------------- marker=blnk imark=Rgvrtp(icol) IF((imark.ge.PRRTSE.and.imark.le.PRRTSL).or. & (imark.ge.PRATSE.and.imark.le.PRATSL).or. & (imark.ge.PRR1TD.and.imark.le.PRA1TD).or. & (imark.ge.PRR1ST.and.imark.le.PRA1ST))THEN IF(index(grpstr(1:ngrpcr),'change for after').gt.0)THEN marker(2:3)='@@' imsg=4 ELSE IF(index(grpstr(1:ngrpcr),'change for before').gt.0)THEN marker(2:3)='&&' imsg=2 ELSE IF(index(grpstr(1:ngrpcr),'starting').gt.0)THEN marker(3:3)='@' imsg=3 ELSE marker(3:3)='&' imsg=1 END IF c----------------------------------------------------------------------- c set up indicator variable for descriptive message following c regressor printout c----------------------------------------------------------------------- IF(imark.ge.PRR1TD)THEN tmsg=3 ELSE IF(imark.ge.PRRTSE.and.imark.le.PRRTSL)THEN tmsg=imark-PRRTSE+1 ELSE tmsg=imark-PRATSE+1 END IF IF(msg(imsg).gt.0.and.msg(imsg).ne.tmsg)THEN msg(imsg)=9 ELSE IF(msg(imsg).eq.0)THEN msg(imsg)=tmsg END IF END IF c----------------------------------------------------------------------- c Print the regression estimates and possibly the standard errors c and t-values. c----------------------------------------------------------------------- cfix=' ' IF((.not.Regfx(icol)).and.lprtrs)THEN WRITE(Mt1,1070)marker(1:nblnk),colstr(1:ncolcr),B(icol),seb, & tval c----------------------------------------------------------------------- ELSE IF(Regfx(icol))THEN WRITE(Mt1,1071)marker(1:nblnk),colstr(1:ncolcr),B(icol), & ' (fixed)' cfix='(fixed)' ELSE WRITE(Mt1,1070)marker(1:nblnk),colstr(1:ncolcr),B(icol) END IF END IF c----------------------------------------------------------------------- IF(Lsaves)THEN IF((.not.Regfx(icol)).and.lprtrs)THEN WRITE(fh1,1080)grpstr(1:ngrpcr),TABCHR,colstr(1:ncolcr), & TABCHR,B(icol),TABCHR,seb,TABCHR,cfix ELSE WRITE(fh1,1080)grpstr(1:ngrpcr),TABCHR,colstr(1:ncolcr), & TABCHR,B(icol),TABCHR,ZERO,TABCHR,cfix END IF END IF c----------------------------------------------------------------------- IF(Lgraf)THEN IF((.not.Regfx(icol)).and.lprtrs)THEN WRITE(fh2,1080)grpstr(1:ngrpcr),TABCHR,colstr(1:ncolcr), & TABCHR,B(icol),TABCHR,seb,TABCHR,cfix ELSE WRITE(fh2,1080)grpstr(1:ngrpcr),TABCHR,colstr(1:ncolcr), & TABCHR,B(icol),TABCHR,ZERO,TABCHR,cfix END IF END IF c----------------------------------------------------------------------- IF(Ldiag)THEN CALL reglbl(grpstr,ngrpcr,tmpstr,ntmp,Rgvrtp(icol)) IF((.not.Regfx(icol)).and.lprtrs)THEN WRITE(Nform,2080)tmpstr(1:ntmp),'$',colstr(1:ncolcr),': ', & B(icol),' ',seb,' ',tval,' ',cfix ELSE WRITE(Nform,2080)tmpstr(1:ntmp),'$',colstr(1:ncolcr),': ', & B(icol),' ',ZERO,' ',ZERO,' ',cfix END IF END IF 1080 FORMAT(sp,a,a,a,a,e22.15,a,e22.15,a,a) 2080 FORMAT(sp,a,a,a,3(a,e22.15),a,a) END DO c----------------------------------------------------------------------- c For Seasonal, Trading day, and Stock Trading Day c----------------------------------------------------------------------- IF((Lprtes.and.lprtrs).or.Ldiag)THEN ncolcr=0 CALL setchr(' ',PCOLCR,colstr) IF((grpstr(1:min(11,ngrpcr)).eq.'Trading Day'.or. & grpstr(1:min(17,ngrpcr)).eq.'Stock Trading Day').and. & begcol.lt.endcol)THEN ncolcr=3 colstr(1:ncolcr)='Sun' IF(((.not.Fulltd).and.index(grpstr(1:ngrpcr),'(before').gt.0) & .or.index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN ncolcr=5 colstr(1:ncolcr)='Sun I' ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0 & .or.index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN ncolcr=6 colstr(1:ncolcr)='Sun II' END IF c----------------------------------------------------------------------- ELSE IF((grpstr(1:min(25,ngrpcr)).eq. & '1-Coefficient Trading Day'.or. & grpstr(1:min(31,ngrpcr)).eq. & '1-Coefficient Stock Trading Day').and. & begcol.eq.endcol)THEN ncolcr=7 colstr(1:ncolcr)='Sat/Sun' IF(((.not.Fulltd).and.index(grpstr(1:ngrpcr),'(before').gt.0) & .or.index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN ncolcr=9 colstr(1:ncolcr)='Sat/Sun I' ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0 & .or.index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN ncolcr=10 colstr(1:ncolcr)='Sat/Sun II' END IF c----------------------------------------------------------------------- ELSE IF(grpstr(1:min(8,ngrpcr)).eq.'Seasonal')THEN IF(Sp.eq.12)THEN ncolcr=3 colstr(1:ncolcr)='Dec' IF(((.not.Lseff).and.index(grpstr(1:ngrpcr),'(before').gt.0) & .or.index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN ncolcr=5 colstr(1:ncolcr)='Dec I' ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0 & .or.index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN ncolcr=6 colstr(1:ncolcr)='Dec II' END IF c----------------------------------------------------------------------- ELSE ipos=1 CALL itoc(Sp,colstr,ipos) IF(Lfatal)RETURN IF(mod(Sp,100).ge.11.and.mod(Sp,100).le.13)THEN colstr(ipos:ipos+1)='th' ELSE colstr(ipos:ipos+1)=ordend(mod(Sp,10)) END IF ncolcr=ipos+1 IF(index(grpstr(1:ngrpcr),'(before').gt.0.or. & index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN colstr(ncolcr+1:ncolcr+2)=' I' ncolcr=ncolcr+2 ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0.or. & index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN colstr(ncolcr+1:ncolcr+3)=' II' ncolcr=ncolcr+3 END IF END IF END IF c----------------------------------------------------------------------- IF(ncolcr.gt.0)THEN IF(begcol.eq.endcol)THEN ldrvf1=T starz='**' ELSE ldrvfc=T starz=' *' END IF seb=ZERO cfix= ' ' IF(Var.gt.ZERO)THEN c----------------------------------------------------------------------- c Sum the coefficient estimates b(begcol) + ... + b(endcol). Also c compute the variance of this sum and the corresponding t-statistic c (tstat). c----------------------------------------------------------------------- sumb=-B(begcol) IF(regidx(begcol).eq.NOTSET)THEN baselt=NOTSET sumvar=0D0 ELSE baselt=regidx(begcol)*(regidx(begcol)+1)/2 sumvar=xpxinv(baselt) END IF c----------------------------------------------------------------------- IF(begcol.eq.endcol)THEN sumb=sumb*TWOPT5 IF(baselt.ne.NOTSET)seb=(sqrt(sumvar)*rmse)*TWOPT5 ELSE DO icol=begcol+1,endcol sumb=sumb-B(icol) IF(regidx(icol).ne.NOTSET)THEN baselt=(regidx(icol)-1)*regidx(icol)/2 sumvar=sumvar+xpxinv(baselt+regidx(icol)) c----------------------------------------------------------------------- DO jcol=begcol,icol-1 IF(regidx(jcol).ne.NOTSET) & sumvar=sumvar+TWO*xpxinv(baselt+regidx(jcol)) END DO END IF END DO IF(baselt.ne.NOTSET)seb=sqrt(sumvar)*rmse END IF c----------------------------------------------------------------------- IF(baselt.ne.NOTSET)THEN tval=sumb/seb IF(Lprtes)WRITE(Mt1,1070)blnk(1:nblnk-2)//starz, & colstr(1:ncolcr)//' (derived)', & sumb,seb,tval c----------------------------------------------------------------------- ELSE IF(Lprtes)WRITE(Mt1,1071)blnk(1:nblnk-2)//starz, & colstr(1:ncolcr)//' (derived)', & sumb,' (fixed)' cfix='(fixed)' seb=ZERO tval=ZERO END IF ELSE sumb=-B(begcol) IF(begcol.eq.endcol)THEN sumb=sumb*TWOPT5 ELSE DO icol=begcol+1,endcol sumb=sumb-B(icol) END DO END IF c----------------------------------------------------------------------- seb=ZERO tval=ZERO IF(Lprtes)WRITE(Mt1,1070)blnk(1:nblnk-2)//starz, & colstr(1:ncolcr)//' (derived)', & sumb,seb END IF IF(Ldiag)THEN CALL insstr(grpstr(1:ngrpcr)//'$'//colstr(1:ncolcr),ndrv, & PDRV,drvttl,drvptr,ndrvtl) IF(Lfatal)RETURN bdrv(ndrvtl)=sumb sedrv(ndrvtl)=seb fixdrv(ndrvtl)=cfix tvdrv(ndrvtl)=tval ndrv=ndrv+1 END IF END IF END IF END DO IF(Ldiag.and.ndrvtl.gt.0)THEN WRITE(Nform,1081)ndrvtl 1081 FORMAT('nregderived: ',i3) DO icol=1,ndrvtl CALL getstr(drvttl,drvptr,Ndrvtl,icol,drvstr,nchr) IF(Lfatal)RETURN WRITE(Nform,1082)drvstr(1:nchr),': ',bdrv(icol),' ', & sedrv(icol),' ',tvdrv(icol),' ',fixdrv(icol) 1082 FORMAT(sp,a,3(a,e22.15),a,a) END DO END IF c----------------------------------------------------------------------- c Print the tail line and the change of regime regressor message c and/or the derived factor message if there were any c----------------------------------------------------------------------- IF(Lprtes)THEN WRITE(Mt1,1020)('-',i=1,tbwdth) IF(tmsg.gt.0)THEN lprrgm=F DO imsg=1,4 IF(msg(imsg).gt.0)THEN CALL getstr(COGDIC,cogptr,PCOG,msg(imsg),grpstr,ngrpcr) IF(lprrgm)WRITE(Mt1,'()') IF(imsg.eq.1)THEN WRITE(Mt1,1301)grpstr(1:ngrpcr) ELSE IF(imsg.eq.2)THEN WRITE(Mt1,1302)grpstr(1:ngrpcr) ELSE IF(imsg.eq.3)THEN WRITE(Mt1,1303)grpstr(1:ngrpcr) ELSE WRITE(Mt1,1304)grpstr(1:ngrpcr) END IF IF(.not.lprrgm)lprrgm=T END IF END DO IF((ldrvf1.or.ldrvfc).and.lprtrs)WRITE(Mt1,'()') END IF IF(ldrvfc.and.lprtrs)WRITE(Mt1,1300) IF(ldrvf1.and.lprtrs)THEN IF(ldrvfc)WRITE(Mt1,'()') WRITE(Mt1,1310) END IF END IF c----------------------------------------------------------------------- c Compute and print out the chi^2 tests for the seasonal effects, c and trading day but not Automatically Identified Outliers. c----------------------------------------------------------------------- IF(((Lprtes.and.lprchi).or.lsvchi).and.Iregfx.lt.3)THEN lprthd=F lprund=F IF(lprchi)lprthd=T c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) CALL eltlen(igrp,Grp,Ngrp,numg) IF(Lfatal)RETURN IF((Rgvrtp(begcol).ne.PRGTAA.and.Rgvrtp(begcol).ne.PRGTAL.and. & Rgvrtp(begcol).ne.PRGTAT.and.Rgvrtp(begcol).ne.PRGTUD.and. & Rgvrtp(begcol).ne.PRGULM.and.Rgvrtp(begcol).ne.PRGULQ.and. & Rgvrtp(begcol).ne.PRGULY).and.numg.gt.1)THEN IF(lprchi)lprund=T endcol=Grp(igrp)-1 CALL getstr(Grpttl,Grpptr,Ngrp,igrp,str,nchr) IF(Lfatal)RETURN info=0 baselt=regidx(begcol) df=endcol-begcol+1 IF(Iregfx.eq.2)THEN IF(baselt.eq.NOTSET)df=df-1 DO icol=begcol+1,endcol IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE baselt=regidx(icol) END IF END DO END IF IF(baselt.ne.NOTSET) & CALL chitst(xpxinv,begcol,endcol,chi2vl,pv,regidx,T,info) CALL savchi(lsvchi,F,lprthd,tbwdth,baselt,str,nchr,info,df, & chi2vl,pv,'Regressors','chi$') IF(lprchi)THEN CALL prtchi(Mt1,lprthd,tbwdth,baselt,str,nchr,info,df,chi2vl, & pv,'Regressors') IF(lprthd)lprthd=F END IF END IF END DO c----------------------------------------------------------------------- IF(lsvchi.or.lprchi) & CALL cmpchi(xpxinv,regidx,lsvchi,F,lprchi,lprthd,tbwdth,F) c----------------------------------------------------------------------- c Print the tail line c----------------------------------------------------------------------- IF(lprund)WRITE(Mt1,1020)('-',i=1,tbwdth) c----------------------------------------------------------------------- c print seasonal f-tests, if seasonal regressors are present c (BCM July 2007) c----------------------------------------------------------------------- IF(lsvchi.or.lprchi.or.Svltab(LSLSFT)) & CALL sftest(xpxinv,regidx,lprchi,lsvchi,Svltab(LSLSFT),F) c----------------------------------------------------------------------- c print trading day f-tests, if trading day regressors are present c (BCM July 2011) c----------------------------------------------------------------------- IF(lsvchi.or.lprchi.or.Svltab(LSLTFT)) & CALL tdftest(xpxinv,regidx,lprchi,lsvchi,Svltab(LSLTFT),F) END IF c----------------------------------------------------------------------- c Save the covariance matrix and print the correlation matrix c of the regression variables. If not printing out the regression c standard errors don't print out related statistics. c----------------------------------------------------------------------- IF(lprtrs)THEN IF(Lsavcm.and.Iregfx.lt.3)CALL svrgcm(nefobs,xpxinv,regidx) IF((.not.Lfatal).and.Lprtcm.and.Iregfx.lt.3) & CALL cormtx(xpxinv,regidx) c----------------------------------------------------------------------- c Print the temporary level-shift tests if requested. c----------------------------------------------------------------------- IF((.not.Lfatal).and.Tlsrun.gt.1.and.(Prttls.or.Ldiag).and. & Iregfx.lt.3)CALL templs(Lsrun,rmse,xpxinv,Prttls,Ldiag) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Print out the ARMA parameters. If the ARMA part of the model c is fixed then only print out the estimates c----------------------------------------------------------------------- begopr=Mdl(DIFF-1) beglag=Opr(begopr-1) endopr=Mdl(MA)-1 IF(Ldiag)THEN WRITE(Nform,1000)'nonseasonaldiff: ',Nnsedf WRITE(Nform,1000)'seasonaldiff: ',Nseadf WRITE(Nform,1000)'nmodel: ',Opr(endopr)-Opr(Mdl(AR-1)-1) END IF c----------------------------------------------------------------------- IF(lprtse.and.Convrg.and.Var.gt.2D0*dpmpar(1))THEN lprtse=T tbwdth=53 ELSE lprtse=F tbwdth=37 END IF c----------------------------------------------------------------------- IF(Lprtes.and.(lprvar.or.endopr.gt.0))THEN endlag=Opr(endopr)-1 CALL isfixd(MODEL,Arimaf,beglag,endlag,cfix) IF(Nb.gt.0)WRITE(Mt1,'()') IF(Lestim.and.cfix.eq.'(fixed)')lprtse=F c----------------------------------------------------------------------- IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1130)Mdlttl(1:Nmdlcr),Mdldsn(1:Nmddcr) 1130 FORMAT(' ',a,': ',a) IF(.not.Lprtdf)THEN IF(Nnsedf.gt.0)WRITE(Mt1,1140)'Nonseasonal differences',Nnsedf IF(Nseadf.gt.0)WRITE(Mt1,1140)'Seasonal differences',Nseadf 1140 FORMAT(' ',a,':',t28,i2) END IF c----------------------------------------------------------------------- IF(lprtse)THEN WRITE(Mt1,1150) 1150 FORMAT(t47,'Standard',/,' Parameter',t31,'Estimate',t49, & 'Errors') c----------------------------------------------------------------------- ELSE IF(Lestim.and.cfix.eq.'(fixed)')THEN WRITE(Mt1,1160) 1160 FORMAT(/,' Parameter',t26,'Value (fixed)') c ------------------------------------------------------------------ ELSE WRITE(Mt1,1170) 1170 FORMAT(/,' Parameter',t34,'Value') END IF c----------------------------------------------------------------------- WRITE(Mt1,1020)('-',i=1,tbwdth) END IF c----------------------------------------------------------------------- IF(endopr.gt.0)THEN iestpm=0 c----------------------------------------------------------------------- IF(Lsaves.or.Lgraf)THEN IF(lprtse)THEN IF(Lsaves)WRITE(fh1,1180)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR IF(Lgraf)WRITE(fh2,1180)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR 1180 FORMAT('$arima:',/,'$arima$estimates:',/,'operator',a,'factor', & a,'period',a,'lag',a,'estimate',a,'standard error',a, & 'fixed',/,'--------',a,'------',a,'------',a,'---',a, & '--------',a,'--------------',a,'-----') c----------------------------------------------------------------------- ELSE IF(Lsaves)WRITE(fh1,1190)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR,TABCHR,TABCHR,TABCHR IF(Lgraf)WRITE(fh2,1190)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR,TABCHR,TABCHR,TABCHR 1190 FORMAT('$arima:',/,'$arima$estimates:',/,'operator',a,'factor', & a,'period',a,'lag',a,'estimate',a,'fixed',/,'--------', & a,'------',a,'------',a,'---',a,'--------',a,'-----') END IF END IF c----------------------------------------------------------------------- lfrtgr=T c----------------------------------------------------------------------- IF(Lprtdf)THEN begfac=DIFF ELSE begfac=AR END IF c ------------------------------------------------------------------ DO iflt=begfac,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c----------------------------------------------------------------------- DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c----------------------------------------------------------------------- CALL isfixd(OPRS,Arimaf,beglag,endlag,cfix) CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(Lprtes)THEN IF(.not.lfrtgr)WRITE(Mt1,'()') IF(lprtse)THEN WRITE(Mt1,1200)tmpttl(1:ntmpcr),cfix 1200 FORMAT(' ',a,t45,a) ELSE WRITE(Mt1,1210)tmpttl(1:ntmpcr),cfix 1210 FORMAT(' ',a,' ',a) END IF c----------------------------------------------------------------------- lfrtgr=F END IF c----------------------------------------------------------------------- DO ilag=beglag,endlag CALL isfixd(LAGS,Arimaf,ilag,ilag,cfix) IF(.not.Arimaf(ilag))iestpm=iestpm+1 c----------------------------------------------------------------------- IF(Lprtes)THEN IF(.not.(Arimaf(ilag).or..not.lprtse))THEN WRITE(Mt1,1220)Arimal(ilag),Arimap(ilag), & sqrt(Var*Armacm(iestpm,iestpm)) 1220 FORMAT(' Lag',i3,f29.4,f16.5) ELSE IF(lprtse)THEN WRITE(Mt1,1230)Arimal(ilag),Arimap(ilag),cfix 1230 FORMAT(' Lag',i3,f29.4,' ',a) c----------------------------------------------------------------------- ELSE WRITE(Mt1,1240)Arimal(ilag),cfix,Arimap(ilag) 1240 FORMAT(' Lag',i3,' ',a,t19,f20.4) c----------------------------------------------------------------------- END IF END IF c----------------------------------------------------------------------- DO spchr=ntmpcr,1,-1 IF(tmpttl(spchr:spchr).eq.' ')GO TO 10 END DO spchr=1 10 IF(Lsaves.or.Lgraf.or.Ldiag)THEN c----------------------------------------------------------------------- IF(.not.lprtse)THEN IF(Lsaves)WRITE(fh1,1250)tmpttl(spchr+1:ntmpcr),TABCHR, & tmpttl(1:spchr-1),TABCHR, & Oprfac(iopr),TABCHR,Arimal(ilag), & TABCHR,Arimap(ilag),TABCHR,cfix IF(Lgraf)WRITE(fh2,1250)tmpttl(spchr+1:ntmpcr),TABCHR, & tmpttl(1:spchr-1),TABCHR, & Oprfac(iopr),TABCHR,Arimal(ilag), & TABCHR,Arimap(ilag),TABCHR,cfix IF(Ldiag)WRITE(Nform,1261)tmpttl(spchr+1:ntmpcr),'$', & tmpttl(1:spchr-1),'$',Oprfac(iopr), & '$',Arimal(ilag),': ',Arimap(ilag), & ' ',ZERO,' ',ZERO,' ',cfix ELSE IF(Arimaf(ilag))THEN IF(Lsaves) & WRITE(fh1,1260)tmpttl(spchr+1:ntmpcr),TABCHR, & tmpttl(1:spchr-1),TABCHR,Oprfac(iopr), & TABCHR,Arimal(ilag),TABCHR,Arimap(ilag), & TABCHR,ZERO,TABCHR,cfix IF(Lgraf) & WRITE(fh2,1260)tmpttl(spchr+1:ntmpcr),TABCHR, & tmpttl(1:spchr-1),TABCHR,Oprfac(iopr), & TABCHR,Arimal(ilag),TABCHR,Arimap(ilag), & TABCHR,ZERO,TABCHR,cfix IF(Ldiag) & WRITE(Nform,1261)tmpttl(spchr+1:ntmpcr),'$', & tmpttl(1:spchr-1),'$',Oprfac(iopr),'$', & Arimal(ilag),': ',Arimap(ilag),' ', & ZERO,' ',ZERO,' ',cfix 1250 FORMAT(a,a,a,a,i2.2,a,i2.2,a,sp,e21.14,a,a) 1260 FORMAT(a,a,a,a,i2.2,a,i2.2,a,sp,e21.14,a,e21.14,a,a) 1261 FORMAT(a,a,a,a,i2.2,a,i2.2,a,sp,3(e21.14,a),a) c----------------------------------------------------------------------- ELSE searma=sqrt(Var*Armacm(iestpm,iestpm)) IF(Lsaves) & WRITE(fh1,1260)tmpttl(spchr+1:ntmpcr),TABCHR, & tmpttl(1:spchr-1),TABCHR,Oprfac(iopr), & TABCHR,Arimal(ilag),TABCHR,Arimap(ilag), & TABCHR,searma,TABCHR,cfix IF(Lgraf) & WRITE(fh2,1260)tmpttl(spchr+1:ntmpcr),TABCHR, & tmpttl(1:spchr-1),TABCHR,Oprfac(iopr), & TABCHR,Arimal(ilag),TABCHR,Arimap(ilag), & TABCHR,searma,TABCHR,cfix IF(Ldiag) & WRITE(Nform,1261)tmpttl(spchr+1:ntmpcr),'$', & tmpttl(1:spchr-1),'$',Oprfac(iopr),'$', & Arimal(ilag),': ',Arimap(ilag),' ', & searma,' ',Arimap(ilag)/searma,' ', & cfix END IF END IF END DO END DO END DO END IF c----------------------------------------------------------------------- c Compute the standard error of the innovation variance, if printed or c saved (BCM March 2004) c----------------------------------------------------------------------- IF((Lprtes.and.lprvar).or.Lgraf.or.(Ldiag.and.Convrg))THEN nefobs=Nspobs-Nintvl dnefob=dble(nefobs) seinov=sqrt(TWO/dnefob)*Var END IF c----------------------------------------------------------------------- IF(Lprtes)THEN IF(lprvar)THEN IF(endopr.gt.0)WRITE(Mt1,'()') WRITE(Mt1,1270)' Variance ',Var WRITE(Mt1,1270)' SE of Var',seinov 1270 FORMAT(a,e33.5) IF(endopr.gt.0)WRITE(Mt1,1020)('-',i=1,tbwdth) END IF END IF c----------------------------------------------------------------------- IF(Lsaves)THEN WRITE(fh1,1280)TABCHR,Var,TABCHR,seinov IF(Irev.eq.0.and.Issap.eq.0)THEN CALL fclose(fh1) ELSE CALL wrtdat(Begmdl,Sp,begstr,nbeg) IF(.not.Lfatal)CALL wrtdat(Endmdl,Sp,endstr,nend) IF(Lfatal)RETURN WRITE(fh1,1283)begstr(1:nbeg),endstr(1:nend) IF(((.not.Rvtran).and.Irev.gt.0).or. & ((.not.Sstran).and.Issap.gt.0))WRITE(fh1,'(1x,a)')'-----' END IF END IF IF(Lgraf)THEN WRITE(fh2,1280)TABCHR,Var,TABCHR,seinov CALL fclose(fh2) END IF IF(Ldiag)THEN IF(Convrg)THEN WRITE(Nform,1281)'variance$mle: ',Var WRITE(Nform,1281)'variance$se: ',seinov ELSE WRITE(Nform,1281)'variance$mle: ',ZERO WRITE(Nform,1281)'variance$se: ',ZERO END IF END IF 1280 FORMAT(sp,'$variance:',//,'mle',a,e21.14,/,'se',a,e21.14) 1281 FORMAT(a,e21.14) 1282 FORMAT('converged: ',a) 1283 FORMAT('$modelspan: ',a,' to ',a) c----------------------------------------------------------------------- 1070 FORMAT(a,a,t25,f14.4,:f16.5,:f13.2) 1071 FORMAT(a,a,t25,f14.4,a16) 1301 FORMAT(' &The I values estimate the ',a,' coefficients', & /,' for the span of data before the change date.') 1302 FORMAT(' &&The I values estimate how much the early ',a, & /,' coefficients differ from those estimated for the span', & ' of data',/,' starting at the change date.') 1303 FORMAT(' @The II values estimate the ',a,' coefficients', & /,' for the span of data starting at the change date.') 1304 FORMAT(' @@The II values estimate how much the early ',a, & /,' coefficients differ from those estimated for the span', & ' of data',/,' before the change date.') 1300 FORMAT(' *For full trading-day and stable seasonal effects, ', & 'the derived',/, & ' parameter estimate is obtained indirectly as minus ', & 'the sum',/, & ' of the directly estimated parameters that define the ', & 'effect.') 1310 FORMAT(' **For the one coefficient trading-day effect, the ', & 'derived',/, & ' parameter estimate is obtained indirectly as minus ', & '-2.5 times',/, & ' the directly estimated parameter that defines ', & 'the effect.') c----------------------------------------------------------------------- RETURN END prtmsp.f0000664006604000003110000000367014521201546011673 0ustar sun00315stepsC Last change: BCM 24 Nov 97 11:16 am SUBROUTINE prtmsp(Begdat,Enddat,Sp,Lxreg) IMPLICIT NONE c----------------------------------------------------------------------- c Prints the model span for a given model estimation c----------------------------------------------------------------------- INCLUDE 'title.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL Lxreg CHARACTER bdtstr*(10),edtstr*(10) INTEGER Begdat,Enddat,nchr1,nchr2,Sp DIMENSION Begdat(2),Enddat(2) c ------------------------------------------------------------------ c create character versions of the beginning and ending dates c ------------------------------------------------------------------ CALL wrtdat(Begdat,Sp,bdtstr,nchr1) IF(.not.Lfatal)CALL wrtdat(Enddat,Sp,edtstr,nchr2) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Write them out c ------------------------------------------------------------------ IF(Lcmpaq)THEN IF(Lxreg)THEN WRITE(Mt1,1010)' Irregular Component Regression Span', & bdtstr(1:nchr1),edtstr(1:nchr2) ELSE WRITE(Mt1,1010)' regARIMA Model Span',bdtstr(1:nchr1), & edtstr(1:nchr2) END IF ELSE IF(Lxreg)THEN WRITE(Mt1,1020)' Irregular Component Regression Span', & bdtstr(1:nchr1),edtstr(1:nchr2) ELSE WRITE(Mt1,1020)' regARIMA Model Span',bdtstr(1:nchr1), & edtstr(1:nchr2) END IF END IF c ------------------------------------------------------------------ 1010 FORMAT(a,': ',a,' to ',a) 1020 FORMAT(/,a,/,' From ',a,' to ',a) c ------------------------------------------------------------------ RETURN END prtmsr.f0000664006604000003110000001623014521201547011672 0ustar sun00315stepsC Last change: BCM 1 Oct 1998 10:45 am **==prtmsr.f processed by SPAG 4.03F at 10:40 on 20 Oct 1994 SUBROUTINE prtmsr(Msr,Revspn,Ny,Nptr) c----------------------------------------------------------------------- c Print and/or save a table of the percent revision, concurrent c and final value of seasonally adjusted series, seasonal factors, c or month to month changes. c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'tfmts.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'cchars.i' c----------------------------------------------------------------------- INCLUDE 'tfmts.prm' INCLUDE 'tbltitle.prm' INCLUDE 'desadj.prm' c----------------------------------------------------------------------- LOGICAL F,T INTEGER MO,YR PARAMETER(MO=2,YR=1,F=.false.,T=.true.) c----------------------------------------------------------------------- CHARACTER cblank*22,dash*132,filter*3,tfmt*110,fbase*110,fsum*5, & outstr*50,tblttl*(PTTLEN),fobs*5 INTEGER i,j,k,Revspn,Ny,fh,Msr,Nptr,numrev,ik,ipos,idate,rdbdat, & ndash,ntbttl,ifmt,npos LOGICAL locok DIMENSION Msr(PREV),Revspn(2),filter(3),idate(2) c----------------------------------------------------------------------- DATA filter/'3x3','3x5','3x9'/ c----------------------------------------------------------------------- INCLUDE 'tfmts.var' INCLUDE 'desadj.var' c----------------------------------------------------------------------- IF(.not.(Prttab(Nptr).or.Savtab(Nptr)))RETURN c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- CALL setchr(' ',22,cblank) CALL setchr('-',132,dash) dash(1:1)=' ' c----------------------------------------------------------------------- c If seasonal filters are to be printed, print out title. c----------------------------------------------------------------------- IF(Prttab(Nptr))THEN numrev=Endrev-Begrev c----------------------------------------------------------------------- c Print out title, table header c----------------------------------------------------------------------- CALL makttl(DSADIC,dsaptr,PDSA,Nptr,PDSUM4,tblttl,ntbttl,T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),Revspn,Ny,numrev,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c print header for table. If period option used, this will contain c only the concurrent period. c----------------------------------------------------------------------- ndash=Tblcol*(Tblwid+1)+10 c----------------------------------------------------------------------- WRITE(Mt1,1010)dash(1:ndash) WRITE(Mt1,Fmtcol)' Year',(Colhdr(i),i=2,Ny+1) WRITE(Mt1,1010)dash(1:ndash) 1010 FORMAT(a) c----------------------------------------------------------------------- c Construct format for table c----------------------------------------------------------------------- if(Tblwid.gt.9)then write(fobs,1050)Tblwid 1050 format('a',i2) ifmt=3 else write(fobs,1060)Tblwid 1060 format('a',i1) ifmt=2 end if write(fsum,1050)Tblwid+2 fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,tfmt,fobs(1:ifmt),fsum(1:3),ipos,npos) c----------------------------------------------------------------------- c If you are only printing out one period (ie, calendar month) in a c year, print only those observation now by looping all observations c for that period. c----------------------------------------------------------------------- j=Revspn(YR)-1 c----------------------------------------------------------------------- c If you are printing out an entire year's observations, set the c pointer for the first observation and loop until you get to the c end. c----------------------------------------------------------------------- Revptr=1 DO WHILE (Revptr.le.numrev) j=j+1 c----------------------------------------------------------------------- c Print out choices for seasonal filter. c If this is then first year, check what the date of the first c observation tested is and adjust pointer for December value to c allow for spaces if first observation not January/1st Quarter. c----------------------------------------------------------------------- IF((Revptr.eq.1).and.(Revspn(MO).gt.1))THEN k=Ny-Revspn(MO)+1 WRITE(Mt1,tfmt(1:npos))j,(cblank(1:Tblwid),ik=1,Ny-k), & (filter(Msr(i)),i=Revptr,k) ELSE k=Revptr+Ny-1 IF(k.gt.numrev)k=numrev WRITE(Mt1,tfmt(1:npos))j,(filter(Msr(i)),i=Revptr,k) END IF WRITE(Mt1,1010)cblank(1:1) c----------------------------------------------------------------------- Revptr=k+1 END DO END IF c----------------------------------------------------------------------- c If percent revisions are to be saved, open file for saved c revisions. c----------------------------------------------------------------------- IF(Savtab(Nptr))THEN CALL opnfil(T,F,Nptr,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for revisions c----------------------------------------------------------------------- WRITE(fh,1020)'date',TABCHR,'sf' WRITE(fh,1020)'----',TABCHR,'---' c----------------------------------------------------------------------- c begin looping though observations c----------------------------------------------------------------------- DO i=Begrev,Endrev-1 Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Set date of revision for observation Revptr c----------------------------------------------------------------------- CALL addate(Revspn,Ny,Revptr-1,idate) rdbdat=100*idate(YR)+idate(MO) c----------------------------------------------------------------------- c Save revision measure with date c----------------------------------------------------------------------- ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 outstr(ipos:ipos+2)=filter(Msr(Revptr)) WRITE(fh,1020)outstr(1:ipos+2) END DO CALL fclose(fh) END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1020 FORMAT(a:,a,a:,a,a) END prtmtx.f0000664006604000003110000000534014521201547011701 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:30 pm SUBROUTINE prtmtx(Begxy,Sp,Xy,Nrxy,Ncxy,Ttlstr,Ttlptr,Nttl) IMPLICIT NONE c ------------------------------------------------------------------ c INCLUDE 'srslen.prm' c INCLUDE 'model.prm' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER dash*25,space*25 CHARACTER str*(10),Ttlstr*(*),fmt1*(7),fmt2*(9),fmt3*(21) INTEGER Begxy,ibeg,ielt,iend,idate,nchr,Ncxy,Nrxy,Nttl,Sp,Ttlptr, & nt,colwid,maxwid,ncol INTEGER Mxtbwd DOUBLE PRECISION Xy DIMENSION Begxy(2),idate(2),Ttlptr(0:Nttl),Xy(*),colwid(11) DATA dash/'-------------------------'/ DATA space/' '/ c ------------------------------------------------------------------ c Initialize variables used in printing matrix c Changed by Brian Monsell, October 25, 1994 c ------------------------------------------------------------------ Mxtbwd=80 IF(Lwdprt)Mxtbwd=132 CALL setint(11,11,colwid) maxwid=11 DO ielt=1,Nttl maxwid=max(Ttlptr(ielt)-Ttlptr(ielt-1),maxwid) END DO maxwid=maxwid+2 ncol=(Mxtbwd-10)/maxwid DO ielt=1,Nttl nt=mod(ielt,ncol) IF(nt.eq.0)nt=ncol colwid(nt)=max(Ttlptr(ielt)-Ttlptr(ielt-1),colwid(nt)) END DO nt=min(Nttl,ncol) WRITE(fmt1,1010)'a',2*ncol WRITE(fmt2,1010)'t11',2*ncol 1010 FORMAT('(',a,',',i2,'a)') c ------------------------------------------------------------------ WRITE(Mt1,fmt1)' Date', & (space(1:max(maxwid+Ttlptr(ielt-1)-Ttlptr(ielt),1)) & ,Ttlstr(Ttlptr(ielt-1):Ttlptr(ielt)-1),ielt=1,nt) IF(Nttl.gt.ncol)WRITE(Mt1,fmt2)(space(1:max(maxwid+Ttlptr(ielt-1)- & Ttlptr(ielt),1)), & Ttlstr(Ttlptr(ielt-1):Ttlptr(ielt) & -1),ielt=nt+1,Nttl) WRITE(Mt1,fmt1)' ----', & (space(1:maxwid-colwid(ielt)),dash(1:colwid(ielt)), & ielt=1,nt) c ------------------------------------------------------------------ WRITE(fmt3,1020)ncol,maxwid 1020 FORMAT('(2x,a8,(:t11,',i1,'E',i2,'.4))') DO iend=Nttl,Ncxy*Nrxy,Ncxy ibeg=iend-Nttl+1 CALL addate(Begxy,Sp,(iend-Nttl+Ncxy)/Ncxy-1,idate) CALL wrtdat(idate,Sp,str,nchr) IF(Lfatal)RETURN WRITE(Mt1,fmt3)str(1:nchr),(Xy(ielt),ielt=ibeg,iend) END DO c ------------------------------------------------------------------ RETURN END prtnfn.f0000664006604000003110000000530414521201547011652 0ustar sun00315stepsC Last change: BCM 27 Oct 97 1:07 pm SUBROUTINE prtnfn(Fcntyp,Lam,Pcode) IMPLICIT NONE c----------------------------------------------------------------------- c prtnfn.f, Release 1, Subroutine Version 1.4, Modified 24 Oct 1994. c----------------------------------------------------------------------- C Prints the Logit or Box-Cox transformation formulae c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c ------------------------------------------------------------------ INCLUDE 'title.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ CHARACTER ytrans*(29) INTEGER Fcntyp,nytrns,Pcode DOUBLE PRECISION Lam c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ call setchr(' ',29,ytrans) IF(Fcntyp.eq.3)THEN nytrns=12 ytrans(1:nytrns)='log(y/(1-y))' c ------------------------------------------------------------------ ELSE IF(Fcntyp.eq.0)THEN nytrns=19 ytrans(1:nytrns)='Automatic selection' c ------------------------------------------------------------------ ELSE IF(dpeq(Lam,ZERO))THEN nytrns=6 ytrans(1:nytrns)='Log(y)' c ------------------------------------------------------------------ ELSE IF(dpeq(Lam,ONE))THEN nytrns=17 ytrans(1:nytrns)='No transformation' c ------------------------------------------------------------------ ELSE IF(dpeq(Lam,0.5D0))THEN nytrns=7 ytrans(1:nytrns)='sqrt(y)' c ------------------------------------------------------------------ ELSE IF(Lam.ge.ZERO)THEN nytrns=28 WRITE(ytrans(1:nytrns),1010)Lam,Lam,Lam 1010 FORMAT(f5.2,'^2+((y^',f5.2,')-1)/',f5.2) ELSE nytrns=29 WRITE(ytrans(1:nytrns),1020)Lam,Lam,Lam 1020 FORMAT(f5.2,'^2+((y^',f5.2,')-1)/(',f5.2,')') END IF c ------------------------------------------------------------------ IF(Pcode.eq.0)THEN IF(Lcmpaq)THEN WRITE(Mt1,1040)' Transformation',' '//ytrans(1:nytrns) ELSE WRITE(Mt1,1030)ytrans(1:nytrns) END IF ELSE IF(Pcode.eq.1)THEN WRITE(Nform,1040)'transform',ytrans(1:nytrns) ELSE WRITE(Nform,1040)'aictrans',ytrans(1:nytrns) END IF 1030 FORMAT(' Transformation',/,' ',a) 1040 FORMAT(a,': ',a) c ------------------------------------------------------------------ RETURN END prtopt.f0000664006604000003110000000473514521201547011702 0ustar sun00315stepsC Last change: BCM 5 May 1998 4:00 pm SUBROUTINE prtopt(Lestim,Mxiter,Mxnlit) IMPLICIT NONE c----------------------------------------------------------------------- c prtopt.f, Release 1, Subroutine Version 1.5, Modified 16 Feb 1995. c----------------------------------------------------------------------- c Prints the nonlinear estimation options c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER cexact*(24),ceval*(40) LOGICAL Lestim INTEGER Mxiter,Mxnlit,nexact,neval c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- IF(Lextar.and.Lextma)THEN cexact='Exact ARMA' nexact=10 ELSE IF(Lextma)THEN cexact='Exact MA, conditional AR' nexact=24 ELSE cexact='Conditional' nexact=11 END IF c----------------------------------------------------------------------- IF(Lestim)THEN ceval='estimation' neval=10 ELSE IF(Iregfx.gt.0)THEN ceval='evaluation' neval=10 ELSE IF(Ncxy.gt.1)THEN ceval='evaluation with GLS regression estimates' neval=40 ELSE ceval='evaluation' neval=10 END IF WRITE(Mt1,1010)cexact(1:nexact),ceval(1:neval) 1010 FORMAT(' ',a,' likelihood ',a) c----------------------------------------------------------------------- IF(Lestim)THEN IF(Ncxy.gt.1)THEN WRITE(Mt1,1020)Mxiter 1020 FORMAT(' Max total ARMA iterations ',t39,i8) IF(Mxnlit.gt.0)WRITE(Mt1,1030)Mxnlit 1030 FORMAT(' Max ARMA iter''s w/in an IGLS iteration ',t39,i8) WRITE(Mt1,1040)Tol 1040 FORMAT(' Convergence tolerance ',t38,1p,g9.2) IF((.not.dpeq(Nltol,Tol)).OR.(.not.dpeq(Nltol0,100D0*Nltol))) & WRITE(Mt1,1050)Nltol 1050 FORMAT(' ARMA convergence tolerance',t38,1p,g9.2) c----------------------------------------------------------------------- ELSE IF(Mxnlit.gt.0)WRITE(Mt1,1020)Mxiter WRITE(Mt1,1040)Tol END IF END IF c----------------------------------------------------------------------- RETURN END prtous.i0000664006604000003110000000057214521201547011704 0ustar sun00315stepsC C... Variables in Common Block /prtous/ ... integer xotab,ptab,ntab,stab,caltab,uctab,patab,cytab, $ ltptab,ertab,rg0tab,rgsatab,stptab,stntab, $ utab,ctab,rtptab,rtsatab common /prtous/ xotab,ptab,ntab,stab,caltab,uctab,patab,cytab, $ ltptab,ertab,rg0tab,rgsatab,stptab,stntab,utab,ctab, $ rtptab,rtsatab prtref.f0000664006604000003110000003373614521201547011657 0ustar sun00315stepsC Last change: BCM 17 Jul 2003 6:22 pm SUBROUTINE prtref(Begxy,Nrxy,Fctdrp,Nfcst,Nbcst,Outdec,Lprtre, & Lsavre,Ftd,Fhol,Fao,Fls,Ftc,Fso,Fusr,Fsea,Fmv, & Fcyc,Nusrrg,Lseats,Rmcnst,Lprtrr,Lsavrr,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- c prtref.f, Release 1, Subroutine Version 1.5, Modified 20 Oct 1994. c----------------------------------------------------------------------- c Computes regression adjustments for the groups of regression c variables and the regression residuals. The groups are: the c constant, seasonal effects, trading day, holiday, ao outliers, c ls's and ramps, and user-defined effects. The adjustments c are done on the prior-adjusted and transformed scale. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'mdltbl.i' INCLUDE 'usrreg.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' * INCLUDE 'seatad.cmn' c ------------------------------------------------------------------ LOGICAL F,T INTEGER PTTL DOUBLE PRECISION ZERO PARAMETER(PTTL=14,ZERO=0D0,F=.false.,T=.true.) c ------------------------------------------------------------------ CHARACTER str*(PCOLCR),ttlstr*(120) DOUBLE PRECISION txy,Ftd,Fhol,Fao,Fls,Ftc,Fso,Fusr,Fmv,Fsea,fcyc, & dvec,trr LOGICAL Finao,Finhol,Lprtre,Lsavre,Finls,Fintc,Finusr,Lseats,lusr, & Rmcnst,Lprtrr,Lsavrr,Lgraf INTEGER Adjtd,Adjhol,Adjao,Adjls,Adjsea,Adjusr,Adjcyc,begeff, & Begxy,endeff,i,icol,ieff,irgeff,nchr,neff,Nrxy,nttl,nref, & regeff,rgefpt,rgeftp,ttlptr,rtype,iusr,Nusrrg,Adjso,Adjtc, & ibrr,ierr,Fctdrp,Nfcst,Nbcst,Outdec DIMENSION Begxy(2),regeff(11),Ftd(PLEN), & Fao(PLEN),Fls(PLEN),Ftc(PLEN),Fusr(PLEN),Fhol(PLEN), & Fmv(PLEN),ttlptr(0:PTTL),txy(PLEN*PTTL),Fsea(PLEN), & Fso(PLEN),Fcyc(PLEN),dvec(1),trr(PLEN) c----------------------------------------------------------------------- COMMON /x11adj/ Adjtd,Adjhol,Adjao,Adjls,Adjtc,Adjso,Adjsea, & Adjcyc,Adjusr,Finhol,Finao,Finls,Fintc,Finusr c----------------------------------------------------------------------- c Get the names from c ../dictionary/strary REF <../dictionary/effects.dic c----------------------------------------------------------------------- CHARACTER REFDIC*127 INTEGER refptr,PREF PARAMETER(PREF=14) DIMENSION refptr(0:PREF) PARAMETER(REFDIC='SeasonalTrading DayLength-of-MonthLength-of-Quar &terLeap YearHolidayAOLS and RampTCUser-definedMissing ValueSOConst &antTransitory') DATA refptr/1,9,20,35,52,61,68,70,81,83,95,108,110,118,128/ c----------------------------------------------------------------------- DIMENSION rgefpt(0:PREF),rgeftp(65) DATA rgefpt/1,8,21,28,32,36,46,49,56,58,59,60,62,64,66/ DATA rgeftp/ & PRGTSE,PRGTTS,PRGTUS,PRRTSE,PRRTTS,PRATSE,PRATTS,PRGTTD, & PRGTST,PRRTTD,PRRTST,PRATTD,PRATST,PRG1TD,PRR1TD,PRA1TD, & PRG1ST,PRR1ST,PRA1ST,PRGUTD,PRGTSL,PRRTSL,PRATSL,PRGTLM, & PRRTLM,PRATLM,PRGULM,PRGTLQ,PRRTLQ,PRATLQ,PRGULQ,PRGTLY, & PRRTLY,PRATLY,PRGULY,PRGTEA,PRGTEC,PRGTES,PRGTLD,PRGTTH, & PRGTUH,PRGUH2,PRGUH3,PRGUH4,PRGUH5,PRGTAO,PRGTAA,PRGUAO, & PRGTLS,PRGTRP,PRGTAL,PRGTTL,PRGTQD,PRGTQI,PRGULS,PRGTTC, & PRGTAT,PRGTUD,PRGTMV,PRGTSO,PRGUSO,PRGTCN,PRGUCN,PRGCYC, & PRGUCY/ c----------------------------------------------------------------------- c Initialize the titles c----------------------------------------------------------------------- CALL intlst(PTTL,ttlptr,nttl) c----------------------------------------------------------------------- c Find which regression effects there are. c----------------------------------------------------------------------- c if removeconstant = yes, also remove constant term - adjust c number of regression effects accordingly (BCM - July 2008) c----------------------------------------------------------------------- nref=PREF IF(.not.Rmcnst)nref=nref-1 DO irgeff=1,nref begeff=rgefpt(irgeff-1) endeff=rgefpt(irgeff)-1 DO icol=1,Nb DO ieff=begeff,endeff IF(Rgvrtp(icol).eq.rgeftp(ieff))THEN CALL getstr(REFDIC,refptr,PREF,irgeff,str,nchr) IF(.not.Lfatal)CALL insstr(str(1:nchr),nttl+1,PTTL,ttlstr, & ttlptr,nttl) IF(Lfatal)RETURN regeff(nttl)=irgeff GO TO 10 END IF END DO END DO 10 CONTINUE END DO c----------------------------------------------------------------------- c Total regression effects c----------------------------------------------------------------------- CALL insstr('Total Reg',nttl+1,PTTL,ttlstr,ttlptr,nttl) c----------------------------------------------------------------------- c Regression residuals c----------------------------------------------------------------------- IF(.not.Lfatal)CALL insstr('Reg Resids',nttl+1,PTTL,ttlstr,ttlptr, & nttl) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Calculate the factors. c----------------------------------------------------------------------- neff=nttl-2 dvec(1)=0.0D0 DO i=1,neff CALL dcopy(Nrxy,dvec,0,txy(i),nttl) irgeff=regeff(i) begeff=rgefpt(irgeff-1) endeff=rgefpt(irgeff)-1 c----------------------------------------------------------------------- c Find the next column of the given regression effect type c----------------------------------------------------------------------- DO icol=1,Nb DO ieff=begeff,endeff IF(Rgvrtp(icol).eq.rgeftp(ieff))THEN CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,txy(i),nttl) GO TO 20 END IF END DO 20 CONTINUE END DO END DO c----------------------------------------------------------------------- c Calculate the total regression effects c----------------------------------------------------------------------- CALL dcopy(Nrxy,dvec,0,txy(nttl-1),nttl) c CALL setdp(0D0,Nrxy,txy(nttl-1)) DO icol=1,neff CALL daxpy(Nrxy,1D0,txy(icol),nttl,txy(nttl-1),nttl) END DO c----------------------------------------------------------------------- c Calculate the regression residuals c----------------------------------------------------------------------- CALL dcopy(Nrxy,Xy(Ncxy),Ncxy,txy(nttl),nttl) CALL daxpy(Nrxy,-1D0,txy(nttl-1),nttl,txy(nttl),nttl) c ------------------------------------------------------------------ IF(Lprtre)THEN CALL prtmtx(Begxy,Sp,txy,Nrxy,nttl,ttlstr,ttlptr,nttl) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(Lsavre)THEN CALL savmtx(LESTRE,Begxy,Sp,txy,Nrxy,nttl,ttlstr,ttlptr,nttl) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If regression residuals are printed or saved, store the regression c residuals in a temporary variable trr. (BCM July 2008) c----------------------------------------------------------------------- IF(Lprtrr.or.Lsavrr.or.Lgraf)THEN ibrr=1 ierr=Nrxy-Nbcst-max(Nfcst-Fctdrp,0) IF(Nbcst.gt.0)THEN ibrr=ibrr+Nbcst ierr=ierr+Nfcst END IF DO i=ibrr,ierr trr(i-ibrr+1)=txy(i*nttl) END DO c----------------------------------------------------------------------- c print or save the regression residuals. (BCM July 2008) c----------------------------------------------------------------------- IF(Lprtrr)THEN CALL prtshd('Residuals from the Estimated Regression Effects', & Begspn,Sp,Nspobs,T) IF(Lfatal)RETURN CALL prttbl(Begspn,Sp,trr,Nspobs,'Data',Outdec) END IF IF(Lsavrr)THEN CALL savtbl(LESRRS,Begspn,1,Nspobs,Sp,trr,Serno,Nser,F) IF(Lfatal)RETURN END IF IF(Lgraf)THEN CALL savtbl(LESRRS,Begspn,1,Nspobs,Sp,trr,Serno,Nser,T) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ c Generate prior adjustment factors. First, initialize regression c factors to zero for SEATS adjustments c----------------------------------------------------------------------- IF(Lseats)CALL setdp(ZERO,PLEN,Fcyc) c----------------------------------------------------------------------- c determine type of regression variable c----------------------------------------------------------------------- iusr=1 DO icol=1,Nb lusr=F rtype=Rgvrtp(icol) IF(Nusrrg.gt.0)THEN IF(rtype.eq.PRGTUD)THEN rtype=Usrtyp(iusr) iusr=iusr+1 lusr=T ELSE IF((rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGTUS)THEN iusr=iusr+1 END IF END IF c----------------------------------------------------------------------- c Generate regARIMA trading day factors c----------------------------------------------------------------------- IF(Adjtd.eq.1.and. & ((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY))) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Ftd,1) c----------------------------------------------------------------------- c Generate regARIMA holiday factors c----------------------------------------------------------------------- IF(((Adjhol.eq.1).or.Finhol).and. & (rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES.or. & rtype.eq.PRGTLD.or.rtype.eq.PRGTTH.or. & (rtype.ge.PRGTUH.and.rtype.le.PRGUH5))) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fhol,1) c----------------------------------------------------------------------- c Generate regARIMA User-defined regression factors c----------------------------------------------------------------------- IF(((Adjusr.eq.1).or.Finusr).and.(rtype.eq.PRGTUD)) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fusr,1) c----------------------------------------------------------------------- c Generate regARIMA seasonal regression factors c source added to generate seasonal regression factor when SEATS c is specified for seasonal adjustment (BCM 04-10-05) c----------------------------------------------------------------------- IF((Adjsea.eq.1).and.((rtype.eq.PRGTUS).or.(Lseats.and. & (rtype.eq.PRGTSE.or.rtype.eq.PRGTTS.or.rtype.eq.PRRTSE.or. & rtype.eq.PRRTTS.or.rtype.eq.PRATSE.or.rtype.eq.PRATTS)))) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fsea,1) c----------------------------------------------------------------------- c Generate regARIMA AO outlier factors c----------------------------------------------------------------------- IF(((Adjao.eq.1).or.Finao).and. & (rtype.eq.PRGTAO.or.rtype.eq.PRGTAA.or.rtype.eq.PRGUAO)) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fao,1) c----------------------------------------------------------------------- c Generate regARIMA Level Change Outlier factors c----------------------------------------------------------------------- IF(((Adjls.eq.1).or.Finls).and.(rtype.eq.PRGTLS.or. & rtype.eq.PRGTRP.or.rtype.eq.PRGTAL.or.rtype.eq.PRGTTL.or. & rtype.eq.PRGTQI.or.rtype.eq.PRGTQD.or.rtype.eq.PRGULS)) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fls,1) c----------------------------------------------------------------------- c Generate regARIMA Temporary Change Outlier factors c----------------------------------------------------------------------- IF(((Adjtc.eq.1).or.Fintc).and.(rtype.eq.PRGTTC.or. & rtype.eq.PRGTAT)) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Ftc,1) c----------------------------------------------------------------------- c Generate regARIMA MV outlier factors c----------------------------------------------------------------------- IF(rtype.eq.PRGTMV)CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fmv,1) c----------------------------------------------------------------------- c Generate regARIMA SO outlier factors c----------------------------------------------------------------------- * IF((Adjso.eq.1).and.(rtype.eq.PRGTSO.or.rtype.eq.PRGTAS)) IF((Adjso.eq.1).and.rtype.eq.PRGTSO.or.rtype.eq.PRGUSO) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fso,1) c----------------------------------------------------------------------- c Generate regARIMA transitory component for SEATS adjustments c (Aug 2004 - BCM) c----------------------------------------------------------------------- IF(Lseats.and.lusr)THEN IF(rtype.eq.PRGCYC)THEN CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fcyc,1) IF(Adjcyc.eq.0)Adjcyc=1 END IF END IF c----------------------------------------------------------------------- END DO c----------------------------------------------------------------------- RETURN END prtrev.f0000664006604000003110000006706614521201547011702 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:50 pm SUBROUTINE prtrev(Fin,Cnc,Revspn,Tbltyp,Nptr,Ntargt,Vtargt,Lsumm, & Lgraf,Lr1y2y) c----------------------------------------------------------------------- c Print and/or save a table of the percent revision, concurrent c and final value of seasonally adjusted series, seasonal factors, c trend component or month to month changes. c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'tfmts.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'dgnsvl.i' INCLUDE 'units.cmn' INCLUDE 'cchars.i' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- INCLUDE 'tbltitle.prm' INCLUDE 'desdgn.prm' c----------------------------------------------------------------------- LOGICAL F,T INTEGER MO,YR,PCOL,PCOLRV,PC1 DOUBLE PRECISION PCT,ONE,ZERO PARAMETER(MO=2,YR=1,F=.false.,T=.true.,PCOLRV=23,PCT=100D0, & ONE=1D0,ZERO=0D0,PCOL=PTARGT+1,PC1=PCOL+1) c----------------------------------------------------------------------- CHARACTER cobs*(13),cpobs*(3),tfmt1*(110),tblttl*(PTTLEN), & hdrttl*(PCOLRV*PC1),hd2ttl*(PCOLRV*PC1),tfmt2*(110), & outstr*(6+(23*PC1)),revlbl*(20),laglbl*(5),brklbl*(7) DOUBLE PRECISION Cnc,Fin,rev,tmp,trev,aarpd,aaryr,aartot,narpd, & naryr,nartot,fin1yr,ts,revhng,drv,xtmp INTEGER i,j,Revspn,fh,fh2,Tbltyp,Nptr,k,k2,i3,ielt,ipos,lstrev, & idate,rdbdat,ntbttl,ncol,i2,i0,npos,iper,hdrptr,hd2ptr, & nhdr,nhd2,iyr,nstr,rnum,tbw,end2,k3,nlbl,Vtargt,Ntargt, & nhdrtl,nhd2tl,Lsumm LOGICAL Lgraf,locok,Lr1y2y DIMENSION Cnc(PREV),Fin(0:PTARGT,PREV),rev(0:PCOL,PREV),Revspn(2), & trev(PREV+12),idate(2),tmp(0:2,PREV),ts(5),cpobs(16), & Vtargt(PTARGT),aarpd(0:PCOL,12),aaryr(0:PCOL,PREVY), & aartot(0:PCOL,1),narpd(0:PCOL,12),naryr(0:PCOL,PREVY), & nartot(0:PCOL,1),hdrptr(0:PC1),hd2ptr(0:PC1), & revhng(0:PCOL,5) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- INCLUDE 'desdgn.var' DATA cpobs/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec','1st','2nd','3rd','4th'/ c----------------------------------------------------------------------- c Set logical variable to determine if percent revisions are to be c printed out c----------------------------------------------------------------------- locok=T Rvper=T IF(Tbltyp.eq.2.or.Tbltyp.eq.5)THEN Rvper=F ELSE IF(Muladd.eq.1)THEN IF(Tbltyp.eq.6.or.Rvdiff.eq.1)THEN Rvper=F ELSE i=Begrev DO WHILE(i.le.Endtbl.and.Rvper) IF(Cnc(i-Begrev+1).le.0)Rvper=F i=i+1 END DO END IF END IF c----------------------------------------------------------------------- IF((.not.(Tbltyp.eq.2.or.Tbltyp.eq.5)).and.Lsumm.gt.0)THEN IF(Rvper)THEN WRITE(Nform,1010)Tbltyp,'percent' ELSE WRITE(Nform,1010)Tbltyp,'difference' END IF 1010 FORMAT('r',i2.2,'.aarmode: ',a) END IF c----------------------------------------------------------------------- c Initialize values for printing tables c----------------------------------------------------------------------- ncol=Ntargt IF(Lr1y2y)ncol=ncol+1 c----------------------------------------------------------------------- c Generate table format c----------------------------------------------------------------------- IF(Prttab(Nptr).or.Prttab(Nptr+1).or.Svltab(LSLASA+Tbltyp-1))THEN npos=21 WRITE(tfmt1,1020)ncol+1 1020 FORMAT('(1x,a5,1x,',i1,'(1x,f9.2))') WRITE(tfmt2,1030)ncol+1 1030 FORMAT('(2x,i4,1x,',i1,'(1x,f9.2))') END IF c----------------------------------------------------------------------- c create column headers c----------------------------------------------------------------------- IF(Prttab(Nptr).or.Prttab(Nptr+1))THEN CALL intlst(PCOL+1,hdrptr,nhdrtl) nhdr=nhdrtl+1 DO i2=ncol,0,-1 IF(i2.eq.ncol.and.Lr1y2y)THEN ipos=1 CALL itoc(Ny,cobs,ipos) CALL insstr(cobs(1:(ipos-1))//' later-',nhdr,PC1,hdrttl, & hdrptr,nhdrtl) ELSE IF(Cnctar.or.i2.eq.0)THEN CALL insstr('Conc -',nhdr,PC1,hdrttl,hdrptr,nhdrtl) ELSE ipos=1 CALL itoc(Vtargt(i2),cobs,ipos) CALL insstr(cobs(1:(ipos-1))//' later-',nhdr,PC1,hdrttl, & hdrptr,nhdrtl) END IF END IF IF(Lfatal)RETURN END DO CALL intlst(PC1,hd2ptr,nhd2tl) nhd2=nhd2tl+1 DO i2=ncol,0,-1 IF(i2.eq.ncol.and.Lr1y2y)THEN ipos=1 CALL itoc(2*Ny,cobs,ipos) CALL insstr(cobs(1:(ipos-1))//' later ',nhd2,PC1,hd2ttl, & hd2ptr,nhd2tl) ELSE IF((.not.Cnctar).or.i2.eq.0)THEN CALL insstr('Final ',nhd2,PC1,hd2ttl,hd2ptr,nhd2tl) ELSE ipos=1 CALL itoc(Vtargt(i2),cobs,ipos) CALL insstr(cobs(1:(ipos-1))//' later ',nhd2,PC1,hd2ttl, & hd2ptr,nhd2tl) END IF END IF IF(Lfatal)RETURN END DO END IF c----------------------------------------------------------------------- c Intitalize variables for summary tables c----------------------------------------------------------------------- iper=Revspn(MO)-1 iyr=1 CALL setdp(0D0,PC1*12,aarpd) CALL setdp(0D0,PC1*PREVY,aaryr) CALL setdp(0D0,PC1,aartot) CALL setdp(0D0,PC1*12,narpd) CALL setdp(0D0,PC1*PREVY,naryr) CALL setdp(0D0,PC1,nartot) c----------------------------------------------------------------------- c Compute revision for given estimate c----------------------------------------------------------------------- DO i=Begrev,Endtbl-1 Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Set indexes for summary tables c----------------------------------------------------------------------- iper=iper+1 IF(iper.gt.Ny)THEN iper=1 iyr=iyr+1 END IF c----------------------------------------------------------------------- c Calculate the (percent) revision between the concurrent and final c adjustments. c----------------------------------------------------------------------- DO i2=0,Ntargt lstrev=Endsa IF(i2.gt.0)lstrev=lstrev-Vtargt(i2) IF(Cnctar)lstrev=lstrev+1 IF(i2.gt.0.and.i.ge.lstrev)THEN rev(i2,Revptr)=DNOTST ELSE IF(Cnctar.or.i2.eq.0)THEN rev(i2,Revptr)=Fin(i2,Revptr)-Cnc(Revptr) IF(Rvper)rev(i2,Revptr)=(rev(i2,Revptr)/Cnc(Revptr))*PCT ELSE rev(i2,Revptr)=Fin(0,Revptr)-Fin(i2,Revptr) IF(Rvper)rev(i2,Revptr)=(rev(i2,Revptr)/Fin(i2,Revptr))*PCT END IF c----------------------------------------------------------------------- c Keep track of summary statistics c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Lsumm.gt.0)THEN drv=dabs(rev(i2,Revptr)) aarpd(i2,iper)=aarpd(i2,iper)+drv narpd(i2,iper)=narpd(i2,iper)+ONE aaryr(i2,iyr)=aaryr(i2,iyr)+drv naryr(i2,iyr)=naryr(i2,iyr)+ONE aartot(i2,1)=aartot(i2,1)+drv nartot(i2,1)=nartot(i2,1)+ONE END IF END IF c----------------------------------------------------------------------- IF(Lr1y2y.and.i2.gt.0)THEN IF(Vtargt(i2).eq.Ny)fin1yr=Fin(i2,Revptr) IF(Vtargt(i2).eq.2*Ny)THEN c IF(i.ge.Endsa-Vtargt(i2)+1)THEN IF(i.ge.Endsa-Vtargt(i2))THEN rev(ncol,Revptr)=DNOTST ELSE rev(ncol,Revptr)=Fin(i2,Revptr)-fin1yr IF(Rvper)rev(ncol,Revptr)=(rev(ncol,Revptr)/fin1yr)*PCT c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Svltab(LSLASA+Tbltyp-1).or. & Lsumm.gt.0)THEN drv=dabs(rev(ncol,Revptr)) aarpd(ncol,iper)=aarpd(ncol,iper)+drv narpd(ncol,iper)=narpd(ncol,iper)+ONE aaryr(ncol,iyr)=aaryr(ncol,iyr)+drv naryr(ncol,iyr)=naryr(ncol,iyr)+ONE aartot(ncol,1)=aartot(ncol,1)+drv nartot(ncol,1)=nartot(ncol,1)+ONE END IF c----------------------------------------------------------------------- END IF END IF END IF END DO END DO IF(Prttab(Nptr))THEN c----------------------------------------------------------------------- c First, print out header information c----------------------------------------------------------------------- CALL makttl(DSDDIC,dsdptr,PDSD,Nptr,PDSUM6,tblttl,ntbttl,T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),Revspn,Ny,Revnum,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print out table c----------------------------------------------------------------------- i0=0 j=Revspn(YR)-1 i=Begrev i2=Begrev+Ny-Revspn(MO) i3=Revspn(MO) DO WHILE (i.lt.Endtbl) IF(i2.ge.Endtbl)i2=Endtbl-1 j=j+1 ipos=1 CALL itoc(j,cobs,ipos) CALL prrvob(rev,Ncol,i-Begrev+1,i2-Begrev+1,1,1, & cobs,ipos-1,hdrttl,hdrptr,nhdrtl,hd2ttl,hd2ptr, & nhd2tl,i0,tfmt1(1:npos),i3,PCOL,PC1,9, & tblttl(1:ntbttl),F) IF(Lfatal)RETURN IF(i.eq.Begrev)i3=1 i=i2+1 i2=i2+Ny END DO END IF c----------------------------------------------------------------------- c print out summary tables, if necessary. c----------------------------------------------------------------------- IF(Prttab(Nptr+1))THEN c----------------------------------------------------------------------- c First, print out header information c----------------------------------------------------------------------- CALL makttl(DSDDIC,dsdptr,PDSD,Nptr+1,PDSUM6,tblttl,ntbttl,T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),Revspn,Ny,0,T) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Compute summary statistics c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Lsumm.gt.0.or.Svltab(LSLASA+Tbltyp-1))THEN DO j=0,ncol IF(dpeq(nartot(j,1),ZERO))THEN aartot(j,1)=DNOTST ELSE aartot(j,1)=aartot(j,1)/nartot(j,1) END IF DO i=1,max(Ny,iyr) IF(i.le.Ny)THEN IF(dpeq(narpd(j,i),ZERO))THEN aarpd(j,i)=DNOTST ELSE aarpd(j,i)=aarpd(j,i)/narpd(j,i) END IF END IF IF(i.le.iyr)THEN IF(dpeq(naryr(j,i),ZERO))THEN aaryr(j,i)=DNOTST ELSE aaryr(j,i)=aaryr(j,i)/naryr(j,i) END IF END IF END DO END DO END IF c----------------------------------------------------------------------- c First, print out absolute average for each period. c----------------------------------------------------------------------- IF(Prttab(Nptr+1))THEN i0=0 IF(Ny.eq.12)THEN cobs='Months: ' nstr=7 ELSE cobs='Quarters: ' nstr=9 END IF CALL prrvob(aarpd,Ncol,1,Ny,1,1,cobs,nstr,hdrttl,hdrptr,nhdrtl, & hd2ttl,hd2ptr,nhd2tl,i0,tfmt1(1:npos),1,PCOL,PC1,9, & tblttl(1:ntbttl),T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Then, print out absolute average for each year. c----------------------------------------------------------------------- cobs='Years: ' nstr=6 CALL prrvob(aaryr,Ncol,1,iyr,1,2,cobs,nstr,hdrttl,hdrptr,nhdrtl, & hd2ttl,hd2ptr,nhd2tl,i0,tfmt2(1:npos),Revspn(YR)-1, & PCOL,PC1,9,tblttl(1:ntbttl),T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Finally, print out the total absolute average. c----------------------------------------------------------------------- cobs='Total: ' CALL prrvob(aartot,Ncol,1,1,1,0,cobs,nstr,hdrttl,hdrptr,nhdrtl, & hd2ttl,hd2ptr,nhd2tl,i0,tfmt1(1:npos),Revspn(YR)-1, & PCOL,PC1,9,tblttl(1:ntbttl),T) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Compute hinge statistics for the absolute revisions c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Lsumm.gt.0)THEN DO i=0,ncol i2=0 DO k=1,INT(nartot(i,1)) i2=i2+1 trev(i2)=dabs(rev(i,k)) END DO CALL hinge(trev,i2,ts,xtmp,0) DO k=1,5 revhng(i,k)=ts(k) END DO END DO END IF IF(Prttab(Nptr+1))THEN cobs='Hinge Values:' CALL prrvob(revhng,Ncol,1,5,1,3,cobs,13,hdrttl,hdrptr,nhdrtl, & hd2ttl,hd2ptr,nhd2tl,i0,tfmt1(1:npos),1,PCOL,PC1,9, & tblttl(1:ntbttl),T) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Save absolute average revision between concurrent and final, if c requested. c----------------------------------------------------------------------- IF(Svltab(LSLASA+Tbltyp-1))THEN IF(Tbltyp.eq.1)THEN nlbl=13 revlbl(1:nlbl)='Seasonal Adj.' ELSE IF(Tbltyp.eq.2)THEN nlbl=15 revlbl(1:nlbl)='Changes in Adj.' ELSE IF(Tbltyp.eq.3)THEN nlbl=18 revlbl(1:nlbl)='Ind. Seasonal Adj.' ELSE IF(Tbltyp.eq.4)THEN nlbl=5 revlbl(1:nlbl)='Trend' ELSE IF(Tbltyp.eq.5)THEN nlbl=16 revlbl(1:nlbl)='Changes in Trend' END IF WRITE(Ng,1050)revlbl(1:nlbl),aartot(0,1) c----------------------------------------------------------------------- c IF(ncol.gt.0)THEN c DO i=1,ncol c IF(i.eq.ncol.and.Lr1y2y)THEN c WRITE(Ng,1051)revlbl(1:nlbl),aartot(i,1) c ELSE c WRITE(Ng,1052)revlbl(1:nlbl),aartot(i,1),Vtargt(i) c END IF c END DO c END IF c----------------------------------------------------------------------- END IF 1050 FORMAT(' AveAbsRev of ',a,' : ',t40,f10.3) c 1051 FORMAT(' AveAbsRev of ',a,t40,f10.3,', 2yr-1yr After') c 1052 FORMAT(' AveAbsRev of ',a,t40,f10.3,', ',i2,' Lag(s) After') c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN DO j=0,ncol c----------------------------------------------------------------------- IF(j.eq.ncol.and.Lr1y2y)THEN laglbl='d2y1y' ELSE IF(j.eq.0)THEN laglbl='lag00' ELSE WRITE(laglbl,1048)Vtargt(j) END IF c----------------------------------------------------------------------- WRITE(Nform,1049)Tbltyp,laglbl,'aar.all',aartot(j,1) c----------------------------------------------------------------------- i2=0 IF(Ny.eq.4)i2=12 DO i=1,Ny IF(.not.dpeq(aarpd(j,i),DNOTST))THEN WRITE(brklbl,1047)'p',i WRITE(Nform,2049)Tbltyp,laglbl,brklbl,cpobs(i+i2),aarpd(j,i) END IF END DO c----------------------------------------------------------------------- i2=Revspn(YR)-1 DO i=1,iyr IF(.not.dpeq(aaryr(j,i),DNOTST))THEN WRITE(brklbl,1047)'y',i WRITE(Nform,3049)Tbltyp,laglbl,brklbl,i+i2,aaryr(j,i) END IF END DO c----------------------------------------------------------------------- WRITE(Nform,1053)Tbltyp,laglbl,'hinge.min',revhng(j,1) WRITE(Nform,1053)Tbltyp,laglbl,'hinge.25p',revhng(j,2) WRITE(Nform,1053)Tbltyp,laglbl,'hinge.med',revhng(j,3) WRITE(Nform,1053)Tbltyp,laglbl,'hinge.75p',revhng(j,4) WRITE(Nform,1053)Tbltyp,laglbl,'hinge.max',revhng(j,5) END DO c----------------------------------------------------------------------- 1047 FORMAT('aar.',a,i2.2) 1048 FORMAT('lag',i2.2) 1049 FORMAT('r0',i1,'.',a,'.',a,': ',E17.10) 2049 FORMAT('r0',i1,'.',a,'.',a,': ',a,' ',E17.10) 3049 FORMAT('r0',i1,'.',a,'.',a,': ',i4,' ',E17.10) 1053 FORMAT('r0',i1,'.',a,'.',a,': ',E17.10) END IF c----------------------------------------------------------------------- c If concurrent and final adjustments are to be printed, print out c title. c----------------------------------------------------------------------- IF(Prttab(Nptr+2))THEN c----------------------------------------------------------------------- c Print out header information c----------------------------------------------------------------------- CALL makttl(DSDDIC,dsdptr,PDSD,Nptr+2,PDSUM6,tblttl,ntbttl,T,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- npos=31 tbw=Tblwid IF(Tblwid.lt.10)tbw=10 IF(Tbltyp.eq.2.or.Tbltyp.eq.5)THEN WRITE(tfmt1,1021)tbw,2,tbw WRITE(tfmt2,1031)tbw,2,tbw ELSE WRITE(tfmt1,1021)tbw,1,tbw WRITE(tfmt2,1031)tbw,1,tbw END IF 1021 FORMAT('(1x,a5,1x,2(1x,f',i2,'.',i1,'),1x,f',i2,'.2)') 1031 FORMAT('(2x,i4,1x,2(1x,f',i2,'.',i1,'),1x,f',i2,'.2)') c----------------------------------------------------------------------- DO i=0,Ntargt i0=0 c----------------------------------------------------------------------- c Create data dictionary for column headers c----------------------------------------------------------------------- CALL intlst(PC1,hdrptr,nhdrtl) nhdr=nhdrtl+1 CALL insstr('Revision',nhdr,PC1,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN IF(Cnctar.or.i.eq.0)THEN CALL insstr('Final',nhdr,PC1,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN rnum=Revnum ELSE ipos=1 CALL itoc(Vtargt(i),cobs,ipos) CALL insstr(cobs(1:(ipos-1))//' later',nhdr,PC1,hdrttl,hdrptr, & nhdrtl) IF(Lfatal)RETURN rnum=Revnum-Vtargt(i) END IF IF(Cnctar.or.i.eq.0)THEN CALL insstr('Concurrent',nhdr,PC1,hdrttl,hdrptr,nhdrtl) ELSE CALL insstr('Final',nhdr,PC1,hdrttl,hdrptr,nhdrtl) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- CALL prtshd(tblttl(1:ntbttl),Revspn,Ny,rnum,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- DO j=1,rnum IF(Cnctar.or.i.eq.0)THEN tmp(0,j)=Cnc(j) ELSE tmp(0,j)=Fin(0,j) END IF tmp(1,j)=Fin(i,j) tmp(2,j)=rev(i,j) END DO c----------------------------------------------------------------------- IF(i.gt.0)THEN end2=Endsa-(Vtargt(i)+1) if(end2.gt.Endtbl-1)end2=Endtbl-1 ELSE end2=Endtbl-1 END IF j=Revspn(YR)-1 k=Begrev k2=Begrev+Ny-Revspn(MO) k3=Revspn(MO) DO WHILE (k.le.end2) IF(k2.gt.end2)k2=end2 j=j+1 ipos=1 CALL itoc(j,cobs,ipos) CALL prrvob(tmp,2,k-Begrev+1,k2-Begrev+1,1,1,cobs,ipos-1, & hdrttl,hdrptr,nhdrtl,hd2ttl,hd2ptr,0,i0, & tfmt1(1:npos),k3,2,3,tbw,tblttl(1:ntbttl),F) IF(Lfatal)RETURN IF(k.eq.Begrev)k3=1 k=k2+1 k2=k2+Ny END DO END DO END IF c----------------------------------------------------------------------- c If percent revisions are to be saved, open file for saved c revisions. c----------------------------------------------------------------------- IF(Savtab(Nptr))THEN CALL opnfil(T,F,Nptr,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for revisions c----------------------------------------------------------------------- IF(Tbltyp.eq.1)THEN nlbl=11 revlbl(1:nlbl)='SA_revision' ELSE IF(Tbltyp.eq.2)THEN nlbl=13 revlbl(1:nlbl)='CHNG_revision' ELSE IF(Tbltyp.eq.3)THEN nlbl=15 revlbl(1:nlbl)='Ind_SA_revision' ELSE IF(Tbltyp.eq.4)THEN nlbl=13 revlbl(1:nlbl)='TRND_revision' ELSE IF(Tbltyp.eq.5)THEN nlbl=18 revlbl(1:nlbl)='CHNG_TRND_revision' ELSE IF(Tbltyp.eq.6)THEN nlbl=11 revlbl(1:nlbl)='SF_revision' END IF c----------------------------------------------------------------------- CALL intlst(PC1,hdrptr,nhdrtl) nhdr=nhdrtl+1 IF(Ntargt.gt.0)THEN IF(Lr1y2y)THEN CALL insstr(revlbl(1:(nlbl-5))//'(1yr-2yr)',nhdr,PC1,hdrttl, & hdrptr,nhdrtl) IF(Lfatal)RETURN END IF DO i=Ntargt,1,-1 ipos=1 CALL itoc(Vtargt(i),cobs,ipos) CALL insstr(revlbl(1:(nlbl-5))//'('//cobs(1:(ipos-1))//')', & nhdr,PC1,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN END DO END IF CALL insstr(revlbl(1:nlbl),nhdr,PC1,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN WRITE(fh,1040)'date',(TABCHR, & hdrttl(hdrptr(ielt):hdrptr(ielt+1)-1),ielt=0,ncol) WRITE(fh,1040)'----',(TABCHR,'-----------------------', & ielt=0,ncol) c----------------------------------------------------------------------- c begin looping though observations c----------------------------------------------------------------------- DO i=Begrev,Endtbl-1 Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Set date of revision for observation Revptr c----------------------------------------------------------------------- CALL addate(Revspn,Ny,Revptr-1,idate) rdbdat=100*idate(YR)+idate(MO) c----------------------------------------------------------------------- c Save revision measure with date c----------------------------------------------------------------------- ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN DO k=0,ncol outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(rev(k,Revptr),outstr,ipos) IF(Lfatal)RETURN END DO WRITE(fh,1040)outstr(1:ipos-1) END DO CALL fclose(fh) END IF c----------------------------------------------------------------------- c If concurrent and final adjustments are to be saved, open file for c saved adjustments. c----------------------------------------------------------------------- IF(Savtab(Nptr+2).or.Lgraf)THEN ncol=0 IF(Savtab(Nptr+2))CALL opnfil(T,F,Nptr+2,fh,locok) IF(locok.and.Lgraf)CALL opnfil(T,Lgraf,Nptr+2,fh2,locok) IF(.not.locok)THEN CALL abend() RETURN END IF c----------------------------------------------------------------------- c Print header for revisions c----------------------------------------------------------------------- IF(Tbltyp.eq.1)THEN nlbl=3 revlbl(1:nlbl)='_SA' ELSE IF(Tbltyp.eq.2)THEN nlbl=5 revlbl(1:nlbl)='_CHNG' ELSE IF(Tbltyp.eq.3)THEN nlbl=7 revlbl(1:nlbl)='_Ind_SA' ELSE IF(Tbltyp.eq.4)THEN nlbl=5 revlbl(1:nlbl)='_TRND' ELSE IF(Tbltyp.eq.5)THEN nlbl=10 revlbl(1:nlbl)='_CHNG_TRND' END IF CALL intlst(PC1,hdrptr,nhdrtl) nhdr=nhdrtl+1 IF(Ntargt.gt.0)THEN DO i=Ntargt,1,-1 ipos=1 CALL itoc(Vtargt(i),cobs,ipos) IF(Vtargt(i).le.9)THEN CALL insstr('Conc(0'//cobs(1:(ipos-1))//')'//revlbl(1:nlbl), & nhdr,PC1,hdrttl,hdrptr,nhdrtl) ELSE CALL insstr('Conc('//cobs(1:(ipos-1))//')'//revlbl(1:nlbl), & nhdr,PC1,hdrttl,hdrptr,nhdrtl) END IF IF(Lfatal)RETURN END DO END IF CALL insstr('Final'//revlbl(1:nlbl),nhdr,PC1,hdrttl,hdrptr, & nhdrtl) IF(.not.Lfatal)CALL insstr('Conc'//revlbl(1:nlbl),nhdr,PC1, & hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN IF(Savtab(Nptr+2))THEN WRITE(fh,1040)'date',(TABCHR, & hdrttl(hdrptr(ielt-1):(hdrptr(ielt)-1)),ielt=1, & nhdrtl) WRITE(fh,1040)'----',(TABCHR,'-----------------------', & ielt=1,nhdrtl) END IF IF(Lgraf)THEN WRITE(fh2,1040)'date',(TABCHR, & hdrttl(hdrptr(ielt-1):(hdrptr(ielt)-1)),ielt=1, & nhdrtl) WRITE(fh2,1040)'----',(TABCHR,'-----------------------', & ielt=1,nhdrtl) END IF c----------------------------------------------------------------------- c begin looping though observations c----------------------------------------------------------------------- DO i=Begrev,Endtbl-1 Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Set date for ith revision c----------------------------------------------------------------------- CALL addate(Revspn,Ny,Revptr-1,idate) rdbdat=100*idate(YR)+idate(MO) c----------------------------------------------------------------------- c Save concurrent and final adjustments with date c----------------------------------------------------------------------- ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Cnc(Revptr),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Fin(0,Revptr),outstr,ipos) IF(Lfatal)RETURN DO k=1,Ntargt outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Fin(k,Revptr),outstr,ipos) IF(Lfatal)RETURN END DO IF(Savtab(Nptr+2))WRITE(fh,1040)outstr(1:ipos-1) IF(Lgraf)WRITE(fh2,1040)outstr(1:ipos-1) END DO IF(Savtab(Nptr+2))CALL fclose(fh) IF(Lgraf)CALL fclose(fh2) END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1040 FORMAT(1000a) END prtrts.f0000664006604000003110000001437014521201547011704 0ustar sun00315stepsC Last change: BCM 25 Jun 1998 10:10 am SUBROUTINE prtrts(Lprt,Lsav,Lsvlg,Ldiag) IMPLICIT NONE c----------------------------------------------------------------------- c Prints out the roots of phi(B)=0 and theta(B)=0; each root has c four components: Real, Imaginary, Module, and Frequency c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c dotln c Local pgrpcr character dotted line under the model title c degree i Maximum lag of phi(B) or theta(B) c degp1 i degree + 1 c coeff d Coefficients of phi(B) or theta(B) in order of increasing c powers c rcoef d Coefficients of phi(B) or theta(B) in order of decreasing c powers c zeror d Real part of the roots c zeroi d Imaginary part of the roots c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'mdltbl.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER lower1*(1),lower2*(4),dotln*(POPRCR+1),tmpttl*(POPRCR), & outstr*(100) LOGICAL allinv,Lprt,Lsav,Lsvlg,Ldiag,fcnok INTEGER i,i2,k,beglag,begopr,endlag,endopr,factor,iflt,ilag,iopr, & ntmpcr,degree,spchr,fh,ipos DOUBLE PRECISION coeff(PORDER+1),zeror(PORDER),zeroi(PORDER), & zerom(PORDER),zerof(PORDER) DATA dotln/ & ' -----------------------------------------------------------' & / c----------------------------------------------------------------------- c Print out the roots of phi(B)=0 and theta(B)=0 with AR part first c----------------------------------------------------------------------- begopr=Mdl(AR-1) beglag=Opr(begopr-1) endopr=Mdl(MA)-1 c ------------------------------------------------------------------ c Nov 2005 BCM - add statement to avoid printing out root table c when no ARMA operators are in the model IF(endopr.gt.0.and.begopr.le.endopr)THEN endlag=Opr(endopr)-1 c ------------------------------------------------------------------ IF(Lprt)WRITE(Mt1,1010)Mdlttl(1:Nmdlcr),dotln IF(Lsvlg)WRITE(Ng,1010)Mdlttl(1:Nmdlcr),dotln 1010 FORMAT(/,' Roots of ',a,/,' Root',t25,'Real',t31,'Imaginary', & t44,'Modulus',t53,'Frequency',/,a) IF(Lsav)THEN CALL opnfil(T,F,LESTRT,fh,fcnok) IF(.not.fcnok)THEN CALL abend RETURN END IF WRITE(fh,1011)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR,TABCHR, & TABCHR,TABCHR,TABCHR,TABCHR,TABCHR,TABCHR 1011 FORMAT('Operator',a,'Factor',a,'Root',a,'Real',a,'Imaginary',a, & 'Modulus',a,'Frequency',/,'--------',a,'------',a, & '----',a,'----',a,'---------',a,'-------',a,'---------') END IF c ------------------------------------------------------------------ DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(Lprt)WRITE(Mt1,1020)tmpttl(1:ntmpcr) IF(Lsvlg)WRITE(Ng,1020)tmpttl(1:ntmpcr) IF(Lsav.or.Ldiag)THEN DO spchr=ntmpcr,1,-1 IF(tmpttl(spchr:spchr).eq.' ')GO TO 10 END DO spchr=1 END IF 1020 FORMAT(' ',a,t35) c ------------------------------------------------------------------ 10 factor=Oprfac(iopr) degree=Arimal(endlag)/factor coeff(1)=-1.0D0 CALL setdp(0D0,degree,coeff(2)) c DO i=2,degree+1 c coeff(i)=0.d0 c END DO c ------------------------------------------------------------------ DO ilag=beglag,endlag coeff(Arimal(ilag)/factor+1)=Arimap(ilag) END DO CALL roots(coeff,degree,allinv,zeror,zeroi,zerom,zerof) IF(Lfatal)RETURN c ------------------------------------------------------------------ DO i=1,degree IF(Lprt)WRITE(Mt1,1030)i,zeror(i),zeroi(i),zerom(i),zerof(i) IF(Lsvlg)WRITE(Ng,1030)i,zeror(i),zeroi(i),zerom(i),zerof(i) 1030 FORMAT(' Root',i3,t18,4F11.4) IF(Lsav.or.Ldiag)THEN ipos=1 CALL dtoc(zeror(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(zeroi(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(zerom(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(zerof(i),outstr,ipos) IF(Lfatal)RETURN IF(Lsav)THEN WRITE(fh,1031)tmpttl(spchr+1:ntmpcr),TABCHR, & tmpttl(1:spchr-1),TABCHR,i,TABCHR, & outstr(1:(ipos-1)) END IF IF(Ldiag)THEN lower1=CHAR(ICHAR(tmpttl(1:1))+32) DO k=spchr+1,ntmpcr i2=k-spchr lower2(i2:i2)=CHAR(ICHAR(tmpttl(k:k))+32) END DO WRITE(Nform,1031)'roots.'//lower2(1:i2),'.', & lower1//tmpttl(2:spchr-1),'.',i,': ', & outstr(1:(ipos-1)) END IF 1031 FORMAT(a,a,a,a,i2.2,a,a) END IF END DO END DO END DO IF(Lprt)WRITE(Mt1,1040)dotln IF(Lsvlg)WRITE(Ng,1041)dotln IF(Lsav)CALL fclose(fh) END IF c ------------------------------------------------------------------ 1040 FORMAT(a) 1041 FORMAT(a,/) RETURN END prtrv2.f0000664006604000003110000005325514521201547011612 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:50 pm SUBROUTINE prtrv2(Fin,Cnc,Cnc2,Revspn,Nptr,Lsumm,Lgraf) c----------------------------------------------------------------------- c Print and/or save a table of the percent revision, concurrent c and final value of the regular (cnc) and projected (cnc2) seasonal c factors. c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'dgnsvl.i' INCLUDE 'units.cmn' INCLUDE 'cchars.i' INCLUDE 'tfmts.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- INCLUDE 'tbltitle.prm' INCLUDE 'desdgn.prm' c----------------------------------------------------------------------- LOGICAL F,T INTEGER MO,YR,PCOLRV,PNCHDR PARAMETER(MO=2,YR=1,F=.false.,T=.true.,PCOLRV=23,PNCHDR=6) c----------------------------------------------------------------------- CHARACTER cobs*(13),cpobs*(3),tfmt1*(110),tblttl*(PTTLEN), & hdrttl*(PCOLRV*PNCHDR),hd2ttl*(PCOLRV*PNCHDR), & tfmt2*(110),outstr*(6+(23*3)),brklbl*(7) DOUBLE PRECISION Cnc,Cnc2,Fin,rev,tmp,trev,aarpd,aaryr,aartot, & narpd,naryr,nartot,ts,revhng,drv,xtmp INTEGER i,j,Lsumm,Revspn,fh,fh2,Nptr,k,k2,i3,ielt,ipos, & idate,ntbttl,ncol,i2,i0,npos, & iper,hdrptr,hd2ptr,rdbdat,nhdr,nhd2,iyr, & nstr,tbw,end2,k3,nhdrtl,nhd2tl LOGICAL Lgraf,locok DIMENSION Cnc(PREV),Cnc2(PREV),Fin(PREV),rev(0:1,PREV),Revspn(2), & trev(PREV+12),idate(2),tmp(0:5,PREV),ts(5),cpobs(16), & aarpd(0:1,12),aaryr(0:1,PREVY),aartot(0:1,1), & narpd(0:1,12),naryr(0:1,PREVY),nartot(0:1,1), & hdrptr(0:PNCHDR),hd2ptr(0:PNCHDR),revhng(0:1,5) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- INCLUDE 'desdgn.var' DATA cpobs/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec','1st','2nd','3rd','4th'/ c----------------------------------------------------------------------- c Set logical variable to determine if percent revisions are to be c printed out c----------------------------------------------------------------------- Rvper=T IF(Muladd.eq.1)Rvper=F IF(Lsumm.gt.0)THEN IF(Rvper)THEN WRITE(Nform,1010)'percent' ELSE WRITE(Nform,1010)'difference' END IF 1010 FORMAT('r06.aarmode: ',a) END IF c----------------------------------------------------------------------- c Initialize values for printing tables c----------------------------------------------------------------------- ncol=1 c----------------------------------------------------------------------- c Generate table format c----------------------------------------------------------------------- IF(Prttab(Nptr).or.Prttab(Nptr+1))THEN npos=21 WRITE(tfmt1,1020)ncol+1 1020 FORMAT('(1x,a5,1x,',i1,'(1x,f9.2))') WRITE(tfmt2,1030)ncol+1 1030 FORMAT('(2x,i4,1x,',i1,'(1x,f9.2))') c----------------------------------------------------------------------- c create column headers c----------------------------------------------------------------------- CALL intlst(PNCHDR,hdrptr,nhdrtl) nhdr=nhdrtl+1 CALL insstr('Proj -',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN CALL insstr('Conc -',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN CALL intlst(PNCHDR,hd2ptr,nhd2tl) nhd2=nhd2tl+1 DO i2=1,2 CALL insstr('Final ',nhd2,3,hd2ttl,hd2ptr,nhd2tl) IF(Lfatal)RETURN END DO END IF c----------------------------------------------------------------------- c Intitalize variables for summary tables c----------------------------------------------------------------------- iper=Revspn(MO)-1 iyr=1 CALL setdp(0D0,24,aarpd) CALL setdp(0D0,2*PREVY,aaryr) CALL setdp(0D0,2,aartot) CALL setdp(0D0,24,narpd) CALL setdp(0D0,2*PREVY,naryr) CALL setdp(0D0,2,nartot) c----------------------------------------------------------------------- c Compute revision for given estimate c----------------------------------------------------------------------- DO i=Begrev,Endsa-1 Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Set indexes for summary tables c----------------------------------------------------------------------- iper=iper+1 IF(iper.gt.Ny)THEN iper=1 iyr=iyr+1 END IF c----------------------------------------------------------------------- c Calculate the (percent) revision between the concurrent and final c adjustments. c----------------------------------------------------------------------- rev(0,Revptr)=Fin(Revptr)-Cnc(Revptr) IF(Rvper)rev(0,Revptr)=(rev(0,Revptr)/Cnc(Revptr))*100D0 rev(1,Revptr)=Fin(Revptr)-Cnc2(Revptr) IF(Rvper)rev(1,Revptr)=(rev(1,Revptr)/Cnc2(Revptr))*100D0 c----------------------------------------------------------------------- c Keep track of summary statistics c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Lsumm.gt.0.or.Svltab(LSLASF).or. & Svltab(LSLASP))THEN DO i2=0,1 drv=dabs(rev(i2,Revptr)) aarpd(i2,iper)=aarpd(i2,iper)+drv narpd(i2,iper)=narpd(i2,iper)+1D0 aaryr(i2,iyr)=aaryr(i2,iyr)+drv naryr(i2,iyr)=naryr(i2,iyr)+1D0 aartot(i2,1)=aartot(i2,1)+drv nartot(i2,1)=nartot(i2,1)+1D0 END DO END IF END DO IF(Prttab(Nptr))THEN c----------------------------------------------------------------------- c First, print out header information c----------------------------------------------------------------------- CALL makttl(DSDDIC,dsdptr,PDSD,Nptr,PDSUM6,tblttl,ntbttl,T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),Revspn,Ny,Revnum,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print out table c----------------------------------------------------------------------- i0=0 j=Revspn(YR)-1 i=Begrev i2=Begrev+Ny-Revspn(MO) i3=Revspn(MO) DO WHILE (i.lt.Endsa) IF(i2.ge.Endsa)i2=Endsa-1 j=j+1 ipos=1 CALL itoc(j,cobs,ipos) CALL prrvob(rev,ncol,i-Begrev+1,i2-Begrev+1,1,1, & cobs,ipos-1,hdrttl,hdrptr,nhdrtl,hd2ttl, & hd2ptr,nhd2tl,i0,tfmt1(1:npos),i3,1,PNCHDR,9, & tblttl(1:ntbttl),F) IF(Lfatal)RETURN IF(i.eq.Begrev)i3=1 i=i2+1 i2=i2+Ny END DO END IF c----------------------------------------------------------------------- c print out summary tables, if necessary. c----------------------------------------------------------------------- IF(Prttab(Nptr+1))THEN c----------------------------------------------------------------------- c First, print out header information c----------------------------------------------------------------------- CALL makttl(DSDDIC,dsdptr,PDSD,Nptr+1,PDSUM6,tblttl,ntbttl,T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),Revspn,Ny,0,T) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Compute summary statistics c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Lsumm.gt.0.or.Svltab(LSLASF).or. & Svltab(LSLASP))THEN DO j=0,ncol IF(dpeq(nartot(j,1),0D0))THEN aartot(j,1)=DNOTST ELSE aartot(j,1)=aartot(j,1)/nartot(j,1) END IF DO i=1,max(Ny,iyr) IF(i.le.Ny)THEN IF(dpeq(narpd(j,i),0D0))THEN aarpd(j,i)=DNOTST ELSE aarpd(j,i)=aarpd(j,i)/narpd(j,i) END IF END IF IF(i.le.iyr)THEN IF(dpeq(naryr(j,i),0D0))THEN aaryr(j,i)=DNOTST ELSE aaryr(j,i)=aaryr(j,i)/naryr(j,i) END IF END IF END DO END DO END IF c----------------------------------------------------------------------- c First, print out absolute average for each period. c----------------------------------------------------------------------- IF(Prttab(Nptr+1))THEN i0=0 IF(Ny.eq.12)THEN cobs='Months: ' nstr=7 ELSE cobs='Quarters: ' nstr=9 END IF CALL prrvob(aarpd,ncol,1,Ny,1,1,cobs,nstr,hdrttl,hdrptr, & nhdrtl,hd2ttl,hd2ptr,nhd2tl,i0,tfmt1(1:npos),1,1, & PNCHDR,9,tblttl(1:ntbttl),T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Then, print out absolute average for each year. c----------------------------------------------------------------------- cobs='Years: ' nstr=6 CALL prrvob(aaryr,ncol,1,iyr,1,2,cobs,nstr,hdrttl,hdrptr, & nhdrtl,hd2ttl,hd2ptr,nhd2tl,i0,tfmt2(1:npos), & Revspn(YR)-1,1,PNCHDR,9,tblttl(1:ntbttl),T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Finally, print out the total absolute average. c----------------------------------------------------------------------- cobs='Total: ' CALL prrvob(aartot,ncol,1,1,1,0,cobs,nstr,hdrttl,hdrptr, & nhdrtl,hd2ttl,hd2ptr,nhd2tl,i0,tfmt1(1:npos), & Revspn(YR)-1,1,PNCHDR,9,tblttl(1:ntbttl),T) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Compute hinge statistics for the absolute revisions c----------------------------------------------------------------------- IF(Prttab(Nptr+1).or.Lsumm.gt.0)THEN DO i=0,ncol i2=0 DO k=1,INT(nartot(i,1)) i2=i2+1 trev(i2)=dabs(rev(i,k)) END DO CALL hinge(trev,i2,ts,xtmp,0) DO k=1,5 revhng(i,k)=ts(k) END DO END DO END IF IF(Prttab(Nptr+1))THEN cobs='Hinge Values:' CALL prrvob(revhng,ncol,1,5,1,3,cobs,13,hdrttl,hdrptr,nhdrtl, & hd2ttl,hd2ptr,nhd2tl,i0,tfmt1(1:npos),1,1,PNCHDR,9, & tblttl(1:ntbttl),T) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Svltab(LSLASF))WRITE(Ng,1050)'Seasonal',aartot(0,1) IF(Svltab(LSLASP))WRITE(Ng,1050)'Projected Seasonal',aartot(1,1) IF(Lsumm.gt.0)THEN c----------------------------------------------------------------------- WRITE(Nform,1051)'r06.lag00.aar.all',aartot(0,1) c----------------------------------------------------------------------- i2=0 IF(Ny.eq.4)i2=12 DO i=1,Ny IF(.not.dpeq(aarpd(0,i),DNOTST))THEN WRITE(brklbl,1049)'p',i WRITE(Nform,2049)'r06.lag00.',brklbl,cpobs(i+i2),aarpd(0,i) END IF END DO c----------------------------------------------------------------------- i2=Revspn(YR)-1 DO i=1,iyr IF(.not.dpeq(aaryr(0,i),DNOTST))THEN WRITE(brklbl,1049)'y',i WRITE(Nform,3049)'r06.lag00.',brklbl,i+i2,aaryr(0,i) END IF END DO c----------------------------------------------------------------------- WRITE(Nform,1051)'r06.lag00.hinge.min',revhng(0,1) WRITE(Nform,1051)'r06.lag00.hinge.25p',revhng(0,2) WRITE(Nform,1051)'r06.lag00.hinge.med',revhng(0,3) WRITE(Nform,1051)'r06.lag00.hinge.75p',revhng(0,4) WRITE(Nform,1051)'r06.lag00.hinge.max',revhng(0,5) c----------------------------------------------------------------------- WRITE(Nform,1051)'r06.proj.aar.all',aartot(1,1) c----------------------------------------------------------------------- i2=0 IF(Ny.eq.4)i2=12 DO i=1,Ny IF(.not.dpeq(aarpd(1,i),DNOTST))THEN WRITE(brklbl,1049)'p',i WRITE(Nform,2049)'r06.proj.',brklbl,cpobs(i+i2),aarpd(1,i) END IF END DO c----------------------------------------------------------------------- i2=Revspn(YR)-1 DO i=1,iyr IF(.not.dpeq(aaryr(1,i),DNOTST))THEN WRITE(brklbl,1049)'y',i WRITE(Nform,3049)'r06.proj.',brklbl,i+i2,aaryr(1,i) END IF END DO c----------------------------------------------------------------------- WRITE(Nform,1051)'r06.proj.hinge.min',revhng(1,1) WRITE(Nform,1051)'r06.proj.hinge.25p',revhng(1,2) WRITE(Nform,1051)'r06.proj.hinge.med',revhng(1,3) WRITE(Nform,1051)'r06.proj.hinge.75p',revhng(1,4) WRITE(Nform,1051)'r06.proj.hinge.max',revhng(1,5) END IF c----------------------------------------------------------------------- 1049 FORMAT('aar.',a,i2.2) 2049 FORMAT(a,a,': ',a,' ',E17.10) 3049 FORMAT(a,a,': ',i4,' ',E17.10) 1050 FORMAT(' AveAbsRev of ',a,' : ',t40,f10.3) 1051 FORMAT(a,': ',E17.10) c----------------------------------------------------------------------- c If concurrent and final adjustments are to be printed, print out c title. c----------------------------------------------------------------------- IF(Prttab(Nptr+2))THEN c----------------------------------------------------------------------- c Print out header information c----------------------------------------------------------------------- CALL makttl(DSDDIC,dsdptr,PDSD,Nptr+2,PDSUM6,tblttl,ntbttl,T,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- npos=34 tbw=Tblwid IF(Tblwid.lt.10)tbw=10 WRITE(tfmt1,1021)tbw,tbw 1021 FORMAT('(1x,a5,1x,2(2(1x,f',i2,'.1),1x,f',i2,'.2))') WRITE(tfmt2,1031)tbw,tbw 1031 FORMAT('(2x,i4,1x,2(2(1x,f',i2,'.1),1x,f',i2,'.2))') c----------------------------------------------------------------------- i0=0 c----------------------------------------------------------------------- c Create data dictionary for column headers c----------------------------------------------------------------------- CALL intlst(PNCHDR,hdrptr,nhdrtl) nhdr=nhdrtl+1 CALL insstr('Revision',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(.not.Lfatal) & CALL insstr('Final',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(.not.Lfatal) & CALL insstr('Proj',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(.not.Lfatal) & CALL insstr('Revision',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(.not.Lfatal) & CALL insstr('Final',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(.not.Lfatal) & CALL insstr('Conc',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN c----------------------------------------------------------------------- CALL prtshd(tblttl(1:ntbttl),Revspn,Ny,Revnum,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- DO j=1,Revnum tmp(0,j)=Cnc(j) tmp(1,j)=Fin(j) tmp(2,j)=rev(0,j) tmp(3,j)=Cnc2(j) tmp(4,j)=Fin(j) tmp(5,j)=rev(1,j) END DO c----------------------------------------------------------------------- end2=Endsa-1 j=Revspn(YR)-1 k=Begrev k2=Begrev+Ny-Revspn(MO) k3=Revspn(MO) DO WHILE (k.le.end2) IF(k2.gt.end2)k2=end2 j=j+1 ipos=1 CALL itoc(j,cobs,ipos) CALL prrvob(tmp,5,k-Begrev+1,k2-Begrev+1,1,1,cobs,ipos-1, & hdrttl,hdrptr,nhdrtl,hd2ttl,hd2ptr,0,i0, & tfmt1(1:npos),k3,5,PNCHDR,tbw,tblttl(1:ntbttl), & F) IF(Lfatal)RETURN IF(k.eq.Begrev)k3=1 k=k2+1 k2=k2+Ny END DO END IF c----------------------------------------------------------------------- c If percent revisions are to be saved, open file for saved c revisions. c----------------------------------------------------------------------- IF(Savtab(Nptr))THEN CALL opnfil(T,F,Nptr,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for revisions c----------------------------------------------------------------------- CALL intlst(PNCHDR,hdrptr,nhdrtl) nhdr=nhdrtl+1 CALL insstr('PROJ_SF_revision',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) c----------------------------------------------------------------------- CALL intlst(PNCHDR,hdrptr,nhdrtl) nhdr=nhdrtl+1 CALL insstr('SF_revision',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) c----------------------------------------------------------------------- IF(Lfatal)RETURN WRITE(fh,1040)'date',(TABCHR, & hdrttl(hdrptr(ielt):hdrptr(ielt+1)-1),ielt=0,ncol) WRITE(fh,1040)'----',(TABCHR,'-----------------------', & ielt=0,ncol) c----------------------------------------------------------------------- c begin looping though observations c----------------------------------------------------------------------- DO i=Begrev,Endsa-1 Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Set date of revision for observation Revptr c----------------------------------------------------------------------- CALL addate(Revspn,Ny,Revptr-1,idate) rdbdat=100*idate(YR)+idate(MO) c----------------------------------------------------------------------- c Save revision measure with date c----------------------------------------------------------------------- ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN DO k=0,ncol outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(rev(k,Revptr),outstr,ipos) IF(Lfatal)RETURN END DO WRITE(fh,1040)outstr(1:ipos-1) END DO CALL fclose(fh) END IF c----------------------------------------------------------------------- c If concurrent and final adjustments are to be saved, open file for c saved adjustments. c----------------------------------------------------------------------- IF(Savtab(Nptr+2).or.Lgraf)THEN IF(Savtab(Nptr+2))CALL opnfil(T,F,Nptr+2,fh,locok) IF(Lgraf)CALL opnfil(T,Lgraf,Nptr+2,fh2,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for revisions c----------------------------------------------------------------------- CALL intlst(3,hdrptr,nhdrtl) nhdr=nhdrtl+1 ipos=1 CALL insstr('Final_SF',nhdr,PNCHDR,hdrttl,hdrptr,nhdrtl) IF(.not.Lfatal)CALL insstr('Proj_SF',nhdr,3,hdrttl,hdrptr, & nhdrtl) IF(.not.Lfatal)CALL insstr('Conc_SF',nhdr,3,hdrttl,hdrptr,nhdrtl) IF(Lfatal)RETURN IF(Savtab(Nptr+2))THEN WRITE(fh,1040)'date',(TABCHR, & hdrttl(hdrptr(ielt-1):hdrptr(ielt)-1),ielt=1,nhdrtl) WRITE(fh,1040)'----',(TABCHR,'-----------------------', & ielt=1,nhdrtl) END IF IF(Lgraf)THEN WRITE(fh2,1040)'date',(TABCHR, & hdrttl(hdrptr(ielt-1):hdrptr(ielt)-1),ielt=1,nhdrtl) WRITE(fh2,1040)'----',(TABCHR,'-----------------------', & ielt=1,nhdrtl) END IF c----------------------------------------------------------------------- c begin looping though observations c----------------------------------------------------------------------- DO i=Begrev,Endsa-1 Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Set date for ith revision c----------------------------------------------------------------------- CALL addate(Revspn,Ny,Revptr-1,idate) rdbdat=100*idate(YR)+idate(MO) c----------------------------------------------------------------------- c Save concurrent and final adjustments with date c----------------------------------------------------------------------- ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Cnc(Revptr),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Cnc2(Revptr),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Fin(Revptr),outstr,ipos) IF(Lfatal)RETURN IF(Savtab(Nptr+2))WRITE(fh,1040)outstr(1:ipos-1) IF(Lgraf)WRITE(fh2,1040)outstr(1:ipos-1) END DO IF(Savtab(Nptr+2))CALL fclose(fh) IF(Lgraf)CALL fclose(fh2) END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1040 FORMAT(1000a) END prtsft.f0000664006604000003110000000547714521201550011672 0ustar sun00315steps SUBROUTINE prtsft(Lprsft,Lprhdr,Tbwdth,Lsvsft,Lsvlog,Baselt, & Grpstr,Nchr,Info,Df1,Df2,Sftvl,Pv) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'title.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER Grpstr*(PGRPCR) LOGICAL Lprsft,Lprhdr,Lsvsft,Lsvlog INTEGER Tbwdth,Baselt,Nchr,Info,Df1,Df2,i DOUBLE PRECISION Sftvl,Pv c----------------------------------------------------------------------- IF(Lprhdr)THEN IF(.not.Lcmpaq)WRITE(Mt1,'()') WRITE(Mt1,1010)' ' WRITE(Mt1,1020)('-',i=1,tbwdth) WRITE(Mt1,1030) WRITE(Mt1,1020)('-',i=1,tbwdth) IF(Lsvlog)THEN WRITE(Ng,1010)':' WRITE(Ng,1030) WRITE(Ng,1020)'-----------------',' ', & '-------',' ','-----------',' ', & '-------' END IF Lprhdr=F END IF c----------------------------------------------------------------------- IF(Lsvsft.and.baselt.ne.NOTSET) & WRITE(Nform,1040)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv c----------------------------------------------------------------------- IF(Lprsft)THEN IF(Info.eq.0)THEN IF(Baselt.eq.NOTSET)THEN WRITE(Mt1,1080)Grpstr(1:Nchr) IF(Lsvlog)WRITE(Ng,1080)Grpstr(1:Nchr) ELSE IF(Nchr.gt.34)THEN WRITE(Mt1,1050)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv IF(Lsvlog)WRITE(Ng,1050)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv ELSE WRITE(Mt1,1060)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv IF(Lsvlog)WRITE(Ng,1060)Grpstr(1:Nchr),Df1,Df2,Sftvl,Pv END IF END IF c----------------------------------------------------------------------- ELSE WRITE(Mt1,1070)Grpstr(1:Nchr) IF(Lsvlog)WRITE(Ng,1070)Grpstr(1:Nchr) END IF END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(/,' F Tests for Seasonal Regressors',a1) 1020 FORMAT(' ',120(a)) 1030 FORMAT(' Regression Effect',t40,'df',t51,'F-statistic',t66, & 'P-Value') 1040 FORMAT('sftest$',a,': ',2(1x,i4),2(1x,e22.15)) 1050 FORMAT(' ',a,/,t35,i4,',',i4,f16.2,f13.2) 1060 FORMAT(' ',a,t35,i4,',',i4,f16.2,f13.2) 1070 FORMAT(' ',a,t52,'Not tested') 1080 FORMAT(' ',a,t41,'All coefficients fixed') c----------------------------------------------------------------------- END prtshd.f0000664006604000003110000000360714521201550011645 0ustar sun00315stepsC Last change:Jan. 2021, change blnk to lenghth 79 C previous change: BCM 21 Apr 98 2:17 pm **==prtshd.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE prtshd(Ttlhdr,Begdat,Sp,Nobs,Locpag) IMPLICIT NONE c----------------------------------------------------------------------- c Prints the header information for a time series. c----------------------------------------------------------------------- INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'title.cmn' c ------------------------------------------------------------------ INTEGER PSRSCR PARAMETER(PSRSCR=79) c ------------------------------------------------------------------ LOGICAL Locpag CHARACTER Ttlhdr*(*),bdtstr*(10),blnk*(PSRSCR),edtstr*(10) INTEGER Begdat,idate,nchr1,nchr2,Nobs,Sp DIMENSION Begdat(2),idate(2) c ------------------------------------------------------------------ DATA blnk/ &' & '/ c ------------------------------------------------------------------ IF(Lpage.and.Locpag)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF CALL addate(Begdat,Sp,Nobs-1,idate) CALL wrtdat(Begdat,Sp,bdtstr,nchr1) IF(.not.Lfatal)CALL wrtdat(idate,Sp,edtstr,nchr2) IF(Lfatal)RETURN IF(len(Ttlhdr).gt.0)WRITE(Mt1,1020)Ttlhdr 1020 FORMAT(/,' ',a) IF(Nobs.gt.0)THEN WRITE(Mt1,1030)blnk(1:17-nchr1-nchr2),bdtstr(1:nchr1), & edtstr(1:nchr2),Nobs 1030 FORMAT(' From ',a,a,' to ',a,/,' Observations ',i6) END IF c ------------------------------------------------------------------ RETURN c ------------------------------------------------------------------ END prttbl1.f0000664006604000003110000002750614521201550011735 0ustar sun00315stepsC Last change: BCM 19 Apr 2007 10:39 am SUBROUTINE prttbl1(Begdat,Sp,Y,Nobs,Srsttl,Nttl,Outdec,Nfor, & thisId) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine, prttbl, prints a table of monthly data. What month c the series begins in is adjusted for. c----------------------------------------------------------------------- c Parameters and include files c Name Type Description c----------------------------------------------------------------------- c one d Double precision 1 c pt5 d Double precision .5 c zero d Double precision 0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'hiddn.cmn' c----------------------------------------------------------------------- c Input Type Description c----------------------------------------------------------------------- c begdat i 2 long array containing the year and period of the begining c date c nobs i Number of observations to be printed c sp i Seasonal period or sampling period c srsttl c 81 long character string for the input title of the series c y i Nobs long vector of observations c----------------------------------------------------------------------- CHARACTER Srsttl*(50),thisId*(*) INTEGER Begdat,Nobs,Sp,Nfor,Nttl DOUBLE PRECISION Y,yy DIMENSION Begdat(2),Y(*),yy(POBS) c----------------------------------------------------------------------- c Local Type Description c----------------------------------------------------------------------- c cmonth c Array of month abbreviations c fmt1 c String containing the format for the first year of data c i i Index value c ibeg i Index of begining observation on the current line c iend i Index of last observation on the current line c iyr i lndex for the year to be printed c ncol i Number of columns in the printout c----------------------------------------------------------------------- CHARACTER blnk*80,cmonth*3,amonth*9,cqtr*3,fmt1*120,fmt2*120, & thisOb*30,valuhd*5,cperiod*2 LOGICAL thisNeg INTEGER BTWNCL,blkwd,clwdth,i,ibeg,idate,idxwd,iend,irow,INCOL, & istrt,itmp,j,mindec,MNSGFG,nblk,nblkln,nclprt,nclskp,ncol, & ndec,nidxhd,nrows,nvalhd,Outdec,strtyr,ivec,mxtbl,nmonth, & iyr,i2,istrtf,nend PARAMETER(BTWNCL=3,INCOL=2,MNSGFG=3) DIMENSION cmonth(12),cqtr(4),idate(2),ivec(1),nmonth(12), & amonth(12),cperiod(13) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION ceilng EXTERNAL dpeq,ceilng c----------------------------------------------------------------------- DATA blnk/ &' & '/ DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA amonth/'January ','February ','March ','April ', & '@ ','June ','July ','August ', & 'September','October ','November ','December '/ DATA nmonth/7,8,5,5,1,4,4,6,9,7,8,8/ DATA cqtr/'1st','2nd','3rd','4th'/ DATA cperiod/' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9','10', & '11','12','13'/ c----------------------------------------------------------------------- c Return if this is a transparent seasonal adjustment for sliding c spans, revisions, or X-11 Holiday adjustment. c----------------------------------------------------------------------- IF(Lhiddn)RETURN c----------------------------------------------------------------------- c Print the series title c----------------------------------------------------------------------- IF(Nttl.gt.1)CALL writTagOneLine(Mt1,'h3','@',Srsttl(1:Nttl)) c----------------------------------------------------------------------- c Figure the column width and decimals c----------------------------------------------------------------------- nend=Nobs+Nfor CALL numfmt(Y,nend,Outdec,clwdth,mindec) IF(mindec.gt.Outdec)THEN ndec=min(mindec+MNSGFG-1,11) clwdth=clwdth-Outdec+ndec+1 ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 * clwdth=min(max(clwdth,3),15) c----------------------------------------------------------------------- c copy y into yy vector (BCM April 2007) c----------------------------------------------------------------------- thisNeg=.false. DO i=1,nend yy(i) = Y(i) c----------------------------------------------------------------------- c For cases where ndec = 0 and the decimal fraction is exactly .5, c make an adjustment to ensure the number will round properly c when printed (BCM April 2007) c----------------------------------------------------------------------- IF(dpeq(yy(i)-ceilng(yy(i)-0.5D0),0.5D0).and.ndec.eq.0) & yy(i)=yy(i)+0.01D0 IF(yy(i).lt.0.and.(.not.thisNeg))thisNeg=.true. END DO IF(thisNeg)clwdth=clwdth+1 IF(ndec.lt.10)THEN WRITE(fmt1,1000)clwdth,ndec ELSE WRITE(fmt1,1001)clwdth,ndec END IF 1000 FORMAT('(f',i2.2,'.',i1,') ') 1001 FORMAT('(f',i2.2,'.',i2,')') c----------------------------------------------------------------------- strtyr=Begdat(YR) * IF(Sp.eq.1)strtyr=strtyr-1 * ivec(1)=strtyr+Nobs * CALL intfmt(ivec,1,idxwd) * idxwd=max(2,idxwd) * IF(idxwd.gt.3)THEN * nidxhd=4 * idxhd(1:nidxhd)='Year' * ELSE * nidxhd=2 * idxhd(1:nidxhd)='Yr' * END IF if(Sp.eq.1)THEN istrt=1 CALL mkTableTag(Mt1,'w40',Srsttl(1:Nttl)) CALL mkCaption(Mt1,Srsttl(1:Nttl)) else istrt=Begdat(MO) CALL mkTableTag(Mt1,'x11',Srsttl(1:Nttl)) CALL mkCaption(Mt1,Srsttl(1:Nttl)) end if CALL writTag(Mt1,'') CALL writTag(Mt1,'') CALL mkTableCell(Mt1,'head',' ') c----------------------------------------------------------------------- IF(Sp.eq.12)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col',amonth(i)(1:nmonth(i)), & cmonth(i)) end do ELSE IF (Sp.eq.4)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@',cqtr(i)//' Quarter') end do ELSE do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@','Period '//cperiod(i)) end do END IF CALL writTag(Mt1,'') CALL writTag(Mt1,'') CALL writTag(Mt1,'') c----------------------------------------------------------------------- c print out first year c----------------------------------------------------------------------- CALL writTag(Mt1,'') write(Mt1,1010)strtyr 1010 FORMAT('',i4,'') if (istrt.gt.1)THEN DO i=1,istrt-1 CALL mkTableCell(Mt1,'@',' ') END DO END IF iend=min(Sp-Begdat(2)+1,12,Nobs) DO i=1,iend write(thisOb,fmt1)yy(i) IF(yy(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO IF ((iend+istrt).lt.Sp)THEN DO i=iend+istrt+1,Sp CALL mkTableCell(Mt1,'@',' ') END DO END IF CALL writTag(Mt1,'') IF((istrt+Nobs-1).le.Sp)THEN CALL writTag(Mt1,'') CALL mkPOneLine(Mt2,'@',' ') RETURN END IF c----------------------------------------------------------------------- c Now print out the rest of the table c----------------------------------------------------------------------- iyr=Begdat(YR) DO ibeg=iend+1,Nobs,Sp CALL writTag(Mt1,'') i2=ibeg+Sp-1 iend=min(i2,Nobs) iyr=iyr+1 write(Mt1,1010)iyr DO i=ibeg,iend write(thisOb,fmt1)yy(i) IF(yy(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO IF(i2.le.iend)CALL writTag(Mt1,'') END DO IF (i2.gt.iend) THEN DO i=iend+1,i2 CALL mkTableCell(Mt1,'@',' ') END DO CALL writTag(Mt1,'') END IF CALL writTag(Mt1,'') CALL writTag(Mt1,'') CALL mkPOneLine(Mt1,'@',' ') c ------------------------------------------------------------------ c Now print out the forecasts c ------------------------------------------------------------------ istrt=iend+1 strtyr=iyr if (istrt.gt.i2) THEN strtyr=strtyr+1 istrtf=1 i2=i2+Sp ELSE istrtf=istrt-(i2-Sp) END IF c ------------------------------------------------------------------ if(Sp.eq.1)THEN CALL mkTableTag(Mt1,'w40','Forecasts of '//Srsttl(1:Nttl)) CALL mkCaption(Mt1,'Forecasts of '//Srsttl(1:Nttl)) else CALL mkTableTag(Mt1,'x11',Srsttl(1:Nttl)) CALL mkCaption(Mt1,'Forecasts of '//Srsttl(1:Nttl)) end if CALL writTag(Mt1,'') CALL writTag(Mt1,'') CALL mkTableCell(Mt1,'head',' ') c----------------------------------------------------------------------- IF(Sp.eq.12)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col',amonth(i)(1:nmonth(i)), & cmonth(i)) end do ELSE IF (Sp.eq.4)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@',cqtr(i)//' Quarter') end do ELSE do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@','Period '//cperiod(i)) end do END IF CALL writTag(Mt1,'') CALL writTag(Mt1,'') CALL writTag(Mt1,'') c----------------------------------------------------------------------- c print out first year of forecasts c----------------------------------------------------------------------- CALL writTag(Mt1,'') write(Mt1,1010)strtyr if (istrtf.gt.1)THEN DO i=1,istrtf-1 CALL mkTableCell(Mt1,'@',' ') END DO END IF iend=min(iend+nfor,i2) DO i=istrt,iend write(thisOb,fmt1)yy(i) IF(yy(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO IF (iend.lt.i2)THEN DO i=iend+1,i2 CALL mkTableCell(Mt1,'@',' ') END DO END IF CALL writTag(Mt1,'') c----------------------------------------------------------------------- c Now print out the rest of the table c----------------------------------------------------------------------- iyr=strtyr DO ibeg=iend+1,nend,Sp CALL writTag(Mt1,'') i2=ibeg+Sp-1 iend=min(i2,nend) iyr=iyr+1 write(Mt1,1010)iyr DO i=ibeg,iend write(thisOb,fmt1)yy(i) IF(yy(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO IF(i2.le.iend)CALL writTag(Mt1,'') END DO IF (i2.gt.iend) THEN DO i=iend+1,i2 CALL mkTableCell(Mt1,'@',' ') END DO CALL writTag(Mt1,'') END IF CALL writTag(Mt1,'') CALL writTag(Mt1,'') CALL mkPOneLine(Mt1,'@',' ') c ------------------------------------------------------------------ RETURN END prttbl2.f0000664006604000003110000001773514521201550011741 0ustar sun00315stepsC Last change: BCM 19 Apr 2007 10:39 am SUBROUTINE prttb2(Begdat,Sp,Y,Nobs,Srsttl,Outdec) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine, prttbl, prints a table of monthly data. What month c the series begins in is adjusted for. c----------------------------------------------------------------------- c Parameters and include files c Name Type Description c----------------------------------------------------------------------- c one d Double precision 1 c pt5 d Double precision .5 c zero d Double precision 0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' INCLUDE 'title.cmn' c ------------------------------------------------------------------ INTEGER Mxtbwd c----------------------------------------------------------------------- c Input Type Description c----------------------------------------------------------------------- c begdat i 2 long array containing the year and period of the begining c date c nobs i Number of observations to be printed c sp i Seasonal period or sampling period c srsttl c 81 long character string for the input title of the series c y i Nobs long vector of observations c----------------------------------------------------------------------- CHARACTER Srsttl*(*) INTEGER Begdat,Nobs,Sp DOUBLE PRECISION Y,yy DIMENSION Begdat(2),Y(Nobs),yy(POBS) c----------------------------------------------------------------------- c Local Type Description c----------------------------------------------------------------------- c cmonth c Array of month abbreviations c fmt1 c String containing the format for the first year of data c i i Index value c ibeg i Index of begining observation on the current line c iend i Index of last observation on the current line c iyr i lndex for the year to be printed c ncol i Number of columns in the printout c----------------------------------------------------------------------- CHARACTER blnk*80,cmonth*3,amonth*9,cqtr*3,fmt1*120,fmt2*120, & thisOb*30,valuhd*5,cperiod*2 INTEGER BTWNCL,blkwd,clwdth,i,ibeg,idate,idxwd,iend,irow,INCOL, & istrt,itmp,j,mindec,MNSGFG,nblk,nblkln,nclprt,nclskp,ncol, & ndec,nidxhd,nrows,nvalhd,Outdec,strtyr,ivec,mxtbl,nmonth PARAMETER(BTWNCL=3,INCOL=2,MNSGFG=3) DIMENSION cmonth(12),cqtr(4),idate(2),ivec(1),nmonth(12), & amonth(12),cperiod(2) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION ceilng EXTERNAL dpeq,ceilng c----------------------------------------------------------------------- DATA blnk/ &' & '/ DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA amonth/'January ','February ','March ','April ', & '@ ','June ','July ','August ', & 'September','October ','November ','December '/ DATA nmonth/7,8,5,5,1,4,4,6,9,7,8,8/ DATA cqtr/'1st','2nd','3rd','4th'/ DATA cperiod/' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9','10', & '11','12','13'/ c----------------------------------------------------------------------- c Print the series title c----------------------------------------------------------------------- Mxtbwd=80 * IF(Lwdprt)Mxtbwd=132 IF(len(Srsttl).gt.1)CALL writTagOneLine(Mt1,'h3','@',Srsttl) c----------------------------------------------------------------------- c Figure the column width and decimals c----------------------------------------------------------------------- CALL numfmt(Y,Nobs,Outdec,clwdth,mindec) IF(mindec.gt.Outdec)THEN ndec=min(mindec+MNSGFG-1,11) clwdth=clwdth-Outdec+ndec ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 * clwdth=min(max(clwdth,3),15) WRITE(fmt1,1000)clwdth,ndec 1000 FORMAT('(f',i2.2,'.',i1,')') c----------------------------------------------------------------------- c copy y into yy vector (BCM April 2007) c----------------------------------------------------------------------- thisNeg=.false. DO i=1,Nobs yy(i) = Y(i) c----------------------------------------------------------------------- c For cases where ndec = 0 and the decimal fraction is exactly .5, c make an adjustment to ensure the number will round properly c when printed (BCM April 2007) c----------------------------------------------------------------------- IF(dpeq(yy(i)-ceilng(yy(i)-0.5D0),0.5D0).and.ndec.eq.0) & yy(i)=yy(i)+0.01D0 IF(yy(i).lt.0.and.(.not.thisNeg))thisNeg=.true. END DO IF(thisNeg)clwdth=clwdth+1 WRITE(fmt1,1000)clwdth,ndec WRITE(fmt2,1000)clwdth+2,ndec 1000 FORMAT('(f',i2.2,'.',i1,')') c----------------------------------------------------------------------- strtyr=Begdat(YR) * IF(Sp.eq.1)strtyr=strtyr-1 * ivec(1)=strtyr+Nobs * CALL intfmt(ivec,1,idxwd) * idxwd=max(2,idxwd) * IF(idxwd.gt.3)THEN * nidxhd=4 * idxhd(1:nidxhd)='Year' * ELSE * nidxhd=2 * idxhd(1:nidxhd)='Yr' * END IF if(Sp.eq.1)THEN istrt=1 CALL mkTableTag(Mt1,'w40',Srsttl) CALL mkCaption(Mt1,'w40',Srsttl) else istrt=Begdat(MO) CALL mkTableTag(Mt1,'x11',Srsttl) CALL mkCaption(Mt1,'x11',Srsttl) end if CALL writTag(Mt1,'') CALL mkTableCell(Mt1,'@',' ') c----------------------------------------------------------------------- IF(Sp.eq.12)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col',amonth(i)(1:nmonth(i)), & cmonth(i)) end do ELSE IF (Sp.eq.4)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@',cqtr(i)//' Quarter') end do ELSE do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@','Period '//cperiod(i)) end do END DO CALL mkHeaderCellScope(Mt1,0,0,'col','@','Total') CALL writTag(Mt1,'') c----------------------------------------------------------------------- c print out first year c----------------------------------------------------------------------- CALL writTag(Mt1,'') write(Mt1,1010)strtyr 1010 FORMAT('',i4,'') if (istrt.gt.1)THEN DO i=1,istrt-1 CALL mkTableCell(Mt1,'@',' ') END DO END IF iend=min(Sp-Begdat(2)+1,12,Nobs) DO i=istrt,tend write(thisOb,fmt1)yy(i) IF(yy(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO CALL writTag(Mt1,'') c----------------------------------------------------------------------- c Now print out the rest of the table c----------------------------------------------------------------------- DO ibeg=iend+1,Nobs,Sp CALL writTag(Mt1,'') i2=ibeg+Sp-1 iend=min(i2,Nobs) iyr=iyr+1 write(Mt1,1010)iyr DO i=ibeg,iend write(thisOb,fmt1)yy(i) IF(Y(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO IF (i2.gt.iend) THEN DO i=i2+1,iend CALL mkTableCell(Mt1,'@',' ') END DO END IF CALL writTag(Mt1,'') END DO CALL writTag(Mt1,'') CALL mkPOneLine(Mt2,'@',' ') c ------------------------------------------------------------------ RETURN END prttbl.f0000664006604000003110000003237114521201550011650 0ustar sun00315stepsC Last change: BCM 19 Apr 2007 10:39 am SUBROUTINE prttbl(Begdat,Sp,Y,Nobs,Srsttl,Outdec) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine, prttbl, prints a table of monthly data. What month c the series begins in is adjusted for. c----------------------------------------------------------------------- c Parameters and include files c Name Type Description c----------------------------------------------------------------------- c one d Double precision 1 c pt5 d Double precision .5 c zero d Double precision 0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' INCLUDE 'title.cmn' c ------------------------------------------------------------------ INTEGER Mxtbwd c----------------------------------------------------------------------- c Input Type Description c----------------------------------------------------------------------- c begdat i 2 long array containing the year and period of the begining c date c nobs i Number of observations to be printed c sp i Seasonal period or sampling period c srsttl c 81 long character string for the input title of the series c y i Nobs long vector of observations c----------------------------------------------------------------------- CHARACTER Srsttl*(*) INTEGER Begdat,Nobs,Sp DOUBLE PRECISION Y,yy DIMENSION Begdat(2),Y(Nobs),yy(POBS) c----------------------------------------------------------------------- c Local Type Description c----------------------------------------------------------------------- c cmonth c Array of month abbreviations c fmt1 c String containing the format for the first year of data c i i Index value c ibeg i Index of begining observation on the current line c iend i Index of last observation on the current line c iyr i lndex for the year to be printed c ncol i Number of columns in the printout c----------------------------------------------------------------------- CHARACTER blnk*80,cmonth*3,cqtr*3,fmt1*120,fmt2*120,idxhd*4, & valuhd*5 INTEGER BTWNCL,blkwd,clwdth,i,ibeg,idate,idxwd,iend,irow,INCOL, & istrt,itmp,j,mindec,MNSGFG,nblk,nblkln,nclprt,nclskp,ncol, & ndec,nidxhd,nrows,nvalhd,Outdec,strtyr,ivec,mxtbl PARAMETER(BTWNCL=3,INCOL=2,MNSGFG=3) DIMENSION cmonth(12),cqtr(4),idate(2),ivec(1) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION ceilng EXTERNAL dpeq,ceilng c----------------------------------------------------------------------- DATA blnk/ &' & '/ DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA cqtr/'1st','2nd','3rd','4th'/ c----------------------------------------------------------------------- c Print the series title c----------------------------------------------------------------------- Mxtbwd=80 IF(Lwdprt)Mxtbwd=132 IF(len(Srsttl).gt.1)THEN WRITE(Mt1,1010)Srsttl 1010 FORMAT(/,' ',a) END IF c----------------------------------------------------------------------- c Figure the column width and decimals c----------------------------------------------------------------------- CALL numfmt(Y,Nobs,Outdec,clwdth,mindec) IF(mindec.gt.Outdec)THEN ndec=min(mindec+MNSGFG-1,11) clwdth=clwdth-Outdec+ndec ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 clwdth=min(max(clwdth,3),15) c----------------------------------------------------------------------- c copy y into yy vector (BCM April 2007) c----------------------------------------------------------------------- DO i=1,Nobs yy(i) = Y(i) c----------------------------------------------------------------------- c For cases where ndec = 0 and the decimal fraction is exactly .5, c make an adjustment to ensure the number will round properly c when printed (BCM April 2007) c----------------------------------------------------------------------- IF(dpeq(yy(i)-ceilng(yy(i)-0.5D0),0.5D0).and.ndec.eq.0) & yy(i)=yy(i)+0.01D0 END DO c----------------------------------------------------------------------- strtyr=Begdat(YR) IF(Sp.eq.1)strtyr=strtyr-1 ivec(1)=strtyr+Nobs CALL intfmt(ivec,1,idxwd) idxwd=max(2,idxwd) IF(idxwd.gt.3)THEN nidxhd=4 idxhd(1:nidxhd)='Year' ELSE nidxhd=2 idxhd(1:nidxhd)='Yr' END IF c----------------------------------------------------------------------- c Print out the heading, what there is of the first year of data, c and calculate how many values were printed in the first year. c----------------------------------------------------------------------- IF(Sp.eq.1)THEN blkwd=(BTWNCL+idxwd+INCOL+clwdth) ncol=(Mxtbwd-2)/blkwd ncol=min(ncol,int(sqrt(float(Nobs)))) ncol=max(min(ncol,5),1) valuhd='Value' nvalhd=min(5,clwdth) c ------------------------------------------------------------------ WRITE(Mt1,1020)' ',('-',i=1,blkwd-BTWNCL), & ((' ',i=1,BTWNCL),('-',i=1,blkwd-BTWNCL),j=2,ncol) 1020 FORMAT(200(a)) WRITE(Mt1,1030)blnk(1:2+idxwd-nidxhd),idxhd(1:nidxhd), & blnk(1:INCOL+clwdth-nvalhd),valuhd(1:nvalhd), & (blnk(1:BTWNCL+idxwd-nidxhd),idxhd(1:nidxhd), & blnk(1:INCOL+clwdth-nvalhd),valuhd(1:nvalhd),i=2, & ncol) 1030 FORMAT(a,a,a,a,4(a,a,a,a)) WRITE(Mt1,1020)' ',('-',i=1,blkwd-BTWNCL), & ((' ',i=1,BTWNCL),('-',i=1,blkwd-BTWNCL),j=2,ncol) c ------------------------------------------------------------------ WRITE(fmt1,1040)2+idxwd,INCOL+clwdth,ndec,ncol-1,BTWNCL+idxwd, & INCOL+clwdth,ndec 1040 FORMAT('((i',i2.2,',f',i2.2,'.',i2.2,',:',i2,'(i',i2.2,',f',i2.2, & '.',i2.2,')))') c ------------------------------------------------------------------ nrows=(Nobs+ncol-1)/ncol DO irow=1,nrows WRITE(Mt1,fmt1)(strtyr+i,yy(i),i=irow,Nobs,nrows) END DO c----------------------------------------------------------------------- c Tables for periodic data c----------------------------------------------------------------------- ELSE IF(Sp.ge.6)THEN nblk=Sp istrt=Begdat(MO) iend=min(nblk-istrt+1,Nobs) c ------------------------------------------------------------------ nvalhd=3 itmp=INCOL+clwdth-nvalhd c----------------------------------------------------------------------- c Decide on the number of columns c----------------------------------------------------------------------- mxtbl=Mxtbwd-nidxhd-INCOL-2 IF(Sp.ne.12)THEN ncol=min(5,mxtbl/(INCOL+clwdth)) ELSE IF((Sp.ge.12.and.12*(INCOL+clwdth).le.mxtbl).or. & (Sp*(INCOL+clwdth).le.mxtbl))THEN ncol=Sp ELSE IF(6*(INCOL+clwdth).le.mxtbl)THEN ncol=6 ELSE ncol=4 END IF c ------------------------------------------------------------------ WRITE(Mt1,1050)' ', & ('-',i=1,idxwd+BTWNCL+(ncol-1)*INCOL+ncol*clwdth) 1050 FORMAT(200(a)) c ------------------------------------------------------------------ IF(Sp.eq.12)THEN c ------------------------------------------------------------------ IF(ncol.lt.nblk)THEN WRITE(fmt2,1060)ncol-1 1060 FORMAT('(a,a,a,',i2.2,'(a,a))') WRITE(Mt1,fmt2)blnk(1:2+idxwd),blnk(1:BTWNCL+clwdth-nvalhd), & cmonth(1),(blnk(1:itmp),cmonth(i),i=2,ncol) DO ibeg=ncol+1,nblk-ncol,ncol WRITE(Mt1,fmt2)blnk(1:2+idxwd),blnk(1:BTWNCL+clwdth-nvalhd), & cmonth(ibeg), & (blnk(1:itmp),cmonth(i),i=ibeg+1,ibeg+ncol-1) END DO END IF c ------------------------------------------------------------------ ibeg=ncol*(nblk/ncol)+1 IF(ibeg.gt.nblk)ibeg=nblk-ncol+1 WRITE(fmt2,1070)ncol-1 1070 FORMAT('(a,a,a,a,',i2.2,'(a,a))') WRITE(Mt1,fmt2)blnk(1:2+idxwd-nidxhd),idxhd(1:nidxhd), & blnk(1:BTWNCL+clwdth-nvalhd),cmonth(ibeg), & (blnk(1:itmp),cmonth(i),i=ibeg+1,nblk) c ------------------------------------------------------------------ ELSE WRITE(Mt1,1080)blnk(1:2+idxwd),blnk(1:BTWNCL+clwdth-nvalhd),1, & (blnk(1:itmp),i,i=2,ncol) 1080 FORMAT(a,a,i3,4(a,i3)) c ------------------------------------------------------------------ DO ibeg=ncol+1,nblk-ncol,ncol WRITE(Mt1,1080)blnk(1:2+idxwd),blnk(1:BTWNCL+clwdth-nvalhd), & ibeg,(blnk(1:itmp),i,i=ibeg+1,ibeg+ncol-1) END DO c ------------------------------------------------------------------ ibeg=ncol*(nblk/ncol)+1 IF(ibeg.gt.nblk)ibeg=nblk-ncol+1 WRITE(Mt1,1090)blnk(1:2+idxwd-nidxhd),idxhd(1:nidxhd), & blnk(1:BTWNCL+clwdth-nvalhd),ibeg, & (blnk(1:itmp),i,i=ibeg+1,nblk) 1090 FORMAT(a,a,a,i3,4(a,i3)) END IF c ------------------------------------------------------------------ ELSE ncol=Sp nblk=5*Sp IF(Sp.eq.4)THEN mxtbl=Mxtbwd-nidxhd-INCOL-2 ncol=min(4,mxtbl/(INCOL+clwdth)) nblk=Sp END IF istrt=Begdat(MO) iend=min(nblk-ncol*mod(Begdat(YR),5)-istrt+1,Nobs) IF(Sp.eq.4)iend=min(Sp-istrt+1,Nobs) c ------------------------------------------------------------------ nvalhd=3 itmp=INCOL+clwdth-nvalhd c ------------------------------------------------------------------ WRITE(Mt1,1050)' ', & ('-',i=1,idxwd+BTWNCL+(ncol-1)*INCOL+ncol*clwdth) c ------------------------------------------------------------------ IF(Sp.eq.4)THEN WRITE(Mt1,1100)blnk(1:2+idxwd-nidxhd),idxhd(1:nidxhd), & blnk(1:itmp+BTWNCL-INCOL),cqtr(1), & (blnk(1:itmp),cqtr(i),i=2,4) 1100 FORMAT(a,a,a,a,3(a,a)) c ------------------------------------------------------------------ ELSE WRITE(Mt1,1110)blnk(1:2+idxwd-nidxhd),idxhd(1:nidxhd), & blnk(1:itmp+BTWNCL-INCOL),1, & (blnk(1:itmp),i,i=2,Sp) 1110 FORMAT(a,a,a,i3,5(a,i3)) END IF END IF c ------------------------------------------------------------------ WRITE(Mt1,1050)' ',('-',i=1,idxwd+BTWNCL+(ncol-1)*INCOL+ncol* & clwdth) c ------------------------------------------------------------------ IF(istrt.gt.ncol)THEN nblkln=(istrt-1)/ncol nclskp=istrt-ncol*nblkln-1 nclprt=min(nblk,ncol)-nclskp WRITE(fmt1,1120)2+idxwd,nblkln,2+idxwd+BTWNCL-INCOL+ & nclskp*(INCOL+clwdth),nclprt,INCOL+clwdth,ndec, & 2+idxwd+BTWNCL-INCOL,ncol,INCOL+clwdth,ndec 1120 FORMAT('(i',i2.2,',',i1,'(/),',i2,'x,',i2,'f',i2.2,'.',i2.2, & ':,/,(',i2,'x,:',i2,'f',i2.2,'.',i2.2,'))') c ------------------------------------------------------------------ ELSE WRITE(fmt1,1130)2+idxwd,BTWNCL-INCOL+(istrt-1)*(INCOL+clwdth), & ncol-istrt+1,INCOL+clwdth,ndec, & 2+idxwd+BTWNCL-INCOL,ncol,INCOL+clwdth,ndec 1130 FORMAT('(i',i2.2,',',i3,'x,:',i2,'f',i2.2,'.',i2.2,',/,(',i2, & 'x,:',i2,'f',i2.2,'.',i2.2,'))') END IF c ------------------------------------------------------------------ CALL addate(Begdat,Sp,0,idate) WRITE(Mt1,fmt1)strtyr,(yy(i),i=1,iend) c----------------------------------------------------------------------- c Now print out the rest of the table c----------------------------------------------------------------------- WRITE(fmt1,1140)2+idxwd,BTWNCL+clwdth,ndec,ncol-1,INCOL+clwdth, & ndec,2+idxwd+BTWNCL-INCOL,ncol,INCOL+clwdth,ndec 1140 FORMAT('(i',i2.2,',f',i2.2,'.',i2.2,',:',i2,'f',i2.2,'.',i2.2, & ' ,/,(',i2,'x,:',i2,'f',i2.2,'.',i2.2,'))') CALL addate(idate,Sp,iend,idate) c ------------------------------------------------------------------ DO ibeg=iend+1,Nobs,nblk iend=min(ibeg+nblk-1,Nobs) * IF(.not.Lcmpaq)WRITE(Mt1,'()') IF(.not.(Lcmpaq.or.Sp.eq.4))WRITE(Mt1,'()') WRITE(Mt1,fmt1)idate(YR),(yy(i),i=ibeg,iend) CALL addate(idate,Sp,iend-ibeg+1,idate) END DO c ------------------------------------------------------------------ WRITE(Mt1,1050)' ',('-',i=1,idxwd+BTWNCL+(ncol-1)*INCOL+ncol* & clwdth) END IF c ------------------------------------------------------------------ RETURN END prttblsum.f0000664006604000003110000001774014521201550012400 0ustar sun00315stepsC Last change: BCM 19 Apr 2007 10:39 am SUBROUTINE prttblsum(Begdat,Sp,Y,Nobs,Srsttl,Outdec) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine, prttbl, prints a table of monthly data. What month c the series begins in is adjusted for. c----------------------------------------------------------------------- c Parameters and include files c Name Type Description c----------------------------------------------------------------------- c one d Double precision 1 c pt5 d Double precision .5 c zero d Double precision 0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' INCLUDE 'title.cmn' c ------------------------------------------------------------------ INTEGER Mxtbwd c----------------------------------------------------------------------- c Input Type Description c----------------------------------------------------------------------- c begdat i 2 long array containing the year and period of the begining c date c nobs i Number of observations to be printed c sp i Seasonal period or sampling period c srsttl c 81 long character string for the input title of the series c y i Nobs long vector of observations c----------------------------------------------------------------------- CHARACTER Srsttl*(*) INTEGER Begdat,Nobs,Sp DOUBLE PRECISION Y,yy DIMENSION Begdat(2),Y(Nobs),yy(POBS) c----------------------------------------------------------------------- c Local Type Description c----------------------------------------------------------------------- c cmonth c Array of month abbreviations c fmt1 c String containing the format for the first year of data c i i Index value c ibeg i Index of begining observation on the current line c iend i Index of last observation on the current line c iyr i lndex for the year to be printed c ncol i Number of columns in the printout c----------------------------------------------------------------------- CHARACTER blnk*80,cmonth*3,amonth*9,cqtr*3,fmt1*120,fmt2*120, & thisOb*30,valuhd*5,cperiod*2 INTEGER BTWNCL,blkwd,clwdth,i,ibeg,idate,idxwd,iend,irow,INCOL, & istrt,itmp,j,mindec,MNSGFG,nblk,nblkln,nclprt,nclskp,ncol, & ndec,nidxhd,nrows,nvalhd,Outdec,strtyr,ivec,mxtbl,nmonth PARAMETER(BTWNCL=3,INCOL=2,MNSGFG=3) DIMENSION cmonth(12),cqtr(4),idate(2),ivec(1),nmonth(12), & amonth(12),cperiod(2) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION ceilng EXTERNAL dpeq,ceilng c----------------------------------------------------------------------- DATA blnk/ &' & '/ DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA amonth/'January ','February ','March ','April ', & '@ ','June ','July ','August ', & 'September','October ','November ','December '/ DATA nmonth/7,8,5,5,1,4,4,6,9,7,8,8/ DATA cqtr/'1st','2nd','3rd','4th'/ DATA cperiod/' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9','10', & '11','12','13'/ c----------------------------------------------------------------------- c Print the series title c----------------------------------------------------------------------- Mxtbwd=80 * IF(Lwdprt)Mxtbwd=132 IF(len(Srsttl).gt.1)CALL writTagOneLine(Mt1,'h3','@',Srsttl) c----------------------------------------------------------------------- c Figure the column width and decimals c----------------------------------------------------------------------- CALL numfmt(Y,Nobs,Outdec,clwdth,mindec) IF(mindec.gt.Outdec)THEN ndec=min(mindec+MNSGFG-1,11) clwdth=clwdth-Outdec+ndec ELSE ndec=Outdec END IF IF(ndec.eq.0)clwdth=clwdth+1 * clwdth=min(max(clwdth,3),15) WRITE(fmt1,1000)clwdth,ndec 1000 FORMAT('(f',i2.2,'.',i1,')') c----------------------------------------------------------------------- c copy y into yy vector (BCM April 2007) c----------------------------------------------------------------------- thisNeg=.false. DO i=1,Nobs yy(i) = Y(i) c----------------------------------------------------------------------- c For cases where ndec = 0 and the decimal fraction is exactly .5, c make an adjustment to ensure the number will round properly c when printed (BCM April 2007) c----------------------------------------------------------------------- IF(dpeq(yy(i)-ceilng(yy(i)-0.5D0),0.5D0).and.ndec.eq.0) & yy(i)=yy(i)+0.01D0 IF(yy(i).lt.0.and.(.not.thisNeg))thisNeg=.true. END DO IF(thisNeg)clwdth=clwdth+1 WRITE(fmt1,1000)clwdth,ndec WRITE(fmt2,1000)clwdth+2,ndec 1000 FORMAT('(f',i2.2,'.',i1,')') c----------------------------------------------------------------------- strtyr=Begdat(YR) * IF(Sp.eq.1)strtyr=strtyr-1 * ivec(1)=strtyr+Nobs * CALL intfmt(ivec,1,idxwd) * idxwd=max(2,idxwd) * IF(idxwd.gt.3)THEN * nidxhd=4 * idxhd(1:nidxhd)='Year' * ELSE * nidxhd=2 * idxhd(1:nidxhd)='Yr' * END IF if(Sp.eq.1)THEN istrt=1 CALL mkTableTag(Mt1,'w40',Srsttl) CALL mkCaption(Mt1,'w40',Srsttl) else istrt=Begdat(MO) CALL mkTableTag(Mt1,'x11',Srsttl) CALL mkCaption(Mt1,'x11',Srsttl) end if CALL writTag(Mt1,'') CALL mkTableCell(Mt1,'@',' ') c----------------------------------------------------------------------- IF(Sp.eq.12)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col',amonth(i)(1:nmonth(i)), & cmonth(i)) end do ELSE IF (Sp.eq.4)THEN do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@',cqtr(i)//' Quarter') end do ELSE do i = 1,Sp CALL mkHeaderCellScope(Mt1,0,0,'col','@','Period '//cperiod(i)) end do END DO CALL mkHeaderCellScope(Mt1,0,0,'col','@','Total') CALL writTag(Mt1,'') c----------------------------------------------------------------------- c print out first year c----------------------------------------------------------------------- CALL writTag(Mt1,'') write(Mt1,1010)strtyr 1010 FORMAT('',i4,'') if (istrt.gt.1)THEN DO i=1,istrt-1 CALL mkTableCell(Mt1,'@',' ') END DO END IF iend=min(Sp-Begdat(2)+1,12,Nobs) DO i=istrt,tend write(thisOb,fmt1)yy(i) IF(yy(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO CALL writTag(Mt1,'') c----------------------------------------------------------------------- c Now print out the rest of the table c----------------------------------------------------------------------- DO ibeg=iend+1,Nobs,Sp CALL writTag(Mt1,'') i2=ibeg+Sp-1 iend=min(i2,Nobs) iyr=iyr+1 write(Mt1,1010)iyr DO i=ibeg,iend write(thisOb,fmt1)yy(i) IF(Y(i).lt.0D0)THEN CALL mkTableCell(Mt1,'nowrap',thisOb) ELSE CALL mkTableCell(Mt1,'@',thisOb) END IF END DO IF (i2.gt.iend) THEN DO i=i2+1,iend CALL mkTableCell(Mt1,'@',' ') END DO END IF CALL writTag(Mt1,'') END DO CALL writTag(Mt1,'') CALL mkPOneLine(Mt2,'@',' ') c ------------------------------------------------------------------ RETURN END prttd.f0000664006604000003110000000744514521201550011502 0ustar sun00315stepsC Last change: BCM 28 Sep 1998 11:09 am SUBROUTINE prttd(Td,Td1,Ctype,Tdzero,Tddate,Lrgmtd,Fulltd,Tdfmt, & Ny,Mq) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'units.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION Td,Td1 CHARACTER Ctype*(*),Tdfmt*(50),datstr*(10),daylbl*(15),Mq*(7) LOGICAL Lrgmtd,Fulltd INTEGER i,j,Tdzero,Tddate,nchdat,Ny DIMENSION daylbl(2,4),Tddate(2),Td(*),Td1(*) c----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- DATA (daylbl(1,j),j=1,4)/'92-day quarters','91-day quarters', & 'Leap year Q1 ','Non-Leap Q1 '/ DATA (daylbl(2,j),j=1,4)/'31-day months ','30-day months ', & 'Leap year Feb. ','Non-Leap Feb. '/ c----------------------------------------------------------------------- j=1 IF(Ny.eq.12)j=2 IF(Lrgmtd)THEN CALL wrtdat(Tddate,Ny,datstr,nchdat) IF(Fulltd.or.Tdzero.gt.0)THEN WRITE(Mt1,1010)Ctype,datstr(1:nchdat) 1010 FORMAT(//,6x,'Day of Week Component for ',a,' Trading Day ', & 'Factors (before ',a,'):',/) ELSE WRITE(Mt1,1020)Ctype,datstr(1:nchdat) 1020 FORMAT(//,6x,'Day of Week Component for ',a,' Trading Day ', & 'Factors (starting ',a,'):',/) END IF ELSE WRITE(Mt1,1030)Ctype 1030 FORMAT(//,6x,'Day of Week Component for ',a,' Trading Day ', & 'Factors:',/) END IF WRITE(Mt1,1040)Mq(1:nblank(Mq)) 1040 FORMAT(39x,a,'s starting on:',/,21x,'Mon Tue Wed', & ' Thu Fri Sat Sun') c----------------------------------------------------------------------- c Print trading day factors for each type of month/quarter. Print c out results for 31/92 day months/quarters first. c----------------------------------------------------------------------- WRITE(Mt1,Tdfmt)daylbl(j,1),(Td(i),i=8,14) c----------------------------------------------------------------------- c Print out results for 30 day months (90 day quarters) c----------------------------------------------------------------------- WRITE(Mt1,Tdfmt)daylbl(j,2),(Td(i),i=1,7) c----------------------------------------------------------------------- c Print out results for Leap year Februaries (First Quarters) c----------------------------------------------------------------------- WRITE(Mt1,Tdfmt)daylbl(j,3),(Td(i),i=22,28) c----------------------------------------------------------------------- c Print out results for Leap year First Quarters c----------------------------------------------------------------------- IF(Ny.eq.4)WRITE(Mt1,Tdfmt)daylbl(j,4),(Td(i),i=15,21) c----------------------------------------------------------------------- c IF Change of Regime trading day variables were used, c print out trading day from change of regime here. c----------------------------------------------------------------------- IF((Fulltd.or.Tdzero.eq.2).and.Lrgmtd)THEN IF(Tdzero.eq.1)THEN WRITE(Mt1,1010)Ctype,datstr(1:nchdat) ELSE WRITE(Mt1,1020)Ctype,datstr(1:nchdat) END IF WRITE(Mt1,1040)Mq(1:nblank(Mq)) WRITE(Mt1,Tdfmt)daylbl(j,1),(Td1(i),i=8,14) WRITE(Mt1,Tdfmt)daylbl(j,2),(Td1(i),i=1,7) WRITE(Mt1,Tdfmt)daylbl(j,3),(Td1(i),i=22,28) IF(Ny.eq.4)WRITE(Mt1,Tdfmt)daylbl(j,4),(Td1(i),i=15,21) END IF c----------------------------------------------------------------------- RETURN END prttrn.f0000664006604000003110000001773014521201550011674 0ustar sun00315steps SUBROUTINE prttrn(Stc,Trnchr,Ib,Ie,Ktabl,Tblptr) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE GENERATES a table of the trend component with c labels for observations that were replaced because they were c less than zero (for a multipicative seasonal adjustment). c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'tbltitle.prm' INCLUDE 'notset.prm' INCLUDE 'error.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'tfmts.cmn' INCLUDE 'units.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- c Include data dictionary of table formats c----------------------------------------------------------------------- INCLUDE 'tfmts.prm' INCLUDE 'tfmts2.prm' c----------------------------------------------------------------------- CHARACTER fsum*(5),Trnchr*(1),fobs*(5),tblttl*(PTTLEN), & ifmt1a*(110),ifmt2a*(110),fbase*(110),fmtcl2*(110), & ctmp*(1) DOUBLE PRECISION Stc,tmp,xmin,xmax,dvec INTEGER Ib,Ie,Tblptr,iopt,Ktabl,tw2,idate,begtbl,ipos,ntbttl,l,im, & im1,im2,jyr,kyr,nbk,nbk2,i,ldec,ipow,ifmt,nfmt1a,nfmt2a, & npos,nobs,ib1,ie1 DIMENSION Stc(PLEN),Trnchr(PLEN),tmp(PSP+1),ctmp(PSP+1),dvec(1), & idate(2),begtbl(2) c----------------------------------------------------------------------- DOUBLE PRECISION totals,sdev EXTERNAL totals,sdev c----------------------------------------------------------------------- c include files containing DATA statements c----------------------------------------------------------------------- INCLUDE 'tfmts.var' INCLUDE 'tfmts2.var' c----------------------------------------------------------------------- c INITIALIZE variables c----------------------------------------------------------------------- ldec=Kdec ipow=0 iopt=0 DO i=Ib,Ie IF(i.eq.Ib)THEN xmin=Stc(i) xmax=Stc(i) ELSE IF(xmin.gt.Stc(i))xmin=Stc(i) IF(xmax.lt.Stc(i))xmax=Stc(i) END IF END DO c----------------------------------------------------------------------- c Create formats for printing out the table c----------------------------------------------------------------------- IF(Tblwid.gt.9)then write(fobs,1010)Tblwid,ldec 1010 FORMAT('f',i2,'.',i1) ifmt=5 ELSE write(fobs,1020)Tblwid,ldec 1020 FORMAT('f',i1,'.',i1) ifmt=4 end if write(fsum,1010)Tblwid+2,ldec CALL setchr(' ',110,fbase) CALL getstr(TF2DIC,tf2ptr,PTF2,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,ifmt1a,fobs(1:ifmt),fsum,ipos,nfmt1a) CALL setchr(' ',110,fbase) CALL getstr(TF2DIC,tf2ptr,PTF2,Iptr+1,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,ifmt2a,fobs(1:ifmt),fsum,ipos,nfmt2a) c----------------------------------------------------------------------- c Construct revised format for column headings. c----------------------------------------------------------------------- c tw2=Tblwid+1 tw2=Tblwid if(tw2.gt.9)then write(fobs,1030)tw2 1030 FORMAT('a',i2) ifmt=3 else write(fobs,1040)tw2 1040 FORMAT('a',i1) ifmt=2 end if write(fsum,1030)tw2+2 CALL setchr(' ',110,fbase) CALL getstr(TFMDIC,tfmptr,PTFM,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,fmtcl2,fobs(1:ifmt),fsum(1:3),ipos,npos) fmtcl2(1:npos)=Ifmt2(1:6)//fmtcl2(7:npos) c----------------------------------------------------------------------- c Generate headers and subheaders for the table c----------------------------------------------------------------------- CALL getdes(Tblptr,tblttl,ntbttl,T) IF(Lfatal)RETURN nobs=Ie-Ib+1 begtbl(YR)=Lyr begtbl(MO)=mod(Ib,Ny) IF(begtbl(MO).eq.0)begtbl(MO)=Ny IF(Ib.gt.Pos1bk)begtbl(YR)=begtbl(YR)+((Ib-1)/Ny)-((Pos1bk-1)/Ny) CALL tblhdr(Ktabl,0,Ixreg,nobs,begtbl,Ny,dvec,tblttl(1:ntbttl)) IF(Lfatal)RETURN IF(Ny.eq.4)THEN l=5 ELSE l=13 END IF CALL prtcol(l,0,Tblcol,tw2,Ny,Mt1,2,'TOTAL',Disp2,Disp3,fmtcl2, & Colhdr) c----------------------------------------------------------------------- c print out table c----------------------------------------------------------------------- jyr=Lyr+(Ib-1)/Ny kyr=(Ie+Ny-1)/Ny+Lyr-1 * iin=iin+(jyr-Lyr) DO i=1,PSP+1 tmp(i)=DNOTST ctmp(i)=' ' END DO ib1=Ib ie1=(jyr-Lyr+1)*Ny IF(ie1.gt.Ie)ie1=Ie im=Ib-(Ib-1)/Ny*Ny DO WHILE (T) im1=im DO i=ib1,ie1 tmp(im)=Stc(i) ctmp(im)=Trnchr(i) im=im+1 END DO im2=im-1 tmp(l)=totals(tmp,im1,im2,1,0) c----------------------------------------------------------------------- c Compute number of blanks for the beginning or end of the series c for observations not in the series. c----------------------------------------------------------------------- nbk=0 IF(jyr.eq.begtbl(YR).and.begtbl(MO).gt.1)nbk=begtbl(MO) nbk2=0 IF(ie1.eq.Ie)THEN CALL addate(begtbl,Ny,nobs-1,idate) nbk2=idate(MO) IF(nbk2.eq.Ny)nbk2=0 END IF c----------------------------------------------------------------------- c Write out this year's data. c----------------------------------------------------------------------- CALL wrttb2(tmp,ctmp,jyr,'XXXXX',l,ldec,Mt1,ifmt1a(1:nfmt1a), & tw2,Tblcol,Disp1,Disp2,Disp3,nbk,nbk2,ipow,0, & l.eq.13.or.l.eq.5) IF(Lfatal)RETURN WRITE(Mt1,1050) 1050 FORMAT(' ') c----------------------------------------------------------------------- c Update year, starting and ending position of year c----------------------------------------------------------------------- jyr=jyr+1 im=1 ib1=ie1+1 ie1=ie1+Ny IF(kyr.eq.jyr)THEN DO i=1,Ny tmp(i)=DNOTST END DO ie1=Ie ELSE IF(kyr.lt.jyr)THEN ie1=Ib+Ny-1 im=Ib-(Ib-1)/Ny*Ny nbk=0 nbk2=0 DO i=Ib,ie1 ctmp(im)=' ' IF(i.gt.Ie)THEN tmp(im)=DNOTST IF(i.eq.im)THEN IF(nbk2.eq.0)nbk2=im-1 ELSE IF(nbk.eq.0)nbk=1 nbk=nbk+1 END IF ELSE tmp(im)=totals(Stc,i,Ie,Ny,1) END IF IF(im.eq.Ny)im=0 im=im+1 END DO C --- GENERATE COLUMN SUMMARY FORMATS. c02 WRITE(MT1,IF2) TYRLY(NOP1),(TMP(I),I = 1,NY) CALL wrttb2(tmp,ctmp,0,'AVGE ',Ny,ldec,Mt1,ifmt2a(1:nfmt2a), & tw2,Tblcol,Disp1,Disp2,Disp3,nbk,nbk2,ipow,0,F) IF(Lfatal)RETURN tmp(1)=totals(Stc,Ib,Ie,1,0) tmp(2)=tmp(1)/dble(Ie-Ib+1) tmp(3)=sdev(Stc,Ib,Ie,1,iopt) C --- WRITE TABLE SUMMARY. WRITE(Mt1,Ifmt3)(tmp(i),i=1,3),xmin,xmax GO TO 10 END IF END DO c----------------------------------------------------------------------- 10 IF(Lwdprt)THEN WRITE(Mt1,1060)PRGNAM ELSE WRITE(Mt1,1070)PRGNAM END IF 1060 FORMAT(//,' * - Trend cycle estimate that had a negative', & ' value replaced by ',a,'.') 1070 FORMAT(//,' * - Trend cycle estimate that had a negative ', & 'value replaced by',/,' ',a,'.') c----------------------------------------------------------------------- RETURN END prtukp.f0000664006604000003110000001305614521201550011665 0ustar sun00315steps SUBROUTINE prtukp(Mt,Iagr,Ny,Lsvlg) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'arima.cmn' INCLUDE 'title.cmn' INCLUDE 'tukey.cmn' INCLUDE 'rho.cmn' INCLUDE 'error.cmn' INCLUDE 'spctbl.i' c----------------------------------------------------------------------- LOGICAL Lsvlg CHARACTER thisLb*(36),cPeak*(2),begstr*(10),endstr*(10) INTEGER Mt,Iagr,i,k,nLb,nchr1,nchr2,Ny DOUBLE PRECISION thisPk,thisTd DIMENSION thisPk(6),cPeak(7) c----------------------------------------------------------------------- IF(Lpage.and.(.not.Lsvlg))THEN WRITE(Mt,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(Iagr.eq.4)THEN WRITE(Mt,1000)' Peak probabilities for Tukey spectrum '// & 'estimator: Indirect adjustments' ELSE WRITE(Mt,1000) & ' Peak probabilities for Tukey spectrum estimator' END IF c----------------------------------------------------------------------- CALL wrtdat(Bgspec,Ny,begstr,nchr1) IF(.not.Lfatal)CALL wrtdat(Endspn,Ny,endstr,nchr2) IF(Lfatal)RETURN WRITE(Mt,1020)begstr(1:nchr1),endstr(1:nchr2) WRiTE(Mt,1005) c----------------------------------------------------------------------- DO i=1,Ntukey thisLb=' ' c----------------------------------------------------------------------- c Set up labels, peak vectors c----------------------------------------------------------------------- IF(Itukey(i).eq.LSPCRS)THEN CALL copy(Ptsr,6,1,thisPk) thisTD=Pttdr nLb=16 thisLb(1:nLb)=' Model Residuals' ELSE IF(Itukey(i).eq.LSPTS0.or.Itukey(i).eq.LSPT0C)THEN CALL copy(Ptso,6,1,thisPk) thisTD=Pttdo CALL mkspst(Spcsrs,thisLb,nLb,k,.true.) ELSE IF(Itukey(i).eq.LSPTS1.or.Itukey(i).eq.LSPT1I.or. & Itukey(i).eq.LSPT1S)THEN CALL copy(Ptsa,6,1,thisPk) thisTD=Pttda IF(Itukey(i).eq.LSPTS1)THEN IF(Lrbstsa)THEN nLb=32 thisLb(1:nLb)=' Seasonally adjusted series (E2)' ELSE nLb=33 thisLb(1:nLb)=' Seasonally adjusted series (D11)' END IF ELSE IF(Itukey(i).eq.LSPT1I)THEN IF(Lrbstsa)THEN nLb=33 thisLb(1:nLb)=' Ind. Seasonally adj. series (E2)' ELSE nLb=34 thisLb(1:nLb)=' Ind. Seasonally adj. series (D11)' END IF ELSE IF(Itukey(i).eq.LSPT1S)THEN nLb=35 thisLb(1:nLb)=' Seasonally adjusted series (SEATS)' END IF ELSE IF(Itukey(i).eq.LSPTS2.or.Itukey(i).eq.LSPT2I.or. & Itukey(i).eq.LSPT2S)THEN CALL copy(Ptsi,6,1,thisPk) thisTD=Pttdi IF(Itukey(i).eq.LSPTS2)THEN IF(Lrbstsa)THEN nLb=24 thisLb(1:nLb)=' Modified Irregular (E3)' ELSE nLb=16 thisLb(1:nLb)=' Irregular (D13)' END IF ELSE IF(Itukey(i).eq.LSPT2I)THEN IF(Lrbstsa)THEN nLb=33 thisLb(1:nLb)=' Indirect Modified Irregular (E3)' ELSE nLb=25 thisLb(1:nLb)=' Indirect Irregular (D13)' END IF ELSE IF(Itukey(i).eq.LSPT2S)THEN IF(Lrbstsa)THEN nLb=29 thisLb(1:nLb)=' Stochastic Irregular (SEATS)' ELSE nLb=18 thisLb(1:nLb)=' Irregular (SEATS)' END IF END IF END IF c----------------------------------------------------------------------- c Set up c----------------------------------------------------------------------- DO k=1,6 IF(thisPk(k).gt.0.99D0)THEN cPeak(k)='**' ELSE IF(thisPk(k).gt.0.90D0)THEN cPeak(k)='* ' ELSE cPeak(k)=' ' END IF END DO IF(thisTD.gt.0.99D0)THEN cPeak(7)='**' ELSE IF(thisTD.gt.0.90D0)THEN cPeak(7)='* ' ELSE cPeak(7)=' ' END IF c----------------------------------------------------------------------- c Write out probabilities and peak labels for each seasonal freq, c trading day c----------------------------------------------------------------------- IF(Lsvlg)then WRITE(Mt,1030)thisLb,(cPeak(k),k=1,6),cPeak(7) ELSE WRITE(Mt,1010)thisLb,(thisPk(k),cPeak(k),k=1,6),thisTD,cPeak(7) * WRITE(Mt,1010)thisLb,(thisPk(k),k=1,6),thisTD * WRITE(Mt,1020)(cPeak(k),k=1,6),cPeak(7) END IF END DO WRITE(Mt,1040) c----------------------------------------------------------------------- 1000 FORMAT(/,a) 1005 FORMAT(40x, & ' S1 S2 S3 S4 S5 S6 TD', & /,40x, & '------ ------ ------ ------ ------ ------ ------') * 1000 FORMAT(a,/,40x,' S1 S2 S3 S4 S5 S6 TD',/, * & 40x,'----- ----- ----- ----- ----- ----- -----') 1010 FORMAT(1x,A36,3x,7(F6.3,A2,1x)) 1020 FORMAT(' Spectrum estimated from ',a,' to ',a,'.',/) * 1010 FORMAT(1x,A36,3x,7(F5.3,1x)) * 1020 FORMAT(40x,7(2x,a2,2x)) 1030 FORMAT(1x,A36,3x,7(3x,a2,4x)) 1040 FORMAT(' ----------',/, & 5x,'** - Peak Probability > 0.99,',/, & 5x,' * - 0.90 < Peak Probability < 0.99',//) c----------------------------------------------------------------------- RETURN END prtxrg.f0000664006604000003110000006377714521201550011705 0ustar sun00315stepsC Last change: BCM 10 Dec 1998 10:33 am SUBROUTINE prtxrg(Lestim,Lprtes,Lsaves,Lprtcm,Lsavcm,Itbles,Fh, & Ldiag) IMPLICIT NONE c----------------------------------------------------------------------- c Prints out the X-11 regression estimates, standard errors and c t-values c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begcol i Local index for the begining column in b of the current c group of regression effects c endcol i Local index for the last column in b of the current c group of regression effects c i i Local do loop index c igrp i Local do loop index for the current group of regression c variables, suchas trading day c ndf i Local number of degrees of freedom, nefobs-nb c nefobs i Number of effective observations, nw, the length of the c differenced series is used if exact AR and MA, nwp, the c length of the AR filtered data if conditional used or only c exact MA. c nelt i Local number of elements in the packed form of c chol([X:y]'[X:y]) c rmse d Local root mean square error a'a/(nefobs-nb). Note, a'a c is the ncth diagonal element of the cholesky c decomposition of the filtered [X:y]'[X:y] matrix c seb d Local standard error of the current regression estimate, c b(i). Seb=sqrt(X'X[i,i])*rmse c tmp d Local temporary scalar c tval d Local t-value=b(i)/seb c xpxinv d Local pb(pb+1)/2, ncxy(ncxy+1)/2 used vector to hold the c packed form of the inverse of X'X c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) DOUBLE PRECISION TWO,TWOPT5,ZERO PARAMETER(TWO=2D0,TWOPT5=2.5D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'units.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'cogreg.prm' c----------------------------------------------------------------------- INTEGER PTBLWD,PDRV PARAMETER(PTBLWD=PGRPCR+6,PDRV=4) c----------------------------------------------------------------------- CHARACTER blnk*(5),colstr*(PCOLCR),grpstr*(PGRPCR),str*(PGRPCR), & starz*(2),begstr*(10),endstr*(10),marker*(5),cfix*(7), & fixdrv*(7),drvttl*((PCOLCR+PGRPCR+1)*PDRV), & drvstr*(PCOLCR+PGRPCR+1) LOGICAL ldrvfc,ldrvf1,fcnok,Lestim,lfrtgr,linhol,linotl,lishol, & lisotl,lnewgr,lprchi,Lprtes,lprthd,lprtrs,lprund,lprvar, & Lsaves,Lprtcm,Lsavcm,Ldiag,lprrgm INTEGER baselt,begcol,endcol,Fh,i,icol,igrp,info,jcol,Itbles, & nblnk,nchr,ncol,nefobs,nelt,ngrpcr,ncolcr,tbwdth,regidx, & nfix,df,nb2,j,nbeg,nend,drvptr,ndrvtl,ndrv,imark,msg, & imsg,tmsg DOUBLE PRECISION chi2vl,dpmpar,pv,rmse,seb,sumb,sumvar,tmp,tval, & xpxinv,bdrv,sedrv,tvdrv c DIMENSION xpxinv(PB*(PB+1)/2),tmp(2),regidx(PB) DIMENSION xpxinv(PXPX),tmp(2),regidx(PB),bdrv(PDRV),sedrv(PDRV), & drvptr(0:PDRV),msg(4),tvdrv(PDRV),fixdrv(0:PDRV) c----------------------------------------------------------------------- c Bob Fay moved EXTERNAL statement up c----------------------------------------------------------------------- EXTERNAL dpmpar c----------------------------------------------------------------------- DATA blnk/' '/ c----------------------------------------------------------------------- INCLUDE 'cogreg.var' c----------------------------------------------------------------------- c Open the save file to print the estimates if necessary. c----------------------------------------------------------------------- nb2=0 ndrvtl=0 ndrv=0 cfix=' ' IF(Ldiag)THEN CALL intlst(PDRV,drvptr,ndrvtl) ndrv=ndrvtl+1 END IF IF(Lsaves.and.(Irev.le.1.and.Issap.le.1))THEN CALL opnfil(T,F,Itbles,Fh,fcnok) IF(.not.fcnok)THEN CALL abend RETURN END IF END IF tmsg=0 CALL setint(0,4,msg) c----------------------------------------------------------------------- c Print out the convergence error messages and determine what to c print depending on whether or not the model converged. If the model c does converge, report the number of iterations and print the estimates c and standard errors. c----------------------------------------------------------------------- nefobs=Nspobs-Nintvl c CALL prterr(nefobs,Lestim) c IF(Lfatal)RETURN c----------------------------------------------------------------------- c Report convergence c----------------------------------------------------------------------- IF(Convrg)THEN IF(.not.Lhiddn.and.Lestim.and.Nestpm.gt.0)THEN IF(Lprtes)WRITE(Mt1,120)Nliter,Nfev END IF END IF 120 FORMAT(' Estimation converged in',i5,' ARMA iterations,',i5, & ' function evaluations.') c----------------------------------------------------------------------- c Print estimates only or SE and other tests. If the model has not c converged the standard errors, t-statistics, chi^2 tests, and c MLE variance will not be printed out. c----------------------------------------------------------------------- lprchi=Lprtes lprvar=Lprtes c----------------------------------------------------------------------- lprtrs=T IF(Convrg.and.Var.gt.2D0*dpmpar(1))THEN tbwdth=PTBLWD ELSE lprtrs=F tbwdth=37 lprchi=F END IF IF(Ldiag)WRITE(Nform,1000)'nxreg: ',Nb 1000 FORMAT(a,i3) c----------------------------------------------------------------------- c Find the number of columns in [X:y] and the number of regression c variables. c----------------------------------------------------------------------- IF(Ngrp.gt.0)THEN c ------------------------------------------------------------------ c Generate number of unfixed regressors c ------------------------------------------------------------------ nb2=Nb IF(Iregfx.ge.2)THEN DO j=1,Nb IF(Regfx(j))nb2=nb2-1 END DO END IF c----------------------------------------------------------------------- c Get the root mean square error and X'X inverse. c----------------------------------------------------------------------- IF(nb2.gt.0)THEN c nelt=Ncxy*(Ncxy+1)/2 nelt=(nb2+1)*(nb2+2)/2 c----------------------------------------------------------------------- IF(Var.gt.2D0*dpmpar(1))THEN rmse=sqrt(Var) CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,nb2,tmp,1) c CALL dppdi(xpxinv,Nb,tmp,1) c----------------------------------------------------------------------- ELSE rmse=ZERO END IF ELSE rmse=ZERO END IF c----------------------------------------------------------------------- c Print out the regression estimates, standard errors, and t-values c for each regression group. c----------------------------------------------------------------------- IF(Lprtes)THEN WRITE(Mt1,1010) 1010 FORMAT(/,' Regression Model') WRITE(Mt1,1020)('-',i=1,tbwdth) 1020 FORMAT(' ',120(a)) c----------------------------------------------------------------------- IF(lprtrs)THEN WRITE(Mt1,1030) 1030 FORMAT(t30,'Parameter',t47,'Standard',/,' Variable',t31, & 'Estimate',t50,'Error',t61,'t-value') c----------------------------------------------------------------------- ELSE WRITE(Mt1,1040) 1040 FORMAT(t30,'Parameter',/,' Variable',t34,'Value') END IF c----------------------------------------------------------------------- WRITE(Mt1,1020)('-',i=1,tbwdth) END IF c----------------------------------------------------------------------- IF(Lsaves)WRITE(Fh,1050)TABCHR,TABCHR,TABCHR,TABCHR,TABCHR,TABCHR 1050 FORMAT('$regression:',/,'$regression$estimates:',/,'group',a, & 'variable',a,'estimate',a,'standard error',/,'-----',a, & '--------',a,'-----------',a,'--------------') c----------------------------------------------------------------------- c Foreach regression variable or group of variables find their c starting and ending columns and initialize variables indicate c whether c----------------------------------------------------------------------- ldrvfc=F ldrvf1=F lfrtgr=T linhol=F linotl=F nfix=0 c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 lnewgr=T lishol=Rgvrtp(begcol).eq.PRGTTH.or.Rgvrtp(begcol).eq.PRGTLD.or. & ((Rgvrtp(begcol).eq.PRGTEC.or.Rgvrtp(begcol).eq.PRGTEA) & .and.(begcol-endcol).eq.0) lisotl=Rgvrtp(begcol).eq.PRGTAO c----------------------------------------------------------------------- c Get the title of the regression group and indicate whether the c group/effect is and outlier or holiday effect. c----------------------------------------------------------------------- CALL getstr(Grpttl,Grpptr,Ngrp,igrp,grpstr,ngrpcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c For each regression variable in the group calculate the standard c error and t-value if the variance in nonzero c----------------------------------------------------------------------- DO icol=begcol,endcol IF(Regfx(icol))THEN seb=ZERO nfix=nfix+1 regidx(icol)=NOTSET ELSE regidx(icol)=icol-nfix seb=sqrt(xpxinv(regidx(icol)*(regidx(icol)+1)/2))*rmse END IF c----------------------------------------------------------------------- c compute t value, or set to zero is se is zero c----------------------------------------------------------------------- IF(seb.gt.ZERO)THEN tval=B(icol)/seb ELSE tval=ZERO END IF c----------------------------------------------------------------------- c Get the title of the effect c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,icol,colstr,ncolcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Set up the formatting. New groups of effects skip a line before c the title unless it is the first group which is under the title or c is an outlier effect following another outlier or a holiday effect c following another holiday effect. Effects within a group are indented c but groups of single effects are not. c----------------------------------------------------------------------- IF(Lprtes)THEN IF(.not.lfrtgr.and.lnewgr)THEN IF(.not.((lishol.and.linhol).or.(lisotl.and.linotl))) & WRITE(Mt1,'()') END IF c----------------------------------------------------------------------- IF(lnewgr)THEN linhol=lishol linotl=lisotl c----------------------------------------------------------------------- IF(grpstr(1:ngrpcr).ne.colstr(1:ncolcr))THEN WRITE(Mt1,1060)grpstr(1:ngrpcr) 1060 FORMAT(' ',a) nblnk=3 ELSE nblnk=1 END IF END IF c----------------------------------------------------------------------- c Now that the group title has been printed it is nolonger a new c or first group. c----------------------------------------------------------------------- lnewgr=F lfrtgr=F c----------------------------------------------------------------------- c If the regressor is a change of regime regressor, ensure that the c proper label is printed next to the regressor name. c----------------------------------------------------------------------- marker=blnk imark=Rgvrtp(icol) IF((imark.ge.PRRTSE.and.imark.le.PRRTSL).or.(imark.ge.PRATSE & .and.imark.le.PRATSL).or.(imark.ge.PRR1TD.and. & imark.lt.PRGTUH))THEN IF(index(grpstr(1:ngrpcr),'change for after').gt.0)THEN marker(2:3)='@@' imsg=4 ELSE IF(index(grpstr(1:ngrpcr),'change for before').gt.0)THEN marker(2:3)='&&' imsg=2 ELSE IF(index(grpstr(1:ngrpcr),'starting').gt.0)THEN marker(3:3)='@' imsg=3 ELSE marker(3:3)='&' imsg=1 END IF c----------------------------------------------------------------------- c set up indicator variable for descriptive message following c regressor printout c----------------------------------------------------------------------- IF(imark.ge.PRR1TD)THEN tmsg=3 ELSE IF(imark.ge.PRRTSE.and.imark.le.PRRTSL)THEN tmsg=imark-PRRTSE+1 ELSE tmsg=imark-PRATSE+1 END IF IF(msg(imsg).gt.0.and.msg(imsg).ne.tmsg)THEN msg(imsg)=9 ELSE IF(msg(imsg).eq.0)THEN msg(imsg)=tmsg END IF END IF c----------------------------------------------------------------------- c Print the regression estimates and possibly the standard errors c and t-values. c----------------------------------------------------------------------- cfix=' ' IF((.not.Regfx(icol)).and.lprtrs)THEN WRITE(Mt1,1070)marker(1:nblnk),colstr(1:ncolcr),B(icol),seb, & tval 1070 FORMAT(a,a,t25,f14.4,:f16.5,:f13.2) c----------------------------------------------------------------------- ELSE IF(Regfx(icol))THEN WRITE(Mt1,1071)marker(1:nblnk),colstr(1:ncolcr),B(icol), & ' (fixed)' cfix='(fixed)' ELSE WRITE(Mt1,1070)marker(1:nblnk),colstr(1:ncolcr),B(icol) END IF END IF c----------------------------------------------------------------------- IF(Lsaves)WRITE(Fh,1080)grpstr(1:ngrpcr),TABCHR, & colstr(1:ncolcr),TABCHR,B(icol),TABCHR, & seb,TABCHR,cfix IF(Ldiag)WRITE(Nform,2080)grpstr(1:ngrpcr),'$', & colstr(1:ncolcr),': ',B(icol),' ', & seb,' ',tval,' ',cfix 1080 FORMAT(sp,a,a,a,a,e22.15,a,e22.15,a,a) 2080 FORMAT(sp,a,a,a,3(a,e22.15),a,a) END DO c----------------------------------------------------------------------- c For Trading day, and Stock Trading Day c----------------------------------------------------------------------- IF(Lprtes.and.lprtrs)THEN ncolcr=0 CALL setchr(' ',PCOLCR,colstr) IF((grpstr(1:min(11,ngrpcr)).eq.'Trading Day'.and. & begcol.lt.endcol).or. & grpstr(1:min(17,ngrpcr)).eq.'Stock Trading Day')THEN ncolcr=3 colstr(1:ncolcr)='Sun' IF(((.not.Fulltd).and.index(grpstr(1:ngrpcr),'(before').gt.0) & .or.index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN ncolcr=5 colstr(1:ncolcr)='Sun I' ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0 & .or.index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN ncolcr=6 colstr(1:ncolcr)='Sun II' END IF c----------------------------------------------------------------------- ELSE IF(grpstr(1:min(11,ngrpcr)).eq.'Trading Day'.and. & begcol.eq.endcol)THEN ncolcr=7 colstr(1:ncolcr)='Sat/Sun' IF(((.not.Fulltd).and.index(grpstr(1:ngrpcr),'(before').gt.0) & .or.index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN ncolcr=9 colstr(1:ncolcr)='Sat/Sun I' ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0 & .or.index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN ncolcr=10 colstr(1:ncolcr)='Sat/Sun II' END IF END IF c----------------------------------------------------------------------- IF(ncolcr.gt.0)THEN IF(begcol.eq.endcol)THEN ldrvf1=T starz='**' ELSE ldrvfc=T starz=' *' END IF cfix= ' ' IF(Var.gt.ZERO)THEN c----------------------------------------------------------------------- c Sum the coefficient estimates b(begcol) + ... + b(endcol). Also c compute the variance of this sum and the corresponding t-statistic c (tstat). c----------------------------------------------------------------------- sumb=-B(begcol) IF(regidx(begcol).eq.NOTSET)THEN baselt=NOTSET sumvar=0D0 ELSE baselt=regidx(begcol)*(regidx(begcol)+1)/2 sumvar=xpxinv(baselt) END IF c----------------------------------------------------------------------- IF(begcol.eq.endcol)THEN sumb=sumb*TWOPT5 IF(baselt.ne.NOTSET)seb=(sqrt(sumvar)*rmse)*TWOPT5 ELSE DO icol=begcol+1,endcol sumb=sumb-B(icol) IF(regidx(icol).ne.NOTSET)THEN baselt=(regidx(icol)-1)*regidx(icol)/2 sumvar=sumvar+xpxinv(baselt+regidx(icol)) c----------------------------------------------------------------------- DO jcol=begcol,icol-1 IF(regidx(jcol).ne.NOTSET) & sumvar=sumvar+TWO*xpxinv(baselt+regidx(jcol)) END DO END IF END DO IF(baselt.ne.NOTSET)seb=sqrt(sumvar)*rmse END IF c----------------------------------------------------------------------- IF(baselt.ne.NOTSET)THEN tval=sumb/seb WRITE(Mt1,1070)blnk(1:nblnk-2)//starz,colstr(1:ncolcr) & //' (derived)',sumb,seb,tval c----------------------------------------------------------------------- ELSE WRITE(Mt1,1071)blnk(1:nblnk-2)//starz,colstr(1:ncolcr) & //' (derived)',sumb,' (fixed)' 1071 FORMAT(a,a,t25,f14.4,a16) cfix='(fixed)' seb=ZERO tval=ZERO END IF c----------------------------------------------------------------------- ELSE sumb=-B(begcol) IF(begcol.eq.endcol)THEN sumb=sumb*TWOPT5 ELSE DO icol=begcol+1,endcol sumb=sumb-B(icol) END DO END IF c----------------------------------------------------------------------- WRITE(Mt1,1070)blnk(1:nblnk-2)//starz,colstr(1:ncolcr) & //' (derived)',sumb,ZERO END IF IF(Ldiag)THEN CALL insstr(grpstr(1:ngrpcr)//'$'//colstr(1:ncolcr),ndrv, & PDRV,drvttl,drvptr,ndrvtl) IF(Lfatal)RETURN bdrv(ndrvtl)=sumb sedrv(ndrvtl)=seb fixdrv(ndrvtl)=cfix tvdrv(ndrvtl)=tval ndrv=ndrv+1 END IF END IF END IF END DO IF(Ldiag.and.ndrvtl.gt.0)THEN WRITE(Nform,1081)ndrvtl 1081 FORMAT('nxregderived: ',i3) DO icol=1,ndrvtl CALL getstr(drvttl,drvptr,Ndrvtl,icol,drvstr,nchr) IF(Lfatal)RETURN WRITE(Nform,1082)drvstr(1:nchr),': ',bdrv(icol),' ', & sedrv(icol),' ',tvdrv(icol),' ',fixdrv(icol) 1082 FORMAT(sp,a,3(a,e22.15),a,a) END DO END IF c----------------------------------------------------------------------- c Print the tail line and the derived factor message if there were c any c----------------------------------------------------------------------- IF(Lprtes)THEN WRITE(Mt1,1020)('-',i=1,tbwdth) IF(tmsg.gt.0)THEN lprrgm=F DO imsg=1,4 IF(msg(imsg).gt.0)THEN CALL getstr(COGDIC,cogptr,PCOG,msg(imsg),grpstr,ngrpcr) IF(lprrgm)WRITE(Mt1,'()') IF(imsg.eq.1)THEN WRITE(Mt1,1301)grpstr(1:ngrpcr) ELSE IF(imsg.eq.2)THEN WRITE(Mt1,1302)grpstr(1:ngrpcr) ELSE IF(imsg.eq.3)THEN WRITE(Mt1,1303)grpstr(1:ngrpcr) ELSE WRITE(Mt1,1304)grpstr(1:ngrpcr) END IF IF(.not.lprrgm)lprrgm=T END IF END DO IF((ldrvf1.or.ldrvfc).and.lprtrs)WRITE(Mt1,'()') END IF IF(ldrvfc.and.lprtrs)WRITE(Mt1,1300) IF(ldrvf1.and.lprtrs)THEN IF(ldrvfc)WRITE(Mt1,'()') WRITE(Mt1,1310) END IF c----------------------------------------------------------------------- c Compute and print out the chi^2 tests for the seasonal effects, c and trading day but not Automatically Identified Outliers. c----------------------------------------------------------------------- IF(Iregfx.lt.3.and.(lprchi.or.Ldiag))THEN lprthd=T lprund=F IF(lprchi)lprthd=T c----------------------------------------------------------------------- DO igrp=1,Ngrp CALL eltlen(igrp,Grp,Ngrp,ncol) IF(Lfatal)RETURN begcol=Grp(igrp-1) IF(ncol.gt.1.and.Rgvrtp(begcol).ne.PRGTAA)THEN lprund=T CALL getstr(Grpttl,Grpptr,Ngrp,igrp,str,nchr) IF(Lfatal)RETURN endcol=Grp(igrp)-1 info=0 baselt=regidx(begcol) df=endcol-begcol+1 IF(Iregfx.eq.2)THEN IF(baselt.eq.NOTSET)df=df-1 DO icol=begcol+1,endcol IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE baselt=regidx(icol) END IF END DO END IF IF(baselt.ne.NOTSET) & CALL chitst(xpxinv,begcol,endcol,chi2vl,pv,regidx,T,info) CALL savchi(Ldiag,F,lprthd,tbwdth,baselt,str,nchr,info,df, & chi2vl,pv,CNOTST,'chi$') IF(lprchi)THEN CALL prtchi(Mt1,lprthd,tbwdth,baselt,str,nchr,info,df, & chi2vl,pv,'Regressors') IF(lprthd)lprthd=F END IF END IF END DO c----------------------------------------------------------------------- IF(Ldiag.or.lprchi) & CALL cmpchi(xpxinv,regidx,Ldiag,F,lprchi,lprthd,tbwdth,T) c----------------------------------------------------------------------- c Print the tail line c----------------------------------------------------------------------- IF(lprund)WRITE(Mt1,1020)('-',i=1,tbwdth) END IF END IF c----------------------------------------------------------------------- c Save the covariance matrix and print the correlation matrix c of the regression variables. If not printing out the regression c standard errors don't print out related statistics. c----------------------------------------------------------------------- IF(lprtrs)THEN IF(Lsavcm)CALL svrgcm(nefobs,xpxinv,regidx) IF(.not.Lfatal.and.Lprtcm.and.Iregfx.lt.3) & CALL cormtx(xpxinv,regidx) END IF END IF c----------------------------------------------------------------------- IF(Lprtes)THEN IF(lprvar)THEN c IF(endopr.gt.0)WRITE(Mt1,'()') WRITE(Mt1,1130)Var 1130 FORMAT(/, ' Variance',e33.5) c IF(endopr.gt.0)WRITE(Mt1,1020)('-',i=1,tbwdth) END IF END IF c----------------------------------------------------------------------- IF(Lsaves)THEN WRITE(Fh,1140)TABCHR,Var 1140 FORMAT(sp,'$variance:',/,'ols',a,e21.14) IF(Irev.eq.0.and.Issap.eq.0)THEN CALL fclose(Fh) ELSE CALL wrtdat(Begxrg,Sp,begstr,nbeg) IF(.not.Lfatal)CALL wrtdat(Endxrg,Sp,endstr,nend) IF(Lfatal)RETURN WRITE(Fh,1282)begstr(1:nbeg),endstr(1:nend) 1282 FORMAT('$x11regression$span: ',a,' to ',a) WRITE(Fh,'(1x,a)')'-----' END IF END IF c----------------------------------------------------------------------- 1300 FORMAT(' *For full trading-day effects, the derived ', & 'parameter estimate',/, & ' is obtained indirectly as minus the sum of the', & ' directly estimated',/, & ' parameters that define the effect.') 1301 FORMAT(' &The I values estimate the ',a,' coefficients', & /,' for the span of data before the change date.') 1302 FORMAT(' &&The I values estimate how much the early ',a, & /,' coefficients differ from those estimated for the span', & ' of data',/,' starting at the change date.') 1303 FORMAT(' @The II values estimate the ',a,' coefficients', & /,' for the span of data starting at the change date.') 1304 FORMAT(' @@The II values estimate how much the early ',a, & /,' coefficients differ from those estimated for the span', & ' of data',/,' before the change date.') 1310 FORMAT(' **For the one coefficient trading-day effect, the ', & 'derived',/, & ' parameter estimate is obtained indirectly as minus ', & '-2.5 times',/, & ' the directly estimated parameter that defines ', & 'the effect.') c----------------------------------------------------------------------- RETURN END punch.f0000664006604000003110000000422514521201551011454 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:50 pm **==punch.f processed by SPAG 4.03F at 15:10 on 1 Aug 1994 SUBROUTINE punch(X,Mfda,Mlda,Itbl,Lgraf,Lpct) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'hiddn.cmn' INCLUDE 'extend.cmn' INCLUDE 'title.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONEHND PARAMETER(ONEHND=100D0) c ------------------------------------------------------------------ c Argument Lpct, parameter ONEHND added to allow certain tables to c be printed as percentages - BCM July 2006 c ------------------------------------------------------------------ LOGICAL Lgraf,Lpct INTEGER Mfda,Mlda,Itbl,i DOUBLE PRECISION X,y DIMENSION X(*),y(PLEN) c INTEGER frstdt c DIMENSION frstdt(2) c----------------------------------------------------------------------- * LOGICAL F,T * PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- c Check to see if this is a revisions history, holiday, prior c simultaneous trading day or sliding spans seasonal adjustment run. c ------------------------------------------------------------------ IF(Lhiddn)RETURN c ------------------------------------------------------------------ c Otherwise, store in /rdb format, date then value. c First, if table is to be stored as a percentage, multiply the c series by one hundred - BCM July 2006 c ------------------------------------------------------------------ IF(Lpct)THEN DO i=Mfda,Mlda y(i)=X(i)*ONEHND END DO ELSE DO i=Mfda,Mlda y(i)=X(i) END DO END IF c ------------------------------------------------------------------ c CALL savtbl(Itbl,Begbak,Mfda,Mlda,Ny,X,Serno,Nser) CALL savtbl(Itbl,Begbk2,Mfda,Mlda,Ny,y,Serno,Nser,Lgraf) RETURN c ------------------------------------------------------------------ END putbak.f0000664006604000003110000000207214521201551011623 0ustar sun00315stepsC Last change: BCM 15 Jan 98 11:08 am **==putbak.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE putbak(Lstchr) IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'lex.i' CHARACTER Lstchr*(1) LOGICAL rngbuf EXTERNAL rngbuf c ----------------------------------------------------------------- IF(Pos(PCHAR).le.1)THEN IF(rngbuf(3,Pos(PLINE),Linex,Lineln))THEN Pos(PCHAR)=Lineln ELSE CALL inpter(PERROR,Pos,'Can''t push input buffer back anymore') END IF END IF c ----------------------------------------------------------------- IF(Lstchr.ne.Linex(Pos(PCHAR)-1:Pos(PCHAR)-1))THEN Pos(PCHAR)=Pos(PCHAR)-1 CALL inpter(PERROR,Pos, & '"'//Lstchr//'" is not the last character ') CALL abend RETURN ELSE Pos(PCHAR)=Pos(PCHAR)-1 END IF c ----------------------------------------------------------------- RETURN END putrev.f0000664006604000003110000000351614521201551011666 0ustar sun00315stepsC Last change: BCM 25 Nov 97 10:36 am SUBROUTINE putrev(Inrev,Outrev,Outch,Outind,Iptr,Lrv,Lrvch,Muladd, & Itype,Rvdiff,Indrev) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine puts the values into the proper vector or matrix c for the revisions history analysis c----------------------------------------------------------------------- DOUBLE PRECISION PCT,ZERO LOGICAL F PARAMETER(PCT=100D0,ZERO=0D0,F=.false.) c----------------------------------------------------------------------- INCLUDE 'agr.cmn' c----------------------------------------------------------------------- LOGICAL Lrv,Lrvch DOUBLE PRECISION Inrev,Outrev,Outch,Outind INTEGER Iptr,Itype,Muladd,Rvdiff,Indrev DIMENSION Inrev(*) c----------------------------------------------------------------------- IF(Lrv)THEN Outrev=Inrev(Iptr) IF(Itype.eq.0)THEN IF(Muladd.ne.1)Outrev=Outrev*PCT ELSE IF(Itype.eq.1)THEN IF(Iagr.eq.2.and.Iag.ge.0.and.Indrev.gt.0)THEN IF(Iag.eq.0)Outind=Outind+(Inrev(Iptr)*W) IF(Iag.eq.1)Outind=Outind-(Inrev(Iptr)*W) IF(Iag.eq.2)Outind=Outind*(Inrev(Iptr)*W) IF(Iag.eq.3)Outind=Outind/(Inrev(Iptr)*W) END IF END IF END IF c----------------------------------------------------------------------- IF(Lrvch)THEN Outch=Inrev(Iptr)-Inrev(Iptr-1) IF(Muladd.eq.1.and.Rvdiff.eq.2)THEN IF(Inrev(Iptr-1).le.ZERO)THEN Lrvch=F Rvdiff=-1 END IF END IF IF(Muladd.ne.1.or.Rvdiff.eq.2)Outch=(Outch/Inrev(Iptr-1))*PCT END IF c----------------------------------------------------------------------- RETURN END putstr.f0000664006604000003110000000162214521201551011676 0ustar sun00315stepsC Last change: BCM 2 Apr 98 1:01 pm **==putstr.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE putstr(Str,Pstr,Chrvec,Ptrvec,Nstr) IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'error.cmn' c ----------------------------------------------------------------- CHARACTER Chrvec*(*),Str*(*) INTEGER Nstr,Pstr,Ptrvec DIMENSION Ptrvec(0:Pstr) c ----------------------------------------------------------------- CALL insptr(.true.,len(Str),Nstr+1,Pstr,len(Chrvec),Ptrvec,Nstr) c ----------------------------------------------------------------- IF(.not.Lfatal)Chrvec(Ptrvec(Nstr-1):Ptrvec(Nstr)-1)=Str c ----------------------------------------------------------------- RETURN c ----------------------------------------------------------------- END qcmmnt.f0000664006604000003110000000350714521201551011640 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:21 pm LOGICAL FUNCTION qcmmnt(Str,Nchr) IMPLICIT NONE c----------------------------------------------------------------------- c qcmmnt.f, Release 1, Subroutine Version 1.4, Modified 03 Feb 1995. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'cchars.i' c ----------------------------------------------------------------- CHARACTER chr*1,dmychr*1,Str*(*),tmpstr*5 INTEGER Nchr,nichr,pchr c ----------------------------------------------------------------- CHARACTER getchr*1 EXTERNAL getchr c ----------------------------------------------------------------- IF(getchr(chr).eq.'#')THEN qcmmnt=.true. pchr=len(Str) Nchr=0 DO WHILE (.true.) c ----------------------------------------------------------------- chr=getchr(dmychr) IF(Nchr.ge.pchr)THEN Pos(PCHAR)=Pos(PCHAR)-Nchr nichr=1 CALL itoc(pchr+1,tmpstr,nichr) CALL inpter(PERROR,Pos,'COMMENT must be shorter than '// & tmpstr(:(nichr-1))//' characters.') Pos(PCHAR)=Pos(PCHAR)+Nchr c ----------------------------------------------------------------- ELSE IF(chr.eq.CHREOF)THEN CALL putbak(chr) c ----------------------------------------------------------------- ELSE IF(chr.ne.NEWLIN)THEN Nchr=Nchr+1 Str(Nchr:Nchr)=chr GO TO 10 END IF GO TO 20 10 CONTINUE END DO c ----------------------------------------------------------------- ELSE qcmmnt=.false. CALL putbak(chr) END IF c ----------------------------------------------------------------- 20 RETURN END qcontr.f0000664006604000003110000000270514521201551011646 0ustar sun00315stepsC Last change: BCM 22 Jul 1998 9:40 am **==qcontr.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE qcontr(Mal,Mq) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE PRINTS THE QUALITY CONTROL STATISTICS IN A C --- SUMMARIZED FORM AT THE END OF THE PRINTOUT. c----------------------------------------------------------------------- INCLUDE 'agr.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' c----------------------------------------------------------------------- CHARACTER aggs*(8),atype*(8) INTEGER i,k,Mal,Mq DIMENSION aggs(3),atype(10) c----------------------------------------------------------------------- DATA atype/'M-AUTO ','M-NONE ','M-MLT ','M-ADD ','M-LOG ', & 'Q-AUTO ','Q-NONE ','Q-MLT ','Q-ADD ','Q-LOG '/ DATA aggs/' ','DIRECT ','INDIRECT'/ c----------------------------------------------------------------------- k=Iagr-1 IF(k.lt.1)k=1 i=Mal+3 IF(Mq.eq.4)i=i+5 c----------------------------------------------------------------------- WRITE(Ng,1010)atype(i),Serno(1:6),Title(1:40),aggs(k) 1010 FORMAT(/,2X,A7,2X,A6,' -------- -------- ',A40,2x,A8) IF(Ntitle.gt.40)WRITE(Ng,1020)Title(41:Ntitle) 1020 FORMAT(36X,A) c----------------------------------------------------------------------- RETURN END qdoble.f0000664006604000003110000000620414521201551011604 0ustar sun00315stepsC Last change: BCM 14 Oct 97 9:05 am **==qdoble.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 LOGICAL FUNCTION qdoble(Str,Nchr,Alsoin) IMPLICIT NONE c ----------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER decchr*1,dmychr*1,expchr*1,sgnchr*1,Str*(*) LOGICAL Alsoin,havsgn INTEGER Nchr,nchr2 c ----------------------------------------------------------------- CHARACTER getchr*1 LOGICAL qintgr INTEGER indx EXTERNAL getchr,qintgr,indx c ----------------------------------------------------------------- qdoble=F Alsoin=F c ----------------------------------------------------------------- sgnchr=getchr(dmychr) IF(sgnchr.eq.'+'.or.sgnchr.eq.'-')THEN havsgn=T Nchr=1 Str(Nchr:Nchr)=sgnchr ELSE havsgn=F CALL putbak(sgnchr) Nchr=0 END IF c ----------------------------------------------------------------- qdoble=qintgr(Str(Nchr+1:),nchr2) Alsoin=qdoble IF(qdoble)Nchr=Nchr+nchr2 c ----------------------------------------------------------------- IF(getchr(decchr).eq.'.')THEN Alsoin=F Nchr=Nchr+1 Str(Nchr:Nchr)=decchr c ----------------------------------------------------------------- IF(qintgr(Str(Nchr+1:),nchr2))THEN qdoble=T Nchr=Nchr+nchr2 ELSE IF(.not.qdoble)THEN CALL putbak(decchr) Nchr=Nchr-1 END IF c ----------------------------------------------------------------- ELSE CALL putbak(decchr) END IF c ----------------------------------------------------------------- IF(.not.qdoble.and.havsgn)THEN CALL putbak(sgnchr) Nchr=0 END IF c ----------------------------------------------------------------- IF(qdoble)THEN IF(indx('eEdD^',getchr(expchr)).eq.0)THEN CALL putbak(expchr) c ----------------------------------------------------------------- ELSE Nchr=Nchr+1 Str(Nchr:Nchr)=expchr c ----------------------------------------------------------------- sgnchr=getchr(dmychr) IF(sgnchr.eq.'+'.or.sgnchr.eq.'-')THEN havsgn=T Nchr=Nchr+1 Str(Nchr:Nchr)=sgnchr c ----------------------------------------------------------------- ELSE havsgn=F CALL putbak(sgnchr) END IF c ----------------------------------------------------------------- IF(qintgr(Str(Nchr+1:),nchr2))THEN Alsoin=F Nchr=Nchr+nchr2 c ----------------------------------------------------------------- ELSE IF(havsgn)THEN CALL putbak(sgnchr) Nchr=Nchr-1 END IF CALL putbak(expchr) Nchr=Nchr-1 END IF END IF END IF c ----------------------------------------------------------------- RETURN END qintgr.f0000664006604000003110000000250414521201551011641 0ustar sun00315stepsC Last change: BCM 14 Oct 97 9:11 am **==qintgr.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 LOGICAL FUNCTION qintgr(Str,Nchr) IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'lex.i' c ----------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER chr*1,dmychr*1,Str*(*) INTEGER Nchr,pchr c ------------------------------------------------------------------ CHARACTER getchr*1 EXTERNAL getchr c ----------------------------------------------------------------- pchr=len(Str) qintgr=F Nchr=0 DO WHILE (T) c ----------------------------------------------------------------- IF(Nchr.le.pchr)THEN chr=getchr(dmychr) IF(chr.ge.CZERO.and.chr.le.CNINE)THEN qintgr=T Nchr=Nchr+1 Str(Nchr:Nchr)=chr GO TO 10 END IF c ----------------------------------------------------------------- CALL putbak(chr) END IF GO TO 20 10 CONTINUE END DO c ----------------------------------------------------------------- 20 RETURN END qmap2.f0000664006604000003110000001713414521201551011362 0ustar sun00315steps**==aa0001.f processed by SPAG 6.05Fc at 11:55 on 4 Oct 2004 SUBROUTINE qmap2(Series,Stci,Stci2,Lfda,Llda,Ny,Iagr) IMPLICIT NONE **--AA00013 C C*** Start of declarations rewritten by SPAG c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'force.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'frctbl.i' INCLUDE 'cmptbl.i' c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO,MONE LOGICAL F PARAMETER(F=.false.,ONE=1D0,ZERO=0D0,MONE=-1D0) C C Arguments C DOUBLE PRECISION Series,Stci,Stci2 INTEGER Lfda,Llda,Ny DIMENSION Series(*),Stci(*),Stci2(*) C C Local variables C REAL*8 and11(PYRS),ansum(PYRS),ttf,cratio(PLEN),rratio(PLEN), & delta(PLEN,PLEN),deltapi(PLEN,PLEN),det,esp,r2(PLEN,PYRS), & rtz(PLEN),wcomp1(PLEN,PLEN),wcomp2(PLEN,PLEN), & wcomp3(PLEN,PLEN),xa(PLEN,1),xd(PLEN,1),xx(PLEN,1) DOUBLE PRECISION DABS INTEGER*4 i,j,k,kk,kkt,kmq,naly, & np,npnp INTEGER knpn,npn1,Iagr,ns REAL*8 mx1(PYRS,1),mx2(PYRS,1),mx3(PYRS,1) REAL*8 Cmat(PLEN,PLEN),Omec(PLEN,PLEN),R1(PLEN,PYRS), & Tmx1(PLEN,PLEN),Ttmat(PLEN,PLEN),Ttmat2(PYRS,PLEN) REAL*8 Invr(PYRS,PYRS),Jmat(PYRS,PLEN),Jmatpi(PLEN,PYRS) C DOUBLE PRECISION SIMUL EXTERNAL SIMUL C np=Llda-Lfda+1 * ngrid=Ny C * WRITE (*,'('' NO. OF POINTS '',I4)') np ns=Begyrt-Lfda+1 DO WHILE (ns.le.0) ns=ns+ny END DO naly=(np-ns+1)/Ny npnp=naly*Ny * ne=ns+npnp-1 * write(6,*) 'stpos, naly, npnp = ',ns, naly, npnp C CONSTRUCTION OF MATRIX J AND J PI DO i=1,naly DO j=1,np Jmat(i,j)=ZERO END DO END DO k=ns DO i=1,naly kmq=k+Ny-1 DO j=k,kmq Jmat(i,j)=ONE END DO k=kmq+1 END DO DO i=1,naly DO j=1,np Jmatpi(j,i)=Jmat(i,j) END DO END DO DO j=1,np xx(j,1)=Series(j+Lfda-1) xa(j,1)=Stci(j+Lfda-1) END DO C CONSTRUCTION OF MATRIX C c TFF added by Statstics Canada, March 2006 C *************** modify factor TTF ***************** TTF = 0.0D0 DO I =1, NP TTF = TTF + DABS(XA(I,1)) END DO TTF = TTF/NP DO i=1,np DO j=1,np Cmat(i,j)=ZERO END DO END DO c TFF used to modifiy CMAT by Statstics Canada, March 2006 DO i=1,np CMAT(I,I) = DABS(XA(I,1)/TTF)**LAMDA END DO C ****************************************************** IF (rol.LE.0.99999D00) THEN C CONSTRUCTION OF MATRIX OMECA OMEC IF (rol.LT.1.0D-10) THEN DO i=1,np DO j=1,np Omec(i,j)=ZERO END DO END DO DO i=1,np Omec(i,i)=ONE END DO ELSE DO i=1,np DO j=1,np k=ABS(i-j) Omec(i,j)=rol**k END DO END DO END IF kk=PLEN kkt=PYRS CALL MATMLT(Cmat,Omec,Ttmat,np,np,np,kk,kk,kk) CALL MATMLT(Ttmat,Cmat,Tmx1,np,np,np,kk,kk,kk) CALL MATMLT(Tmx1,Jmatpi,R1,np,np,naly,kk,kk,kk) CALL MATMLT(Jmat,Tmx1,Ttmat2,naly,np,np,kkt,kk,kkt) CALL MATMLT(Ttmat2,Jmatpi,Invr,naly,np,naly,kkt,kk,kkt) esp=1.0D-20 det=SIMUL(naly,Invr,ansum,esp,-1,kkt) CALL MATMLT(R1,Invr,r2,np,naly,naly,kk,kkt,kk) CALL MATMLT(Jmat,xx,mx1,naly,np,1,kkt,kk,kkt) CALL MATMLT(Jmat,xa,mx2,naly,np,1,kkt,kk,kkt) CALL ADD_SUB(mx1,mx2,mx3,naly,1,kkt,0) CALL MATMLT(r2,mx3,xd,np,naly,1,kk,kkt,kk) CALL ADD_SUB(xa,xd,xx,np,1,kk,1) DO j=1,np Stci2(j+Lfda-1)=xx(j,1) END DO ELSE C c inverse of CMAT computed by Statstics Canada, March 2006 C *************************************************************** C ***************** FIND THE INVERSE OF CMAT ******************** C *************************************************************** DO I = 1, NP CMAT(I,I) = ONE/CMAT(I,I) END DO C **************************************************************** C CONSTRUCTION OF MATRIX DELTA npn1=np-1 DO i=1,np DO j=1,np delta(i,j)=ZERO END DO END DO DO i=1,npn1 delta(i,i)=MONE delta(i,i+1)=ONE END DO DO i=1,npn1 DO j=1,np deltapi(j,i)=delta(i,j) END DO END DO C CONSTRUCTION OF MATRIX OMECA OMEC kk=PLEN kkt=PYRS CALL MATMLT(deltapi,delta,Ttmat,np,npn1,np,kk,kk,kk) CALL MATMLT(Cmat,Ttmat,Omec,np,np,np,kk,kk,kk) CALL MATMLT(Omec,Cmat,Tmx1,np,np,np,kk,kk,kk) C TMX1 = C*DEL'*DEL*C, A T by T square matrix. C Construction of the big matrix. knpn=np+naly DO i=1,knpn DO j=1,knpn wcomp1(i,j)=ZERO END DO END DO DO i=1,np DO j=1,np wcomp1(i,j)=Tmx1(i,j) END DO END DO DO i=1,np DO j=1,naly wcomp1(i,np+j)=Jmatpi(i,j) END DO END DO DO i=1,naly DO j=1,np wcomp1(np+i,j)=Jmat(i,j) END DO END DO DO i=1,knpn DO j=1,knpn wcomp2(i,j)=ZERO END DO END DO DO i=1,np DO j=1,np wcomp2(i,j)=Tmx1(i,j) END DO END DO DO i=1,naly wcomp2(np+i,np+i)=ONE END DO DO i=1,naly DO j=1,np wcomp2(np+i,j)=Jmat(i,j) END DO END DO C Find the inverse of WCOMP1 esp=1.0D-10 det=SIMUL(knpn,wcomp1,rratio,esp,-1,kk) CALL MATMLT(wcomp1,wcomp2,wcomp3,knpn,knpn,knpn,kk,kk,kk) C R2 IS A SUBMATRIX OF WCOMP3 DO i=1,np DO j=1,naly r2(i,j)=wcomp3(i,j+np) END DO END DO DO j=1,np xx(j,1)=Series(j+Lfda-1) xa(j,1)=Stci(j+Lfda-1) END DO CALL MATMLT(Jmat,xx,mx1,naly,np,1,kkt,kk,kkt) CALL MATMLT(Jmat,xa,mx2,naly,np,1,kkt,kk,kkt) CALL ADD_SUB(mx1,mx2,mx3,naly,1,kkt,0) CALL MATMLT(r2,mx3,xd,np,naly,1,kk,kkt,kk) CALL ADD_SUB(xa,xd,xx,np,1,kk,1) DO j=1,np Stci2(j+Lfda-1)=xx(j,1) END DO END IF C *********** ADDITION NEW OUTPUT ************** DO j=1,naly ansum(j)=mx1(j,1) and11(j)=mx2(j,1) END DO IF (Mid.EQ.0) THEN DO j=1,np cratio(j)=Stci2(j+Lfda-1)/Stci(j+Lfda-1)-ONE rratio(j)=ZERO END DO ELSE DO j=1,np cratio(j)=Stci2(j+Lfda-1)-Stci(j+Lfda-1) rratio(j)=ZERO END DO END IF CALL MEANCRA(ansum,and11,rtz,Mid,Ny,naly) npnp=naly*Ny DO j=1,npnp rratio(j+ns-1)=rtz(j) END DO IF(Iagr.eq.4)THEN IF(Savtab(LCPCRI))CALL punch(cratio,Lfda,Llda,LCPCRI,F,F) IF(.not.Lfatal.and.Savtab(LCPRRI)) & CALL punch(rratio,Lfda,Llda,LCPRRI,F,F) ELSE IF(Savtab(LFRCCR))CALL punch(cratio,Lfda,Llda,LFRCCR,F,F) IF(.not.Lfatal.and.Savtab(LFRCRR)) & CALL punch(rratio,Lfda,Llda,LFRCRR,F,F) END IF RETURN END qmap.f0000664006604000003110000001136514521201551011300 0ustar sun00315stepsC Last change: BCM 29 Oct 97 7:18 am **==qmap.f processed by SPAG 4.03F at 09:02 on 13 Sep 1994 SUBROUTINE qmap(Series,Stci,Stci2,Lfda,Llda,Ny,Ns,Ne,Nyrt) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION Series,Stci,Stci2 INTEGER i,i1,i2,ii,ij,j,j1,j2,jy,k1,k2,k3,l,l1,l2,Lfda,Llda,n1,n2, & n3 INTEGER n4,Ne,Ns,ntest,Ny,Nyrt,ny2 C*** End of declarations inserted by SPAG DOUBLE PRECISION w,wq,wm1,wm2,tmp1,tmp2,r(186) DIMENSION w(200),wm1(75),wm2(75),wq(50),Series(*),Stci(*),Stci2(*) EQUIVALENCE(w(1),wq(1)),(w(51),wm1(1)),(w(126),wm2(1)) DATA wq/ & 0.3101014D0,-0.0745478D0,0.0179083D0,-0.0042489D0,0.0007868D0, & 0.2860609D0,-0.0447286D0,0.0107450D0,-0.0025492D0,0.0004721D0, & 0.2379797D0,0.0149095D0,-0.0035817D0,0.0008498D0,-0.0001575D0, & 0.1658580D0,0.1043667D0,-0.0250716D0,0.0059485D0,-0.0011016D0, & 0.0696957D0,0.2236430D0,-0.0537249D0,0.0127467D0,-0.0023605D0, & 0.0033526D0,0.2818963D0,-0.0436963D0,0.0103673D0,-0.0019199D0, & -0.0331716D0,0.2791267D0,0.0050143D0,-0.0011897D0,0.0002203D0, & -0.0398767D0,0.2153340D0,0.0924069D0,-0.0219243D0,0.0040601D0, & -0.0167627D0,0.0905184D0,0.2184814D0,-0.0518365D0,0.0095994D0, & -0.0008120D0,0.0043849D0,0.2815186D0,-0.0430668D0,0.0079753D0/ DATA wm1/ & 0.1053950D0,-0.0279005D0,0.0073776D0,-0.0019194D0,0.0003807D0, & 0.1044693D0,-0.0267298D0,0.0070680D0,-0.0018389D0,0.0003647D0, & 0.1026180D0,-0.0243885D0,0.0064489D0,-0.0016778D0,0.0003327D0, & 0.0998410D0,-0.0208766D0,0.0055203D0,-0.0014362D0,0.0002849D0, & 0.0961383D0,-0.0161940D0,0.0042821D0,-0.0011141D0,0.0002210D0, & 0.0915100D0,-0.0103407D0,0.0027344D0,-0.0007114D0,0.0001410D0, & 0.0859560D0,-0.0033168D0,0.0008771D0,-0.0002282D0,0.0000453D0, & 0.0794764D0,0.0048777D0,-0.0012898D0,0.0003356D0,-0.0000666D0, & 0.0720711D0,0.0142429D0,-0.0037662D0,0.0009799D0,-0.0001943D0, & 0.0637402D0,0.0247787D0,-0.0065521D0,0.0017046D0,-0.0003381D0, & 0.0544835D0,0.0364852D0,-0.0096476D0,0.0025100D0,-0.0004978D0, & 0.0443012D0,0.0493624D0,-0.0130527D0,0.0033959D0,-0.0006735D0, & 0.0331933D0,0.0634102D0,-0.0167673D0,0.0043624D0,-0.0008652D0, & 0.0232560D0,0.0750521D0,-0.0189211D0,0.0049227D0,-0.0009764D0, & 0.0144893D0,0.0842882D0,-0.0195142D0,0.0050770D0,-0.0010070D0/ DATA wm2/ & 0.0068933D0,0.0911184D0,-0.0185466D0,0.0048253D0,-0.0009570D0, & 0.0004679D0,0.0955427D0,-0.0160183D0,0.0041675D0,-0.0008267D0, & -0.0047868D0,0.0975612D0,-0.0119292D0,0.0031037D0,-0.0006156D0, & -0.0088708D0,0.0971739D0,-0.0062794D0,0.0016337D0,-0.0003240D0, & -0.0117842D0,0.0943806D0,0.0009312D0,-0.0002423D0,0.0000480D0, & -0.0135270D0,0.0891815D0,0.0097025D0,-0.0025243D0,0.0005007D0, & -0.0140991D0,0.0815765D0,0.0200345D0,-0.0052124D0,0.0010338D0, & -0.0135006D0,0.0715657D0,0.0319272D0,-0.0083065D0,0.0016475D0, & -0.0117315D0,0.0591490D0,0.0453807D0,-0.0118068D0,0.0023417D0, & -0.0087915D0,0.0443265D0,0.0603949D0,-0.0157130D0,0.0031165D0, & -0.0061612D0,0.0310647D0,0.0729068D0,-0.0180586D0,0.0035816D0, & -0.0038405D0,0.0193636D0,0.0829163D0,-0.0188434D0,0.0037373D0, & -0.0018293D0,0.0092233D0,0.0904234D0,-0.0180674D0,0.0035834D0, & -0.0001277D0,0.0006437D0,0.0954281D0,-0.0157308D0,0.0031200D0, & 0.0012644D0,-0.0063752D0,0.0979305D0,-0.0118334D0,0.0023470D0/ Ns=Lfda ntest=(Lfda-1)/Ny*Ny+Nyrt IF(ntest.gt.Lfda)Ns=ntest IF(ntest.lt.Lfda)Ns=ntest+Ny ny2=Nyrt-1 IF(ny2.eq.0)ny2=Ny Ne=(Llda/Ny*Ny)-(Ny-ny2) IF((Llda-Ne).ge.Ny)Ne=Ne+Ny n1=(Ns-1)/Ny+1 n2=Ne/Ny DO i=n1,n2 n3=(i-1)*Ny+Nyrt n4=i*Ny+(Nyrt-1) r(i)=0.0D0 DO j=n3,n4 r(i)=r(i)+Series(j)-Stci(j) END DO END DO jy=0 IF(Ny.eq.12)jy=50 k1=2*Ny DO i=1,k1 i1=Ns+i-1 i2=Ne-i+1 tmp1=Stci(i1) tmp2=Stci(i2) ii=(i-1)*5+jy DO j=1,5 j1=n1+j-1 j2=n2-j+1 ij=ii+j tmp1=tmp1+r(j1)*w(ij) tmp2=tmp2+r(j2)*w(ij) END DO Stci2(i1)=tmp1 Stci2(i2)=tmp2 END DO l1=n1+2 l2=n2-2 DO l=l1,l2 k2=(l-1)*Ny+Nyrt k3=k2+Ny/2-1 j1=l-2 j2=l+2 DO i=k2,k3 i2=2*k2+Ny-i-1 tmp1=Stci(i) tmp2=Stci(i2) ii=5*(i+k1-k2)+1+jy DO j=j1,j2 ij=ii+j-j1 tmp1=tmp1+r(j)*w(ij) tmp2=tmp2+r(j2+j1-j)*w(ij) END DO Stci2(i)=tmp1 Stci2(i2)=tmp2 END DO END DO RETURN END qname.f0000664006604000003110000000443414521201552011443 0ustar sun00315stepsC Last change: BCM 14 Oct 97 9:11 am LOGICAL FUNCTION qname(Astrng,Nchr) IMPLICIT NONE c----------------------------------------------------------------------- c qname.f, Release 1, Subroutine Version 1.4, Modified 03 Feb 1995. c----------------------------------------------------------------------- INCLUDE 'lex.i' c----------------------------------------------------------------------- CHARACTER Astrng*(*),dmychr*1,chr*1,str*5 INTEGER Nchr,nichr,pchr c----------------------------------------------------------------------- CHARACTER getchr*1 EXTERNAL getchr c ----------------------------------------------------------------- qname=.false. pchr=len(Astrng) Nchr=0 c ----------------------------------------------------------------- chr=getchr(dmychr) IF((chr.ge.BIGA.and.chr.le.BIGZ).or. & (chr.ge.LITTLA.and.chr.le.LITTLZ))THEN qname=.true. Nchr=1 Astrng(Nchr:Nchr)=chr DO WHILE (.true.) c ----------------------------------------------------------------- chr=getchr(dmychr) IF((chr.ge.BIGA.and.chr.le.BIGZ).or. & (chr.ge.LITTLA.and.chr.le.LITTLZ).or. & (chr.ge.CZERO.and.chr.le.CNINE).or.chr.eq.'-'.or. & chr.eq.'_'.or.chr.eq.'@'.or.chr.eq.'$'.or.chr.eq.'%'.or. & chr.eq.'.')THEN Nchr=Nchr+1 IF(Nchr.le.pchr)THEN Astrng(Nchr:Nchr)=chr GO TO 10 ELSE Pos(PCHAR)=Pos(PCHAR)-Nchr nichr=1 CALL itoc(pchr+1,str,nichr) CALL inpter(PERROR,Pos,'NAME must be shorter than '// & str(:(nichr-1))//' characters.') Pos(PCHAR)=Pos(PCHAR)+Nchr Lexok=.false. END IF END IF GO TO 20 10 CONTINUE END DO END IF c ----------------------------------------------------------------- 20 CALL putbak(chr) DO WHILE (.true.) IF(qname)THEN IF(Astrng(Nchr:Nchr).eq.'.')THEN CALL putbak(Astrng(Nchr:Nchr)) Nchr=Nchr-1 GO TO 30 END IF END IF c ----------------------------------------------------------------- RETURN 30 CONTINUE END DO END qquote.f0000664006604000003110000000510714521201552011656 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:23 pm LOGICAL FUNCTION qquote(Astrng,Nchr) IMPLICIT NONE c----------------------------------------------------------------------- c qquote.f, Release 1, Subroutine Version 1.4, Modified 03 Feb 1995. c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'cchars.i' c ----------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER Astrng*(*),dmychr*1,chr*1,qchr*1,str*5 INTEGER Nchr,nichr,pchr c ------------------------------------------------------------------ CHARACTER getchr*1 EXTERNAL getchr c ----------------------------------------------------------------- pchr=len(Astrng) Nchr=0 c ----------------------------------------------------------------- chr=getchr(dmychr) IF(chr.ne.'"'.and.chr.ne.'''')THEN qquote=F CALL putbak(chr) c ----------------------------------------------------------------- ELSE qquote=T Nchr=0 qchr=chr DO WHILE (T) c ----------------------------------------------------------------- chr=getchr(dmychr) IF(chr.eq.NEWLIN)THEN Pos(PCHAR)=Pos(PCHAR)-Nchr-2 CALL inpter(PERROR,Pos, &'Quote can''t wrap to next line--end-of-line assumed to be end qu &ote') Pos(PCHAR)=Pos(PCHAR)+Nchr+2 Lexok=F c ----------------------------------------------------------------- ELSE IF(Nchr.ge.pchr)THEN Pos(PCHAR)=Pos(PCHAR)-Nchr nichr=1 CALL itoc(pchr+1,str,nichr) CALL inpter(PERROR,Pos,'QUOTE must be shorter than '// & str(:(nichr-1))//' characters.') Pos(PCHAR)=Pos(PCHAR)+Nchr Lexok=F c ----------------------------------------------------------------- ELSE IF(chr.ne.qchr)THEN Nchr=Nchr+1 Astrng(Nchr:Nchr)=chr GO TO 10 END IF GO TO 20 10 CONTINUE END DO END IF c ----------------------------------------------------------------- 20 IF(qquote.and.Nchr.eq.0)THEN Pos(PCHAR)=Pos(PCHAR)-1 CALL inpter(PERROR,Pos, & 'Quotes must contain at least one character.') Pos(PCHAR)=Pos(PCHAR)+1 Lexok=F END IF c ----------------------------------------------------------------- RETURN END qrfac.f0000664006604000003110000001262614521201552011440 0ustar sun00315stepsC Last change: BCM 29 Sep 97 8:59 am **==qrfac.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE qrfac(M,N,A,Lda,Pivot,Ipvt,Lipvt,Rdiag,Acnorm,Wa) IMPLICIT NONE INTEGER M,N,Lda,Lipvt INTEGER Ipvt(Lipvt) LOGICAL Pivot DOUBLE PRECISION A(Lda,N),Rdiag(N),Acnorm(N),Wa(N) C ********** C C SUBROUTINE QRFAC C C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM C C T C I - (1/U(K))*U*U C C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF A. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). C C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. C C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, C THEN NO COLUMN PIVOTING IS DONE. C C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. C C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN C LIPVT MUST BE AT LEAST N. C C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C DIAGONAL ELEMENTS OF R. C C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE C WITH RDIAG. C C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA C CAN COINCIDE WITH RDIAG. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... DPMPAR,ENORM C C FORTRAN-SUPPLIED ... DMAX1,DSQRT,MIN0 C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER i,j,jp1,k,kmax,minmn DOUBLE PRECISION ajnorm,epsmch,one,p05,sum,temp,zero DOUBLE PRECISION dpmpar,enorm LOGICAL dpeq EXTERNAL dpeq DATA one,p05,zero/1.0D0,5.0D-2,0.0D0/ C C EPSMCH IS THE MACHINE PRECISION. C epsmch=dpmpar(1) C C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. C DO j=1,N Acnorm(j)=enorm(M,A(1,j)) Rdiag(j)=Acnorm(j) Wa(j)=Rdiag(j) IF(Pivot)Ipvt(j)=j END DO C C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. C minmn=min0(M,N) DO j=1,minmn IF(Pivot)THEN C C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. C kmax=j DO k=j,N IF(Rdiag(k).gt.Rdiag(kmax))kmax=k END DO IF(kmax.ne.j)THEN DO i=1,M temp=A(i,j) A(i,j)=A(i,kmax) A(i,kmax)=temp END DO Rdiag(kmax)=Rdiag(j) Wa(kmax)=Wa(j) k=Ipvt(j) Ipvt(j)=Ipvt(kmax) Ipvt(kmax)=k END IF END IF C C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. C ajnorm=enorm(M-j+1,A(j,j)) IF(.not.dpeq(ajnorm,zero))THEN IF(A(j,j).lt.zero)ajnorm=-ajnorm DO i=j,M A(i,j)=A(i,j)/ajnorm END DO A(j,j)=A(j,j)+one C C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS C AND UPDATE THE NORMS. C jp1=j+1 IF(N.ge.jp1)THEN DO k=jp1,N sum=zero DO i=j,M sum=sum+A(i,j)*A(i,k) END DO temp=sum/A(j,j) DO i=j,M A(i,k)=A(i,k)-temp*A(i,j) END DO IF(.not.(.not.Pivot.or.dpeq(Rdiag(k),zero)))THEN temp=A(j,k)/Rdiag(k) Rdiag(k)=Rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) IF(p05*(Rdiag(k)/Wa(k))**2.le.epsmch)THEN Rdiag(k)=enorm(M-j,A(jp1,k)) Wa(k)=Rdiag(k) END IF END IF END DO END IF END IF Rdiag(j)=-ajnorm END DO RETURN C C LAST CARD OF SUBROUTINE QRFAC. C END qrsolv.f0000664006604000003110000001415214521201552011666 0ustar sun00315stepsC Last change: BCM 21 Nov 97 10:24 pm **==qrsolv.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE qrsolv(N,R,Ldr,Ipvt,Diag,Qtb,X,Sdiag,Wa) IMPLICIT NONE INTEGER N,Ldr INTEGER Ipvt(N) DOUBLE PRECISION R(Ldr,N),Diag(N),Qtb(N),X(N),Sdiag(N),Wa(N) C ********** C C SUBROUTINE QRSOLV C C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH C SOLVES THE SYSTEM C C A*X = B , D*X = 0 , C C IN THE LEAST SQUARES SENSE. C C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM C A*X = B, D*X = 0, IS THEN EQUIVALENT TO C C T T C R*Z = Q *B , P *D*P*Z = 0 , C C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT C C T T T C P *(A *A + D*D)*P = S *S . C C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. C C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. C C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. C C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE C DIAGONAL ELEMENTS OF THE MATRIX D. C C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. C C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. C C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. C C WA IS A WORK ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... DABS,DSQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER i,j,jp1,k,kp1,l,nsing DOUBLE PRECISION cosine,cotan,p5,p25,qtbpj,sine,summ,tangnt,temp, & zero LOGICAL dpeq EXTERNAL dpeq DATA p5,p25,zero/5.0D-1,2.5D-1,0.0D0/ C C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. C DO j=1,N DO i=j,N R(i,j)=R(j,i) END DO X(j)=R(j,j) Wa(j)=Qtb(j) END DO C C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. C DO j=1,N C C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. C l=Ipvt(j) IF(.not.dpeq(Diag(l),zero))THEN DO k=j,N Sdiag(k)=zero END DO Sdiag(j)=Diag(l) C C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. C qtbpj=zero DO k=j,N C C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. C IF(.not.dpeq(Sdiag(k),zero))THEN IF(dabs(R(k,k)).ge.dabs(Sdiag(k)))THEN tangnt=Sdiag(k)/R(k,k) cosine=p5/dsqrt(p25+p25*tangnt**2) sine=cosine*tangnt ELSE cotan=R(k,k)/Sdiag(k) sine=p5/dsqrt(p25+p25*cotan**2) cosine=sine*cotan END IF C C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). C R(k,k)=cosine*R(k,k)+sine*Sdiag(k) temp=cosine*Wa(k)+sine*qtbpj qtbpj=-sine*Wa(k)+cosine*qtbpj Wa(k)=temp C C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. C kp1=k+1 IF(N.ge.kp1)THEN DO i=kp1,N temp=cosine*R(i,k)+sine*Sdiag(i) Sdiag(i)=-sine*R(i,k)+cosine*Sdiag(i) R(i,k)=temp END DO END IF END IF END DO END IF C C STORE THE DIAGONAL ELEMENT OF S AND RESTORE C THE CORRESPONDING DIAGONAL ELEMENT OF R. C Sdiag(j)=R(j,j) R(j,j)=X(j) END DO C C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. C nsing=N DO j=1,N IF(dpeq(Sdiag(j),zero).and.nsing.eq.N)nsing=j-1 IF(nsing.lt.N)Wa(j)=zero END DO IF(nsing.ge.1)THEN DO k=1,nsing j=nsing-k+1 summ=zero jp1=j+1 IF(nsing.ge.jp1)THEN DO i=jp1,nsing summ=summ+R(i,j)*Wa(i) END DO END IF Wa(j)=(Wa(j)-summ)/Sdiag(j) END DO END IF C C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. C DO j=1,N l=Ipvt(j) X(l)=Wa(j) END DO RETURN C C LAST CARD OF SUBROUTINE QRSOLV. C END qsdiff.f0000664006604000003110000000246214521201552011615 0ustar sun00315steps SUBROUTINE qsDiff(Srs,Pos1,Posf,Lmodel,Nnsedf,Nseadf,Ny,QS) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- DOUBLE PRECISION Srs,aux,Qs,xmean INTEGER Pos1,Posf,Nnsedf,Nseadf,nz,i,j,k,ndif,posCorr,Ny LOGICAL Lmodel DIMENSION srs(PLEN),aux(PLEN) c----------------------------------------------------------------------- nz=Posf-Pos1+1 do i=Pos1,Posf-1 aux(i-Pos1+1)=srs(i+1)-srs(i) end do k=nz-1 IF(Lmodel)THEN ndif=max(min(2,(Nnsedf+Nseadf)),1) ELSE ndif=1 END IF IF(ndif.gt.1)THEN do j=1,ndif-1 k=k-1 do i=1,k aux(i)=aux(i+1)-aux(i) end do end do END IF CALL smeadl(aux,1,k,k,xmean) call calcQS2(aux,k,ny,QS,posCorr) c----------------------------------------------------------------------- IF(posCorr.eq.1.and.ndif.eq.1)THEN k=k-1 do i=1,k aux(i)=aux(i+1)-aux(i) end do call calcQS2(aux,k,ny,QS,posCorr) END IF c----------------------------------------------------------------------- RETURN END qtoken.f0000664006604000003110000000516314521201552011643 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:21 pm **==qtoken.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE qtoken() IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'cchars.i' c ----------------------------------------------------------------- CHARACTER chr*1,dmychr*1 INTEGER toktyp c ----------------------------------------------------------------- CHARACTER getchr*1 EXTERNAL getchr c ----------------------------------------------------------------- chr=getchr(dmychr) IF(chr.eq.CHREOF.or.chr.eq.NEWLIN)THEN CALL putbak(chr) c ------------------------------------------------------------------ ELSE IF(chr.eq.'{')THEN toktyp=LBRACE c ------------------------------------------------------------------ ELSE IF(chr.eq.'}')THEN toktyp=RBRACE c ------------------------------------------------------------------ ELSE IF(chr.eq.'(')THEN toktyp=LPAREN c ------------------------------------------------------------------ ELSE IF(chr.eq.')')THEN toktyp=RPAREN c ------------------------------------------------------------------ ELSE IF(chr.eq.'[')THEN toktyp=LBRAKT c ------------------------------------------------------------------ ELSE IF(chr.eq.']')THEN toktyp=RBRAKT c ------------------------------------------------------------------ ELSE IF(chr.eq.',')THEN toktyp=COMMA c ------------------------------------------------------------------ ELSE IF(chr.eq.'+')THEN toktyp=PLUS c ------------------------------------------------------------------ ELSE IF(chr.eq.'-')THEN toktyp=MINUS c ------------------------------------------------------------------ ELSE IF(chr.eq.'=')THEN toktyp=EQUALS c ----------------------------------------------------------------- ELSE IF(chr.eq.'.')THEN toktyp=PERIOD c ----------------------------------------------------------------- ELSE IF(chr.eq.'/')THEN toktyp=SLASH c ----------------------------------------------------------------- ELSE IF(chr.eq.'*')THEN toktyp=STAR c ----------------------------------------------------------------- ELSE toktyp=BADTOK END IF Nxtkln=1 Nxtktp=toktyp Nxttok(1:1)=chr END IF c ----------------------------------------------------------------- RETURN END quad.f0000664006604000003110000000477614521201552011305 0ustar sun00315stepsC Last change: BCM 25 Nov 97 11:05 am **==quad.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE quad(A,B1,C,Snr,Sni,Lr,Li) IMPLICIT NONE C ********************************************************************** C * * C * CALCULATE THE ZEROS OF THE QUADRATIC A*Z**2+B1*Z+C. * C * THE QUADRATIC FORMULA, MODIFIED TO AVOID OVERFLOW, IS USED TO * C * FIND THE LARGER ZERO IF THE ZEROS ARE REAL AND BOTH ZEROS * C * ARE COMPLEX. * C * THE SMALLER REAL ZERO IS FOUND DIRECTLY FROM THE PRODUCT OF * C * THE ZEROS C/A. * C * * C ********************************************************************** DOUBLE PRECISION ZERO,TWO PARAMETER(ZERO=0D0,TWO=2D0) C----------------------------------------------------------------------- DOUBLE PRECISION A,B1,C,Snr,Sni,Lr,Li,b,d,e,dabs,dsqrt C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- IF(dpeq(A,ZERO))THEN Snr=ZERO IF(.not.dpeq(B1,ZERO))Snr=-C/B1 Lr=ZERO ELSE IF(.not.dpeq(C,ZERO))THEN C----------------------------------------------------------------------- C COMPUTE DISCRIMINANT AVOIDING OVERFLOW C----------------------------------------------------------------------- b=B1/TWO IF(dabs(b).lt.dabs(C))THEN e=A IF(C.lt.0.D0)e=-A e=b*(b/dabs(C))-e d=dsqrt(dabs(e))*dsqrt(dabs(C)) ELSE e=1.D0-(A/b)*(C/b) d=dsqrt(dabs(e))*dabs(b) END IF IF(e.lt.ZERO)GO TO 10 C----------------------------------------------------------------------- C REAL ZEROS C----------------------------------------------------------------------- IF(b.ge.ZERO)d=-d Lr=(-b+d)/A Snr=ZERO IF(.not.dpeq(Lr,ZERO))Snr=(C/Lr)/A ELSE Snr=ZERO Lr=-B1/A END IF Sni=ZERO Li=ZERO RETURN C----------------------------------------------------------------------- C COMPLEX CONJUGATE ZEROS C----------------------------------------------------------------------- 10 Snr=-b/A Lr=Snr Sni=dabs(d/A) Li=-Sni RETURN END quadit.f0000664006604000003110000001106014521201552011622 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:45 pm SUBROUTINE quadit(Uu,Vv,Nz) IMPLICIT NONE C ********************************************************************** C * * C * VARIABLE- SHIFT K-POLYNOMIAL ITERATION FOR A QUADRATIC FACTOR * C * CONVERGES ONLY IF THE ZEROS ARE EQUIMODULAR OR NEARLY SO.* C * UU,VV - COEFFICIENTS OF STARTING QUADRATIC * C * NZ - NUMBER OF ZERO FOUND * C * * C ********************************************************************** DOUBLE PRECISION ZERO,ONE,TWO,FOUR,FIVE,TWNTY PARAMETER(ZERO=0D0,ONE=1D0,TWO=2D0,FOUR=4D0,FIVE=5D0,TWNTY=20D0) C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'global.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION ui,vi,Uu,Vv,dabs DOUBLE PRECISION mp,omp,ee,relstp,t,zm INTEGER Nz,type,i,j LOGICAL tried C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- Nz=0 tried=.false. U=Uu V0=Vv j=0 DO WHILE (.true.) C----------------------------------------------------------------------- C MAIN LOOP C----------------------------------------------------------------------- CALL quad(ONE,U,V0,Szr,Szi,Lzr,Lzi) C----------------------------------------------------------------------- C RETURN IF ROOTS OF THE QUADRATIC ARE REAL AND NOT CLOSE TO MULTIPLE OR C NEARLY EQUAL AND OF OPPOSITE SIGN C----------------------------------------------------------------------- IF(dabs(dabs(Szr)-dabs(Lzr)).gt..01D0*dabs(Lzr))RETURN C----------------------------------------------------------------------- C EVALUATE POLYNOMIAL BY QUADRATIC SYNTHETIC DIVISION C----------------------------------------------------------------------- CALL quadsd(N0,U,V0,P0,Qp,A0,B0) mp=dabs(A0-Szr*B0)+dabs(Szi*B0) C----------------------------------------------------------------------- C COMPUTE A RIGOROUS BOUND ON THE ROUNDING ERROR IN EVALUTING P0 C----------------------------------------------------------------------- zm=sqrt(dabs(V0)) ee=TWO*dabs(Qp(1)) t=-Szr*B0 DO i=2,N ee=ee*zm+dabs(Qp(i)) END DO ee=ee*zm+dabs(A0+t) ee=(FIVE*Mre+FOUR*Are)*ee-(FIVE*Mre+TWO*Are) & *(dabs(A0+t)+dabs(B0)*zm)+TWO*Are*dabs(t) C----------------------------------------------------------------------- C ITERATION HAS CONVERGED SUFFICIENTLY IF THE POLYNOMIAL VALUE IS LESS C THAN 20 TIMES THIS BOUND C----------------------------------------------------------------------- IF(mp.gt.TWNTY*ee)THEN j=j+1 C----------------------------------------------------------------------- C STOP ITERATION AFTER 20 STEPS C----------------------------------------------------------------------- IF(j.gt.20)RETURN IF(j.ge.2)THEN IF(.not.(relstp.gt..01D0.or.mp.lt.omp.or.tried))THEN C----------------------------------------------------------------------- C A CLUSTER APPEARS TO BE STALLING THE CONVERGENCE. C FIVE FIXED SHIFT STEPS ARE TAKEN WITH A U,V0 CLOSE TO THE CLUSTER C----------------------------------------------------------------------- IF(relstp.lt.Eta)relstp=Eta relstp=sqrt(relstp) U=U-U*relstp V0=V0+V0*relstp CALL quadsd(N0,U,V0,P0,Qp,A0,B0) DO i=1,5 CALL calcsc(type) CALL nextk(type) END DO tried=.true. j=0 END IF END IF omp=mp C----------------------------------------------------------------------- C CALCULATE NEXT K POLYNOMIAL AND NEW U AND V0 C----------------------------------------------------------------------- CALL calcsc(type) CALL nextk(type) CALL calcsc(type) CALL newest(type,ui,vi) C----------------------------------------------------------------------- C IF VI IS ZERO THE ITERATION IS NOT CONVERGING C----------------------------------------------------------------------- IF(dpeq(vi,ZERO))RETURN relstp=dabs((vi-V0)/vi) U=ui V0=vi ELSE Nz=2 RETURN END IF END DO END quadsd.f0000664006604000003110000000146014521201552011617 0ustar sun00315steps**==quadsd.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE quadsd(Nn,U,V,P,Q,A,B) IMPLICIT NONE C ********************************************************************** C * * C * DIVIDES P BY THE QUADRATIC 1,U,V PLACING THE QUOTIENT IN Q AND * C * THE REMAINDER IN A,B * C * * C ********************************************************************** INTEGER i,Nn DOUBLE PRECISION P(Nn),Q(Nn),U,V,A,B,c B=P(1) Q(1)=B A=P(2)-U*B Q(2)=A DO i=3,Nn c=P(i)-U*A-V*B Q(i)=c B=A A=c END DO RETURN END ratneg.f0000664006604000003110000001304414521201552011617 0ustar sun00315steps SUBROUTINE ratneg(Nelta,Arimap,Arimal,Opr,Begopr,Endopr,C) IMPLICIT NONE c----------------------------------------------------------------------- c Makes a power series expansion, c(x), with nrc terms out of a rational c function with numerator, a(x), with nra terms and denominator, b(x), with c nb terms. Where a(x) is in the form c c a(1)+a(2)*x+a(3)*x^2+...+a(nra)*x^(nra-1). c c and the b(x) is in the form c c 1-b(1)x^-lagb(1)-b(2)x^-lagb(2)- ... -b(nb)x^-lagb(nb). c c c(x) is in the same form as a(x). In ratneg the powers of the c denominator are negative so c will have nra-1 positive powers and c an infinite number of negative powers. Compute the expansion with c negative powers of b by solving c c (c(1)+c(2)x^1...+c(nra)x^(nra-1))(1-b(1)x^-lagb(1)- ...- c b(nb)x^-lagb(nb))=(a(1)+a(2)x^1+...+a(nra)x^nra-1) c c for the c's by making equations of terms with like powers. Note that c c(nra) is solved first and the rest are solved using the c's after. c The routine assumes that c has no more terms than a but generally c any coefficients higher than nra-1, a(nra), are 0. All the a coefficients c are needed no matter how many c coefficients are desired because the c recursion goes from back to front. c is a on input and is transformed c into C which is also an nra by nca matrix. If nb=0 this subroutine c does nothing. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c arimal i Input, parima long array containing the nonzero lags of the c arima error structure. The structure is specified by opr c and mdl. c arimap d Input, parma long array containing the parameter c estimates of the arima error structure. The structure c of the vector is specified by opr and mdl. The lags c associated with the estimates are in arimal. c begelt i Local first element, i, of c(i) in loop c beglag i Local index for the starting element in arimal and arimap c of the current lag operator c begopr i Input index for th3 starting AR or MA operator in the c opr array. Differencing is included as an AR operator c c d I/O Na by nca matrix, the a matrix on input and the c, c expansion matrix-output. Note that the input will be the c same as the output if nb=0 c endlag i Local index for the last element in arimal and arimap c of the current lag operator c endopr i Local index for th3 last AR or MA operator in the c opr array. Differencing is included as an AR operator c i i Local do loop index c ilag i Local do loop index for the current lag c itmp i Local index for the current lagged element c iopr i Local index for the current lag operator c nelta i Local number of elements in the a matrix, ie the c matrix c on input c opr i Input 2 by * array of operator specifications, The first element c in the specification is the pointer to its place in the coef c and lag vectors, second is the number of lags in the operator, c and third is the type of operator (this information is also c specified in the mdl matrix. c sum d Local sum of coeffients of all the like powers of c a and c c zero d Local PARAMETER for a double precision 0 c----------------------------------------------------------------------- c Type variables c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ DOUBLE PRECISION M300,ZERO PARAMETER(M300=1D-300,ZERO=0D0) c LOGICAL T,F c PARAMETER(T=.true.,F=.false.,PA=PLEN+PORDER,ONE=1D0) c ------------------------------------------------------------------ INTEGER Arimal,beglag,Begopr,endlag,Endopr,i,ilag,iopr,itmp,Nelta, & Opr DOUBLE PRECISION Arimap,C,sum DIMENSION Arimap(PARIMA),Arimal(PARIMA),C(*),Opr(0:POPR) c----------------------------------------------------------------------- c Since c is the a matrix on input the c's don't need to be c initialized at the start of the recursions. Calculate the number c of elements in the c matrix. c----------------------------------------------------------------------- c CALL under0(T) c ------------------------------------------------------------------ DO iopr=Begopr,Endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c----------------------------------------------------------------------- c Calculate the c(i)'s, i=nra-lagb(1)+1 to 1 c----------------------------------------------------------------------- DO i=Nelta-Arimal(beglag),1,-1 sum=C(i) c----------------------------------------------------------------------- c Calculate c(i) c----------------------------------------------------------------------- DO ilag=beglag,endlag itmp=i+Arimal(ilag) IF(itmp.le.Nelta)sum=sum+Arimap(ilag)*C(itmp) END DO c ------------------------------------------------------------------ IF (abs(sum).gt.M300)THEN C(i)=sum ELSE IF(abs(sum).gt.ZERO)THEN C(i)=ZERO END IF END DO END DO c CALL under0(F) c ------------------------------------------------------------------ RETURN END ratpos.f0000664006604000003110000001404214521201553011647 0ustar sun00315steps SUBROUTINE ratpos(Nelta,Arimap,Arimal,Opr,Begopr,Endopr,Neltc,C) IMPLICIT NONE c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c arimal i Input, parima long array containing the nonzero lags of the c arima error structure. The structure is specified by opr c and mdl. c arimap d Input, parma long array containing the parameter c estimates of the arima error structure. The structure c of the vector is specified by opr and mdl. The lags c associated with the estimates are in arimal. c begelt i Local first element, i, of c(i) in loop c beglag i Local index for the starting element in arimal and arimap c of the current lag operator c begopr i Input index for th3 starting AR or MA operator in the c opr array. Differencing is included as an AR operator c c d I/O Na by nca matrix, the a matrix on input and the c, c expansion matrix-output. Note that the input will be the c same as the output if nb=0 c endlag i Local index for the last element in arimal and arimap c of the current lag operator c endopr i Local index for th3 last AR or MA operator in the c opr array. Differencing is included as an AR operator c i i Local do loop index c ilag i Local do loop index for the current lag c itmp i Local index for the current lagged element c iopr i Local index for the current lag operator c nelta i Local number of elements in the a matrix, ie the c matrix c on input c neltc i Local number of elements in the c matrix c ntmpa i Local number of elements in the a vector of ratpos. On input c its nelta but if there are more operator the length is no c nolonger nelta but neltc because it has been through the c filter once c opr i Input 3 by * array of operator specifications, The first element c in the specification is the pointer to its place in the coef c and lag vectors, second is the number of lags in the operator, c and third is the type of operator (this information is also c specified in the mdl matrix. c sum d Local sum of coeffients of all the like powers of c a and c c zero d Local PARAMETER for a double precision 0 c----------------------------------------------------------------------- c Type variables c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c LOGICAL T,F c PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INTEGER Arimal,begelt,beglag,Begopr,endlag,Endopr,i,ilag,iopr, & itmp,Nelta,Neltc,ntmpa,Opr DOUBLE PRECISION Arimap,C,sum DIMENSION Arimap(*),Arimal(*),C(*),Opr(0:POPR) c----------------------------------------------------------------------- c Makes a power series expansion, c(x), with nrc terms out of a rational c function with numerator, a(x), with nra terms and a denominator, b(x), c with nb terms. Where a(x) is in the form c c a(1)+a(2)*x+a(3)*x^2+...+a(nra)*x^(nra-1). c c and the b(x) is in the form c c 1-b(1)x^lagb(1)-b(2)x^lagb(2)- ... -b(nb)x^lagb(nb). c c c(x) is in the same form as a(x). In ratpos the powers of the c demonminator, b, are positve. Compute the expansion by solving c c (c(1)+c(2)x^1...+c(nrc)x^(nrc-1))(1-b(1)x^lagb(1)-...-b(nb)x^nb*lagb(nb))= c (a(1+a(2)x^1+...+a(nra)x^nra-1) c c for the c's by making equations of terms with like powers on both sides c of the equation. Solve c(1) first then each suceeding one recursively. c The summation will decrease in the b's and increase in the a's so that c power of the products will remain constant. Zero out the power series c expansion array, c. C is an nrc by nca matrix. The first nra terms c are initilized to the a's. c----------------------------------------------------------------------- c Note c is the a matrix on input. First c calculate the number of elements in the c/a matrices c----------------------------------------------------------------------- ntmpa=Nelta c CALL under0(T) c ------------------------------------------------------------------ DO iopr=Begopr,Endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 IF(endlag.gt.beglag)THEN begelt=Arimal(beglag)+1 ELSE begelt=1 END IF c ------------------------------------------------------------------ DO i=ntmpa+1,begelt-1 C(i)=ZERO END DO c----------------------------------------------------------------------- c Calculate the c(i)'s, i=lagb(nlag)+1,lag(nlag+1) c----------------------------------------------------------------------- DO i=begelt,Neltc IF(i.le.ntmpa)THEN sum=C(i) c ------------------------------------------------------------------ ELSE sum=ZERO END IF c----------------------------------------------------------------------- c Calculate c(i) c----------------------------------------------------------------------- DO ilag=beglag,endlag itmp=i-Arimal(ilag) IF(itmp.gt.0) THEN IF(Dabs(Arimap(ilag)).gt.1.D-150.and.Dabs(C(itmp)).gt.1.D-150) & sum=sum+Arimap(ilag)*C(itmp) END IF END DO c ------------------------------------------------------------------ C(i)=sum END DO c ------------------------------------------------------------------ ntmpa=Neltc END DO c CALL under0(F) c ------------------------------------------------------------------ RETURN END rdotlr.f0000664006604000003110000001330714521201553011650 0ustar sun00315stepsC Last change: BCM 25 Nov 97 8:48 am SUBROUTINE rdotlr(Otlttl,Begspn,Sp,Otlind,Begotl,Endotl,Locok) IMPLICIT NONE c----------------------------------------------------------------------- c Reads an outlier specifier 'AOyr.mo', 'LSyr.mo', 'TCyr.mo', c 'SOyr.mo', 'TLSyr.mo-yr.mo', or 'RPyr.mo-yr.mo' and returns the type c of outlier, time point(s). c----------------------------------------------------------------------- c CHANGES FOR TC Outlier by Brian Monsell June 1997 c CHANGES FOR SO Outlier by Brian Monsell July 2003 c CHANGES FOR TLS Outlier by Brian Monsell April 2009 c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begspn i Input 2 long vector (yr,mo) for the begining data of the c data or regression variables, used as a reference to c calculate t0. c begotl i Output begining point for a ramp outlier and t0 for an AO c or level shift. c endotl i Output end point for a ramp outlier and undefined for an c AO or LS c otldat i Local 4 long vector for the begining (yr,mo) and possibly c the ending (yr,mo) of the outlier. c otlttl c Input outlier specifier to be read c otltyp c Output outlier type, either AO, LS, TC, or RP, for c additive, level shift, temporary change or ramp outlier c respectively. c sp i Length of the seasonal period c----------------------------------------------------------------------- c Data typing and variable initialization c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ INTEGER PEXERR PARAMETER(PEXERR=3) c ------------------------------------------------------------------ CHARACTER Otlttl*(*),errstr*(LINLEN) LOGICAL Locok INTEGER begdat,Begotl,Begspn,enddat,Endotl,ipos,Sp,strinx,itmp, & nott,nerr DIMENSION begdat(2),Begspn(2),enddat(2),itmp(2) EXTERNAL strinx c----------------------------------------------------------------------- c This argument dictionary was created with the command c ../../dictionary/strary otl < ../../dictionary/outlier.type.dic c----------------------------------------------------------------------- CHARACTER OTLDIC*18 INTEGER Otlind,otlptr,POTL PARAMETER(POTL=9) DIMENSION otlptr(0:POTL) PARAMETER(OTLDIC='aolstcrpmvtlsoqiqd') DATA otlptr/1,3,5,7,9,11,13,15,17,19/ c----------------------------------------------------------------------- c Read the type and date(s) c----------------------------------------------------------------------- Endotl=0 nott=len(Otlttl) errstr=' ' Locok=.true. Otlind=strinx(.false.,OTLDIC,otlptr,1,POTL,Otlttl(1:2)) c ------------------------------------------------------------------ IF(Otlind.eq.0)THEN nerr=nott+45 errstr(1:nerr)='Outlier type, "'//Otlttl(1:nott)// & '" is not an AO, LS, RP, SO, TL, TC, MV, QI or QD.' CALL inpter(PEXERR,itmp,errstr(1:nerr)) Locok=.false. RETURN END IF c ------------------------------------------------------------------ ipos=3 CALL ctodat(Otlttl,Sp,ipos,begdat,Locok) IF(.not.Locok)THEN nerr=nott+42 errstr(1:nerr)='Outlier "'//Otlttl(1:nott)// & '" does not occur on a valid date.' CALL inpter(PEXERR,itmp,errstr(1:nerr)) RETURN END IF CALL dfdate(begdat,Begspn,Sp,Begotl) Begotl=Begotl+1 c----------------------------------------------------------------------- c Ramp outlier end date c----------------------------------------------------------------------- IF(Locok.and.(Otlind.eq.RP.or.Otlind.eq.TLS.or.Otlind.eq.QI.or. & Otlind.eq.QD))THEN IF(Otlttl(ipos:ipos).ne.'-')THEN IF(Otlind.eq.RP)THEN nerr=nott+30 errstr(1:nerr)='"'//Otlttl(1:nott)// & '" is an invalid ramp outlier.' ELSE IF(Otlind.eq.QI.or.Otlind.eq.QD)THEN nerr=nott+40 errstr(1:nerr)='"'//Otlttl(1:nott)// & '" is an invalid quadratic ramp outlier.' ELSE nerr=nott+47 errstr(1:nerr)='"'//Otlttl(1:nott)// & '" is an invalid temporary level shift outlier.' END IF CALL inpter(PEXERR,itmp,errstr(1:nerr)) Locok=.false. c ------------------------------------------------------------------ ELSE ipos=ipos+1 CALL ctodat(Otlttl,Sp,ipos,enddat,Locok) IF(.not.Locok)THEN IF(Otlind.eq.RP)THEN nerr=nott+47 errstr(1:nerr)='Ramp outlier "'//Otlttl(1:nott)// & '" does not have a valid end date.' ELSE IF(Otlind.eq.QI.or.Otlind.eq.QD)THEN nerr=nott+57 errstr(1:nerr)='Quadratic Ramp outlier "'//Otlttl(1:nott)// & '" does not have a valid end date.' ELSE nerr=nott+45 errstr(1:nerr)='TL outlier "'//Otlttl(1:nott)// & '" does not have a valid end date.' END IF CALL inpter(PEXERR,itmp,errstr(1:nerr)) ELSE CALL dfdate(enddat,Begspn,Sp,Endotl) Endotl=Endotl+1 END IF END IF END IF c ------------------------------------------------------------------ RETURN END rdotls.f0000664006604000003110000001311514521201553011646 0ustar sun00315stepsC Last change: allow AOSdate-0.0,LSSdate-0.0 format C previous change: BCM 25 Nov 97 8:48 am SUBROUTINE rdotls(Otlttl,Begspn,Endmdl,Sp,Otlind,Begotl,Endotl, & Locok) IMPLICIT NONE c----------------------------------------------------------------------- c Reads an outlier sequence specifier 'LSSyr.mo-yr.mo' or c 'AOSyr.mo-yr.mo' and returns the type of c outlier, time point(s). c----------------------------------------------------------------------- c CHANGES FOR AOS,LSS Outlier by Brian Monsell April 2012 c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begspn i Input 2 long vector (yr,mo) for the begining data of the c data or regression variables, used as a reference to c calculate t0. c begotl i Output begining point for a ramp outlier and t0 for an AO c or level shift. c endotl i Output end point for a ramp outlier and undefined for an c AO or LS c otldat i Local 4 long vector for the begining (yr,mo) and possibly c the ending (yr,mo) of the outlier. c otlttl c Input outlier specifier to be read c otltyp c Output outlier type, either AO, LS, TC, or RP, for c additive, level shift, temporary change or ramp outlier c respectively. c sp i Length of the seasonal period c----------------------------------------------------------------------- c Data typing and variable initialization c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ INTEGER PEXERR LOGICAL F,T PARAMETER(F=.false.,T=.true.,PEXERR=3) c ------------------------------------------------------------------ CHARACTER Otlttl*(*),errstr*(LINLEN) LOGICAL Locok INTEGER begdat,Endmdl,Begotl,Begspn,enddat,Endotl,ipos,Sp,strinx, & itmp,nott,nerr DIMENSION begdat(2),Endmdl(2),Begspn(2),enddat(2),itmp(2) EXTERNAL strinx c----------------------------------------------------------------------- c This argument dictionary was created with the command c ../../dictionary/strary otl < ../../dictionary/outlier.type.dic c----------------------------------------------------------------------- CHARACTER OTLDIC*6 INTEGER Otlind,otlptr,POTL PARAMETER(POTL=2) DIMENSION otlptr(0:POTL) PARAMETER(OTLDIC='aoslss') DATA otlptr/1,4,7/ c----------------------------------------------------------------------- c Read the type and date(s) c----------------------------------------------------------------------- Endotl=0 nott=len(Otlttl) errstr=' ' Locok=.true. Otlind=strinx(.false.,OTLDIC,otlptr,1,POTL,Otlttl(1:3)) c ------------------------------------------------------------------ IF(Otlind.eq.0)THEN nerr=nott+47 errstr(1:nerr)='Outlier sequence type, "'//Otlttl(1:nott)// & '" is not an AOS or LSS.' CALL inpter(PEXERR,itmp,errstr(1:nerr)) Locok=.false. RETURN END IF c ------------------------------------------------------------------ ipos=4 CALL ctodat(Otlttl,Sp,ipos,begdat,Locok) IF(.not.Locok)THEN nerr=nott+42 errstr(1:nerr)='Outlier "'//Otlttl(1:nott)// & '" does not occur on a valid date.' CALL inpter(PEXERR,itmp,errstr(1:nerr)) RETURN END IF CALL dfdate(begdat,Begspn,Sp,Begotl) Begotl=Begotl+1 c----------------------------------------------------------------------- c Sequence outlier end date c----------------------------------------------------------------------- IF(Locok)THEN IF(Otlttl(ipos:ipos).ne.'-')THEN IF(Otlind.eq.AO)THEN nerr=nott+41 errstr(1:nerr)='"'//Otlttl(1:nott)// & '" is an invalid AO sequence variable.' ELSE nerr=nott+50 errstr(1:nerr)='"'//Otlttl(1:nott)// & '" is an invalid level shift sequence variable.' END IF CALL inpter(PEXERR,itmp,errstr(1:nerr)) Locok=.false. c ------------------------------------------------------------------ ELSE ipos=ipos+1 CALL ctodat(Otlttl,Sp,ipos,enddat,Locok) c ------------------------------------------------------------------ c If date = 0.0, set enddat to end of model span, c reset Locok to TRUE c ------------------------------------------------------------------ if (enddat(YR).eq.0.and.enddat(MO).eq.0) then enddat(YR) = Endmdl(YR) enddat(MO) = Endmdl(MO) Locok = T end if IF(.not.Locok)THEN nerr=nott+55 IF(Otlind.eq.AO)THEN errstr(1:nerr)='AO sequence variable "'//Otlttl(1:nott)// & '" does not have a valid end date.' ELSE errstr(1:nerr)='LS sequence variable "'//Otlttl(1:nott)// & '" does not have a valid end date.' END IF CALL inpter(PEXERR,itmp,errstr(1:nerr)) ELSE CALL dfdate(enddat,Begspn,Sp,Endotl) Endotl=Endotl+1 END IF END IF END IF c ------------------------------------------------------------------ RETURN END rdregm.f0000664006604000003110000000365314521201553011625 0ustar sun00315stepsC Last change: BCM 22 Sep 1998 11:00 am SUBROUTINE rdregm(Rgmttl,Begspn,Sp,Zeroz,Rgmidx,Locok) IMPLICIT NONE c----------------------------------------------------------------------- c Reads change of regime information from the group title of a c set of change of regime regressors c----------------------------------------------------------------------- CHARACTER Rgmttl*(*) LOGICAL Locok INTEGER begrgm,Begspn,ipos,nchr,Rgmidx,Sp,strinx,Zeroz DIMENSION begrgm(2),Begspn(2) EXTERNAL strinx c----------------------------------------------------------------------- c check to see if regressor has zeros before or after the date. c----------------------------------------------------------------------- Locok=.true. Rgmidx=0 Zeroz=0 nchr=LEN(Rgmttl) c----------------------------------------------------------------------- ipos=index(Rgmttl(1:nchr),'(starting ') IF(ipos.eq.0)THEN ipos=index(Rgmttl(1:nchr),'(before ') IF(ipos.eq.0)THEN ipos=index(Rgmttl(1:nchr),'(change from before ') RETURN END IF Zeroz=1 ELSE Zeroz=-1 END IF c----------------------------------------------------------------------- c Read regime date from group title string c----------------------------------------------------------------------- IF(Zeroz.eq.1)THEN ipos=ipos+8 ELSE ipos=ipos+10 END IF CALL ctodat(Rgmttl(1:(nchr-1)),Sp,ipos,begrgm,Locok) c----------------------------------------------------------------------- c if ok, compute displacement from Begspn c----------------------------------------------------------------------- IF(Locok)THEN CALL dfdate(begrgm,Begspn,Sp,Rgmidx) Rgmidx=Rgmidx+1 END IF c----------------------------------------------------------------------- RETURN END realit.f0000664006604000003110000001044114521201553011616 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:45 pm SUBROUTINE realit(Sss,Nz,Iflag) IMPLICIT NONE C ********************************************************************** C * * C * VARIABLE- SHIFT H POLYNOMIAL ITERATION FOR A REAL ZERO. * C * SSS - STARTING ITERATE * C * NZ - NUMBER OF ZERO FOUND * C * IFLAG - FLAG TO INDICATE A PAIR OF ZEROS NEAR REAL AXIS. * C * * C*********************************************************************** C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'global.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION pv,kv,t,s,Sss,dabs,ms,mp,omp,ee INTEGER Nz,Iflag,i,j C----------------------------------------------------------------------- Nz=0 s=Sss Iflag=0 j=0 DO WHILE (.true.) C----------------------------------------------------------------------- C MAIN LOOP C----------------------------------------------------------------------- pv=P0(1) C----------------------------------------------------------------------- C EVALUATE P0 AT S C----------------------------------------------------------------------- Qp(1)=pv DO i=2,N0 pv=pv*s+P0(i) Qp(i)=pv END DO mp=dabs(pv) C----------------------------------------------------------------------- C COMPUTE A RIGOROUS BOUND ON THE ERROR IN EVALUATING P0 C----------------------------------------------------------------------- ms=dabs(s) ee=(Mre/(Are+Mre))*dabs(Qp(1)) DO i=2,N0 ee=ee*ms+dabs(Qp(i)) END DO C----------------------------------------------------------------------- C ITERATION HAS CONVERGED SUFFICIENTLY IF THE C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND C----------------------------------------------------------------------- IF(mp.gt.20D0*((Are+Mre)*ee-Mre*mp))THEN j=j+1 C----------------------------------------------------------------------- C STOP ITERATION AFTER 10 STEPS C----------------------------------------------------------------------- IF(j.gt.10)RETURN IF(j.ge.2)THEN IF(dabs(t).le..001D0*dabs(s-t).and.mp.gt.omp)THEN C----------------------------------------------------------------------- C A CLUSTER OF ZEROS NEAR THE REAL AXIS HAS BEEN ENCOUNTERED RETURN WITH C IFLAG SET TO INITIATE A QUADRATIC ITERATION C----------------------------------------------------------------------- Iflag=1 Sss=s RETURN END IF END IF C----------------------------------------------------------------------- C RETURN IF THE POLYNOMIAL VALUE HAS INCREASED SIGNIFICANTLY C----------------------------------------------------------------------- omp=mp C----------------------------------------------------------------------- C COMPUTE T, THE NEXT POLYNOMIAL, AND THE NEW ITERATE C----------------------------------------------------------------------- kv=K(1) Qk(1)=kv DO i=2,N kv=kv*s+K(i) Qk(i)=kv END DO IF(dabs(kv).le.dabs(K(N))*10D0*Eta)THEN C----------------------------------------------------------------------- C USE UNSCALED FORM C----------------------------------------------------------------------- K(1)=0.0D0 DO i=2,N K(i)=Qk(i-1) END DO ELSE C----------------------------------------------------------------------- C USE THE SCALED FORM OF THE RECURRENCE IF THE VALUE C OF K AT S IS NONZERO C----------------------------------------------------------------------- t=-pv/kv K(1)=Qp(1) DO i=2,N K(i)=t*Qk(i-1)+Qp(i) END DO END IF kv=K(1) DO i=2,N kv=kv*s+K(i) END DO t=0.D0 IF(dabs(kv).gt.dabs(K(N))*10D0*Eta)t=-pv/kv s=s+t ELSE Nz=1 Szr=s Szi=0.D0 RETURN END IF END DO END regfix.f0000664006604000003110000000321514521201553011623 0ustar sun00315stepsC Last change: BCM 13 Oct 1998 3:20 pm SUBROUTINE regfix() IMPLICIT NONE c----------------------------------------------------------------------- c Test whether all the fixed parameters have values. If there are c no regression variables, the default is not to fix in case any c automatic outliers are found. c----------------------------------------------------------------------- c Also, will set up Regfx variable for each regressor based on the c value of Ifix (BMonsell, 1998) c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.TRUE.,F=.FALSE.) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c INCLUDE 'x11adj.cmn' c ------------------------------------------------------------------ INTEGER ieff LOGICAL allfix c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ Iregfx=0 allfix=T IF(Nb.gt.0)THEN DO ieff=1,Nb IF(dpeq(B(ieff),DNOTST))THEN IF(allfix)allfix=F ELSE allfix=allfix.and.Regfx(ieff) IF(Iregfx.eq.0)Iregfx=1 IF(Regfx(ieff).and.Iregfx.eq.1)Iregfx=2 END IF END DO END IF IF(allfix.and.Iregfx.gt.0)Iregfx=3 c ------------------------------------------------------------------ RETURN END reglbl.f0000664006604000003110000000370714521201553011614 0ustar sun00315steps SUBROUTINE reglbl(Grpstr,Ngrpcr,Rglabl,Nrglbl,Rtype) IMPLICIT NONE c----------------------------------------------------------------------- c Provide shorter group names for summary diagnostic output, and c group all outliers declared by the user into a group called user. c Return label of length Nrglbl in character variable Rglabl. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c----------------------------------------------------------------------- CHARACTER grpstr*(PGRPCR),Rglabl*(PGRPCR) INTEGER Ngrpcr,Nrglbl,Rtype c----------------------------------------------------------------------- c Initialize Rglabl to blanks c----------------------------------------------------------------------- CALL setchr(' ',PGRPCR,Rglabl) c----------------------------------------------------------------------- c Shorten label for automatic outliers c----------------------------------------------------------------------- * IF(Rtype.eq.PRGTAA.or.Rtype.eq.PRGTAL.or.Rtype.eq.PRGTAT.or. * & Rtype.eq.PRGTAS)THEN IF(Rtype.eq.PRGTAA.or.Rtype.eq.PRGTAL.or.Rtype.eq.PRGTAT)THEN Nrglbl=11 Rglabl(1:Nrglbl)='AutoOutlier' c----------------------------------------------------------------------- c Group other outliers into Outlier group c----------------------------------------------------------------------- ELSE IF(Rtype.eq.PRGTAO.or.Rtype.eq.PRGTLS.or.Rtype.eq.PRGTTC.or. & Rtype.eq.PRGTRP.or.Rtype.eq.PRGTSO.or.Rtype.eq.PRGTTL.or. & Rtype.eq.PRGTQI.or.Rtype.eq.PRGTQD.or.Rtype.eq.PRSQAO.or. & Rtype.eq.PRSQLS)THEN Nrglbl=7 Rglabl(1:Nrglbl)='Outlier' ELSE Nrglbl=Ngrpcr Rglabl(1:Nrglbl)=Grpstr(1:Ngrpcr) END IF c----------------------------------------------------------------------- RETURN END regvar.f0000664006604000003110000004675214521201553011642 0ustar sun00315stepsC Last change: BCM 22 Sep 1998 10:58 am SUBROUTINE regvar(Y,Nobpf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,Xmeans,Elong) IMPLICIT NONE c----------------------------------------------------------------------- c Adds the data and special regression variables, constant, c seasonal effects, trading day, AO's and LS's, and ramps. Checks c the user defined regression variable input. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c bgusrX i Input begining date for the user defined regression c variables, this is notset if there are no user variables c begXy i Output beginning date for the extended Xy matrix (yr,mo) c This is set to begspn-nbcst if there are no user c regression variables c begspn i Input beginning date for the input series (yr,mo) c fctdrp i Input number of observations dropped off the span before c starting the forecasts c frstry i Output the first element of Xy to use in the estimation c ielt i Local index for the current element c igrp i Local index for the current regression group c itmp i Local temporary scalar c iXymU i Local difference between the begining of the user defined c regression variables and the begining of the Xy matrix c which is defined by the begining of the data - number of c backcasts c nbcst i Input number of backcasts requested c nfcst i Input number of forecasts requested c nrusrX i Input number of rows of user defined regression variables c nrxy i I/O On input it's the length of the user defined regression c matrix, on output, it's the rows in [X:y]. c one d Local PARAMETER for a double precision 1 c puserX i PARAMETER of the maximum number of elements in the c user specified regression matrix c pXy i Input PARAMETER for the maximum number of elements in the c extended [X:y] matrix Xy c tsrs d Work pobs long temporary series vector c userX d Input puserX, nrowsx by nuserg columns used, matrix of c user specified regression variables c y d Input pobs (nspobs used) Vector of possibly transformed data c undifferenced series c----------------------------------------------------------------------- c Variable Typing and Initialization c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO LOGICAL F,T INTEGER PLOM,PLOQ PARAMETER(F=.false.,T=.true.,ONE=1D0,ZERO=0D0,PLOM=2,PLOQ=3) c ------------------------------------------------------------------ INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ INTEGER PXY PARAMETER(PXY=PLEN*(PB+1)) c ------------------------------------------------------------------ CHARACTER igrptl*(PGRPCR) LOGICAL begrgm,chkcvr,lom,locok,Xmeans,ltd1,Elong,lckurg,lurspc INTEGER begcol,Bgusrx,begelt,Begxy,ctoi,endcol,endelt,Fctdrp, & Frstry,i,ielt,ipos,itogrp,igrp,ixymu,irow,lstngp,ndays, & Nbcst,nchr,Nfcst,nigrpc,Nobpf,Nrusrx,Nrxy,Priadj,typidx, & Reglom,smpday,strinx,idtpos,regmdt,itype,thisgp,rtype2 DOUBLE PRECISION lomadj,Userx,Y,tsrs,emean DIMENSION Bgusrx(2),Begxy(2),Userx(PUSERX),Y(*),regmdt(2), & tsrs(PLEN),begrgm(PLEN),emean(PSP) EXTERNAL chkcvr,ctoi,strinx c---------------------------------------------------------------------- CHARACTER UTYDIC*320 INTEGER utyptr,PUTY PARAMETER(PUTY=15) DIMENSION utyptr(0:PUTY) PARAMETER(UTYDIC='User-defined SeasonalUser-defined HolidayUser-de &fined Holiday Group 2User-defined Holiday Group 3User-defined Holi &day Group 4User-defined Holiday Group 5User-defined ConstantUser-d &efined Trading DayUser-defined LOMUser-defined LOQUser-defined Lea &p YearUser-defined AOUser-defined LSUser-defined SOUser-defined Tr &ansitory') c---------------------------------------------------------------------- DATA utyptr / 1,22,42,70,98,126,154,175,199,215,231,253,268,283, & 298,321 / c---------------------------------------------------------------------- c Define the dimensions of the Xy matrix c----------------------------------------------------------------------- lckurg=T CALL addate(Begspn,Sp,-Nbcst,Begxy) Nrxy=Nspobs+Nbcst+max(0,Nfcst-Fctdrp) c----------------------------------------------------------------------- c Check the dimensions of the data and regressor variables c----------------------------------------------------------------------- IF(Nrxy*Ncxy.gt.PXY)THEN CALL errhdr WRITE(STDERR,1010)Nrxy,Ncxy,PXY WRITE(Mt2,1010)Nrxy,Ncxy,PXY 1010 FORMAT(/,' Too many elements in [X:y]',i4,' *',i3,' >',i6) CALL abend RETURN END IF c----------------------------------------------------------------------- c Add the possibly transformed data to the last column of Xy. c Note that there might be rows of regression variables before the data c starts because of backcasts. c----------------------------------------------------------------------- Frstry=Nbcst*Ncxy+1 CALL copycl(Y,Nobpf,1,1,Ncxy,Ncxy,Xy(Frstry)) c----------------------------------------------------------------------- c Set Observations of Xy that stand in for the backcasts to zero c (BCM July 2008) c----------------------------------------------------------------------- IF(Nbcst.gt.0)THEN DO irow=1,Nbcst ielt=irow*Ncxy Xy(ielt)=ZERO END DO END IF c----------------------------------------------------------------------- c Add each regression variable or group c----------------------------------------------------------------------- igrp=0 lstngp=Ngrp DO WHILE (igrp.lt.Ngrp) igrp=igrp+1 CALL setlg(T,PLEN,begrgm) c ------------------------------------------------------------------ CALL getstr(Grpttl,Grpptr,Ngrp,igrp,igrptl,nchr) IF(Lfatal)RETURN nigrpc=index(igrptl(1:nchr),'[')-1 IF(nigrpc.eq.-1)nigrpc=nchr IF(igrptl(1:3).eq.'AOS'.or.igrptl(1:3).eq.'LSS')THEN nigrpc=3 ELSE IF(igrptl(1:2).eq.'AO'.or.igrptl(1:2).eq.'LS'.or. & igrptl(1:2).eq.'Rp'.or.igrptl(1:2).eq.'Mi'.or. & igrptl(1:2).eq.'TC'.or.igrptl(1:2).eq.'SO'.or. & igrptl(1:2).eq.'TL'.or.igrptl(1:2).eq.'QI'.or. & igrptl(1:2).eq.'QD')THEN nigrpc=2 END IF c----------------------------------------------------------------------- c Determine the beginning and ending columns in the group c----------------------------------------------------------------------- begcol=Grp(igrp-1) endcol=Grp(igrp)-1 rtype2=Rgvrtp(begcol) IF(rtype2.gt.100)rtype2=rtype2-100 * call profiler(3,'within regvar') c----------------------------------------------------------------------- c Determine the type of regression variable c----------------------------------------------------------------------- GO TO(10,20,30,40,50,50,60,70,80,90, & 100,110,120,120,120,130,130,140,150,150, & 150,150,150,150,150,150,90,120,90,155, & 155,155,155,155,155,155,155,140,120,120, & 40,150,155,120,130,70,150,155,140,140, & 140,140,140,120,120,140,140,140,140,140, & 140,140,140,140,140),rtype2 c----------------------------------------------------------------------- c Constant is a column of ones filtered by 1/Diff(B). c----------------------------------------------------------------------- 10 CALL setdp(ONE,Nrxy,tsrs) CALL ratpos(Nrxy,Arimap,Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1,Nrxy, & tsrs) CALL copycl(tsrs,Nrxy,1,1,Ncxy,begcol,Xy) GO TO 160 c----------------------------------------------------------------------- c Seasonal effects c----------------------------------------------------------------------- 20 CALL addsef(Begxy,Nrxy,Ncxy,begcol,endcol,Xy,begrgm) IF(Lfatal)RETURN GO TO 160 c----------------------------------------------------------------------- c Trigonometric Seasonal effects c----------------------------------------------------------------------- 30 CALL adsncs(Begxy,Sp,Nrxy,Ncxy,Colttl,Colptr,begcol,endcol,Xy, & begrgm) IF(Lfatal)RETURN GO TO 160 c----------------------------------------------------------------------- c Trading Day effects c----------------------------------------------------------------------- 40 ltd1=rtype2.eq.PRG1TD.or.rtype2.eq.PRR1TD.or.rtype2.eq.PRA1TD CALL td6var(Begxy,Sp,Nrxy,Ncxy,begcol,endcol,0,Xy,begrgm,ltd1) IF(Lfatal)RETURN GO TO 160 c----------------------------------------------------------------------- c Length-of-Month and Length-of-Quarter effects c----------------------------------------------------------------------- 50 CALL td7var(Begxy,Sp,Nrxy,Ncxy,begcol,T,F,F,Xy,begrgm) GO TO 160 c----------------------------------------------------------------------- c Leap Year effect c----------------------------------------------------------------------- 60 CALL td7var(Begxy,Sp,Nrxy,Ncxy,begcol,F,F,F,Xy,begrgm) GO TO 160 c----------------------------------------------------------------------- c Stock Trading Day effects c----------------------------------------------------------------------- 70 ltd1=rtype2.eq.PRG1ST.or.rtype2.eq.PRR1ST.or.rtype2.eq.PRA1ST ipos=nigrpc+2 smpday=ctoi(igrptl(1:nchr),ipos) CALL td6var(Begxy,Sp,Nrxy,Ncxy,begcol,endcol,smpday,Xy,begrgm, & ltd1) IF(Lfatal)RETURN GO TO 160 c----------------------------------------------------------------------- c Stock Length-of-Month effect c* Use this for regARIMA instead, X-13A-S uses leap year as a base c* 80 CALL td7var(Begxy,Sp,Nrxy,Ncxy,begcol,F,T,F,Xy,begrgm) c----------------------------------------------------------------------- 80 CALL td7var(Begxy,Sp,Nrxy,Ncxy,begcol,T,T,F,Xy,begrgm) GO TO 160 c----------------------------------------------------------------------- c Easter holiday effect c----------------------------------------------------------------------- 90 DO ielt=begcol,endcol CALL getstr(Colttl,Colptr,Nb,ielt,igrptl,nchr) IF(Lfatal)RETURN nigrpc=index(igrptl(1:nchr),'[')-1 ipos=nigrpc+2 ndays=ctoi(igrptl(1:nchr),ipos) CALL estrmu(Begxy,Nrxy,Sp,ndays,Elong,emean,rtype2.eq.PRGTES) CALL adestr(Begxy,Nrxy,Ncxy,Sp,ielt,ndays,Easidx,Xy,Xmeans, & emean,rtype2.eq.PRGTES) END DO GO TO 160 c----------------------------------------------------------------------- c Labor day holiday effect c----------------------------------------------------------------------- 100 ipos=nigrpc+2 ndays=ctoi(igrptl(1:nchr),ipos) CALL adlabr(Begxy,Nrxy,Ncxy,begcol,ndays,Xy,Xmeans) GO TO 160 c----------------------------------------------------------------------- c Thanksgiving-Christmas holiday effect c----------------------------------------------------------------------- 110 ipos=nigrpc+2 ndays=ctoi(igrptl(1:nchr),ipos) CALL adthnk(Begxy,Nrxy,Ncxy,begcol,ndays,Xy,Xmeans) GO TO 160 c----------------------------------------------------------------------- c AOs, LSs, MVs, TCs, SOs, TLs, and Ramps c----------------------------------------------------------------------- 120 CALL addotl(Begxy,Nrxy,Nbcst,begcol,endcol) IF(Lfatal)RETURN GO TO 160 c----------------------------------------------------------------------- c Automatically Identified Outliers c----------------------------------------------------------------------- 130 CALL addotl(Begxy,Nrxy,Nbcst,begcol,endcol) IF(Lfatal)RETURN GO TO 160 c----------------------------------------------------------------------- c User-defined regression variables. First check the dates or the c variables. c----------------------------------------------------------------------- 140 IF(lckurg)THEN IF(.not.chkcvr(Bgusrx,Nrusrx,Begspn,Nspobs,Sp))THEN CALL cvrerr('user-defined regression variables',Bgusrx,Nrusrx, & 'span of data',Begspn,Nspobs,Sp) IF(.not.Lfatal)CALL abend() RETURN c ------------------------------------------------------------------ ELSE IF(.not.chkcvr(Bgusrx,Nrusrx,Begxy,Nrxy,Sp))THEN CALL cvrerr('user-defined regression variables',Bgusrx,Nrusrx, & 'forecasts',Begxy,Nrxy,Sp) IF(.not.Lfatal)CALL abend() RETURN c ------------------------------------------------------------------ END IF lckurg=F END IF CALL dfdate(Begxy,Bgusrx,Sp,ixymu) c ------------------------------------------------------------------ c Determine what type of user defined regressor is being added c ------------------------------------------------------------------ typidx=strinx(F,UTYDIC,utyptr,1,PUTY,igrptl(1:nchr)) itype=typidx IF(typidx.eq.1)THEN itype=PRGTUS ELSE IF(typidx.ge.2.and.typidx.le.6)THEN itype=PRGTUH+typidx-2 ELSE IF(typidx.eq.7)THEN itype=PRGUCN ELSE IF(typidx.eq.8)THEN itype=PRGUTD ELSE IF(typidx.eq.9)THEN itype=PRGULM ELSE IF(typidx.eq.10)THEN itype=PRGULQ ELSE IF(typidx.eq.11)THEN itype=PRGULY ELSE IF(typidx.eq.12)THEN itype=PRGUAO ELSE IF(typidx.eq.13)THEN itype=PRGULS ELSE IF(typidx.eq.14)THEN itype=PRGUSO ELSE IF(typidx.eq.15)THEN itype=PRGUCY END IF c ------------------------------------------------------------------ c Only add the type of user defined regressor specified c ------------------------------------------------------------------ thisgp=1 DO i=1,Ncusrx lurspc=(Usrtyp(i).ge.PRGTUH.and.Usrtyp(i).le.PRGUH5).or. & Usrtyp(i).eq.PRGTUS.or. & (Usrtyp(i).ge.PRGUTD.and.Usrtyp(i).le.PRGUCY) IF(lurspc)THEN IF(itype.eq.Usrtyp(i))THEN itogrp=begcol+thisgp-1 CALL copycl(Userx(ixymu*ncusrx+1),Nrxy,ncusrx,i,Ncxy, & itogrp,Xy) thisgp=thisgp+1 END IF ELSE IF(itype.eq.0)THEN itogrp=begcol+thisgp-1 CALL copycl(Userx(ixymu*ncusrx+1),Nrxy,ncusrx,i,Ncxy, & itogrp,Xy) thisgp=thisgp+1 END IF END DO GO TO 160 c---------------------------------------------------------------------- c Change of regime regression variables. First, get the date of c the change-of-regime from the group title. c---------------------------------------------------------------------- 150 idtpos=index(igrptl(1:nchr),'(before ')+8 IF(idtpos.eq.8) & idtpos=index(igrptl(1:nchr),'(change for before ')+19 CALL ctodat(igrptl(1:nchr-1),Sp,idtpos,regmdt,locok) c---------------------------------------------------------------------- c Set the pointer for the start of the regime change, then c generate the proper regression variables. c---------------------------------------------------------------------- CALL gtrgpt(Begxy,regmdt,1,begrgm,Nrxy) IF(rtype2.eq.PRR1TD)GO TO 40 IF(rtype2.eq.PRR1ST)GO TO 70 GO TO(20,30,40,50,50,60,70,80),rtype2-PRRTSE+1 c---------------------------------------------------------------------- c Change of regime regression variables, regressor defined after c the change of regime data. First, get the date of the c change-of-regime from the group title. c---------------------------------------------------------------------- 155 idtpos=index(igrptl(1:nchr),'(starting ')+10 IF(idtpos.eq.10) & idtpos=index(igrptl(1:nchr),'(change for after ')+18 CALL ctodat(igrptl(1:nchr-1),Sp,idtpos,regmdt,locok) c---------------------------------------------------------------------- c Set the pointer for the start of the regime change, then c check to see if the start of the regime date is before the end c of the data. c---------------------------------------------------------------------- CALL gtrgpt(Begxy,regmdt,-1,begrgm,Nrxy) c---------------------------------------------------------------------- c generate the proper regression variables. c---------------------------------------------------------------------- IF(rtype2.eq.PRA1TD)GO TO 40 IF(rtype2.eq.PRA1ST)GO TO 70 GO TO(20,30,40,50,50,60,70,80),rtype2-PRATSE+1 c---------------------------------------------------------------------- c In case a group (of outliers outside the span) has been deleted c then do not index igrp because the next group has move into the c previous location. c---------------------------------------------------------------------- 160 IF(lstngp.gt.Ngrp)igrp=igrp-1 lstngp=Ngrp END DO c---------------------------------------------------------------------- c Generate length of month factors and adjust the regression c variables. The series is already adjusted in adjsrs because c those prior adjustment factors are used in the calculation of the c jacobian in prlkhd but the regression variables are not. c For the regression adjustment none=1, td=2, or all=3 c----------------------------------------------------------------------- IF(Reglom.gt.1.and.Priadj.gt.1)THEN c----------------------------------------------------------------------- c Generate length of period factors. Note lom and loq are the c same the factor is determined by the seasonal period. c----------------------------------------------------------------------- IF(Priadj.eq.PLOM.or.Priadj.eq.PLOQ)THEN lom=T ELSE lom=F END IF c----------------------------------------------------------------------- c The 7th trading day factors c----------------------------------------------------------------------- CALL setlg(T,PLEN,begrgm) CALL td7var(Begxy,Sp,Nrxy,1,1,lom,F,T,tsrs,begrgm) c----------------------------------------------------------------------- IF(Reglom.eq.3)THEN begcol=1 endcol=Ncxy-1 c ------------------------------------------------------------------ ELSE igrp=strinx(F,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(igrp.le.0)GO TO 170 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 END IF c ------------------------------------------------------------------ DO irow=1,Nrxy begelt=Ncxy*(irow-1) endelt=begelt+endcol begelt=begelt+begcol lomadj=tsrs(irow) DO ielt=begelt,endelt Xy(ielt)=Xy(ielt)*lomadj END DO END DO END IF c ------------------------------------------------------------------ 170 RETURN END regx11.f0000664006604000003110000000744214521201553011454 0ustar sun00315stepsC Last change: BCM 14 May 1998 8:45 am SUBROUTINE regx11(A) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine performs an OLS regression on the irregular c component of an X-11 seasonal adjustment. The regressors have c been previously chosen by the user. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c----------------------------------------------------------------------- LOGICAL F DOUBLE PRECISION ONE,PI,TWO,ZERO,MONE PARAMETER(ONE=1D0,PI=3.14159265358979D0,TWO=2D0,ZERO=0D0, & MONE=-1D0,F=.false.) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'series.cmn' INCLUDE 'error.cmn' INCLUDE 'xclude.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER PA,PXA,PXY PARAMETER(PA=PLEN+2*PORDER,PXY=PLEN*(PB+1),PXA=PA*(PB+1)) c----------------------------------------------------------------------- DOUBLE PRECISION A,apa,txy INTEGER nrtxy,neltxy DIMENSION A(PA),txy(PXA) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION dpmpar EXTERNAL dpmpar,dpeq c----------------------------------------------------------------------- c Check the work array size c----------------------------------------------------------------------- Nfev=0 IF(Nspobs*Ncxy.gt.PXY)THEN CALL errhdr WRITE(STDERR,1010)Nspobs,Ncxy,PXA WRITE(Mt2,1010)Nspobs,Ncxy,PXA 1010 FORMAT(/,' ERROR: Work array too small,',i4,'*',i4,'>',i6,'.') CALL abend RETURN END IF c----------------------------------------------------------------------- Armaer=0 Dnefob=dble(Nspobs-Nintvl) neltxy=Nspobs*Ncxy nrtxy=Nspobs CALL copy(Xy,neltxy,1,txy) c----------------------------------------------------------------------- c If observations excluded from regression, delete the offending c rows of data from txy and adjust the row length variables. c----------------------------------------------------------------------- IF(Nxcld.gt.0)THEN CALL dlrgrw(txy,Ncxy,Nspobs,Rgxcld) nrtxy=nrtxy-Nxcld neltxy=nrtxy*Ncxy Dnefob=Dnefob-Nxcld END IF c----------------------------------------------------------------------- c Perform OLS regression c----------------------------------------------------------------------- IF(Nb.le.0)THEN CALL yprmy(txy,nrtxy,apa) Chlxpx(1)=sqrt(apa) ELSE CALL olsreg(txy,nrtxy,Ncxy,Ncxy,B,Chlxpx,PXPX,Sngcol) IF(Lfatal)RETURN IF(Sngcol.gt.0)THEN Convrg=F Armaer=PSNGER RETURN END IF Nfev=Nfev+Ncxy+1 END IF c----------------------------------------------------------------------- c Calculate the objective function. c----------------------------------------------------------------------- CALL resid(txy,nrtxy,Ncxy,Ncxy,1,Nb,MONE,B,A) IF(Lfatal)RETURN CALL yprmy(A,nrtxy,apa) c----------------------------------------------------------------------- c Calculate the maximum likelihood variance and the likelihood c----------------------------------------------------------------------- Var=apa/Dnefob IF(Var.lt.TWO*dpmpar(1))Var=ZERO IF(dpeq(Var,ZERO))THEN Lnlkhd=ZERO ELSE Lnlkhd=-(Dnefob*(log(TWO*PI*Var)+ONE))/TWO END IF c----------------------------------------------------------------------- RETURN END replac.f0000664006604000003110000000727514521201553011617 0ustar sun00315stepsC Last change: BCM 11 Sep 97 3:16 pm SUBROUTINE replac(X,Y,Stwt,Lfda,Llda,Nm) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE REPLACES VALUES IN ARRAY X WHICH HAVE A WEIGHT C --- LESS THAN 1.0. THE REPLACEMENT VALUES ARE STORED IN ARRAY Y. C --- THE REPLACEMENT VALUES ARE COMPUTED USING AN AVERAGE C --- OF THE NON-FULL WEIGHT VALUE TIMES ITS WEIGHT AND THE NEAREST C --- 4 FULL-WEIGHT VALUES. c----------------------------------------------------------------------- DOUBLE PRECISION BIG,ONE PARAMETER(BIG=10D16,ONE=1D0) c----------------------------------------------------------------------- DOUBLE PRECISION totals,ave,Stwt,sumx,X,Y INTEGER i,inc,j,kfda,klda,l,Lfda,Llda,m,n,Nm,ihee,ihle,m2,nnm DIMENSION X(Llda),Y(Llda),Stwt(Llda) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- IF(Nm.ne.1)THEN DO i=1,Llda Y(i)=BIG END DO END IF DO i=1,Nm kfda=Lfda+i-1 klda=(Llda-kfda)/Nm*Nm+kfda IF(Nm.ne.1)ave=totals(X,kfda,klda,Nm,1) DO j=kfda,Llda,Nm C --- TEST FOR FULL WEIGHT (1.0). 00403500 IF(dpeq(Stwt(j),ONE))GO TO 80 n=0 sumx=Stwt(j)*X(j) c change by brian c. monsell C --- SET INDICATORS FOR HITTING ENDS 00403200 ihee=0 ihle=0 c end of change by brian c. monsell IF(j-Nm.le.kfda)THEN C --- EXTREME VALUES IN THE FIRST 2 LOCATIONS AT EITHER END OF THE ARRAY00404100 C --- ARE REPLACED USING THE FOUR NEAREST NON-EXTREME VALUES. 00404200 m=kfda l=klda inc=Nm ELSE IF(klda-Nm.gt.j)GO TO 20 m=klda l=kfda inc=-Nm END IF 10 IF(Stwt(m).ge.ONE)THEN sumx=sumx+X(m) n=n+1 IF(n.ge.4)GO TO 60 END IF IF(m.eq.l)GO TO 50 m=m+inc GO TO 10 C --- EXTREME CENTRAL VALUES ARE REPLACED BY THE 2 NEAREST NON-EXTREME 00405700 C --- VALUES ON EACH SIDE IF 2 NON-EXTREME VALUES EXIST ON EACH SIDE. 00405800 C --- IF NOT, THE EXTREME CENTRAL VALUES ARE REPLACED BY THE FOUR 00405900 C --- NEAREST NON-EXTREME VALUES. 00406000 20 m=j c change by brian c. monsell IF(ihle.eq.0.and.ihee.eq.1)m=m2 c end of change by brian c. monsell l=klda inc=Nm 30 DO WHILE (m.ne.l) m=m+inc IF(dpeq(Stwt(m),ONE))THEN sumx=sumx+X(m) n=n+1 GO TO(30,40,30,60),n GO TO 40 END IF END DO IF(inc.eq.Nm)ihle=1 nnm=-Nm IF(inc.eq.nnm)ihee=1 IF(ihle.eq.0)GO TO 20 IF(ihee.ne.0)GO TO 50 c 15 M = J 00407600 c change by brian c. monsell 40 IF(ihle.le.0.or.n.ne.2)THEN IF(ihee.gt.0)THEN m=m2 ELSE m2=m m=j END IF c end of change by brian c. monsell l=kfda inc=-Nm END IF GO TO 30 50 IF(Nm.le.1)GO TO 80 C --- IF THERE ARE FEWER THAN 4 FULL WEIGHT VALUES IN THE MONTH, REPLACE00408100 C --- THE EXTREME VALUE WITH THE AVERAGE OF ALL THE SI VALUES. 00408200 X(j)=ave GO TO 70 60 X(j)=sumx/(n+Stwt(j)) IF(Nm.le.1)GO TO 80 70 Y(j)=X(j) 80 CONTINUE END DO END DO RETURN END replyf.f0000664006604000003110000000470014521201554011641 0ustar sun00315stepsC Last change: BCM 13 Jul 2005 3:05 pm SUBROUTINE replyf() IMPLICIT NONE c----------------------------------------------------------------------- c Replace leap year february regressor with appropriate length of c month/quarter regressor if kfulsm=2. c Brian Monsell, July 2005 c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER thisg*(PGRPCR),thisc*(PCOLCR),perstr*(7) DOUBLE PRECISION thisb LOGICAL thisf INTEGER icol,igrp,begcol,endcol,iper,nchr,thisty,ncol,idsp c----------------------------------------------------------------------- perstr='Month ' iper=5 idsp=2 IF(Sp.eq.4)then perstr='Quarter' iper=7 idsp=1 END IF c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 icol=endcol DO WHILE(icol.ge.begcol) IF(Rgvrtp(icol).eq.PRGTLY.or.Rgvrtp(icol).eq.PRRTLY.or. & Rgvrtp(icol).eq.PRATLY)THEN thisb=B(icol) thisf=Regfx(icol) thisty=Rgvrtp(icol) IF(Rgvrtp(icol).eq.PRRTLY.or.Rgvrtp(icol).eq.PRATLY)THEN CALL getstr(Grpttl,Grpptr,Ngrp,igrp,thisg,nchr) IF(Lfatal)RETURN END IF CALL dlrgef(icol,Nspobs,1) IF(Lfatal)RETURN IF(thisty.eq.PRGTLY)THEN CALL adrgef(thisb,'Length-of-'//perstr(1:iper), & 'Length-of-'//perstr(1:iper),thisty-idsp,thisf,F) ELSE IF(thisty.eq.PRRTLY)THEN ncol=iper+12 thisc(1:ncol)='Length-of-'//perstr(1:iper)//' I' ELSE ncol=iper+13 thisc='Length-of-'//perstr(1:iper)//' II' END IF CALL adrgef(thisb,thisc(1:ncol), & 'Length-of-'//perstr(1:iper)//thisg(10:nchr), & thisty-idsp,thisf,F) END IF END IF icol=icol-1 END DO END DO c----------------------------------------------------------------------- RETURN END resid2.f0000664006604000003110000000213714521201554011532 0ustar sun00315steps SUBROUTINE resid2(Xy,Nr,Nc,Nb,Xdev,B,Rsd,Sti) IMPLICIT NONE c----------------------------------------------------------------------- c Returns the residuals from an X-11 regression model for a c multiplicative seasonal adjustment when both X-11 and Holiday c regressors are used. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION Xy,B,Rsd,tmp,Sti INTEGER icol,irow,ir2,Nr,Nc,Nb,Xdev DIMENSION B(*),Rsd(*),tmp(PLEN),Xy(Nc*Nr),Sti(PLEN) c----------------------------------------------------------------------- DO icol=1,Nb CALL daxpy(Nr,B(icol),Xy(icol),Nc,tmp,1) END DO c----------------------------------------------------------------------- DO irow=1,Nr ir2=irow+Xdev-1 Rsd(irow)=(Xnstar(ir2)*Sti(ir2))-(Xn(ir2)+tmp(irow))/Kvec(irow) END DO c----------------------------------------------------------------------- RETURN END resid.f0000664006604000003110000000677114521201554011460 0ustar sun00315stepsC Last change: BCM 26 Jan 98 1:20 pm **==resid.f processed by SPAG 4.03F at 09:52 on 1 Mar 1994 SUBROUTINE resid(Xy,Nr,Nc,Pc,Begcol,Endcol,Fac,B,Rsd) IMPLICIT NONE c----------------------------------------------------------------------- c Returns the residuals from a regression model, rsd=y+sign(fac)*Xb c where X and y are the extended matrix [X:y] and the data vector y is c in the pcth column so if pc=nc then there can be only nc-1 regression c effects. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c addsub i Local factor to add or subtract the regression residuals c thus calculating y-Xb or a+Xb c b d Input min(nc,pc-1) long vector of regression parameter c estimates c begcol i Input begining column of X used to calculate the residuals c endcol i Input end column of X used to calculate the residuals c fac d Input scalar whose sign determines weather the regression c effects are added or subtracted from the data. c i i Local do loop index c j i Local do loop index c nc i Input number for columns used in [X:y] c nr i Input number of rows in both X and y c one d Local PARAMETER of a double precision 1 c pc i Input PARAMETER for the leading array (column) index of [X:y] c rsd d Output nr long vector of residuals c sum d Local inner product of x(i,.)*b(.) c xy d Input nr by nc [X:y] matrix with the data vector y in the c pcth column which may not be nc+1 c zo d Local PARAMETER for a double precision 0 c----------------------------------------------------------------------- c Data typing and initialization c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE PARAMETER(ONE=1D0) INTEGER Pc c----------------------------------------------------------------------- INTEGER Begcol,Endcol,icol,Nc,Nr DOUBLE PRECISION addsub,B,Fac,Rsd,Xy DIMENSION B(*),Rsd(Nr),Xy(Pc*Nr) c----------------------------------------------------------------------- c First check that the begining and ending columns are between 1 c and nc. c----------------------------------------------------------------------- IF(Nc.eq.0.or.Endcol+1.eq.Begcol)THEN CALL dcopy(Nr,Xy(Pc),Pc,Rsd,1) ELSE IF(Begcol.lt.1.or.Endcol.gt.Nc.or.Endcol.lt.Begcol)THEN CALL errhdr WRITE(STDERR,1010)Begcol,Endcol,Nc WRITE(Mt2,1010)Begcol,Endcol,Nc 1010 FORMAT(/,' Column error, 1<=begcol<=endcol<= nc',/,26x,3I8) CALL abend RETURN c----------------------------------------------------------------------- c Make addsub from fac c----------------------------------------------------------------------- ELSE addsub=sign(ONE,Fac) CALL dcopy(Nr,Xy(Pc),Pc,Rsd,1) c----------------------------------------------------------------------- c Calculate the residuals c----------------------------------------------------------------------- DO icol=Begcol,Endcol CALL daxpy(Nr,addsub*B(icol),Xy(icol),Pc,Rsd,1) END DO END IF c----------------------------------------------------------------------- RETURN END restor.f0000664006604000003110000000613514521201554011662 0ustar sun00315stepsC Last change: Nov.2, 2023 reset nrusrx value C previous change: BCM 16 Feb 1999 3:52 pm SUBROUTINE restor(Lmodel,Lx11,Lx11rg) IMPLICIT NONE c----------------------------------------------------------------------- C USE TEMPORARY VARIABLES TO RESET ORIGINAL SEASONAL ADJUSTMENT C OPTIONS for the sliding spans and revisions analysis options. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'lzero.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'ssprep.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- INTEGER PACM PARAMETER(PACM=(PLEN+2*PORDER)*PARIMA) c ------------------------------------------------------------------ LOGICAL Lmodel,Lx11,Lx11rg INTEGER i c----------------------------------------------------------------------- Kfmt=Kfm2 c----------------------------------------------------------------------- IF(Lx11)THEN DO i=1,12 Lter(i)=Lt2(i) END DO c Lopt=Lop2 Ktcopt=Ktc2 Tic=Tc2 END IF IF(Lx11rg)THEN c DO i=1,7 c Dwt(i)=Dwt2(i) c D(i)=0. c END DO Kswv=Ksw2 Khol=Kh2 END IF c----------------------------------------------------------------------- C USE TEMPORARY VARIABLES TO RESET ORIGINAL regARIMA OPTIONS. c----------------------------------------------------------------------- IF(Lmodel)THEN Ngrp=Ngr2 Ngrptl=Ngrt2 Ncxy=Ncxy2 Nb=Nbb Priadj=Pri2 Ncoltl=Nct2 i=PCOLCR*PB Colttl(1:i)=Cttl(1:i) i=PGRPCR*PGRP Grpttl(1:i)=Gttl(1:i) CALL cpyint(Clptr(0),PB+1,1,Colptr(0)) CALL cpyint(G2(0),PGRP+1,1,Grp(0)) CALL cpyint(Gptr(0),PGRP+1,1,Grpptr(0)) CALL cpyint(Rgv2,PB,1,Rgvrtp) CALL copy(Ap2,PARIMA,1,Arimap) CALL copy(Bb,PB,1,B) CALL copylg(Fxa,PB,1,Arimaf) Nrxy=Nr2 Iregfx=Irfx2 CALL copylg(Regfx2,PB,1,Regfx) Ncusrx=Ncusr2 Nrusrx=Nrusrx2 Picktd=Pktd2 Adjtd=Atd Adjhol=Ahol Adjao=Aao Adjls=Als Adjtc=Atc Adjso=Aso Adjsea=Asea Adjusr=Ausr Finhol=Fnhol Finao=Fnao Finls=Fnls Fintc=Fntc Finusr=Fnusr Fulltd=Flltd Lma=Lma2 Lar=Lar2 Nintvl=Nintv2 Nextvl=Nextv2 Mxdflg=Mxdfl2 Mxarlg=Mxarl2 Mxmalg=Mxmal2 Var=V2 CALL copy(Chx2,PXPX,1,Chlxpx) CALL copy(Chg2,PGPG,1,Chlgpg) CALL copy(Acm2,PACM,1,Armacm) Lndtcv=Dtcv2 END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END revchk.f0000664006604000003110000014655514521201554011641 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 12:41 pm SUBROUTINE revchk(Irev,Irevsa,Ixreg,Ny,Lfda,Llda,Ltmax,Nspobs, & Begspn,Endspn,Begmdl,Lx11,Lseats,Lmodel,Lnoprt, & Iagr,Ncomp,Fctdrp,Lr1y2y,Revsa,Revmdl,Fhnote, & Khol,Kfulsm) IMPLICIT NONE c----------------------------------------------------------------------- c Check settings for revisons history analysis c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revtrg.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11reg.cmn' * INCLUDE 'seatcm.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'revtbl.i' INCLUDE 'error.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F,T INTEGER LRVR1S,LRVR1A,LRVR2S,LRVR2A,LRVR3S,LRVR3A,LRVR4S, & LRVR4A,LRVR5S,LRVR5A,LRVR6S,LRVR6A,LRVR8A,MINSPN,MINYR PARAMETER(F=.false.,T=.true.,LRVR1S=LREVR1+1,MINSPN=60,MINYR=5, & LRVR1A=LREVR1+2,LRVR2S=LREVR2+1,LRVR2A=LREVR2+2, & LRVR3S=LREVR3+1,LRVR3A=LREVR3+2,LRVR4S=LREVR4+1, & LRVR4A=LREVR4+2,LRVR5S=LREVR5+1,LRVR5A=LREVR5+2, & LRVR6S=LREVR6+1,LRVR6A=LREVR6+2,LRVR8A=LREVR8+1) c----------------------------------------------------------------------- CHARACTER str*(10),datstr*(10) LOGICAL Lx11,Lseats,Lmodel,Lnoprt,Revsa,Revmdl,Lr1y2y,nosarv, & usstrt,isFixed,tdfix INTEGER Begspn,Endspn,Begmdl,Fctdrp,Irev,Ixreg,Lfda,Llda,Ny, & Nspobs,nyrev,Ltmax,i,i2,strtyr,Iagr,imdl,idate,ndmdl, & nchr,nchdat,ndx11,n1,Ncomp,Fhnote,Irevsa,Khol,Kfulsm, & icol,ntd,begopr,endopr,rtype,iusr DIMENSION Begspn(2),Endspn(2),Begmdl(2),idate(2),strtyr(-1:5) c----------------------------------------------------------------------- c strtyr - number of years in starting period for each type of c seasonal filter. c----------------------------------------------------------------------- DATA strtyr/6,5,6,8,12,18,6/ c----------------------------------------------------------------------- Lr1y2y=F usstrt=Rvstrt(1).gt.0 c----------------------------------------------------------------------- IF(Lseats.and.(((Lrvsa.or.Lrvch).and.(.not.Havesa)).or. & ((Lrvtrn.or.Lrvtch).and.(.not.Havetr)).or. & (Lrvsf.and.(.not.Havesf))))THEN CALL writln('WARNING: History analysis for estimates derived from & SEATS adjustments',STDERR,Mt2,T) CALL writln(' cannot be done when SEATS cannot perform a &signal extraction.',STDERR,Mt2,F) Irev=0 Irevsa=-1 IF(Indrev.gt.0)Indrev=0 RETURN END IF c----------------------------------------------------------------------- c If seasonal adjustment not done, set logical indicators for s.a. c revisions estimates (s.a. series, sf, changes) to false and print c warning message. c----------------------------------------------------------------------- IF(.not.(Lx11.or.Lseats))THEN IF(Lrvsa)THEN CALL writln('ERROR: Cannot calculate revision statistics for sea &sonally adjusted data',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not specified via &x11 or seats spec.',STDERR,Mt2,F) Lrvsa=F IF(Indrev.gt.0)Indrev=0 END IF c----------------------------------------------------------------------- IF(Lrvsf)THEN CALL writln('ERROR: Cannot calculate revision statistics for sea &sonal factors',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not specified via &x11 or seats spec.',STDERR,Mt2,F) Lrvsf=F END IF c----------------------------------------------------------------------- IF(Lrvch)THEN CALL writln('ERROR: Cannot calculate revision statistics for cha &nges in the adjusted data',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not specified via &x11 or seats spec.',STDERR,Mt2,F) Lrvch=F END IF c----------------------------------------------------------------------- IF(Lrvtrn)THEN CALL writln('ERROR: Cannot calculate revision statistics for tre &nd component',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not specified via &x11 or seats spec.',STDERR,Mt2,F) Lrvtrn=F END IF c----------------------------------------------------------------------- IF(Lrvtch)THEN CALL writln('ERROR: Cannot calculate revision statistics for cha &nges in the trend',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not specified via &x11 or seats spec.',STDERR,Mt2,F) Lrvtch=F END IF ELSE IF(Lseats)THEN IF(Lrvsa.and.(.not.Havesa))THEN CALL writln('ERROR: Cannot calculate revision statistics for sea &sonally adjusted data',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not performed duri &ng SEATS analysis.',STDERR,Mt2,F) Lrvsa=F IF(Indrev.gt.0)Indrev=0 END IF c----------------------------------------------------------------------- IF(Lrvsf.and.(.not.Havesf))THEN CALL writln('ERROR: Cannot calculate revision statistics for sea &sonal factors',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not performed duri &ng SEATS analysis.',STDERR,Mt2,F) Lrvsf=F END IF c----------------------------------------------------------------------- IF(Lrvch.and.(.not.Havesa))THEN CALL writln('ERROR: Cannot calculate revision statistics for cha &nges in the adjusted data',STDERR,Mt2,T) CALL writln(' if seasonal adjustment is not performed duri &ng SEATS analysis.',STDERR,Mt2,F) Lrvch=F END IF c----------------------------------------------------------------------- IF(Lrvtrn.and.(.not.Havetr))THEN CALL writln('ERROR: Cannot calculate revision statistics for tre &nd component',STDERR,Mt2,T) CALL writln(' if trend component not estimated during SEAT &S analysis.',STDERR,Mt2,F) Lrvtrn=F END IF c----------------------------------------------------------------------- IF(Lrvtch.and.(.not.Havetr))THEN CALL writln('ERROR: Cannot calculate revision statistics for cha &nges in the trend',STDERR,Mt2,T) CALL writln(' if trend component not estimated during SEAT &S analysis.',STDERR,Mt2,F) Lrvtch=F END IF END IF c----------------------------------------------------------------------- c If regARIMA modelling not done, set logical indicators for s.a. c revisions estimates (s.a. series, sf, changes) to false and print c warning message. c----------------------------------------------------------------------- IF(.not.Lmodel)THEN IF(Prttab(LREVOT))Prttab(LREVOT)=F IF(Lrvaic)THEN CALL writln('ERROR: Cannot calculate revision statistics for lik &elihood statistics',STDERR,Mt2,T) CALL writln(' if regARIMA modelling is not specified.', & STDERR,Mt2,F) Lrvaic=F END IF c----------------------------------------------------------------------- IF(Lrvfct)THEN CALL writln('ERROR: Cannot calculate revision statistics for for &ecasts if no forecasts',STDERR,Mt2,T) CALL writln(' are specified.',STDERR,Mt2,F) Lrvfct=F END IF c----------------------------------------------------------------------- IF(Lrvarma)THEN CALL writln('ERROR: Cannot calculate revision statistics for ARM &A parameters if no',STDERR,Mt2,T) CALL writln(' ARIMA model is specified.',STDERR,Mt2,F) Lrvarma=F END IF c----------------------------------------------------------------------- IF(Lrvtdrg)THEN CALL writln('ERROR: Cannot calculate revision statistics for tra &ding day ',STDERR,Mt2,T) CALL writln( & ' coefficients if no ARIMA model is specified.', & STDERR,Mt2,F) Lrvtdrg=F END IF c----------------------------------------------------------------------- c If projected seasonal factors are analysed and the number of c forecasts are > 0 and < Ny, do not perform projected seasonal c factor revisions history analysis c----------------------------------------------------------------------- ELSE IF(Nfcst.gt.0.and.Nfcst.lt.Ny.and.Lrvsf)THEN CALL writln('WARNING: Cannot calculate revision statistics for pr &ojected seasonal',Fhnote,Mt2,T) CALL writln(' factors unless either zero forecasts or at &least one year of',Fhnote,Mt2,F) CALL writln(' forecasts are specified.',Fhnote,Mt2,F) Lrvsf=F c----------------------------------------------------------------------- ELSE IF(Lrvarma)THEN isFixed=T IF(.not.Revfix)THEN DO i=AR,MA begopr=Mdl(i-1) endopr=Mdl(i)-1 DO i2=begopr,endopr isFixed=isFixed.and.Arimaf(i) END DO END DO END IF IF(isFixed)THEN CALL writln('ERROR: Cannot calculate revision statistics for '// & 'ARMA parameters if all',STDERR,Mt2,T) IF(Revfix)THEN CALL writln(' coefficients in regARIMA model is fixed '// & '(fixmdl=yes).',STDERR,Mt2,F) ELSE CALL writln(' the ARIMA model coefficients are fixed.', & STDERR,Mt2,F) END IF Lrvarma=F END IF c----------------------------------------------------------------------- ELSE IF(Lrvtdrg)THEN isFixed=T DO icol=1,Nb rtype=Rgvrtp(icol) IF(Nusrrg.gt.0)THEN IF(rtype.eq.PRGTUD)THEN rtype=Usrtyp(iusr) iusr=iusr+1 ELSE IF((rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGTUS)THEN iusr=iusr+1 END IF END IF c----------------------------------------------------------------------- c regARIMA trading day regressors c----------------------------------------------------------------------- IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY))THEN Ntd=Ntd+1 IF(.not.Revfix)isFixed=isFixed.and.Regfx(i) END IF END DO IF(Ntd.gt.0.and.Nrvfxr.gt.0)THEN tdfix=F DO i=1,Nrvfxr IF(Rvfxrg(i).eq.1)tdfix=T END DO END IF IF(ntd.eq.0)THEN CALL writln('ERROR: Cannot calculate revision statistics for tra &ding day ',STDERR,Mt2,T) CALL writln(' coefficients if no trading day regressors ar &e specified.',STDERR,Mt2,F) Lrvtdrg=F ELSE IF(tdfix)THEN CALL writln('ERROR: Cannot calculate revision statistics for tra &ding day ',STDERR,Mt2,T) CALL writln(' coefficients if fixreg=td.',STDERR,Mt2,F) Lrvtdrg=F ELSE IF(isFixed)THEN CALL writln('ERROR: Cannot calculate revision statistics for tra &ding day ',STDERR,Mt2,T) IF(Revfix)THEN CALL writln(' coefficients if regARIMA model is fixed (fi &xmdl=yes).',STDERR,Mt2,F) ELSE CALL writln(' coefficients if all trading day regressors &are fixed.',STDERR,Mt2,F) END IF Lrvtdrg=F END IF END IF c----------------------------------------------------------------------- c If revisions analysis is not selected for a particular estimate, c turn off the print and save indicators for that estimate. c----------------------------------------------------------------------- IF(.not.Lrvsa.and. & (Prttab(LREVR1).or.Prttab(LRVR1S).or.Prttab(LRVR1A).or. & Savtab(LREVR1).or.Savtab(LRVR1S).or.Savtab(LRVR1A).or. & Prttab(LREVR3).or.Prttab(LRVR3S).or.Prttab(LRVR3A).or. & Savtab(LREVR3).or.Savtab(LRVR3S).or.Savtab(LRVR3A)))THEN IF(Prttab(LREVR1))Prttab(LREVR1)=F IF(Savtab(LREVR1))Savtab(LREVR1)=F IF(Prttab(LRVR1S))Prttab(LRVR1S)=F IF(Savtab(LRVR1S))Savtab(LRVR1S)=F IF(Prttab(LRVR1A))Prttab(LRVR1A)=F IF(Savtab(LRVR1A))Savtab(LRVR1A)=F IF(Prttab(LREVR3))Prttab(LREVR3)=F IF(Savtab(LREVR3))Savtab(LREVR3)=F IF(Prttab(LRVR3S))Prttab(LRVR3S)=F IF(Savtab(LRVR3S))Savtab(LRVR3S)=F IF(Prttab(LRVR3A))Prttab(LRVR3A)=F IF(Savtab(LRVR3A))Savtab(LRVR3A)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvch.and. & (Prttab(LREVR2).or.Prttab(LRVR2S).or.Prttab(LRVR2A).or. & Savtab(LREVR2).or.Savtab(LRVR2S).or.Savtab(LRVR2A)))THEN IF(Prttab(LREVR2))Prttab(LREVR2)=F IF(Savtab(LREVR2))Savtab(LREVR2)=F IF(Prttab(LRVR2S))Prttab(LRVR2S)=F IF(Savtab(LRVR2S))Savtab(LRVR2S)=F IF(Prttab(LRVR2A))Prttab(LRVR2A)=F IF(Savtab(LRVR2A))Savtab(LRVR2A)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvtrn.and. & (Prttab(LREVR4).or.Prttab(LRVR4S).or.Prttab(LRVR4A).or. & Savtab(LREVR4).or.Savtab(LRVR4S).or.Savtab(LRVR4A)))THEN IF(Prttab(LREVR4))Prttab(LREVR4)=F IF(Savtab(LREVR4))Savtab(LREVR4)=F IF(Prttab(LRVR4S))Prttab(LRVR4S)=F IF(Savtab(LRVR4S))Savtab(LRVR4S)=F IF(Prttab(LRVR4A))Prttab(LRVR4A)=F IF(Savtab(LRVR4A))Savtab(LRVR4A)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvtch.and. & (Prttab(LREVR5).or.Prttab(LRVR5S).or.Prttab(LRVR5A).or. & Savtab(LREVR5).or.Savtab(LRVR5S).or.Savtab(LRVR5A)))THEN IF(Prttab(LREVR5))Prttab(LREVR5)=F IF(Savtab(LREVR5))Savtab(LREVR5)=F IF(Prttab(LRVR5S))Prttab(LRVR5S)=F IF(Savtab(LRVR5S))Savtab(LRVR5S)=F IF(Prttab(LRVR5A))Prttab(LRVR5A)=F IF(Savtab(LRVR5A))Savtab(LRVR5A)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvsf.and. & (Prttab(LREVR6).or.Prttab(LRVR6S).or.Prttab(LRVR6A).or. & Savtab(LREVR6).or.Savtab(LRVR6S).or.Savtab(LRVR6A)))THEN IF(Prttab(LREVR6))Prttab(LREVR6)=F IF(Savtab(LREVR6))Savtab(LREVR6)=F IF(Prttab(LRVR6S))Prttab(LRVR6S)=F IF(Savtab(LRVR6S))Savtab(LRVR6S)=F IF(Prttab(LRVR6A))Prttab(LRVR6A)=F IF(Savtab(LRVR6A))Savtab(LRVR6A)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvaic.and.(Prttab(LREVR7).or.Savtab(LREVR7)))THEN IF(Prttab(LREVR7))Prttab(LREVR7)=F IF(Savtab(LREVR7))Savtab(LREVR7)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvfct.and.(Prttab(LREVR8).or.Savtab(LREVR8).or. & Prttab(LRVR8A)))THEN IF(Prttab(LREVR8))Prttab(LREVR8)=F IF(Savtab(LREVR8))Savtab(LREVR8)=F IF(Prttab(LRVR8A))Prttab(LRVR8A)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvarma.and.(Prttab(LRVR9A).or.Savtab(LRVR9A)))THEN IF(Prttab(LRVR9A))Prttab(LRVR9A)=F IF(Savtab(LRVR9A))Savtab(LRVR9A)=F END IF c----------------------------------------------------------------------- IF(.not.Lrvtdrg.and.(Prttab(LRVR9B).or.Savtab(LRVR9B)))THEN IF(Prttab(LRVR9B))Prttab(LRVR9B)=F IF(Savtab(LRVR9B))Savtab(LRVR9B)=F END IF c----------------------------------------------------------------------- c If estimate selected for revisions analysis but no tables are c printed or stored, ensure that the revisions table will be printed c out. c comment out for Build 59 - 9/24/2021 if print=none, no tables are c printed c----------------------------------------------------------------------- c IF(.not.Lnoprt)THEN c IF(Lrvsa)THEN c IF(.not.(Prttab(LREVR1).or.Prttab(LRVR1S).or.Prttab(LRVR1A).or. c & Savtab(LREVR1).or.Savtab(LRVR1S).or.Savtab(LRVR1A))) c & Prttab(LREVR1)=T c IF(Iagr.ge.5.and..not. c & (Prttab(LREVR3).or.Prttab(LRVR3S).or.Prttab(LRVR3A).or. c & Savtab(LREVR3).or.Savtab(LRVR3S).or.Savtab(LRVR3A))) c & Prttab(LREVR3)=T c END IF c IF(Lrvch.and..not. c & (Prttab(LREVR2).or.Prttab(LRVR2S).or.Prttab(LRVR2A).or. c & Savtab(LREVR2).or.Savtab(LRVR2S).or.Savtab(LRVR2A))) c & Prttab(LREVR2)=T c IF(Lrvtrn.and..not. c & (Prttab(LREVR4).or.Prttab(LRVR4S).or.Prttab(LRVR4A).or. c & Savtab(LREVR4).or.Savtab(LRVR4S).or.Savtab(LRVR4A))) c & Prttab(LREVR4)=T c IF(Lrvtch.and..not. c & (Prttab(LREVR5).or.Prttab(LRVR5S).or.Prttab(LRVR5A).or. c & Savtab(LREVR5).or.Savtab(LRVR5S).or.Savtab(LRVR5A))) c & Prttab(LREVR5)=T c IF(Lrvsf.and..not. c & (Prttab(LREVR6).or.Prttab(LRVR6S).or.Prttab(LRVR6A).or. c & Savtab(LREVR6).or.Savtab(LRVR6S).or.Savtab(LRVR6A))) c & Prttab(LREVR6)=T c IF(Lrvaic.and..not.(Prttab(LREVR7).or.Savtab(LREVR7))) c & Prttab(LREVR7)=T c IF(Lrvfct.and..not.(Prttab(LREVR8).or.Savtab(LREVR8).or. c & Prttab(LRVR8A)))Prttab(LREVR8)=T c IF(Lrvarma.and..not.(Prttab(LRVR9A).or.Savtab(LRVR9A))) c & Prttab(LRVR9A)=T c IF(Lrvtdrg.and..not.(Prttab(LRVR9B).or.Savtab(LRVR9B))) c & Prttab(LRVR9B)=T c END IF c----------------------------------------------------------------------- c Check to see if value of the forecast lag to be collected is c appropriate and if revisions of the forecasts should be collected. c----------------------------------------------------------------------- IF(Lrvfct)THEN IF(Nfcst.eq.0)THEN CALL writln('ERROR: Cannot calculate revision statistics for for &ecasts if no forecasts',STDERR,Mt2,T) CALL writln(' are specified via the forecast spec.', & STDERR,Mt2,F) Lrvfct=F c----------------------------------------------------------------------- c If revisions are not collected of the forecasts, set Nfctlg=0 c----------------------------------------------------------------------- DO i=1,Nfctlg Rfctlg(i)=0 END DO Nfctlg=0 c----------------------------------------------------------------------- c If the forecast lag has not been specified, set equal to 1. c----------------------------------------------------------------------- ELSE IF(Nfctlg.eq.0)THEN Nfctlg=2 Rfctlg(1)=1 IF(Nfcst.ge.Ny)THEN Rfctlg(2)=Ny ELSE IF(Nfcst.gt.1)THEN Rfctlg(2)=Nfcst ELSE Nfctlg=1 END IF c----------------------------------------------------------------------- c If the forecast lag is greater than the number of forecasts, c print an error message. c----------------------------------------------------------------------- ELSE DO i=1,Nfctlg IF(Rfctlg(i).gt.Nfcst)THEN CALL writln('WARNING: Cannot utilize forecast lead for history & that is greater than',Fhnote,Mt2,T) CALL writln(' the number of forecasts (maxlead).', & Fhnote,Mt2,F) CALL writln(' History analysis for forecasts will not &be done for this run.',Fhnote,Mt2,T) Lrvfct=F END IF END DO IF(Lrvfct)CALL intsrt(Nfctlg,Rfctlg) END IF IF(Fctdrp.gt.0)Fctdrp=0 END IF c----------------------------------------------------------------------- c If summary measures run being done, only allow seasonal c adjustments to be tallied for composite run. c----------------------------------------------------------------------- IF(Kfulsm.ge.1)THEN nosarv=Kfulsm.eq.1.or.(.not.(Axrgtd.or.Axrghl.or.Adjtd.eq.1.or. & Adjhol.eq.1.or.Khol.gt.0)) IF(Lrvsa)THEN IF(Iagr.eq.0.or.Iagr.ge.5)THEN IF(nosarv)THEN CALL writln('ERROR: Cannot calculate revision statistics for s &easonally adjusted data',STDERR,Mt2,T) IF(Kfulsm.eq.1)THEN CALL writln(' if a summary measures run is specified in & the x11 spec.',STDERR,Mt2,F) ELSE CALL writln(' if a trend estimation run is specified in & the x11 spec.',STDERR,Mt2,F) END IF Lrvsa=F END IF ELSE IF(Prttab(LREVR1))Prttab(LREVR1)=F IF(Prttab(LRVR1S))Prttab(LRVR1S)=F IF(Prttab(LRVR1A))Prttab(LRVR1A)=F IF(Savtab(LREVR1))Savtab(LREVR1)=F END IF END IF c----------------------------------------------------------------------- IF(Lrvsf)THEN CALL writln('ERROR: Cannot calculate revision statistics for sea &sonal factors',STDERR,Mt2,T) IF(Kfulsm.eq.1)THEN CALL writln(' if a summary measures run is specified in t &he x11 spec.',STDERR,Mt2,F) ELSE CALL writln(' if a trend estimation run is specified in t &he x11 spec.',STDERR,Mt2,F) END IF Lrvsf=F END IF c----------------------------------------------------------------------- IF(Lrvch.and.nosarv)THEN CALL writln('ERROR: Cannot calculate revision statistics for cha &nges in the adjusted data',STDERR,Mt2,T) IF(Kfulsm.eq.1)THEN CALL writln(' if a summary measures run is specified in t &he x11 spec.',STDERR,Mt2,F) ELSE CALL writln(' if a trend estimation run is specified in t &he x11 spec.',STDERR,Mt2,F) END IF Lrvch=F END IF c----------------------------------------------------------------------- IF(Lrvtrn.and.Kfulsm.eq.1)THEN CALL writln('ERROR: Cannot calculate revision statistics for tre &nd component',STDERR,Mt2,T) CALL writln(' if a summary measures run is specified in th &e x11 spec.',STDERR,Mt2,F) Lrvtrn=F END IF c----------------------------------------------------------------------- IF(Lrvtch.and.Kfulsm.eq.1)THEN CALL writln('ERROR: Cannot calculate revision statistics for cha &nges in the trend',STDERR,Mt2,T) CALL writln(' if a summary measures run is specified in th &e x11 spec.',STDERR,Mt2,F) Lrvtch=F END IF c----------------------------------------------------------------------- c If this is a composite analysis, make sure all components were c accounted for in the indirect adjustment. If not, print out c warning message and do not compute revisions for indirect seasonal c adjustments. c----------------------------------------------------------------------- ELSE IF(Iagr.ge.5.and.Ncomp.ne.Nrcomp)THEN IF(.not.Lquiet)WRITE(STDERR,1070)Ncomp,Nrcomp WRITE(Mt2,1070)Ncomp,Nrcomp IF(Indrev.gt.0)Indrev=0 END IF c----------------------------------------------------------------------- c Check to see if there will be a revisions analysis on at least one c of the estimates. If not, print out warning message. c----------------------------------------------------------------------- IF(.not.(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvaic.or.Lrvfct.or.Lrvtrn.or. & Lrvtch.or.Lrvarma.or.Lrvtdrg))THEN CALL writln('WARNING: History analysis will not be performed for &this run because',Fhnote,Mt2,T) CALL writln(' of error(s) indicated above.',Fhnote,Mt2,F) Irev=0 IF(Irevsa.gt.0)Irevsa=-1 IF(Indrev.gt.0)Indrev=0 RETURN END IF c----------------------------------------------------------------------- c Set up starting period c----------------------------------------------------------------------- Revsa=(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvtrn.or.Lrvtch) Revmdl=(Lrvfct.or.Lrvaic.or.Lrvarma.or.Lrvtdrg) IF(Rvstrt(MO).eq.0.and.Rvstrt(YR).eq.0)THEN IF(Revmdl)THEN imdl=8*Ny IF(Ny.eq.4)imdl=10*Ny IF(Revsa)THEN IF(imdl.ge.strtyr(Ltmax)*Ny)THEN CALL addate(Begspn,Ny,imdl,Rvstrt) IF(imdl.gt.strtyr(Ltmax))THEN IF (Lrvfct) THEN WRITE(Mt2,1010)'forecast' ELSE IF (Lrvaic) THEN WRITE(Mt2,1010)'AIC' ELSE IF (Lrvarma) THEN WRITE(Mt2,1010)'ARMA coefficients' ELSE IF (Lrvtdrg) THEN WRITE(Mt2,1010)'TD coefficients' END IF END IF ELSE CALL addate(Begspn,Ny,strtyr(Ltmax)*Ny,Rvstrt) IF (Lrvfct) THEN WRITE(Mt2,1020)'forecast' ELSE IF (Lrvaic) THEN WRITE(Mt2,1020)'AIC' ELSE IF (Lrvarma) THEN WRITE(Mt2,1020)'ARMA coefficients' ELSE IF (Lrvtdrg) THEN WRITE(Mt2,1020)'TD coefficients' END IF END IF ELSE CALL addate(Begspn,Ny,imdl,Rvstrt) END IF ELSE CALL addate(Begspn,Ny,strtyr(Ltmax)*Ny,Rvstrt) END IF ELSE IF(Rvstrt(YR).lt.1900)Rvstrt(YR)=1900+Rvstrt(YR) END IF c----------------------------------------------------------------------- c Set up ending period c----------------------------------------------------------------------- IF(Rvend(MO).eq.0.and.Rvend(YR).eq.0)THEN CALL addate(Begspn,Ny,Nspobs-1,Rvend) ELSE IF(.not.Revsa)THEN CALL writln('WARNING: Ending date of revisions valid only for es &timates derived from',Fhnote,Mt2,T) CALL writln(' seasonal adjustment (seasonally adjusted d &ata, seasonal factors',Fhnote,Mt2,F) CALL writln(' trends, etc.).',Fhnote,Mt2,F) CALL writln(' Ending date of history analysis reset to e &nd of series.',Fhnote,Mt2,T) CALL addate(Begspn,Ny,Nspobs-1,Rvend) ELSE IF(Rvend(YR).lt.1900)THEN Rvend(YR)=1900+Rvend(YR) END IF END IF IF(Irev.eq.2)CALL addate(Begspn,Ny,Nspobs-Ny,Rvend) c----------------------------------------------------------------------- c Check to see if there will be enough data between the start of c the model span and the start of the revisons history loop. c----------------------------------------------------------------------- IF(Lmodel)THEN CALL dfdate(Rvstrt,Begmdl,Ny,ndmdl) ndmdl=ndmdl+1 IF(ndmdl.lt.MINSPN)THEN c----------------------------------------------------------------------- c IF the model is fixed, see if the number of effective observations c will be enough to evaluate the regARIMA model c----------------------------------------------------------------------- IF(Revfix)THEN n1=Nintvl+Nextvl+1 ndmdl=ndmdl-Nintvl c----------------------------------------------------------------------- c If there are not enough effective observations, attempt to c change the starting point of the revisions history to c allow enough observations to evaluate the model c----------------------------------------------------------------------- IF(ndmdl.lt.Nextvl)THEN nchr=1 CALL itoc(n1,str,nchr) IF(Lfatal)RETURN CALL addate(Begmdl,Ny,n1,idate) CALL dfdate(Endspn,idate,Ny,ndmdl) c----------------------------------------------------------------------- c check to see if the proposed starting date for the revisions c history is within the span of data. If so, update the c revisions history starting date. c----------------------------------------------------------------------- IF(ndmdl.gt.0)THEN CALL cpyint(idate,2,1,Rvstrt) c----------------------------------------------------------------------- c If the user specified the starting date for the revisions c history, print out a message docmenting the change in the c revisions history starting date. c----------------------------------------------------------------------- IF(usstrt)THEN CALL wrtdat(Rvstrt,Ny,datstr,nchdat) IF(Lfatal)RETURN CALL writln('NOTE: The start of the history analysis has bee &n advanced to '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' to allow '//str(1:nchr-1)// & ' observations between the start of the model span', & Fhnote,Mt2,F) CALL writln(' and the start of the history analysis.', & Fhnote,Mt2,F) usstrt=F IF(Indrev.gt.0)THEN CALL writln(' Due to this change, the program will not & generate a history analysis',Fhnote,Mt2,T) CALL writln(' of the indirect seasonal adjustments.', & Fhnote,Mt2,F) CALL writln(' Change the starting date for all history & analysis to be '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' or later.',Fhnote,Mt2,F) Indrev=0 END IF END IF ELSE c----------------------------------------------------------------------- c If the proposed starting date for the revisions c history is not within the span of data, update the model span c starting date to be the beginning of the data span, and check if c there are enough observations to evaluate the regARIMA model. c----------------------------------------------------------------------- CALL cpyint(Begspn,2,1,Begmdl) CALL dfdate(Rvstrt,Begmdl,Ny,ndmdl) ndmdl=ndmdl+1 c----------------------------------------------------------------------- c If there are not, print an error message and stop execution c----------------------------------------------------------------------- IF(ndmdl.lt.n1)THEN CALL writln('ERROR: There must be at least '// & str(1:nchr-1)// & ' observations between the start of', & STDERR,Mt2,T) CALL writln(' the model span and the start of the hist &ory analysis when a',STDERR,Mt2,F) CALL writln(' '//Mdldsn(1:Nmddcr)// & ' ARIMA model is present.',STDERR,Mt2,F) IF(Indrev.gt.0)Indrev=0 CALL abend RETURN c----------------------------------------------------------------------- c If there are, print a message explaining what happened c----------------------------------------------------------------------- ELSE CALL writln('NOTE: regARIMA model span will be reset during &the history analysis.',Fhnote,Mt2,T) END IF END IF END IF ELSE c----------------------------------------------------------------------- c IF the model is not fixed, determine if there are more than MINSPN c observations between the start of the model span and the end of the c data span. c----------------------------------------------------------------------- CALL addate(Begmdl,Ny,MINSPN,idate) CALL dfdate(Endspn,idate,Ny,ndmdl) c----------------------------------------------------------------------- c IF there are, use this date as the start of the revisions history c analysis. c----------------------------------------------------------------------- nchr=1 CALL wrtdat(Rvstrt,Ny,datstr,nchdat) IF(.not.Lfatal)CALL itoc(MINSPN,str,nchr) IF(ndmdl.gt.0)THEN CALL cpyint(idate,2,1,Rvstrt) c----------------------------------------------------------------------- c If the user specified the starting date for the revisions c history, print out a message docmenting the change in the c revisions history starting date. c----------------------------------------------------------------------- IF(usstrt)THEN CALL wrtdat(Rvstrt,Ny,datstr,nchdat) IF(Lfatal)RETURN CALL writln('NOTE: The start of the history analysis has been & advanced to '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' to allow '//str(1:nchr-1)// & ' observations between the start of the model span', & Fhnote,Mt2,F) CALL writln(' and the start of the history analysis.', & Fhnote,Mt2,F) usstrt=F IF(Indrev.gt.0)THEN CALL writln(' Due to this change, the program will not &generate a history analysis',Fhnote,Mt2,T) CALL writln(' of the indirect seasonal adjustments.', & Fhnote,Mt2,F) CALL writln(' Change the starting date for all history &analysis to be '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' or later.',Fhnote,Mt2,F) Indrev=0 END IF END IF ELSE c----------------------------------------------------------------------- c If the proposed starting date for the revisions history is not c within the span of data, update the model span starting date to be c the beginning of the data span. c----------------------------------------------------------------------- CALL dfdate(Begmdl,Begspn,Ny,ndmdl) IF(ndmdl.gt.0)CALL cpyint(Begspn,2,1,Begmdl) IF(.not.Revfix)THEN Revfix=T IF(ndmdl.gt.0)THEN CALL writln('NOTE: Since the number of observations modeled &is less than '//str(1:nchr-1)//',',Fhnote,Mt2,T) CALL writln(' regARIMA model span will be reset and reg &ARIMA model parameters',Fhnote,Mt2,F) CALL writln(' will be held fixed during the history ana &lysis.',Fhnote,Mt2,F) ELSE CALL writln('NOTE: Since the number of observations modeled &is less than '//str(1:nchr-1)//',',Fhnote,Mt2,T) CALL writln(' regARIMA model parameters will be held fi &xed during the ',Fhnote,Mt2,F) CALL writln(' history analysis.',Fhnote,Mt2,F) END IF END IF END IF END IF END IF c----------------------------------------------------------------------- c If the regARIMA model is to be fixed, update model parameters c once a year as for the 0.per convention, and print out a c warning to this effect. c----------------------------------------------------------------------- IF(Fixper.gt.0.and.Revfix)THEN Fixper=0 CALL writln('NOTE: regARIMA model parameters will not be re-esti &mated once a year',Fhnote,Mt2,T) CALL writln(' during the history analysis.',Fhnote,Mt2,F) END IF c----------------------------------------------------------------------- c If the regARIMA model is to be updated once a year as for the 0.per c convention, turn off the model refresh option, and print out a c warning to this effect. c----------------------------------------------------------------------- IF(Fixper.gt.0.and.Lrfrsh)THEN Lrfrsh=F CALL writln('NOTE: In order to allow parameter estimation to occ &ur only once a year,',Fhnote,Mt2,T) CALL writln(' the refresh option is ignored.',Fhnote,Mt2,F) END IF END IF c----------------------------------------------------------------------- c Ensure there are at least 5 years of data when seasonal c adjustment is done. c----------------------------------------------------------------------- IF(Lx11)THEN CALL dfdate(Rvstrt,Begspn,Ny,ndmdl) ndmdl=ndmdl+1 c----------------------------------------------------------------------- c determine if there are more than MINYR years between the start and c end of the data span. c----------------------------------------------------------------------- IF(ndmdl.lt.MINYR*Ny)THEN CALL addate(Begspn,Ny,MINYR*Ny,idate) CALL dfdate(Endspn,idate,Ny,ndx11) nchr=1 CALL itoc(MINYR,str,nchr) IF(Lfatal)RETURN c----------------------------------------------------------------------- c IF there are, use this date as the start of the revisions history c analysis. c----------------------------------------------------------------------- IF(ndx11.gt.0)THEN CALL cpyint(idate,2,1,Rvstrt) c----------------------------------------------------------------------- c If the user specified the starting date for the revisions c history, print out a message docmenting the change in the c revisions history starting date. c----------------------------------------------------------------------- IF(usstrt)THEN CALL wrtdat(Rvstrt,Ny,datstr,nchdat) IF(Lfatal)RETURN CALL writln('NOTE: The start of the history analysis has been &advanced to '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' to allow '//str(1:nchr-1)// & ' years between the start of the data span and the start', & Fhnote,Mt2,F) CALL writln(' of the history analysis.', & Fhnote,Mt2,F) usstrt=F IF(Indrev.gt.0)THEN CALL writln(' Due to this change, the program will not g &enerate a history analysis',Fhnote,Mt2,T) CALL writln(' of the indirect seasonal adjustments.', & Fhnote,Mt2,F) CALL writln(' Change the starting date for all history a &nalysis to be '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' or later.',Fhnote,Mt2,F) Indrev=0 END IF END IF ELSE c----------------------------------------------------------------------- c If there are not enough observations, then check if history c analysis for forecasts and/or aic is being done. c----------------------------------------------------------------------- IF(Revmdl)THEN c----------------------------------------------------------------------- c If so, turn off history analysis for seasonal adjustment estimates c and print a warning message. c----------------------------------------------------------------------- IF(Lrvsa)THEN Lrvsa=F IF(Indrev.gt.0)Indrev=0 END IF IF(Lrvch)Lrvch=F IF(Lrvtrn)Lrvtrn=F IF(Lrvtch)Lrvtch=F IF(Lrvsf)Lrvsf=F Revsa=F CALL writln('NOTE: There must be at least '//str(1:nchr-1)// & 'years between the start of',Fhnote,Mt2,T) CALL writln(' the data span and the start of the history &analysis when seasonal',Fhnote,Mt2,F) CALL writln(' adjustment is performed.', & Fhnote,Mt2,F) CALL writln(' History analysis of seasonal adjustments, t &rends, and their',Fhnote,Mt2,T) CALL writln(' related changes are not performed.', & Fhnote,Mt2,F) ELSE c----------------------------------------------------------------------- c If not, print an error message and stop program execution c----------------------------------------------------------------------- CALL writln('ERROR: There must be at least '//str(1:nchr-1)// & ' years between the start of',STDERR,Mt2,T) CALL writln(' the data span and the start of the history & analysis when seasonal',STDERR,Mt2,F) CALL writln(' adjustment is performed.', & STDERR,Mt2,F) If(Indrev.gt.0)Indrev=0 CALL abend RETURN END IF END IF END IF END IF c----------------------------------------------------------------------- c Check to see if there will be enough data between the start of c the span used for the irregular regression and the start of the c revisons history loop. c----------------------------------------------------------------------- IF(Ixreg.gt.0)THEN CALL dfdate(Rvstrt,Begxrg,Ny,ndmdl) ndmdl=ndmdl+1 IF(ndmdl.lt.MINSPN)THEN c----------------------------------------------------------------------- c determine if there are more than MINSPN observations between the c start and end of the data span. c----------------------------------------------------------------------- CALL addate(Begxrg,Ny,MINSPN,idate) CALL dfdate(Endspn,idate,Ny,ndmdl) c----------------------------------------------------------------------- c IF there are, use this date as the start of the revisions history c analysis. c----------------------------------------------------------------------- IF(ndmdl.gt.0)THEN nchr=1 CALL cpyint(idate,2,1,Rvstrt) c----------------------------------------------------------------------- c If the user specified the starting date for the revisions c history, print out a message docmenting the change in the c revisions history starting date. c----------------------------------------------------------------------- IF(usstrt)THEN CALL wrtdat(Rvstrt,Ny,datstr,nchdat) IF(.not.Lfatal)CALL itoc(MINSPN,str,nchr) IF(Lfatal)RETURN CALL writln('WARNING: The start of the history analysis has be &en changed to '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' to allow '//str(1:nchr-1)// & ' observations between the start of the ', & Fhnote,Mt2,F) CALL writln(' irregular regression and the start of th &e history analysis.',Fhnote,Mt2,F) usstrt=F IF(Indrev.gt.0)THEN CALL writln(' Due to this change, the program will no &t generate a history analysis',Fhnote,Mt2,T) CALL writln(' of the indirect seasonal adjustments.', & Fhnote,Mt2,F) CALL writln(' Change the starting date for all histor &y analysis to be '//datstr(1:nchdat),Fhnote,Mt2,T) CALL writln(' or later.',Fhnote,Mt2,F) Indrev=0 END IF END IF ELSE c----------------------------------------------------------------------- c If the proposed starting date for the revisions history is not c within the span of data, update the starting date of the irregular c regression to be the beginning of the data span. c----------------------------------------------------------------------- CALL cpyint(Begspn,2,1,Begxrg) IF(Revfxx)THEN CALL writln( & 'NOTE: Span for irregular regression will be reset.', & Fhnote,Mt2,T) ELSE c----------------------------------------------------------------------- c If irregular regression coefficients were to be estimated, have c irregular regression coefficients fixed. c----------------------------------------------------------------------- Revfxx=T CALL writln('NOTE: Span for irregular regression will be reset & and the irregular regression',Fhnote,Mt2,T) CALL writln(' coefficients will be held fixed during the &history analysis.',Fhnote,Mt2,F) END IF END IF END IF c----------------------------------------------------------------------- IF(Fxprxr.gt.0.and.Revfxx)THEN Fxprxr=0 CALL writln('NOTE: Irregular component regression parameters wil &l not be re-estimated',Fhnote,Mt2,T) CALL writln(' once a year during the revisions history anal &ysis.',Fhnote,Mt2,F) END IF END IF c----------------------------------------------------------------------- c Check to see if there is enough data for revisions analysis c----------------------------------------------------------------------- CALL dfdate(Rvend,Rvstrt,Ny,nyrev) IF(nyrev.lt.0)THEN IF(usstrt)THEN nchr=1 CALL wrtdat(Rvstrt,Ny,datstr,nchr) IF(Lfatal)RETURN CALL writln('NOTE: Not enough data to perform history analysis s &tarting in '//datstr(1:nchr)//'.',Fhnote,Mt2,T) ELSE CALL writln('NOTE: Not enough data to perform history analysis u &sing default starting',Fhnote,Mt2,T) CALL writln(' date; use start argument in history spec to o &verride default.',Fhnote,Mt2,F) END IF CALL writln(' See '//SPCSEC//' of the '//PRGNAM//' '// & DOCNAM//'.',Fhnote,Mt2,F) Irev=0 IF(Irevsa.gt.0)Irevsa=-1 IF(Indrev.gt.0)Indrev=0 RETURN END IF c----------------------------------------------------------------------- c Check to see if all forecast lags are valid. c----------------------------------------------------------------------- IF(Nfctlg.gt.0.and.Lrvfct)THEN DO i=Nfctlg,1,-1 IF(nyrev.lt.Rfctlg(i))THEN IF(usstrt)THEN CALL wrtdat(Rvstrt,Ny,datstr,nchr) IF(Lfatal)RETURN IF(.not.Lquiet)WRITE(STDERR,1030)Rfctlg(i),datstr(1:nchr), & SPCSEC,PRGNAM,DOCNAM WRITE(Mt2,1030)Rfctlg(i),datstr(1:nchr),SPCSEC,PRGNAM,DOCNAM ELSE IF(.not.Lquiet)WRITE(STDERR,1040)Rfctlg(i),SPCSEC,PRGNAM, & DOCNAM WRITE(Mt2,1040)Rfctlg(i),SPCSEC,PRGNAM,DOCNAM END IF Rfctlg(i)=0 Nfctlg=Nfctlg-1 END IF END DO IF(Nfctlg.eq.0)THEN Irev=0 RETURN END IF END IF CALL setrvp(Begspn,Ny,Lfda,Llda,Lmodel) c----------------------------------------------------------------------- c If revision targets specified for seasonally adjusted series, c sort them and see if one and two year revision targets are c specified. c----------------------------------------------------------------------- IF(Ntarsa.gt.0)THEN CALL intsrt(Ntarsa,Targsa) i2=0 DO i=Ntarsa,1,-1 IF(nyrev.le.Targsa(i))THEN IF(usstrt)THEN CALL wrtdat(Rvstrt,Ny,datstr,nchr) IF(Lfatal)RETURN IF(.not.Lquiet) & WRITE(STDERR,1050)'seasonal adjustments',Targsa(i), & datstr(1:nchr),SPCSEC,PRGNAM,DOCNAM WRITE(Mt2,1050)'seasonal adjustments',Targsa(i), & datstr(1:nchr),SPCSEC,PRGNAM,DOCNAM ELSE IF(.not.Lquiet) & WRITE(STDERR,1060)'seasonal adjustments',Targsa(i),SPCSEC, & PRGNAM,DOCNAM WRITE(Mt2,1060)'seasonal adjustments',Targsa(i),SPCSEC,PRGNAM, & DOCNAM END IF Targsa(i)=0 Ntarsa=Ntarsa-1 ELSE IF(Targsa(i).eq.Ny.or.Targsa(i).eq.2*Ny)i2=i2+1 END IF END DO Lr1y2y=i2.eq.2 END IF c----------------------------------------------------------------------- c If revision targets specified for trend component, sort them. c----------------------------------------------------------------------- IF(Ntartr.gt.0)THEN CALL intsrt(Ntartr,Targtr) i2=0 DO i=Ntartr,1,-1 IF(nyrev.le.Targtr(i))THEN IF(usstrt)THEN CALL wrtdat(Rvstrt,Ny,datstr,nchr) IF(Lfatal)RETURN IF(.not.Lquiet) & WRITE(STDERR,1050)'trends',Targtr(i),datstr(1:nchr), & SPCSEC,PRGNAM,DOCNAM WRITE(Mt2,1050)'trends',Targtr(i),datstr(1:nchr),SPCSEC, & PRGNAM,DOCNAM ELSE IF(.not.Lquiet)WRITE(STDERR,1060)'trends',Targtr(i),SPCSEC, & PRGNAM,DOCNAM WRITE(Mt2,1060)'trends',Targtr(i),SPCSEC,PRGNAM,DOCNAM END IF Targtr(i)=0 Ntartr=Ntartr-1 ELSE IF(Targtr(i).eq.Ny.or.Targtr(i).eq.2*Ny)i2=i2+1 END IF END DO Lr1y2y=i2.eq.2 END IF c----------------------------------------------------------------------- 1010 FORMAT(' NOTE: The default starting date of the ',a,' history ', & 'analysis has been',/, & ' used since it is later than the default starting ', & 'date determined by',/, & ' the length of the maximum seasonal filter from ', & 'the seasonal adjustment.') 1020 FORMAT(' NOTE: The default starting date determined by the ', & 'length of the maximum',/, & ' seasonal filter from the seasonal adjustment was ', & 'used since it is',/, & ' later than the default starting date for the ',a, & ' history analysis.') 1030 FORMAT(/,' NOTE: Not enough data to perform forecast history ', & 'analysis for lag ',i2,/,' starting in ',a,'.', & /,' See ',a,' of the ',a,' ',a,'.') 1040 FORMAT(/,' NOTE: Not enough data to perform forecast history ', & 'analysis for lag ',i2,/, & ' from default starting date.',/, & /,' See ',a,' of the ',a,' ',a,'.') 1050 FORMAT(/,' NOTE: Not enough data to perform a history ', & 'analysis for ',a,/, & ' at lag ',i2,' starting in ',a,'.',/, & /,' See ',a,' of the ',a,' ',a,'.') 1060 FORMAT(/,' NOTE: Not enough data to perform a history ', & 'analysis for ',a,/, & ' at lag ',i2,' from default starting date.', & /,' See ',a,' of the ',a,' ',a,'.') 1070 FORMAT(/,' NOTE: Composite seasonal adjustment performed with ', & i3,' component(s), ', & /,' but the indirect concurrent seasonal ', & /,' adjustments collected for', & /,' the revisions history analysis were updated ', & 'for only ',i3,' component(s).',/, & /,' Revisions histories of the indirect ', & 'seasonal adjustments will not', & /,' be produced. Check for errors in the ', & 'revisions histories of the', & /,' components, and ensure that a history spec', & ' is present in the', & /,' spec files of all the components.') c----------------------------------------------------------------------- RETURN END rev.cmn0000664006604000003110000001243314521201554011466 0ustar sun00315stepsc----------------------------------------------------------------------- c Revptr - Pointer for revisions analyis (which observation is c now the concurrent) c Begrev - Position of the first observation of the revisions c history analysis c Endrev - Position of the last observation of the revisions history c analysis c Endtbl - Position of the last observation of the revisions history c analysis of seasonal adjustment estimates c Endsa - Position of the ending observation of the final seasonal c adjustment to be performed for the revisions history c analysis c Beglup - Position of the first observation of the revisions c history analysis loop c Rfctlg - Integer vector of forecast lags to be analyzed c Rvstrt - Starting date for revisions history analysis specifed c by the user c Lupbeg - Starting date for revisions history analysis loop c Rvend - Ending date for revisions history analysis of seasonal c adjustment estimates specifed by the user c Nfctlg - Number of forecast lags in Rfctlg c Fixper - Period every year for which the model will be estimated c in the revisions history. Every other period, the model c parameters will be fixed to what they were at the last c value of Fixper c Frstsa - pointer for first observation where a seasonal adjustment c will be performed c Otlrev - indicator variable determining how outliers are treated c in revisions history (0=keep,1=remove,2=auto identify) c Otlwin - specifies how many observations before the end of the c series will be tested for outliers in each adjustment c done by the revisions history analysis c Revnum - Number of observations in the revisions history c Rvfxrg - Integer array that determines which regressors are fixed c during the revisions history analysis (1-td,2-holiday, c 3-user defined regressors,4-outlier) c Nrvfxr - number of elements defined in Rvfxrg c Nrvarma- Number of ARMA coefficients saved c Nrvtd - Number of trading day coefficients saved c----------------------------------------------------------------------- INTEGER Revptr,Begrev,Endrev,Endsa,Endtbl,Rfctlg,Rvstrt,Revnum, & Rvend,Nfctlg,Fixper,Otlrev,Otlwin,Lupbeg,Beglup,Frstsa, & Rvfxrg,Nrvfxr,Nrcomp,Rvdiff,Fhsfh,Indrev,Indrvs,Nrvarma, & Nrvtd c----------------------------------------------------------------------- c Lrvsa - Logical variable which indicates if a revisions history c analysis is to be performed on the seasonally adjusted c series. c Lrvsf - Logical variable which indicates if a revisions history c analysis is to be performed on the seasonal factors, c both concurrent and projected c Lrvch - Logical variable which indicates if a revisions history c analysis is to be performed on the month-to-month changes c of the seasonally adjusted series c Lrvtrn - Logical variable which indicates if a revisions history c analysis is to be performed on the final trend c Lrvtch - Logical variable which indicates if a revisions history c analysis is to be performed on the month-to-month changes c of the final trend c Lrvfct - Logical variable which indicates if a revisions history c analysis is to be performed on the forecasts c Lrvaic - Logical variable which indicates if a revisions history c analysis is to be performed on the AIC statistic c Revfix - Logical variable which indicates if REGARIMA model c parameters will be fixed for this revisions history c analysis c Lrfrsh - Logical variable which indicates if REGARIMA model c parameters will be refreshed at the beginning of each c estimation during this revisions history analysis c Rvtran - Do not print out tables from transparent modeling and c seasonal adjustments generated during history analysis c (if true) c Cnctar - Concurrent adjustments are the target for target lags c (if true), else final adjustments are targets c----------------------------------------------------------------------- LOGICAL Lrvsa,Lrvsf,Lrvch,Lrvtrn,Lrvaic,Lrvfct,Lrvarma,Lrvtdrg, & Revfix,Revfxx,Lrfrsh,Lrvtch,Rvtran,Cnctar,Rvxotl,Rvtrfc c----------------------------------------------------------------------- DIMENSION Rfctlg(PFCLAG),Rvstrt(2),Rvend(2),Lupbeg(2),Rvfxrg(4), & Indrvs(2) c----------------------------------------------------------------------- COMMON /revcmn/ Begrev,Endrev,Endsa,Endtbl,Revptr,Rfctlg,Nfctlg, & Fixper,Rvstrt,Rvend,Lupbeg,Beglup,Frstsa,Otlrev, & Otlwin,Revnum,Rvfxrg,Nrvfxr,Nrcomp,Rvdiff,Fhsfh, & Indrev,Indrvs,Nrvarma,Nrvtd COMMON /revlog/ Lrvsa,Lrvsf,Lrvch,Lrvtrn,Lrvtch,Lrvaic,Lrvfct, & Lrvarma,Lrvtdrg,Lrfrsh,Revfix,Revfxx,Rvtran, & Cnctar,Rvxotl,Rvtrfc revdrv.f0000664006604000003110000014425214521201554011657 0ustar sun00315stepsC Last change: Jan. 2021, c change variable name cmdl to cmdls to avoid conflit with common block c name cmdl in model.cmn --Mar. 2021 C Last change: BCM 23 Mar 2005 3:38 pm SUBROUTINE revdrv(Ltmax,Lmodel,Lx11,X11agr,Lseats,Lcomp,Lgraf, & Iagr,Ncomp) IMPLICIT NONE C----------------------------------------------------------------------- c Driver routine for the revision analysis procedure. C----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'stdio.i' INCLUDE 'arima.cmn' INCLUDE 'inpt.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'units.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revtrg.cmn' INCLUDE 'revsrs.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'seatdg.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'xrgtbl.i' INCLUDE 'mdltbl.i' INCLUDE 'revtbl.i' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'dgnsvl.i' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'otlrev.cmn' INCLUDE 'otxrev.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11log.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'missng.cmn' INCLUDE 'cchars.i' INCLUDE 'x11opt.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'xeastr.cmn' c----------------------------------------------------------------------- LOGICAL T,F INTEGER LRVR1S,LRVR1A PARAMETER(T=.true.,F=.false.,LRVR1S=LREVR1+1,LRVR1A=LREVR1+2) c----------------------------------------------------------------------- CHARACTER outstr*(85),igrptl*(PGRPCR),datstr*(10),cmdls*(132), & usfxtl*(PCOLCR*PUREG*2),chARMA*(PGRPCR+5),cblnk*(25), & chash*(25),tfmt1*(5),tfmt2*(20),tfmt3*(20), & outARMA*(6+(23*PARIMA)),chRgGp*(PGRPCR),chTDrg*(PCOLCR), & outTDrg*(6+(16*(PGRPCR+PCOLCR))) LOGICAL Lmodel,Lx11,X11agr,locok,lchmsr,lhdr,lx11fn,addreg,erregm, & Lcomp,revmdl,lr1y2y,Lgraf,tdfix,holfix,usrfix,Lseats,lTop, & lsetfn,otlfix,revsa,ltmp,lastfx,upuser,bfx2,upusrx,lstxfx DOUBLE PRECISION revaic,rvlkhd,CncARMA,Cnctdrg INTEGER i,i2,j,k,fh,fh2,ipos,Ltmax,Iagr,smdmat,ncmdl,idtpos, & nefobs,vmsr,endall,idate,rdbdat,ndate,othndl,begcol,igrp, & nchr,lf1,begrgm,regmdt,nbeg,nend,mdl2,mdl2x,nendx,endcol, & icol,nusfx,nusftl,usfptr,Ncomp,fhnote,nchARMA,nRgGp, & rGrpNm,nTDrg,grptot,Nrvtdrg,jgrp,ipos2 * INTEGER itick1,itick2 DIMENSION smdmat(PREV,6),revaic(PREV),vmsr(PREV),rvlkhd(PREV), & endall(2),idate(2),regmdt(2),mdl2(2),mdl2x(2),bfx2(PB), & usfptr(0:PUREG),chARMA(PARIMA),nchARMA(PARIMA), & CncARMA(PARIMA,PREV),ChTDrg(PARIMA),NTDrg(16),NRgGp(5), & Cnctdrg(16,PREV),ChRgGp(5),rGrpNm(5) C----------------------------------------------------------------------- LOGICAL istrue,dpeq INTEGER nblank,strinx EXTERNAL istrue,nblank,strinx,dpeq C----------------------------------------------------------------------- c Check if revisions history is set up correctly c----------------------------------------------------------------------- fhnote=STDERR IF(Lquiet)fhnote=0 CALL revchk(Irev,Irevsa,Ixreg,Ny,Pos1ob,Posfob,Ltmax,Nspobs, & Begspn,Endspn,Begmdl,Lx11,Lseats,Lmodel,Lnoprt,Iagr, & Ncomp,Fctdrp,lr1y2y,revsa,revmdl,fhnote,Khol,Kfulsm) c----------------------------------------------------------------------- IF(Irev.eq.0.or.Lfatal)RETURN C----------------------------------------------------------------------- c Print out revisions history header c----------------------------------------------------------------------- IF(Prttab(LRVHDR).and.Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF CALL revhdr(Prttab(LRVHDR),lr1y2y,revsa,revmdl,Lmodel,Ny,Endspn, & Iagr) IF(Lfatal)RETURN c----------------------------------------------------------------------- addreg=F c----------------------------------------------------------------------- c If automatic modelling done, setup so the model selected for c the entire series will be used in each model estimation done by c the revisions history procedure. c----------------------------------------------------------------------- Lautox=F Lautom=F Lautod=F c----------------------------------------------------------------------- tdfix=F holfix=F usrfix=F otlfix=F IF(Nrvfxr.gt.0.and.((Nb.gt.0.and.Iregfx.lt.3).or.Nbx.gt.0))THEN DO i=1,Nrvfxr IF(Rvfxrg(i).eq.1)THEN tdfix=T ELSE IF(Rvfxrg(i).eq.2)THEN holfix=T ELSE IF(Rvfxrg(i).eq.3)THEN usrfix=T ELSE IF(Rvfxrg(i).eq.4)THEN otlfix=T END IF END DO END IF IF(Nb.gt.0)CALL rvfixd(tdfix,holfix,otlfix,usrfix,Iregfx,Regfx, & Nb,Rgvrtp,Nusrrg,Usrtyp,Ncusrx,Userfx) IF(Nbx.gt.0)CALL rvfixd(tdfix,holfix,otlfix,usrfix,Irgxfx,Regfxx, & Nbx,Rgxvtp,Nusxrg,Usxtyp,Nusxrg,Usrxfx) IF((Lrvsa.or.Lrvch).and.Kfulsm.eq.2)THEN IF((tdfix.and.(Adjtd.eq.1.or.Axrgtd)).or. & (holfix.and.(Adjhol.eq.1.or.Axrghl.or.Khol.gt.0)).or. & (Revfix.and.(Adjtd.eq.1.or.Adjhol.eq.1)))THEN IF(Lrvsa)THEN IF(Iagr.eq.0.or.Iagr.ge.5)THEN CALL writln('ERROR: Cannot calculate revision statistics for s &easonally adjusted data',STDERR,Mt2,T) CALL writln(' if a trend estimation run is specified in &the x11 spec and',STDERR,Mt2,F) CALL writln(' trading day and/or holiday factors are hel &d fixed.',STDERR,Mt2,F) Lrvsa=F ELSE IF(Prttab(LREVR1))Prttab(LREVR1)=F IF(Prttab(LRVR1S))Prttab(LRVR1S)=F IF(Prttab(LRVR1A))Prttab(LRVR1A)=F IF(Savtab(LREVR1))Savtab(LREVR1)=F END IF END IF IF(Lrvch)THEN CALL writln('ERROR: Cannot calculate revision statistics for ch &angs in the adjusted data',STDERR,Mt2,T) CALL writln(' if a trend estimation run is specified in &the x11 spec and',STDERR,Mt2,F) CALL writln(' trading day and/or holiday factors are hel &d fixed.',STDERR,Mt2,F) Lrvch=F END IF END IF IF(.not.(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvaic.or.Lrvfct.or.Lrvtrn & .or.Lrvtch))THEN CALL writln('WARNING: History analysis will not be performed for & this run because',fhnote,Mt2,T) CALL writln(' of error(s) indicated above.',fhnote,Mt2, & F) Irev=0 IF(Irev.gt.0)Irevsa=-1 RETURN END IF END IF c----------------------------------------------------------------------- c Remove level changes for series, regression matrix, if necessary c----------------------------------------------------------------------- lhdr=T c----------------------------------------------------------------------- IF(Lmodel)THEN addreg=T c----------------------------------------------------------------------- c Check to see if there are any change of regime regression c variables in the model. If there is, check to see if the c change of regime will be defined over the revision period. c----------------------------------------------------------------------- IF(Lrgmse.or.Lrgmtd.or.Lrgmln)THEN erregm=F locok=T DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF(Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRATTD.or. & Rgvrtp(begcol).eq.PRATSE.or.Rgvrtp(begcol).eq.PRATTS.or. & Rgvrtp(begcol).eq.PRATLM.or.Rgvrtp(begcol).eq.PRATLQ.or. & Rgvrtp(begcol).eq.PRATLY.or.Rgvrtp(begcol).eq.PRATSL.or. & Rgvrtp(begcol).eq.PRA1TD.or.Rgvrtp(begcol).eq.PRA1ST)THEN c----------------------------------------------------------------------- CALL getstr(Grpttl,Grpptr,Ngrp,igrp,igrptl,nchr) IF(Lfatal)RETURN idtpos=index(igrptl(1:nchr),'(starting ')+10 CALL ctodat(igrptl(1:nchr-1),Ny,idtpos,regmdt,locok) CALL dfdate(Lupbeg,regmdt,Ny,begrgm) IF(begrgm.le.Ny)THEN IF(.not.erregm)THEN CALL writln('NOTE: The following change of regime regression & variables are not',Mt1,Mt2,T) CALL writln(' defined for at least one year before the &startup period of the',Mt1,Mt2,F) CALL writln(' history analysis:',Mt1,Mt2,F) END IF erregm=T CALL writln(' '//igrptl(1:nchr),Mt1,Mt2,F) c----------------------------------------------------------------------- DO icol=begcol,endcol IF(.not.Regfx(icol))Regfx(icol)=T END DO c----------------------------------------------------------------------- END IF END IF END DO IF(erregm)THEN CALL writln(' The regressors listed above will be fixed to & their estimated',Mt1,Mt2,T) CALL writln(' values from the original series.', & Mt1,Mt2,F) Iregfx=2 END IF c----------------------------------------------------------------------- c If change-of-regime regression variables check out, be sure c model parameters are fixed. c----------------------------------------------------------------------- c IF(.not.Revfix)THEN c Revfix=T c CALL writln('NOTE: Since change of regime regression variables c &are used, model',STDERR,Mt2,T) c CALL writln(' parameters will be held fixed during the his c &tory analysis.',STDERR,Mt2,F) c END IF END IF c----------------------------------------------------------------------- c Check the user defined regression variables c----------------------------------------------------------------------- CALL dfdate(Begmdl,Begspn,Ny,nbeg) CALL dfdate(Endspn,Endmdl,Ny,nend) CALL cpyint(Endmdl,2,1,mdl2) c----------------------------------------------------------------------- c Fix model parameters, if requested. c----------------------------------------------------------------------- IF(Revfix)THEN CALL setlg(T,PARIMA,Arimaf) CALL setlg(T,PB,Regfx) Iregfx=3 IF(.not.Userfx)THEN Userfx=Ncusrx.gt.0 IF(Userfx)THEN CALL bakusr(Userx,Usrtyp,Usrptr,Ncusrx,Usrttl,Regfx,B, & Rgvrtp,Ngrp,Grpttl,Grp,Grpptr,Ngrptl,0,T) END IF END IF c ELSE IF(.not.Lrfrsh)THEN c IF(Nb.gt.0)THEN c DO i=1,Nb c IF(.not.Regfx(i))B(i)=DNOTST c END DO c END IF c DO i=1,PARIMA c IF((.not.Arimaf(i)).and.(.not.dpeq(Arimap,ZERO))) c & Arimap(i)=DNOTST c END DO END IF c----------------------------------------------------------------------- c Turn off automatic outlier identification. c----------------------------------------------------------------------- IF(Otlrev.lt.2)THEN IF(Ltstls)Ltstls=F IF(Ltstao)Ltstao=F IF(Ltsttc)Ltsttc=F * IF(Ltstso)Ltstso=F ELSE * IF((.not.Ltstls).and.(.not.Ltstao).and.(.not.Ltsttc).and. * & (.not.Ltstso))THEN IF((.not.Ltstls).and.(.not.Ltstao).and.(.not.Ltsttc))THEN Ltstls=T Ltstao=T END IF END IF c----------------------------------------------------------------------- c Outliers automatically identified in a previous run will be c removed from the regression model c----------------------------------------------------------------------- IF(Otlrev.gt.0)THEN CALL rmatot(Nrxy,Otlrev,Otlwin,Beglup,Begxy,othndl,otlfix, & Prttab(LREVOT),Savtab(LREVOT),lhdr) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Remove outliers from the regression variables if they occur c after the starting date of the revision history analysis. c----------------------------------------------------------------------- CALL intlst(PB,Otrptr,Notrtl) CALL rmotrv(Begxy,Beglup,Nrxy,Botr,Otrptr,Notrtl,Fixotr,Otrttl, & Otlrev.eq.0.or.Otlrev.eq.2,othndl,Prttab(LREVOT), & Savtab(LREVOT),lhdr) IF(Lfatal)RETURN IF(Notrtl.gt.0)CALL ssprep(Lmodel,F,F) END IF c----------------------------------------------------------------------- IF(Ixreg.gt.0)THEN CALL cpyint(Endxrg,2,1,mdl2x) IF(Revfxx)THEN CALL setlg(T,PB,Regfxx) IF(Irgxfx.lt.3)Irgxfx=3 IF(.not.Usrxfx)THEN Usrxfx=Nusxrg.gt.0 IF(Usrxfx)THEN CALL bakusr(Xuserx,Usxtyp,Usrxpt,Nusxrg,Usrxtt,Regfxx,Bx, & Rgxvtp,Nxgrp,Grpttx,Grpx,Gpxptr,Ngrptx,1,T) END IF END IF END IF c----------------------------------------------------------------------- c If reweighting is to be done, check to see if trading day c regressors are fixed. If so, reset Lxrneg c----------------------------------------------------------------------- igrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Trading Day') IF(Lxrneg.and.igrp.gt.0)THEN begcol=Grpx(igrp-1) endcol=Grpx(igrp)-1 Lxrneg=.not.istrue(Regfxx,begcol,endcol) END IF c----------------------------------------------------------------------- c Outliers automatically identified in a previous run will be c removed from the irregular regression model c----------------------------------------------------------------------- CALL loadxr(F) IF(Rvxotl)THEN CALL rmatot(Nrxy,1,Otlwin,Beglup,Begxy,0,otlfix,F,F,lhdr) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Remove outliers from the irregular regression variables if they c occur after the starting date of the revision history analysis. c----------------------------------------------------------------------- CALL intlst(PB,Otxptr,Notxtl) CALL rmotrv(Begxy,Beglup,Nrxy,Botx,Otxptr,Notxtl,Fixotx,Otxttl, & .not.Rvxotl,0,F,F,ltmp) IF(Lfatal)RETURN c----------------------------------------------------------------------- CALL loadxr(T) IF(Lmodel)CALL restor(Lmodel,F,F) END IF c----------------------------------------------------------------------- c Set up printing control variables. c----------------------------------------------------------------------- IF(Rvtran)Lhiddn=T DO i=1,NTBL c ------------------------------------------------------------------ c BCM - July 29, 2009 c Special code to save seasonal factor forecasts for concurrent c SEATS adjustments. c IF(i.lt.LRVHDR.or.i.GT.(LREVR8+2))THEN c ------------------------------------------------------------------ IF(i.lt.LRVHDR.or.i.GT.(LRVR9B))THEN IF(Rvtran)THEN Prttab(i)=F Savtab(i)=F ELSE IF(i.ne.LESTES.and.i.ne.LXRXRG.and.i.ne.(LXRXRG+1))Savtab(i)=F END IF END IF END DO DO i=1,NSVLOG IF(i.lt.LSLASA.or.i.gt.LSLALR)Svltab(i)=F END DO c----------------------------------------------------------------------- c Prepare for revisions looping by storing current values of the c modeling parameters. c----------------------------------------------------------------------- C CALL ssprep(Lmodel,Lx11,Ixreg.gt.0) CALL ssprep(Lmodel,F,F) c----------------------------------------------------------------------- c Start to loop through the last Ny*3 seasonal adjustment, c storing the concurrent seasonal factor and seasonally adjusted c series. c----------------------------------------------------------------------- Irev=4 locok=T lchmsr=F c----------------------------------------------------------------------- CALL intlst(PUREG,usfptr,nusftl) nusfx=nusftl+1 c----------------------------------------------------------------------- lx11fn=Lx11 lsetfn=Lseats Ierhdr=NOTSET c ------------------------------------------------------------------ c BCM - July 29, 2009 c Special code to save seasonal factor forecasts for concurrent c adjustments. c ------------------------------------------------------------------ IF(Savtab(LRVSSH))THEN CALL opnfil(T,F,LRVSSH,Fhsfh,locok) IF(.not.locok)THEN CALL abend RETURN END IF END IF c ------------------------------------------------------------------ DO i=Beglup,Endrev c----------------------------------------------------------------------- c Check to see if we have gotten to the end of the seasonal c adjustment revisions history. If so, ensure seasonal adjustment c is not performed until the final seasonal adjustment. c----------------------------------------------------------------------- IF(i.gt.Endsa)THEN IF(i.eq.Endrev.and.lx11fn)THEN Lx11=T ELSE IF(Lx11)THEN Lx11=F END IF IF(i.eq.Endrev.and.lsetfn)THEN Lseats=T ELSE IF(Lseats)THEN Lseats=F END IF END IF c----------------------------------------------------------------------- c IF i < Begrev, then either do a special seasonal adjustment for c projected factors, or fit model parameters for the first occurance c of the period Fixper. c----------------------------------------------------------------------- IF(i.ge.Begrev)THEN c----------------------------------------------------------------------- c if no seasonal adjustment and none of the model diagnostics are c being saved, then break out of revision loop. c----------------------------------------------------------------------- IF(i.eq.Begrev)THEN Lx11=lx11fn Lseats=lsetfn END IF IF(.not.(Lx11.or.Lseats).and..not.revmdl)GO TO 10 ELSE IF(i.eq.Beglup)THEN IF(Beglup.lt.Frstsa)THEN Lx11=F Lseats=F END IF ELSE IF(i.eq.Frstsa)THEN IF(Beglup.lt.Frstsa)THEN Lx11=lx11fn Lseats=lsetfn END IF ELSE GO TO 10 END IF c----------------------------------------------------------------------- c Initialize variables for seasonal adjustment loop. c----------------------------------------------------------------------- Posfob=i CALL x11int Posffc=i+Nfcst Length=Posfob-Pos1ob+1 Nspobs=Length Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nomnfy) Lstyr=Lyr+(Posfob/Ny) IF(mod(Posfob,Ny).eq.0)Lstyr=Lstyr-1 c----------------------------------------------------------------------- c Copy original series into STcsi and Series c----------------------------------------------------------------------- CALL copy(Orig(Pos1ob),Length,1,Stcsi(Pos1ob)) CALL copy(Orig(Pos1ob),Length,1,Series(Pos1ob)) c----------------------------------------------------------------------- c Set span Beginning and Ending Date for modeling routines c----------------------------------------------------------------------- CALL addate(Begspn,Ny,Posfob-Pos1ob,Endspn) CALL wrtdat(Endspn,Sp,Crvend,Nrvend) IF(Lfatal)RETURN IF(Lmodel)THEN IF(Fixper.gt.0)THEN CALL cpyint(Endspn,2,1,Endmdl) IF(Endmdl(MO).eq.Fixper)THEN addreg=T ELSE IF(Endmdl(MO).lt.Fixper)Endmdl(YR)=Endmdl(YR)-1 Endmdl(MO)=Fixper IF(addreg)addreg=F END IF ELSE CALL dfdate(Endspn,mdl2,Ny,nend) IF(nend.le.0)THEN CALL cpyint(Endspn,2,1,Endmdl) ELSE CALL cpyint(mdl2,2,1,Endmdl) END IF END IF END IF IF(Fxprxr.gt.0)THEN CALL cpyint(Endspn,2,1,Endxrg) IF(Endxrg(MO).ne.Fxprxr)THEN IF(Endxrg(MO).lt.Fxprxr)Endxrg(YR)=Endxrg(YR)-1 Endxrg(MO)=Fxprxr END IF ELSE nendx=0 IF(Ixreg.gt.0)CALL dfdate(Endspn,mdl2x,Ny,nendx) IF(nendx.le.0)THEN CALL cpyint(Endspn,2,1,Endxrg) ELSE CALL cpyint(mdl2x,2,1,Endxrg) END IF END IF c----------------------------------------------------------------------- c Reset start and end of outlier testing c----------------------------------------------------------------------- IF(Otlrev.ge.2)THEN CALL addate(Endspn,Ny,-Otlwin,Begtst) CALL cpyint(Endspn,2,1,Endtst) END IF c----------------------------------------------------------------------- c Reset pointer for concurrent revision. c----------------------------------------------------------------------- Revptr=i-Begrev+1 c----------------------------------------------------------------------- c Restore previous seasonal adjustment and modelling settings c----------------------------------------------------------------------- CALL restor(Lmodel,Lx11,Ixreg.gt.0) IF(Lmsr.eq.6)Lterm=Lmsr IF(Ixreg.eq.3)THEN Ixreg=1 IF(Lmodel.or.Fxprxr.gt.0.or.Khol.gt.0)Ixreg=2 END IF c IF(.not.Lrfrsh)Iregfx=1 c----------------------------------------------------------------------- c Set logical variable that generates X-11 holiday date indicator c variable c----------------------------------------------------------------------- IF(Lgenx)THEN Lgenx=F c----------------------------------------------------------------------- c Check to see if easter adjustment can be done in all spans, c if specified. c----------------------------------------------------------------------- IF(Keastr.eq.1)THEN lf1=(Pos1bk/12)*12+3 IF(lf1.lt.Pos1bk)lf1=lf1+12 CALL chkeas(lf1,Posfob) IF((Ieast(1)*Ieast(2)*Ieast(3)*Ieast(4)).eq.0)THEN CALL errhdr WRITE(Mt2,1010)' because there are:' WRITE(STDERR,1010)'.' 1010 FORMAT(/,'ERROR: X-11 Easter adjustment cannot be estimated ', & 'for the history', & /,' analysis specified in this run',a,/) Keastr=0 END IF IF(Ieast(1).eq.0)WRITE(Mt2,1020) 1020 FORMAT(8x,'No years of data with Easter before April 1st.') IF(Ieast(2).eq.0)WRITE(Mt2,1030) 1030 FORMAT(8x,'No years of data with Easter after April 16th.') IF(Ieast(3).eq.0)WRITE(Mt2,1040) 1040 FORMAT(8x,'No years of data with Easter between April 2nd ', & 'and April 8th.') IF(Ieast(4).eq.0)WRITE(Mt2,1050) 1050 FORMAT(8x,'No years of data with Easter between April 8th ', & 'and April 15th.') IF((Ieast(1)*Ieast(2)*Ieast(3)*Ieast(4)).eq.0)THEN WRITE(Mt2,1060) WRITE(STDERR,1060) 1060 FORMAT(/,8x,'Either choose a later starting date for the ', & 'history analysis', & /,8x,'or preadjust the series using Easter ', & 'effects estimated from a', & /,8x,'regARIMA model.') END IF END IF END IF c----------------------------------------------------------------------- c Check to see if X-11 holiday adjustment can still be done. c----------------------------------------------------------------------- IF(Khol.eq.2)Khol=Keastr c----------------------------------------------------------------------- c If outliers have been removed, check if they can be c reintroduced into the regression matrix. c----------------------------------------------------------------------- IF(addreg.and.i.gt.Begrev.and.Notrtl.gt.0)THEN CALL dfdate(Endspn,Endmdl,Ny,nend) CALL chkorv(Begxy,i-nend,Botr,Otrptr,Notrtl,Fixotr,Otrttl, & othndl,otlfix,Nrxy,Prttab(LREVOT),Savtab(LREVOT), & lhdr,T) IF(Lfatal)RETURN END IF IF(Ixreg.gt.0)THEN CALL loadxr(F) IF(i.gt.Begrev.and.Notxtl.gt.0.and.(.not.Rvxotl))THEN CALL dfdate(Endspn,Endxrg,Ny,nend) CALL chkorv(Begxy,i-nend,Botx,Otxptr,Notxtl,Fixotx,Otxttl,0, & otlfix,Nrxy,F,F,ltmp,F) IF(Lfatal)RETURN ELSE IF(Rvxotl)THEN CALL rmatot(Nrxy,1,Otlwin,Beglup,Begxy,0,otlfix,F,F,lhdr) IF(Lfatal)RETURN END IF CALL loadxr(T) IF(Lmodel)CALL restor(Lmodel,F,F) END IF c----------------------------------------------------------------------- c Reset missing value code. c----------------------------------------------------------------------- IF(Missng)Missng=F c----------------------------------------------------------------------- c Check user-defined regressors to see that they are well-defined c for the span of data c----------------------------------------------------------------------- upuser=F upusrx=F lastfx=Userfx lstxfx=Usrxfx IF(Nusxrg.gt.0)THEN CALL copylg(Regfxx,Nbx,1,bfx2) CALL chusrg(upusrx,usfxtl,nusfx,nusftl,usfptr) IF(Lfatal)RETURN IF(upusrx)THEN IF(.not.Usrxfx)Usrxfx=T CALL bakusr(Xuserx,Usxtyp,Usrxpt,Nusxrg,Usrxtt,Regfxx,Bx, & Rgxvtp,Nxgrp,Grpttx,Grpx,Gpxptr,Ngrptx,1, & .not.lstxfx) END IF END IF IF(Ncusrx.gt.0)THEN CALL copylg(Regfx,Nb,1,bfx2) CALL chusrg(upuser,usfxtl,nusfx,nusftl,usfptr) IF(Lfatal)RETURN IF(upuser)THEN IF(.not.Userfx)Userfx=T CALL bakusr(Userx,Usrtyp,Usrptr,Ncusrx,Usrttl,Regfx,B,Rgvrtp, & Ngrp,Grpttl,Grp,Grpptr,Ngrptl,0,.not.lastfx) CALL ssprep(T,F,F) END IF END IF c----------------------------------------------------------------------- c Perform seasonal adjustment. c----------------------------------------------------------------------- CALL x11ari(Lmodel,Lx11,X11agr,Lseats,Lcomp,Issap,Irev,Irevsa, & Ixreg,0,F,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(Irev.lt.0)THEN Irev=0 IF(Irevsa.gt.0)Irevsa=-1 RETURN END IF C----------------------------------------------------------------------- c If there was an error in the ARIMA model estimation, print out c the error message here. C----------------------------------------------------------------------- IF(Armaer.lt.0.or.Armaer.gt.1)THEN nefobs=Nspobs-Nintvl CALL prterr(nefobs,F) IF(Armaer.eq.PMXIER.or.Lfatal)THEN IF(.not.Lfatal)call abend RETURN END IF Armaer=0 END IF C----------------------------------------------------------------------- c Store AICC and likelihood values C----------------------------------------------------------------------- IF(Revptr.gt.0)THEN IF(Lrvaic)THEN revaic(Revptr)=Aicc rvlkhd(Revptr)=Olkhd END IF C----------------------------------------------------------------------- c Store ARMA Model Parameters C----------------------------------------------------------------------- IF(Lrvarma)THEN CALL rvarma(Revptr,chARMA,nchARMA,Nrvarma,CncARMA) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- c Store regARMA trading day Parameters C----------------------------------------------------------------------- IF(Lrvtdrg)THEN CALL rvtdrg(Revptr,chRgGp,nRgGp,rGrpNm,grptot,chTDrg,nTDrg, & Nrvtdrg,Cnctdrg) IF(Lfatal)RETURN IF(grptot.eq.0)Lrvtdrg=.false. END IF C----------------------------------------------------------------------- c Store Seats Model C----------------------------------------------------------------------- IF(Lseats)THEN smdmat(Revptr,1)=Iprsm smdmat(Revptr,2)=Idrsm smdmat(Revptr,3)=Iqrsm IF(Ipssm.eq.NOTSET)THEN smdmat(Revptr,4)=Ipssm ELSE smdmat(Revptr,4)=Ipssm/Ny END IF smdmat(Revptr,5)=Idssm IF(Iqssm.eq.NOTSET)THEN smdmat(Revptr,6)=Iqssm ELSE smdmat(Revptr,6)=Iqssm/Ny END IF END IF C----------------------------------------------------------------------- c Store choice of seasonal filter if MSR seasonal chosen. Test if c choice of seasonal filter has changed. C----------------------------------------------------------------------- IF(Lmsr.eq.5.and.Revptr.gt.0)THEN vmsr(Revptr)=Lterm IF(.not.lchmsr.and.(vmsr(1).ne.vmsr(Revptr)))lchmsr=T END IF END IF C----------------------------------------------------------------------- c Delete automatically identified outliers if any are found. C----------------------------------------------------------------------- IF(Otlrev.ge.2)THEN CALL rmatot(Nrxy,Otlrev,Otlwin,i,Begxy,othndl,otlfix, & Prttab(LREVOT),Savtab(LREVOT),lhdr) IF(Lfatal)RETURN C----------------------------------------------------------------------- c Create revision files for Andrew Bruce... C----------------------------------------------------------------------- c CALL copy(Stci(Pos1ob),Nobspf,1,temp) c WRITE(rsahnd,*) (temp(j),j=1,nrvopf) c CALL copy(Facao(Pos1ob),Nobspf,1,temp) c WRITE(raohnd,*) (temp(j),j=1,nrvopf) c CALL copy(Facls(Pos1ob),Nobspf,1,temp) c WRITE(rlshnd,*) (temp(j),j=1,nrvopf) C----------------------------------------------------------------------- END IF C----------------------------------------------------------------------- c Refresh stored model parameters C----------------------------------------------------------------------- IF(Lmodel)THEN IF(upuser)THEN CALL copylg(bfx2,Nb,1,Regfx) Userfx=lastfx CALL ssprep(T,F,F) END IF IF(Lrfrsh)CALL restor(Lmodel,F,F) END IF IF(upusrx)THEN CALL copylg(bfx2,Nb,1,Regfxx) Usrxfx=lstxfx END IF 10 CONTINUE END DO c ------------------------------------------------------------------ c BCM - September 9, 2009 c Special code to save seasonal factor forecasts for concurrent c adjustments. c ------------------------------------------------------------------ IF(Savtab(LRVSSH))CALL fclose(Fhsfh) C----------------------------------------------------------------------- Irev=5 IF(Ierhdr.ne.NOTSET)CALL errhdr c----------------------------------------------------------------------- IF(lhdr.and.Prttab(LREVOT))WRITE(Mt1,1070)'outliers' 1070 FORMAT(/,' No ',a,' kept or deleted during this history ', & 'analysis.') C----------------------------------------------------------------------- IF(nusftl.gt.0)THEN CALL writln('NOTE: The user defined regressors listed below were &held fixed',Mt1,Mt2,T) CALL writln(' for at least one span during the history analy &sis:',Mt1,Mt2,F) DO igrp=1,nusftl CALL getstr(usfxtl,usfptr,nusfx,igrp,outstr,ipos) IF(Lfatal)RETURN CALL writln(' '//outstr(1:ipos),Mt1,Mt2,F) END DO END IF c----------------------------------------------------------------------- c close outlier files. C----------------------------------------------------------------------- c IF(Otlrev.ge.2)THEN c CALL fclose(othndl) c CALL fclose(rsahnd) c CALL fclose(raohnd) c CALL fclose(rlshnd) c WRITE(STDOUT,*)' P x N Revisions matrices have been stored in:' c WRITE(STDOUT,*)' ',Cursrs(1:nsrs)//'.rsa, ', c & Cursrs(1:nsrs)//'.rao, ',Cursrs(1:nsrs)//'.rls' c WRITE(STDOUT,*)' P=# of revisions=',nrvsrs c WRITE(STDOUT,*)' N=# of observations in fcst extended series=', c & nrvopf c END IF c----------------------------------------------------------------------- c Compute the starting and ending date of revisions c----------------------------------------------------------------------- CALL addate(Rvstrt,Ny,Revnum-1,endall) IF(Lsumm.gt.0)CALL svrvhd(endall,Ny,Irevsa) c----------------------------------------------------------------------- c If seasonal filter selection from the moving seasonality ratio c has changed over the revision span, print a warning message. c----------------------------------------------------------------------- IF(lchmsr)THEN IF(.not.Lnoprt)WRITE(Mt1,1080) WRITE(Mt2,1080) 1080 FORMAT(/,' NOTE: The seasonal filter used to generate the ', & 'seasonal component has ', & /,' changed during the revision period. This ', & 'could increase the size', & /,' of revisions.') IF(.not.Prttab(LREVR0))Prttab(LREVR0)=T END IF c----------------------------------------------------------------------- IF(Lmsr.eq.5)THEN CALL prtmsr(vmsr,Rvstrt,Ny,LREVR0) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- Lhiddn=F Kpart=7 c----------------------------------------------------------------------- c Print and/or save the revisions of the seasonally adjusted series. c----------------------------------------------------------------------- IF(.not.Lfatal.and.Lrvsa) & CALL prtrev(Finsa,Cncsa,Rvstrt,1,LREVR1,Ntarsa,Targsa,Lsumm, & Lgraf,lr1y2y) c----------------------------------------------------------------------- c Print and/or save the changes in the seasonally adjusted series c revisions. c----------------------------------------------------------------------- IF(.not.Lfatal.and.Lrvch) & CALL prtrev(Finch,Cncch,Rvstrt,2,LREVR2,Ntarsa,Targsa,Lsumm, & Lgraf,lr1y2y) c----------------------------------------------------------------------- c Print and/or save the revisions of the indirect seasonally c adjusted series. c----------------------------------------------------------------------- IF(.not.Lfatal.and.(Iagr.ge.5.and.Lrvsa))THEN IF(Nrcomp.eq.Ncomp.and.Indrev.gt.0)THEN IF(Lsumm.gt.0)WRITE(Nform,1130)'yes' CALL prtrev(Finisa,Cncisa,Rvstrt,3,LREVR3,Ntarsa,Targsa,Lsumm, & Lgraf,lr1y2y) ELSE IF(Lsumm.gt.0)WRITE(Nform,1130)'no' END IF END IF c----------------------------------------------------------------------- c Print and/or save the trend revisions. c----------------------------------------------------------------------- IF(.not.Lfatal.and.Lrvtrn) & CALL prtrev(Fintrn,Cnctrn,Rvstrt,4,LREVR4,Ntartr,Targtr,Lsumm, & Lgraf,F) c----------------------------------------------------------------------- c Print and/or save the revisions in the month-to-month (or quarter- c to-quarter) changes in the trend. c----------------------------------------------------------------------- IF(.not.Lfatal.and.Lrvtch) & CALL prtrev(Fintch,Cnctch,Rvstrt,5,LREVR5,Ntartr,Targtr,Lsumm, & Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print and/or save the seasonal factor revisions. c----------------------------------------------------------------------- IF(.not.Lfatal.and.Lrvsf) & CALL prtrv2(Finsf,Cncsf,Cncsfp,Rvstrt,LREVR6,Lsumm,Lgraf) c----------------------------------------------------------------------- c Reset ending date if AICC or forecast revisions are printed out. c----------------------------------------------------------------------- IF(Lrvaic.or.Lrvfct)CALL addate(endall,Ny,1,endall) c----------------------------------------------------------------------- c Print Likelihood statistics c----------------------------------------------------------------------- IF(Lrvaic)THEN j=0 IF(Savtab(LREVR7).or.Lgraf)THEN IF(Savtab(LREVR7))CALL opnfil(T,F,LREVR7,fh,locok) IF(locok.and.Lgraf)CALL opnfil(T,Lgraf,LREVR7,fh2,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for AICC revisions c----------------------------------------------------------------------- IF(Savtab(LREVR7))THEN WRITE(fh,1120)'date',TABCHR,'Log_Likelihood',TABCHR,'AICC' WRITE(fh,1120)'------',TABCHR,'-----------------------', & TABCHR,'-----------------------' END IF IF(Lgraf)THEN WRITE(fh2,1120)'date',TABCHR,'Log_Likelihood',TABCHR,'AICC' WRITE(fh2,1120)'------',TABCHR,'-----------------------', & TABCHR,'-----------------------' END IF END IF DO i=Begrev,Endrev Revptr=i-Begrev+1 j=j+1 c----------------------------------------------------------------------- c Print header for likelihood statistics c----------------------------------------------------------------------- IF(mod(j,48).eq.1.and.Prttab(LREVR7))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1090)Rvstrt(MO),Rvstrt(YR),endall(MO),endall(YR) 1090 FORMAT(' R 7. Likelihood statistics from estimating ', & 'regARIMA model over spans with',/, & ' ending dates ',i2,':',i4,' to ',i2,':',i4,//) WRITE(Mt1,1100) 1100 FORMAT(3x,'Span End',9x,'Log Likelihood',15x,'AICC',/, & 3x,'--------',9x,'--------------',15x,'----') END IF c----------------------------------------------------------------------- c Print out AICC and Likelihood value c----------------------------------------------------------------------- CALL addate(Rvstrt,Ny,j-1,idate) CALL wrtdat(idate,Ny,datstr,ndate) IF(Lfatal)RETURN IF(Prttab(LREVR7))WRITE(Mt1,1110)datstr(1:ndate),rvlkhd(Revptr), & revaic(Revptr) 1110 FORMAT(3x,a,5x,2(3x,f15.3)) IF(Savtab(LREVR7).or.Lgraf)THEN c----------------------------------------------------------------------- c Set date of revision for observation Revptr c----------------------------------------------------------------------- rdbdat=100*idate(YR)+idate(MO) c----------------------------------------------------------------------- c Save AICC revisions with date c----------------------------------------------------------------------- ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(rvlkhd(Revptr),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(revaic(Revptr),outstr,ipos) IF(Lfatal)RETURN IF(Savtab(LREVR7))WRITE(fh,1120)outstr(1:ipos-1) IF(Lgraf)WRITE(fh2,1120)outstr(1:ipos-1) END IF END DO IF(Savtab(LREVR7))CALL fclose(fh) IF(Lgraf)CALL fclose(fh2) END IF c----------------------------------------------------------------------- c Print forecast errors c----------------------------------------------------------------------- IF(Lrvfct)THEN * CALL gnfcrv(fcter,fctss,Orig) * CALL prfcrv(fcter,fctss,endall,Ny,LREVR8,LSLAFE,Lgraf,Lsumm) CALL prfcrv(Orig,endall,Ny,Lam,Fcntyp,LREVR8,LSLAFE,Lgraf,Lsumm) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print SEATS models c----------------------------------------------------------------------- IF(Lseats.and.(Prttab(LREVR9).or.Savtab(LREVR9)))THEN j=0 IF(Savtab(LREVR9))THEN CALL opnfil(T,F,LREVR9,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF WRITE(fh,1120)'date',TABCHR,'SEATS_Model' WRITE(fh,1120)'------',TABCHR,'-----------------------' END IF DO i=Begrev,Endrev Revptr=i-Begrev+1 j=j+1 c----------------------------------------------------------------------- c Print header for SEATS model c----------------------------------------------------------------------- IF(mod(j,48).eq.1.and.Prttab(LREVR9))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,2090)Rvstrt(MO),Rvstrt(YR),endall(MO),endall(YR) 2090 FORMAT(' R 9. SEATS ARIMA model used for spans with',/, & ' ending dates ',i2,':',i4,' to ',i2,':',i4,//) WRITE(Mt1,2100) 2100 FORMAT(3x,'Span End',9x,'ARIMA Model',/, & 3x,'--------',9x,'-----------') END IF c----------------------------------------------------------------------- c Print out SEATS model c----------------------------------------------------------------------- CALL addate(Rvstrt,Ny,j-1,idate) CALL wrtdat(idate,Ny,datstr,ndate) IF(Lfatal)RETURN IF(smdmat(Revptr,1).eq.NOTSET)THEN IF(Prttab(LREVR9))WRITE(Mt1,2110)datstr(1:ndate),'no model' IF(Savtab(LREVR9))WRITE(fh,1120)datstr(1:ndate),TABCHR,'none' ELSE CALL mkmdsn(smdmat(Revptr,1),smdmat(Revptr,2),smdmat(Revptr,3), & smdmat(Revptr,4),smdmat(Revptr,5),smdmat(Revptr,6), & cmdls,ncmdl) IF(Lfatal)RETURN IF(Prttab(LREVR9))WRITE(Mt1,2110)datstr(1:ndate),cmdls(1:ncmdl) IF(Savtab(LREVR9))WRITE(fh,1120)datstr(1:ndate),TABCHR, & cmdls(1:ncmdl) END IF 2110 FORMAT(3x,a,5x,a) END DO IF(Savtab(LREVR9))CALL fclose(fh) END IF c----------------------------------------------------------------------- c Print history of ARIMA coefficients c----------------------------------------------------------------------- IF(Lrvarma)THEN IF(.not.(Prttab(LRVR9A).or.Savtab(LRVR9A)))RETURN j=0 IF(Savtab(LRVR9A))THEN CALL opnfil(T,F,LRVR9A,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF write(tfmt1,1140)2*Nrvarma+1 1140 FORMAT('(',i2,'a)') WRITE(fh,tfmt1)'date', & (TABCHR,chARMA(i)(1:nchARMA(i)),i=1,Nrvarma) WRITE(fh,tfmt1)'------', & (TABCHR,'-----------------------',i=1,Nrvarma) END IF write(tfmt2,1150)Nrvarma 1150 FORMAT('(2x,A,',i2,'(3x,a25))') write(tfmt3,1160)Nrvarma 1160 FORMAT('(2x,A,',i2,'(10x,f18.6))') * write(*,*)'*',tfmt2,'* *',tfmt3,'*' CALL setchr('-',25,chash) CALL setchr(' ',25,cblnk) DO i=Begrev,Endrev Revptr=i-Begrev+1 j=j+1 c----------------------------------------------------------------------- c Print header for SEATS model c----------------------------------------------------------------------- IF(mod(j,48).eq.1.and.Prttab(LRVR9A))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,3090)Rvstrt(MO),Rvstrt(YR),endall(MO),endall(YR) 3090 FORMAT(' R 9.A ARIMA model coefficients used for spans with',/, & ' ending dates ',i2,':',i4,' to ',i2,':',i4,//) WRITE(Mt1,tfmt2)'Span End',(cblnk(1:(25-nchARMA(i2)))// & chARMA(i2)(1:nchARMA(i2)),i2=1,Nrvarma) WRITE(Mt1,tfmt2)'--------',(chash,i2=1,Nrvarma) END IF c----------------------------------------------------------------------- c Print out SEATS model c----------------------------------------------------------------------- CALL addate(Rvstrt,Ny,j-1,idate) CALL wrtdat(idate,Ny,datstr,ndate) IF(Lfatal)RETURN IF(Prttab(LRVR9A)) & WRITE(Mt1,tfmt3)datstr(1:ndate), & (CncARMA(k,Revptr),k=1,Nrvarma) c----------------------------------------------------------------------- c Save ARIMA model coefficients c----------------------------------------------------------------------- IF(Savtab(LRVR9A))THEN rdbdat=100*idate(YR)+idate(MO) ipos=1 CALL itoc(rdbdat,outARMA,ipos) IF(Lfatal)RETURN DO k=1,Nrvarma outARMA(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(CncARMA(k,Revptr),outARMA,ipos) IF(Lfatal)RETURN END DO WRITE(fh,1120)outARMA(1:ipos-1) END IF END DO IF(Savtab(LRVR9A))CALL fclose(fh) END IF c----------------------------------------------------------------------- c Print history of regARIMA TD coefficients c----------------------------------------------------------------------- IF(Lrvtdrg)THEN IF(.not.(Prttab(LRVR9B).or.Savtab(LRVR9B)))RETURN IF(Savtab(LRVR9B))THEN CALL opnfil(T,F,LRVR9B,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF outTDrg(1:8)='Span End' icol=0 ipos=9 DO igrp=1,grptot DO jgrp=1,RGrpNm(igrp) icol=icol+1 outTDrg(ipos:ipos)=TABCHR ipos=ipos+1 ipos2=ipos+(NRgGp(igrp)+NTDrg(icol)) outTDrg(ipos:ipos2)=ChRgGp(igrp)(1:NRgGp(igrp))//'.'// & ChTDrg(icol)(1:NTDrg(icol)) ipos=ipos2+1 END DO END DO WRITE(fh,1120)outTDrg(1:ipos-1) write(tfmt1,1141)2*Nrvtdrg+1 1141 FORMAT('(',i2,'a)') WRITE(fh,tfmt1)'------', & (TABCHR,'-----------------------',i=1,Nrvtdrg) END IF * write(*,*)'*',tfmt2,'* *',tfmt3,'*' CALL setchr('-',25,chash) CALL setchr(' ',25,cblnk) IF(Prttab(LRVR9B))THEN icol=0 DO igrp=1,grptot IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,3091)Rvstrt(MO),Rvstrt(YR),endall(MO),endall(YR) 3091 FORMAT(' R 9.B regARIMA trading day coefficients used for ', & 'spans with',/, & ' ending dates ',i2,':',i4,' to ',i2,':',i4,/) WRITE(Mt1,3092)igrp,ChRgGp(igrp)(1:NRgGp(igrp)) 3092 FORMAT(/,5x,'Group ',i2,' : ',a,/) write(tfmt2,1151)RGrpNm(igrp) 1151 FORMAT('(2x,A,',i2,'(3x,a17))') write(tfmt3,1161)RGrpNm(igrp) 1161 FORMAT('(2x,A,',i2,'( 5x,f15.6))') WRITE(Mt1,tfmt2)'Span End',(cblnk(1:(17-NTDrg(i2)))// & ChTDrg(i2)(1:NTDrg(i2)),i2=icol+1,icol+RGrpNm(igrp)) WRITE(Mt1,tfmt2)'--------',(chash(1:17),i2=1,NrvTDrg) j=0 DO i=Begrev,Endrev Revptr=i-Begrev+1 j=j+1 c----------------------------------------------------------------------- c Print header for regARIMA trading day coefficients c----------------------------------------------------------------------- IF(mod(j,45).eq.1.and.j.gt.1)THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,3091)Rvstrt(MO),Rvstrt(YR),endall(MO),endall(YR) WRITE(Mt1,3092)igrp,ChRgGp(igrp)(1:NRgGp(igrp)) write(tfmt2,1151)RGrpNm(igrp) write(tfmt3,1161)RGrpNm(igrp) WRITE(Mt1,tfmt2)'Span End',(cblnk(1:(17-NTDrg(i2)))// & ChTDrg(i2)(1:NTDrg(i2)),i2=icol+1,icol+RGrpNm(igrp)) WRITE(Mt1,tfmt2)'--------',(chash(1:17),i2=1,NrvTDrg) END IF c----------------------------------------------------------------------- c Print out regARIMA trading day coefficients c----------------------------------------------------------------------- CALL addate(Rvstrt,Ny,j-1,idate) CALL wrtdat(idate,Ny,datstr,ndate) IF(Lfatal)RETURN WRITE(Mt1,tfmt3)datstr(1:ndate), & (CncTDrg(k,Revptr),k=icol+1,icol+RGrpNm(igrp)) END DO icol=icol+RGrpNm(igrp) END DO END IF c----------------------------------------------------------------------- c Save regARIMA trading day coefficients c----------------------------------------------------------------------- IF(Savtab(LRVR9B))THEN j=0 DO i=Begrev,Endrev Revptr=i-Begrev+1 j=j+1 CALL addate(Rvstrt,Ny,j-1,idate) rdbdat=100*idate(YR)+idate(MO) ipos=1 CALL itoc(rdbdat,outARMA,ipos) IF(Lfatal)RETURN DO k=1,NrvTDrg outTDrg(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(CncTDrg(k,Revptr),outARMA,ipos) IF(Lfatal)RETURN END DO WRITE(fh,1120)outARMA(1:ipos-1) END DO CALL fclose(fh) END IF END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1120 FORMAT(a:,a,a:,a,a,a,a) 1130 FORMAT('historyindsa: ',a) END c----------------------------------------------------------------------- revhdr.f0000664006604000003110000001650514521201554011640 0ustar sun00315stepsC Last change: BCM 29 Sep 1998 10:48 am SUBROUTINE revhdr(Lprt,Lr1y2y,Revsa,Revmdl,Lmodel,Ny,Endspn,Iagr) IMPLICIT NONE c----------------------------------------------------------------------- C ***** PRINTS HEADING THAT IDENTIFIES WHICH OPTIONS ARE BEING USED C ***** IN A GIVEN Revisions history ANALYSIS. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revtrg.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER laglbl*(45),str*(10),cregfx*(12) LOGICAL Lprt,Lr1y2y,Revsa,Revmdl,Lmodel INTEGER Ny,nlglbl,nchr,i,Endspn,nyrev,Iagr,nregfx DIMENSION Endspn(2),cregfx(4),nregfx(4) c----------------------------------------------------------------------- DATA cregfx/'Trading Day ','Holiday ','User-defined', & 'Outlier '/ DATA nregfx/11,7,12,7/ c----------------------------------------------------------------------- c If revisions history not done, or results not printed out, c exit routine. c----------------------------------------------------------------------- IF((.not.(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvtrn.or.Lrvtch.or.Lrvaic & .or.Lrvfct)).or.(.not.Lprt))RETURN c----------------------------------------------------------------------- WRITE(Mt1,1010) 1010 FORMAT(//,' R 0 Summary of options selected for revisions ', & 'history analysis.', & //,' History analysis performed for the following:',/, & ' ---------------------------------------------') IF(Lrvsa)THEN IF(Iagr.eq.5)THEN IF(Indrev.gt.0)THEN WRITE(Mt1,1020)'Direct and Indirect Seasonally Adjusted Series' ELSE WRITE(Mt1,1020)'Direct Seasonally Adjusted Series' END IF ELSE WRITE(Mt1,1020)'Final Seasonally Adjusted Series' END IF END IF IF(Lrvch) & WRITE(Mt1,1020)'Changes in Final Seasonally Adjusted Series' IF(Lrvtrn)WRITE(Mt1,1020)'Final Trend-Cycle Component' IF(Lrvtch)WRITE(Mt1,1020)'Changes in Final Trend Cycle Component' IF(Lrvaic)WRITE(Mt1,1020)'AIC' IF(Lrvfct)WRITE(Mt1,1020)'Forecast Errors' IF(Lrvarma)WRITE(Mt1,1020)'ARMA Model Coefficients' IF(Lrvtdrg)WRITE(Mt1,1020)'Trading Day Coefficients' 1020 FORMAT(5x,'- ',a) WRITE(Mt1,1030) 1030 FORMAT(' ') c----------------------------------------------------------------------- IF(Lrvsa.and.Iagr.eq.5.and.Indrev.eq.0)THEN WRITE(Mt1,1021) 1021 FORMAT(' History analysis was not performed on the ', & 'Indirect Seasonally Adjusted Series ',/ & ' for one of the following reasons:') WRITE(Mt1,1020)'Identical starting dates not provided for the'// & ' history analysis of all' WRITE(Mt1,1022)'the components;' WRITE(Mt1,1020) & 'History analysis of seasonal adjustments not specified '// & 'for all the' WRITE(Mt1,1022)'components;' WRITE(Mt1,1020) & 'Starting date specified for total series doesn''t match '// & 'starting date for' WRITE(Mt1,1022)'the component series;' 1022 FORMAT(7x,a) WRITE(Mt1,1020) & 'Starting date not specified for total series.' WRITE(Mt1,1030) WRITE(Mt1,1023) 1023 FORMAT(' Revise the input specification files for the ', & 'components and total series',/, & ' accordingly and rerun the metafile to generate ', & 'revisions history analysis for',/ & ' the indirect seasonally adjusted series.') WRITE(Mt1,1030) END IF c----------------------------------------------------------------------- IF(Ntarsa.gt.0)THEN IF(Lrvsa.and.Lrvch)THEN laglbl='Seasonally Adjusted Series and Changes:' nlglbl=39 ELSE IF(Lrvsa)THEN laglbl='Seasonally Adjusted Series:' nlglbl=27 ELSE laglbl='Changes in the Seasonally Adjusted Series:' nlglbl=42 END IF WRITE(Mt1,1040)laglbl(1:nlglbl) WRITE(Mt1,1050)(Targsa(i),i=1,Ntarsa) IF(Lr1y2y)WRITE(Mt1,1050)Ny,Ny*2 END IF IF(Ntartr.gt.0)THEN IF(Lrvtrn.and.Lrvtch)THEN laglbl='Trend-Cycle Component and Changes:' nlglbl=34 ELSE IF(Lrvsa)THEN laglbl='Trend-Cycle Component:' nlglbl=22 ELSE laglbl='Changes in the Trend Cycle Component:' nlglbl=37 END IF WRITE(Mt1,1040)laglbl(1:nlglbl) WRITE(Mt1,1050)(Targtr(i),i=1,Ntartr) END IF 1040 FORMAT(' Lags from Concurrent Analyzed for ',a) 1050 FORMAT(5x,5i5) * 1060 FORMAT(' Difference between Lag ',i2,' and ',i2,' Analyzed.') IF(Ntarsa.gt.0.or.Ntartr.gt.0)WRITE(Mt1,1030) c----------------------------------------------------------------------- IF(Lrvfct.and.Nfctlg.gt.0)THEN WRITE(Mt1,1070) 1070 FORMAT(' Forecast Lags Analyzed for Forecast Error History', & ' Analysis:') WRITE(Mt1,1050)(Rfctlg(i),i=1,Nfctlg) WRITE(Mt1,1030) END IF c----------------------------------------------------------------------- CALL wrtdat(Rvstrt,Ny,str,nchr) IF(Lfatal)RETURN WRITE(Mt1,1080)str(1:nchr) 1080 FORMAT(' Starting date for history analysis: ',a) CALL wrtdat(Rvend,Ny,str,nchr) IF(Lfatal)RETURN IF(Revsa.and.Revmdl)THEN CALL dfdate(Rvend,Endspn,Ny,nyrev) IF(nyrev.eq.0)THEN WRITE(Mt1,1090)'history analysis',str(1:nchr) ELSE WRITE(Mt1,1090)'seasonal adjustment history analysis', & str(1:nchr) CALL wrtdat(Endspn,Ny,str,nchr) IF(Lfatal)RETURN WRITE(Mt1,1090)'regARIMA model history analysis',str(1:nchr) END IF ELSE WRITE(Mt1,1090)'history analysis',str(1:nchr) END IF 1090 FORMAT(' Ending date for ',a,': ',a) WRITE(Mt1,1030) c----------------------------------------------------------------------- IF(Revsa)THEN IF(Cnctar)THEN WRITE(Mt1,1100)'Concurrent' ELSE WRITE(Mt1,1100)'Final' END IF WRITE(Mt1,1030) END IF 1100 FORMAT(' Seasonal Adjustment Revisions Computed Using ',a, & ' as Target.') c----------------------------------------------------------------------- IF(Lmodel)THEN IF(Revfix)THEN WRITE(Mt1,1120)'fixed' ELSE WRITE(Mt1,1120)'estimated' IF(Lrfrsh)WRITE(Mt1,1130) IF(Nrvfxr.gt.0)THEN WRITE(Mt1,1140) WRITE(Mt1,1150)(cregfx(Rvfxrg(i))(1:nregfx(Rvfxrg(i))), & i=1,Nrvfxr) END IF END IF END IF 1120 FORMAT(' regARIMA coefficient estimates are ',a, & ' during the history analysis.') 1130 FORMAT(' Starting values are reset to the values estimated for ', & 'the full span of data.') 1140 FORMAT(' The following regressors are held fixed during the ', & 'history analysis:') 1150 FORMAT(5x,a:,' ',a:,' ',a:,' ',a:,' ',a) c----------------------------------------------------------------------- RETURN END rev.prm0000664006604000003110000000130014521201554011476 0ustar sun00315stepsc----------------------------------------------------------------------- c PREV - maximum number of observations that can be analyzed in a c revisions history analysis c PFCLAG - maximum number of forecast lags that can be analyzed in a c revisions history analysis c PREVY - maximum number of years that can be analyzed in a c revisions history analysis c PTARGT - maximum number of targets that can be analyzed in a c revisions history analysis c----------------------------------------------------------------------- INTEGER PREV, PFCLAG, PREVY, PTARGT PARAMETER(PREV=PLEN-20,PFCLAG=4,PREVY=PYRS-5,PTARGT=5) revrse.f0000664006604000003110000000216214521201555011647 0ustar sun00315steps**==revrse.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE revrse(Frwd,Nr,Nc,Bkwd) IMPLICIT NONE c----------------------------------------------------------------------- c Reverses the rows of x, an nr by nc matrix. Note that we go c halfway through the series. c----------------------------------------------------------------------- INTEGER Nr,Nc,hlf,i,j,backi DOUBLE PRECISION Frwd(Nc,Nr),Bkwd(Nc,Nr),tmp c----------------------------------------------------------------------- c If the number of rows is even then exchange half the rows, hlf=nr/2. c If the number of rows is odd make sure the middle row is written also, c hlf=nr/2+1. c----------------------------------------------------------------------- hlf=(Nr+1)/2 DO i=1,hlf backi=Nr-i+1 c ------------------------------------------------------------------ DO j=1,Nc tmp=Frwd(j,i) Bkwd(j,i)=Frwd(j,backi) Bkwd(j,backi)=tmp END DO END DO c ------------------------------------------------------------------ RETURN END revs.i0000664006604000003110000000215214521201555011322 0ustar sun00315stepsC C Created by REG on 03 Jan 2006 C C... Variables in Common Block /firevs/ C MSEs and revision statistics given finite amount of data C in the past and semi-infinite amount of data in the future C where index identifies irregular, seasonal, and trend components. DOUBLE PRECISION infMSEs(3), infRevs(3) C MSEs and revision statistics given finite amount of data C in the past and finite amount of data in the future and C relative revision statistics to infRevs C where first index identifies irregular, seasonal, trend components C and where second index identifies one, two, three, four, five years C of data in the future. DOUBLE PRECISION finMSEs(3,5), finRevs(3,5), relRevs(3,5) C MSEs given finite anount of data in the past C and no data in the future DOUBLE PRECISION curMSEs(3) C Standard Error of Revisions for last 5 years of observations C for seasonal component and then trend component. DOUBLE PRECISION seRevs(60,2) common /firevs/ curMSEs, finMSEs, finRevs, infMSEs, infRevs, & relRevs, seRevsrevsrs.cmn0000664006604000003110000000376614521201555012230 0ustar sun00315stepsc----------------------------------------------------------------------- c This common block has the series used to generate the revisions c history analysis c----------------------------------------------------------------------- c Cncsf - Concurrent estimates for the seasonal factors c Cncsfp - Concurrent estimates for the projected seasonal factors c Finsf - Final estimates for the seasonal factors c Cncch - Concurrent estimates for the month-to-month changes c Finch - Final estimates for the month-to-month changes c Cncsa - Concurrent estimates for the seasonally adjusted series c Finsa - Final estimates for the seasonally adjusted series c Cncisa - Concurrent estimates for the indirect seasonally adjusted c series c Finisa - Final estimates for the indirect seasonally adjusted c series c Cncfct - Concurrent estimates for the forecasts for selected lags c Cnctrn - Concurrent estimates for the final trend c Fintrn - Final estimates for the final trend c Cnctch - Concurrent estimates for the month-to-month changes of c the final trend c Fintch - Final estimates for the month-to-month changes of the c final trend c----------------------------------------------------------------------- DOUBLE PRECISION Cncsf,Cncsfp,Finsf,Cncch,Finch,Cncsa,Finsa, & Cncisa,Finisa,Cncfct,Cnctrn,Fintrn,Cnctch, & Fintch DIMENSION Cncsf(PREV),Cncsfp(PREV),Finsf(PREV),Cncsa(PREV), & Finsa(0:PTARGT,PREV),Cncisa(PREV),Finisa(0:PTARGT,PREV), & Cncch(PREV),Finch(0:PTARGT,PREV),Cnctrn(PREV), & Fintrn(0:PTARGT,PREV),Cncfct(PFCLAG,PREV),Cnctch(PREV), & Fintch(0:PTARGT,PREV) c----------------------------------------------------------------------- COMMON /revdta/ Cncsf,Cncsfp,Finsf,Cncsa,Finsa,Cncisa,Finisa, & Cncch,Finch,Cncfct,Cnctrn,Fintrn,Cnctch,Fintch revtbl.i0000664006604000003110000000323514521201555011644 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c revision REV or RV c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c table of outliers identified during revision analysis OT c table of msr seasonal filters in revision period R0 c revision of s.a. data R1 c conc and final est. of s. a. data R1A c revision of seasonal R2 c conc and final est. of seasonal R2A c revision of change in s.a. R3 c conc and final est. of change in s.a. R3A c revision of trend R4 c conc and final est. of trend R4A c likelihood revisions R5 c forecast revisions R6 c----------------------------------------------------------------------- INTEGER LRVHDR,LREVOT,LREVR0,LREVR1,LREVR2,LREVR3,LREVR4,LREVR5, & LREVR6,LREVR7,LREVR8,LREVR9,LRVSSH,LRVR9A,LRVR9B PARAMETER( & LRVHDR=240,LREVOT=241,LREVR0=242,LREVR1=243,LREVR2=246, & LREVR3=249,LREVR4=252,LREVR5=255,LREVR6=258,LREVR7=261, & LREVR8=262,LREVR9=264,LRVSSH=265,LRVR9A=266,LRVR9B=267) revtrg.cmn0000664006604000003110000000117414521201555012204 0ustar sun00315stepsc Targsa - Integer vector of displacements for seasonal adjustment c revisions history targets c Ntarsa - Number of seasonal adjustment revisions history targets c Targtr - Integer vector of displacements for trend revisions c history targets c Ntartr - Number of trend revisions history targets c----------------------------------------------------------------------- INTEGER Targsa,Ntarsa,Targtr,Ntartr DIMENSION Targsa(PTARGT),Targtr(PTARGT) c----------------------------------------------------------------------- COMMON /revtrg/ Targsa,Ntarsa,Targtr,Ntartr revusr.cmn0000664006604000003110000000217014521201555012216 0ustar sun00315stepsc----------------------------------------------------------------------- c Rusttl - data dictionary containing the names of the user-defined c regressors deleted during the revisions/sliding spans c analysis c Buser - parameter values for the user-defined regressors deleted c during the revisions/sliding spans analysis c Rusptr - pointer vector for data dictionary for user-defined c regressors deleted during the revisions/sliding spans c analysis c Nrustl - number of user-defined regressors deleted during the c revisions/sliding spans analysis c----------------------------------------------------------------------- CHARACTER Rusttl*(PCOLCR*PB) DOUBLE PRECISION Buser INTEGER Rusptr,Nrustl,Nzero,Nusadd,Usradd DIMENSION Rusptr(0:PUREG),Buser(PUREG),Nzero(PUREG),Usradd(PUREG) c----------------------------------------------------------------------- COMMON /revusr/ Buser,Rusptr,Nzero,Nrustl,Usradd,Nusadd,Rusttl c----------------------------------------------------------------------- rgarma.f0000664006604000003110000004774714521201555011634 0ustar sun00315stepsC Last change: SRD 31 Jan 100 7:33 am SUBROUTINE rgarma(Lestim,Mxiter,Mxnlit,Lprtit,A,Na,Nefobs,Lauto) c----------------------------------------------------------------------- c rgarma.f, Release 1, Subroutine Version 1.14, Modified 07 Dec 1995. c----------------------------------------------------------------------- c Regarma, reg+arma ARMA parameters estimated in the nonlinear c routine and the regression parameters calculated by GLS at each c function evaluation. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c a d Output pobs na used vector of residuals c (r(t)'s + sqrt(log(detcov))) from the kalman filter c apa d Local scalar for a'a c estprm d Local parima, nestpm used, long vector of parameters c estimated in the nonlinear routine. c info i Local integer passing convergence and error warnings form c the minpack nonlinear routine, lmdif. c intflt l Local PARAMETER switch to initialize/calculate |G'G| c iter i Local scalar for the number of overall iterations c ipvt i Local work array for the nonlinear routine parima>=nestpm c or the number of nonlinear parameters c convrg l Local flag, indicates whether the iterations call abend() c lerr l Local error for X'X not positive definite (.true.). Used c in the cholesky decomposition return c lestim l Input logical to estimate the model c locest l Local flag on whether to estimate the model on this pass c lprtit l Input logical whether to print out the iteration and c convergence information c mxiter i Input maximum number of cumulative ARMA iterations c na i Output number of a(t)'s, or the number of residuals used in c the nonlinear routine, na=nspobs+nqstar c nefobs i Input number of effective observations and the length of c the differenced regression variables and series less the c order of the DF*AR operators. c nestpm i Local number of parameters estimated in the non linear c routine c nfev i Local number of AR+MA filterings of a column of data or c regression effect c nliter i Local number of nonlinear iterations c nprint i Local flag whether lmdif should print out the iteration c information (=1) or not (=0) c nrtXy i Local number of rows in tXy c nrXy i Input length of the series, or number of rows in [X:y] c objfcn d Local objective function, either the c deviance=^var*D**(1/nefobs). The obective c function is used as the convergence criterion and to c calculate the likelihood. c one d PARAMETER scalar for a double precision 1.0d0 c pi d Local PARAMETER for pi c pt5 i Local PARAMETER for .5d0 c pxa i Input PARAMETER for the number of elements in tXy, c >=na*ncXy c pXy i Input PARAMETER for the number of elements in Xy c >=nefobs*ncXy c two d Local PARAMETER for a double precision 2 c tXy d Local work pxa, nrXy by ncXy temporary matrix for the c regression variables and data. Also a work array for the c nonlinear routine and pxa >= na*(nestpm+1)+5*nestpm c zero d Local PARAMETER for 0.0d0 c----------------------------------------------------------------------- c Variable typing and initialization c----------------------------------------------------------------------- IMPLICIT NONE LOGICAL F,T PARAMETER(F=.false.,T=.true.) LOGICAL LCLOSE DOUBLE PRECISION ONE,PI,TWO,ZERO,MONE PARAMETER(LCLOSE=T,ONE=1D0,PI=3.14159265358979D0,TWO=2D0, & ZERO=0D0,MONE=-1D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'mdltbl.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'hiddn.cmn' c----------------------------------------------------------------------- INCLUDE 'series.cmn' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER PA,PXA,PXY PARAMETER(PA=PLEN+2*PORDER,PXY=PLEN*(PB+1),PXA=PA*(PB+1)) c----------------------------------------------------------------------- INTEGER ipvt DOUBLE PRECISION estprm,txy,dvec DIMENSION estprm(PARIMA),ipvt(PARIMA),txy(PXA),dvec(1) c----------------------------------------------------------------------- LOGICAL intflt,Lestim,lnxstp,locest,Lprtit,stpitr,Lauto,la,gudrun INTEGER flterr,i,iflag,info,inverr,iter,lstnit,Mxiter,Mxnlit,Na, & Nefobs,neltxy,nprint,nrtxy,tnlitr c INTEGER bset DOUBLE PRECISION A,apa,devtol,dpmpar,eps,nltolf,objfcn,tnltol DIMENSION A(PA) c----------------------------------------------------------------------- DOUBLE PRECISION diag(PARIMA),qtf(PARIMA),wa1(PARIMA),wa2(PARIMA), & wa3(PARIMA),wa4(PA),tmpa(PA) EQUIVALENCE(diag,txy),(qtf,txy(PARIMA+1)),(wa1,txy(2*PARIMA+1)), & (wa2,txy(3*PARIMA+1)),(wa3,txy(4*PARIMA+1)), & (wa4,txy(5*PARIMA+1)),(tmpa,txy(5*PARIMA+PA+1)) c----------------------------------------------------------------------- c Changed by BCM Feb 1996 to ensure iteration information is printed c in multiple runs. c ------------------------------------------------------------------ LOGICAL Frstcl,Scndcl COMMON /lgiter / Frstcl,Scndcl c ------------------------------------------------------------------ LOGICAL xyzero,dpeq EXTERNAL dpeq,dpmpar,fcnar,stpitr INTEGER nelta,i2 c----------------------------------------------------------------------- IF(Lprtit)THEN Frstcl=T Scndcl=F END IF gudrun=Issap.LT.2.AND.Irev.lt.4 c----------------------------------------------------------------------- c Check the work array size c----------------------------------------------------------------------- IF(Nspobs*Ncxy.gt.PXY)THEN CALL errhdr WRITE(STDERR,1010)Nspobs,Ncxy,PXY WRITE(Mt2,1010)Nspobs,Ncxy,PXY 1010 FORMAT(/,' ERROR: Work array too small,',i4,'*',i4,'>',i6,'.') IF(Lauto)THEN Lauto=F ELSE CALL abend END IF RETURN END IF c----------------------------------------------------------------------- c Set some dimensions and parameters c----------------------------------------------------------------------- info=1 Armaer=0 intflt=T locest=Lestim Lrgrsd=1D6 c----------------------------------------------------------------------- IF(Lprtit)THEN nprint=1 ELSE nprint=0 END IF c----------------------------------------------------------------------- c Copy the model specifications to the common variables and c difference Xy into Xy c----------------------------------------------------------------------- CALL strtvl() c bset=Iregfx c IF(bset.ge.3.and.Nb.gt.0)bset=0 la=.false. CALL setmdl(estprm,la) IF(Lfatal)RETURN c----------------------------------------------------------------------- Nefobs=Nspobs-Nintvl * IF(Nefobs.le.Nextvl)THEN IF(Nefobs.lt.Nextvl)THEN WRITE(STDERR,1020)Nefobs,Nextvl WRITE(Mt2,1020)Nefobs,Nextvl 1020 FORMAT(/,' ERROR: Number of observations after differencing ', & 'and/or conditional AR', & /,' estimation is',i4,', which is less than the ', & 'minimum series length', & /,' required for the model estimated,',i4,'.',/) IF(Lauto)THEN CALL writln(' Check automatic modeling options (reduce ma &xorder for automdl, or',Mt1,Mt2,T) CALL writln(' check models used with pickmdl) and try aga &in.',Mt1,Mt2,F) Lauto=F ELSE CALL abend END IF RETURN END IF c----------------------------------------------------------------------- Dnefob=dble(Nefobs) neltxy=Nspobs*Ncxy c----------------------------------------------------------------------- c check to see if the objective function is zero c----------------------------------------------------------------------- IF((Mdl(DIFF)-Mdl(DIFF-1)).gt.0)THEN nelta=Nspobs i2=0 DO i=Ncxy,neltxy,Ncxy i2=i2+1 txy(i2)=Xy(i) END DO CALL arflt(nelta,Arimap,Arimal,Opr,Mdl(DIFF-1),Mdl(DIFF)-1,txy, & nelta) i2 = 1 xyzero = dpeq(txy(1),ZERO) DO WHILE (i2.lt.nelta.and.xyzero) i2=i2+1 xyzero = dpeq(txy(i2),ZERO) END DO IF(xyzero)THEN Armaer=POBFN0 IF(Lauto)Lauto=F RETURN END IF END IF c----------------------------------------------------------------------- c Input convergence tolerances are based on the log likelihood c but the program checks for convergence of the deviance so the c tolerances are converted c----------------------------------------------------------------------- devtol=2D0/Dnefob*Tol c----------------------------------------------------------------------- IF(Lar.or.Lma)THEN Na=Nefobs+Mxmalg ELSE Na=Nefobs END IF c----------------------------------------------------------------------- c Nonlinear tolerances and maximum iterations are set to the overall c if there is no regression. c----------------------------------------------------------------------- eps=Stepln c----------------------------------------------------------------------- IF(Nb.gt.0)THEN tnltol=2D0/Dnefob*Nltol0 nltolf=2D0/Dnefob*Nltol tnlitr=Mxnlit ELSE tnltol=devtol tnlitr=Mxiter END IF c----------------------------------------------------------------------- c Nonlinear least squares ARMA estimation. First, check that c the work arrays are big enough c----------------------------------------------------------------------- IF(Nestpm.gt.0)THEN Nlwrk=max(Na,Nspobs)*(Nestpm+1)+5*Nestpm c----------------------------------------------------------------------- IF(Nlwrk.gt.PXA)THEN WRITE(STDERR,1030)Nlwrk,PXA WRITE(Mt2,1030)Nlwrk,PXA 1030 FORMAT(/,' ERROR: Non linear work array too small',i6,'>',i6, & '.') IF(Lauto)THEN Lauto=F ELSE CALL abend END IF RETURN c----------------------------------------------------------------------- ELSE Nlwrk=max(Na,Nspobs) END IF END IF c----------------------------------------------------------------------- iter=0 Nliter=0 Nfev=0 c----------------------------------------------------------------------- c Iteration loop, first do a GLS to get the regression estimates c then send the regressor to a nonlinear least squares routine to get a c new estimate of the ARMA parameters. c----------------------------------------------------------------------- c write(ng,9000)'init',iter, lnxstp, info, convrg, armaer DO WHILE (T) CALL copy(Xy,neltxy,1,txy) CALL armafl(Nspobs,Ncxy,intflt,F,txy,nrtxy,PXA,flterr) c----------------------------------------------------------------------- c If the filter doesn't work check for invertibility and c stationarity, report the error, and return. c----------------------------------------------------------------------- IF(flterr.gt.0)THEN IF(Mdl(MA).gt.Mdl(DIFF))THEN CALL chkrt2(T,inverr,Lhiddn) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(inverr.gt.0)THEN Armaer=inverr c ------------------------------------------------------------------ ELSE Armaer=flterr Var=ZERO END IF c----------------------------------------------------------------------- ELSE Armaer=flterr Var=ZERO END IF c----------------------------------------------------------------------- GO TO 10 END IF c----------------------------------------------------------------------- c Calculate the regression parameters given the ARMA parameters c from the last iteration (or initial values if it's the first c iteration). c----------------------------------------------------------------------- apa=0D0 IF(Nb.le.0)THEN CALL yprmy(txy,nrtxy,apa) Chlxpx(1)=sqrt(apa) c ELSE IF(bset.gt.0)THEN c IF(locest.and.Nestpm.gt.0)THEN c bset=0 c ELSE c CALL xprmx(txy,nrtxy,Ncxy,Ncxy,Chlxpx) c CALL dppfa(Chlxpx,Ncxy,Sngcol) c----------------------------------------------------------------------- c IF(Sngcol.gt.0)THEN c Convrg=F c Armaer=PSNGER c GO TO 10 c END IF c END IF c----------------------------------------------------------------------- ELSE CALL olsreg(txy,nrtxy,Ncxy,Ncxy,B,Chlxpx,PXPX,Sngcol) IF(Lfatal)RETURN IF(Sngcol.gt.0)THEN Convrg=F Armaer=PSNGER IF(Lauto)Lauto=F GO TO 10 END IF c----------------------------------------------------------------------- Nfev=Nfev+Ncxy+1 END IF c----------------------------------------------------------------------- c Calculate the objective function and decide on convergence. c Note that if there is no regression we only need to go through c lmdif once. c----------------------------------------------------------------------- CALL resid(txy,nrtxy,Ncxy,Ncxy,1,Nb,MONE,B,A) IF(Lfatal)RETURN CALL yprmy(A,nrtxy,apa) objfcn=apa*exp(Lndtcv/Dnefob) c----------------------------------------------------------------------- c Calculate the magnitude of the largest residual needed for the c constrained estimation in Minpack. c----------------------------------------------------------------------- IF(iter.eq.0)THEN CALL maxvec(A,nrtxy,Lrgrsd) Lrgrsd=Lrgrsd*exp(Lndtcv/TWO/Dnefob) END IF lnxstp=locest.and.Nestpm.gt.0.and. & stpitr(Lprier,objfcn,devtol,iter,Nliter,Mxiter,Convrg, & Armaer,Lhiddn) iter=iter+1 c write(ng,9000)'lnxstp,iter,convrg',iter, lnxstp, info, convrg, c & armaer IF(Lprtit)THEN dvec(1)=objfcn IF(Nliter.eq.0)CALL prtitr(dvec,1,estprm,Nestpm,'ARMA',Nliter, & Nfev) IF(.not.Lfatal.and.Nb.gt.0) & CALL prtitr(dvec,1,B,Nb,'IGLS',iter,Nfev) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Re-estimate the ARMA parameters. Note that the a's are deviance c values when returned from lmdif, not ARMA filtered residuals. c Also, if there are no iterations in the nonlinear routine then c it has not changed the pamameters, and the mimimization has converged. c After the first iteration the nonlinear tolerance is changed to the c IGLS tolerance unless it has been defined by the user. c----------------------------------------------------------------------- IF(lnxstp)THEN IF(iter.gt.2)tnltol=nltolf lstnit=Nliter CALL resid(Xy,Nspobs,Ncxy,Ncxy,1,Nb,MONE,B,Tsrs) CALL lmdif(fcnar,Na,Nestpm,estprm,A,Lauto,gudrun,tnltol,ZERO, & ZERO,Nliter+tnlitr,eps,diag,1,100D0,nprint,info, & Nliter,Nfev,Armacm,PA,ipvt,qtf,wa1,wa2,wa3,wa4) IF(Lfatal)RETURN c write(ng,9000)'after lmdif',iter, lnxstp, info, convrg, armaer locest=Nb.gt.0 IF(info.ge.1.and.info.le.8.and.Nliter.gt.lstnit)GO TO 20 END IF c----------------------------------------------------------------------- c Print out any errors in the convergence of the MINPACK nonlinear c estimation routine. Let the program go on because the user may be c able to spot and error from the parameter estimates. Info= 1 to 4 c means the estimation has converged and that will be printed out later. c----------------------------------------------------------------------- IF(Lestim.and.Nestpm.gt.0)THEN IF(Nb.eq.0)THEN Convrg=Convrg.and.(info.ge.1.and.info.le.4).or. & (info.ge.6.and.info.le.8) ELSE Convrg=Convrg.and.info.ge.1.and.info.le.8 END IF c write(ng,9000)'convrg=',iter, lnxstp, info, convrg, armaer c----------------------------------------------------------------------- IF(info.lt.0)THEN Armaer=PUNKER Convrg=F Var=ZERO GO TO 10 c----------------------------------------------------------------------- ELSE IF(info.eq.0)THEN Armaer=PINPER c----------------------------------------------------------------------- ELSE IF(info.eq.5.or.(Nliter.ge.Mxiter.and..not.Convrg))THEN IF(Nliter.ge.Mxiter)THEN Armaer=PMXIER ELSE Armaer=PMXFER END IF c----------------------------------------------------------------------- ELSE IF(info.ge.1.and.info.le.4)THEN Armaer=0 c----------------------------------------------------------------------- ELSE Armaer=info END IF c write(ng,9000)'armaer=',iter, lnxstp, info, convrg, armaer END IF c----------------------------------------------------------------------- c Calculate the maximum likelihood variance and the likelihood c----------------------------------------------------------------------- Var=apa/Dnefob IF(Var.lt.TWO*dpmpar(1))Var=ZERO IF(dpeq(Var,ZERO))THEN Lnlkhd=ZERO ELSE Lnlkhd=-(Lndtcv+Dnefob*(log(TWO*PI*Var)+ONE))/TWO END IF c----------------------------------------------------------------------- c Calculate the covariance of the ARMA parameters from the c information from the minpack routine only if the model is estimated c so we know the parameters are at their MLE's c----------------------------------------------------------------------- IF(Lestim.and.Nestpm.gt.0.and.Convrg)THEN CALL resid(Xy,Nspobs,Ncxy,Ncxy,1,Nb,MONE,B,Tsrs) c CALL fcnar(Na,tmpa,estprm,tmpa,Lauto,info,F) CALL fcnar(Na,Nestpm,estprm,tmpa,Lauto,gudrun,info,F) IF(Lfatal)RETURN c WRITE(Mtprof,*)' info after fcnar = ',info c write(ng,9000)'after fcnar',iter, lnxstp, info, convrg, armaer iflag=2 CALL fdjac2(fcnar,Na,Nestpm,estprm,tmpa,Lauto,gudrun,Armacm,PA, & iflag,0d0,wa4,F) CALL upespm(estprm) c----------------------------------------------------------------------- IF(iflag.ge.0)THEN CALL qrfac(Na,Nestpm,Armacm,PA,T,ipvt,Nestpm,wa1,wa2,wa3) DO i=1,Nestpm Armacm(i,i)=wa1(i) c qtf(i)=wa4(i) END DO c----------------------------------------------------------------------- CALL covar(Nestpm,Armacm,PA,ipvt,tnltol,info) c write(ng,9000)'after covar',iter, lnxstp, info, convrg, armaer Lcalcm=info.eq.0 IF(.not.Lcalcm)Armaer=PACSER ELSE Lcalcm=F END IF c write(ng,9000)'lcalcm=',iter, lnxstp, info, convrg, armaer END IF c----------------------------------------------------------------------- IF(Savtab(LESTIT))THEN dvec(1)=ZERO CALL savitr(LCLOSE,iter,iter,ZERO,dvec,1) END IF c----------------------------------------------------------------------- 10 RETURN 20 CONTINUE END DO c 9000 FORMAT(a27,' iter = ',i3,' lnxstp = ',l2,' info = ',i3, c & ' convrg = ',l2,' armaer = ',i3) END rgtdhl.f0000664006604000003110000000651214521201555011630 0ustar sun00315stepsC Last change: BCM 3 Mar 1999 8:00 am SUBROUTINE rgtdhl(A,Nbeg) IMPLICIT NONE c----------------------------------------------------------------------- c If multiplicative seasonal adjustment and trading day and holiday c appear as regressors, calculate the effect of the mean holiday c effect. c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'x11log.cmn' INCLUDE 'error.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c----------------------------------------------------------------------- DOUBLE PRECISION A,xnk INTEGER i,i2,frstry,Nbeg c----------------------------------------------------------------------- DIMENSION A(PA),xnk(PLEN) c----------------------------------------------------------------------- c Return if this is not a true multiplicative seasonal adjustment c (not Pseudo-Additive) with Bell-Hilmer Easter and trading day c regressors. (This is done within the routine so that the c call from the outlier identification routines is kept as clean as c possible.) c----------------------------------------------------------------------- IF(.not.(Xhlnln.and.((.not.Psuadd).and.Muladd.eq.0).and. & Easidx.eq.0.and.((.not.Axruhl).and.Holgrp.gt.0).and. & Tdgrp.gt.0))RETURN c----------------------------------------------------------------------- CALL kfcn(Begxrg,Nrxy,Pos1ob+Nbeg,Xelong) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Perform regression to remove the mean holiday effect c----------------------------------------------------------------------- DO i=1,Nspobs i2=i+Pos1ob+Nbeg-1 xnk(i)=Kvec(i)*Xnstar(i2)*Sti(i2)-Xn(i2) c xnk(i)=(Xnstar(i2)*Sti(i2)-Xn(i2))/Kvec(i) END DO CALL regvar(xnk,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,F,Xelong) IF(Lfatal)RETURN c CALL xrghol(Pos1ob+Nbeg,F,Xlpyr,Daybar) CALL xrgdiv(Kvec) CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(Lfatal)RETURN c----------------------------------------------------------------------- c Compute revised Kvec c----------------------------------------------------------------------- CALL kfcn(Begxrg,Nrxy,Pos1ob+Nbeg,Xelong) c----------------------------------------------------------------------- c Compute residuals from this non-linear estimation c----------------------------------------------------------------------- IF(.not.Lfatal) & CALL resid2(Xy,Nrxy,Ncxy,Nb,Pos1ob+Nbeg,B,A,Sti) c----------------------------------------------------------------------- RETURN END rho2.f0000664006604000003110000000106114521201555011210 0ustar sun00315steps**==rho2.f processed by SPAG 4.03F at 16:22 on 30 Mar 1994 c----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION rho2(U) IMPLICIT NONE DOUBLE PRECISION U,u2 c----------------------------------------------------------------------- IF(abs(U).gt.2.798D0)THEN rho2=6.502D0 ELSE u2=U*U rho2=(0.9249D0*u2)+(0.0812D0*u2*u2)-(0.0119D0*u2*u2*u2) END IF c----------------------------------------------------------------------- RETURN END rho.cmn0000664006604000003110000000355614521201555011471 0ustar sun00315stepsc----------------------------------------------------------------------- c Thtapr - taper for spectrum c Bgspec - Starting date for spectral plots c Spctyp - indicator variable = 0 if AR-spectrum is computed, 1 if c periodogram is computed. c Spcsrs - indicator variable = 0 if original series used, 1 if c outlier adjusted series is used, 2 if adjusted original c series is used. c Cspeak - character string of series with seasonal peaks in c spectrum c Ctpeak - character string of series with td peaks in spectrum c Nspeak - string length of Cspeak c Ntpeak - string length of Ctpeak c Lsavpk - logical variable for whether information on spectral c peaks are to be saved c Spcdff - Logical variable which indicates when a difference is c performed on the original series and/or seasonally adj. c series prior to generating spectral estimates c----------------------------------------------------------------------- CHARACTER Cspeak*35,Ctpeak*35 DOUBLE PRECISION Thtapr,Spclim,Plocal INTEGER Bgspec,Spctyp,Nspeak,Ntpeak,Spcsrs,Mxarsp,Peakwd,Spdfor, & Ntukfq LOGICAL Lsavpk,Spcdff,Lfqalt,Axsame,Svallf,Ldecbl,Lstdff,Lprsfq, & Llogqs,Ltk120,Lqchk,Lrbstsa c----------------------------------------------------------------------- DIMENSION Bgspec(2) c----------------------------------------------------------------------- COMMON /rho / Thtapr,Spclim,Plocal,Bgspec,Spctyp,Nspeak,Ntpeak, & Spcsrs,Mxarsp,Peakwd,Spdfor,Lsavpk,Spcdff,Lfqalt, & Svallf,Ldecbl,Axsame,Lstdff,Lprsfq,Llogqs,Ltk120, & Lqchk,Lrbstsa COMMON /crho / Cspeak,Ctpeak c----------------------------------------------------------------------- rmatot.f0000664006604000003110000002223114521201556011647 0ustar sun00315stepsC Last change: BCM 30 Jun 1998 8:46 am SUBROUTINE rmatot(Nrxy,Otlrev,Otlwin,Begrev,Begxy,Othndl,Otlfix, & Lprt,Lsav,Lhdr) IMPLICIT NONE c----------------------------------------------------------------------- c Outliers automatically identified in a previous run will be c removed from the regression model if they fall within the c "window" given by Otlwin c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'ssprep.cmn' INCLUDE 'title.cmn' INCLUDE 'cchars.i' c----------------------------------------------------------------------- CHARACTER CPLUS*(1) LOGICAL T,F PARAMETER(CPLUS='+',T=.true.,F=.false.) c----------------------------------------------------------------------- CHARACTER atrttl*(PCOLCR*PB),datstr*(10),rmrttl*(PCOLCR*PB), & outstr*(PCOLCR*PB),str*(PCOLCR) LOGICAL locok,Lsav,Lprt,Lhdr,update,vfix,Otlfix DOUBLE PRECISION batr INTEGER atrptr,natrtl,icol,Othndl,Nrxy,Otlrev,Otlwin,Begrev,vtype, & rmrptr,nrmrtl,end2,nreg,nchr,nchr2,otltyp,i,nauto,begotl, & endotl,Begxy,curdat,nrm,nchdat,rtype,iotlr,limchr,n1,n2,n0 DIMENSION atrptr(0:PB),rmrptr(0:PB),batr(PB),Begxy(2),curdat(2), & vtype(PB),vfix(PB) c----------------------------------------------------------------------- c Initialize outlier dictionaries and pointer variables. c----------------------------------------------------------------------- CALL intlst(PB,atrptr,natrtl) CALL intlst(PB,rmrptr,nrmrtl) nreg=natrtl+1 nrm=nrmrtl+1 nauto=0 c----------------------------------------------------------------------- DO i=Nb,1,-1 rtype=Rgvrtp(i) c----------------------------------------------------------------------- c If automatic outlier detection is to be done, get outlier c information. c----------------------------------------------------------------------- * IF(rtype.eq.PRGTAA.or.rtype.eq.PRGTAL.or.rtype.eq.PRGTAT.or. * & rtype.eq.PRGTAS)THEN IF(rtype.eq.PRGTAA.or.rtype.eq.PRGTAL.or.rtype.eq.PRGTAT)THEN CALL getstr(Colttl,Colptr,Ncoltl,i,str,nchr) IF(Lfatal)RETURN CALL rdotlr(str(1:nchr),Begxy,Sp,otltyp,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF IF(Otlrev.ge.2)THEN c----------------------------------------------------------------------- c Determine if the outlier is to be saved, ie, does it occur before c the start of the revision history analysis. c----------------------------------------------------------------------- end2=Begrev-Otlwin IF(begotl.le.end2)THEN CALL insstr(str(1:nchr),nreg,PB,atrttl,atrptr,natrtl) IF(Lfatal)RETURN batr(natrtl)=B(i) * IF(otltyp.eq.TC.or.otltyp.eq.SO)THEN IF(otltyp.eq.TC)THEN vtype(natrtl)=rtype-1 ELSE vtype(natrtl)=rtype-3 END IF vfix(natrtl)=Regfx(i).or.Otlfix nreg=nreg+1 ELSE CALL insstr(str(1:nchr),nrm,PB,rmrttl,rmrptr,nrmrtl) IF(Lfatal)RETURN nrm=nrm+1 END IF ELSE CALL insstr(str(1:nchr),nrm,PB,rmrttl,rmrptr,nrmrtl) IF(Lfatal)RETURN nrm=nrm+1 END IF c----------------------------------------------------------------------- c Delete automatic outlier c----------------------------------------------------------------------- iotlr=i CALL dlrgef(iotlr,Nrxy,1) IF(Lfatal)RETURN nauto=nauto+1 END IF END DO c----------------------------------------------------------------------- c If automatically identified outliers have been saved, reenter c them as regular outliers. c----------------------------------------------------------------------- IF(nauto.eq.0)RETURN IF(Otlrev.ge.2.and.natrtl.gt.0)THEN update=F DO icol=1,natrtl CALL getstr(atrttl,atrptr,natrtl,icol,str,nchr) IF(.not.Lfatal)CALL adrgef(batr(icol),str(1:nchr),str(1:nchr), & vtype(icol),vfix(icol),F) IF(Lfatal)RETURN IF(.not.update)update=T END DO IF(update)THEN c----------------------------------------------------------------------- c Update stored model parameters with newly stored regressor c----------------------------------------------------------------------- Ngr2=Ngrp Ngrt2=Ngrptl Ncxy2=Ncxy Nbb=Nb Nct2=Ncoltl Cttl=Colttl Gttl=Grpttl CALL cpyint(Colptr(0),PB+1,1,Clptr(0)) CALL cpyint(Grp(0),PGRP+1,1,G2(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Gptr(0)) CALL copy(B,PB,1,Bb) CALL cpyint(Rgvrtp,PB,1,Rgv2) CALL copylg(Regfx,PB,1,Regfx2) END IF END IF c----------------------------------------------------------------------- c Store outlier variables in special file. First, determine date. c----------------------------------------------------------------------- CALL addate(Begxy,Sp,Begrev-1,curdat) CALL wrtdat(curdat,Sp,datstr,nchdat) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print out headers, if necessary c----------------------------------------------------------------------- IF(Lhdr.and.((nrmrtl.gt.0.AND.Otlrev.eq.1.or.Otlrev.eq.3).or. & natrtl.gt.0))THEN CALL rvrghd(Othndl,Mt1,Lsav,Lprt) IF(Lfatal)RETURN Lhdr=F END IF c----------------------------------------------------------------------- c Print out outliers that were kept, if any c----------------------------------------------------------------------- IF(Lprt.or.Lsav)THEN limchr=80 IF(Lwdprt)limchr=132 nchr=1 n0=1 n2=1 IF(natrtl.gt.0)THEN DO i=1,natrtl CALL getstr(atrttl,atrptr,natrtl,i,str,nchr2) IF(Lfatal)RETURN outstr(nchr:(nchr+nchr2-1))=str(1:nchr2) IF(Lprt)n2=nchr2 nchr=nchr+nchr2 IF(i.lt.natrtl)THEN outstr(nchr:nchr)=CPLUS nchr=nchr+1 IF(Lprt)n2=n2+1 END IF IF(Lprt)THEN IF((nchr-n0+36).gt.limchr)THEN n1=nchr-n2-1 IF(n0.eq.1)THEN WRITE(Mt1,1030)datstr(1:nchdat),'kept',outstr(n0:n1) ELSE WRITE(Mt1,1030)' ',' ',outstr(n0:n1) END IF n0=n1+1 END IF END IF END DO END IF nchr=nchr-1 IF(Lprt.and.nchr.gt.0)THEN IF(n0.eq.1)THEN WRITE(Mt1,1030)datstr(1:nchdat),'kept',outstr(1:nchr) ELSE WRITE(Mt1,1030)' ',' ',outstr(n0:nchr) END IF END IF IF(Lsav)THEN IF(nchr.eq.0)THEN outstr(1:4)='none' nchr=nchr+4 END IF WRITE(Othndl,1010)datstr(1:nchdat),TABCHR,'kept',TABCHR, & outstr(1:nchr) END IF END IF c----------------------------------------------------------------------- c Print out outliers that were deleted, if any c----------------------------------------------------------------------- IF(Lsav.or.Lprt)THEN nchr=1 n0=1 n2=1 IF(nrmrtl.gt.0)THEN DO i=1,nrmrtl CALL getstr(rmrttl,rmrptr,nrmrtl,i,str,nchr2) IF(Lfatal)RETURN outstr(nchr:(nchr+nchr2-1))=str(1:nchr2) nchr=nchr+nchr2 IF(Lprt)n2=nchr2 IF(i.lt.nrmrtl)THEN outstr(nchr:nchr)=CPLUS nchr=nchr+1 IF(Lprt)n2=n2+1 END IF IF(Lprt)THEN IF((nchr-n0+36).gt.limchr)THEN n1=nchr-n2-1 IF(n0.eq.1)THEN WRITE(Mt1,1030)datstr(1:nchdat),'deleted(auto)', & outstr(n0:n1) ELSE WRITE(Mt1,1030)' ',' ',outstr(n0:n1) END IF n0=n1+1 END IF END IF END DO END IF nchr=nchr-1 IF(Lprt.and.nchr.gt.0)THEN IF(n0.eq.1)THEN WRITE(Mt1,1030)datstr(1:nchdat),'deleted(auto)',outstr(1:nchr) ELSE WRITE(Mt1,1030)' ',' ',outstr(n0:nchr) END IF END IF IF(Lsav)THEN IF(nchr.eq.0)THEN outstr(1:4)='none' nchr=nchr+4 IF(Lhdr)THEN CALL rvrghd(Othndl,Mt1,Lsav,Lprt) IF(Lfatal)RETURN Lhdr=F END IF END IF WRITE(Othndl,1010)datstr(1:nchdat),TABCHR,'deleted(auto)', & TABCHR,outstr(1:nchr) END IF END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(a,a,a,a,a) 1030 FORMAT(4x,a,t21,a,t36,a) END rmfix.f0000664006604000003110000001210114521201556011461 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 3:01 pm SUBROUTINE rmfix(Trnsrs,Nbcst,Nrxy,Fxindx) IMPLICIT NONE c----------------------------------------------------------------------- c If Fxindx = 1, this routine removes fixed regressors from c regression matrix, as well as the effects of the fixed regressors c from the transformed series. c If Fxindx = 2, this routine is used to remove all regressors c from the regression matrix, as well as the effects of the c regressors from the transformed series (except for the constant c term), prior to identifying differencing and ARMA model orders in c the automatic model identification procedure. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'fxreg.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T DOUBLE PRECISION ZERO PARAMETER(T=.TRUE.,ZERO=0D0) c----------------------------------------------------------------------- CHARACTER str*(PCOLCR),strgrp*(PGRPCR) INTEGER Fxindx,i,icol,nreg,Nbcst,nchr,nchgrp,igrp,oldfix,numgrp, & endcol,begcol,Nrxy DOUBLE PRECISION Trnsrs(PLEN) c----------------------------------------------------------------------- c Initialize data dictionary for fixed regression effects and fixed c regression effect groups. c----------------------------------------------------------------------- IF(Fxindx.lt.2.or.Nfxttl.eq.0)THEN CALL setdp(ZERO,PLEN,Fixfac) CALL intlst(PB,Cfxptr,Nfxttl) CALL intlst(PGRP,Gfxptr,Ngfxtl) CALL intlst(PGRP,Grpfix,Ngrpfx) END IF * ELSE IF(Fxindx.eq.2)CALL setdp(ZERO,PLEN,Fixfc2) * END IF oldfix=Nfxttl nreg=Nfxttl+1 numgrp=Ngfxtl+1 IF(Ngrp.eq.0)RETURN c----------------------------------------------------------------------- c Step through each group of regressors, finding those that are c fixed. c----------------------------------------------------------------------- DO igrp=Ngrp,1,-1 CALL getstr(Grpttl,Grpptr,Ngrptl,igrp,strgrp,nchgrp) IF(Lfatal)RETURN endcol=Grp(igrp)-1 begcol=Grp(igrp-1) icol=endcol DO WHILE (icol.ge.begcol) IF(Regfx(icol).or.Fxindx.eq.2)THEN c----------------------------------------------------------------------- c If regressor is fixed, make copy of it in the data dictionary c of fixed regressors. c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(.not.Lfatal) & CALL insstr(str(1:nchr),nreg,PB,Cfxttl,Cfxptr,Nfxttl) IF(Lfatal)RETURN Bfx(Nfxttl)=B(icol) Fxtype(Nfxttl)=Rgvrtp(icol) Fixind(Nfxttl)=Fxindx nreg=nreg+1 c----------------------------------------------------------------------- c Generate regression effect for fixed regressors c----------------------------------------------------------------------- IF(Fxindx.eq.2)THEN IF(Rgvrtp(icol).ne.PRGTCN) & CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fixfc2,1) ELSE CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fixfac,1) END IF c----------------------------------------------------------------------- c Remove from regression matrix. c----------------------------------------------------------------------- IF((Rgvrtp(icol).ge.PRGTUH.and.Rgvrtp(icol).le.PRGUH5).or. & Rgvrtp(icol).eq.PRGTUS.or.Rgvrtp(icol).eq.PRGTUD.or. & Rgvrtp(icol).eq.PRGUAO.or.Rgvrtp(icol).eq.PRGULS.or. & Rgvrtp(icol).eq.PRGUSO.or.Rgvrtp(icol).eq.PRGUTD.or. & Rgvrtp(icol).eq.PRGULM.or.Rgvrtp(icol).eq.PRGULQ.or. & Rgvrtp(icol).eq.PRGULY.or.Rgvrtp(icol).eq.PRGUCN.or. & Rgvrtp(icol).eq.PRGUCY)THEN CALL dlusrg(icol-begcol+1) IF(Lfatal)RETURN END IF CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN END IF icol=icol-1 END DO IF(oldfix.lt.Nfxttl)THEN CALL insstr(strgrp(1:nchgrp),numgrp,PGRP,Gfxttl,Gfxptr,Ngfxtl) IF(.not.Lfatal) & CALL insptr(T,Nfxttl-oldfix,numgrp,PGRP,PB,Grpfix,Ngrpfx) IF(Lfatal)RETURN oldfix=Nfxttl numgrp=numgrp+1 END IF END DO c----------------------------------------------------------------------- c Remove regression effect for fixed regressors from transformed c series c----------------------------------------------------------------------- IF(Nfxttl.gt.0)THEN IF(Fxindx.eq.2)THEN DO i=1,Nspobs Trnsrs(i)=Trnsrs(i)-Fixfc2(i+Nbcst) END DO ELSE DO i=1,Nspobs Trnsrs(i)=Trnsrs(i)-Fixfac(i+Nbcst) END DO END IF END IF c----------------------------------------------------------------------- RETURN END rmlnvr.f0000664006604000003110000000377614521201556011676 0ustar sun00315stepsC Last change: BCM 25 Nov 1998 12:27 pm SUBROUTINE rmlnvr(Priadj,Kfulsm,Nspobs) IMPLICIT NONE c----------------------------------------------------------------------- c Remove length of month or leap year regressor c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'picktd.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T PARAMETER(T=.true.) c----------------------------------------------------------------------- INTEGER Nspobs,Priadj,Kfulsm,icol,strinx EXTERNAL strinx c----------------------------------------------------------------------- c Reset prior adjustment variable c if type=trend specified in the x11 spec, then use lom or loq c adjustment (BCM, July 2005) c----------------------------------------------------------------------- IF(Priadj.eq.0)THEN IF(Kfulsm.eq.2)THEN IF(Sp.eq.12)THEN Priadj=2 ELSE IF(Sp.eq.4)THEN Priadj=3 END IF ELSE Priadj=4 END IF END IF c ------------------------------------------------------------------ c Check for length-of-period or leap year regressor and remove it. c ------------------------------------------------------------------ icol=1 DO WHILE (icol.gt.0) icol=strinx(T,Colttl,Colptr,1,Ncoltl,'Length-of-') IF(icol.eq.0)icol=strinx(T,Colttl,Colptr,1,Ncoltl,'Leap Year') IF(icol.gt.0)THEN CALL dlrgef(icol,Nspobs,1) IF(Lfatal)RETURN END IF END DO c ------------------------------------------------------------------ IF(Lndate(1).ne.NOTSET)THEN Lnzero=0 CALL setint(NOTSET,2,Lndate) END IF c ------------------------------------------------------------------ RETURN END rmlpyr.f0000664006604000003110000000547414521201556011700 0ustar sun00315steps SUBROUTINE rmlpyr(Trnsrs,Nobspf) IMPLICIT NONE c----------------------------------------------------------------------- c remove prior effects like leap year adjustments when trading day c factors are removed from the regression matrix and Picktd = true. c (BCM May 2004). c----------------------------------------------------------------------- LOGICAL F,T INTEGER DIV,MULT,PLOM,PLOQ PARAMETER(DIV=4,MULT=3,PLOM=2,PLOQ=3,F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'inpt.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' INCLUDE 'adj.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION Trnsrs,lomeff INTEGER Nobspf LOGICAL lom,begrgm DIMENSION Trnsrs(*),lomeff(PLEN),begrgm(PLEN) c----------------------------------------------------------------------- c Generate leap year effect c----------------------------------------------------------------------- IF(Priadj.eq.PLOM.or.Priadj.eq.PLOQ)THEN lom=T ELSE lom=F END IF IF(Lrgmtd.and.MOD(Tdzero,2).ne.0)THEN CALL gtrgpt(Begadj,Tddate,Tdzero,begrgm,Nadj) ELSE CALL setlg(T,PLEN,begrgm) END IF CALL td7var(Begadj,Sp,Nadj,1,1,lom,F,T,lomeff,begrgm) c----------------------------------------------------------------------- c Adjust the series for the length of month effect c----------------------------------------------------------------------- CALL eltfcn(DIV,Y(Frstsy),Adj(Adj1st),Nobspf,PLEN,Trnsrs) CALL eltfcn(MULT,Trnsrs,lomeff(Adj1st),Nobspf,PLEN,Trnsrs) IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF IF(Lfatal)RETURN CALL eltfcn(DIV,Adj(Adj1st),lomeff(Adj1st),Nobspf,PLEN, & Adj(Adj1st)) c----------------------------------------------------------------------- c copy updated adjustment factors into Sprior c----------------------------------------------------------------------- CALL copy(Adj,Nadj,-1,Sprior(Setpri)) c----------------------------------------------------------------------- c Update indicator variables c----------------------------------------------------------------------- Priadj=0 IF(Nustad.eq.0.and.Nuspad.eq.0)THEN Kfmt=0 IF(Lpradj)Lpradj=F END IF c----------------------------------------------------------------------- RETURN END rmotrv.f0000664006604000003110000001423214521201556011674 0ustar sun00315stepsC Last change: BCM 19 Jun 2002 5:41 pm SUBROUTINE rmotrv(Begxy,Begrev,Nrxy,Botr,Otrptr,Notrtl,Fixotr, & Otrttl,Lotlrv,Othndl,Lprt,Lsav,Lhdr) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine removes additive outliers from the regression c variables if they occur after the starting date of the revision c history analysis. These outliers will be saved so that they can c be reentered into the regression matrix when there is enough data. c----------------------------------------------------------------------- CHARACTER CPLUS*1 PARAMETER(CPLUS='+') c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' INCLUDE 'cchars.i' c----------------------------------------------------------------------- CHARACTER outstr*(PCOLCR*PB),datstr*(10),str*(PCOLCR), & Otrttl*(PCOLCR*PB) LOGICAL locok,Lprt,Lsav,Lhdr,Fixotr,Lotlrv INTEGER Begxy,otltyp,begotl,endotl,icol,Nrxy,Begrev,nchr,nreg, & Othndl,curdat,notlr,rtype,nchdat,nstr,Otrptr,Notrtl,n0,n1, & n2,limchr DOUBLE PRECISION Botr DIMENSION Otrptr(0:PB),Botr(PB),Fixotr(PB),Begxy(2),curdat(2) c----------------------------------------------------------------------- nreg=Notrtl+1 notlr=0 nchr=1 c----------------------------------------------------------------------- c Get character string for date of current observation. c----------------------------------------------------------------------- IF(Lsav.or.Lprt)THEN CALL addate(Begxy,Sp,Begrev-1,curdat) CALL wrtdat(curdat,Sp,datstr,nchdat) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Check outliers to see if any fall after the start of the c revisions history analysis c----------------------------------------------------------------------- icol=Nb endotl=0 DO WHILE (icol.ge.1) rtype=Rgvrtp(icol) IF(rtype.eq.PRGTAO.or.rtype.eq.PRGTLS.or.rtype.eq.PRGTRP.or. & rtype.eq.PRGTAA.or.rtype.eq.PRGTAL.or.rtype.eq.PRGTTC.or. & rtype.eq.PRGTQD.or.rtype.eq.PRGTQI.or. * & rtype.eq.PRGTTL)THEN & rtype.eq.PRGTAT.or.rtype.eq.PRGTSO.or.rtype.eq.PRGTTL)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nstr) IF(Lfatal)RETURN CALL rdotlr(str(1:nstr),Begxy,Sp,otltyp,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- IF(((otltyp.eq.RP.or.otltyp.eq.TLS).and.(begotl.gt.Begrev.or. & endotl.gt.Begrev)).or. & ((otltyp.ne.RP.and.otltyp.ne.TLS).and.begotl.gt.Begrev))THEN c----------------------------------------------------------------------- c Save the outlier and parameter estimate so that it can be c added back to the regression matrix later. c----------------------------------------------------------------------- IF(Lotlrv)THEN CALL insstr(str(1:nstr),nreg,PB,Otrttl,Otrptr,Notrtl) IF(Lfatal)RETURN Botr(Notrtl)=B(icol) Fixotr(Notrtl)=Regfx(icol) nreg=nreg+1 END IF c----------------------------------------------------------------------- c Delete outlier if it occurs after the start of the revision c history analysis c----------------------------------------------------------------------- CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN notlr=notlr+1 c----------------------------------------------------------------------- c update character string of outliers deleted. First, print header, c if necessary c----------------------------------------------------------------------- IF(Lhdr)THEN CALL rvrghd(Othndl,Mt1,Lsav,Lprt) IF(Lfatal)RETURN Lhdr=.false. END IF c----------------------------------------------------------------------- IF(Lprt.or.Lsav)THEN IF(nchr.gt.1)THEN outstr(nchr:nchr)=CPLUS nchr=nchr+1 END IF c----------------------------------------------------------------------- outstr(nchr:(nchr+nstr-1))=str(1:nstr) nchr=nchr+nstr END IF END IF END IF icol=icol-1 c----------------------------------------------------------------------- END DO c----------------------------------------------------------------------- c Print out and/or save outliers that were deleted, if any c----------------------------------------------------------------------- IF(Lsav.or.Lprt)THEN nchr=nchr-1 IF(Lprt.and.nchr.gt.0)THEN limchr=80 IF(Lwdprt)limchr=132 IF(nchr.le.limchr)THEN WRITE(Mt1,1030)datstr(1:nchdat),'deleted',outstr(1:nchr) ELSE n0=1 n1=1 n2=1 DO WHILE (n2.gt.0) n2=index(outstr(n1:nchr),'+') IF((n2+n1-n0+35).gt.limchr)THEN IF(n0.eq.1)THEN WRITE(Mt1,1030)datstr(1:nchdat),'deleted',outstr(n0:n1-1) ELSE WRITE(Mt1,1030)' ',' ',outstr(n0:n1-1) END IF n0=n1 END IF n1=n2+n1 END DO WRITE(Mt1,1030)' ',' ',outstr(n0:nchr) END IF END IF IF(Lsav)THEN IF(nchr.eq.0)THEN outstr(1:4)='none' nchr=nchr+3 IF(Lhdr)THEN CALL rvrghd(Othndl,Mt1,Lsav,Lprt) IF(Lfatal)RETURN Lhdr=.false. END IF END IF WRITE(Othndl,1010)datstr(1:nchdat),TABCHR,'deleted', & TABCHR,outstr(1:nchr) END IF END IF RETURN c----------------------------------------------------------------------- 1010 FORMAT(a,a,a,a,a) 1030 FORMAT(4x,a,t21,a,t36,a) END rmotss.f0000664006604000003110000000563014521201556011674 0ustar sun00315stepsC Last change: BCM 3 Sep 2003 3:59 pm SUBROUTINE rmotss(Icol,Begxy,Nrxy,Strtss,Starta,Enda,Botr,Otrptr, & Notrtl,Fixotr,Otrttl,Otlfix,Revchg) IMPLICIT NONE c----------------------------------------------------------------------- c Remove and store outliers before a sliding spans run. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER str*(PCOLCR),Otrttl*(PCOLCR*PB) DOUBLE PRECISION Botr LOGICAL Otlfix,locok,Revchg,Fixotr INTEGER nchr,Icol,otltyp,begotl,endotl,Strtss,Starta,Enda,sspos, & sspos1,sspos2,nreg,Begxy,Nrxy,Otrptr,Notrtl DIMENSION Otrptr(0:PB),Botr(PB),Fixotr(PB),Strtss(2),Starta(2), & Enda(2),Begxy(2) c----------------------------------------------------------------------- nreg=Notrtl+1 CALL getstr(Colttl,Colptr,Ncoltl,Icol,str,nchr) IF(Lfatal)RETURN CALL rdotlr(str(1:nchr),Begxy,Sp,otltyp,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Delete the outlier if it falls before the start of the first c sliding span. c----------------------------------------------------------------------- CALL dfdate(Strtss,Begxy,Sp,sspos) sspos=sspos+1 IF(begotl.lt.sspos)THEN IF(.not.Revchg)Revchg=.true. CALL dlrgef(Icol,Nrxy,1) RETURN END IF c----------------------------------------------------------------------- c If outlier will be undefined in one or more spans, save the c outlier and parameter estimate so it can be added back to the c regression matrix later, then delete the outlier variable. c----------------------------------------------------------------------- CALL dfdate(Starta,Begxy,Sp,sspos1) sspos1=sspos1+1 CALL dfdate(Enda,Begxy,Sp,sspos2) sspos2=sspos2+1 IF( & (otltyp.eq.AO.and.((begotl.lt.sspos1).or.(begotl.gt.sspos2))).or. & (otltyp.eq.LS.and.((begotl.le.sspos1).or.(begotl.ge.sspos2))).or. & (otltyp.eq.SO.and.((begotl.le.sspos1).or.(begotl.ge.sspos2))).or. & (otltyp.eq.TC.and.((begotl.lt.sspos1).or.(begotl.gt.sspos2))) & .or. & (otltyp.eq.RP.and.(.not.(begotl.gt.sspos1.and.begotl.lt.sspos2))) & )THEN Revchg=.true. CALL insstr(str(1:nchr),nreg,PB,Otrttl,Otrptr,Notrtl) IF(Lfatal)RETURN Botr(Notrtl)=B(Icol) Fixotr(Notrtl)=Regfx(Icol).or.Otlfix CALL dlrgef(Icol,Nrxy,1) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- RETURN END rmpadj.f0000664006604000003110000000411214521201556011614 0ustar sun00315stepsC Last change: BCM 12 Mar 98 9:52 am SUBROUTINE rmpadj(Series,Sprior,Pos1,Pos2,Muladd) IMPLICIT NONE c ------------------------------------------------------------------ c Remove the permanent prior adjustment factors from the final c seasonally adjusted series. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'lzero.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION Series,Sprior INTEGER i,i2,i3,Muladd,Pos1,Pos2 DIMENSION Series(*),Sprior(*) c ------------------------------------------------------------------ c If no predetermined prior adjustments => adjust by Usrpad c If predetermined prior adjustments & no temporary prior c adjustments => adjust by Sprior c If predetermined prior adjustments & temporary prior adjustments c => adjust by Sprior minus/divided Usrtad c ------------------------------------------------------------------ DO i=Pos1,Pos2 i2=Frstap+i-Pos1+Lsp-1 IF(Muladd.eq.1)THEN c ------------------------------------------------------------------ IF(Priadj.le.1)THEN Series(i)=Series(i)-Usrpad(i2) ELSE IF(Nustad.eq.0)THEN Series(i)=Series(i)-Sprior(i) ELSE i3=Frstat+i-Pos1+Lsp-1 Series(i)=Series(i)-(Sprior(i)-Usrtad(i3)) END IF END IF ELSE IF(Priadj.LE.1)THEN Series(i)=Series(i)/Usrpad(i2) ELSE IF(Nustad.eq.0)THEN Series(i)=Series(i)/Sprior(i) ELSE i3=Frstat+i-Pos1+Lsp-1 Series(i)=Series(i)/(Sprior(i)/Usrtad(i3)) END IF END IF END IF END DO c ------------------------------------------------------------------ RETURN c ------------------------------------------------------------------ END rmtadj.f0000664006604000003110000000411114521201556011617 0ustar sun00315stepsC Last change: BCM 12 Mar 98 9:53 am SUBROUTINE rmtadj(Series,Sprior,Pos1,Pos2,Muladd) IMPLICIT NONE c ------------------------------------------------------------------ c Remove the permanent prior adjustment factors from the final c seasonally adjusted series. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'lzero.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION Series,Sprior INTEGER i,i2,i3,Muladd,Pos1,Pos2 DIMENSION Series(*),Sprior(*) c ------------------------------------------------------------------ c If no predetermined prior adjustments => adjust by Usrtad c If predetermined prior adjustments & no permanent prior c adjustments => adjust by Sprior c If predetermined prior adjustments & permanent prior adjustments c => adjust by Sprior minus/divided Usrpad c ------------------------------------------------------------------ DO i=Pos1,Pos2 i2=Frstat+i-Pos1+Lsp-1 IF(Muladd.eq.1)THEN c ------------------------------------------------------------------ IF(Priadj.le.1)THEN Series(i)=Series(i)-Usrtad(i2) ELSE IF(Nuspad.eq.0)THEN Series(i)=Series(i)-Sprior(i) ELSE i3=Frstap+i-Pos1+Lsp-1 Series(i)=Series(i)-(Sprior(i)-Usrpad(i3)) END IF END IF ELSE IF(Priadj.LE.1)THEN Series(i)=Series(i)/Usrtad(i2) ELSE IF(Nustad.eq.0)THEN Series(i)=Series(i)/Sprior(i) ELSE i3=Frstap+i-Pos1+Lsp-1 Series(i)=Series(i)/(Sprior(i)/Usrpad(i3)) END IF END IF END IF END DO c ------------------------------------------------------------------ RETURN c ------------------------------------------------------------------ END rndsa.f0000664006604000003110000001221214521201556011446 0ustar sun00315stepsc Last change: Mar. 2021 C previous change: BCM 17 Apr 2003 11:17 pm SUBROUTINE rndsa(Sa,Sarnd,L1,L2,Rndok) IMPLICIT NONE c ------------------------------------------------------------------- c Round the seasonally adjusted values so that they sum to the same c value as the rounded annual total, as in the UK version of X-11. c Author: Brian C. Monsell - August 1995 c ------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'units.cmn' INCLUDE 'x11opt.cmn' c ------------------------------------------------------------------- * DOUBLE PRECISION ILIM LOGICAL F,T * PARAMETER(ILIM=2147483647D0) PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------- CHARACTER thisvl*(21) DOUBLE PRECISION c,cindx,Sa,sumx,X,Sarnd,thisx LOGICAL Rndok INTEGER j,L1,L2,ll1,ll2,r,sumr,d,round,ij,nn DIMENSION Sa(*),Sarnd(*),X(PSP),c(PSP),r(PSP),cindx(PSP), & thisx(PSP) EXTERNAL round c ------------------------------------------------------------------- c initialize variables c ------------------------------------------------------------------- Rndok=T ll1=L1 IF((ll1/Ny)*Ny.eq.ll1)THEN x(1) = SA(ll1)*(10D0**Kdec) r(1) = round(x(1)) Sarnd(ll1)= r(1)/(10D0**Kdec) ll1=ll1+1 END IF DO WHILE (ll1.le.L2) sumx=0D0 sumr=0 ll2=((ll1/Ny)+1)*Ny IF(ll2.gt.L2)ll2=L2 c ------------------------------------------------------------------- c begin looping through every year of seasonally adjusted data. c ------------------------------------------------------------------- DO ij=ll1,ll2 j=ij-ll1+1 cindx(j)=dble(j) c ------------------------------------------------------------------- c multiply observations by 10^(# of significant digits in output) and c see if this number can be represented as an integer. If not, exit c subroutine c ------------------------------------------------------------------- x(j)=SA(ij)*(10D0**Kdec) IF(x(j).gt.1000D0)THEN write(thisvl,1000)x(j) thisvl(18:20)='000' read(thisvl,1000)thisx(j) x(j)=x(j)-thisx(j) 1000 FORMAT(f21.0) ELSE thisx(j)=0D0 END IF * IF(ABS(x(j)).gt.ILIM)THEN * CALL writln('ERROR: Cannot perform rounding on seasonally adjus * &ted series:',STDERR,Mt2,T) * CALL writln(' observation too large to be represented as * &an integer.',STDERR,Mt2,F) * Rndok=F * RETURN * END IF c ------------------------------------------------------------------- c round seasonally adjusted numbers to integers, and store the c difference between the rounded and original figures. c ------------------------------------------------------------------ r(j)=round(x(j)) c(j)=dble(r(j))-x(j) sumx=sumx+x(j) * IF((ABS(sumx).gt.ILIM).OR.((ILIM-sumr).lt.r(j)))THEN * CALL writln('ERROR: Cannot perform rounding on seasonally adjus * &ted series:',STDERR,Mt2,T) * CALL writln(' yearly total too large to be represented as * & an integer.',STDERR,Mt2,F) * Rndok=F * RETURN * END IF sumr=sumr+r(j) END DO c ------------------------------------------------------------------ c Determine the difference between the rounded yearly total and the c total of the rounded observations. c ------------------------------------------------------------------ d=round(sumx)-sumr c ------------------------------------------------------------------- c Sort the differences c ------------------------------------------------------------------- nn=ll2-ll1+1 CALL ssort(c,cindx,nn,2) c ------------------------------------------------------------------- c if d is greater than zero, add 1 to the observations with the c d largest differences in c. c ------------------------------------------------------------------- IF(d.gt.0)THEN DO j=nn,nn-d+1 ij=int(cindx(j)) r(ij)=r(ij)+1 END DO c ------------------------------------------------------------------- c if d is less than zero, subract 1 from the observations with the c d largest smallest in c. c ------------------------------------------------------------------- ELSE IF(d.lt.0)THEN DO j=1,d ij=int(cindx(j)) r(ij)=r(ij)-1 END DO END IF c ------------------------------------------------------------------- c Store result into Sarnd. c ------------------------------------------------------------------- DO ij=ll1,ll2 j=ij-ll1+1 Sarnd(ij)=(thisx(j)+dble(r(j)))/(10D0**Kdec) END DO ll1=ll2+1 END DO c ------------------------------------------------------------------- RETURN END rngbuf.f0000664006604000003110000001452714521201557011636 0ustar sun00315stepsC Last change: BCM 13 May 2005 1:42 pm LOGICAL FUNCTION rngbuf(Cmd,Linno,Lin,Linln) c----------------------------------------------------------------------- c rngbuf.f, Release 1, Subroutine Version 1.2, Modified 03 Feb 1995. c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'lex.i' INCLUDE 'cchars.i' INCLUDE 'stdio.i' c ----------------------------------------------------------------- LOGICAL PFAIL,PSCCD PARAMETER(PFAIL=.false.,PSCCD=.true.) c ----------------------------------------------------------------- CHARACTER Lin*(*),nxtchr INTEGER Cmd,i,Linln,Linno c ----------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- LOGICAL psteof CHARACTER buf(0:PBUFSZ-1)*(LINLEN) INTEGER bufln(0:PBUFSZ-1),begbuf,endbuf,crntbf,crntln SAVE buf,bufln,begbuf,endbuf,crntbf,crntln,psteof c----------------------------------------------------------------------- c Which command c----------------------------------------------------------------------- rngbuf=PSCCD c ----------------------------------------------------------------- GO TO(10,20,50,60),Cmd WRITE(STDERR,*)'System error: illegal buffer request,',Cmd CALL abend() RETURN c----------------------------------------------------------------------- c Initialize the Buffer c----------------------------------------------------------------------- 10 crntln=0 begbuf=PBUFSZ-1 endbuf=PBUFSZ-1 crntbf=endbuf bufln(0)=0 psteof=.false. Lexok=.true. GO TO 80 c----------------------------------------------------------------------- c Read the next line and fail if EOF c----------------------------------------------------------------------- 20 IF(psteof)GO TO 70 c----------------------------------------------------------------------- c Read in a new line if necessary c----------------------------------------------------------------------- IF(crntbf.eq.endbuf)THEN READ(Inputx,1010,END=70)Lin 1010 FORMAT(a) c ----------------------------------------------------------------- endbuf=mod(endbuf+1,PBUFSZ) IF(begbuf.eq.endbuf)begbuf=mod(begbuf+1,PBUFSZ) crntbf=mod(crntbf+1,PBUFSZ) c----------------------------------------------------------------------- c Tack on an EOL c----------------------------------------------------------------------- Linln=nblank(Lin) Linln=Linln+1 IF(Linln.gt.LINLEN)THEN WRITE(STDERR,*)' ERROR: Input record longer than limit :', & LINLEN CALL abend() RETURN END IF Lin(Linln:Linln)=NEWLIN c----------------------------------------------------------------------- c Filter out all unprintable characters c----------------------------------------------------------------------- i=1 c ----------------------------------------------------------------- DO WHILE (.true.) * i=i+1 c ----------------------------------------------------------------- IF(i.lt.Linln)THEN nxtchr=Lin(i:i) c ----------------------------------------------------------------- c Change by BCM to allow tab characters to be read in spec file c and not skipped over - May 2005 c ----------------------------------------------------------------- IF((nxtchr.lt.' '.or.nxtchr.gt.'~').and. & (.not.(nxtchr.eq.TABCHR)))THEN C CALL inpter(PERROR,Pos,'Skipped over unprintable character her C &e') Lin(i:Linln-1)=Lin(i+1:Linln) Linln=Linln-1 c ----------------------------------------------------------------- ELSE i=i+1 END IF GO TO 30 END IF c ----------------------------------------------------------------- GO TO 40 30 CONTINUE END DO c----------------------------------------------------------------------- c Store the next line in the buffer and return c----------------------------------------------------------------------- 40 buf(endbuf)=Lin bufln(endbuf)=Linln c ----------------------------------------------------------------- ELSE crntbf=mod(crntbf+1,PBUFSZ) Lin=buf(crntbf) Linln=bufln(crntbf) END IF c ----------------------------------------------------------------- crntln=crntln+1 Linno=crntln GO TO 80 c----------------------------------------------------------------------- c Push back the last line on to the stack c----------------------------------------------------------------------- 50 IF(crntbf.eq.begbuf)THEN rngbuf=PFAIL Linln=0 c----------------------------------------------------------------------- c If we are at the EOF we don't need to back up, just return the c last line in the file. c----------------------------------------------------------------------- ELSE IF(.not.psteof)THEN crntbf=mod(crntbf+PBUFSZ-1,PBUFSZ) crntln=crntln-1 END IF c ----------------------------------------------------------------- Lin=buf(crntbf) Linln=bufln(crntbf) Linno=crntln psteof=.false. END IF GO TO 80 c----------------------------------------------------------------------- c Get a line Lineno and fail if the line isn't in the buffer c----------------------------------------------------------------------- 60 IF(Linno.lt.crntln-mod(crntbf+PBUFSZ-begbuf,PBUFSZ).or. & Linno.gt.crntln)THEN rngbuf=PFAIL Linln=0 c ----------------------------------------------------------------- ELSE i=mod(crntbf+Linno-crntln+PBUFSZ,PBUFSZ) Lin=buf(i) Linln=bufln(i) END IF c END CASE STATEMENT GO TO 80 c----------------------------------------------------------------------- c Reached the EOF c----------------------------------------------------------------------- 70 Lin(1:1)=CHREOF Linln=1 psteof=.true. rngbuf=PFAIL c ----------------------------------------------------------------- 80 RETURN END rngbuf.g77.f0000664006604000003110000001104414521201557012230 0ustar sun00315stepsC Last change: BCM 13 May 2005 1:42 pm LOGICAL FUNCTION rngbuf(Cmd,Linno,Lin,Linln) c----------------------------------------------------------------------- c rngbuf.f, Release 1, Subroutine Version 1.2, Modified 03 Feb 1995. c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'lex.i' INCLUDE 'cchars.i' INCLUDE 'stdio.i' INCLUDE 'error.cmn' c ----------------------------------------------------------------- LOGICAL PFAIL,PSCCD PARAMETER(PFAIL=.false.,PSCCD=.true.) c ----------------------------------------------------------------- CHARACTER Lin*(*),nxtchr INTEGER Cmd,i,Linln,Linno c ----------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- LOGICAL psteof CHARACTER buf(0:PBUFSZ-1)*(LINLEN) INTEGER bufln(0:PBUFSZ-1),begbuf,endbuf,crntbf,crntln SAVE buf,bufln,begbuf,endbuf,crntbf,crntln,psteof c----------------------------------------------------------------------- c Which command c----------------------------------------------------------------------- rngbuf=PSCCD c ----------------------------------------------------------------- GO TO(10,20,50,60),Cmd WRITE(STDERR,*)'System error: illegal buffer request,',Cmd CALL abend() RETURN c----------------------------------------------------------------------- c Initialize the Buffer c----------------------------------------------------------------------- 10 crntln=0 begbuf=PBUFSZ-1 endbuf=PBUFSZ-1 crntbf=endbuf bufln(0)=0 psteof=.false. Lexok=.true. GO TO 80 c----------------------------------------------------------------------- c Read the next line and fail if EOF c----------------------------------------------------------------------- 20 IF(psteof)GO TO 70 c----------------------------------------------------------------------- c Read in a new line if necessary c----------------------------------------------------------------------- IF(crntbf.eq.endbuf)THEN READ(Inputx,1010,END=70)Lin 1010 FORMAT(a) CALL upbuf(Linno,Lin,Linln,buf,bufln,begbuf,endbuf,crntbf) IF(Lfatal)RETURN c ----------------------------------------------------------------- ELSE crntbf=mod(crntbf+1,PBUFSZ) Lin=buf(crntbf) Linln=bufln(crntbf) END IF c ----------------------------------------------------------------- crntln=crntln+1 Linno=crntln GO TO 80 c----------------------------------------------------------------------- c Push back the last line on to the stack c----------------------------------------------------------------------- 50 IF(crntbf.eq.begbuf)THEN rngbuf=PFAIL Linln=0 c----------------------------------------------------------------------- c If we are at the EOF we don't need to back up, just return the c last line in the file. c----------------------------------------------------------------------- ELSE IF(.not.psteof)THEN crntbf=mod(crntbf+PBUFSZ-1,PBUFSZ) crntln=crntln-1 END IF c ----------------------------------------------------------------- Lin=buf(crntbf) Linln=bufln(crntbf) Linno=crntln psteof=.false. END IF GO TO 80 c----------------------------------------------------------------------- c Get a line Lineno and fail if the line isn't in the buffer c----------------------------------------------------------------------- 60 IF(Linno.lt.crntln-mod(crntbf+PBUFSZ-begbuf,PBUFSZ).or. & Linno.gt.crntln)THEN rngbuf=PFAIL Linln=0 c ----------------------------------------------------------------- ELSE i=mod(crntbf+Linno-crntln+PBUFSZ,PBUFSZ) Lin=buf(i) Linln=bufln(i) END IF c END CASE STATEMENT GO TO 80 c----------------------------------------------------------------------- c Reached the EOF c----------------------------------------------------------------------- 70 Linln=nblank(Lin) IF(Linln.gt.0)THEN CALL upbuf(Linno,Lin,Linln,buf,bufln,begbuf,endbuf,crntbf) IF(Lfatal)RETURN END IF Lin(1:1)=CHREOF Linln=1 psteof=.true. rngbuf=PFAIL c ----------------------------------------------------------------- 80 RETURN END roots.f0000664006604000003110000001053614521201557011515 0ustar sun00315stepsC Last change: BCM 14 May 1998 9:17 am SUBROUTINE roots(Thetab,Degree,Allinv,Zeror,Zeroi,Zerom,Zerof) IMPLICIT NONE c----------------------------------------------------------------------- c Find the modulus and frequency of the roots of a polynomial c c THETAB - double precision vector of coefficients of THETA(B) in c order of increasing powers c DEGREE - maximum lag of MA model (i.e. the degree of THETA(B)) c ALLINV - output logical; true if all the zeros of the input c THETAB are invertible. c ZEROR - output double precision vector of the real parts of the c roots c ZEROI - output double precision vector of the imaginary parts of c the roots c ZEROM - output double precision vector of the modulus of the c roots c ZEROF - output double precision vector of the frequency of the c roots c c The first two parameters are the input and also the output. c Parameter DEGREE may change if the input leading coefficient of c THETA(B) is near 0.0. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'units.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO,ONE PARAMETER(ZERO=0D0,ONE=1D0) c ------------------------------------------------------------------ DOUBLE PRECISION op,Zeror,Zeroi,Thetab,Zerom,Zerof INTEGER Degree,i,degp1 LOGICAL fail,Allinv DIMENSION op(PORDER+1),Zeror(PORDER),Zeroi(PORDER), & Thetab(PORDER+1),Zerom(PORDER),Zerof(PORDER) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ degp1=Degree+1 c----------------------------------------------------------------------- c Reverse thetab to op in order of decreasing powers c----------------------------------------------------------------------- CALL revrse(Thetab,degp1,1,op) c----------------------------------------------------------------------- c Check the coefficient of the highest degree to see if it is c near zero. If there are no roots then exit because there is nothing c to check. c----------------------------------------------------------------------- DO WHILE (dpeq(op(1),ZERO)) IF(Degree.eq.1)THEN Allinv=.true. c ------------------------------------------------------------------ c reduce degree of polynomial by one before exiting routine c BCM January 2007 c ------------------------------------------------------------------ Degree=Degree-1 GO TO 10 END IF c ------------------------------------------------------------------ DO i=1,Degree op(i)=op(i+1) END DO Degree=Degree-1 END DO c----------------------------------------------------------------------- c Find the roots of the polynomial equation c----------------------------------------------------------------------- CALL rpoly(op,Degree,Zeror,Zeroi,fail) c----------------------------------------------------------------------- c Compute the modulus and frequency of each zero complex roots c are g(i) and g(i+1) c----------------------------------------------------------------------- IF(.not.fail)THEN Allinv=.true. i=0 c ------------------------------------------------------------------ DO WHILE (i.lt.Degree) i=i+1 Zerom(i)=sqrt(Zeror(i)**2+Zeroi(i)**2) Zerof(i)=datan2(Zeroi(i),Zeror(i))/6.28318730707959D0 IF((Zerom(i).lt.ONE).and.Allinv)Allinv=.false. c ------------------------------------------------------------------ IF(.not.dpeq(Zeroi(i),ZERO))THEN i=i+1 Zerom(i)=Zerom(i-1) Zerof(i)=ZERO-Zerof(i-1) END IF END DO c ------------------------------------------------------------------ ELSE IF(.not.Lquiet)WRITE(STDERR,1010) WRITE(Mt1,1010) 1010 FORMAT(' WARNING: Not all zeros of the AR or MA polynomial were', & 'found.') END IF c ------------------------------------------------------------------ 10 RETURN END round.f0000664006604000003110000000137214521201557011474 0ustar sun00315stepsC Last change: BCM 3 Aug 1998 12:53 pm INTEGER FUNCTION round(x) IMPLICIT NONE c ------------------------------------------------------------------- c Round x, returning an integer c ------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION X,ceilng,c1,c2 EXTERNAL ceilng,dpeq c ------------------------------------------------------------------- c1=ceilng(X-0.5D0) c2=ceilng(X) IF(dpeq(c1,c2))THEN round=idint(c2) ELSE IF(dpeq(c1,X-0.5D0))THEN round=idint(c2) ELSE round=idint(c2)-1 END IF c ------------------------------------------------------------------- RETURN END rplus.f0000664006604000003110000001600414521201557011510 0ustar sun00315stepsC Last change: BCM 20 May 1998 11:10 am SUBROUTINE rplus(X,I,Nopt,Nop2,Mpd,Numyr,Numpr,Ncol,Ssdiff) IMPLICIT NONE c----------------------------------------------------------------------- c ***** this subroutine computes the maximum percentage difference c ***** r for observation i over ncol spans, and determines if c ***** this month should be flagged. monthly (aobs) and yearly c ***** (ymon) averages of the maximum percentage difference are c ***** incremented, as well as the sliding spans histogram values c ***** (kount) and the number of months flagged for each month c ***** (nobs) and year (nyr). determines if the estimates for c ***** observation i have undergone a change of direction. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'notset.prm' INCLUDE 'ssap.cmn' INCLUDE 'sspvec.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONEHND,ZERO PARAMETER(ONEHND=100D0,ZERO=0D0) c----------------------------------------------------------------------- LOGICAL Lsaneg,Ssdiff DOUBLE PRECISION Mpd,X,xbase,xj,xmn,xmx,Saabav INTEGER I,ibase,ij,iy,j,j2,jay,jay2,jay3,jbase,k,mon,Nop2,Nopt, & Numyr,Numpr,year,Ncol,temp DIMENSION X(MXLEN,MXCOL),Numyr(MXYR),Numpr(PSP) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- COMMON /addneg/ Saabav,Lsaneg c----------------------------------------------------------------------- mon=mod(I,Nsea) IF(mon.eq.0)mon=Nsea iy=(I-1)/Nsea year=Iyr+iy temp=0 Csign(I,Nopt)=0 c----------------------------------------------------------------------- c Find the earliest span with a value of X that is defined (jay) c----------------------------------------------------------------------- j=1 DO WHILE (dpeq(X(I,j),DNOTST)) j=j+1 END DO jay=j c----------------------------------------------------------------------- c Compute the minimum and maximum value of X for observation I, c and also the latest span with a value (jay2). c----------------------------------------------------------------------- xmx=X(I,j) xmn=X(I,j) DO j2=jay,Ncol IF(.not.dpeq(X(I,j2),DNOTST))THEN IF(xmx.lt.X(I,j2))xmx=X(I,j2) IF(xmn.gt.X(I,j2))xmn=X(I,j2) j=j2 END IF END DO jay2=j c----------------------------------------------------------------------- c Compute the maximum percentage difference (Mpd) c----------------------------------------------------------------------- Mpd=xmx-xmn IF((.not.Ssdiff).and.Nop2.eq.0)THEN IF(Lsaneg.and.(xmx.gt.0.and.xmn.lt.0))THEN Mpd=(Mpd/Saabav)*ONEHND ELSE IF(xmn.gt.0)THEN Mpd=(Mpd/xmn)*ONEHND ELSE Mpd=(Mpd/abs(xmx))*ONEHND END IF END IF c----------------------------------------------------------------------- c If observation I is before starting date of sliding spans c comparisons, set label to dashes c----------------------------------------------------------------------- IF(I.lt.Ic)THEN Per(I,Nopt)=-1 RETURN END IF c----------------------------------------------------------------------- c If trading day factors done, adjust total number of trading day c comparisons if observation tested is a non-leap year february. c----------------------------------------------------------------------- IF(Nopt.eq.2.and.Nsea.eq.12.and.mon.eq.2.and.mod(year,4).gt.0)THEN Itot(Nopt)=Itot(Nopt)-1 ELSE c----------------------------------------------------------------------- c Update number of observations tested for a given year, month c----------------------------------------------------------------------- Numpr(mon)=Numpr(mon)+1 Numyr(iy)=Numyr(iy)+1 END IF c----------------------------------------------------------------------- c If maximum percent difference is greater than cutoff value, c set label, histogram variables to reflect magnitude of Mpd. c----------------------------------------------------------------------- IF((.not.Ssdiff).and.Mpd.ge.Cut(Nopt,1))THEN DO k=1,4 IF(Mpd.ge.Cut(Nopt,k))THEN temp=temp+1 Kount(Nopt,k)=Kount(Nopt,k)+1 END IF END DO Per(I,Nopt)=temp c----------------------------------------------------------------------- c Also increment counters for number of observations flagged, as c well as number of observations within each calendar month/quarter c and year. c----------------------------------------------------------------------- Ntot(Nopt)=Ntot(Nopt)+1 SSnobs(mon,Nopt)=SSnobs(mon,Nopt)+1 SSnyr(iy,Nopt)=SSnyr(iy,Nopt)+1 END IF c----------------------------------------------------------------------- c Add maximum percent difference to variables used to compute the c average MPD for given calendar months/quarters and years. c----------------------------------------------------------------------- Aobs(mon,Nopt)=Aobs(mon,Nopt)+Mpd Ayr(iy,Nopt)=Ayr(iy,Nopt)+Mpd c----------------------------------------------------------------------- c Check to see if there is a turning point over the spans c----------------------------------------------------------------------- Cturn(I,Nopt)=0 jay3=jay2-jay+1 IF(jay3.ge.3)THEN ibase=0 jbase=0 c ittot=ittot+1 DO j=jay+1,jay2 IF(Cturn(I,Nopt).eq.0)THEN xj=X(I,j)-X(I,j-1) IF(xj.lt.ZERO)ibase=-1 IF(xj.gt.ZERO)ibase=1 IF(jbase.eq.0)THEN jbase=ibase ELSE IF(ibase.ne.jbase)THEN IF((.not.Ssdiff).and.Nop2.eq.0)xj=(xj/X(I,j-1))*ONEHND IF(abs(xj).gt.1)THEN Iturn(Nopt)=Iturn(Nopt)+1 Cturn(I,Nopt)=1 ELSE jbase=ibase END IF END IF END IF END DO END IF c----------------------------------------------------------------------- c Check to see if there is a change in sign over the spans (except c if the seasonally adjusted data is being analyzed). c----------------------------------------------------------------------- IF(Nopt.eq.3)RETURN jbase=0 xbase=ONEHND IF(Ssdiff.or.Nop2.gt.0)xbase=ZERO DO j=jay,jay2 IF(X(I,j).lt.xbase)THEN ibase=-1 ELSE IF(X(I,j).gt.xbase)THEN ibase=1 ELSE ibase=0 END IF IF(jbase.eq.0)THEN jbase=ibase ELSE ij=ibase+jbase IF(ij.eq.0)THEN Chsgn(Nopt)=Chsgn(Nopt)+1 Csign(I,Nopt)=1 RETURN END IF END IF END DO RETURN END rpoly.f0000664006604000003110000003210514521201557011510 0ustar sun00315stepsC Last change: BCM 25 Nov 97 3:27 pm SUBROUTINE rpoly(Op,Degree,Zeror,Zeroi,Fail) IMPLICIT NONE C ********************************************************************** C * * C * FINDS THE ZEROS OF A REAL POLYNOMIAL * C * * C * OP - DOUBLE PRECISION VECTOR OF COEFFICIENTS IN ORDER OF * C * DECREASING POWERS. * C * DEGREE - INTEGER DEGREE OF POLYNOMIAL. * C * ZEROR - OUTPUT DOUBLE PRECISION VECTOR OF REAL PARTS OF THE * C * ZEROS. * C * ZEROI - OUTPUT DOUBLE PRECISION VECTOR OF IMAGINARY PARTS OF * C * THE ZEROS. * C * FAIL - OUTPUT LOGICAL PARAMETER, TRUE ONLY IF LEADING * C * COEFFICIENT IS ZERO OR IF RPOLY HAS FOUND FEWER THAN * C * DEGREE ZEROS. IN THE LATTER CASE DEGREE IS RESET TO * C * THE NUMBER OF ZEROS FOUND. * C * * C * TO CHANGE THE SIZE OF POLYNOMIALS WHICH CAN BE SOLVED, RESET * C * THE DIMENSIONS OF THE ARRAYS IN THE COMMON AREA AND IN THE * C * FOLLOWING DECLARATIONS. THE SUBROUTINE USES SINGLE PRECISION * C * CALCULATIONS FOR SCALING, BOUNDS AND ERROR CALCULATIONS. ALL * C * CALCULATIONS FOR THE ITERATIONS ARE DONE IN DOUBLE PRECISION. * C * * C * ******************************************************************** INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'global.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION ZERO,TEN,ONE PARAMETER(ZERO=0D0,TEN=10D0,ONE=1D0) C----------------------------------------------------------------------- DOUBLE PRECISION Op,temp,Zeror,Zeroi,t,aa,bb,cc,dabs,factor DOUBLE PRECISION lo,xmax,xmin,xx,yy,cosr,sinr,xxx,x,bnd,xm,ff,df, & dx,pt,sc,base,infin,smalno INTEGER Degree,cnt,nz,i,j,jj,nm1,l LOGICAL Fail,zerok DIMENSION Op(PORDER+1),temp(PORDER+1),Zeror(PORDER), & pt(PORDER+1),Zeroi(PORDER) C----------------------------------------------------------------------- c DOUBLE PRECISION dpmpar c EXTERNAL dpmpar LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- C THE FOLLOWING STATEMENTS SET MACHINE CONSTANTS USED IN VARIOUS PARTS C OF THE PROGRAM. THE MEANING OF THE FOUR CONSTANTS ARE... C ETA THE MAXIMUM RELATIVE REPRESENTATION ERROR WHICH CAN BE C DESCRIBED AS THE SMALLEST POSITIVE FLOATING POINT NUMBER SUCH C THAT 1.D0+ETA IS GREATER THAN 1. C INFINY THE LARGEST FLOATING-POINT NUMBER. C SMALNO THE SMALLEST POSITIVE FLOATING-POINT NUMBER IF THE EXPONENT C RANGE DIFFERS IN SINGLE AND DOUBLE PRECISION THEN SMALNO AND C INFINY SHOULD INDICATE THE SMALLER RANGE. C BASE THE BASE OF THE FLOATING-POINT NUMBER SYSTEM USED. C THE VALUES BELOW CORRESPOND TO THE BURROUGHS B6700 C----------------------------------------------------------------------- C C The following constants came from page 9 of "Numerical Computation C Guide" by Sun Workstation C base=TEN Eta=.5D0*base**(1-15) infin=1.797D30 smalno=1.0D-38 C The following numbers correspondent to B6700 c base=8. c Eta=.5*base**(1-26) c infin=4.3E68 c smalno=1.0E-45 c c Eta=dpmpar(1) c infin=dpmpar(3) c smalno=dpmpar(2) C----------------------------------------------------------------------- C ARE AND MRE REFER TO THE UNIT ERROR IN + AND * RESPECTIVELY. C THEY ARE ASSUMED TO BE THE SAME AS ETA. C----------------------------------------------------------------------- Are=Eta Mre=Eta lo=smalno/Eta C----------------------------------------------------------------------- C INITIALIZATION OF CONSTANTS FOR SHIFT ROTATION C----------------------------------------------------------------------- xx=.70710678D0 yy=-xx cosr=-.069756474D0 sinr=.99756405D0 Fail=.false. N=Degree N0=N+1 C----------------------------------------------------------------------- C ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO. C----------------------------------------------------------------------- IF(.not.dpeq(Op(1),ZERO))THEN C----------------------------------------------------------------------- C REMOVE THE ZEROS AT THE ORIGIN IF ANY C----------------------------------------------------------------------- DO WHILE (dpeq(Op(N0),ZERO)) j=Degree-N+1 Zeror(j)=ZERO Zeroi(j)=ZERO N0=N0-1 N=N-1 END DO C----------------------------------------------------------------------- C MAKE A COPY OF THE COEFFICIENTS C----------------------------------------------------------------------- DO i=1,N0 P0(i)=Op(i) END DO ELSE Fail=.true. Degree=0 RETURN END IF C----------------------------------------------------------------------- C START THE ALGORITHM FOR ONE ZERO C----------------------------------------------------------------------- 10 IF(N.gt.2)THEN C----------------------------------------------------------------------- C FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS. C----------------------------------------------------------------------- xmax=ZERO xmin=infin c ------------------------------------------------------------------ DO i=1,N0 x=abs(P0(i)) IF(x.gt.xmax)xmax=x IF((.not.dpeq(x,ZERO)).and.x.lt.xmin)xmin=x END DO c ------------------------------------------------------------------ ELSE IF(N.lt.1)RETURN C----------------------------------------------------------------------- C CALCULATE THE FINAL ZERO OR PAIR OF ZEROS C----------------------------------------------------------------------- IF(N.eq.2)THEN CALL quad(P0(1),P0(2),P0(3),Zeror(Degree-1),Zeroi(Degree-1), & Zeror(Degree),Zeroi(Degree)) c ------------------------------------------------------------------ ELSE Zeror(Degree)=-P0(2)/P0(1) Zeroi(Degree)=ZERO END IF RETURN END IF C----------------------------------------------------------------------- C SCALE IF THERE ARE LARGE OR VERY SMALL COEFFICIENTS COMPUTES A SCALE C FACTOR TO MULTIPLY THE COEFFICIENTS OF THE POLYNOMIAL. THE SCALING IS C DONE TO AVOID OVERFLOW AND TO AVOID UNDETECTED UNDERFLOW INTERFERING C WITH THE CONVERGENCE CRITERION. THE FACTOR IS A POWER OF THE BASE C----------------------------------------------------------------------- sc=lo/xmin c ------------------------------------------------------------------ IF(sc.le.ONE)THEN IF(xmax.lt.TEN)GO TO 20 IF(dpeq(sc,ZERO))sc=smalno c ------------------------------------------------------------------ ELSE IF(infin/sc.lt.xmax)THEN GO TO 20 END IF c ------------------------------------------------------------------ l=idint(dlog(sc)/dlog(base)+.5D0) factor=(base*ONE)**l c ------------------------------------------------------------------ IF(.not.dpeq(factor,ONE))THEN DO i=1,N0 P0(i)=factor*P0(i) END DO END IF C----------------------------------------------------------------------- C COMPUTE LOWER BOUND ON MODULI OF ZEROS. C----------------------------------------------------------------------- 20 DO i=1,N0 pt(i)=abs(P0(i)) END DO pt(N0)=-pt(N0) C----------------------------------------------------------------------- C COMPUTE UPPER ESTIMATE OF BOUND C----------------------------------------------------------------------- x=exp((dlog(-pt(N0))-dlog(pt(1)))/dble(N)) C----------------------------------------------------------------------- C IF NEWTON STEP AT THE ORIGIN IS BETTER, USE IT. C----------------------------------------------------------------------- IF(.not.dpeq(pt(N),ZERO))THEN xm=-pt(N0)/pt(N) IF(xm.lt.x)x=xm END IF C----------------------------------------------------------------------- C CHOP THE INTERVAL (0,X) UNTIL FF .LE. 0 C----------------------------------------------------------------------- DO WHILE (.true.) xm=x*.1D0 ff=pt(1) DO i=2,N0 ff=ff*xm+pt(i) END DO c ------------------------------------------------------------------ IF(ff.le.ZERO)GO TO 30 x=xm END DO C----------------------------------------------------------------------- C DO NEWTON ITERATION UNTIL X CONVERGES TO TWO DECIMAL PLACES C----------------------------------------------------------------------- 30 dx=x DO WHILE (abs(dx/x).gt..005D0) ff=pt(1) df=ff c ------------------------------------------------------------------ DO i=2,N ff=ff*x+pt(i) df=df*x+ff END DO c ------------------------------------------------------------------ ff=ff*x+pt(N0) dx=ff/df x=x-dx END DO bnd=x C----------------------------------------------------------------------- C COMPUTE THE DERIVATIVE AS THE INTIAL K POLYNOMIAL AND C DO 5 STEPS WITH NO SHIFT C----------------------------------------------------------------------- nm1=N-1 DO i=2,N K(i)=dble(N0-i)*P0(i)/dble(N) END DO c ------------------------------------------------------------------ K(1)=P0(1) aa=P0(N0) bb=P0(N) zerok=dpeq(K(N),ZERO) c ------------------------------------------------------------------ DO jj=1,5 cc=K(N) IF(zerok)THEN C----------------------------------------------------------------------- C USE UNSCALED FORM OF RECURRENCE C----------------------------------------------------------------------- DO i=1,nm1 j=N0-i K(j)=K(j-1) END DO K(1)=ZERO zerok=dpeq(K(N),ZERO) ELSE C----------------------------------------------------------------------- C USE SCALED FORM OF RECURRENCE IF VALUE OF K AT 0 IS NONZERO C----------------------------------------------------------------------- t=-aa/cc DO i=1,nm1 j=N0-i K(j)=t*K(j-1)+P0(j) END DO K(1)=P0(1) zerok=dabs(K(N)).le.dabs(bb)*Eta*TEN END IF END DO C----------------------------------------------------------------------- C SAVE K FOR RESTARTS WITH NEW SHIFTS C----------------------------------------------------------------------- DO i=1,N temp(i)=K(i) END DO C----------------------------------------------------------------------- C LOOP TO SELECT THE QUADRATIC CORRESPONDING TO EACH NEW SHIFT C----------------------------------------------------------------------- DO cnt=1,20 C----------------------------------------------------------------------- C QUADRATIC CORRESPONDS TO A DOUBLE SHIFT TO A NON-REAL POINT AND ITS C COMPLEX CONJUGATE. THE POINT HAS MODULUS BND AND AMPLITUDE ROTATED BY C 94 DEGREES FROM THE PREVIOUS SHIFT C----------------------------------------------------------------------- xxx=cosr*xx-sinr*yy yy=sinr*xx+cosr*yy xx=xxx Snr=bnd*xx Sni=bnd*yy U=-2.0D0*Snr V0=bnd C----------------------------------------------------------------------- C SECOND STAGE CALCULATION, FIXED QUADRATIC C----------------------------------------------------------------------- CALL fxshfr(20*cnt,nz) IF(nz.eq.0)THEN C----------------------------------------------------------------------- C IF THE ITERATION IS UNSUCCESSFUL ANOTHER QUADRATIC C IS CHOSEN AFTER RESTORING K C----------------------------------------------------------------------- DO i=1,N K(i)=temp(i) END DO ELSE C----------------------------------------------------------------------- C THE SECOND STAGE JUMPS DIRECTLY TO ONE OF THE THIRD STAGE ITERATIONS C AND RETURNS HERE IF SUCCESSFUL. DEFLATE THE POLYNOMIAL, STORE THE ZERO C OR ZEROS AND RETURN TO THE MAIN ALGORITHM. C----------------------------------------------------------------------- j=Degree-N+1 Zeror(j)=Szr Zeroi(j)=Szi N0=N0-nz N=N0-1 DO i=1,N0 P0(i)=Qp(i) END DO IF(nz.ne.1)THEN Zeror(j+1)=Lzr Zeroi(j+1)=Lzi END IF GO TO 10 END IF END DO C----------------------------------------------------------------------- C RETURN WITH FAILURE IF NO CONVERGENCE WITH 20 SHIFTS C----------------------------------------------------------------------- Fail=.true. Degree=Degree-N RETURN END rtestm.i0000664006604000003110000000021514521201557011661 0ustar sun00315stepsC C... Variables in Common Block /seasTest/ ... real*8 RTtre(Mpkp),RTsa(Mpkp) integer nrt common /rtestm/ RTtre,RTsa,nrt rv2ss.f0000664006604000003110000001452714521201557011432 0ustar sun00315stepsC Last change: BCM 23 Mar 2005 1:33 pm SUBROUTINE rv2ss(Lmodel,Lx11,Lx11rg,Lseats) IMPLICIT NONE c----------------------------------------------------------------------- C USE TEMPORARY VARIABLES TO RESET ORIGINAL SEASONAL ADJUSTMENT C OPTIONS for the sliding spans and revisions analysis options. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'agr.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'adj.cmn' INCLUDE 'lzero.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'extend.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'ssprep.cmn' INCLUDE 'ss2rv.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'seatmd.cmn' INCLUDE 'stcfcm.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'xeastr.cmn' c----------------------------------------------------------------------- INTEGER PACM PARAMETER(PACM=(PLEN+2*PORDER)*PARIMA) c----------------------------------------------------------------------- LOGICAL Lmodel,Lx11,Lx11rg,Lseats INTEGER i c----------------------------------------------------------------------- Kfm2=Kfm2rv Iagr=Iagrrv c----------------------------------------------------------------------- IF(Lx11)THEN DO i=1,12 Lt2(i)=Lt2rv(i) END DO Ktc2=Ktc2rv Tc2=Tc2rv END IF c----------------------------------------------------------------------- IF(Lx11rg)THEN Ksw2=Ksw2rv c----------------------------------------------------------------------- Nxgrp=Ngx2rv Ngrptx=Ngrx2r Nxcxy=Nxxy2r Nbx=Nbbxrv Ncoltx=Ncx2rv i=PCOLCR*PB Colttx(1:i)=Cttxrv(1:i) i=PGRPCR*PGRP Grpttx(1:i)=Gttxrv(1:i) CALL cpyint(Cxptrv(0),PB+1,1,Clxptr(0)) CALL cpyint(Gx2rv(0),PGRP+1,1,Grpx(0)) CALL cpyint(Gptxrv(0),PGRP+1,1,Gpxptr(0)) CALL cpyint(Rgvx2r,PB,1,Rgxvtp) Nxrxy=Nxr2rv Ncxusx=Ncxu2r Irgxfx=Ifxx2r CALL copylg(Rxfx2r,PB,1,Regfxx) CALL cpyint(Xbxyrv,2,1,Xbegxy) CALL copy(Bbxrv,PB,1,Bx) c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- c **** Store model parameters to be saved in temporary variables c----------------------------------------------------------------------- IF(Lmodel)THEN c----------------------------------------------------------------------- c Reset value of Priadj if reset in tdlom subroutine. c----------------------------------------------------------------------- Pri2=Pri2rv c----------------------------------------------------------------------- Ngr2=Ngr2rv Ngrt2=Ngrt2r Ncxy2=Ncxy2r Nbb=Nbbrv Nct2=Nct2rv i=PCOLCR*PB Cttl(1:i)=Cttlrv(1:i) i=PGRPCR*PGRP Gttl(1:i)=Gttlrv(1:i) CALL cpyint(Clptrv(0),PB+1,1,Clptr(0)) CALL cpyint(G2rv(0),PGRP+1,1,G2(0)) CALL cpyint(Gptrrv(0),PGRP+1,1,Gptr(0)) CALL cpyint(Rgv2rv,PB,1,Rgv2) CALL copy(Ap2rv,PARIMA,1,Ap2) CALL copy(Bbrv,PB,1,Bb) CALL copylg(Fxarv,PARIMA,1,Fxa) Nr2=Nr2rv Ncusr2=Ncus2r Irfx2=Irfx2r CALL copylg(Rgfx2r,PB,1,Regfx2) Pktd2=Pktd2r Atd=Atdrv Ahol=Aholrv Aao=Aaorv Als=Alsrv Atc=Atcrv Aso=Asorv Asea=Asearv Acyc=Acycrv Ausr=Ausrrv Fnhol=Fnholr Fnao=Fnaorv Fnls=Fnlsrv Fntc=Fntcrv Fnusr=Fnusrv Flltd=Flltdr Ltstao=Ltaorv Ltstls=Ltlsrv Ltsttc=Lttcrv * Ltstso=Ltsorv Lma2=Lma2r Lar2=Lar2r Nintv2=Nint2r Nextv2=Next2r Mxdfl2=Mxdf2r Mxarl2=Mxar2r Mxmal2=Mxma2r V2=V2r CALL copy(Chx2r,PXPX,1,Chx2) CALL copy(Chg2r,PGPG,1,Chg2) CALL copy(Acm2r,PACM,1,Acm2) Dtcv2=Dtcv2r END IF c----------------------------------------------------------------------- Nspobs=Nsporv Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst Lsp=Lsprv Nbcst2=Nbk2rv CALL setxpt(Nfcst,Lx11.or.Lseats,Fctdrp) Ly0=Ly0rv Lstyr=Lstyrv Lyr=Lyrrv CALL cpyint(Bspnrv,2,1,Begspn) CALL cpyint(Espnrv,2,1,Endspn) Frstsy=Frstrv Nomnfy=Nobs-Frstsy+1 Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nomnfy) CALL cpyint(Bmdlrv,2,1,Begmdl) CALL cpyint(Emdlrv,2,1,Endmdl) Ixreg=Ixrgrv CALL cpyint(Bxrgrv,2,1,Begxrg) CALL cpyint(Exrgrv,2,1,Endxrg) Khol=Kholrv Keastr=Keasrv Lgenx=Lgnxrv CALL copy(Orig,PLEN,1,Series) CALL copy(Orig,PLEN,1,Stcsi) CALL copy(Orig,PLEN,1,Sto) CALL copylg(Prtbrv,NTBL,1,Prttab) Adj1st=A1strv CALL cpyint(Bgxyrv,2,1,Begxy) c----------------------------------------------------------------------- IF(Lseats)THEN Havetr=Htrrv Havesf=Hsfrv Haveir=Hirrv Havesa=Hsarv Havecy=Hcyrv Havftr =Hftrrv Havfsf =Hfsfrv Havfir =Hfirrv Havfsa =Hfsarv Havfcy=Hfcyrv Hseftr=Hsftrv Hsefsf=Hsfsrv Hsefor=Hsforv Hsefsa=Hsfarv Hsefcy=Hsfcrv Hsrftr=Hrftrv Hsrfsf=Hrfsrv Hsrfsa=Hrfarv Hsrfcy=Hrfcrv Hvstsa=Hstarv Hvstir=Hstirv Ntcnum=Ntcnrv Ntcden=Ntcdrv Nsnum=Nsnrv Nsden=Nsdrv Nsanum=Nsanrv Nsaden=Nsadrv Ntrnum=Ntrnrv Ntrden=Ntrdrv Ntcwkf=Ntcwkr Nsawkf=Nsawkr Nswkf=Nswkrv Ntrwkf=Ntrwkr Nirwkf=Nirwkr Tcvar=Tcvrv Svar=Svrv Savar=Savrv Trvar=Trvrv Irrvar=Irrvrv Hsttrv = Hvstft Hstsrv = Hvstfs Hstorv = Hvstfo Hstdrv = Hvstfa Hstcrv = Hvstfc END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END rvarma.f0000664006604000003110000000361014521201557011632 0ustar sun00315steps SUBROUTINE rvarma(Revptr,ChARMA,NchARMA,Nrvarma,CncARMA) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'rev.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER Revptr,iarma,iflt,begopr,endopr,iopr,beglag,endlag,ilag, & ntmpcr,ictmp,NchARMA,Nrvarma CHARACTER tmpttl*(PGRPCR+5),ChARMA*(PGRPCR+5),ctmp*(3) DOUBLE PRECISION CncARMA DIMENSION ChARMA(PARIMA),NchARMA(PARIMA),CncARMA(PARIMA,PREV) c----------------------------------------------------------------------- iarma=1 DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c----------------------------------------------------------------------- DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN c----------------------------------------------------------------------- DO ilag=beglag,endlag IF(.not.Arimaf(ilag))THEN CncARMA(iarma,Revptr)=Arimap(ilag) IF(Revptr.eq.1)THEN chARMA(iarma)=' ' ictmp=1 CALL itoc(Arimal(ilag),ctmp,ictmp) IF(Lfatal)RETURN ChARMA(iarma)=tmpttl(1:ntmpcr)//'['//ctmp(1:(ictmp-1))//']' NchARMA(iarma)=ntmpcr+ictmp+1 Nrvarma=iarma END IF iarma=iarma+1 END IF END DO c----------------------------------------------------------------------- END DO c----------------------------------------------------------------------- END DO c----------------------------------------------------------------------- RETURN END rvfixd.f0000664006604000003110000000602314521201557011645 0ustar sun00315stepsC Last change: BCM 8 Dec 1998 4:02 pm SUBROUTINE rvfixd(Tdfix,Holfix,Otlfix,Usrfix,Iregfx,Regfx,Nb, & Rgvrtp,Nusrrg,Usrtyp,Ncusrx,Userfx) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c----------------------------------------------------------------------- LOGICAL T PARAMETER (T=.true.) c----------------------------------------------------------------------- LOGICAL Tdfix,Holfix,Otlfix,Usrfix,allfix,Regfx,Userfx INTEGER i,Iregfx,iusr,Nb,Rgvrtp,Nusrrg,Usrtyp,rtype,Ncusrx DIMENSION Rgvrtp(*),Usrtyp(*),Regfx(*) c----------------------------------------------------------------------- iusr=1 allfix=T DO i=1,Nb rtype=Rgvrtp(i) IF(Nusrrg.gt.0)THEN IF(rtype.eq.PRGTUD)THEN rtype=Usrtyp(iusr) iusr=iusr+1 ELSE IF((rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGTUS)THEN iusr=iusr+1 END IF END IF IF((Tdfix.AND.((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or. & rtype.eq.PRRTTD.or.rtype.eq.PRRTST.or.rtype.eq.PRATTD.or. & rtype.eq.PRATST.or.rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or. & rtype.eq.PRA1TD.or.rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or. & rtype.eq.PRA1ST).or.(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or. & rtype.eq.PRGTLQ.or.rtype.eq.PRGTLY.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRATSL.or. & rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or.rtype.eq.PRATLQ.or. & rtype.eq.PRATLY).or.rtype.eq.PRGUTD.or.rtype.eq.PRGULY.or. & rtype.eq.PRGULM.or.rtype.eq.PRGULQ)).or. & (Holfix.AND.(rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or. & rtype.eq.PRGTES.or.rtype.eq.PRGTLD.or. & rtype.eq.PRGTTH.or. & (rtype.ge.PRGTUH.and.rtype.le.PRGUH5))).or. & (Usrfix.AND.(rtype.eq.PRGTUD.or.rtype.eq.PRGTUS.or. & (rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGUTD.or.rtype.eq.PRGULY.or. & rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGUAO.or.rtype.eq.PRGULS.or. & rtype.eq.PRGUCN.or.rtype.eq.PRGUCY.or. & rtype.eq.PRGUSO)).or. & (Otlfix.AND.(rtype.eq.PRGTAO.or.rtype.eq.PRGTLS.or. & rtype.eq.PRGTRP.or.rtype.eq.PRGTTC.or.rtype.eq.PRGTSO.or. & rtype.eq.PRGTAL.or.rtype.eq.PRGTAA.or.rtype.eq.PRGTAT.or. & rtype.eq.PRGTQD.or.rtype.eq.PRGTQI.or.rtype.eq.PRGTTL.or. & rtype.eq.PRGUAO.or.rtype.eq.PRGULS.or.rtype.eq.PRGUSO)))THEN Regfx(i)=T IF(Iregfx.le.1)Iregfx=2 END IF allfix=allfix.and.Regfx(i) END DO IF(allfix.and.Iregfx.eq.2)Iregfx=3 IF(.not.Userfx)Userfx=(Usrfix.and.Ncusrx.gt.0) c----------------------------------------------------------------------- RETURN END rvrghd.f0000664006604000003110000000270114521201560011630 0ustar sun00315stepsC Last change: BCM 15 Jan 98 11:54 am SUBROUTINE rvrghd(Othndl,Mt1,Lsav,Lprt) IMPLICIT NONE c----------------------------------------------------------------------- c Print out header information for revisions regressor history c table c----------------------------------------------------------------------- INCLUDE 'title.cmn' INCLUDE 'revtbl.i' INCLUDE 'cchars.i' c----------------------------------------------------------------------- INTEGER Othndl,Mt1 LOGICAL Lsav,Lprt,locok c----------------------------------------------------------------------- IF(Lsav)THEN CALL opnfil(.true.,.false.,LREVOT,Othndl,locok) IF(.not.locok)THEN CALL abend RETURN END IF WRITE(Othndl,1010)'date',TABCHR,'action',TABCHR,'regressors' WRITE(Othndl,1010)'----',TABCHR,'------',TABCHR,'----------' END IF IF(Lprt)THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1020) END IF c----------------------------------------------------------------------- RETURN 1010 FORMAT(a,a,a,a,a) 1020 FORMAT(//,' Actions on regARIMA outlier regressors from full ', & 'data span',//, & 4x,'Ending Date',5x,'Action',9x,'Outliers',/, & 4x,'-----------',5x,'------',9x,'--------') END rvtdrg.f0000664006604000003110000001220214521201560011641 0ustar sun00315steps SUBROUTINE rvtdrg(Revptr,ChRgGp,NRgGp,RGrpNm,Grptot,ChTDrg,NTDrg, & Nrvtdrg,Cnctdrg) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'error.cmn' INCLUDE 'rev.prm' INCLUDE 'usrreg.cmn' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INTEGER Revptr,itd,icol,begcol,endcol,igrp,ngrpcr,NRgGp,RGrpNm, & ntmpcr,ictmp,NchARMA,Nrvtdrg,iusr,rtype,NTDrg,thisG,oldtd, & ncolcr,Grptot LOGICAL isTD,isLen,isUser,isGood CHARACTER ChRgGp*(PGRPCR),ChTDrg*(PCOLCR),grpstr*(PGRPCR), & tmpttl*(PCOLCR),colstr*(PCOLCR) DOUBLE PRECISION Cnctdrg,sumTD DIMENSION ChTDrg(PARIMA),NTDrg(16),Cnctdrg(16,PREV),ChRgGp(5), & NRgGp(5),RgrpNm(5) c----------------------------------------------------------------------- itd=0 iusr=0 thisG=0 c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 rtype=Rgvrtp(begcol) isTD=rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST.or. & rtype.eq.PRGUTD isLen=rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY.or. & rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or.rtype.eq.PRGULY isUser=rtype.eq.PRGTUD.or.(rtype.ge.PRGTUH.and.rtype.le.PRGUH5) & .or.rtype.eq.PRGTUS.or.rtype.eq.PRGUTD.or.rtype.eq.PRGULM & .or.rtype.eq.PRGULQ.or.rtype.eq.PRGULY.or.rtype.eq.PRGUAO & .or.rtype.eq.PRGULS.or.rtype.eq.PRGUCN.or.rtype.eq.PRGUCY & .or.rtype.eq.PRGUSO IF(isTD.or.isLen.or.isUser)THEN oldtd=itd sumTD=0D0 DO icol=begcol,endcol isGood=F IF(isUser)THEN iusr=iusr+1 IF(rtype.eq.PRGTUD)rtype=Usrtyp(iusr) IF(rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or. & rtype.eq.PRGULQ.or.rtype.eq.PRGULY)THEN IF(.not.Regfx(icol))isGood=T END IF ELSE IF(.not.Regfx(icol))isGood=T END IF IF(isGood)THEN itd=itd+1 Cnctdrg(itd,Revptr)=B(icol) CALL getstr(Colttl,Colptr,Ncoltl,icol,colstr,ncolcr) IF(Lfatal)RETURN ChTDrg(itd)=colstr(1:ncolcr) NTDrg(itd)=ncolcr sumTD=sumTD+B(icol) END IF END DO IF(itd.gt.oldtd)THEN thisG=thisG+1 CALL getstr(Grpttl,Grpptr,Ngrp,igrp,grpstr,ngrpcr) IF(Lfatal)RETURN ChRgGp(thisG)=grpstr(1:ngrpcr) NRgGp(thisG)=ngrpcr RGrpNm(thisG)=endcol-begcol+1 END IF IF(isTD)THEN itd=itd+1 Cnctdrg(itd,Revptr)=0D0-sumTD IF((grpstr(1:min(11,ngrpcr)).eq.'Trading Day'.or. & grpstr(1:min(17,ngrpcr)).eq.'Stock Trading Day').and. & begcol.lt.endcol)THEN ncolcr=3 colstr(1:ncolcr)='Sun' IF(((.not.Fulltd).and.index(grpstr(1:ngrpcr),'(before').gt.0) & .or.index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN ncolcr=5 colstr(1:ncolcr)='Sun I' ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0 & .or.index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN ncolcr=6 colstr(1:ncolcr)='Sun II' END IF ELSE IF((grpstr(1:min(25,ngrpcr)).eq. & '1-Coefficient Trading Day'.or. & grpstr(1:min(31,ngrpcr)).eq. & '1-Coefficient Stock Trading Day').and. & begcol.eq.endcol)THEN ncolcr=7 colstr(1:ncolcr)='Sat/Sun' IF(((.not.Fulltd).and.index(grpstr(1:ngrpcr),'(before').gt.0) & .or.index(grpstr(1:ngrpcr),'(change for before').gt.0)THEN ncolcr=9 colstr(1:ncolcr)='Sat/Sun I' ELSE IF(index(grpstr(1:ngrpcr),'(starting').gt.0 & .or.index(grpstr(1:ngrpcr),'(change for after').gt.0)THEN ncolcr=10 colstr(1:ncolcr)='Sat/Sun II' END IF END IF ChTDrg(itd)=colstr(1:ncolcr) NTDrg(itd)=ncolcr RGrpNm(thisG)=RGrpNm(thisG)+1 END IF END IF END DO c----------------------------------------------------------------------- Nrvtdrg=itd Grptot=thisG c----------------------------------------------------------------------- RETURN END sautco.f0000664006604000003110000000205614521201560011635 0ustar sun00315steps**==sautco.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE sautco(X,Cxx,N1,N2,N,Lagh1,R,Good) IMPLICIT NONE C*** Start of declarations inserted by SPAG LOGICAL Good,dpeq DOUBLE PRECISION cn,R,X,xmean,cx0,Cxx INTEGER Lagh1,N,N1,N2 EXTERNAL dpeq C*** End of declarations inserted by SPAG C THE OUTPUTS ARE AUTOCOVARIANCES (CXX(I), I = 0, LAGH) AND C AUTO CORRELATIONS (NORMALIZED COVARIANCES). C TUKEY-HANNING TAPER ROUTINE ADDED BY B. C. MONSELL 7-88 DIMENSION X(*),Cxx(*) DIMENSION cn(1001) C MEAN DELETION CALL smeadl(X,N1,N2,N,xmean) C APPLY THE TUKEY-HANNING TAPER PRIOR TO CALCULATING THE SPECTRUM IF(R.gt.0D0)CALL taper(X,N1,N2,R) C AUTO COVARIANCE COMPUTATION C COMMON SUBROUTINE CALL CALL crosco(X,X,N1,N2,N,Cxx,Lagh1) C NORMALIZATION cx0=Cxx(1) IF(dpeq(cx0,0D0))THEN good=.false. ELSE C COMMON SUBROUTINE CALL CALL cornom(Cxx,cn,Lagh1,cx0,cx0) END IF RETURN END savacf.f0000664006604000003110000001011714521201560011577 0ustar sun00315stepsC Last change: BCM 5 Mar 1999 9:44 am **==savacf.f processed by SPAG 4.03F at 10:31 on 29 Jul 1994 SUBROUTINE savacf(Fh,Itbl,Rho,Se,Mxlag,Ndf,Nsdf) c----------------------------------------------------------------------- c SAVACF() prints out the sample autocorrelation function, standard c errors. Called by prtacf() c----------------------------------------------------------------------- c Name type description c----------------------------------------------------------------------- c rho d Ouput vector of sample autocorrelations c se d The standard errors c mxlag i Length of vector rho, se c itbl i Table id for PACF or ACF, see tbllog.i c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'mdltbl.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER outstr*108 INTEGER i,Itbl,Mxlag,Fh,ipos,Ndf,Nsdf DOUBLE PRECISION Rho,Se DIMENSION Rho(Mxlag),Se(Mxlag) c----------------------------------------------------------------------- INTEGER PR PARAMETER(PR=PLEN/4) INCLUDE 'autoq.cmn' c----------------------------------------------------------------------- c Print the seasonal and nonseasonal differences used in the ACFs c and PACFs generated from the identify spec. c----------------------------------------------------------------------- IF(Ndf.ne.NOTSET)WRITE(Fh,1001)'$diff=',Ndf IF(Nsdf.ne.NOTSET)WRITE(Fh,1001)'$sdiff=',Nsdf 1001 FORMAT(a,i2) c----------------------------------------------------------------------- c Print the autocorrelation function c----------------------------------------------------------------------- IF(Itbl.eq.LCKACF.or.Itbl.eq.LIDACF.or.Itbl.eq.LCKAC2)THEN IF(Itbl.eq.LCKAC2)THEN WRITE(Fh,1010)'Lag',TABCHR,'Sample_ACF2',TABCHR,'SE_of_ACF2', & TABCHR,'Ljung-Box_Q',TABCHR,'df_of_Q',TABCHR, & 'P-value' ELSE WRITE(Fh,1010)'Lag',TABCHR,'Sample_ACF',TABCHR,'SE_of_ACF', & TABCHR,'Ljung-Box_Q',TABCHR,'df_of_Q',TABCHR, & 'P-value' END IF WRITE(Fh,1010)'---',TABCHR,'-----------------------',TABCHR, & '-----------------------',TABCHR, & '-----------------------',TABCHR,'---',TABCHR, & '-----------------------' ELSE WRITE(Fh,1010)'Lag',TABCHR,'Sample_PACF',TABCHR,'S.E._of_PACF' WRITE(Fh,1010)'---',TABCHR,'-----------------------',TABCHR, & '-----------------------' END IF c ------------------------------------------------------------------ DO i=1,Mxlag ipos=1 IF(i.lt.10)THEN outstr(ipos:ipos)='0' ipos=ipos+1 END IF CALL itoc(i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Rho(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Se(i),outstr,ipos) IF(Lfatal)RETURN IF(Itbl.eq.LCKACF.or.Itbl.eq.LCKAC2.or.Itbl.eq.LIDACF)THEN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Qs(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 IF(Dgf(i).lt.10)THEN outstr(ipos:ipos)='0' ipos=ipos+1 END IF CALL itoc(Dgf(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Qpv(i),outstr,ipos) IF(Lfatal)RETURN END IF WRITE(Fh,1010)outstr(1:ipos-1) END DO c ------------------------------------------------------------------ RETURN c ------------------------------------------------------------------ 1010 FORMAT(a:,a,a,a,a:,a,a,a,a,a,a) END savchi.f0000664006604000003110000000221114521201560011605 0ustar sun00315steps SUBROUTINE savchi(Lsvchi,Lsvlch,Lprhdr,Tbwdth,Baselt,Grpstr,Nchr, & Info,Df,Chi2vl,Pv,Hdrstr,Savkey) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER Grpstr*(PGRPCR),Savkey*(*),Hdrstr*(*) LOGICAL Lprhdr,Lsvchi,Lsvlch INTEGER Tbwdth,Baselt,Nchr,Info,Df,i DOUBLE PRECISION Chi2vl,Pv c----------------------------------------------------------------------- IF(Lsvchi.and.baselt.ne.NOTSET) & WRITE(Nform,1010)Savkey,Grpstr(1:Nchr),Df,Chi2vl,Pv IF(Lsvlch) & CALL prtchi(Ng,Lprhdr,Tbwdth,Baselt,Grpstr,Nchr,Info,Df,Chi2vl, & Pv,Hdrstr) c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(a,a,': ',i4,2(1x,e22.15)) c----------------------------------------------------------------------- END savcmn.cmn0000664006604000003110000000126714521201560012161 0ustar sun00315stepsc----------------------------------------------------------------------- c This is a set of common blocks used in the EDITOR subroutine of c X-11-ARIMA, and contains most of the variables used by the c seasonal adjustment routines of X-12-ARIMA c----------------------------------------------------------------------- CHARACTER Svfmt*(11) c----------------------------------------------------------------------- c Length - Length of the series c---------------------------------------------------------------------- INTEGER Svprec,Svsize c----------------------------------------------------------------------- COMMON /savcmn/ Svprec,Svsize,Svfmt savd8b.f0000664006604000003110000000576514521201560011540 0ustar sun00315steps SUBROUTINE savd8b(Itbl,Begdat,I1,Na,Sp,Avec,Albl,Label,Nser, * Lopgrf) c----------------------------------------------------------------------- c Prints out a table in /rdb format, date then value. c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'cchars.i' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'filext.prm' c ------------------------------------------------------------------ CHARACTER outstr*35,Label*(64),tmplbl*(70),Albl*(2) LOGICAL locok,Lopgrf INTEGER Begdat,fh,idate,ipos,Itbl,Na,rdbdat,tpnt,I1,Sp,Nser,ns4 DOUBLE PRECISION Avec DIMENSION Avec(*),Albl(*),Begdat(2),idate(2) c----------------------------------------------------------------------- INTEGER MO,YR PARAMETER(MO=2,YR=1) c ------------------------------------------------------------------ INCLUDE 'filext.var' c----------------------------------------------------------------------- c Open file with the an extension which depends on the type of the c series. c----------------------------------------------------------------------- CALL opnfil(.true.,Lopgrf,Itbl,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- ns4=Nser+4 tmplbl(1:ns4)=Label(1:Nser)//'.'//tbxdic(Itbl) c----------------------------------------------------------------------- c Print timeseries c----------------------------------------------------------------------- WRITE(fh,1010)'date',TABCHR,tmplbl(1:ns4),TABCHR,'Ext&Otl_Label', & TABCHR,'LS_Label' 1010 FORMAT(a:,a,a,a,a,a,a) WRITE(fh,1010)'------',TABCHR,'-----------------------',TABCHR, & '-',TABCHR, & '-' c ------------------------------------------------------------------ DO tpnt=I1,Na CALL addate(Begdat,Sp,tpnt-1,idate) IF(Sp.eq.1)THEN rdbdat=idate(YR) c ------------------------------------------------------------------ ELSE rdbdat=100*idate(YR)+idate(MO) END IF c ------------------------------------------------------------------ ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Avec(tpnt),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 outstr(ipos:ipos)=Albl(tpnt)(1:1) ipos=ipos+1 outstr(ipos:ipos)=TABCHR ipos=ipos+1 outstr(ipos:ipos)=Albl(tpnt)(2:2) WRITE(fh,1010)outstr(1:ipos) END DO c ------------------------------------------------------------------ IF(locok)CALL fclose(fh) RETURN c ------------------------------------------------------------------ END savitr.f0000664006604000003110000001046614521201560011653 0ustar sun00315stepsC Last change: BCM 15 Jan 98 12:05 pm SUBROUTINE savitr(Lfcn,Iteri,Itera,Lglkhd,Parms,Nparms) IMPLICIT NONE c----------------------------------------------------------------------- c Save the iterations, both the nonlinear and the overall c iterations c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c iteri i Input number of IGLS iterations c itera i Input number of ARMA iterations c lglkhd d Input log likelihood c nparms i Input number of ARMA parmeters to save c parms d Input ARMA parameters c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'savcmn.cmn' INCLUDE 'mdltbl.i' c----------------------------------------------------------------------- CHARACTER outstr*(10+(22*(PB+PARIMA+1))),dash*(22) LOGICAL frstcl,Lfcn,locok INTEGER i,Iteri,Itera,Nparms,fh,ipos DOUBLE PRECISION Lglkhd,Parms(Nparms) c----------------------------------------------------------------------- SAVE frstcl,fh c----------------------------------------------------------------------- DATA frstcl/.true./ DATA dash /'----------------------'/ c----------------------------------------------------------------------- IF(frstcl)THEN CALL opnfil(.true.,.false.,LESTIT,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- IF(Nb.gt.0)THEN WRITE(fh,1010)'overall',TABCHR,'nonlinear',TABCHR, & 'loglikelihood',TABCHR, & ('arma',i,TABCHR,i=1,Nparms), & ('reg',i,TABCHR,i=1,Nb) 1010 FORMAT(a,a,a,a,a,a,100(a,i2.2,a)) WRITE(fh,1030)'-------',TABCHR,'---------',TABCHR, & dash(1:Svsize),TABCHR,(dash(1:Svsize),TABCHR, & i=1,Nparms),(dash(1:Svsize),TABCHR,i=1,Nb) c----------------------------------------------------------------------- ELSE WRITE(fh,1020)'nonlinear',TABCHR,'loglikelihood',TABCHR, & ('arma',i,TABCHR,i=1,Nparms) 1020 FORMAT(a,a,a,a,100(a,i2.2,a)) WRITE(fh,1030)'---------',TABCHR,dash(1:Svsize),TABCHR, & (dash(1:Svsize),TABCHR,i=1,Nparms), & (dash(1:Svsize),TABCHR,i=1,Nb) END IF c----------------------------------------------------------------------- 1030 FORMAT(a:,100a) frstcl=.false. END IF c----------------------------------------------------------------------- c Save the iterations c----------------------------------------------------------------------- IF(Lfcn)THEN CALL fclose(fh) c frstcl=.true. c----------------------------------------------------------------------- ELSE ipos=1 c----------------------------------------------------------------------- IF(Nb.gt.0)THEN CALL itoc(Iteri,outstr,ipos) outstr(ipos:ipos)=TABCHR ipos=ipos+1 END IF c----------------------------------------------------------------------- CALL itoc(Itera,outstr,ipos) outstr(ipos:ipos)=TABCHR ipos=ipos+1 c----------------------------------------------------------------------- CALL dtoc(Lglkhd,outstr,ipos) outstr(ipos:ipos)=TABCHR ipos=ipos+1 c----------------------------------------------------------------------- DO i=1,Nparms CALL dtoc(Parms(i),outstr,ipos) outstr(ipos:ipos)=TABCHR ipos=ipos+1 END DO c----------------------------------------------------------------------- IF(Nb.gt.0)THEN DO i=1,Nb CALL dtoc(B(i),outstr,ipos) outstr(ipos:ipos)=TABCHR ipos=ipos+1 END DO END IF c----------------------------------------------------------------------- WRITE(fh,1030)outstr(1:ipos-1) END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END savmdc.f0000664006604000003110000000760314521201560011617 0ustar sun00315steps SUBROUTINE savmdc(Nptr) IMPLICIT NONE c----------------------------------------------------------------------- c Save the Wiener-Kolmogrov filters from SEATS into a file. c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' * INCLUDE 'cchars.i' INCLUDE 'seatmd.cmn' * INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER fh,icol,Nptr LOGICAL locok c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c open file c----------------------------------------------------------------------- CALL opnfil(T,F,Nptr,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Save model estimates associated with the trend cycle c----------------------------------------------------------------------- IF(Ntcnum.gt.0)THEN WRITE(fh,1010)'ntcnum: ',Ntcnum DO icol=1,Ntcnum WRITE(fh,1020)'tcnum.',icol-1,Tcnum(icol) END DO END IF IF(Ntcden.gt.0)THEN WRITE(fh,1010)'ntcden: ',Ntcden DO icol=1,Ntcden WRITE(fh,1020)'tcden.',icol-1,Tcden(icol) END DO END IF IF(.not.dpeq(Tcvar,DNOTST))WRITE(fh,1030)'tcvar: ',Tcvar c----------------------------------------------------------------------- c Save model estimates associated with the seasonal c----------------------------------------------------------------------- IF(Nsnum.gt.0)THEN WRITE(fh,1010)'nsnum: ',Nsnum DO icol=1,Nsnum WRITE(fh,1020)'snum.',icol-1,Snum(icol) END DO END IF IF(Nsden.gt.0)THEN WRITE(fh,1010)'nsden: ',Nsden DO icol=1,Nsden WRITE(fh,1020)'sden.',icol-1,Sden(icol) END DO END IF IF(.not.dpeq(Svar,DNOTST))WRITE(fh,1030)'svar: ',Svar c----------------------------------------------------------------------- c save model estimates associated with the seasonally adjusted c component c----------------------------------------------------------------------- IF(Nsanum.gt.0)THEN WRITE(fh,1010)'nsanum: ',Nsanum DO icol=1,Nsanum WRITE(fh,1020)'sanum.',icol-1,Sanum(icol) END DO END IF IF(Nsaden.gt.0)THEN WRITE(fh,1010)'nsaden: ',Nsaden DO icol=1,Nsaden WRITE(fh,1020)'saden.',icol-1,Saden(icol) END DO END IF IF(.not.dpeq(Savar,DNOTST))WRITE(fh,1030)'savar: ',Savar c----------------------------------------------------------------------- c Transitory component estimates c----------------------------------------------------------------------- IF(Ntrnum.gt.0)THEN WRITE(fh,1010)'ntrnum: ',Ntrnum DO icol=1,Ntrnum WRITE(fh,1020)'trnum.',icol-1,Trnum(icol) END DO END IF IF(Ntrden.gt.0)THEN WRITE(fh,1010)'ntrden: ',Ntrden DO icol=1,Ntrden WRITE(fh,1020)'trden.',icol-1,Trden(icol) END DO END IF IF(.not.dpeq(Trvar,DNOTST))WRITE(fh,1030)'trvar: ',Trvar c----------------------------------------------------------------------- c irregular estimates c----------------------------------------------------------------------- IF(.not.dpeq(Irrvar,DNOTST))WRITE(fh,1030)'irrvar: ',Irrvar c----------------------------------------------------------------------- 1010 FORMAT(a,i3) 1020 FORMAT(a,i3.3,': ',e22.15) 1030 FORMAT(a,e22.15) c----------------------------------------------------------------------- RETURN END savmdl.f0000664006604000003110000005277114521201560011636 0ustar sun00315stepsC Last change: BCM 3 Sep 2003 2:21 pm SUBROUTINE savmdl(Begxy,Nrxy,Elong) IMPLICIT NONE c----------------------------------------------------------------------- c Prints out input file with regression, ARIMA specs c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'mdltbl.i' INCLUDE 'x11adj.cmn' INCLUDE 'savcmn.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER armopr*(4),icoltl*(PCOLCR),igrptl*(PGRPCR), & outstr*(PGRPCR) CHARACTER fmtusr*(20) LOGICAL locok,nxtreg,prvreg,Elong INTEGER begcol,beglag,begopr,begusr,Begxy,chrlen,endchr,endcol, & endlag,endopr,fh,ibeg,icol,iend,ielt,iflt,igrp,ilag,iopr, & ipos,nchr,nigrpc,noutcr,Nrxy,nusr,i,idtbeg,idtend,nigrp2, & ncol DIMENSION Begxy(2),armopr(2:3) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ CHARACTER URGDIC*184 INTEGER urgptr,PURG,urgidx PARAMETER(PURG=65) DIMENSION urgptr(0:PURG) PARAMETER(URGDIC='constanttdlomloqlpyeartdstocklomstockeasterlabor &thanksaolsrpusereasterstocksceasterseasonaltcsoholidayholiday2holi &day3holiday4holiday5transitorysocycletdlomloqleapyraolssoconstantc &ycle') c ------------------------------------------------------------------ DATA urgptr/1,9,9,9,11,14,17,23,30,38,44,49,55,57,59,61,61,61,65, & 65,65,65,65,65,65,65,65,76,76,84,84,84,84,84,84,84,84, & 84,92,94,94,94,94,94,96,96,96,96,96,103,111,119,127, & 135,145,147,152,154,157,160,166,168,170,172,180,185/ DATA armopr/'ar ','ma '/ c----------------------------------------------------------------------- c Open file with the an extension which depends on the type of the c series. c----------------------------------------------------------------------- begusr=0 CALL opnfil(T,F,LESTMD,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print regression spec c----------------------------------------------------------------------- IF(Nb.gt.0)THEN WRITE(fh,1010) 1010 FORMAT(' regression{',/,' variables=(') c----------------------------------------------------------------------- c Print the regression variables c----------------------------------------------------------------------- DO igrp=1,Ngrp CALL getstr(Grpttl,Grpptr,Ngrp,igrp,igrptl,nchr) IF(Lfatal)RETURN nigrpc=index(igrptl(1:nchr),'[')-1 IF(nigrpc.eq.-1)nigrpc=nchr IF(igrptl(1:2).eq.'AO'.or.igrptl(1:2).eq.'LS'.or.igrptl(1:2) & .eq.'Rp'.or.igrptl(1:2).eq.'TC'.or.igrptl(1:2).eq.'SO'.or. & igrptl(1:2).eq.'TL')nigrpc=2 c----------------------------------------------------------------------- c Determine the beginning and ending columns in the group c----------------------------------------------------------------------- begcol=Grp(igrp-1) endcol=Grp(igrp)-1 c----------------------------------------------------------------------- c check to see if next group is a set of change-of-regime regression c variables c----------------------------------------------------------------------- nxtreg=F IF(igrp.lt.Ngrp)THEN IF(((Rgvrtp(endcol+1).gt.PRGTUD.and.Rgvrtp(endcol+1).lt.PRGTMV) & .AND.((Rgvrtp(endcol+1)-Rgvrtp(endcol)).eq.17)).or. & (Rgvrtp(endcol+1).eq.PRG1ST.AND. & ((Rgvrtp(endcol+1)-Rgvrtp(endcol)).eq.1)))nxtreg=T END IF prvreg=F IF(igrp.gt.1)THEN IF(((Rgvrtp(begcol).gt.PRGTUD.and.Rgvrtp(begcol).lt.PRGTMV) & .AND.((Rgvrtp(begcol)-Rgvrtp(begcol-1)).eq.17)).or. & (Rgvrtp(begcol).eq.PRG1ST.AND. & ((Rgvrtp(begcol)-Rgvrtp(begcol-1)).eq.1)))prvreg=T END IF c----------------------------------------------------------------------- c Determine the type of regression variable c----------------------------------------------------------------------- GO TO(10,20,30,40,50,60,70,80,90,100, & 110,120,130,140,150,160,160,170,20,30, & 40,50,60,70,80,90,105,131,190,20, & 30,40,50,60,70,80,90,170,210,160, & 40,40,40,155,160,80,80,80,170,170, & 170,170,170,145,155,170,170,170,170,170, & 170,170,170,170,170),Rgvrtp(begcol) c----------------------------------------------------------------------- c Constant is a column of ones filtered by 1/Diff(B). c----------------------------------------------------------------------- 10 noutcr=5 outstr='const' GO TO 220 c----------------------------------------------------------------------- c Seasonal effects c----------------------------------------------------------------------- 20 IF(prvreg)GO TO 180 noutcr=8 outstr='seasonal' IF(Rgvrtp(begcol).eq.PRRTSE)GO TO 180 IF(Rgvrtp(begcol).eq.PRATSE)GO TO 200 GO TO 220 c----------------------------------------------------------------------- c Trigonometric Seasonal effects c----------------------------------------------------------------------- 30 IF(prvreg)GO TO 180 outstr='sincos[' ipos=8 DO icol=endcol,begcol,-2 CALL getstr(Colttl,Colptr,Ncoltl,icol,icoltl,ncol) IF(Lfatal)RETURN endchr=index(icoltl(1:ncol),'t/')-1 chrlen=endchr-8 outstr(ipos:(ipos+chrlen))=icoltl(9:endchr)//',' ipos=ipos+chrlen+1 END DO c ------------------------------------------------------------------ noutcr=ipos-1 outstr(noutcr:noutcr)=']' IF(Rgvrtp(begcol).eq.PRRTTS)GO TO 180 IF(Rgvrtp(begcol).eq.PRATTS)GO TO 200 GO TO 220 c----------------------------------------------------------------------- c Trading Day effects c----------------------------------------------------------------------- 40 IF(prvreg)GO TO 180 IF(Picktd)THEN IF(begcol.eq.endcol)THEN noutcr=7 outstr='td1coef' ELSE noutcr=2 outstr='td' END IF ELSE IF(begcol.eq.endcol)THEN noutcr=11 outstr='td1nolpyear' ELSE noutcr=10 outstr='tdnolpyear' END IF END IF IF(Rgvrtp(begcol).eq.PRRTTD.or.Rgvrtp(begcol).eq.PRR1TD) & GO TO 180 IF(Rgvrtp(begcol).eq.PRATTD.or.Rgvrtp(begcol).eq.PRA1TD) & GO TO 200 GO TO 220 c----------------------------------------------------------------------- c Length-of-Month and Length-of-Quarter effects. Only include c if the trading day was not specified by td. c----------------------------------------------------------------------- 50 IF(prvreg)GO TO 180 IF(Picktd)THEN noutcr=0 c ------------------------------------------------------------------ ELSE noutcr=3 outstr='lom' IF(Rgvrtp(begcol).eq.PRRTLM)GO TO 180 IF(Rgvrtp(begcol).eq.PRATLM)GO TO 200 END IF GO TO 220 c----------------------------------------------------------------------- c Length-of-Quarter effects. Only include c if the trading day was not specified by td. c----------------------------------------------------------------------- 60 IF(prvreg)GO TO 180 IF(Picktd)THEN noutcr=0 c ------------------------------------------------------------------ ELSE noutcr=3 outstr='loq' IF(Rgvrtp(begcol).eq.PRRTLQ)GO TO 180 IF(Rgvrtp(begcol).eq.PRATLQ)GO TO 200 END IF GO TO 220 c----------------------------------------------------------------------- c Leap Year effect c----------------------------------------------------------------------- 70 IF(prvreg)GO TO 180 IF(Picktd)THEN noutcr=0 c ------------------------------------------------------------------ ELSE noutcr=6 outstr='lpyear' IF(Rgvrtp(begcol).eq.PRRTLY)GO TO 180 IF(Rgvrtp(begcol).eq.PRATLY)GO TO 200 END IF GO TO 220 c----------------------------------------------------------------------- c Stock Trading Day effects c----------------------------------------------------------------------- 80 IF(prvreg)GO TO 180 nigrp2=index(igrptl(1:nchr),']') IF(begcol.eq.endcol)THEN noutcr=12+nigrp2-nigrpc outstr='tdstock1coef'//igrptl((nigrpc+1):nigrp2) ELSE noutcr=7+nigrp2-nigrpc outstr='tdstock'//igrptl((nigrpc+1):nigrp2) END IF IF(Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRR1ST) & GO TO 180 IF(Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRA1ST) & GO TO 200 GO TO 220 c----------------------------------------------------------------------- c Stock Length-of-Month effect c----------------------------------------------------------------------- 90 IF(prvreg)GO TO 180 noutcr=8 outstr='lomstock' IF(Rgvrtp(begcol).eq.PRRTSL)GO TO 180 IF(Rgvrtp(begcol).eq.PRATSL)GO TO 200 GO TO 220 c----------------------------------------------------------------------- c Easter holiday effect c----------------------------------------------------------------------- 100 DO icol=begcol,endcol CALL getstr(Colttl,Colptr,Nb,icol,igrptl,nchr) IF(Lfatal)RETURN nigrpc=index(igrptl(1:nchr),'[')-1 noutcr=6+nchr-nigrpc outstr='easter'//igrptl((nigrpc+1):nchr) IF(icol.lt.endcol)WRITE(fh,1020)outstr(1:noutcr) END DO GO TO 220 c----------------------------------------------------------------------- c Stock Easter holiday effect c----------------------------------------------------------------------- 105 DO icol=begcol,endcol CALL getstr(Colttl,Colptr,Nb,icol,igrptl,nchr) IF(Lfatal)RETURN nigrpc=index(igrptl(1:nchr),'[')-1 noutcr=11+nchr-nigrpc outstr='easterstock'//igrptl((nigrpc+1):nchr) IF(icol.lt.endcol)WRITE(fh,1020)outstr(1:noutcr) END DO GO TO 220 c----------------------------------------------------------------------- c Labor day holiday effect c----------------------------------------------------------------------- 110 noutcr=5+nchr-nigrpc outstr='labor'//igrptl((nigrpc+1):nchr) GO TO 220 c----------------------------------------------------------------------- c Thanksgiving-Christmas holiday effect c----------------------------------------------------------------------- 120 noutcr=5+nchr-nigrpc outstr='thank'//igrptl((nigrpc+1):nchr) GO TO 220 c----------------------------------------------------------------------- c AOs c----------------------------------------------------------------------- 130 noutcr=2+nchr-nigrpc outstr='ao'//igrptl((nigrpc+1):nchr) GO TO 220 c----------------------------------------------------------------------- c MVs - skip over c----------------------------------------------------------------------- 131 noutcr=0 GO TO 220 c----------------------------------------------------------------------- c LSs c----------------------------------------------------------------------- 140 noutcr=2+nchr-nigrpc outstr='ls'//igrptl((nigrpc+1):nchr) GO TO 220 c----------------------------------------------------------------------- c TLSs c----------------------------------------------------------------------- 145 noutcr=2+nchr-nigrpc outstr='tl'//igrptl((nigrpc+1):nchr) GO TO 220 c----------------------------------------------------------------------- c Ramps c----------------------------------------------------------------------- 150 noutcr=2+nchr-nigrpc outstr='rp'//igrptl((nigrpc+1):nchr) GO TO 220 c----------------------------------------------------------------------- c SOs c----------------------------------------------------------------------- 155 noutcr=2+nchr-nigrpc outstr='so'//igrptl((nigrpc+1):nchr) GO TO 220 c----------------------------------------------------------------------- c Automatically Identified Outliers c----------------------------------------------------------------------- 160 DO icol=begcol,endcol CALL getstr(Colttl,Colptr,Ncoltl,icol,icoltl,nchr) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(icoltl(1:2).eq.'AO')THEN icoltl(1:2)='ao' ELSE IF(icoltl(1:2).eq.'TC')THEN icoltl(1:2)='tc' ELSE IF(icoltl(1:2).eq.'LS')THEN icoltl(1:2)='ls' * ELSE IF(icoltl(1:2).eq.'SO')THEN * icoltl(1:2)='so' END IF c ------------------------------------------------------------------ WRITE(fh,1020)icoltl(1:nchr) END DO 1020 FORMAT(' ',a) c ------------------------------------------------------------------ noutcr=0 GO TO 220 c----------------------------------------------------------------------- c User-defined regression variables. First check the dates or the c variables. c----------------------------------------------------------------------- 170 IF(begusr.eq.0)begusr=igrp noutcr=0 GO TO 220 c----------------------------------------------------------------------- c Change of regime regression variables. First, get the date of c the change-of-regime from the group title. c----------------------------------------------------------------------- 180 idtbeg=index(igrptl(1:nchr),'(before ')+8 IF(idtbeg.eq.8) & idtbeg=index(igrptl(1:nchr),'(change for before ')+19 idtend=index(igrptl(idtbeg:nchr),')')+idtbeg-2 IF(prvreg)THEN outstr(noutcr+1:)='/'//igrptl(idtbeg:idtend)//'/' noutcr=noutcr+idtend-idtbeg+3 ELSE outstr(noutcr+1:)='/'//igrptl(idtbeg:idtend)//'//' noutcr=noutcr+idtend-idtbeg+4 END IF GO TO 220 c----------------------------------------------------------------------- c statistics canada Easter holiday effect c----------------------------------------------------------------------- 190 DO icol=begcol,endcol CALL getstr(Colttl,Colptr,Nb,icol,igrptl,nchr) IF(Lfatal)RETURN nigrpc=index(igrptl(1:nchr),'[')-1 noutcr=8+nchr-nigrpc outstr='sceaster'//igrptl((nigrpc+1):nchr) IF(icol.lt.endcol)WRITE(fh,1020)outstr(1:noutcr) END DO GO TO 220 c----------------------------------------------------------------------- c Change of regime regression variables. First, get the date of c the change-of-regime from the group title. c----------------------------------------------------------------------- 200 idtbeg=index(igrptl(1:nchr),'(starting ')+10 IF(idtbeg.eq.10) & idtbeg=index(igrptl(1:nchr),'(change for after ')+18 idtend=index(igrptl(idtbeg:nchr),')')+idtbeg-2 outstr(noutcr+1:)='//'//igrptl(idtbeg:idtend)//'/' noutcr=noutcr+idtend-idtbeg+4 GO TO 220 c----------------------------------------------------------------------- c TCs c----------------------------------------------------------------------- 210 noutcr=2+nchr-nigrpc outstr='tc'//igrptl((nigrpc+1):nchr) c----------------------------------------------------------------------- c Write out the regression term c----------------------------------------------------------------------- 220 IF(.not.nxtreg.and.noutcr.gt.0)WRITE(fh,1020)outstr(1:noutcr) END DO c----------------------------------------------------------------------- c Write out the closing parentheses for the variables argument. c----------------------------------------------------------------------- WRITE(fh,1020)' )' c----------------------------------------------------------------------- c User-defined regression variables. Add the effect names, start c date and the data. c----------------------------------------------------------------------- IF(begusr.gt.0)THEN WRITE(fh,1030) 1030 FORMAT(' user=(') DO igrp=begusr,Ngrp begcol=Grp(igrp-1) IF((Rgvrtp(begcol).ge.PRGTUH.and.Rgvrtp(begcol).le.PRGUH5).or. & Rgvrtp(begcol).eq.PRGTUD.or.Rgvrtp(begcol).eq.PRGTUS.or. & Rgvrtp(begcol).eq.PRGUTD.or.Rgvrtp(begcol).eq.PRGULM.or. & Rgvrtp(begcol).eq.PRGULQ.or.Rgvrtp(begcol).eq.PRGULY.or. & Rgvrtp(begcol).eq.PRGUAO.or.Rgvrtp(begcol).eq.PRGULS.or. & Rgvrtp(begcol).eq.PRGUSO.or.Rgvrtp(begcol).eq.PRGUCN.or. & Rgvrtp(begcol).eq.PRGUCY)THEN endcol=Grp(igrp)-1 DO icol=begcol,endcol CALL getstr(Colttl,Colptr,Ncoltl,icol,icoltl,nchr) IF(Lfatal)RETURN WRITE(fh,1020)icoltl(1:nchr) END DO END IF END DO c ------------------------------------------------------------------ WRITE(fh,1020)' )' c ------------------------------------------------------------------ CALL wrtdat(Begxy,Sp,outstr,nchr) IF(Lfatal)RETURN WRITE(fh,1021)'start='//outstr(1:nchr) 1021 FORMAT(' ',a) c----------------------------------------------------------------------- c The data start at the span and go until the end of the c forecasts. c----------------------------------------------------------------------- WRITE(fh,1021)'data=(' nusr=endcol-begusr+1 WRITE(fmtusr,1040)Svsize+1,Svprec 1040 FORMAT('(t5,4e',i2.2,'.',i2.2,')') DO iend=endcol,Ncxy*Nrxy,Ncxy ibeg=iend-nusr+1 WRITE(fh,fmtusr)(Xy(ielt),ielt=ibeg,iend) c WRITE(fh,1040)(Xy(ielt),ielt=ibeg,iend) c 1040 FORMAT(t5,4g16.6) END DO WRITE(fh,1020)' )' IF(Nusrrg.gt.0)THEN WRITE(fh,1021)'usertype=(' DO urgidx=1,Nusrrg CALL getstr(URGDIC,urgptr,PURG,Usrtyp(urgidx),outstr,nchr) IF(Lfatal)RETURN WRITE(fh,1020)' '//outstr(1:nchr) END DO WRITE(fh,1020)' )' END IF END IF c----------------------------------------------------------------------- c Printout the noapply option c----------------------------------------------------------------------- IF(Adjtd.eq.-1.or.Adjao.eq.-1.or.Adjls.eq.-1.or.Adjtc.eq.-1.or. & Adjso.eq.-1.or.Adjhol.eq.-1.or.Adjsea.eq.-1.or.Adjusr.eq.-1) & THEN WRITE(fh,1021)'noapply=(' IF(Adjtd.eq.-1)WRITE(fh,1020)' td' IF(Adjao.eq.-1)WRITE(fh,1020)' ao' IF(Adjls.eq.-1)WRITE(fh,1020)' ls' IF(Adjtc.eq.-1)WRITE(fh,1020)' tc' IF(Adjso.eq.-1)WRITE(fh,1020)' so' IF(Adjhol.eq.-1)WRITE(fh,1020)' holiday' IF(Adjsea.eq.-1)WRITE(fh,1020)' userseasonal' IF(Adjusr.eq.-1)WRITE(fh,1020)' user' WRITE(fh,1020)' )' END IF c----------------------------------------------------------------------- c Printout the regression coeffficients c----------------------------------------------------------------------- WRITE(fh,1021)'b=(' DO i=1,Nb IF(Rgvrtp(i).ne.PRGTUD)THEN IF(Regfx(i))THEN WRITE(fh,1080)B(i),'f' ELSE WRITE(fh,1080)B(i) END IF END IF END DO IF(begusr.gt.0)THEN DO i=1,Nb IF(Rgvrtp(i).eq.PRGTUD)THEN IF(Regfx(i))THEN WRITE(fh,1080)B(i),'f' ELSE WRITE(fh,1080)B(i) END IF END IF END DO END IF 1080 FORMAT(' ',e24.10,a) WRITE(fh,1020)' )' c----------------------------------------------------------------------- c Print out miscellaneous additional options if they are different c than the default. c----------------------------------------------------------------------- IF(.not.Elong)WRITE(fh,1021)'eastermeans=no' IF(.not.dpeq(Tcalfa,0.7D0))WRITE(fh,2020)' tcrate=',Tcalfa 2020 FORMAT(a,f14.6) WRITE(fh,1050) 1050 FORMAT(' }') END IF c----------------------------------------------------------------------- c Add the ARIMA model if there is any c----------------------------------------------------------------------- WRITE(fh,1060)Mdldsn(1:Nmddcr) 1060 FORMAT(/,' arima{model=',/,' ',a) c ------------------------------------------------------------------ CALL prarma(fh) c ------------------------------------------------------------------ WRITE(fh,1100) 1100 FORMAT(' }') c ------------------------------------------------------------------ IF(locok)CALL fclose(fh) c ------------------------------------------------------------------ RETURN END savmtx.f0000664006604000003110000000567214521201561011671 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:33 pm SUBROUTINE savmtx(Itbl,Begxy,Sp,Xy,Nrxy,Ncxy,Ttlstr,Ttlptr,Nttl) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'cchars.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'savcmn.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER Ttlstr*(*),outstr*(6+22*PB),dash*(22) LOGICAL locok INTEGER begelt,Begxy,endelt,fh,ielt,idate,ipos,Itbl,Ncxy,Nrxy, & Nttl,rdbdat,Sp,tpnt,Ttlptr DOUBLE PRECISION Xy DIMENSION Begxy(2),idate(2),Ttlptr(0:Nttl),Xy(*) c----------------------------------------------------------------------- DATA dash /'----------------------'/ c----------------------------------------------------------------------- c Open file with the an extension which depends on the type of the c series. c----------------------------------------------------------------------- CALL opnfil(.true.,.false.,Itbl,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print the regression matrix or effects. c Figure the columns of the matrix are nb+1. c Print the column titles as the variable or column names then write c the dash line. The column names are taken from the ttlstr string c vector. Then write the dates before the nb columns. c----------------------------------------------------------------------- WRITE(fh,1010)'Date', & (TABCHR,Ttlstr(Ttlptr(ielt-1):Ttlptr(ielt)-1), & ielt=1,Nttl) 1010 FORMAT(1000a) WRITE(fh,1010)'----',(TABCHR,dash(1:Svsize),ielt=1,Nttl) c ------------------------------------------------------------------ DO tpnt=1,Nrxy CALL addate(Begxy,Sp,tpnt-1,idate) IF(Sp.eq.1)THEN rdbdat=idate(YR) ELSE rdbdat=100*idate(YR)+idate(MO) END IF c ------------------------------------------------------------------ begelt=Ncxy*(tpnt-1)+1 endelt=Ncxy*tpnt-(Ncxy-Nttl) ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN c ------------------------------------------------------------------ DO ielt=begelt,endelt outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Xy(ielt),outstr,ipos) IF(Lfatal)RETURN END DO c ------------------------------------------------------------------ WRITE(fh,1010)outstr(1:ipos-1) END DO c----------------------------------------------------------------------- c Print the acf and pacf where for the acf the columns are the lag, c acf, standard error, Ljung-Box statistic, (and p-value). c----------------------------------------------------------------------- IF(locok)CALL fclose(fh) RETURN END savotl.f0000664006604000003110000001432714521201561011654 0ustar sun00315stepsC Last change: BCM 8 Aug 2011 9:44 am **==savacf.f processed by SPAG 4.03F at 10:31 on 29 Jul 1994 SUBROUTINE savotl(Lsumm,Lsvlog,Gudrun,Lidotl) c----------------------------------------------------------------------- c Print out entries for diagnostic and log files related to outlier c regressors c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,TWO PARAMETER(ZERO=0D0,TWO=2D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ INTEGER Lsumm,i1,i2,iauto,iao,ils,itc,iso,iramp,itls,iuser,nchr, & nb2,nelt,nfix,iall LOGICAL Gudrun,Lsvlog,Lidotl CHARACTER icoltl*(PCOLCR) DOUBLE PRECISION xpxinv,tmp,rmse,seb DIMENSION xpxinv(PXPX),tmp(2) c----------------------------------------------------------------------- DOUBLE PRECISION dpmpar LOGICAL dpeq EXTERNAL dpmpar,dpeq c----------------------------------------------------------------------- IF(.not.((Lsumm.gt.0.or.(Lsvlog.and.Lidotl)).and.gudrun))RETURN c----------------------------------------------------------------------- iauto=0 iall=0 iao=0 ils=0 itc=0 iso=0 iramp=0 itls=0 iuser=0 c----------------------------------------------------------------------- c if saving info to log, initialize variables needed to generate c t-statistic for outlier regressors c----------------------------------------------------------------------- IF(Lsvlog)THEN c ------------------------------------------------------------------ c Generate number of unfixed regressors c ------------------------------------------------------------------ nb2=Nb IF(Iregfx.ge.2)THEN DO i1=1,Nb IF(Regfx(i1))nb2=nb2-1 END DO END IF c----------------------------------------------------------------------- c Get the root mean square error and X'X inverse. c----------------------------------------------------------------------- IF(nb2.gt.0)THEN c nelt=Ncxy*(Ncxy+1)/2 nelt=(nb2+1)*(nb2+2)/2 c----------------------------------------------------------------------- IF(Var.gt.TWO*dpmpar(1))THEN rmse=sqrt(Var) CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,nb2,tmp,1) c CALL dppdi(xpxinv,Nb,tmp,1) c----------------------------------------------------------------------- ELSE rmse=ZERO END IF ELSE rmse=ZERO END IF nfix=0 END IF c----------------------------------------------------------------------- IF(Nb.gt.0)THEN DO i1=1,Nb IF(Rgvrtp(i1).eq.PRGTAA.or.Rgvrtp(i1).eq.PRGTAL.or. * & Rgvrtp(i1).eq.PRGTAT.or.Rgvrtp(i1).eq.PRGTAS)THEN & Rgvrtp(i1).eq.PRGTAT)THEN iauto=iauto+1 IF(Lsvlog)THEN IF(iauto.eq.1)THEN WRITE(Ng,1060)' ' WRITE(Ng,1060)' Outliers identifed in this run:' END IF c----------------------------------------------------------------------- c Compute standard error of regressor c----------------------------------------------------------------------- i2=i1-nfix seb=sqrt(xpxinv(i2*(i2+1)/2))*rmse c----------------------------------------------------------------------- c Print out regressor with t statistic c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Nb,i1,icoltl,nchr) IF(Lfatal)RETURN IF(dpeq(seb,ZERO))THEN WRITE(Ng,1060)' ',icoltl(1:nchr) ELSE WRITE(Ng,1050)icoltl(1:nchr),B(i1)/seb END IF END IF ELSE IF(Lsvlog)THEN IF(Regfx(i1))nfix=nfix+1 END IF IF(Rgvrtp(i1).eq.PRGTAA.or.Rgvrtp(i1).eq.PRGTAO.or. & Rgvrtp(i1).eq.PRGUAO)THEN iao=iao+1 iall=iall+1 END IF IF(Rgvrtp(i1).eq.PRGTAL.or.Rgvrtp(i1).eq.PRGTLS.or. & Rgvrtp(i1).eq.PRGULS)THEN ils=ils+1 iall=iall+1 END IF IF(Rgvrtp(i1).eq.PRGTAT.or.Rgvrtp(i1).eq.PRGTTC)THEN itc=itc+1 iall=iall+1 END IF * IF(Rgvrtp(i1).eq.PRGTAS.or.Rgvrtp(i1).eq.PRGTSO)iso=iso+1 IF(Rgvrtp(i1).eq.PRGTSO.or.Rgvrtp(i1).eq.PRGUSO)THEN iso=iso+1 iall=iall+1 END IF IF(Rgvrtp(i1).eq.PRGTRP.or.Rgvrtp(i1).eq.PRGTQD.or. & Rgvrtp(i1).eq.PRGTQI)THEN iramp=iramp+1 iall=iall+1 END IF IF(Rgvrtp(i1).eq.PRGTTL)THEN itls=itls+1 iall=iall+1 END IF IF(Ncusrx.gt.0)THEN IF(Rgvrtp(i1).eq.PRGUAO.or.Rgvrtp(i1).eq.PRGULS.or. & Rgvrtp(i1).eq.PRGUSO)iuser=iuser+1 END IF END DO END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1080)'outlier.ao: ',iao WRITE(Nform,1080)'outlier.ls: ',ils WRITE(Nform,1080)'outlier.tc: ',itc WRITE(Nform,1080)'outlier.so: ',iso WRITE(Nform,1080)'outlier.rp: ',iramp WRITE(Nform,1080)'outlier.tls: ',itls IF(Ncusrx.gt.0)WRITE(Nform,1080)'outlier.user: ',iuser WRITE(Nform,1080)'outlier.total: ',iall IF(lidotl)WRITE(Nform,1080)'autoout: ',iauto END IF IF(Lsvlog)THEN WRITE(Ng,1060)' ' IF(iauto.eq.0)THEN WRITE(Ng,1060)' ','No outliers identified' ELSE WRITE(Ng,1070)' Total number of outliers identified: ',iauto END IF WRITE(Ng,1060)' ' END IF c ------------------------------------------------------------------ 1050 FORMAT(5x,a,' (t=',f10.2,')') 1060 FORMAT(a:,a) 1070 FORMAT(a,i6) 1080 FORMAT(a,i2) c ------------------------------------------------------------------ RETURN END savpk.f0000664006604000003110000001163414521201561011466 0ustar sun00315steps SUBROUTINE savpk(Iagr,Lsumm,Nspdir,Ntpdir) IMPLICIT NONE c ------------------------------------------------------------------ c save spectral peak information in log file and/or .xdg/.mdg file c ------------------------------------------------------------------ INCLUDE 'rho.cmn' INCLUDE 'units.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'spcsvl.i' c ------------------------------------------------------------------ INTEGER Iagr,Lsumm,Nspdir,Ntpdir c ------------------------------------------------------------------ IF(Ntpeak.eq.0)THEN Ctpeak(1:4)='none' Ntpeak=4 ELSE Ntpeak=Ntpeak-1 END IF IF(Nspeak.eq.0)THEN Cspeak(1:4)='none' Nspeak=4 ELSE Nspeak=Nspeak-1 END IF IF(Iagr.lt.3.and.Svltab(LSLSPK))THEN WRITE(Ng,1000)' Seasonal Spectral Peaks : ',Cspeak(1:Nspeak) WRITE(Ng,1000)' TD Spectral Peaks : ',Ctpeak(1:Ntpeak) ELSE IF (Iagr.gt.3)THEN IF(Svltab(LSLSPK).or.Svltab(LSLDSP))THEN IF(Cspeak(1:Nspeak).eq.'none')THEN WRITE(Ng,1000)' Seasonal Spectral Peaks (direct) : ', & Cspeak(1:Nspeak) ELSE IF(Nspdir.eq.0)THEN WRITE(Ng,1000)' Seasonal Spectral Peaks (direct) : ','none' ELSE IF(Nspdir.eq.Nspeak)THEN WRITE(Ng,1000)' Seasonal Spectral Peaks (direct) : ', & Cspeak(1:Nspeak) ELSE WRITE(Ng,1000)' Seasonal Spectral Peaks (direct) : ', & Cspeak(1:Nspdir) END IF IF(Ctpeak(1:Ntpeak).eq.'none')THEN WRITE(Ng,1000)' TD Spectral Peaks (direct) : ', & Ctpeak(1:Ntpeak) ELSE IF(Ntpdir.eq.0)THEN WRITE(Ng,1000)' TD Spectral Peaks (direct) : ','none' ELSE IF(Ntpdir.eq.Ntpeak)THEN WRITE(Ng,1000)' TD Spectral Peaks (direct) : ', & Ctpeak(1:Ntpeak) ELSE WRITE(Ng,1000)' TD Spectral Peaks (direct) : ', & Ctpeak(1:Ntpdir) END IF END IF IF(Svltab(LSLSPK))WRITE(Ng,1000)' ',' ' IF(Svltab(LSLSPK).or.Svltab(LSLISP))THEN IF(Cspeak(1:Nspeak).eq.'none')THEN WRITE(Ng,1000)' Seasonal Spectral Peaks (indirect) : ', & Cspeak(1:Nspeak) ELSE IF(Nspdir.eq.0)THEN WRITE(Ng,1000)' Seasonal Spectral Peaks (indirect) : ', & Cspeak(1:Nspeak) ELSE IF(Nspdir.eq.Nspeak)THEN WRITE(Ng,1000)' Seasonal Spectral Peaks (indirect) : ','none' ELSE WRITE(Ng,1000)' Seasonal Spectral Peaks (indirect) : ', & Cspeak((Nspdir+1):Nspeak) END IF IF(Ctpeak(1:Ntpeak).eq.'none')THEN WRITE(Ng,1000)' TD Spectral Peaks (indirect) : ', & Ctpeak(1:Ntpeak) ELSE IF(Ntpdir.eq.0)THEN WRITE(Ng,1000)' TD Spectral Peaks (indirect) : ', & Ctpeak(1:Ntpeak) ELSE IF(Ntpdir.eq.Ntpeak)THEN WRITE(Ng,1000)' TD Spectral Peaks (indirect) : ','none' ELSE WRITE(Ng,1000)' TD Spectral Peaks (indirect) : ', & Ctpeak((Ntpdir+1):Ntpeak) END IF END IF END IF c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN WRITE(Nform,1000)'peaks.seas: ',Cspeak(1:Nspeak) WRITE(Nform,1000)'peaks.td: ',Ctpeak(1:Ntpeak) IF(Iagr.gt.3)THEN IF(Cspeak(1:Nspeak).eq.'none')THEN WRITE(Nform,1000)'peaks.seas.dir: ',Cspeak(1:Nspeak) WRITE(Nform,1000)'peaks.seas.ind: ',Cspeak(1:Nspeak) ELSE IF(Nspdir.eq.0)THEN WRITE(Nform,1000)'peaks.seas.dir: ','none' WRITE(Nform,1000)'peaks.seas.ind: ',Cspeak(1:Nspeak) ELSE IF(Nspdir.eq.Nspeak)THEN WRITE(Nform,1000)'peaks.seas.dir: ',Cspeak(1:Nspeak) WRITE(Nform,1000)'peaks.seas.ind: ','none' ELSE WRITE(Nform,1000)'peaks.seas.dir: ',Cspeak(1:Nspdir) WRITE(Nform,1000)'peaks.seas.ind: ',Cspeak((Nspdir+1):Nspeak) END IF IF(Ctpeak(1:Ntpeak).eq.'none')THEN WRITE(Nform,1000)'peaks.td.dir: ',Ctpeak(1:Ntpeak) WRITE(Nform,1000)'peaks.td.ind: ',Ctpeak(1:Ntpeak) ELSE IF(Ntpdir.eq.0)THEN WRITE(Nform,1000)'peaks.td.dir: ','none' WRITE(Nform,1000)'peaks.td.ind: ',Ctpeak(1:Ntpeak) ELSE IF(Ntpdir.eq.Ntpeak)THEN WRITE(Nform,1000)'peaks.td.dir: ',Ctpeak(1:Ntpeak) WRITE(Nform,1000)'peaks.td.ind: ','none' ELSE WRITE(Nform,1000)'peaks.td.dir: ',Ctpeak(1:Ntpdir) WRITE(Nform,1000)'peaks.td.ind: ',Ctpeak((Ntpdir+1):Ntpeak) END IF END IF END IF 1000 FORMAT(a,a) RETURN END savspp.f0000664006604000003110000000402714521201561011654 0ustar sun00315stepsC Last change: BCM 15 Jan 98 12:01 pm **==savspp.f processed by SPAG 4.03F at 10:40 on 20 Oct 1994 SUBROUTINE savspp(Itbl,Sx,Frq,Nfrq,Lab,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- CHARACTER outstr*50,Lab*(*) INTEGER fh,i,ipos,Itbl,Nfrq DOUBLE PRECISION Sx,Frq DIMENSION Sx(0:(Nfrq-1)),Frq(0:(Nfrq-1)) LOGICAL lok,Lgraf c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ c Check to see if this is a spectrum. If so, store in a special c /rdb format. c ------------------------------------------------------------------ CALL opnfil(.true.,Lgraf,Itbl,fh,lok) IF(.not.lok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header information based on type of spectral plot c----------------------------------------------------------------------- WRITE(fh,1010)'Pos',TABCHR,'Frequency',TABCHR,Lab WRITE(fh,1010)'---',TABCHR,'-----------------------',TABCHR, & '-----------------------' c----------------------------------------------------------------------- c Save spectrum c----------------------------------------------------------------------- DO i=0,Nfrq-1 ipos=1 CALL itoc(i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Frq(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Sx(i),outstr,ipos) IF(Lfatal)RETURN WRITE(fh,1010)outstr(1:ipos-1) END DO c----------------------------------------------------------------------- CALL fclose(fh) RETURN c----------------------------------------------------------------------- 1010 FORMAT(a:,a,a,a,a) END savstp.f0000664006604000003110000000444314521201561011662 0ustar sun00315stepsC Last change: BCM 15 Jan 98 12:01 pm **==savspp.f processed by SPAG 4.03F at 10:40 on 20 Oct 1994 SUBROUTINE savstp(Itbl,Sx,Nfrq,Lab,Ldecbl,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- CHARACTER outstr*50,Lab*(*) INTEGER fh,i,ipos,Itbl,Nfrq DOUBLE PRECISION Sx,frq,sxx DIMENSION Sx(0:100) LOGICAL lok,Ldecbl,Lgraf c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'error.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION decibl EXTERNAL decibl c----------------------------------------------------------------------- c Check to see if this is a spectrum. If so, store in a special c /rdb format. c ------------------------------------------------------------------ CALL opnfil(.true.,Lgraf,Itbl,fh,lok) IF(.not.lok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header information based on type of spectral plot c----------------------------------------------------------------------- WRITE(fh,1010)'Pos',TABCHR,'Frequency',TABCHR,Lab WRITE(fh,1010)'---',TABCHR,'-----------------------',TABCHR, & '-----------------------' c----------------------------------------------------------------------- c Save spectrum c----------------------------------------------------------------------- DO i=0,Nfrq/2 ipos=1 CALL itoc(i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 frq=dble(float(i)/float(Nfrq)) CALL dtoc(frq,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 sxx=Sx(i) IF(Ldecbl)THEN IF(sxx.lt.0D0)sxx=-sxx sxx=decibl(sxx) END IF CALL dtoc(sxx,outstr,ipos) IF(Lfatal)RETURN WRITE(fh,1010)outstr(1:ipos-1) END DO c----------------------------------------------------------------------- CALL fclose(fh) RETURN c----------------------------------------------------------------------- 1010 FORMAT(a:,a,a,a,a) END savtbl.f0000664006604000003110000000644414521201561011640 0ustar sun00315stepsC Last change: BCM 11 Jun 1998 4:05 pm **==savtbl.f processed by SPAG 4.03F at 12:05 on 12 Jul 1994 SUBROUTINE savtbl(Itbl,Begdat,I1,Na,Sp,Avec,Label,Nser,Lopgrf) c----------------------------------------------------------------------- c Prints out a table in /rdb format, date then value. c----------------------------------------------------------------------- c Itbl - index number of table c Begdat - beginning date of series in table - c integer array of length 2 c i1 - pointer for position of first observation in table c Na - pointer for position of final observation in table c Avec - table data, double precison c label - series name, character scalar of length 64 c Nser - length of the series name c Lopgrf - Logical variable denoting whether output will be stored c in graphics directory. c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'cchars.i' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'filext.prm' c ------------------------------------------------------------------ CHARACTER outstr*30,Label*(64),tmplbl*(70) LOGICAL locok,Lopgrf INTEGER Begdat,fh,idate,ipos,Itbl,Na,rdbdat,tpnt,I1,Sp,Nser,ns4 DOUBLE PRECISION Avec DIMENSION Avec(*),Begdat(2),idate(2) c----------------------------------------------------------------------- INTEGER MO,YR PARAMETER(MO=2,YR=1) c ------------------------------------------------------------------ INCLUDE 'filext.var' c----------------------------------------------------------------------- c Open file with the an extension which depends on the type of the c series. c----------------------------------------------------------------------- CALL opnfil(.true.,Lopgrf,Itbl,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- ns4=Nser+4 tmplbl(1:ns4)=Label(1:Nser)//'.'//tbxdic(Itbl) c----------------------------------------------------------------------- c Print timeseries c----------------------------------------------------------------------- WRITE(fh,1010)'date',TABCHR,tmplbl(1:ns4) 1010 FORMAT(a:,a,a) WRITE(fh,1010)'------',TABCHR,'-----------------------' c ------------------------------------------------------------------ DO tpnt=I1,Na CALL addate(Begdat,Sp,tpnt-1,idate) IF(Sp.eq.1)THEN rdbdat=idate(YR) c ------------------------------------------------------------------ ELSE rdbdat=100*idate(YR)+idate(MO) END IF c ------------------------------------------------------------------ ipos=1 CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Avec(tpnt),outstr,ipos) IF(Lfatal)RETURN WRITE(fh,1010)outstr(1:ipos-1) END DO c ------------------------------------------------------------------ IF(locok)CALL fclose(fh) RETURN c ------------------------------------------------------------------ END savtpk.f0000664006604000003110000001031114521201561011641 0ustar sun00315steps SUBROUTINE savtpk(Iagr,Lsumm,Cstuk,Cttuk,Cstk90,Cttk90, & Cstuki,Cttuki,Csti90,Ctti90) IMPLICIT NONE c ------------------------------------------------------------------ c save spectral peak information in log file and/or .xdg/.mdg file c ------------------------------------------------------------------ INCLUDE 'units.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'spcsvl.i' c ------------------------------------------------------------------ CHARACTER Cstuk*(35),Cttuk*(35),Cstk90*(35),Cttk90*(35), & Cstuki*(35),Cttuki*(35),Csti90*(35),Ctti90*(35) INTEGER Iagr,Lsumm,nstuk,nttuk,nstk90,nttk90, & nstuki,nttuki,nsti90,ntti90 c ------------------------------------------------------------------ INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- nstuk=nblank(Cstuk) nttuk=nblank(Cttuk) nstk90=nblank(Cstk90) nttk90=nblank(Cttk90) IF(Iagr.gt.3)THEN nstuki=nblank(Cstuki) nttuki=nblank(Cttuki) nsti90=nblank(Csti90) ntti90=nblank(Ctti90) END IF c ------------------------------------------------------------------ IF(Iagr.lt.3.and.Svltab(LSLTPK))THEN WRITE(Ng,1000)' ',' ' WRITE(Ng,1000)' ',' ' WRITE(Ng,1000)' For Peak Probability > ','0.99' WRITE(Ng,1000)' Seasonal Tukey Spectral Peaks : ',Cstuk(1:nstuk) WRITE(Ng,1000)' TD Tukey Spectral Peaks : ',Cttuk(1:nttuk) WRITE(Ng,1000)' ',' ' WRITE(Ng,1000)' For Peak Probability > ','0.90' WRITE(Ng,1000)' Seasonal Tukey Spectral Peaks : ', & Cstk90(1:nstk90) WRITE(Ng,1000)' TD Tukey Spectral Peaks : ', & Cttk90(1:nttk90) ELSE IF (Iagr.gt.3)THEN IF(Svltab(LSLTPK).or.Svltab(LSLDTP).or.Svltab(LSLITP))THEN WRITE(Ng,1000)' ',' ' WRITE(Ng,1000)' Peak Probability > ','0.99' END IF IF(Svltab(LSLTPK).or.Svltab(LSLDTP))THEN WRITE(Ng,1000)' Seasonal Tukey Spectral Peaks (direct) : ', & Cstuk(1:nstuk) WRITE(Ng,1000)' TD Tukey Spectral Peaks (direct) : ', & Cttuk(1:nttuk) END IF IF(Svltab(LSLTPK))WRITE(Ng,1000)' ',' ' IF(Svltab(LSLTPK).or.Svltab(LSLITP))THEN WRITE(Ng,1000)' Seasonal Tukey Spectral Peaks (indirect) : ', & Cstuki(1:nstuki) WRITE(Ng,1000)' TD Tukey Spectral Peaks (indirect) : ', & Cttuki(1:nttuki) END IF IF(Svltab(LSLTPK).or.Svltab(LSLDTP).or.Svltab(LSLITP))THEN WRITE(Ng,1000)' ',' ' WRITE(Ng,1000)' Peak Probability > ','0.90' END IF IF(Svltab(LSLTPK).or.Svltab(LSLDTP))THEN WRITE(Ng,1000)' Seasonal Tukey Spectral Peaks (direct) : ', & Cstk90(1:nstk90) WRITE(Ng,1000)' TD Tukey Spectral Peaks (direct) : ', & Cttk90(1:nttk90) END IF IF(Svltab(LSLTPK))WRITE(Ng,1000)' ',' ' IF(Svltab(LSLTPK).or.Svltab(LSLITP))THEN WRITE(Ng,1000)' Seasonal Tukey Spectral Peaks (indirect) : ', & Csti90(1:nsti90) WRITE(Ng,1000)' TD Tukey Spectral Peaks (indirect) : ', & Ctti90(1:ntti90) END IF END IF c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN WRITE(Nform,1000)'peaks.tukey.seas: ',Cstuk(1:nstuk) WRITE(Nform,1000)'peaks.tukey.td: ',Cttuk(1:nttuk) IF(Iagr.gt.3)THEN WRITE(Nform,1000)'peaks.tukey.seas.ind: ',Cstuki(1:nstuki) WRITE(Nform,1000)'peaks.tukey.td.ind: ',Cttuki(1:nttuki) END IF WRITE(Nform,1000)'peaks.tukey.p90.seas: ',Cstk90(1:nstk90) WRITE(Nform,1000)'peaks.tukey.p90.td: ',Cttk90(1:nttk90) IF(Iagr.gt.3)THEN WRITE(Nform,1000)'peaks.tukey.p90.seas.ind: ',Csti90(1:nsti90) WRITE(Nform,1000)'peaks.tukey.p90.td.ind: ',Ctti90(1:ntti90) END IF END IF 1000 FORMAT(a,a) RETURN END savwkf.f0000664006604000003110000000705314521201561011643 0ustar sun00315steps SUBROUTINE savwkf(Nptr) IMPLICIT NONE c----------------------------------------------------------------------- c Save the Wiener-Kolmogrov filters from SEATS into a file. c----------------------------------------------------------------------- LOGICAL T,F INTEGER PSTLEN PARAMETER(T=.true.,F=.false.,PSTLEN=120) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'cchars.i' INCLUDE 'seatmd.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER str*(PSTLEN) INTEGER fh,ipos,icol,nlen,ncol,Nptr LOGICAL locok c----------------------------------------------------------------------- c open file c----------------------------------------------------------------------- CALL opnfil(T,F,Nptr,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c----------------------------------------------------------------------- c Print header for end filters c----------------------------------------------------------------------- CALL setchr(' ',PSTLEN,str) str(1:3)='lag' ipos=4 nlen=NOTSET ncol=0 IF(Ntcwkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 IF(nlen.eq.NOTSET)nlen=Ntcwkf str(ipos:ipos+11)='TC_WK_Filter' ipos=ipos+12 ncol=ncol+1 END IF IF(Nsawkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 IF(nlen.eq.NOTSET)nlen=Nsawkf str(ipos:ipos+11)='SA_WK_Filter' ipos=ipos+12 ncol=ncol+1 END IF IF(Nswkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 IF(nlen.eq.NOTSET)nlen=Nswkf str(ipos:ipos+10)='S_WK_Filter' ipos=ipos+11 ncol=ncol+1 END IF IF(Ntrwkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 IF(nlen.eq.NOTSET)nlen=Ntrwkf str(ipos:ipos+11)='TR_WK_Filter' ipos=ipos+12 ncol=ncol+1 END IF IF(Nirwkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 IF(nlen.eq.NOTSET)nlen=Nirwkf str(ipos:ipos+12)='IRR_WK_Filter' ipos=ipos+13 ncol=ncol+1 END IF WRITE(fh,1000)str(1:(ipos-1)) WRITE(fh,1000)'---', & (TABCHR,'-----------------------',icol=1,ncol) c----------------------------------------------------------------------- DO icol=1,nlen ipos=1 CALL itoc(icol,str,ipos) IF(Ntcwkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Tcwkf(icol),str,ipos) IF(Lfatal)RETURN END IF IF(Nsawkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Sawkf(icol),str,ipos) IF(Lfatal)RETURN END IF IF(Nswkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Swkf(icol),str,ipos) IF(Lfatal)RETURN END IF IF(Ntrwkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Trwkf(icol),str,ipos) IF(Lfatal)RETURN END IF IF(Nirwkf.gt.0)THEN str(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Irwkf(icol),str,ipos) IF(Lfatal)RETURN END IF WRITE(fh,1000)str(1:(ipos-1)) END DO c----------------------------------------------------------------------- 1000 FORMAT(1000a) CALL fclose(fh) RETURN END sceast.f0000664006604000003110000000172214521201561011621 0ustar sun00315steps DOUBLE PRECISION FUNCTION sceast(Ndays,Pdays,First,Ineast) IMPLICIT NONE c ------------------------------------------------------------------ c function generates the Statistics Canada Easter regressor c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1.0D0,ZERO=0.0D0) c ------------------------------------------------------------------ LOGICAL First,Ineast INTEGER Ndays,Pdays c ------------------------------------------------------------------ IF(First)THEN IF(Pdays.eq.Ndays.or.Ineast)THEN sceast=ONE ELSE sceast=dble(Pdays)/dble(Ndays) END IF ELSE IF(Pdays.eq.Ndays)THEN sceast=ZERO ELSE sceast=dble(Pdays-Ndays)/dble(Ndays) END IF END IF c ------------------------------------------------------------------ RETURN END scrmlt.f0000664006604000003110000000114014521201561011635 0ustar sun00315steps**==scrmlt.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE scrmlt(C,N,X) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to multiply a double precision vector by a scalar c----------------------------------------------------------------------- INTEGER i,N DOUBLE PRECISION C,X(*) c ------------------------------------------------------------------ DO i=1,N X(i)=C*X(i) END DO c ------------------------------------------------------------------ RETURN END sdev.f0000664006604000003110000000327314521201562011304 0ustar sun00315steps**==sdev.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 DOUBLE PRECISION FUNCTION sdev(X,I,J,K,Iopt) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS FUNCTION CALCULATES THE STANDARD DEVIATION OF X. IF IOPT = 0 C --- THE MEAN OF X IS COMPUTED, IF IOPT = 1 THE MEAN IS ASSUMED TO BE C --- ZERO, AND IF IOPT = 2 THE MEAN IS ASSUMED TO BE ONE. c----------------------------------------------------------------------- c revised by BCM March 2006 to handle cases where "bad" values for c multiplicative seasonal adjustment are found c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE PARAMETER(ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'notset.prm' c----------------------------------------------------------------------- DOUBLE PRECISION ave,fn,X,totals INTEGER I,Iopt,J,K,l DIMENSION X(*) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- fn=ZERO IF(Iopt.lt.1)THEN ave=totals(X,I,J,K,1) ELSE IF(Iopt.eq.1)THEN ave=ZERO ELSE ave=ONE END IF sdev=ZERO DO l=I,J,K * IF((.not.(Missng.and.X(l).eq.Mvval).and.Gudval(l))THEN IF(.not.dpeq(X(l),DNOTST))THEN sdev=sdev+(X(l)-ave)*(X(l)-ave) fn=fn+ONE END IF END DO IF(fn.gt.ZERO)THEN sdev=sqrt(sdev/fn) ELSE sdev=DNOTST END IF RETURN END sdxtrm.f0000664006604000003110000000652714521201562011671 0ustar sun00315stepsC Last change: BCM 2 Oct 97 7:47 am **==sdxtrm.f processed by SPAG 4.03F at 17:02 on 16 May 1994 DOUBLE PRECISION FUNCTION sdxtrm(Xi,Xbar,L,M,Nsp,Imad,Istep,Ny, & Lgrp) c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'xtrm.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER (ZERO=0D0) c----------------------------------------------------------------------- LOGICAL Lgrp,lselec,lsig DOUBLE PRECISION Xi,Xbar,stau,xn,abdev,median INTEGER L,M,Nsp,Imad,Istep,n,ixn,i2,Ny,nper DIMENSION Xi(*),abdev(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq,istrue DOUBLE PRECISION rho2 EXTERNAL rho2,istrue,dpeq c----------------------------------------------------------------------- C --- COMPUTE FIVE YEAR STANDARD DEVIATION (OR MEDIAN ABSOLUTE C DEVIATION) OF THE IRREGULARS. c----------------------------------------------------------------------- sdxtrm=ZERO xn=ZERO ixn=0 lsig=istrue(Csigvc,1,Ny).and.Ksdev.eq.4 DO n=L,M,Nsp lselec=.true. IF(lsig)THEN nper=mod(n,Ny) IF(nper.eq.0)nper=Ny lselec=Csigvc(nper).and.Lgrp IF(.not.lselec)lselec=(.not.Csigvc(nper)).and.(.not.Lgrp) END IF IF((.not.(Istep.eq.2.and.dpeq(Stwt(n),ZERO))).and.lselec)THEN c----------------------------------------------------------------------- C --- OMIT EXTREMES FROM THE CALCULATION OF THE FIVE YEAR SD OR MAD c----------------------------------------------------------------------- xn=xn+1D0 ixn=ixn+1 IF(Imad.eq.0)sdxtrm=sdxtrm+(Xi(n)-Xbar)*(Xi(n)-Xbar) IF(Imad.eq.1.or.Imad.eq.3)abdev(ixn)=abs(Xi(n)-Xbar) IF(Imad.eq.2.or.Imad.eq.4)abdev(ixn)=abs(log(Xi(n))) END IF END DO IF(Imad.eq.0)sdxtrm=sqrt(sdxtrm/xn) IF(Imad.ge.1)THEN ixn=int(xn) CALL shlsrt(ixn,abdev) c----------------------------------------------------------------------- c --- calculate median absolute difference c----------------------------------------------------------------------- IF(mod(ixn,2).eq.0)THEN median=(abdev(ixn/2)+abdev(ixn/2+1))/2D0 ELSE median=abdev((ixn+1)/2) END IF c----------------------------------------------------------------------- c --- calculate median absolute deviation c----------------------------------------------------------------------- sdxtrm=median/0.6745D0 IF(Imad.eq.2.or.Imad.eq.4)sdxtrm=sqrt(exp(sdxtrm*sdxtrm)*(exp( & sdxtrm*sdxtrm)-1)) c----------------------------------------------------------------------- c --- derive tau adjustment for mad standard error c----------------------------------------------------------------------- IF(Imad.ge.3)THEN stau=ZERO DO i2=1,ixn stau=stau+rho2(abdev(i2)/sdxtrm) END DO sdxtrm=sqrt(sdxtrm*sdxtrm*stau/n) END IF END IF c----------------------------------------------------------------------- RETURN END seastest.i0000664006604000003110000000035114521201562012173 0ustar sun00315stepsC C... Variables in Common Block /seasTest/ ... integer OST,crQS,crSNP,crPeaks integer totalSeasTR,totalSeasSA,totalSeasIR common /seasTest/ OST,crQS,crSNP,crPeaks, $ totalSeasTR,totalSeasSA,totalSeasIR seatad.cmn0000664006604000003110000000030014521201562012120 0ustar sun00315steps DOUBLE PRECISION Orixs,Fctses DIMENSION Orixs(PLEN),Fctses(PFCST) c----------------------------------------------------------------------- COMMON / adseat / Orixs,Fctses seatad.f0000664006604000003110000001156714521201562011611 0ustar sun00315steps SUBROUTINE seatad(Muladd,Ny,Nfcst) IMPLICIT NONE C----------------------------------------------------------------------- c Make adjustments or set seasonal adjustment component variables c generated by the SEATS signal extraction routines c Created by Brian Monsell October 2005 C----------------------------------------------------------------------- INCLUDE 'srslen.prm' * INCLUDE 'lzero.cmn' * INCLUDE 'priadj.cmn' * INCLUDE 'priusr.cmn' INCLUDE 'seatcm.cmn' c INCLUDE 'seatmd.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' C----------------------------------------------------------------------- INTEGER Muladd,Ny,Nfcst,i,i2,nlast C----------------------------------------------------------------------- nlast=Posffc c IF(Nfcst.gt.3*Ny)nlast=nlast-(Nfcst-3*Ny) C----------------------------------------------------------------------- IF(Muladd.ne.1)THEN DO i=Pos1bk,nlast IF(Havesf)Seatsf(i)=Seatsf(i)/100D0 IF(Haveir)Seatir(i)=Seatir(i)/100D0 IF(Haveaf)Seataf(i)=Seataf(i)/100D0 IF(Havecy)Seatcy(i)=Seatcy(i)/100D0 END DO END IF C----------------------------------------------------------------------- c append seasonal forecasts to seasonal component, if it exists. c also combine seasonal component with seasonal regression factors. C----------------------------------------------------------------------- IF(Havesf)THEN IF(Havfsf)THEN DO i=Posfob+1,nlast Seatsf(i)=Setfsf(i-Posfob) IF(Muladd.ne.1)Seatsf(i)=Seatsf(i)/100D0 END DO END IF IF(Adjsea.eq.1)CALL addmul(Seatsf,Facsea,Seatsf,Pos1bk,Posffc) END IF C----------------------------------------------------------------------- c append forecasts of adjusted series to seasonally adjusted series, c if it exists. c also remove seasonal component from final seasonally adjusted data. C----------------------------------------------------------------------- IF(Havesa)THEN IF(Havfsa)THEN DO i=Posfob+1,nlast Seatsa(i)=Setfsa(i-Posfob) END DO END IF IF(Adjsea.eq.1)CALL divsub(Seatsa,Seatsa,Facsea,Pos1bk,Posffc) C----------------------------------------------------------------------- c if there are temporary prior adjustments, add these back to the c seasonally adjusted series *C----------------------------------------------------------------------- * IF(Nustad.gt.0)THEN * DO i=Pos1bk,Posffc * i2=Frstat+i-Pos1bk+Lsp-1 * IF(Muladd.eq.1)THEN * Seatsa(i)=Seatsa(i)+Usrtad(i2) * ELSE * Seatsa(i)=Seatsa(i)*Usrtad(i2) * END IF * END DO * END IF C----------------------------------------------------------------------- * IF(Finao.and.Nao.gt.0) * & CALL divsub(Seatsa,Seatsa,Facao,Pos1bk,Posffc) * IF(Finls.and.Nls.gt.0) * & CALL divsub(Seatsa,Seatsa,Facls,Pos1bk,Posffc) * IF(Fintc.and.Ntc.gt.0) * & CALL divsub(Seatsa,Seatsa,Factc,Pos1bk,Posffc) * IF(Finusr) * & CALL divsub(Seatsa,Seatsa,Facusr,Pos1bk,Posffc) END IF C----------------------------------------------------------------------- c append forecasts of trend to the trend component, if it exists. C----------------------------------------------------------------------- IF(Havetr)THEN IF(Havftr)THEN DO i=Posfob+1,nlast Seattr(i)=Setftr(i-Posfob) END DO END IF END IF C----------------------------------------------------------------------- c append forecasts of irregular to the irregular component, c if it exists. C----------------------------------------------------------------------- IF(Haveir)THEN IF(Havfir)THEN DO i=Posfob+1,nlast Seatir(i)=Setfir(i-Posfob) IF(Muladd.ne.1)Seatir(i)=Seatir(i)/100D0 END DO END IF END IF C----------------------------------------------------------------------- c append forecasts of transitory to the transitory component, c if it exists. C----------------------------------------------------------------------- IF(Havecy)THEN IF(Havfcy)THEN DO i=Posfob+1,nlast Seatcy(i)=Setfcy(i-Posfob) IF(Muladd.ne.1)Seatcy(i)=Seatcy(i)/100D0 END DO END IF END IF C----------------------------------------------------------------------- c combine adjustment factors with seasonal regression factors. C----------------------------------------------------------------------- IF(Haveaf)THEN IF(Adjsea.eq.1)CALL addmul(Seataf,Facsea,Seataf,Pos1bk,nlast) END IF C----------------------------------------------------------------------- RETURN END seatcm.cmn0000664006604000003110000000347514521201562012153 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Seattr,Seatsf,Seatir,Seatsa,Seatcy,Setftr, & Setfsf,Setfir,Setfsa,Setfcy,Sttftr,Sttfsf, & Sttfor,Sttfsa,Sttfcy,Sseftr,Ssefsf,Ssefor, & Ssefsa,Ssefcy,Ssrftr,Ssrfsf,Ssrfsa,Ssrfcy, & Seataf,Spitrc,Spis,Spitra,Spisa,Sep,Sebp,Seq, & Sebq,Stocir,Stocsa,Setsa2,Stsarn,Sttrse,Stsfse, & Stsase,Stcyse,Setcyc,Setltt,Odiff DIMENSION Seattr(PLEN),Seatsf(PLEN),Seatir(PLEN),Seatsa(PLEN), & Seatcy(PLEN),Setftr(PFCST),Setfsf(PFCST),Setfir(PFCST), & Setfsa(PFCST),Setfcy(PFCST),Sttftr(PFCST),Sttfsf(PFCST), & Sttfor(PFCST),Sttfsa(PFCST),Sttfcy(PFCST),Sseftr(PFCST), & Ssefsf(PFCST),Ssefor(PFCST),Ssefsa(PFCST),Ssefcy(PFCST), & Ssrftr(PFCST),Ssrfsf(PFCST),Ssrfsa(PFCST),Ssrfcy(PFCST), & Seataf(PLEN),Spitrc(PLEN),Spis(PLEN),Spitra(PLEN), & Spisa(PLEN),Sep(3),Sebp(3),Seq(3),Sebq(3),Stocir(PLEN), & Stocsa(PLEN),Setsa2(PLEN),Stsarn(PLEN),Sttrse(PLEN), & Stsfse(PLEN),Stsase(PLEN),Stcyse(PLEN),Setcyc(PLEN), & Setltt(PLEN),Odiff(PLEN) c----------------------------------------------------------------------- COMMON / seatcm / Seattr,Seatsf,Seatir,Seatsa,Seatcy,Setftr, & Setfsf,Setfir,Setfsa,Setfcy,Sttftr,Sttfsf, & Sttfor,Sttfsa,Sttfcy,Sseftr,Ssefsf,Ssefor, & Ssefsa,Ssefcy,Ssrftr,Ssrfsf,Ssrfsa,Ssrfcy, & Seataf,Spitrc,Spis,Spitra,Spisa,Sep,Sebp, & Seq,Sebq,Stocir,Stocsa,Setsa2,Stsarn,Sttrse, & Stsfse,Stsase,Stcyse,Setcyc,Setltt,Odiff seatdg.cmn0000664006604000003110000000171214521201562012136 0ustar sun00315steps CHARACTER X13mdl*(132) DOUBLE PRECISION Kurt,Kurtse,Testnm,Skew,Skewse,Sdres,Ceetrn, & Ceesad,Prsetr,Prsesa,Aadasa,Aadatr,Tsetrn,Tsesea, & Tsetcm,Tsesad,Vartrn,Varsad,Varirr,Varsea,Dwstat, & SeasNP INTEGER Iprsm,Iqrsm,Ipssm,Iqssm,Idrsm,Idssm,Ssghst,Ssgcnc,Ssgfct, & Nxmdl DIMENSION Prsetr(5),Prsesa(5),Vartrn(3),Varsad(3),Varirr(3), & Varsea(3) c----------------------------------------------------------------------- COMMON /stdiag/Kurt,Kurtse,Testnm,Skew,Skewse,Sdres,Ceetrn,Ceesad, & Prsetr,Prsesa,Aadasa,Aadatr,Tsetrn,Tsesea,Tsetcm, & Tsesad,Vartrn,Varsad,Varirr,Varsea,Dwstat,SeasNP, & Ssghst,Ssgcnc,Ssgfct,Iprsm,Iqrsm,Ipssm,Iqssm,Idrsm, & Idssm COMMON /chdiag/X13mdl,Nxmdl c----------------------------------------------------------------------- seatdg.f0000664006604000003110000005456114521201562011620 0ustar sun00315stepsC Last change: BCM 19 May 2003 9:29 am SUBROUTINE seatdg(Issap,Irev,Irevsa,Ny,Iag,Iagr,Muladd,Lsumm, & Lseats,Lgraf,Lam,Nfcst,Length) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' INCLUDE 'notset.prm' INCLUDE 'model.prm' INCLUDE 'stdio.i' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'seatcm.cmn' INCLUDE 'seatdg.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'units.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'setsvl.i' INCLUDE 'inpt.cmn' INCLUDE 'cmpflts.i' INCLUDE 'force.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'seattb.i' INCLUDE 'sig.i' INCLUDE 'revtbl.i' c ------------------------------------------------------------------ INTEGER N1,N12 DOUBLE PRECISION ZERO PARAMETER (N12 = 12, N1 = 1, ZERO = 0D0) INCLUDE 'calc.i' c ------------------------------------------------------------------ DOUBLE PRECISION TSELIM LOGICAL F,T PARAMETER (TSELIM=0.001D0,T=.true.,F=.false.) c ------------------------------------------------------------------ INTEGER Issap,Irev,Irevsa,Ny,Iag,Iagr,Muladd,i,ncmdl,Lsumm,nstr1, & nstr2,Nfcst,idate,bjmdvc,Length DOUBLE PRECISION Lam,tval LOGICAL Lseats,Lgraf c change variable name cmdl to cmdls, sig to sigs to avoid conflit with c common block name cmdl in model.cmn and sig in sig.i --Jan. 2021 CHARACTER sigs*(1),cmdls*(132),ssig*(1),str1*(8),str2*(19) DIMENSION ssig(-1:1),idate(2),bjmdvc(6) c ------------------------------------------------------------------ INTEGER getSsf,getSsp2,getSsh LOGICAL dpeq,istrue EXTERNAL dpeq,istrue,getSsf,getSsp2,getSsh c ------------------------------------------------------------------ DATA ssig / '+','0','-' / c ------------------------------------------------------------------ IF(Issap.lt.2.and.Irev.lt.4)THEN IF(Havesa)THEN IF(Havesf)THEN IF(Lsumm.gt.0)WRITE(Nform,1000)'seatsadj','yes' ELSE IF(Lsumm.gt.0)WRITE(Nform,1000)'seatsadj','nosf' END IF ELSE IF(Lsumm.gt.0)WRITE(Nform,1000)'seatsadj','no' END IF END IF c ------------------------------------------------------------------ c If runs for the revisions history or sliding spans analysis are c done, store the required components. c ------------------------------------------------------------------ IF(Issap.gt.0)THEN IF((.not.Havesa).or.(.not.Havesf))THEN IF(.not.Havesa)THEN str1 = 'cannot' nstr1 = 6 str2 = 'signal extraction' nstr2 = 17 ELSE str1 = 'does not' nstr1 = 8 str2 = 'seasonal adjustment' nstr2 = 19 END IF IF(.not.Lquiet)WRITE(STDERR,1070)str1(1:nstr1) WRITE(Mt2,1070)str1(1:nstr1) IF(Issap.eq.2)THEN IF(.not.Lquiet) & WRITE(STDERR,1080)str2(1:nstr2),' for a span of data.' WRITE(Mt2,1080)str2(1:nstr2),' for a span of data.' Issap=0-Issap RETURN ELSE IF(.not.Lquiet)WRITE(STDERR,1080)str2(1:nstr2),'.' WRITE(Mt2,1080)str2(1:nstr2),'.' Issap=0 END IF END IF END IF IF(Issap.eq.2)THEN CALL ssrit(Seatsf,Pos1ob,Posfob,2,Series) IF(Lrndsa)THEN CALL ssrit(Stsarn,Pos1ob,Posfob,3,Series) ELSE IF(Iyrt.gt.0)THEN CALL ssrit(Setsa2,Pos1ob,Posfob,3,Series) ELSE CALL ssrit(Seatsa,Pos1ob,Posfob,3,Series) END IF RETURN END IF c ------------------------------------------------------------------ IF(Irev.gt.0)THEN IF(((Lrvsa.or.Lrvch).and.((.not.Havesa).or.(.not.Havesf))).or. & ((Lrvtrn.or.Lrvtch).and.(.not.Havetr)).or. & (Lrvsf.and.(.not.Havesf)))THEN CALL writln('WARNING: History analysis for estimates derived fro &m SEATS adjustments',STDERR,Mt2,T) CALL writln(' cannot be done when SEATS cannot perform a & signal extraction.',STDERR,Mt2,F) IF((Lrvsa.or.Lrvch).and.((.not.Havesa).or.(.not.Havesf)))THEN IF(Lrvsa)Lrvsa=F IF(Lrvch)Lrvch=F END IF IF((Lrvtrn.or.Lrvtch).and.(.not.Havetr))THEN IF(Lrvtrn)Lrvtrn=F IF(Lrvtch)Lrvtch=F END IF IF(Lrvsf.and.(.not.Havesf))Lrvsf=F c ------------------------------------------------------------------ IF(.not.(Lrvsf.or.Lrvsa.or.Lrvch.or.Lrvtrn.or.Lrvtch))THEN IF(Irevsa.gt.0)Irevsa=-1 IF(Lrvaic.or.Lrvfct)THEN Lseats=F IF(Irev.eq.4)RETURN ELSE IF(Irev.eq.4)THEN Irev=0-Irev RETURN ELSE Irev=0 END IF END IF END IF END IF END IF c ------------------------------------------------------------------ IF(Irev.eq.4)THEN IF(Lrvsf)THEN CALL getrev(Seatsf,Posfob,Muladd,0,Ny,Iag,Iagr) c ------------------------------------------------------------------ c BCM - July 29, 2009 c Special code to save seasonal factor forecasts for concurrent c adjustments. c ------------------------------------------------------------------ IF(Revptr.gt.0.and.Savtab(LRVSSH))THEN CALL addate(Rvstrt,Ny,Revptr,idate) * WRITE(Fhsfh,1120)'begfct.rev',Revptr,idate WRITE(Fhsfh,1120)idate IF(Muladd.ne.1)THEN DO i=1,Nfcst WRITE(Fhsfh,1130)Setfsf(i)/100D0 END DO ELSE DO i=1,Nfcst WRITE(Fhsfh,1130)Setfsf(i) END DO END IF END IF END IF IF(Lrvsa.or.Lrvch)THEN IF(Lrndsa)THEN CALL getrev(Stsarn,Posfob,Muladd,1,Ny,Iag,Iagr) ELSE IF(Iyrt.gt.0)THEN CALL getrev(Setsa2,Posfob,Muladd,1,Ny,Iag,Iagr) ELSE CALL getrev(Seatsa,Posfob,Muladd,1,Ny,Iag,Iagr) END IF END IF IF(Lrvtrn.or.Lrvtch) & CALL getrev(Seattr,Posfob,Muladd,2,Ny,Iag,Iagr) END IF c ------------------------------------------------------------------ IF(Issap.eq.2.or.Irev.eq.4)RETURN c----------------------------------------------------------------------- c Save squared gain and phase delay, if requested c----------------------------------------------------------------------- IF(Savtab(LSESGS).and.lSAGain(1))THEN CALL svfltd(fltW,SAGain,LSESGS,F,1,'SA_Squ_Gain_Symetric') IF(Lfatal)RETURN END IF IF(Savtab(LSESGC).and.lSAGain(2))THEN CALL svfltd(fltW,SAGain,LSESGC,F,2,'SA_Squ_Gain_Conc') IF(Lfatal)RETURN END IF IF(Savtab(LSETGS).and.lTreGain(1))THEN CALL svfltd(fltW,treGain,LSETGS,F,1,'Trn_Squ_Gain_Symetric') IF(Lfatal)RETURN END IF IF(Savtab(LSETGC).and.lTreGain(2))THEN CALL svfltd(fltW,treGain,LSETGC,F,2,'Trn_Squ_Gain_Conc') IF(Lfatal)RETURN END IF IF(Savtab(LSESDC).and.lSATmShf(2))THEN CALL svfltd(fltW,SATmShf,LSESDC,F,2,'SA_Time_Shift_Conc') IF(Lfatal)RETURN END IF IF(Savtab(LSETDC).and.ltreTmShf(2))THEN CALL svfltd(fltW,treTmShf,LSETDC,F,2,'Trn_Time_Shift_Conc') IF(Lfatal)RETURN END IF IF(Lgraf)THEN IF(lSAGain(1))THEN CALL svfltd(fltW,SAGain,LSESGS,Lgraf,1,'SA_Squ_Gain_Symetric') IF(Lfatal)RETURN END IF IF(lSAGain(2))THEN CALL svfltd(fltW,SAGain,LSESGC,Lgraf,2,'SA_Squ_Gain_Conc') IF(Lfatal)RETURN END IF IF(lTreGain(1))THEN CALL svfltd(fltW,treGain,LSETGS,Lgraf,1,'Trn_Squ_Gain_Symetric') IF(Lfatal)RETURN END IF IF(lTreGain(2))THEN CALL svfltd(fltW,treGain,LSETGC,Lgraf,2,'Trn_Squ_Gain_Conc') IF(Lfatal)RETURN END IF IF(lSATmShf(2))THEN CALL svfltd(fltW,SATmShf,LSESDC,Lgraf,2,'SA_Time_Shift_Conc') IF(Lfatal)RETURN END IF IF(ltreTmShf(2))THEN CALL svfltd(fltW,treTmShf,LSETDC,Lgraf,2,'Trn_Time_Shift_Conc') IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- IF(Savtab(LSESFS).and.lSaFlt(1))THEN CALL svflt(Pos1ob,Posfob,SAFlt,LSESFS,F,1,'SA_Filter_Symetric') IF(Lfatal)RETURN END IF IF(Savtab(LSESFC).and.lSaFlt(2))THEN CALL svflt(Pos1ob,Posfob,SAFlt,LSESFC,F,2,'SA_Filter_Conc') IF(Lfatal)RETURN END IF IF(Savtab(LSETFS).and.lTreFlt(1))THEN CALL svflt(Pos1ob,Posfob,treFlt,LSETFS,F,1, & 'Trn_Filter_Symetric') IF(Lfatal)RETURN END IF IF(Savtab(LSETFC).and.lTreFlt(2))THEN CALL svflt(Pos1ob,Posfob,treFlt,LSETFC,F,2,'Trn_Filter_Conc') IF(Lfatal)RETURN END IF IF(Lgraf)THEN IF(lSaFlt(1))THEN CALL svflt(Pos1ob,Posfob,SAFlt,LSESFS,Lgraf,1, & 'SA_Filter_Symetric') IF(Lfatal)RETURN END IF IF(lSaFlt(2))THEN CALL svflt(Pos1ob,Posfob,SAFlt,LSESFC,Lgraf,2, & 'SA_Filter_Conc') IF(Lfatal)RETURN END IF IF(lTreFlt(1))THEN CALL svflt(Pos1ob,Posfob,treFlt,LSETFS,Lgraf,1, & 'Trn_Filter_Symetric') IF(Lfatal)RETURN END IF IF(lTreFlt(2))THEN CALL svflt(Pos1ob,Posfob,treFlt,LSETFC,Lgraf,2, & 'Trn_Filter_Conc') IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ ncmdl=0 IF(Iprsm.ne.NOTSET.and.Iqrsm.ne.NOTSET.and.Ipssm.ne.NOTSET.and. & Iqssm.ne.NOTSET.and.Idrsm.ne.NOTSET.and.Idssm.ne.NOTSET)THEN Ipssm=Ipssm/Ny Iqssm=Iqssm/Ny CALL mkmdsn(Iprsm,Idrsm,Iqrsm,Ipssm,Idssm,Iqssm,cmdls,ncmdl) bjmdvc(1)=Iprsm bjmdvc(2)=Idrsm bjmdvc(3)=Iqrsm bjmdvc(4)=Ipssm bjmdvc(5)=Idssm bjmdvc(6)=Iqssm ELSE CALL mkmdsn(P,D,Q,Bp,Bd,Bq,cmdls,ncmdl) bjmdvc(1)=P bjmdvc(2)=D bjmdvc(3)=Q bjmdvc(4)=Bp bjmdvc(5)=Bd bjmdvc(6)=Bq END IF IF(Lfatal)RETURN IF(ncmdl.gt.0)THEN IF(Svltab(LSLSMD))THEN IF(cmdls(1:ncmdl).eq.X13mdl(1:Nxmdl))THEN WRITE(Ng,1000)' SEATS model',cmdls(1:ncmdl) ELSE WRITE(Ng,1000)' SEATS model',cmdls(1:ncmdl)// & ' (SEATS routines changed ARIMA model)' END IF END IF IF(Lsumm.gt.0)WRITE(Nform,1000)'seatsmdl',cmdls(1:ncmdl) IF(cmdls(1:ncmdl).ne.X13mdl(1:Nxmdl))THEN CALL writln('NOTE: Model used for SEATS decomposition is differe &nt from the model',STDERR,Mt2,T) CALL writln(' estimated in the regARIMA modeling module of &X-13A-S.',STDERR,Mt2,F) END IF END IF c ------------------------------------------------------------------ IF ((.not.istrue(Svltab,LSLSMD,LSLSSG)).and.Lsumm.eq.0) RETURN c----------------------------------------------------------------------- c BCM 4-11-2006 - add seats model coefficients to savelog output c----------------------------------------------------------------------- IF(Lsumm.gt.0.or.Svltab(LSLSMD))THEN IF(Lsumm.gt.0)THEN WRITE(Nform,1090)'seats$nonseasonaldiff',D WRITE(Nform,1090)'seats$seasonaldiff',Bd WRITE(Nform,1090)'seats$nmodel',P+Q+Bp+Bq END IF IF(P.gt.0)THEN DO i=1,P tval=ZERO IF(Sep(i).gt.ZERO)tval=Phi(i)/Sep(i) IF(Svltab(LSLSMD)) & WRITE(Ng,1100)' Nonseasonal AR(',i,') - ',Phi(i),' ', & Sep(i),' ',tval IF(Lsumm.gt.0) & WRITE(Nform,1100)'seats$AR$Nonseasonal$01$',i,': ',Phi(i), & ' ',Sep(i),' ',tval END DO END IF IF(Bp.gt.0)THEN DO i=1,Bp tval=ZERO IF(Sebp(i).gt.ZERO)tval=Bphi(i)/Sebp(i) IF(Svltab(LSLSMD)) & WRITE(Ng,1100)' Seasonal AR(',i,') - ',Bphi(i),' ', & Sebp(i),' ',tval IF(Lsumm.gt.0) & WRITE(Nform,1100)'seats$AR$Seasonal$12$',i*Ny,': ',Bphi(i), & ' ',Sebp(i),' ',tval END DO END IF IF(Q.gt.0)THEN DO i=1,Q tval=ZERO IF(Seq(i).gt.ZERO)tval=Th(i)/Seq(i) IF(Svltab(LSLSMD)) & WRITE(Ng,1100)' Nonseasonal MA(',i,') - ',Th(i),' ', & Sebp(i),' ',tval IF(Lsumm.gt.0) & WRITE(Nform,1100)'seats$MA$Nonseasonal$01$',i,': ',Th(i), & ' ',Seq(i),' ',tval END DO END IF IF(Bq.gt.0)THEN DO i=1,Bq tval=ZERO IF(Sebq(i).gt.ZERO)tval=Bth(i)/Sebq(i) IF(Svltab(LSLSMD)) & WRITE(Ng,1100)' Seasonal MA(',i,') - ',Bth(i),' ', & Sebq(i),' ',tval IF(Lsumm.gt.0) & WRITE(Nform,1100)'seats$MA$Seasonal$12$',i*Ny,': ',Bth(i), & ' ',Sebq(i),' ',tval END DO END IF IF(Svltab(LSLSMD))WRITE(Ng,1061)' ' END IF c ------------------------------------------------------------------ IF(Svltab(LSLSNR).or.Lsumm.gt.0)THEN IF(.not.dpeq(Testnm,DNOTST))THEN IF(Svltab(LSLSNR)) & WRITE(Ng,1010)' Normality Test',Testnm,'( Chi-Squared(2) )' IF(Lsumm.gt.0)WRITE(Nform,1010)'normalitytest',Testnm,' ' END IF IF(.not.dpeq(Kurt,DNOTST))THEN IF(Svltab(LSLSNR))WRITE(Ng,1020)' SEATS Kurtosis',Kurt,Kurtse IF(Lsumm.gt.0)WRITE(Nform,1020)'SEATSkurtosis',Kurt,Kurtse END IF IF(.not.dpeq(Skew,DNOTST))THEN IF(Svltab(LSLSNR))WRITE(Ng,1020)' SEATS Skewness',Skew,Skewse IF(Lsumm.gt.0)WRITE(Nform,1020)'SEATSskewness',Skew,Skewse END IF IF(.not.dpeq(Sdres,DNOTST))THEN IF(Svltab(LSLSNR))THEN WRITE(Ng,1030)' Residual SD',Sdres,' ' WRITE(Ng,1030)' Residual Variance',Sdres*Sdres,' ' END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1030)'varsd',Sdres,' ' WRITE(Nform,1030)'varres',Sdres*Sdres,' ' END IF END IF IF(Svltab(LSLSNR))WRITE(Ng,1061)' ' END IF c ------------------------------------------------------------------ IF(Ny.gt.1)THEN IF(.not.dpeq(Dwstat,DNOTST))THEN IF(Svltab(LSLDW))WRITE(Ng,1010)'Durbin-Watson',Dwstat,' ' IF(Lsumm.gt.0)WRITE(Nform,1010)'SEATSdurbinwatson',Dwstat,' ' END IF IF(.not.dpeq(SeasNP,DNOTST))THEN IF(Svltab(LSLFRS))THEN nstr1=1 CALL itoc(Ny-1,str1,nstr1) WRITE(Ng,1010)'Non-parametric Test for Residual '// & 'Seasonality (Friedman)',SeasNP, & '( Chi-Squared('//str1(1:(nstr1-1))//' )' END IF IF(Lsumm.gt.0)WRITE(Nform,1010)'SEATSfriedman',SeasNP,' ' END IF END IF c ------------------------------------------------------------------ c write message to savelog if seasonal adjustment not performed c and exit if signal extraction not done c Added by BCM 10-04-05 c ------------------------------------------------------------------ IF(.not.Havesa)THEN IF(istrue(Svltab,LSLSMD,LSLSSG))WRITE(Ng,1110) RETURN END IF c ------------------------------------------------------------------ IF(Svltab(LSLTSE).or.Lsumm.gt.0)THEN IF(.not.dpeq(Tsetrn,DNOTST))THEN sigs=' ' IF(Tsetrn.gt.TSELIM)sigs='*' IF(Svltab(LSLTSE)) & WRITE(Ng,1030)' Total Squared Error (trend)',Tsetrn,sigs IF(Lsumm.gt.0)WRITE(Nform,1030)'tsetrend',Tsetrn,sigs END IF IF(.not.dpeq(Tsesea,DNOTST))THEN sigs=' ' IF(Tsesea.gt.TSELIM)sigs='*' IF(Svltab(LSLTSE)) & WRITE(Ng,1030)' Total Squared Error (seasonal)',Tsesea,sigs IF(Lsumm.gt.0)WRITE(Nform,1030)'tseseasonal',Tsesea,sigs END IF IF(.not.dpeq(Tsetcm,DNOTST))THEN sigs=' ' IF(Tsetcm.gt.TSELIM)sigs='*' IF(Svltab(LSLTSE)) & WRITE(Ng,1030)' Total Squared Error (transistory)', & Tsetcm,sigs IF(Lsumm.gt.0)WRITE(Nform,1030)'tsetransitory',Tsetcm,sigs END IF IF(.not.dpeq(Tsesad,DNOTST))THEN sigs=' ' IF(Tsesad.gt.TSELIM)sigs='*' IF(Svltab(LSLTSE)) & WRITE(Ng,1030)' Total Squared Error (seas adj)',Tsesad,sigs IF(Lsumm.gt.0)WRITE(Nform,1030)'tseseasadj',Tsesad,sigs END IF IF(Svltab(LSLTSE))WRITE(Ng,1061)' ' END IF c ------------------------------------------------------------------ IF(Svltab(LSLCVR).or.Lsumm.gt.0)THEN IF(.not.dpeq(Vartrn(1),DNOTST))THEN sigs=' ' IF(Vartrn(1).le.Vartrn(2))sigs='*' IF(Svltab(LSLCVR)) & WRITE(Ng,1040)' Trend Variance',(Vartrn(i),i=1,3),sigs IF(Lsumm.gt.0)WRITE(Nform,1040)'vartrend',(Vartrn(i),i=1,3),sigs END IF IF(.not.dpeq(Varsad(1),DNOTST))THEN sigs=' ' IF(Varsad(1).le.Varsad(2))sigs='*' IF(Svltab(LSLCVR)) & WRITE(Ng,1040)' Sadj Variance',(Varsad(i),i=1,3),sigs IF(Lsumm.gt.0) & WRITE(Nform,1040)'varseasadj',(Varsad(i),i=1,3),sigs END IF IF(.not.dpeq(Varirr(1),DNOTST))THEN sigs=' ' IF(Varirr(1).le.Varirr(2))sigs='*' IF(Svltab(LSLCVR)) & WRITE(Ng,1040)' Irregular Variance',(Varirr(i),i=1,3),sigs IF(Lsumm.gt.0)WRITE(Nform,1040)'varirreg',(Varirr(i),i=1,3),sigs END IF IF(.not.dpeq(Varsea(1),DNOTST))THEN sigs=' ' IF(Varsea(1).le.Varsea(2))sigs='*' IF(Svltab(LSLCVR)) & WRITE(Ng,1040)' Seasonal Variance',(Varsea(i),i=1,3),sigs IF(Lsumm.gt.0) & WRITE(Nform,1040)'varseasonal',(Varsea(i),i=1,3),sigs END IF IF(Svltab(LSLCVR))WRITE(Ng,1061)' ' END IF c----------------------------------------------------------------------- IF(Svltab(LSLCEE).or.Lsumm.gt.0)THEN IF(.not.(dpeq(Ceetrn,DNOTST).or.dpeq(Ceesad,DNOTST)))THEN IF(Svltab(LSLCEE))THEN WRITE(Ng,1010)' Concurrent estimation error (trend)', & Ceetrn,' ' WRITE(Ng,1010)' Concurrent estimation error (S. A.)', & Ceesad,' ' WRITE(Ng,1061)' ' END IF IF(Lsumm.gt.0)WRITE(Nform,1020)'concesterr',Ceetrn,Ceesad END IF END IF c----------------------------------------------------------------------- IF(Svltab(LSLPRS).or.Lsumm.gt.0)THEN DO i=1,5 IF(.not.(dpeq(Prsetr(i),DNOTST).or.dpeq(Prsesa(1),DNOTST)))THEN IF(Svltab(LSLPRS))WRITE(Ng,1050)' Pct. Reduction Year ', & i,Prsetr(i),Prsesa(i) IF(Lsumm.gt.0) & WRITE(Nform,1050)'pctreductionyr',i,Prsetr(i),Prsesa(i) END IF END DO IF(Svltab(LSLPRS))WRITE(Ng,1061)' ' END IF c----------------------------------------------------------------------- IF(Svltab(LSLAAD).or.Lsumm.gt.0)THEN IF(.not.(dpeq(Ceetrn,DNOTST).or.dpeq(Ceesad,DNOTST)))THEN IF(Svltab(LSLAAD))THEN WRITE(Ng,1020) & ' Ave. Value of Abs. Diff. in Annual Averages', & Aadatr,Aadasa WRITE(Ng,1061)' ' END IF IF(Lsumm.gt.0)WRITE(Nform,1020)'avadaa',Aadatr,Aadasa END IF END IF c----------------------------------------------------------------------- IF(Svltab(LSLSSG).or.Lsumm.gt.0)THEN IF(Svltab(LSLSSG))THEN IF(Ssghst.ne.NOTSET)WRITE(Ng,1060) & ' Significant Seasonal Periods in Historical Estimator', & getSsh(),ssig(Ssghst) IF(Ssgcnc.ne.NOTSET)WRITE(Ng,1060) & ' Significant Seasonal Periods in Concurrent Estimator', & getSsp2(),ssig(Ssgcnc) IF(Ssgfct.ne.NOTSET)WRITE(Ng,1060) & ' Significant Seasonal Periods in Forecast for Next Year', & getSsf(),ssig(Ssgfct) IF(Ssghst.ne.NOTSET.and.Ssgcnc.ne.NOTSET.and.Ssgfct.ne.NOTSET) & WRITE(Ng,1061)' ' END IF IF(Lsumm.gt.0)THEN IF(Ssghst.ne.NOTSET) & WRITE(Nform,1060)'sigseashist',getSsh(),ssig(Ssghst) IF(Ssgcnc.ne.NOTSET) & WRITE(Nform,1060)'sigseasconc',getSsp2(),ssig(Ssgcnc) IF(Ssgfct.ne.NOTSET) & WRITE(Nform,1060)'sigseasfcst',getSsf(),ssig(Ssgfct) END IF END IF c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN IF(dpeq(Lam,ZERO))THEN WRITE(Nform,1000)'finmode','multiplicative' ELSE WRITE(Nform,1000)'finmode','additive' END IF END IF c----------------------------------------------------------------------- c Save over/under adjustment diagnostics to diagnostic output and/or c Log file c----------------------------------------------------------------------- IF(Svltab(LSLOUE).or.Lsumm.gt.0.and.((out.eq.0).or.(out.eq.2))) & CALL svoudg(Svltab(LSLOUE),Lsumm,Ny) c----------------------------------------------------------------------- 1000 FORMAT(a,': ',a) 1010 FORMAT(a,':',f10.4,3x,a) 1020 FORMAT(a,':',f10.4,3x,f10.4) 1030 FORMAT(a,':',e20.10,3x,a) 1040 FORMAT(a,':',3(f10.4,1x),2x,a) 1050 FORMAT(a,i1,':',f10.4,3x,f10.4) 1060 FORMAT(a,':',i4,3x,a) 1061 FORMAT(a) 1070 FORMAT(' WARNING: Sliding spans analysis cannot be done when', & ' SEATS ',a,' perform') 1080 FORMAT(' a ',a,a) 1090 FORMAT(a,': ',i3) 1100 FORMAT(a,i2.2,3(a,e21.14)) 1110 FORMAT(/,' SEATS adjustment diagnostics cannot be saved when ', & 'SEATS cannot perform', & /,' a signal extraction.',/) * 1120 FORMAT(a,i3.3,': ',2i5) 1120 FORMAT(2i5) 1130 FORMAT(1x,e21.14) RETURN END seatfc.f0000664006604000003110000000645014521201562011610 0ustar sun00315steps SUBROUTINE seatfc(Ny,Iagr) IMPLICIT NONE c ------------------------------------------------------------------ c perform procedures from the force spec on SEATS seasonal c adjustments - June 2005 - BCM c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'seatcm.cmn' INCLUDE 'force.cmn' INCLUDE 'inpt.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11ptr.cmn' c ------------------------------------------------------------------ LOGICAL rndok DOUBLE PRECISION stbase,tempk INTEGER i,Iagr,ib,ie,Ny,lstfrc DIMENSION stbase(PLEN) c ------------------------------------------------------------------ c use Lfctfr to set last observation to be forced (BCM, May 2006) c ------------------------------------------------------------------ IF(Lfctfr)THEN lstfrc=Posffc ELSE lstfrc=Posfob END IF c ------------------------------------------------------------------ IF(Iyrt.gt.0)THEN c ------------------------------------------------------------------ c Based on value of Iyrt, set up target (stbase) for forcing the c seasonally adjusted series (BCM, May 2003) c ------------------------------------------------------------------ IF(Iftrgt.eq.0)THEN CALL copy(Series,lstfrc,1,stbase) ELSE IF(Iftrgt.eq.1)THEN CALL copy(Stocal,lstfrc,1,stbase) ELSE CALL copy(Stopp,lstfrc,1,stbase) IF(Iftrgt.eq.3)CALL divsub(stbase,stbase,Faccal,Pos1ob,lstfrc) END IF c ----------------------------------------------------------------- IF(Iyrt.eq.1)THEN CALL qmap(stbase,Seatsa,Setsa2,Pos1ob,lstfrc,Ny,ib,ie,Begyrt) c ------------------------------------------------------------------ c Change made October 1995 to duplicate X-11-ARIMA/88 partial year c adjustment of yearly totals. BCM c ------------------------------------------------------------------ IF(ie.lt.lstfrc)THEN tempk=Setsa2(ie)-Seatsa(ie) DO i=ie+1,lstfrc Setsa2(i)=Seatsa(i)+tempk END DO END IF c ------------------------------------------------------------------ c Change made May 2005 to do the same partial year adjustment c to early data BCM c ------------------------------------------------------------------ IF(ib.gt.Pos1ob)THEN tempk=Setsa2(ib)-Seatsa(ib) DO i=Posfob,ib-1 Setsa2(i)=Seatsa(i)+tempk END DO END IF ELSE IF(Iyrt.eq.2)THEN CALL qmap2(stbase,Seatsa,Setsa2,Pos1ob,lstfrc,Ny,Iagr) END IF ELSE CALL copy(Seatsa,lstfrc,1,Setsa2) END IF c ------------------------------------------------------------------ c If option selected ensure the rounded seasonally adjusted values c equals the rounded seasonally adjusted total. c ------------------------------------------------------------------ IF(Lrndsa)THEN CALL rndsa(Setsa2,Stsarn,Pos1ob,Posfob,rndok) IF(.not.rndok)Lrndsa=rndok END IF c ------------------------------------------------------------------ RETURN END seatlg.cmn0000664006604000003110000000165314521201562012152 0ustar sun00315stepsc----------------------------------------------------------------------- LOGICAL Havetr,Havesf,Haveir,Havesa,Havecy,Havftr,Havfsf,Havfir, & Havfsa,Havfcy,Hvfttr,Hvftsf,Hvftor,Hvftsa,Hvftcy,Hseftr, & Hsefsf,Hsefor,Hsefsa,Hsefcy,Hsrftr,Hsrfsf,Hsrfsa,Hsrfcy, & Haveaf,Hpitrc,Hpis,Hpitra,Hpisa,Hvstsa,Hvstir,Hvtrse, & Hvsfse,Hvsase,Hvcyse,Hvscyc,Hvsltt,Hvodff c----------------------------------------------------------------------- COMMON / seatlg / Havetr,Havesf,Haveir,Havesa,Havecy,Havftr, & Havfsf,Havfir,Havfsa,Havfcy,Hvfttr,Hvftsf, & Hvftor,Hvftsa,Hvftcy,Hseftr,Hsefsf,Hsefor, & Hsefsa,Hsefcy,Hsrftr,Hsrfsf,Hsrfsa,Hsrfcy, & Haveaf,Hpitrc,Hpis,Hpitra,Hvstir,Hpisa,Hvstsa, & Hvtrse,Hvsfse,Hvsase,Hvcyse,Hvscyc,Hvsltt, & Hvodff seatmd.cmn0000664006604000003110000000223614521201563012147 0ustar sun00315steps INTEGER Ntcnum,Ntcden,Nsnum,Nsden,Nsanum,Nsaden,Ntrnum,Ntrden, & Ntcwkf,Nsawkf,Nswkf,Ntrwkf,Nirwkf,Nrsdex,Nsfsa,Nsftr, & Nsfsf,Nsfir,Nsfcy,Lstsse,Lstyse,Lsttse,Lstase,Nfcfor, & Nodiff DOUBLE PRECISION Tcnum,Tcden,Tcvar,Snum,Sden,Svar,Sanum,Saden, & Savar,Trnum,Trden,Trvar,Irrvar,Tcwkf,Sawkf, & Swkf,Trwkf,Irwkf,Srsdex DIMENSION Tcnum(8),Tcden(8),Snum(27),Sden(27),Sanum(32),Saden(20), & Trnum(32),Trden(17),Tcwkf(120),Sawkf(120),Swkf(120), & Trwkf(120),Irwkf(120),Srsdex(PLEN) c----------------------------------------------------------------------- COMMON /seatmd/ Tcnum,Tcden,Tcvar,Snum,Sden,Svar,Sanum,Saden, & Savar,Trnum,Trden,Trvar,Irrvar,Tcwkf,Sawkf,Swkf, & Trwkf,Irwkf,Srsdex,Ntcnum,Ntcden,Nsnum,Nsden, & Nsanum,Nsaden,Ntrnum,Ntrden,Ntcwkf,Nsawkf,Nswkf, & Ntrwkf,Nirwkf,Nrsdex,Nsfsa,Nsftr,Nsfsf,Nsfir, & Nsfcy,Lstsse,Lstyse,Lsttse,Lstase,Nfcfor,Nodiff c----------------------------------------------------------------------- seatop.cmn0000664006604000003110000000121614521201563012162 0ustar sun00315stepsc----------------------------------------------------------------------- c Options from Seats spec c----------------------------------------------------------------------- CHARACTER*100 Tabtbl DOUBLE PRECISION Epsph2,Xl2,Rmod2,Epsiv2,Hplan2 INTEGER Qmax2,Out2,Maxit2,Kmean,Bias2,Iphtrf,Hptrgt LOGICAL Lnoadm,Lhp,Lstsea,Lfinit,Lmdsum,Lsgud,Lhprmls c----------------------------------------------------------------------- COMMON /setopt/ Epsph2,Xl2,Rmod2,Epsiv2,Hplan2,Qmax2,Out2,Bias2, & Maxit2,Kmean,Iphtrf,Hptrgt,Lnoadm,Lhp,Lsgud, & Lstsea,Lfinit,Lmdsum,Lhprmls,Tabtbl seatpr.f0000664006604000003110000006314114521201563011642 0ustar sun00315stepsc Last change: 10/2021- add if trendtc=yes, treat tc as ls, print/ c save long trend table without outlier effects c previous Change, fix .dor issue- Mar. 2021 SUBROUTINE seatpr(Begspn,Endspn,Ny,Muladd,Kpart,Kdec,Lsumm,Lgraf, & Lam,Lttc) IMPLICIT NONE C----------------------------------------------------------------------- c Driver routine for the printing and saving tables saved from the c SEATS seasonal adjustment routines C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' INCLUDE 'notset.prm' INCLUDE 'seatcm.cmn' INCLUDE 'seatmd.cmn' INCLUDE 'seatdg.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'adj.cmn' INCLUDE 'inpt.cmn' INCLUDE 'force.cmn' INCLUDE 'extend.cmn' INCLUDE 'error.cmn' INCLUDE 'priusr.cmn' INCLUDE 'title.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'seattb.i' INCLUDE 'frctbl.i' INCLUDE 'mdltbl.i' INCLUDE 'spctbl.i' INCLUDE 'sig.i' C----------------------------------------------------------------------- INCLUDE 'tbltitle.prm' INCLUDE 'desset.prm' C----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0,F=.false.,T=.true.) c ------------------------------------------------------------------ INTEGER N1,N12 PARAMETER (N12 = 12, N1 = 1) INCLUDE 'calc.i' C----------------------------------------------------------------------- CHARACTER tblttl*(PTTLEN) DOUBLE PRECISION dvec,Lam,setsac,settrc,stcirb,frcfac,sfsum, & sadiff,trdiff,trcy,trcydf,stadsa,stadtr,stadsf, & saoadj,iroadj,setadj LOGICAL Lgraf,pre18b,taklog,Lttc INTEGER Begspn,Endspn,Lsumm,Ny,Muladd,Kpart,kp2,i,lastob,lstfrc, & frstob,sf1ob,sa1ob,tr1ob,idate,ntbttl,ndiff,Kdec,outdec, & thisd,nlast,begfct DIMENSION Begspn(2),Endspn(2),dvec(1),setsac(PLEN),settrc(PLEN), & stcirb(PLEN),frcfac(PLEN),sfsum(PLEN),sadiff(PLEN), & trdiff(PLEN),trcy(PLEN),trcydf(PLEN),idate(2),begfct(2), & stadsa(PLEN),stadtr(PLEN),stadsf(PLEN),saoadj(PLEN), & iroadj(PLEN),setadj(PLEN) c----------------------------------------------------------------------- CHARACTER getAna,getTMCS LOGICAL dpeq EXTERNAL dpeq,getAna,getTMCS C----------------------------------------------------------------------- DOUBLE PRECISION Ckhs DIMENSION Ckhs(PLEN) COMMON /kcser / Ckhs C----------------------------------------------------------------------- INCLUDE 'desset.var' C----------------------------------------------------------------------- kp2=Kpart Kpart=-1 lastob=Posfob IF(Savfct)THEN lastob=Posffc END IF nlast=Posffc frstob=Pos1ob IF(Savbct)frstob=Pos1bk outdec=Kdec IF((.not.dpeq(Lam,ONE)).and.outdec.lt.3)outdec=3 CALL addate(Begspn,Ny,Posfob-Pos1ob+1,begfct) C----------------------------------------------------------------------- IF(Savtab(LSEMDC))THEN IF(.not.(dpeq(Tcvar,DNOTST).and.dpeq(Svar,DNOTST).and. & dpeq(Savar,DNOTST).and.dpeq(Trvar,DNOTST).and. & dpeq(Irrvar,DNOTST)))CALL savmdc(LSEMDC) END IF C----------------------------------------------------------------------- IF(Savtab(LSEWKF))THEN IF(.not.(Ntcwkf.eq.NOTSET.and.Nsawkf.eq.NOTSET.and. & Nswkf.eq.NOTSET.and.Ntrwkf.eq.NOTSET.and.Nirwkf.eq.NOTSET)) & CALL savwkf(LSEWKF) END IF C----------------------------------------------------------------------- IF(Savtab(LSEPIN).and.Hpitrc)THEN CALL punch(Spitrc,Pos1ob,Posfob,LSEPSI,F,F) IF(Lfatal)RETURN END IF i=LSEPIN+1 IF(Savtab(i).and.Hpis)THEN CALL punch(Spis,Pos1ob,Posfob,i,F,F) IF(Lfatal)RETURN END IF i=LSEPIN+2 IF(Savtab(i).and.Hpitra)THEN CALL punch(Spitra,Pos1ob,Posfob,i,F,F) IF(Lfatal)RETURN END IF i=LSEPIN+3 IF(Savtab(i).and.Hpisa)THEN CALL punch(Spisa,Pos1ob,Posfob,i,F,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c write differenced original series (Nov 2013 BCM) c changed Mar,2021, make thisd = Bd*Ny+D c only Nodiff > 0 , print or save table c ------------------------------------------------------------------ IF(Prttab(LSEDOR).or.Savtab(LSEDOR).or.Lgraf)THEN c IF(Idssm.ne.NOTSET.and.Idrsm.ne.NOTSET)THEN thisd=Bd*Ny+D c ELSE c thisd=Bd+D c end if c ------------------------------------------------------------------ CALL addate(Begspn,Ny,thisd,idate) IF(Prttab(LSEDOR).and.Nodiff.gt.0)THEN CALL makttl(DSEDIC,dseptr,PDSE,LSEDOR,PDSUM10,tblttl,ntbttl, & T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),idate,Ny,Nodiff,T) IF(.not.Lfatal) & CALL prttbl(idate,Ny,Odiff,Nodiff,'Data',outdec) END IF IF(.not.Lfatal.and.Savtab(LSEDOR).and.Nodiff.gt.0) & CALL savtbl(LSEDOR,idate,1,Nodiff,Ny,Odiff,Serno,Nser,F) IF(.not.Lfatal.and.Lgraf.and.Nodiff.gt.0) & CALL savtbl(LSEDOR,idate,1,Nodiff,Ny,Odiff,Serno,Nser,Lgraf) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF((Prttab(LSPERS).or.Savtab(LSPERS).or.Lgraf).and.Nrsdex.gt.0 & .and.((getAna().eq.'Y').or.(getTMCS().eq.'Y')).and. & Ny.eq.12)THEN CALL spcrsd(Srsdex,Nrsdex,Begspn,Ny,Endspn,LSPERS,T,Lsumm,Lgraf) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF(Havesf)THEN IF(Prttab(LSESEA).or.Prttab(LSEPSS)) & CALL table(Seatsf,Pos1ob,Posfob,10,1,1,dvec,LSESEA) IF(.not.Lfatal.and.Savtab(LSESEA)) & CALL punch(Seatsf,frstob,lastob,LSESEA,F,F) IF(.not.Lfatal.and.Savtab(LSEPSS)) & CALL punch(Seatsf,frstob,lastob,LSEPSS,F,Muladd.ne.1) IF(.not.Lfatal.and.Lgraf) & CALL punch(Seatsf,frstob,lastob,LSESEA,Lgraf,F) IF(Lfatal)RETURN C----------------------------------------------------------------------- c save seasonal se C----------------------------------------------------------------------- IF(Hvsfse)THEN IF(Savtab(LSESSF))CALL punch(Stsfse,frstob,Lstsse,LSESSF,F,F) IF(Lgraf)CALL punch(Stsfse,frstob,Lstsse,LSESSF,Lgraf,F) END IF C----------------------------------------------------------------------- c compute seasonal sums, print out and save (BCM, Feb 2008) C----------------------------------------------------------------------- IF((Prttab(LSESSM).or.Savtab(LSESSM).or.Lgraf).and.Havesf)THEN c ------------------------------------------------------------------ c Remove outliers from series before differencing c ------------------------------------------------------------------ CALL copy(Seatsf(Pos1ob),nlast-Pos1ob+1,1,stadsf(Pos1ob)) IF(Adjso.eq.1)CALL divsub(stadsf,stadsf,Facso,Pos1ob,nlast) c ------------------------------------------------------------------ CALL genssm(stadsf,Pos1ob,nlast,sfsum,sf1ob,Ny,Lam) IF(Prttab(LSESSM))THEN ndiff=Posfob-sf1ob+1 CALL addate(Begspn,Ny,sf1ob-Pos1ob,idate) CALL makttl(DSEDIC,dseptr,PDSE,LSESSM,PDSUM10,tblttl,ntbttl, & T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),idate,Ny,ndiff,T) IF(.not.Lfatal) & CALL prttbl(idate,Ny,sfsum(sf1ob),ndiff,'Data',outdec) END IF IF(.not.Lfatal.and.Savtab(LSESSM)) & CALL punch(sfsum,sf1ob,lastob,LSESSM,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(sfsum,sf1ob,lastob,LSESSM,Lgraf,F) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- C Save seasonal stochastic forecasts C----------------------------------------------------------------------- IF(Havfsf)THEN i=LSEFCD+1 CALL addate(Endspn,Ny,1,idate) IF(Savtab(i)) & CALL savtbl(i,begfct,1,Nsfsf,Ny,Setfsf,Serno,Nser,F) IF(.not.Lfatal.and.Lgraf) & CALL savtbl(i,begfct,1,Nsfsf,Ny,Setfsf,Serno,Nser,Lgraf) IF(Lfatal)RETURN END IF END IF C----------------------------------------------------------------------- IF(Havesa)THEN c ------------------------------------------------------------------ C --- remove constant from seasonally adjusted series. c (added by BCM July 2005) c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN CALL copy(Seatsa,nlast,-1,setsac) DO i=Pos1ob,nlast Seatsa(i)=Seatsa(i)-Cnstnt END DO END IF c ------------------------------------------------------------------ IF(Prttab(LSESE2).or.Savtab(LSESE2).or.Lgraf)THEN CALL copy(Seatsa,nlast,-1,saoadj) IF((.not.Finao).and.Adjao.eq.1) & CALL divsub(saoadj,saoadj,Facao,Pos1bk,nlast) IF((.not.Finls).and.Adjls.eq.1) & CALL divsub(saoadj,saoadj,Facls,Pos1bk,nlast) END IF c ------------------------------------------------------------------ IF(Prttab(LSESA).or.(Out.ne.2.and.Nustad.gt.0)) & CALL table(Seatsa,Pos1ob,Posfob,11,1,1,dvec,LSESA) IF(.not.Lfatal.and.Savtab(LSESA)) & CALL punch(Seatsa,frstob,lastob,LSESA,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Seatsa,frstob,lastob,LSESA,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ CALL copy(Seatsa(Pos1ob),nlast-Pos1ob+1,1,Ckhs(Pos1ob)) c ------------------------------------------------------------------ IF(Prttab(LSESE2).or.(Out.ne.2.and.Nustad.gt.0)) & CALL table(saoadj,Pos1ob,Posfob,11,1,1,dvec,LSESE2) IF(.not.Lfatal.and.Savtab(LSESE2)) & CALL punch(saoadj,frstob,lastob,LSESE2,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(saoadj,frstob,lastob,LSESE2,Lgraf,F) IF(Lfatal)RETURN C----------------------------------------------------------------------- c save sa se C----------------------------------------------------------------------- IF(Hvsase)THEN IF(Savtab(LSESSA))CALL punch(Stsase,frstob,Lstase,LSESSA,F,F) IF(Lgraf)CALL punch(Stsase,frstob,Lstase,LSESSA,Lgraf,F) END IF c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN IF(Prttab(LSESAC)) & CALL table(setsac,Pos1ob,Posfob,11,1,1,dvec,LSESAC) IF(.not.Lfatal.and.Savtab(LSESAC)) & CALL punch(setsac,frstob,lastob,LSESAC,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(setsac,frstob,lastob,LSESAC,Lgraf,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c write differenced seasonally adjusted series (Feb 2008 BCM) c ------------------------------------------------------------------ IF(Prttab(LSEDSA).or.Savtab(LSEDSA).or.Lgraf)THEN c ------------------------------------------------------------------ IF(Idssm.ne.NOTSET.and.Idrsm.ne.NOTSET)THEN thisd=Idssm+Idrsm ELSE thisd=Bd+D end if taklog=dpeq(Lam,ZERO) c ------------------------------------------------------------------ c Remove outliers from series before differencing c ------------------------------------------------------------------ CALL copy(Seatsa(Pos1ob),Posfob-Pos1ob+1,1,stadsa(Pos1ob)) IF(Adjao.eq.1)CALL divsub(stadsa,stadsa,Facao,Pos1ob,Posfob) IF(Adjls.eq.1)CALL divsub(stadsa,stadsa,Facls,Pos1ob,Posfob) IF(Adjtc.eq.1)CALL divsub(stadsa,stadsa,Factc,Pos1ob,Posfob) IF(Adjso.eq.1)CALL divsub(stadsa,stadsa,Facso,Pos1ob,Posfob) c ------------------------------------------------------------------ CALL gendff(stadsa,Pos1ob,Posfob,sadiff,sa1ob,taklog,T,thisd) IF(Prttab(LSEDSA))THEN ndiff=Posfob-sa1ob+1 CALL addate(Begspn,Ny,sa1ob-Pos1ob,idate) CALL makttl(DSEDIC,dseptr,PDSE,LSEDSA,PDSUM10,tblttl,ntbttl, & T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),idate,Ny,ndiff,T) IF(.not.Lfatal) & CALL prttbl(idate,Ny,sadiff(sa1ob),ndiff,'Data',outdec) END IF IF(.not.Lfatal.and.Savtab(LSEDSA)) & CALL punch(sadiff,sa1ob,Posfob,LSEDSA,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(sadiff,sa1ob,Posfob,LSEDSA,Lgraf,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ C --- WRITE SEASONALLY ADJUSTED SERIES WITH REVISED YEARLY TOTALS D11A. c ------------------------------------------------------------------ IF(Iyrt.gt.0)THEN c ------------------------------------------------------------------ c use Lfctfr to set last observation to be forced (BCM, May 2006) c ------------------------------------------------------------------ IF(Lfctfr)THEN lstfrc=nlast ELSE lstfrc=Posfob END IF IF(Prttab(LFCSAA)) & CALL table(Setsa2,Pos1ob,Posfob,11,2,2,dvec,LFCSAA) IF(.not.Lfatal.and.Savtab(LFCSAA)) & CALL punch(Setsa2,Pos1ob,Posfob,LFCSAA,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Setsa2,Pos1ob,Posfob,LFCSAA,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ c compute forcing factor from seasonally adjusted series c (BCM May 2006) c ------------------------------------------------------------------ CALL divsub(frcfac,Seatsa,Setsa2,Posfob,lstfrc) c ------------------------------------------------------------------ C --- WRITE SEASONALLY ADJUSTED SERIES WITH REVISED YEARLY TOTALS D11A. c ------------------------------------------------------------------ IF(Prttab(LFRFAC)) & CALL table(frcfac,Pos1ob,Posfob,11,6,1,dvec,LFRFAC) IF((.not.Lfatal).and.Savtab(LFRFAC)) & CALL punch(frcfac,Pos1ob,lstfrc,LFRFAC,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(frcfac,Pos1ob,lstfrc,LFRFAC,Lgraf,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c If option selected ensure the rounded seasonally adjusted values c equals the rounded seasonally adjusted total. c ------------------------------------------------------------------ IF(Lrndsa)THEN c ------------------------------------------------------------------ C --- WRITE rounded SEASONALLY ADJUSTED SERIES c ------------------------------------------------------------------ IF(Prttab(LFCRND)) & CALL table(Stsarn,Pos1ob,Posfob,11,3,2,dvec,LFCRND) IF(.not.Lfatal.and.Savtab(LFCRND)) & CALL punch(Stsarn,Pos1ob,Posfob,LFCRND,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Stsarn,Pos1ob,Posfob,LFCRND,Lgraf,F) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF(Havfsa)THEN i=LSEFCD+3 IF(Savtab(i)) & CALL savtbl(i,begfct,1,Nsfsa,Ny,Setfsa,Serno,Nser,F) IF(.not.Lfatal.and.Lgraf) & CALL savtbl(i,begfct,1,Nsfsa,Ny,Setfsa,Serno,Nser,Lgraf) IF(Lfatal)RETURN END IF END IF C----------------------------------------------------------------------- IF(Havetr)THEN CALL copy(Seattr(Pos1ob),Posfob-Pos1ob+1,1,setadj(Pos1ob)) c ------------------------------------------------------------------ C --- remove constant from trend component. (added by BCM July 2005) c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN CALL copy(Seattr,nlast,-1,settrc) DO i=Pos1ob,nlast Seattr(i)=Seattr(i)-Cnstnt END DO END IF IF(Prttab(LSETRN)) & CALL table(Seattr,Pos1ob,Posfob,12,1,1,dvec,LSETRN) IF(.not.Lfatal.and.Savtab(LSETRN)) & CALL punch(Seattr,frstob,lastob,LSETRN,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Seattr,frstob,lastob,LSETRN,Lgraf,F) IF(Lfatal)RETURN C----------------------------------------------------------------------- c save trend se C----------------------------------------------------------------------- IF(Hvtrse)THEN IF(Savtab(LSESTR))CALL punch(Sttrse,frstob,Lsttse,LSESTR,F,F) IF(Lgraf)CALL punch(Sttrse,frstob,Lsttse,LSESTR,Lgraf,F) END IF c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN IF(Prttab(LSETAC)) & CALL table(settrc,Pos1ob,Posfob,11,1,1,dvec,LSETAC) IF(.not.Lfatal.and.Savtab(LSETAC)) & CALL punch(settrc,frstob,lastob,LSETAC,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(settrc,frstob,lastob,LSETAC,Lgraf,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c Remove LS outliers or TC outlier if trendtc = yes from trend c print trend without outlier effects table c ------------------------------------------------------------------ IF((.not.Finls).and.Adjls.eq.1) & CALL divsub(setadj,setadj,Facls,Pos1ob,Posfob) IF((.not.Fintc).and.Lttc.and.Adjtc.eq.1) & CALL divsub(setadj,setadj,Factc,Pos1ob,Posfob) c ------------------------------------------------------------------ c write final trend cycel without outlier effects trend (Sep 2021) c ------------------------------------------------------------------ IF(Prttab(LSESTL))THEN CALL table(setadj,Pos1ob,Posfob,12,1,1,dvec,LSESTL) END IF IF(.not.Lfatal.and.Savtab(LSESTL)) & CALL punch(setadj,Pos1ob,Posfob,LSESTL,F,F) c ------------------------------------------------------------------ c write differenced trend (Feb 2008 BCM) c ------------------------------------------------------------------ IF(Prttab(LSEDTR).or.Savtab(LSEDTR).or.Lgraf)THEN IF(Idssm.ne.NOTSET.and.Idrsm.ne.NOTSET)THEN thisd=Idssm+Idrsm ELSE thisd=Bd+D end if c ------------------------------------------------------------------ c Remove LS outliers from series before differencing c ------------------------------------------------------------------ CALL copy(Seattr(Pos1ob),Posfob-Pos1ob+1,1,stadtr(Pos1ob)) IF(Adjls.eq.1)CALL divsub(stadtr,stadtr,Facls,Pos1ob,Posfob) c ------------------------------------------------------------------ taklog=dpeq(Lam,ZERO) CALL gendff(stadtr,Pos1ob,Posfob,trdiff,tr1ob,taklog,T,thisd) IF(Prttab(LSEDTR))THEN ndiff=Posfob-tr1ob+1 CALL addate(Begspn,Ny,tr1ob-Pos1ob,idate) CALL makttl(DSEDIC,dseptr,PDSE,LSEDTR,PDSUM10,tblttl,ntbttl, & T,F) IF(.not.Lfatal)CALL prtshd(tblttl(1:ntbttl),idate,Ny,ndiff,T) IF(.not.Lfatal) & CALL prttbl(idate,Ny,trdiff(tr1ob),ndiff,'Data',outdec) END IF IF(.not.Lfatal.and.Savtab(LSEDTR)) & CALL punch(trdiff,tr1ob,Posfob,LSEDTR,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(trdiff,tr1ob,Posfob,LSEDTR,Lgraf,F) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF(Havftr)THEN IF(Savtab(LSEFCD)) & CALL savtbl(LSEFCD,begfct,1,Nsftr,Ny,Setftr,Serno,Nser,F) IF(.not.Lfatal.and.Lgraf) & CALL savtbl(LSEFCD,begfct,1,Nsftr,Ny,Setftr,Serno,Nser,Lgraf) END IF IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF(Haveir)THEN c ------------------------------------------------------------------ IF(Prttab(LSESE3).or.Savtab(LSESE3).or.Lgraf)THEN CALL copy(Seatir,nlast,-1,iroadj) IF((.not.Finao).and.Adjao.eq.1) & CALL divsub(iroadj,iroadj,Facao,Pos1bk,nlast) END IF c ------------------------------------------------------------------ IF(Prttab(LSEIRR).or.Prttab(LSEPSI)) & CALL table(Seatir,Pos1ob,Posfob,13,1,1,dvec,LSEIRR) IF(.not.Lfatal.and.Savtab(LSEIRR)) & CALL punch(Seatir,frstob,lastob,LSEIRR,F,F) IF(.not.Lfatal.and.Savtab(LSEPSI)) & CALL punch(Seatir,frstob,lastob,LSEPSI,F,Muladd.ne.1) IF(.not.Lfatal.and.Lgraf) & CALL punch(Seatir,frstob,lastob,LSEIRR,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Prttab(LSESE3)) & CALL table(iroadj,Pos1ob,Posfob,13,1,1,dvec,LSESE3) IF(.not.Lfatal.and.Savtab(LSESE3)) & CALL punch(iroadj,frstob,lastob,LSESE3,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(iroadj,frstob,lastob,LSESE3,Lgraf,F) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF(Havecy)THEN IF(Prttab(LSETRA).or.Prttab(LSEPSC)) & CALL table(Seatcy,Pos1ob,Posfob,14,1,1,dvec,LSETRA) IF(.not.Lfatal.and.Savtab(LSETRA)) & CALL punch(Seatcy,frstob,lastob,LSETRA,F,F) IF(.not.Lfatal.and.Savtab(LSEPSC)) & CALL punch(Seatcy,frstob,lastob,LSEPSC,F,Muladd.ne.1) IF(.not.Lfatal.and.Lgraf) & CALL punch(Seatcy,frstob,lastob,LSETRA,Lgraf,F) IF(Lfatal)RETURN C----------------------------------------------------------------------- c save transitory se C----------------------------------------------------------------------- IF(Hvcyse)THEN IF(Savtab(LSESCY))CALL punch(Stcyse,frstob,Lstyse,LSESCY,F,F) IF(Lgraf)CALL punch(Stcyse,frstob,Lstyse,LSESCY,Lgraf,F) END IF C----------------------------------------------------------------------- IF(Havfcy)THEN i=LSEFCD+4 IF(Savtab(i)) & CALL savtbl(i,begfct,1,Nsfcy,Ny,Setfcy,Serno,Nser,F) IF(.not.Lfatal.and.Lgraf) & CALL savtbl(i,begfct,1,Nsfcy,Ny,Setfcy,Serno,Nser,Lgraf) IF(Lfatal)RETURN END IF END IF C----------------------------------------------------------------------- IF(Hvscyc)THEN IF(Prttab(LSECYC).or.Prttab(LSECYC)) & CALL table(Setcyc,Pos1ob,Posfob,14,2,1,dvec,LSECYC) IF(.not.Lfatal.and.Savtab(LSECYC)) & CALL punch(Setcyc,frstob,lastob,LSECYC,F,F) IF(Lfatal)RETURN END IF IF(Hvsltt)THEN IF(Prttab(LSELTT).or.Prttab(LSELTT)) & CALL table(Setltt,Pos1ob,Posfob,14,3,1,dvec,LSELTT) IF(.not.Lfatal.and.Savtab(LSELTT)) & CALL punch(Setltt,frstob,lastob,LSELTT,F,F) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF(Haveaf)THEN * IF(Muladd.ne.1)THEN * DO i=Pos1ob,Posffc * Seataf(i)=Seataf(i)/100D0 * END DO * END IF IF(Prttab(LSECAF).or.Prttab(LSEPSI)) & CALL table(Seataf,Pos1ob,Posfob,16,1,1,dvec,LSECAF) IF(.not.Lfatal.and.Savtab(LSECAF)) & CALL punch(Seataf,frstob,lastob,LSECAF,F,F) IF(.not.Lfatal.and.Savtab(LSEPSI)) & CALL punch(Seataf,frstob,lastob,LSEPSI,F,Muladd.ne.1) IF(.not.Lfatal.and.Lgraf) & CALL punch(Seataf,frstob,lastob,LSECAF,Lgraf,F) IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- c Print Final adjustment ratios - A1 / D11. c----------------------------------------------------------------------- IF(Havesa)THEN i=Pos1ob pre18b=F DO WHILE (i.le.nlast) IF(dpeq(Seatsa(i),ZERO))THEN IF(dpeq(Series(i),ZERO))THEN stcirb(i)=ONE ELSE stcirb(i)=DNOTST IF(.not.pre18b)pre18b=T END IF ELSE IF(dpeq(Series(i),ZERO).or.Series(i).lt.ZERO)pre18b=T stcirb(i)=Series(i)/Seatsa(i) END IF i=i+1 END DO IF(Prttab(LSES18)) & CALL table(stcirb,Pos1ob,Posfob,18,1,1,dvec,LSES18) IF(.not.Lfatal.and.Savtab(LSES18)) & CALL punch(stcirb,frstob,lastob,LSES18,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(stcirb,frstob,lastob,LSES18,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print/Save total adjustment factors (BCM - July 2005) c----------------------------------------------------------------------- IF(pre18b)THEN CALL divsub(stcirb,Series,Seatsa,Pos1ob,nlast) IF(Prttab(LSESEB)) & CALL table(stcirb,Pos1ob,Posfob,18,2,1,dvec,LSESEB) IF(.not.Lfatal.and.Savtab(LSESEB)) & CALL punch(stcirb,frstob,lastob,LSESEB,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(stcirb,frstob,lastob,LSESEB,Lgraf,F) IF(Lfatal)RETURN END IF END IF C----------------------------------------------------------------------- Kpart=kp2 RETURN END seatserr.i0000664006604000003110000000021214521201563012165 0ustar sun00315stepsC C... Variables in Common Block /SeatsError/ ... integer countError,haveError common /SeatsError/ countError,haveError seattb.i0000664006604000003110000000311514521201563011624 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c Seats SET, ST c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c spectrum of sa series S1 c spectrum of irregular S2 c----------------------------------------------------------------------- INTEGER LSETRN,LSETAC,LSESEA,LSEPSS,LSEIRR,LSEPSI,LSESA,LSESAC, & LSETRA,LSEPSC,LSECAF,LSEPSA,LSEFCD,LSES18,LSESEB,LSEWKF, & LSEMDC,LSEPIN,LSESGS,LSESGC,LSETGS,LSETGC,LSESDC,LSETDC, & LSESFS,LSESFC,LSETFS,LSETFC,LSEDOR,LSEDSA,LSEDTR,LSESSM, & LSECYC,LSELTT,LSESSF,LSESSA,LSESTR,LSESCY,LSESE2,LSESE3, & LSESTL PARAMETER( & LSETRN=349,LSETAC=350,LSESEA=351,LSEPSS=352,LSEIRR=353, & LSEPSI=354,LSESA=355,LSESAC=356,LSETRA=357,LSEPSC=358, & LSECAF=359,LSEPSA=360,LSEFCD=361,LSES18=366,LSESEB=367, & LSEWKF=368,LSEMDC=369,LSEPIN=370,LSESGS=374,LSESGC=375, & LSETGS=376,LSETGC=377,LSESDC=378,LSETDC=379,LSESFS=380, & LSESFC=381,LSETFS=382,LSETFC=383,LSEDOR=384,LSEDSA=385, & LSEDTR=386,LSESSM=387,LSECYC=388,LSELTT=389,LSESSF=390, & LSESSA=391,LSESTR=392,LSESCY=393,LSESE2=394,LSESE3=395, & LSESTL=396) serates.f0000664006604000003110000001745114521201563012015 0ustar sun00315stepsc SErates.F c To compute the Se of the Rates of growth c c c SErates conpute the Se of the rates of growth c INPUT PARAMETERS c real*8 H(0:lH) :Numerator of revision error c $ THr(1:lTHr) :MA of the serie in real signs, also denominator of the revision error c $ PSIE(0:2*pk+1):innovations weights of the component filter for B^pk to F^pk+1,PSIE(pk) is the PSIE of concurrent c $ Vr=(Vc*H_F(1))^2 : Variance of revision error model in terms of Va c $ Va :Variance of residuals c integer mq :number of observations per year c $ LastPer :the Last period which period of the year is c $ nOutPar :number of SDrev,SDR1 and of SDRmq c c OUTPUT PARAMETERS c real*8 SDrev(nOutPar), !SDrev(i):component revision SE for B^(i-1) c $ SDR1(nOutPar), !SDR1(i):revision SE of rate T(1,1) for B^(i-1) c $ SDR1f, !SDR1f:revision SE of rate (1-F) for concurrent c $ SDRmq(nOutPar), !SDRmq(i):revision SE of interannual rate T(1,mq) c $ SDRmqF, !revision SE of (1-F^mq) for concurrent c $ SDRmqC, !revision SE of (B^(mq/2-1)-F^(mq/2)) c $ SDRmqC2, !revision SE of (B^(mq/2-2)-F^(mq/2-1)) c $ SDRmqPf !revision SE of annual rate for the present year subroutine SErates(H,lH,THr,lTHr,PSIE,pK,Vr,Va,mq,LastPer,nOutPar, $ SDrev,SDR1,SDR1f,SDRmqF,SDRmqC,SDRmqPf,SDRmq,SDRmqC2) implicit none c INPUT PARAMETERS integer lH, !LH+1:length of H_F $ lTHr, !length of THr $ pK, !PSIE(pk) is the PSIE of concurrent $ mq, !number of observations per year $ LastPer, !the Last period which period of the year is $ nOutPar !number of SDrev,SDR1 and of SDRmq c real*8 H(*), !Numerator of revision error $ THr(*), !TH of the serie in BOX-Jenkins $ PSIE(0:2*pk+1), !innovations weights $ Vr, !Variance of revision error model in units Va $ Va !Variance of residuals c c INTRINSIC FUNCTIONS intrinsic ABS c OUTPUT PARAMETERS real*8 SDrev(nOutPar), !SDrev(i):component revision SE $ SDR1(nOutPar), !SDR1(i):revision SE T(1,1) $ SDR1f, !SDR1f:revision SE (1-F) $ SDRmq(nOutPar), !SDRmq(i):revision SE T(1,mq) $ SDRmqF, !revision SE of (1-F^mq) for concurrent $ SDRmqC, !revision SE of (B^(mq/2-1)-F^(mq/2)) $ SDRmqC2, !revision SE of (B^(mq/2-2)-F^(mq/2-1)) $ SDRmqPf !revision SE of annual rate for the present year c c LOCAL PARAMETERS integer i real*8 TH(60) c do i=1,lTHr-1 TH(i)=-THr(i+1) end do call seRev(H,TH,lH,lTHr-1,PSIE,pK,Vr,Va,nOutPar,SDrev) call seT11(H,TH,lH,lTHr-1,PSIE,pK,Vr,Va,nOutPar,SDR1,SDR1f) call seT1mq(H,TH,lH,lTHr-1,PSIE,pk,Vr,Va,mq,LastPer,nOutPar, $ SDRmq,SDRmqF,SDRmqC,SDRmqPf,SDRmqC2) end subroutine c subroutine seRev(H,TH,lH,lTH,PSIE,pK,Vr,Va,nOutPar,SDrev) implicit none include 'units.cmn' c INPUT PARAMETERS integer lH,lTH,pK,nOutPar real*8 H(*),TH(*),PSIE(0:2*pk+1),Vr,Va c C OUTPUT PARAMETERS real*8 SDrev(nOutPar) c c INTRINSIC FUNCTIONS intrinsic ABS c LOCAL PARAMETERS real*8 cov(0:0),rho(0:0),g(0:0),Ve,Vrev(nOutPar) integer i c * WRITE(Ng,*)' subroutine seRev, call 1' call BFAC(TH,H,lTH,lH,0,cov,rho,Ve,Vr,g,0) Vrev(1)=cov(0) if ((Vrev(1)) .lt. 1.0D-14) then Vrev(1)=0.0D0 end if Do i=2,nOutPar Vrev(i)=Vrev(i-1)-PSIE(1-i+pk)*PSIE(1-i+pk) if ((Vrev(i)) .lt. 1.0E-14) then Vrev(i)=0.0d0 end if end do do i=1,nOutPar SDrev(i)=sqrt(Vrev(i)*Va) end do end subroutine c c subroutine seT11(H,TH,lH,lTH,PSIE,pk,Vr,Va,nOutPar,SDR1,SDR1f) implicit none include 'units.cmn' c INPUT PARAMETERS integer lH,lTH,pK,nOutPar real*8 H(*),TH(*),PSIE(0:2*pk+1),Vr,Va c C OUTPUT PARAMETERS real*8 SDR1(nOutPar),SDR1f c c INTRINSIC FUNCTIONS intrinsic ABS C LOCAL PARAMETERS integer i,lHc1 real*8 delta1(1),Hc1(60),cov(0:0),rho(0:0),Ve,g(0:0),Hc1r(60), $ Vr1(nOutPar),Vr1f,THr(60),PSIE1(50+1) delta1(1)=1 call MPBBJ(H,delta1,lH,1,Hc1) lHc1=lH+1 * WRITE(Ng,*)' subroutine seT11, call 1' call BFAC(TH,Hc1,lTH,lHc1,0,cov,rho,Ve,Vr,g,0) c THr(1)=1 do i=1,lTH THr(i+1)=-TH(i) !THr in real signs end do Hc1r(1)=1 do i=2,lHc1+1 Hc1r(i)=-Hc1(i-1) !Hc1r in real signs end do call getPSIE(Hc1r,lHc1,THr,lTH,sqrt(Vr),50,PSIE1) Vr1(1)=(cov(0)-PSIE1(1)*PSIE1(1)) if ((Vr1(1)) .lt. 1.0E-14) then Vr1(1)=0.0d0 end if do i=2,nOutPar Vr1(i)=Vr1(i-1)-PSIE1(i)*PSIE1(i) if ((Vr1(i)) .lt. 1.0E-14) then Vr1(i)=0.0d0 end if end do do i=1,nOutPar SDR1(i)=sqrt(Vr1(i)*Va) end do Vr1f=Vr1(1)*Va+(PSIE(pk)-PSIE(pk-1))*(PSIE(pk)-PSIE(pk-1))*Va SDR1f=sqrt(Vr1f) end subroutine c c subroutine seT1mq(H,TH,lH,lTH,PSIE,pk,Vr,Va,mq,lastPer,nOutPar, $ SDRmq,SDRmqF,SDRmqC,SDRmqPf,SDRmqC2) implicit none c INPUT PARAMETERS integer lH,lTH,pK,mq,lastPer,nOutPar real*8 H(*),TH(*),PSIE(0:2*pk+1),Vr,Va c c OUTPUT PARAMETERS real*8 SDRmq(nOutPar),SDRmqF,SDRmqC,SDRmqPf,SDRmqC2 c c INTRINSIC FUNCTIONS intrinsic ABS c LOCAL PARAMETERS real*8 cov(0:0),rho(0:0),g(0:0),Ve,Vrmq(nOutPar),THr(60), $ HpMQ(60),HpMQr(60),PSIEmq(50),a(12),VrmqF,VrmqC,VrmqC2, $ VrmqPf,DeltaMQ(12) integer i,lHpMQ,Iper c THr(1)=1 DO i=1,lTH THr(i+1)=-TH(i) end do do i=1,mq-1 DeltaMQ(i)=0 end do DeltaMQ(mq)=1 !(1-B^mq) in Box-Jenkins notation c call MPBBJ(H,DeltaMQ,lH,mq,HpMQ) lHpMQ=lH+mq call BFAC(TH,HpMQ,lTH,lHpMQ,0,cov,rho,Ve,Vr,g,0) HpMQr(1)=1 Do i=1,lHpMQ HpMQr(i+1)=-HpMQ(i) end do call getPSIE(HpMQr,lHpMQ,THr,lTH,sqrt(Vr),50,PSIEmq) c Vrmq(1)=cov(0) do i=1,mq Vrmq(1)=Vrmq(1)-PSIEmq(i)*PSIEmq(i) end do if ((Vrmq(1)) .lt. 1.0D-14) then Vrmq(1)=0.0D0 end if Do i=2,NoutPar Vrmq(i)=Vrmq(i-1)-PSIEmq(i+mq-1)*PSIEmq(i+mq-1) if ((Vrmq(i)) .lt. 1.0D-14) then Vrmq(i)=0.0D0 end if end do do i=1,nOutPar SDRmq(i)=sqrt(Vrmq(i)*Va) end do do i=1,mq a(i)=PSIE(pk+mq-i)-PSIE(pk-i) end do c VrMQf=VrMQ(1)*Va do i=1,mq VrMQf=VrMQf+a(i)*a(i)*Va end Do SDrMQf=sqrt(VrMQf) c Iper=lastPer+1 VrMQpf=VrMQ(1)*Va do i=Iper,mq VrMQpf=VrMQpf+a(i)*a(i)*Va end do SDRmqPf=sqrt(VrMQpf) VrMQc=VrMQ(1)*Va do i=(mq/2)+1,mq VrMQc=VrMQc+a(i)*a(i)*Va end do SDRmqC=sqrt(VrMQc) VrMQc2=VrMQ(1)*Va do i=(mq/2)+2,mq VrMQc2=VrMQc2+a(i)*a(i)*Va end do SDRmqC2=sqrt(VrMQc2) end subroutine c c subroutine SEratesOut(SDrev,SDR1,SDR1f,SDRmq,SDRmqF, $ SDRmqC,SDRmqPf,SDRmqC2,nOutPar,nio) implicit none c INPUT PARAMETERS integer nOutPar, $ nio !FileIdentifier real*8 SDRev(nOutPar),SDR1(nOutPar),SDR1f, $ SDRmq(nOutPAr),SDRmqF,SDRmqC,SDRmqPf,SDRmqC2 c EXTERNAL FUNCTIONS integer istrlen external istrlen c LOCAL PARAMETERS integer i character cad*1000,cad2*1000 c write(nio,'(" N SDRev SDR1 SDRmq")') do i=1,nOutPar write(nio,'(I3," ",G11.3," ",G11.3," ",G11.3)') $ i,SDRev(i),SDR1(i),SDRmq(i) end do c write(nio,'("SDR1f=",G11.3)') SDR1f write(nio,'("SDRmqF=",G11.3)') SDRmqF write(nio,'("SDRmqC=",G11.3)') SDRmqC write(nio,'("SDRmqC2=",G11.3)') SDRmqC2 write(nio,'("SDRmqPf=",G11.3)') SDRmqpf end subroutine series.cmn0000664006604000003110000000227514521201563012167 0ustar sun00315stepsc----------------------------------------------------------------------- c Variables in the common cseries used in the nonlinear routine. c Common should only be found in the main and the function evaluation c routine. This file is dependant on srslen.prm c----------------------------------------------------------------------- c Name Type Description cseries common variables c----------------------------------------------------------------------- c Dnefob d Input number of effective observations and the length of c the differenced regression variables and series less the c order of the DF*AR operators if the AR is conditional and c less DF if the AR is exact. c Lrgrsd d magnitude of the largest residual needed for the c constrained estimation in Minpack c Tsrs d Psrs long copy of the series input to the nonlinear routine c----------------------------------------------------------------------- c Variable typing and initialization c----------------------------------------------------------------------- DOUBLE PRECISION Dnefob,Lrgrsd,Tsrs DIMENSION Tsrs(PLEN) COMMON /csrs/ Dnefob,Lrgrsd,Tsrs sername.i0000664006604000003110000000021514521201563011772 0ustar sun00315stepsC C... Variables in Common Block /serName/ ... integer niter character mattitle*180 common /serName/ niter,mattitle serrlev.i0000664006604000003110000000051214521201563012022 0ustar sun00315stepsC C... Variables in Common Block /serrlev/ ... real*8 SEFES real*8 SETA(-kp:kp),SETP(-kp:kp),SETS(-kp:kp),SETC(-kp:kp), $ SESER(kp),SERA(-kp:kp),SERP(-kp:kp),SERC(-kp:kp), $ SERS(-kp:kp) common /serrlev/ SETA,SETP,SETS,SETC,SESER,SEFES,SERA,SERP,SERC, $ SERS sesfcast.i0000664006604000003110000000026514521201563012160 0ustar sun00315stepsC C... Variables in Common Block /sesfcast/ ... real*8 SESFCAST(KP),RFACT(KP),ERESID(MPKP) integer numEresid common /sesfcast/ SESFCAST,RFACT,ERESID,numEresid setadj.f0000664006604000003110000000234614521201564011617 0ustar sun00315stepsC Last change: BCM 23 Dec 97 9:58 am SUBROUTINE setadj(Usr,Nusr,Usrsrs,Nusrs,Usrbeg,Havusr,Nprtyp, & Adjtmp,Nadtmp,Bgusra,Srsnam,Nsrs,Isrs,Argok) IMPLICIT NONE c ------------------------------------------------------------------ CHARACTER Usrsrs*(*),Srsnam*(*) LOGICAL Havusr,Argok DOUBLE PRECISION Adjtmp,Usr INTEGER Bgusra,Isrs,j,j2,Nusr,Nusrs,Usrbeg,Nadtmp,Nprtyp, & Nsrs DIMENSION Adjtmp(*),Bgusra(2),Usr(*),Usrbeg(2) c ------------------------------------------------------------------ IF(Isrs.gt.0)THEN j2=0 DO j=Isrs,Nadtmp,Nprtyp j2=j2+1 Usr(j2)=Adjtmp(j) END DO Nusr=j2 ELSE CALL copy(Adjtmp,Nadtmp,1,Usr) Nusr=Nadtmp END IF c ------------------------------------------------------------------ Usrsrs=Srsnam Nusrs=Nsrs c ------------------------------------------------------------------ CALL cpyint(Bgusra,2,1,Usrbeg) c ------------------------------------------------------------------ IF(Argok)Havusr=.true. c ------------------------------------------------------------------ RETURN END setamx.f0000664006604000003110000000420314521201564011640 0ustar sun00315steps SUBROUTINE setamx(Mdindx,Lseff,Locok,Inptok) IMPLICIT NONE c ------------------------------------------------------------------ c Set Automatic model for pickmdl if file is not specified c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER tmpdsn*(132) INTEGER Mdindx,sdiff,sma,nsar,nsdiff,nsma,ntmp LOGICAL Lseff,Locok,Inptok c----------------------------------------------------------------------- c Set order of seasonal differencing and seasonal moving average c----------------------------------------------------------------------- IF(Lseff)THEN sdiff=0 sma=0 ELSE sdiff=1 sma=1 END IF c----------------------------------------------------------------------- c set model depending on index of model requested c----------------------------------------------------------------------- IF(Mdindx.eq.1)THEN nsar=0 nsdiff=1 nsma=1 ELSE IF(Mdindx.eq.2)THEN nsar=0 nsdiff=1 nsma=2 ELSE IF(Mdindx.eq.3)THEN nsar=2 nsdiff=1 nsma=0 ELSE IF(Mdindx.eq.4)THEN nsar=0 nsdiff=2 nsma=2 ELSE IF(Mdindx.eq.5)THEN nsar=2 nsdiff=1 nsma=2 END IF CALL mdlset(nsar,nsdiff,nsma,0,sdiff,sma,Locok) Inptok=Inptok.and.Locok c----------------------------------------------------------------------- IF((.not.Locok).or.Lfatal)THEN CALL mkmdsn(nsar,nsdiff,nsma,0,sdiff,sma,tmpdsn,ntmp) WRITE(STDERR,1010) WRITE(Mt2,1010) END IF c----------------------------------------------------------------------- 1010 FORMAT(/,' ERROR: Unable to set up ARIMA model ',a,' for pickmdl', & /,' automatic model selection procedure for the ', & 'reason(s)',/,'given above.') c----------------------------------------------------------------------- RETURN END setapt.f0000664006604000003110000000257714521201564011653 0ustar sun00315steps SUBROUTINE setapt(Nb,Nf,Begspn,Sp) IMPLICIT NONE c----------------------------------------------------------------------- c set pointers for indirect adjustment, based on number of c backcasts (Nb) and number of forecasts (Nf) c----------------------------------------------------------------------- INTEGER MO PARAMETER(MO=2) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'agr.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11ptr.cmn' c----------------------------------------------------------------------- INTEGER Begspn,Nb,Nf,Sp DIMENSION Begspn(2) c----------------------------------------------------------------------- IF(Indnfc.eq.NOTSET)THEN Indnfc=Nf Indnbc=Nb Ind1bk=Pos1ob-Nb Ind1ob=Pos1ob Indfob=Posfob Indffc=Posfob+Nf CALL addate(Begspn,Sp,-Nb,Ibgbk2) IF(Ibgbk2(MO).gt.1)Ibgbk2(MO)=1 ELSE IF(Indnbc.gt.Nbcst)THEN Indnbc=Nbcst Ind1bk=Ind1ob-Nbcst CALL cpyint(Begbak,2,1,Ibgbk) * CALL cpyint(Begbk2,2,1,Ibgbk2) END IF IF(Indnfc.gt.Nfcst)THEN Indnfc=Nfcst Indffc=Indfob+Nfcst END IF END IF c----------------------------------------------------------------------- RETURN END setarg.f0000664006604000003110000001011414521201564011622 0ustar sun00315stepsC Last change: BCM 2 Dec 97 7:19 am SUBROUTINE setarg() IMPLICIT NONE c----------------------------------------------------------------------- c Set up pointer, character variables for getarg routines. c BCM November 2005 - c Allow quotation marks surrounding arguments to include c spaces in director/file names c----------------------------------------------------------------------- INCLUDE 'getarg.prm' INCLUDE 'getarg.cmn' INCLUDE 'stdio.i' c----------------------------------------------------------------------- LOGICAL F PARAMETER(F=.false.) c----------------------------------------------------------------------- CHARACTER cmdln*(CLEN) INTEGER frstch,lastch,next,xlen,nblnk,nquote LOGICAL lquote c----------------------------------------------------------------------- Arg = & ' ' c CALL getcl(cmdln) CALL setchr(' ',CLEN,cmdln) cmdln(1:41)= & 'R:\DATA\SHARE\TimeSeries\X13AS\airlinex11' c ------------------------------------------------------------------ frstch = 1 next = 1 Narg = 0 Ptr(Narg) = 1 nblnk = 0 c --- initialize variables to allow for quotation marks c --- BCM - November 2005 lquote = F nquote = 0 c ------------------------------------------------------------------ 10 lastch = index(cmdln(frstch:CLEN) , ' ') + frstch - 1 xlen = lastch - frstch + 1 IF( xlen.eq.1 )RETURN c --- if a quotation mark is found in an earlier argument, c --- check to see if the first character is a quotation mark and c --- print out message to correct program flags and stop processing c --- BCM - November 2005 IF(lquote)THEN IF(cmdln(frstch:frstch).eq.'"')THEN WRITE(STDERR,1010) & ' ERROR: Improper number of quotation marks in program flags.' WRITE(STDERR,1020) & ' Check position of quotation marks in flags.' CALL abend RETURN END IF ELSE c --- if a quotation mark is not found in an earlier argument, c --- check to see if the first character is a quotation mark c --- BCM - November 2005 lquote = cmdln(frstch:frstch).eq.'"' IF(lquote)THEN c --- if a quotation mark is found in the first character, c --- adjust pointer variables and set lquote to true c --- BCM - November 2005 frstch = frstch + 1 xlen = xlen - 1 nquote = nquote + 1 END IF END IF IF(cmdln((lastch-1):(lastch-1)).eq.'"') THEN c --- if a quotation mark is found in the final character, c --- adjust pointer variables and set lquote to false c --- BCM - November 2005 lastch=lastch-2 xlen = xlen - 1 nquote = nquote + 1 lquote = F END IF Arg(next:next + xlen - 1) = cmdln(frstch:lastch) next = next + xlen c --- only update pointers of data dictionary if closing quote is c --- not found or no quotation marks found c --- BCM - November 2005 IF(.not.lquote)THEN Narg = Narg + 1 Ptr(Narg) = next END IF frstch = next + nblnk + nquote DO WHILE ( .true. ) IF( cmdln(frstch:frstch).eq.' ' )THEN frstch = frstch + 1 c --- if a quotation mark was found, add space to data dictionary c --- BCM - November 2005 IF(lquote)THEN Arg(next:next)=' ' next=next+1 ELSE nblnk = nblnk + 1 END IF IF( frstch.le.CLEN )GO TO 20 c --- if a quotation mark was found and a closing quote is not found, c --- print out error message and stop processing. c --- BCM - November 2005 IF(lquote)THEN WRITE(STDERR,1010) & ' ERROR: Closing quotation mark not found in program flags.' CALL abend END IF RETURN END IF GO TO 10 20 CONTINUE END DO 1010 FORMAT(/,a) 1020 FORMAT(a) END setchr.f0000664006604000003110000000124714521201564011634 0ustar sun00315stepsC Last change: BCM 25 Nov 97 9:52 am **==setchr.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE setchr(Chr,Nchr,Chrvec) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to set each character in a character vector to chr c----------------------------------------------------------------------- CHARACTER Chr*1,Chrvec*(*) INTEGER i,Nchr c ------------------------------------------------------------------ DO i=1,Nchr Chrvec(i:i)=Chr END DO c ------------------------------------------------------------------ RETURN END setcv.f0000664006604000003110000000761714521201564011477 0ustar sun00315stepsC Last change: BCM 28 Apr 1998 11:04 am DOUBLE PRECISION FUNCTION setcv(Nspobs,Cvalfa) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'stdio.i' c ------------------------------------------------------------------ LOGICAL F,T DOUBLE PRECISION PI,ONE,TWO PARAMETER(F=.false.,T=.true.,PI=3.14159265358979D0,ONE=1D0, & TWO=2D0) c ------------------------------------------------------------------ INTEGER Nspobs,i,iflag DOUBLE PRECISION Cvalfa,dnobs,y,xmat,beta,x,acv,bcv c---------------------------------------------------------------------- DOUBLE PRECISION setcvl,ppnd EXTERNAL setcvl,ppnd c---------------------------------------------------------------------- DIMENSION x(3),xmat(3,3),y(3),beta(3) c---------------------------------------------------------------------- DATA x / 2.0D0,100.0D0,200.0D0 / c---------------------------------------------------------------------- c Compute critical value based on length of series (see Ljung) c---------------------------------------------------------------------- setcv=DNOTST IF(Nspobs.eq.1)THEN c---------------------------------------------------------------------- c If only one observation in the outlier span, set the critical c value based on the normal deviate corresponding to alpha. c---------------------------------------------------------------------- setcv=ppnd(ONE-(Cvalfa/TWO),iflag) IF(iflag.eq.1)THEN CALL writln('ERROR: Default outlier critical value cannot be der &ived due to an',STDERR,Mt2,T) CALL writln(' internal error. Use the critical argument t &o set the outlier',STDERR,Mt2,F) CALL writln(' critical value.',STDERR,Mt2,T) setcv=DNOTST RETURN END IF c ------------------------------------------------------------------ c Else, set up equation to solve to get approximation formula for c this value of alpha. c ------------------------------------------------------------------ ELSE dnobs=DBLE(Nspobs) do i=1,3 if(i.eq.1)THEN y(1)=ppnd((ONE+sqrt(ONE-Cvalfa))/TWO,iflag) IF(iflag.eq.1)THEN CALL writln('ERROR: Default outlier critical value cannot be d &erived due to an',STDERR,Mt2,T) CALL writln(' internal error. Use the critical argument & to set the outlier',STDERR,Mt2,F) CALL writln(' critical value.',STDERR,Mt2,T) RETURN END IF ELSE y(i)=setcvl(int(x(i)),Cvalfa) END IF xmat(i,1)=ONE xmat(i,3)=sqrt(TWO*log(x(i))) xmat(i,2)=(LOG(LOG(x(i)))+LOG(TWO*TWO*PI))/(TWO*xmat(i,3)) END DO c ------------------------------------------------------------------ c solve equations... c ------------------------------------------------------------------ call lassol(3,xmat,y,3,beta,iflag) IF(iflag.eq.2)THEN CALL writln('ERROR: Default outlier critical value cannot be der &ived due to an',STDERR,Mt2,T) CALL writln(' estimation error. Use the critical argument &to set the outlier',STDERR,Mt2,F) CALL writln(' critical value.',STDERR,Mt2,T) RETURN END IF c---------------------------------------------------------------------- c Use coefficients to derive critical value for outlier span length c dnobs. c---------------------------------------------------------------------- acv=SQRT(TWO * LOG(dnobs)) bcv=(LOG(LOG(dnobs))+LOG(TWO*TWO*PI))/(TWO*acv) setcv=beta(1) + beta(2)*bcv + beta(3)*acv END IF c---------------------------------------------------------------------- RETURN END setcvl.f0000664006604000003110000000336614521201564011650 0ustar sun00315stepsC Last change: BCM 28 Apr 1998 11:04 am DOUBLE PRECISION FUNCTION setcvl(Nspobs,Cvalfa) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'stdio.i' c ------------------------------------------------------------------ LOGICAL F,T DOUBLE PRECISION PI,ONE,TWO,MINPT5 PARAMETER(F=.false.,T=.true.,PI=3.14159265358979D0,ONE=1D0, & TWO=2D0,MINPT5=-0.5D0) c ------------------------------------------------------------------ INTEGER Nspobs DOUBLE PRECISION dnobs,acv,bcv,xcv,Cvalfa,pmod c---------------------------------------------------------------------- c Compute critical value based on length of series (see Ljung) c---------------------------------------------------------------------- IF(Nspobs.eq.1)THEN CALL writln('ERROR: Default outlier critical value cannot be deri &ved for an outlier',STDERR,Mt2,T) CALL writln(' span of one observation. Either use the crit &ical argument to',STDERR,Mt2,F) CALL writln(' set the outlier critical value, or change the &setting of the',STDERR,Mt2,T) CALL writln(' defaultcritical argument.',STDERR,Mt2,T) Cvalfa=DNOTST setcvl=DNOTST RETURN END IF c---------------------------------------------------------------------- pmod=TWO-SQRT(ONE+Cvalfa) dnobs=DBLE(Nspobs) acv=SQRT(TWO * LOG(dnobs)) bcv=acv-(LOG(LOG(dnobs))+LOG(TWO*TWO*PI))/(TWO*acv) xcv=-LOG(MINPT5 * LOG(pmod)) setcvl=(xcv/acv) + bcv c---------------------------------------------------------------------- RETURN END setdp.f0000664006604000003110000000113714521201564011461 0ustar sun00315steps**==setdp.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE setdp(Const,N,X) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to set a double precision vector to const*J c----------------------------------------------------------------------- INTEGER i,N DOUBLE PRECISION Const,X(*) c ------------------------------------------------------------------ DO i=1,N X(i)=Const END DO c ------------------------------------------------------------------ RETURN END setint.f0000664006604000003110000000111014521201564011637 0ustar sun00315steps**==setint.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE setint(Intcnt,Nh,H) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to set an integer vector to intcnt*J c----------------------------------------------------------------------- INTEGER i,Intcnt,Nh,H(*) c ------------------------------------------------------------------ DO i=1,Nh H(i)=Intcnt END DO c ------------------------------------------------------------------ RETURN END setlg.f0000664006604000003110000000114414521201565011457 0ustar sun00315steps**==setlg.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE setlg(Lconst,N,X) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to set a logical vector to lconst*J c----------------------------------------------------------------------- LOGICAL Lconst,X INTEGER i,N DIMENSION X(*) c ------------------------------------------------------------------ DO i=1,N X(i)=Lconst END DO c ------------------------------------------------------------------ RETURN END setmdl.f0000664006604000003110000003742614521201565011645 0ustar sun00315stepsC Last change: SRD 31 Jan 100 7:39 am SUBROUTINE setmdl(Estprm,Laumts) IMPLICIT NONE c----------------------------------------------------------------------- c setmdl.f, Release 1, Subroutine Version 1.3, Modified 01 May 1995. 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 fcnkf, 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 fcnkf call. c----------------------------------------------------------------------- c Jan 2000 - Argument added to facilitate testing if initial values c generated from HR routine were valid (BCM) c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begptr i Local pointer to the first row in opr of the current c difference, AR, or MA filter c estprm d Input nestpm long vector of estimated parameters from the c nonlinear routine. 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,coef, and fix. c iopr i Local index for the current operator, it is the pointer c to the current row in the operator specfication matrix, c opr. c beglag i Local pointer to the current coefficient and lag in arimap c and arimal c nestpm i Input number of parmeters in estprm 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 c filter. c one d Local PARAMETER for a double precision 1 c oprptr i Local pointer of the current row of opr, specifying the c current operator c zero d Local PARAMETER for double precision 0 c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INTEGER beglag,begopr,endlag,endopr,iflt,ilag,iopr LOGICAL Laumts DOUBLE PRECISION Estprm DIMENSION Estprm(PARIMA) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c The following declaractions were added by Bor-Chung Chen for c the initial checking of invertibility and stationarity on 4/26/1995. c----------------------------------------------------------------------- CHARACTER dotln*(POPRCR+1),tmpttl*(POPRCR) LOGICAL allinv,allfix,onunit,mains,maon,mainsa,maonua,arona INTEGER factor,degree,ntmpcr,i DOUBLE PRECISION coef(PORDER+1),zeror(PORDER),zeroi(PORDER), & zerom(PORDER),zerof(PORDER) c----------------------------------------------------------------------- c The following declaractions were added by Brian C. Monsell for c the shrinkage of MA operators when roots are close to the unit circle C on 1/8/1998. c----------------------------------------------------------------------- DOUBLE PRECISION PT9 PARAMETER(PT9=0.9D0) LOGICAL shrnkp INTEGER lagind DIMENSION lagind(PORDER) LOGICAL first SAVE first DATA first/.true./ c----------------------------------------------------------------------- DATA dotln/ & ' -----------------------------------------------------------' & / c----------------------------------------------------------------------- mainsa=F maonua=F arona=F c----------------------------------------------------------------------- c For each AR and MA filter find out how many estimated parameters c and add them to the estimated parameter vector estprm. c----------------------------------------------------------------------- Nestpm=0 shrnkp=F DO iflt=DIFF,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ DO ilag=beglag,endlag IF(.not.Arimaf(ilag))THEN Nestpm=Nestpm+1 Estprm(Nestpm)=Arimap(ilag) c----------------------------------------------------------------------- c CODE ADDED BY Brian Monsell Jan. 1998 c Save lag corresponding to the ith estimated operator, in case c this operator is to be shrunk later. c----------------------------------------------------------------------- IF(.not.first)lagind(ilag)=Nestpm c----------------------------------------------------------------------- END IF END DO END DO END DO c----------------------------------------------------------------------- c Compute the roots of initial theta(B)=0 c----------------------------------------------------------------------- begopr=Mdl(MA-1) beglag=Opr(begopr-1) endopr=Mdl(MA)-1 c ------------------------------------------------------------------ IF(endopr.gt.0)THEN endlag=Opr(endopr)-1 mainsa=F maonua=F c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ factor=Oprfac(iopr) degree=Arimal(endlag)/factor coef(1)=-1.0D0 CALL setdp(0D0,degree,coef(2)) c ------------------------------------------------------------------ CALL setdp(0D0,PORDER,zeror) CALL setdp(0D0,PORDER,zeroi) CALL setdp(0D0,PORDER,zerom) c ------------------------------------------------------------------ DO ilag=beglag,endlag coef(Arimal(ilag)/factor+1)=Arimap(ilag) END DO c ------------------------------------------------------------------ CALL roots(coef,degree,allinv,zeror,zeroi,zerom,zerof) c----------------------------------------------------------------------- c Check invertibility c the roots are g(i)=(zeror(i), zeroi(i)), i=1,2,...,degree c complex roots are g(i) and g(i+1) c If all zeros are invertible do nothing; otherwise print an error c message and STOP execution of the program. c----------------------------------------------------------------------- mains=F IF(.not.allinv)THEN c----------------------------------------------------------------------- CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(.not.Laumts)WRITE(STDERR,1010)tmpttl(1:ntmpcr) WRITE(Mt2,1010)tmpttl(1:ntmpcr) 1010 FORMAT(/,' ERROR: ',a,' polynomial with initial parameters', & ' is noninvertible',/,' with root(s) inside the', & ' unit circle. RESPECIFY model with',/, & ' different initial parameters.',/) c ------------------------------------------------------------------ mains=T mainsa=T c ------------------------------------------------------------------ END IF onunit=F c----------------------------------------------------------------------- c CODE ADDED BY Brian Monsell Jan. 1998 c Initialize shrnkp, which indicates whether the operator should c be shrunk. c----------------------------------------------------------------------- shrnkp=F i=0 DO WHILE (i.lt.degree) i=i+1 c----------------------------------------------------------------------- c CODE ADDED BY Brian Monsell Jan. 1998 c If first entry, to see if initial parameters are noninvertible c with roots on the unit circle. Else, see if operator has roots c too close to the unit circle and should be shrunk. c----------------------------------------------------------------------- IF(first)THEN IF(dpeq(zerom(i),1D0).AND.(.not.onunit))onunit=T ELSE IF((zerom(i).le.1.06D0).AND.(.not.shrnkp))shrnkp=T END IF END DO allfix=T DO ilag=beglag,endlag IF((.not.Arimaf(ilag)).and.allfix)allfix=F END DO c ------------------------------------------------------------------ maon=F IF(onunit.and.(.not.allfix))THEN CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(.not.Laumts)WRITE(STDERR,1020)tmpttl(1:ntmpcr) WRITE(Mt2,1020)tmpttl(1:ntmpcr) IF(.not.Laumts)WRITE(Mt1,1020)tmpttl(1:ntmpcr) 1020 FORMAT(/,' ERROR: ',a,' polynomial with initial parameters', & ' is noninvertible',/,' with root(s) on the ', & 'unit circle. RESPECIFY model with',/, & ' different initial parameters.',/) maon=T maonua=T END IF c----------------------------------------------------------------------- c CODE ADDED BY Brian Monsell Jan. 1998 c Multiply model parameter estimates for this operator by a c constant, and update the entries in the estimated parameter c vector. c ------------------------------------------------------------------ IF(shrnkp.AND.(.not.allfix))THEN c CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) c IF(Lfatal)RETURN c WRITE(STDERR,1021)tmpttl(1:ntmpcr) c WRITE(Mt2,1021)tmpttl(1:ntmpcr) c WRITE(Mt1,1021)tmpttl(1:ntmpcr) c1021 FORMAT(/,' WARNING: ',a,' polynomial from a previous estimation', c & ' has root(s)',/,' on or near the unit circle.') DO ilag=beglag,endlag IF(.not.Arimaf(ilag))THEN Arimap(ilag)=Arimap(ilag)*(PT9**Arimal(ilag)) Estprm(lagind(ilag))=Arimap(ilag) END IF END DO END IF c ------------------------------------------------------------------ IF((mains.or.maon).and.(.not.Laumts))THEN WRITE(Mt1,1030)tmpttl(1:ntmpcr),dotln 1030 FORMAT(' ',a,' Roots',/,' Root',t25,'Real',t31,'Imaginary', & t44,'Modulus',t53,'Frequency',/,a) c ------------------------------------------------------------------ DO i=1,degree WRITE(Mt1,1040)i,zeror(i),zeroi(i),zerom(i),zerof(i) 1040 FORMAT(' Root',i3,t18,4F11.4) END DO WRITE(Mt1,1000)dotln END IF c----------------------------------------------------------------------- END DO END IF c----------------------------------------------------------------------- c Compute the roots of initial phi(B)=0 c----------------------------------------------------------------------- begopr=Mdl(AR-1) beglag=Opr(begopr-1) endopr=Mdl(AR)-1 c ------------------------------------------------------------------ IF(endopr.gt.0)THEN endlag=Opr(endopr)-1 arona=F c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ factor=Oprfac(iopr) degree=Arimal(endlag)/factor coef(1)=-1.0D0 c ------------------------------------------------------------------ CALL setdp(0D0,PORDER,zeror) CALL setdp(0D0,PORDER,zeroi) CALL setdp(0D0,PORDER,zerom) c ------------------------------------------------------------------ CALL setdp(0D0,degree,coef(2)) c ------------------------------------------------------------------ DO ilag=beglag,endlag coef(Arimal(ilag)/factor+1)=Arimap(ilag) END DO c ------------------------------------------------------------------ CALL roots(coef,degree,allinv,zeror,zeroi,zerom,zerof) c----------------------------------------------------------------------- c Check stationarity the roots are g(i)=(zeror(i), zeroi(i)), c i=1,2,...,degree and the complex roots are g(i) and g(i+1). c If all zeros are stationary do nothing; otherwise print a warning c message. The program may bomb later if the exact AR is used. c----------------------------------------------------------------------- onunit=F i=0 DO WHILE (i.lt.degree) i=i+1 IF(dpeq(zerom(i),1D0).and..not.onunit)onunit=T END DO IF((.not.allinv).or.onunit)THEN CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(Lar)THEN IF(.not.Laumts)WRITE(STDERR,1050)tmpttl(1:ntmpcr) WRITE(Mt2,1050)tmpttl(1:ntmpcr) IF(.not.Laumts)WRITE(Mt1,1050)tmpttl(1:ntmpcr) 1050 FORMAT(/,' ERROR: ',a,' polynomial with initial parameters', & ' is nonstationary',/,' with root(s) on or', & ' inside the unit circle. RESPECIFY the',/, & ' model with different initial parameters.', & /) arona=T c ------------------------------------------------------------------ ELSE IF(.not.(Laumts.or.Lquiet))WRITE(STDERR,1060)tmpttl(1:ntmpcr) WRITE(Mt2,1060)tmpttl(1:ntmpcr) IF(.not.Laumts)WRITE(Mt1,1060)tmpttl(1:ntmpcr) 1060 FORMAT(/,' WARNING: ',a,' polynomial with initial parameters', & ' is nonstationary', & /,' with root(s) on or inside the unit ', & 'circle. RESPECIFY the model', & /,' with different initial parameters.',/) END IF c ------------------------------------------------------------------ IF(.not.Laumts)THEN WRITE(Mt1,1030)tmpttl(1:ntmpcr),dotln c ------------------------------------------------------------------ DO i=1,degree WRITE(Mt1,1040)i,zeror(i),zeroi(i),zerom(i),zerof(i) END DO WRITE(Mt1,1000)dotln END IF c ------------------------------------------------------------------ c IF(.not.arona)arona=T c ------------------------------------------------------------------ END IF END DO END IF c----------------------------------------------------------------------- c CODE ADDED BY Brian Monsell Jan. 1998 c ------------------------------------------------------------------ first=.false. c ------------------------------------------------------------------ IF(mainsa.or.maonua.or.arona)THEN IF(Laumts)THEN Laumts=F ELSE CALL abend END IF END IF c ------------------------------------------------------------------ 1000 FORMAT(a) c ------------------------------------------------------------------ RETURN END setmv.f0000664006604000003110000000133414521201565011500 0ustar sun00315steps SUBROUTINE setmv(Srs,Mvind,Mvval,Pos1ob,Posfob) IMPLICIT NONE c----------------------------------------------------------------------- c Check to see if prior adjustments have brought down missing c value code, and reset missing value code if this has occurred. c----------------------------------------------------------------------- DOUBLE PRECISION Srs,Mvval LOGICAL Mvind INTEGER Pos1ob,Posfob,i DIMENSION Srs(*),Mvind(*) c----------------------------------------------------------------------- DO i=Pos1ob,Posfob IF(Mvind(i))Srs(i)=Mvval END DO c----------------------------------------------------------------------- RETURN END setopr.f0000664006604000003110000001175214521201565011663 0ustar sun00315stepsC Last change: BCM 18 Dec 1998 10:13 am SUBROUTINE setopr(Optype,Coef,Lag,Fix,Ncoef,Nd,Naimcf,Locok, & Inptok) IMPLICIT NONE c----------------------------------------------------------------------- c Setup the variables for the MA and AR parameters and add the c coefficients and lags to the model. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c coef d Input pcoef ncoef used long vector of nonzero coefficients c to be added to arimap c fixvec l Input array to determine what parameters are fixed and c not estimated. c i i Local do loop index and temporary scalar c lag i Input pcoef ncoef used long vector of the lags of the nonzero c coefficients to be added to arimal. c ncoef i Input number of non zero coefficients in coef and lag c optitl c Output 20 character scalar for the title of the current c operator. c optypn c Local 20 character 3 long vector of names of the types of c operators. c----------------------------------------------------------------------- c INCLUDE 'lex.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' INCLUDE 'stdio.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ INTEGER LINLEN LOGICAL T,F PARAMETER(LINLEN=133,T=.true.,F=.false.) c ------------------------------------------------------------------ CHARACTER str*(LINLEN) LOGICAL Fix,getint,Inptok,Locok INTEGER i,ipos,Lag,mxord,Naimcf,nchr,Ncoef,Optype,ivec,Nd DOUBLE PRECISION Coef,dpvec DIMENSION Coef(*),Fix(*),Lag(*),dpvec(1),ivec(1) EXTERNAL getint c ------------------------------------------------------------------ CHARACTER OPRDIC*8 INTEGER oprptr,POPDIC PARAMETER(POPDIC=3) DIMENSION oprptr(0:POPDIC) PARAMETER(OPRDIC='DIFFARMA') DATA oprptr/1,5,7,9/ c----------------------------------------------------------------------- c Get the number of differences, number of lags, or the lags c themselves for one of the AR, differencing, or MA operators within c an ARIMA, (AR DIFF MA)Period, factor. Called from GETMDL. c----------------------------------------------------------------------- Locok=T IF(Optype.eq.DIFF)THEN mxord=PDIFOR ELSE mxord=PORDER END IF c----------------------------------------------------------------------- c If only the number of differences or lags are specified then c fill then in. c----------------------------------------------------------------------- IF(Ncoef.gt.mxord)THEN str='Maximum number of ' ipos=19 CALL getstr(OPRDIC,oprptr,POPDIC,Optype,str(ipos:),nchr) IF(Lfatal)RETURN ipos=ipos+nchr str(ipos:)=' lags, ' ipos=ipos+7 c ------------------------------------------------------------------ CALL itoc(mxord,str,ipos) IF(Lfatal)RETURN str(ipos:)=', exceeded.' ipos=ipos+11 CALL writln('ERROR: '//str(1:ipos-1),STDERR,Mt2,T) Locok=F c ------------------------------------------------------------------ ELSE IF(Naimcf+Ncoef-1.gt.PARIMA)THEN str='Maximum number of ARIMA coefficients, ' ipos=39 CALL itoc(PARIMA,str,ipos) IF(Lfatal)RETURN str(ipos:)=', exceeded. Reduce the model order.' ipos=ipos+36 CALL writln('ERROR: '//str(1:ipos-1),STDERR,Mt2,T) Locok=F c----------------------------------------------------------------------- c Set up the (1-B)^nd difference operator c----------------------------------------------------------------------- ELSE IF(Optype.eq.DIFF)THEN c Nd=Ncoef IF(Nd.gt.0)THEN Ncoef=0 ivec(1)=1 dpvec(1)=1D0 DO i=1,Nd CALL polyml(dpvec,ivec,1,Coef,Lag,Ncoef,PDIFOR,Coef,Lag,Ncoef) END DO END IF c----------------------------------------------------------------------- c Fill in the lags for the AR or MA operator and put in default c starting values of 0.1. Note, AR and MA operators are not fixed c by default. c----------------------------------------------------------------------- ELSE IF(Ncoef.gt.0)THEN DO i=1,Ncoef Lag(i)=i END DO END IF c----------------------------------------------------------------------- c Set the coefficient and fix vector if it hasn't been done. c----------------------------------------------------------------------- IF(Optype.ne.DIFF)CALL setdp(DNOTST,Ncoef,Coef) CALL setlg(Optype.eq.DIFF,Ncoef,Fix) c ------------------------------------------------------------------ Naimcf=Naimcf+Ncoef Inptok=Inptok.and.Locok RETURN END setpt.f0000664006604000003110000000336214521201565011504 0ustar sun00315stepsC Last change: BCM 24 Nov 97 12:47 pm SUBROUTINE setpt(Mt1,Arma,Str) IMPLICIT NONE c ------------------------------------------------------------------ c Set up variable used to print out ARIMA model parameters in c automatic modeling. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER tmpttl*(POPRCR),Str*(*) INTEGER Mt1,begopr,endopr,iopr,beglag,endlag,ntmpcr,ilag,Arma,i, & i2,npt DOUBLE PRECISION pt DIMENSION pt(PARIMA) c ------------------------------------------------------------------ npt=0 begopr=Mdl(Arma-1) endopr=Mdl(Arma)-1 DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN IF(tmpttl(1:ntmpcr).eq.Str)THEN DO ilag=beglag,endlag npt=npt+1 pt(npt)=Arimap(ilag) END DO END IF END DO c ------------------------------------------------------------------ c If npt > 0, print out parameter estimates c ------------------------------------------------------------------ IF(npt.gt.0)THEN i2=npt IF(npt.gt.5)i2=5 WRITE(Mt1,1010)Str,(pt(i),i=1,i2) 1010 FORMAT(' ',a,' parameter estimates:',t40,5f8.3) IF(i2.lt.npt)WRITE(Mt1,1020)(pt(i),i=i2+1,npt) 1020 FORMAT(t40,5f8.3) END IF RETURN c ------------------------------------------------------------------ END setrvp.f0000664006604000003110000000537514521201565011676 0ustar sun00315steps SUBROUTINE setrvp(Begspn,Ny,Lfda,Llda,Lmodel) IMPLICIT NONE c----------------------------------------------------------------------- c --- Set pointer for beginning, end of adjustment loop for revisions c analysis c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revtrg.cmn' c----------------------------------------------------------------------- INTEGER MO,YR PARAMETER(MO=2,YR=1) c----------------------------------------------------------------------- INTEGER Begspn,Ny,Lfda,Llda,i,mxrlag LOGICAL Lmodel DIMENSION Begspn(2) c----------------------------------------------------------------------- CALL dfdate(Rvstrt,Begspn,Ny,Begrev) Begrev=Begrev+Lfda CALL dfdate(Rvend,Begspn,Ny,Endsa) Endsa=Endsa+Lfda Endrev=Llda IF(Endsa.ne.Endrev)Endsa=Endsa+1 Endtbl=Endsa Revnum=Endtbl-Begrev IF(Ntarsa.gt.0.or.Ntartr.gt.0)THEN mxrlag=0 IF(Ntarsa.gt.0)THEN DO i=1,Ntarsa IF(mxrlag.lt.Targsa(i))mxrlag=Targsa(i) END DO END IF IF(Ntartr.gt.0)THEN DO i=1,Ntartr IF(mxrlag.lt.Targtr(i))mxrlag=Targtr(i) END DO END IF Endsa=Endsa+mxrlag IF(Endsa.gt.Llda)Endsa=Llda END IF c Revptr=Endrev-Begrev+1 c----------------------------------------------------------------------- c Set Beglup, the first observation in the loop. Will be different c from Begrev only if revisions history of the projected seasonal c factors are requested. c----------------------------------------------------------------------- Beglup=Begrev CALL cpyint(Rvstrt,2,1,Lupbeg) IF(Lrvsf)THEN Lupbeg(YR)=Rvstrt(YR)-1 Lupbeg(MO)=Ny CALL dfdate(Lupbeg,Begspn,Ny,Beglup) Beglup=Beglup+Lfda Frstsa=Beglup ELSE Frstsa=Begrev END IF c----------------------------------------------------------------------- c If Fixper > 0, set the beginning of the loop so that the first c model estimation occurs at the first occurance of the period c Fixper before the revision history loop. c----------------------------------------------------------------------- IF(Fixper.gt.0.and.Lmodel)THEN IF(Lupbeg(MO).gt.Fixper)THEN Beglup=Beglup-(Lupbeg(MO)-Fixper) Lupbeg(MO)=Fixper ELSE IF(Lupbeg(MO).lt.Fixper)THEN Beglup=Beglup-(Ny-(Fixper-Lupbeg(MO))) Lupbeg(MO)=Fixper Lupbeg(YR)=Lupbeg(YR)-1 END IF END IF c----------------------------------------------------------------------- RETURN END setspn.f0000664006604000003110000000276614521201565011670 0ustar sun00315stepsC Last change: BCM 10 Mar 98 10:40 am SUBROUTINE setspn(Sp,Nend,Nbeg,Begspn,Endspn,Begmdl,Endmdl,Nspobs, & Frstsy,Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy, & Begadj,Adj1st) IMPLICIT NONE c----------------------------------------------------------------------- c If a model span has been used, reset beginning and ending dates c for span and reset span length and other pointers. c----------------------------------------------------------------------- INTEGER Sp,Nend,Nbeg,Begspn,Endspn,Begmdl,Endmdl,Nspobs,Frstsy, & Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy,Begadj,Adj1st DIMENSION Begspn(2),Endspn(2),Begmdl(2),Endmdl(2),Begsrs(2), & Begadj(2) c----------------------------------------------------------------------- IF(Nend.gt.0)CALL addate(Endmdl,Sp,Nend,Endspn) IF(Nbeg.gt.0)CALL addate(Begmdl,Sp,-Nbeg,Begspn) c----------------------------------------------------------------------- c Reset length of series, other pointers c----------------------------------------------------------------------- CALL dfdate(Endspn,Begspn,Sp,Nspobs) Nspobs=Nspobs+1 CALL dfdate(Begspn,Begsrs,Sp,Frstsy) Frstsy=Frstsy+1 Nomnfy=Nobs-Frstsy+1 Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nomnfy) CALL dfdate(Begspn,Begadj,Sp,Adj1st) Adj1st=Adj1st+1 c----------------------------------------------------------------------- RETURN END setssp.f0000664006604000003110000003164114521201565011667 0ustar sun00315stepsC Last change: BCM 19 May 2003 2:29 pm SUBROUTINE setssp(Issap,Begspn,Pos1,Pos2,Ltmax,Lmodel,Lseats, & Lncset,Lnlset,Otlfix) IMPLICIT NONE c----------------------------------------------------------------------- c Set up sliding spans options c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'ssap.prm' INCLUDE 'notset.prm' INCLUDE 'agr.cmn' INCLUDE 'error.cmn' INCLUDE 'ssap.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'units.cmn' INCLUDE 'lzero.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11log.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11opt.cmn' c INCLUDE 'model.cmn' c----------------------------------------------------------------------- INTEGER MAXNL LOGICAL T,F PARAMETER(MAXNL=4,T=.true.,F=.false.) c----------------------------------------------------------------------- CHARACTER numstr*(10) LOGICAL tdfix,holfix,Otlfix,usrfix,Lnlset,Lncset,mdlok,Lmodel, & Lseats INTEGER i,Issap,nl,l2,Ltmax,ncmax,lm,begss,endss,Pos1,Pos2,frstsp, & nmcomp,ssbak,ipos,ipos2,Begspn,pos0,lyr0,fhnote DIMENSION nl(-1:MAXNL),ssbak(2),frstsp(2),begss(2),endss(2), & Begspn(2) c----------------------------------------------------------------------- INTEGER mdssln EXTERNAL mdssln c----------------------------------------------------------------------- DATA nl/6,6,7,8,11,17/ c----------------------------------------------------------------------- fhnote=STDERR IF(Lquiet)fhnote=0 IF(Itd.ne.1.AND.(Axrgtd.OR.Adjtd.gt.0))Itd=1 IF(Ihol.ne.1.AND.(Axrghl.or.Adjhol.gt.0))Ihol=1 IF(Itd.eq.1.and.Adjtd.gt.0.and.Ssinit.eq.1)Itd=-1 IF(Ihol.eq.1.and.Adjhol.gt.0.and.Ssinit.eq.1)Ihol=-1 IF(Ihol.eq.1.and.(.not.Finhol))Ihol=0 IF(Muladd.ne.1)THEN IF(Ssdiff)Ssdiff=F IF(Ssidif.and.Iagr.ge.5)Ssidif=F END IF c----------------------------------------------------------------------- c Check to see if summary measures run is done; if so, only go on if c this is a component of a composite seasonal adjustment. c----------------------------------------------------------------------- IF(Kfulsm.eq.1)THEN CALL writln('WARNING: No seasonal adjustment has been done becaus &e type=summary',fhnote,Mt2,T) CALL writln(' occurs in the x11 spec. Therefore no slidi &ng spans analysis',fhnote,Mt2,F) CALL writln(' has been done.',fhnote,Mt2,F) IF(Iagr.eq.2)THEN CALL writln(' The unadjusted series from this spec file &has been incorporated',fhnote,Mt2,T) CALL writln(' into the composite seasonal adjustment for & each of the sliding',fhnote,Mt2,F) CALL writln(' spans.',fhnote,Mt2,F) ELSE IF(Iagr.ge.0)CALL abend RETURN END IF END IF c----------------------------------------------------------------------- c check to see if there is enough data for sliding spans c----------------------------------------------------------------------- IF(Lncset.and.Lnlset)THEN IF(Length.LT.(Nlen+(Ncol-1)*Ny))THEN ipos=1 CALL itoc(Ncol,numstr,ipos) ipos2=ipos CALL itoc(Nlen,numstr,ipos2) Issap=0 CALL writln('NOTE: Not enough data to produce '// & numstr(1:(ipos-1))//' sliding spans of length '// & numstr(ipos:(ipos2-1))//'.',fhnote,Mt2,T) END IF c----------------------------------------------------------------------- c set length of sliding spans for stable seasonal. c----------------------------------------------------------------------- ELSE IF(Ltmax.eq.5)THEN IF(.not.Lncset)THEN IF(Lnlset)THEN ncmax=((Length-Nlen)/Ny)+1 IF(ncmax.ge.4)THEN Ncol=4 ELSE IF(ncmax.le.1)THEN Issap=0 CALL writln('NOTE: Not enough data to perform sliding spans an &alysis.',fhnote,Mt2,T) ipos=1 CALL itoc(Nlen,numstr,ipos) CALL writln(' '// & 'Must be able to form at least two spans of length '// & numstr(1:ipos-1)//'.',fhnote,Mt2,F) ELSE Ncol=ncmax END IF ELSE Ncol=4 END IF END IF IF(.not.Lnlset)THEN Nlen=Length-(Ncol-1)*Ny IF(Nlen.gt.nl(MAXNL)*Ny)THEN Nlen=nl(MAXNL)*Ny IF(Lstmo.lt.Ny)Nlen=Nlen-Ny END IF IF(Nlen.lt.3*Ny)THEN IF(Lncset)THEN Issap=0 ipos=1 CALL itoc(Ncol,numstr,ipos) CALL writln('NOTE: Not enough data to produce '// & numstr(1:(ipos-1))// & ' spans with at least 3 years of data.', & fhnote,Mt2,T) ELSE Ncol=((Length-3*Ny)/Ny)+1 IF(Ncol.le.1)THEN Issap=0 CALL writln('NOTE: Not enough data to perform sliding spans a &nalysis.',fhnote,Mt2,T) CALL writln(' Must have at least 3 years of data in each & span to perform',fhnote,Mt2,F) CALL writln(' sliding spans analysis for stable seasonal & filters.',fhnote,Mt2,F) END IF END IF IF(Issap.gt.0)Nlen=Length-Ny*(Ncol-1) END IF END IF ELSE c----------------------------------------------------------------------- c set length of sliding spans for other seasonal filter lengths, or c by the first order seasonal moving average parameter estimate if c SEATS seasonal adjustments are used. c----------------------------------------------------------------------- IF(.not.Lnlset)THEN IF(Lseats)THEN Nlen=mdssln(Ny) ELSE Nlen=nl(Ltmax)*Ny END IF END IF ncmax=((Length-Nlen)/Ny)+1 IF(Lncset)THEN IF(ncmax.lt.Ncol)THEN ipos=1 CALL itoc(Ncol,numstr,ipos) ipos2=ipos CALL itoc(Nlen,numstr,ipos2) Issap=0 CALL writln('NOTE: Not enough data to produce '// & numstr(1:(ipos-1))//' sliding spans of length '// & numstr(ipos:(ipos2-1))//'.',fhnote,Mt2,T) END IF ELSE IF(ncmax.gt.4)THEN Ncol=4 ELSE IF(ncmax.lt.2)THEN Issap=0 CALL writln('NOTE: Not enough data to perform sliding spans ana &lysis.',fhnote,Mt2,T) IF(Lnlset)THEN ipos=1 CALL itoc(Nlen,numstr,ipos) CALL writln(' '// & 'Must be able to form at least two spans of length '// & numstr(1:ipos-1)//'.',fhnote,Mt2,F) ELSE CALL writln(' Must be able to form at least two sliding s &pans.',fhnote,Mt2,F) END IF ELSE Ncol=ncmax END IF END IF END IF IF(Issap.eq.0)THEN Ncol=0 Nlen=0 * CALL abend RETURN END IF c----------------------------------------------------------------------- c set number of months (Sslen) to be used in sliding spans c analysis. c----------------------------------------------------------------------- Sslen=Nlen+(Ncol-1)*Ny c----------------------------------------------------------------------- c set first month, year of sliding spans analysis. c----------------------------------------------------------------------- IF(Length.eq.Sslen)THEN Im=mod(Pos1,Ny) Iyr=Lyr+(Pos1/Ny) IF(Im.eq.0)THEN Im=Ny Iyr=Iyr-1 END IF ELSE l2=Length-(Nlen+(Ncol-1)*Ny) Iyr=Lyr+(Pos1+l2)/Ny Im=mod(Pos1+l2,Ny) IF(Im.eq.0)THEN Im=Ny Iyr=Iyr-1 END IF c IF(Ny.eq.4)Ltmax=Ltmax-3 IF((.not.Lnlset).and.Ltmax.lt.4)THEN c----------------------------------------------------------------------- c set first month of sliding spans analysis to be january or c first quarter of series. adjust nlen, len if necessary. c----------------------------------------------------------------------- lyr0=Lyr+(Pos1/Ny) pos0=mod(Pos1,Ny) IF(pos0.eq.0)THEN pos0=Ny lyr0=lyr-1 END IF IF((pos0.eq.1.and.Im.ne.1).or.(pos0.lt.Im.and.Iyr.eq.lyr0))THEN Nlen=(Im-Pos0)+Nlen Im=Pos0 ELSE IF(Im.gt.1.and.Iyr.gt.lyr0)THEN Nlen=(Im-1)+Nlen Im=1 END IF END IF Sslen=Nlen+(Ncol-1)*Ny END IF c----------------------------------------------------------------------- c set last month of sliding spans analysis. c----------------------------------------------------------------------- lm=mod(SSlen,Ny) IF(lm.eq.0)lm=Ny c----------------------------------------------------------------------- c set first month (icm) and year (icyr) of sliding spans c comparisons, relative position of first sliding spans c comparison (ic). c----------------------------------------------------------------------- IF(Strtss(YR).eq.NOTSET)THEN Strtss(YR)=Iyr+1 Strtss(MO)=Im Icm=Im Icyr=Iyr+1 Ic=Im+Ny ELSE frstsp(MO)=Im frstsp(YR)=Iyr CALL dfdate(Strtss,frstsp,Ny,i) IF(i.ge.Ny)THEN Icm=Strtss(MO) Icyr=Strtss(YR) Ic=(Icyr-Iyr)*Ny+Icm ELSE CALL writln('WARNING: Date of the first sliding spans comparison & is set too early.',fhnote,Mt2,T) CALL writln(' This date will be reset so that it is one &year after the',fhnote,Mt2,F) CALL writln(' starting date of the first span.',fhnote, & Mt2,F) Icm=Im Icyr=Iyr+1 Ic=Im+Ny Strtss(MO)=Icm Strtss(YR)=Icyr END IF END IF c----------------------------------------------------------------------- c Set number of sliding spans comparisons for each type of variable c----------------------------------------------------------------------- begss(YR)=Iyr begss(MO)=Im CALL addate(begss,Ny,Sslen-Ny,endss) CALL dfdate(endss,Strtss,Ny,nmcomp) DO i=1,5 IF(i.le.3)THEN Itot(i)=nmcomp ELSE IF(i.eq.4)THEN Itot(i)=nmcomp-1 ELSE Itot(i)=nmcomp-Ny END IF END DO c----------------------------------------------------------------------- c calculate beginning date of backcasts c----------------------------------------------------------------------- CALL addate(begss,Ny,-Nbcst,ssbak) c----------------------------------------------------------------------- c if first month of backcasts not = 1, increase number of backcasts c to accomodate. c----------------------------------------------------------------------- IF(ssbak(MO).gt.1)THEN Nbcst2=Nbcst+ssbak(MO)-1 ELSE Nbcst2=Nbcst END IF c----------------------------------------------------------------------- c Check to see if length of span is long enough to support c trading day adjustment. c----------------------------------------------------------------------- IF(Nlen.lt.5*Ny)THEN IF(Itd.eq.1)Itd=-2 IF(Ihol.eq.1)Ihol=-2 END IF c----------------------------------------------------------------------- Nsea=Ny L0=Pos2-(Nlen+Im-2+(Ncol-1)*Ny) tdfix=F holfix=F usrfix=F Otlfix=F IF(Nssfxr.gt.0)THEN DO i=1,Nssfxr IF(Ssfxrg(i).eq.1)THEN tdfix=T ELSE IF(Ssfxrg(i).eq.2)THEN holfix=T ELSE IF(Ssfxrg(i).eq.3)THEN usrfix=T ELSE IF(Ssfxrg(i).eq.4)THEN Otlfix=T END IF END DO END IF C----------------------------------------------------------------------- IF(Nssfxr.gt.0)THEN CALL cpyint(Ssfxrg,4,1,Ssfxxr) Nssfxx=Nssfxr END IF C----------------------------------------------------------------------- c Set regARIMA modelling options for sliding spans, if regARIMA c modelling requested C----------------------------------------------------------------------- IF(Lmodel)THEN mdlok=T CALL ssmdl(Iyr,Im,Itd,Ihol,tdfix,holfix,Otlfix,usrfix,mdlok) IF(.not.mdlok)Lfatal=T IF(Lfatal)RETURN END IF C----------------------------------------------------------------------- IF(Nbx.gt.0)THEN CALL ssxmdl(Begspn,Begss,Itd,Ihol,tdfix,holfix,Otlfix,usrfix) IF(Lfatal)RETURN IF(Lmodel)CALL restor(Lmodel,F,F) END IF c----------------------------------------------------------------------- RETURN END setsvl.i0000664006604000003110000000200514521201565011661 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for svltbl are of the form LSL c where the types are c----------------------------------------------------------------------- c seats model smd c normality test nrm c total squared error tse c component variance cvr c concurrent estimate error cee c percent reduction se prs c average abs. diff. in annual averages aad c----------------------------------------------------------------------- INTEGER LSLSMD,LSLXMD,LSLSNR,LSLTSE,LSLCVR,LSLCEE,LSLPRS,LSLAAD, & LSLOUE,LSLOUS,LSLSSG,LSLDW,LSLFRS,LSLALS PARAMETER( & LSLSMD= 95,LSLXMD= 96,LSLSNR= 98,LSLTSE= 99,LSLCVR=100, & LSLCEE=101,LSLPRS=102,LSLAAD=103,LSLOUE=104,LSLOUS=105, & LSLSSG=106,LSLDW=107,LSLFRS=108,LSLALS=109) settab.prm0000664006604000003110000000201414521201565012171 0ustar sun00315steps DATA sumtab/ & T,F,F,F,F,F,F,F,F,F, F,F,F,F,T,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,T,T, F,F,F,T,F,F,T,F,F,F, & F,F,F,F,F,F,F,F,F,T, T,T,T,T,T,T,T,T,T,T, T,T,F,F,F,F,F,T,T,T, & T,T,T,T,T,T,F,F,F,F, F,F,T,T,F,F,F,F,F,F, F,F,F,F,F,F,F,T,T,F, & F,F,T,F,F,F/ c ------------------------------------------------------------------ DATA deftab/ & T,T,T,F,T,T,T,F,F,T, T,T,T,T,T,T,F,F,T,F, T,F,T,F,T,F,F,T,F,F, & T,T,T,T,T,T,T,F,T,T, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,T,F,F,F, & T,F,F,F,T,F,T,F,F,T, F,F,T,F,F,T,T,F,F,F, T,F,T,F,F,T,T,T,F,T, & F,T,T,F,T,F,F,T,T,T, T,T,T,F,T,T,F,T,T,T, T,T,T,T,T,T,F,T,F,T, & F,T,F,T,F,T,F,T,T,T, T,T,T,T,T,T,T,T,T,T, T,T,F,F,F,F,F,T,T,T, & T,T,T,T,T,T,F,F,F,F, T,F,T,T,T,T,T,T,T,T, F,F,F,T,T,T,F,T,T,F, & T,T,T,T,F,F/ setup.f0000664006604000003110000000436314521201566011510 0ustar sun00315stepsC Last change: BCM 12 Nov 1998 10:53 am **==setup.f processed by SPAG 4.03F at 11:38 on 7 Nov 1994 SUBROUTINE setup(Icode,Icod2) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'chrt.cmn' INCLUDE 'rho.cmn' c----------------------------------------------------------------------- INTEGER i,Icod2,Icode,j,j2,k,k2 c----------------------------------------------------------------------- Fact1=52D0 Ifact2=54 Ibottm=55 C*************** C SET UP CHART BOUNDARIES C*************** DO i=1,110 DO j=1,55 Ia(i,j)=' ' END DO END DO IF(Nseas.eq.12.or.Icode.eq.7)THEN DO i=1,61 Iyear(i)=int(Xdata3(i)) END DO ELSE Inyr=0 DO i=1,30,2 j=i/2+1 IF(Ifrst.eq.1)THEN Iyear(j)=int(Xdata3(i)) ELSE Iyear(j)=int(Xdata3(i+1)) END IF IF(i.le.Nyr)Inyr=Inyr+1 END DO END IF Icmax=N1+1 Ydiff=Ymax-Ymin DO j=1,53,4 j2=((53-j)/4)+1 Ymid(j2)=(Ydiff*(j-1))/52+Ymin END DO Ia(1,1)=I11 Ia(1,Ibottm)=I10 Ia(Icmax+1,1)=I8 Ia(Icmax+1,Ibottm)=I9 DO i=2,Ibottm-1 Ia(1,i)=I4 Ia(Icmax+1,i)=I4 END DO IF(((Icode-7)*(Icod2-15)*Icode).ne.0)THEN k=Nseas-Ifrst+2 DO i=1,Ibottm DO j=k,Icmax,Nseas Ia(j,i)=I7 END DO END DO END IF IF(Icode.eq.0)THEN DO i=1,Ibottm DO j=1,Icmax j2=j-2 IF(Nseas.eq.10)THEN IF(Lfqalt.and.j2.eq.36)Ia(j,i)='T' IF(j2.eq.42.or.j2.eq.52)Ia(j,i)='T' ELSE IF(Icod2.eq.0)THEN IF(Lfqalt.and.(j2.eq.35.or.j2.eq.41.or.j2.eq.46))Ia(j,i)='T' IF(j2.eq.5.or.j2.eq.11)Ia(j,i)='T' END IF IF(mod(j2,Nseas).eq.0.and.j2.gt.0)Ia(j,i)='S' END DO END DO END IF DO i=2,Icmax Ia(i,1)=I3 Ia(i,Ibottm)=I3 IF(((Icode-7)*(Icod2-15)*Icode).ne.0)THEN DO k2=3,12,3 Ia(i,Imid(k2))=I7 END DO END IF END DO RETURN END setwrt.f0000664006604000003110000000224414521201566011674 0ustar sun00315steps SUBROUTINE setwrt(Wrt,Wrtidx) IMPLICIT NONE c set up format variable wrt for the routine fortbl. c the actual format used depends on the wrtidx index variable INTEGER Wrtidx,i CHARACTER*12 wrt(*),wrt0(10),wrt1(5),wrt2(4),wrt3(5),wrt4(4) data wrt0/ $ '(6X','''DATE'',11X','''FORECAST''','11X','''SE'',13X,','N', $ '(''FORECAST''','11X,''SER''',',12X,','))'/ data wrt1/'(2X,A3,','''-'',I4,2X,','N','(1X,F16.4,','1X,F16.4))'/ data wrt2/'(25X,','N','(A13,20X','))'/ data wrt3/'(2X,A3,','''-'',I4,5X,','N','(1X,F16.4,','14X,F16.4))'/ data wrt4/'(20X,','N','(5X,A13,10X','))'/ IF (Wrtidx.eq.0) THEN DO i = 1,10 wrt(i) = wrt0(i) END DO ELSE IF (Wrtidx.eq.1) THEN DO i = 1,5 wrt(i) = wrt1(i) END DO ELSE IF (Wrtidx.eq.2) THEN DO i = 1,4 wrt(i) = wrt2(i) END DO ELSE IF (Wrtidx.eq.3) THEN DO i = 1,5 wrt(i) = wrt3(i) END DO ELSE IF (Wrtidx.eq.4) THEN DO i = 1,4 wrt(i) = wrt4(i) END DO END IF RETURN END setxpt.f0000664006604000003110000000211514521201566011670 0ustar sun00315steps**==setxpt.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE setxpt(Nf2,Lsadj,Fctdrp) IMPLICIT NONE c----------------------------------------------------------------------- c Set up "pointers" variables for X-11 to tell where backcasts, c data, forecasts begin and end. c----------------------------------------------------------------------- INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'lzero.cmn' c----------------------------------------------------------------------- INTEGER Fctdrp,nspobs,Nf2 LOGICAL Lsadj c----------------------------------------------------------------------- c Set X-11 Pointer values c----------------------------------------------------------------------- nspobs=Nofpob-Nf2 Pos1bk=Nbcst2-Nbcst+Lsp Pos1ob=Nbcst2+Lsp Posfob=Nbcst2+nspobs+Lsp-1 Posffc=Nbcst2+nspobs+Nfcst+Lsp-1 IF((.not.Lsadj).and.Fctdrp.gt.0)Posffc=max(Posfob,Posffc-Fctdrp) c----------------------------------------------------------------------- RETURN END sfcast.i0000664006604000003110000000041614521201566011631 0ustar sun00315stepsC C... Variables in Common Block /savefcast/ ... integer NSFCAST,NSFCAST1 C.. C This variable is for test to be removed C integer Iseasse real*8 SQFSAVE real*8 SFCAST(KP) common /savefcast/ SFCAST,SQFSAVE,NSFCAST,Iseasse,NSFCAST1 sfmax.f0000664006604000003110000000275514521201566011471 0ustar sun00315stepsC Last change: BCM 19 May 1998 3:28 pm **==sfmax.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 INTEGER FUNCTION sfmax(Lterm,Lter,Ny) IMPLICIT NONE c----------------------------------------------------------------------- c Determines the longest seasonal filter length used in a given c seasonal adjustment. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- INTEGER i,Lterm,Lter,Ny LOGICAL lstabl DIMENSION Lter(PSP) c----------------------------------------------------------------------- c Intialize sfmax c----------------------------------------------------------------------- sfmax=Lterm IF(sfmax.eq.6.or.sfmax.eq.5)THEN sfmax=0 ELSE IF(sfmax.eq.7)THEN sfmax=-1 END IF lstabl=.true. c----------------------------------------------------------------------- c Loop through monthly seasonal factors to find maximum filter c length. c----------------------------------------------------------------------- DO i=2,Ny IF(Lter(i).eq.0.and.sfmax.lt.1)THEN sfmax=2 ELSE IF(Lter(i).gt.sfmax.and.Lter(i).lt.5)THEN sfmax=Lter(i) END IF lstabl=lstabl.AND.(Lter(i).eq.5) END DO IF(lstabl)sfmax=5 c----------------------------------------------------------------------- RETURN END sfmsr.f0000664006604000003110000001062114521201566011474 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 11:21 pm **==sfmsr.f processed by SPAG 4.03F at 08:51 on 15 Sep 1994 SUBROUTINE sfmsr(Sts,Stsi,Lfda,Llda,Lldaf,Lprt,Lsav) IMPLICIT NONE c ------------------------------------------------------------------ c This subroutine implements the MSR seasonal filter selection c option from X-11-ARIMA/88 c This implementation designed by BCM - January 1993 c Added Sts, Stsi to calling arguments - July 2005 c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'units.cmn' INCLUDE 'work2.cmn' INCLUDE 'x11opt.cmn' c ------------------------------------------------------------------ CHARACTER*3 filter DOUBLE PRECISION Sts,Stsi LOGICAL Lprt,Lsav INTEGER Lfda,Llda,Lldaf,llda1,i DIMENSION filter(3),Sts(PLEN),Stsi(PLEN) c ------------------------------------------------------------------ DATA filter/'3x3','3x5','3x9'/ c ------------------------------------------------------------------ c If MSR seasonal filter selection option is selected, calculate c a global MSR and try to select a seasonal filter length. c ------------------------------------------------------------------ IF(Lterm.eq.6)THEN IF(Lmsr.eq.6)THEN IF(Lprt)WRITE(Mt1,1010) c ------------------------------------------------------------------ c set llda1 to the end of the last whole year c ------------------------------------------------------------------ llda1=Llda-mod(Llda,Ny) i=1 DO WHILE (Lterm.eq.6) c ------------------------------------------------------------------ c If span to be tested is less than 5 years long, use a 3x5 c seasonal filter. c ------------------------------------------------------------------ IF((llda1-Lfda+1).lt.(5*Ny))THEN Lterm=2 IF(Lprt)WRITE(Mt1,1020) ELSE CALL vsfa(Stsi,Lfda,llda1,Ny) IF(Lsav)WRITE(Nform,1060)i,Ratis IF(Ratis.le.2.5D0)THEN Lterm=1 IF(Lprt)WRITE(Mt1,1030)i,Ratis,filter(Lterm) ELSE IF(Ratis.ge.6.5D0)THEN Lterm=3 IF(Lprt)WRITE(Mt1,1030)i,Ratis,filter(Lterm) ELSE IF(Ratis.ge.3.5D0.and.Ratis.le.5.5D0)THEN Lterm=2 IF(Lprt)WRITE(Mt1,1030)i,Ratis,filter(Lterm) L3x5=.true. ELSE c ------------------------------------------------------------------ c If Global MSR meets none of the criteria, drop a year from the c end of the series and try again. c ------------------------------------------------------------------ llda1=llda1-Ny IF(Lprt)WRITE(Mt1,1040)i,Ratis i=i+1 END IF END IF END DO DO i=1,Ny IF(Lter(i).eq.6)Lter(i)=Lterm IF(L3x5.and.(Lter(i).ne.0.and.Lter(i).ne.2))L3x5=.false. END DO c ------------------------------------------------------------------ c Save seasonal filter length decision c ------------------------------------------------------------------ IF(Lsav)WRITE(Nform,1050)filter(Lterm) ELSE c ------------------------------------------------------------------ c If this is a sliding spans run, reset seasonal filter length to c the selection made for the entire series. c ------------------------------------------------------------------ Lterm=Lmsr DO i=1,Ny IF(Lter(i).eq.6)Lter(i)=Lmsr END DO END IF END IF c ------------------------------------------------------------------ CALL vsfa(Stsi,Lfda,Llda,Ny) CALL vsfb(Sts,Stsi,Lfda,Lldaf,Ny) c ------------------------------------------------------------------ RETURN c ------------------------------------------------------------------ 1010 FORMAT('1 Final Seasonal Filter Selection via GLOBAL MSR',/) 1020 FORMAT(' *** Not enough data to continue, 3x5 seasonal filter ', & 'selected ***') 1030 FORMAT(' Pass No. ',i2,': Global MSR = ',f6.2,', ',a3, & ' seasonal filter selected.') 1040 FORMAT(' Pass No. ',i2,': Global MSR = ',f6.2) 1050 FORMAT('sfmsr: ',a3) 1060 FORMAT('autosf.msr',i2.2,': ',f6.2) c ------------------------------------------------------------------ END sform.i0000664006604000003110000000021414521201566011470 0ustar sun00315stepsC C... Variables in Common Block /sform/ ... integer NZ,NYER,NPER,NFREQ,REVERSE common /sform/ NZ,NYER,NPER,NFREQ,REVERSE sftest.f0000664006604000003110000002061114521201566011652 0ustar sun00315steps SUBROUTINE sftest(Xpxinv,Regidx,Lprsft,Lsvsft,Lsvlog,Lxreg) IMPLICIT NONE c----------------------------------------------------------------------- c generate model-based f-tests for seasonality from chi square c statistics of seasonal regressors; also generate model-based c f-tests for combinations of seasonal regression groups, c such as change of regime regressors and user defined seasonal c regressors c (BCM July 2007) c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'mdldg.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER grpstr*(PGRPCR) DOUBLE PRECISION Xpxinv,chi2vl,pv LOGICAL Lxreg,Lprsft,Lsvsft,Lsvlog,lprthd,lprund INTEGER baselt,begcol,endcol,igrp,gsearg,gusea,Regidx,rgi2,rtype, & k,df,df1,df2,iusr,utype,info,tbwdth,nchr,icol,ud1st,i, & udlast DIMENSION gsearg(0:2),gusea(0:2),Regidx(PB),rgi2(PB),Xpxinv(PXPX) c----------------------------------------------------------------------- DOUBLE PRECISION fvalue EXTERNAL fvalue c----------------------------------------------------------------------- lprthd=T lprund=F tbwdth=71 c----------------------------------------------------------------------- c Compute number of regressors estimated c----------------------------------------------------------------------- k=Nb IF(Iregfx.eq.2)THEN DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 DO icol=begcol,endcol IF(regidx(icol).eq.NOTSET)k=k-1 END DO END DO END IF df2=Nspobs-Mxdflg-k c----------------------------------------------------------------------- c Print out f-tests for individual groups of seasonal regressors c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) rtype=Rgvrtp(begcol) IF(rtype.eq.PRRTTS.or.rtype.eq.PRRTSE.or.rtype.eq.PRATTS.or. & rtype.eq.PRATSE.or.rtype.eq.PRGTTS.or.rtype.eq.PRGTSE)THEN IF(Lprsft)lprund=T endcol=Grp(igrp)-1 CALL getstr(Grpttl,Grpptr,Ngrp,igrp,grpstr,nchr) IF(Lfatal)RETURN info=0 baselt=regidx(begcol) df=endcol-begcol+1 IF(Iregfx.eq.2)THEN IF(baselt.eq.NOTSET)df=df-1 DO icol=begcol+1,endcol IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE baselt=regidx(icol) END IF END DO END IF IF(baselt.ne.NOTSET) & CALL chitst(Xpxinv,begcol,endcol,chi2vl,pv,regidx,T,info) df1=df c df2=Nspobs-Mxdflg-df1 Sfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Sfpv=fvalue(Sfval,df1,df2) CALL prtft(Lprsft,lprthd,tbwdth,Lsvsft,Lsvlog,baselt,grpstr, & nchr,'Seasonal',info,df1,df2,Sfval,Sfpv) END IF END DO c----------------------------------------------------------------------- c Create pointer dictionaries for different tests we wish to c perform c----------------------------------------------------------------------- DO icol=0,2 gsearg(icol)=0 gusea(icol)=0 END DO ud1st=NOTSET udlast=NOTSET iusr=1 c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 rtype=Rgvrtp(begcol) c----------------------------------------------------------------------- IF(rtype.eq.PRGTUD.or.rtype.eq.PRGTUS.or.rtype.eq.PRGUTD.or. & rtype.eq.PRGTUH.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY.or.rtype.eq.PRGUAO.or.rtype.eq.PRGULS.or. & rtype.eq.PRGUSO.or.rtype.eq.PRGUCN.or.rtype.eq.PRGUCY.or. & rtype.eq.PRGUH2.or.rtype.eq.PRGUH3.or.rtype.eq.PRGUH4.or. & rtype.eq.PRGUH5)THEN IF(ud1st.eq.NOTSET)ud1st=begcol END IF IF(rtype.eq.PRGTUS)THEN gusea(0)=gusea(0)+1 IF(gusea(0).eq.1)gusea(1)=begcol gusea(2)=endcol c----------------------------------------------------------------------- ELSE IF(rtype.eq.PRRTTS.or.rtype.eq.PRRTSE.or. & rtype.eq.PRATTS.or.rtype.eq.PRATSE.or. & rtype.eq.PRGTTS.or.rtype.eq.PRGTSE)THEN gsearg(0)=gsearg(0)+1 IF(gsearg(0).eq.1)gsearg(1)=begcol gsearg(2)=endcol END IF END DO c----------------------------------------------------------------------- c Generate combined Chi-Square test for seasonal regressors c----------------------------------------------------------------------- IF(gsearg(0).ge.2)THEN CALL setint(NOTSET,Nb,rgi2) df=gsearg(2)-gsearg(1)+1 baselt=regidx(gsearg(1)) info=0 DO icol=gsearg(1),gsearg(2) rtype=Rgvrtp(icol) IF(rtype.eq.PRRTTS.or.rtype.eq.PRRTSE.or.rtype.eq.PRATTS.or. & rtype.eq.PRATSE.or.rtype.eq.PRGTTS.or.rtype.eq.PRGTSE)THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF END DO CALL chitst(Xpxinv,gsearg(1),gsearg(2),chi2vl,pv,rgi2,F,info) df1=df c df2=Nspobs-Mxdflg-df1 Sfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Sfpv=fvalue(Sfval,df1,df2) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=9 grpstr(1:nchr)='Combined ' rtype=Rgvrtp(gsearg(1)) IF(rtype.eq.PRRTTS.or.rtype.eq.PRATTS)THEN grpstr(nchr+1:nchr+14)='Trigonometric ' nchr=nchr+14 END IF grpstr(nchr+1:nchr+19)='Seasonal Regressors' nchr=nchr+19 CALL prtft(Lprsft,lprthd,tbwdth,Lsvsft,Lsvlog,baselt,grpstr, & nchr,'Seasonal',info,df1,df2,Sfval,Sfpv) END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for user defined seasonal c regressors if there are more than one type of user defined c regressor defined. c----------------------------------------------------------------------- IF(gusea(0).gt.0.and.(gusea(2)-gusea(1)).gt.0)THEN CALL setint(NOTSET,Nb,rgi2) df=gusea(2)-gusea(1)+1 baselt=regidx(gusea(1)) DO icol=gusea(1),gusea(2) iusr=icol-ud1st+1 IF(Lxreg)THEN utype=Usxtyp(iusr) ELSE utype=Usrtyp(iusr) END IF IF(utype.eq.PRGTUS)THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF END DO CALL chitst(Xpxinv,gusea(1),gusea(2),chi2vl,pv,rgi2, & gusea(0).lt.2,info) df1=df c df2=Nspobs-Mxdflg-df1 Usfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Usfpv=fvalue(Usfval,df1,df2) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=32 grpstr(1:nchr)='User-defined Seasonal Regressors' CALL prtft(Lprsft,lprthd,tbwdth,Lsvsft,Lsvlog,baselt,grpstr, & nchr,'Seasonal',info,df1,df2,Usfval,Usfpv) END IF c----------------------------------------------------------------------- c Print the tail line c----------------------------------------------------------------------- IF(lprund)WRITE(Mt1,1020)('-',i=1,tbwdth) IF(Lsvlog)WRITE(Ng,1020)' ' c----------------------------------------------------------------------- 1020 FORMAT(' ',120(a)) RETURN ENDshlsrt.f0000664006604000003110000000652214521201566011666 0ustar sun00315steps**==shlsrt.f processed by SPAG 4.03F at 17:22 on 11 Mar 1994 SUBROUTINE shlsrt(Nr,Vecx) c----------------------------------------------------------------------- c Returns sorted Vecx. Uses a shell sort. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c abss d Work pa long nr used vector to hold the sorted absolute c values c bot i Local index to the element at the bottom of the gap, i.e. c index with the lower value. c gap i Local distance between the records that are being compared. c gap starts out at half the number of records and is halved c until it reaches 1. c i i Local do loop c median d Output median of the absolute differences c nabss i Work PARAMETER for the length of abss c nr i Input row dimension of s c nsrt i Local number of comparisons to make on one pass through the c records c pa i Local PARAMETER for the maximum number of innovation errors c s d Input nr long vector to be sorted. c tmp d Local temporary scalar c top i Local index to the element at the top of the gap, i.e. c index with the higher value and gap higher than bot. c----------------------------------------------------------------------- c Type the variables c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ INTEGER bot,gap,Nr,nsrt,top DOUBLE PRECISION Vecx,tmp DIMENSION Vecx(*) c----------------------------------------------------------------------- c Use a Shell sort the nr records of Vecx. Compares records half c the number of records apart, then keep halving the gap size until c records next to eachother are compared. c----------------------------------------------------------------------- gap=Nr DO WHILE (.true.) gap=gap/2 IF(gap.gt.0)THEN nsrt=Nr-gap c----------------------------------------------------------------------- c Compare and sort nsrt records that are gap records apart. c----------------------------------------------------------------------- bot=0 DO WHILE (.true.) bot=bot+1 IF(bot.le.nsrt)THEN DO WHILE (.true.) c ------------------------------------------------------------------ top=bot+gap c----------------------------------------------------------------------- c See if Vecx(top) and Vecx(bot) need to be exchanged and switch c them if they do. c----------------------------------------------------------------------- IF(Vecx(bot).le.Vecx(top))GO TO 10 tmp=Vecx(top) Vecx(top)=Vecx(bot) Vecx(bot)=tmp c ------------------------------------------------------------------ IF(bot.le.gap)GO TO 10 bot=bot-gap END DO END IF GO TO 20 10 CONTINUE END DO END IF c ------------------------------------------------------------------ bot=Nr/2 c ------------------------------------------------------------------ RETURN 20 CONTINUE END DO END shrink.f0000664006604000003110000000631314521201566011643 0ustar sun00315stepsC Last change: BCM 7 May 2003 2:05 pm SUBROUTINE shrink(Stsi,Sts,Mtype,Ishrnk,Muladd,Ny) IMPLICIT NONE C----------------------------------------------------------------------- c Generate seasonal factors based on the global shrinkage method c given in the paper "Shrinkage Est. of Time Series Seasonal Factors c and their Effect on Forecasting Accuracy", c Miller & Williams (2003) C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11ptr.cmn' C----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE,THREE,NINE,TEN PARAMETER (ZERO=0D0,ONE=1D0,THREE=3D0,NINE=9D0,TEN=10D0) C----------------------------------------------------------------------- DOUBLE PRECISION Stsi,Sts,varsts,wtx11,dn,varmu,dlx11,v, & sssf,den INTEGER Ishrnk,Mtype,i,j,lx11,Ny,i2,Muladd DIMENSION Stsi(PLEN),Sts(PLEN),varsts(PSP),lx11(5) C----------------------------------------------------------------------- DATA lx11 /1,3,5,9,15/ C----------------------------------------------------------------------- c initialize variables C----------------------------------------------------------------------- CALL setdp(ZERO,PSP,varsts) wtx11 = ZERO varmu = ZERO C----------------------------------------------------------------------- c compute variance of SI ratios C----------------------------------------------------------------------- IF (Ishrnk.eq.1) THEN DO i=Pos1ob,Pos1ob+Ny-1 dn=ZERO i2=MOD(i,Ny) IF(i2.eq.0)i2=Ny DO j=i,Posfob,Ny dn=dn+ONE sssf=(Stsi(j)-Sts(j))*(Stsi(j)-Sts(j)) varsts(i2)=varsts(i2)+sssf END DO varsts(i2)=varsts(i2)/(dn-ONE) varmu=varmu+varsts(i2) END DO varmu=varmu/DBLE(Ny) ELSE DO i=Pos1ob,Posfob varmu=(Stsi(i)-Sts(i))*(Stsi(i)-Sts(i))+varmu END DO varmu=varmu/DBLE(Posfob-Pos1ob+1-Ny) END IF C----------------------------------------------------------------------- c compute weights based on the seasonal filter used C----------------------------------------------------------------------- IF (Mtype.eq.7) THEN wtx11=ONE/THREE ELSE dlx11=DBLE(lx11(Mtype)) den=(dlx11*THREE)*(dlx11*THREE) wtx11=TEN/den DO j=1,lx11(Mtype)-2 wtx11=wtx11+NINE/den END DO END IF v=wtx11*varmu C----------------------------------------------------------------------- C For global shrinkage estimator, compute a(k) C----------------------------------------------------------------------- IF (Ishrnk.eq.1) THEN CALL glbshk(Sts,V,Ny,Muladd) ELSE C----------------------------------------------------------------------- C code for local shrinkage estimator C----------------------------------------------------------------------- CALL locshk(Sts,V,Ny) END IF C----------------------------------------------------------------------- RETURN C----------------------------------------------------------------------- END sicp2.f0000664006604000003110000000542214521201567011366 0ustar sun00315stepsC Last change: BCM 19 Jun 2002 5:56 pm **==sicp2.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE sicp2(Cyy,L1,N1,N2,Coef,Moar,Osd,Oaic) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION a,aic,am,b,Coef,d,d2,Oaic,Osd DOUBLE PRECISION cst01,cst1,cst2,Cyy,sd,sdr,se INTEGER i,im,l,L1,lm,m,Moar,mp1,n,N1,N2 C*** End of declarations inserted by SPAG C COMMON SUBROUTINE C THIS SUBROUTINE FITS AUTOREGRESSIVE MODELS OF SUCCESSIVELY C INCREASING ORDER UP TO L(=L1-1). C INPUT: C CYY(I),I=0,L1 AUTOCOVARIANCE SEQUENCE C L1: L1=L+1, L IS THE UPPER LIMIT OF THE MODEL ORDER C N LENGTH OF ORIGINAL DATA C OUT PUT: C COEF : AR-COEFFICIENTS C MOAR: ORDER OF AR C OSD: INNOVATION VARIANCE C OAIC: VALUE OF AIC DIMENSION Cyy(L1),Coef(L1) DIMENSION a(101),b(101) DOUBLE PRECISION an c CHARACTER*1 f(41),ax,bl,sta,ffff c DATA(f(i),i=1,41)/41*' '/ c DATA ax,bl,sta/' ',' ','*'/ n=N2-N1+1 c cst0=0.0D-00 cst1=1.0D-00 cst2=2.0D-00 c cst20=20.0D-00 c cst05=0.05D-00 cst01=0.00001D-00 l=L1-1 sd=Cyy(1) an=dble(n) Oaic=an*log(sd) Osd=sd Moar=0 C INITIAL CONDITION PRINTOUT c ran=cst1/sqrt(an) c scalh=cst20 c jj0=scalh+cst1 c ian=scalh*(ran+cst05) c ian1=ian+jj0 c ian2=2*ian+jj0 c lan1=-ian+jj0 c lan2=-2*ian+jj0 c f(jj0)=ax c f(ian1)=ax c f(ian2)=ax c f(lan1)=ax c f(lan2)=ax se=Cyy(2) C ITERATION START DO m=1,l sdr=sd/Cyy(1) IF(sdr.lt.cst01)GO TO 10 mp1=m+1 d=se/sd a(m)=d d2=d*d sd=(cst1-d2)*sd am=m aic=an*log(sd)+cst2*am IF(m.ne.1)THEN C A(I) COMPUTATION lm=m-1 DO i=1,lm a(i)=a(i)-d*b(i) END DO END IF DO i=1,m im=mp1-i b(i)=a(im) END DO C M,SD,AIC PRINTOUT c IF(a(m).lt.cst0)THEN c nfc=scalh*(a(m)-cst05) c ELSE c nfc=scalh*(a(m)+cst05) c END IF c anfc=nfc c jj=int(anfc+scalh+cst1) c ffff=f(jj) c f(jj)=sta c f(jj)=ffff C C ----- 5/15/80 ----- C IF(Oaic.ge.aic)THEN Oaic=aic Osd=sd Moar=m END IF IF(m.ne.l)THEN se=Cyy(m+2) DO i=1,m se=se-b(i)*Cyy(i+1) END DO END IF END DO C ----- 5/15/80 ----- 10 Oaic=aic Osd=sd Moar=l DO i=1,l Coef(i)=-a(i) END DO c f(jj0)=bl c f(ian1)=bl c f(ian2)=bl c f(lan1)=bl c f(lan2)=bl RETURN END si.f0000664006604000003110000000776514521201567010775 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 11:46 am **==si.f processed by SPAG 4.03F at 12:06 on 12 Jul 1994 SUBROUTINE si(Ksect,Kfda,Klda,Nyr,Iforc,Nbcst,Kersa1,Ksdev1,Lfd1, & Lld1,Kfulsm,Kfdax,Kldax) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE CALCULATES THE SEASONALS FROM THE SI ESTIMATES C --- FOR PART B. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'xtrm.cmn' INCLUDE 'x11tbl.i' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO LOGICAL F PARAMETER(F=.false.,ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- INTEGER Iforc,iftny,k,Nbcst,Kfda,Klda,Ksect,l,lfd,Lfd1,lld,Lld1, & llda,Kersa1,Ksdev1,Nyr,iv,l1,l2,i,Kfulsm,Kfdax,Kldax DOUBLE PRECISION Temp,dvec DIMENSION Temp(PLEN),dvec(1) c ------------------------------------------------------------------ COMMON /work / Temp c ------------------------------------------------------------------ dvec(1)=ZERO lfd=Lfd1+(Nyr/2) lld=Lld1-(Nyr/2) l=Lld1-Lfd1+1 llda=Klda IF(Iforc.ne.0.and.Ksect.eq.1)llda=Klda-Iforc c ------------------------------------------------------------------ IF(Kfulsm.lt.2)THEN IF(Ksect.eq.2)CALL vsfa(Stsi,Kfda,llda,Nyr) CALL vsfb(Sts,Stsi,Kfda,Klda,Nyr) END IF c ------------------------------------------------------------------ k=Ksect*5-2 iftny=15*Nyr IF(Ksect.eq.2)THEN IF(Prttab(LX11B8))CALL table(Stsi,Lfd1,Lld1,k,1,1,dvec,LX11B8) IF(.not.Lfatal.and.Savtab(LX11B8)) & CALL punch(Stsi,Lfd1,Lld1,LX11B8,F,F) ELSE IF(Iforc.eq.0)THEN IF(Prttab(LX11B3))CALL table(Stsi,lfd,lld,k,1,1,dvec,LX11B3) IF(.not.Lfatal.and.Savtab(LX11B3)) & CALL punch(Stsi,lfd,lld,LX11B3,F,F) ELSE IF(l.le.iftny.and.Nbcst.gt.0)THEN IF(Prttab(LX11B3))CALL table(Stsi,Lfd1,Lld1,k,1,1,dvec,LX11B3) IF(.not.Lfatal.and.Savtab(LX11B3)) & CALL punch(Stsi,Lfd1,Lld1,LX11B3,F,F) ELSE IF(Prttab(LX11B3))CALL table(Stsi,lfd,Lld1,k,1,1,dvec,LX11B3) IF(.not.Lfatal.and.Savtab(LX11B3)) & CALL punch(Stsi,lfd,Lld1,LX11B3,F,F) END IF IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Kfulsm.eq.2)THEN CALL copy(Stsi,Klda,1,Sti) ELSE IF(Psuadd)THEN DO i=Kfda,Klda Sti(i)=Stsi(i)-Sts(i)+ONE END DO ELSE CALL divsub(Sti,Stsi,Sts,Kfda,Klda) END IF END IF c ------------------------------------------------------------------ IF(Ksect.eq.1.and.Ksdev.lt.4)THEN CALL vtest(Sti,iv,Kfdax,Kldax) CALL entsch(Kersa1,Ksdev1,Kersa,Ksdev,iv) END IF CALL xtrm(Sti,Kfda,Klda,Kfdax,Kldax) CALL replac(Stsi,Temp,Stwt,Kfda,Klda,Nyr) k=k+1 IF(Ksect.eq.1.and.Prttab(LX11B4))THEN l1=lfd l2=Lld1 IF(Iforc.eq.0)THEN l2=lld ELSE IF(l.le.iftny.and.Nbcst.gt.0)THEN l1=Lfd1 END IF IF(Ksdev.eq.0)THEN CALL table(Temp,l1,l2,k,1,4,Stdev,LX11B4) ELSE CALL table(Temp,l1,l2,k,1,5,dvec,LX11B4) END IF ELSE IF(Prttab(LX11B9))THEN IF(Ksdev.eq.0)THEN CALL table(Temp,Lfd1,Lld1,k,1,4,Stdev,LX11B9) ELSE CALL table(Temp,Lfd1,Lld1,k,1,5,dvec,LX11B9) END IF END IF c ------------------------------------------------------------------ IF(.not.Lfatal.and.Kfulsm.lt.2)CALL vsfb(Sts,Stsi,Kfda,Klda,Nyr) c ------------------------------------------------------------------ RETURN END sig1.i0000664006604000003110000000027214521201567011212 0ustar sun00315stepsC C... Variables in Common Block /sig1/ ... integer NOVER,IONEOUT,ITABLE,NREESTIMATED,PSIEINIC,PSIEFIN common /sig1/ NOVER,IONEOUT,ITABLE,NREESTIMATED,PSIEINIC,PSIEFIN sigex.f0000664006604000003110000047065514521201567011503 0ustar sun00315stepsC Last change: change the endloop for kons in .tbs to lfor instead C of lfor/2 to make consistent with main output C previous change: REG 05 Jun 2006, 09 May 2006, 24 Apr 2006 C Previous change: REG 10 Mar 2006, 17 Feb 2006, 20 Oct 2005, 30 Aug 2005, c and 17 Nov 2005 C C C THIS SUBROUTINE CALCULATES THE TREND,SEASONAL AND IRREGULAR C COMPONENT FOR A SERIES Z,USING THE ARIMA MODEL C ALREADY CALCULATED. C C C FIRST VERSION OF SIGEX-JAN 1983 REVISED 1990 (GABRIELE) C REVISED 1990-1994 (GIANLUCA) REVISED 1994-1996 (GIANLUCA,VICTOR,AGUSTIN) C C INPUT PARAMETERS C C Z : THE SERIES + FORECAST C BZ : REVERSED SERIES AND BACKCAST C OZ : ORIGINAL SERIES C A : BACK-RESIDUALS (USED TO COMPUTE PSEUDO-INNOVATIONS) C AA : RESIDUALS C LAMD : 0 TRANSFORMATION OF DATA, 1 NO TRANSFORMATION C P : THE DIMENSION OF PHI -1 C D : DELTA C Q : THE DIMENSION OF THETA -1 C BP : THE DIMENSION OF BPHI C BQ : THE DIMENSION OF BTHETA C MQ : FREQUENCY C PHI : NON-SEASONAL AR MODEL (true signs) C BPHI : SEASONAL AR MODEL (true signs) C THETA : NON-SEASONAL MA MODEL (true signs) C BTHETA : SEASONAL MA MODEL (true signs) C ZAF : MEAN CORRECTION FORECAST (see SUBROUTINE FCAST) C ZAB : MEAN CORRECTION BACKCAST (see SUBROUTINE FCAST) C HS : CONTROL THE SPECTRA GRAPHICS C IMZ : IMAGINARY PART OF THE ROOTS OF AR NON-SEASONAL MODEL C REZ : REAL PART OF THE ROOTS OF AR NON-SEASONAL MODEL C MODUL : MODULUS OF THE ROOTS OF AR NON-SEASONAL MODEL C AR : PERIOD OF THE ROOTS OF AR NON-SEASONAL MODEL C LFOR : DIMENSION OF THE FORECAST AND BACKCAST C NOSERIE : 1 ONLY THEORETICAL DECOMPOSITION, NO SERIE INPUTED,0 OTHERWISE C INIT : 0 ESTIMATION PERFORMED IN ANALTS,1 ESTIMATION WITH INITIAL C VALUES FROM THE USER, 2 NO ESTIMATION C IMEAN : 1 MEAN CORRECTIOIN PERFORMED, 0 NO MEAN CORRECTION C TH : SAME AS FOR THETA (OUTPUT) C BTH : SAME AS FOR BTHETA C C C Modified by REG on 30 Aug 2005 to add nFixed to SIGEX parameter list subroutine SIGEX(z,bz,oz,a,aa,forbias,lamd,p,d,q,bp,bd,bq,mq, $ phi,bphi,theta,btheta,zaf,zab,imz,rez,modul,ar, c $ lfor,noserie,init,imean,th,bth,smtr,status, $ lfor,fhi,noserie,init,imean,ph,bph,th,bth,status, $ hpcycle,rogtable,hplan,HPper,maxSpect, $ type,alpha,acfe,posbphi,printphtrf, $ tabtables,IOUT,Ndevice, $ printBack,back,sr,SQSTAT,SDF,SSE,mAuto, $ n_1,n0,tvalRUNS,Qstat,DF,Pstat1,spstat1, $ wnormtes,wsk,skewne,test1,wkk,rkurt,test,r,SEa, $ Resid,flagTstu,it,iper,iyear, $ rmean,rstd,DW,KEN,RTVAL,SumSres,F,Nyer1,Nper1, $ Pstar_seats,Qstar_seats,InputModel,niter, $ mattitle,Lgraf,nFixed, $ IsCloseToTD,fixParam,x, $ ImeanOut,Wdif,WdifCen,nwDif,WmDifXL,VdifXL, $ QstatXL,rXL,seRxl,partACF,sePartACF,model, $ PicosXL,tstmean,Wm,seMean,nx,Cmatrix, $ sePHI,seTH,seBPHI,seBTH, $ MArez,MAimz,MAmodul,MAar,MApr,pr, $ OutNA,StochTD,ItnSearch,IfnSearch,nxSearch,Esearch, $ FIsearch,xSearch,varwnc,numser,remMeanMCS, $ *,*) C C.. Implicits .. implicit none INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'notset.prm' include 'dimensions.i' include 'component.i' include 'stream.i' include 'bench.i' include 'force.cmn' INCLUDE 'seatop.cmn' include 'date.i' include 'transcad.i' include 'serrlev.i' C C.. Parameters .. integer nfl, mc, pk, n10, n12, max_wind, mx, mw, n60 PARAMETER(mx=300,mw=1200,nfl=POBS*2,mc=1000,n60=60,pk=550, $ n10=10,n12=12,max_wind=5) c INPUT PARAMETERS OUTSEATS logical printBack integer IOUT,mAuto,DF,SDF,numSer real*8 resid(MPKp),back(MpKp),Qstat,Pstat1,spstat1 real*8 sr(50),SQstat,SSE(50),tvalRUNS integer n_1,n0 real*8 wnormtes,wsk,skewne,test1,wkk,rkurt,test,r(50),SEa(50) integer flagTstu,NDEVICE,IPER,IYEAR,it,Nper1,nYer1 integer Pstar_seats,Qstar_seats real*8 Rmean,Rstd,DW,KEN,RTVAL,F,SumSres,x(n10) c INPUT OutPara.m integer niter character Mattitle*180 c INPUT/OUTPUT PARAMETERS integer InputModel c OUTPUT PARAMETERS logical IsCloseToTD integer fixParam(n10) c c INPUT/OUTPUT PARAMETER OutPart2 c INPUT integer ImeanOut,nwDif,model real*8 Wdif(*),WdifCen(*),WmDifXL,VdifXL real*8 QstatXL,rXL(5*n10),seRxl(5*n10),partACF(5*n10),sePartACF character PicosXL(7)*2 integer tstmean,nx real*8 Wm,seMean,Cmatrix(n10,n10), $ sePHI(n10),seTH(n10),seBPHI(n10),seBTH(n10), $ MArez(5*n12+n12/3),MAimz(5*n12+n12/3),MAmodul(5*n12+n12/3), $ MAar(5*n12+n12/3),MApr(5*n12+n12/3), $ pr(5*n12+n12/3) C C INPUT PARAMETER OutSearch integer ItnSearch,IfnSearch,nxSearch,Esearch(n10) real*8 FIsearch,xSearch(n10) C C.. Formal Arguments .. c integer lamd,p,d,q,bp,bd,bq,mq,lfor,noserie,init,imean,smtr, integer lamd,p,d,q,bp,bd,bq,mq,lfor,fhi,noserie,init,imean, $ hpcycle,rogtable,type,acfe,posbphi,printphtrf, $ outNA,stochTD character status LOGICAL Lgraf real*8 z(mpkp),bz(mpkp+kp),oz(mpkp),a(mpkp),forbias(kp),phi(4), $ bphi(13),theta(4),btheta(25),zaf,zab,imz(64),rez(64), $ modul(64),ar(64),th(*),bth(*),aa(*),hplan, $ HPper,alpha,maxSpect real*8 fosa(mpkp) logical remMeanMCS character tabtables*100 C.. Added by REG on 30 Aug 2005 to create input/output variable nFixed integer nFixed C C.. Local Scalars .. logical root0c,rootPIc,rootPIs,IsUgly integer dplusd,i,ilag,ilen,ireg,itf,j,j0,jf,jl,k,lf,lon,mq2, $ mqo,n1,n2,nbphi,nbth,ncycth,nelen,nfilt,nfor,nlen,nounit, $ nphi,ntcclass,ntfclass,nth,nthclass,nthnc,nthnp,lfor2, $ ntitle,nvn,nxout,nye,nz1,nzero,overmaxbias,msecross,ifail * integer nus,smtr,pgHPSGfilt,RST integer nus,smtr,pgHPSGfilt,RST,nval,ninicio,lfor1 character*7 COdate real*8 tmp2 real*8 maxValS,maxValS1,maxValS2 cc Local variables for Business Cycle intermediate steps integer HPpar real*8 chcycs(MAxCompDim),PHItots(MaxCompDim),PHItots2(MaxCompDim) integer nchcycs,nPHItots,nPHItots2 real*8 VfcBc,VfcM,VrcM,VrcBc,PSIEm(0:2*pk+1),PSIEbc(0:2*pk+1),VfBc integer WithoutVf real*8 seM(pk*2+2),seBc(pk*2+2) cc real*8 ph(3),bph(3) cc Models of Business Cycle and Long Term Trend real*8 PHIm(MaxCompDim),THETm(MaxCompDim),Vm, $ PHIbc(MaxCompDim),THETbc(MaxCompDim),Vbc integer nTHETm,nPHIm,nTHETbc,nPHIbc character ModelStrCt*(MaxStrLength),ModelStrMt*(maxStrLength), & caption0*(60) cc c New Spectrum Local cc integer wFilePic cc c Asymmetric Filters local cc c o_a_fil, !filter of t-m when the serie Xt is of -Inf:t c hp, !Length of Cp c hseas, !Length of Cs c mw_mq !present phased till w=PI/floor((MQ+1)/2) integer o_a_fil,hp,nPHInp,hseas,nPHIns,mw_mq cc c cc* integer pstar,nzlen,nstar,ifault,ncount,iret integer nyer2,nper2 integer Lierr character Lerrext*180 character filename*180 character sEnd*3 c character comp*32 character buff*80,buff1*80,buff2*80,fname*30,subtitle*50, $ cad6*50,cad7*50 real*8 cmu,fee,hcross,kc,kcross,km,rrj,sabsdif1,sabsdif2,sfull1, $ sfull2,sfull3,stci,stpc,stpi,stps,stsc,stsi,sum,sum1,sum2, $ sum3,varerr,varwna,varwnc,varwnp,varwns,vwnnc,vwnnp,vz, $ wvara,zsum,sum0,sum00,kons,tmpmq,xlimit,Vcomp,varwnt,varwca real*8 pi integer realTime C added varwnt, varwca; Feb, 2003 DEKM real*8 bseps,bsepc,bsepi,bsesc,bsesi,bseci C C.. Local Arrays .. real*8 ARnSA(50) integer nARnSA,ivec(1) real*8 cc(32),ceff(mpkp),cs(32),ct(32),cycle(mpkp), $ cycles(mpkp),feeadj(0:12),feecyc(0:12),feetre(0:12), $ forsbias(kp),fortbias(kp),fsa(-kp:kp),ftr(-kp:kp),g(3), $ h(4,5),hpcyc(mpkp),hpregc(mpkp),hpregt(mpkp),hpth(3), $ hptmp(mpkp),hptrtmp(mpkp),hptrend(mpkp),ir(mpkp), $ osa(mpkp),ot(mpkp),pread(mpkp),psiea(nfl),psiec(nfl), $ psiecs(nfl),tmpBC(mpkp),tmpTrend(mpkp) real*8 psiep(nfl),psieps(nfl),psies(nfl),psiess(nfl), $ psitot(nfl),psiue(nfl),rceadj(0:12),rcetre(0:12), $ sa(mpkp),sc(mpkp),scs(mpkp),sec(mpkp),ses(mpkp), $ sesa(mpkp),set(mpkp), $ sigat1(0:kp),sigatac(kp),sigataf(kp),sigatmq(2), $ sigpt1(0:kp),sigptac(kp),sigptaf(kp),sigptmq(2),sigxtmq(2), $ teeadj(0:12),teetre(0:12),thnc(32),thnp(32),tmp(mpkp), $ totcyc(mpkp),trend(mpkp),trends(mpkp),us(50),vn(80), $ rceDummy(0:12),rceCyc(0:12),compHP(mpkp),RegHP(mpkp), $ eTrend(mpkp),extSA(MPKP),extZ(MPKP) c $ ,eCycle(mp+kp),eSC(mp+kp),eIR(MP+KP) real*8 DRTsa(Mpkp),DRTtre(Mpkp),sumsa,sumtre integer sp,sy, nzsave real*8 ba(mpkp),scmean(mpkp) real*8 tmpUs(50),toterr,tmptoterr integer ntmpUs,NAfijado c character strTest*(MaxStrLength) c Revision errors DECFB real*8 HFp(n60-1),HFsa(n60-1),Hdummy(n60-1),Vrp,Vrsa,Vrdummy integer lHp0,lHFsa,lDummy real*8 Ep(0:(n60-1)),Edummy(0:(n60-1)),Hs(n60-1),Vrs, $ Es(0:(n60-1)),Hc(n60-1),Vrc,Ec(0:(n60-1)),Esa(0:(n60-1)), $ Hu(n60-1),Eu(0:(n60-1)),Vru integer lEp,lEdummy,lHs,lEs,lHc,lEc,lEsa,lHu,lEu c Theoretical spectra c integer nden real*8 den(maxCompDim) character cname*20 cc c cc c Arrays related to the Asymmetric Trend filter c !weights of trend asymmetric filter real*8 alphap(0:2*mx) c !phase and transfer of trend Asymetric filter at different w values real*8 transfp(0:mw),phasep(0:mw),w(0:mw),phaseDp(0:mw), $ FdelayP(0:mw),FdelaySA(0:mw) !Ignored part of asymmetric filter real*8 cp(0:mx) real*8 PHInp(80) c Arrays related with Asymmetric seasonal filter c !weights of SEAS asymmetric filter real*8 alphas(0:2*mx) c ! phase and transfer of Seasonal Asymmetric filter at different w values real*8 transfs(0:mw),phases(0:mw),phaseDs(0:mw) c !Ignored part of asymmetric filter real*8 cSEAS(0:mx) real*8 PHIns(80),PHIs(80) real*8 tmpdelay(0:mw) integer nalen1,nalen2,nalen3,nPHIs c ------------------- real*8 ctmp(8),dvec(1) integer nctmp cc c cc character* 12 cmonth(12),period(12) C added by DEKM Feb 6, 2003 real*8 pscyc(32), thtra(32) integer npscyc, nthtra C added by DEKM Feb 20, 2003 real*8 chpsi(32), thcya(32) integer nchpsi, nthcya C added by REG on Aug 30, 2005 to create local variables c for alternative under/over diagnostics C modified by REG on May 9, 2006 to itemize number of model ARIMA c parameters integer ds, dt, nParam(4), nDiff(2) C C.. External Functions .. character getTmcs integer ISTRLEN,ResidualSeasTest external ISTRLEN,ResidualSeasTest,getTmcs character*36 getWindN external getWindN C C.. External Calls .. external APPROXIMATE, AUTOCOMP, BFAC, CONJ, CONV, CROSS, DECFB, $ DETCOMP, ESTBUR, F1RST, HANDLE_POINT, HPOUTPUT, HPPARAM, $ HPTRCOMP, MAK1, MPBBJ, OUTTABLE, PINNOV, RATESGROWTH, $ SECOND, SERROR, SERRORL, SPECTRUM, TABLE2, USRENTRY, $ TruncaSpectra C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C.. Intrinsic Functions .. intrinsic ABS, DBLE, LOG, MAX, SQRT include 'acfst.i' * include 'cxfinal.i' C.. Added by REG on 30 Sep 2005 for new include file include 'cmpflts.i' include 'dirs.i' include 'estb.i' * include 'func.i' include 'func2.i' * include 'func3.i' include 'func4.i' include 'func5.i' include 'hdflag.i' include 'hspect.i' include 'models.i' include 'pinno.i' include 'preadtr.i' include 'sfcast.i' include 'sesfcast.i' include 'sform.i' include 'sig.i' include 'sig1.i' include 'spe.i' * include 'stream.i' * include 'test.i' * include 'bartlett.i' include 'cross.i' include 'titl.i' include 'buffers.i' include 'peaks.i' include 'spectra.i' include 'strmodel.i' include 'seastest.i' include 'rtestm.i' * include 'indhtml.i' C.. Added by REG on 30 Aug 2005 for new include file include 'across.i' C LINES OF CODE ADDED FOR X-13A-S : 3 INCLUDE 'hiddn.cmn' include 'error.cmn' include 'units.cmn' C END OF CODE BLOCK C C.. Data Declarations .. data cmonth /'Jan', 'Feb','Mar','Apr','May','Jun', $ 'Jul','Aug','Sep','Oct','Nov', $ 'Dec'/ data Period /'1st','2nd','3rd', $ '4th','5th','6th', $ '7th','8th','9th', $ '10th','11th','12th'/ C C ... Executable Statements ... C C C********************************************************************** C********************************************************************** C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'Pre Sigex') !DEC$ end if CUNX#end if * write(*,*) ' TRAMO = ',Tramo realTime = 0 pi = acos(-1.0D0) root0c=.FALSE. rootPIc=.FALSE. rootPIs=.FALSE. nounit = 0 ntitle = ISTRLEN(Ttlset) call setNmmu(imean) call setNmp(p) call setNmd(d) call setNmq(q) call setNmBp(Bp) call setNmBd(Bd) call setNmBq(Bq) CALL setdp(0D0,mpkp,hpcyc) CALL setdp(0D0,mpkp,hptrend) CALL setdp(0D0,mpkp,trend) CALL setdp(DNOTST,mpkp,sa) CALL setdp(DNOTST,mpkp,sc) CALL setdp(0D0,kp,sigptac) CALL setdp(0D0,kp,sigptaf) CALL setdp(0D0,kp,sigatac) CALL setdp(0D0,kp,sigataf) do i=0,mw FdelayP(i)=0D0 FdelaySA(i)=0D0 c initialize more arrays transfp(i)=0D0 phasep(i)=0D0 w(i)=0D0 phaseDp(i)=0D0 transfs(i)=0D0 phases(i)=0D0 phaseDs(i)=0D0 END DO c reinitialize the value of these variables to 0 lEp = 0 lEdummy = 0 lHs = 0 lEs = 0 lHc = 0 lEc = 0 lEsa = 0 lHu = 0 lEu = 0 Vrp = 0D0 Vrsa = 0D0 Vrc = 0D0 Vrs = 0D0 Vru = 0D0 CALL setdp(0D0,mpkp,sec) CALL setdp(0D0,mpkp,ses) CALL setdp(0D0,mpkp,sesa) CALL setdp(0D0,mpkp,set) lfor = Max(lfor,Max(8,2*mq)) * write(*,*)' lfor = ',lfor c do i=1,3 c PHIout(i)=ph(i) c THout(i)=th(i) c BPHIout(i)=bph(i) c enddo * if (lfor .gt. 24) then * lfor = 24 * end if if (noserie .eq. 1) then Sqf = 1.0d0 end if c if (mq2 .gt. 24) then c mq2 = 24 c end if call setSd(sqf) ntcclass=NOTSET ntfclass=NOTSET nthclass=NOTSET C********************************************************************** nphi = p + 1 nth = q + 1 nbth = bq*mq + 1 nbphi = bp*mq + 1 C C NUMERATOR OF MODEL C call CONV(theta,nth,btheta,nbth,Thstr0,Qstar0) C********************************************************************* C C COMPUTE TREND SEASONAL AND CYCLE AUTOREGRESSIVE POLYNOMIAL C C TREND DENOMINATOR = CHI C STATIONARY TREND DENOMINATOR = CHIS C NON-STATIONARY TREND DENOMINATOR = CHINS C CYCLE DENOMINATOR = CYC C STATIONARY CYCLE DENOMINATOR = CYCS C NON-STATIONARY CYCLE DENOMINATOR = CYCNS C SEASONAL DENOMINATOR = PSI C STATIONARY SEASONAL DENOMINATOR = PSIS C NON-STATIONARY SEASONAL DENOMINATOR = PSINS C STATIONARY SEASONALLY ADJUSTED DENOMINATOR = ADJS C NON-STATIONARY SEASONALLY ADJUSTED DENOMINATOR = ADJNS C SEASONALLY ADJUSTED DENOMINATOR = CHCYC C C NUMERATOR = Thstr0 C TOTAL DENOMINATOR = TOTDEN C C THE NON-STATIONARITY MAY ARISE FROM DIFFERENCING AND/OR UNIT ROOTS C Chins(1) = 1.0d0 Nchins = 1 dplusd = d + bd if (dplusd .ne. 0) then do i = 1,dplusd Chins(i+1) = 0.0d0 do j = 1,i k = i - j + 2 Chins(k) = Chins(k) - Chins(k-1) end do end do end if Nchins = dplusd + 1 Chis(1) = 1.0d0 Nchis = 1 if (bp .ne. 0.and. bphi(mq+1).lt.0.0d0) then cmu = (-bphi(mq+1))**(1.0d0/mq) Dum(1) = 1.0d0 Dum(2) = -cmu if (ABS(1.0d0-cmu) .lt. 1.0d-13) then call CONV(Dum,2,Chins,Nchins,Chins,Nchins) else call CONV(Dum,2,Chis,Nchis,Chis,Nchis) end if end if Psins(1) = 1.0d0 do i = 2,27 Psins(i) = 0.0d0 Psi(i) = 0.0d0 end do Npsins = 1 Psis(1) = 1.0d0 Npsis = 1 if (bd .ne. 0) then c rootPIs=.TRUE. do i = 1,mq Dum(i) = 1.0d0 end do call CONV(Dum,mq,Psins,Npsins,Psins,Npsins) if (bd .ne. 1) then call CONV(Dum,mq,Psins,Npsins,Psins,Npsins) end if end if if (bp .ne. 0.and. bphi(mq+1).lt.0.0d0) then c rootPIs=.TRUE. Dum(1) = 1.0d0 do i = 2,mq Dum(i) = cmu * Dum(i-1) end do if (ABS(1.0d0-cmu) .lt. 1.0d-13) then call CONV(Dum,mq,Psins,Npsins,Psins,Npsins) else call CONV(Dum,mq,Psis,Npsis,Psis,Npsis) end if end if 5000 if (bp.gt.0 .and. bphi(mq+1).gt.0.0d0) then do i=1,mq+1 cycs(i) = bphi(i) enddo ncycs = mq + 1 else Cycs(1) = 1.0d0 Ncycs = 1 end if Cycns(1) = 1.0d0 Ncycns = 1 C C COMPUTATION OF THE STATIONARY AND NON-STATIONARY (IF UNIT ROOTS) C DENOMINATOR OF THE COMPONENTS C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(3,'Pre first') !DEC$ end if CUNX#end if IsCloseToTD=.FALSE. call F1RST(p,imz,rez,ar,Epsphi,mq,Cycns,Ncycns,Psins,Npsins,Cycs, $ Ncycs,Chins,Nchins,Chis,Nchis,modul,Psis,Npsis,Rmod, $ root0c,rootPIc,rootPIs,IsCloseToTD) CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(3,'after first') c CALL outARMAParam(.false.) !DEC$ end if CUNX#end if C C C if ((qstar0.gt.pstar_seats .or. ncyc.gt.(mq+1)).and. $ bp.eq.1.and. bphi(1).le.0.0d0) then c To avoid Transitory of lest than a year with transitory of more than a year bp=0 status='Z' init=0 call SetTmcs('Y') CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'leave Sigex return 1') !DEC$ end if CUNX#end if return 1 end if if ((stochTD.eq.0).or.(stochTD.eq.-1).and.(npatd.eq.0)) then IsCloseToTD=.False. end if call CONV(Chis,Nchis,Chins,Nchins,Chi,Nchi) call CONV(Psis,Npsis,Psins,Npsins,Psi,Npsi) call CONV(Cycs,Ncycs,Cycns,Ncycns,Cyc,Ncyc) if (isCloseToTD) then TransLcad="TD-STOCHASTIC" nTransLcad=istrlen(TransLcad) TransCad ="TD.Stoch" nTransCad=istrlen(TransCad) c the TD roots will not be in SA do i=1,Nchi Chcyc(i)=Chi(i) endDO nchcyc=nChi call CONV(Chi,Nchi,Cyc,Ncyc,Ctmp,Nctmp) call CONV(Psi,Npsi,Ctmp,Nctmp,Totden,Ntotd) do i=1,Nchis Adjs(i)=Chis(i) enddo Nadjs=Nchis do i=1,Nchins Adjns(i)=Chins(i) enddo Nadjns=nChins else TransLcad="TRANSITORY" nTransLcad=istrlen(TransLcad) TransCad ="TRANS" nTransCad=istrlen(TransCad) call CONV(Chi,Nchi,Cyc,Ncyc,Chcyc,Nchcyc) C added (DEKM Feb 2003) C multiply Psi and Cyc to get denominator of seasonal-cycle model C multiply Chi and Psi to get denominator of trend-seasonal model C call CONV(Psi, Npsi, Cyc, Ncyc, Pscyc, Npscyc) call CONV(Chi, Nchi, Psi, Npsi, Chpsi, Nchpsi) C end of added code block call CONV(Psi,Npsi,Chcyc,Nchcyc,Totden,Ntotd) call CONV(Cycs,Ncycs,Chis,Nchis,Adjs,Nadjs) call CONV(Cycns,Ncycns,Chins,Nchins,Adjns,Nadjns) end if if (IsCloseToTD .and. Ncyc.gt.3) then if (inputmodel.eq.1) then call ShowFirstModel(nio,p,d,q,bp,bd,bq,th, $ Bth,ph,Bph,imean,tramo,init) end if p=p-1 status='X' if (q.le.2) then q=q+1 status='Y' end if init=0 call SetTmcs('y') x(1)=2.0d0*rez(1) x(2)=-(rez(1)*rez(1)+imz(1)*imz(1)) x(1)=x(1)/(1.0d0-x(2)) fixParam(1)=1 fixParam(2)=1 if (out.eq.0) then call shCloseTD(nio,InputModel,p,d,q,bp,bd,bq) end if inputModel=inputModel+1 CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'leave Sigex return 1') !DEC$ end if CUNX#end if return 1 end if C C pstar = p + d + mq*(bd+bp) + 1 C C C THIS SUBROUTINE COMPUTES THE HARMONIC FUNCTIONS FOR THE COMPONENTS, C THE FILTER DENOMINATORS, THE NUMERATOR OF THE COMPONENT MODELS C AND THEIR INNOVATIONS VARIANCE : C C CT : trend filter C CS : seasonal filter C CC : cycle filter C C C C c call OutPart2(nio,nidx,HTML,z,nz,Lam,ImeanOut,noserie,Pg,Out, c $ iter,Itab,Iid,p,D,q,bp,BD,bq,Nper,Nyer,mq, c $ Wdif,WdifCen,nwDif,WmDifXL,Zvar,VdifXL, c $ QstatXL,df,rXL,seRxl,M,partACF,sePartACF,model, c $ PicosXL,init,tstmean,Wm,seMean,nx,Cmatrix, c $ PHI,TH,BPHI,BTH,sePHI,seTH,seBPHI,seBTH, c $ MArez,MAimz,MAmodul,MAar,MApr, c $ rez,imz,modul,ar,pr,thstar,isVa0) c if (noserie.ne.1) then c Call OutSeats(HTML,IOUT,Nio,Ndevice,Nidx,SMTR, c $ printBack,back,sr,SQSTAT,SDF,SSE,mAuto,nfreq, c $ n_1,n0,tvalRUNS, c $ Qstat,DF,Pstat1,spstat1, c $ wnormtes,wsk,skewne,test1,wkk,rkurt,test,r,SEa, c $ Resid,flagTstu,it,iper,iyear, c $ rmean,rstd,DW,KEN,RTVAL,SumSres,F,Nyer1,Nper1, c $ Pstar_seats,Qstar_seats,D,BD) c end if c call OutDenC(Out,HTML,Nidx,Nio,Titleg,init,pstar, c $ p,d,q,bp,bd,bq,theta,nTh,Btheta,nBth, c $ phi,nPhi,Bphi,nBphi,Thstr0,Qstar, c $ Chis,nChis,Chins,nChins,Chi,nChi, c $ Cycs,nCycs,Cycns,nCycns,Cyc,nCyc, c $ Psis,nPsis,Psins,nPsins,Psi,nPsi, c $ Adjs,nAdjs,Adjns,nAdjns,Chcyc,nChcyc, c $ Totden,nTotD) wvara = 1.0d0 buff2 = 'OK' NAfijado=0 c call profiler(3,'Pre SPECTRUM') * write(Mtprof,*)' nio = ',nio * write(Mtprof,*)' out = ',out * write(Mtprof,*)' ItnSearch = ',ItnSearch * write(Mtprof,*)' IfnSearch = ',IfnSearch * write(Mtprof,*)' FIsearch = ',FIsearch * write(Mtprof,*)' nxSearch = ',nxSearch * do j=1,nxSearch * write(Mtprof,*)' xSearch(',j,'), Esearch(',j,') = ',xSearch(j), * & Esearch(j) * end do call SPECTRUM(Noadmiss,OutNA,Thstr0,Qstar0, $ Chi,Nchi,Cyc,Ncyc,Psi,Npsi, C C added arguments for seasonal-cycle denominator Pscyc and its dimension Npscyc, C seasonal-cycle numerator thtra and it's dimension nthtra, and C varwnt, the innovations variance for the seasonal-cycle component C DEKM 6 Feb 2003 C added arguments chpsi, nchpsi (trend-seasonal denominator and dimension), C thcya, nthcya (cycle adjusted numerator and it's dimension), C varwca (innovations variance for cycle adjusted component) C DEKM 20 Feb 2003 $ Chcyc,Nchcyc,Pscyc, npscyc, Chpsi, nchpsi, $ pstar,mq,bd,d,ct,cs,cc,Qt1, $ Sqg,Pg,Out,ncycth,Thetp,Nthetp,Thets,Nthets,Thetc, $ Nthetc,Thadj,Nthadj,Thtra, nthtra,Thcya, nthcya, $ varwnp,varwns, $ varwnc,varwna, varwnt, varwca, c $ buff2,smtr,Har,*5005) $ buff2,Har,chis,nchis,psis,npsis,cycs,ncycs, * $ adjs,nadjs,noserie,smtr,iter,sqf, $ adjs,nadjs,noserie,iter,sqf, c Para OutSeats $ IOUT,Ndevice, $ printBack,back,sr,SQSTAT,SDF,SSE,mAuto,nfreq, $ n_1,n0,tvalRUNS,Qstat,DF,Pstat1,spstat1, $ wnormtes,wsk,skewne,test1,wkk,rkurt,test,r,SEa, $ Resid,flagTstu,it,iper,iyear, $ rmean,rstd,DW,KEN,RTVAL,SumSres,F,Nyer1,Nper1, $ Pstar_seats,Qstar_seats, c Para OutDenC $ Titleg,init,p,q,bp,bq,theta,nTh,Btheta,nBth, $ phi,nPhi,Bphi,nBphi,Chins,Cycns,Psins,Adjns, $ Totden,nTotD,InputModel, c Para OutPara.m $ niter,mattitle,Lgraf, c Para indicar raices reales $ root0c,rootPIc,rootPIs,IsUgly,IsCloseToTD, c Para OutPart2 $ ImeanOut,Wdif,WdifCen,nwDif,WmDifXL,VdifXL, $ QstatXL,rXL,seRxl,partACF,sePartACF,model, $ PicosXL,tstmean,Wm,seMean,nx,Cmatrix, $ sePHI,seTH,seBPHI,seBTH,ph,th,bph, $ MArez,MAimz,MAmodul,MAar,MApr, $ rez,imz,modul,ar,pr, * $ Z,nz,ILam,Itab,IID,Nper,Nyer,Zvar,M,BTH, $ Z,nz,ILam,Nper,Nyer,Zvar,M,BTH, c Para OutSearch $ ItnSearch,IfnSearch,nxSearch,Esearch, $ FIsearch,xSearch,status,NAfijado,tramo,Lsgud, $ *5005) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN c call profiler(2,'after SPECTRUM') c CALL outARMAParam(.false.) C END OF CODE BLOCK if (isUgly .and. Noadmiss.ne.3) then init=0 if (getTmcs().eq.'C' .or. getTmcs().eq.'X')then call setTmcs('X') call setAna('Y') else call setAna('Y') call setTmcs('Y') end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'leave Sigex return 1') !DEC$ end if CUNX#end if return 1 end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(3,'pre getSpectrum') !DEC$ end if CUNX#end if if ((Noadmiss.ne.3).and.(NAfijado.ne.1).and.(NAfijado.ne.2))then c Calculamos el espectro del modelo elegido por Seats call getAR(phi,p,d,bphi,bp,bd,mq,den,nden) call getSpectrum(Thstr0,qstar0,den,nden,spectse) do i=1,Lspect spectse(i)=spectse(i)/(2.0d0*pi) enddo end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(3,'after getSpectrum') c CALL outARMAParam(.false.) !DEC$ end if CUNX#end if C C BEGIN NEW MODEL APPROXIMATION 14/05/1996 C cc parte nueva if ((Noadmiss .eq. 3).or.(NAfijado.eq.1).or.(NAfijado.eq.2)) then if (Nsfcast .eq. 0) then do i = 1,MAX(2*mq,lfor) Sfcast(i) = z(Nz+i) end do c Nsfcast = 1 !So Final Trend will not be corrected, because Stoch_Trend=Xlin-Stoch_Seas-Stoch_trans Nsfcast1=1 if ((getTmcs().eq.'C').or.(getTmcs().eq.'X'))then call setAna('X') call setTmcs('X') else call setAna('Y') call setTmcs('Y') end if Sqfsave = Sqf end if if (NAfijado.eq.1) then goto 5002 else if (NAfijado.eq.2) then goto 5001 end if call APPROXIMATE(p,q,d,bd,bp,bq,rez,imz,init,Noadmiss,imean, $ type,th,bth,ph,bph,mq,status,out,fixparam, $ remMeanMCS,*5002,*5001) write (Nio,9006) 9006 FORMAT(2X,'************************************',/, $ 2X,' PROBLEMS IN THE APPROX. ROUTINE ',/, $ 2X,' PLEASE E-MAIL THE INPUT FILE TO ',/, $ 2X,' x12a@census.gov ',/, $ 2X,'************************************') Handle = 1 Lierr=0 Lerrext=' ' C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK call HANDLE_POINT goto 5002 c call profiler(3,'after APPROXIMATE') c CALL outARMAParam(.false.) 5001 if (Out .eq. 0) then write (Nio,9007)'THE MODEL HAS NO ADMISSIBLE DECOMPOSITION' 9007 format(2x,a) 7032 format ( $ 2x,'MODEL CHANGED TO :',/,2x,'(',1x,i1,',',2x,i1,',',2x,i1,',' $ ,1x,')',4x,'(',1x,i1,',',2x,i1,',',2x,i1,1x,')') write (Nio,7032) p, d, q, bp, bd, bq end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'leave Sigex return 2') !DEC$ end if CUNX#end if return 2 c 5002 call profiler(3,'after APPROXIMATE') c CALL outARMAParam(.false.) 5002 if (Out .eq. 0) then write (Nio,9007)'THE MODEL HAS NO ADMISSIBLE DECOMPOSITION' write (Nio,7032) p, d, q, bp, bd, bq CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'return Sigex return 1 line 825') !DEC$ end if CUNX#end if end if return 1 else status = 'Z' C C HERE INTRODUCE THE NEW PART OF USRENTRY FOR THE MODELS C if (noadmiss.ne.-1) then if (Nsfcast .eq. 0 .and. Nsfcast1 .eq. 0) then call setAna('N') end if end if dvec(1)=DBLE(imean) call USRENTRY(dvec,1,1,1,1,1023) call USRENTRY(phi,1,nphi,1,4,1010) call USRENTRY(theta,1,nth,1,4,1011) call USRENTRY(bphi,1,nbphi,1,13,1012) call USRENTRY(btheta,1,nbth,1,14,1013) call USRENTRY(Thstr0,1,Qstar0,1,40,1014) call USRENTRY(Totden,1,Ntotd,1,40,1015) dvec(1)=DBLE(d) call USRENTRY(dvec,1,1,1,1,1016) dvec(1)=DBLE(bd) call USRENTRY(dvec,1,1,1,1,1017) dvec(1)=DBLE(mq) call USRENTRY(dvec,1,1,1,1,1018) call USRENTRY(Thetp,1,Nchi,1,8,1050) call USRENTRY(Chi,1,Nchi,1,8,1051) dvec(1)=DBLE(varwnp) call USRENTRY(dvec,1,1,1,1,1063) call USRENTRY(Thets,1,Npsi,1,8,1052) call USRENTRY(Psi,1,Npsi,1,8,1053) dvec(1)=DBLE(varwns) call USRENTRY(dvec,1,1,1,1,1064) call USRENTRY(Thetc,1,Nthetc,1,27,1054) call USRENTRY(Cyc,1,Ncyc,1,17,1055) dvec(1)=DBLE(varwnc) call USRENTRY(dvec,1,1,1,1,1065) call USRENTRY(Thadj,1,Nthadj,1,32,1056) call USRENTRY(Chcyc,1,Nchcyc,1,20,1057) dvec(1)=DBLE(varwna) call USRENTRY(dvec,1,1,1,1,1066) dvec(1)=DBLE(Qt1) call USRENTRY(dvec,1,1,1,1,1067) do i = 1,Na ba(Na-i+1) = a(i) end do call USRENTRY(a,1,Na,1,MPKP,1101) call setSdt(Sqrt(varwnp)*sqf) call setSds(Sqrt(varwns)*sqf) call setSdc(Sqrt(varwnc)*sqf) call setSdsa(Sqrt(varwna)*sqf) call setSdi(Sqrt(Qt1)*sqf) C C C SWITCH ALL THE ARRAYS NEEDED FOR ROUTINE DECFB INTO B-J NOTATION C C do i = 1,Nchi-1 Thetp(i) = -Thetp(i+1) Chi(i) = -Chi(i+1) end do do i = 1,Npsi-1 Thets(i) = -Thets(i+1) Psi(i) = -Psi(i+1) end do do i = 1,Ncyc-1 Cyc(i) = -Cyc(i+1) end do do i = 1,Nthetc-1 Thetc(i) = -Thetc(i+1) end do do i = 1,pstar-1 Totden(i) = -Totden(i+1) end do do i = 1,Qstar0-1 Thstr0(i) = -Thstr0(i+1) end do do i = 1,Nchis-1 Chis(i) = -Chis(i+1) end do do i = 1,Npsis-1 Psis(i) = -Psis(i+1) end do do i = 1,Ncycs-1 Cycs(i) = -Cycs(i+1) end do do i=1,nchcyc-1 chcyc(i)= -chcyc(i+1) end do do i=1,nthadj-1 thadj(i)= -thadj(i+1) end do nchcyc=nchcyc-1 nthadj=nthadj-1 Nchi = Nchi - 1 Npsi = Npsi - 1 Ncyc = Ncyc - 1 Ncycs = Ncycs - 1 Nchis = Nchis - 1 Npsis = Npsis - 1 Nthetp = Nthetp - 1 Nthets = Nthets - 1 Nthetc = Nthetc - 1 pstar = pstar - 1 Qstar0 = Qstar0 - 1 C C SET THE LENGTH OF THE PSI'S FILTERS C nfilt = pk lf = nfilt ilen = lf C C * do i = 1,pk*2 do i = 1,nfl psiep(i) = 0.0d0 psieps(i) = 0.0d0 psies(i) = 0.0d0 psiess(i) = 0.0d0 psiec(i) = 0.0d0 psiecs(i) = 0.0d0 psiea(i) = 0.0d0 psiue(i) = 0.0d0 psitot(i) = 0.0d0 end do C C ***** TREND ***** C if (Nchi .ne. 0) then C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre Trend Sigex') !DEC$ end if CUNX#end if call MPBBJ(Cyc,Psi,Ncyc,Npsi,Dum) Ndum = Npsi + Ncyc call DECFB(Chi,Thstr0,Nchi,Qstar0,Thetp,Dum,Nthetp,Ndum, $ varwnp,psiep,pk,rcetre,HFp,lHp0,Vrp,Ep,lEp) if (Nchis .ne. Nchi) then call DECFB(Chis,Thstr0,Nchis,Qstar0,Thetp,Dum,Nthetp,Ndum, $ varwnp,psieps,pk,rceDummy,Hdummy,lDummy,Vrdummy, $ Edummy,lEdummy) else do i = 1,nfilt*2+1 if (abs(psiep(i)).gt.1.0D-30) then psieps(i) = psiep(i) end if end do end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Trend Sigex') !DEC$ end if CUNX#end if else HFp(1)=0 lHp0=0 Vrp=0 do i=0,12 rcetre(i)=0.0d0 end do end if C C ***** SEASONAL ***** C if (Npsi .ne. 0) then C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre SEASONAL Sigex') !DEC$ end if CUNX#end if call MPBBJ(Cyc,Chi,Ncyc,Nchi,Dum) Ndum = Nchi + Ncyc call DECFB(Psi,Thstr0,Npsi,Qstar0,Thets,Dum,Nthets,Ndum, $ varwns,psies,pk,rceAdj,Hs,lHs,Vrs,Es,lEs) if (Npsis .ne. Npsi) then call DECFB(Psis,Thstr0,Npsis,Qstar0,Thets,Dum,Nthets,Ndum, $ varwns,psiess,pk,rceDummy,Hdummy,lDummy,Vrdummy, $ Edummy,lEdummy) else do i = 1,nfilt*2+1 psiess(i) = psies(i) end do end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Seasonal Sigex') !DEC$ end if CUNX#end if else do i=0,12 rceAdj(i)=0.0d0 end do end if C C ***** CYCLE ***** C if (varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. Ncyc.ne.0)) then C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre Cycle Sigex') !DEC$ end if CUNX#end if call MPBBJ(Chi,Psi,Nchi,Npsi,Dum) Ndum = Npsi + Nchi call DECFB(Cyc,Thstr0,Ncyc,Qstar0,Thetc,Dum,Nthetc,Ndum, $ varwnc,psiec,pk,rceCyc,Hc,lHc,Vrc,Ec,lEc) if (Ncycs .ne. Ncyc) then call DECFB(Cycs,Thstr0,Ncycs,Qstar0,Thetc,Dum,Nthetc,Ndum, $ varwnc,psiecs,pk,rceDummy,Hdummy,lDummy,Vrdummy, $ Edummy,lEdummy) else do i = 1,nfilt*2+1 psiecs(i) = psiec(i) end do end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Cycle Sigex') !DEC$ end if CUNX#end if else do i=0,12 rceCyc(i)=0 end do end if C C ***** SA ***** (only to obtain HFsa for RatesGrowth) C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre SA Sigex') !DEC$ end if CUNX#end if if (IsCloseToTD) then call MPBBJ(PSI,Cyc,NPSI,Ncyc,ARnSA) NarNsa = Ncyc + NPSI call DECFB(chcyc,thstr0,nchcyc,Qstar0, $ thadj,ARnSA,nthadj,nARnSA,varWna, $ PSIEa,pk,RceDummy,HFsa,lHFsa,Vrsa,Esa,lEsa) else call DECFB(chcyc,Thstr0,nchcyc,Qstar0, $ thadj,PSI,nthadj,Npsi,varWna, $ PSIEa,pk,RceDummy,HFsa,lHFsa,Vrsa,Esa,lEsa) end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'SA Sigex') !DEC$ end if CUNX#end if C ***** Irregular ***** C nzero = 0 call DECFB(Dum,Thstr0,nzero,Qstar0,vn,Totden,nzero,pstar, $ Qt1,psiue,pk,rceDummy,Hu,lHu,Vru,Eu,lEu) lon = MAX(8,2*mq) do i=1,nfilt*2+1 if (abs(psiep(i)) .lt. 1.0D-28) psiep(i)=0.0D0 if (abs(psiec(i)) .lt. 1.0D-28) psiec(i)=0.0D0 if (abs(psiue(i)) .lt. 1.0D-28) psiue(i)=0.0D0 end do if (IsCloseToTD) then do i = 1,nfilt*2+1 psiea(i) = psiep(i) + psiue(i) tmp2=abs(psiep(i))+abs(psiue(i)) if (tmp2 .gt. 0.0D0) then if (abs(psiea(i))/tmp2 .lt. 1.0D-10) psiea(i)=0.0D0 end if end do else do i = 1,nfilt*2+1 psiea(i) = psiep(i) + psiec(i) + psiue(i) tmp2=abs(psiep(i))+abs(psiec(i))+abs(psiue(i)) if (tmp2 .gt. 0.0D0) then if (abs(psiea(i))/tmp2 .lt. 1.0D-10) then psiea(i)=0.0D0 end if end if end do end if do i=1,nfilt*2+1 if (abs(psiea(i)) .lt. 1.0D-27) then psiea(i)=0.0D0 end if end do tmp2=0.0d0 do i=2,50 if (psiea(i) .ne. 0.0d0) then tmp2=1.0d0 end if end do if (tmp2 .lt. 0.5d0) then psiea(1)=0.0D0 end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Irregular Sigex') !DEC$ end if CUNX#end if C C DISPLAY RESULTS C if (Out .eq. 0) then call ModelEst(MQ,d,bd,isCloseToTD,varwnp,HFp,lHp0,Vrp,Ep,lEp, $ varwns,Hs,lHs,Vrs,Es,lEs,varwnc,Hc,lHc,Vrc,Ec,lEc, $ varwna,HFsa,lHFsa,Vrsa,Esa,lEsa,Qt1,Hu,lHu,Vru,Eu,lEu) 7033 format ( $ //,4x,'MOVING AVERAGE REPRESENTATION OF ESTIMATORS', $ ' (NONSTATIONARY)') write (Nio,7033) write (Nio,9008) 9008 format(//,4x,'The model for the components differs', $ ' from that of its theoretical MMSE estimator.',/,4x, $ 'The MA expressions of the estimators in terms of the ', $ 'observed series innovation',/,4x,'is given below.',/,4x, $ '(Negative lags represent future values;', $ ' positive lags represent past values.',/,4x, $ 'Lag 0 denotes the last observed period.') write (Nio,9009) 9009 format(//,4x,'The last column (the sum of the Psi-Weights)', $ ' should be zero',/,4x, $ 'for negative lags, 1 for lag=0, and equal to the', $ ' Box-Jenkins',/,4x,'Psi-Weights for positive lags.',/) write (Nio,9010) 9010 format(4x,'PSIEP(LAG), for example, represents the effect ', $ 'of the overall',/,4x, $ 'innovation at period (t-lag) on the estimator of the ', $ 'trend for period t.',/,4x, $ 'Similarly for the other components.',/) end if if (Out .eq. 0) then 7034 format ( $ //,3x,' LAG',6x,'PSIEP',7x,'PSIES',7x,'PSIEC',7x,'PSIEA',7x, $ 'PSIUE',13x,'PSIX',/) write (Nio,7034) end if do i = lf-lon+1,lf+1+lon ilag = i - 1 - lf psitot(i) = psiep(i) + psies(i) + psiec(i) + psiue(i) if (Out .eq. 0) then if (ilag .eq. 0) then write (Nio,*) end if 7035 format (3x,i4,5f12.4,5x,f12.4) write (Nio,7035) $ ilag, psiep(i), psies(i), psiec(i), psiea(i), psiue(i), $ psitot(i) end if if (ilag .eq. 0) then write (Nio,*) end if end do call usrentry(PSIEP,1,2*pk,1,nfl,1501) call usrentry(PSIEA,1,2*pk,1,nfl,1502) call usrentry(PSIES,1,2*pk,1,nfl,1503) ! if (Itable .eq. 1) then ! call OpenFilePsie(iret) ! if (iret.eq.0)then ! call OUTPSIES(titleg,nFilt,PSIEP,PSIEA,PSIES,PSIUE,PSIEC, ! $ PsieInic,PsieFin) ! end if ! end if if (out.eq.0) then zsum = 0.0d0 do i = lf-lon+1,lf zsum = zsum + psitot(i) end do zsum = zsum + psitot(lf+1) - 1.0d0 C LINES OF CODE COMMENTED FOR X-13A-S : 2 C write (Nio,'(//,2x,''DETERMINISTIC COMPONENT FROM TRAMO'',/,2x, C $ ''----------------------------------'')') C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 2 write (Nio,9011) 9011 format(//,2x,'DETERMINISTIC COMPONENT FROM regARIMA',/, $ 2x,'-------------------------------------') C END OF CODE BLOCK if (Noutr+Nouir+Neast+Npatd+Npareg .eq. 0) then write (Nio,9012) 9012 FORMAT(14X,'NONE') else if (Noutr .eq. 1) write (Nio,9013)'LS (TREND-CYCLE)' if (Nouir .eq. 1) write (Nio,9013)'AO-TC (IRREGULAR)' if (Neast .eq. 1) write (Nio,9013)'EASTER EFFECT' if (Npatd .gt. 0) write (Nio,9013)'TRADING DAY EFFECT' if (Npareg .eq. 1) then write (Nio,9013)'REGRESSION VARIABLE' if (Neff(0) .eq. 1) & write (Nio,9013)' SEPARATE REGRESSION EFFECT' if (Neff(1) .eq. 1) & write (Nio,9013)' TREND-CYCLE REGRESSION EFFECT' if (Neff(2) .eq. 1) & write (Nio,9013)' SEASONAL REGRESSION EFFECT' if (Neff(3) .eq. 1) & write (Nio,9013)' IRREGULAR REGRESSION EFFECT' if (Neff(4) .eq. 1) & write (Nio,9013)' OTHER REGRESSION EFFECT IN SA SERIES' if (Neff(5) .eq. 1) & write (Nio,9013)' TRANSITORY REGRESSION EFFECT' end if end if 9013 format(6X,a) buff = 'OK' if (zsum .gt. (lon+1)*1.0d-1) then buff = 'SOME OF THE FILTERS ARE NUMERICALLY UNSTABLE' end if if (buff(10:10) .eq. ' ') then write (Nio,9014) buff 9014 format(6X,'DERIVATION OF THE FILTERS :',2X,A) else write (Nio,9015) buff 9015 format(6x,'DERIVATION OF THE FILTERS :',/, $ 10x,'"',a,'"') end if end if * if ((Pg.eq.0) .and. (Out.eq.0).and.(iter.eq.0)) then * if (Nchi .ge. 1) then * fname = 'PSITRE.T4' * subtitle = 'PSI-WEIGHTS(B,F) TREND-CYCLE' * call PLOTFLT1(fname,subtitle,psiep,lon,lf,4,15) * end if * if (Npsi .ge. 1) then * fname = 'PSISEAS.T4' * subtitle = 'PSI-WEIGHTS(B,F) SEASONAL' * call PLOTFLT1(fname,subtitle,psies,lon,lf,4,15) * end if * if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0.or.Ncyc.ge.1)) then * fname = 'PSITRA.T4' * write(subtitle,9016)transLcad(1:ntransLcad) * 9016 FORMAT('PSI-WEIGHTS(B,F) ',A,' COMPONENT') * call PLOTFLT1(fname,subtitle,psiec,lon,lf,4,15) * end if * if (Npsi .ge. 1) then * fname = 'PSISA.T4' * subtitle = 'PSI-WEIGHTS(B,F) SA SERIES' * call PLOTFLT1(fname,subtitle,psiea,lon,lf,4,15) * end if * end if C C******************************************************************* C SWITCH FROM B-J TO POLYNOMIAL NOTATION C C (WE SHOULD CHANGE THE ROUTINE DECFB IN C ORDER TO BE ABLE TO PASS ARRAYS IN POLYNOMIAL NOTATION) C C do i = 1,Nchi Thetp(Nchi+2-i) = -Thetp(Nchi+1-i) Chi(Nchi+2-i) = -Chi(Nchi+1-i) end do do i = 1,Npsi Thets(Npsi+2-i) = -Thets(Npsi+1-i) Psi(Npsi+2-i) = -Psi(Npsi+1-i) end do do i = 1,Ncyc Cyc(Ncyc+2-i) = -Cyc(Ncyc+1-i) end do do i = 1,Nthetc Thetc(Nthetc+2-i) = -Thetc(Nthetc+1-i) end do do i = 1,pstar Totden(pstar+2-i) = -Totden(pstar+1-i) end do do i = 1,Qstar0 Thstr0(Qstar0+2-i) = -Thstr0(Qstar0+1-i) end do do i = 1,Nchis Chis(Nchis+2-i) = -Chis(Nchis+1-i) end do do i = 1,Npsis Psis(Npsis+2-i) = -Psis(Npsis+1-i) end do do i = 1,Ncycs Cycs(Ncycs+2-i) = -Cycs(Ncycs+1-i) end do do i=nchcyc,1,-1 ChCyc(i+1)=-ChCyc(i) end do do i=nthadj,1,-1 Thadj(i+1)=-Thadj(i) end do ChCyc(1)=1.0d0 Thadj(1)=1.0d0 Chi(1) = 1.0d0 Psi(1) = 1.0d0 Cyc(1) = 1.0d0 Cycs(1) = 1.0d0 Chis(1) = 1.0d0 Psis(1) = 1.0d0 Totden(1) = 1.0d0 Thetp(1) = 1.0d0 Thets(1) = 1.0d0 Thetc(1) = 1.0d0 Thstr0(1) = 1.0d0 nChCyc=nChCyc+1 nThadj=nThadj+1 Nchi = Nchi + 1 Npsi = Npsi + 1 Ncyc = Ncyc + 1 Nchis = Nchis + 1 Npsis = Npsis + 1 Ncycs = Ncycs + 1 Nthetp = Nthetp + 1 Nthets = Nthets + 1 Nthetc = Nthetc + 1 pstar = pstar + 1 Qstar0 = Qstar0 + 1 C C********** END OF SWITCH ************************************* C if (noserie .ne. 1) then CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre ESTBUR') !DEC$ end if CUNX#end if c if (Lsumm.gt.0) THEN c write(Nform,1610)'lfor', lfor c write(Nform,1610)'fhi', fhi c 1610 FORMAT(a,': ',i5) c END IF call ESTBUR(z,bz,Totden,pstar,Thstr0,Qstar0,ct,cs,cc,mq,zaf,zab, $ trend,sc,cycle,sa,ir,Npsi,d,bd,fhi,forbias,fortbias, $ forsbias,ncycth,varwnc,imean,isCloseToTD) * if (TRAMO.ne.0)then * lfor=fhi * endif CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'ESTBUR') !DEC$ end if CUNX#end if * if (Pg.eq.0) then * if (iter.eq.0) then * if (out.lt.2) then * if (lamd.eq.0) then * if (Npsi .gt. 1) then * fname = 'SEAS.T' * subtitle = 'SEASONAL COMPONENT' * call PLOTLSERIES(fname,subtitle,sc,Nz,1,999.0d0) * fname = 'SEASADJT.T' * subtitle = 'SA SERIES (LOGS)' * call PLOTLSERIES(fname,subtitle,sa,Nz,1,0.0d0) * end if * if (Nchi.gt.1) then * fname = 'TRENDT.T' * subtitle = 'TREND-CYCLE COMPONENT' * call PLOTLSERIES(fname,subtitle,trend,Nz,1,0.0d0) * end if * end if * if (varwnc.gt.1.0D-10 .and.(ncycth.eq.1.or.Ncyc.gt.1)) then * fname = 'TRANS.T' * if (IsCloseToTD) then * subtitle = 'TRADING DAY COMPONENT' * else * subtitle = 'TRANSITORY COMPONENT' * end if * if (lamd.eq.1) then * call PLOTSERIES(fname,subtitle,cycle,Nz,1,999.0d0) * else * call PLOTLSERIES(fname,subtitle,cycle,Nz,1,999.0d0) * end if * end if * fname = 'IRREG.T' * subtitle = 'IRREGULAR COMPONENT' * if (lamd.eq.1) then * call PLOTSERIES(fname,subtitle,ir,Nz,0,999.0d0) * else * call PLOTLSERIES(fname,subtitle,ir,Nz,0,999.0d0) * end if * end if * else * if (nouir.eq.0 .and. neff(3).eq.0 .and. lamd.eq.1 * $ .and.out.lt.2) then * fname = Ttlset(1:ntitle) //'.FIR' * subtitle = 'IRREGULAR COMPONENT' * call PLOTSERIES(fname,subtitle,ir,Nz,0,999.0d0) * write (17,9017) fname 9017 format(A) * end if * end if * end if cc c New Spectrum computation cc * if ((pg .eq. 0).and.(iter.eq.0).and.(out.eq.0)) then * wFilePic=1 * else wFilePic=0 * end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre SpectrumComputation') !DEC$ end if CUNX#end if if (Nchi .gt. 1) then cname='Differenced Trend ' call SpectrumComputation(trend,nz,mq,cname,'DP',wFilePic,1, $ picosTr,totalSeasTR) end if cname='Differenced SA ' call SpectrumComputation(sa,nz,mq,cname,'SA',wFilePic,1, $ picosSA,totalSeasSA) c cname='irregular' c shortName='u' cname='irregular ' call SpectrumComputation(ir,nz,mq,cname,'u ',wFilePic,0, $ picosIr,totalSeasIR) CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'SpectrumComputation') !DEC$ end if CUNX#end if cc c cc end if C----------------------------------------------------------------------- C CALCULATE THE ALTERNATIVE UNDER/OVER DIAGNOSTICS C Added by REG on 30 Aug 2005 to call getDiag(). C Modified by REG on 17 Nov 2005 for revision processing. C Modified by REG on 17 Feb 2006 to enable only when out not equal to 1. C Modified by REG on 24 Apr 2006 to pass SEATS out parameter to C getDiag(). C Modified by REG on 09 May 2006 to itemize number of model ARIMA C parameters. C if (Lfinit) then ds = Npsins - 1 dt = Nchins - 1 nParam(1) = p nParam(2) = q nParam(3) = bp nParam(4) = bq nDiff(1) = d nDiff(2) = bd call getDiag( ds, dt, Nz, z, out, Init, & Psis, Npsis-1, Psins, Npsins-1, Thets, Nthets-1, & Chis, Nchis-1, Chins, Nchins-1, Thetp, Nthetp-1, & Cycs, Ncycs-1, Thetc, Nthetc-1, Thstr0, Qstar0-1, & Chcyc, Nchcyc-1, Thadj, Nthadj-1, & Pscyc, Npscyc-1, Thtra, Nthtra-1, & varwns, varwnp, varwnc, varwna, varwnt, & Qt1, Sqf, mq, nParam, nFixed, nDiff ) end if C----------------------------------------------------------------------- C C C COMPUTE THE ACF OF COMPONENTS,ESTIMATORS,ESTIMAT (STATION. TRANSF.) C C DUM() AND VN() US() ARE USED AS DUMMY TO COMPUTE THE ARRAYS TO BE PASSED C TO BFAC. IMZ AND REZ ARE USED FOR GAM AND G (NOT NEEDED). C C C ***TREND*** C C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre AUTOCOMP SIGEX') !DEC$ end if CUNX#end if mqo = mq c if (smtr .eq. 1) then c nxout = 2 c else nxout = Out c end if call AUTOCOMP(oz,z,trend,trends,sa,sc,scs,cycle,cycles,ir,wvara, $ varwnp,varwns,varwna,varwnc,phi,nphi,theta,nth, $ psieps,psiess,psiecs,psiue,nfl,Qt1,pg,nxout,mq, $ Ttlset,noserie,Sqf,ncycth,lamd,psiep,psies,psiec, $ psiea,lf,iter,IsCloseToTD) CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'AUTOCOMP SIGEX') !DEC$ end if CUNX#end if if (acfe .gt. 0) then if (Iter .eq. 0) then cdos cdos filename=Outdir(1:ISTRLEN(Outdir)) // '\\moments\\acfes.m' cunix filename=Outdir(1:ISTRLEN(Outdir)) // '/moments/acfes.m' call OPENDEVICE (filename,48,0,ifail) do i=1,acfe write (48,9018) acfpem(i),acfaem(i),acfsem(i), $ acfcem(i),acfiem(i) 9018 format(5(2x,g18.9)) end do call CLOSEDEVICE(48) cdos cdos filename=Outdir(1:ISTRLEN(Outdir)) // '\\moments\\vares.m' cunix filename=Outdir(1:ISTRLEN(Outdir)) // '/moments/vares.m' call OPENDEVICE (filename,48,0,ifail) write (48,9018) acfpem(0),acfaem(0),acfsem(0), $ acfcem(0),acfiem(0) call CLOSEDEVICE(48) else write (80,9017) ' '//Titleg do i=1,acfe write (80,9018) acfpem(i),acfaem(i),acfsem(i), $ acfcem(i),acfiem(i) end do write (81,9017) ' '//Titleg write (81,9018) acfpem(0),acfaem(0),acfsem(0), $ acfcem(0),acfiem(0) end if end if if (Out .eq. 0) then write (Nio,9019) 9019 format(//,4x,'For all components it should happen that :', $ /,8x,'- Var(Component) > Var(Estimator)', $ /,8x,'- Var(Estimator) close to Var(Estimate)',/) write (Nio,9020) 9020 format(/,4x,'* If, for a component, Var(Estimator) >> ', $ 'Var(Estimate), there is UNDERESTIMATION', $ /,6x,'of the component.', $ //,4x,'* If Var(Estimator) << Var(Estimate), ', $ 'the component has been OVERESTIMATED.',/) end if C ****************************************************************** C SKIP THE COMPUTATION OF THE CROSS CORRELATIONS C ****************************************************************** C C SKIP THE COMPUTATION OF THE CROSS-CORRELATION. THERE WERE SOME C PROBLEMS : THE MATRIX OF THE LINEAR SYSTEM MAY BE CLOSE TO SINGULAR C NEAR TO THE SINGULAR. RESULTS ARE ERRONEOUS C C TO REACTIVATE COMMENT THE FOLLOWING "GOTO 661" C C GOTO 661 C C C COMPUTE CROSS-CORRELATION OF ESTIMATORS (STAT. TRANSF.) C C c lon = mqo CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'pre CROSS-ESTIMATORS SIGEX') !DEC$ end if CUNX#end if if (numser.le.5) then nval=nfilt ninicio=1 else nval=180 ninicio=nfilt-nval end if lon = mc do k = 0,lon crpser(k) = 0.0d0 crpsem(k) = 0.0d0 crpcer(k) = 0.0d0 crpcem(k) = 0.0d0 crpier(k) = 0.0d0 crpiem(k) = 0.0d0 crscer(k) = 0.0d0 crscem(k) = 0.0d0 crsier(k) = 0.0d0 crsiem(k) = 0.0d0 crcier(k) = 0.0d0 crciem(k) = 0.0d0 do i = ninicio+k+1,ninicio+2*nval+1 crpser(k) = crpser(k) + psieps(i)*psiess(i-k) crpier(k) = crpier(k) + psieps(i)*psiue(i-k) crsier(k) = crsier(k) + psiess(i)*psiue(i-k) end do if (numser.le.5) then do i = ninicio+k+1,ninicio+2*nval+1 crpcer(k) = crpcer(k) + psieps(i)*psiecs(i-k) crscer(k) = crscer(k) + psiess(i)*psiecs(i-k) crcier(k) = crcier(k) + psiecs(i)*psiue(i-k) end do end if end do C do k = -lon,-1 crpser(k) = 0.0d0 crpsem(k) = 0.0d0 crpcer(k) = 0.0d0 crpcem(k) = 0.0d0 crpier(k) = 0.0d0 crpiem(k) = 0.0d0 crscer(k) = 0.0d0 crscem(k) = 0.0d0 crsier(k) = 0.0d0 crsiem(k) = 0.0d0 crcier(k) = 0.0d0 crciem(k) = 0.0d0 do i = ninicio+1,ninicio+2*nval+1+k crpser(k) = crpser(k) + psieps(i)*psiess(i-k) crpier(k) = crpier(k) + psieps(i)*psiue(i-k) crsier(k) = crsier(k) + psiess(i)*psiue(i-k) enddo if (numser.le.5) then do i = ninicio+1,ninicio+2*nval+1+k crpcer(k) = crpcer(k) + psieps(i)*psiecs(i-k) crscer(k) = crscer(k) + psiess(i)*psiecs(i-k) crcier(k) = crcier(k) + psiecs(i)*psiue(i-k) end do end if end do C stps = (Acfper(0)*Acfser(0))**0.5d0 stpc = (Acfper(0)*Acfcer(0))**0.5d0 stpi = (Acfper(0)*Acfier(0))**0.5d0 stsc = (Acfser(0)*Acfcer(0))**0.5d0 stsi = (Acfser(0)*Acfier(0))**0.5d0 stci = (Acfcer(0)*Acfier(0))**0.5d0 C if (stps .gt. 0.0d0) then do k = -lon,lon crpser(k) = crpser(k) / stps end do end if if (stpc .gt. 0.0d0) then do k = -lon,lon crpcer(k) = crpcer(k) / stpc end do end if if (stpi .gt. 0.0d0) then do k = -lon,lon crpier(k) = crpier(k) / stpi end do end if if (stsc .gt. 0.0d0) then do k = -lon,lon crscer(k) = crscer(k) / stsc end do end if if (stsi .gt. 0.0d0) then do k = -lon,lon crsier(k) = crsier(k) / stsi end do end if if (stci .gt. 0.0d0) then do k = -lon,lon crcier(k) = crcier(k) / stci end do end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'CROSS-ESTIMATORS SIGEX') !DEC$ end if CUNX#end if C C C COMPUTE CROSS-CORRELATION OF ESTIMATES (STAT. TRANSF.) C bseps = -1.0d0 bsepc = -1.0d0 bsepi = -1.0d0 bsesc = -1.0d0 bsesi = -1.0d0 bseci = -1.0d0 if (noserie .eq. 0) then msecross = mqo if (Nchi.gt.1 .and. Npsi.gt.1) then n1 = Nz - Nchins + 1 n2 = Nz - Npsins + 1 call CROSS(trends,scs,n1,n2,msecross,crpsem) end if if (Nchi.gt.1 .and. & varwnc.gt.1.0D-10 .and. (Ncyc.gt.1.or.ncycth.gt.0)) then n1 = Nz - Nchins + 1 n2 = Nz - Ncycns + 1 call CROSS(trends,cycles,n1,n2,msecross,crpcem) end if if (Nchi .gt. 1) then n1 = Nz - Nchins + 1 n2 = Nz call CROSS(trends,ir,n1,n2,msecross,crpiem) end if if ((varwnc.gt.1.0D-10 .and.(ncycth.gt.0.or.Ncyc.gt.1)) $ .and. Npsi.gt.1) then n1 = Nz - Npsins + 1 n2 = Nz - Ncycns + 1 call CROSS(scs,cycles,n1,n2,msecross,crscem) end if if (Npsi .gt. 1) then n1 = Nz - Npsins + 1 n2 = Nz call CROSS(scs,ir,n1,n2,msecross,crsiem) end if if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0.or.Ncyc.gt.1)) then n1 = Nz - Ncycns + 1 n2 = Nz call CROSS(cycles,ir,n1,n2,msecross,crciem) end if nzlen = Min(nz-Nchins,Nz-Npsins+1) if (acfe .gt. 0) then if (Iter .eq. 0) then cdos cdos filename=Outdir(1:ISTRLEN(Outdir)) // '\\moments\\ccfes.m' cunix filename=Outdir(1:ISTRLEN(Outdir)) // '/moments/ccfes.m' call OPENDEVICE (filename,48,0,ifail) write (48,9021) crpsem(0),crsiem(0),crpiem(0), $ crscem(0),crpcem(0),crciem(0) 9021 format(6(2x,g18.9)) call CLOSEDEVICE(48) else write (82,9017) ' '//Titleg write (82,9021) crpsem(0),crsiem(0),crpiem(0), $ crscem(0),crpcem(0),crciem(0) end if end if if (numSer.le.5) then call SEBARTLETTCC (nzlen,mc,crpser,crpcer,crpier, & crscer,crsier,crcier,bseps,bsepc, & bsepi,bsesc,bsesi,bseci,qt1,numser) else call SEBARTLETTCC (nzlen,180,crpser,crpcer,crpier, & crscer,crsier,crcier,bseps,bsepc, & bsepi,bsesc,bsesi,bseci,qt1,numser) end if end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'CROSS-ESTIMATES SIGEX') !DEC$ end if CUNX#end if C if (Lfinit) then c----------------------------------------------------------------------- c Modified by REG on 02 May 2006 to output alternate crosscorrelation c statistics. call altCrossTables( ) c Modified by REG on 17 Feb 2006 to disable SEATS crosscorrelation test c except when out equals 1. Note that existing inline code has been c packaged as new subroutine putCrossTables() at bottom of this file. call putCrossTables( bseps, bsepc, bsepi, bsesc, bsesi, bseci, & ncycth, noserie, .true., & crciem(0), crcier(0), crpcem(0), crpcer(0), & crpiem(0), crpier(0), crpsem(0), crpser(0), & crscem(0), crscer(0), crsiem(0), crsier(0), & varwnc, qt1 ) c----------------------------------------------------------------------- c Modified by REG on 17 Feb 2006 to disable SEATS diagnostic test c except when out equals 1 or else call alternate diagnostics test call UnderOverTest(Mq,bseps,bsepc,bsepi,bsesc,bsesi,bseci,qt1, $ numSer) else if (Out .eq. 0) THEN c----------------------------------------------------------------------- c Modified by REG on 17 Feb 2006 to always call alternative c diagnostics test regardless of SEATS out parameter c except when out equals 1. c write(*,*)' enter altUnderOverTest' call altUnderOverTest(Mq,Out) c write(*,*)' exit altUnderOverTest' end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'UnderOverTest') !DEC$ end if CUNX#end if CC ****************************************************************** CC END SKIP THE COMPUTATION OF THE CROSS CORRELATIONS CC ****************************************************************** CC CC BEGIN THE COMPUTATION OF PSEUDO-INNOVATIONS CC c if (smtr .eq. 1) then c nxout = 0 c else nxout = Out c end if * if ((noserie.eq.0) .and. (nxout.eq.1)) then * write (Nio,'(//,11x,''PSEUDO-INNOVATIONS IN THE COMPONENTS'')') * write (Nio,'(11x,''------------------------------------'',/)') * if (Nchi .gt. 1) then * call CONV(Psi,Npsi,Cyc,Ncyc,Dum1,Ndum1) * 7036 format (/,' PSEUDO INNOVATIONS IN TREND-CYCLE') * write (Nio,7036) * comp = 'TREND-CYCLE' * call PINNOV(Thetp,Nthetp,Dum1,Ndum1,Thstr0,Qstar0,a,Na,Ndec, * $ varwnp,Pg,comp) * end if * if (Npsi .gt. 1) then * call CONV(Chi,Nchi,Cyc,Ncyc,Dum1,Ndum1) * 7037 format (/,' PSEUDO INNOVATIONS IN SEASONAL') * write (Nio,7037) * comp = 'SEASONAL' * call PINNOV(Thets,Nthets,Dum1,Ndum1,Thstr0,Qstar0,a,Na,Ndec, * $ varwns,Pg,comp) * end if * if ((ncycth.eq.1) .or. (Ncyc.gt.1)) then * call CONV(Chi,Nchi,Psi,Npsi,Dum1,Ndum1) * 7038 format (/,' PSEUDO INNOVATIONS IN TRANS. COMPONENT') * write (Nio,7038) * comp = 'TRANSITORY' * call PINNOV(Thetc,Nthetc,Dum1,Ndum1,Thstr0,Qstar0,a,Na,Ndec, * $ varwnc,Pg,comp) * end if * if (Npsi .gt. 1) then * comp = 'SEASONALLY ADJUSTED SERIES' * write (Nio, * $ '(/,'' PSEUDO INNOVATIONS IN SEASONALLY ADJUSTED SERIES'')') * call PINNOV(Thadj,Nthadj,Psi,Npsi,Thstr0,Qstar0,a,Na,Ndec, * $ varwna,Pg,comp) * end if * end if C C C COMPUTE THE ACF OF THE FINAL ESTIMATION ERROR F(T) C --------------------------------------------------- C C***************************************************************** C I-COMPONENT C C Thstr0 * F(T) = THET-I * THET-NON_I * ERR C C VAR(ERR)= VAR(ERR-I) * VAR(ERR-NON_I) C****************************************************************** C C (A) FOR EVERY COMPONENT WE COMPUTE FIRST *THET-NON_I* AND *VAR(ERR)* C USING THE *MAK1* SUBROUTINE C (B) THEN WE USE *BFAC* TO COMPUTE THE ACF C C (FOR THE SEASONALLY ADJUSTED PART (A) IS UNNECESSARY) C C****************************************************************** C C C *** TREND *** C if (Nchi .eq. 1) then do i = 0,12 feetre(i) = 0.0d0 end do else if (Npsi+Ncyc+ncycth .eq. 2) then thnp(1) = 1.0d0 nthnp = 1 vwnnp = Qt1 else do i = 1,50 us(i) = 0.0d0 end do call CONV(Thets,Nthets,Cyc,Ncyc,Dum,Ndum) call CONJ(Dum,Ndum,Dum,Ndum,vn,nvn) do i = 1,nvn us(i) = us(i) + vn(i)*varwns end do nus=nvn call CONV(Thetc,Nthetc,Psi,Npsi,Dum,Ndum) call CONJ(Dum,Ndum,Dum,Ndum,vn,nvn) nus=max(nvn,nus) do i=nvn+1,nus Vn(i)=0.0d0 enddo do i = 1,nus us(i) = us(i) + vn(i)*varwnc end do call CONV(Cyc,Ncyc,Psi,Npsi,Dum,Ndum) call CONJ(Dum,Ndum,Dum,Ndum,vn,nvn) do i = 1,nvn us(i) = us(i) + vn(i)*Qt1 end do caption0=' ' call MAK1(us,nus,thnp,nthnp,vwnnp,nounit,1,caption0,0, & toterr) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK c Obtaining the TOTAL SQUARED ERROR of THnp c call CONJ(THnp,nTHnp,THnp,nTHnp,tmpUS,ntmpUS) c toterr=0.d0 c do i=1,nus c toterr=toterr+(vwnnp*tmpUS(i)-us(i))**2 c endDo ccc Output Traces c call ShowModel(Dum,nDum,THnp,nTHnp,Vwnnp,'nP',strTest) c write(nio,'(//,A)') strTest c write(nio,'("Total squared error nP = ",G10.4)') toterr ccc END Output Traces c END Obtaining the TOTAL SQUARED ERROR of THnp end if call CONV(Thetp,Nthetp,thnp,nthnp,Dum,Ndum) do i = 1,Qstar0-1 vn(i) = -Thstr0(i+1) end do do i = 1,Ndum-1 Dum(i) = -Dum(i+1) end do varerr = vwnnp * varwnp Ndum = Ndum - 1 nvn = Qstar0 - 1 c WRITE(*,*)' subroutine sigex, call 1' call BFAC(vn,Dum,nvn,Ndum,mq,rez,feetre,vz,varerr,imz,mq) c WRITE(*,*)' exit BFAC, call 1' feetre(0) = vz end if C C *** CYCLE *** C if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0.or.Ncyc.gt.1)) then do i = 0,12 feecyc(i) = 0.0d0 end do else if (Npsi+Nchi .eq. 2) then thnc(1) = 1.0d0 nthnc = 1 vwnnc = Qt1 else do i = 1,Nchi+Npsi-1 us(i) = 0.0d0 end do c WRITE(*,*)' enter CONV, CONJ' call CONV(Thets,Nthets,Chi,Nchi,Dum,Ndum) call CONJ(Dum,Ndum,Dum,Ndum,vn,nvn) c WRITE(*,*)' exit CONV, CONJ' do i = 1,nvn us(i) = us(i) + vn(i)*varwns end do c WRITE(*,*)' enter CONV, CONJ' call CONV(Thetp,Nthetp,Psi,Npsi,Dum,Ndum) call CONJ(Dum,Ndum,Dum,Ndum,vn,nvn) c WRITE(*,*)' exit CONV, CONJ' do i = 1,nvn us(i) = us(i) + vn(i)*varwnp end do c WRITE(*,*)' enter CONV, CONJ' call CONV(Chi,Nchi,Psi,Npsi,Dum,Ndum) call CONJ(Dum,Ndum,Dum,Ndum,vn,nvn) c WRITE(*,*)' exit CONV, CONJ' do i = 1,nvn us(i) = us(i) + vn(i)*Qt1 end do caption0=' ' c WRITE(*,*)' enter MAK1' call MAK1(us,nvn,thnc,nthnc,vwnnc,nounit,1,caption0,0, & tmptoterr) c WRITE(*,*)' exit MAK1' C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK end if c WRITE(*,*)' enter CONV' call CONV(Thetc,Nthetc,thnc,nthnc,Dum,Ndum) c WRITE(*,*)' exit CONV' do i = 1,Qstar0-1 vn(i) = -Thstr0(i+1) end do do i = 1,Ndum-1 Dum(i) = -Dum(i+1) end do varerr = vwnnc * varwnc Ndum = Ndum - 1 nvn = Qstar0 - 1 c WRITE(*,*)' subroutine sigex, call 2' call BFAC(vn,Dum,nvn,Ndum,mq,rez,feecyc,vz,varerr,imz,mq) feecyc(0) = vz end if C C *** SEASONALLY ADJUSTED *** C if (Nchcyc .eq. 1) then do i = 0,12 feeadj(i) = 0.0d0 end do else call CONV(Thadj,Nthadj,Thets,Nthets,Dum,Ndum) do i = 1,Qstar0-1 vn(i) = -Thstr0(i+1) end do do i = 1,Ndum-1 Dum(i) = -Dum(i+1) end do varerr = varwns * varwna Ndum = Ndum - 1 nvn = Qstar0 - 1 c WRITE(*,*)' subroutine sigex, call 3' call BFAC(vn,Dum,nvn,Ndum,mq,rez,feeadj,vz,varerr,imz,mq) feeadj(0) = vz end if cc c ASYMMETRIC FILTER COMPUTATION 10-09-2004 c Output commented out by REG on 30 Sep 2005. cc c Now we are going to compute the weights of the Concurrent filters c c because we want the concurrent filter o_a_fil=0 c (the corresponding to the latest observation ) tmpmq=(Mq+1)/2 c /floor(tmpmq) mw_mq=mw c Calculating asymmetric trend filter call CONV(Cyc,Ncyc,Psi,Npsi,PHInp,nPHInp) nalen1 = q+Mq*bq nalen2 = nchi - 1 nalen3 = nthetp-1 xlimit = pi if (mq .gt. 1) then xlimit = 2.0d0*pi/dble(mq) end if if (nchi .eq. 1) then do i=0,2*mx alphap(i) = 0.0d0 enddo do i=0, mx transfp(i) = 0.0d0 enddo else call Afilter(alphap,transfp,phasep,phaseDp,w,Cp,hp, $ o_a_fil,Thstr0,q+Mq*bq,chi,nchi-1,thetp,nthetp-1,varwnp, $ PHInp,nPHInp-1) end if end if c Modified by REG on 02/17/2006, to enable SEATS output when out = 1 if (out .eq. 0) then write (Nio,9022) 9022 format(//) write (Nio,9023)'ASYMMETRIC TREND CONCURRENT','semi-infinite' 9023 format(2x,'WEIGHTS FOR ',a,' ESTIMATOR FILTER (',a, & ' realization)') write (Nio,9024) 9024 format(/,3(3X,'exp(B)',8x,'WEIGHTS',2X)) write (Nio,9025)(i,alphap(i),i=0,60) 9025 format(3(3X,I6,8X,F9.6)) end if * if ((pg .eq. 0).and.(iter.eq.0).and.(out.eq.0)) then * fname = 'WEASTR.T4' * subtitle = 'WEIGHTS OF ASYMMETRIC TREND CONCURRENT FILTER' * call PLOTFLT(fname,subtitle,alphap,61,0,10) * end if c Modified by REG on 02/17/2006, to enable SEATS output when out = 1 if (out .eq. 0) then if (printphtrf .eq. 1) then write (Nio,9026) 'TRANSFER FUNCTION AND PHASE DELAY', & 'ASYMMETRIC TREND', 'semi-infinite' 9026 format(//,' ',a,' OF ',a,' FILTER (',a,' realization)') write (Nio,9027) 'W','Transfp(w)','phaseDELAYp(w)' 9027 format(/,14x,A5,3X,A13,3X,A13) write (Nio,9028)w(0),transfp(0),0 write (Nio,9028) $ (w(i),transfp(i),-phasep(i)/w(i),i=10,mw_mq,10) 9028 format(13x,F6.3,3X,F13.8,3X,F13.8) end if end if * if ((pg .eq. 0).and.(iter.eq.0).and.(out.eq.0)) then * fname = 'SQASTR.T4F' * subtitle = 'SQUARED GAIN OF ASYMMETRIC CONCURRENT TREND FILTER' * call PLOTFILTERS(fname,subtitle,transfp,mw_mq+1,Mq,-10.0d0,pi,1) * fname = 'PHASTR.T4F' * subtitle = 'PHASE DELAY OF ASYMMETRIC CONCURRENT TREND FILTER' * tmpdelay(0) = 0.0d0 * if (nchi .eq. 1) then * do i=1,mw_mq * tmpdelay(i) = 0.0d0 * end do * else * do i=1,mw_mq * tmpdelay(i) = -phasep(i) / w(i) * end do * end if * call PLOTFILTERS(fname,subtitle,tmpdelay,mw_mq+1,Mq,-10.0d0, * $ xlimit,1) * end if if (IscloseToTD) then call CONV(Cyc,Ncyc,Psi,Npsi,PHIs,nPHIs) nalen1 = q+Mq*bq nalen3 = nThadj-1 call Afilter(alphas,transfs,phases,phaseDs,w,Cseas,hSEAS, $ o_a_fil,thstr0,nalen1,CHI,nCHI-1,Thadj,nalen3, $ varwna,PHIs,nPHIs-1) else call CONV(Cyc,Ncyc,Chi,Nchi,PHIns,nPHIns) nalen1 = q+Mq*bq nalen2 = nPHIns-1 nalen3 = nThadj-1 call Afilter(alphas,transfs,phases,phaseDs,w,Cseas,hSEAS, $ o_a_fil,thstr0,q+bq*Mq,PHIns,nPHIns-1,Thadj,nThadj-1, $ varwna,Psi,nPsi) end if c Modified by REG on 02/17/2006, to enable SEATS output when out = 1 if (out .eq. 1 .or. out .eq. 0) then write (Nio,9022) write (Nio,9023)'ASYMMETRIC SA CONCURRENT','semi-infinite' write (Nio,9024) write (Nio,9025)(i,alphas(i),i=0,60) end if * if ((pg .eq. 0).and.(iter.eq.0).and.(out.eq.0)) then * fname = 'WEASSA.T4' * subtitle = 'WEIGHTS OF ASYMMETRIC SA CONCURRENT FILTER' * call PLOTFLT(fname,subtitle,alphas,61,0,10) * end if if ((printphtrf .eq. 1).and.(out.eq.0)) then write (Nio,9026) 'TRANSFER FUNCTION AND PHASE DELAY', & 'ASYMMETRIC SA', 'semi-infinite' write (Nio,9027) 'W','Transfsa(w)','phaseDELAYsa(w)' write (Nio,9028) w(0),transfs(0),0 write (Nio,9028) $ (w(i),transfs(i),-phases(i)/w(i),i=10,mw_mq,10) end if * if ((pg .eq. 0).and.(iter.eq.0).and.(out.eq.0)) then * fname = 'SQASSA.T4F' * subtitle = 'SQUARED GAIN OF ASYMMETRIC CONCURRENT SA FILTER' * call PLOTFILTERS(fname,subtitle,transfs,mw_mq+1,Mq,-10.0d0,pi,1) * fname = 'PHASSA.T4F' * subtitle = 'PHASE DELAY OF ASYMMETRIC CONCURRENT SA FILTER' * tmpdelay(0) = 0.0d0 * do i=1,mw_mq * tmpdelay(i) = -phases(i) / w(i) * end do * call PLOTFILTERS(fname,subtitle,tmpdelay,mw_mq+1,Mq,-10.0d0, * $ xlimit,1) * end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'ASYMMETRIC FILTER SIGEX') !DEC$ end if CUNX#end if cc c Finite filters cc if ((noserie.eq.0).and.(numSer.le.5).and.(nz.lt.120)) then call FinitoFilter(ct,cs,cc,nz,1200,mq,out,IsCloseToTD, $ FDelayp,FDelaySA,pg+iter) end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'FINITO FILTER SIGEX') !DEC$ end if CUNX#end if c c Table PHASE DIAGRAM c if (out.eq.0) then if (noserie.eq.0.and.numser.le.5.and.nz.lt.120) then call Phas2Dia(nio,phaseDp,phaseDs,FDelayp,FDelaySA,mq) else call PhaseDia(nio,phaseDp,phaseDs,mq) end if end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'PHASE DIAGRAM SIGEX') !DEC$ end if CUNX#end if cc c Finite Filter processing that replaces semi-infinite processing c that is commented out above, by REG on 30 Sep 2005, c except when out = 1, by REG on 17 Feb 2006. c Modified by REG, on 24 Apr 2006. c Modified by REG, on 05 Jun 2006, to output time-shift=-phase-delay c instead of phase-delay. cc if (Lfinit) then write (Nio,9022) write (Nio,9023)'ASYMMETRIC TREND CONCURRENT','finite' write (Nio,9024) write (Nio,9025)(i,treFlt(i+1,2),i=0,60) c write (Nio,9026) 'SQUARED GAIN AND TIME SHIFT', & 'ASYMMETRIC TREND', 'finite' write (Nio,9029) 'W','SqGainT(W)','TimeShiftT(W)' 9029 format(/,18x,A,6X,A,5X,A) write (Nio,9028) $ (fltW(i),treGain(i,2),treTmShf(i,2),i=0,mw,10) if (concFltZ(2)) then write(Nio,9030) 9030 format(/,' Warning: Time Shift may not be continuous since', & ' Gain of partial filter is near zero for some w.') end if c write (Nio,9022) write(Nio,9023)'ASYMMETRIC SA CONCURRENT','finite' write(Nio,9024) write(Nio,9025)(i,SAFlt(i+1,2),i=0,60) c write (Nio,9026) 'SQUARED GAIN AND TIME SHIFT', & 'ASYMMETRIC SA', 'finite' write (Nio,9029) 'W','SqGainSA(W)','TimeShiftSA(W)' write(Nio,9028) $ (fltW(i),SAGain(i,2),SATmShf(i,2),i=0,mw,10) if (concFltZ(1)) then write(Nio,9030) end if end if C C C COMPUTE REVISION IN CONCURRENT ESTIMATORS (ACF) C COMPUTE RATES C C C SA SERIES C if ((Npsi .gt. 1) .and. (noserie .eq. 0))then fee = feeadj(0) if (Out .eq. 0) then call SERROR(ses,Nz,psies,nfilt,fee,Sqf,sc,lamd) c move the setting of ses within the if statement...BCM 04-28-2006 if (lamd .eq. 0) then do i = 1,Nz ses(i) = ses(i) * 100.0d0 end do end if end if end if C C TRANSITORY COMPONENT C if ((varwnc.gt.1.0D-10 .and.(ncycth.eq.1).or.(Ncyc.gt.1)) $ .and. (Out .eq. 0) .and. (noserie .eq. 0)) then call SERROR(sec,Nz,psiec,nfilt,feecyc(0),Sqf,cycle,lamd) end if C C TREND C if (Nchi.gt.1 .and. Out.ne.2 .and. noserie .eq. 0) then call SERROR(set,Nz,psiep,nfilt,feetre(0),Sqf,trend,lamd) end if C C SA SERIES C if (Nchcyc.gt.1 .and. Out.ne.2 .and. noserie .eq. 0) then call SERROR(sesa,Nz,psiea,nfilt,feeadj(0),Sqf,sa,lamd) end if C IF (LAMD.EQ.1) THEN do i = 1,Nz+lfor scs(i) = sc(i) cycles(i) = cycle(i) end do C end if C overmaxbias=0 CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'REVISIONS SIGEX') !DEC$ end if CUNX#end if cc c Messages of Spectral Analysis cc if ((noserie.ne.1).and.((mq.eq.4).or.(mq.eq.12))) then if (NChi .gt. 1) then cname='Trend ' call SpectrumComputation(trend,nz,mq,cname,'P ',0,1,PicosTr, & totalSeasTR) end if cname='SA Series ' call SpectrumComputation(sa,nz,mq,cname,'SA',0,1,PicosSA, & totalSeasSA) if (out.eq.0) then c call warnPeaks(nio,picosSA,'SA Series',mq,HTML) end if cname='Irregular ' call SpectrumComputation(ir,nz,mq,cname,'U ',0,0,PicosIr, & totalSeasIR) if (out.eq.0) then c call warnPeaks(nio,picosIr,'Irregular',mq,HTML) c call tablaPicos(nio,nidx,picosSA,picosTr,picosIr,mq, call tablaPicos(nio,picosSA,picosTr,picosIr,mq, $ totalSeasTR,totalSeasSA,totalSeasIR) RST=ResidualSeasTest(d,bd,crQS,crSNP,crPeaks,nz,sa,picosSA, $ totalSeasSA,mq,1,nio) end if end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'SPECTRUMCOMPUTATION SIGEX') !DEC$ end if CUNX#end if cc c cc * write(*,*)' lfor = ',lfor call SECOND(sigpt1,sigat1,nlen,sigptac,sigatac,sigptaf, $ sigataf,sigptmq,sigatmq,sigxtmq,rcetre,rceadj,teetre, $ teeadj,nelen,mq,psiep,psiea,psiec,feetre,feeadj, $ feecyc,psies,psitot,z,trend,sa,cycle,sc,nfilt,Sqf,Nz, $ mq2,lamd,Ttlset,Ncyc,Npsi,lfor,noserie,ir,oz, $ Pg,Out,Iter,Bias,forbias,forsbias,fortbias,Tramo, c $ Maxbias,smtr,ncycth,Ioneout,nthclass,ntcclass, $ ncycth,Ioneout,nthclass,ntcclass, $ ntfclass,overmaxbias,Nchcyc,alpha,rceCyc, $ IsCloseToTD,varwnc) CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'SECOND SIGEX') !DEC$ end if CUNX#end if call setSeCect(Sqrt(teetre(0))*sqf) call setSeCecsa(Sqrt(teeadj(0))*sqf) call setRSeCect(Sqrt(rcetre(0))*sqf) call setRSeCecsa(Sqrt(rceadj(0))*sqf) c if (hpcycle.eq.-1) then if ((mq.eq.12 .and. nz.ge.120).or. $ (mq.eq.6 .and. nz.ge.60).or. $ (mq.eq.4 .and. nz.ge.48).or. $ (mq.eq.3 .and. nz.ge.45).or. $ (mq.eq.2 .and. nz.ge.30).or. $ (mq.eq.1 .and. nz.ge.15))then c hpcycle=1 c change this to cover hptarget is sadj or orig--Jan, 2021 if (Hptrgt.ne.NOTSET) then hpcycle = Hptrgt else hpcycle = 1 end if else hpcycle=0 end if end if if (hpcycle .ge. 1) then C C HERE INTRODUCE THE HPTREND-HPCYCLE COMPUTATION C call HPPARAM(mq,hplan,HPper,HPpar,hpth,km,kc,g,h) dvec(1)=HPlan call UsrEntry(dvec,1,1,1,1,1075) dvec(1)=HPper call UsrEntry(dvec,1,1,1,1,1076) call UsrEntry(HPth,1,3,1,3,1077) dvec(1)=Kc call UsrEntry(dvec,1,1,1,1,1073) dvec(1)=Km call UsrEntry(dvec,1,1,1,1,1083) if (Ilam.eq.0) then do i=1,Nz+lfor hpregt(i)=1 hpregc(i)=1 enddo else do i=1,Nz+lfor hpregt(i)=0 hpregc(i)=0 enddo end if if (hpcycle .eq. 1) then call getBcycleComp(d+bd,mq,0,chi,nchi,chis,nchis, $ THETp,nTHETp,varwnp,HPth,Km,Kc, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ PHIm,nPHIm,THETm,nTHETm,Vm,WithoutVf) if (ilam.eq.1) then do i=1,NZ+LFor eTrend(i)=Trend(i)+Pareg(i,1) if(.not.Lhprmls)eTrend(i)=eTrend(i)+PaOutR(i) enddo else do i=1,NZ+LFor eTrend(i)=log(Trend(i))+log(Pareg(i,1)) if(.not.Lhprmls)eTrend(i)=eTrend(i)+log(PaOutR(i)) enddo end if call HPTRCOMP(eTRend,Nz,lfor,hptrend,hpcyc,hpth,km,g,h) c call UsrEntry(HPcyc,1,nz,1,MPKP,1320) c call UsrEntry(HPtrend,1,nz,1,MPKP,1330) c call UsrEntry(HPcyc,nz+1,nz+lFor,1,MPKP,1321) c call UsrEntry(HPtrend,nz+1,nz+lFor,1,MPKP,1331) else if (hpcycle .eq. 2) then call conv(chis,nchis,cyc,ncyc,chcycs,nchcycs) call getBcycleComp(d+bd,mq,0,chcyc,nchcyc,chcycs,nchcycs, $ thadj,nthadj,varwna,HPth,km,kc, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ PHIm,nPHIm,THETm,nTHETm,Vm,WithoutVf) if (ilam.eq.1) then do i=1,NZ+LFor extSA(i)=SA(i)+Pareg(i,1)+Pareg(i,3) $ +Pareg(i,4)+Pareg(i,7) c if (MQ.le.2) then extSA(i)=extSA(i)+PaOuIR(i) c end if if (.not.isCloseToTD) extSA(i)=extSA(i)+Pareg(i,5) if (.not.Lhprmls) extSA(i)=extSA(i)+PaOuTR(i) enddo else do i=1,NZ+LFor extSA(i)=log(SA(i))+log(PaOuTR(i))+log(Pareg(i,3)) $ +log(Pareg(i,1))+log(Pareg(i,4))+log(Pareg(i,7)) c if (MQ.le.2) then extSA(i)=extSA(i)+log(PaOuIR(i)) c end if if (.not.isCloseToTD) extSA(i)=extSA(i)+log(Pareg(i,5)) if (.not.Lhprmls) extSA(i)=extSA(i)+log(PaOuTR(i)) enddo end if call HPTRCOMP(extSA,Nz,lfor,hptrend,hpcyc,hpth,km,g,h) c call UsrEntry(HPcyc,1,nz,1,MPKP,1320) c call UsrEntry(HPcyc,nz+1,nz+lFor,1,MPKP,1321) c call UsrEntry(HPtrend,1,nz,1,MPKP,1330) c call UsrEntry(HPtrend,nz+1,nz+lFor,1,MPKP,1331) else if (hpcycle .eq. 3) then C Calcularemos el Business cycle de la serie interpolada (Tram) call conv(chis,nchis,cyc,ncyc,PHItots2,nPHItots2) call conv(PHItots2,nPHItots2,PSI,nPSI,PHItots,nPHItots) call getBcycleComp(d+bd,mq,bd,PHI,nPHI,PHItots,nPHItots, $ Thstr0,qstar0,1.0d0,HPth,Km,Kc, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ PHIm,nPHIm,THETm,nTHETm,Vm,withoutVf) if (iLAM.eq.1) then do i=1,NZ+lFor extZ(i)=Z(i)+Pareg(i,3)+Pareg(i,4) $ +Pareg(i,5)+PaReg(i,2)+PaReg(i,0)+Pareg(i,7) $ +PaOuIR(i)+PaEast(i)+PaTD(i)+PaOuS(i) $ +Pareg(i,1) IF(.not.Lhprmls)extZ(i)=extZ(i)+PaouTR(i) enddo else do i=1,NZ+lFor extZ(i)=Z(i)+log(Pareg(i,3))+log(Pareg(i,4)) $ +log(Pareg(i,5))+log(PaReg(i,2)) $ +log(PaReg(i,0))+log(Pareg(i,7)) $ +log(PaOuIR(i))+log(PaEast(i))+log(PaTD(i)) $ +log(PaOuS(i))+log(Pareg(i,1)) IF(.not.Lhprmls)extZ(i)=extZ(i)+log(PaouTR(i)) enddo end if call HPTRCOMP(extZ,Nz,lfor,hptrend,hpcyc,hpth,km,g,h) c call UsrEntry(HPcyc,1,nz,1,MPKP,1320) c call UsrEntry(HPcyc,nz+1,nz+lFor,1,MPKP,1321) c call UsrEntry(HPtrend,1,nz,1,MPKP,1330) c call UsrEntry(HPtrend,nz+1,nz+lFor,1,MPKP,1331) end if call UsrEntry(THETbc,1,nTHETbc,1,MaxCompDim,1070) call UsrEntry(PHIbc,1,nPHIbc,1,MaxCompDim,1071) dvec(1)=Vbc call UsrEntry(dvec,1,1,1,1,1072) call UsrEntry(THETm,1,nTHETm,1,MaxCompDim,1080) call UsrEntry(PHIm,1,nPHIm,1,MaxCompDim,1081) dvec(1)=Vm call UsrEntry(dvec,1,1,1,1,1082) IF(Lhprmls)THEN if (ilam.eq.1) then do i=1,NZ+LFor hptrend(i)=hptrend(i)+PaOutR(i) end do else do i=1,NZ+LFor hptrend(i)=hptrend(i)+log(PaOutR(i)) end do end if END IF DO i=1,NZ+LFor tmpBC(i)=HPcyc(i) tmpTrend(i)=HPtrend(i) compHP(i)=HPtrend(i)+HPcyc(i) if (lamd.eq.0)then compHP(i)=exp(compHP(i)) tmpBC(i)=100.0d0*exp(tmpBC(i)) tmpTrend(i)=exp(tmpTrend(i)) end if enddo call usrEntry(tmpBC,1,nz,1,mpkp,1320) call usrEntry(tmpBC,nz+1,nz+lfor,1,mpkp,1321) call usrEntry(tmpTrend,1,nz,1,mpkp,1330) call usrEntry(tmpTrend,nz+1,nz+lfor,1,mpkp,1331) call getErrorBc(HPcycle,HPth,varwns,qt1,varwnc,d+bd,pk, $ PHIm,nPHIm,THETm,nTHETm,Vm, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ VfcM,VfcBc,VrcM,VrcBc,PSIEm,PSIEbc,WithoutVf, $ PHInp,nPHInp) * if ((out.eq.0).and.(iter.eq.0).and.(pg.eq.0)) then * pgHPSGfilt=0 * else pgHPSGfilt=1 * end if call HPSGfilters(HPcycle,PHInp,nPHInp,THETm,nTHETm, $ THETbc,nTHETbc,Vbc, $ HPth,3,Vm,Thstr0,Qstar0,d,bd,mq,SQG,pgHPSGfilt) call getBcSpectra(PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ PHIm,nPHIm,THETm,nTHETm,Vm, $ Thstr0,qstar0,PHI,p,d,bphi,bp,bd,MQ) call RevErrorBc(HpCycle,HPth,varwns,qt1,varwnc,d+bd, $ pk, $ PHIm,nPHIm,THETm,nTHETm,Vm, $ PHIbc,nPHIbc,THETbc,nTHETbc,Vbc, $ VrcM,VrcBc,PSIEm,PSIEbc) c The final errors are Va*VfcM and Va*VfcBc if ((Lamd.eq.0).and.(VfcBc*sqf*sqf.gt.138))then WithoutVf=3 call SErrorF(SeM,nz,lFor,psiem,pk,0.0d0,sqf,hptrend,lamd) call SErrorF(SeBc,nz,lFor,psieBc,pk,0.0d0,sqf,hpcyc,lamd) else c call SErrorF(SeM,nz,lFor,psiem,pk,Vfcm,sqf,hptrend,lamd) c call SErrorF(SeBc,nz,lFor,psieBc,pk,VfcBc,sqf,hpcyc,lamd) call SErrorF(SeM,nz,lFor,psiem,pk,0.0d0,sqf,hptrend,lamd) call SErrorF(SeBc,nz,lFor,psieBc,pk,0.0d0,sqf,hpcyc,lamd) end if if (lamd.eq.0) then do i=1,nz+lFor seBc(i)=100*seBc(i) c So seBc/100 is the factor of confidence interval t-val=1.0 arround factor Bc end do end if call usrentry(seBC,1,nz+lfor,1,mpkp,1322) call usrentry(seM,1,nz+lfor,1,mpkp,1332) end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'BUSINESS CYCLE SIGEX') !DEC$ end if CUNX#end if c Aquf escribimos todos los grßficos de los espectros te=ricos * if ((pg .eq. 0).and.(iter.eq.0).and.(out.eq.0)) then * maxValS=maxValT(ncycth,ncyc,npsi,Hpcycle,d,bd,mq,varwnc) * maxValS1=max(1.6D0*maxValS,1.5d0) * if (maxSpect.gt.0.0d0) then * maxValS2=max(2.0d0*maxValS,maxSpect) * else * maxValS2=max(2.0d0*maxValS,1.5d0*10.0d0) * end if * call truncaSpectra(d,bd,mq,maxValS2,nchi, * $ ncycth,nchcyc,npsi,HpCycle,varwnc) * call plotSpectra(MQ,maxValS1,nchi,ncycth,ncyc, * $ nchcyc,npsi,hpcycle,varwnc) * end if C OUTPUT SECTION C -------------- C AT THIS MOMENT WE WANT TO DISPLAY ALL THE TABLES OF COMPONENTS C C TABLE 1: ORIGINAL SERIES C if (noserie .eq. 1) then if ((out.eq.0).and. (hpcycle.ge.1)) then if (hpcycle.eq.1) then Vcomp=varwnp call PresentaHP(HPth,HPcycle,Km,HPlan,varwnp, $ ModelStrCt,ModelStrMt) else if (hpcycle.eq.2) then Vcomp=varwna call PresentaHP(HPth,HPcycle,Km,HPlan,varwna, $ ModelStrCt,ModelStrMt) else if (hpcycle.eq.3) then Vcomp=1.0d0 call PresentaHP(HPth,HPcycle,Km,HPlan,1.0d0, $ ModelStrCt,ModelStrMt) end if call OutHeadHP(ModelStrCt,ModelStrMt,HPth,Km, $ HPper,HPlan,HPpar,HPcycle,VfcBc,VfcM, $ VfBc,WithoutVf,MQ,D+BD,Vcomp) end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'leave Sigex line 2559') !DEC$ end if CUNX#end if return end if c if ((Out.eq.0) .and. (Bias.eq.-1) .and. (lamd.eq.0)) then write (Nio,9031)'LEVELS FOR EVERY YEAR.' write (Nio,9032) 9031 FORMAT(//,2x,'SERIES OF LEVELS (INCLUDING FORECASTS) HAVE',/,2x, $ 'BEEN CORRECTED FOR BIAS IN ',a,//) 9032 FORMAT(2x,'WARNING:',/,11x, $ 'IF ANNUAL BIASES ARE LARGE, THIS CORRECTION MAY AFFECT',/11x, $ 'THE STOCHASTIC PROPERTIES OF THE DECOMPOSITION.',/) end if if ((Out.eq.0) .and. (Bias.eq.1) .and. (lamd.eq.0)) then write (Nio,9031)'OVERALL LEVEL.' end if c rober: ojo!!!!!! aqui habia un end if de mas que va ahora al final de la subrutina C C HERE INTRODUCE THE TABLE OF THE ANNUAL MEANS C FOR ORIGINAL SERIES, SA SERIES AND TREND C if ((lamd.eq.0) .and. (mq.ne.1)) then j0 = 0 if (Nper .ne. 1) then j0 = mq + 1 - Nper end if jf = Nz - j0 - ((Nz-j0)/mq)*mq jl = ((lfor/mq)+1)*mq - lfor - jf itf = lfor + 2*mq + jl Nf = (jf+itf) / mq Nt = Nf + (Nz-j0)/mq nye = Nyer if (j0 .ne. 0) then nye = Nyer + 1 end if if (Out .eq. 0) then write (Nio,9033) 9033 format(//,3x,'ANNUAL AVERAGES',/, $ 3x,'---------------',/, $ 3x,'(including forecasting period)',/) end if if (Out .eq. 0) then write (Nio,9034) 9034 format(4x,'YEAR',11x,'SERIES',14x,'SA SERIES',12x, $ 'TREND-CYCLE',/) end if sfull1 = 0.0d0 sfull2 = 0.0d0 sfull3 = 0.0d0 sabsdif1 = 0.0d0 sabsdif2 = 0.0d0 do i = 1,Nt-2 sum1 = 0.0d0 sum2 = 0.0d0 sum3 = 0.0d0 do j = 1,mq if (((i-1)*mq+j+j0) .le. Nz) then sum1 = sum1 + oz((i-1)*mq+j+j0) sum2 = sum2 + sa((i-1)*mq+j+j0) sum3 = sum3 + trend((i-1)*mq+j+j0) else if (((i-1)*mq+j+j0-Nz).le.Kp) then sum1 = sum1 + forbias((i-1)*mq+j+j0-Nz) sum2 = sum2 + forsbias((i-1)*mq+j+j0-Nz) sum3 = sum3 + fortbias((i-1)*mq+j+j0-Nz) end if end do sum1 = sum1 / DBLE(mq) sum2 = sum2 / DBLE(mq) sum3 = sum3 / DBLE(mq) if (Out .eq. 0) then write (Nio,9035) nye+(i-1), sum1, sum2, sum3 9035 format(4X,I4,9X,G12.4,9X,G12.4,10X,G12.4) end if sfull1 = sfull1 + sum1 sfull2 = sfull2 + sum2 sfull3 = sfull3 + sum3 sabsdif1 = sabsdif1 + (ABS(sum1-sum2)) sabsdif2 = sabsdif2 + (ABS(sum1-sum3)) end do sfull1 = sfull1 / DBLE(Nt-2) sfull2 = sfull2 / DBLE(Nt-2) sfull3 = sfull3 / DBLE(Nt-2) sabsdif1 = sabsdif1 / DBLE(Nt-2) sabsdif2 = sabsdif2 / DBLE(Nt-2) dvec(1)=(sabsdif1/sfull2)*100.0d0 call USRENTRY(dvec,1,1,1,1,1950) dvec(1)=(sabsdif2/sfull3)*100.0d0 call USRENTRY(dvec,1,1,1,1,1951) if (Out .eq. 0) then write (Nio,9036)sfull1, sfull2, sfull3 9036 format(/,2x,'FULL PERIOD',4x,g12.4,9x,g12.4,10x,g12.4) end if if (Out .eq. 0) then write (Nio,9037) 9037 format (/,4x,'AVERAGE VALUE OF ABSOLUTE', $ /,4x,'DIFFERENCES IN ANNUAL AVERAGES :', $ /,4x,'(in % of average level)',/) end if if (ABS(sfull2) .lt. 1.0d-8) then sfull2 = 1.0d-6 end if if (ABS(sfull3) .lt. 1.0d-8) then sfull3 = 1.0d-6 end if call setDaasa((sabsdif1/sfull2)*100.0d0) call setDaat((sabsdif2/sfull3)*100.0d0) if (Out .eq. 0) then write (Nio,9038)'ADJUSTED SERIES : ',(sabsdif1/sfull2)*100.0d0 9038 format(/,4X,a,2X,G12.3) end if if (Out .eq. 0) then write (Nio,9038)' TREND-CYCLE : ',(sabsdif2/sfull3)*100.0d0 end if end if if ((Out .eq. 0 ) .and. (overmaxbias .eq. 1)) then write (Nio,9039)PRGNAM 9039 format(///,2x,'DIFFERENCES IN ANNUAL AVERAGES OF ', $ 'ORIGINAL SERIES,',/,2x,'SA SERIES AND TREND-CYCLE', $ ' ARE LARGE. TO AVOID DISTORSION OF',/,2x, $ 'THE STOCHASTIC PROPERTIES OF THE SERIES, IT SHOULD ', $ 'BE MODELLED',/,2x,'IN LEVELS.',//,2x,A, C LINES OF CODE COMMENTED FOR X-13A-S : 1 C $ 'TRAMO-S2001 SHOULD BE RERUN WITH Ilam=1')') C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 $ ' SHOULD BE RERUN WITH NO TRANSFORMATION.') C END OF CODE BLOCK end if if (Out .eq. 0) then 7040 format ( $ ///' PART 4 : ESTIMATES OF THE COMPONENTS (LEVELS)',/, $ ' ---------------------------------------------',//) write (Nio,7040) if (lamd .eq. 1) then write (Nio,9040) 9040 format(/,4x,'THE SE ARE THOSE OF THE TOTAL ESTIMATION ERROR =', $ /,4x,'REVISION ERROR AND FINAL ESTIMATION ERROR.',/) end if end if C C IMPOSE FORECAST SA = FORECAST TREND WHEN BIAS=-1 C if (Bias .eq. -1) then do i = 1,MAX(lfor,MAX(8,2*mq)) sa(Nz+i) = trend(Nz+i) end do end if C C BEGIN DETERMINISTIC COMPONENT FROM TRAMO C if (Tramo .eq. 1) then if (lamd .eq. 0) then if (Npareg .eq. 1) then do i = 1,Nz+lfor sum0 = 1.0d0 do j = 0,5 sum0 = sum0 * Pareg(i,j) end do sum0 = sum0 * Pareg(i,7) pread(i) = $ Paoutr(i) * Paouir(i) * Paeast(i) * Patd(i) * sum0 * 100d0 end do else do i = 1,Nz+lfor pread(i) = $ Paoutr(i) * Paouir(i) * Paeast(i) * Patd(i) * 100D0 end do end if call USRENTRY(pread,1,Nz+lfor,1,MPKP,1299) * if (Pg .eq. 0) then * if (iter.eq.0) then * if (out.lt.2) then * fname = 'PREADF.T' * subtitle = 'PREADJUSTMENT FACTORS' * call PLOTSERIES(fname,subtitle,pread,Nz,1,0.0d0) *c fname = 'XORIG.T' *c subtitle = 'ORIG. UNCORRECTED SERIES (from TRAMO)' *c call PLOTSERIES(fname,subtitle,Tram,Nz,1,0.0d0) * fname = 'FDETF.T5' * subtitle = 'FORECAST PREADJUSTMENT FACTORS' * call PLOTFCAST(fname,subtitle,pread,lfor,Nz,0) * end if * else *c esta condicion nunca se cumple porque estamos dentro de una condicional tramo=1!!!!!!!!!! * if ((Ioneout.eq.0) .and. (Tramo.le.0).and.(out.eq.0)) then * fname = Ttlset(1:ntitle) // '.PRE' * subtitle = 'PREADJUSTMENT FACTORS' * call PLOTSERIES(fname,subtitle,pread,Nz,1,0.0d0) * write (17,9017) fname * end if * end if * end if else if (Npareg .eq. 1) then do i = 1,Nz+lfor sum0 = 0.0d0 do j = 0,5 sum0 = sum0 + Pareg(i,j) end do sum0 = sum0 * Pareg(i,7) pread(i) = Paoutr(i) + Paouir(i) + Paeast(i) + Patd(i) + sum0 end do else do i = 1,Nz+lfor pread(i) = Paoutr(i) + Paouir(i) + Paeast(i) + Patd(i) end do end if if (Out .eq. 0) then write (Nio,9041) 9041 format(/,' PREADJUSTMENT COMPONENT', $ /,' Outliers and Other Deterministic Effects', $ //,' (from regARIMA)') C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(pread) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(pread) C END OF CODE BLOCK end if call USRENTRY(pread,1,Nz+lfor,1,MPKP,1299) * if (Pg .eq. 0) then * if (iter.eq.0) then * if (out.lt.2) then * fname = 'PREADC.T' * subtitle = 'PREADJUSTMENT COMPONENT' * call PLOTSERIES(fname,subtitle,pread,Nz,1,0.0d0) *c fname = 'XORIG.T' *c subtitle = 'ORIG. UNCORRECTED SERIES (from TRAMO=' *c call PLOTSERIES(fname,subtitle,Tram,Nz,1,0.0d0) * fname = 'FDETC.T5' * subtitle = 'FORECAST PREADJUSTMENT COMPONENT' * call PLOTFCAST(fname,subtitle,pread,lfor,Nz,0) * end if * else *c estamos dentro de tramo=1!!!!!!! Nunca escribiremos esto * if ((Ioneout.eq.0).and.(Tramo.le.0).and.(out.eq.0)) then * fname = Ttlset(1:ntitle) // '.PRE' * subtitle = 'PREADJUSTMENT COMPONENT' * call PLOTSERIES(fname,subtitle,pread,Nz,1,0.0d0) * write (17,9017) fname * end if * end if * end if end if end if C C END DETERMINISTIC COMPONENT FROM TRAMO C C C IF (OUT.EQ.1) WRITE(NIO,35) if (Out .eq. 0) then 7041 format ( $ //,' ARIMA SERIES',/,' (Corrected by regARIMA)',/ $ ' "Original Series" FOR SEATS') write (Nio,7041) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(oz) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(oz) C END OF CODE BLOCK end if cc c Compute Concurrent Real-Time SA and Trend cc nrt=4*mq if (mq .lt. 6) then nrt = 5*mq end if nrt = min (Na,max (16,nrt)) nrt = min(nrt,nz-1) do i=1,nrt sumsa=0.0d0 sumtre=0.0d0 do j=1,i k=Na-i+j sumsa=sumsa+PSIEA(nfilt+1-j)*aa(k) sumtre=sumtre+PSIEP(nfilt+1-j)*aa(k) enddo RTsa(nrt-i+1)=sa(Nz-i) - sumsa DRTsa(nrt-i+1)=sa(Nz-i) - RTsa(nrt-i+1) RTtre(nrt-i+1)=trend(Nz-i) - sumtre DRTtre(nrt-i+1)=trend(Nz-i) - RTtre(nrt-i+1) enddo cc c cc * write(Mtprof,*) ' Npsi = ',Npsi if (Npsi .ne. 1) then if (lamd .ne. 0) then C C TABLE 2B: SEASONAL COMPONENTS C if (Out .eq. 0) then 7042 format (/,' SEASONAL COMPONENT ') write (Nio,7042) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(sc) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(sc) C END OF CODE BLOCK end if cc c Here introduce the new Seasonal Component graph with the mean for the periods cc * if (PG .eq. 0) then * if (iter.eq.0) then * if(out.lt.2) then *c sum = 0.0d0 *c j = nper-1 *c icount = 0 *c k = 0 *c do i=1,nz *c sum = sum + sc(i) *c j = j+1 *c icount = icount + 1 *c if (j .eq. mq) then *c k = k+1 *c do j0=k,k+icount-1 *c scmean(j0) = sum / dble(icount) *c end do *c j = 0 *c k=k+icount-1 *c icount = 0 *c sum = 0.0d0 *c end if *c if (i .eq. nz) then *c k = k+1 *c do j0=k,k+icount-1 *c scmean(j0) = sum / dble(icount) *c end do *c j = 0 *c k=k+icount-1 *c icount = 0 *c sum = 0.0d0 *c end if *c end do *c fname = 'SEASM.T' *c subtitle = 'SEASONAL COMPONENT + SE' *c call STRTOLOW(fname) *c filename = GRAPHDIR(1:ISTRLEN(GRAPHDIR)) // '\series\' // *c $ fname(1:ISTRLEN(fname)) *c call OPENDEVICE(filename,8,0,ifault) *c if (ifault .eq. 0) then *c write (8,'(I3,/,I2,/f8.3,/,2X,A)')nz,0,-999.0,TITLEG *c write (8,'(2X,A,/,I3)') subtitle(1:ISTRLEN(subtitle)),mq *cCUNX#ifdef TSW *c!DEC$ IF DEFINED (TSW) *c write (8,'(2X,I3,/,I4,/,I3,/,I1)') Nper, Nyer, Mq, 0 *cCUNX#end if *c!DEC$ end if *c do i=1,nz *c write (8,'(g16.8)') sc(i) *c end do *c do i=1,nz *c write (8,'(3(g16.8,x))') sc(i)-1.645d0*ses(i), *c $ sc(i)+1.645d0*ses(i),scmean(i) *c end do *c call CLOSEDEVICE(8) *c end if *cc *c *cc * fname = 'SSLCI.T' *CUNX#ifdef TSW *!DEC$ IF DEFINED (TSW) * subtitle = 'STOCHASTIC SEASONAL' *CUNX#end if *!DEC$ end if * call PLOTSERIESCI(fname,subtitle,sc,ses,Nz,1,-666.0d0) * end if * else * if (Neast.eq.0 .and. Neff(2).eq.0 .and. Npatd.eq.0 * $ .and. Nous.eq.0 .and. out.lt.2 .and. * $ (.not.IscloseToTD)) then * fname = Ttlset(1:ntitle) // '.sf' * subtitle = 'FINAL SEASONAL' * call PLOTSERIES(fname,subtitle,sc,nz,1,0.0d0) * write (17,9017) fname * end if * end if * end if else C C TABLE 2A: SEASONAL FACTORS FOR MULTIPLICATIVE SERIES C if (Out .eq. 0) then write (Nio,9043) 9043 format(//,4x,'STOCHASTIC COMPONENT',/, $ 4x,'--------------------') write (Nio,9044) 9044 format(/,4x,'THE SE ARE THOSE OF THE TOTAL ESTIMATION ERROR =', $ /,4x,'REVISION ERROR AND FINAL ESTIMATION ERROR.') 7043 format (/,' SEASONAL FACTORS (X 100)') write (Nio,7043) call TABLE2(sc) end if cc c Here introduce the new Seasonal Factors graph with the mean for the periods cc * if ((pg .eq. 0).and.(iter.eq.0).and. * $ ((out.lt.2).or.(out.eq.2.).and.(tramo.le.0))) then *c sum = 0.0d0 *c j = nper-1 *c icount = 0 *c k = 0 *c do i=1,nz *c sum = sum + sc(i) *c j = j+1 *c icount = icount + 1 *c if (j .eq. mq) then *c k = k+1 *c do j0=k,k+icount-1 *c scmean(j0) = sum / dble(icount) *c end do *c j = 0 *c k=k+icount-1 *c icount = 0 *c sum = 0.0d0 *c end if *c if (i .eq. nz) then *c k = k+1 *c do j0=k,k+icount-1 *c scmean(j0) = sum / dble(icount) *c end do *c j = 0 *c k=k+icount-1 *c icount = 0 *c sum = 0.0d0 *c end if *c end do *c fname = 'SEASM.T' *c subtitle = 'SEASONAL FACTORS + SE' *c call STRTOLOW(fname) *c filename = GRAPHDIR(1:ISTRLEN(GRAPHDIR)) // '\series\' // *c $ fname(1:ISTRLEN(fname)) *c call OPENDEVICE(filename,8,0,ifault) *c if (ifault .eq. 0) then *c write (8,'(I3,/,I2,/f8.3,/,2X,A)')nz,1,-999.0,TITLEG *c write (8,'(2X,A,/,I3)') subtitle(1:ISTRLEN(subtitle)),mq *cCUNX#ifdef TSW *c!DEC$ IF DEFINED (TSW) *c write (8,'(2X,I3,/,I4,/,I3,/,I1)') Nper, Nyer, Mq,0 *cCUNX#end if *c!DEC$ end if *c do i=1,nz *c write (8,'(g16.8)') sc(i) *c end do *c do i=1,nz *c write (8,'(3(g16.8,x))') sc(i)-1.645d0*ses(i), *c $ sc(i)+1.645d0*ses(i),scmean(i) *c end do *c call CLOSEDEVICE(8) *c end if * fname = 'SSLCI.T' *CUNX#ifdef DOS *!DEC$ IF DEFINED (DOS) * subtitle = * & 'STOCHASTIC SEASONAL FACTORS with Confidence Intervals' *CUNX#end if *!DEC$ end if * if ((pg .eq. 0).and.(iter.ne.0).and. * $ (out.lt.2.).and.(tramo.le.0)) then * fname = Ttlset(1:ntitle) // '.sf' * subtitle = 'FINAL SEASONAL FACTORS' * call PLOTSERIES(fname,subtitle,sc,nz,1,0.0d0) * write (17,9017) fname * end if *CUNX#ifdef DOS *!DEC$ IF DEFINED (DOS) * if ((Pg .eq. 0).and.(iter.eq.0).and.(out.lt.3)) then * if (Tramo .gt. 0) then * if (out.lt.2) then * fname = 'SEASFAC.T' * subtitle = 'STOCHASTIC SEASONAL FACTORS' * call PLOTLSERIES(fname,subtitle,sc,Nz,1,888.0d0) * end if * else * fname = 'SFIN.T' * subtitle = 'FINAL SEASONAL FACTORS' * call PLOTLSERIES(fname,subtitle,sc,Nz,1,888.0d0) * end if * end if *CUNX#end if *!DEC$ end if * end if if (lamd .eq. 0) then if (Out .eq. 0) then write (Nio,9045)'SEASONAL FACTORS (X 100)' 9045 FORMAT(/,1X,'STANDARD ERROR OF ',a,/) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(ses) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(ses) C END OF CODE BLOCK end if else if (Out .eq. 0) then write (Nio,9045)'SEASONAL' C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(ses) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(ses) C END OF CODE BLOCK end if end if * if ((Nchcyc.gt.1 .and. ncycth.eq.0 .and. ncyc.eq.1) .and. * $ (Out .ne. 2)) then if ((Out .eq. 0) .and. (Nchcyc .gt. 1) ) then if (((nthclass.eq.1).or.(nthclass.eq.0)) .and. (ntcclass.eq.1) $ .and. (ntfclass.eq.1)) then write (Nio,9046) 9046 format(/,4x,'GIVEN THAT THE SEASONALITY IS NOT SIGNIFICANT, ', $ 'THE SEASONAL', $ /,4x,'COMPONENT ESTIMATE MAY WELL BE SPURIOUS') end if end if if (lamd .ne. 0) goto 5003 end if C C TABLE 3A: CYCLICAL FACTORS FOR MULTIPLICATIVE SERIES C if (IsCloseToTD) then cad6='STOCHASTIC TD FACTOR (X 100)' cad7='STANDARD ERROR OF STOCHASTIC TD COMP.' call usrentry(cycle,1,nz,1,MPKP,1207) else cad6='TRANSITORY FACTORS (X 100)' cad7='STANDARD ERROR OF TRANSITORY COMP.' end if if (varwnc.gt.1.0D-10 .and.(ncycth.eq.0) .and. (Ncyc.eq.1)) then goto 5004 else if (lamd .ne. 1) then * if (pg.eq.0) then * if (Iter.ne.0) then * if ((Ioneout.eq.0).and.(Tramo.le.0).and.(out.eq.0).and. * $ (.not.isCloseToTD)) then * fname = Ttlset(1:ntitle) // '.CYC' * write(subtitle,9047) transLcad(1:ntransLcad) * 9047 format('FINAL ',A,' FACTORS') * call PLOTSERIES(fname,subtitle,cycle,Nz,1,0.0d0) * write (17,9017) fname * end if * else * if (Tramo .gt. 0 .or. IscloseToTD) then * if (out.lt.2) then * fname = 'TRANSFAC.T' * if (IsCloseToTD) then * subtitle = 'STOCHASTIC TD FACTORS' * else * subtitle = 'STOCHASTIC TRANSITORY FACTORS' * end if * call PLOTSERIES(fname,subtitle,cycle,Nz,1,888.0d0) * end if * else * if (out.lt.3) then * fname = 'TRAFIN.T' * write(subtitle,9047) transLcad(1:nTransLcad) * call PLOTSERIES(fname,subtitle,cycle,Nz,1,888.0d0) * end if * end if * end if * end if if (Out .eq. 0) then 7044 format (/,A) write (Nio,7044) cad6(1:istrlen(cad6)) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(cycle) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(cycle) C END OF CODE BLOCK if ((varwnc.gt.1.0D-10 .and.(ncycth.eq.1).or.(Ncyc.gt.1)) $ .and. (noserie .eq. 0)) then write (Nio,9048) cad7(1:istrlen(cad7)) 9048 format(/,1X,A,/) call TABLE2(sec) end if end if goto 5004 end if C C TABLE 3B: CYCLE COMPONENTS C 5003 if (varwnc.gt.1.0D-10 .and.ncycth.ne.0 .or. Ncyc.ne.1) then if (IsCloseToTD) then cad7='STANDARD ERROR OF STOCHASTIC TD COMP.' subtitle = 'STOCHASTIC TD COMPONENT' call usrentry(cycles,1,nz,1,MPKP,1207) else cad7='STANDARD ERROR OF TRANSITORY COMP.' subtitle = 'TRANSITORY COMPONENT' end if * if ((Iter.ne.0) .and. (Ioneout.eq.0) .and. (Tramo.le.0) .and. * $ (out.eq.0)) then * fname = Ttlset(1:ntitle) // '.CYC' * call PLOTSERIES(fname,subtitle,cycles,Nz,1,0.0d0) * write (17,9017) fname * end if if (Out .eq. 0) then 7045 format (/,A) write (Nio,7045) subtitle(1:istrlen(subtitle)) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(cycles) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(cycles) C END OF CODE BLOCK end if if ((Out.eq.0) .and. (lamd.eq.1)) then write (Nio,9048)'STANDARD ERROR OF TRANSITORY COMP.' C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(sec) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(sec) C END OF CODE BLOCK end if if ((Out.eq.0) .and. (lamd.eq.0)) then write (Nio,9048) cad7(1:istrlen(cad7)) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(sec) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(sec) C END OF CODE BLOCK end if end if end if C C TABLE 4: TREND C c resume updating here at difference 278 5004 continue * if ((Iter.ne.0) .and. (Ioneout.eq.0) .and. (Tramo.le.0).and. * $ (out.lt.2).and.(.not.isCloseToTD).and.(pg.eq.0)) then * fname = Ttlset(1:ntitle) // '.TRE' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,trend,Nz,1,0.0d0) * write (17,9017) fname * end if if (Out .eq. 0) then 7046 format (/,' TREND-CYCLE') write (Nio,7046) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(trend) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(trend) C END OF CODE BLOCK write (Nio,9048)'STANDARD ERROR OF TREND-CYCLE' C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(set) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(set) C END OF CODE BLOCK end if cc c Real-Time Trend estimator printout cc if (realtime.eq.1)then if (Out .eq. 0) then call Index2Date(Nz-nrt,sp,sy,nper,nyer,mq,nz) nyer2 = nyer nper2 = nper nzsave = nz nper = sp nyer = sy nz = nrt write (Nio,9049)'TREND-CYCLE' 9049 format(//,' REAL-TIME ESTIMATORS OF ',a, $ ' (SEQUENCE OF CONCURRENT ESTIMATORS)') call TABLE2(RTtre) write (Nio,9050)'TREND-CYCLE' 9050 format(//,' REVISION FROM UPDATING REAL-TIME ',a, $ ' ESTIMATORS') call TABLE2(DRTtre) * if ((pg .eq. 0) .and. (Iter .eq. 0)) then * fname = 'RTTRE.T' * subtitle = 'REAL-TIME Trend-Cycle Estimators' * call PLOTSERIES(fname,subtitle,RTtre,Nz,0,0.0d0) * COdate = Odate * Odate = '00-0000' * fname = 'RTRTRE.T' * subtitle= * $ 'REVISION FROM UPDATING REAL-TIME Trend-Cycle Estimators' * call PLOTSERIES(fname,subtitle,DRTtre,Nz,0,999.0d0) * Odate = COdate * end if nyer = nyer2 nper = nper2 nz = nzsave end if end if * if ((Pg .eq. 0).and.(iter.eq.0)) then *!DEC$ IF DEFINED (DOS) *CUNX#ifdef DOS * if (Tramo .gt. 0 .or. isCloseToTD) then * if (out.lt.2) then * fname = 'TRENDO.T' * subtitle = 'STOCHASTIC TREND-CYCLE' * call PLOTSERIES(fname,subtitle,trend,Nz,1,0.0d0) * end if * else * if (out.lt.3) then * fname = 'TRFIN.T' * subtitle = 'FINAL TREND-CYCLE' * call PLOTSERIES(fname,subtitle,trend,Nz,1,0.0d0) * end if * end if *CUNX#end if *!DEC$ end if * fname = 'STRCI.T' *!DEC$ IF DEFINED (DOS) *CUNX#ifdef DOS * subtitle = 'STOCHASTIC TREND-CYCLE with Confidence Intervals' *CUNX#end if *!DEC$ end if *!DEC$ IF DEFINED (TSW) *CUNX#ifdef TSW * subtitle = 'STOCHASTIC TREND-CYCLE' *CUNX#end if *!DEC$ end if * if ((out.lt.2).or.(out.eq.2).and.(tramo.le.0)) then * call PLOTSERIESCI(fname,subtitle,trend,set,Nz,1,-666.0d0) * end if * end if c if ((Pg.eq.0) .and. (Ilam.eq.0) .and. (Out.ne.2)) then c fname = 'TRATE.T' c do i = 2,Nz c bz(i-1) = 100.0d0 * (LOG(trend(i))-LOG(trend(i-1))) c end do c if (mq .eq. 12) then c subtitle = 'TREND-CYCLE; MONTHLY RATE of GROWTH (%)' c end if c if (mq .eq. 4) then c subtitle = 'TREND-CYCLE; QUARTERLY RATE of GROWTH (%)' c end if c if ((mq.ne.12) .and. (mq.ne.4)) then c subtitle = 'TREND-CYCLE; RATE of GROWTH in PERIOD (%)' c end if c Nyer2 = Nyer c Nper2 = Nper c Nper=Nper+1 c if (Nper .gt. Mq) then c Nper = 1 c Nyer = Nyer + 1 c end if c call PLOTSERIES(fname,subtitle,bz,Nz-1,1,0.0d0) c Nyer = Nyer2 c Nper = Nper2 c end if * if ((iter.eq.0).and.(Pg.eq.0).and.(Ilam.eq.1).and. * & (Out.lt.2)) then * fname = 'GROWT.T' * subtitle = 'PERIOD-TO-PERIOD TREND-CYCLE GROWTH' * do i = 2,Nz * bz(i-1) = trend(i) - trend(i-1) * end do * Nyer2 = Nyer * Nper2 = Nper * Nper=Nper+1 * if (Nper .gt. Mq) then * Nper = 1 * Nyer = Nyer + 1 * end if * call PLOTRSERIES(fname,subtitle,bz,Nz-1,1,0.0d0) * Nyer = Nyer2 * Nper = Nper2 * end if if (Npsi .ne. 1) then C C TABLE 5: S.A. SERIES C * if (pg.eq.0) then * if (Iter.ne.0) then * if ((Ioneout.eq.0) .and. (Tramo.le.0).and. (out.lt.2)) then * fname = Ttlset(1:ntitle) // '.SA' * subtitle = 'SEASONALLY ADJUSTED SERIES' * call PLOTSERIES(fname,subtitle,sa,Nz,1,0.0d0) * write (17,9017) fname * end if * else *!DEC$ IF DEFINED (DOS) *CUNX#ifdef DOS * if (Tramo .gt. 0) then * if (out.lt.2) then * fname = 'SEASADJO.T' * subtitle = 'STOCHASTIC SA SERIES' * call PLOTSERIES(fname,subtitle,sa,Nz,1,0.0d0) * end if * else * if (out.lt.3) then * fname = 'SAFIN.T' * subtitle = 'FINAL SA SERIES' * call PLOTSERIES(fname,subtitle,sa,Nz,1,0.0d0) * end if * end if *CUNX#end if *!DEC$ end if * fname = 'SSACI.T' *!DEC$ IF DEFINED (DOS) *CUNX#ifdef DOS * subtitle = 'STOCHASTIC SA SERIES with Confidence Intervals' *CUNX#end if *!DEC$ end if *!DEC$ IF DEFINED (TSW) *CUNX#ifdef TSW * subtitle = 'STOCHASTIC SA SERIES' *CUNX#end if *!DEC$ end if * if (out.lt.2) then * call PLOTSERIESCI(fname,subtitle,sa,sesa,Nz,1,-666.0d0) * end if * end if * end if if (Out .eq. 0) then 7047 format (/,' SEASONALLY ADJUSTED SERIES') write (Nio,7047) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(sa) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(sa) C END OF CODE BLOCK end if if (Out .eq. 0) then write (Nio,9048) 'STANDARD ERROR OF SEASONALLY ADJUSTED SERIES' C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(sesa) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(sesa) C END OF CODE BLOCK end if if (realTime.eq.1) then if (Out .eq. 0) then call Index2Date(Nz-nrt,sp,sy,nper,nyer,mq,nz) nyer2 = nyer nper2 = nper nzsave = nz nper = sp nyer = sy nz = nrt write (Nio,9049)'SA SERIES' call TABLE2(RTsa) write (Nio,9050)'SA SERIES' call TABLE2(DRTsa) * if ((pg .eq. 0) .and. (Iter .eq. 0)) then * fname = 'RTSA.T' * subtitle = 'REAL-TIME SA Series Estimators' * call PLOTSERIES(fname,subtitle,RTsa,Nz,0,0.0d0) * COdate = Odate * Odate = '00-0000' * fname = 'RTRSA.T' * subtitle= * $ 'REVISION FROM UPDATING REAL-TIME SA Series Estimators' * call PLOTSERIES(fname,subtitle,DRTsa,Nz,0,999.0d0) * Odate = COdate * end if nyer = nyer2 nper = nper2 nz = nzsave end if end if c if ((Pg.eq.0) .and. (Ilam.eq.0) .and. (Out.ne.2)) then c fname = 'SARATE.T' c if (mq .eq. 12) then c subtitle = 'SA SERIES; MONTHLY RATE of GROWTH (%)' c end if c if (mq .eq. 4) then c subtitle = 'SA SERIES; QUARTERLY RATE of GROWTH (%)' c end if c if ((mq.ne.12) .and. (mq.ne.4)) then c subtitle = 'SA; RATE of GROWTH in PERIOD (%)' c end if c do i = 2,Nz c bz(i-1) = 100.0d0 * (LOG(sa(i))-LOG(sa(i-1))) c end do c Nyer2 = Nyer c Nper2 = Nper c Nper=Nper+1 c if (Nper .gt. Mq) then c Nper = 1 c Nyer = Nyer + 1 c end if c call PLOTSERIES(fname,subtitle,bz,Nz-1,1,0.0d0) c Nyer = Nyer2 c Nper = Nper2 c end if * if ((iter.eq.0).and.(Pg.eq.0).and.(Ilam.eq.1).and. * & (Out.lt.2)) then * fname = 'GROWSA.T' * subtitle = 'PERIOD-TO-PERIOD SA SERIES GROWTH' * do i = 2,Nz * bz(i-1) = sa(i) - sa(i-1) * end do * Nyer2 = Nyer * Nper2 = Nper * Nper=Nper+1 * if (Nper .gt. Mq) then * Nper = 1 * Nyer = Nyer + 1 * end if * call PLOTRSERIES(fname,subtitle,bz,Nz-1,1,0.0d0) * Nyer = Nyer2 * Nper = Nper2 * end if end if C C TABLE 6: IRREGULAR C if (lamd .ne. 0) then if (Out .eq. 0) then 7048 format (/,' IRREGULAR COMPONENT') write (Nio,7048) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(ir) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(ir) C END OF CODE BLOCK end if else * if (Pg .eq. 0) then * if (iter.eq.0) then * if (Tramo .gt. 0 .or. IsCloseToTD) then * if (out.lt.2) then * fname = 'IRREGFAC.T' * subtitle = 'STOCHASTIC IRREGULAR FACTORS' * call PLOTSERIES(fname,subtitle,ir,Nz,1,888.0d0) * end if * else * if (out.lt.3) then * fname = 'IRFIN.T' * subtitle = 'FINAL IRREGULAR FACTORS' * call PLOTSERIES(fname,subtitle,ir,Nz,1,888.0d0) * end if * end if * else * if ((tramo.le.0) .and. (out.lt.2) .and. (Ioneout.eq.0).and. * $ (.not.isCloseTotD)) then * fname = Ttlset(1:ntitle) //'.FIR' * subtitle = 'FINAL IRREGULAR FACTORS' * call PLOTSERIES(fname,subtitle,ir,Nz,1,888.0d0) * write (17,9017) fname * end if * end if * end if if (Out .eq. 0) then 7049 format (/,' IRREGULAR FACTORS (X 100)') write (Nio,7049) C LINES OF CODE COMMENTED FOR X-13A-S : 1 C call TABLE(ir) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 call TABLE2(ir) C END OF CODE BLOCK end if end if if (lamd.eq.0) then call SERRORL(z,trend,sc,cycle,sa,Nchi,Npsi,Ncyc,ncycth,Nz,Sqf, $ lfor,alpha,IsCloseToTD,varwnc,out) end if if (lamd .eq. 1) then if (NSFCAST .eq. 0) then call usrentry(z,Nz+1,Nz+Lfor,1,MPKP,1205) else call usrentry(SFCAST,1,Lfor,1,PFCST,1205) end if call usrentry(SESFCAST,1,Lfor,1,PFCST,1206) c call usrentry(Setp,kp+2,Kp+1+Lfor,-kp,kp,1256) c call usrentry(Seta,kp+2,Kp+1+Lfor,-kp,kp,1257) call usrentry(Setp,1,Lfor,-kp,kp,1256) call usrentry(Seta,1,Lfor,-kp,kp,1257) if (npsi .gt. 1) then c call usrentry(Sets,kp+2,Kp+1+Lfor,-kp,kp,1258) call usrentry(Sets,1,Lfor,-kp,kp,1258) endif if (varwnc.gt.1.0D-10 .and. ((ncycth.eq.1) .or. (ncyc.gt.1))) $ then c call usrentry(Setc,kp+2,Kp+1+Lfor,-kp,kp,1259) call usrentry(Setc,1,Lfor,-kp,kp,1259) endif end if c if (HTML .eq. 1) then c write (Nio,'("")') c end if C C C HERE INTRODUCE THE USRENTRY FOR THE STHOCASTIC COMPONENT C call USRENTRY(trend,1,Nz+lfor,1,MPKP,1200) call USRENTRY(sc,1,Nz+lfor,1,MPKP,1201) if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0) .or. (Ncyc.gt.1)) then call USRENTRY(cycle,1,Nz+lfor,1,MPKP,1202) end if call USRENTRY(sa,1,Nz+lfor,1,MPKP,1203) call USRENTRY(ir,1,Nz,1,MPKP,1204) if (Tramo .le. 0) then call USRENTRY(trend,1,Nz,1,MPKP,1310) call USRENTRY(sc,1,Nz,1,MPKP,1311) call USRENTRY(cycle,1,Nz,1,MPKP,1313) call USRENTRY(sa,1,Nz,1,MPKP,1309) call USRENTRY(ir,1,Nz,1,MPKP,1312) call USRENTRY(trend,Nz+1,Nz+lfor,1,MPKP,1410) call USRENTRY(sc,Nz+1,Nz+lfor,1,MPKP,1411) if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0) .or. (Ncyc.gt.1)) then call USRENTRY(cycle,Nz+1,Nz+lfor,1,MPKP,1413) end if call USRENTRY(sa,Nz+1,Nz+lfor,1,MPKP,1409) call USRENTRY(ir,Nz+1,Nz,1,MPKP,1412) end if call USRENTRY(set,1,Nz,1,mp,2200) if ((Npsi .gt. 1) .and. (noserie .eq. 0))then call USRENTRY(ses,1,Nz,1,mp,2201) endif if ((ncycth.gt.0) .or. (Ncyc.gt.1)) then call USRENTRY(sec,1,Nz,1,mp,2202) endif call USRENTRY(sesa,1,Nz,1,mp,2203) cc c Here Introduce the new graphs SI-S Ratio cc !DEC$ IF DEFINED (DOS) CUNX#ifdef DOS * if ((pg.eq.0).and.(iter.eq.0).and.(out.lt.2)) then * if (lamd .eq. 0) then * do i=1,nz * scmean(i) = (sc(i)/100.0d0)*(cycle(i)/100.0d0)* * $ (ir(i)/100.0d0) * end do * else * do i=1,nz * scmean(i) = sc(i) + cycle(i) + ir(i) * end do * end if * do j=1,mq * k=j+nper-1 * if (k .gt. mq) then * k = k-mq * end if * write (fname,9051)'SI-S',k,'.T' * 9051 format (a,i2.2,a) * if (mq .eq. 12) then * write (subtitle,9052)'SI-S ',cmonth(k) * else * write (subtitle,9052)'SI-S ',period(k) * end if * 9052 format(a,a) * sum0 = 0.0d0 * ncount = 0 * if (lamd .eq. 0) then * do i=j,nz,mq * sum0=sum0+(sc(i) /100.0d0) * ncount = ncount+1 * end do * else * do i=j,nz,mq * sum0=sum0 +sc(i) * ncount = ncount+1 * end do * end if * sum0 = sum0 / Dble(ncount) * call STRTOLOW(fname) *cdos * filename = GRAPHDIR(1:ISTRLEN(GRAPHDIR)) // '\\si-ratio\\' // * $ fname(1:ISTRLEN(fname)) *cunix *cunix filename = GRAPHDIR(1:ISTRLEN(GRAPHDIR)) // '/si-ratio/' // * call OPENDEVICE(filename,48,0,ifault) * if (ifault .eq. 0) then * write (48,9053)ncount,999,sum0,TITLEG * 9053 format(I3,/,I3,/f8.3,/,2X,A) * write (48,9054) subtitle(1:ISTRLEN(subtitle)),mq * 9054 format(2X,A,/,I3) * if (lamd .eq. 0) then * do i=j,nz,mq * write (48,9055) sc(i)/100.0d0 * end do * else * do i=j,nz,mq * write (48,9055) sc(i) * end do * end if * do i=j,nz,mq * write (48,9055) scmean(i) * end do * call CLOSEDEVICE(48) * end if * end do * end if * 9055 format(g16.8) CUNX#end if !DEC$ end if !DEC$ IF DEFINED (TSW) CUNX#ifdef TSW * if ((pg.eq.0).and.((out.eq.0).or.(iter.eq.0).and.(out.lt.2))) then * if (lamd .eq. 0) then * do i=1,nz * scmean(i) = (sc(i)/100.0d0)*(cycle(i)/100.0d0)* * $ (ir(i)/100.0d0) * end do * else * do i=1,nz * scmean(i) = sc(i) + cycle(i) + ir(i) * end do * end if * if (iter.eq.0) then * fname = 'SI-Sratio.rt' * else * fname = Ttlset(1:ntitle)//'.sir' * end if * call STRTOLOW(fname) *cdos * filename = GRAPHDIR(1:ISTRLEN(GRAPHDIR)) // '\\si-ratio\\' // * $ fname(1:ISTRLEN(fname)) *cunix *cunix filename = GRAPHDIR(1:ISTRLEN(GRAPHDIR)) // '/si-ratio/' // * call OPENDEVICE(filename,48,0,ifault) * if (ifault .eq. 0) then * write (48,9056) TITLEG * write (48,9057) 'SI-S Ratios',mq * 9056 format(2X,A) * 9057 format(2X,A,/,I3) * end if * do j=1,mq * k=j+nper-1 * if (k .gt. mq) then * k = k-mq * end if * sum = 0.0d0 * ncount = 0 * if (lamd .eq. 0) then * do i=j,nz,mq * sum=sum+sc(i) /100.0d0 * ncount = ncount+1 * end do * else * do i=j,nz,mq * sum=sum+sc(i) * ncount = ncount+1 * end do * end if * sum = sum /Dble(ncount) * if (ifault .eq. 0) then * write (48,9058)ncount,sum * 9058 format(I3,/,g18.3) * if (mq .eq. 12) then * if (lamd .eq. 0) then * do i=j,nz,mq * write (48,9059) sc(i)/100.0d0, cmonth(k) * end do * else * do i=j,nz,mq * write (48,9059) sc(i), cmonth(k) * end do * end if * do i=j,nz,mq * write (48,9059)scmean(i), cmonth(k) * end do * else * if (lamd .eq. 0) then * do i=j,nz,mq * write (48,9059) sc(i)/100.0d0, period(k) * end do * else * do i=j,nz,mq * write (48,9059) sc(i), period(k) * end do * end if * do i=j,nz,mq * write (48,9059)scmean(i), period(k) * end do * end if * end if * end do * call CLOSEDEVICE(48) * if (iter.ne.0) then * write (47,9017) fname * end if * end if * 9059 format(g16.8,4x,A) CUNX#end if !DEC$ end if C C CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'TABLES AND GRAPH SIGEX') !DEC$ end if CUNX#end if if (Tramo .gt. 0) then if(HPcycle.ge.1) then if (lamd .eq. 0) then sum0 = 0.0d0 sum00 = 0.0d0 do i = 1,Nz+lfor sum0 = sum0 + CompHP(i) sum00 = sum00 + Exp(hptrend(i)) end do kons = sum0 / sum00 end if if (lamd .eq. 0) then do i = 1,Nz+lfor hptmp(i) = 100.0d0 * (trend(i)/(kons*EXP(hptrend(i)))) hptrtmp(i) = kons*Exp(hptrend(i)) end do else do i = 1,Nz+lfor hptmp(i) = hpcyc(i) hptrtmp(i) = hptrend(i) end do end if end if * call profiler(3,'DETCOMP SIGEX') call DETCOMP(hptmp,hptrtmp,hpcycle,psiep,psiea,Sqf,ilen,oz,bz,z, $ trend,sa,sc,ir,cycle,pread,aa,na,osa,ot, $ ftr,fsa,Ncyc,ncycth,Out,Pg,Nz,mq,lamd,Ttlset,Npsi, $ Nchi,Iter,Ioneout,Fortr,lfor,Nreestimated,Itable, $ tabtables,Nper,Nyer,IsCloseToTD,varwnc) c----------------------------------------------------------------------- IF(Issap.eq.2.or.Irev.eq.4)RETURN c----------------------------------------------------------------------- do i = Nz+1,Nz+lfor osa(i) = fsa(i-Nz) ot(i) = ftr(i-Nz) end do CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'DETCOMP SIGEX') !DEC$ end if CUNX#end if C C HERE INTRODUCE THE NEW RATES OF GROWTH C if (lamd .eq. 0) then * do i = Nz+1,Nz+nfor do i = Nz+1,Nz+lfor oz(i) = Exp(z(i)) end do else * do i = Nz+1,Nz+nfor do i = Nz+1,Nz+lfor oz(i) = z(i) end do end if c if (Out .eq. 0) then call RATESGROWTH(mq,lamd,Sqf,Tram,ot,osa,Nz,sigpt1,sigat1, $ nlen,sigptac,sigatac,sigptaf,sigataf,sigptmq, $ sigatmq,rcetre,rceadj,teetre,teeadj,psiep, $ psiea,psitot,lf,Nyer,Nper,Reverse,Pg, $ rogtable,Iter,Ttlset,Out, $ Thstr0,q+mq*bq+1,HFp,lHp0,Vrp,HFsa,lHFsa,Vrsa) else if (Itable .eq. 1) then C LINES OF CODE COMMENTED FOR X-13A-S : 1 C nfor = MAX(8,2*mq) C nfor = Max(lfor,MAX(8,2*mq)) C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 nfor = lfor C END OF CODE BLOCK if (lamd .eq. 0) then do i = 1,Nz+nfor ceff(i) = 1.0d0 end do do i = Nz+1,Nz+MAX(lfor,MAX(8,2*mq)) ir(i) = 100.0d0 end do else do i = 1,Nz+MAX(lfor,MAX(8,2*mq)) ceff(i) = 0.0d0 end do end if if (ITER .gt. 2) then call ProcTables(tabtables) end if if (HPCYCLE.ge.1)then if (lamd .eq. 0) then do i = 1,Nz+lfor hptmp(i) = 100.0d0 * EXP(hpcyc(i)) hptrtmp(i) = Exp(hptrend(i)) end do else do i = 1,Nz+lfor hptmp(i) = hpcyc(i) hptrtmp(i) = hptrend(i) end do end if end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'RATESGROWTH SIGEX') !DEC$ end if CUNX#end if cc c Benchmark cc if (((MQ.eq.4) .or. (MQ.eq.12)) .and. (bcMark.eq.1)) then Lamda = Blamda Mid = Bmid Rol = Brol IF (rol.gt.0.99999D00) THEN if (MQ .eq.12) then rol = 0.9d0 else rol = 0.729d0 end if end if Iftrgt = 0 do i=1,nz+lfor tmp(i)=z(i) end do Begyrt = 1 call qmap2(tmp,sa,fosa,1,nz+lfor,mq,0) if (Out .eq. 0) then write (Nio,9060) 9060 format(//,2X,'FINAL SA SERIES WITH REVISED YEARLY',/) call TABLE2(fosa) end if * if (pg .eq. 0) then * if (iter.ne.0) then * if ((ioneout.eq.0) .and. (out.eq.0)) then * fname = Ttlset(1:ntitle) // '.SAR' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,fosa,nz,1,0.0d0) * write (17,'(A)') fname * end if * else * if (out.lt.2) then * fname = 'FSAFIN.T' * subtitle = 'FINAL SA SERIES WITH REVISED YEARLY' * call PLOTSERIES(fname,subtitle,fosa,nz,1,0.0d0) * end if * end if * end if call USRENTRY(fosa,1,nz,1,MPKP,1314) end if cc c cc call OUTTABLE2(Titleg,z,trend,sa,sc,ir,cycle,pread,ceff, $ eresid,numEresid,hptmp,hptrtmp,hpcycle,lamd,1, $ Nz,mq,1,sunits,lfor,trend,sa,fosa,IsCloseToTD) end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'RATESGROWTH SIGEX') !DEC$ end if CUNX#end if C IF ((OUT.NE.2).AND.(LAMD.EQ.0)) THEN C WRITE(NIO,'(//,4X,''RATE OF GROWTH'')') C WRITE(NIO,'(4X,''--------------'')') C WRITE(NIO,'(4X, C $ ''(Period To Period; In Percentage Points)'')') C CALL RATES(Z,TREND,SA,TMP,TMP,TMP,NCHI,NPSI,LFOR,0) C end if C C HERE INTRODUCE THE NEW RATES OF GROWTH C if (lamd .eq. 0) then do i = Nz+1,Nz+nfor oz(i) = Exp(z(i)) end do else do i = Nz+1,Nz+nfor oz(i) = z(i) end do end if * if (Out .lt. 2) then call RATESGROWTH(mq,lamd,Sqf,oz,trend,sa,Nz,sigpt1,sigat1, $ nlen,sigptac,sigatac,sigptaf,sigataf,sigptmq, $ sigatmq,rcetre,rceadj,teetre,teeadj,psiep, $ psiea,psitot,lf,Nyer,Nper,Reverse,Pg, $ rogtable,Iter,Titleg,Out, $ Thstr0,q+mq*bq+1,HFp,lHp0,Vrp,HFsa,lHFsa,Vrsa) * end if * end if end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'RATESGrowth new SIGEX') !DEC$ end if CUNX#end if C C c 5005 continue * 5005 if ((Iter.ne.0) .and. (Ioneout.eq.1) .and. (Tramo.le.0)) then * write (22,'(/,4X,A)') Titleg * write (22,'(2x,''TREND-CYCLE'',2x,''SA SERIES'',8x, * $ ''TRANS. COMP.'',4x,''PREAD. COMP'')') * write (22,'(4(6X,G18.9))') * $ (trend(i), sa(i), cycle(i), 0.0d0, i = 1,Nz) * end if if (hpcycle .lt. 1) then CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) c call profiler(2,'leave Sigex line 3964') !DEC$ end if CUNX#end if return end if ireg = 0 if (HPcycle.eq.1) then call HPOUTPUT(lamd,compHP,hptrend,hpcyc,hpregt,hpregc,totcyc, $ ireg,lfor,Out,Pg,HPper,HPlan,HPpar,HPcycle,km,hpth,varwnp, $ VfcBc,VfcM,VfBc,WithoutVf,seBc,seM,iter,MQ,D+BD) else if (HPcycle .eq. 2) then call HPOUTPUT(lamd,compHP,hptrend,hpcyc,hpregt,hpregc,totcyc, $ ireg,lfor,Out,Pg,HPper,HPlan,HPpar,HPcycle,km,hpth,varwna, $ VfcBc,VfcM,VfBc,WithoutVf,seBc,seM,iter,MQ,D+BD) else if (HPcycle .eq. 3) then call HPOUTPUT(lamd,compHP,hptrend,hpcyc,hpregt,hpregc,totcyc, $ ireg,lfor,Out,Pg,HPper,HPlan,HPpar,HPcycle,km,hpth,1.0d0, $ VfcBc,VfcM,VfBc,WithoutVf,seBc,seM,iter,MQ,D+BD) end if * if ((pg.eq.0).and.(Iter.ne.0) .and. (Ioneout.eq.0) * $ .and. (out.eq.0)) then * fname = Ttlset(1:ntitle) // '.CHP' * if (lamd .eq. 1) then * subtitle = 'TOTAL CYCLICAL COMPONENT' * else * subtitle = 'TOTAL CYCLICAL FACTORS' * end if * call PLOTSERIES(fname,subtitle,totcyc,Nz,1,0.0d0) * write (17,9017) fname * end if 5005 continue CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(2,'Sigex') !DEC$ end if CUNX#end if end cc c c c Tpeaks: retorna si se detectan picos en el espectro ACF windowing usando Tukey c Solo esta calculado para las ventanas m=112, 79 y 43 c wSpeaks(i): 1:if thereis a Seasonal spectral peak for w=i*pi/6 Radians; 0 If there is not a peaks subroutine Tpeaks(H,m,MQ,TDpeaks,wSpeaks,Speaks,nSpeaks) implicit none c INPUT PARAMETERS integer m,MQ real*8 H(0:60) c OUTPUT PARAMETERS integer TDpeaks,wSpeaks(6),Speaks(6),nSpeaks c LOCAL PARAMETERS real*8 incHpi,incHmiddle,incHtd,incH integer indSmiddle(5),indPI,indTD,nIndSmiddle,i integer prob c do i=1,6 wSpeaks(i)=0 enddo prob=2 select case(prob) case(1) !Test at 99% select case(m) case(112) incHpi=5.51d0 incHmiddle=3.86d0 incHtd=incHmiddle case(79) incHpi=9.1d0 incHmiddle=3.86D0 incHtd=incHmiddle case default c incHtd=4.08d0 incHpi=8.82D0 incHmiddle=3.86D0 incHtd=incHmiddle end select case default !Test at 95% select case(m) case(112) incHpi=3.67d0 incHmiddle=2.7d0 incHtd=incHmiddle case(79) incHpi=4.45d0 incHmiddle=2.7D0 incHtd=incHmiddle case default incHpi=4.36D0 incHmiddle=2.7D0 incHtd=2.85d0 end select end select select case(m) case(112) indSmiddle(1)=10 indSmiddle(2)=20 indSmiddle(3)=29 indSmiddle(4)=38 indSmiddle(5)=48 nIndSmiddle=5 indTD=40 indPI=57 case(79) indSmiddle(1)=8 indSmiddle(2)=14 indSmiddle(3)=21 indSmiddle(4)=27 indSmiddle(5)=34 nIndSmiddle=5 indTD=29 indPI=40 case default indTD=-1 indPI=22 nIndSmiddle=0 select case(mq) case(6) indSmiddle(1)=8 indSmiddle(2)=15 nIndSmiddle=2 case(4) indTD=14 indSmiddle(1)=12 nIndSmiddle=1 case(3) indPI=-1 indSmiddle(1)=15 nIndSmiddle=1 case(1) indPI=-1 end select end select TDpeaks=-1 nSpeaks=0 if (indTD.gt.0) then incH=2*H(indTD)/(H(indTD+1)+H(indTD-1)) if (incH.gt.IncHtd) then TDpeaks=indTD end if end if do i=1,nIndSmiddle IncH=2*H(indSmiddle(i)) incH=incH/(H(indSmiddle(i)+1)+H(indSmiddle(i)-1)) if (incH.gt.incHmiddle) then Speaks(nSpeaks+1)=indSmiddle(i) nSpeaks=nSpeaks+1 wSpeaks(i)=1 end if enddo if (indPI.gt.0) then IncH=H(indPI)/H(indPI-1) if (incH.gt.incHpi) then nSpeaks=nSpeaks+1 sPeaks(nSpeaks)=indPI wSpeaks(MQ/2)=1 end if end if end c c c getTukeyPeaks: given a series(serie(1:nserie)) with its MQ return its spectrum(H), c the choosen Tukey window size(m) and c if it has got TD peaks (TDpeak) or seasonal peaks(Speaks(1:nSpeaks)) c Besides: wSpeaks(i): 1:if thereis a Seasonal spectral peak for w=i*pi/6 Radians; 0 If there is not a peaks subroutine getTukeyPeaks(serie,nz,mq,H,m, $ TDpeak,wSpeaks,Speaks,nSpeaks) implicit none c INPUT real*8 serie(*) integer nz,mq c OUTPUT real*8 H(0:120) integer m,TDpeak,Speaks(6),nSpeaks,wSpeaks(6) c LOCAL real*8 window(0:120) integer iwindow,i c iwindow=2 !Tukey TDpeak=-1 nSpeaks=0 if ((MQ.ne.12).and.(nz.ge.60)) then m=44 else if ((nz.ge.120).and.(mq.eq.12)) then m=112 else if ((nz.gt.79).and.(mq.eq.12)) then m=79 else do i=1,6 wSpeaks(i)=0 enddo m=-1 return end if call getWind(iWindow,m,window) call covWind(H,m,serie,nz,window,60) call TPeaks(H,m,MQ,TDpeak,wSpeaks,Speaks,nSpeaks) end cc cc cc graph: 1: write graph files; 0:do not write graph files c OUTPUT: c picos(i,1)='A' seasonal spectral peaks found with AR(30) for w=i*PI/6; c ='-' Not Seas peak with AR(30) for w=i*PI/6; c picos(i,2)='T' seasonal spectral peaks found with Tukey for w=i*PI/6; c ='-' Not Seas peak with Tukey for w=i*PI/6; c picos(7,1)='A' TD peak found with AR(30) c ='-' No TD peak found with AR(30) c picos(7,2)='T' TD peak found with Tukey c ='-' No TD peak found with Tukey c graph: Graph Files are written if graph=1 c ndiffer: numero de veces que se diferencia la serie subroutine SpectrumComputation(serie,nserie,mq,cname,shortName, $ graph,ndiffer, $ picos,totalSeasPeaks) implicit none INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' c INPUT PARAMETERS c integer nserie,mq integer graph,ndiffer double precision serie(nserie) character cname*(20),shortName*2 c OUTPUT PARAMETERS character*2 picos(7) integer totalSeasPeaks c OUTPUT FILES: c 'SPECAR'+shortName+'.T3' => 'AR(30) Spectral Peaks of '+ cname c 'SPECSM'+shortName+'.T3' => 'SMOOTHING HISTOGRAM M=4 of '+cname c 'SPECW'+shortName+'.T3' => 'ACF WINDOWING OF '+cname c c c INTERNAL PARAMETERS integer nARpeaks_TD,nARpeaks_S,nTpeaks_s integer ARpeaks_TD(6),ARpeaks_S(6) integer Tpeaks_TD,Tpeaks_s(6),wTpeaks_s(6) real*8 pARpeaks_TD(6),pARpeaks_S(6) real*8 pTpeaks_TD,pTpeaks_s(6),mv(14) integer i,j,dm,iwin,k,ndserie integer SeasTukeyPeaks,SeasARpeaks double precision Szz(nfrq),ow(nfrq), $ H(nw2),dserie(nserie),Xmean c double precision smoothHist(0:mp),transf(0:mp) external getWindN character*36 getWindN character fname*30,subtitle*50,name*36,tmp*8 integer Istrlen external Istrlen c seasTukeyPeaks=0 seasARpeaks=0 ndserie=nserie do i=1,ndserie dserie(i)=serie(i) enddo do j=1,ndiffer ndserie=ndserie-1 do i=1,ndserie dserie(i)=dserie(i+1)-dserie(i) enddo enddo do i = 1,nfrq Szz(i) = 0.0d0 end do nARpeaks_TD=0 nARpeaks_S=0 if ((nDserie.ge.60.and.mq.ne.12).or.(nDserie.ge.80)) then call GetPeaks(Dserie,nDserie,mq,Szz,ow, $ ARpeaks_TD,nARpeaks_TD,pARpeaks_TD, $ ARpeaks_S,nARpeaks_S,pARpeaks_S,0) * if (graph.eq.1) then *cdos * fname='AR\\SPECAR'// shortname(1:istrlen(shortName))//'.T3' *cunix *cunix fname='AR/SPECAR'// shortname(1:istrlen(shortName))//'.T3' * k=min(30,nDserie-1) * write(tmp,2000) k * 2000 format(i2) * subtitle = 'AR('//tmp(1:istrlen(tmp))//') Spectral Peaks of ' * $ //cname(1:istrlen(cname)) * call PLOTSPCT(fname,subtitle,Szz,nfrq,ARpeaks_TD,nARpeaks_TD, * $ mq,-20.0d0,1) * end if end if c m=4 !the smoothing index c call getHist(Dserie,nDserie,transf) c call smoothH(transf,(nDserie/2),m,smoothHist) c fname = 'SPECSM'//shortName(1:istrlen(shortName))//'.T3' c subtitle = 'SMOOTHED HISTOGRAM M = 4 of ' c $ //cname(1:istrlen(cname)) c call PLOTSPECTRUM(fname,subtitle,smoothHist, c $ (nDserie/2)+1,mq,-10.0d0,1) c c now compute the spectrum with windowing cc c dm=100 c dm=min(dm,nDserie-1) !to avoid an underdetermined system c iwin = 2 c call Windowin(1,iwin,smoothHist,dm,Dserie,nDserie,1) iwin = 2 call Smeadl(Dserie,1,nDserie,nDserie,Xmean) call getTPeaks(Dserie,nDserie,mq,H,dm,pTpeaks_TD,pTpeaks_s,mv) c call getTukeyPeaks(Dserie,nDserie,mq, c $ H,dm,Tpeaks_TD,wTpeaks_s,Tpeaks_s,nTpeaks_s) * if ((dm.gt.0).and.(graph.eq.1)) then * name = getWindN(iwin) *cdos * write(fname,2001)'tukey\\SPW',iwin, * $ shortName(1:istrlen(shortName)),'.T3' *cunix *cunix write(fname,'(A,i1,a,a)')'tukey/SPW',iwin, *cunix $ shortName(1:istrlen(shortName)),'.T3' * 2001 format(A,i1,a,a) * write(tmp,2002) dm * 2002 format(i3) * subtitle = 'ACF Windowing ' //name(1:istrlen(name))// ' of ' * $ // cname(1:istrlen(cname)) // ' M = '// tmp * call PLOTSPECTRUM(fname,subtitle,H,(dble(dm)/2.0d0)+1.0d0, * $ mq,-10.0d0,1) * end if if ((nDserie.ge.60.and.mq.ne.12).or.(nDserie.ge.80)) then call rellPico2(pARpeaks_s,pARpeaks_TD,pTpeaks_s,pTpeaks_TD, $ mv,mq,dm,seasARpeaks,seasTukeyPeaks,picos) else do i=1,7 picos(i)='nc' enddo end if totalSeasPeaks=SeasTukeyPeaks+SeasARpeaks end subroutine cc c New Spectrum c cc C C C OUTPUT CROSS-CORRELATION TABLES C C Modified by REG on 30 Aug 2005 to create a new subroutine based C on sigex() inline code that output the cross-correlation tables. C This inline code has been modified to handle repeated code C as subroutines. These new supporting subroutines C follow below. C Modified by REG on 02 May 2006 to not print seasonal C cross-correlation statistics when seasonal component not present. C subroutine putCrossTables( bseps, bsepc, bsepi, bsesc, bsesi, & bseci, ncycth, noserie, notAlt, & crciem, crcier, crpcem, crpcer, & crpiem, crpier, crpsem, crpser, & crscem, crscer, crsiem, crsier, & varwnc, qt1 ) implicit none integer ncycth, noserie real*8 bseps, bsepc, bsepi, bsesc, bsesi, bseci integer mc parameter (mc = 0) real*8 crciem(-mc:mc),crcier(-mc:mc),crpcem(-mc:mc), $ crpcer(-mc:mc),crpiem(-mc:mc),crpier(-mc:mc), $ crpsem(-mc:mc),crpser(-mc:mc),crscem(-mc:mc), $ crscer(-mc:mc),crsiem(-mc:mc),crsier(-mc:mc) real*8 varwnc, qt1 logical notAlt integer nstar real*8 hcross, kcross character subtitle*60, cblank*10 C include 'cross.i' include 'hspect.i' include 'estb.i' include 'sform.i' include 'stream.i' include 'transcad.i' * include 'indhtml.i' logical dpeq cblank = ' ' nstar = 0 write (Nio,2000) 2000 format(/,12x,'CROSSCORRELATION BETWEEN STATIONARY', $ ' TRANSFORMATION OF ESTIMATORS',/) if ( notAlt ) then write (Nio,2001) 'SE ' else write (Nio,2001) 'Var.' end if 2001 format(35X,'ESTIMATOR',12X,'ESTIMATE',8x,A4,/) C C Output first part of cross correlation table C if ( npsins .gt. 1 ) then call putCrossTbl1( bseps, nstar, crpser(0), crpsem(0), $ 'TREND-CYCLE/SEASONAL ' ) if (qt1.ne.0.0d0) then call putCrossTbl1( bsesi, nstar, crsier(0), crsiem(0), $ 'SEASONAL/IRREGULAR ' ) end if end if if (qt1.ne.0.0d0) then call putCrossTbl1( bsepi, nstar, crpier(0), crpiem(0), $ 'TREND-CYCLE/IRREGULAR ' ) end if if ( notAlt .and. varwnc.gt.1.0D-10 .and. & ((ncycth.gt.0) .or. (Ncyc.gt.1)) ) then if ( npsins .gt. 1 ) then write(subtitle,2002)'SEASONAL',transLcad(1:ntransLcad), & cblank(1:(26-(ntransLcad+9))) call putCrossTbl1( bsesc, nstar, crpser(0), crscem(0), $ subtitle(1:26)) end if write(subtitle,2002)'TREND-CYCLE',transLcad(1:ntransLcad), & cblank(1:(26-(ntransLcad+12))) call putCrossTbl1( bsepc, nstar, crpcer(0), crpcem(0), $ subtitle(1:26)) c call putCrossTbl1( bsesi, nstar, crsier(0), crsiem(0), c $ 'SEASONAL/IRREGULAR ' ) if (qt1.ne.0.0d0) then write(subtitle,2002)'irregular',transLcad(1:ntransLcad), & cblank(1:(26-(ntransLcad+10))) call putCrossTbl1( bseci, nstar, crcier(0), crciem(0), $ subtitle(1:26)) end if end if 2002 format(A,a,'/',A) if (nstar .gt. 0) then write (Nio,2003) 2003 format(/,4x,'(**) : unreliable SE estimate.') end if if (noserie .eq. 0) then write (Nio,2004) 2004 format(//,10x,'For all pairs of components, the ', $ 'crosscorrelation between', $ /,10x,'the estimators and that between the estimates ', $ 'should be', $ /,10x,'broadly in agreement.') hcross = 2.5d0 * (1.0d0/SQRT(Nz*1.0d0)) kcross = 0.25d0 write (Nio,2005) 2005 format(/,4x,'COMPARISON BETWEEN THEORETICAL AND EMPIRICAL ', $ 'CROSSCORRELATION',/) C C Output second part of cross correlation table C if ( npsins .gt. 1 ) then call putCrossTbl2( crpser(0), crpsem(0), hcross, $ 'TREND-CYCLE/SEASONAL ' ) if (qt1.ne.0.0d0) then call putCrossTbl2( crsier(0), crsiem(0), hcross, $ 'SEASONAL/IRREGULAR ' ) end if end if if (qt1.ne.0.0d0) then call putCrossTbl2( crpier(0), crpiem(0), hcross, $ 'TREND-CYCLE/IRREGULAR' ) end if if (notAlt .and. (varwnc.gt.1.0D-10 .and. (ncycth.gt.0) $ .or. (Ncyc.gt.1)) ) then if ( npsins .gt. 1 ) then write(subtitle,2002)'SEASONAL',transLcad(1:ntransLcad), & cblank(1:(26-(ntransLcad+9))) call putCrossTbl2( crscer(0), crscem(0), hcross, $ subtitle(1:26)) end if write(subtitle,2002)'TREND-CYCLE',transLcad(1:ntransLcad), & cblank(1:(26-(ntransLcad+12))) call putCrossTbl2( crpcer(0), crpcem(0), hcross, $ subtitle(1:26)) if (qt1.ne.0.0d0) then write(subtitle,2002)transLcad(1:ntransLcad),'IRREGULAR', & cblank(1:(26-(ntransLcad+10))) call putCrossTbl2( crcier(0), crciem(0), hcross, $ subtitle(1:26)) end if end if C C Output third part of cross correlation table C write (Nio,2006) 2006 format(/) if ( npsins .gt. 1 ) then call putCrossTbl3( crpser(0), 'TREND-CYCLE', 'SEASONAL', kcross) if (qt1.ne.0.0d0) then call putCrossTbl3( crsier(0), 'SEASONAL', 'IRREGULAR', kcross ) end if end if if (qt1.ne.0.0d0) then call putCrossTbl3( crpier(0), 'TREND-CYCLE', 'IRREGULAR', & kcross ) end if if (notAlt .and. (varwnc.gt.1.0D-10 .and. & (ncycth.gt.0) .or. (Ncyc.gt.1)) ) then if ( npsins .gt. 1 ) then call putCrossTbl3( crscer(0), 'SEASONAL', & transLcad(1:ntransLcad), kcross ) end if call putCrossTbl3( crpcer(0), 'TREND-CYCLE', & transLcad(1:ntransLcad), kcross ) if (qt1.ne.0.0d0) then call putCrossTbl3( crcier(0), transLcad(1:ntransLcad), & 'IRREGULAR', kcross ) end if end if end if return end C C OUTPUT CROSS-CORRELATION TABLES C C Added by REG on 02 May 2006 to create a new subroutine C that outputs alternative cross-covariance table. C subroutine altCrossTables( ) implicit none real*8 bseps, bsepi, bsesi integer nstar include 'across.i' include 'hspect.i' include 'stream.i' bseps = DSQRT( seaTreVar ) bsepi = DSQRT( seaIrrVar ) bsesi = DSQRT( treIrrVar ) nstar = 0 write (Nio,1000) 1000 format(//,12x,'Crosscovariance Between Stationary', $ ' Transformation Of Estimators In Units Of Var(A)',/) write (Nio,1001)'SE ' 1001 format(35X,'Estimator',12X,'Estimate',8x,A4,/) C C Output first part of cross correlation table C if ( npsins .gt. 1 ) then call putCrossTbl1( bseps, nstar, seaTreEso, seaTreEst, $ 'Trend-Cycle/Seasonal ' ) call putCrossTbl1( bsesi, nstar, seaIrrEso, seaIrrEst, $ 'Seasonal/Irregular ' ) end if call putCrossTbl1( bsepi, nstar, treIrrEso, treIrrEst, $ 'Trend-Cycle/Irregular' ) if (nstar .gt. 0) then write (Nio,1002) 1002 format(/,4x,'(**) : unreliable SE estimate.') end if return end subroutine putCrossTbl1( bse, nstar, estimator, estimate, & crossAsc ) implicit none integer nstar real*8 bse, estimator, estimate character*(*) crossAsc include 'stream.i' logical dpeq c if (bseps .lt. 0.0d0) then c nstar = nstar + 1 c write (Nio,'(4X,''TREND-CYCLE/SEASONAL'',8X,F10.3,10X,F10.3, c $ 8x,a)') crpser(0), crpsem(0), ' (**) ' c else c write (Nio,'(4X,''TREND-CYCLE/SEASONAL'',8X,F10.3,10X,F10.3, c $ 4x,F10.3)') crpser(0), crpsem(0), bseps c end if c if ((ABS(crpser(0)).gt.1.0d-1).and. c $ (ABS(crpsem(0)).gt.1.0d-1).and. c $ (.not.dpeq(Sign(crpser(0),crpsem(0)),crpser(0)))) then c call setCcc('E') c end if if (bse .lt. 0.0d0) then nstar = nstar + 1 write (Nio,1001)crossAsc, estimator, estimate, ' (**) ' else write (Nio,1002)crossAsc, estimator, estimate, bse end if if ((ABS(estimator).gt.1.0d-1).and. $ (ABS(estimate).gt.1.0d-1).and. $ (.not.dpeq(Sign(estimator,estimate),estimator))) then call setCcc('E') end if 1001 format(4X,A26,7X,F10.3,10X,F10.3,8x,a) 1002 format(4X,A26,7X,F10.3,10X,F10.3,4x,F10.3) return end subroutine putCrossTbl2( estimator, estimate, hcross, crossAsc ) implicit none real*8 estimator, estimate, hcross character*(*) crossAsc include 'stream.i' c if (ABS(crpser(0)-crpsem(0)) .lt. hcross) then c write (Nio,'(4X,''TREND-CYCLE/SEASONAL : OK'')') c else c write (Nio, c $ '(4x,''TREND-CYCLE/SEASONAL : NOT IN AGREEMENT'',/,27x, c $ ''(Indicates model '',/,27x,''misspecification)'')') c end if if (ABS(estimator-estimate) .lt. hcross) then write (Nio,'(4X,A26,'' : OK'')') crossAsc else write (Nio,'(4x,a,'' : NOT IN AGREEMENT'',/,27x, $ ''(Indicates model misspecification)'')') $ crossAsc end if return end subroutine putCrossTbl3( estimator, cmpnt1Asc, cmpnt2Asc, kcross ) implicit none real*8 estimator, kcross character*(*) cmpnt1Asc, cmpnt2Asc include 'stream.i' c if (ABS(crpser(0)) .lt. kcross) then c write (Nio,'(4x,''TREND-CYCLE and SEASONAL component '', c $ ''estimators can be seen as approximately uncorrelated.'')') c else if ((kcross.le.ABS(crpser(0))) .and. c $ (ABS(crpser(0)).le.0.5d0)) then c write (Nio,'(4x,''TREND-CYCLE and SEASONAL component '', c $ ''estimators are mildly correlated.'')') c else if (ABS(crpser(0)) .gt. 0.5d0) then c write (Nio,'(4x,''MMSE estimation induces substantial '', c $ ''correlation between the estimators'',/,4x, c $ ''of the TREND-CYCLE and SEASONAL components.'')') c end if if (ABS(estimator) .lt. kcross) then write (Nio,1001) cmpnt1Asc, cmpnt2Asc else if ((kcross.le.ABS(estimator)) .and. $ (ABS(estimator).le.0.5d0)) then write (Nio,1002) cmpnt1Asc, cmpnt2Asc else if (ABS(estimator) .gt. 0.5d0) then write (Nio,1003) cmpnt1Asc, cmpnt2Asc end if 1001 format(4x,A,' and ',A,' component estimators', $ ' can be seen as approximately uncorrelated.') 1002 format(4x,A,' and ',A,' component estimators', $ ' are mildly correlated.') 1003 format(4x,'MMSE estimation induces substantial ', $ 'correlation between the estimators',/,4x, $ 'of the ',A,' and ',A,' components.') return end cc c cc subroutine OUTPSIES(titleg,nFilt,PSIEP,PSIEA,PSIES,PSIUE,PSIEC, $ PsieInic,PsieFin) integer nFilt,PsieInic,PsieFin character titleg*80 real*8 PSIEP(*),PSIEA(*),PSIES(*),PSIUE(*),PSIEC(*) c external functions integer istrlen external istrlen c Local variables integer i include 'stream.i' write (37,1001) titleg(1:istrlen(titleg)) write (37,1002) do i=nFilt+PsieInic+1,nFilt+PsieFin+1 write (37,1003) i-(nFilt+1),PSIEP(i),PSIEA(i), $ PSIES(i),PSIUE(i),PSIEC(i) end do 1001 format('"',A,'"') 1002 format(' LAG',12X,'P',14X,'N',14X,'S',14X,'U',14X,'C') 1003 format(I4,5X,5(F14.11,X)) return end subroutine sig.i0000664006604000003110000000065214521201567011133 0ustar sun00315stepsC C... Variables in Common Block /sig/ ... integer SQG,HAR,FORTR,ILAM,NA,PG,NOADMISS,OUT,ITER,L,NDEC, $ BIAS,INOADMISS,RSA,NHTOFIX character TTLSET*80 real*8 SQF,DOF,TIME,ZVAR,SEK,EPSPHI,RMOD,MAXBIAS common /sig/ TTLSET,SQF,DOF,TIME,ZVAR,SEK,EPSPHI,RMOD,MAXBIAS, $ SQG,HAR,FORTR,ILAM,NA,PG,NOADMISS,OUT,ITER,L, $ NDEC,BIAS,INOADMISS,RSA,NHTOFIX sigsub.f0000664006604000003110000022757114521201567011655 0ustar sun00315stepsC Last change: REG 27 Apr 2006 and 5 Jan 2006 C Previous change: BCM 4 Oct 2002 1:59 pm C C THIS SUBROUTINE PERFORMS THE ALLOCATION OF AR-NONSEASONAL ROOTS C TO THE COMPONENTS C C INPUT PARAMETERS C C P : DIMENSION OF AR NONSEASONAL MODEL (NUMBER OF ROOTS) C IMZ : IMAGINARY PART OF ROOTS C REZ : REAL PART OF ROOTS C AR : PERIOD OF THE ROOTS C EPSHI : IS A CONSTANT (SEE MANUAL) C MQ : FREQUENCY C CYCNS : NON-STATIONARY CYCLE DENOMINATOR (true signs) C NCYCNS : DIMENSION OF CYCNS C PSINS : NON-STATIONARY SEASONAL DENOMINATOR (true signs) C NPSINS : DIMENSION OF PSINS C CYCS : STATIONARY CYCLE DENOMINATOR (true signs) C NCYCS : DIMENSION OF CYCS C CHINS : NON-STATIONARY TREND DENOMINATOR (true signs) C NCHINS : DIMENSION OF CHINS C CHIS : STATIONARY TREND DENOMINATOR (true signs) C NCHIS : DIMENSION OF CHIS C MODUL : MODULUS OF THE ROOTS C PSIS : STATIONARY SEASONAL DENOMINATOR (true signs) C NPSIS : DIMENSION OF PSIS C subroutine F1RST(p,imz,rez,ar,epsphi,mq,cycns,ncycns,psins,npsins, $ cycs,ncycs,chins,nchins,chis,nchis,modul,psis, $ npsis,rmod,root0c,rootPIc,rootPIs,IsCloseTOTD) C C C.. Implicits .. implicit none C C.. Formal Arguments .. integer p,mq,ncycns,npsins,ncycs,nchins,nchis,npsis real*8 imz(64),rez(64),ar(64),epsphi,cycns(5),psins(27),cycs(17), $ chins(8),chis(5),modul(64),psis(16),rmod logical root0c,rootPIc,rootPIs,IsCloseToTD C C.. Local Scalars .. integer i,intocycle,neps,ny real*8 k,RmodS C C.. Local Arrays .. real*8 dum(80) C C.. External Calls .. logical IsCloseTD external CONV,IsCloseTD C C.. Intrinsic Functions .. intrinsic ABS, DBLE C C ... Executable Statements ... C C if (p .eq. 0) return C C TALE CHECK E' CORRETTO PERCHE' LE RADICI SONO IN ORDINE C PRIMA LE COMPLESSE POI LE REALI. DUNQUE SE LA PRIMA E' REALE C ALLORA SONO TUTTE REALI. C ny=2 if (nPSIns.gt.1 .or. nPSIs.gt.1) then rmodS=rmod else rmodS=0.9d0 end if if (-1.0d-13.lt.imz(1) .and. imz(1).lt.1.0d-13) then do i = 1,p dum(1) = 1.0d0 dum(2) = -rez(i) if (rez(i) .le. 0.0d0) then if (ABS(1.0d0+rez(i)) .lt. 1.0d-06) then if (mq .eq. 1) then rootPIc=.TRUE. call CONV(dum,2,cycns,ncycns,cycns,ncycns) else rootPIc=.TRUE. call CONV(dum,2,psins,npsins,psins,npsins) end if else if (mq .eq. 1) then rootPIc=.TRUE. call CONV(dum,2,cycs,ncycs,cycs,ncycs) else if (ABS(rez(i)) .ge. RmodS) then rootPIc=.TRUE. call CONV(dum,2,psis,npsis,psis,npsis) else rootPIc=.TRUE. call CONV(dum,2,cycs,ncycs,cycs,ncycs) end if else if (ABS(1.0d0-rez(i)) .lt. 1.0d-06) then call CONV(dum,2,chins,nchins,chins,nchins) else if (ABS(rez(i)) .ge. rmod) then call CONV(dum,2,chis,nchis,chis,nchis) else rootPIc=.TRUE. call CONV(dum,2,cycs,ncycs,cycs,ncycs) end if end do C C RADICI COMPLESSE C else dum(1) = 1.0d0 dum(2) = -2*rez(1) dum(3) = rez(1)**2 + imz(1)**2 if (mq .eq. 1) then if ((modul(1).gt.rmod) .and. $ (ABS(ar(1)).lt.360d0/dble(ny*MQ)))then if (ABS(modul(1)-1.0d0) .lt. 1.0d-6) then call CONV(dum,3,chins,nchins,chins,nchins) else call CONV(dum,3,chis,nchis,chis,nchis) end if else if (ABS((modul(1)-1.0d0)) .lt. 1.0d-6) then call CONV(dum,3,cycns,ncycns,cycns,ncycns) else call CONV(dum,3,cycs,ncycs,cycs,ncycs) end if endif else C C C k = DBLE(360/mq) i = 1 C C HERE WE INTRODUCE THE NEW USE OF EPSPHI C if ((mq.eq.12) .or. (mq.eq.6) .or. (mq.eq.4) .or. (mq.eq.2)) $ then c if (ABS(ar(1)) .le. epsphi) then if ((modul(1).gt.rmod) .and. $ (ABS(ar(1)).lt.360d0/dble(ny*MQ)))then if (ABS(modul(1)-1.0d0) .lt. 1.0d-6) then call CONV(dum,3,chins,nchins,chins,nchins) else call CONV(dum,3,chis,nchis,chis,nchis) end if else * if (mq .eq. 12) then * neps = 3 * end if * if (mq .eq. 6) then * neps = 4 * end if * if (mq .eq. 4) then * neps = 6 * end if * if (mq .eq. 3) then * neps = 8 * end if * if (mq .eq. 2) then * neps = 10 * end if if ((mq.ne.12) .and. (mq.ne.6) .and. (mq.ne.4) .and. $ (mq.ne.3).and. (mq.ne.2) .and. (mq.ne.1)) then neps = 3 end if neps = 1 intocycle = 1 do i = 1,mq/2 if (mq.ne.12 .or. i.ne.4 .or. epsphi.le.2.5d0) then if ((ABS(ar(1)).gt.((k*i)-(neps*epsphi))) .and. $ (ABS(ar(1)).lt.((k*i)+(neps*epsphi))).and. $ modul(1).ge.RmodS) then intocycle = 0 end if else if ((ABS(ar(1)).gt.((k*i)-(neps*2.5d0))) .and. $ (ABS(ar(1)).lt.((k*i)+(neps*2.5d0))).and. $ modul(1).ge.RmodS) then intocycle = 0 end if end if end do if (intocycle .eq. 0) then if (ABS(modul(1)-1.0d0) .lt. 1.0d-6) then call CONV(dum,3,psins,npsins,psins,npsins) else call CONV(dum,3,psis,npsis,psis,npsis) end if else if (ABS(modul(1)-1.0d0) .lt. 1.0d-6) then IsCloseToTD=IsCloseTD(ar(1),MQ) call CONV(dum,3,cycns,ncycns,cycns,ncycns) else IsCloseToTD=IsCloseTD(ar(1),MQ) call CONV(dum,3,cycs,ncycs,cycs,ncycs) end if end if C C HERE ENDS THE NEW USE OF EPSPHI C else if ((ABS(ar(1)).le.k-epsphi).or. $ (ABS(ar(1)).ge.k+epsphi).or. $ (modul(1).lt.RmodS)) then if (ABS(modul(1)-1.0d0) .lt. 1.0d-6) then call CONV(dum,3,cycns,ncycns,cycns,ncycns) else call CONV(dum,3,cycs,ncycs,cycs,ncycs) end if else if (ABS(modul(1)-1.0d0) .lt. 1.0d-6) then call CONV(dum,3,psins,npsins,psins,npsins) else call CONV(dum,3,psis,npsis,psis,npsis) end if end if C C C if (p .le. 2) return dum(1) = 1.0d0 dum(2) = -rez(3) if (rez(3) .gt. 0.0d0) then if (ABS(1.0d0-rez(3)) .lt. 1.0d-06) then call CONV(dum,2,chins,nchins,chins,nchins) return end if if (ABS(rez(3)) .ge. RmodS) then call CONV(dum,2,chis,nchis,chis,nchis) else root0c=.TRUE. call CONV(dum,2,cycs,ncycs,cycs,ncycs) end if else if (ABS(1.0d0+rez(3)) .lt. 1.0d-06) then if (mq .eq. 1) then root0c=.TRUE. call CONV(dum,2,cycns,ncycns,cycns,ncycns) else root0c=.TRUE. call CONV(dum,2,psins,npsins,psins,npsins) end if else if (mq .eq. 1) then root0c=.TRUE. call CONV(dum,2,cycs,ncycs,cycs,ncycs) return end if if (ABS(rez(3)) .ge. rmod) then root0c=.TRUE. call CONV(dum,2,psis,npsis,psis,npsis) else if (ABS(rez(3)) .lt. rmod) then root0c=.TRUE. call CONV(dum,2,cycs,ncycs,cycs,ncycs) end if end if end if return end c c logical function isCloseTD(w,MQ) implicit none c INPUT PARAMETERS real*8 w integer MQ c LOCAL PARAMETERS real*8 dist,wtd1,wtd2 real*8 dist1,dist2,pi c------------------------------------- pi=3.14159265358979D0 IsCloseTD=.FALSE. Dist=-1.0d0 c------------------------------------- if (MQ.eq.12) then Wtd1=0.6964D0*180.0d0 Dist1=0.5d0*(Wtd1-2.0d0*180.0d0/3.0d0) Dist2=(0.12d0/pi)*180.0 c wtd2=0.8640D0*180.0D0 C if ((abs(w).gt. (Wtd1-dist1)).and.(abs(w).lt.(Wtd1+dist2))) then if ((abs(w).lt. (0.732d0*180.0d0)).and. $ (abs(w).gt.(0.680556d0*180.0d0))) then IsCloseTD=.TRUE. end if c------------------------------------- else if (MQ.eq.4) then Dist=0.02D0*180.0D0 WTD1=0.0892D0*180.0D0 c Wtd2=0.1785D0*180.0D0 if (abs(abs(w)-wtd1).lt.Dist) then isCloseTD=.TRUE. end if end if c------------------------------------- return end C C THIS SUBROUTINE COMPUTES TOTAL ESTIMATION ERROR, REVISION ERRORS C STANDARD ERROR OF RECENT ESTIMATES AND FORECASTS, AND OF THE RATES OF C GROWTH C C INPUT PARAMETERS C C MQ : FREQUENCY C PSIEP : PSI-WEIGTHS (B,F) OF TREND C PSIEA : PSI-WEIGTHS (B,F) OF SEASONALLY ADJUSTED C PSIEC : PSI-WEIGTHS (B,F) OF CYCLE C FEETRE : ACF OF FINAL ESTIMATION ERROR OF TREND C FEEADJ : ACF OF FINAL ESTIMATION ERROR OF SEASONALLY ADJUSTED C FEECYC : ACF OF FINAL ESTIMATION ERROR OF CYCLE C PSIES : PSI-WEIGTHS (B,F) OF SEASONAL C PSITOT : PSI-WEIGTHS (B,F) TOTAL C Z : ORIGINAL SERIES AND FORECAST C TREND : TREND COMPONENT C SA : SEASONALLY ADJUSTED SERIES C CYCLE : CYCLICAL COMPONENT C SC : SEASONAL COMPONENT C NFILT : DIMENSION OF PSIEP,PSIES,PSIEC,PSIEA,PSITOT C SQF : STANDARD ERROR OF RESIDUALS C NZ : DIMENSION OF THE SERIES C MQ2 : 2*FREQUENCY C LAMD : 0 TRANSFORMED DATA, 1 NOT TRANSFORMED C TITLE : NAME OF THE SERIES C NCYC : DIMENSION OF CYCLE DENOMINATOR C NPSI : DIMENSION OF SEASONAL DENOMINATOR C LFOR : DIMENSION OF FORECAST C NOSERIE : 1 NOSERIE INPUTED, 0 OTHERWISE C IR : IRREGULAR COMPONENT C OZ : ORIGINAL SERIES C PG : 0 FILES FOR GRAPH, 1 NO FILES C OUT : CONTROL OF PRINTOUT C ITER : ITERATION MODE (IF <> 0 NOPRINT ON THE SCREEN) C NOADMISS : 2 APPROXIMATED MODEL, NO APPROXIMATION OTHERWISE C C subroutine SECOND(sigpt1,sigat1,nlen,sigptac,sigatac, $ sigptaf,sigataf,sigptmq,sigatmq,sigxtmq,rcetre, $ rceadj,teetre,teeadj,nelen,mq,psiep,psiea,psiec, $ feetre,feeadj,feecyc,psies,psitot,z,trend,sa, $ cycle,sc,nfilt,sqf,nz,mq2,lamd,title,ncyc,npsi, $ lfor,noserie,ir,oz,pg,out,iter,bias, C $ forbias,forsbias,fortbias,tramo,maxbias,smtr, $ forbias,forsbias,fortbias,tramo, $ ncycth,ioneout,nthclass,ntcclass,ntfclass, $ overmaxbias,Nchcyc,alpha,rceCyc,IsCloseToTD, $ varwnc) C C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer nfl parameter (nfl = mp*2) real*8 maxbias parameter (maxbias=0.5d0) C INCLUDE 'seatop.cmn' C C.. Formal Arguments .. integer nlen,nelen,mq,nfilt,nz,mq2,lamd,ncyc,npsi,lfor,noserie, C $ nannua,pg,out,iter,bias,tramo,smtr,ncycth,ioneout, $ pg,out,iter,bias,tramo,ncycth,ioneout, $ nthclass,ntcclass,ntfclass,overmaxbias,Nchcyc character title*80 real*8 sigpt1(0:24),sigat1(0:24),sigptac(24),sigatac(24), $ sigptaf(24),sigataf(24),sigptmq(2),sigatmq(2),sigxtmq(2), $ rcetre(0:12),rceadj(0:12),teetre(0:12),teeadj(0:12), $ psiep(nfl),psiea(nfl),psiec(nfl),feetre(0:12),feeadj(0:12), $ feecyc(0:12),psies(nfl),psitot(nfl),z(*),trend(mpkp), $ sa(mpkp),cycle(mpkp),sc(mpkp),sqf,ir(mpkp), $ oz(mpkp),forbias(kp),forsbias(kp),fortbias(kp), & alpha,dvec(1),rcecyc(0:12),varwnc logical IsCloseToTD C C.. Local Scalars .. integer i,ii,j,k,lon,ndiv,nstart,ntitle,nyr,vabs character fname*30,subtitle*50 logical bool,noseas,noS,noC real*8 aa,ac,amean,ap,at,aux1,aux2,ba, $ bias1c,bias2c,bias3c,bpp,bser,c1,c2,c3,ca,cp,pamean,pmean, $ por,ppmean,psmean,pzmean,rfactse,sefea,sefec,sefep,smean, $ v3fd,v3fp,vca real*8 vcp,vdd,vfa,vfp,vmi,vmig,vmigu,vpc,vpp,vraa,vrpp,vx,xx, $ ymax,ymin,zmean C C.. Local Arrays .. real*8 adum(12),atdum(12),bdum(12),btdum(12), $ splot(2*kp+1,3),st1d(0:13),st1p(0:13),st3d(0:13),st3p(0:13), $ stdf(12),stdt(12),stpf(12),stpt(12),teecyc(0:12),tmp(kp), $ tmp1(kp),tmp2(kp),vreadj(0:5),vrecyc(0:5),vresea(0:12), $ vretre(0:5) C C.. External Functions .. real*8 DMEAN integer ISTRLEN real*8 RAIZ external DMEAN, ISTRLEN, RAIZ C C.. External Calls .. external ABIASC, BIASCORR, Seasign, SMRFACT, USRENTRY C LINES OF CODE ADDED FOR X-13A-S : 2 logical dpeq external dpeq C END OF CODE BLOCK C C.. Intrinsic Functions .. intrinsic EXP, LOG, SQRT include 'sfcast.i' include 'serrlev.i' include 'sesfcast.i' include 'stream.i' include 'revs.i' * include 'indhtml.i' include 'transcad.i' C C ... Executable Statements ... C * write(*,*)' lfor = ',lfor lon = mq * do k = 0,lon * rcetre(k) = 0.0d0 * rceadj(k) = 0.0d0 * rcecyc(k) = 0.0d0 * do i = k+1,nfilt * rcetre(k) = rcetre(k) + psiep(i)*psiep(i-k) * rceadj(k) = rceadj(k) + psiea(i)*psiea(i-k) * rcecyc(k) = rcecyc(k) + psiec(i)*psiec(i-k) * end do * end do * do k = 1,lon * if (rcetre(0) .gt. 1.0d-13) then * rcetre(k) = rcetre(k) / rcetre(0) * end if * if (rceadj(0) .gt. 1.0d-13) then * rceadj(k) = rceadj(k) / rceadj(0) * end if * if (rcecyc(0) .gt. 1.0d-13) then * rcecyc(k) = rcecyc(k) / rcecyc(0) * end if * end do C C COMPUTE TOTAL ESTIMATION ERROR (ACF) C teeadj(0) = feeadj(0) + rceadj(0) teecyc(0) = feecyc(0) + rcecyc(0) teetre(0) = feetre(0) + rcetre(0) C do i = 1,lon teetre(i) = feetre(i)*feetre(0) + rcetre(i)*rcetre(0) teeadj(i) = feeadj(i)*feeadj(0) + rceadj(i)*rceadj(0) teecyc(i) = feecyc(i)*feecyc(0) + rcecyc(i)*rcecyc(0) end do C do k = 1,lon if (teetre(0) .gt. 1.0d-13) then teetre(k) = teetre(k) / teetre(0) end if if (teeadj(0) .gt. 1.0d-13) then teeadj(k) = teeadj(k) / teeadj(0) end if if (teecyc(0) .gt. 1.0d-13) then teecyc(k) = teecyc(k) / teecyc(0) end if end do call USRENTRY(feetre,0,lon,0,12,1102) call USRENTRY(rcetre,0,lon,0,12,1103) call USRENTRY(teetre,0,lon,0,12,1104) call USRENTRY(feeadj,0,lon,0,12,1105) call USRENTRY(rceadj,0,lon,0,12,1106) call USRENTRY(teeadj,0,lon,0,12,1107) nelen = lon if (Out .eq. 0) then C C C OUTPUT RESULTS OF -ACF- OF ESTIMATION ERRORS C C 7000 format ( $ ///,' PART 3 : ERROR ANALYSIS',/,' -----------------------',//) write (Nio,7000) end if C C if (Lfinit) then C Modified by REG on 01/05/2006 write (Nio,7001) infMSEs(3), infMSEs(2), ' (SEMI-INFINITE)', $ infRevs(3), infRevs(2), $ curMSEs(3), curMSEs(2) 7001 format ( $ //,30x,'ESTIMATION ERROR VARIANCE'/,30x,' (In units of Var(a))' $ ,//34x,'TREND-CYCLE',2x,'SA SERIES',//2x,'FINAL ESTIMATION' $ ,15x,f6.3,10x,f6.3,/,2x,'ERROR',a,//2x,'REVISION IN CON-' $ ,15x,f6.3,10x,f6.3,/,2x,'CURRENT ERROR',//2x,'TOTAL ESTIMATION' $ ,15x,f6.3,10x,f6.3,/,2x,'ERROR (CONCURRENT',/,2x,'ESTIMATOR)') else if (out.eq.0)THEN 7003 format ( $ //,' ',25x,'FINAL ESTIMATION ERROR',21x,'REVISION IN', $ ' CONCURRENT ESTIMATOR'//' ACF (LAG)',12x,' TREND-CYCLE ',5x, $ 'SA SERIES',14x,' TREND-CYCLE ',4x,'SA SERIES'/) write (Nio,7003) do i = 1,lon 7004 format (1x,i7,2x,12x,f8.3,10x,f8.3,17x,f8.3,8x,f8.3) write (Nio,7004) i, feetre(i), feeadj(i), rcetre(i), rceadj(i) end do 7005 format (/,' ','VAR.(*)',2x,12x,f8.3,10x,f8.3,17x,f8.3,8x,f8.3) write (Nio,7005) feetre(0), feeadj(0), rcetre(0), rceadj(0) 7006 format ( $ ////6x,'TOTAL ESTIMATION ERROR (CONCURRENT ESTIMATOR)',/6x, $ '---------------------------------------------',//8x,'ACF (LAG)' $ ,5x,' TREND-CYCLE ',4x,'SA SERIES'/) write (Nio,7006) do i = 1,lon 7007 format (2x,i10,11x,f8.3,8x,f8.3) write (Nio,7007) i, teetre(i), teeadj(i) end do 7008 format (/,' ',6x,'VAR.(*)',9x,f8.3,8x,f8.3) write (Nio,7008) teetre(0), teeadj(0) write (Nio,7009) end if 7009 format (//,' ',' (*) IN UNITS OF VAR(A)') C C C COMPUTE THE VARIANCE OF REVISION FOR DIFFERENT PERIODS C vretre(0) = rcetre(0) vrecyc(0) = rcecyc(0) vreadj(0) = rceadj(0) do i = 1,5 vretre(i) = vretre(i-1) vrecyc(i) = vrecyc(i-1) vreadj(i) = vreadj(i-1) nstart = nfilt + 1 - mq*(i-1) do j = 1,mq vretre(i) = vretre(i) - psiep(nstart-j)*psiep(nstart-j) vrecyc(i) = vrecyc(i) - psiec(nstart-j)*psiec(nstart-j) vreadj(i) = vreadj(i) - psiea(nstart-j)*psiea(nstart-j) end do end do do i=1,5 if ( vreadj(i) .lt. 1.0D-16) then vreadj(i)=0.0d0 end if if (vrecyc(i) .lt. 1.0D-16 ) then vrecyc(i)=0.0D0 end if if (vretre(i) .lt. 1.0D-16) then vretre(i)=0.0D0 end if end do C if (out .eq. 0) then 7016 format ( $ ///,' ','VARIANCE OF THE REVISION ERROR (*)',/,' ', $ '------------------------------',//' ADDITIONAL',12x, $ ' TREND-CYCLE ',4x,' SA SERIES'/' PERIODS'//) C write (Nio,7016) do i = 0,5 j = i * mq 7017 format (2x,i5,10x,2(7x,g11.4)) write (Nio,7017) j, vretre(i), vreadj(i) end do end if call USRENTRY(vretre,0,5,0,5,1515) call USRENTRY(vreadj,0,5,0,5,1516) C C COMPUTE THE REDUCTION IN THE STD. ERR. OF REVISION AFTER C ADDITIONAL YEARS (DISPLAY AND DON'T STORE) C if (out .eq. 0) then 7020 format ( $ ///,' ',' PERCENTAGE REDUCTION IN THE STANDARD ERROR', $ ' OF THE REVISION AFTER ADDITIONAL YEARS'/ $ ' (COMPARISON WITH CONCURRENT ESTIMATORS)'///) write (Nio,7020) end if C Modified by REG on 04/27/2006 and 01/05/2006 IF(Lfinit)then C---------------------------------------------------------------------- C Output alternate revisions after additional years. C---------------------------------------------------------------------- do i = 1,5 if (out .eq. 0) then write (Nio,7021) i, relRevs(3,i), relRevs(2,i) end if tmp(i)=relRevs(3,i) tmp1(i)=relRevs(2,i) end do else do i = 1,5 at = vretre(0) ac = vrecyc(0) aa = vreadj(0) if (at .gt. 1.0d-13) then at = (1.0-RAIZ(vretre(i)/vretre(0))) * 100.0 end if if (ac .gt. 1.0d-13) then ac = (1.0-RAIZ(vrecyc(i)/vrecyc(0))) * 100.0 end if if (aa .gt. 1.0d-13) then aa = (1.0-RAIZ(vreadj(i)/vreadj(0))) * 100.0 end if tmp(i) = at tmp1(i) = aa C---------------------------------------------------------------------- C Output SEATS revisions after additional years. C---------------------------------------------------------------------- if (out .eq. 0) then 7021 format (3x,'AFTER',i2,' YEAR',7x,g11.4,7x,g11.4) write (Nio,7021) i, at, aa end if end do C C Modified by REG on 01/05/2006 end if call setCovt1(tmp(1)) call setCovsa1(tmp1(1)) call setCovt5(tmp(5)) call setCovsa5(tmp1(5)) call USRENTRY(tmp,1,5,1,kp,1517) call USRENTRY(tmp1,1,5,1,kp,1518) C C COMPUTE THE VARIANCE OF REVISION ERROR FOR THE SEASONAL C do j = 0,mq vresea(j) = 0.0d0 end do if (npsi .ne. 1) then do i = 1,nfilt vresea(0) = vresea(0) + psies(i)*psies(i) end do do i = 1,mq vresea(i) = vresea(i-1) + psies(nfilt+i)*psies(nfilt+i) end do if (out .eq. 0) then 7023 format ( $ ///,' ','VARIANCE OF THE REVISION ERROR FOR THE ', $ 'SEASONAL COMPONENT (ONE YEAR AHEAD ADJUSTMENT)',/,' ', $ '---------------------------------------', $ '----------------------------------------------',// $ ' PERIODS AHEAD',10x,'VARIANCE (*)'/) write (Nio,7023) do i = 0,mq 7024 format (2x,i8,15x,g11.4) write (Nio,7024) i, vresea(i) end do end if call USRENTRY(vresea,0,mq,0,12,1519) C vpc = 0.0d0 do i = 0,mq-1 vpc = vpc + vresea(i) end do vpc = vpc / mq vpc = (1.0-SQRT(vresea(0)/vpc)) * 100.0 if (out .eq. 0) then 7025 format ( $ ///,' ','AVERAGE PERCENTAGE REDUCTION IN RMSE FROM', $ ' CONCURRENT ADJUSTMENT',g11.4) write (Nio,7025) vpc end if dvec(1)=vpc call USRENTRY(dvec,1,1,1,1,1520) end if if (out .eq. 0) then write (Nio,7009) end if C C C COMPUTE THE STANDARD ERROR OF RECENT ESTIMATE AND FORECAST C C TOTAL (SET@) AND DUE TO REVISION (SER@) C C C mq2 = lfor * mq2 = 2*mq Serc(-mq2) = 0.0d0 Serp(-mq2) = 0.0d0 Sera(-mq2) = 0.0d0 Sers(-mq2) = 0.0d0 do i = 1,nfilt-mq2 Serp(-mq2) = Serp(-mq2) + psiep(i)*psiep(i) Sera(-mq2) = Sera(-mq2) + psiea(i)*psiea(i) Sers(-mq2) = Sers(-mq2) + psies(i)*psies(i) Serc(-mq2) = Serc(-mq2) + psiec(i)*psiec(i) end do do k = -mq2+1,mq2 Serp(k) = Serp(k-1) + psiep(nfilt+k)*psiep(nfilt+k) Sera(k) = Sera(k-1) + psiea(nfilt+k)*psiea(nfilt+k) Sers(k) = Sers(k-1) + psies(nfilt+k)*psies(nfilt+k) Serc(k) = Serc(k-1) + psiec(nfilt+k)*psiec(nfilt+k) end do C do k = -mq2,mq2 Setp(k) = SQRT(feetre(0)+Serp(k)) * sqf Seta(k) = SQRT(feeadj(0)+Sera(k)) * sqf Sets(k) = SQRT(feeadj(0)+Sers(k)) * sqf Setc(k) = SQRT(feecyc(0)+Serc(k)) * sqf end do do k = -mq2,mq2 Serp(k) = SQRT(Serp(k)) * sqf Sera(k) = SQRT(Sera(k)) * sqf Sers(k) = SQRT(Sers(k)) * sqf Serc(k) = SQRT(Serc(k)) * sqf end do Seser(1) = 1.0d0 do i = 1,mq2-1 Seser(i+1) = Seser(i) + psitot(nfilt+1+i)*psitot(nfilt+1+i) end do do i = 1,mq2 Seser(i) = SQRT(Seser(i)) * sqf end do C if (noserie .eq. 1) return C call USRENTRY(trend,nz-mq2,nz,1,mpkp,1121) call USRENTRY(Setp,-mq2,0,-kp,kp,1122) call USRENTRY(Serp,-mq2,0,-kp,kp,1123) call USRENTRY(sa,nz-mq2,nz,1,mpkp,1124) call USRENTRY(Seta,-mq2,0,-kp,kp,1125) call USRENTRY(Sera,-mq2,0,-kp,kp,1126) call USRENTRY(sc,nz-mq2,nz,1,mpkp,1127) call USRENTRY(Sets,-mq2,0,-kp,kp,1128) call USRENTRY(Sers,-mq2,0,-kp,kp,1129) if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0 .and. ncyc.gt.1)) then call USRENTRY(cycle,nz-mq2,nz,1,mpkp,1144) call USRENTRY(Setc,-mq2,0,-kp,kp,1145) call USRENTRY(Serc,-mq2,0,-kp,kp,1146) end if sefep = SQRT(feetre(0)) * sqf sefea = SQRT(feeadj(0)) * sqf sefec = SQRT(feecyc(0)) * sqf Sefes = sefea dvec(1)=sefep call USRENTRY(dvec,1,1,1,1,1130) dvec(1)=sefea call USRENTRY(dvec,1,1,1,1,1131) dvec(1)=sefes call USRENTRY(dvec,1,1,1,1,1132) if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0 .and. ncyc.gt.1)) then dvec(1)=sefec call USRENTRY(dvec,1,1,1,1,1147) end if if (out .eq. 0) then if (lamd .eq. 0) then 7026 format ( $ //,' ',12x,'LOGS DECOMPOSITION OF THE SERIES: RECENT', $ ' ESTIMATES'/' ',12x,'---------------------------------------', $ '-----------'//1x,'PERIOD',5x,'SERIES ',22x,' TREND-CYCLE',37x, $ 'SA SERIES',//30x,'ESTIMATE',10x,'STANDARD ERROR',20x,'ESTIMATE' $ ,10x,'STANDARD ERROR'/46x,'TOTAL',6x,' OF REVISION',27x, $ 'TOTAL',6x,' OF REVISION'/) write (Nio,7026) else 7027 format ( $ //,' ',12x,'ADDITIVE DECOMPOSITION OF THE SERIES:', $ ' RECENT ESTIMATES'/' ',12x, $ '---------------------------------------','---------------'//1x, $ 'PERIOD',5x,'SERIES ',22x,' TREND-CYCLE',37x,'SA SERIES',//30x, $ 'ESTIMATE',10x,'STANDARD ERROR',20x,'ESTIMATE',10x, $ 'STANDARD ERROR'/46x,'TOTAL',6x,' OF REVISION',27x,'TOTAL' $ ,6x,' OF REVISION'/) write (Nio,7027) end if do i = -MAX(8,2*mq),0 j = nz + i 7028 format ( $ 2x,i4,2x,g11.4,7x,g11.4,4x,g11.4,4x,g11.4,12x,g11.4, $ 4x,g11.4,4x,g11.4) write (Nio,7028) $ i, z(j), trend(j), Setp(i), Serp(i), sa(j), Seta(i), $ Sera(i) end do end if if (out .eq. 0) then 7029 format ( $ //,' STANDARD ERROR OF',23x,g11.4,42x,g11.4,/' FINAL ESTIMATOR') write (Nio,7029) sefep, sefea end if c rober: 4/3 continuar por aqui if (out.eq.0 .or. lamd.ne.1) then c Nota:por que esta esta condicion aqui???! if ((out.ne.0) .and. (ITER .eq. 0) .and. (lamd.eq.0)) then goto 5000 else if (varwnc.lt.1.0D-10 .or. $ (ncycth.eq.0 .and. ncyc.eq.1)) then if (out.eq.0) then 7030 format ( $ /,/1x,'PERIOD',20x,'SEASONAL',//18x,'ESTIMATE',10x, $ 'STANDARD ERROR'/33x,'TOTAL',6x,' OF REVISION'/) write (Nio,7030) do i = -MAX(8,2*mq),0 j = nz + i 7031 format ( $ 2x,i4,7x,g11.4,4x,g11.4,4x,g11.4,12x,g11.4,4x,g11.4,4x,g11.4) write (Nio,7031) i, sc(j), Sets(i), Sers(i) end do 7032 format(//,' STANDARD ERROR OF',15x,g11.4,/,' FINAL ESTIMATOR') write (Nio,7032) Sefes end if else if (out.eq.0) then 7033 format ( $ /,/1x,'PERIOD',20x,'SEASONAL',45x,' TRANS. ',//18x,'ESTIMATE' $ ,10x,'STANDARD ERROR',20x,'ESTIMATE',10x,'STANDARD ERROR'/33x, $ 'TOTAL',6x,' OF REVISION',27x,'TOTAL',6x,' OF REVISION'/) write (Nio,7033) do i = -MAX(8,2*mq),0 j = nz + i write (Nio,7031) $ i, sc(j), Sets(i), Sers(i), cycle(j), Setc(i), Serc(i) end do 7034 format ( $ //,' STANDARD ERROR OF',10x,g11.4,42x,g11.4,/, $ ' FINAL ESTIMATOR') write (Nio,7034) Sefes, sefec end if end if end if C C if (out .eq. 0) then if (lamd .eq. 0) then 7035 format ( $ //,' ',12x,'FORECAST OF THE STOCHASTIC SERIES ', $ 'AND COMPONENTS (LOGS)'/,' ',12x, $ '----------------------------------','---------------------'/ $ /1x,'PERIOD',5x,'SERIES ',32x,' TREND-CYCLE',37x,'SA SERIES',// $ 10x,'FORECAST',8x,'S.E.',10x,'FORECAST',10x,'STANDARD ERROR' $ ,20x,'FORECAST',10x,'STANDARD ERROR'/56x,'TOTAL',6x, $ ' OF REVISION',27x,'TOTAL',6x,' OF REVISION'/) write (Nio,7035) else 7036 format ( $ //,' ',12x,'FORECAST OF THE STOCHASTIC SERIES ','AND COMPONENTS' $ /,' ',12x,'----------------------------------','--------------'/ $ /1x,'PERIOD',5x,'SERIES ',32x,' TREND-CYCLE',37x,'SA SERIES',// $ 10x,'FORECAST',8x,'S.E.',10x,'FORECAST',10x,'STANDARD ERROR' $ ,20x,'FORECAST',10x,'STANDARD ERROR'/56x,'TOTAL',6x, $ ' OF REVISION',27x,'TOTAL',6x,' OF REVISION'/) write (Nio,7036) end if end if c Ya se escribe antes c if (out .eq. 0) then c if (HTML .eq. 1) then c write (Nio,'("

    THE SE ARE THOSE OF THE TOTAL", c $ " ESTIMATION ERROR = REVISION ERROR AND ", c $ "FINAL ESTIMATION ERROR.

    ")') c else c write (Nio, c $'(/,4x,''THE SE ARE THOSE OF THE TOTAL ESTIMATION ERROR ='', c $/,4x,''REVISION ERROR AND FINAL ESTIMATION ERROR.'',/)') c end if c end if if (npsi .eq. 1) then do i = 1,mq2 if (IscloseToTD) then sa(nz+i) = z(nz+i) - cycle(nz+i) else sa(nz+i) = z(nz+i) end if end do C LINES OF CODE COMMENTED FOR X-13A-S : 1 C else if ((smtr.eq.0) .and. (ncyc.eq.1)) then C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 else if ((ncyc.eq.1)) then C END OF CODE BLOCK do i = 1,mq2 sa(nz+i) = trend(nz+i) end do end if call USRENTRY(z,nz+1,nz+mq2,1,mpkp,1133) call USRENTRY(Seser,1,mq2,1,kp,1134) call USRENTRY(sa,nz+1,nz+mq2,1,mpkp,1138) call USRENTRY(Seta,1,mq2,-kp,kp,1139) call USRENTRY(Sera,1,mq2,-kp,kp,1140) call USRENTRY(sc,nz+1,nz+mq2,1,mpkp,1141) call USRENTRY(Sets,1,mq2,-kp,kp,1142) call USRENTRY(Sers,1,mq2,-kp,kp,1143) if (varwnc.gt.1.0D-10 .and.(ncycth.gt.0 .and. ncyc.gt.1)) then call USRENTRY(cycle,nz+1,nz+mq2,1,mpkp,1170) call USRENTRY(Setc,1,mq2,-kp,kp,1171) call USRENTRY(Serc,1,mq2,-kp,kp,1172) end if if (Nsfcast .eq. 0) then call USRENTRY(trend,nz+1,nz+mq2,1,mpkp,1135) call USRENTRY(Setp,1,mq2,-kp,kp,1136) call USRENTRY(Serp,1,mq2,-kp,kp,1137) if (out .eq. 0) then 7037 format ( $ 2x,i4,2x,g11.4,2x,g11.4,4x,g11.4,4x,g11.4,4x,g11.4, $ 12x,g11.4,4x,g11.4,4x,g11.4) do i = 1,mq2 j = nz + i write (Nio,7037) $ i, z(j), Seser(i), trend(j), Setp(i), Serp(i), sa(j), $ Seta(i), Sera(i) end do end if else rfactse = Sqfsave / sqf do i = 1,mq2 Rfact(i) = Sfcast(i) / z(nz+i) end do call SMRFACT(Rfact,mq2,mq) if (out .eq. 0) then do i = 1,mq2 j = nz + i write (Nio,7037) $ i, Sfcast(i), Sesfcast(i), trend(j)*Rfact(i), $ Setp(i)*rfactse, Serp(i)*rfactse, sa(j), Seta(i), Sera(i) end do end if do i = 1,mq2 tmp(i) = trend(nz+i) * Rfact(i) tmp1(i) = Setp(i) * rfactse tmp2(i) = Serp(i) * rfactse end do call USRENTRY(tmp,1,mq2,1,kp,1135) call USRENTRY(tmp1,1,mq2,1,kp,1136) call USRENTRY(tmp2,1,mq2,1,kp,1137) end if if (varwnc.lt.1.0D-10 .or.(ncycth.eq.0 .and. ncyc.eq.1)) then if (out .eq. 0) then 7038 format ( $ //,' ',/1x,'PERIOD',20x,' SEASONAL',//18x,'FORECAST',10x, $ 'STANDARD ERROR',/33x,'TOTAL',6x,' OF REVISION'/) write (Nio,7038) end if if (out .eq. 0) then c rober: Nfscast no hace nada el codigo es el mismo para las 2 posibilidades del if c REVISAR!! if (Nsfcast .eq. 0) then do i = 1,mq2 j = nz + i 7039 format (2x,i4,7x,g11.4,4x,g11.4,4x,g11.4) write (Nio,7039) i, sc(j), Sets(i), Sers(i) end do else do i = 1,mq2 j = nz + i write (Nio,7039) i, sc(j), Sets(i), Sers(i) end do end if end if if ((out.eq.0) .and. (Nsfcast.eq.1)) then write (Nio,'(/,30x,''DUE TO THE APPROXIMATION, THE S.E.'',/, $ 30x,''OF THE COMPONENT MAY BE UNRELIABLE'',/)') end if else if (out .eq. 0) then 7040 format ( $ //,' ',/1x,'PERIOD',20x,' SEASONAL',45x,'TRANS.',//18x, $ 'FORECAST',10x,'STANDARD ERROR',20x,'FORECAST',10x, $ 'STANDARD ERROR'/33x,'TOTAL',6x,' OF REVISION',27x,'TOTAL' $ ,6x,' OF REVISION'/) write (Nio,7040) end if if (out .eq. 0) then if (Nsfcast .eq. 0) then do i = 1,mq2 j = nz + i 7041 format ( $ 2x,i4,7x,g11.4,4x,g11.4,4x,g11.4,12x,g11.4,4x,g11.4,4x,g11.4) write (Nio,7041) $ i, sc(j), Sets(i), Sers(i), cycle(j), Setc(i), Serc(i) end do else do i = 1,mq2 j = nz + i write (Nio,7041) $ i, sc(j), Sets(i), Sers(i), cycle(j), Setc(i), Serc(i) end do end if end if if ((out.eq.0) .and. (Nsfcast.eq.1)) then write (Nio,'(/,30x,''DUE TO THE APPROXIMATION, THE S.E.'',/, $ 30x,''OF THE COMPONENT MAY BE UNRELIABLE'',/)') end if end if C C C HERE INTRODUCE THE CHECK ON THE SEASONAL SIGNIFICANCE C C if ((Nchcyc .gt. 1) .and. (ABS(Sefes) .gt. 1.0d-8)) then 5000 call SEASIGN(Npsi,lamd,alpha,sc,Sets,Sefes,nz,mq2, $ mq,nthclass,ntcclass,ntfclass,out) c end if C C zmean = DMEAN(nz,z) pmean = DMEAN(nz,trend) amean = DMEAN(nz,sa) smean = DMEAN(nz,sc) pzmean = 0.0d0 ppmean = 0.0d0 pamean = 0.0d0 psmean = 0.0d0 if (mq .eq. 1) then do i = nz-11,nz pzmean = pzmean + z(i)/12.0 ppmean = ppmean + trend(i)/12.0 pamean = pamean + sa(i)/12.0 psmean = psmean + sc(i)/12.0 end do else do i = nz-mq*3+1,nz pzmean = pzmean + z(i) ppmean = ppmean + trend(i) pamean = pamean + sa(i) psmean = psmean + sc(i) end do ndiv = mq * 3 pzmean = pzmean / ndiv ppmean = ppmean / ndiv pamean = pamean / ndiv psmean = psmean / ndiv end if if (out .eq. 0) then 7044 format (//,' ','SAMPLE MEANS',/,' ','------------'/) write (Nio,7044) if (mq .eq. 1) then 7045 format ( $ 15x,'COMPLETE PERIOD',4x,'LAST 12 OBSERVATIONS'/' SERIES ' $ ,6x,g11.4,6x,g11.4/' TREND-CYCLE',3x,g11.4,6x,g11.4/' SA SERIES' $ ,5x,g11.4,6x,g11.4/' SEASONAL',6x,g11.4,6x,g11.4) write (Nio,7045) $ zmean, pzmean, pmean, ppmean, amean, pamean, smean, psmean else 7046 format ( $ 15x,'COMPLETE PERIOD',4x,'LAST THREE YEARS'/' SERIES ' $ ,6x,g11.4,6x,g11.4/' TREND-CYCLE',3x,g11.4,6x,g11.4/' SA SERIES' $ ,5x,g11.4,6x,g11.4/' SEASONAL',6x,g11.4,6x,g11.4) write (Nio,7046) $ zmean, pzmean, pmean, ppmean, amean, pamean, smean, psmean end if end if C do i = 1,2*kp+1 do j = 1,3 splot(i,j) = 0.0d0 end do end do do i = kp-mq2,kp+mq2 do j = 1,3 splot(i,j) = z(nz-kp+i) if ((nz-kp+i.gt.nz) .and. (Nsfcast.eq.1)) then splot(i,j) = Sfcast(i-kp) end if end do end do do i = 1,mq2 splot(kp+i,1) = splot(kp+i,1) - Seser(i)*alpha splot(kp+i,2) = splot(kp+i,2) + Seser(i)*alpha end do ymin = splot(kp-mq2,1) ymax = splot(kp-mq2,1) do j = 1,3 do i = kp-mq2,kp+mq2 bser = splot(i,j) if (bser .le. ymin) then ymin = bser end if if (bser .ge. ymax) then ymax = bser end if end do end do * if ((pg .eq. 0).and.(iter.eq.0).and.(out.lt.2)) then * if (lamd.eq.0) then * fname = 'FORXL.T5' * write(subtitle,'("FORECAST: ",A," COMPONENT")') * $ transLcad(1:nTransLcad) * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * fname = 'FORX.T5' * subtitle = 'FORECAST OF STOCHASTIC SERIES' * do j = 1,3 * do i = kp-mq2,kp+mq2 * splot(i,j) = EXP(splot(i,j)) * end do * end do * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * else * fname = 'FORX.T5' * subtitle = 'FORECAST OF STOCHASTIC SERIES' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * end if C C ntitle = ISTRLEN(title) * if ((iter.ne.0) .and. (ioneout.eq.0) .and. (tramo.le.0) .and. * $ (out.eq.0).and.(pg.eq.0)) then * fname = title(1:ntitle) // '.FX' * subtitle = 'FORECAST OF STOCHASTIC SERIES' * if (lamd .eq. 0) then * do j = 1,3 * do i = kp-mq2,kp+mq2 * splot(i,j) = EXP(splot(i,j)) * end do * end do * end if * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) ** write (27,'(A)') fname * end if C C do i = 1,2*kp+1 do j = 1,3 splot(i,j) = 0.0d0 end do end do do i = kp-mq2,kp+mq2 splot(i,3) = trend(nz-kp+i) if ((nz-kp+i.gt.nz) .and. (Nsfcast.eq.1)) then splot(i,3) = trend(nz-kp+i) * Rfact(i-kp) end if splot(i,1) = splot(i,3) - Setp(i-kp)*alpha splot(i,2) = splot(i,3) + Setp(i-kp)*alpha end do ymin = splot(kp-mq2,1) ymax = splot(kp-mq2,1) do j = 1,3 do i = kp-mq2,kp+mq2 bser = splot(i,j) if (bser .le. ymin) then ymin = bser end if if (bser .ge. ymax) then ymax = bser end if end do end do * if ((pg .eq. 0).and.(iter.eq.0)) then * if (lamd.eq.0) then * if (out.lt.2) then * fname = 'FORTC.T5' * subtitle = 'FORECAST: TREND-CYCLE COMPONENT' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * else * if (lamd .eq. 1) then * subtitle = 'FORECAST: TREND-CYCLE' * if (tramo .gt. 0) then * if (out.lt.2) then * fname = 'FORT.T5' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * else * if (out.lt.3) then * fname = 'FTRFIN.T5' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * end if * end if * end if * end if noseas = .true. do i = 1,2*kp+1 do j = 1,3 splot(i,j) = 0.0d0 end do end do do i = kp-mq2,kp+mq2 if ((lamd.eq.0) .and. (sc(nz-kp+i).gt.1.0d-9)) then noseas = .false. end if if ((lamd.eq.1) .and. (sc(nz-kp+i).gt.1.0d-9)) then noseas = .false. end if splot(i,3) = sc(nz-kp+i) splot(i,1) = splot(i,3) - Sets(i-kp)*alpha splot(i,2) = splot(i,3) + Sets(i-kp)*alpha end do ymin = splot(kp-mq2,1) ymax = splot(kp-mq2,1) do j = 1,3 do i = kp-mq2,kp+mq2 bser = splot(i,j) if (bser .le. ymin) then ymin = bser end if if (bser .ge. ymax) then ymax = bser end if end do end do * if ((pg.eq.0) .and. (.not.noseas) .and.(lamd.eq.1).and. * & (iter.eq.0)) then * if ((out.eq.0).or.(out.eq.1).and.(tramo.le.0)) then * fname = 'FORSC.T5' * subtitle = 'FORECAST: SEASONAL COMPONENT' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * end if CC C CC * if ((pg.eq.0).and.(iter.eq.0).and. * $ ((out.lt.2).or.(out.eq.2).and.(tramo.le.0))) then * do i = 1,2*kp+1 * do j = 1,3 * splot(i,j) = 0.0d0 * end do * end do * do i = kp-mq2,kp+mq2 * splot(i,3) = sa(nz-kp+i) * splot(i,1) = splot(i,3) - Seta(i-kp)*alpha * splot(i,2) = splot(i,3) + Seta(i-kp)*alpha * end do * fname = 'FORSA.T5' * subtitle = 'FORECAST: STOCHASTIC SA SERIES' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if CC C CC if (varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. ncyc.ne.1)) then do i = 1,2*kp+1 do j = 1,3 splot(i,j) = 0.0d0 end do end do do i = kp-mq2,kp+mq2 splot(i,3) = cycle(nz-kp+i) splot(i,1) = splot(i,3) - Setc(i-kp)*alpha splot(i,2) = splot(i,3) + Setc(i-kp)*alpha end do ymin = splot(kp-mq2,1) ymax = splot(kp-mq2,1) bser = 0.0d0 do j = 1,3 do i = kp-mq2,kp+mq2 bser = splot(i,j) if (bser .le. ymin) then ymin = bser end if if (bser .ge. ymax) then ymax = bser end if end do end do bool = .false. do i = kp-mq2,kp+mq2 do j = 1,3 if (.not.dpeq(splot(i,j), 0.0d0)) then bool = .true. end if end do end do * if ((pg.eq.0).and.(iter.eq.0).and.(bool).and.(lamd.eq.1)) then * if ((out.lt.2).and.(tramo.le.0)) then * fname = 'FORYC.T5' * subtitle = 'FORECAST: TRANSITORY COMPONENT' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * end if end if C C LINES OF CODE ADDED FOR X-13A-S : 5 lon = mq if (mq .lt. 6) then lon = 2 * lon end if nlen = lon C LINES OF CODE COMMENTED FOR X-13A-S : 1 c if (out .ne. 3) then C C C BEGIN COMPUTATION FOR RATES OF GROWTH C C TABLE T11 C C LINES OF CODE COMMENTED FOR X-13A-S : 4 C lon = mq C if (mq .lt. 6) then C lon = 2 * lon C end if if (lamd .eq. 0) then por = 1.0d0 end if if (lamd .eq. 1) then por = 0.01d0 end if C LINES OF CODE COMMENTED FOR X-13A-S : 1 C c2 = mq * 100.0 C if (nannua .eq. 0) then C c2 = 100.0 C end if C END OF CODE BLOCK C LINES OF CODE ADDED FOR X-13A-S : 1 c2 = 100.0 C END OF CODE BLOCK c1 = c2 * sqf st1p(0) = $ c1 * $ RAIZ(2*teetre(0)*(1.0-teetre(1))-psiep(nfilt)*psiep(nfilt)) st1d(0) = $ c1 * $ RAIZ(2*teeadj(0)*(1.0-teeadj(1))-psiea(nfilt)*psiea(nfilt)) sigpt1(0) = st1p(0) * por sigat1(0) = st1d(0) * por do k = 1,lon st1p(k) = st1p(k-1) * st1p(k-1) st1d(k) = st1d(k-1) * st1d(k-1) aux1 = (psiep(nfilt-k)-psiep(nfilt+1-k)) * $ (psiep(nfilt-k)-psiep(nfilt+1-k)) aux2 = (psiea(nfilt-k)-psiea(nfilt+1-k)) * $ (psiea(nfilt-k)-psiea(nfilt+1-k)) aux1 = c1 * c1 * aux1 aux2 = c1 * c1 * aux2 st1p(k) = st1p(k) - aux1 st1d(k) = st1d(k) - aux2 st1p(k) = RAIZ(st1p(k)) st1d(k) = RAIZ(st1d(k)) sigpt1(k) = st1p(k) * por sigat1(k) = st1d(k) * por end do st1p(lon+1) = c1 * RAIZ(2.*feetre(0)*(1.-feetre(1))) st1d(lon+1) = c1 * RAIZ(2.*feeadj(0)*(1.-feeadj(1))) sigpt1(lon+1) = st1p(lon+1) * por sigat1(lon+1) = st1d(lon+1) * por C LINES OF CODE COMMENTED FOR X-13A-S : 1 C nlen = lon C C TABLE T31 C C AT THIS POINT WE DESTROY THE STANDARD ERROR DUE TO REVISION C if (mq .ge. 6) then c3 = 100.0 * sqf Serc(0) = rcetre(3)*rcetre(0) + psiep(nfilt+1)*psiep(nfilt-2) do k = 1,lon Serc(k) = Serc(k-1) - psiep(nfilt+2-k)*psiep(nfilt-k-1) end do v3fp = 2 * feetre(0) * (1-feetre(3)) do k = 0,mq2 Serp(k) = (Serp(-k)/sqf)**2 Sera(k) = (Sera(-k)/sqf)**2 end do C C C st3p(0) = $ c3 * $ RAIZ(v3fp+rcetre(0)+psiep(nfilt+1)*psiep(nfilt+1)+Serp(2)- $ 2*Serc(0)) do k = 1,lon st3p(k) = c3 * RAIZ(v3fp+Serp(k-1)+Serp(k+2)-2*Serc(k)) end do st3p(lon+1) = c3 * RAIZ(v3fp) Serc(0) = rceadj(3)*rceadj(0) + psiea(nfilt+1)*psiea(nfilt-2) do k = 1,lon Serc(k) = Serc(k-1) - psiea(nfilt+2-k)*psiea(nfilt-k-1) end do v3fd = 2 * feeadj(0) * (1-feeadj(3)) st3d(0) = $ c3 * $ RAIZ(v3fd+rceadj(0)+psiea(nfilt+1)*psiea(nfilt+1)+Sera(2)- $ 2*Serc(0)) do k = 1,lon st3d(k) = c3 * RAIZ(v3fd+Sera(k-1)+Sera(k+2)-2*Serc(k)) end do st3d(lon+1) = c3 * RAIZ(v3fd) end if C C TASAS ACUMULADAS C if (mq.eq.12 .or. mq.eq.4 .or. mq.eq.6) then do i = 1,mq adum(i) = 2. * teetre(0) * (1.-teetre(i)) bdum(i) = 2. * feetre(0) * (1.-feetre(i)) atdum(i) = 2. * teeadj(0) * (1.-teeadj(i)) btdum(i) = 2. * feeadj(0) * (1.-feeadj(i)) aux1 = 0.0 aux2 = 0.0 do k = 1,i aux1 = aux1 + psiep(nfilt+1-k)*psiep(nfilt+1-k) aux2 = aux2 + psiea(nfilt+1-k)*psiea(nfilt+1-k) end do adum(i) = adum(i) - aux1 c2 = 100.0 stpt(i) = mq * (c2/i) * RAIZ(adum(i)*sqf**2) stpf(i) = mq * (c2/i) * RAIZ(bdum(i)*sqf**2) atdum(i) = atdum(i) - aux2 stdt(i) = mq * (c2/i) * RAIZ(atdum(i)*sqf**2) stdf(i) = mq * (c2/i) * RAIZ(btdum(i)*sqf**2) sigptac(i) = stpt(i) * por sigatac(i) = stdt(i) * por sigptaf(i) = stpf(i) * por sigataf(i) = stdf(i) * por end do end if C C TASA T(1 MQ) C if (mq .ne. 1) then vx = 1.0d0 do i = 1,mq/2-1 vx = vx + psitot(nfilt+1+i)*psitot(nfilt+1+i) end do vfp = 2. * feetre(0) * (1.-feetre(mq)) vfa = 2. * feeadj(0) * (1.-feeadj(mq)) vrpp = 2. * rcetre(0) * (1.-rcetre(mq)) vraa = 2. * rceadj(0) * (1.-rceadj(mq)) ap = 0.0d0 aa = 0.0d0 bpp = 0.0d0 ba = 0.0d0 cp = 0.0d0 ca = 0.0d0 do i = 0,mq/2-1 ap = ap + psiep(nfilt+1+i)*psiep(nfilt+1+i) aa = aa + psiea(nfilt+1+i)*psiea(nfilt+1+i) end do ii = -mq/2 if (mq .eq. 3) then ii = -1 end if do i = ii,-1 bpp = bpp + psiep(nfilt+1+i)*psiep(nfilt+1+i) ba = ba + psiea(nfilt+1+i)*psiea(nfilt+1+i) end do do i = 0,mq/2-1 cp = cp + psiep(nfilt+1+i)*psiep(nfilt+1+i-mq) ca = ca + psiea(nfilt+1+i)*psiea(nfilt+1+i-mq) end do vpp = vrpp + ap - bpp - 2.*cp vdd = vraa + aa - ba - 2.*ca vcp = vfp + vpp vca = vfa + vdd C C C C IF (LAMD.EQ.0) THEN C IF (OUT.EQ.1) WRITE(NIO,8790)MQ C 8790 FORMAT(///,10X,'(CENTERED) ESTIMATOR OF THE PRESENT',/,10X, C * 'RATE OF ANNUAL GROWTH, T(1',I3,')', C * /,10X,'(LINEAR APPROXIMATION)') C END IF C IF (LAMD.EQ.1) THEN C IF (OUT.EQ.1) WRITE(NIO,8550) C 8550 FORMAT(///,10X,'(CENTERED) ESTIMATOR OF THE PRESENT',/,10X, C *'ANNUAL GROWTH') C END IF C IF (OUT.EQ.1) WRITE(NIO,8791) C 8791 FORMAT(/,8X,'STANDARD',6X,'TREND-CYCLE',2X,'SEAS. ADJ.', C *5X,'ORIGINAL',/,10X,'ERROR',20X,'SERIES',9X,'SERIES',/) C C CONCURRENT ESTIMATOR T(1,MQ) C vmi = RAIZ(vcp*sqf*sqf) * 100. vmig = RAIZ(vca*sqf*sqf) * 100. vmigu = RAIZ(vx*sqf*sqf) * 100. sigptmq(1) = vmi * por sigatmq(1) = vmig * por sigxtmq(1) = vmigu * por C IF (OUT.EQ.1) WRITE(NIO,8792) VMI*POR,VMIG*POR,VMIGU*POR C 8792 FORMAT(6X,'CONCURRENT',3X,F10.3,3X,F10.3,5X,F10.3,/,6X, C *'ESTIMATOR',/) c if (out .ne. 0) then C C FINAL ESTIMATOR T(1,MQ) C vmi = RAIZ(vfp*sqf*sqf) * 100. vmig = RAIZ(vfa*sqf*sqf) * 100. sigptmq(2) = vmi * por sigatmq(2) = vmig * por sigxtmq(2) = 0.0d0 c end if end if C LINES OF CODE COMMENTED FOR X-13A-S : 1 c end if C IF ((LAMD.EQ.0).AND.(OUT.EQ.0).AND.(MQ.GE.6)) THEN C WRITE(NIO,2144)ST1P(0)*POR,ST1D(0)*POR,ST3P(0)*POR, C $ ST3D(0)*POR,VMI*POR,VMIG*POR,VMIGU*POR,MQ C end if C IF ((LAMD.EQ.0).AND.(OUT.EQ.0).AND.(MQ.LT.6)) THEN C WRITE(NIO,2145)ST1P(0)*POR,ST1D(0)*POR, C $ VMI*POR,VMIG*POR,VMIGU*POR,MQ C end if C IF ((LAMD.EQ.1).AND.(OUT.EQ.0).AND.(MQ.GE.6)) THEN C WRITE(NIO,2146)ST1P(0)*POR,ST1D(0)*POR,ST3P(0)*POR, C $ ST3D(0)*POR,VMI*POR,VMIG*POR,VMIGU*POR,MQ C end if C IF ((LAMD.EQ.1).AND.(OUT.EQ.0).AND.(MQ.LT.6)) THEN C WRITE(NIO,2147)ST1P(0)*POR,ST1D(0)*POR, C $ VMI*POR,VMIG*POR,VMIGU*POR,MQ C end if C 2144 FORMAT(//,6X,'STANDARD ERROR OF THE CONCURRENT RATES OF ', C $ 'GROWTH ESTIMATORS',/,4X,'(In points of annualized percent ', C $'growth. Linear approximations)',//,33X,'TREND-CYCLE',2X, C $'SA SERIES',8X,'ORIGINAL SERIES',//,2X,'PERIOD TO PERIOD RATE ', C $5X,G11.3,5X,G11.3,/2X,'OF GROWTH OF THE',/,2X,'SERIES (T11)', C $//,2X,'RATE OF GROWTH OF ',9X,G11.3,5X,G11.3,/,2X, C $'A 3-PERIOD CENTERED',/,2X,'MOVING AVERAGE (T31)',//, C $2X,'(CENTERED) ESTIMATOR',7X,G11.3,6X,G11.3, C $10X,G11.3,/2X,'OF THE ANNUAL GROWTH',/,2X '(T 1',I3,')') C 2145 FORMAT(//,6X,'STANDARD ERROR OF THE CONCURRENT RATES OF ', C $ 'GROWTH ESTIMATORS',/,4X,'(In points of annualized percent ', C $'growth. Linear approximations)',//,33X,'TREND-CYCLE',2X, C $'SA SERIES',8X,'ORIGINAL SERIES',//,2X,'PERIOD TO PERIOD RATE ', C $5X,G11.3,5X,G11.3,/,2X,'OF GROWTH OF THE',/,2X,'SERIES (T11)', C $//,2X,'(CENTERED) ESTIMATOR',7X,G11.3,6X,G11.3, C $10X,G11.3,/2X,'OF THE ANNUAL GROWTH',/,2X '(T 1',I3,')') C 2146 FORMAT(//,6X,'STANDARD ERROR OF THE CONCURRENT RATES OF ', C $ 'ESTIMATORS',/,4X,'(In points of annualized percent ', C $'growth. Linear approximations)',//,33X,'TREND-CYCLE',2X, C $'SA SERIES',8X,'ORIGINAL SERIES',//,2X,'PERIOD TO PERIOD GROWTH', C $4X,G11.3,5X,G11.3,/2X,'OF THE SERIES (T11)',//, C $2X,'PERIOD GROWTH OF ',9X,G11.3,5X,G11.3,/,2X, C $'A 3-PERIOD OF THE',/,2X,'CENTERED SERIES (T31)',//, C $2X,'(CENTERED) ESTIMATOR',7X,G11.3, C $5X,G11.3,10X,G11.3,/2X,'OF THE ANNUAL GROWTH'/,2X,'(T 1',I3,')') C 2147 FORMAT(//,6X,'STANDARD ERROR OF THE CONCURRENT RATES OF ', C $ 'ESTIMATORS',/,4X,'(In points of annualized percent ', C $'growth. Linear approximations)',//,33X,'TREND-CYCLE',2X, C $'SA SERIES',8X,'ORIGINAL SERIES',//,2X,'PERIOD TO PERIOD GROWTH', C $4X,G11.3,5X,G11.3,/2X,'OF THE SERIES (T11)',//, C $2X,'(CENTERED) ESTIMATOR',7X,G11.3, C $5X,G11.3,10X,G11.3,/2X,'OF THE ANNUAL GROWTH'/,2X,'(T 1',I3,')') noC=varwnc.lt.1.0d-10 .and.ncycth.eq.0.and.Ncyc.eq.1 if (lamd .eq. 1) then C C ADDITIVE CASE, LAMD = 1. SIGMA $ SIGLT ALREADY CALCULATED C do i = 1,nz if (IsCloseToTD) then sa(i) = oz(i) - sc(i) - cycle(i) else sa(i) = oz(i) - sc(i) end if end do else if (bias .eq. -1) then call BIASCORR(forbias,forsbias,fortbias,trend,sc,z,cycle,ir,sa, $ mq,lfor,npsi,noC) else bias1c = 1.0d0 bias3c = 1.0d0 if (bias .eq. 1) then bias1c = 0.0d0 bias2c = 0.0d0 nyr = (nz/mq) * mq do i = 1,nz if (i .le. nyr) then bias1c = bias1c + EXP(sc(i)) end if bias2c = bias2c + EXP(ir(i)) end do bias1c = bias1c / nyr bias2c = bias2c / nz bias3c = bias1c * bias2c call ABIASC(mq,lfor,oz,trend,z,sc,forbias,forsbias,fortbias, $ bias1c,bias3c,xx,npsi,noc) if (xx .gt. maxbias) then overmaxbias=1 C write (Nio,'(/,2x,''DIFFERENCES IN ANNUAL AVERAGES'',/2x, C $ ''EXCEED THE ALLOWED LIMIT ('',f8.2,'')'',/,2x, C $ ''PARAMETER BIAS SET=-1'')') maxbias C bias = -1 C call BIASCORR(forbias,forsbias,fortbias,trend,sc,z,cycle,ir,sa, C $ mq,lfor,npsi) C goto 5001 end if end if do i = 1,nz sc(i) = EXP(sc(i)) / bias1c cycle(i) = EXP(cycle(i)) if (IsCloseToTD) then sa(i) = EXP(z(i)) / (sc(i)*cycle(i)) else sa(i) = EXP(z(i)) / sc(i) end if trend(i) = EXP(trend(i)) * bias3c if (IsCloseToTD) then ir(i) = LOG(sa(i)/trend(i)) else ir(i) = LOG(sa(i)/(trend(i)*cycle(i))) end if sc(i) = 100.0d0 * sc(i) cycle(i) = 100.0d0 * cycle(i) ir(i) = 100.0d0 * EXP(ir(i)) end do do i = 1,lfor k = nz + i if (npsi.ne.1) then sc(k) = EXP(sc(k)) / bias1c else sc(k) = exp(sc(k)) endif if (npsi.ne.1 .or. .not.noC)then trend(k) = EXP(trend(k)) * bias3c else trend(k) = EXP(trend(k)) endif cycle(k) = EXP(cycle(k)) if (IsCloseToTD)then sa(k) = EXP(z(k)) / (sc(k)*cycle(k)) else sa(k) = EXP(z(k)) / sc(k) end if cycle(k) = cycle(k) * 100.0d0 sc(k) = 100.0d0 * sc(k) end do do i = 1,59 if (npsi.ne.1) then forsbias(i) = EXP(forbias(i)) / (EXP(forsbias(i))/bias1c) else forsbias(i) = EXP(forbias(i)) / (EXP(forsbias(i))) endif if (npsi.ne.1 .or. .not.noC)then fortbias(i) = EXP(fortbias(i)) * bias3c else fortbias(i) = EXP(fortbias(i)) endif forbias(i) = EXP(forbias(i)) end do end if C C antes era out=2 ! 5001 if (out .eq. 0) then write (Nio,'(6X,''BIAS PARAMETER ='',I2)') bias end if do i = 1,2*kp+1 do j = 1,3 splot(i,j) = 0.0d0 end do end do do i = kp-mq2,kp+mq2 if (lamd .eq. 0) then splot(i,3) = LOG(trend(nz-kp+i)) if ((nz-kp+i.gt.nz) .and. (Nsfcast.eq.1)) then splot(i,3) = LOG(trend(nz-kp+i)) * Rfact(i-kp) end if splot(i,1) = splot(i,3) - Setp(i-kp)*alpha splot(i,2) = splot(i,3) + Setp(i-kp)*alpha else splot(i,3) = trend(nz-kp+i) if ((nz-kp+i.gt.nz) .and. (Nsfcast.eq.1)) then splot(i,3) = trend(nz-kp+i) * Rfact(i-kp) end if splot(i,1) = splot(i,3) - Setp(i-kp)*alpha splot(i,2) = splot(i,3) + Setp(i-kp)*alpha end if end do c ymin = splot(kp-mq2,1) c ymax = splot(kp-mq2,1) c do j = 1,3 c do i = kp-mq2,kp+mq2 c bser = splot(i,j) c if (bser .le. ymin) then c ymin = bser c end if c if (bser .ge. ymax) then c ymax = bser c end if c end do c end do * if ((iter.eq.0).and.(pg.eq.0).and.(lamd.eq.0)) then * subtitle = 'FORECAST: TREND-CYCLE' * do j = 1,3 * do i = kp-mq2,kp+mq2 * splot(i,j) = EXP(splot(i,j)) * end do * end do * if (tramo .gt. 0) then * if (out.lt.2) then * fname = 'FORT.T5' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * else * if (out.lt.3) then * fname = 'FTRFIN.T5' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * end if * end if C C * if ((iter.ne.0) .and. (ioneout.eq.0) .and. (tramo.le.0) .and. * $ (out.lt.2).and.(pg.eq.0)) then * fname = title(1:ntitle) // '.FTR' * subtitle = 'FORECAST: TREND-CYCLE' * if (lamd .eq. 0) then * do j = 1,3 * do i = kp-mq2,kp+mq2 * splot(i,j) = EXP(splot(i,j)) * end do * end do * end if * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) ** write (27,'(A)') fname * end if C C noseas = .true. do i = 1,2*kp+1 do j = 1,3 splot(i,j) = 0.0d0 end do end do do i = kp-mq2,kp+mq2 if (lamd.eq.0)THEN if(LOG(sc(nz-kp+i)/100.0d0).gt.1.0d-9) noseas = .false. end if if ((lamd.eq.1) .and. (sc(nz-kp+i).gt.1.0d-9)) then noseas = .false. end if if (lamd .eq. 0) then splot(i,3) = LOG(sc(nz-kp+i)/100.0d0) splot(i,1) = splot(i,3) - Sets(i-kp)*alpha splot(i,2) = splot(i,3) + Sets(i-kp)*alpha else splot(i,3) = sc(nz-kp+i) splot(i,1) = splot(i,3) - Sets(i-kp)*alpha splot(i,2) = splot(i,3) + Sets(i-kp)*alpha end if end do c c ymin = splot(kp-mq2,1) c ymax = splot(kp-mq2,1) c do j = 1,3 c do i = kp-mq2,kp+mq2 c bser = splot(i,j) c if (bser .le. ymin) then c ymin = bser c end if c if (bser .ge. ymax) then c ymax = bser c end if c end do c end do * if ((pg.eq.0) .and. (.not.noseas) .and.(lamd.eq.0).and. * $ (iter.eq.0)) then * if ((out.lt.2).or. (out.eq.2).and.(tramo.le.0)) then * subtitle = 'FORECAST: SEASONAL FACTORS' * do j = 1,3 * do i = kp-mq2,kp+mq2 * splot(i,j) = 100.0d0 * EXP(splot(i,j)) * end do * end do * if (tramo .gt. 0) then * fname = 'FORSF.T5' * else * fname = 'FSFIN.T5' * end if * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * end if CC C CC * if ((pg.eq.0).and.(iter.eq.0).and. * & ((out.lt.2).or.(out.eq.2).and.(tramo.le.0))) then * do i = 1,2*kp+1 * do j = 1,3 * splot(i,j) = 0.0d0 * end do * end do * do i = kp-mq2,kp+mq2 * splot(i,3) = sa(nz-kp+i) * splot(i,1) = splot(i,3) - Seta(i-kp)*alpha * splot(i,2) = splot(i,3) + Seta(i-kp)*alpha * end do * fname = 'FORSA.T5' * subtitle = 'FORECAST: STOCHASTIC SA SERIES' * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if CC C CC C C if (varwnc.gt.1.0D-10 .and.(ncycth.ne.0 .or. ncyc.ne.1)) then do i = 1,2*kp+1 do j = 1,3 splot(i,j) = 0.0d0 end do end do do i = kp-mq2,kp+mq2 if (lamd .eq. 0) then splot(i,3) = LOG(cycle(nz-kp+i)/100.0d0) splot(i,1) = splot(i,3) - Setc(i-kp)*alpha splot(i,2) = splot(i,3) + Setc(i-kp)*alpha else splot(i,3) = cycle(nz-kp+i) splot(i,1) = splot(i,3) - Setc(i-kp)*alpha splot(i,2) = splot(i,3) + Setc(i-kp)*alpha end if end do bool = .false. do i = kp-mq2,kp+mq2 do j = 1,3 if (.not.dpeq(splot(i,j), 0.0d0)) then bool = .true. end if end do end do * if (bool) then * if (iter.eq.0) then * if (out.lt.2) then * fname = 'FORYC.T5' * write(subtitle,'("FORECAST: ",A," COMPONENT")') * $ transLcad(1:nTransLCad) * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * if (lamd .eq. 0) then * if (tramo .gt. 0) then * fname = 'FORYF.T5' * else * fname = 'FTRAFIN.T5' * end if * write(subtitle,'("FORECAST: ",A," FACTORS")') * $ transLcad(1:nTransLCad) * do j = 1,3 * do i = kp-mq2,kp+mq2 * splot(i,j) = 100.0d0 * EXP(splot(i,j)) * end do * end do * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) * end if * end if * else * if (ioneout.ne.0 .or. tramo.ge.0.or. out.ne.0) return * if (lamd .eq. 0) then * do j = 1,3 * do i = kp-mq2,kp+mq2 * splot(i,j) = EXP(splot(i,j)) * end do * end do * end if * fname = title(1:ntitle) // '.FCY' * write(subtitle,'("FORECAST: ",A)') transLCad(1:ntransLcad) * call PLOTFCAST2(fname,subtitle,splot,mq2,nz,1) ** write (27,'(A)') fname * end if * end if end if end C C C subroutine SMRFACT(rfact,mq2,mq) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer kp parameter (kp = PFCST) C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Maybe Written .. real*8 rfact(kp) C.. In/Out Status: Read, Not Written .. integer mq2 C.. In/Out Status: Read, Not Written .. integer mq C C.. Local Scalars .. integer i,k real*8 sum C C.. Local Arrays .. real*8 rs(kp),rstmp(-kp:kp) C C.. Intrinsic Functions .. intrinsic MOD C C ... Executable Statements ... C do i = 1,mq2 rstmp(i) = rfact(i) end do if (MOD(mq,2) .eq. 1) then do i = 0,(mq-1)/2-1 rstmp(-i) = 1.0d0 end do do i = 0,(mq-1)/2 sum = 0.0d0 do k = 0,2*i sum = sum + rstmp(mq2-k) end do rs(mq2-i) = (1.0d0/(2.0d0*i+1)) * sum end do do i = mq2-(mq-1)/2,1,(-1) sum = 0.0d0 do k = -(mq-1)/2,(mq-1)/2 sum = sum + rstmp(i+k) end do rs(i) = (1/(mq*1.0d0)) * sum end do else do i = 0,mq/2-1 rstmp(-i) = 1.0d0 end do rs(mq2) = rstmp(mq2) do i = 1,mq/2 sum = 0.0d0 do k = 1,2*i-1 sum = sum + rstmp(mq2-k) end do rs(mq2-i) = (1/(4.d0*i)) * (rstmp(mq2)+2.d0*sum+rstmp(mq2-2*i)) end do do i = mq2-(mq/2)-1,1,(-1) sum = 0.0d0 do k = -(mq/2)+1,(mq/2)-1 sum = sum + rstmp(i+k) end do rs(i) = (1/(2.d0*mq)) * (rstmp(i-mq/2)+2.0d0*sum+rstmp(i+mq/2)) end do end if do i = 1,mq2 rfact(i) = rs(i) end do end C C C subroutine Seasign(Npsi,lamd,alpha,sc,sets,sefes,nz, $ mq2,mq,nthclass,ntcclass,ntfclass,out) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' C C.. Formal Arguments .. integer nz,mq2,mq,nthclass,ntcclass,ntfclass,out,Npsi,lamd real*8 sc(mpkp),sets(-kp:kp),sefes,alpha C C.. Local Scalars .. integer i,j,k,ntc90,ntc95,nth3,ntcseas,ntf90,ntf95,ntfseas, $ nth90,nth95,nthseas real*8 const90,const95,const3,a1,a2,a3,a4,a5,a6,a7,a8,dvec C C.. Local Arrays .. real*8 tcseas(kp),tfseas(kp),thseas(kp) dimension a1(1),a2(1),a3(1),a4(1),a5(1),a6(1),a7(1),a8(1),dvec(1) C C.. External Calls .. external CLASSIFY C C.. Intrinsic Functions .. intrinsic ABS include 'stream.i' C C ... Executable Statements ... C nth95=0 ntc95=0 nth3=0 ntf95=0 nth90=0 ntc90=0 ntf90=0 if (lamd .eq. 0) then a1(1) = EXP(Sefes*alpha) * 100.0 a2(1) = EXP(Sets(0)*alpha) * 100.0 a3(1) = EXP(Sefes*1.037d0) * 100.0 a4(1) = EXP(Sets(0)*1.037d0) * 100.0 a5(1) = EXP(-Sefes*alpha) * 100.0 a6(1) = EXP(-Sets(0)*alpha) * 100.0 a7(1) = EXP(-Sefes*1.037d0) * 100.0 a8(1) = EXP(-Sets(0)*1.037d0) * 100.0 call USRENTRY(a5,1,1,1,1,1507) call USRENTRY(a1,1,1,1,1,1508) call USRENTRY(a6,1,1,1,1,1509) call USRENTRY(a2,1,1,1,1,1510) call USRENTRY(a7,1,1,1,1,1511) call USRENTRY(a3,1,1,1,1,1512) call USRENTRY(a8,1,1,1,1,1513) call USRENTRY(a4,1,1,1,1,1514) else a1(1) = Sefes * alpha a2(1) = Sets(0) * alpha a3(1) = Sefes * 1.037d0 a4(1) = Sets(0) * 1.037d0 dvec(1)=-a1(1) call USRENTRY(dvec,1,1,1,1,1507) call USRENTRY(a1,1,1,1,1,1508) dvec(1)=-a2(1) call USRENTRY(dvec,1,1,1,1,1509) call USRENTRY(a2,1,1,1,1,1510) dvec(1)=-a3(1) call USRENTRY(dvec,1,1,1,1,1511) call USRENTRY(a3,1,1,1,1,1512) dvec(1)=-a4(1) call USRENTRY(dvec,1,1,1,1,1513) call USRENTRY(a4,1,1,1,1,1514) end if if (Npsi.gt.1) then If (out.eq.0) then write (nio,'(//,2x,''SIGNIFICANCE OF SEASONALITY'',/,2x, $ ''---------------------------'',/)') end if if (ABS(sefes) .lt. 1.0d-8) then If (out.eq.0) then write (nio,'(//,4x,''FINAL ESTIMATION ERROR VARIANCE '', & ''OF SA IS ZERO'' & ,/,4x,''SEASONAL SIGNIFICANCE TEST SKIPPED'')') end if call setSsh(nth95) call setSsp2(ntc95) call setSsf(ntf95) call setESS(nth95,nth3,MQ) return end if else call setSsh(nth95) call setSsp2(ntc95) call setSsf(ntf95) call setESS(nth95,nth3,MQ) return end if const90 = 1.645d0 const95 = 1.96d0 const3 = 3.0d0 do i = -mq2,-mq-1 j = nz + i k = i + mq2 + 1 thseas(k) = ABS(sc(j)/sefes) end do nthseas = mq do i = -mq+1,0 j = nz + i k = i + mq tcseas(k) = ABS(sc(j)/sets(i)) end do ntcseas = mq do i = 1,mq j = nz + i tfseas(i) = ABS(sc(j)/sets(i)) end do ntfseas = mq call CLASSIFY(thseas,nthseas,mq,nthclass) call CLASSIFY(tcseas,ntcseas,mq,ntcclass) call CLASSIFY(tfseas,ntfseas,mq,ntfclass) if (ntfclass .eq. -1) then nthclass = -1 ntcclass = -1 end if if (ntcclass .eq. -1) then nthclass = -1 end if if (ntfclass .eq. 0) then if (nthclass .eq. 1) then nthclass = 0 end if if (ntcclass .eq. 1) then ntcclass = 0 end if end if if (ntcclass.eq.0 .and. nthclass.eq.1) then nthclass = 0 end if if (out.eq.0) then write (nio,'(4x,''Significance of seasonality is '', $ ''assessed using the variances of the'',/,4x, $ ''total estimation error, which includes the '', $ ''error in the preliminary estimator'',/,4x, $ ''(the revision error) and the error in the final estimator.'')') write (nio,'(4x,''Because the S.E. of the seasonal '', $ ''component estimator varies (it reaches a minimum'',/,4x, $ ''for historical estimation and a maximum for the most '', $ ''distant forecast), the significance of seasonality'',/,4x, $ ''will be different for different periods.'',/,4x, $ ''An extreme example would be a series showing '', $ ''significant seasonality for historical estimates,'',/,4x, $ ''that is poorly captured concurrently, and useless for '', $ ''forecasting.'')') end if C C C do i = 1,nthseas if (thseas(i) .ge. const90) then nth90 = nth90 + 1 end if if (thseas(i) .ge. const95) then nth95 = nth95 + 1 end if if (thseas(i) .ge. const3) then nth3 = nth3 + 1 end if end do do i = 1,ntcseas if (tcseas(i) .ge. const90) then ntc90 = ntc90 + 1 end if if (tcseas(i) .ge. const95) then ntc95 = ntc95 + 1 end if end do do i = 1,ntfseas if (tfseas(i) .ge. const90) then ntf90 = ntf90 + 1 end if if (tfseas(i) .ge. const95) then ntf95 = ntf95 + 1 end if end do call setSsh(nth95) call setSsp2(ntc95) call setSsf(ntf95) call setESS(nth95,nth3,MQ) c call usrentry(ntf95*1.0d0,1,1,1,1,1038) if (out.eq.0) then write (nio, $'(//,8x,''SEASONAL'',22x,''NUMBER OF PERIODS IN A YEAR THAT'' $,/,8x,''COMPONENT'',21x,''HAVE SIGNIFICANT SEASONALITY'',/,44x, $ ''90%'',10x,''95%'')') write (nio,'(/,4X,''HISTORICAL ESTIMATOR'',19X,I3,10X,I3)') $ nth90, nth95 write (nio,'(/,4X,''PRELIMINARY ESTIMATOR'',18X,I3,10X,I3)') $ ntc90, ntc95 write (nio,'(4X,''FOR LAST YEAR'')') write (nio,'(/,4X,''FORECAST FOR NEXT YEAR'',17X,I3,10X,I3)') $ ntf90, ntf95 C write (nio,'(//,4x,''For the present series :'',/,4x, $ ''------------------------'',/)') if (nthclass .eq. -1) then write (nio,'(6x,''FINAL OR HISTORICAL ESTIMATION SHOWS '', $ ''CLEARLY SIGNIFICANT SEASONALITY IN THE SERIES.'',/)') else if (nthclass .eq. 0) then write (nio,'(6x,''FINAL OR HISTORICAL ESTIMATION SHOWS '', $ ''BORDERLINE SIGNIFICANT SEASONALITY IN THE SERIES.'',/)') else write (nio,'(6x,''FINAL OR HISTORICAL ESTIMATION SHOWS '', $ ''NOT SIGNIFICANT SEASONALITY IN THE SERIES.'',/)') end if if (ntcclass .eq. -1) then write (nio,'(6x,''CONCURRENT AND PRELIMINARY '', $ ''ESTIMATION SHOW CLEARLY SIGNIFICANT SEASONALITY '', $ ''FOR RECENT PERIODS (LAST YEAR).'',/)') else if (ntcclass .eq. 0) then write (nio,'(6x,''CONCURRENT AND PRELIMINARY '', $ ''ESTIMATION SHOW BORDERLINE SIGNIFICANT SEASONALITY '', $ ''FOR RECENT PERIODS (LAST YEAR).'',/)') else write (nio,'(6x,''CONCURRENT AND PRELIMINARY '', $ ''ESTIMATION SHOW NOT SIGNIFICANT SEASONALITY '', $ ''FOR RECENT PERIODS (LAST YEAR).'',/)') end if if (ntfclass .eq. -1) then write (nio,'(6x,''ONE-YEAR AHEAD FORECAST FUNCTION '', $ ''CONTAINS CLEARLY SIGNIFICANT SEASONALITY.'',/)') else if (ntfclass .eq. 0) then write (nio,'(6x,''ONE-YEAR AHEAD FORECAST FUNCTION '', $ ''CONTAINS BORDERLINE SIGNIFICANT SEASONALITY.'',/)') else write (nio,'(6x,''ONE-YEAR AHEAD FORECAST FUNCTION '', $ ''CONTAINS NOT SIGNIFICANT SEASONALITY.'',/)') end if if (((nthclass.eq.0).and.(ntcclass.eq.1).and.(ntfclass.eq.1)) $ .or.((nthclass.eq.1).and.(ntcclass.eq.1).and.(ntfclass.eq.1))) $ then write (nio,'(/,20x,''"SEASONALITY IS NOT PRESENT OR IS '', $''TOO WEAK TO BE ACCURATELY CAPTURED.'',/,20x, $''THE SERIES, POSSIBLY, SHOULD NOT BE SEASONALLY ADJUSTED.'', $/,20x,''TO OBTAIN THE TREND-CYCLE, '', $''SIMPLY LET THE SEASONAL COMPONENT BE ADDED TO'',/,20x, $''THE IRREGULAR IN THE PRESENT RUN, OR TRY A '', $''NON-SEASONAL MODEL."'',/)') end if end if if (lamd.eq.0) then if (out .eq. 0) then 7042 format ( $ ///' CONFIDENCE INTERVAL AROUND A SEASONAL FACTOR OF 100',/ $ ' ---------------------------------------------------',//28x, $ 'FINAL ESTIMATOR',24x,'CONCURRENT ESTIMATOR'/' 95%'/ $ ' CONFIDENCE',12x,2g11.4,20x,2g11.4,/' INTERVAL'//' 70%'/ $ ' CONFIDENCE',12x,2g11.4,20x,2g11.4,/' INTERVAL'/) write (Nio,7042) a5(1), a1(1), a6(1), a2(1), & a7(1), a3(1), a8(1), a4(1) end if else if (out .eq. 0) then 7043 format ( $ ///' CONFIDENCE INTERVAL AROUND A SEASONAL COMPONENT OF 0',/ $ ' ----------------------------------------------------',//20x, $ 'FINAL ESTIMATOR',20x,'CONCURRENT ESTIMATOR'/' 90%'/ $ ' CONFIDENCE',12x,2g11.4,20x,2g11.4,/' INTERVAL'//' 70%'/ $ ' CONFIDENCE',12x,2g11.4,20x,2g11.4,/' INTERVAL'/) write (Nio,7043) -a1(1), a1(1), -a2(1), a2(1), & -a3(1), a3(1), -a4(1), a4(1) end if end if end C C C subroutine CLASSIFY(val,nval,mq,svalue) C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' integer kp parameter (kp = PFCST) C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Not Written .. real*8 val(kp) C.. In/Out Status: Maybe Read, Not Written .. integer nval C.. In/Out Status: Read, Not Written .. integer mq C.. In/Out Status: Not Read, Overwritten .. integer svalue C C.. Local Scalars .. integer i real*8 count1,count2,count3 C C ... Executable Statements ... C C C sVALUE IS THE SIGNIFICANCE : C -1 CLEARLY SIGNIFICANT C 0 BORDERLINE SIGNIFICANT C 1 NOT SIGNIFICANT C svalue = 1 if (mq .eq. 2) then do i = 1,nval if (val(i) .gt. (2.1d0)) then svalue = -1 end if end do if (svalue .ne. 1) return do i = 1,nval if (val(i) .gt. (1.9d0)) then svalue = 0 end if end do else if (mq .eq. 3) then count1 = 0 count2 = 0 do i = 1,nval if (val(i) .gt. (2.2d0)) then count1 = count1 + 1 end if if (val(i) .gt. (2.0d0)) then count2 = count2 + 1 end if end do if (count1 .ge. 1) then svalue = -1 else if (count2 .ge. 2) then svalue = -1 end if if (svalue .ne. 1) return count1 = 0 count2 = 0 do i = 1,nval if (val(i) .gt. (2.0d0)) then count1 = count1 + 1 end if if (val(i) .gt. (1.8d0)) then count2 = count2 + 1 end if end do if (count1 .ge. 1) then svalue = 0 else if (count2 .ge. 2) then svalue = 0 end if else if (mq .eq. 4) then count1 = 0 count2 = 0 count3 = 0 do i = 1,nval if (val(i) .gt. (2.5d0)) then count1 = count1 + 1 end if if (val(i) .gt. (2.2d0)) then count2 = count2 + 1 end if if (val(i) .gt. (2.0d0)) then count3 = count3 + 1 end if end do if (count1 .ge. 1) then svalue = -1 else if (count2 .ge. 2) then svalue = -1 else if (count3 .ge. 3) then svalue = -1 end if if (svalue .ne. 1) return count1 = 0 count2 = 0 do i = 1,nval if (val(i) .gt. (2.2d0)) then count1 = count1 + 1 end if if (val(i) .gt. (1.9d0)) then count2 = count2 + 1 end if end do if (count1 .ge. 1) then svalue = 0 else if (count2 .ge. 2) then svalue = 0 end if else if (mq .eq. 6) then count1 = 0 count2 = 0 count3 = 0 do i = 1,nval if (val(i) .gt. (5.0d0)) then count3 = count3 + 1 end if end do if (count1 .ge. 1) then svalue = -1 else if (count2 .ge. 2) then svalue = -1 else if (count3 .ge. 3) then svalue = -1 end if if (svalue .ne. 1) return count1 = 0 count2 = 0 do i = 1,nval if (val(i) .gt. (2.5d0)) then count1 = count1 + 1 end if if (val(i) .gt. (1.9d0)) then count2 = count2 + 1 end if end do if (count1 .ge. 1) then svalue = 0 else if (count2 .ge. 2) then svalue = 0 end if else if (mq .eq. 12) then count1 = 0 count2 = 0 count3 = 0 do i = 1,nval if (val(i) .gt. (3.0d0)) then count1 = count1 + 1 end if if (val(i) .gt. (2.5d0)) then count2 = count2 + 1 end if if (val(i) .gt. (2.0d0)) then count3 = count3 + 1 end if end do if (count1 .ge. 1) then svalue = -1 else if (count2 .ge. 2) then svalue = -1 else if (count3 .ge. 3) then svalue = -1 end if if (svalue .ne. 1) return count1 = 0 count2 = 0 count3 = 0 do i = 1,nval if (val(i) .gt. (2.5d0)) then count1 = count1 + 1 end if if (val(i) .gt. (2.0d0)) then count2 = count2 + 1 end if if (val(i) .gt. (1.85d0)) then count3 = count3 + 1 end if end do if (count1 .ge. 1) then svalue = 0 return end if if (count2 .ge. 2) then svalue = 0 else if (count3 .ge. 3) then svalue = 0 end if end if end C C C simul.f0000664006604000003110000000621414521201567011477 0ustar sun00315steps**==simul.f processed by SPAG 6.05Fc at 12:31 on 12 Oct 2004 DOUBLE PRECISION FUNCTION SIMUL(N,A,X,Eps,Indic,Ia) IMPLICIT NONE **--SIMUL7 C C*** Start of declarations rewritten by SPAG INCLUDE 'srslen.prm' C C Dummy arguments C REAL*8 Eps INTEGER Ia,Indic,N REAL*8 A(Ia,*),X(N) C C Local variables C REAL*8 aijck,deter,pivot,y(PLEN) DOUBLE PRECISION DABS,DBLE INTEGER i,intch,ip1,irowi,irowj,irowk,iscan,j,jcoli,jcolj,jcolk, & jscan,jtemp,k,km1,imax,nm1,INT REAL*8 irow(PLEN),jcol(PLEN),jord(PLEN) LOGICAL dpeq EXTERNAL dpeq C C*** End of declarations rewritten by SPAG C c **** Start of Executable Program imax=N DO i=1,N irow(i)=0D0 jcol(i)=0D0 END DO IF (Indic.GE.0) imax=N+1 IF (N.LE.396) THEN deter=1.0D0 DO k=1,N km1=k-1 pivot=0.0D0 DO i=1,N DO j=1,N IF (k.NE.1) THEN DO iscan=1,km1 DO jscan=1,km1 IF (dpeq(DBLE(i),irow(iscan))) GO TO 10 IF (dpeq(DBLE(j),jcol(jscan))) GO TO 10 END DO END DO END IF IF (DABS(A(i,j)).GT.DABS(pivot)) THEN pivot=A(i,j) irow(k)=DBLE(i) jcol(k)=DBLE(j) END IF 10 END DO END DO IF (DABS(pivot).GT.Eps) THEN irowk=INT(irow(k)) jcolk=INT(jcol(k)) deter=deter*pivot DO j=1,imax A(irowk,j)=A(irowk,j)/pivot END DO A(irowk,jcolk)=1.0D0/pivot DO i=1,N aijck=A(i,jcolk) IF (i.NE.irowk) THEN A(i,jcolk)=-aijck/pivot DO j=1,imax IF (j.NE.jcolk) A(i,j)=A(i,j)-aijck*A(irowk,j) END DO END IF END DO ELSE SIMUL=0.0D0 RETURN END IF END DO DO i=1,N irowi=INT(irow(i)) jcoli=INT(jcol(i)) jord(irowi)=jcol(i) IF (Indic.GE.0) X(jcoli)=A(irowi,imax) END DO intch=0 nm1=N-1 DO i=1,nm1 ip1=i+1 DO j=ip1,N IF (jord(j).LT.jord(i)) THEN jtemp=INT(jord(j)) jord(j)=jord(i) jord(i)=DBLE(jtemp) intch=intch+1 END IF END DO END DO IF (intch/2*2.NE.intch) deter=-deter IF (Indic.LE.0) THEN DO j=1,N DO i=1,N irowi=INT(irow(i)) jcoli=INT(jcol(i)) y(jcoli)=A(irowi,j) END DO DO i=1,N A(i,j)=y(i) END DO END DO DO i=1,N DO j=1,N irowj=INT(irow(j)) jcolj=INT(jcol(j)) y(irowj)=A(i,jcolj) END DO DO j=1,N A(i,j)=y(j) END DO END DO SIMUL=deter RETURN END IF ELSE WRITE (6,1010) 1010 FORMAT ('ON TOO BIG') SIMUL=0.0D0 RETURN END IF SIMUL=deter RETURN END skparg.f0000664006604000003110000000300414521201567011627 0ustar sun00315steps**==skparg.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE skparg IMPLICIT NONE c---------------------------------------------------------------------- c Tries to skip over to the next argument in the function as c best it can. Since the function arguments are of the form: c NAME = VALUE or c NAME = (VALUE LIST) . c If the last token is not the ='s then it finds the value c or value list. If the last token is then ='s then it tries to c find the ='s first. Note this will skip over comments and quotes c because it uses lex. c---------------------------------------------------------------------- INCLUDE 'lex.i' c ----------------------------------------------------------------- INTEGER clsgrp EXTERNAL clsgrp c ----------------------------------------------------------------- IF(Nxtktp.eq.EQUALS)CALL lex() c ----------------------------------------------------------------- IF(Nxtktp.eq.LPAREN.or.Nxtktp.eq.LBRAKT)THEN CALL skplst(clsgrp(Nxtktp)) ELSE IF(Nxtktp.eq.DBL.or.Nxtktp.eq.INTGR.or.Nxtktp.eq.NAME.or. & Nxtktp.eq.QUOTE)THEN CALL lex() ELSE CALL inpter(PERROR,Lstpos,'Expected NAME=VALUE or NAME=(LIST) '// & 'not "'//Nxttok(1:Nxtkln)//'"') CALL abend END IF c ----------------------------------------------------------------- RETURN c ----------------------------------------------------------------- END skparm.f0000664006604000003110000000242014521201570011630 0ustar sun00315steps**==skparm.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE skparm(Lauto) IMPLICIT NONE c----------------------------------------------------------------------- c Trys to point the input stream beyond the current an ARMA model c----------------------------------------------------------------------- INCLUDE 'lex.i' c ------------------------------------------------------------------ LOGICAL Lauto c ------------------------------------------------------------------ DO WHILE (.true.) c ------------------------------------------------------------------ IF(Nxtktp.ne.NAME.and.Nxtktp.ne.QUOTE.and.Nxtktp.ne.RBRACE.and. & Nxtktp.ne.EOF)THEN c ------------------------------------------------------------------ c Added by BCM April 1996 to break out of endless loop when a "bad" c model is entered in a model file. c ------------------------------------------------------------------ IF(Lauto.and.Nxtktp.eq.STAR)RETURN c ------------------------------------------------------------------ CALL lex() GO TO 10 END IF c ------------------------------------------------------------------ RETURN 10 CONTINUE END DO END skpfcn.f0000664006604000003110000000223414521201570011622 0ustar sun00315steps**==skpfcn.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE skpfcn(Fname,Nfn) c----------------------------------------------------------------------- c Trys to point the input stream beyond the current specification c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'lex.i' c ------------------------------------------------------------------ CHARACTER Fname*(LINLEN) INTEGER Nfn c ------------------------------------------------------------------ DO WHILE (.true.) IF(Nxtktp.eq.EOF)THEN CALL inpter(PERROR,Lstpos, & 'No closing brace "}" on specification, "'// & Fname(1:Nfn)//'"') c ------------------------------------------------------------------ ELSE IF(Nxtktp.ne.RBRACE)THEN CALL lex() GO TO 10 c ------------------------------------------------------------------ ELSE CALL lex() END IF GO TO 20 10 CONTINUE END DO c ------------------------------------------------------------------ 20 RETURN END skplst.f0000664006604000003110000000163514521201570011662 0ustar sun00315steps**==skplst.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE skplst(Clsgtp) c---------------------------------------------------------------------- c Looks for a close list character or end-of-file and returns. c Note this will skip over comments and quotes because it uses lex. c---------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'lex.i' c ----------------------------------------------------------------- INTEGER Clsgtp c ----------------------------------------------------------------- DO WHILE (.true.) IF(Nxtktp.ne.Clsgtp.and.Nxtktp.ne.EOF)THEN CALL lex() c ----------------------------------------------------------------- ELSE CALL lex() RETURN END IF END DO c ----------------------------------------------------------------- END smeadl.f0000664006604000003110000000073414521201570011606 0ustar sun00315steps**==smeadl.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE smeadl(X,N1,N2,N,Xmean) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION an,sumf,X,Xmean INTEGER i,N,N1,N2 C*** End of declarations inserted by SPAG C MEAN DELETION C SUMF: FUNCTION DIMENSION X(*) an=dble(N) Xmean=sumf(X,N1,N2)/an DO i=N1,N2 X(i)=X(i)-Xmean END DO RETURN END smpeak.f0000664006604000003110000000432014521201570011614 0ustar sun00315stepsC Last change: BCM 12 Nov 1998 10:53 am **==ispeak.f processed by SPAG 4.03F at 14:16 on 28 Sep 1994 INTEGER FUNCTION smpeak(Sxx,Lsa,Peaks,Lowlim,Uplim,Npeaks,Star1, & Mlimit,Nform,Spclab) IMPLICIT NONE c----------------------------------------------------------------------- c Function that flags possible trading day or seasonal peaks in a c given set of spectral estimates. Peak must be greater than the c median of the spectral estimates computed (Mlimit). The peaks of c interest are defined in the vector pkvec. c----------------------------------------------------------------------- INCLUDE 'notset.prm' c----------------------------------------------------------------------- CHARACTER labvec*(2),domfrq*(2),frqlab*(2),Spclab*(*) LOGICAL Lsa DOUBLE PRECISION Mlimit,Sxx,sbase,Star1,domsxx,starz INTEGER i,freq,Nform,pkidx,Peaks,Lowlim,Uplim,Npeaks DIMENSION Sxx(*),Peaks(*),Lowlim(*),Uplim(*),labvec(10) c----------------------------------------------------------------------- DATA labvec/'t1','t2','t3','t4','t5','s1','s2','s3','s4','s5'/ c----------------------------------------------------------------------- domfrq = 'no' domsxx = DNOTST smpeak = NOTSET c----------------------------------------------------------------------- DO i=1,Npeaks freq=Peaks(i) sbase=max(Sxx(Lowlim(i)),Sxx(Uplim(i))) starz=(Sxx(freq)-sbase)/Star1 pkidx=i IF(Lsa)pkidx=i+5 frqlab=labvec(pkidx) IF(Sxx(freq).gt.domsxx.and.Sxx(freq).gt.Mlimit.and. & starz.gt.0D0)THEN domfrq=frqlab domsxx=Sxx(freq) smpeak=freq END IF IF(starz.le.0D0)THEN WRITE(Nform,1010)Spclab,frqlab,'nopeak' ELSE IF(Sxx(freq).gt.Mlimit)THEN WRITE(Nform,1020)Spclab,frqlab,starz,'+' ELSE WRITE(Nform,1020)Spclab,frqlab,starz,' ' END IF END DO WRITE(Nform,1010)Spclab,frqlab(1:1)//'.dom',domfrq c----------------------------------------------------------------------- 1010 FORMAT(a,'.',a,': ',a) 1020 FORMAT(a,'.',a,': ',f6.1,' ',a) RETURN END snrasp.f0000664006604000003110000000410114521201570011637 0ustar sun00315steps**==snrasp.f processed by SPAG 4.03F at 10:39 on 20 Oct 1994 SUBROUTINE snrasp(A,B,Sxx,Frq,Sgme2,L,K,H1,Ldecbl) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION A,B,cst1,g,gi1,gi2,gr1,gr2,pxx,Sgme2,t,Sxx,Frq INTEGER i,i1,K,k1,L,l1 LOGICAL Ldecbl C*** End of declarations inserted by SPAG c----------------------------------------------------------------------- C THIS PROGRAM COMPUTES POWER SPECTRUM OF AN AR-MA PROCESS DEFINED B C X(N)=A(1)X(N-1)+...+A(L)X(N-L)+E(N)+B(1)E(N-1)+...+B(K)E(N-K), C WHERE E(N) IS A WHITE NOISE WITH ZERO MEAN AND VARIANCE EQUAL TO C SGME2. OUTPUTS PXX(I) ARE GIVEN AT FREQUENCIES I/(2*H) C I=0,1,...,H. C REQUIRED INPUTS ARE: C L,K,H,SGME2,(A(I),I=1,L), AND (B(I),I=1,K). C 0 IS ALLOWABLE AS L AND/OR K. c----------------------------------------------------------------------- INTEGER H1 DIMENSION A(*),B(*) DIMENSION g(H1),gr1(H1),gi1(H1),gr2(H1),gi2(H1) DIMENSION pxx(H1),Sxx(*),Frq(*) c----------------------------------------------------------------------- DOUBLE PRECISION decibl EXTERNAL decibl c----------------------------------------------------------------------- cst1=1.0D-00 IF(L.gt.0)THEN DO i=1,L A(i)=-A(i) END DO END IF l1=L+1 k1=K+1 g(1)=cst1 IF(L.gt.0)THEN DO i=1,L i1=i+1 g(i1)=-A(i) END DO END IF C COMMON SUBROUTINE CALL CALL fouger(g,l1,gr1,gi1,H1,Frq) g(1)=cst1 IF(K.gt.0)THEN DO i=1,K i1=i+1 g(i1)=B(i) END DO END IF C COMMON SUBROUTINE CALL CALL fouger(g,k1,gr2,gi2,H1,Frq) DO i=1,H1 pxx(i)=(gr2(i)**2+gi2(i)**2)/(gr1(i)**2+gi1(i)**2)*Sgme2 END DO IF(Ldecbl)THEN DO i=1,H1 t=pxx(i) IF(t.lt.0D0)t=-t Sxx(i)=decibl(dble(t)) END DO ELSE DO i=1,H1 Sxx(i)=pxx(i) END DO END IF RETURN END spcdrv.f0000664006604000003110000011604014521201570011640 0ustar sun00315stepsC Last change: BCM 19 May 2003 9:46 am SUBROUTINE spcdrv(Muladd,Iagr,Kswv,Ny,Lx11,Kfulsm,X11agr,Lseats, & Psuadd,Lgraf,Lmodel) IMPLICIT NONE c----------------------------------------------------------------------- c Routine which computes the spectrum for the detrended original c series, detrended seasonally adjusted series, and the irregular c component modified for extreme values. If there are peaks c detected at the trading day or seasonal frequencies, these are c noted. c----------------------------------------------------------------------- c AR-Spectrum routines originally appeared in the BAYSEA program, c developed by H. Akaike and G. Kitagawa of the Institute for c Statistical Mathematics. c----------------------------------------------------------------------- CHARACTER STTDIC*74 INTEGER PSTT,IONE,SIXONE,IZERO,ITEN,NTDLIM DOUBLE PRECISION ZERO,ONE LOGICAL F,T PARAMETER(F=.false.,T=.true.,PSTT=4,IONE=1,SIXONE=61,IZERO=0, & ZERO=0D0,ONE=1D0,ITEN=10,NTDLIM=60, & STTDIC='differencedundifferenceddifferenced, transformed &undifferenced, transformed') c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'tbltitle.prm' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'inpt.cmn' INCLUDE 'model.cmn' INCLUDE 'seatcm.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'units.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'error.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'title.cmn' INCLUDE 'rho.cmn' INCLUDE 'spcidx.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'x11log.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'adxser.cmn' INCLUDE 'tukey.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'spcsvl.i' INCLUDE 'mdltbl.i' INCLUDE 'spctbl.i' c----------------------------------------------------------------------- CHARACTER ttl*(PTTLEN),pkstr*(24),begstr*(10),cttl*(26),arstr*(2), & ctype*(19),endstr*(10),spcstr*(36),csatbl*(11), & skystr*(10) DOUBLE PRECISION Lam,orisxx,sasxx,irrsxx,orsxx2,sasxx2,irsxx2, & Stime,Stmcd,trnsrs,srs,tmpsrs,Stex,Htmp,mvtmp INTEGER i,l0,l1,Ny,Muladd,Iagr,Kswv,ipk,ipos,Fcntyp,nchr1,nchr2, & sttptr,nttl,ittl,ntype,itbl,numttl,mtspc,ltdori,ltdsa, & ltdirr,lsori,lssa,lsirr,frqidx,icode,Endspn,Begxy,Nrxy, & nplot,nspstr,nspst2,domfqs,domfqt,nobspc,fhnote,nsatbl, & Kfulsm,istr,ldsp,l2,igrp,mtmp,nsrs,nkystr LOGICAL goori,gosa,goirr,Lx11,X11agr,Lseats,prtori,prtsa,prtirr, & Psuadd,Lgraf,ltdfrq,nosa,Lmodel DIMENSION orisxx(61),sasxx(61),irrsxx(61),orsxx2(76),sasxx2(76), & irsxx2(76),trnsrs(PLEN),tmpsrs(PLEN), & Stex(PLEN),Stmcd(PLEN),Stime(PLEN),sttptr(0:PSTT), & numttl(2),ttl(2),srs(PLEN),Begxy(2),Endspn(2), & Htmp(0:PLEN),mvtmp(14) c----------------------------------------------------------------------- COMMON /armalm/ Lam,Fcntyp COMMON /armaxy/ Endspn,Begxy,Nrxy COMMON /mq5a / Stmcd,Stime COMMON /mq10 / Stex c----------------------------------------------------------------------- LOGICAL dpeq,ispos INTEGER strinx EXTERNAL dpeq,ispos,strinx c----------------------------------------------------------------------- DATA sttptr/1,12,25,49,75/ c----------------------------------------------------------------------- c Set logical variables for printing out spectra c----------------------------------------------------------------------- prtsa=(Iagr.lt.4.and.((Lseats.and.Prttab(LSPS1S)).or. & (Lx11.and.Kfulsm.eq.0.and.Prttab(LSPCS1)))).or. & (Iagr.eq.4.and.Prttab(LSPS1I)) prtirr=(Iagr.lt.4.and.((Lseats.and.Prttab(LSPS2S)).or. & (Lx11.and.Kfulsm.eq.0.and.Prttab(LSPCS2)))).or. & (Iagr.eq.4.and.Prttab(LSPS2I).and.X11agr) prtori=(Iagr.lt.3.and.Prttab(LSPCS0)).or. & (Iagr.eq.3.and.Prttab(LSPS0C)) c----------------------------------------------------------------------- fhnote=STDERR IF(Lquiet)fhnote=0 nosa=.not.((Lx11.and.Kfulsm.eq.0).or.Lseats) c----------------------------------------------------------------------- c Initialize indicator variable for spectral plot title c----------------------------------------------------------------------- ittl=2 IF(Spcdff)THEN IF(Spdfor.eq.NOTSET)THEN IF(Lmodel)THEN Spdfor=max(Nnsedf+Nseadf-1,1) ELSE Spdfor=1 END IF END IF END IF IF(Lsumm.gt.0)THEN IF(Spcdff)THEN WRITE(Nform,1000)'diffspec: ','yes' WRITE(Nform,1010)'diffspecorder: ',Spdfor IF(Lstdff)THEN WRITE(Nform,1000)'diffspecstart: ','yes' ELSE WRITE(Nform,1000)'diffspecstart: ','no' END IF ELSE WRITE(Nform,1000)'diffspec: ','no' END IF END IF IF(Spdfor.eq.0)THEN IF(Spcdff)Spcdff=F ELSE ittl=1 END IF c----------------------------------------------------------------------- c Get relative position of starting point for spectrums c----------------------------------------------------------------------- c CALL dfdate(Bgspec,Begbak,Ny,ipos) CALL dfdate(Bgspec,Begbk2,Ny,ipos) ipos=ipos+1 IF(Lstdff)THEN l1=ipos l0=l1-Spdfor IF(l0.lt.Pos1ob)THEN ldsp=Pos1ob-l0 l1=l1+ldsp CALL addate(Bgspec,Ny,ldsp,Bgspec) l0=Pos1ob END IF ELSE l0=ipos l1=ipos+Spdfor END IF nobspc=Posfob-l1+1 ltdfrq=nobspc.gt.NTDLIM c----------------------------------------------------------------------- c Check to see if all observations are good for logged original c series c----------------------------------------------------------------------- goori=Iagr.le.3 gosa=F goirr=F IF(goori)THEN c----------------------------------------------------------------------- IF(Spcsrs.ge.2)THEN CALL copy(Stcsi,PLEN,1,srs) IF(Lx11.and.(Spcsrs.eq.2))THEN IF(Psuadd)THEN DO i=Pos1ob,Posfob IF(Kfulsm.eq.2)THEN srs(i)=Stc(i)*Sti(i) ELSE srs(i)=Stc(i)*(Sts(i)+(Sti(i)-ONE)) END IF END DO ELSE CALL addmul(srs,srs,Stex,Pos1bk,Posffc) END IF END IF ELSE CALL copy(Series,PLEN,1,srs) IF(Spcsrs.eq.1)THEN IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,ipos,Posfob) IF(Adjao.eq.1)CALL divsub(srs,srs,Facao,ipos,Posfob) IF(Adjtc.eq.1)CALL divsub(srs,srs,Factc,ipos,Posfob) IF(Adjso.eq.1)CALL divsub(srs,srs,Facso,ipos,Posfob) END IF END IF IF(Muladd.eq.0)goori=ispos(srs,ipos,Posfob) END IF IF(goori)THEN c----------------------------------------------------------------------- c Detrend original series before computing spectrum c----------------------------------------------------------------------- IF(Lx11)THEN IF(Muladd.ne.1)ittl=ittl+2 CALL gendff(srs,l0,Posfob,tmpsrs,l2,Muladd.ne.1,F,Spdfor) ELSE IF(dpeq(Lam,ZERO))THEN CALL gendff(srs,l0,Posfob,tmpsrs,l2,T,F,Spdfor) ittl=ittl+2 ELSE CALL gendff(srs,l0,Posfob,tmpsrs,l2,F,F,Spdfor) END IF END IF IF(Spctyp.eq.0)THEN c----------------------------------------------------------------------- c Compute the AR-spectrum for the detrended original series c----------------------------------------------------------------------- CALL spgrh(tmpsrs,orsxx2,frqpk,Thtapr,l1,Posfob,nfreq,Ny,Mxarsp, & Ldecbl,goori) CALL spgrh(tmpsrs,orisxx,frq,Thtapr,l1,Posfob,61,Ny,Mxarsp, & Ldecbl,goori) ELSE c----------------------------------------------------------------------- c Else, compute the periodogram for the detrended original series c----------------------------------------------------------------------- CALL spgrh2(tmpsrs,orsxx2,frqpk,l1,Posfob,nfreq,Ldecbl) CALL spgrh2(tmpsrs,orisxx,frq,l1,Posfob,61,Ldecbl) END IF c----------------------------------------------------------------------- c Save spectrum of the detrended original series c----------------------------------------------------------------------- itbl=LSPCS0 IF(Iagr.eq.4)itbl=LSPS0C IF((Savtab(itbl).or.Lgraf).and.goori)THEN CALL mksplb(itbl,spcstr,nspstr,Spcsrs,Ldecbl) IF(Svallf)THEN IF(Savtab(itbl).and.goori) & CALL savspp(itbl,orsxx2,frqpk,nfreq,spcstr(1:nspstr),F) IF(.not.Lfatal.and.Lgraf.and.goori) & CALL savspp(itbl,orsxx2,frqpk,nfreq,spcstr(1:nspstr),Lgraf) ELSE IF(Savtab(itbl).and.goori) & CALL savspp(itbl,orisxx,frq,61,spcstr(1:nspstr),F) IF(.not.Lfatal.and.Lgraf.and.goori) & CALL savspp(itbl,orisxx,frq,61,spcstr(1:nspstr),Lgraf) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- c peaks for Tukey filtered spectrum from TRAMO/SEATS c----------------------------------------------------------------------- IF(Iagr.eq.4)THEN itbl=LSPT0C ELSE itbl=LSPTS0 END IF IF(Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK).or. & Savtab(itbl).or.Lgraf)THEN nsrs=Posfob-l1+1 IF(nsrs.gt.80)THEN DO i=l1,Posfob srs(i-l1+1)=tmpsrs(i) END DO CALL getTPeaks(srs,nsrs,Ny,Htmp,mtmp,Pttdo,Ptso,mvtmp) IF(Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK))THEN Ntukey=Ntukey+1 Itukey(Ntukey)=itbl END IF IF(Savtab(itbl).or.Lgraf)THEN CALL mkstlb(itbl,spcstr,nspstr,Spcsrs) IF(Savtab(itbl)) & CALL savstp(itbl,Htmp,mtmp,spcstr(1:nspstr),Ldecbl,F) IF((.not.Lfatal).and.Lgraf) & CALL savstp(itbl,Htmp,mtmp,spcstr(1:nspstr),Ldecbl,Lgraf) IF(Lfatal)RETURN END IF IF(Lsumm.gt.0)THEN CALL mkspky(1,skystr,nkystr,Iagr,Lseats) write(Nform,1080)skystr(1:nkystr),mtmp END IF END IF END IF c----------------------------------------------------------------------- c Print out error message for spectral plot of logged original c series if data value is less than zero. c----------------------------------------------------------------------- ELSE IF(Iagr.le.3)THEN CALL writln('ERROR: Spectral plot for the logged original series &cannot be done for',STDERR,Mt2,T) CALL writln(' a series with values less than or equal to ze &ro.',STDERR,Mt2,F) END IF IF((Lx11.and.Kfulsm.eq.0).or.Lseats)THEN c----------------------------------------------------------------------- c Check to see if all observations are good for logged seasonally c adjusted series c----------------------------------------------------------------------- gosa=T IF(Lx11)THEN IF(Lrbstsa)THEN IF(Muladd.eq.0)THEN DO i=ipos,Posfob gosa=gosa.and.Stcime(i).gt.ZERO END DO END IF END IF ELSE gosa=Hvstsa END IF IF(gosa)THEN IF(Iagr.eq.4)THEN IF(X11agr)THEN IF(Lrbstsa)THEN CALL copy(Stcime,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,ipos,Posfob) ELSE CALL copy(Stci,PLEN,1,srs) END IF ELSE CALL copy(Stci,PLEN,1,srs) IF(Adjls.eq.1.and.Lrbstsa) & CALL divsub(srs,srs,Facls,ipos,Posfob) END IF ELSE IF(Lx11)THEN IF(Lrbstsa)THEN CALL copy(Stcime,PLEN,1,srs) IF(Adjls.eq.1)CALL divsub(srs,srs,Facls,ipos,Posfob) ELSE CALL copy(Stci,PLEN,1,srs) END IF ELSE IF(Lrbstsa)THEN CALL copy(Stocsa,PLEN,1,srs) ELSE CALL copy(Seatsa,PLEN,1,srs) END IF END IF c----------------------------------------------------------------------- c Detrend seasonally adjusted series before computing spectrum c----------------------------------------------------------------------- CALL gendff(srs,l0,Posfob,tmpsrs,l2,Muladd.ne.1,F,Spdfor) c----------------------------------------------------------------------- c Compute the AR-spectrum for the detrended seasonally adjusted c series c----------------------------------------------------------------------- IF(Spctyp.eq.0)THEN CALL spgrh(tmpsrs,sasxx2,frqpk,Thtapr,l1,Posfob,nfreq,Ny, & Mxarsp,Ldecbl,gosa) CALL spgrh(tmpsrs,sasxx,frq,Thtapr,l1,Posfob,61,Ny,Mxarsp, & Ldecbl,gosa) ELSE c----------------------------------------------------------------------- c Else, compute the periodogram for the detrended seasonally c adjusted series c----------------------------------------------------------------------- CALL spgrh2(tmpsrs,sasxx2,frqpk,l1,Posfob,nfreq,Ldecbl) CALL spgrh2(tmpsrs,sasxx,frq,l1,Posfob,61,Ldecbl) END IF c----------------------------------------------------------------------- c Save spectrum of the detrended seasonally adjusted series c----------------------------------------------------------------------- IF(Iagr.eq.4)THEN itbl=LSPS1I ELSE IF(Lseats)THEN itbl=LSPS1S ELSE itbl=LSPCS1 END IF IF((Savtab(itbl).or.Lgraf).and.gosa)THEN CALL mksplb(itbl,spcstr,nspstr,Spcsrs,Ldecbl) IF(Svallf)THEN IF(Savtab(itbl).and.gosa) & CALL savspp(itbl,sasxx2,frqpk,nfreq,spcstr(1:nspstr),F) IF((.not.Lfatal).and.Lgraf.and.gosa) & CALL savspp(itbl,sasxx2,frqpk,nfreq,spcstr(1:nspstr),Lgraf) ELSE IF(Savtab(itbl).and.gosa) & CALL savspp(itbl,sasxx,frq,61,spcstr(1:nspstr),F) IF((.not.Lfatal).and.Lgraf.and.gosa) & CALL savspp(itbl,sasxx,frq,61,spcstr(1:nspstr),Lgraf) END IF IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c peaks for Tukey filtered spectrum from TRAMO/SEATS c----------------------------------------------------------------------- IF(Iagr.eq.4)THEN itbl=LSPT1I ELSE IF(Lseats)THEN itbl=LSPT1S ELSE itbl=LSPTS1 END IF IF((Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK).or. & Savtab(itbl).or.Lgraf).and.gosa)THEN nsrs=Posfob-l1+1 IF(nsrs.gt.80)THEN DO i=l1,Posfob srs(i-l1+1)=tmpsrs(i) END DO CALL getTPeaks(srs,nsrs,Ny,Htmp,mtmp,Pttda,Ptsa,mvtmp) IF(Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK))THEN Ntukey=Ntukey+1 Itukey(Ntukey)=itbl END IF IF(Savtab(itbl).or.Lgraf)THEN CALL mkstlb(itbl,spcstr,nspstr,Spcsrs) IF(Savtab(itbl)) & CALL savstp(itbl,Htmp,mtmp,spcstr(1:nspstr),Ldecbl,F) IF((.not.Lfatal).and.Lgraf) & CALL savstp(itbl,Htmp,mtmp,spcstr(1:nspstr),Ldecbl,Lgraf) IF(Lfatal)RETURN END IF IF(Lsumm.gt.0)THEN CALL mkspky(2,skystr,nkystr,Iagr,Lseats) write(Nform,1080)skystr(1:nkystr),mtmp END IF END IF END IF c----------------------------------------------------------------------- c Print out error message for spectral plot of logged original c series if data value is less than zero. c----------------------------------------------------------------------- ELSE IF(Lx11)THEN CALL writln('ERROR: Spectral plot for the logged seasonally adju &sted series cannot',STDERR,Mt2,T) CALL writln(' be done for a seasonal adjustment with value &s less than or equal',STDERR,Mt2,F) CALL writln(' to zero.',STDERR,Mt2,F) c----------------------------------------------------------------------- c Print out warning message when SEATS cannot supply a seasonal c adjustment. c----------------------------------------------------------------------- ELSE CALL writln('NOTE: Spectral plot for the seasonally adjusted ser &ies cannot be done',fhnote,Mt2,T) CALL writln(' when SEATS cannot perform a signal extraction &.',fhnote,Mt2,F) RETURN END IF c----------------------------------------------------------------------- c Compute the AR-spectrum for the modified irregular component c----------------------------------------------------------------------- goirr=T IF(Lseats)goirr=Hvstir IF(Iagr.eq.4)goirr=goirr.and.X11agr IF(goirr)THEN DO i=ipos,Posfob IF(Lx11)THEN IF(Lrbstsa)THEN tmpsrs(i)=Stime(i) ELSE tmpsrs(i)=Sti(i) END IF ELSE IF(Lrbstsa)THEN tmpsrs(i)=Stocir(i) ELSE tmpsrs(i)=Seatir(i) END IF END IF IF(Muladd.ne.1)tmpsrs(i)=tmpsrs(i)-1D0 END DO c----------------------------------------------------------------------- IF(Spctyp.eq.0)THEN CALL spgrh(tmpsrs,irsxx2,frqpk,Thtapr,ipos,Posfob,nfreq,Ny, & Mxarsp,Ldecbl,goirr) CALL spgrh(tmpsrs,irrsxx,frq,Thtapr,ipos,Posfob,61,Ny,Mxarsp, & Ldecbl,goirr) ELSE c----------------------------------------------------------------------- c Else, compute the periodogram for the modified irregular component c----------------------------------------------------------------------- CALL spgrh2(tmpsrs,irsxx2,frqpk,ipos,Posfob,nfreq,Ldecbl) CALL spgrh2(tmpsrs,irrsxx,frq,ipos,Posfob,61,Ldecbl) END IF c----------------------------------------------------------------------- c Save spectrum of the modified irregular component c----------------------------------------------------------------------- IF(Iagr.eq.4)THEN itbl=LSPS2I ELSE IF(Lseats)THEN itbl=LSPS2S ELSE itbl=LSPCS2 END IF IF((Savtab(itbl).or.Lgraf).and.goirr)THEN CALL mksplb(itbl,spcstr,nspstr,Spcsrs,Ldecbl) IF(Svallf)THEN IF(Savtab(itbl).and.goirr) & CALL savspp(itbl,irsxx2,frqpk,nfreq,spcstr(1:nspstr),F) IF(.not.Lfatal.and.Lgraf.and.goirr) & CALL savspp(itbl,irsxx2,frqpk,nfreq,spcstr(1:nspstr),Lgraf) ELSE IF(Savtab(itbl).and.goirr) & CALL savspp(itbl,irrsxx,frq,61,spcstr(1:nspstr),F) IF(.not.Lfatal.and.Lgraf.and.goirr) & CALL savspp(itbl,irrsxx,frq,61,spcstr(1:nspstr),Lgraf) END IF IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c peaks for Tukey filtered spectrum from TRAMO/SEATS c----------------------------------------------------------------------- IF(Iagr.eq.4)THEN itbl=LSPT2I ELSE IF(Lseats)THEN itbl=LSPT2S ELSE itbl=LSPTS2 END IF IF((Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK).or. & Savtab(itbl).or.Lgraf).and.goirr)THEN nsrs=Posfob-ipos+1 IF(nsrs.gt.80)THEN DO i=ipos,Posfob srs(i-ipos+1)=tmpsrs(i) END DO CALL getTPeaks(srs,nsrs,Ny,Htmp,mtmp,Pttdi,Ptsi,mvtmp) IF(Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK))THEN Ntukey=Ntukey+1 Itukey(Ntukey)=itbl END IF IF(Savtab(itbl).or.Lgraf)THEN CALL mkstlb(itbl,spcstr,nspstr,Spcsrs) IF(Savtab(itbl)) & CALL savstp(itbl,Htmp,mtmp,spcstr(1:nspstr),Ldecbl,F) IF((.not.Lfatal).and.Lgraf) & CALL savstp(itbl,Htmp,mtmp,spcstr(1:nspstr),Ldecbl,Lgraf) IF(Lfatal)RETURN END IF IF(Lsumm.gt.0)THEN CALL mkspky(3,skystr,nkystr,Iagr,Lseats) write(Nform,1080)skystr(1:nkystr),mtmp END IF END IF END IF c----------------------------------------------------------------------- END IF END IF c----------------------------------------------------------------------- IF(.not.(goori.or.gosa.or.goirr))RETURN c----------------------------------------------------------------------- c Determine if there are peaks in the spectral plots. c----------------------------------------------------------------------- ltdsa=0 ltdirr=0 lssa=0 lsirr=0 IF((Lx11.and.Kfulsm.eq.0).or.Lseats)THEN IF(gosa)THEN CALL idpeak(sasxx,sasxx2,Spclim,Ny,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,ltdsa,lssa,frqpk,Plocal,Ldecbl, & ltdfrq) IF(Lsumm.gt.0) & CALL svpeak(sasxx,sasxx2,2,Iagr,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,Lseats,Ldecbl,ltdfrq) END IF IF(goirr)THEN CALL idpeak(irrsxx,irsxx2,Spclim,Ny,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,ltdirr,lsirr,frqpk,Plocal,Ldecbl, & ltdfrq) IF(Lsumm.gt.0) & CALL svpeak(irrsxx,irsxx2,3,Iagr,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,Lseats,Ldecbl,ltdfrq) END IF END IF c----------------------------------------------------------------------- c If TD adjustment done, do not search for trading day peaks c in the original series. Search for seasonal peaks only when there c is no seasonal adjustment performed. c----------------------------------------------------------------------- IF(prtsa)THEN prtsa=prtsa.and.gosa ELSE prtsa=(ltdsa.gt.0.or.lssa.gt.0).and.(.not.Lnoprt) END IF IF(prtirr)THEN prtirr=prtirr.and.goirr ELSE prtirr=(ltdirr.gt.0.or.lsirr.gt.0).and.(.not.Lnoprt) END IF ltdori=0 lsori=0 IF(goori)THEN CALL idpeak(orisxx,orsxx2,Spclim,Ny,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,ltdori,lsori,frqpk,Plocal,Ldecbl, & ltdfrq) IF(Lsumm.gt.0) & CALL svpeak(orisxx,orsxx2,1,Iagr,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,Lseats,Ldecbl,ltdfrq) END IF c----------------------------------------------------------------------- c Get descriptor for spectral plot title c----------------------------------------------------------------------- CALL getstr(STTDIC,STTPTR,PSTT,ittl,cttl,nttl) IF(.not.Lfatal)CALL wrtdat(Bgspec,Ny,begstr,nchr1) IF(.not.Lfatal)CALL wrtdat(Endspn,Ny,endstr,nchr2) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print a warning message if a peak is found in any of the spectral c plots. *c----------------------------------------------------------------------- IF((ltdori.gt.0.or.ltdsa.gt.0.or.ltdirr.gt.0).and. & (lssa.gt.0.or.lsirr.gt.0.or.(nosa.and.lsori.gt.0)))THEN CALL writln('WARNING: Visually significant seasonal and trading d &ay peaks have ',fhnote,Mt2,T) CALL writln( &' been found in one or more of the estimated spectra.', & fhnote,Mt2,F) pkstr='trading day and seasonal' ipk=24 ELSE IF((ltdori.gt.0.or.ltdsa.gt.0.or.ltdirr.gt.0).or. & (lssa.gt.0.or.lsirr.gt.0.or.(nosa.and.lsori.gt.0)))THEN IF(ltdori.gt.0.or.ltdsa.gt.0.or.ltdirr.gt.0)THEN pkstr='trading day' ipk=11 ELSE pkstr='seasonal' ipk=8 END IF CALL writln('WARNING: At least one visually significant '// & pkstr(1:ipk)//' peak has been',fhnote,Mt2,T) CALL writln( & ' found in one or more of the estimated spectra.', & fhnote,Mt2,F) END IF c----------------------------------------------------------------------- mtspc=Mt1 IF(ltdori.gt.0.or.ltdsa.gt.0.or.ltdirr.gt.0.or.lssa.gt.0.or. & lsirr.gt.0.or.(nosa.and.lsori.gt.0))THEN IF((.not.(prtori.or.prtsa.or.prtirr)).and.Lnoprt)THEN mtspc=Mt2 WRITE(STDERR,1070) ELSE IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF END IF nplot=0 IF(ltdori.gt.0.or.(nosa.and.lsori.gt.0))nplot=nplot+1 IF(ltdsa.gt.0.or.lssa.gt.0)nplot=nplot+1 IF(ltdirr.gt.0.or.lsirr.gt.0)nplot=nplot+1 IF(nplot.eq.1)THEN WRITE(mtspc,1020)pkstr(1:ipk),'plot',begstr(1:nchr1) ELSE WRITE(mtspc,1020)pkstr(1:ipk),'plots',begstr(1:nchr1) END IF c----------------------------------------------------------------------- c Warning for detrended original c----------------------------------------------------------------------- CALL mkspst(Spcsrs,spcstr,nspstr,nspst2,F) IF((.not.((Lx11.and.Kfulsm.eq.0).or.Lseats).and.lsori.gt.0).and. & ltdori.gt.0)THEN WRITE(mtspc,1040)cttl(1:nttl)//spcstr(1:nspstr),lsori,ltdori ELSE IF(ltdori.gt.0)THEN WRITE(mtspc,1030)cttl(1:nttl)//spcstr(1:nspstr),ltdori ELSE IF((.not.Lx11).and.lsori.gt.0)THEN WRITE(mtspc,1050)cttl(1:nttl)//spcstr(1:nspstr),lsori END IF c----------------------------------------------------------------------- c Warning for detrended seasonally adjusted series c----------------------------------------------------------------------- IF(Lseats)THEN csatbl(1:7) = '(SEATS)' nsatbl=7 ELSE IF(Iagr.le.3.or.X11agr)THEN IF(Lrbstsa)THEN csatbl(1:10) = '(Table E2)' nsatbl=10 ELSE csatbl(1:11) = '(Table D11)' nsatbl=11 END IF ELSE csatbl(1:11) = '(Table D11)' nsatbl=11 END IF IF(ltdsa.gt.0.and.lssa.gt.0)THEN WRITE(mtspc,1040)cttl(1:nttl)//' seasonally adjusted series '// & csatbl(1:nsatbl),lssa,ltdsa ELSE IF(ltdsa.gt.0)THEN WRITE(mtspc,1030)cttl(1:nttl)//' seasonally adjusted series '// & csatbl(1:nsatbl),ltdsa ELSE IF(lssa.gt.0)THEN WRITE(mtspc,1050)cttl(1:nttl)//' seasonally adjusted series '// & csatbl(1:nsatbl),lssa END IF c----------------------------------------------------------------------- c Warning for modified irregular series c----------------------------------------------------------------------- IF(ltdirr.gt.0.and.lsirr.gt.0)THEN IF(Lx11)THEN IF(Lrbstsa)THEN WRITE(mtspc,1040)'Modified irregular component (Table E3)', & lsirr,ltdirr ELSE WRITE(mtspc,1040)'Irregular component (Table D13)', & lsirr,ltdirr END IF ELSE IF(Lrbstsa)THEN WRITE(mtspc,1040)'Stochastic irregular component (SEATS)', & lsirr,ltdirr ELSE WRITE(mtspc,1040)'Irregular component (SEATS)',lsirr,ltdirr END IF END IF ELSE IF(ltdirr.gt.0)THEN IF(Lx11)THEN IF(Lrbstsa)THEN WRITE(mtspc,1040)'Modified irregular component (Table E3)', & ltdirr ELSE WRITE(mtspc,1040)'Irregular component (Table D13)', & ltdirr END IF ELSE IF(Lrbstsa)THEN WRITE(mtspc,1040)'Stochastic irregular component (SEATS)', & ltdirr ELSE WRITE(mtspc,1040)'Irregular component (SEATS)',ltdirr END IF END IF ELSE IF(lsirr.gt.0)THEN IF(Lx11)THEN IF(Lrbstsa)THEN WRITE(mtspc,1040)'Modified irregular component (Table E3)', & lsirr ELSE WRITE(mtspc,1040)'Irregular component (Table D13)', & lsirr END IF ELSE IF(Lrbstsa)THEN WRITE(mtspc,1040)'Stochastic irregular component (SEATS)', & lsirr ELSE WRITE(mtspc,1040)'Irregular component (SEATS)',lsirr END IF END IF END IF END IF c----------------------------------------------------------------------- c Print warning message if no seasonal peaks is found in original c series and x11 spec present. c----------------------------------------------------------------------- IF(((Lx11.and.Kfulsm.eq.0).or.Lseats).and.lsori.eq.0.and. & goori)THEN IF(Lnoprt.and.mtspc.eq.Mt1)mtspc=Mt2 CALL mkspst(Spcsrs,spcstr,nspstr,nspst2,F) IF(.not.Lquiet)WRITE(STDERR,1060)spcstr(1:nspstr) WRITE(mtspc,1060)spcstr(1:nspstr) IF(Iagr.lt.4)WRITE(mtspc,1061) END IF c----------------------------------------------------------------------- IF(Lsavpk)THEN IF(ltdori.gt.0)THEN Ctpeak((Ntpeak+1):(Ntpeak+3))='ori' Ntpeak=Ntpeak+4 END IF IF(nosa.and.lsori.gt.0)THEN Cspeak((Nspeak+1):(Nspeak+3))='ori' Nspeak=Nspeak+4 END IF IF(ltdsa.gt.0)THEN IF(Iagr.le.3)THEN Ctpeak((Ntpeak+1):(Ntpeak+2))='sa' Ntpeak=Ntpeak+3 ELSE Ctpeak((Ntpeak+1):(Ntpeak+5))='indsa' Ntpeak=Ntpeak+6 END IF END IF IF(lssa.gt.0)THEN IF(Iagr.le.3)THEN Cspeak((Nspeak+1):(Nspeak+2))='sa' Nspeak=Nspeak+3 ELSE Cspeak((Nspeak+1):(Nspeak+5))='indsa' Nspeak=Nspeak+6 END IF END IF IF(ltdirr.gt.0)THEN IF(Iagr.le.3)THEN Ctpeak((Ntpeak+1):(Ntpeak+3))='irr' Ntpeak=Ntpeak+4 ELSE Ctpeak((Ntpeak+1):(Ntpeak+6))='indirr' Ntpeak=Ntpeak+7 END IF END IF IF(lsirr.gt.0)THEN IF(Iagr.le.3)THEN Cspeak((Nspeak+1):(Nspeak+3))='irr' Nspeak=Nspeak+4 ELSE Cspeak((Nspeak+1):(Nspeak+6))='indirr' Nspeak=Nspeak+7 END IF END IF END IF c----------------------------------------------------------------------- c Print plots of spectrums. If peaks are found, produce plots c even if they are not selected by the user. c----------------------------------------------------------------------- IF(.not.(prtori.or.prtsa.or.prtirr).and.Lnoprt)RETURN c----------------------------------------------------------------------- c Spectrum plot for detrended original series c----------------------------------------------------------------------- icode=20 IF(.not.ltdfrq)icode=21 IF(Ldecbl)THEN IF(Spctyp.eq.0)THEN ctype='10*LOG(SPECTRUM)' ntype=16 ELSE ctype='10*LOG(PERIODOGRAM)' ntype=19 END IF ELSE IF(Spctyp.eq.0)THEN ctype='SPECTRUM' ntype=8 ELSE ctype='PERIODOGRAM' ntype=11 END IF END IF IF(goori.and.prtori)THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF c----------------------------------------------------------------------- CALL mkspst(Spcsrs,spcstr,nspstr,nspst2,T) IF(Lwdprt)THEN ttl(1)='G 0 '//ctype(1:ntype)//' of the '//cttl(1:nttl)//' '// & spcstr(1:nspstr) numttl(1)=ntype+nttl+nspstr+14 ttl(2)=' Spectrum estimated from '//begstr(1:nchr1)// & ' to '//endstr(1:nchr2)//'.' numttl(2)=34+nchr1+nchr2 ELSE ttl(1)='G 0 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & spcstr(1:nspst2) numttl(1)=ntype+nttl+nspst2+13 ttl(2)=' '//spcstr(nspst2+1:nspstr)// & '. Spectrum estimated from '//begstr(1:nchr1)//' to '// & endstr(1:nchr2)//'.' numttl(2)=nspstr-nspst2+nchr1+nchr2+36 END IF c----------------------------------------------------------------------- IF(((Lx11.and.Kfulsm.eq.0).or.Lseats).and.prtori.and.prtsa.and. & Axsame)THEN CALL grzlst(IONE,SIXONE,IZERO,orisxx,sasxx,SIXONE,ITEN,IZERO) ELSE CALL grzlst(IONE,SIXONE,IZERO,orisxx,orisxx,SIXONE,ITEN,IZERO) END IF CALL chrt(ttl,numttl,icode,1,120/Ny) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(nosa)RETURN c----------------------------------------------------------------------- c Spectrum plot for detrended seasonally adjusted series c----------------------------------------------------------------------- IF(prtsa)THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(Lwdprt)THEN IF(Lseats)THEN ttl(1)='G 1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' Seasonally Adjusted Data (SEATS).' numttl(1)=ntype+nttl+47 ELSE IF(Iagr.le.3)THEN IF(Lrbstsa)THEN ttl(1)='G 1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' Seasonally Adjusted Data (Table E2).' numttl(1)=ntype+nttl+50 ELSE ttl(1)='G 1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' Seasonally Adjusted Data (Table D11).' numttl(1)=ntype+nttl+51 END IF ELSE IF(X11agr)THEN IF(Lrbstsa)THEN ttl(1)='G 1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' Seasonally Adjusted Data (Table E2).' numttl(1)=ntype+nttl+50 ELSE ttl(1)='G 1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' Seasonally Adjusted Data (Table D11).' numttl(1)=ntype+nttl+51 END IF ELSE ttl(1)='G 1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' indirect seasonally adjusted data (Table D11).' numttl(1)=ntype+nttl+60 END IF ttl(2)=' Spectrum estimated from '//begstr(1:nchr1)// & ' to '//endstr(1:nchr2)//'.' numttl(2)=34+nchr1+nchr2 ELSE IF(Iagr.le.3)THEN ttl(1)='G 1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' seasonally adjusted' numttl(1)=ntype+nttl+34 ELSE ttl(1)='G.1 '//ctype(1:ntype)//' of the '//cttl(1:nttl)// & ' indirect seasonally adjusted' numttl(1)=ntype+nttl+43 END IF IF(Lseats)THEN ttl(2)=' data (SEATS). Spectrum estimated from '// & begstr(1:nchr1)//' to '//endstr(1:nchr2)//'.' numttl(2)=49+nchr1+nchr2 ELSE IF(Lrbstsa)THEN ttl(2)=' data (Table E2). Spectrum estimated from '// & begstr(1:nchr1)//' to '//endstr(1:nchr2)//'.' numttl(2)=52+nchr1+nchr2 ELSE ttl(2)=' data (Table D11). Spectrum estimated from '// & begstr(1:nchr1)//' to '//endstr(1:nchr2)//'.' numttl(2)=53+nchr1+nchr2 END IF END IF END IF IF(goori.and.prtori.and.prtsa.and.Axsame)THEN CALL grzlst(IONE,SIXONE,IZERO,sasxx,orisxx,SIXONE,ITEN,IZERO) ELSE CALL grzlst(IONE,SIXONE,IZERO,sasxx,sasxx,SIXONE,ITEN,IZERO) END IF CALL chrt(ttl,numttl,icode,1,120/Ny) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Spectrum plot for modified irregular series c----------------------------------------------------------------------- IF(prtirr)THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(Lseats)THEN ttl(1)='G 2 '//ctype(1:ntype)// & ' of the Stochastic Irregular (SEATS).' numttl(1)=ntype+42 ELSE IF(Iagr.le.3)THEN IF(Lrbstsa)THEN ttl(1)='G 2 '//ctype(1:ntype)// & ' of the Modified Irregular (Table E3).' numttl(1)=ntype+45 ELSE ttl(1)='G 2 '//ctype(1:ntype)// & ' of the Irregular (Table D13).' numttl(1)=ntype+37 END IF ELSE IF(Lrbstsa)THEN ttl(1)='G 2 '//ctype(1:ntype)// & ' of the Indirect Modified Irregular (Table E3).' numttl(1)=ntype+54 ELSE ttl(1)='G 2 '//ctype(1:ntype)// & ' of the Modified Irregular (Table D13).' numttl(1)=ntype+46 END IF END IF ttl(2)=' Spectrum estimated from '//begstr(1:nchr1)// & ' to '//endstr(1:nchr2)//'.' numttl(2)=34+nchr1+nchr2 CALL grzlst(IONE,SIXONE,IZERO,irrsxx,irrsxx,SIXONE,ITEN,IZERO) CALL chrt(ttl,numttl,icode,1,120/Ny) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1000 FORMAT(a,a) 1010 FORMAT(a,i4) 1020 FORMAT(//,' Visually significant residual ',a,' peaks have been', & /,' found in the spectral ',a,' of the following series', & ' starting in ',a,':',/) 1030 FORMAT(10x,a,' (',i1,' Trading Day peak(s))',/) 1040 FORMAT(10x,a,' (',i1,' Seasonal and ',i1,' Trading Day peaks)',/) 1050 FORMAT(10x,a,' (',i1,' Seasonal peak(s))',/) 1070 FORMAT(/,' Rerun the input file without the output ', & 'suppression option',/, & ' (-n flag) for more details.') 1060 FORMAT(//,' WARNING: Series should not be a candidate for ', & 'seasonal adjustment',/, & ' because the spectrum of the',a,/ & ' has no visually significant seasonal peaks.') 1061 FORMAT(/,' If this is a component series of an ', & 'indirectly adjusted',/, & ' composite series, consider using type = ', & 'trend or type = summary',/, & ' in the x11 spec.') 1080 FORMAT(a,'.tukey.m: ',i5) END spcidx.cmn0000664006604000003110000000141014521201570012153 0ustar sun00315stepsc----------------------------------------------------------------------- c Store peak indexes, frequencies for spectral estimates c----------------------------------------------------------------------- DOUBLE PRECISION Sfreq,Tfreq,Frq,Frqpk INTEGER Slow,Sup,Tlow,Tup,Speak,Nsfreq,Tpeak,Ntfreq,Nfreq c----------------------------------------------------------------------- DIMENSION Slow(6),Sup(5),Tlow(5),Tup(5),Speak(6),Tpeak(6), & sfreq(6),tfreq(6),Frq(61),Frqpk(76) c----------------------------------------------------------------------- COMMON /cspcid/ Frq,Frqpk,Sfreq,Tfreq,Slow,Sup,Tlow,Tup,Speak, & Tpeak,Nsfreq,Ntfreq,Nfreq c-----------------------------------------------------------------------spcrsd.f0000664006604000003110000002537514521201570011647 0ustar sun00315stepsC Last change: BCM 9 Dec 1998 4:30 pm SUBROUTINE spcrsd(A,Na,Begrsd,Sp,Endspn,Tblptr,Lseats,Lsumm,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- c Routine which computes the spectrum for the regARIMA model c residuals. If there are peaks detected at the trading day or c seasonal frequencies, these are noted. c----------------------------------------------------------------------- c AR-Spectrum routines originally appeared in the BAYSEA program, c developed by H. Akaike and G. Kitagawa of the Institute for c Statistical Mathematics. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'tbltitle.prm' INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'rho.cmn' INCLUDE 'tukey.cmn' INCLUDE 'spcidx.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'spctbl.i' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'spcsvl.i' c----------------------------------------------------------------------- INTEGER IONE,SIXONE,IZERO,ITEN,PA,NTDLIM LOGICAL F,T PARAMETER(F=.false.,T=.true.,IONE=1,SIXONE=61,IZERO=0,ITEN=10, & NTDLIM=60,PA=PLEN+2*PORDER) c----------------------------------------------------------------------- CHARACTER begstr*(10),ctype*(19),endstr*(10),ttl*(PTTLEN), & pkstr*(24),slbl*(36),arstr*(2),skystr*(10) DOUBLE PRECISION A,Temp,rsdsxx,rssxx2,tmpsxx,pklim,star1,Hrsd, & mvrsd INTEGER Begrsd,Endspn,frqidx,i,ipos,Na,ltdrsd,lsrsd,nchr1,nchr2, & ntype,icode,numttl,Sp,ipk,Tblptr,Lsumm,domfqt,domfqs,ns, & fhnote,nobspc,istr,mrsd,ntmp,nkystr LOGICAL gorsd,Lgraf,ltdfrq,Lseats DIMENSION A(*),Begrsd(2),Temp(PA),rsdsxx(61),rssxx2(76),mvrsd(14), & tmpsxx(61),Endspn(2),ttl(2),numttl(2),Hrsd(0:PLEN) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- fhnote=STDERR IF(Lquiet)fhnote=0 c----------------------------------------------------------------------- IF(.not.(Sp.eq.12.or.Sp.eq.4))THEN CALL writln('ERROR: Spectral plots currently can only be generate &d for monthly or',STDERR,Mt2,T) CALL writln(' quarterly time series.',STDERR,Mt2,F) RETURN END IF c----------------------------------------------------------------------- c Get relative position of starting point for spectrums c----------------------------------------------------------------------- CALL dfdate(Bgspec,Begrsd,Sp,ipos) IF(ipos.lt.0)THEN ipos=1 CALL wrtdat(Begrsd,Sp,begstr,nchr1) ELSE ipos=ipos+1 CALL wrtdat(Bgspec,Sp,begstr,nchr1) END IF IF(.not.Lfatal)CALL wrtdat(Endspn,Sp,endstr,nchr2) IF(Lfatal)RETURN c----------------------------------------------------------------------- gorsd=T nobspc=Na-ipos+1 ltdfrq=nobspc.gt.NTDLIM c----------------------------------------------------------------------- CALL copy(A,Na,-1,Temp) IF(Spctyp.eq.0)THEN CALL spgrh(Temp,rssxx2,frqpk,Thtapr,ipos,Na,nfreq,Sp,Mxarsp, & Ldecbl,gorsd) CALL spgrh(Temp,rsdsxx,frq,Thtapr,ipos,Na,61,Sp,Mxarsp, & Ldecbl,gorsd) ELSE c----------------------------------------------------------------------- c Else, compute the periodogram for the regARIMA model residuals c----------------------------------------------------------------------- CALL spgrh2(Temp,rssxx2,frqpk,ipos,Na,nfreq,Ldecbl) CALL spgrh2(Temp,rsdsxx,frq,ipos,Na,61,Ldecbl) END IF c----------------------------------------------------------------------- c Save spectrum of the regARIMA model residuals c----------------------------------------------------------------------- IF(.not.gorsd)RETURN c----------------------------------------------------------------------- IF(Savtab(Tblptr).or.Lgraf)THEN CALL mksplb(Tblptr,slbl,ns,0,Ldecbl) IF(Svallf)THEN IF(Savtab(Tblptr)) & CALL savspp(Tblptr,rssxx2,frqpk,nfreq,slbl(1:ns),F) IF(.not.Lfatal.and.Lgraf) & CALL savspp(Tblptr,rssxx2,frqpk,nfreq,slbl(1:ns),Lgraf) ELSE IF(Savtab(Tblptr)) & CALL savspp(Tblptr,rsdsxx,frq,61,slbl(1:ns),F) IF(.not.Lfatal.and.Lgraf) & CALL savspp(Tblptr,rsdsxx,frq,61,slbl(1:ns),Lgraf) END IF IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF((Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK).or. & Lsumm.gt.0.or.Savtab(Tblptr).or.Lgraf).AND.(Sp.eq.12))THEN ntmp=na-ipos+1 IF(ntmp.ge.80)THEN IF(ipos.gt.1)THEN DO i=ipos,Na Temp(i-ipos+1)=a(i) END DO END IF CALL getTPeaks(a,ntmp,Sp,Hrsd,mrsd,Pttdr,Ptsr,mvrsd) IF(Prttab(LSPCTP).or.Savtab(LSPCTP).or.Svltab(LSLTPK).or. & Lsumm.gt.0)THEN Ntukey=Ntukey+1 Itukey(Ntukey)=Tblptr END IF IF(Savtab(Tblptr).or.Lgraf)THEN CALL mkstlb(Tblptr,slbl,ns,Spcsrs) IF(Savtab(Tblptr)) & CALL savstp(LSPTRS,Hrsd,mrsd,slbl(1:ns),Ldecbl,F) IF((.not.Lfatal).and.Lgraf) & CALL savstp(LSPTRS,Hrsd,mrsd,slbl(1:ns),Ldecbl,Lgraf) IF(Lfatal)RETURN END IF IF(Lsumm.gt.0)THEN CALL mkspky(4,skystr,nkystr,0,Lseats) write(Nform,1080)skystr(1:nkystr),mrsd END IF END IF END IF c----------------------------------------------------------------------- ltdrsd=0 lsrsd=0 CALL idpeak(rsdsxx,rssxx2,Spclim,Sp,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,ltdrsd,lsrsd,frqpk,Plocal,Ldecbl, & ltdfrq) IF(Lsumm.gt.0) & CALL svpeak(rsdsxx,rssxx2,0,0,tpeak,tlow,tup,ntfreq,speak, & slow,sup,nsfreq,Lseats,Ldecbl,ltdfrq) c----------------------------------------------------------------------- IF(ltdrsd.gt.0.and.lsrsd.gt.0.and.Prttab(Tblptr))THEN CALL writln('WARNING: Visually significant seasonal and trading d &ay peaks have ',fhnote,Mt2,T) IF(Lseats)THEN CALL writln(' been found in the estimated spectrum of th &e SEATS extended residuals.',fhnote,Mt2,F) ELSE CALL writln(' been found in the estimated spectrum of th &e regARIMA residuals.',fhnote,Mt2,F) END IF pkstr='trading day and seasonal' ipk=24 ELSE IF(ltdrsd.gt.0.and.Prttab(Tblptr))THEN CALL writln('WARNING: At least one visually significant trading d &ay peak has been',fhnote,Mt2,T) IF(Lseats)THEN CALL writln(' found in the estimated spectrum of the SEA &TS extended residuals.',fhnote,Mt2,F) ELSE CALL writln(' found in the estimated spectrum of the reg &ARIMA residuals.',fhnote,Mt2,F) END IF pkstr='trading day' ipk=11 ELSE IF(lsrsd.gt.0.and.Prttab(Tblptr))THEN CALL writln('WARNING: At least one visually significant seasonal &peak has been found',fhnote,Mt2,T) IF(Lseats)THEN CALL writln(' in the estimated spectrum of the SEATS ext &ended residuals.',fhnote,Mt2,F) ELSE CALL writln(' in the estimated spectrum of the regARIMA &residuals.',fhnote,Mt2,F) END IF pkstr='seasonal' ipk=8 END IF c----------------------------------------------------------------------- IF((lsrsd.gt.0.or.ltdrsd.gt.0))THEN IF(Prttab(Tblptr))THEN ns=24 IF(Lseats)THEN slbl(1:ns)='SEATS extended residuals' ELSE slbl(1:ns)='regARIMA model residuals' END IF IF(ltdrsd.gt.0.and.lsrsd.gt.0)THEN WRITE(Mt1,1020)'V',pkstr(1:ipk),'have',begstr(1:nchr1) WRITE(Mt1,1040)slbl(1:ns),lsrsd,ltdrsd ELSE WRITE(Mt1,1020)'At least one v',pkstr(1:ipk),'has', & begstr(1:nchr1) IF(ltdrsd.gt.0)THEN WRITE(Mt1,1030)slbl(1:ns),ltdrsd ELSE IF(lsrsd.gt.0)THEN WRITE(Mt1,1050)slbl(1:ns),lsrsd END IF END IF END IF IF(Lsavpk)THEN IF(Lseats)THEN ns=6 slbl(1:ns)='extrsd' ELSE ns=3 slbl(1:ns)='rsd' END IF IF(ltdrsd.gt.0)THEN Ctpeak((Ntpeak+1):(Ntpeak+ns))=slbl(1:ns) Ntpeak=Ntpeak+ns+1 END IF IF(lsrsd.gt.0)THEN Cspeak((Nspeak+1):(Nspeak+ns))=slbl(1:ns) Nspeak=Nspeak+ns+1 END IF END IF END IF c----------------------------------------------------------------------- c Spectrum plot for detrended original series c----------------------------------------------------------------------- IF(.not.Prttab(Tblptr))RETURN icode=20 IF(.not.ltdfrq)icode=21 IF(Spctyp.eq.0)THEN ctype='10*LOG(SPECTRUM)' ntype=16 ELSE ctype='10*LOG(PERIODOGRAM)' ntype=19 END IF IF((ltdrsd.gt.0.or.ltdrsd.gt.0).and.Prttab(Tblptr)) & WRITE(Mt1,'(//)') IF(Lseats)THEN ttl(1)=' '//ctype(1:ntype)// & ' of the SEATS extended residuals.' ELSE ttl(1)=' '//ctype(1:ntype)// & ' of the regARIMA model residuals.' END IF numttl(1)=ntype+37 ttl(2)=' Spectrum estimated from '//begstr(1:nchr1)// & ' to '//endstr(1:nchr2)//'.' numttl(2)=34+nchr1+nchr2 CALL grzlst(IONE,SIXONE,IZERO,rsdsxx,rsdsxx,SIXONE,ITEN,IZERO) CALL chrt(ttl,numttl,icode,1,120/Sp) c----------------------------------------------------------------------- 1020 FORMAT(//,2x,a,'isually significant residual ',a,' peaks ',a, & ' been', & /,' found in the spectral plot of the following series', & ' starting in ',a,':',/) 1030 FORMAT(10x,a,' (',i1,' Trading Day peak(s))',/) 1040 FORMAT(10x,a,' (',i1,' Seasonal and ',i1,' Trading Day peak(s))', & /) 1050 FORMAT(10x,a,' (',i1,' Seasonal peak(s))',/) * 1070 FORMAT(/,' Rerun the input file without the output ', * & 'suppression option',/, * & ' (-n flag) for more details.') 1080 FORMAT(a,'.tukey.m: ',i5) c----------------------------------------------------------------------- RETURN END spcsvl.i0000664006604000003110000000145614521201571011661 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for svltbl are of the form LSL c where the types are c----------------------------------------------------------------------- c Spectral plots with peaks SPC c Spectral plots with peaks, composite adjustment CSP c----------------------------------------------------------------------- INTEGER LSLSPK,LSLDSP,LSLISP,LSLTPK,LSLDTP,LSLITP,LSLQS,LSLDQS, & LSLIQS,LSLQCH,LSLNPA,LSLDNP,LSLINP,LSLALP PARAMETER( & LSLSPK= 61,LSLDSP= 62,LSLISP= 63,LSLTPK= 64,LSLDTP= 65, & LSLITP= 66,LSLQS= 67,LSLDQS= 68,LSLIQS= 69,LSLQCH= 70, & LSLNPA= 71,LSLDNP= 72,LSLINP= 73,LSLALP= 74) spctbl.i0000664006604000003110000000306714521201571011636 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c spectrum SPC, SP c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c spectrum of original series S0 c spectrum of residuals RS c spectrum, diff seas. adj. srs S1 c spectrum, modified irregular S2 c spectrum of sa series S1S c spectrum of mod irregular S2S c spectrum of extended residuals ERS c spectrum of ind sa series S1I c spectrum of ind mod irregular S2I c spectrum of composite series S0C c----------------------------------------------------------------------- INTEGER LSPCS0,LSPCRS,LSPCS1,LSPCS2,LSPS1S,LSPS2S,LSPERS,LSPS1I, & LSPS2I,LSPS0C,LSPTS0,LSPTRS,LSPTS1,LSPTS2,LSPT1S,LSPT2S, & LSPTER,LSPT1I,LSPT2I,LSPT0C,LSPCQS,LSPQSI,LSPCTP,LSPCQC, & LSPNPA,LSPNPI PARAMETER( & LSPCS0=93,LSPCRS=94,LSPCS1=95,LSPCS2=96,LSPS1S=97, & LSPS2S=98,LSPERS=99,LSPS1I=100,LSPS2I=101,LSPS0C=102, & LSPTS0=103,LSPTRS=104,LSPTS1=105,LSPTS2=106,LSPT1S=107, & LSPT2S=108,LSPTER=109,LSPT1I=110,LSPT2I=111,LSPT0C=112, & LSPCQS=113,LSPQSI=114,LSPCTP=115,LSPCQC=116,LSPNPA=117, & LSPNPI=118) special.f0000664006604000003110000002211214521201571011754 0ustar sun00315stepsc Special.f c Here we calculate the mathematical functions: c LogGamma(x): log(Gamma(x)) c BetaInc: the beta cumulative distribution c Fcdp: F cumulative distribution c tcdp: t cumulative distribution c suma: sum of values c suma2: squared sum of values real*8 function LogGamma(a) c INPUT PARAMETERS real*8 a c LOCAL PARAMETERS integer j real*8 suma,s2pi,tmp,y,c0,c(6) SAVE c parameter (c0=1.000000000190015d0) DATA c /76.18009172947146d0,-86.50532032941677d0, & 24.01409824083091d0,-1.231739572450155d0, & .1208650973866179d-2,-.5395239384953d-5/ parameter (s2pi=2.5066282746310005d0) y=a tmp=a+5.5d0 tmp=(a+.5d0)*log(tmp)-tmp suma=c0 do j=1,6 y=y+1.0d0 suma=suma+c(j)/y end do LogGamma=tmp+log(s2pi*suma/a) return end real*8 function BetaInc(x,a,b) c Return the probability of value<=x for distribution Beta(a,b) implicit none real*8 a,b,x,e external LogGamma,BetaCfra real*8 bt,LogGamma,BetaCfra C INTRINSIC FUNCTIONS intrinsic LOG,EXP,MAX if (x .le. 0.0d0) then BetaInc=0.0d0 return elseif (x .ge. 1.0d0) then BetaInc=1.0d0 return end if e=LogGamma(a+b)-LogGamma(a)-LogGamma(b) & +a*LOG(x)+b*LOG(1.0d0-x) bt=EXP(max(e,-500.0D0)) !To avoid underflow exception if (x .lt. (a+1.0d0)/(a+b+2.0d0)) then BetaInc=bt*BetaCfra(a,b,x)/a else BetaInc=1.0d0-bt*BetaCfra(b,a,1.0d0-x)/b end if end real*8 function BetaCfra(a,b,x) c continued fraction evaluation for Beta Incomplete function c using Lentz's method implicit none real*8 a,b,x c LOCAL PARAMETERS integer MaxItera real*8 EPS,FP_MIN parameter(MaxItera=1000,EPS=1.0d-7,FP_MIN=1.0D-78) integer m,m2 real*8 aa,c,d,f,del d=1.0-(a+b)*x/(a+1) if (abs(d) .le. FP_MIN) d=FP_MIN d=1.0/d c=1.0 f=d do m=1,MaxItera c even step m2=2*m aa=m*(b-m)*x/((a-1+m2)*(a+m2)) d=1.0d0+aa*d if (abs(d) .le. FP_MIN) d=FP_MIN d=1.0d0/d c=1.0d0+aa/c if (abs(c) .le. FP_MIN) c=FP_MIN f=f*d*c c odd step aa=-(a+m)*(a+b+m)*x/((a+m2)*(a+1+m2)) d=1.0d0+aa*d if (abs(d) .lt. FP_MIN) d=FP_MIN d=1.0d0/d c=1.0d0+aa/c if (abs(c) .lt. FP_MIN) c=FP_MIN del=d*c f=f*d*c if (abs(del-1.0d0) .lt. EPS) then BetaCfra=f return end if end do BetaCfra=f write(*,*)'Error MaxItera too small in BetaCfra' return end real*8 function Fcdf(F,x,y) c returns the probability of F(x,y)<=F for a given F value real*8 F,x,y real*8 BetaInc Fcdf=1-BetaInc(y/(y+x*F),y/2,x/2) return end real*8 function tcdf(t,df) c returns the probability of t(df)<=t for a given t value real*8 t,df real*8 BetaInc if (t .ge. 0) then tcdf=1-.5*BetaInc(df/(df+t*t),df/2,.5d0) else tcdf=.5*betainc(df/(df+t*t),df/2,.5d0) end if return end real*8 function suma(a,n1,n2) implicit none real*8 a(*) integer n1,n2,i real*8 tmp tmp=0 do i=n1,n2 tmp=tmp+a(i) end do suma=tmp end real*8 function suma2(a,n1,n2) implicit none real*8 a(*) integer n1,n2,i real*8 tmp tmp=0 do i=n1,n2 tmp=tmp+a(i)*a(i) end do suma2=tmp end real*8 function variance(a,n1,n2) implicit none real*8 a(*),m,va integer n1,n2,i external suma,suma2 real*8 suma,suma2 m=suma(a,n1,n2)/DBLE(n2-n1+1) va=suma2(a,n1,n2)/DBLE(n2-n1+1) - m*m variance=(DBLE(n2-n1+1)/DBLE(n2-n1))*va end real*8 function calcQS3(Z,nz,mq) C C THIS SUBROUTINE CALCULATES THE PIERCE qs STATISTIC OF THE C Z SERIES C NZ : NUMBER OF OBSERVATIONS OF THE SERIES C C.. Implicits .. implicit none C C.. Parameters .. integer n10 parameter (n10 = 10) C C.. Formal Arguments .. integer nz,nw,mq real*8 z(*) C C.. Local Scalars .. integer i,j,k,nr real*8 c0,QS C C.. Local Arrays .. real*8 c(5*n10), r(24) C ... Executable Statements ... c0 = 0.0d0 do i = 1,nz c0 = c0 + z(i)*z(i) end do c0 = c0 / nz nr=MQ+MQ do k = 1,nr c(k) = 0.0d0 j = k + 1 do i = j,nz c(k) = c(k) + z(i)*z(i-k) end do c(k) = c(k) / nz r(k) = c(k) / c0 end do QS = 0.0d0 if (mq.ne.1 .and. r(mq).gt.0.0d0) then do j = 1,2 k = j * mq if (r(k).gt.0d0) then QS = QS + (r(k)*r(k))/(nz-k) end if end do QS = QS * nz * (nz+2) end if calcQS3=QS return end c c c integer function indexGE(val,arrVal,nArrVal) implicit none c INPUT integer nArrVal real*8 Val,arrVal(nArrVal) c LOCAL integer i c---------------------------------------------------- i=0 do while(i.lt.nArrVal) if (arrVal(i+1).le.val) then i=i+1 else indexGE=i return end if enddo indexGE=i end c c c subroutine acuArea(Arr,nArr,acuArr) implicit none c INPUT PARAMETERS integer nArr real*8 Arr(nArr) c OUTPUT real*8 acuArr(nArr) c LOCAL integer i real*8 tmpAcu c--------------------------------------------------- tmpAcu=0.0d0 do i=1,nArr tmpAcu=tmpAcu+arr(i) acuArr(i)=tmpAcu enddo end subroutine c c c integer function Median(arr,nArr) implicit none include 'spectrum.i' c INPUT real*8 arr(Lspect) integer nArr c LOCAL real*8 acuArr(Lspect) c EXTERNAL integer indexGE external indexGE c--------------------------------------------------- call acuArea(arr,nArr,acuArr) median=indexGE(acuArr(nArr)/2.0d0,AcuArr,nArr) end function c c c integer function indexMax(Arr,nArr) implicit none include 'spectrum.i' c INPUT integer nArr real*8 arr(Lspect) c LOCAL integer ind,i real*8 val c -------------------------------------------------- ind=1 val=arr(1) do i=2,nArr if (arr(i).gt.val) then ind=i val=arr(i) end if enddo indexMax=ind end function c cc c real*8 function MEANxI(arr,nArr) implicit none c INPUT integer nArr real*8 arr(nArr) c LOCAL integer i real*8 sum,sum2 c -------------------------------------------------- sum=0.0d0 sum2=0.0d0 do i=1,nArr sum=sum+DBLE(i)*Arr(i) sum2=sum2+Arr(i) enddo sum=sum/sum2 MEANxI=sum end function c c c Writes MODE period, MEAN period and Median period of a spectrum subroutine areaStat(Arr,nArr,MQ,Caption,DBD) implicit none include 'stream.i' real*8 pi,tol parameter (pi = 3.14159265358979D0,tol=1.0d-8) c INPUT PARAMETERS integer nArr,MQ,DBD real*8 arr(nArr) character Caption*(*) c LOCAL PARAMETERS integer iMode,iMedian,lCap real*8 fMode,fMean,fMedian c EXTERNAL integer istrlen,indexMax,Median real*8 MEANxI external MEANxI,istrlen,indexMax,Median c --------------------------------------------------- lCap=istrLen(Caption) if (DBD.ge.3) then fmode=0.0d0 fmean=0.0d0 fmedian=0.0d0 else iMode=indexMax(Arr,nArr) fMean=MEANxI(Arr,nArr) iMedian=Median(Arr,nArr) fMode=DBLE((imode)*MQ)/DBLE((nArr)*2) fMean=(fMean)*DBLE(MQ)/DBLE((nArr)*2) fMedian=DBLE((iMedian)*MQ)/DBLE((nArr)*2) end if write(nio,'(//,6x,A,/)') Caption(1:lCap) if (fMode.gt.tol) then write(nio,'(/,10x,''MODE = '',F12.2, & '' years cycle'')') 1.0d0/fMode else write(nio,'(/,10x,''MODE = INF years cycle'')') end if if (fMEAN.gt.tol) then write(nio,'(/,10x,''MEAN = '',F12.2, & '' years cycle'')') 1.0d0/fMean else write(nio,'(/,10x,''MEAN = INF years cycle'')') end if if (fMedian.gt.tol) then write(nio,'(/,10x,''MEDIAN = '',F12.2, & '' years cycle'',//)') 1.0d0/fMedian else write(nio,'(/,10x,''MEDIAN = INF years cycle'',//)') end if end subroutine specpeak.f0000664006604000003110000006131314521201571012135 0ustar sun00315stepscc c New Spectrum cc C Last change: Domingo Perez 14 September 2004 SUBROUTINE GetPeaks(z,nz,mq,Szz,w, $ TDpeaks,nTDpeaks,pTDpeaks, $ SeasPeaks,nSeasPeaks,pSeaspeaks,differ) IMPLICIT NONE include 'spectrum.i' c c INPUT PARAMETERS c integer nz,mq double precision z(nz) integer differ c c OUTPUT PARAMETERS c INCLUDE 'srslen.prm' include 'dimensions.i' cc c cc integer nTDpeaks,!number of peaks detected at TD frequencies $ nSeasPEaks !number of peaks detected at Seasonal frequencies integer TDpeaks(6), !peaks detected at TD frequencies $ Seaspeaks(6) !peaks detected at Seasonal frequencies double precision w(nfrq), !frequencies $ Szz(nfrq) !Spectrum of (1-B)z at w frequencies real*8 pTDpeaks(6), !chance of peaks detected at TD frequencies $ pSeaspeaks(6) !chance of peaks detected at Seasonal frequencies c c INTERNAL PARAMETERS c integer i,N1 real*8 pi2 double precision diffz(nz) !(1-B)z c Initialize nTDpeaks=0 nSeasPEaks=0 do i=1,6 TDpeaks(i)=0 Seaspeaks(i)=0 pTDpeaks(i)=0d0 pSeaspeaks(i)=0d0 end do c pi2=2.0d0*acos(-1.0d0) c 120=12*10 cogemos los últimos 10 años para el AR(30) en el caso MQ=12 if (nz.gt.SPECLENGTH) then N1=nz-SPECLENGTH+1 else N1=1 end if if (differ .eq. 1) then do i = N1,nz-1 diffz(i-N1+1)=z(i+1)-z(i) end do c Vz=getVar(diffz,nz-1) call GetPeak1(diffz,nz-N1,mq,Szz,w, $ TDpeaks,nTDpeaks,pTDpeaks, $ SeasPeaks,nSeasPeaks,pSeasPeaks) else c Vz=getVar(z,nz) do i=N1,nz diffz(i-N1+1)=z(i) enddo call GetPeak1(diffz,nz-N1+1,mq,Szz,w, $ TDpeaks,nTDpeaks,pTDpeaks, $ SeasPeaks,nSeasPeaks,pSeasPeaks) end if do i=1,nfrq Szz(i) = exp(Szz(i)*log(10.0d0)/10.0d0) end do c sSzz=0 c do i=2,nfrq c sSzz=sSzz+Szz(i) c end do c sSzz=sSzz/(nfrq-1) c do i=1,nfrq c Szz(i)=Szz(i)*Vz/sSzz c end do do i = 1,nfrq w(i) = w(i) * pi2 end do end c SUBROUTINE GetPeak1(diffz,ndiffz,mq,Szz,frq, $ TDpeaks,nTDpeaks,pTDpeaks, $ SeasPeaks,nSeasPeaks,pSeasPeaks) IMPLICIT NONE c c INPUT PARAMETERS c integer ndiffz,mq double precision diffz(ndiffz) ! the differenced serie (1-B)Z c c OUTPUT PARAMETERS c INCLUDE 'srslen.prm' include 'dimensions.i' include 'rho.cmn' cc c cc integer nTDpeaks,nSeasPeaks double precision frq(nfrq), !frequencies $ Szz(nfrq) !Spectrum of (1-B)z at w frequencies integer TDpeaks(6), !peaks detected at TD frequencies $ SeasPeaks(6) !peaks detected at Seas frequencies real*8 pTDpeaks(6), !prob peaks detected at TD frequencies $ pSeasPeaks(6) !prob peaks detected at Seas frequencies c c INTERNAL PARAMETERS c integer i,frqidx,N1,k double precision LIMSPC,pklim,tmpSzz(nfrq),Rango logical good c antiguo c parameter(LIMSPC=6D0) c nuevo c parameter(LIMSPC=4D0) c c Functions c c integer ispeak,ispeak2 c external ispeak,ispeak2 integer pARpeak external pARpeak c----------------------------------------------------------------------- c inicializando freq y frqidx c----------------------------------------------------------------------- DO i = 1,61 frq(i)=dble(i-1)/120.0 END DO IF(mq.eq.12)THEN frq(42)=.3482-frq(2) frq(43)=.3482 frq(44)=.3482+frq(2) frq(52)=.432-frq(2) frq(53)=.432 frq(54)=.432+frq(2) frqidx=1 c ELSE !IF(mq.eq.4)THEN c frq(5)=.0446-frq(2) c frq(6)=.0446 c frq(7)=.0446+frq(2) c frq(11)=.0893-frq(2) c frq(12)=.0893 c frq(13)=.0893+frq(2) ELSE !IF(mq.eq.4)THEN frq(35)=.29465-frq(2) frq(36)=.29465 frq(37)=.29465+frq(2) frq(41)= 0.3393-frq(2) frq(42)= 0.3393 frq(43)= 0.3393+frq(2) frqidx=2 !ELSE Error('solo hacemos spectral plots para mq=12 ó 4') ! RETURN !END IF END IF c----------------------------------------------------------------------- good=.true. n1=1 call spgrh(diffz,Szz,frq,0D0,n1,ndiffz,nfrq,mq,Mxarsp,Ldecbl,good) c k=min(30,ndiffz/2) !to avoid underdetermined system c call getSpect(diffz,ndiffz,frq,nfrq,k,Szz,good) do i = 1,nfrq tmpSzz(i)=Szz(i) end do nTDpeaks=0 nSeaspeaks=0 call shlsrt(nfrq,tmpSzz) !sort the array tmpSzz Rango=(tmpSzz(nfrq)-tmpSzz(1)) if ((mq .eq. 12) .or. (mq .eq. 4)) then c pklim=Rango*(LIMSPC/52D0) c nTDpeaks=ispeak(Szz,frqidx,pklim,tmpSzz(31),TDpeaks) c nSeaspeaks=ispeak(Szz,2+frqidx,pklim,tmpSzz(31),Seaspeaks) nTDpeaks=pARpeak(Szz,frqidx,Rango,tmpSzz(31), $ pTDpeaks,TDpeaks) nSeaspeaks=pARpeak(Szz,2+frqidx,Rango,tmpSzz(31), $ pSeasPeaks,SeasPeaks) else if (mq.eq.6) then c nSeaspeaks=ispeak(Szz,5,pklim,tmpSzz(31),Seaspeaks) nSeaspeaks=pARpeak(Szz,5,Rango,tmpSzz(31), $ pSeasPeaks,SeasPeaks) else if (mq.eq.2) then c nSeaspeaks=ispeak(Szz,6,pklim,tmpSzz(31),Seaspeaks) nSeaspeaks=pARpeak(Szz,6,Rango,tmpSzz(31), $ pSeasPeaks,SeasPeaks) else if (mq.eq.3) then c nSeaspeaks=ispeak(Szz,7,pklim,tmpSzz(31),Seaspeaks) nSeaspeaks=pARpeak(Szz,7,Rango,tmpSzz(31), $ pSeasPeaks,SeasPeaks) else nSeasPeaks=0 end if end if c end subroutine c c cc c cc logical function SeasSpectCrit2(pico,mq) implicit none C Test al 99% integer mq character pico(7)*2 c local integer i,ipicos,idoble ipicos=0 idoble=0 if (mq.eq.4) then do i=1,2 if ((pico(i)(1:1).eq.'A').or.(pico(i)(2:2).eq.'T')) then ipicos=ipicos+1 end if end do if (pico(1).eq.'AT') then SeasSpectCrit2=.true. else if (ipicos.eq.2) then SeasSpectCrit2=.true. else SeasSpectCrit2=.false. end if else if (mq.eq.12) then SeasSpectCrit2=.false. do i=1,6 if (pico(i).eq.'AT') then idoble=idoble+1 ipicos=ipicos+1 else if ((pico(i)(1:1).eq.'A').or.(pico(i)(2:2).eq.'T')) then ipicos=ipicos+1 end if end do SELECT CASE (ipicos) CASE (4,5,6) SeasSpectCrit2=.true. CASE (3) if (((pico(6)(1:1).ne.'A').and.(pico(6)(2:2).ne.'T')).or. $ (idoble.ge.1))then SeasSpectCrit2=.true. end if CASE (2) if (pico(6).eq.'AT') then if (idoble.eq.2) then SeasSpectCrit2=.true. end if else if (pico(6)(1:1).ne.'A'.or.pico(6)(2:2).ne.'T') then if (idoble.ge.1) then SeasSpectCrit2=.true. end if end if CASE DEFAULT SeasSpectCrit2=.false. END SELECT else SeasSpectCrit2=.false. end if end cc c cc logical function SeasSpectCrit(pico,mq) implicit none C Test al 95% integer mq character pico(7)*2 c local integer i,ipicos,idoble ipicos=0 idoble=0 if (mq.eq.4) then do i=1,2 if ((pico(i).ne.'--').and.(pico(i).ne.'nc')) then ipicos=ipicos+1 end if end do if ((pico(1).eq.'AT'))then SeasSpectCrit=.true. else if (ipicos.eq.2) then SeasSpectCrit=.true. else SeasSpectCrit=.false. end if else if (mq.eq.12) then SeasSpectCrit=.false. do i=1,6 if (pico(i).eq.'AT') then idoble=idoble+1 ipicos=ipicos+1 else if ((pico(i).ne.'--').and.(pico(i).ne.'nc')) then ipicos=ipicos+1 end if end do SELECT CASE (ipicos) CASE (4,5,6) SeasSpectCrit=.true. CASE (3) if ((pico(6).eq.'--').or.(pico(6).eq.'nc').or. $ (idoble.ge.1))then SeasSpectCrit=.true. end if CASE (2) if ((pico(6)(1:1).eq.'A'.or.pico(6)(1:1).eq.'a').and. $ (pico(6)(2:2).eq.'T'.or.pico(6)(2:2).eq.'t')) then if (idoble.eq.2) then SeasSpectCrit=.true. end if else if (pico(6).eq.'--') then if (idoble.ge.1) then SeasSpectCrit=.true. end if end if CASE DEFAULT SeasSpectCrit=.false. END SELECT else SeasSpectCrit=.false. end if end c c c c c c subroutine dfPeaks(m,nz,df1,df2,df3,df4) implicit none c INPUT integer nz,m c OUTPUT real*8 df1,df2,df3,df4 c LOCAL real*8 n100,n_100,df(3,4) c---------------------------------------------- if (m.eq.120) then df(1,1)=0.317d0 df(2,1)=2.7706d0 df(3,1)=2.6516d0 df(1,2)=2.0934d0 df(2,2)=7.0464d0 df(3,2)=10.5217d0 df(1,3)=-.4336d0 df(2,3)=1.4463d0 df(3,3)=3.0668d0 df(1,4)=0.6411d0 df(2,4)=3.6073d0 df(3,4)=7.9892d0 else if (m.eq.112) then df(1,1)=0.5463d0 df(2,1)=2.9303d0 df(3,1)=2.2042d0 df(1,2)=1.1329d0 df(2,2)=7.6924d0 df(3,2)=10.8795d0 df(1,3)=-.3492d0 df(2,3)=1.533d0 df(3,3)=2.7696d0 df(1,4)=0.9829d0 df(2,4)=3.8217d0 df(3,4)=6.9345d0 else if (m.eq.44) then df(1,1)=1.3779d0 df(2,1)=7.2620d0 df(3,1)=0.3725d0 df(1,2)=3.1495d0 df(2,2)=18.0654d0 df(3,2)=3.5564d0 df(1,3)=0.2504d0 df(2,3)=3.6616d0 df(3,3)=0.7929d0 df(1,4)=0.504d0 df(2,4)=9.7201d0 df(3,4)=3.0605d0 else if (m.eq.79) then df1=6.35251d0 df2=19.6308d0 df3=2.29316d0 df4=6.55412d0 end if if (m.eq.112 .or. m.eq.44 .or. m.eq.120) then n100=dble(nz)/100.0d0 n_100=100.d0/dble(nz) df1=df(1,1)+df(2,1)*n100+df(3,1)*n_100 df2=df(1,2)+df(2,2)*n100+df(3,2)*n_100 df3=df(1,3)+df(2,3)*n100+df(3,3)*n_100 df4=df(1,4)+df(2,4)*n100+df(3,4)*n_100 end if end c c c Tpeaks2: retorna la probabilidad de picos en el espectro ACF windowing usando Tukey c Solo esta calculado para las ventanas m=112, 79 y 44 subroutine Tpeaks2(H,m,MQ,nz,pTDpeaks,pSpeaks,mv) implicit none c INPUT PARAMETERS integer m,MQ,nz real*8 H(*) c OUTPUT PARAMETERS real*8 pTDpeaks,pSpeaks(6) real*8 mv(14) c LOCAL PARAMETERS real*8 incH,mv1,mv2,mv3,vA1,vA2 real*8 df1,df2,df3,df4 integer i,indM(5),nIndM,indTD,indPI,k c EXTERNAL real*8 Fcdf external Fcdf c------------------------------------------------- do i=1,6 pSpeaks(i)=0.0d0 enddo pTDpeaks=0.0d0 call dfPeaks(m,nz,df1,df2,df3,df4) select case(m) case(120) indM(1)=11 indM(2)=21 indM(3)=31 indM(4)=41 indM(5)=51 nIndM=5 indTD=43 indPI=61 case(112) indM(1)=10 indM(2)=20 indM(3)=29 indM(4)=38 indM(5)=48 nIndM=5 indTD=40 indPI=57 case(79) indM(1)=8 indM(2)=14 indM(3)=21 indM(4)=27 indM(5)=34 nIndM=5 indTD=29 indPI=40 case default indTD=-1 indPI=22 nIndM=0 select case(mq) case(6) indM(1)=8 indM(2)=15 nIndM=2 case(4) c indTD=3 indTD=14 indM(1)=12 nIndM=1 case(3) indPI=-1 indM(1)=15 nIndM=1 case(1) indPI=-1 end select end select do i=1,nIndM IncH=2*H(indM(i)) incH=incH/(H(indM(i)+1)+H(indM(i)-1)) pSpeaks(i)=Fcdf(incH,df1,df2) c Obtencion de valores de test que tiene en cuenta picos anchos mv1=H(indM(i))/H(indM(i)-1) mv2=H(indM(i))/H(indM(i)+1) vA1=2*H(indM(i))/(H(indM(i)-1)+H(indM(i)-2)) vA2=2*H(indM(i))/(H(indM(i)+1)+H(indM(i)+2)) if (mV1.lt.mV2) then mv(i*2-1)=mv1 else mv(i*2-1)=mv2 end if if (VA1.lt.mv1) then VA1=mv1 end if if (VA2.lt.mv2) then VA2=mv2 end if if (vA1.lt.vA2) then mV3=VA1 else mv3=VA2 end if if ((MQ.eq.12.and.i.eq.4).or.MQ.eq.4) then mv(i*2)=VA1 else mv(i*2)=mv3 end if end do k=nIndM if (indPI.gt.0) then IncH=H(indPI)/H(indPI-1) pSpeaks(MQ/2)=Fcdf(incH,df3,df4) c Obtencion de valores de test que tiene en cuenta picos anchos k=k+1 mv(k*2-1)=H(indPI)/H(indPI-1) VA1=2*H(indPI)/(H(indPI-1)+H(indPI-2)) if (VA1.gt.mv(2*k-1)) then mv(2*k)=VA1 else mv(2*k)=mv(k*2-1) end if end if if (indTD.gt.0) then incH=2*H(indTD)/(H(indTD+1)+H(indTD-1)) pTDpeaks=Fcdf(incH,df1,df2) c Obtencion de valores de test que tiene en cuenta picos anchos k=k+1 mv1=H(indTD)/H(indTD-1) mv2=H(indTD)/H(indTD+1) VA2=2*H(indTD)/(H(indTD+1)+H(indTD+2)) if (mv1.lt.mv2) then mv(k*2-1)=mv1 else mv(k*2-1)=mv2 endif if (VA2.lt.mv2) then VA2=mv2 endif if (VA2.lt.mv1) then mv(k*2)=VA2 else mv(k*2)=mv1 endif end if end c c c getTPeaks: given a series(serie(1:nserie)) with its MQ c return its spectrum(H), the choosen Tukey window size(m) and c the probability of TD peaks (pTDpeak) and of seasonal peaks(Speaks(1:nSpeaks)) c Besides: wSpeaks(i): 1:if thereis a Seasonal spectral peak for w=i*pi/6 Radians; 0 If there is not a peaks subroutine getTPeaks(serie,nz,mq,H,m,pTDpeak,pSpeaks,mv) implicit none INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' INCLUDE 'rho.cmn' c INPUT real*8 serie(*),mv(14) integer nz,mq c OUTPUT real*8 H(*),pTDpeak,pSpeaks(6) integer m c LOCAL real*8 window(0:120) integer iwindow,i c iwindow=2 !Tukey if (Ltk120.and.nz.ge.120.and.mq.eq.12) then c if (Ltk120) then m=120 else if ((MQ.ne.12).and.(nz.ge.60)) then m=44 else if ((nz.ge.120).and.(mq.eq.12)) then m=112 else if ((nz.ge.80).and.(mq.eq.12)) then m=79 else pTDpeak=0.0d0 do i=1,6 pSpeaks(i)=0.0d0 enddo m=-1 return end if call getWind(iWindow,m,window) call covWind(H,m,serie,nz,window,nw2) call Tpeaks2(H,m,MQ,nz,pTDpeak,pSpeaks,mv) end cc C Last change: BCM 12 Nov 1998 10:53 am **==ispeak.f processed by SPAG 4.03F at 14:16 on 28 Sep 1994 c INPUT Sxx(1:61): AR(30) pseudo-spectrum c PKidx=1 analyze TD freq for MQ=12 c PKidx=2 analyze TD freq for MQ=4 c PKidx=3 analyze Seasonal frequencies for MQ=12 c PKidx=4 analyze Seasonal frequencies for MQ=4 c PKidx=5 analyze Seasonal frequencies for MQ=6 c PKidx=6 analyze Seasonal frequencies for MQ=2 c PKidx=7 analyze Seasonal frequencies for MQ=3 c Rango=max(Sxx)-min(Sxx) c Mlimit=mediana(Sxx) c OUTPUT c peaks(1:pARpeak): probabilidad acumulada de los diferentes c picos supuesto que son espectro de una serie de ruido c blanco diferenciada una vez. integer function pARpeak(Sxx,Pkidx,Rango,Mlimit, $ ppeaks,peaks) IMPLICIT NONE c----------------------------------------------------------------------- c Function that flags possible trading day or seasonal peaks in a c given set of spectral estimates. Peak must be greater than the c median of the spectral estimates computed (Mlimit). The peaks of c interest are defined in the vector pkvec. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' include 'dimensions.i' c INPUT PARAMETERS INTEGER Pkidx Double precision Sxx(61),Rango,Mlimit c OUTPUT PARAMETERS real*8 ppeaks(6) integer peaks(6) c LOCAL PARAMETERS integer j,i,freq,cont real*8 incH,incH2 c----------------------------------------------------------------------- integer pkvec(18-1),pkptr(0:7) DATA pkvec/43,53,36,42,11,21,31,41,51,61,31,61,21,41,61,61,41/ DATA pkptr/1,3,5,11,13,16,17,18/ c----------------------------------------------------------------------- real*8 silHf(100),silHm(100) DATA silHf/0.0696,0.0705,0.0715,0.0726,0.0735, & 0.0746,0.0756,0.0768,0.0778,0.0788, & 0.0801,0.0812,0.0822,0.0834,0.0845, & 0.0857,0.0869,0.0881,0.0895,0.0909, & 0.0923,0.0935,0.0948,0.0961,0.0975, & 0.0988,0.1003,0.1018,0.1034,0.1047, & 0.1062,0.1076,0.1090,0.1106,0.1125, & 0.1143,0.1161,0.1175,0.1192,0.1208, & 0.1224,0.1245,0.1263,0.1282,0.1301, & 0.1324,0.1342,0.1360,0.1381,0.1404, & 0.1428,0.1452,0.1477,0.1500,0.1523, & 0.1548,0.1573,0.1598,0.1620,0.1645, & 0.1674,0.1702,0.1731,0.1756,0.1790, & 0.1820,0.1852,0.1883,0.1922,0.1958, & 0.1991,0.2030,0.2069,0.2108,0.2154, & 0.2198,0.2243,0.2296,0.2347,0.2396, & 0.2447,0.2510,0.2572,0.2640,0.2717, & 0.2787,0.2863,0.2952,0.3043,0.3147, & 0.3259,0.3385,0.3522,0.3658,0.3849, & 0.4040,0.4314,0.4590,0.4958,0.5485/ DATA silHm/0.0023,0.0029,0.0036,0.0042,0.0048, & 0.0055,0.0061,0.0068,0.0074,0.0080, & 0.0089,0.0095,0.0102,0.0109,0.0116, & 0.0123,0.0131,0.0139,0.0147,0.0154, & 0.0162,0.0169,0.0178,0.0186,0.0195, & 0.0203,0.0212,0.0221,0.0230,0.0240, & 0.0249,0.0259,0.0270,0.0280,0.0290, & 0.0300,0.0309,0.0319,0.0330,0.0342, & 0.0353,0.0364,0.0376,0.0388,0.0400, & 0.0411,0.0424,0.0435,0.0448,0.0459, & 0.0474,0.0488,0.0502,0.0515,0.0529, & 0.0544,0.0559,0.0572,0.0589,0.0606, & 0.0624,0.0640,0.0658,0.0676,0.0695, & 0.0714,0.0732,0.0751,0.0768,0.0790, & 0.0814,0.0839,0.0864,0.0889,0.0912, & 0.0939,0.0968,0.0995,0.1027,0.1057, & 0.1093,0.1127,0.1163,0.1202,0.1239, & 0.1280,0.1332,0.1379,0.1430,0.1490, & 0.1551,0.1620,0.1705,0.1794,0.1901, & 0.2025,0.2173,0.2380,0.2661,0.3120/ c la probabilidad de un pico espureo sea mayor que 80+i*0.2% c se da si supera en Plimit a las frecuencias adjacentes c donde Plimit=silHf(i+1)*Rango (para pico en frecuencia pi radianes) c Plimit=silHm(i+1)*Rango (para frecuencia no pi radianes ni 0 radianes) c----------------------------------------------------------------------- c----------------------------------------------------------------------- c EXTERNAL integer indexGE external indexGE c----------------------------------------------------------------------- do i=1,6 ppeaks(i)=0.0d0 enddo cont=0 DO i=pkptr(Pkidx-1),pkptr(Pkidx)-1 j=i-pkptr(Pkidx-1)+1 freq=pkvec(i) ppeaks(j)=0.0d0 IF(Sxx(freq).gt.Mlimit)THEN incH=(Sxx(freq)-Sxx(freq-1))/Rango if (freq.ne.61) then incH2=(Sxx(freq)-Sxx(freq+1))/Rango if (incH.gt.incH2) then incH=incH2 end if if (incH.gt.0.0d0) then ppeaks(j)=0.8+0.002*indexGE(incH,silHm,100) end if else if (incH.gt.0.0d0) then ppeaks(j)=0.8+0.002*indexGE(incH,silHf,100) end if end if if (pPeaks(j).ge.0.90d0)then cont=cont+1 Peaks(cont)=freq end if END IF END DO pARpeak=cont RETURN END c c subroutine rellPico2(pARpeaks_s,pARpeaks_TD,pTpeaks_s,pTpeaks_TD, $ mv,mq,dm,peaksARseas,peaksTseas,pico) implicit none real*8 prob1,prob2,probA parameter(prob1=0.99d0,prob2=0.90d0,probA=0.79d0) c INPUT VARIABLES integer mq,dm real*8 pTpeaks_s(6),pTpeaks_TD,pARPeaks_TD(6),pARpeaks_S(6), $ mv(14) c OUTPUT VARIABLES character pico(7)*2 integer peaksARseas,peaksTseas c LOCAL VARIABLES integer i,tmp,peaksTtd,peaksARtd c external integer nPicosAnchos,picosAnchosTD external nPicosAnchos,picosAnchosTD c-------------------- c-------------------- do i=1,7 pico(i)='--' enddo if ((pARPeaks_TD(1).ge.prob1)) then pico(7)(1:1)='A' else if ((pARPeaks_TD(1).ge.prob2)) then pico(7)(1:1)='a' end if if (pTpeaks_TD.ge.prob1) then pico(7)(2:2)='T' else if (pTpeaks_TD.ge.prob2) then pico(7)(2:2)='t' end if do i=1,6 if (pTpeaks_s(i).ge.prob1) then pico(i)(2:2)='T' else if (pTpeaks_s(i).ge.prob2) then pico(i)(2:2)='t' end if if (pARpeaks_s(i).ge.prob1) then pico(i)(1:1)='A' else if (pARpeaks_s(i).ge.prob2) then pico(i)(1:1)='a' end if enddo end c c integer function nPicosAnchos(mv,m,MQ,picos) implicit none c INPUT PARAMETERS real*8 mv(14) integer m,MQ c OUTPUT PARAMETERS character*2 picos(7) c LOCAL PARAMETERS integer i,cont real*8 mC,mC1,mC2,mC3,mC4,mC5,mC6,mCe4 c ------------------------------------------- cont=0 if (MQ.eq.12.and.m.eq.112) then mC=3.0d0 mCe4=3.0d0 mC1=1.76d0 mC2=1.77d0 mC3=2.05d0 mC4=3.01d0 mC5=1.76d0 mC6=2.29d0 elseif (MQ.eq.12.and.m.eq.79) then mC=3.0d0 mCe4=2.81d0 mC1=1.64d0 mC2=1.78d0 mC3=1.67d0 mC4=2.82d0 mC5=1.85d0 mC6=1.97d0 else c No se han calculado los valores críticos optimos para otros M nPicosAnchos=0 return endif do i=1,6 picos(i)(2:2)='-' enddo c if (m.ne.79)then if (mv(1).ge.mC.or.(mv(1).gt.1.0d0.and.mv(2).ge.mC1))then cont=cont+1 picos(1)(2:2)='T' endif c endif if (mv(3).ge.mC.or.(mv(3).gt.1.0d0.and.mv(4).ge.mC2))then cont=cont+1 picos(2)(2:2)='T' endif if (mv(5).ge.mC.or.(mv(5).gt.1.0d0.and.mv(6).ge.mC3))then cont=cont+1 picos(3)(2:2)='T' endif if (mv(7).ge.mCe4.or.(mv(7).gt.1.0d0.and.mv(8).ge.mC4))then cont=cont+1 picos(4)(2:2)='T' endif if (mv(9).ge.mC.or.(mv(9).gt.1.0d0.and.mv(10).ge.mC5))then cont=cont+1 picos(5)(2:2)='T' endif if (mv(11).ge.mC.or.(mv(11).gt.1.0d0.and.mv(12).ge.mC5))then cont=cont+1 picos(6)(2:2)='T' endif nPicosAnchos=cont end c c integer function picosAnchosTD(mv,m,MQ) implicit none c INPUT PARAMETERS real*8 mv(14) integer m,MQ c LOCAL PARAMETERS integer i,cont real*8 mC,mC1,mC2,mC3,mC4,mC5,mC6,mCe4 c ------------------------------------------- cont=0 if (MQ.eq.12.and.m.eq.112) then mCe4=3.0d0 mC4=3.01d0 else if (MQ.eq.12.and.m.eq.79) then mCe4=2.81d0 mC4=2.82d0 else c No se han calculado los valores críticos optimos para otros M picosAnchosTD=0 return endif if (mv(MQ+1).ge.mCe4.or. $ (mv(MQ+1).gt.1.0d0.and.mv(MQ+2).ge.mC4))then cont=cont+1 endif picosAnchosTD=cont end spectra.i0000664006604000003110000000104414521201571012001 0ustar sun00315stepsc spectra.i include 'spectrum.i' real*8 spect(Lspect),spectse(Lspect),spects(Lspect), $ spectsa(Lspect),spectt(Lspect),specty(Lspect), $ spectBC(Lspect),spectM(Lspect),spectei(Lspect), $ spectes(Lspect),spectet(Lspect),spectey(Lspect), $ spectesa(Lspect),spectec(Lspect),specteBC(Lspect), $ specteM(Lspect) common /spectra/ spect,spectse,spects,spectsa,spectt,specty, $ spectBC,spectM,spectei,spectes,spectet,spectey,spectesa, $ spectec,specteBC,specteM spectrum2.f0000664006604000003110000022164614521201572012276 0ustar sun00315steps subroutine DecompSpectrum(NOADMISS,NOSERIE, $ CHI,nCHI,PSI,nPSI,CYC,nCYC,CHIS,nCHIS, $ PSIS,nPSIS,ADJS,nADJS,CYCS,nCYCS,THSTAR,QSTAR,SQF, $ ct,cs,cc,Qt1, $ SQG,mq,bd,d,PG,OUT,ITER, $ estar,enot,enoc,Us,nUS,Vn,nVn, $ ncycth, $ THETP,nTHETP,THETS,nTHETS,THETC,nTHETC,THADJ,nTHADJ, $ CHCYC,nCHCYC, $ VarWNP,varwns,varwnc,varwna,buff2, $ pscyc, varwnt, thtra, npscyc, nthtra, $ chpsi, varwca, thcya, nchpsi, nthcya, NoDecompOut) implicit none c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- c INPUT PARAMETERS integer NOADMISS,nchi,npsi,nCYC,SQG,MQ,bd,d,PG,OUT,ITER,NOSERIE integer nChis,nADJS,nPSIS,nCYCS real*8 ct(32),cs(32),cc(32),Cyc(5),CYCs(5), $ chi(8),CHIS(5),PSI(27),PSIS(16),SQF real*8 ADJS(5) include 'func.i' include 'func2.i' include 'func3.i' include 'func4.i' include 'func5.i' include 'test.i' include 'buffers.i' include 'spectra.i' include 'dirs.i' include 'stream.i' include 'error.cmn' integer nUS,nVn,ncycth,Qstar, npscyc, nthtra, $ nchpsi, nthcya integer nounit real*8 qt1,estar,enot,enoc,Us(50),Vn(80),THstar(27), $ pscyc(32), varwnt, thtra(32), $ chpsi(32), varwca, thcya(32) c OUTPUT PARAMETERS include 'strmodel.i' integer nTHETP,nTHETS,nTHETC,NTHADJ,NCHCYC,NoDecompOut real*8 thetp(8),thets(27),thetc(32),thadj(32),chcyc(8) real*8 varWnp,varwns,varwnc,varwna character buff2*80 c LOCAL PARAMETERS real*8 Qmin,utf(8),x,pi real*8 arg,y(300),vf(27),UCF(32),toterr,dvec(1) integer I,J,IOUT,nsaltos character fname*30,subtitle*50,auxs*350,caption0*(60) logical isopen c External Functions real*8 FUNC0 integer ISTRLEN external FUNC0,ISTRLEN intrinsic abs c ----------------- pi = 3.14159265358979D0 Qmin=Qt1 NoDecompOut=0 nounit = 0 C C SUBTRACT MINIMA AND SET UP FILTERS NUMERATORS C do i = 1,32 ct(i) = ZERO cs(i) = ZERO cc(i) = ZERO end do C do i = 1,Nf Dum1(i) = Ff(i) end do Ndum1 = Nf if (nchi .ne. 1) then Ut(Nt) = ZERO Nut = Nt do i = 1,Nut utf(i) = Ut(i) - enot*Ft(i) end do call SPC(Utf,Nut,Ft,Nt,ONE,spectt) C********************************************************** call MULTFN(utf,Nut,Fc,Nc,vn,nvn) call MULTFN(vn,nvn,Fs,Ns,us,nus) C C********************************************************** do i = 1,nus Dum(i) = us(i) end do Ndum = nus Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do C C GC 08/07/98 if (d.ne.0 .or. bd.ne.0) then y(1) = ONE end if if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then fname = 'FILTFT.T4F' if (sqg .eq. 1) then subtitle = 'SQUARED GAIN OF TREND-CYCLE FILTER' else subtitle = 'FILTER for TREND-CYCLE (F.D.)' end if call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) end if C C********************************************************** C C********************************************************** do i = 1,Nh Dum(i) = Fh(i) end do Ndum = Nh Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg * qt1 if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then fname = 'FILTFI.T4F' if (sqg .eq. 1) then subtitle = 'SQUARED GAIN OF IRREGULAR FILTER' else subtitle = 'FILTER for IRREGULAR (F.D.)' end if call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) end if C C********************************************************** ct(1) = us(1) do j = 2,nus ct(j) = 0.5d0 * us(j) end do end if C if (npsi .ne. 1) then V(Ns) = ZERO do i = 1,Ns vf(i) = V(i) - estar*Fs(i) end do call SPC(Vf,Ns,Fs,Ns,ONE,spectS) C********************************************************** call MULTFN(vf,Ns,Fc,Nc,vn,nvn) call MULTFN(vn,nvn,Ft,Nt,us,nus) C C********************************************************** do i = 1,nus Dum(i) = us(i) end do Ndum = nus Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then fname = 'FILTFS.T4F' if (sqg .eq. 1) then subtitle = 'SQUARED GAIN OF SEASONAL FILTER' else subtitle = 'FILTER for SEASONAL (F.D.)' end if call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) end if C C********************************************************** cs(1) = us(1) do j = 2,nus cs(j) = 0.5d0 * us(j) end do end if if (ncycth.ne.0 .or. ncyc.ne.1) then C C CORREZIONE DI GIANLUCA 06-09-95 TOP-HEAVY CYCLE C if (ncycth .eq. 0) then do i=Nuc+1,Nc Uc(i) = ZERO end do Nuc = Nc else do i = Nc+1,Nuc Fc(i) = ZERO end do Nc = Nuc end if do i = 1,Nuc ucf(i) = Uc(i) - enoc*Fc(i) end do call SPC(Ucf,Nuc,Fc,nc,ONE,specty) C********************************************************** call MULTFN(ucf,Nuc,Fs,Ns,vn,nvn) call MULTFN(vn,nvn,Ft,Nt,us,nus) C C********************************************************** do i = 1,nus Dum(i) = us(i) end do Ndum = nus Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then fname = 'FILTFY.T4F' if (sqg .eq. 1) then subtitle = 'SQUARED GAIN OF TRANSITORY FILTER' else subtitle = 'FILTER for TRANSITORY (F.D.)' end if call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) end if C C********************************************************** cc(1) = us(1) do j = 2,nus cc(j) = 0.5d0 * us(j) end do end if C Debug added by REG on 12/22/2005 * if (out .eq. nnohar) then * do i=1,Nf * fp1b(i)=ZERO * fp2b(i)=ZERO * fp3b(i)=ZERO * fp4b(i)=ZERO * end do * write (Nio,8003) 'UTF(X)', (Utf(i), i = 1,Nut) * write (Nio,8003) 'VF(X)', (Vf(i), i = 1,Ns) * write (Nio,8003) 'UCF(X)', (Ucf(i), i = 1,Nuc) * write (Nio,8003) 'I(X)', qt1 *c8003 format( //, 1x, a, //, 10(8(f11.4,1x),/) ) * call MULTFN(Vf,Ns,Ft,Nt,fp1a,np1a) * call MULTFN(Utf,Nut,Fs,Ns,fp2a,np2a) * call MULTFN(fp1a,np1a,Fc,Nc,fp1b,np1b) * call MULTFN(fp2a,np2a,Fc,Nc,fp2b,np2b) * if ( Nuc .gt. 0 ) then * call MULTFN(Ucf,Nuc,Fs,Ns,fp3a,np3a) * call MULTFN(fp3a,np3a,Ft,Nt,fp3b,np3b) * end if * qt1a(1)=qt1 * call MULTFN(qt1a,1,Fh,Nh,fp4b,np4b) * do i = 1,Nf * Dum(i) = Ff(i) - fp1b(i) - fp2b(i) - fp3b(i) - fp4b(i) * end do * 8028 format ( ///, * $ ' DUM(X) = F(X)-VF(X)T(X)C(X)-UTF(X)S(X)C(X)-UCF(X)S(X)T(X)', * $ '-I(X)H(X).',' THIS SHOULD BE ZERO', //, 10(8(g12.5,1x),/) ) * write (Nio,8028) (Dum(i), i = 1,Nf) * end if C C FIND THE MA REPRESENTATION OF THE THREE NUMERATORS C nthetp = 1 nthets = 1 nthetc = 1 nthadj = 1 thetp(1) = ONE thets(1) = ONE thetc(1) = ONE thadj(1) = ONE C C SPECTRUM OF IRREGULAR ESTIMATOR C if (pg .eq. 0) then call SPC(Fh,Nh,Ff,Nf,Qt1*Qt1,spectei) end if if (out.eq.0) then iout=0 else iout=1 endif call MAspectrum(iout,HTML,nidx,nio,buff2, $ chi,nchi,utf,nut,thetp,nthetp,varwnp, $ npsi,vf,ns,thets,nthets,varwns, $ cyc,ncyc,ncycth,ucf,nuc,thetc,nthetc,varwnc, $ chcyc,nchcyc,thstar,qstar,thadj,nthadj,varwna, $ us,nus,qt1) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK C **** TREND **** C if (nchi .ne. 1) then if (pg .eq. 0) then call SPCEST(utf,Nut,Fs,Ns,Fc,Nc,Ft,Nt,Ff,Nf,spectet) end if end if C if (npsi .ne. 1) then C C **** SEAS. **** C if (pg .eq. 0) then call SPCEST(vf,Ns,Ft,Nt,Fc,Nc,Fs,Ns,Ff,Nf,specteS) end if end if C if (ncycth.ne.0 .or. ncyc.ne.1) then C C **** CYCLE **** C if (varwnc .lt.ZERO) then if ((noadmiss.eq.1) .or. (noadmiss.eq.2)) then noadmiss = 3 if (HTML .eq. 1) then call SWarn(Nio) write (Nio,'("
    DECOMPOSITION INVALID
    ", $ "THE MODEL IS APPROXIMATED")') call EWarn(Nio) else 2051 format ( $ ////,4x,' DECOMPOSITION INVALID'//,10x, $ '*****************************',/,12x, $ 'THE MODEL IS APPROXIMATED',/,10x, $ '*****************************',/) write (NIO,2051) endif return else if (HTML .eq. 1) then call SWarn(Nio) write (Nio,'("
    DECOMPOSITION INVALID,IRREGULAR ", $ "SPECTRUM NEGATIVE
    TRY ANOTHER MODEL OR," $ " FOR AN APPROXIMATION, SET NOADMISS=YES.")') call EWarn(Nio) else 2052 format ( $ ////,' DECOMPOSITION INVALID,IRREGULAR SPECTRUM NEGATIVE'/, $ ' TRY ANOTHER MODEL OR, FOR AN APPROXIMATION,', $ ' SET NOADMISS=YES.' $ ) write (NIO,2052) endif NoDecompOut=1 return end if end if if (pg .eq. 0) then call SPCEST(ucf,Nuc,Fs,Ns,Ft,Nt,Fc,Nc,Ff,Nf,spectey) end if end if C if (nchcyc.ne.1 .or. ncycth.ne.0) then if (npsi .eq. 1) then do i = 1,qstar thadj(i) = thstar(i) end do do i = qstar+1,nchcyc thadj(i) = ZERO end do c nthadj = MAX(qstar,nchcyc) nthadj=qstar varwna = ONE else C C C FIND MA REPRESENTATION OF SEASONALLY ADJUSTED SERIES C call MULTFN(Ft,Nt,Fc,Nc,vn,nvn) if (pg .eq. 0) then call SPCEST(us,nus,Fs,Ns,ONE,1,vn,nvn,Ff,Nf,specteSA) end if call getSpectrum(thadj,nthadj,chcyc,nchcyc,spectSA) do i=1,Lspect spectSA(i)=varwna*spectSA(i)/(2.0D0*pi) enddo call MULTFN(us,nus,Fs,Ns,Dum,Ndum) do i = 1,Nf Dum1(i) = Ff(i) end do Ndum1 = Nf Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do C C GC 08/07/98 if (d.ne.0 .or. bd.ne.0) then y(1) = ONE end if if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then fname = 'FILTFADJ.T4F' if (sqg .eq. 1) then subtitle = 'SQUARED GAIN OF SA SERIES FILTER' else subtitle = 'FILTER for TREND-CYCLE (F.D.)' end if call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) end if end if end if C C added by DEKM Feb 6 2003 to compute trend adjusted component varwnt = ZERO if (npscyc.ne.1 .or. ncycth.ne.0) then if (nchi .eq. 1) then do i = 1,qstar thtra(i) = thstar(i) end do do i = qstar+1,npscyc thtra(i) = ZERO end do nthtra = MAX(qstar,npscyc) varwnt = ONE else C C C FIND MA REPRESENTATION OF TREND ADJUSTED SERIES C call CONJ(pscyc,npscyc,pscyc,npscyc,us,nus) do i = 1,nus us(i) = us(i) * qt1 end do C C.. Modified by REG on 12/22/2005 if (npsi .ne. 1) then call CONV(thets,nthets,cyc,ncyc,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwns,us,nus) end if if (ncycth.ne.0 .or. ncyc.ne.1) then call CONV(thetc,nthetc,psi,npsi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwnc,us,nus) end if iout = 1 if (out .eq. 1) then 7138 format ( $ //,4x,' MA ROOTS OF TREND ADJUSTED SERIES'/,4x, $ ' --------------------------------------') write (Nio,7138) iout = 0 end if c Here we do spectral factorization to get trend adjusted numerator (thtra) c comment added DEKM 20 Feb 03 caption0=' ' call MAK1(us,nus,thtra,nthtra,varwnt,nounit,iout,caption0,0, & toterr) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK call CONJ(thtra,nthtra,thtra,nthtra,vn,nvn) if (nus .ne. nvn) then 7034 format ( $ /,' ','THE LENGTH OF THE MA DOESN''T MATCH WITH THE ACF') write (Nio,7034) end if toterr = ZERO do i = 1,nvn toterr = toterr + (vn(i)*varwnt-us(i))**2 end do dvec(1)=toterr call USRENTRY(dvec,1,1,1903) if (toterr .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if if (out .eq. 1) then 7035 format (/,5x,'TOTAL SQUARED ERROR=',d15.7) write (Nio,7035) toterr end if end if else nthtra=1 thtra(1)=1D0 end if C C added by DEKM 1 May 2003 to compute cycle adjusted component C C varwca = ZERO if (nchpsi.ne.1 .or. ncycth.ne.0) then C.. Modified by REG on 12/22/2005 if ((ncyc .eq. 1) .and. (ncycth. eq. 0)) then do i = 1,qstar thcya(i) = thstar(i) end do do i = qstar+1,nchpsi thcya(i) = ZERO end do nthcya = MAX(qstar, nchpsi) varwca = ONE else C C C FIND MA REPRESENTATION OF CYCLE ADJUSTED SERIES C call CONJ(chpsi,nchpsi,chpsi,nchpsi,us,nus) do i = 1,nus us(i) = us(i) * qt1 end do C if (nchi .ne. 1) then call CONV(thetp,nthetp,psi,npsi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwnp,us,nus) end if C.. Modified by REG on 12/22/2005 if (npsi.ne.1) then call CONV(thets,nthets,chi,nchi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwns,us,nus) end if iout = 1 if (out .eq. 1) then 9980 format ( $ //,4x,' MA ROOTS OF CYCLE ADJUSTED SERIES'/,4x, $ ' --------------------------------------') write (Nio,9980) iout = 0 end if c Here we do spectral factorization to get cycle adjusted numerator (thcya) c comment added DEKM 20 Feb 03 caption0=' ' call MAK1(us,nus,thcya,nthcya,varwca,nounit,iout,caption0,0, & toterr) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK call CONJ(thcya,nthcya,thcya,nthcya,vn,nvn) if (nus .ne. nvn) then write (Nio,7034) end if C.. Modified by REG on 12/22/2005 toterr = ZERO do i = 1,nvn toterr = toterr + (vn(i)*varwca-us(i))**2 end do dvec(1)=toterr call USRENTRY(dvec,1,1,1903) if (toterr .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if if (out .eq. 1) then write (Nio,7035) toterr end if C C C GC 08/07/98 c if (d.ne.0 .or. bd.ne.0) then c y(1) = hs c end if c if (pg .eq. 0) then c fname = 'SPECTSA.T3' c subtitle = 'SPECTRUM SA SERIES' c call PLOTSPECTRUM(fname,subtitle,y,300,600/mq,hs) c end if c call MULTFN(us,nus,Fs,Ns,Dum,Ndum) c do i = 1,Nf c Dum1(i) = Ff(i) c end do c Ndum1 = Nf c Ifunc = 5 c do i = 1,120 c x = (ONE/120.0d0) * pi * i c arg = F(x) c y(i) = arg c if (sqg .eq. 1) then c y(i) = y(i)**2 c end if c end do C C GC 08/07/98 c if (d.ne.0 .or. bd.ne.0) then c y(1) = ONE c end if c if ((pg.eq.0) .and. (out.eq.1)) then c fname = 'FILTFADJ.T4F' c if (sqg .eq. 1) then c subtitle = 'SQUARED GAIN OF SA SERIES FILTER' c else c subtitle = 'FILTER for TREND-CYCLE (F.D.)' c end if c call PLOTFILTERS(fname,subtitle,y,120,240/mq,ZERO) c end if end if end if C OUTPUT COMPONENTS C c rober if ((noadmiss.eq.1) .or. (noadmiss.eq.2) .or. (noadmiss.eq.0) & .and. (noserie.eq.1)) then c call WriteLinCompMatrix() if (html .eq.1) then inquire(file= outdir(1:istrlen(outdir))//'\summarys.htm', & opened=IsOpen) if (isopen) then lu61=' ' if (varwna.gt.1.0d-20) then c trend-cycle model if (nchis.gt.1) then if (chis(2).gt.0) then write(lu61,'(''(1+'',f5.2,''B'')') chis(2) else write(lu61,'(''(1'',f5.2,''B'')') chis(2) end if do i=3, nchis if (chis(i).gt.0) then write(lu61,'(A,''+'',f5.2,''B'',i2,'''')') & lu61(1:istrlen(lu61)),chis(i),i-1 else write(lu61,'(A,f5.2,''B'',i2,'''')') & lu61(1:istrlen(lu61)),chis(i),i-1 end if end do lu61=lu61(1:istrlen(lu61))//') ' end if if (bd+d.gt.0) then if (bd+d.eq.1) then lu61=lu61(1:istrlen(lu61))//' ∇' else write(lu61,'(A,''∇'',i1,'''')') & lu61(1:istrlen(lu61)),bd+d end if end if lu61=lu61(1:istrlen(lu61))//' pt = ' if (nthetp.gt.1) then if (thetp(2).gt.0) then write(lu61,'(A,'' (1+'',f5.2,''B'')') & lu61(1:istrlen(lu61)),thetp(2) else write(lu61,'(A,''(1'',f5.2,''B'')') & lu61(1:istrlen(lu61)),thetp(2) end if do i=3, nthetp if (thetp(i).gt.0) then write(lu61,'(A,''+'',f5.2,''B'',i2,'''')') & lu61(1:istrlen(lu61)),thetp(i),i-1 else write(lu61,'(A,f5.2,''B'',i2,'''')') & lu61(1:istrlen(lu61)),thetp(i),i-1 end if end do lu61=lu61(1:istrlen(lu61))//')' end if lu61=lu61(1:istrlen(lu61))//' apt, '// & 'apt∼N(0,' c write(lu61,'(A,f12.6,") niid")') c & lu61(1:istrlen(lu61)),varwnp write(lu61,'(A,f12.6,") niid")') & lu61(1:istrlen(lu61)), varwnp*sqf*sqf end if c seasonal model lu62=' ' if (varwns.gt.1.0d-20) then if (npsis.gt.1) then if (psis(2) .gt.0) then write(lu62,'(''(1+'',f5.2,''B'')') psis(2) else write(lu62,'(''(1'',f5.2,''B'')') psis(2) end if do i=3, npsis if (psis(i) .gt.0) then write(lu62,'(A,''+'',f5.2,''B'',i2,'''')') & lu62(1:istrlen(lu62)),psis(i),i-1 else write(lu62,'(A,f5.2,''B'',i2,'''')') & lu62(1:istrlen(lu62)),psis(i),i-1 end if end do lu62=lu62(1:istrlen(lu62))//')' end if if (bd.gt.0) then lu62=lu62(1:istrlen(lu62))//' S st = ' else lu62=lu62(1:istrlen(lu62))//' st = ' end if if (nthets.gt.1) then if (thets(2) .gt.0) then write(lu62,'(A,'' (1+'',f5.2,''B'')') & lu62(1:istrlen(lu62)),thets(2) else write(lu62,'(A,'' (1'',f5.2,''B'')') & lu62(1:istrlen(lu62)),thets(2) end if do i=3,nthets if (thets(i) .gt.0) then write(lu62,'(A,''+'',f5.2,''B'',i2,'''')') & lu62(1:istrlen(lu62)),thets(i) ,i-1 else write(lu62,'(A,f5.2,''B'',i2,'''')') & lu62(1:istrlen(lu62)),thets(i) ,i-1 end if end do lu62=lu62(1:istrlen(lu62))//')' end if lu62=lu62(1:istrlen(lu62))//' ast ,'// & 'ast∼N(0,' write(lu62,'(A,f12.6,") niid")') & lu62(1:istrlen(lu62)),varwns*sqf*sqf end if c seasonally adjusted lu63=' ' if (varwna.gt.1.0d-20) then if (nadjs.gt.1) then if (adjs(2).gt.0) then write(lu63,'(''(1+'',f5.2,''B'')') adjs(2) else write(lu63,'(''(1'',f5.2,''B'')') adjs(2) end if do i=3, nadjs if (adjs(i).gt.0) then write(lu63,'(A,''+'',f5.2,''B'',i2,'''')') & lu63(1:istrlen(lu63)),adjs(i),i-1 else write(lu63,'(A,f5.2,''B'',i2,'''')') & lu63(1:istrlen(lu63)),adjs(i),i-1 end if end do lu63=lu63(1:istrlen(lu63))//')' end if if (bd+d.gt.0) then if (bd+d.eq.1) then lu63=lu63(1:istrlen(lu63))//' ∇' else c lu63=lu63(1:istrlen(lu63))//' ∇'// c & '' write(lu63,'(A,'' ∇'',i1,a6)') & lu63(1:istrlen(lu63)),bd+d,'' end if end if lu63=lu63(1:istrlen(lu63))//' nt = ' if (nthadj.gt.1) then if (thadj(2).gt.0) then write(lu63,'(A,'' (1+'',f5.2,''B'')') & lu63(1:istrlen(lu63)),thadj(2) else write(lu63,'(A,'' (1'',f5.2,''B'')') & lu63(1:istrlen(lu63)),thadj(2) end if do i=3, nthadj if (thadj(i).gt.0) then write(lu63,'(A,''+'',f5.2,''B'',i2,'''')') & lu63(1:istrlen(lu63)),thadj(i),i-1 else write(lu63,'(A,f5.2,''B'',i2,'''')') & lu63(1:istrlen(lu63)),thadj(i),i-1 end if end do lu63=lu63(1:istrlen(lu63))//')' end if lu63=lu63(1:istrlen(lu63))//' ant ,'// & 'ant∼N(0,' write(lu63,'(A,f12.6,") niid")') & lu63(1:istrlen(lu63)),varwna *sqf*sqf end if c transitorio lu64=' ' if (varwnc.gt.1.0d-20) then if (ncycs.gt.1) then if (cycs(2).gt.0) then write(lu64,'(''(1+'',f5.2,''B'')') cycs(2) else write(lu64,'(''(1'',f5.2,''B'')') cycs(2) end if do i=3, ncycs if (cycs(i).gt.0) then write(lu64,'(A,''+'',f5.2,''B'',i2,'''')') & lu64(1:istrlen(lu64)),cycs(i),i-1 else write(lu64,'(A,f5.2,''B'',i2,'''')') & lu64(1:istrlen(lu64)),cycs(i),i-1 end if end do lu64=lu64(1:istrlen(lu64))//')' end if lu64=lu64(1:istrlen(lu64))//' ct = ' if (nthetc.gt.1) then if (thetc(2).gt.0) then write(lu64,'(A,'' (1+'',f5.2,''B'')') & lu64(1:istrlen(lu64)),thetc(2) else write(lu64,'(A,'' (1'',f5.2,''B'')') & lu64(1:istrlen(lu64)),thetc(2) end if do i=3, nthetc if (thetc(i).gt.0) then write(lu64,'(A,''+'',f5.2,''B'',i2,'''')') & lu64(1:istrlen(lu64)),thetc(i),i-1 else write(lu64,'(A,f5.2,''B'',i2,'''')') & lu64(1:istrlen(lu64)),thetc(i),i-1 end if end do lu64=lu64(1:istrlen(lu64))//')' end if lu64=lu64(1:istrlen(lu64))//' act ,'// & 'act∼N(0,' write(lu64,'(A,f12.6,") niid")') & lu64(1:istrlen(lu64)),varwnc *sqf*sqf end if lu64I=' ' if (qt1.gt.1.0d-20) then write(lu64I,'("ut = N(0,",G12.6,") niid")') & qt1 *sqf*sqf end if else inquire(61,opened=IsOpen) if (Isopen) then write (61,'('''',i2,'''')') bd+d do i=2, nchis write (61,'('''',f5.2,'''')') & chis(i) end do do i=nchis+1,5 write (61,'('''',i5,'''')') 0 end do do i=2, nthetp write (61,'('''',f5.2,'''')') & thetp(i) end do do i=nthetp+1,8 write (61,'('''',i5,'''')') 0 end do write (61,'('''',G12.6,'''')') & varwnp write (61, '("")') end if inquire(63,opened=IsOpen) if (Isopen) then write (63,'('''',i2,'''')') d+bd do i=2, nadjs write (63,'('''',f5.2,'''')') $ adjs(i) end do do i=nadjs+1,5 write (63,'('''',i5,'''')') 0 end do do i=2, nthadj write (63,'('''',f5.2,'''')') & thadj(i) end do do i=nthadj+1,18 write (63,'('''',i5,'''')') 0 end do write (63,'('''',G12.6,'''')') varwna*sqf*sqf write (63, '("")') end if c inquire(62,opened=IsOpen) if (Isopen) then write (62,'('''',i2,'''')') bd do i=2, npsis write (62,'('''',f5.2,'''')') $ psis(i) end do do i=npsis+1,15 write (62,'('''',i5,'''')') 0 end do do i=2, nthets write (62,'('''',f5.2,'''')') & thets(i) end do do i=nthets+1,26 write (62,'('''',i5,'''')') 0 end do write (62,'('''',G12.6,'''')') varwns*sqf*sqf write (62, '("")') end if c inquire(64,opened=IsOpen) if (Isopen) then do i=2, ncycs write (64,'('''',f5.2,'''')') $ cycs(i) end do do i=ncycs+1,4 write (64,'('''',i5,'''')') 0 end do do i=2, nthetc write (64,'('''',f5.2,'''')') & thetc(i) end do do i=nthetc+1,16 write (64,'('''',i5,'''')') 0 end do write (64,'('''',G12.6,'''')') varwnc*sqf*sqf write (64,'('''',G12.6,'''')') qt1*sqf*sqf write (64, '("")') end if end if else inquire(file= outdir(1:istrlen(outdir))//'\summarys.txt', & opened=IsOpen) if (isopen) then if (varwna.gt.1.0d-20) then c trend-cycle model if (nchis.gt.1) then if (chis(2).gt.0) then write(lu61,'(''(1 +'',f5.2,''B'')') chis(2) else write(lu61,'(''(1 -'',f5.2,''B'')') abs(chis(2)) end if do i=3, nchis if (chis(i).gt.0) then write(lu61,'(A,'' +'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),chis(i),i-1 else write(lu61,'(A,'' -'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),abs(chis(i)),i-1 end if end do lu61=lu61(1:istrlen(lu61))//') ' end if if (bd+d.gt.0) then if (bd+d.eq.1) then lu61=lu61(1:istrlen(lu61))//' (1-B)' else write(lu61,'(A,''(1-B)^'',i1)') & lu61(1:istrlen(lu61)),bd+d end if end if lu61=lu61(1:istrlen(lu61))//' p(t) = ' if (nthetp.gt.1) then if (thetp(2).gt.0) then write(lu61,'(A,'' (1 +'',f5.2,''B'')') & lu61(1:istrlen(lu61)),thetp(2) else write(lu61,'(A,'' (1 -'',f5.2,''B'')') & lu61(1:istrlen(lu61)),thetp(2) end if do i=3, nthetp if (thetp(i).gt.0) then write(lu61,'(A,'' +'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),thetp(i),i-1 else write(lu61,'(A,'' -'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),abs(thetp(i)),i-1 end if end do lu61=lu61(1:istrlen(lu61))//')' end if lu61=lu61(1:istrlen(lu61))//' ap(t), ap(t)~N(0,' write(lu61,'(A,G12.6)') lu61(1:istrlen(lu61)),varwnp*sqf*sqf lu61=lu61(1:istrlen(lu61))//') niid' end if c seasonal model lu62=' ' nsaltos=0 if (varwns.gt.1.0d-20) then if (npsis.gt.1) then if (psis(2) .gt.0) then write(lu62,'(''(1 +'',f5.2,''B'')') psis(2) else write(lu62,'(''(1 -'',f5.2,''B'')') abs(psis(2)) end if do i=3, min(10,npsis) if (psis(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i1)') & lu62(1:istrlen(lu62)),psis(i),i-1 else write(lu62,'(A,'' -'',f5.2,''B^'',i1)') & lu62(1:istrlen(lu62)),abs(psis(i)),i-1 end if end do do i=11, npsis if ((istrlen(lu62)+11-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (psis(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),psis(i),i-1 else write(lu62,'(A,'' -'',f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),abs(psis(i)),i-1 end if end do lu62=lu62(1:istrlen(lu62))//')' end if if ((istrlen(lu62)+10-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (bd.gt.0) then lu62=lu62(1:istrlen(lu62))//' S s(t) = ' else lu62=lu62(1:istrlen(lu62))//' s(t) = ' end if if (nthets.gt.1) then if ((istrlen(lu62)+11-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (thets(2) .gt.0) then write(lu62,'(A,'' (1 +'',f5.2,''B'')') & lu62(1:istrlen(lu62)),thets(2) else write(lu62,'(A,'' (1 -'',f5.2,''B'')') & lu62(1:istrlen(lu62)),abs(thets(2)) end if do i=3,min(10,nthets) if ((istrlen(lu62)+10-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (thets(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i1)') & lu62(1:istrlen(lu62)),thets(i) ,i-1 else write(lu62,'(A," -"f5.2,"B^",i1)') & lu62(1:istrlen(lu62)),abs(thets(i)) ,i-1 end if end do do i=11,nthets if ((istrlen(lu62)+11-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (thets(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),thets(i) ,i-1 else write(lu62,'(A,'' -''f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),abs(thets(i)) ,i-1 end if end do lu62=lu62(1:istrlen(lu62))//')' end if lu62=lu62(1:istrlen(lu62))//' as(t),' if ((istrlen(lu62)+24-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) end if write(lu62,'(A,'' as(t)~N(0,'',G12.6)') & lu62(1:istrlen(lu62)),varwns*sqf*sqf lu62=lu62(1:istrlen(lu62))//') niid' end if c seasonally adjusted lu63=' ' nsaltos=0 if (varwna.gt.1.0d-20) then if (nadjs.gt.1) then if (adjs(2).gt.0) then write(lu63,'(''(1 +'',f5.2,''B'')') adjs(2) else write(lu63,'(''(1 -'',f5.2,''B'')') abs(adjs(2)) end if do i=3, nadjs if (adjs(i).gt.0) then write(lu63,'(A,'' +'',f5.2,''B^'',i1)') & lu63(1:istrlen(lu63)),adjs(i),i-1 else write(lu63,'(A,'' -''f5.2,''B^'',i1)') & lu63(1:istrlen(lu63)),abs(adjs(i)),i-1 end if end do lu63=lu63(1:istrlen(lu63))//')' end if if (bd+d.gt.0) then if (bd+d.eq.1) then lu63=lu63(1:istrlen(lu63))//' (1-B)' else lu63=lu63(1:istrlen(lu63))//' (1-B)^' write(lu63,'(A ,i1)') lu63(1:istrlen(lu63)), bd+d end if end if lu63=lu63(1:istrlen(lu63))//' n(t) = ' if (nthadj.gt.1) then if (thadj(2).gt.0) then write(lu63,'(A,'' (1 +'',f5.2,''B'')') & lu63(1:istrlen(lu63)),thadj(2) else write(lu63,'(A,'' (1 -'',f5.2,''B'')') & lu63(1:istrlen(lu63)),abs(thadj(2)) end if do i=3, min(10,nthadj) if ((istrlen(lu63)+10-nsaltos*130).gt.130) then lu63=lu63(1:istrlen(lu63))//char(10) nsaltos=nsaltos+1 end if if (thadj(i).gt.0) then write(lu63,'(A,'' +'',f5.2,''B^'',i1)') & lu63(1:istrlen(lu63)),thadj(i),i-1 else write(lu63,'(A,'' -''f5.2,''B^'',i1)') & lu63(1:istrlen(lu63)),abs(thadj(i)),i-1 end if end do do i=11, nthadj if ((istrlen(lu63)+11-nsaltos*130).gt.130) then lu63=lu63(1:istrlen(lu63))//char(10) nsaltos=nsaltos+1 end if if (thadj(i).gt.0) then write(lu63,'(A,'' +'',f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),thadj(i),i-1 else write(lu63,'(A,'' -''f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),abs(thadj(i)),i-1 end if end do lu63=lu63(1:istrlen(lu63))//')' end if if ((istrlen(lu63)+24-nsaltos*130).gt.130) then lu63=lu63(1:istrlen(lu63))//char(10) end if lu63=lu63(1:istrlen(lu63))//' an(t)' write(lu63,'(A,'', an(t)~N(0,'',G12.6)') & lu63(1:istrlen(lu63)),varwna *sqf*sqf lu63=lu63(1:istrlen(lu63))//') niid' end if c transitorio lu64=' ' nsaltos=0 if (varwnc.gt.1.0d-20) then if (ncycs.gt.1) then if (cycs(2).gt.0) then write(lu64,'(''(1 +'',f5.2,''B'')') cycs(2) else write(lu64,'(''(1 -'',f5.2,''B'')') abs(cycs(2)) end if do i=3, ncycs if (cycs(i).gt.0) then write(lu64,'(A,'' +'',f5.2,''B^'',i1)') & lu64(1:istrlen(lu64)),cycs(i),i-1 else write(lu64,'(A,'' -'',f5.2,''B^'',i1)') & lu64(1:istrlen(lu64)),cycs(i),i-1 end if end do lu64=lu64(1:istrlen(lu64))//')' end if lu64=lu64(1:istrlen(lu64))//' c(t) = ' if (nthetc.gt.1) then if (thetc(2).gt.0) then write(lu64,'(A,'' (1 +'',f5.2,''B'')') & lu64(1:istrlen(lu64)),thetc(2) else write(lu64,'(A,'' (1 -'',f5.2,''B'')') & lu64(1:istrlen(lu64)),abs(thetc(2)) end if do i=3, min(10,nthetc) if ((istrlen(lu64)+11-nsaltos*130).gt.130) then lu64=lu64(1:istrlen(lu64))//char(10) nsaltos=nsaltos+1 end if if (thetc(i).gt.0) then write(lu64,'(A,'' +'',f5.2,''B^'',i1)') & lu64(1:istrlen(lu64)),thetc(i),i-1 else write(lu64,'(A,'' -'',f5.2,''B^'',i1)') & lu64(1:istrlen(lu64)),abs(thetc(i)),i-1 end if end do do i=11, nthetc if ((istrlen(lu64)+12-nsaltos*130).gt.130) then lu64=lu64(1:istrlen(lu64))//char(10) nsaltos=nsaltos+1 end if if (thetc(i).gt.0) then write(lu64,'(A,'' +'',f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),thetc(i),i-1 else write(lu64,'(A,'' -''f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),abs(thetc(i)),i-1 end if end do lu64=lu64(1:istrlen(lu64))//')' end if lu64=lu64(1:istrlen(lu64))//' ac(t),' if ((istrlen(lu64)+24-nsaltos*130).gt.130) then lu64=lu64(1:istrlen(lu64))//char(10) end if write(lu64,'(A,'' ac(t)~N(0,'',G12.6)') & lu64(1:istrlen(lu64)),varwnc*sqf*sqf lu64=lu64(1:istrlen(lu64))//') niid' end if lu64I=' ' if (qt1.gt.1.0d-20) then write(lu64I,'("u(t) = N(0,",G12.6)') qt1*sqf*sqf lu64I=lu64I(1:istrlen(lu64I))//') niid' end if else inquire(61,opened=IsOpen) if (Isopen) then write (auxS,'(i2)') bd+d do i=2, nchis write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),chis(i) end do do i=nchis+1,5 write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end do do i=2, nthetp write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thetp(i) end do do i=nthetp+1,8 write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end do write (61,'(A,x,A,5x,f12.6)') buffS(1:27), $ auxS(1:istrlen(auxS)),varwnp end if inquire(63,opened=IsOpen) if (Isopen) then write (auxS,'(i2)') d+bd do i=2, nadjs write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),adjs(i) end do do i=nadjs+1,5 write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end do do i=2, nthadj if (i .gt. 10) then write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thadj(i) else write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thadj(i) end if end do do i=nthadj+1,18 if (i .gt. 10) then write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 else write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end if end do write(63,'(A,x,A,3x,f12.6)') buffS(1:27), $ auxS(1:istrlen(auxS)),varwna end if c inquire(62,opened=IsOpen) if (Isopen) then write (auxS,'(i2)') bd do i=2, npsis if (i .gt. 10) then write (auxS,'(A,4x,f5.2)') auxS(1:istrlen(auxS)),psis(i) else write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),psis(i) end if end do do i=npsis+1,15 if (i .gt. 10) then write (auxS,'(A,4x,i5)') auxS(1:istrlen(auxS)),0 else write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end if end do do i=2, nthets if (i .gt. 10) then write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thets(i) else write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thets(i) end if end do do i=nthets+1,26 if (i .gt. 10) then write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 else write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end if end do write (62,'(A,x,A,3x,f12.6)') buffS(1:27), $ auxS(1:istrlen(auxS)),varwns end if c inquire(64,opened=IsOpen) if (Isopen) then write (auxS,'(A)') ' ' do i=2, ncycs write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),cycs(i) end do do i=ncycs+1,4 write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end do do i=2, nthetc write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thetc(i) end do do i=nthetc+1,16 write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end do write (64,'(A,A,3x,f12.6,6x,f12.6)') $ buffS(1:27),auxS(1:istrlen(auxS)),varwnc,qt1 end if end if end if end if call ShowComp(out,buff2,HTML,nio,Nidx, $ chi,nchi,thetp,nthetp,varwnp, $ psi,nPSI,thets,nthets,varwns, $ ncycth,cyc,ncyc,thetc,nthetc,varwnc,qt1, $ chcyc,nchcyc,thadj,nthadj,varwna) end cc c cc subroutine ShowInvalDecomp(Out,HTML,nidx,nio,buff2, $ chi,nchi,enot,psi,npsi,estar, $ cyc,ncyc,ncycth,enoc, $ chcyc,nchcyc,thstar,qstar,qt1) implicit none c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c----------------------------------------------------------------------- include 'func.i' include 'func2.i' include 'func3.i' include 'error.cmn' c INPUT PARAMETERS integer Out,HTML,nidx,nio,nchi,npsi, $ ncyc,ncycth,nchcyc,qstar real*8 chi(8),cyc(5),chcyc(8),thstar(27), $ qt1,psi(27),enot,estar,enoc c LOCAL PARAMETERS integer Noprint,nthetp,nthets,nthetc,nthadj,nus,i real*8 thetp(8),varwnp,thets(27),varwns,vf(27),ucf(32), $ thetc(32),varwnc,thadj(32),varwna,us(50),utf(8) character buff2*80 c ------------------------------------------ if (nchi .ne. 1) then Ut(Nt) = ZERO Nut = Nt do i = 1,Nut utf(i) = Ut(i) - enot*Ft(i) end do endif if (npsi .ne. 1) then V(Ns) = ZERO do i = 1,Ns vf(i) = V(i) - estar*Fs(i) end do endif if (ncycth.ne.0 .or. ncyc.ne.1) then if (ncycth .eq. 0) then do i=Nuc+1,Nc Uc(i) = ZERO end do Nuc = Nc else do i = Nc+1,Nuc Fc(i) = ZERO end do Nc = Nuc end if do i = 1,Nuc ucf(i) = Uc(i) - enoc*Fc(i) end do endif if (out.eq.0) then Noprint=0 else Noprint=1 endif c Noprint=1 call MAspectrum(Noprint,HTML,nidx,nio,buff2, $ chi,nchi,utf,nut,thetp,nthetp,varwnp, $ npsi,vf,ns,thets,nthets,varwns, $ cyc,ncyc,ncycth,ucf,nuc,thetc,nthetc,varwnc, $ chcyc,nchcyc,thstar,qstar,thadj,nthadj,varwna, $ us,nus,qt1) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK buff2='NO ADMISSIBLE' call ShowComp(out,buff2,HTML,nio,Nidx, $ chi,nchi,thetp,nthetp,varwnp, $ psi,nPSI,thets,nthets,varwns, $ ncycth,cyc,ncyc,thetc,nthetc,varwnc,qt1, $ chcyc,nchcyc,thadj,nthadj,varwna) end cc c cc subroutine ShowComp(out,buff2,HTML,nio,Nidx, $ chi,nchi,thetp,nthetp,varwnp, $ psi,nPSI,thets,nthets,varwns, $ ncycth,cyc,ncyc,thetc,nthetc,varwnc,qt1, $ chcyc,nchcyc,thadj,nthadj,varwna) implicit none c----------------------------------------------------------------------- real*8 ONE,ZERO parameter(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- c INPUT PARAMETERS integer out,HTML,nio,Nidx,nchi,nthetp,nPSI,nthets, $ ncycth,ncyc,nthetc,nchcyc,nthadj character buff2*80 real*8 chi(8),thetp(8),varwnp,psi(27),thets(27),varwns,dvec(1), $ cyc(5),thetc(32),varwnc,chcyc(8),thadj(32),varwna,qt1 c LOCAL PARAMETERS integer i c--------------------------------- if (out .eq. 0) then if (buff2(8:8) .eq. ' ') then if (HTML .eq. 1) then write (Nio,'(''

    DERIVATION OF THE COMPONENT '', $ ''MODELS :'',a,''

    '')')buff2 else write (Nio,'(/6x,''DERIVATION OF THE COMPONENT MODELS :'', $ 2x,a)')buff2 endif else if (HTML .eq. 1) then write (Nio,'(''

    DERIVATION OF THE COMPONENT '', $ ''MODELS : "'',a,''"

    '')') buff2 else write (Nio, $'(/6x,''DERIVATION OF THE COMPONENT MODELS :'',/,10x,''"'',a, $''"'')') buff2 endif end if if (HTML .eq. 1) then call AddIdx(Nidx,Nio,'Models for the Components','0028',0,28) write(Nio,'(''

    MODELS FOR THE COMPONENTS

    '')') write(Nio,'(''
    '')') else 7039 format ( $ ///,/,' ',20x,'MODELS FOR THE COMPONENTS',/,21x,25('-'),///) write (Nio,7039) end if if (nchi .ne. 1) then if (HTML .eq. 1) then write(nio,'("

    TREND-CYCLE

    ")') write(nio,'(''
    TREND-CYCLE NUMERATOR(MOVING AVERAGE '', $ ''POL.)
    '')') call WrTabHtmPol2(thetp,nthetp,12,nio,31 ) c write(nio,'(''
    TREND-CYCLE DENOMINATOR AUTOREGRESSIVE '', $ ''( POL.)
    '')') call WrTabHtmPol2(chi,nchi,12,nio,32) c write (Nio,'('''', $ ''
    INNOV. VAR. (*)'', f12.6,''
    '')') varwnp else 7040 format (///,' TREND-CYCLE NUMERATOR (MOVING AVERAGE POL.)') write (Nio,7040) write (Nio,7053) (thetp(i), i = 1,nthetp) 7041 format (' TREND-CYCLE DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7041) write (Nio,7053) (chi(i), i = 1,nchi) 7042 format (' INNOV. VAR. (*)',f12.6) write (Nio,7042) varwnp C LINES OF CODE ADDED FOR X-13A-S : 5 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000 endif CALL USRENTRY(THETP,1,NTHETP,2001) CALL USRENTRY(CHI,1,NCHI,2002) dvec(1)=Varwnp call USRENTRY(dvec,1,1,2003) C END OF CODE BLOCK IF(varwnp.gt.ONE.or.varwnp.lt.ZERO)THEN if (HTML .eq. 1) then write (Nio,'("
    (*) IN UNITS OF VAR(A)")') write (Nio,'("

    ")') IF(varwnp.gt.ONE)THEN WRITE (Nio,9000)'

    ','trend','greater than one','.

    ', & '

    ','.

    ' WRITE (Mt2,9000)'

    ','trend','greater than one','.

    ', & '

    ','.

    ' ELSE WRITE (Nio,9000)'

    ','trend','less than zero','.

    ', & '

    ','.

    ' WRITE (Mt2,9000)'

    ','trend','less than zero','.

    ', & '

    ','.

    ' END IF else write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') IF(varwnp.gt.ONE)THEN WRITE (Nio,9000)' ','trend','greater than one','.',' ','.' WRITE (Mt2,9000)' ','trend','greater than one','.',' ','.' ELSE WRITE (Nio,9000)' ','trend','less than zero','.',' ','.' WRITE (Mt2,9000)' ','trend','less than zero','.',' ','.' END IF endif CALL abend() RETURN 9000 FORMAT(/,a,'The innovation variance of the ',a,' is ',a,',',/, & ' an indication that the model is not suitable for ', & 'signal extraction',a,/, & a,'Examine the arima model used for this ', & 'decomposition for possible unit roots,',/, & ' and try another model',a) END IF end if c resume here at difference number 97 if (npsi .ne. 1) then if (HTML .eq. 1) then write(nio,'("

    SEASONAL

    ")') write(nio,'(''
    SEAS. '', $ ''NUMERATOR (MOVING AVERAGE '', $ ''POL.)
    '')') call WrTabHtmPol2(thets,nthets,12,nio,33) write(nio,'(''
    SEAS. '', $ ''DENOMINATOR (AUTOREGRESSIVE '', $ ''POL.)
    '')') call WrTabHtmPol2(psi,npsi,12,nio,34) write (Nio,'("

    INNOV. VAR. (*) ",f12.6, $ "

    ")')varwns else 7043 format (///,' SEAS. NUMERATOR (MOVING AVERAGE POL.)') write (Nio,7043) write (Nio,7053) (thets(i), i = 1,nthets) 7044 format (' SEAS. DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7044) write (Nio,7053) (psi(i), i = 1,npsi) write (Nio,7042) varwns endif C LINES OF CODE ADDED FOR X-13A-S : 5 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000 CALL USRENTRY(THETS,1,NTHETS,2004) CALL USRENTRY(PSI,1,NPSI,2005) dvec(1)=Varwns call USRENTRY(dvec,1,1,2006) C END OF CODE BLOCK IF(Varwns.gt.ONE.or.Varwns.lt.ZERO)THEN if (HTML .eq. 1) then write (Nio,'("
    (*) IN UNITS OF VAR(A)")') write (Nio,'("

    ")') IF(varwnp.gt.ONE)THEN WRITE (Nio,9000)'

    ','seasonal','greater than one','.

    ', & '

    ','.

    ' WRITE (Mt2,9000)'

    ','seasonal','greater than one','.

    ', & '

    ','.

    ' ELSE WRITE (Nio,9000)'

    ','seasonal','less than zero','.

    ', & '

    ','.

    ' WRITE (Mt2,9000)'

    ','seasonal','less than zero','.

    ', & '

    ','.

    ' END IF else write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') IF(Varwns.gt.ONE)THEN WRITE (Nio,9000)'seasonal','greater than one' WRITE (Mt2,9000)'seasonal','greater than one' ELSE WRITE (Nio,9000)'seasonal','less than zero' WRITE (Mt2,9000)'seasonal','less than zero' END IF endif Lfatal=.true. RETURN END IF end if if (ncycth.ne.0 .or. ncyc.ne.1) then if (HTML .eq. 1) then write(nio,'("

    TRANSITORY

    ")') write(nio,'(''
    TRANSITORY NUMERATOR (MOVING AVERAGE '', $ ''POL.)
    '')') call WrTabHtmPol2(thetc,nthetc,12,nio,35) write(nio,'(''
    TRANSITORY DENOMINATOR (AUTOREGRESSIVE'', $ '' POL.)
    '')') call WrTabHtmPol2(cyc,ncyc,12,nio,36) write (Nio,'("

    INNOV. VAR. (*) ", $ f12.6,"

    ")') varwnc else 7045 format (///,' TRANSITORY NUMERATOR (MOVING AVERAGE POL.)') write (Nio,7045) write (Nio,7053) (thetc(i), i = 1,nthetc) 7046 format (' TRANSITORY DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7046) write (Nio,7053) (cyc(i), i = 1,ncyc) write (Nio,7042) varwnc endif C LINES OF CODE ADDED FOR X-13A-S : 5 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000 CALL USRENTRY(THETC,1,NTHETC,2007) CALL USRENTRY(CYC,1,NCYC,2008) dvec(1)=Varwnc call USRENTRY(dvec,1,1,2009) C END OF CODE BLOCK IF(Varwnc.gt.ONE.or.Varwnc.lt.ZERO)THEN if (HTML .eq. 1) then write (Nio,'("
    (*) IN UNITS OF VAR(A)")') write (Nio,'("

    ")') IF(varwnp.gt.ONE)THEN WRITE (Nio,9000)'

    ','transitory','greater than one', & '.

    ','

    ','.

    ' WRITE (Mt2,9000)'

    ','transitory','greater than one', & '.

    ','

    ','.

    ' ELSE WRITE (Nio,9000)'

    ','transitory','less than zero','.

    ', & '

    ','.

    ' WRITE (Mt2,9000)'

    ','transitory','less than zero','.

    ', & '

    ','.

    ' END IF else write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') IF(Varwnc.gt.ONE)THEN WRITE (Nio,9000)'transitory','greater than one' WRITE (Mt2,9000)'transitory','greater than one' ELSE WRITE (Nio,9000)'transitory','less than zero' WRITE (Mt2,9000)'transitory','less than zero' END IF endif Lfatal=.true. RETURN END IF end if c if (smtr .ne. 1) then if (HTML .eq. 1) then write (Nio,'("

    IRREGULAR

    ")') write (Nio,'(''

    VAR.'', $ '' (*) '',f12.6,''

    '')') qt1 else 7047 format (///,' IRREGULAR') write (Nio,7047) 7048 format (' VAR. (*) ',f12.5) write (Nio,7048) qt1 endif C LINES OF CODE ADDED FOR X-13A-S : 1 dvec(1)=qt1 call USRENTRY(dvec,1,1,2010) C END OF CODE BLOCK c end if if (HTML .eq. 1) then write(nio,'("

    SEASONALLY ADJUSTED

    ")') write(nio,'(''
    SEASONALLY ADJUSTED NUMERATOR (MOVING '', $ ''AVERAGE POL.)
    '')') call WrTabHtmPol2(thadj,nthadj,12,nio,37) write(nio,'(''
    SEASONALLY ADJUSTED DENOMINATOR (AUTO'', $ ''REGRESSIVE POL.)
    '')') call WrTabHtmPol2(chcyc,nchcyc,12,nio,38) write (Nio,'(''

    INNOV. VAR. (*) '',f12.6, $ ''

    '')') varwna write (Nio,'(''

    (*) IN UNITS OF VAR(A)'', $ ''

    '')') else 7049 format ( $ ///,' SEASONALLY ADJUSTED NUMERATOR ','(MOVING AVERAGE POL.)') write (Nio,7049) write (Nio,7053) (thadj(i), i = 1,nthadj) 7050 format ( $ /,' SEASONALLY ADJUSTED DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7050) write (Nio,7053) (chcyc(i), i = 1,nchcyc) 7053 format (12f11.5) write (Nio,7042) varwna endif C LINES OF CODE ADDED FOR X-13A-S : 5 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000 CALL USRENTRY(THADJ,1,NTHADJ,2011) CALL USRENTRY(CHCYC,1,NCHCYC,2012) dvec(1)=Varwna call USRENTRY(dvec,1,1,2013) C END OF CODE BLOCK C C IF(Varwna.gt.ONE.or.Varwna.lt.ZERO)THEN if (HTML .eq. 1) then write (Nio,'("
    (*) IN UNITS OF VAR(A)")') write (Nio,'("

    ")') IF(varwnp.gt.ONE)THEN WRITE (Nio,9000)'

    ','seasonal adjustment', & 'greater than one','.

    ','

    ','.

    ' WRITE (Mt2,9000)'

    ','seasonal adjustment', & 'greater than one','.

    ','

    ','.

    ' ELSE WRITE (Nio,9000)'

    ','seasonal adjustment','less than zero', & '.

    ','

    ','.

    ' WRITE (Mt2,9000)'

    ','seasonal adjustment','less than zero', & '.

    ','

    ','.

    ' END IF else write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') IF(Varwna.gt.ONE)THEN WRITE (Nio,9000)'seasonal adjustment','greater than one' WRITE (Mt2,9000)'seasonal adjustment','greater than one' ELSE WRITE (Nio,9000)'seasonal adjustment','less than zero' WRITE (Mt2,9000)'seasonal adjustment','less than zero' END IF end if Lfatal=.true. RETURN END IF if (HTML .eq. 1) then write (Nio,'(''

    (*) IN UNITS OF VAR(A)'')') else write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') end if end if end cc c cc subroutine MAspectrum(Noprint,HTML,nidx,nio,buff2, $ chi,nchi,utf,nut,thetp,nthetp,varwnp, $ npsi,vf,ns,thets,nthets,varwns, $ cyc,ncyc,ncycth,ucf,nuc,thetc,nthetc,varwnc, $ chcyc,nchcyc,thstar,qstar,thadj,nthadj,varwna, $ us,nus,qt1) implicit none c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'error.cmn' c----------------------------------------------------------------------- c INPUT PARAMETERS integer Noprint,HTML,nidx,nio,nchi,nut,npsi,ns, $ ncyc,ncycth,nuc,nchcyc,qstar real*8 chi(8),utf(8),vf(27),cyc(5),ucf(32),chcyc(8),thstar(27), $ qt1 c OUTPUT PARAMETERS integer nthetp,nthets,nthetc,nthadj,nus real*8 thetp(8),varwnp,thets(27),varwns,dvec(1), $ thetc(32),varwnc,thadj(32),varwna,us(50) character buff2*80,caption0*(60) c LOCAL PARAMETERS real*8 toterrP,toterrS,toterrC,toterrSA,Dum(80),Vn(80) integer nounit,nDum,nVn,i C **** TREND **** C varwnp = ZERO caption0=' ' if (noprint.ne.1) then if (HTML .eq. 1) then call AddIdx(Nidx,Nio,'Factorization of MA Polyn.','0027',0,27) write (Nio,'("

    FACTORIZATION OF THE", $ " MA POLYN. FOR THE COMPONENTS

    ")') else write (Nio, $'(///,''FACTORIZATION OF THE MA POLYN. FOR THE COMPONENTS'',/, $''-------------------------------------------------'')') end if end if nounit = 0 if (nchi .ne. 1) then caption0(1:23)='MA ROOTS OF TREND-CYCLE' call MAK1(utf,Nut,thetp,nthetp,varwnp,nounit,Noprint, $ caption0,23,toterrP) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrP call USRENTRY(dvec,1,1,1900) if (noprint.ne.1) then if (toterrP .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if endif end if C varwns = ZERO if (npsi .ne. 1) then C C **** SEAS. **** C caption0(1:20)='MA ROOTS OF SEASONAL' call MAK1(vf,Ns,thets,nthets,varwns,nounit,noprint, $ caption0,20,toterrS) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrS call USRENTRY(dvec,1,1,1901) if (noprint.ne.1) then if (toterrS .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if endif end if C varwnc = ZERO if (ncycth.ne.0 .or. ncyc.ne.1) then C C **** CYCLE **** C caption0(1:22)="MA ROOTS OF TRANSITORY" call MAK1(ucf,Nuc,thetc,nthetc,varwnc,nounit,noprint, $ caption0,22,toterrC) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrC call USRENTRY(dvec,1,1,1902) if (noprint.ne.1) then if (toterrC .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if endif end if C varwna = ZERO if (nchcyc.ne.1 .or. ncycth.ne.0) then if (npsi .eq. 1) then do i = 1,qstar thadj(i) = thstar(i) end do do i = qstar+1,nchcyc thadj(i) = ZERO end do c nthadj = MAX(qstar,nchcyc) nthadj=qstar varwna = ONE else C C C FIND MA REPRESENTATION OF SEASONALLY ADJUSTED SERIES C call CONJ(chcyc,nchcyc,chcyc,nchcyc,us,nus) do i = 1,nus us(i) = us(i) * qt1 end do do i=nus+1,50 us(i)=0 end do C if (nchi .ne. 1) then call CONV(thetp,nthetp,cyc,ncyc,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) do i = 1,Ndum us(i) = us(i) + varwnp*Dum(i) end do nus = MAX(nus,Ndum) end if if (ncycth.ne.0 .or. ncyc.ne.1) then call CONV(thetc,nthetc,chi,nchi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) do i = 1,Ndum us(i) = us(i) + varwnc*Dum(i) end do nus = MAX(nus,Ndum) end if caption0(1:38)="MA ROOTS OF SEASONALLY ADJUSTED SERIES" call MAK1(us,nus,thadj,nthadj,varwna,nounit,noprint, $ caption0,38,toterrSA) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrSA call USRENTRY(dvec,1,1,1903) if (noprint.ne.1) then if (toterrSA .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if end if endif endif end cc c cc subroutine PLOTOrigSpectrum(p,d,q,bp,bd,bq,mq,Th,Phi,BTh,BPhi) implicit none c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- integer n1,n12,lspect,d,bd parameter (n12 = 12, n1 = 1,Lspect=300) c parametros formales integer p,q,bp,bq,mq real*8 PHI(3*N1),TH(3*N1),BPHI(3*N1),BTH(3*N1),Output(Lspect) c locales real*8 PHIST(2*N12+5),THSTAR(2*N12+3*N1),polDifs(2*N12+3*N1), $ polAR(2*N12+3*N1),fMA(32),fAR(32) integer i,j,k,grPhist,grThstar,fMAdim,fARdim,grpolAR,grPolDifs character fname*30,subtitle*50 cc grpolAR = P + Bp*Mq+1 grthstar = Q + Bq*Mq+1 do i = 2,2*N12+3*N1 polAR(i) = ZERO end do polAR(1) = ONE if (P .ne. 0) then do i = 1,P polAR(i+1) = -Phi(i) end do end if if (Bp .ne. 0) then do i = 1,Bp j = i * Mq+1 polAR(j) = -Bphi(i) if (P .ne. 0) then do k = 1,P polAR(k+j) = Phi(k)*Bphi(i) end do end if end do end if c Los delta (1-B)^d c grPolDifs=bd*mq+d+1 polDifs(1)=1 do i = 2,2*N12+3*N1 polDifs(i) = ZERO end do if (d.eq.0) then if (bd.eq.1) then poldifs(mq+1)=-1 end if else if(d.eq.1) then polDifs(2)=-1 if (bd.ne.0) then polDifs(mq+1)=-1 polDifs(mq+2)=1 end if elseif (d.eq.2) then polDifs(2)=-2 polDifs(3)=1 if (bd.ne.0) then polDifs(mq+1)=polDifs(mq+1)-1 polDifs(mq+2)=2 polDifs(mq+3)=-1 end if end if do i = 1,2*N12+5 phist(i)=0 end do call CONV(polAR,grpolAR,polDifs,grPolDifs,phist,grPhist) thstar(1)=ONE do i = 2,2*N12+3*N1 Thstar(i) = ZERO end do if (Q .ne. 0) then do i = 1,Q Thstar(i+1) = -Th(i) end do end if if (Bq .ne. 0) then do i = 1,Bq j = i * Mq+1 Thstar(j) = -Bth(i) if (Q .ne. 0) then do k = 1,Q Thstar(k+j) = Th(k)*Bth(i) end do end if end do end if c prueba call CONJ(thstar,grthstar,thstar,grthstar,fMA,fMAdim) call CONJ(phist,grPhist,phist,grPhist,fAR,fARdim) call SPC(fMA,fMAdim,fAR,fARdim,1.d0,Output) c generamos el fichero CUNX#ifdef DOS !DEC$ IF DEFINED (DOS) fname='SPECT.T3' CUNX#endif !DEC$ ENDIF CUNX#ifdef TSW !DEC$ IF DEFINED (TSW) fname='MODEL\SPECT.T3' CUNX#endif !DEC$ ENDIF subtitle='SPECTRUM MODEL SERIES' call PlotSpectrum(fname,subtitle,Output,dble(Lspect),mq,1.5d0,1) end cc c cc logical function SeasSpectCrit(pico,mq) integer mq character pico(7)*2 c local integer i,ipicos,idoble ipicos=0 idoble=0 if (mq.eq.4) then do i=1,2 if ((pico(i).ne.'--').and.(pico(i).ne.'nc')) then ipicos=ipicos+1 end if end do if (pico(1).eq.'AT') then SeasSpectCrit=.true. else if (ipicos.eq.2) then SeasSpectCrit=.true. else SeasSpectCrit=.false. end if else do i=1,5 if (pico(i).eq.'AT') then idoble=idoble+1 ipicos=ipicos+1 else if ((pico(i).eq.'--').or.(pico(i).eq.'nc')) then c instruccion "dummy" idoble=idoble else ipicos=ipicos+1 end if end do SELECT CASE (ipicos) CASE (3,4,5) SeasSpectCrit=.true. CASE (2) if (ipicos.ge.1) then SeasSpectCrit=.true. else if (pico(6).eq.'AT') then SeasSpectCrit=.true. else SeasSpectCrit=.false. end if CASE (1) if ((idoble.eq.1).and.(pico(6).eq.'AT')) then SeasSpectCrit=.true. else SeasSpectCrit=.false. end if CASE DEFAULT SeasSpectCrit=.false. END SELECT end if end cc c cc logical function TDSpectCrit(pico) implicit none character pico(7)*2 if (pico(7).eq.'AT') then TDSpectCrit=.true. else TDSpectCrit=.false. end if end c c c integer function testseas(nz,aux,mq,picos) implicit none integer mp,kp parameter (kp = 65, mp = 600) real*8 aux(mp+kp) character picos(7)*2 integer nz,mq c variables locales real*8 qs,snp c funciones llamadas logical SeasSpectCrit real*8 calcQS,kendalls external SeasSpectCrit,calcQS,kendalls c QS=calcQS(aux,nz,mq) c write (16,*) 'qs=',qs SNP=kendalls(aux,nz,mq) c write (16,*) 'SNP',snp if (QS.gt.9.21d0) then testseas=1 else if (SNP.gt.24.73d0.and.mq.eq.12.or. $ SNP.gt.11.35d0.and.mq.eq.4) then testseas=1 else if (qs.gt.6 .and. (SNP.gt.19.7d0.and.mq.eq.12.or. $ SNP.gt.7.82d0.and.mq.eq.4)) then testseas=1 else if (seasSpectCrit(picos,mq)) then testseas=1 else testseas=0 end if return end cc c cc integer function ResidualSeasTest(crQS,crSNP,crpicos,nz,sa,picSA, $ mq,html,imprimir,nio,nidx) implicit none C.. Parameters .. integer mp,kp parameter (kp = 65, mp = 600) integer mq,nz,html,imprimir,nio,nidx character picSA(7)*2 real*8 sa(mp+kp/2) c c variables locales real*8 aux(mp+kp),QS,SNP integer i,k,OverTest,crQs,crSNP,crpicos c funciones llamadas logical SeasSpectCrit real*8 calcQS,kendalls external SeasSpectCrit,calcQS,kendalls c k=nz-1 OverTest=0 do i=1,k aux(i)=sa(i+1)-sa(i) end do * QS=calcQS(aux,nz,mq) * SNP=kendalls(aux,nz,mq) QS=calcQS(aux,k,mq) SNP=kendalls(aux,k,mq) if (QS.gt.9.21d0) then OverTest=OverTest+1 crQs=1 else crQS=0 end if if (SNP.gt.24.73d0.and.mq.eq.12.or. $ SNP.gt.11.35d0.and.mq.eq.4) then OverTest=OverTest+1 crSNP=1 else crSNP=0 end if if (seasSpectCrit(picSA,mq)) then OverTest=OverTest+1 crpicos=1 else crpicos=0 end if if (imprimir.gt.0) then call WrResidSeasTest(OverTest,crQs,crSNP,crpicos,html,nio,nidx) end if ResidualSeasTest=OverTest return end cc c cc subroutine WrResidSeasTest(OST,crQs,crSNP,crPeaks,html,nio,nidx) implicit none integer OST,crQs,crSNP,crPeaks,html,nio,nidx c character spicos*3,sqs*3,sSNP*3 c if (crQS.eq.1) then sQs='YES' else sQS='NO ' end if if (crSNP.eq.1) then sSNP='YES' else sSNP='NO ' end if if (crPeaks.eq.1) then spicos='YES' else spicos='NO ' end if if (html.eq.1) then write(nio,*) '

    OVERALL TEST FOR RESIDUAL SEASONALITY

    ' write(nio,'('''')') write(nio,'('''')') sQs write(nio,'('''')') sSNP write(nio,'(''
    AUTOCORRELATION FUNCTION '', $ ''EVIDENCE'',A3,''
    NON-PARAMETRIC EVIDENCE '', $ '''',A3,''
    SPECTRAL EVIDENCE '', $ '''',A3,''
    '')') sPicos If (OST.gt.1) then write(nio,'(''

    RESIDUAL SEASONALITY DETECTED IN '', $ ''SEASONALLY ADJUSTED SERIES

    '')') else write(nio,'(''

    NO RESIDUAL SEASONALITY DETECTED IN '', $ ''SEASONALLY ADJUSTED SERIES

    '')') end if else write(nio,*) write(nio,*) write(nio,'("Overall test for residual seasonality ")') write(nio,*) write(nio,*) write(nio,'('' Autocorrelation function evidence : '',A3)') sQs write(nio,'('' Non-paranetric evidence'',11x,'': '',A3)') sSNP write(nio,'('' Spectral evidence'',17x,'': '',A3)') sPicos write(nio,*) If (OST .gt.1) then write(nio,'('' Residual seasonality detected in '', $ ''seasonally adjusted series'')') else write(nio,'('' No residual seasonality detected in '', $ ''seasonally adjusted series'')') end if end if end C C C THIS SUBROUTINE CALCULATES C,THE SUM OF D1*A(Z) AND D2*B(Z) C C INPUT PARAMETER C A : FIRST POLYNOMIAL (true signs) A(1) + A(2)*COS(W) + ... + C A(MPLUS1)*COS((MPLUS1-1)*W) C MPLUS1 : DIMENSION OF A C B : SECOND POLYNOMIAL (true signs) " " " " C NPLUS1 : DIMENSION OF B C C : SUM OF A + B (true signs) " " " " C LPLUS1 : DIMENSION OF C C C This subroutine added by REG on 12/22/2005 C subroutine ADDJ(a,mplus1,d1,b,nplus1,d2,c,lplus1) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Maybe Written if c=a or c=b real*8 a(*), b(*) C.. In/Out Status: Read, Maybe Written if lplus1=mplus1 or lplus1=nplus1 integer mplus1, nplus1 C.. In/Out Status: Maybe Read if c=a or c=b, Written .. real*8 c(*) C.. In/Out Status: Not Read, Overwritten .. integer lplus1 C.. In/Out Status: Read .. real*8 d1, d2 C C.. Local Scalars .. integer i,j,k,num C C.. Intrinsic Functions .. intrinsic MAX, MIN C C ... Executable Statements ... C C Add the common part of the polynomials if (min(mplus1,nplus1) .gt. 0) then do i=1,min(mplus1,nplus1) c(i) = d1*a(i)+d2*b(i) end do end if C C For degree of A > degree of B if (mplus1 .gt. nplus1) then do i=nplus1+1,mplus1 c(i)=d1*a(i) end do C C For degree of A V degree of B else if (mplus1 .lt. nplus1) then do i=mplus1+1,nplus1 c(i)=d2*b(i) end do end if C C Set length=degree+1 of C lplus1=max(mplus1,nplus1) return end spectrum.f0000664006604000003110000032065214521201571012210 0ustar sun00315stepsc change variable name test to test2 to avoid conflit with common c block name test in test.i --Mar. 2021 C previous change: REG 22 Dec 2005 C Previous change: BCM 16 May 2003 4:26 pm C THIS SUBROUTINE COMPUTES THE HARMONIC FUNCTIONS FOR THE COMPONENTS, C THE FILTER DENOMINATORS, THE NUMERATOR OF THE COMPONENT MODELS C AND THEIR INNOVATION VARIANCES : C C CT : trend filter C CS : seasonal filter C CC : cycle filter C C C SET UP FACTORS OF SPECTRUM C THE PARAMETER "PRFRA" HAS BEEN DELETED C C ***************HARMONIC FUNCTIONS***************** C C FF = THSTAR X THSTAR = MOVING AVERAGE C C FT = CHI X CHI = TREND C FC = CYC X CYC = CYCLE C FS = PSI X PSI = SEASONAL C FN = FT * FC = CYCLE-TREND (NONSEASONAL) C FH = FN * FS = TOTAL DENOMINATOR C C INPUT PARAMETERS C NOADMISS : TO APPROXIMATE THE MODEL IF IRREGULAR SPECTRUM IS C NEGATIVE. 1 APPROXXIMATION, O NO APPROXIMATION C THSTAR : NUMERATOR OF THE MODEL C QSTAR : DIMENSION OF THSTAR C CHI : DENOMINATOR OF TREND MODEL C NCHI : DIMENSION OF CHI C CYC : DENOMINATOR OF CYCLE MODEL C NCYC : DIMENSION OF CYC C PSI : DENOMINATOR OF SEASONAL MODEL C NPSI : DIMENSION OF PSI C CHCYC : DENOMINATOR OF TREND*CYCLE MODEL C NCHCYC : DIMENSION OF CHCYC C PSCYC : DENOMINATOR OF SEASONAL*CYCLE MODEL (ADDED DEKM 6 Feb 2003) C NPSCYC : DIMENSION OF PSCYC C CHPSI : DENOMINATOR OF TREND*SEASONAL MODEL (ADDED DEKM 20 Feb 2003) C NCHPSI : DIMENSION OF CHPSI C PSTAR : DIMENSION OF THE MODEL DENOMINATOR C MQ : FREQUENCY C TITLE : NAME OF THE SERIES C HS : HEIGH OF SPECTRUM (FOR GRAPHS) C BD : DELTA^MQ DIMENSION C D : DELTA DIMENSION C CT : TREND DENOMINATOR FILTER (OUTPUT) C CS : SEASONAL DENOMINATOR FILTER (OUTPUT) C CC : CYCLE DENOMINATOR FILTER (OUTPUT) C QT1 : SPECTRUM OF IRREGULAR (VARIANCE) (OUTPUT) C SQG : STANDARD ERROR OF RESIDUALS C OUT : TO CONTROL THE PRINTOUT C WVARA : ****** NOT USED ****** C THETP : NUMERATOR OF TREND MODEL (OUTPUT) C NTHETP : DIMENSION OF THETP (OUTPUT) C THETS : NUMERATOR OF SEASONAL MODEL (OUTPUT) C NTHETS : DIMENSION OF THETS (OUTPUT) C THETC : NUMERATOR OF CYCLE MODEL (OUTPUT) C NTHETC : DIMENSION OF THETC (OUTPUT) C THADJ : NUMERATOR OF SEASONALLY ADJUSTED MODEL (OUTPUT) C NTHADJ : DIMENSION OF THADJ (OUTPUT) C THTHA : NUMERATOR OF TREND ADJUSTED MODEL (OUTPUT) (ADDED by DEKM FEB 6 2003) C NTHTHA : DIMENSION OF THTHA (OUTPUT) C THCYA : NUMERATOR OF CYCLE ADJUSTED MODEL (OUTPUT) (ADDED by DEKM FEB 20 2003) C NTHCYA : DIMENSION OF THCYA (OUTPUT) C VARWNP : INNOVATIONS VARIANCE OF TREND (OUTPUT) C VARWNS : INNOVATIONS VARIANCE OF SEASONAL (OUTPUT) C VARWNC : INNOVATIONS VARIANCE OF CYCLE (OUTPUT) C VARWNA : INNOVATIONS VARIANCE OF SEASONALLY ADJUSTED (OUTPUT) C VARWNT : INNOVATIONS VARIANCE OF TREND ADJUSTED (OUTPUT) (ADDED by DEKM FEB 6 2003) C VARWCA : INNOVATIONS VARIANCE OF CYCLE ADJUSTED (OUTPUT) (ADDED by DEKM FEB 20 2003) C C C SUBROUTINE SPECTRUM(NOADMISS,THSTAR,QSTAR,CHI,NCHI,CYC, C $NCYC,PSI,NPSI,CHCYC,NCHCYC,PSTAR,MQ,TITLE,HS,BD, C $D,CT,CS,CC,QT1,SQG,PG,OUT,WVARA,NCYCTH, C $ THETP,NTHETP,THETS,NTHETS,THETC,NTHETC,THADJ,NTHADJ, C $ VARWNP,VARWNS,VARWNC,VARWNA,BUFF2,SMTR,HAR,*) subroutine SPECTRUM(noadmiss,OutNA,thstar,qstar, $ chi,nchi,cyc,ncyc,psi,npsi, $ chcyc,nchcyc,pscyc,npscyc,chpsi,nchpsi, C added arguments pscyc, npscyc (seasonal-cycle denominator and dimension), C ththa, nththa (trend adjusted numerator and it's dimension), C varwnt (innovations variance for trend adjusted component) C DEKM 6 Feb 2003 C added arguments chpsi, nchpsi (trend-seasonal denominator and dimension), C thcya, nthcya (cycle adjusted numerator and it's dimension), C varwca (innovations variance for cycle adjusted component) C DEKM 20 Feb 2003 C $ pstar,mq,bd,d,ct,cs,cc,qt1, $ sqg,pg,out,ncycth,thetp,nthetp,thets,nthets,thetc, $ nthetc,thadj,nthadj,thtra, nthtra,thcya,nthcya, $ varwnp,varwns, $ varwnc,varwna,varwnt,varwca, $ buff2,har,chis,nchis,psis,npsis,cycs,ncycs, $ adjs,nadjs,noserie,iter,sqf, c Para OutSeats $ IOUT,Ndevice, $ printBack,back,sr,SQSTAT,SDF,SSE,mAuto,nfreq, $ n_1,n0,tvalRUNS, $ Qstat,DF,Pstat1,spstat1, $ wnormtes,wsk,skewne,test1,wkk,rkurt,test2,r,SEa, $ Resid,flagTstu,it,iper,iyear, $ rmean,rstd,DW,KEN,RTVAL,SumSres,F_seats,Nyer1,Nper1, $ Pstar_seats,Qstar_seats, c Para OutDenC $ Titleg,init, $ p,q,bp,bq,theta,nTh,Btheta,nBth, $ phi,nPhi,Bphi,nBphi, $ Chins, $ Cycns, $ Psins, $ Adjns, $ Totden,nTot,InputModel, c Para OutPar.m $ niter,mattitle,Lgraf, c Para indicar raices reales $ root0c,rootPIc,rootPIs,isUgly, $ IsCloseToTD, c Para OutPart2 $ ImeanOut,Wdif,WdifCen,nwDif,WmDifXL,VdifXL, $ QstatXL,rXL,seRxl,partACF,sePartACF,model, $ PicosXL,tstmean,Wm,seMean,nx,Cmatrix, $ sePHI,seTH,seBPHI,seBTH,ph,TH,bph, $ MArez,MAimz,MAmodul,MAar,MApr, $ rez,imz,modul,ar,pr, * $ Z,nz,Lam,Itab,IID,Nper,Nyer,Zvar,M,BTH, $ Z,nz,ILam,Nper,Nyer,Zvar,M,BTH, c Para OutSearch $ ItnSearch,IfnSearch,nxSearch,Esearch, $ FIsearch,xSearch,status,NAfijado,tramo,Lsgud,*) C C.. Implicits .. implicit none integer n10,n12,n1 parameter(n1=1,n10=10,n12=12) c----------------------------------------------------------------------- c add include files to define print and save logical vectors, pointer c variables BCM May 2003 c----------------------------------------------------------------------- INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' include 'seattb.i' INCLUDE 'srslen.prm' include 'dimensions.i' include 'stream.i' include 'stdio.i' c----------------------------------------------------------------------- c add include file to allow program to print error message to c error file BCM Oct 2005 c----------------------------------------------------------------------- INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- real*8 ONE,ZERO parameter(ONE=1D0,ZERO=0D0) c INPUT PARAMETERS OUTSEATS logical printBack,root0c,rootPIc,rootPIs,IsCloseToTD integer IOUT,mAuto,DF,SDF real*8 resid(MPKp),back(MpKp),Qstat,Pstat1,spstat1 real*8 sr(50),SQstat,SSE(50),tvalRUNS integer n_1,n0,tramo real*8 wnormtes,wsk,skewne,test1,wkk,rkurt,test2,r(50),SEa(50) integer flagTstu,NDEVICE,IPER,IYEAR,it,Nper1,nYer1 integer Pstar_seats,Qstar_seats,nfreq real*8 Rmean,Rstd,DW,KEN,RTVAL,F_seats,SumSres c INPUT PARAMETERS OUTDENC integer init,p,q,bp,bq,nTh,nBth, $ nPhi,nBphi,nTot character Titleg*80 real*8 theta(4),Btheta(25),phi(4),Bphi(13), $ Chins(8), $ Cycns(5),Psins(27), $ Adjns(8),Totden(40) c InPUT OutPar.m character mattitle*180 integer niter character status c INPUT/OUTPUT PARAMETERS integer InputModel c c INPUT/OUTPUT PARAMETER OutPart2 c INPUT integer ImeanOut,nwDif,model real*8 Wdif(*),WdifCen(*),WmDifXL,VdifXL real*8 QstatXL,rXL(5*n10),seRxl(5*n10),partACF(5*n10),sePartACF character PicosXL(7)*2 integer tstmean,nx real*8 Wm,seMean,Cmatrix(n10,n10), $ sePHI(n10),seTH(n10),seBPHI(n10),seBTH(n10), $ MArez(5*n12+n12/3),MAimz(5*n12+n12/3),MAmodul(5*n12+n12/3), $ MAar(5*n12+n12/3),MApr(5*n12+n12/3), $ TH(3*n1),pH(3*n1),bph(3*n1) real*8 rez(5*n12+n12/3),imz(5*n12+n12/3),modul(5*n12+n12/3), $ ar(5*n12+n12/3),pr(5*n12+n12/3),Z(*),Zvar,BTH(3*n1) integer nz,ILam,Nper,Nyer,M real*8 tmp logical Lsgud C INPUT PARAMETER OutSearch integer ItnSearch,IfnSearch,nxSearch,Esearch(n10) real*8 FIsearch,xSearch(n10) c OUTPUT * integer Itab,IID c OUTPUT PARAMETERS logical isUgly C C.. Formal Arguments .. integer noadmiss,OUTna,qstar,nchi,ncyc,npsi,nchcyc,pstar,mq,bd,d, $ sqg,pg,out,ncycth,nthetp,nthets,nthetc,nthadj,npscyc, $ nthtra,har,nchpsi,nthcya,nchis, $ npsis,ncycs,nadjs,noserie,iter,NAfijado C added arguments npscyc, nthtra DEKM Feb 6, 2003 C added arguments nchpsi, nthcya DEKM Feb 20, 2003 character buff2*80 real*8 thstar(maxTh),chi(8),cyc(17),psi(27),chcyc(20),ct(32), $ cs(32),cc(32),qt1,thetp(8),thets(27),thetc(32),thadj(32), $ varwnp,varwns,varwnc,varwna,chis(17),psis(16),cycs(17), $ adjs(17),sqf, C adding variables (DEKM Feb 6, 2003) $ pscyc(32), varwnt, thtra(32), C adding variables (DEKM Feb 20, 2003) $ chpsi(32), varwca, thcya(32) LOGICAL Lgraf C C.. Local Scalars .. integer nn,nus,nvn,NoDecompOut,NAiter c character fname*30,subtitle*50 c character auxS*350 c real*8 arg,x real*8 enoc,enot,estar, $ qmin cc c (Roberto Lopez: 01/2006. c OUTPUT'S of MinimGrid) cc integer doMinimGrid parameter (doMinimGrid = 1) C C.. Local Arrays .. real*8 fn(50),us(50),vn(80) c $ ,utf(8),y(300) character linePol*(MaxLineLength),strPol*(MaxStrlength) cc c Used for the new Model Approx. cc real*8 Res(MpKp),thstar1(maxTh),rt(32),qt(32),dvec(1) integer Na,i,nrt,nqt logical isVa0,svudg cc c cc C C.. External Functions .. real*8 FUNC0,getSdt,getSds,getSdc,getSdi,getSdsa external FUNC0,getSdt,getSds,getSdc,getSdi,getSdsa integer ISTRLEN,KnownApprox external ISTRLEN,KnownApprox C C.. External Calls .. external CONJ, CONV, DIVFCN, MAK1, MINIM, MULTFN, PARFRA, $ SPCEST, USRENTRY, $ GLOBALMINIM, MINIMGRID C C.. Intrinsic Functions .. intrinsic ABS, INT, MAX, MIN include 'func.i' include 'func2.i' include 'func3.i' include 'func4.i' include 'func5.i' include 'hspect.i' include 'min.i' include 'test.i' include 'buffers.i' include 'spectra.i' include 'dirs.i' include 'strmodel.i' include 'polynom.i' include 'hiddn.cmn' C c OUTna=0 CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Pre Spectrum') !DEC$ ENDIF CUNX#endif svudg=.false. IF(Lsumm.gt.0)svudg=.true. isUgly=.false. isVa0=.false. do i=1,qstar thstar1(i)=thstar(i) enddo * call profiler(3,'Pre SPECTRU') call SPECTRU(thstar,qstar,chi,nchi,cyc,ncyc,psi, $ npsi,pstar,mq,bd,d, $ qt1,out,ncycth, $ har, $ Fn,NN,estar,enot,enoc,Us,nUS,Vn,nVn, $ root0c,rootPIc,rootPIs,isUgly) cc c New experimental Model Approximation cc cc Chequeamos si es uno de los modelos con region de admisibilidad conocida cc en cuyo caso fijamos los coeficientes. IF(Lsgud) $ call showFirstNA(nio,InputModel,p,d,q,bp,bd,bq,theta, $ Btheta,nbth,phi,Bphi,nbphi,imeanout,tramo) if ((qt1 .lt. 0.0d0).and.(noadmiss.ne.0)) then NAfijado=KnownApprox(p,q,d,bd,bp,bq,init,noadmiss, $ th,bth,ph,bph,mq,status) end if if (Noadmiss.eq.-1 .and. qt1.ge.0.0d0)then dvec(1)=1.0d0 call USRENTRY(dvec,1,1,1,1,1019) else if (((qt1 .lt. 0.0d0) .and. (isUgly)).and. $ (Noadmiss.eq.-1)) then if (NAfijado.eq.0) then if (out .eq. 0) then 7151 format (////, $ ' DECOMPOSITION INVALID,SOME SPECTRUM NEGATIVE'//, $ 10x,'*****************************',/,12x, $ 'THE MODEL IS APPROXIMATED',/,10x, $ '*****************************',/) write (Nio,7151) write (Mt2,7151) 7008 format (/,1x, $ '***********************************************', $ '*********************',/,1x, $ 'NUMERATOR OF THE MODEL IS NEW-APPROXIMATED AND THE ', $ 'RESIDUALS RE-COMPUTED',/,1x, $ '***********************************************', $ '*********************') write (Nio,7008) write (Mt2,7008) end if call CONJ(thstar,qstar,thstar,qstar,Ff,Nf) call CONJ(Totden,Pstar,Totden,Pstar,Fh,Nh) do i=nf+1,nh Ff(i)=0.0d0 enddo do i = 1,Nh Ff(i) = Ff(i) + (1.0d-9 -qt1)*Fh(i) end do * call profiler(3,'Pre MAK1') call MAK1 (Ff,max(nf,nh),Thstar,Qstar,qt1,nio,0, $ "APPROXIMATED MODEL MA ", $ 21,tmp) q=qstar-1 bq=0 call setNmq(q) call setNmbq(bq) isVa0=.true. write(nio,'(///,"MA APPROXIMATE MODEL")') call strPolyn('B ',THstar,Qstar,1.0D-6,strPol,LinePol) call AppendLine(strPol,linePol) write(nio,'(A,///)') strPol(1:istrlen(strPol)) * call profiler(3,'Pre CALCRES') call CALCRES(phi,nPhi,Bphi,nBphi,WDifCen,nfrq,ImeanOut,Totden, $ Pstar,Thstar,Qstar,Z,Nz,Resid,back,na,sqf,rmean, $ rstd,rtval,wnormtes,skewne,test1,rkurt,test2, $ sumSres,dw,F_seats,mAuto,nfreq,r,sea,Qstat,DF,D, $ BD,KEN,n_1,n0,tvalRUNS,sr,SQSTAT,SDF,SSE,out) * call profiler(3,'Pre SPECTRU') call SPECTRU(thstar,qstar,chi,nchi,cyc,ncyc,psi, $ npsi,pstar,mq,bd,d, $ qt1,out,ncycth, $ har, $ Fn,NN,estar,enot,enoc,Us,nUS,Vn,nVn, $ root0c,rootPIc,rootPIs,isUgly) call setAna('Y') call setTmcs('Y') c arreglo provisional if (abs(qt1).le.1.0d-2) then qt1=0.0d0 end if c end if end if isUgly=.FALSE. c isUgly=.FALSE. comentar esta línea para activar el quitar componentes con mínimo en 0 o PI c (ver rel 369) Spectru puede devolver ISugly=TRUE si hay algun componente con espectro raro. c c qt1=0.0d0 ! PAra que trague una descomposición no admisible qmin = qt1 if (qmin.ge.0.0d0 .or. OUTna.eq.1) then c De esta manera sólo se escribe el espectro si la descomposición es admisible c o es el modelo de entrada * call profiler(3,'Pre OutSearch') * write(Mtprof,*)' nio = ',nio * write(Mtprof,*)' out = ',out * write(Mtprof,*)' ItnSearch = ',ItnSearch * write(Mtprof,*)' IfnSearch = ',IfnSearch * write(Mtprof,*)' FIsearch = ',FIsearch * write(Mtprof,*)' nxSearch = ',nxSearch * do j=1,nxSearch * write(Mtprof,*)' xSearch(',j,'), Esearch(',j,') = ',xSearch(j), * * Esearch(j) * end do call OutSearch(nio,out,ItnSearch,IfnSearch,FIsearch, $ xSearch,nxSearch,Esearch) * call profiler(3,'Pre outPart2') call OutPart2(nio,z,nz,ILam,ImeanOut,noserie,Pg,Out, * $ iter,Itab,Iid,p,D,q,bp,BD,bq,Nper,Nyer,mq, $ iter,p,D,q,bp,BD,bq,Nper,Nyer,mq, $ Wdif,WdifCen,nwDif,WmDifXL,Zvar,VdifXL, $ QstatXL,df,rXL,seRxl,M,partACF,sePartACF,model, $ PicosXL,init,tstmean,Wm,seMean,nx,Cmatrix, $ PH,TH,BPH,BTH,sePHI,seTH,seBPHI,seBTH, $ MArez,MAimz,MAmodul,MAar,MApr, $ rez,imz,modul,ar,pr,THstar,isVa0) if (noserie.ne.1) then * call profiler(3,'Pre OutSeats') Call OutSeats(IOUT,Nio,Ndevice, $ printBack,back,sr,SQSTAT,SDF,SSE,mAuto,nfreq, $ n_1,n0,tvalRUNS,Qstat,DF,Pstat1,spstat1, $ wnormtes,wsk,skewne,test1,wkk,rkurt,test2,r,SEa, $ Resid,flagTstu,it,iper,iyear, $ rmean,rstd,DW,KEN,RTVAL,SumSres,F_seats,Nyer1, $ Nper1,Pstar_seats,Qstar_seats,D,BD) end if * call profiler(3,'Pre OutDenC1') call OutDenC1(Out,Nio,Titleg, $ p,d,q,bp,bd,bq,theta,nTh,Btheta,nBth, $ phi,nPhi,Bphi,nBphi,noserie) if ((qmin.ge.0.0d0 .or. OUTna.eq.1) .and. Lsgud) then * call profiler(3,'Pre OutDenCN') call OutDenCN(Out,Nio,init,pstar,ThStar,Qstar, $ Chis,nChis,Chins,nChins,Chi,nChi, $ Cycs,nCycs,Cycns,nCycns,Cyc,nCyc, $ Psis,nPsis,Psins,nPsins,Psi,nPsi, $ Adjs,nAdjs,Adjns,nAdjns,Chcyc,nChcyc, $ Totden,nTot) end if else if (Out.eq.0) then * call profiler(3,'Pre ShowNA') call ShowNA(Nio,InputModel) end if end if if (qmin .ge. 0.0d0) then if (IsUgly) then p=p-1 if (q.lt.3) then q=q+1 end if if (out .eq. 0) then 7251 format (////, $ ' DECOMPOSITION INVALID,SOME SPECTRUM NEGATIVE'//, $ 10x,'*****************************',/,12x, $ 'THE MODEL IS APPROXIMATED',/,10x, $ '*****************************',/) write (Nio,7251) write (Mt2,7251) end if else if (iter.ne.0) then * call profiler(3,'Pre OutPara') call OutPara(74,niter,mattitle,NAiter,ImeanOut, $ p,d,q,bp,bd,bq,phi,bphi,nbphi,theta,btheta,nbth, $ qstat,wm,1) end if * call profiler(3,'Pre DecompSpectrum') call DecompSpectrum(NOADMISS,NOSERIE, $ CHI,nCHI,PSI,nPSI,CYC,nCYC,CHIS,nCHIS, $ PSIS,nPSIS,ADJS,nADJS,CYCS,nCYCS,THSTAR,QSTAR,SQF, $ ct,cs,cc,Qt1, $ SQG,mq,bd,d,PG,OUT,ITER, $ estar,enot,enoc,Us,nUS,Vn,nVn, $ ncycth, $ THETP,nTHETP,THETS,nTHETS,THETC,nTHETC,THADJ,nTHADJ, $ CHCYC,nCHCYC, $ VarWNP,varwns,varwnc,varwna,buff2, $ pscyc, varwnt, thtra, npscyc, nthtra, $ chpsi, varwca, thcya, nchpsi, nthcya, NoDecompOut, $ Lsgud,IsCloseToTD,svudg) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK if (NOdecompOut.eq.1) then CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Spectrum') !DEC$ ENDIF CUNX#endif return 1 end if end if else if ((noadmiss.eq.1) .or. (noadmiss.eq.2)) then if (OUTna.eq.1) then * call profiler(3,'Pre ShowInvalDecomp') call ShowInvalDecomp(Out,nio,buff2, $ chi,nchi,enot,psi,npsi,estar, $ cyc,ncyc,ncycth,enoc, $ chcyc,nchcyc,thstar,qstar,qt1,Lsgud, $ IsCloseTOTD,svudg) end if InputModel=InputModel+1 if (nafijado.eq.0) then noadmiss = 3 end if * if (out .eq. 0) then * if (HTML .eq. 1) then * call SWarn(Nio) * write (Nio,'("
    DECOMPOSITION INVALID
    ", * $ "THE MODEL IS APPROXIMATED")') * call EWarn(Nio) * else * 7051 format ( * $ ////,' DECOMPOSITION INVALID,IRREGULAR SPECTRUM NEGATIVE'//,10x, * $ '*****************************',/,12x, * $ 'THE MODEL IS APPROXIMATED',/,10x, * $ '*****************************',/) * write (Nio,7051) * end if * end if else * call profiler(3,'Pre ShowInvalDecomp') call ShowInvalDecomp(Out,nio,buff2, $ chi,nchi,enot,psi,npsi,estar, $ cyc,ncyc,ncycth,enoc, $ chcyc,nchcyc,thstar,qstar,qt1,Lsgud, $ ISCloseToTD,svudg) 7052 format ( $ ////,' DECOMPOSITION INVALID,IRREGULAR SPECTRUM NEGATIVE'/, $ ' TRY ANOTHER MODEL OR, FOR AN APPROXIMATION, SET NOADMISS=YES.' $ ) 7053 format (12f11.5) write (Nio,7052) write (Mt2,7052) write (STDERR,7054) 7054 format ( $ /,' WARNING: Decomposition invalid, irregular spectrum ', $ 'negative.'/, $ ' Try another model or, for an approximation, ', $ 'set NOADMISS=YES.') CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Spectrum') !DEC$ ENDIF CUNX#endif return 1 end if CUNX#ifdef PROFILER !DEC$ IF DEFINED (PROFILER) * call profiler(3,'Spectrum') !DEC$ ENDIF CUNX#endif end c c c subroutine SPECTRU(thstar,qstar,chi,nchi,cyc,ncyc,psi, $ npsi,pstar,mq,bd,d, $ qt1,out,ncycth, $ har, $ Fn,NN,estar,enot,enoc,Us,nUS,Vn,nVn, $ root0c,rootPIc,rootPIs,isUgly) C C.. Implicits .. implicit none INCLUDE 'srslen.prm' include 'dimensions.i' C c----------------------------------------------------------------------- DOUBLE PRECISION ONE PARAMETER(ONE=1D0) c----------------------------------------------------------------------- C.. Formal Arguments .. integer qstar,nchi,ncyc,npsi,pstar,mq,bd,d, $ out,ncycth,har real*8 thstar(maxTh),chi(8),cyc(17),psi(27),qt1 logical root0c,rootPIc,rootPIs,isUgly C C.. Local Scalars .. integer i,ipipp,j,jmq,jsfix,nn,nqt,nrt,nu, $ nus,nvn,ixmin,n_step c character fname*30,subtitle*50 c character auxS*350 c real*8 arg,x real*8 ce1,ce2,cexmin1,cexmin2,e1,e2,enoc,enot,estar, $ exmin1,exmin2,pi,lb,ub,e3,ce3,exmin3, $ cexmin3,exmin7 cc c (Roberto Lopez: 01/2006. c OUTPUT'S of MinimGrid) cc integer doMinimGrid parameter (doMinimGrid = 1) C C.. Local Arrays .. integer iconv(7),jconv(4) real*8 efmin(7),exmin(7),fn(*),qt(32),rt(32),u(22),us(50),vn(80), $ dvec(1) * $ utf(8),vf(27),vn(80),y(300) C C.. External Functions .. real*8 FUNC0,getSdt,getSds,getSdc,getSdi,getSdsa logical istrue external FUNC0,istrue,getSdt,getSds,getSdc,getSdi,getSdsa integer ISTRLEN external ISTRLEN C C.. External Calls .. external CONJ, CONV, DIVFCN, MAK1, MINIM, MULTFN, PARFRA, & SPCEST, USRENTRY, GLOBALMINIM, MINIMGRID C C.. Intrinsic Functions .. intrinsic ABS, INT, MAX, MIN include 'func.i' include 'func2.i' include 'func3.i' include 'func4.i' include 'func5.i' include 'hspect.i' include 'min.i' include 'stream.i' include 'test.i' include 'buffers.i' include 'spectra.i' include 'dirs.i' include 'strmodel.i' include 'transcad.i' C LINES OF CODE ADDED FOR X-13A-S : 2 include 'error.cmn' C END OF CODE BLOCK C Debug added by REG integer np1a, np2a, np3a, np1b, np2b, np3b, np4b double precision fp1a(100), fp2a(100), fp3a(100) double precision fp1b(100), fp2b(100), fp3b(100), fp4b(100) double precision qt1a(1) C C ... Executable Statements ... C jsfix = 0 ncycth = 0 Nuc = 0 do i=1,32 Uc(i)=0.0d0 end do pi = 3.14159265358979D0 call CONJ(thstar,qstar,thstar,qstar,Ff,Nf) call CONJ(chi,nchi,chi,nchi,Ft,Nt) call CONJ(cyc,ncyc,cyc,ncyc,Fc,Nc) call CONJ(psi,npsi,psi,npsi,Fs,Ns) call MULTFN(Ft,Nt,Fc,Nc,fn,nn) call MULTFN(fn,nn,Fs,Ns,Fh,Nh) C C TO REACTIVATE THE PRINTOUT OF THE HARMONIC FUNCTIONS CHANGE HAR PARAMETER C if ((out .eq.0).and.(har.eq.1)) then 7000 format (/,' HARMONIC FUNCTIONS') write (Nio,7000) 7001 format ( $ //' F(X) F(X)'/' ____ = ________________'/ $ ' H(X) T(X) C(X) S(X) '//) write (Nio,7001) 7002 format (/,' F(X)'/) write (Nio,7002) 7003 format (12f11.4) write (Nio,7003) (Ff(i), i = 1,Nf) 7004 format (/,' T(X)'/) write (Nio,7004) write (Nio,7003) (Ft(i), i = 1,Nt) 7005 format (/,' C(X)'/) write (Nio,7005) write (Nio,7003) (Fc(i), i = 1,Nc) 7006 format (/,' S(X)'/) write (Nio,7006) write (Nio,7003) (Fs(i), i = 1,Ns) 7007 format (/,' N(X), FORMED FROM THE PRODUCT T(S)C(X)'/) write (Nio,7007) write (Nio,7003) (fn(i), i = 1,nn) 7008 format ( $ /,' H(X), FORMED FROM THE PRODUCT',' T(X)C(X)S(X) = N(X)S(X)' $ /) write (Nio,7008) write (Nio,7003) (Fh(i), i = 1,Nh) end if C correzione per eliminare i picchi stagionalita' quando non c'e' if (bd .eq. 1) then jmq = mq / 2 else jmq = 0 end if C C PLOT SERIES SPECTRUM C c******* c Ahora calculamos el espectro de la serie de tramo al principio del programa c if (noadmiss.lt.2) then c call SPC(Ff,nf,Fh,nh,1.0D0,spect) c end if C****** C C IDENTIFY COMPONENTS C C QT TO THE IRREGULAR C UT/FT TO TREND C UC/FC TO CYCLE C V/FS TO SEASONAL C U/FN IS THE CYCLE-TREND C C FF/FH = QT + RT/FH C C RT/FH = U/FN + V/FS C U/FN = UT/FT + UC/FC C C QT1 = QT + ENOT + ESTAR + ENOC C ENOT = MINIMUM OF TREND SPECTRUM C ENOC = MINIMUM OF CYCLE SPECTRUM C ESTAR = MINIMUM MINIMORUM OF SEASONAL SPEC C C TREND = PRELIMINARY TREND - ENOT C CICLE = PRELIMINARY CYCLE - ENOC C SEAS. = PRELIMINARY SEAS. - ESTAR C C FORM QUOTIENT QT(X) IF NUMERATOR IS OF HIGHER DEGREE THAN DENOMINATOR C OTHERWISE SET QT(X) = 0 AND REMAINDER RT(X) = FF(X) C C IF(QSTAR.GT.PSTAR) THEN C WRITE(NIO,*)' PTOT > QTOT NO DECOMPSITION IS PERFORMED' C RETURN 1 C end if if (qstar .lt. pstar) then nqt = 1 qt(1) = 0.0d0 do i = 1,qstar rt(i) = Ff(i) end do j = qstar + 1 do i = j,pstar rt(i) = 0.0d0 end do nrt = pstar else call DIVFCN(Ff,Nf,Fh,Nh,qt,nqt,rt,nrt) C FF (total numerator)/FH (total denominator) = QT (quotient) + RT/FH (remainder) c comment added DEKM 20 Feb 03 end if if ((out .eq.0).and.(har.eq.1)) then 7009 format ( $ //' F(X) = QT(X) + RT(X)'/' ____ _____'/ $ ' H(X) H(X) '//' QT(X) QUOTIENT ') write (Nio,7009) 7010 format (' ',8(f11.4,2x)) write (Nio,7010) (qt(i), i = 1,nqt) 7011 format (/,' RT(X) REMAINDER ') write (Nio,7011) write (Nio,7010) (rt(i), i = 1,nrt) end if if (npsi .eq. 1) then jsfix = 1 end if if (mq .eq. 1) then jsfix = 1 end if C C 8484 IS THE END OF THE COMPUTATION OF NUMERATORS OF SPECTRA COMPONENTS C C If trend but no seasonal, cycle or transitory, put remainder rt(i) in trend ut(i) c comment added DEKM 20 Feb 03 if (jsfix.eq.1 .and. ncyc.eq.1 .and. ncycth.eq.0 .and. nchi.gt.1) $ then do i = 1,nrt Ut(i) = rt(i) end do Nut = nrt estar = 0.0d0 enoc = 0.0d0 C C If seasonal but no trend, cycle or transitory, put remainder rt(i) in seasonal v(i) c comment added DEKM 20 Feb 03 else if (jsfix.ne.1 .and. ncyc.eq.1 .and. ncycth.eq.0 .and. $ nchi.eq.1) then do i = 1,nrt V(i) = rt(i) end do Nv = nrt enot = 0.0d0 enoc = 0.0d0 C C If cycle but no seasonal, trend or transitory, put remainder rt(i) in cycle uc(i) c comment added DEKM 20 Feb 03 else if (jsfix.eq.1 .and. ncycth.eq.0 .and. ncyc.gt.1 .and. $ nchi.eq.1) then do i = 1,nrt Uc(i) = rt(i) end do Nuc = nrt estar = 0.0d0 enot = 0.0d0 C C C If seasonal, cycle and trend c comment added DEKM 20 Feb 03 else if (jsfix.ne.1 .and. ncycth.eq.0 .and. ncyc.gt.1 .and. $ nchi.gt.1) then C C FIND H.C.F OF FN(X) AND FS(X) C C******************************************************************** C ACTIVATE WHEN THE TREND COMPONENT IS MUCH BIGGER THAN THE SEASONAL C AND THERE MAY BE PROBLEMS WITH PARFRA (I.E WHEN MQ IS SMALL) C C CALL PARFRA(RT,NRT,FS,NS,FN,NN,V,NV,U,NU) C IF(I.EQ.I) GO TO 2901 C C******************************************************************** C C partial fraction decomposition remainder/(trend-cycle denom*seasonal denom)=(u/trend-cycle denom) + (v/seas denom) c comment added DEKM 20 Feb 03 call PARFRA(rt,nrt,fn,nn,Fs,Ns,u,nu,V,Nv) if ((out .eq.0).and.(har.eq.1)) then 7012 format ( $ ///,' RT(X) = U(X) + V(X)'/' +________ ____ ____'/ $ ' N(X)S(X) N(X) S(X)'//' U(X)') write (Nio,7012) write (Nio,7003) (u(i), i = 1,nu) 7013 format (/,' V(X)') write (Nio,7013) write (Nio,7003) (V(i), i = 1,Nv) end if call MULTFN(u,nu,Fs,Ns,us,nus) call MULTFN(V,Nv,fn,nn,vn,nvn) do i = 1,nus Dum(i) = rt(i) - us(i) - vn(i) end do if ((out .eq.0).and.(har.eq.1)) then 7014 format ( $ ///,' DUM(X) = RT(X) - U(X)S(X) - V(X)N(X).', $ ' THIS SHOULD BE ZERO'//7(2x,f11.4)) write (Nio,7014) (Dum(i), i = 1,nus) end if C C C FIND H.C.F OF FT(X) AND FC(X) C ipipp = ncyc + nchi - 1 do i = nu+1,ipipp u(i) = 0.0d0 end do nu = ipipp C partial fraction decomposition to split cycle and trend c comment added DEKM 20 Feb 03 call PARFRA(u,nu,Fc,Nc,Ft,Nt,Uc,Nuc,Ut,Nut) cc c Correzione 04.05.2006 MAKE IT SENSE ????? cc if ((Nuc .eq. 1) .and. (abs(Uc(Nuc)) .lt.1.0d-15)) then Uc(Nuc) = 1.0d-15 end if if ((out .eq.0).and.(har.eq.1)) then 7015 format ( $ ///,' U(X) = UT(X) + UC(X)'/' +________ _____ _____'/ $ ' T(X)C(X) T(X) C(X)'//' UT(X)') write (Nio,7015) write (Nio,7003) (Ut(i), i = 1,Nut) 7016 format (/,' UC(X)') write (Nio,7016) write (Nio,7003) (Uc(i), i = 1,Nuc) end if call MULTFN(Uc,Nuc,Ft,Nt,us,nus) call MULTFN(Ut,Nut,Fc,Nc,vn,nvn) do i = 1,nu Dum(i) = u(i) - us(i) - vn(i) end do if ((out .eq.0).and.(har.eq.1)) then 7017 format ( $ ///,' DUM(X) = U(X) - UT(X)C(X) - UC(X)T(X).', $ ' THIS SHOULD BE ZERO'//7(2x,f11.4)) write (Nio,7017) (Dum(i), i = 1,nus) end if C c if trend and cycle but no seasonal or transitory split cycle and trend c comment added DEKM 20 Feb 03 else if (jsfix.eq.1 .and. ncycth.eq.0 .and. ncyc.gt.1 .and. $ nchi.gt.1) then C call PARFRA(rt,nrt,Ft,Nt,Fc,Nc,Ut,Nut,Uc,Nuc) if ((out .eq.0).and.(har.eq.1)) then 7018 format ( $ ///,' RT(X) = UT(X) + UC(X)'/'+________ _____ _____'/ $ ' T(X)C(X) T(X) C(X)'//' UT(X)') write (Nio,7018) write (Nio,7003) (Ut(i), i = 1,Nut) 7019 format (/,' UC(X)') write (Nio,7019) write (Nio,7003) (Uc(i), i = 1,Nuc) end if call MULTFN(Uc,Nuc,Ft,Nt,us,nus) call MULTFN(Ut,Nut,Fc,Nc,vn,nvn) do i = 1,nus Dum(i) = rt(i) - us(i) - vn(i) end do if ((out .eq.0).and.(har.eq.1)) then 7020 format ( $ ///,' DUM(X) = RT(X) - UT(X)C(X) - UC(X)T(X).', $ ' THIS SHOULD BE ZERO'//7(f11.4)) write (Nio,7020) (Dum(i), i = 1,nus) end if estar = 0.0d0 c if seasonal and cycle but no trend and transitory split cycle and seasonal c comment added DEKM 20 Feb 03 else if (jsfix.ne.1 .and. ncycth.eq.0 .and. ncyc.gt.1 .and. $ nchi.eq.1) then call PARFRA(rt,nrt,Fc,Nc,Fs,Ns,Uc,Nuc,V,Nv) if ((out .eq.0).and.(har.eq.1)) then 7021 format ( $ ///,' RT(X) = V(X) + UC(X)'/'+________ ______ ______'/ $ ' S(X)C(X) S(X) C(X)'//' V(X)') write (Nio,7021) write (Nio,7003) (V(i), i = 1,Nv) 7022 format (/,' UC(X)') write (Nio,7022) write (Nio,7003) (Uc(i), i = 1,Nuc) end if call MULTFN(Uc,Nuc,Fs,Ns,us,nus) call MULTFN(V,Nv,Fc,Nc,vn,nvn) do i = 1,nus Dum(i) = rt(i) - us(i) - vn(i) end do if ((out .eq.0).and.(har.eq.1)) then 7023 format ( $ ///,' DUM(X) = RT(X) - V(X)C(X) - UC(X)S(X).', $ ' THIS SHOULD BE ZERO',//,7(2x,f11.4)) write (Nio,7023) (Dum(i), i = 1,nus) end if enot = 0.0d0 c if trend and seasonal but no cycle or transitory split seasonal and trend c comment added DEKM 20 Feb 03 else if (jsfix.ne.1 .and. ncycth.eq.0 .and. ncyc.eq.1 .and. $ nchi.gt.1) then call PARFRA(rt,nrt,Ft,Nt,Fs,Ns,Ut,Nut,V,Nv) if ((out .eq.0).and.(har.eq.1)) then 7024 format ( $ ///,' RT(X) = UT(X) + V(X)'/'+________ _____ _____'/ $ ' T(X)S(X) T(X) S(X)'//' UT(X)') write (Nio,7024) write (Nio,7003) (Ut(i), i = 1,Nut) 7025 format (/,' V(X)') write (Nio,7025) write (Nio,7003) (V(i), i = 1,Nv) end if call MULTFN(V,Nv,Ft,Nt,us,nus) call MULTFN(Ut,Nut,Fs,Ns,vn,nvn) do i = 1,nus Dum(i) = rt(i) - us(i) - vn(i) end do if ((out .eq.0).and.(har.eq.1)) then C Debug change by REG on 12/22/2005 7026 format ( $ ///,' DUM(X) = RT(X) - UT(X)S(X) - V(X)T(X).', $ ' THIS SHOULD BE ZERO'//7(f11.4)) write (Nio,7026) (Dum(i), i = 1,nus) end if enoc = 0.0d0 end if C C if (qstar .gt. pstar) then call MULTFN(qt,nqt,Fc,Nc,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(Uc,Nuc,ONE,Dum,NDum,ONE,Uc,Nuc) ncycth = 1 end if C Debug added by REG on 12/22/2005 if ((out .eq.0).and.(har.eq.1)) then do i=1,Nf fp1b(i)=0.0D0 fp2b(i)=0.0D0 fp3b(i)=0.0D0 fp4b(i)=0.0D0 end do write (Nio,8003) 'UT(X)', (Ut(i), i = 1,Nut) write (Nio,8003) 'V(X)', (V(i), i = 1,Nv) write (Nio,8003) 'UC(X)', (Uc(i), i = 1,Nuc) 8003 format( //, 1x, a, //, 10(8(f11.4,1x),/) ) call MULTFN(V,Nv,Ft,Nt,fp1a,np1a) call MULTFN(Ut,Nut,Fs,Ns,fp2a,np2a) call MULTFN(fp1a,np1a,Fc,Nc,fp1b,np1b) call MULTFN(fp2a,np2a,Fc,Nc,fp2b,np2b) if ( Nuc .gt. 0 ) then call MULTFN(Uc,Nuc,Fs,Ns,fp3a,np3a) call MULTFN(fp3a,np3a,Ft,Nt,fp3b,np3b) end if if (Nf .eq. Nh) then call MULTFN(qt,nqt,Fh,Nh,fp4b,np4b) end if do i = 1,Nf Dum(i) = Ff(i) - fp1b(i) - fp2b(i) - fp3b(i) - fp4b(i) end do 8027 format ( ///, $ ' DUM(X) = F(X)-V(X)T(X)C(X)-UT(X)S(X)C(X)-UC(X)S(X)T(X).', $ ' THIS SHOULD BE ZERO', //, 10(8(g12.5,1x),/) ) write (Nio,8027) (Dum(i), i = 1,Nf) end if C C if (nchi .ne. 1) then C C FIND MINIMUM OF TREND SPECTRUM AND PLOT C Ifunc = 2 Dstop = 0.000005d0 Step = 0.01d0 Start = pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0.5d0 * pi ub = pi * call MINIM(e1,exmin1,lb,ub,jconv(1)) n_step=12 call GlobalMINIM(e1,exmin1,lb,ub,jconv(1),n_step,d+bd,mq,2) Start = 0.5d0 * pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0D0 ub = 0.5d0 * pi call GlobalMINIM(e2,exmin2,lb,ub,jconv(2),n_step,d+bd,mq,2) if (abs(exmin2).lt.1.0d-3) then isUgly=.TRUE. end if * call MINIM(e2,exmin2,lb,ub,jconv(2)) enot = MIN(e1,e2) if ((doMinimGrid.gt.0) .and. (ut(1)-enot*ft(1).lt.0.0d0)) then call minimGrid(e3,exmin3,mq,2,2) if (e3 .lt. enot) then exmin2 = exmin3 enot = e3 e2 = e3 end if end if c c MY ADDITION (Donald Martin, July 2002) TO 'SPECTRUM' OF TREND USING GRID SEARCH ALSO c * if (Newmdl.gt.0) THEN * call minim2(e3, ixmin) * exmin3 = dble(float(ixmin)) * if (e3 .lt. enot) enot = e3 * end if end if C if (ncycth.ne.0 .or. ncyc.ne.1) then C C FIND MINIMUM OF CYCLE SPECTRUM AND PLOT C Ifunc = 3 Dstop = 0.000005d0 Step = 0.01d0 Start = pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb=0.5d0*pi ub = pi * call MINIM(ce1,cexmin1,lb,ub,jconv(3)) n_step=12 call GlobalMINIM(ce1,cexmin1,lb,ub,jconv(3),n_step,d+bd,mq,2) if (abs(cexmin1-pi).lt.1.0D-3 .and. rootPIc) then isUgly=.TRUE. end if Start = 0.5d0 * pi C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0D0 ub = 0.5d0*pi * call MINIM(ce2,cexmin2,lb,ub,jconv(4)) call GlobalMINIM(ce2,cexmin2,lb,ub,jconv(4),n_step,d+bd,mq,2) if (abs(cexmin2).lt.1.0D-3 .and. root0c) then isUgly=.TRUE. end if enoc = MIN(ce1,ce2) if ((doMinimGrid.gt.0) .and. (uc(1)-enoc*fc(1).lt.0.0d0)) then call minimGrid(ce3,cexmin3,mq,2,3) if (ce3 .lt. enoc) then enoc = ce3 cexmin2 = cexmin3 ce2 = ce3 end if end if * if (Newmdl.gt.0) THEN *c *c MY ADDITION (DONALD MARTIN, JULY 2002) TO FIND MINIMUM OF *c 'SPECTRUM' OF CYCLE *c * call minim2(ce3,ixmin) * cexmin3 = dble(float(ixmin)) * if (ce3 .lt. enoc) enoc = ce3 * end if end if C if (jsfix .ne. 1) then C C FIND MINIMUM OF SEASONAL SPECTRUM AND PLOT C Ifunc = 1 Dstop = 0.000005d0 Step = 0.01d0 Start = 0.0d0 jmq = mq / 2 C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = 0D0 ub = pi / dble(jmq) call MINIM(efmin(1),exmin(1),lb,ub,iconv(1)) if (abs(efmin(1)-pi).lt.1.0D-3 .and. rootPIs) then isUgly=.TRUE. end if do i = 2,jmq Start = (dble(i-0.5d0) * pi) / dble(jmq) C Changed (by Donald Martin, 7/23/02) set lb and ub, pass to minim. lb = (dble(i-1) * pi) / dble(jmq) ub = (dble(i) * pi) / dble(jmq) call MINIM(efmin(i),exmin(i),lb,ub,iconv(i)) if (abs(efmin(i)-pi).lt.1.0D-3 .and.rootPIs) then isUgly=.TRUE. end if end do estar = 10.0d0 do i = 1,jmq if (efmin(i) .lt. estar) then estar = efmin(i) end if end do * if (Newmdl.gt.0) THEN * call minim2(efmin(7),ixmin) * exmin7 = dble(float(ixmin)) * if (efmin(7) .lt. estar) estar = efmin(7) * end if if ((doMinimGrid.gt.0) .and. (v(1)- estar*fs(1).lt.0.0d0)) then call minimGrid(efmin(jmq+1), exmin(jmq+1),mq,2,1) if (efmin(jmq+1) .lt. estar) then estar = efmin(jmq+1) end if end if end if C if ((out .eq.0).and.(har.eq.1)) then write (Nio,7027) if (jsfix .ne. 1) then 7028 format (' SEASONAL SPECTRUM.LOCAL MINIMA'/) write (Nio,7028) 7027 format ( $ /,' LOCAL ',6x,'FREQUENCY',6x,'CONVERGENCE'/' MINIMA',6x, $ '(RADIANS)',6x,' TEST'//) do i = 1,jmq 7029 format (' ',f9.6,4x,f7.4,11x,i2) write (Nio,7029) efmin(i), exmin(i), iconv(i) end do 7030 format (/,' MINIMUM MINIMORUM'//f11.6) write (Nio,7030) estar end if C if (ncycth.ne.0 .or. ncyc.ne.1) then 7031 format (//,' ',A,' SPECTRUM. SIMPLE MINIMUM'/) write (NIO,7031) TransLcad(1:nTransLcad) write (Nio,7029) ce1, cexmin1, jconv(3) if ((ABS(cexmin1-cexmin2)) .ge. 0.0001d0) then write (Nio,7029) ce2, cexmin2, jconv(4) end if end if if (nchi .ne. 1) then 7032 format (//' TREND-CYCLE SPECTRUM. SIMPLE MINIMUM'/) write (Nio,7032) write (Nio,7029) e1, exmin1, jconv(1) if ((ABS(exmin1-exmin2)) .ge. 0.0001d0) then write (Nio,7029) e2, exmin2, jconv(2) end if end if end if C C C CHECK IF DECOMPOSITION VALID C qt1 = qt(1) + enot + estar + enoc if (qstar .gt. pstar) then qt1 = enot + estar + enoc end if cc c Used for new Model Approximation cc if (qt1 .lt.0.0d0) then isUgly = .true. end if c cc end cc c cc subroutine CALCRES(phi,nPhi,Bphi,nBphi,WDifCen,nWdif,ImeanOut, $ Phistar,nPhistar,Thstar,nThstar,Z,Nz,A,back, $ Na,sqf,rmean,rstd,rtval,wnormtes,skewne, $ test1,rkurt,test2,sumSres,dw,rvar,mAuto,nfreq, $ r,se,Qstat, DF,D,BD,KEN,n_1,n0,tvalRUNS,Sr, $ Sqstat,Sdf,Sse,out) C C C C.. Implicits .. implicit none C C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer n12,n10,n1 parameter (n1 = 1, n10 = 10, n12 = 12) C C.. Formal Arguments .. real*8 A(mpkp),back(mpkp) real*8 Z(mpkp) real*8 WDifCen(mpkp) real*8 Phistar(*),Thstar(*),phi(4),Bphi(13) real*8 sqf,KEN integer nPhistar,nThstar,Nz, Na, out, nPhi,nBphi real*8 rkurt,skewne,wnormtes,test1,test2 real*8 rmean,rstd,rtval,rvar,dw,sumSres integer mAuto,nfreq,DF,Sdf,D,BD,n_1,n0,nWdif,ImeanOut real*8 Qstat,Sqstat,tvalRUNS real*8 r(*),se(*),Sr(*),Sse(*) C C.. External Functions .. real*8 KENDALLS real*8 DMED C C.. Local Scalars .. integer i,j,Np,q1,nna,iauto,wnw,kd,ierr real*8 sum,sumb,f,xmed,ws character*180 cerr C C.. Local Arrays .. real*8 u(mpkp),ub(mpkp) real*8 ba(mpkp),bz(MPKP) real*8 Pstar(27),Qstar(maxTh) integer nPstar,nQstar include 'stream.i' * include 'indhtml.i' include 'pinno.i' C C ... Executable Statements ... C cc c Switch the model to BJ signs and compute the residuals using CLS cc do i=1,nThstar-1 Qstar(i) = -Thstar(i+1) enddo nQstar = nThstar - 1 if (ImeanOut .eq.0) then do i=1,nz bz(Nz-i+1) = z(i) enddo do i=1,nPhistar Pstar(i) = -Phistar(i+1) enddo nPstar = nPhistar - 1 Np = Nz-nPstar do i = 1,Np sum = Z(i+nPstar) sumb = bz(i+nPstar) do j = 1,nPstar sum = sum - Pstar(j)*Z(i+nPstar-j) sumb = sumb - Pstar(j)*bz(i+nPstar-j) end do u(i) = sum ub(i) = sumb end do else cc c Compute PHIST = Phi * Bphi cc call conv(Phi,nPhi,Bphi,nBphi,Pstar,nPstar) do i=2,nPstar Pstar(i-1) = -Pstar(i) enddo nPstar = nPstar - 1 kd = (-1)**(BD+D) j = nWdif do i = 1,nWdif ws = WDifCen(i) * kd bz(i) = WDifCen(nWdif-i+1) * kd bz(nWdif-i+1) = ws j = j - 2 if (j .le. 0) goto 1 end do 1 do i = 1,NWdif sum = WDifCen(i+nPstar) sumb = bz(i+nPstar) do j = 1,nPstar sum = sum - Pstar(j)*WDifCen(i+nPstar-j) sumb = sumb - Pstar(j)*bz(i+nPstar-j) end do u(i) = sum ub(i) = sumb end do Np = NWdif end if do i = 1, nQstar a(i) = 0.0d0 back(i) = 0.0d0 enddo q1 = nQstar + 1 do i = q1,Nz sum = u(i-nQstar) sumb = ub(i-nQstar) do j = 1,nQstar sum = sum + Qstar(j)*a(i-j) sumb = sumb + Qstar(j)*back(i-j) end do a(i) = sum back(i) = sumb end do cc c Residuals statistics computation cc rmean = 0.0d0 rvar = 0.0d0 Na = Np do i = nQstar+1,Na rvar = rvar + a(i)*a(i) rmean = rmean + a(i) end do sumSres = rvar rvar = rvar / (Na-nQstar) sqf = dsqrt(sumSres / DBLE(Na-nQstar) ) call setSD(sqf) rmean = rmean / (Na-nQstar) rstd = (sumSres/Na)**0.5d0 rtval = rmean / rstd skewne = 0.0d0 rkurt = 0.0d0 nna = Na - nPstar do i = 1,Na skewne = skewne + ((a(i)-rmean)**3)/(rvar**1.50d0*nna) rkurt = rkurt + ((a(i)-rmean)**4)/(rvar**2.0d0*nna) end do test1 = SQRT(6.0d0/Na) test2 = SQRT(24.0d0/Na) wnormtes = (skewne**2)/(test1**2) + $ ((rkurt-3)**2)/(test2**2) dw = 0.0d0 do i = 2,Na dw = dw + (a(i)-a(i-1))**2 end do dw = dw / sumSres cc c KENDALL Test cc Ken = kendalls(a,Na,Nfreq) cc c Compute ACF of residuals cc iauto = 1 wNw = Nz - D - Nfreq*BD call AUTO(Na,A,mAuto,r,Iq,wNw,0,Nfreq,iauto, $ Qstat,df,se,ierr,cerr) cc c Test RUNS on Residuals cc xmed = DMED(a,Na) call RACES(a,Na,xmed,1,tvalRUNS,n_1,n0) cc c Squared Residuals cc do i = 1,Na ba(i) = a(i)**2 end do call AUTO(Na,ba,mAuto,Sr,Iq,wNw,0,Nfreq,iauto, $ SQstat,Sdf,Sse,ierr,cerr) cc c OUTPUT Section cc C C end c subroutine DecompSpectrum(NOADMISS,NOSERIE, $ CHI,nCHI,PSI,nPSI,CYC,nCYC,CHIS,nCHIS, $ PSIS,nPSIS,ADJS,nADJS,CYCS,nCYCS,THSTAR,QSTAR,SQF, $ ct,cs,cc,Qt1, $ SQG,mq,bd,d,PG,OUT,ITER, $ estar,enot,enoc,Us,nUS,Vn,nVn, $ ncycth, $ THETP,nTHETP,THETS,nTHETS,THETC,nTHETC,THADJ,nTHADJ, $ CHCYC,nCHCYC, $ VarWNP,varwns,varwnc,varwna,buff2, $ pscyc, varwnt, thtra, npscyc, nthtra, $ chpsi, varwca, thcya, nchpsi, nthcya, NoDecompOut, $ Lsgud, IsCloseToTD, svudg) implicit none include 'srslen.prm' include 'dimensions.i' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- c INPUT PARAMETERS integer NOADMISS,nchi,npsi,nCYC,SQG,MQ,bd,d,PG,OUT,ITER,NOSERIE integer nChis,nADJS,nPSIS,nCYCS real*8 ct(32),cs(32),cc(32),Cyc(17),CYCs(17), $ chi(8),CHIS(5),PSI(27),PSIS(16),SQF real*8 ADJS(17) include 'func.i' include 'func2.i' include 'func3.i' include 'func4.i' include 'func5.i' include 'test.i' include 'buffers.i' include 'spectra.i' include 'dirs.i' include 'stream.i' include 'error.cmn' include 'transcad.i' include 'stdio.i' include 'units.cmn' integer nUS,nVn,ncycth,Qstar, npscyc, nthtra, $ nchpsi, nthcya integer nounit real*8 qt1,estar,enot,enoc,Us(50),Vn(80),THstar(Qstar), $ pscyc(32), varwnt, thtra(32), $ chpsi(32), varwca, thcya(32) logical Lsgud, IsCloseToTD, svudg c OUTPUT PARAMETERS include 'strmodel.i' integer nTHETP,nTHETS,nTHETC,NTHADJ,NCHCYC,NoDecompOut real*8 thetp(8),thets(27),thetc(32),thadj(32),chcyc(20) real*8 varWnp,varwns,varwnc,varwna character buff2*80 c LOCAL PARAMETERS real*8 Qmin,utf(8),x,pi real*8 arg,y(300),vf(27),UCF(32),toterr,dvec(1) integer I,J,IOUT,nsaltos character fname*30,subtitle*50,auxs*350,caption0*(60) logical isopen c External Functions real*8 FUNC0 integer ISTRLEN external FUNC0,ISTRLEN intrinsic abs c ----------------- pi = 3.14159265358793D0 Qmin=Qt1 NoDecompOut=0 nounit = 0 C C SUBTRACT MINIMA AND SET UP FILTERS NUMERATORS C do i = 1,32 ct(i) = ZERO cs(i) = ZERO cc(i) = ZERO end do C do i = 1,Nf Dum1(i) = Ff(i) end do Ndum1 = Nf if (nchi .ne. 1) then Ut(Nt) = ZERO Nut = Nt do i = 1,Nut utf(i) = Ut(i) - enot*Ft(i) end do call SPC(Utf,Nut,Ft,Nt,ONE,spectt) C********************************************************** call MULTFN(utf,Nut,Fc,Nc,vn,nvn) call MULTFN(vn,nvn,Fs,Ns,us,nus) C C********************************************************** do i = 1,nus Dum(i) = us(i) end do Ndum = nus Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do C C GC 08/07/98 if (d.ne.0 .or. bd.ne.0) then y(1) = ONE end if * if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then * fname = 'FILTFT.T4F' * if (sqg .eq. 1) then * subtitle = 'SQUARED GAIN OF TREND-CYCLE FILTER' * else * subtitle = 'FILTER for TREND-CYCLE (F.D.)' * end if * call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) * end if C C********************************************************** C C********************************************************** do i = 1,Nh Dum(i) = Fh(i) end do Ndum = Nh Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg * qt1 if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do * if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then * fname = 'FILTFI.T4F' * if (sqg .eq. 1) then * subtitle = 'SQUARED GAIN OF IRREGULAR FILTER' * else * subtitle = 'FILTER for IRREGULAR (F.D.)' * end if * call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) * end if C C********************************************************** ct(1) = us(1) do j = 2,nus ct(j) = 0.5d0 * us(j) end do end if C if (npsi .ne. 1) then V(Ns) = ZERO do i = 1,Ns vf(i) = V(i) - estar*Fs(i) end do call SPC(Vf,Ns,Fs,Ns,ONE,spectS) C********************************************************** call MULTFN(vf,Ns,Fc,Nc,vn,nvn) call MULTFN(vn,nvn,Ft,Nt,us,nus) C C********************************************************** do i = 1,nus Dum(i) = us(i) end do Ndum = nus Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do * if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then * fname = 'FILTFS.T4F' * if (sqg .eq. 1) then * subtitle = 'SQUARED GAIN OF SEASONAL FILTER' * else * subtitle = 'FILTER for SEASONAL (F.D.)' * end if * call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) * end if C C********************************************************** cs(1) = us(1) do j = 2,nus cs(j) = 0.5d0 * us(j) end do end if if (ncycth.ne.0 .or. ncyc.ne.1) then C C CORREZIONE DI GIANLUCA 06-09-95 TOP-HEAVY CYCLE C if (ncycth .eq. 0) then do i=Nuc+1,Nc Uc(i) = ZERO end do Nuc = Nc else do i = Nc+1,Nuc Fc(i) = ZERO end do Nc = Nuc end if do i = 1,Nuc ucf(i) = Uc(i) - enoc*Fc(i) end do call SPC(Ucf,Nuc,Fc,nc,ONE,specty) C********************************************************** call MULTFN(ucf,Nuc,Fs,Ns,vn,nvn) call MULTFN(vn,nvn,Ft,Nt,us,nus) C C********************************************************** do i = 1,nus Dum(i) = us(i) end do Ndum = nus Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do * if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then * fname = 'FILTFY.T4F' * if (sqg .eq. 1) then * subtitle = 'SQUARED GAIN OF '//transLCad(1:nTransLCad)// * & ' FILTER' * else * subtitle = 'FILTER for '//transLCad(1:nTransLCad)// * & ' (F.D.)' * end if * call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) * end if C C********************************************************** cc(1) = us(1) do j = 2,nus cc(j) = 0.5d0 * us(j) end do end if C Debug added by REG on 12/22/2005 * if (out .eq. nnohar) then * do i=1,Nf * fp1b(i)=ZERO * fp2b(i)=ZERO * fp3b(i)=ZERO * fp4b(i)=ZERO * end do * write (Nio,8003) 'UTF(X)', (Utf(i), i = 1,Nut) * write (Nio,8003) 'VF(X)', (Vf(i), i = 1,Ns) * write (Nio,8003) 'UCF(X)', (Ucf(i), i = 1,Nuc) * write (Nio,8003) 'I(X)', qt1 *c8003 format( //, 1x, a, //, 10(8(f11.4,1x),/) ) * call MULTFN(Vf,Ns,Ft,Nt,fp1a,np1a) * call MULTFN(Utf,Nut,Fs,Ns,fp2a,np2a) * call MULTFN(fp1a,np1a,Fc,Nc,fp1b,np1b) * call MULTFN(fp2a,np2a,Fc,Nc,fp2b,np2b) * if ( Nuc .gt. 0 ) then * call MULTFN(Ucf,Nuc,Fs,Ns,fp3a,np3a) * call MULTFN(fp3a,np3a,Ft,Nt,fp3b,np3b) * end if * qt1a(1)=qt1 * call MULTFN(qt1a,1,Fh,Nh,fp4b,np4b) * do i = 1,Nf * Dum(i) = Ff(i) - fp1b(i) - fp2b(i) - fp3b(i) - fp4b(i) * end do * 8028 format ( ///, * $ ' DUM(X) = F(X)-VF(X)T(X)C(X)-UTF(X)S(X)C(X)-UCF(X)S(X)T(X)', * $ '-I(X)H(X).',' THIS SHOULD BE ZERO', //, 10(8(g12.5,1x),/) ) * write (Nio,8028) (Dum(i), i = 1,Nf) * end if C C FIND THE MA REPRESENTATION OF THE THREE NUMERATORS C nthetp = 1 nthets = 1 nthetc = 1 nthadj = 1 thetp(1) = ONE thets(1) = ONE thetc(1) = ONE thadj(1) = ONE C C SPECTRUM OF IRREGULAR ESTIMATOR C * if (pg .eq. 0) then * call SPC(Fh,Nh,Ff,Nf,Qt1*Qt1,spectei) * end if if (out.eq.0) then iout=0 else iout=1 end if call MAspectrum(iout,nio,buff2, $ chi,nchi,utf,nut,thetp,nthetp,varwnp, $ npsi,vf,ns,thets,nthets,varwns, $ cyc,ncyc,ncycth,ucf,nuc,thetc,nthetc,varwnc, $ chcyc,nchcyc,thstar,qstar,thadj,nthadj,varwna, $ us,nus,qt1,IsCloseToTD) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK C **** TREND **** C * if (nchi .ne. 1) then * if (pg .eq. 0) then * call SPCEST(utf,Nut,Fs,Ns,Fc,Nc,Ft,Nt,Ff,Nf,spectet) * end if * end if C * if (npsi .ne. 1) then C C **** SEAS. **** C * if (pg .eq. 0) then * call SPCEST(vf,Ns,Ft,Nt,Fc,Nc,Fs,Ns,Ff,Nf,specteS) * end if * end if C if (ncycth.ne.0 .or. ncyc.ne.1) then C C **** CYCLE **** C if (varwnc .lt.ZERO) then if ((noadmiss.eq.1) .or. (noadmiss.eq.2)) then noadmiss = 3 if (out.eq.0) then 2051 format ( $ ////,4x,' DECOMPOSITION INVALID'//,10x, $ '*****************************',/,12x, $ 'THE MODEL IS APPROXIMATED',/,10x, $ '*****************************',/) write (NIO,2051) write (Mt2,2051) end if return else if (out.eq.0) then 2052 format ( $ ////,' WARNING: DECOMPOSITION INVALID, IRREGULAR SPECTRUM', $ ' NEGATIVE.',/, $ ' TRY ANOTHER MODEL OR, FOR AN APPROXIMATION, ', $ 'SET NOADMISS=YES.') write (NIO,2052) write (Mt2,2052) end if NoDecompOut=1 return end if end if * if (pg .eq. 0) then * call SPCEST(ucf,Nuc,Fs,Ns,Ft,Nt,Fc,Nc,Ff,Nf,spectey) * end if end if C if (nchcyc.ne.1 .or. ncycth.ne.0) then if (npsi .eq. 1) then do i = 1,qstar thadj(i) = thstar(i) end do do i = qstar+1,nchcyc thadj(i) = ZERO end do c nthadj = MAX(qstar,nchcyc) nthadj=qstar varwna = ONE else C C C FIND MA REPRESENTATION OF SEASONALLY ADJUSTED SERIES C if (IsCloseToTD) then * if (pg .eq. 0) then * call SPCEST(us,nus,Fs,Ns,Fc,nc,Ft,nt,Ff,Nf,specteSA) * end if else call MULTFN(Ft,Nt,Fc,Nc,vn,nvn) * if (pg .eq. 0) then * call SPCEST(us,nus,Fs,Ns,ONE,1,vn,nvn,Ff,Nf,specteSA) * end if end if call getSpectrum(thadj,nthadj,chcyc,nchcyc,spectSA) do i=1,Lspect spectSA(i)=varwna*spectSA(i)/(2.0D0*pi) enddo if (IsCloseToTD) then call MULTFN(us,nus,Fs,Ns,Dum1,Ndum1) call MULTFN(dum1,nDum1,Fc,Nc,Dum,Ndum) else call MULTFN(us,nus,Fs,Ns,Dum,Ndum) end if do i = 1,Nf Dum1(i) = Ff(i) end do Ndum1 = Nf Ifunc = 5 do i = 0,120 x = (ONE/120.0d0) * pi * i arg = FUNC0(x) y(i+1) = arg if (sqg .eq. 1) then y(i+1) = y(i+1)**2 end if end do C C GC 08/07/98 if (d.ne.0 .or. bd.ne.0) then y(1) = ONE end if * if ((pg.eq.0) .and. (out.eq.0).and.(iter.eq.0)) then * fname = 'FILTFADJ.T4F' * if (sqg .eq. 1) then * subtitle = 'SQUARED GAIN OF SA SERIES FILTER' * else * subtitle = 'FILTER for TREND-CYCLE (F.D.)' * end if * call PLOTFILTERS(fname,subtitle,y,121,mq,ZERO,pi,1) * end if end if end if C C added by DEKM Feb 6 2003 to compute trend adjusted component varwnt = ZERO if (npscyc.ne.1 .or. ncycth.ne.0) then if (nchi .eq. 1) then do i = 1,qstar thtra(i) = thstar(i) end do do i = qstar+1,npscyc thtra(i) = ZERO end do nthtra = MAX(qstar,npscyc) varwnt = ONE else C C C FIND MA REPRESENTATION OF TREND ADJUSTED SERIES C call CONJ(pscyc,npscyc,pscyc,npscyc,us,nus) do i = 1,nus us(i) = us(i) * qt1 end do C C.. Modified by REG on 12/22/2005 if (npsi .ne. 1) then call CONV(thets,nthets,cyc,ncyc,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwns,us,nus) end if if (ncycth.ne.0 .or. ncyc.ne.1) then call CONV(thetc,nthetc,psi,npsi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwnc,us,nus) end if iout = 1 if (out .eq. 1) then 7138 format ( $ //,4x,' MA ROOTS OF TREND ADJUSTED SERIES'/,4x, $ ' --------------------------------------') write (Nio,7138) iout = 0 end if c Here we do spectral factorization to get trend adjusted numerator (thtra) c comment added DEKM 20 Feb 03 caption0=' ' call MAK1(us,nus,thtra,nthtra,varwnt,nounit,iout,caption0,0, & toterr) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK call CONJ(thtra,nthtra,thtra,nthtra,vn,nvn) if (nus .ne. nvn) then 7034 format ( $ /,' ','THE LENGTH OF THE MA DOESN''T MATCH WITH THE ACF') write (Nio,7034) end if toterr = ZERO do i = 1,nvn toterr = toterr + (vn(i)*varwnt-us(i))**2 end do dvec(1)=toterr call USRENTRY(dvec,1,1,1,1,1903) if (toterr .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if if (out .eq. 1) then 7035 format (/,5x,'TOTAL SQUARED ERROR=',d15.7) write (Nio,7035) toterr end if end if else nthtra=1 thtra(1)=1D0 end if C C added by DEKM 1 May 2003 to compute cycle adjusted component C C varwca = ZERO if (nchpsi.ne.1 .or. ncycth.ne.0) then C.. Modified by REG on 12/22/2005 if ((ncyc .eq. 1) .and. (ncycth. eq. 0)) then do i = 1,qstar thcya(i) = thstar(i) end do do i = qstar+1,nchpsi thcya(i) = ZERO end do nthcya = MAX(qstar, nchpsi) varwca = ONE else C C C FIND MA REPRESENTATION OF CYCLE ADJUSTED SERIES C call CONJ(chpsi,nchpsi,chpsi,nchpsi,us,nus) do i = 1,nus us(i) = us(i) * qt1 end do C if (nchi .ne. 1) then call CONV(thetp,nthetp,psi,npsi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwnp,us,nus) end if C.. Modified by REG on 12/22/2005 if (npsi.ne.1) then call CONV(thets,nthets,chi,nchi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) C C.. Modified by REG on 12/22/2005 call ADDJ(us,nus,ONE,Dum,NDum,varwns,us,nus) end if iout = 1 if (out .eq. 1) then 9980 format ( $ //,4x,' MA ROOTS OF CYCLE ADJUSTED SERIES'/,4x, $ ' --------------------------------------') write (Nio,9980) iout = 0 end if c Here we do spectral factorization to get cycle adjusted numerator (thcya) c comment added DEKM 20 Feb 03 caption0=' ' call MAK1(us,nus,thcya,nthcya,varwca,nounit,iout,caption0,0, & toterr) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK call CONJ(thcya,nthcya,thcya,nthcya,vn,nvn) if (nus .ne. nvn) then write (Nio,7034) end if C.. Modified by REG on 12/22/2005 toterr = ZERO do i = 1,nvn toterr = toterr + (vn(i)*varwca-us(i))**2 end do dvec(1)=toterr call USRENTRY(dvec,1,1,1,1,1903) if (toterr .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if if (out .eq. 1) then write (Nio,7035) toterr end if C C C GC 08/07/98 c if (d.ne.0 .or. bd.ne.0) then c y(1) = hs c end if c if (pg .eq. 0) then c fname = 'SPECTSA.T3' c subtitle = 'SPECTRUM SA SERIES' c call PLOTSPECTRUM(fname,subtitle,y,300,600/mq,hs) c end if c call MULTFN(us,nus,Fs,Ns,Dum,Ndum) c do i = 1,Nf c Dum1(i) = Ff(i) c end do c Ndum1 = Nf c Ifunc = 5 c do i = 1,120 c x = (ONE/120.0d0) * pi * i c arg = F(x) c y(i) = arg c if (sqg .eq. 1) then c y(i) = y(i)**2 c end if c end do C C GC 08/07/98 c if (d.ne.0 .or. bd.ne.0) then c y(1) = ONE c end if c if ((pg.eq.0) .and. (out.eq.1)) then c fname = 'FILTFADJ.T4F' c if (sqg .eq. 1) then c subtitle = 'SQUARED GAIN OF SA SERIES FILTER' c else c subtitle = 'FILTER for TREND-CYCLE (F.D.)' c end if c call PLOTFILTERS(fname,subtitle,y,120,240/mq,ZERO) c end if end if end if C OUTPUT COMPONENTS C c rober if ((noadmiss.eq.-1).or.(noadmiss.eq.1) .or. (noadmiss.eq.2) & .or. (noadmiss.eq.0).and. (noserie.eq.1)) then c call WriteLinCompMatrix() inquire(file=Cursrs(1:Nfilcr)//'.sum',opened=IsOpen) if (isopen) then if (varwna.gt.1.0d-20) then c trend-cycle model if (nchis.gt.1) then if (chis(2).gt.0) then write(lu61,'(''(1 +'',f5.2,''B'')') chis(2) else write(lu61,'(''(1 -'',f5.2,''B'')') abs(chis(2)) end if do i=3, nchis if (chis(i).gt.0) then write(lu61,'(A,'' +'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),chis(i),i-1 else write(lu61,'(A,'' -'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),abs(chis(i)),i-1 end if end do lu61=lu61(1:istrlen(lu61))//') ' end if if (bd+d.gt.0) then if (bd+d.eq.1) then lu61=lu61(1:istrlen(lu61))//' (1-B)' else write(lu61,'(A,''(1-B)^'',i1)') & lu61(1:istrlen(lu61)),bd+d end if end if lu61=lu61(1:istrlen(lu61))//' p(t) = ' if (nthetp.gt.1) then if (thetp(2).gt.0) then write(lu61,'(A,'' (1 +'',f5.2,''B'')') & lu61(1:istrlen(lu61)),thetp(2) else write(lu61,'(A,'' (1 -'',f5.2,''B'')') & lu61(1:istrlen(lu61)),thetp(2) end if do i=3, nthetp if (thetp(i).gt.0) then write(lu61,'(A,'' +'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),thetp(i),i-1 else write(lu61,'(A,'' -'',f5.2,''B^'',i1)') & lu61(1:istrlen(lu61)),abs(thetp(i)),i-1 end if end do lu61=lu61(1:istrlen(lu61))//')' end if lu61=lu61(1:istrlen(lu61))//' ap(t), ap(t)~N(0,' write(lu61,'(A,G12.4)') lu61(1:istrlen(lu61)),varwnp*sqf*sqf lu61=lu61(1:istrlen(lu61))//') niid' end if c seasonal model lu62=' ' nsaltos=0 if (varwns.gt.1.0d-20) then if (npsis.gt.1) then if (psis(2) .gt.0) then write(lu62,'(''(1 +'',f5.2,''B'')') psis(2) else write(lu62,'(''(1 -'',f5.2,''B'')') abs(psis(2)) end if do i=3, min(10,npsis) if (psis(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i1)') & lu62(1:istrlen(lu62)),psis(i),i-1 else write(lu62,'(A,'' -'',f5.2,''B^'',i1)') & lu62(1:istrlen(lu62)),abs(psis(i)),i-1 end if end do do i=11, npsis if ((istrlen(lu62)+11-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (psis(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),psis(i),i-1 else write(lu62,'(A,'' -'',f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),abs(psis(i)),i-1 end if end do lu62=lu62(1:istrlen(lu62))//')' end if if ((istrlen(lu62)+10-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (bd.gt.0) then lu62=lu62(1:istrlen(lu62))//' S s(t) = ' else lu62=lu62(1:istrlen(lu62))//' s(t) = ' end if if (nthets.gt.1) then if ((istrlen(lu62)+11-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (thets(2) .gt.0) then write(lu62,'(A,'' (1 +'',f5.2,''B'')') & lu62(1:istrlen(lu62)),thets(2) else write(lu62,'(A,'' (1 -'',f5.2,''B'')') & lu62(1:istrlen(lu62)),abs(thets(2)) end if do i=3,min(10,nthets) if ((istrlen(lu62)+10-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (thets(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i1)') & lu62(1:istrlen(lu62)),thets(i) ,i-1 else write(lu62,'(A," -"f5.2,"B^",i1)') & lu62(1:istrlen(lu62)),abs(thets(i)) ,i-1 end if end do do i=11,nthets if ((istrlen(lu62)+11-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) nsaltos=nsaltos+1 end if if (thets(i) .gt.0) then write(lu62,'(A,'' +'',f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),thets(i) ,i-1 else write(lu62,'(A,'' -''f5.2,''B^'',i2)') & lu62(1:istrlen(lu62)),abs(thets(i)) ,i-1 end if end do lu62=lu62(1:istrlen(lu62))//')' end if lu62=lu62(1:istrlen(lu62))//' as(t),' if ((istrlen(lu62)+24-nsaltos*130).gt.130) then lu62=lu62(1:istrlen(lu62))//char(10) end if write(lu62,'(A,'' as(t)~N(0,'',G13.6)') & lu62(1:istrlen(lu62)),varwns*sqf*sqf lu62=lu62(1:istrlen(lu62))//') niid' end if c seasonally adjusted lu63=' ' nsaltos=0 if (varwna.gt.1.0d-20) then if (nadjs.gt.1) then if (adjs(2).gt.0) then write(lu63,'(''(1 +'',f5.2,''B'')') adjs(2) else if (adjs(2).lt.0) then write(lu63,'(''(1 -'',f5.2,''B'')') abs(adjs(2)) else write(lu63,'(''(1'')') end if do i=3, nadjs if (adjs(i).gt.0) then write(lu63,'(A,'' +'',f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),adjs(i),i-1 else if (adjs(i).lt.0) then write(lu63,'(A,'' -''f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),abs(adjs(i)),i-1 end if end do lu63=lu63(1:istrlen(lu63))//')' end if if (bd+d.gt.0) then if (bd+d.eq.1) then lu63=lu63(1:istrlen(lu63))//' (1-B)' else lu63=lu63(1:istrlen(lu63))//' (1-B)^' write(lu63,'(A ,i1)') lu63(1:istrlen(lu63)), bd+d end if end if lu63=lu63(1:istrlen(lu63))//' n(t) = ' if (nthadj.gt.1) then if (thadj(2).gt.0) then write(lu63,'(A,'' (1 +'',f5.2,''B'')') & lu63(1:istrlen(lu63)),thadj(2) else if (thadj(2).lt.0) then write(lu63,'(A,'' (1 -'',f5.2,''B'')') & lu63(1:istrlen(lu63)),abs(thadj(2)) else write(lu63,'(A,'' (1'')')lu63(1:istrlen(lu63)) end if do i=3, min(10,nthadj) if ((istrlen(lu63)+10-nsaltos*130).gt.130) then lu63=lu63(1:istrlen(lu63))//char(10) nsaltos=nsaltos+1 end if if (thadj(i).gt.0) then write(lu63,'(A,'' +'',f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),thadj(i),i-1 else if (thadj(i).lt.0) then write(lu63,'(A,'' -''f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),abs(thadj(i)),i-1 end if end do do i=11, nthadj if ((istrlen(lu63)+11-nsaltos*130).gt.130) then lu63=lu63(1:istrlen(lu63))//char(10) nsaltos=nsaltos+1 end if if (thadj(i).gt.0) then write(lu63,'(A,'' +'',f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),thadj(i),i-1 else if (thadj(i).lt.0) then write(lu63,'(A,'' -''f5.2,''B^'',i2)') & lu63(1:istrlen(lu63)),abs(thadj(i)),i-1 end if end do lu63=lu63(1:istrlen(lu63))//')' end if if ((istrlen(lu63)+24-nsaltos*130).gt.130) then lu63=lu63(1:istrlen(lu63))//char(10) end if lu63=lu63(1:istrlen(lu63))//' an(t)' write(lu63,'(A,'', an(t)~N(0,'',G13.6)') & lu63(1:istrlen(lu63)),varwna *sqf*sqf lu63=lu63(1:istrlen(lu63))//') niid' end if c transitorio lu64=' ' nsaltos=0 if (varwnc.gt.1.0d-20) then if (ncycs.gt.1) then if (cycs(2).gt.0) then write(lu64,'(''(1 +'',f5.2,''B'')') cycs(2) else if (cycs(2).lt.0) then write(lu64,'(''(1 -'',f5.2,''B'')') abs(cycs(2)) else write(lu64,'(''(1 '')') end if do i=3, ncycs if (cycs(i).gt.0) then write(lu64,'(A,'' +'',f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),cycs(i),i-1 else if (cycs(i).lt.0) then write(lu64,'(A,'' -'',f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),cycs(i),i-1 end if end do lu64=lu64(1:istrlen(lu64))//')' end if lu64=lu64(1:istrlen(lu64))//' c(t) = ' if (nthetc.gt.1) then if (thetc(2).gt.0) then write(lu64,'(A,'' (1 +'',f5.2,''B'')') & lu64(1:istrlen(lu64)),thetc(2) else if (thetc(2).lt.0) then write(lu64,'(A,'' (1 -'',f5.2,''B'')') & lu64(1:istrlen(lu64)),abs(thetc(2)) else write(lu64,'(A,'' (1'')') lu64(1:istrlen(lu64)) end if do i=3, min(10,nthetc) if ((istrlen(lu64)+11-nsaltos*130).gt.130) then lu64=lu64(1:istrlen(lu64))//char(10) nsaltos=nsaltos+1 end if if (thetc(i).gt.0) then write(lu64,'(A,'' +'',f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),thetc(i),i-1 else if (thetc(i).lt.0) then write(lu64,'(A,'' -'',f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),abs(thetc(i)),i-1 end if end do do i=11, nthetc if ((istrlen(lu64)+12-nsaltos*130).gt.130) then lu64=lu64(1:istrlen(lu64))//char(10) nsaltos=nsaltos+1 end if if (thetc(i).gt.0) then write(lu64,'(A,'' +'',f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),thetc(i),i-1 else if (thetc(i).lt.0) then write(lu64,'(A,'' -''f5.2,''B^'',i2)') & lu64(1:istrlen(lu64)),abs(thetc(i)),i-1 end if end do lu64=lu64(1:istrlen(lu64))//')' end if lu64=lu64(1:istrlen(lu64))//' ac(t),' if ((istrlen(lu64)+24-nsaltos*130).gt.130) then lu64=lu64(1:istrlen(lu64))//char(10) end if write(lu64,'(A,'' ac(t)~N(0,'',G13.6)') & lu64(1:istrlen(lu64)),varwnc*sqf*sqf lu64=lu64(1:istrlen(lu64))//') niid' end if lu64I=' ' if (qt1.gt.1.0d-20) then write(lu64I,'("u(t) = N(0,",G13.6)') qt1*sqf*sqf lu64I=lu64I(1:istrlen(lu64I))//') niid' end if else inquire(61,opened=IsOpen) if (Isopen) then write (auxS,'(i2)') bd+d do i=2, nchis write (auxS,'(A,4x,f5.2)') auxS(1:istrlen(auxS)),chis(i) end do do i=nchis+1,17 write (auxS,'(A,4x,i5)') auxS(1:istrlen(auxS)),0 end do do i=2, nthetp write (auxS,'(A,4x,f5.2)') auxS(1:istrlen(auxS)),thetp(i) end do do i=nthetp+1,8 write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end do write (61,'(A,x,A,5x,G13.6)') buffS(1:27), $ auxS(1:istrlen(auxS)),varwnp end if inquire(63,opened=IsOpen) if (Isopen) then write (auxS,'(i2)') d+bd do i=2, nadjs write (auxS,'(A,4x,f5.2)') auxS(1:istrlen(auxS)),adjs(i) end do do i=nadjs+1,17 if (i.gt.10) then write (auxS,'(A,4x,i5)') auxS(1:istrlen(auxS)),0 else write (auxS,'(A,4x,i5)') auxS(1:istrlen(auxS)),0 endif end do do i=2, nthadj if (i .gt. 10) then write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thadj(i) else write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thadj(i) end if end do do i=nthadj+1,18 if (i .gt. 10) then write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 else write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end if end do write(63,'(A,x,A,3x,G13.6)') buffS(1:27), $ auxS(1:istrlen(auxS)),varwna end if c inquire(62,opened=IsOpen) if (Isopen) then write (auxS,'(i2)') bd do i=2, npsis if (i .gt. 10) then write (auxS,'(A,4x,f5.2)') auxS(1:istrlen(auxS)),psis(i) else write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),psis(i) end if end do do i=npsis+1,15 if (i .gt. 10) then write (auxS,'(A,4x,i5)') auxS(1:istrlen(auxS)),0 else write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end if end do do i=2, nthets if (i .gt. 10) then write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thets(i) else write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thets(i) end if end do do i=nthets+1,26 if (i .gt. 10) then write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 else write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end if end do write (62,'(A,x,A,3x,G13.6)') buffS(1:27), $ auxS(1:istrlen(auxS)),varwns end if c inquire(64,opened=IsOpen) if (Isopen) then write (auxS,'(A)') ' ' do i=2, ncycs write (auxS,'(A,4x,f5.2)') auxS(1:istrlen(auxS)),cycs(i) end do do i=ncycs+1,16 write (auxS,'(A,4x,i5)') auxS(1:istrlen(auxS)),0 end do do i=2, nthetc write (auxS,'(A,3x,f5.2)') auxS(1:istrlen(auxS)),thetc(i) end do do i=nthetc+1,16 write (auxS,'(A,3x,i5)') auxS(1:istrlen(auxS)),0 end do write (64,'(A,A,3x,G13.6,6x,f12.6)') $ buffS(1:27),auxS(1:istrlen(auxS)),varwnc,qt1 end if end if end if IF(Lsgud)call ShowComp(out,buff2,nio, $ chi,nchi,thetp,nthetp,varwnp, $ psi,nPSI,thets,nthets,varwns, $ ncycth,cyc,ncyc,thetc,nthetc,varwnc,qt1, $ chcyc,nchcyc,thadj,nthadj,varwna,svudg) end cc c cc subroutine ShowInvalDecomp(Out,nio,buff2, $ chi,nchi,enot,psi,npsi,estar, $ cyc,ncyc,ncycth,enoc, $ chcyc,nchcyc,thstar,qstar,qt1,Lsgud, $ IsCloseToTD,svudg) implicit none include 'srslen.prm' include 'dimensions.i' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c----------------------------------------------------------------------- include 'func.i' include 'func2.i' include 'func3.i' include 'error.cmn' c INPUT PARAMETERS integer Out,nio,nchi,npsi, $ ncyc,ncycth,nchcyc,qstar real*8 chi(8),cyc(17),chcyc(20),thstar(Qstar), $ qt1,psi(27),enot,estar,enoc logical Lsgud,IsCloseToTD,svudg c LOCAL PARAMETERS integer Noprint,nthetp,nthets,nthetc,nthadj,nus,i real*8 thetp(8),varwnp,thets(27),varwns,vf(27),ucf(32), $ thetc(32),varwnc,thadj(32),varwna,us(50),utf(8) character buff2*80 c ------------------------------------------ if (nchi .ne. 1) then Ut(Nt) = ZERO Nut = Nt do i = 1,Nut utf(i) = Ut(i) - enot*Ft(i) end do end if if (npsi .ne. 1) then V(Ns) = ZERO do i = 1,Ns vf(i) = V(i) - estar*Fs(i) end do end if if (ncycth.ne.0 .or. ncyc.ne.1) then if (ncycth .eq. 0) then do i=Nuc+1,Nc Uc(i) = ZERO end do Nuc = Nc else do i = Nc+1,Nuc Fc(i) = ZERO end do Nc = Nuc end if do i = 1,Nuc ucf(i) = Uc(i) - enoc*Fc(i) end do end if if (out.eq.0) then Noprint=0 else Noprint=1 end if c Noprint=1 call MAspectrum(Noprint,nio,buff2, $ chi,nchi,utf,nut,thetp,nthetp,varwnp, $ npsi,vf,ns,thets,nthets,varwns, $ cyc,ncyc,ncycth,ucf,nuc,thetc,nthetc,varwnc, $ chcyc,nchcyc,thstar,qstar,thadj,nthadj,varwna, $ us,nus,qt1,IsCloseToTD) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK buff2='NO ADMISSIBLE' IF(Lsgud)call ShowComp(out,buff2,nio, $ chi,nchi,thetp,nthetp,varwnp, $ psi,nPSI,thets,nthets,varwns, $ ncycth,cyc,ncyc,thetc,nthetc,varwnc,qt1, $ chcyc,nchcyc,thadj,nthadj,varwna,svudg) end cc c cc subroutine ShowComp(out,buff2,nio, $ chi,nchi,thetp,nthetp,varwnp, $ psi,nPSI,thets,nthets,varwns, $ ncycth,cyc,ncyc,thetc,nthetc,varwnc,qt1, $ chcyc,nchcyc,thadj,nthadj,varwna,svudg) implicit none c----------------------------------------------------------------------- real*8 ONE,ZERO parameter(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'units.cmn' INCLUDE 'error.cmn' * include 'indhtml.i' include 'transcad.i' INCLUDE 'hiddn.cmn' c----------------------------------------------------------------------- c INPUT PARAMETERS integer out,nio,nchi,nthetp,nPSI,nthets, $ ncycth,ncyc,nthetc,nchcyc,nthadj character buff2*80 real*8 chi(8),thetp(8),varwnp,psi(27),thets(27),varwns,dvec(1), $ cyc(17),thetc(32),varwnc,chcyc(20),thadj(32),varwna,qt1 logical svudg c LOCAL PARAMETERS integer i c--------------------------------- if (out .eq. 0) then if (buff2(8:8) .eq. ' ') then write (Nio,'(/6x,''DERIVATION OF THE COMPONENT MODELS :'', $ 2x,a)')buff2 else write (Nio, $'(/6x,''DERIVATION OF THE COMPONENT MODELS :'',/,10x,''"'',a, $''"'')') buff2 end if c roberto: c ¡¡¡¡continuar por aqui 7039 format ( $ ///,/,' ',20x,'MODELS FOR THE COMPONENTS',/,21x,25('-'),///) write (Nio,7039) if (nchi .ne. 1) then 7040 format (///,' TREND-CYCLE NUMERATOR (MOVING AVERAGE POL.)') write (Nio,7040) write (Nio,7053) (thetp(i), i = 1,nthetp) 7041 format (' TREND-CYCLE DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7041) write (Nio,7053) (chi(i), i = 1,nchi) 7042 format (' INNOV. VAR. (*)',f12.6) write (Nio,7042) varwnp write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') CALL USRENTRY(THETP,1,nthetp,1,8,2001) CALL USRENTRY(chi,1,nchi,1,8,2002) dvec(1)=varwnp call USRENTRY(dvec,1,1,1,1,2003) IF(varwnp.gt.ONE.or.varwnp.lt.ZERO)THEN IF(varwnp.gt.ONE)THEN WRITE (Nio,9000)' ','trend','greater than one','.',' ','.' WRITE (Mt2,9000)' ','trend','greater than one','.',' ','.' ELSE WRITE (Nio,9000)' ','trend','less than zero','.',' ','.' WRITE (Mt2,9000)' ','trend','less than zero','.',' ','.' END IF Lfatal=.true. if (Lsumm.gt.0.and.svudg) THEN WRITE(Nform,9001)'seatsadj: no' svudg=.false. END IF RETURN END IF 9000 FORMAT(/,a,'The innovation variance of the ',a,' is ',a,',',/, & ' an indication that the model is not suitable for ', & 'signal extraction',a,/, & a,'Examine the arima model used for this ', & 'decomposition for possible unit roots,',/, & ' and try another model',a) 9001 FORMAT(a) END IF end if c resume here at difference number 97 if (npsi .ne. 1) then 7043 format (///,' SEAS. NUMERATOR (MOVING AVERAGE POL.)') write (Nio,7043) write (Nio,7053) (thets(i), i = 1,nthets) 7044 format (' SEAS. DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7044) write (Nio,7053) (psi(i), i = 1,npsi) write (Nio,7042) varwns C LINES OF CODE ADDED FOR X-13A-S : 5 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000 CALL USRENTRY(THETS,1,NTHETS,1,27,2004) CALL USRENTRY(PSI,1,NPSI,1,27,2005) dvec(1)=Varwns call USRENTRY(dvec,1,1,1,1,2006) C END OF CODE BLOCK IF(Varwns.gt.ONE.or.Varwns.lt.ZERO)THEN write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') IF(Varwns.gt.ONE)THEN WRITE (Nio,9000)'seasonal','greater than one' WRITE (Mt2,9000)'seasonal','greater than one' ELSE WRITE (Nio,9000)'seasonal','less than zero' WRITE (Mt2,9000)'seasonal','less than zero' END IF if (Lsumm.gt.0.and.svudg) THEN WRITE(Nform,9001)'seatsadj: no' svudg=.false. END IF Lfatal=.true. RETURN END IF end if if (ncycth.ne.0 .or. ncyc.ne.1) then 7045 format (///,A,' NUMERATOR (MOVING AVERAGE POL.)') write (Nio,7045) transLcad(1:nTransLcad) write (Nio,7053) (thetc(i), i = 1,nthetc) 7046 format (' ',A,' DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7046) transLcad(1:nTransLcad) write (Nio,7053) (cyc(i), i = 1,ncyc) write (Nio,7042) varwnc C LINES OF CODE ADDED FOR X-13A-S : 5 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000 CALL USRENTRY(THETC,1,NTHETC,1,32,2007) CALL USRENTRY(CYC,1,NCYC,1,17,2008) dvec(1)=Varwnc call USRENTRY(dvec,1,1,1,1,2009) C END OF CODE BLOCK IF(Varwnc.gt.ONE.or.Varwnc.lt.ZERO)THEN write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') IF(Varwnc.gt.ONE)THEN WRITE (Nio,9000)'transitory','greater than one' WRITE (Mt2,9000)'transitory','greater than one' ELSE WRITE (Nio,9000)'transitory','less than zero' WRITE (Mt2,9000)'transitory','less than zero' END IF if (Lsumm.gt.0.and.svudg) THEN WRITE(Nform,9001)'seatsadj: no' svudg=.false. END IF Lfatal=.true. RETURN END IF end if c if (smtr .ne. 1) then 7047 format (///,' IRREGULAR') write (Nio,7047) 7048 format (' VAR. (*) ',f12.5) write (Nio,7048) qt1 C LINES OF CODE ADDED FOR X-13A-S : 1 dvec(1)=qt1 call USRENTRY(dvec,1,1,1,1,2010) C END OF CODE BLOCK c end if 7049 format ( $ ///,' SEASONALLY ADJUSTED NUMERATOR ','(MOVING AVERAGE POL.)') write (Nio,7049) write (Nio,7053) (thadj(i), i = 1,nthadj) 7050 format ( $ /,' SEASONALLY ADJUSTED DENOMINATOR (AUTOREGRESSIVE POL.)') write (Nio,7050) write (Nio,7053) (chcyc(i), i = 1,nchcyc) 7053 format (12f11.5) write (Nio,7042) varwna C LINES OF CODE ADDED FOR X-13A-S : 5 c Usrentry routines added by BCM to facilitate saving c models of the components July 2000 CALL USRENTRY(THADJ,1,NTHADJ,1,32,2011) CALL USRENTRY(CHCYC,1,NCHCYC,1,20,2012) dvec(1)=Varwna call USRENTRY(dvec,1,1,1,1,2013) C END OF CODE BLOCK C C IF(Varwna.gt.ONE.or.Varwna.lt.ZERO)THEN write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') IF(Varwna.gt.ONE)THEN WRITE (Nio,9000)'seasonal adjustment','greater than one' WRITE (Mt2,9000)'seasonal adjustment','greater than one' ELSE WRITE (Nio,9000)'seasonal adjustment','less than zero' WRITE (Mt2,9000)'seasonal adjustment','less than zero' END IF if (Lsumm.gt.0.and.svudg) THEN WRITE(Nform,9001)'seatsadj: no' svudg=.false. END IF Lfatal=.true. RETURN END IF write (Nio,'(/,2X,''(*) IN UNITS OF VAR(A)'')') end cc c cc subroutine MAspectrum(Noprint,nio,buff2, $ chi,nchi,utf,nut,thetp,nthetp,varwnp, $ npsi,vf,ns,thets,nthets,varwns, $ cyc,ncyc,ncycth,ucf,nuc,thetc,nthetc,varwnc, $ chcyc,nchcyc,thstar,qstar,thadj,nthadj,varwna, $ us,nus,qt1,IsCloseToTD) implicit none include 'srslen.prm' include 'dimensions.i' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'error.cmn' c----------------------------------------------------------------------- c INPUT PARAMETERS integer Noprint,nio,nchi,nut,npsi,ns, $ ncyc,ncycth,nuc,nchcyc,qstar real*8 chi(8),utf(8),vf(27),cyc(17),ucf(32),chcyc(20), $ thstar(Qstar),qt1 logical IsCloseToTD c OUTPUT PARAMETERS integer nthetp,nthets,nthetc,nthadj,nus real*8 thetp(8),varwnp,thets(27),varwns,dvec(1), $ thetc(32),varwnc,thadj(32),varwna,us(50) character buff2*80,caption0*(60) c LOCAL PARAMETERS real*8 toterrP,toterrS,toterrC,toterrSA,Dum(80),Vn(80) integer nounit,nDum,nVn,i C **** TREND **** C varwnp = ZERO caption0=' ' if (noprint.ne.1) then write (Nio, $'(///,''FACTORIZATION OF THE MA POLYN FOR THE COMPONENTS'',/, $''-------------------------------------------------'')') end if nounit = 0 if (nchi .ne. 1) then caption0(1:23)='MA ROOTS OF TREND-CYCLE' call MAK1(utf,Nut,thetp,nthetp,varwnp,nounit,Noprint, $ caption0,23,toterrP) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrP call USRENTRY(dvec,1,1,1,1,1900) if (noprint.ne.1) then if (toterrP .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if end if end if C varwns = ZERO if (npsi .ne. 1) then C C **** SEAS. **** C caption0(1:20)='MA ROOTS OF SEASONAL' call MAK1(vf,Ns,thets,nthets,varwns,nounit,noprint, $ caption0,20,toterrS) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrS call USRENTRY(dvec,1,1,1,1,1901) if (noprint.ne.1) then if (toterrS .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if end if end if C varwnc = ZERO if (ncycth.ne.0 .or. ncyc.ne.1) then C C **** CYCLE **** C if (isCloseToTD) then call MAK1(ucf,Nuc,thetc,nthetc,varwnc,nounit,noprint, $ "MA ROOTS OF TD-STOCHASTIC ", $ 25,toterrC) else call MAK1(ucf,Nuc,thetc,nthetc,varwnc,nounit,noprint, $ "MA ROOTS OF TRANSITORY ", $ 22,toterrC) endif C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrC call USRENTRY(dvec,1,1,1,1,1902) if (noprint.ne.1) then if (toterrC .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if end if end if C varwna = ZERO if (nchcyc.ne.1 .or. ncycth.ne.0) then if (npsi .eq. 1) then do i = 1,qstar thadj(i) = thstar(i) end do do i = qstar+1,nchcyc thadj(i) = ZERO end do c nthadj = MAX(qstar,nchcyc) nthadj=qstar varwna = ONE else C C C FIND MA REPRESENTATION OF SEASONALLY ADJUSTED SERIES C if (isCloseToTD) then call CONJ(chi,nchi,chi,nchi,us,nus) else call CONJ(chcyc,nchcyc,chcyc,nchcyc,us,nus) endif do i = 1,nus us(i) = us(i) * qt1 end do do i=nus+1,50 us(i)=0 end do C if (nchi .ne. 1) then if (isCloseToTD) then call CONJ(thetp,nthetp,thetp,nthetp,Dum,Ndum) else call CONV(thetp,nthetp,cyc,ncyc,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) endif do i = 1,Ndum us(i) = us(i) + varwnp*Dum(i) end do nus = MAX(nus,Ndum) end if if (.not. IsCloseToTD) then if (ncycth.ne.0 .or. ncyc.ne.1) then call CONV(thetc,nthetc,chi,nchi,vn,nvn) call CONJ(vn,nvn,vn,nvn,Dum,Ndum) do i = 1,Ndum us(i) = us(i) + varwnc*Dum(i) end do nus = MAX(nus,Ndum) end if end if caption0(1:38)="MA ROOTS OF SEASONALLY ADJUSTED SERIES" call MAK1(us,nus,thadj,nthadj,varwna,nounit,noprint, $ caption0,38,toterrSA) C LINES OF CODE ADDED FOR X-13A-S : 1 IF(Lfatal)RETURN C END OF CODE BLOCK dvec(1)=toterrSA call USRENTRY(dvec,1,1,1,1,1903) if (noprint.ne.1) then if (toterrSA .gt. 1.0d-2) then call setSf('E') buff2 = $ 'THE SPECIFICATION OF SOME OF THE MODELS MAY BE UNRELIABLE' end if end if end if end if if (noprint.eq.0) then if (varwnc.lt.1.0d-10.and.(ncycth.ne.0 .or. ncyc.ne.1)) then call m_vc_is0(nio) end if endif end cc c cc * subroutine PLOTOrigSpectrum(p,d,q,bp,bd,bq,mq,Th,Phi,BTh,BPhi) * implicit none *c----------------------------------------------------------------------- * DOUBLE PRECISION ONE,ZERO * PARAMETER(ONE=1D0,ZERO=0D0) *c----------------------------------------------------------------------- * integer n1,n12,lspect,d,bd * parameter (n12 = 12, n1 = 1,Lspect=300) *c parametros formales * integer p,q,bp,bq,mq * real*8 PHI(3*N1),TH(3*N1),BPHI(3*N1),BTH(3*N1),Output(Lspect) *c locales * real*8 PHIST(2*N12+5),THSTAR(2*N12+3*N1),polDifs(2*N12+3*N1), * $ polAR(2*N12+3*N1),fMA(32),fAR(32) * integer i,j,k,grPhist,grThstar,fMAdim,fARdim,grpolAR,grPolDifs * character fname*30,subtitle*50 *cc * grpolAR = P + Bp*Mq+1 * grthstar = Q + Bq*Mq+1 * do i = 2,2*N12+3*N1 * polAR(i) = ZERO * end do * polAR(1) = ONE * if (P .ne. 0) then * do i = 1,P * polAR(i+1) = -Phi(i) * end do * end if * if (Bp .ne. 0) then * do i = 1,Bp * j = i * Mq+1 * polAR(j) = -Bphi(i) * if (P .ne. 0) then * do k = 1,P * polAR(k+j) = Phi(k)*Bphi(i) * end do * end if * end do * end if *c Los delta (1-B)^d *c * grPolDifs=bd*mq+d+1 * polDifs(1)=1 * do i = 2,2*N12+3*N1 * polDifs(i) = ZERO * end do * if (d.eq.0) then * if (bd.eq.1) then * poldifs(mq+1)=-1 * end if * else if(d.eq.1) then * polDifs(2)=-1 * if (bd.ne.0) then * polDifs(mq+1)=-1 * polDifs(mq+2)=1 * end if * else if (d.eq.2) then * polDifs(2)=-2 * polDifs(3)=1 * if (bd.ne.0) then * polDifs(mq+1)=polDifs(mq+1)-1 * polDifs(mq+2)=2 * polDifs(mq+3)=-1 * end if * end if * do i = 1,2*N12+5 * phist(i)=0 * end do * call CONV(polAR,grpolAR,polDifs,grPolDifs,phist,grPhist) * thstar(1)=ONE * do i = 2,2*N12+3*N1 * Thstar(i) = ZERO * end do * if (Q .ne. 0) then * do i = 1,Q * Thstar(i+1) = -Th(i) * end do * end if * if (Bq .ne. 0) then * do i = 1,Bq * j = i * Mq+1 * Thstar(j) = -Bth(i) * if (Q .ne. 0) then * do k = 1,Q * Thstar(k+j) = Th(k)*Bth(i) * end do * end if * end do * end if *c prueba * call CONJ(thstar,grthstar,thstar,grthstar,fMA,fMAdim) * call CONJ(phist,grPhist,phist,grPhist,fAR,fARdim) * call SPC(fMA,fMAdim,fAR,fARdim,1.d0,Output) *cdos * fname='MODEL\\SPECT.T3' *cunix *cunix fname='MODEL/SPECT.T3' * subtitle='SPECTRUM MODEL SERIES' * call PlotSpectrum(fname,subtitle,Output,dble(Lspect),mq,1.5d0,1) * end cc c cc logical function TDSpectCrit(pico) implicit none character pico(7)*2 if (pico(7).eq.'AT') then TDSpectCrit=.true. else TDSpectCrit=.false. end if end cc c cc integer function ResidualSeasTest(d,bd,crQS,crSNP,crpicos,nz, $ sa,picSA,totalSeasSA,mq,imprimir,nio) implicit none C.. Parameters .. INCLUDE 'srslen.prm' INCLUDE 'dimensions.i' integer mq,nz,imprimir,nio,d,bd,totalSeasSA character picSA(7)*2 real*8 sa(mpkp) c c variables locales real*8 aux(mpkp),QS,SNP,media,dvec(1) integer i,k,OverTest,crQs,crSNP,crpicos,ndif,j c funciones llamadas logical SeasSpectCrit2 real*8 calcQS3,kendalls external SeasSpectCrit2,calcQS3,kendalls c OverTest=0 ndif=max(min(2,d+bd),1) do i=1,nz aux(i)=sa(i) end do k=nz do j=1,ndif k=k-1 do i=1,k aux(i)=aux(i+1)-aux(i) end do end do media=0 do i=1,k media=media+aux(i) end do media=media/k do i=1,k aux(i)=aux(i)-media end do * QS=calcQS(aux,nz,mq) * SNP=kendalls(aux,nz,mq) QS=calcQS3(aux,k,mq) SNP=kendalls(aux,k,mq) if (QS.gt.9.21d0) then OverTest=OverTest+1 crQs=1 else crQS=0 end if if (SNP.gt.24.73d0.and.mq.eq.12.or. $ SNP.gt.11.35d0.and.mq.eq.4) then OverTest=OverTest+1 crSNP=1 else crSNP=0 end if if (seasSpectCrit2(picSA,mq)) then OverTest=OverTest+1 crpicos=1 else crpicos=0 end if if (imprimir.gt.0) then call WrResidSeasTest(OverTest,crQs,crSNP,crpicos,nio) end if ResidualSeasTest=OverTest dvec(1)=float(OverTest) call usrentry(dvec,1,1,1,1,1604) return end cc c cc subroutine WrResidSeasTest(OST,crQs,crSNP,crPeaks,nio) implicit none integer OST,crQs,crSNP,crPeaks,nio c character spicos*3,sqs*3,sSNP*3 c if (crQS.eq.1) then sQs='YES' else sQS='NO ' end if if (crSNP.eq.1) then sSNP='YES' else sSNP='NO ' end if if (crPeaks.eq.1) then spicos='YES' else spicos='NO ' end if write(nio,*) write(nio,*) write(nio,'("Overall test for residual seasonality ")') write(nio,*) write(nio,*) write(nio,'('' Autocorrelation function evidence : '',A3)') sQs write(nio,'('' Non-parametric evidence'',11x,'': '',A3)') sSNP write(nio,'('' Spectral evidence'',17x,'': '',A3)') sPicos write(nio,*) If (OST .gt.1) then write(nio,'('' Residual seasonality detected in '', $ ''seasonally adjusted series'')') else if (OST .eq.1) then write(nio,'(" Mild evidence of residual seasonality ", $ "detected in seasonally adjusted series")') else write(nio,'('' No residual seasonality detected in '', $ ''seasonally adjusted series'')') end if end C C C THIS SUBROUTINE CALCULATES C,THE SUM OF D1*A(Z) AND D2*B(Z) C C INPUT PARAMETER C A : FIRST POLYNOMIAL (true signs) A(1) + A(2)*COS(W) + ... + C A(MPLUS1)*COS((MPLUS1-1)*W) C MPLUS1 : DIMENSION OF A C B : SECOND POLYNOMIAL (true signs) " " " " C NPLUS1 : DIMENSION OF B C C : SUM OF A + B (true signs) " " " " C LPLUS1 : DIMENSION OF C C C This subroutine added by REG on 12/22/2005 C subroutine ADDJ(a,mplus1,d1,b,nplus1,d2,c,lplus1) C C.. Implicits .. implicit none C C.. Formal Arguments .. C.. In/Out Status: Maybe Read, Maybe Written if c=a or c=b real*8 a(*), b(*) C.. In/Out Status: Read, Maybe Written if lplus1=mplus1 or lplus1=nplus1 integer mplus1, nplus1 C.. In/Out Status: Maybe Read if c=a or c=b, Written .. real*8 c(*) C.. In/Out Status: Not Read, Overwritten .. integer lplus1 C.. In/Out Status: Read .. real*8 d1, d2 C C.. Local Scalars .. integer i,j,k,num C C.. Intrinsic Functions .. intrinsic MAX, MIN C C ... Executable Statements ... C C Add the common part of the polynomials if (min(mplus1,nplus1) .gt. 0) then do i=1,min(mplus1,nplus1) c(i) = d1*a(i)+d2*b(i) end do end if C C For degree of A > degree of B if (mplus1 .gt. nplus1) then do i=nplus1+1,mplus1 c(i)=d1*a(i) end do C C For degree of A V degree of B else if (mplus1 .lt. nplus1) then do i=mplus1+1,nplus1 c(i)=d2*b(i) end do end if C C Set length=degree+1 of C lplus1=max(mplus1,nplus1) return end spectrum.i0000664006604000003110000000014014521201571012176 0ustar sun00315stepsc Spectrum.i integer Lspect,SPECLENGTH parameter (Lspect=300,SPECLENGTH=120) spe.i0000664006604000003110000000013114521201571011123 0ustar sun00315stepsC C... Variables in Common Block /spe/ ... real*8 QT1 common /spe/ QT1 spgrh2.f0000664006604000003110000000411014521201572011540 0ustar sun00315steps SUBROUTINE spgrh2(X,Sxx,Frq,N1,N2,Nspfrq,Ldecbl) IMPLICIT NONE c----------------------------------------------------------------------- c Routine to compute the periodogram (stored in Sxx) of a series X c at frequencies Frq. The starting and ending pointers of the c series are given in N1 and N2 c----------------------------------------------------------------------- c Programmed by Brian C. Monsell, April 1996 c----------------------------------------------------------------------- C INCLUDE 'srslen.prm' c----------------------------------------------------------------------- DOUBLE PRECISION PI,TEN,ZERO,TWO PARAMETER(PI=3.14159265358979D0,TWO=2D0,TEN=10D0,ZERO=0D0) c----------------------------------------------------------------------- c replace dimension length for x (BCM May 2007) DOUBLE PRECISION X,Sxx,Frq,sumc,sums INTEGER i,j,k,N1,N2,n,Nspfrq LOGICAL Ldecbl DIMENSION X(*),Sxx(*),Frq(*) c----------------------------------------------------------------------- c compute number of observations c----------------------------------------------------------------------- n=N2-N1+1 c----------------------------------------------------------------------- c begin loop for frequencies by initialzing sum to zero c----------------------------------------------------------------------- DO i=1,Nspfrq sumc=ZERO sums=ZERO c----------------------------------------------------------------------- c loop over all the observations to calculate sumx c New algorithm out of Shumway's book c----------------------------------------------------------------------- DO j=N1,N2 k=j-N1 sumc=sumc+X(j)*DCOS(TWO*PI*Frq(i)*k) sums=sums+X(j)*DSIN(TWO*PI*Frq(i)*k) END DO sumc=sumc/sqrt(dble(n)) sums=sums/sqrt(dble(n)) Sxx(i)=(sumc*sumc)+(sums*sums) IF(Ldecbl)Sxx(i)=TEN*dlog10(Sxx(i)) END DO c----------------------------------------------------------------------- RETURN END spgrh.f0000664006604000003110000000743314521201572011471 0ustar sun00315steps**==spgrh.f processed by SPAG 4.03F at 10:39 on 20 Oct 1994 SUBROUTINE spgrh(Yy,Sxx,Frq,Thtapr,N1,N2,Nspfrq,Ny,Mxarsp, & Ldecbl,Good) IMPLICIT NONE c----------------------------------------------------------------------- C*** Start of declarations inserted by SPAG c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' c----------------------------------------------------------------------- DOUBLE PRECISION PI,ZERO,ONE,TEN PARAMETER(PI=3.14159265358979D0,ZERO=0D0,ONE=1D0,TEN=10D0) c----------------------------------------------------------------------- LOGICAL Ldecbl,Good DOUBLE PRECISION Yy,Sxx,an,x,y,a,b,cxx,oaic,sgme2,Frq,Thtapr,c2, & s2,dj,pxx INTEGER h,h1,i,ifpl,ifpl1,k,l,lagh,lagh1,n,N1,N2,Nspfrq,Ny,Mxarsp c----------------------------------------------------------------------- C*** End of declarations inserted by SPAG c replace dimension length for yy (BCM May 2007) c----------------------------------------------------------------------- DIMENSION y(PLEN),Yy(*),x(PLEN),cxx(Nspfrq),a(101),b(101),Sxx(*), & Frq(*),pxx(76) c----------------------------------------------------------------------- DOUBLE PRECISION decibl EXTERNAL decibl c----------------------------------------------------------------------- n=N2-N1+1 c----------------------------------------------------------------------- DO i=N1,N2 y(i)=Yy(i) END DO c----------------------------------------------------------------------- h=Nspfrq-1 c----------------------------------------------------------------------- h1=Nspfrq c----------------------------------------------------------------------- DO i=N1,N2 x(i)=y(i) END DO c----------------------------------------------------------------------- C AUTO COVARIANCE COMPUTATION. c----------------------------------------------------------------------- lagh=n-1 lagh=min0(lagh,h) lagh1=lagh+1 CALL sautco(x,cxx,N1,N2,n,lagh1,Thtapr,Good) IF(.not.Good)RETURN an=dble(n) ifpl=idint(3.0D-00*sqrt(an)) c----------------------------------------------------------------------- ifpl=min0(ifpl,50,lagh) c----------------------------------------------------------------------- C ----- 5/15/80 ----- c----------------------------------------------------------------------- IF(Mxarsp.eq.NOTSET)THEN ifpl=30*Ny/12 * ifpl=30 ELSE ifpl=Mxarsp END IF ifpl=min0(ifpl,n-1) c----------------------------------------------------------------------- C ----- 5/15/80 ----- c----------------------------------------------------------------------- ifpl1=ifpl+1 CALL sicp2(cxx,ifpl1,N1,N2,a,l,sgme2,oaic) C k=0 C CALL snrasp(a,b,Sxx,Frq,sgme2,l,k,h1,Ldecbl) c----------------------------------------------------------------------- C ----- 10/1/2010 ----- c----------------------------------------------------------------------- DO i=1,h1 c2=ONE DO k=1,l dj=dble(2*k)*PI*Frq(i) c2=c2+(a(k)*cos(dj)) END DO s2=ZERO DO k=1,l dj=dble(2*k)*PI*Frq(i) s2=s2+(a(k)*sin(dj)) END DO pxx(i)=sgme2/(c2**2 + s2**2) END DO c----------------------------------------------------------------------- IF(Ldecbl)THEN DO i=1,H1 dj=pxx(i) IF(dj.lt.ZERO)dj=-dj Sxx(i)=decibl(dble(dj)) END DO ELSE DO i=1,H1 Sxx(i)=pxx(i) END DO END IF c----------------------------------------------------------------------- RETURN END spmpar.f0000664006604000003110000000432514521201572011645 0ustar sun00315steps**==spmpar.f processed by SPAG 4.03F at 14:31 on 28 Jul 1994 DOUBLE PRECISION FUNCTION spmpar(I) IMPLICIT NONE C----------------------------------------------------------------------- C C SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR C THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT C I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE C SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND C ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN C C SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, C C SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. C C----------------------------------------------------------------------- C WRITTEN BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN VIRGINIA C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE C CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS C MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION C----------------------------------------------------------------------- C .. Scalar Arguments .. INTEGER I C .. C .. Local Scalars .. DOUBLE PRECISION b,binv,bm1,one,w,z INTEGER emax,emin,ibeta,m C .. C .. External Functions .. INTEGER ipmpar EXTERNAL ipmpar C .. C .. Intrinsic Functions .. INTRINSIC dble C .. C .. Executable Statements .. C IF(I.le.1)THEN b=ipmpar(4) m=ipmpar(8) spmpar=b**(1-m) RETURN C ELSE IF(I.le.2)THEN b=ipmpar(4) emin=ipmpar(9) one=dble(1) binv=one/b w=b**(emin+2) spmpar=((w*binv)*binv)*binv RETURN END IF C ibeta=ipmpar(4) m=ipmpar(8) emax=ipmpar(10) C b=ibeta bm1=ibeta-1 one=dble(1) z=b**(m-1) w=((z-one)*b+bm1)/(b*z) C z=b**(emax-2) spmpar=((w*z)*b)*b RETURN END srslen.i0000664006604000003110000000223114521201572011646 0ustar sun00315stepsc----------------------------------------------------------------------- c PLEN is the integer PARAMETER for the maximum length of a c series. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c PFCST i PARAMETER for the maximum number of forecasts c POBS i PARAMETER for the maximum length of the series c PLEN i PARAMETER for the maximum length of the series + back and c forecasts c PYRS i PARAMETER for the maximum number of years in the series + c back and forecasts c PYR1 i PARAMETER for the maximum number of years in the series c PTD i PARAMETER for the number of types of trading day factors c (based on lenght of month, starting period) c PSP - maximum length of seasonal period (formerly in model.cmn) c----------------------------------------------------------------------- INTEGER POBS,PLEN,PFCST,PYR1,PYRS,PSRSCR,PTD,PSP PARAMETER(PSP=12,PFCST=10*PSP,PYR1=65,POBS=PYR1*PSP,PYRS=PYR1+10, & PLEN=POBS+(2*PFCST),PSRSCR=79,PTD=28) srslen.prm0000664006604000003110000000223114521201572012214 0ustar sun00315stepsc----------------------------------------------------------------------- c PLEN is the integer PARAMETER for the maximum length of a c series. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c PFCST i PARAMETER for the maximum number of forecasts c POBS i PARAMETER for the maximum length of the series c PLEN i PARAMETER for the maximum length of the series + back and c forecasts c PYRS i PARAMETER for the maximum number of years in the series + c back and forecasts c PYR1 i PARAMETER for the maximum number of years in the series c PTD i PARAMETER for the number of types of trading day factors c (based on lenght of month, starting period) c PSP - maximum length of seasonal period (formerly in model.cmn) c----------------------------------------------------------------------- INTEGER POBS,PLEN,PFCST,PYR1,PYRS,PSRSCR,PTD,PSP PARAMETER(PSP=12,PFCST=10*PSP,PYR1=65,POBS=PYR1*PSP,PYRS=PYR1+20, & PLEN=POBS+(2*PFCST),PSRSCR=79,PTD=28) ss2rv.cmn0000664006604000003110000000746114521201572011756 0ustar sun00315stepsc----------------------------------------------------------------------- c These variables are all duplicates for other variables that are c changed during the sliding spans and revisions history analysis. c They are used to reset these variables after each span has been c run. c----------------------------------------------------------------------- CHARACTER Cttlrv*(PCOLCR*PB),Gttlrv*(PGRPCR*PGRP), & Cttxrv*(PCOLCR*PB),Gttxrv*(PGRPCR*PGRP) DOUBLE PRECISION Bbrv,Bbxrv,Ap2rv,Tc2rv,V2r,Chx2r,Chg2r,Acm2r, & Dtcv2r,Tcvrv,Svrv,Savrv,Trvrv,Irrvrv INTEGER Clptrv,Ngr2rv,Ngrt2r,Gptrrv,G2rv,Nbbrv,If2rv,Kfm2rv, & Ksw2rv,Ncxy2r,Pri2rv,Atdrv,Aholrv,AAOrv,ALSrv,ATCrv, & Asearv,Acycrv,Ausrrv,Nct2rv,Lt2rv,Rgv2rv,Nr2rv,Ktc2rv, & Nsporv,Lsprv,Ly0rv,Lstyrv,Lyrrv,Bspnrv,Espnrv,Frstrv, & Bmdlrv,Emdlrv,Ixrgrv,Bxrgrv,Exrgrv,Kholrv,Keasrv,Ncus2r, & Nbk2rv,Irfx2r,Iagrrv,A1strv,Bgxyrv,Ngx2rv,Ngrx2r,Nxxy2r, & Nbbxrv,Ncx2rv,Cxptrv,Gx2rv,Gptxrv,Rgvx2r,Nxr2rv,Ncxu2r, & Ifxx2r,Xbxyrv,Nint2r,Next2r,Mxdf2r,Mxar2r,Mxma2r,Asorv, & Ntcnrv,Ntcdrv,Nsnrv,Nsdrv,Nsanrv,Nsadrv,Ntrnrv,Ntrdrv, & Ntcwkr,Nsawkr,Nswkrv,Ntrwkr,Nirwkr LOGICAL Flltdr,Fxarv,Fnholr,FnAOrv,FnLSrv,FnTCrv,Fnusrv,Pktd2r, & Rgfx2r,Lgnxrv,Prtbrv,Ltaorv,Ltlsrv,Lttcrv,Rxfx2r,Lma2r, c & Lar2r,Ltsorv,Htrrv,Hsfrv,Hirrv,Hsarv,Hcyrv,Hftrrv,Hfsfrv, & Lar2r,Htrrv,Hsfrv,Hirrv,Hsarv,Hcyrv,Hftrrv,Hfsfrv, & Hfirrv,Hfsarv,Hfcyrv,Hsftrv,Hsfsrv,Hsforv,Hsfarv,Hsfcrv, & Hrftrv,Hrfsrv,Hrfarv,Hrfcrv,Hstarv,Hstirv,Hsttrv,Hstsrv, & Hstorv,Hstdrv,Hstcrv DIMENSION Ap2rv(PARIMA),Clptrv(0:PB),Gptrrv(0:PGRP),G2rv(0:PGRP), & Bbrv(PB),Bbxrv(PB),Fxarv(PARIMA),Lt2rv(12),Rgv2rv(PB), & Rgvx2r(PB),Bspnrv(2),Espnrv(2),Bmdlrv(2),Emdlrv(2), & Bxrgrv(2),Exrgrv(2),Rgfx2r(PB),Prtbrv(NTBL),Bgxyrv(2), & Rxfx2r(PB),Cxptrv(0:PB),Gx2rv(0:PGRP),Gptxrv(0:PGRP), & Xbxyrv(2),Chx2r(PXPX),Chg2r(PGPG),Acm2r(PLEN+2*PORDER, & PARIMA) c----------------------------------------------------------------------- COMMON /ssrv / Ap2rv,Bbrv,Bbxrv,Chx2r,Chg2r,Tc2rv,V2r,Tcvrv,Svrv, & Savrv,Trvrv,Irrvrv,Acm2r, & Dtcv2r,Iagrrv,Atdrv,Aholrv,AAOrv,ALSrv,ATCrv, & Asorv,Asearv,Acycrv,Ausrrv,Ncxy2r,Nct2rv,Nbbrv, & Ksw2rv,Ncus2r,Ktc2rv,Kfm2rv,If2rv,Lt2rv,Clptrv, & Ngr2rv,Ngrt2r,G2rv,Gptrrv,Rgv2rv,Nr2rv,Pri2rv, & Irfx2r,Ngx2rv,Ngrx2r,Nxxy2r,Nbbxrv,Ncx2rv,Cxptrv, & Gx2rv,Gptxrv,Rgvx2r,Nxr2rv,Ncxu2r,Ifxx2r,Xbxyrv, & Nint2r,Next2r,Mxdf2r,Mxar2r,Mxma2r,Flltdr,Fxarv, & Fnholr,FnAOrv,FnLSrv,FnTCrv,Fnusrv,Rgfx2r,Rxfx2r, & Lma2r,Lar2r,Pktd2r,Cttlrv,Gttlrv,Cttxrv,Gttxrv, & Ntcnrv,Ntcdrv,Nsnrv,Nsdrv,Nsanrv,Nsadrv,Ntrnrv, & Ntrdrv,Ntcwkr,Nsawkr,Nswkrv,Ntrwkr,Nirwkr COMMON /ssrv2 / Nsporv,Lsprv,Nbk2rv,Ly0rv,Lstyrv,Lyrrv, & Bspnrv,Espnrv,Frstrv,Bmdlrv,Emdlrv,Ixrgrv,Bxrgrv, & Exrgrv,Kholrv,Keasrv,A1strv,Bgxyrv,Lgnxrv,Ltaorv, c & Ltlsrv,Lttcrv,Ltsorv,Htrrv,Hsfrv,Hirrv,Hsarv, & Ltlsrv,Lttcrv,Htrrv,Hsfrv,Hirrv,Hsarv, & Hcyrv,Hftrrv,Hfsfrv,Hfirrv,Hfsarv,Hfcyrv,Hsftrv, & Hsfsrv,Hsforv,Hsfarv,Hsfcrv,Hrftrv,Hrfsrv,Hrfarv, & Hrfcrv,Hstarv,Hstirv,Hsttrv,Hstsrv,Hstorv,Hstdrv, & Hstcrv COMMON /ssrvtb/ Prtbrv c----------------------------------------------------------------------- ss2rv.f0000664006604000003110000001473114521201572011424 0ustar sun00315stepsC Last change: BCM 23 Mar 2005 1:33 pm SUBROUTINE ss2rv(Lmodel,Lx11,Lx11rg,Lseats) IMPLICIT NONE c----------------------------------------------------------------------- c Prepare for sliding spans or revision analysis by storing seasonal c adjustment options into temporary variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'agr.cmn' INCLUDE 'adj.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'lzero.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'ssprep.cmn' INCLUDE 'extend.cmn' INCLUDE 'ss2rv.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'xeastr.cmn' INCLUDE 'seatlg.cmn' INCLUDE 'seatmd.cmn' c----------------------------------------------------------------------- INTEGER PACM PARAMETER(PACM=(PLEN+2*PORDER)*PARIMA) c----------------------------------------------------------------------- INTEGER i LOGICAL Lmodel,Lx11,Lx11rg,Lseats c----------------------------------------------------------------------- C **** Store selected options for seasonal adjustment in temporary C **** variables. c----------------------------------------------------------------------- c Store prior adjustment option c----------------------------------------------------------------------- Kfm2rv=Kfm2 Iagrrv=Iagr c----------------------------------------------------------------------- IF(Lx11)THEN DO i=1,12 Lt2rv(i)=Lt2(i) END DO c Lop2=Lopt Ktc2rv=Ktc2 Tc2rv=Tc2 END IF c----------------------------------------------------------------------- IF(Lx11rg)THEN c DO i=1,7 c Dwt2(i)=Dwt(i) c END DO Ksw2rv=Ksw2 c----------------------------------------------------------------------- Ngx2rv=Nxgrp Ngrx2r=Ngrptx Nxxy2r=Nxcxy Nbbxrv=Nbx Ncx2rv=Ncoltx i=PCOLCR*PB Cttxrv(1:i)=Colttx(1:i) i=PGRPCR*PGRP Gttxrv(1:i)=Grpttx(1:i) CALL cpyint(Clxptr(0),PB+1,1,Cxptrv(0)) CALL cpyint(Grpx(0),PGRP+1,1,Gx2rv(0)) CALL cpyint(Gpxptr(0),PGRP+1,1,Gptxrv(0)) CALL cpyint(Rgxvtp,PB,1,Rgvx2r) Nxr2rv=Nxrxy Ncxu2r=Ncxusx Ifxx2r=Irgxfx CALL copylg(Regfxx,PB,1,Rxfx2r) CALL cpyint(Xbegxy,2,1,Xbxyrv) CALL copy(Bx,PB,1,Bbxrv) c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- c **** Store model parameters to be saved in temporary variables c----------------------------------------------------------------------- IF(Lmodel)THEN c----------------------------------------------------------------------- c Reset value of Priadj if reset in tdlom subroutine. c----------------------------------------------------------------------- Pri2rv=Pri2 c----------------------------------------------------------------------- Ngr2rv=Ngrp Ngrt2r=Ngrptl Ncxy2r=Ncxy Nbbrv=Nb Nct2rv=Ncoltl i=PCOLCR*PB Cttlrv(1:i)=Colttl(1:i) i=PGRPCR*PGRP Gttlrv(1:i)=Grpttl(1:i) CALL cpyint(Colptr(0),PB+1,1,Clptrv(0)) CALL cpyint(Grp(0),PGRP+1,1,G2rv(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Gptrrv(0)) CALL cpyint(Rgvrtp,PB,1,Rgv2rv) CALL copy(Arimap,PARIMA,1,Ap2rv) CALL copy(B,PB,1,Bbrv) CALL copylg(Arimaf,PARIMA,1,Fxarv) Nr2rv=Nrxy Ncus2r=Ncusrx Irfx2r=Iregfx CALL copylg(Regfx,PB,1,Rgfx2r) Pktd2r=Picktd Atdrv=Adjtd Aholrv=Adjhol Aaorv=Adjao Alsrv=Adjls Atcrv=Adjtc Asorv=Adjso Asearv=Adjsea Acycrv=Adjcyc Ausrrv=Adjusr Fnholr=Finhol Fnaorv=Finao Fnlsrv=Finls Fntcrv=Fintc Fnusrv=Finusr Flltdr=Fulltd Ltaorv=Ltstao Ltlsrv=Ltstls Lttcrv=Ltsttc * Ltsorv=Ltstso Lma2r=Lma Lar2r=Lar Nint2r=Nintvl Next2r=Nextvl Mxdf2r=Mxdflg Mxar2r=Mxarlg Mxma2r=Mxmalg V2r=Var CALL copy(Chlxpx,PXPX,1,Chx2r) CALL copy(Chlgpg,PGPG,1,Chg2r) CALL copy(Armacm,PACM,1,Acm2r) Dtcv2r=Lndtcv END IF c----------------------------------------------------------------------- Nsporv=Nspobs Nbk2rv=Nbcst2 Lsprv=Lsp Ly0rv=Ly0 Lstyrv=Lstyr Lyrrv=Lyr CALL cpyint(Begspn,2,1,Bspnrv) CALL cpyint(Endspn,2,1,Espnrv) Frstrv=Frstsy CALL cpyint(Begmdl,2,1,Bmdlrv) CALL cpyint(Endmdl,2,1,Emdlrv) Ixrgrv=Ixreg CALL cpyint(Begxrg,2,1,Bxrgrv) CALL cpyint(Endxrg,2,1,Exrgrv) Kholrv=Khol Keasrv=Keastr Lgnxrv=Lgenx CALL copylg(Prttab,NTBL,1,Prtbrv) A1strv=Adj1st CALL cpyint(Begxy,2,1,Bgxyrv) c----------------------------------------------------------------------- IF(Lseats)THEN Htrrv = Havetr Hsfrv = Havesf Hirrv = Haveir Hsarv = Havesa Hcyrv = Havecy Hftrrv = Havftr Hfsfrv = Havfsf Hfirrv = Havfir Hfsarv = Havfsa Hfcyrv = Havfcy * Hfttrv = Hvfttr * Hftsrv = Hvftsf * Hftorv = Hvftor * Hftarv = Hvftsa * Hftcrv = Hvftcy Hsftrv = Hseftr Hsfsrv = Hsefsf Hsforv = Hsefor Hsfarv = Hsefsa Hsfcrv = Hsefcy Hrftrv = Hsrftr Hrfsrv = Hsrfsf Hrfarv = Hsrfsa Hrfcrv = Hsrfcy Hstarv = Hvstsa Hstirv = Hvstir Ntcnrv = Ntcnum Ntcdrv = Ntcden Nsnrv = Nsnum Nsdrv = Nsden Nsanrv = Nsanum Nsadrv = Nsaden Ntrnrv = Ntrnum Ntrdrv = Ntrden Ntcwkr = Ntcwkf Nsawkr = Nsawkf Nswkrv = Nswkf Ntrwkr = Ntrwkf Nirwkr = Nirwkf Tcvrv = Tcvar Svrv = Svar Savrv = Savar Trvrv = Trvar Irrvrv = Irrvar END IF c----------------------------------------------------------------------- RETURN END ssap.cmn0000664006604000003110000000467014521201572011644 0ustar sun00315stepsc----------------------------------------------------------------------- c This common block is used in the sliding spans analysis c----------------------------------------------------------------------- c Ch - character vector with symbols for each sliding spans table c F1 - format for sliding spans table c F2 - format of header for sliding spans table c F3 - format of sliding spans table, E formats c----------------------------------------------------------------------- CHARACTER Ch*(1),F1*(42),F2*(41),F3*(43) c----------------------------------------------------------------------- c Iyr - Year of first sliding span c Im - Month (or quarter) of first sliding span c Nseas - length of seasonal period (12 if monthly, 4 if quarterly) c Lyear - Last year of sliding spans analysis c Lobs - Last month (or quarter) of sliding spans analysis c Ic - position of first sliding spans comparison c Icyr - year of first sliding spans comparison c Icm - month (or quarter) of first sliding spans comparison c Ns1 - Ncol + 1 c Sslen - number of months used in sliding spans analysis c Sslen2 - location of last sliding spans comparison c Ntot - integer vector containing number of observations flagged c for each estimate c Itot - integer vector containing total number of sliding spans c comparisons for each estimate c Itd - Integer indicator variable in sliding spans for TD adj c Ihol - Integer indicator variable in sliding spans that holiday c adjustment has been performed c----------------------------------------------------------------------- INTEGER Itd,Ihol,Iyr,Im,Nsea,Lyear,Lobs,Ns1,Sslen,Sslen2,Ic,Icyr, & Icm,Ntot,Itot,Kount,Indssp,Indcol,Indlen,Nscomp c----------------------------------------------------------------------- c Cut - cutoff values for the sliding spans analysis c----------------------------------------------------------------------- DOUBLE PRECISION Cut c----------------------------------------------------------------------- DIMENSION Cut(NEST,4),Kount(NEST,4),Ntot(NEST),Itot(NEST),Ch(NEST) c----------------------------------------------------------------------- COMMON /sspcmn / Cut,Iyr,Im,Nsea,Lyear,Lobs,Ns1,Sslen,Sslen2,Ic, & Icyr,Icm,Ntot,Itot,Kount,Indssp,Indcol,Indlen, & Nscomp,Itd,Ihol,Ch,F1,F2,F3 ssap.f0000664006604000003110000004377514521201572011325 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 11:22 pm SUBROUTINE ssap(S,Sa,Td,Sfrng,Iagr,Ncol,Nlen,Lsumm,Lyy,Ssdiff, & Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- c ***** main subroutine for the sliding spans analysis. This c ***** subroutine initializes variables and calls subroutines which c ***** generate breakdown tables, a listing of each observation in c ***** each span, and a range analysis of the seasonal factors c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'stdio.i' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'notset.prm' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'dgnsvl.i' INCLUDE 'ssptbl.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'title.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'force.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO LOGICAL T,F PARAMETER(ZERO=0D0,T=.TRUE.,F=.FALSE.) c----------------------------------------------------------------------- LOGICAL Lsaneg,lrange,Lyy,Ssdiff,Lgraf CHARACTER fc*(1),cpobs*(9),upper*(1),eststr*(45),chrarg*(31), & ex*(2) DOUBLE PRECISION c,dmax,S,Sa,Td,yy,Saabav,sabs,dn,Sfrng INTEGER i1,i2,io1,iobs,tagr,l,l0,i,nstr,j,j2,nyears,Lsumm,nyearz, & y,per,narg,nmq,iext,Iagr,n48,Ncol,nqm,isum,ispan,Nlen, & spanvc,fhname DIMENSION c(MXLEN,MXCOL),cpobs(20),dmax(MXLEN,NEST),eststr(NEST), & ex(2*NEST),fc(3),nstr(NEST),per(2*MXCOL),S(MXLEN,MXCOL), & Sa(MXLEN,MXCOL),Sfrng(MXLEN,MXCOL),spanvc(NEST), & Td(MXLEN,MXCOL),y(2*MXCOL),yy(MXLEN,MXCOL) c----------------------------------------------------------------------- INTEGER nblank LOGICAL istrue,dpeq EXTERNAL nblank,istrue,dpeq c----------------------------------------------------------------------- COMMON /addneg/ Saabav,Lsaneg c----------------------------------------------------------------------- CHARACTER SSEDIC*174 INTEGER sseptr,PSSE PARAMETER(PSSE=6) DIMENSION sseptr(0:PSSE) PARAMETER(SSEDIC= &'Seasonal FactorsTrading Day FactorsFinal Seasonally Adjusted Seri &esMonth-to-Month Changes in SA SeriesYear-to-Year Changes in SA Se &riesQuarter-to-Quarter Changes in SA Series') c----------------------------------------------------------------------- DATA sseptr/1,17,36,68,103,136,175/ DATA fc/'2','3','4'/ DATA ex/'a ','ai','b ','bi','c ','ci','d ','di','e ','ei'/ DATA cpobs/'January ','February ','March ','April ', & 'May ','June ','July ','August ','September', & 'October ','November ','December ','First ','Second ', & 'Third ','Fourth ','1st ','2nd ','3rd ', & '4th '/ DATA spanvc/LSSSFS,LSSTDS,LSSSAS,LSSCHS,LSSYCS/ c----------------------------------------------------------------------- l=Im+(Iyr*Nsea)+Nlen-1 Lobs=mod(l,Nsea) IF(Lobs.eq.0)THEN Lobs=Nsea Lyear=(l/Nsea)-1 ELSE Lyear=l/Nsea END IF nyears=Lyear-Iyr+1 Sslen2=Sslen-Nsea+Im Ns1=Ncol+1 nyearz=nyears+Ncol-3 iobs=Im+Nsea-1 io1=1 IF(Nsea.eq.4)io1=2 fhname=STDERR IF(Lquiet)fhname=0 c----------------------------------------------------------------------- c Set variables needed to print out sliding spans tables. c----------------------------------------------------------------------- tagr=0 chrarg='.' narg=1 IF(Iagr.eq.6)THEN tagr=1 chrarg=': Indirect seasonal adjustment.' narg=31 END IF nmq=nblank(Moqu) c----------------------------------------------------------------------- c Set printing of spans output if differences are analyzed c----------------------------------------------------------------------- IF(Ssdiff)THEN IF(.not.Prttab(LSSTDS).AND.(Itd.eq.1).and.tagr.eq.0) & Prttab(LSSTDS)=T IF(.not.Prttab(LSSSFS+tagr))Prttab(LSSSFS+tagr)=T IF(.not.Prttab(LSSSAS+tagr))Prttab(LSSSAS+tagr)=T IF(.not.Prttab(LSSCHS+tagr))Prttab(LSSCHS+tagr)=T IF(.not.Prttab(LSSYCS+tagr).and.Lyy)Prttab(LSSYCS+tagr)=T c IF(Prttab(LSSPCT+tagr))Prttab(LSSPCT+tagr)=F c IF(Prttab(LSSYPC+tagr))Prttab(LSSYPC+tagr)=F IF(Lsumm.gt.0)THEN Savtab(LSSPCT+tagr)=F Savtab(LSSYPC+tagr)=F CALL writln('NOTE: Sliding spans percentages cannot be stored in & a separate diagonstics',Mt2,fhname,T) CALL writln(' file when absolute differences of additive ad &justments are analyzed.',Mt2,fhname,F) END IF IF(Svltab(LSLPCT))THEN CALL writln('NOTE: Sliding spans percentages cannot be saved to &a log file when absolute',Mt2,fhname,T) CALL writln(' differences of additive adjustments are analy &zed.',Mt2,fhname,F) END IF END IF c----------------------------------------------------------------------- c Initialize Ntot (Number of months flagged) to null c----------------------------------------------------------------------- DO i=1,NEST Ntot(i)=NOTSET c----------------------------------------------------------------------- c setup eststr (name of estimate) and nstr (length of name). c----------------------------------------------------------------------- eststr(i)=' ' IF(i.eq.4.and.Nsea.eq.4)THEN CALL getstr(SSEDIC,sseptr,PSSE,PSSE,eststr(i),nstr(i)) ELSE IF(i.lt.5.or.Lyy)THEN CALL getstr(SSEDIC,sseptr,PSSE,i,eststr(i),nstr(i)) END IF IF(Lfatal)RETURN END DO c----------------------------------------------------------------------- Lsaneg=F IF(Muladd.eq.1)THEN c----------------------------------------------------------------------- c If additive adjustment, determine if any values of the c seasonally adjusted series are less than or equal to zero. c----------------------------------------------------------------------- sabs=ZERO dn=ZERO DO i=1,Ncol DO j=1,Sslen j2=j+Im-1 IF((.not.dpeq(Sa(j2,i),DNOTST)).and.j2.ge.Ic)THEN IF(Sa(j2,i).le.0D0)Lsaneg=T sabs=sabs+abs(Sa(j2,i)) dn=dn+1D0 END IF END DO END DO IF(Lsaneg)Saabav=sabs/dn END IF c----------------------------------------------------------------------- c Calculate and print out range values for each span c----------------------------------------------------------------------- lrange=Kfulsm.eq.2 IF((.NOT.Lsaneg).AND.(.NOT.Ssdiff).and.Kfulsm.eq.0)THEN IF(Prttab(LSSFMN+tagr))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF upper=CHAR(ICHAR(Qm(1:1))-32) nqm=nblank(Qm) IF(Muladd.eq.0)THEN WRITE(Mt1,1010)upper,Qm(2:nqm),Serno(1:Nser),chrarg(1:narg), & Moqu(1:nmq) ELSE WRITE(Mt1,1020)upper,Qm(2:nqm),Serno(1:Nser),chrarg(1:narg), & Moqu(1:nmq) END IF END IF IF(Muladd.eq.1)THEN CALL ssrng(Sfrng,cpobs,Iagr,lrange,Ncol,Muladd) ELSE CALL ssrng(S,cpobs,Iagr,lrange,Ncol,Muladd) END IF IF(Prttab(LSSYCS+tagr).AND.(.not.Lyy))Prttab(LSSYCS+tagr)=F END IF c----------------------------------------------------------------------- c Compute the month-to-month and year-to-year changes in the final c seasonally adjusted series for each span. c----------------------------------------------------------------------- CALL xchng(Sa,c,Ncol,Im,Sslen,1,Ssdiff) IF(Lyy)CALL xchng(Sa,yy,Ncol,Im,Sslen,Nsea,Ssdiff) c----------------------------------------------------------------------- c Determine how many months were flagged for each of the seasonal c adjustment estimates collected for the sliding spans procedure c and compute the percentage for months flagged. c----------------------------------------------------------------------- IF(Muladd.eq.0)THEN c----------------------------------------------------------------------- c If multiplicative adjustment, flag seasonal and trading day c factors, if requested. c----------------------------------------------------------------------- IF(Kfulsm.eq.0)CALL mflag(S,1,0,iobs,dmax,Ncol,Ssdiff) IF(Iagr.lt.6)THEN IF(Itd.eq.1)CALL mflag(Td,2,0,iobs,dmax,Ncol,Ssdiff) IF((Kfulsm.eq.0.and.(Lrndsa.or.Iyrt.gt.0.or.Itd.eq.1)).or. & Ihol.eq.1)CALL mflag(Sa,3,0,iobs,dmax,Ncol,Ssdiff) END IF ELSE c----------------------------------------------------------------------- c Flag seasonally adjusted series. c----------------------------------------------------------------------- IF(Ssdiff)THEN IF(Kfulsm.eq.0)CALL mflag(S,1,0,iobs,dmax,Ncol,Ssdiff) IF(Itd.eq.1)CALL mflag(Td,2,0,iobs,dmax,Ncol,Ssdiff) IF((Kfulsm.eq.0.and.(Lrndsa.or.Iyrt.gt.0.or.Itd.eq.1)).or. & Ihol.eq.1)CALL mflag(Sa,3,0,iobs,dmax,Ncol,Ssdiff) ELSE CALL mflag(Sa,3,0,iobs,dmax,Ncol,Ssdiff) END IF END IF c----------------------------------------------------------------------- iobs=iobs+1 CALL mflag(c,4,io1,iobs,dmax,Ncol,Ssdiff) IF(Lyy)THEN iobs=iobs+Nsea-1 CALL mflag(yy,5,3,iobs,dmax,Ncol,Ssdiff) END IF c----------------------------------------------------------------------- c Print out percent of observations flagged as extremes c----------------------------------------------------------------------- IF(.NOT.Ssdiff)THEN IF(lrange)THEN IF(Prttab(LSSPCT+tagr))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1030)Moqu(1:nmq),chrarg(1:narg) END IF IF(Savtab(LSSPCT+tagr).or.Savtab(LSSYPC+tagr)) & WRITE(Nform,1032)'yes' CALL pctrit(ex,tagr,Muladd,Nsea,eststr,nstr,Ntot,Itot,Cut, & Moqu(1:nmq),chrarg(1:narg),Prttab(LSSPCT+tagr), & Savtab(LSSPCT+tagr),Prttab(LSSYPC+tagr), & Savtab(LSSYPC+tagr)) ELSE IF(Svltab(LSLPCT))WRITE(Ng,1031) IF(Savtab(LSSPCT+tagr).or.Savtab(LSSYPC+tagr)) & WRITE(Nform,1032)'no' END IF ELSE IF(Savtab(LSSPCT+tagr).or.Savtab(LSSYPC+tagr)) & WRITE(Nform,1032)'no' END IF 1031 FORMAT(/,5X,'Range of seasonal factors is too low for ', & 'summary sliding spans measures to be reliable.', & /,5x,'Summary sliding spans statistics not computed.') 1032 FORMAT('s2.pct: ',a) c----------------------------------------------------------------------- c Generate summary of months flagged for each estimate c----------------------------------------------------------------------- c For each estimate, check to see if the number of months flagged c has been reset. c----------------------------------------------------------------------- DO i=1,NEST IF(Ntot(i).ne.NOTSET)THEN iext=tagr+(2*i)-1 i2=0 IF(i.gt.3)THEN i2=i-2 IF(i2.eq.2.and.Nsea.eq.12)i2=i2-1 END IF isum=LSSSUM+tagr IF(i.eq.NEST)isum=LSSYSM+tagr IF(Prttab(isum))THEN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF END IF c----------------------------------------------------------------------- c Print or save breakdown tables, histogram for sliding spans c analysis. c----------------------------------------------------------------------- CALL btrit(nyearz,i,i2,Iagr,ex(iext),eststr(i),nstr(i),cpobs, & lrange,Ssdiff,Prttab(isum),Savtab(isum)) ispan=spanvc(i)+tagr CALL sshist(dmax,i,Iagr,ex(iext),iext,eststr(i),nstr(i),lrange, & Prttab(isum),Savtab(isum),Prttab(ispan),Lwdprt, & Ssdiff) IF(Lfatal)RETURN END IF END DO c----------------------------------------------------------------------- c Check to see if spans are printed or stored c----------------------------------------------------------------------- IF(istrue(Prttab,LSSSFS,LSSTDS).or.istrue(Savtab,LSSSFS,LSSTDS) & .OR.Ssdiff.or.Lgraf) & THEN c----------------------------------------------------------------------- c Set up labels for spans printout c----------------------------------------------------------------------- DO l=1,Ncol i1=l i2=l+Ncol y(i1)=Iyr+l-1 y(i2)=Lyear+l-1 per(i1)=Im per(i2)=Lobs END DO c----------------------------------------------------------------------- c Initialize other variables needed to print out spans c----------------------------------------------------------------------- c length=Sslen+Im-1 n48=(Sslen/48)+1 IF(mod(Sslen,48).eq.0)n48=n48-1 l0=Ncol-1 F1(17:17)=fc(l0) F2(6:6)=fc(l0) F3(17:17)=fc(l0) c----------------------------------------------------------------------- c Print out or save spans for each estimate c----------------------------------------------------------------------- DO i=1,NEST IF(Ntot(i).ne.NOTSET)THEN ispan=spanvc(i)+tagr IF(Prttab(ispan))THEN IF(i.eq.1)THEN c----------------------------------------------------------------------- c Print spans of Seasonal factors c----------------------------------------------------------------------- CALL mlist(S,i,0,dmax,n48,Iagr,ex(tagr+1),eststr(i),nstr(i), & Ncol,y,per,Ssdiff) ELSE IF(i.eq.2)THEN c----------------------------------------------------------------------- c Print spans of Trading day factors c----------------------------------------------------------------------- CALL mlist(Td,i,0,dmax,n48,Iagr,ex(3),eststr(i),nstr(i),Ncol, & y,per,Ssdiff) ELSE IF(i.eq.3)THEN c----------------------------------------------------------------------- c Print spans of Seasonally adjusted series c----------------------------------------------------------------------- CALL mlist(Sa,i,0,dmax,n48,Iagr,ex(tagr+5),eststr(i),nstr(i), & Ncol,y,per,Ssdiff) ELSE IF(i.eq.4)THEN c----------------------------------------------------------------------- c Print spans of Month-to-Month (or quarter to quarter) changes c----------------------------------------------------------------------- CALL mlist(c,i,io1,dmax,n48,Iagr,ex(tagr+7),eststr(i), & nstr(i),Ncol,y,per,Ssdiff) ELSE IF(i.eq.5)THEN c----------------------------------------------------------------------- c Print spans of Year-to-Year changes c----------------------------------------------------------------------- CALL mlist(yy,i,3,dmax,n48,Iagr,ex(tagr+9),eststr(i),nstr(i), & Ncol,y,per,Ssdiff) END IF IF(Lfatal)RETURN END IF IF(Savtab(ispan).or.Lgraf)THEN IF(i.eq.1)THEN c----------------------------------------------------------------------- c Save spans of Seasonal factors c----------------------------------------------------------------------- IF(Savtab(ispan))CALL svspan(S,i,dmax,ispan,Ncol,F) IF(Lgraf)CALL svspan(S,i,dmax,ispan,Ncol,Lgraf) ELSE IF(i.eq.2)THEN c----------------------------------------------------------------------- c Save spans of Trading day factors c----------------------------------------------------------------------- IF(Savtab(ispan))CALL svspan(Td,i,dmax,ispan,Ncol,F) IF(Lgraf)CALL svspan(Td,i,dmax,ispan,Ncol,Lgraf) ELSE IF(i.eq.3)THEN c----------------------------------------------------------------------- c Save spans of Seasonally adjusted series c----------------------------------------------------------------------- IF(Savtab(ispan))CALL svspan(Sa,i,dmax,ispan,Ncol,F) IF(Lgraf)CALL svspan(Sa,i,dmax,ispan,Ncol,Lgraf) ELSE IF(i.eq.4)THEN c----------------------------------------------------------------------- c Save spans of Month-to-Month (or quarter to quarter) changes c----------------------------------------------------------------------- IF(Savtab(ispan))CALL svspan(C,i,dmax,ispan,Ncol,F) IF(Lgraf)CALL svspan(C,i,dmax,ispan,Ncol,Lgraf) ELSE IF(i.eq.5)THEN c----------------------------------------------------------------------- c Save spans of Year-to-Year changes c----------------------------------------------------------------------- IF(Savtab(ispan))CALL svspan(yy,i,dmax,ispan,Ncol,F) IF(Lgraf)CALL svspan(yy,i,dmax,ispan,Ncol,Lgraf) END IF IF(Lfatal)RETURN END IF END IF END DO END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(//,' S 1. ',a,a,' means of Seasonal Factors for ',a,a,/, & 8x,'(movements within a ',a,' should be small)') 1020 FORMAT(//,' S 1. ',a,a,' means of Implied Adjustment Factors ', & 'for ',a,a,/,8x,'(movements within a ',a,' should be ', & 'small)') 1030 FORMAT(//,' S 2. Percentage of ',a,'s flagged as unstable',a,/) c----------------------------------------------------------------------- END ssap.prm0000664006604000003110000000073514521201573011664 0ustar sun00315stepsc----------------------------------------------------------------------- c MXLEN : Maximum length of sliding spans matrix c MXCOL : Maximum number of columns in a sliding spans matrix c MXYR : Maximum number of years in sliding span c NEST : Number of estimates analyzed in sliding spans c----------------------------------------------------------------------- INTEGER MXLEN,MXCOL,MXYR,NEST PARAMETER(MXCOL=4,MXYR=23,MXLEN=PSP*MXYR,NEST=5) ssfnot.f0000664006604000003110000001045514521201573011661 0ustar sun00315steps SUBROUTINE ssfnot(Nopt,Nop2,Fnotvc,Fnotky,Nssky) IMPLICIT NONE c----------------------------------------------------------------------- c create footnotes for full printout of sliding spans - c this will create an integer vector of footnote numbers (Fnotvc) c an integer vector of unique footnote codes which can be used to c generate the key for the table (Fnotky) with the number of unique c footnotes for the table (Nssky). c Written by BCM - December 2006 c----------------------------------------------------------------------- INTEGER PSSTP,PSSSC,PSSNT PARAMETER(PSSTP=5,PSSSC=6,PSSNT=7) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'sspvec.cmn' c----------------------------------------------------------------------- CHARACTER Fnotvc*(10) INTEGER Fnotky,Nopt,Nop2,Nssky,i DIMENSION Fnotvc(MXLEN),Fnotky(PSSNT) c----------------------------------------------------------------------- c Initialize Fnotvc to zero, Fnotky to NOTSET c----------------------------------------------------------------------- CALL setint(NOTSET,PSSNT,Fnotky) Nssky=0 c----------------------------------------------------------------------- c For each observation, check to see if any of the indicator c variables has determined whether the observation was flagged as c an extreme (Per), changed direction (Csign), or indicated a c turning point (Cturn) c----------------------------------------------------------------------- DO i=Im,Sslen+Im-1 CALL setchr(' ',10,Fnotvc(i)) IF(Per(i,Nopt).eq.-1)THEN Fnotvc(i)=' NT ' IF(Fnotky(PSSNT).eq.NOTSET)THEN Fnotky(PSSNT)=1 Nssky=Nssky+1 END IF ELSE IF(Per(i,Nopt).gt.0)THEN IF(Fnotky(Per(i,Nopt)).eq.NOTSET)THEN Fnotky(Per(i,Nopt))=1 Nssky=Nssky+1 END IF IF((Cturn(i,Nopt).eq.1).and.(Csign(i,Nopt).eq.1).and. & Per(i,Nopt).gt.0)THEN IF(Nop2.gt.0)THEN WRITE(Fnotvc(i),1010)'SC',Per(i,Nopt),Ch(Nopt) ELSE WRITE(Fnotvc(i),1010)'IE',Per(i,Nopt),Ch(Nopt) END IF 1010 FORMAT(a,', TP, ',i1,a1) IF(Fnotky(PSSSC).eq.NOTSET)THEN Fnotky(PSSSC)=1 Nssky=Nssky+1 END IF IF(Fnotky(PSSTP).eq.NOTSET)THEN Fnotky(PSSTP)=1 Nssky=Nssky+1 END IF ELSE IF((Csign(i,Nopt).eq.1).and.Per(i,Nopt).gt.0)THEN IF(Nop2.gt.0)THEN WRITE(Fnotvc(i),1020)'SC',Per(i,Nopt),Ch(Nopt) ELSE WRITE(Fnotvc(i),1020)'IE',Per(i,Nopt),Ch(Nopt) END IF 1020 FORMAT(' ',a2,', ',i1,a1,' ') IF(Fnotky(PSSSC).eq.NOTSET)THEN Fnotky(PSSSC)=1 Nssky=Nssky+1 END IF ELSE IF((Cturn(i,Nopt).eq.1).and.Per(i,Nopt).gt.0)THEN WRITE(Fnotvc(i),1030)Per(i,Nopt),Ch(Nopt) 1030 FORMAT(' TP, ',i1,a1,' ') IF(Fnotky(PSSTP).eq.NOTSET)THEN Fnotky(PSSTP)=1 Nssky=Nssky+1 END IF ELSE IF(Per(i,Nopt).gt.0)THEN WRITE(Fnotvc(i),1040)Per(i,Nopt),Ch(Nopt) 1040 FORMAT(' ',i1,a1,' ') END IF ELSE IF((Cturn(i,Nopt).eq.1).and.(Csign(i,Nopt).eq.1)) THEN IF(Nop2.gt.0)THEN Fnotvc(i)=' SC, TP ' ELSE Fnotvc(i)=' IE, TP ' END IF IF(Fnotky(PSSSC).eq.NOTSET)THEN Fnotky(PSSSC)=1 Nssky=Nssky+1 END IF IF(Fnotky(PSSTP).eq.NOTSET)THEN Fnotky(PSSTP)=1 Nssky=Nssky+1 END IF ELSE IF(Cturn(i,Nopt).eq.1)THEN Fnotvc(i)=' TP ' IF(Fnotky(PSSTP).eq.NOTSET)THEN Fnotky(PSSTP)=1 Nssky=Nssky+1 END IF ELSE IF(Csign(i,Nopt).eq.1)THEN IF(Nop2.gt.0)THEN Fnotvc(i)=' SC ' ELSE Fnotvc(i)=' IE ' END IF IF(Fnotky(PSSSC).eq.NOTSET)THEN Fnotky(PSSSC)=1 Nssky=Nssky+1 END IF END IF END DO c----------------------------------------------------------------------- RETURN END ssft.cmn0000664006604000003110000000046214521201573011651 0ustar sun00315steps INTEGER Icol,Issqf DOUBLE PRECISION Ssfts,Ssmf c----------------------------------------------------------------------- DIMENSION Ssfts(MXCOL),Ssmf(MXCOL),Issqf(MXCOL) c----------------------------------------------------------------------- COMMON /ssft / Ssfts,Ssmf,Issqf,Icol ssftst.f0000664006604000003110000001005514521201573011667 0ustar sun00315stepsC Last change: BCM 12 Jan 98 8:50 am **==ssftst.f processed by SPAG 4.03F at 12:23 on 21 Jun 1994 SUBROUTINE ssftst(Ncol,Lprt,Lsav) IMPLICIT NONE c----------------------------------------------------------------------- DOUBLE PRECISION NINE,THREE,TWO,SEVEN,ZERO PARAMETER (NINE=9D0,THREE=3D0,TWO=2D0,SEVEN=7D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssft.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER qf*(3),span*(6),label*(20),ftfmt*(46) INTEGER i,Ncol DOUBLE PRECISION ssm7,test1,test2 LOGICAL Lprt,Lsav DIMENSION ssm7(MXCOL),qf(MXCOL),span(MXCOL),label(2) c----------------------------------------------------------------------- DOUBLE PRECISION oldssm7(MXCOL),sstest1(MXCOL),sstest2(MXCOL) c----------------------------------------------------------------------- DATA span/'Span 1','Span 2','Span 3','Span 4'/ DATA label/'Stable seasonality','Moving seasonality'/ c----------------------------------------------------------------------- DO i=1,Ncol qf(i)=' ' test1=ZERO test2=ZERO IF(Issqf(i).eq.0)qf(i)='yes' IF(Issqf(i).eq.1)qf(i)='???' IF(Issqf(i).eq.2)qf(i)=' no' test1=SEVEN/Ssfts(i) test2=(THREE*Ssmf(i))/Ssfts(i) oldssm7(i)=sqrt((test1+test2)/2) IF(oldssm7(i).gt.THREE)oldssm7(i)=THREE c----------------------------------------------------------------------- sstest1(i)=test1 sstest2(i)=test2 IF(test1.gt.NINE)test1=NINE IF(test2.gt.NINE)test2=NINE ssm7(i)=sqrt((test1+test2)/2) END DO c----------------------------------------------------------------------- IF(Lprt)THEN WRITE(Mt1,1010) 1010 FORMAT(//,5x,'Summary of tests for stable and moving ', & 'seasonality from table D8 for each span',/) ftfmt=' ' WRITE(ftfmt,1020)Ncol 1020 FORMAT('(28x,',i1,'(7x,a6))') WRITE(Mt1,ftfmt)(span(i),i=1,Ncol) c----------------------------------------------------------------------- ftfmt=' ' WRITE(ftfmt,1030)Ncol 1030 FORMAT('(5x,a20,6x,',i1,'(2x,f8.2,3x))') WRITE(Mt1,ftfmt)label(1),(Ssfts(i),i=1,Ncol) WRITE(Mt1,1040) 1040 FORMAT(' ') WRITE(Mt1,ftfmt)label(2),(Ssmf(i),i=1,Ncol) WRITE(Mt1,1040) c----------------------------------------------------------------------- ftfmt=' ' WRITE(ftfmt,1050)Ncol 1050 FORMAT('(5x,a,24x,',i1,'(2x,f8.2,3x))') WRITE(Mt1,ftfmt)'m7',(ssm7(i),i=1,Ncol) WRITE(Mt1,1040) c----------------------------------------------------------------------- ftfmt=' ' WRITE(ftfmt,1060)Ncol 1060 FORMAT('(5x,a,',i1,'(8x,a3,2x))') WRITE(Mt1,ftfmt)'Identifiable seasonality?',(qf(i),i=1,Ncol) WRITE(Mt1,1040) c----------------------------------------------------------------------- WRITE(Mt1,1070) 1070 FORMAT(/,10x,'yes = Identifiable seasonality probably present',/, & 10x,'??? = Identifiable seasonality probably not present', & /,10x,' no = Identifiable seasonality not present',//) END IF c----------------------------------------------------------------------- IF(Lsav)THEN ftfmt=' ' WRITE(ftfmt,1080)Ncol 1080 FORMAT('(a,',i1,'(3x,f8.2))') WRITE(Nform,ftfmt)'ssfstab:',(Ssfts(i),i=1,Ncol) WRITE(Nform,ftfmt)'ssfmov:',(Ssmf(i),i=1,Ncol) * WRITE(Nform,ftfmt)'sstest1:',(sstest1(i),i=1,Ncol) * WRITE(Nform,ftfmt)'sstest2:',(sstest2(i),i=1,Ncol) WRITE(Nform,ftfmt)'ssm7:',(ssm7(i),i=1,Ncol) * WRITE(Nform,ftfmt)'oldssm7:',(oldssm7(i),i=1,Ncol) ftfmt=' ' WRITE(ftfmt,1090)Ncol 1090 FORMAT('(a,',i1,'(8x,a3))') WRITE(Nform,ftfmt)'ssident:',(qf(i),i=1,Ncol) END IF c----------------------------------------------------------------------- RETURN END sshist.f0000664006604000003110000000741414521201573011663 0ustar sun00315stepsC Last change: BCM 5 Jan 1999 11:51 am SUBROUTINE sshist(Dmax,Nopt,Iagr,Ext,Iext,Eststr,Nstr,Lrange,Lp, & Ls,Lpspan,Lwdprt,Ssdiff) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'notset.prm' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'ssap.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- LOGICAL Lp,Ls,Lwdprt,Lrange,Lpspan,first,Ssdiff CHARACTER c*(7),Ext*(2),Eststr*(45) DOUBLE PRECISION Dmax,xo INTEGER i,it,l2,n,n1,n2,Nopt,Iagr,Nstr,Iext,nmq DIMENSION Dmax(MXLEN,NEST),xo(MXLEN) c----------------------------------------------------------------------- LOGICAL dpeq INTEGER nblank EXTERNAL dpeq,nblank c----------------------------------------------------------------------- l2=Sslen2-1 it=0 n2=Ic first=T DO i=Ic,l2 IF(dpeq(Dmax(i,Nopt),DNOTST))THEN it=it+1 IF(first)n2=n2+1 ELSE IF(mod(i,Nsea).eq.2.and.Nopt.eq.2.and. & dpeq(Dmax(i,Nopt),0D0))THEN it=it+1 IF(first)n2=n2+1 ELSE n=i-it-Ic+1 xo(n)=Dmax(i,Nopt) IF(first)first=F END IF END DO c----------------------------------------------------------------------- n1=1 IF(Iagr.eq.6)n1=2 c----------------------------------------------------------------------- IF(Muladd.eq.1.and.Ssdiff)THEN CALL histx(xo,n,Muladd,Nsea,Iyr,n2,Iext,Ssdiff,Lp,Ls, & 'Maximum Absolute Differences across spans') ELSE CALL histx(xo,n,Muladd,Nsea,Iyr,n2,Iext,F,Lp,Ls, & 'Maximum Percent Differences across spans') END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Compute and print out "tail" histogram. c----------------------------------------------------------------------- IF((.not.Ssdiff).and.Lp.and.Lrange)THEN nmq=nblank(Moqu) IF(Lwdprt)THEN WRITE(Mt1,1010)Eststr(1:Nstr),Moqu(1:nmq) ELSE WRITE(Mt1,1020)Eststr(1:Nstr),Moqu(1:nmq) END IF c=' ' IF(Lpspan)c(4:6)=Ch(Nopt)//' :' DO i=1,3 IF(Lpspan)WRITE(c(3:3),1030)i WRITE(Mt1,1040)c,Cut(Nopt,i),Cut(Nopt,i+1),Kount(Nopt,i) END DO IF(Lpspan)c(3:3)='4' WRITE(Mt1,1050)c,Cut(Nopt,4),Kount(Nopt,4) END IF c----------------------------------------------------------------------- IF((.not.Ssdiff).and.Ls)THEN DO i=1,3 WRITE(Nform,1060)Ext(1:n1),i,Cut(Nopt,i),Cut(Nopt,i+1), & Kount(Nopt,i) END DO WRITE(Nform,1070)Ext(1:n1),Cut(Nopt,4),Kount(Nopt,4) END IF c----------------------------------------------------------------------- 1010 FORMAT(/,' Breakdown of the maximum percentage differences ', & 'of the ',a,/,' for flagged ',a,'s.',/) 1020 FORMAT(/,' Breakdown of the maximum percentage differences ', & 'of the',/,2x,a,' for flagged ',a,'s.',/) 1030 FORMAT(i1) 1040 FORMAT(' ',a,' Greater than or equal to ',f4.1,'% but less ', & 'than ',f4.1,'% :',1x,i3) 1050 FORMAT(' ',a,' Greater than or equal to ',f4.1,'%',t62,':',1x, & i3,/) 1060 FORMAT('s3.',a,'.thist',i1,':',2x,f4.1,2x,f4.1,2x,i3) 1070 FORMAT('s3.',a,'.thist4:',2x,f4.1,8x,i3) c----------------------------------------------------------------------- RETURN END ssmdl.f0000664006604000003110000003640014521201573011465 0ustar sun00315stepsC Last change: BCM 8 Dec 1998 4:03 pm SUBROUTINE ssmdl(Iyr,Im,Itd,Ihol,Tdfix,Holfix,Otlfix,Usrfix,Locok) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'ssprep.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'otlrev.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'usrreg.cmn' c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- CHARACTER grchr1*(PGRPCR*PGRP),grchr2*(PGRPCR*PGRP), & igrptl*(PGRPCR) INTEGER igrp,begcol,nchr,idtpos,regmdt,begrgm,nbeg,nend,begss, & starta,enda,sspos,endcol,icol,rtype,Iyr,Im,Itd,Ihol, & gr1ptr,gr2ptr,ngrp1,ngrp2,ngr1tl,ngr2tl,fhnote LOGICAL erregm,Locok,regchg,erreg2,Tdfix,Holfix,Usrfix,Otlfix DIMENSION gr1ptr(0:PGRP),gr2ptr(0:PGRP),regmdt(2),starta(2), & enda(2),begss(2) c----------------------------------------------------------------------- c Initialize change of regime dictionaries and pointer variables. c----------------------------------------------------------------------- CALL intlst(PB,gr1ptr,ngr1tl) CALL intlst(PB,gr2ptr,ngr2tl) ngrp1=ngr1tl+1 ngrp2=ngr2tl+1 c----------------------------------------------------------------------- c If automatic modelling done, setup so the model selected for c the entire series will be used in each of the spans c----------------------------------------------------------------------- Lautox=F Lautom=F Lautod=F regchg=F fhnote=STDERR IF(Lquiet)fhnote=0 c----------------------------------------------------------------------- c Fix selected regressors based on values of Ssfxrg c----------------------------------------------------------------------- IF(Nb.gt.0)THEN IF(Nssfxr.gt.0)THEN CALL rvfixd(Tdfix,Holfix,Otlfix,Usrfix,Iregfx,Regfx,Nb,Rgvrtp, & Nusrrg,Usrtyp,Ncusrx,Userfx) IF(Itd.eq.1.and.Tdfix)Itd=-1 IF(Ihol.eq.1.and.Holfix)Ihol=-1 ELSE IF(Iregfx.eq.3)THEN IF(Itd.eq.1)THEN Itd=-1 IF(Ssinit.ne.1)THEN Nssfxr=1 Ssfxrg(1)=1 END IF END IF IF(Ihol.eq.1)THEN Ihol=-1 IF(Ssinit.ne.1)THEN Nssfxr=Nssfxr+1 Ssfxrg(Nssfxr)=2 END IF END IF ELSE IF(Iregfx.eq.2)THEN Tdfix=T Holfix=T DO igrp=1,Ngrp endcol=Grp(igrp)-1 begcol=Grp(igrp-1) rtype=Rgvrtp(begcol) IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRA1TD.or.rtype.eq.PRRTST.or.rtype.eq.PRATTD.or. & rtype.eq.PRATST.or.rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST.or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or. & rtype.eq.PRGTLQ.or.rtype.eq.PRGTLY.or.rtype.eq.PRATLQ.or. & rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or.rtype.eq.PRATSL.or. & rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY).or. & (rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES.or. & rtype.eq.PRGTLD.or.rtype.eq.PRGTTH).or. & (rtype.ge.PRGTUH.and.rtype.le.PRGUH5).or. & rtype.eq.PRGTUS))THEN DO icol=begcol,endcol IF(rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES & .or.rtype.eq.PRGTLD.or.rtype.eq.PRGTTH.or. & (rtype.ge.PRGTUH.and.rtype.le.PRGUH5))THEN Holfix=Holfix.and.Regfx(icol) ELSE Tdfix=Tdfix.and.Regfx(icol) END IF END DO END IF END DO IF(Tdfix.and.Itd.gt.0)THEN Itd=-1 IF(Ssinit.ne.1)THEN Nssfxr=1 Ssfxrg(1)=1 END IF END IF IF(Holfix.and.Ihol.eq.1)THEN Ihol=-1 IF(Ssinit.ne.1)THEN Nssfxr=Nssfxr+1 Ssfxrg(Nssfxr)=2 END IF END IF END IF ELSE Nssfxr=0 END IF c----------------------------------------------------------------------- CALL intlst(PB,Otrptr,Notrtl) IF(Ssotl.le.1)THEN Ltstao=F Ltstls=F Ltsttc=F * Ltstso=F END IF c----------------------------------------------------------------------- c Set up dates for testing change of regime and outlier variables. c----------------------------------------------------------------------- begss(YR)=Iyr begss(MO)=Im CALL addate(begss,Sp,(Ncol-1)*Sp,starta) CALL addate(Endspn,Sp,(1-Ncol)*Sp,enda) CALL dfdate(enda,starta,Sp,sspos) Locok=T erregm=F erreg2=F DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 c----------------------------------------------------------------------- c Check to see if there are any change of regime regression c variables in the model. If there is, check to see if the c change of regime will be defined over all the spans. c----------------------------------------------------------------------- IF(Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRRTSE.or.Rgvrtp(begcol).eq.PRRTTS.or. & Rgvrtp(begcol).eq.PRRTLM.or.Rgvrtp(begcol).eq.PRRTLQ.or. & Rgvrtp(begcol).eq.PRRTLY.or.Rgvrtp(begcol).eq.PRRTSL.or. & Rgvrtp(begcol).eq.PRR1TD.or.Rgvrtp(begcol).eq.PRR1ST)THEN CALL getstr(Grpttl,Grpptr,Ngrp,igrp,igrptl,nchr) IF(Lfatal)RETURN idtpos=index(igrptl(1:nchr),'(before ')+8 IF(idtpos.eq.8) & idtpos=index(igrptl(1:nchr),'(change from before ')+20 CALL ctodat(igrptl(1:nchr-1),Sp,idtpos,regmdt,Locok) CALL dfdate(regmdt,starta,Sp,begrgm) IF(begrgm.le.Sp)THEN CALL insstr(igrptl(1:nchr),ngrp1,PB,grchr1,gr1ptr,ngr1tl) IF(Lfatal)RETURN IF(Ssinit.ne.1)THEN DO icol=begcol,endcol IF(.not.Regfx(icol))THEN Regfx(icol)=T IF(.not.erregm)erregm=T END IF END DO END IF ngrp1=ngrp1+1 IF(.not.regchg)regchg=T ELSE IF(begrgm.ge.sspos.AND. & ((Fulltd.AND.(Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRR1TD.or. & Rgvrtp(begcol).eq.PRR1ST)).or. & (Lseff.AND.(Rgvrtp(begcol).eq.PRRTSE.or. & Rgvrtp(begcol).eq.PRRTTS)).or. & (Fullln.AND.(Rgvrtp(begcol).eq.PRRTLM.or. & Rgvrtp(begcol).eq.PRRTLQ.or.Rgvrtp(begcol).eq.PRRTSL)).or. & (Fulllp.and.Rgvrtp(begcol).eq.PRRTLY)))THEN CALL insstr(igrptl(1:nchr),ngrp2,PB,grchr2,gr2ptr,ngr2tl) IF(Lfatal)RETURN IF(Ssinit.ne.1)THEN DO icol=begcol,endcol IF(.not.Regfx(icol))THEN Regfx(icol)=T IF(.not.erregm)erreg2=T END IF END DO END IF ngrp2=ngrp2+1 IF(.not.regchg)regchg=T END IF ELSE IF(Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRATTD.or. & Rgvrtp(begcol).eq.PRATSE.or.Rgvrtp(begcol).eq.PRATTS.or. & Rgvrtp(begcol).eq.PRATLM.or.Rgvrtp(begcol).eq.PRATLQ.or. & Rgvrtp(begcol).eq.PRATLY.or.Rgvrtp(begcol).eq.PRATSL.or. & Rgvrtp(begcol).eq.PRA1ST.or.Rgvrtp(begcol).eq.PRA1TD)THEN CALL getstr(Grpttl,Grpptr,Ngrp,igrp,igrptl,nchr) IF(Lfatal)RETURN idtpos=index(igrptl(1:nchr),'(starting ')+10 CALL ctodat(igrptl(1:nchr-1),Sp,idtpos,regmdt,Locok) CALL dfdate(enda,regmdt,Sp,begrgm) IF(begrgm.le.Sp)THEN CALL insstr(igrptl(1:nchr),ngrp1,PB,grchr1,gr1ptr,ngr1tl) IF(Lfatal)RETURN IF(Ssinit.ne.1)THEN DO icol=begcol,endcol IF(.not.Regfx(icol))THEN Regfx(icol)=T IF(.not.erregm)erregm=T END IF END DO END IF ngrp1=ngrp1+1 IF(.not.regchg)regchg=T ELSE IF(begrgm.ge.(sspos-Sp).AND. & ((Fulltd.AND.(Rgvrtp(begcol).eq.PRATST.or. & Rgvrtp(begcol).eq.PRATTD.or.Rgvrtp(begcol).eq.PRA1TD.or. & Rgvrtp(begcol).eq.PRA1ST)).or. & (Lseff.AND.(Rgvrtp(begcol).eq.PRATSE.or. & Rgvrtp(begcol).eq.PRATTS)).or. & (Fullln.AND.(Rgvrtp(begcol).eq.PRATLM.or. & Rgvrtp(begcol).eq.PRATLQ.or.Rgvrtp(begcol).eq.PRATSL)).or. & (Fulllp.and.Rgvrtp(begcol).eq.PRATLY)))THEN CALL insstr(igrptl(1:nchr),ngrp2,PB,grchr2,gr2ptr,ngr2tl) IF(Lfatal)RETURN IF(Ssinit.ne.1)THEN DO icol=begcol,endcol IF(.not.Regfx(icol))THEN Regfx(icol)=T IF(.not.erregm)erreg2=T END IF END DO END IF ngrp2=ngrp2+1 IF(.not.regchg)regchg=T END IF c----------------------------------------------------------------------- c Check regular outliers to see if they are defined within the c sliding spans. c----------------------------------------------------------------------- ELSE IF(Rgvrtp(begcol).eq.PRGTAO.or.Rgvrtp(begcol).eq.PRGTLS.or. & Rgvrtp(begcol).eq.PRGTRP.or.Rgvrtp(begcol).eq.PRGTTC.or. & Rgvrtp(begcol).eq.PRGTQD.or.Rgvrtp(begcol).eq.PRGTQI.or. & Rgvrtp(begcol).eq.PRGTSO.or.Rgvrtp(begcol).eq.PRGTTL)THEN DO icol=endcol,begcol,-1 CALL rmotss(icol,Begxy,Nrxy,begss,starta,enda,Botr,Otrptr, & Notrtl,Fixotr,Otrttl,Otlfix.or.Ssinit.eq.1,regchg) END DO IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check automatic outliers to see if they are defined within the c sliding spans. c----------------------------------------------------------------------- ELSE IF(Rgvrtp(begcol).eq.PRGTAA.or.Rgvrtp(begcol).eq.PRGTAL.or. * & Rgvrtp(begcol).eq.PRGTAT.or.Rgvrtp(begcol).eq.PRGTAS)THEN & Rgvrtp(begcol).eq.PRGTAT)THEN icol=endcol DO WHILE (icol.ge.begcol) IF(Ssotl.eq.1)THEN IF(Rgvrtp(icol).eq.PRGTAA)Rgvrtp(icol)=PRGTAO IF(Rgvrtp(icol).eq.PRGTAL)Rgvrtp(icol)=PRGTLS IF(Rgvrtp(icol).eq.PRGTAT)Rgvrtp(icol)=PRGTTC * IF(Rgvrtp(icol).eq.PRGTAS)Rgvrtp(icol)=PRGTSO CALL rmotss(icol,Begxy,Nrxy,begss,starta,enda,Botr,Otrptr, & Notrtl,Fixotr,Otrttl,Otlfix.or.Ssinit.eq.1,regchg) IF(Lfatal)RETURN ELSE CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN END IF icol=icol-1 IF(.not.regchg)regchg=T END DO END IF END DO c----------------------------------------------------------------------- c Print out warning message(s) for change-of-regime variables. c----------------------------------------------------------------------- IF(ngr1tl.gt.0)THEN CALL writln('NOTE: The following change of regime regression vari &ables are not',Mt1,Mt2,T) CALL writln(' defined for at least one year of one of the sp &ans of the',Mt1,Mt2,F) CALL writln(' sliding spans analysis:',Mt1,Mt2,F) DO igrp=1,ngr1tl CALL getstr(grchr1,gr1ptr,ngrp1,igrp,igrptl,nchr) IF(Lfatal)RETURN CALL writln(' '//igrptl(1:nchr),Mt1,Mt2,F) END DO IF(erregm) & CALL writln(' Change of regime regressor will be fixed.', & Mt1,Mt2,T) END IF IF(ngr2tl.gt.0)THEN CALL writln('NOTE: The following change of regime regression vari &ables could cause',Mt1,Mt2,T) CALL writln(' singularity problems in the regression matrix &for at least one',Mt1,Mt2,F) CALL writln(' of the spans of the sliding spans analysis:', & Mt1,Mt2,F) DO igrp=1,ngr2tl CALL getstr(grchr2,gr2ptr,ngrp2,igrp,igrptl,nchr) IF(Lfatal)RETURN CALL writln(' '//igrptl(1:nchr),Mt1,Mt2,F) END DO IF(erreg2) & CALL writln(' Change of regime regressor will be fixed.', & Mt1,Mt2,T) END IF c----------------------------------------------------------------------- c If change-of-regime regression variables check out, set be sure c model parameters are fixed. c----------------------------------------------------------------------- IF(Ssinit.ne.1)THEN c IF(Lrgmse.or.Lrgmtd.or.Lrgmln)THEN c Ssinit=1 c CALL writln('NOTE: Since change of regime regression variables a c &re used, model',Mt1,Mt2,T) c CALL writln(' parameters will be held fixed.',STDERR,Mt2,F) c END IF c----------------------------------------------------------------------- c If a model span is used, be sure model parameters are fixed. c----------------------------------------------------------------------- CALL dfdate(Begmdl,Begspn,Sp,nbeg) CALL dfdate(Endspn,Endmdl,Sp,nend) IF(nbeg.gt.0.or.nend.gt.0)THEN Ssinit=1 IF(Itd.eq.1.and.Adjtd.gt.0)Itd=-1 IF(Ihol.eq.1.and.Adjhol.gt.0)Ihol=-1 CALL writln('NOTE: Since a model span is used, model parameters &will be held fixed.',fhnote,Mt2,T) END IF END IF c----------------------------------------------------------------------- c Fix all model parameters based on value of Ssinit c----------------------------------------------------------------------- IF(Ssinit.eq.1)THEN CALL copy(Arimap,PARIMA,1,Ap2) CALL setlg(T,PARIMA,Fxa) IF(.not.regchg)CALL copy(B,PB,1,Bb) CALL setlg(T,PB,Regfx2) IF(Iregfx.lt.3)Iregfx=3 CALL setlg(T,Nb,Regfx) Irfx2=3 IF(.not.Userfx)Userfx=Ncusrx.gt.0 IF(Userfx)CALL bakusr(Userx,Usrtyp,Usrptr,Ncusrx,Usrttl,Regfx,B, & Rgvrtp,Ngrp,Grpttl,Grp,Grpptr,Ngrptl,0,T) END IF c----------------------------------------------------------------------- c If outlier regressors have been changed, store new regression c variables c----------------------------------------------------------------------- IF(regchg)THEN Ngr2=Ngrp Ngrt2=Ngrptl Ncxy2=Ncxy Nbb=Nb Nct2=Ncoltl Cttl=Colttl Gttl=Grpttl CALL cpyint(Colptr(0),PB+1,1,Clptr(0)) CALL cpyint(Grp(0),PGRP+1,1,G2(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Gptr(0)) CALL cpyint(Rgvrtp,PB,1,Rgv2) CALL copy(B,PB,1,Bb) Irfx2=Iregfx CALL copylg(Regfx,PB,1,Regfx2) END IF c----------------------------------------------------------------------- RETURN END ssort.f0000664006604000003110000002102614521201573011513 0ustar sun00315stepsC Last change: BCM 22 Dec 97 3:01 pm **==ssort.f processed by SPAG 4.03F at 09:53 on 1 Mar 1994 SUBROUTINE ssort(X,Y,N,Kflag) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL T PARAMETER(T=.true.) c----------------------------------------------------------------------- C***BEGIN PROLOGUE SSORT C***DATE WRITTEN 761101 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. N6A2B1 C***KEYWORDS QUICKSORT,SINGLETON QUICKSORT,SORT,SORTING C***AUTHOR JONES, R. E., (SNLA) C WISNIEWSKI, J. A., (SNLA) C***PURPOSE SSORT SORTS ARRAY X AND OPTIONALLY MAKES THE SAME C INTERCHANGES IN ARRAY Y. THE ARRAY X MAY BE SORTED IN C INCREASING ORDER OR DECREASING ORDER. A SLIGHTLY MODIFIED C QUICKSORT ALGORITHM IS USED. C***DESCRIPTION C C WRITTEN BY RONDALL E. JONES C MODIFIED BY JOHN A. WISNIEWSKI TO USE THE SINGLETON QUICKSORT C ALGORITHM. DATE 18 NOVEMBER 1976. C C ABSTRACT C SSORT SORTS ARRAY X AND OPTIONALLY MAKES THE SAME C INTERCHANGES IN ARRAY Y. THE ARRAY X MAY BE SORTED IN C INCREASING ORDER OR DECREASING ORDER. A SLIGHTLY MODIFIED C QUICKSORT ALGORITHM IS USED. C C REFERENCE C SINGLETON, R. C., ALGORITHM 347, AN EFFICIENT ALGORITHM FOR C SORTING WITH MINIMAL STORAGE, CACM,12(3),1969,185-7. C C DESCRIPTION OF PARAMETERS C X - ARRAY OF VALUES TO BE SORTED (USUALLY ABSCISSAS) C Y - ARRAY TO BE (OPTIONALLY) CARRIED ALONG C N - NUMBER OF VALUES IN ARRAY X TO BE SORTED C KFLAG - CONTROL PARAMETER C =2 MEANS SORT X IN INCREASING ORDER AND CARRY Y ALONG. C =1 MEANS SORT X IN INCREASING ORDER (IGNORING Y) C =-1 MEANS SORT X IN DECREASING ORDER (IGNORING Y) C =-2 MEANS SORT X IN DECREASING ORDER AND CARRY Y ALONG. C***REFERENCES SINGLETON,R.C., ALGORITHM 347, AN EFFICIENT ALGORITHM C FOR SORTING WITH MINIMAL STORAGE, CACM,12(3),1969, C 185-7. C***END PROLOGUE SSORT c----------------------------------------------------------------------- DOUBLE PRECISION r,tmp,tt,tty,ty,X,Y INTEGER i,iabs,ij,il,iu,j,k,Kflag,kk,l,m,N,nn c----------------------------------------------------------------------- DIMENSION X(N),Y(N),il(21),iu(21) C***FIRST EXECUTABLE STATEMENT SSORT nn=N kk=iabs(Kflag) C C ALTER ARRAY X TO GET DECREASING ORDER IF NEEDED C IF(Kflag.lt.1)THEN DO i=1,nn X(i)=-X(i) END DO END IF IF(kk.eq.2)THEN C C SORT X AND CARRY Y ALONG C m=1 i=1 j=nn r=.375D0 GO TO 70 ELSE C C SORT X ONLY C m=1 i=1 j=nn r=.375D0 END IF 10 IF(i.eq.j)GO TO 40 IF(r.gt..5898437D0)THEN r=r-.21875D0 ELSE r=r+3.90625D-2 END IF 20 k=i C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T ij=i+idint(dble(j-i)*r) tmp=X(ij) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF(X(i).gt.tmp)THEN X(ij)=X(i) X(i)=tmp tmp=X(ij) END IF l=j C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF(X(j).lt.tmp)THEN X(ij)=X(j) X(j)=tmp tmp=X(ij) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF(X(i).gt.tmp)THEN X(ij)=X(i) X(i)=tmp tmp=X(ij) END IF END IF DO WHILE (T) C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T l=l-1 IF(X(l).le.tmp)THEN DO WHILE (T) C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T k=k+1 IF(X(k).ge.tmp)THEN C INTERCHANGE THESE ELEMENTS IF(k.le.l)THEN tt=X(l) X(l)=X(k) X(k)=tt GO TO 30 ELSE C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF(l-i.le.j-k)THEN il(m)=k iu(m)=j j=l m=m+1 ELSE il(m)=i iu(m)=l i=k m=m+1 END IF GO TO 50 END IF END IF END DO END IF 30 CONTINUE END DO C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 40 m=m-1 IF(m.eq.0)GO TO 130 i=il(m) j=iu(m) 50 IF(j-i.ge.1)GO TO 20 IF(i.eq.1)GO TO 10 i=i-1 DO WHILE (T) i=i+1 IF(i.eq.j)GO TO 40 tmp=X(i+1) IF(X(i).gt.tmp)THEN k=i DO WHILE (T) X(k+1)=X(k) k=k-1 IF(tmp.ge.X(k))THEN X(k+1)=tmp GO TO 60 END IF END DO END IF 60 CONTINUE END DO 70 IF(i.eq.j)GO TO 100 IF(r.gt..5898437D0)THEN r=r-.21875D0 ELSE r=r+3.90625D-2 END IF 80 k=i C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T ij=i+idint(dble(j-i)*r) tmp=X(ij) ty=Y(ij) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF(X(i).gt.tmp)THEN X(ij)=X(i) X(i)=tmp tmp=X(ij) Y(ij)=Y(i) Y(i)=ty ty=Y(ij) END IF l=j C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF(X(j).lt.tmp)THEN X(ij)=X(j) X(j)=tmp tmp=X(ij) Y(ij)=Y(j) Y(j)=ty ty=Y(ij) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF(X(i).gt.tmp)THEN X(ij)=X(i) X(i)=tmp tmp=X(ij) Y(ij)=Y(i) Y(i)=ty ty=Y(ij) END IF END IF DO WHILE (T) C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T l=l-1 IF(X(l).le.tmp)THEN DO WHILE (T) C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T k=k+1 IF(X(k).ge.tmp)THEN C INTERCHANGE THESE ELEMENTS IF(k.le.l)THEN tt=X(l) X(l)=X(k) X(k)=tt tty=Y(l) Y(l)=Y(k) Y(k)=tty GO TO 90 ELSE C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF(l-i.le.j-k)THEN il(m)=k iu(m)=j j=l m=m+1 ELSE il(m)=i iu(m)=l i=k m=m+1 END IF GO TO 110 END IF END IF END DO END IF 90 CONTINUE END DO C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 100 m=m-1 IF(m.eq.0)GO TO 130 i=il(m) j=iu(m) 110 IF(j-i.ge.1)GO TO 80 IF(i.eq.1)GO TO 70 i=i-1 DO WHILE (T) i=i+1 IF(i.eq.j)GO TO 100 tmp=X(i+1) ty=Y(i+1) IF(X(i).gt.tmp)THEN k=i DO WHILE (T) X(k+1)=X(k) Y(k+1)=Y(k) k=k-1 IF(tmp.ge.X(k))THEN X(k+1)=tmp Y(k+1)=ty GO TO 120 END IF END DO END IF 120 CONTINUE END DO C C CLEAN UP C 130 IF(Kflag.ge.1)RETURN DO i=1,nn X(i)=-X(i) END DO RETURN END sspdat.cmn0000664006604000003110000000122014521201573012161 0ustar sun00315stepsC----------------------------------------------------------------------- C Common block that contains data for the sliding spans analysis C----------------------------------------------------------------------- DOUBLE PRECISION Sfind,Saind,Sfinda,S,Sa,Isfadd,Td C----------------------------------------------------------------------- DIMENSION S(MXLEN,MXCOL),Sfind(MXLEN,MXCOL),Sfinda(MXLEN,MXCOL), & Saind(MXLEN,MXCOL),Sa(MXLEN,MXCOL),Isfadd(MXLEN,MXCOL), & Td(MXLEN,MXCOL) C----------------------------------------------------------------------- COMMON /sser / Sfind,Sfinda,Saind,S,Sa,Isfadd,Td sspdrv.f0000664006604000003110000004477014521201573011675 0ustar sun00315stepsC Last change: BCM 23 Mar 2005 3:38 pm SUBROUTINE sspdrv(Ltmax,Lmodel,Lx11,X11agr,Lseats,Lcomp,Lgraf, & Iagr,Ncomp) IMPLICIT NONE C----------------------------------------------------------------------- c Driver routine for the sliding spans analysis procedure. C----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'sspdat.cmn' INCLUDE 'units.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'error.cmn' INCLUDE 'xrgtbl.i' INCLUDE 'mdltbl.i' INCLUDE 'revtbl.i' INCLUDE 'ssptbl.i' INCLUDE 'dgnsvl.i' INCLUDE 'title.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'otlrev.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'x11opt.cmn' C----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) C----------------------------------------------------------------------- CHARACTER otlstr*(PCOLCR),usfxtl*(PCOLCR*PUREG),outstr*(PCOLCR) LOGICAL Lmodel,Lx11,X11agr,Lseats,Lcomp,Lgraf,lyy,lyy2,lncset, & lnlset,otlfix,upuser,lastfx,bfx2,upusrx,lstxfx,ssdbak, & ssidbk INTEGER otl,Iagr,notstr,strinx,i,j,msrtmp,Ltmax,nusfx,nusftl, & usfptr,igrp,ipos,Ncomp C----------------------------------------------------------------------- DIMENSION bfx2(PB),usfptr(0:PUREG) C----------------------------------------------------------------------- EXTERNAL strinx REAL ticks C----------------------------------------------------------------------- CALL intlst(PUREG,usfptr,nusftl) nusfx=nusftl+1 C----------------------------------------------------------------------- c Initialize variables C----------------------------------------------------------------------- lncset=Ncol.gt.0 lnlset=Nlen.GT.0 IF(Iagr.eq.5)THEN IF((.not.lncset).and.(.not.lnlset).and.(.not.Lcomp))THEN Ncol=Indcol Nlen=Indlen END IF END IF CALL setssp(Issap,Begspn,Pos1ob,Posfob,Ltmax,Lmodel,Lseats,lncset, & lnlset,otlfix) IF(Lfatal.or.Issap.eq.0)RETURN Issap=2 c----------------------------------------------------------------------- C Activate no-print option and print no plots c----------------------------------------------------------------------- IF(Sstran)Lhiddn=T DO i=1,NTBL IF(i.lt.LRVHDR.or.i.gt.LSSTDS)THEN IF(Sstran)THEN Prttab(i)=F Savtab(i)=F ELSE IF(i.ne.LESTES.and.i.ne.LXRXRG.and.i.ne.(LXRXRG+1))Savtab(i)=F END IF END IF END DO DO i=1,NSVLOG IF(i.lt.LSLASA.or.i.gt.(LSLPCT+1))Svltab(i)=F END DO IF(Svltab(LSLPCT+1))THEN IF(.not.Svltab(LSLPCT))Svltab(LSLPCT)=T END IF C----------------------------------------------------------------------- c Check options for indirect sliding spans analysis, C----------------------------------------------------------------------- IF(Iagr.eq.5)THEN IF(Indssp.eq.NOTSET)THEN Indssp=-3 ELSE IF(Indssp.gt.0)THEN IF(Nscomp.lt.Ncomp)THEN Indssp=-4 ELSE IF(Indlen.ne.Nlen)THEN Indssp=-5 ELSE IF(Indcol.ne.Ncol)THEN Indssp=-6 END IF IF(Lcomp)Indssp=0 END IF END IF C----------------------------------------------------------------------- c Set up and perform transparent seasonal adjustments for sliding c spans diagonstics C----------------------------------------------------------------------- msrtmp=Lmsr ssdbak=Ssdiff ssidbk=Ssidif Ierhdr=NOTSET DO j=1,Ncol CALL x11int * IF(Ltimer)THEN * CALL cpu_time(ticks) * WRITE(Nform,9000) 'bssx11a',j,':',ticks * END IF CALL ssx11a(j,Lmodel,Lx11,Lseats,msrtmp,Ncol,Nlen,Ixreg,otlfix, & Ssinit,Ssxotl,Ssxint) * IF(Ltimer)THEN * CALL cpu_time(ticks) * WRITE(Nform,9000) 'essx11a',j,':',ticks * END IF IF(Lfatal)RETURN IF(Ixreg.eq.3)Ixreg=2 C----------------------------------------------------------------------- c Reset model parameters to original values. C----------------------------------------------------------------------- IF(Ssinit.eq.2)THEN DO i=1,PARIMA IF(.not.Arimaf(i))Arimap(i)=DNOTST END DO DO i=1,PB IF(Iregfx.eq.0)B(i)=DNOTST END DO IF(Ixreg.gt.0)THEN DO i=1,PB IF(Irgxfx.eq.0)Bx(i)=DNOTST END DO END IF END IF c---------------------------------------------------------------------- c check user defined regressors to see if they are well-defined c for this span. c---------------------------------------------------------------------- upuser=F upusrx=F lastfx=Userfx lstxfx=Usrxfx IF(Nusxrg.gt.0)THEN CALL copylg(Regfxx,Nbx,1,bfx2) CALL chusrg(upusrx,usfxtl,nusfx,nusftl,usfptr) IF(Lfatal)RETURN IF(upusrx)THEN IF(.not.Usrxfx)Usrxfx=T CALL bakusr(Xuserx,Usxtyp,Usrxpt,Nusxrg,Usrxtt,Regfxx,Bx, & Rgxvtp,Nxgrp,Grpttx,Grpx,Gpxptr,Ngrptx,1, & .not.lstxfx) END IF END IF IF(Ncusrx.gt.0)THEN CALL copylg(Regfx,Nb,1,bfx2) CALL chusrg(upuser,usfxtl,nusfx,nusftl,usfptr) IF(Lfatal)RETURN IF(upuser)THEN IF(.not.Userfx)Userfx=T CALL bakusr(Userx,Usrtyp,Usrptr,Ncusrx,Usrttl,Regfx,B,Rgvrtp, & Ngrp,Grpttl,Grp,Grpptr,Ngrp,0,.not.lastfx) CALL ssprep(T,F,F) END IF END IF C----------------------------------------------------------------------- * IF(Ltimer)THEN * CALL cpu_time(ticks) * WRITE(Nform,9000) 'bx11ari',j,':',ticks * END IF CALL x11ari(Lmodel,Lx11,X11agr,Lseats,Lcomp,Issap,Irev,Irevsa, & Ixreg,0,F,F) * IF(Ltimer)THEN * CALL cpu_time(ticks) * WRITE(Nform,9000) 'ex11ari',j,':',ticks * END IF C----------------------------------------------------------------------- c If there was an error in the ARIMA model estimation, print out c the error message here. C----------------------------------------------------------------------- IF(Armaer.eq.PMXIER)THEN CALL abend RETURN ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF IF(Lfatal)RETURN C----------------------------------------------------------------------- C If Seats seasonal adjustment for span is unadmissable, print C message and leave routine. C----------------------------------------------------------------------- IF(Issap.lt.0)THEN Issap=0 RETURN END IF C----------------------------------------------------------------------- c Remove outliers added to regression variables C----------------------------------------------------------------------- IF(Notrtl.gt.0)THEN DO i=1,Notrtl CALL getstr(Otrttl,Otrptr,Notrtl,i,otlstr,notstr) IF(Lfatal)RETURN otl=strinx(T,Colttl,Colptr,1,Nb,otlstr(1:notstr)) IF(otl.gt.0)THEN CALL dlrgef(otl,Nrxy,1) IF(Lfatal)RETURN END IF END DO CALL ssprep(T,F,F) END IF C----------------------------------------------------------------------- C Add user-defined regressors deleted back into regression matrix C----------------------------------------------------------------------- IF(upuser)THEN CALL copylg(bfx2,Nb,1,Regfx) Userfx=lastfx CALL ssprep(T,F,F) END IF IF(upusrx)THEN CALL copylg(bfx2,Nb,1,Regfxx) Usrxfx=lstxfx END IF END DO C----------------------------------------------------------------------- c Reset sliding span indicator, add to header if Ierhdr has changed C----------------------------------------------------------------------- Issap=3 IF(Ierhdr.ne.NOTSET)CALL errhdr C----------------------------------------------------------------------- IF(Ssdiff.and.(.not.ssdbak))THEN CALL writln('NOTE: Seasonally adjusted values for at least one of &the spans was',Mt1,Mt2,T) CALL writln(' less than or equal to zero.',Mt1,Mt2,T) CALL writln(' The sliding spans analysis will be calculated &from the maximum ',Mt1,Mt2,F) CALL writln(' differences of the seasonally adjusted series &rather than ',Mt1,Mt2,F) CALL writln(' the implied adjustment factors.',Mt1,Mt2,F) END IF C----------------------------------------------------------------------- IF(nusftl.gt.0)THEN CALL writln('NOTE: The user defined regressors listed below were &held fixed',Mt1,Mt2,T) CALL writln(' for at least one span during the sliding spans & analysis:',Mt1,Mt2,F) DO igrp=1,nusftl CALL getstr(usfxtl,usfptr,nusfx,igrp,outstr,ipos) IF(Lfatal)RETURN CALL writln(' '//outstr(1:ipos),Mt1,Mt2,F) END DO END IF C----------------------------------------------------------------------- c If summary measures run, return C----------------------------------------------------------------------- IF(Kfulsm.eq.1.or.(Kfulsm.eq.2.and.(Itd.eq.0.and.Ihol.eq.0))) & RETURN c----------------------------------------------------------------------- c Determine if year-to-year changes are to be printed out c----------------------------------------------------------------------- lyy=Prttab(LSSYPC).or.Prttab(LSSYSM) lyy2=(Prttab(LSSYPC+1).or.Prttab(LSSYSM+1)).and.Iagr.eq.5 C----------------------------------------------------------------------- c Print out sliding spans header and F-tests for each span c----------------------------------------------------------------------- IF((Prttab(LSSSHD).or.Prttab(LSSFTS)).and.Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(Prttab(LSSSHD).or.Savtab(LSSSHD)) & CALL ssphdr(Serno,Iagr,Ncol,Nlen,Ssfxrg,Nssfxr,lyy,lyy2,Ssinit, & Ssdiff,lncset,lnlset,Prttab(LSSSHD),Savtab(LSSSHD)) IF((Prttab(LSSFTS).or.Savtab(LSSFTS)).and.(.not.Lseats)) & CALL ssftst(Ncol,Prttab(LSSFTS),Savtab(LSSFTS)) c----------------------------------------------------------------------- c Determine if year-to-year changes are to be computed c----------------------------------------------------------------------- lyy=Prttab(LSSYPC).or.Prttab(LSSYSM).or.Prttab(LSSYCS).or. & Savtab(LSSYPC).or.Savtab(LSSYSM).or.Savtab(LSSYCS).or.Lgraf lyy2=(Prttab(LSSYPC+1).or.Prttab(LSSYSM+1).or.Prttab(LSSYCS+1).or. & Savtab(LSSYPC+1).or.Savtab(LSSYSM+1).or.Savtab(LSSYCS+1).or. & Lgraf).and.Iagr.eq.5 C----------------------------------------------------------------------- c Perform sliding spans analysis C----------------------------------------------------------------------- IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9001) 'bssap:',ticks END IF CALL ssap(S,Sa,Td,Isfadd,Iagr,Ncol,Nlen,Lsumm,lyy,Ssdiff,Lgraf) IF(Lfatal)RETURN IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9001) 'essap:',ticks END IF c----------------------------------------------------------------------- c If this is a composite run, perform sliding spans for indirect c adjustment C----------------------------------------------------------------------- IF(Iagr.eq.5)THEN IF(Indssp.gt.0)THEN Iagr=6 IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1020) C----------------------------------------------------------------------- IF(Lsumm.gt.0)WRITE(Nform,1090)'yes' C----------------------------------------------------------------------- IF(Ssidif.and.(.not.ssidbk))THEN CALL writln('NOTE: The indirect seasonal adjustment for at leas &t one of the spans',Mt1,Mt2,T) CALL writln(' was less than or equal to zero.',Mt1,Mt2,T) CALL writln(' The sliding spans analysis will be calculate &d from the maximum',Mt1,Mt2,F) CALL writln(' differences of the indirect seasonally adjus &ted series rather',Mt1,Mt2,F) CALL writln(' than the implied adjustment factors.', & Mt1,Mt2,F) END IF CALL ssap(Sfind,Saind,Td,Sfinda,Iagr,Ncol,Nlen,Lsumm,lyy2, & Ssidif,Lgraf) ELSE IF(Lsumm.gt.0)WRITE(Nform,1090)'no' IF(Indssp.eq.-1)THEN c insert error message for different span length or number of spans c found for component WRITE(Mt1,1030) WRITE(Mt2,1030) ELSE IF(Indssp.eq.-2)THEN c insert error message for different span length or number of spans c found for component WRITE(Mt1,1040) WRITE(Mt2,1040) ELSE IF(Indssp.eq.-3)THEN c insert error message for no sliding spans analysis of component WRITE(Mt1,1050)Ncomp WRITE(Mt2,1050)Ncomp ELSE IF(Indssp.eq.-4)THEN WRITE(Mt1,1060)Ncomp,Nscomp WRITE(Mt2,1060)Ncomp,Nscomp ELSE IF(Indssp.eq.-5)THEN c insert error message for different span length for direct WRITE(Mt1,1070) WRITE(Mt2,1070) ELSE IF(Indssp.eq.-6)THEN c insert error message for different number of spans for direct WRITE(Mt1,1080) WRITE(Mt2,1080) END IF END IF END IF C----------------------------------------------------------------------- IF(.not.Lfatal)Lhiddn=F C----------------------------------------------------------------------- RETURN C----------------------------------------------------------------------- * 1010 FORMAT(80A1) 1020 FORMAT(//,' Sliding spans analysis: Indirect seasonal ', & 'adjustment',/) 1030 FORMAT(/,' NOTE: Different span lengths were used for the ', & 'sliding spans analysis ', & /,' of the component seasonal adjustments.',/, & /,' Sliding spans analysis of the indirect ', & 'seasonal adjustments will not', & /,' be produced. Use the length argument of the ', & 'slidingspans spec ', & /,' to ensure an appropriate span length is ', & 'specified for each ', & /,' of the component spec files.') 1040 FORMAT(/,' NOTE: The number of sliding spans used for the ', & 'sliding spans analysis ', & /,' has changed for one of the components in the ', & 'composite seasonal adjustment.',/, & /,' Sliding spans analysis of the indirect ', & 'seasonal adjustments will not', & /,' be produced. Check the numspan argument', & ' of the slidingspans spec ', & /,' to ensure the same number of sliding spans is ', & 'specified for each ', & /,' of the component spec files.') 1050 FORMAT(/,' NOTE: Composite seasonal adjustment performed with ', & i3,' components, ', & /,' but the indirect seasonal adjustment for the', & ' sliding spans', & /,' was updated for none of the components.',/, & /,' Sliding spans analysis of the indirect ', & 'seasonal adjustments will not', & /,' be produced. Ensure that a slidingspans spec', & ' is present in the', & /,' spec files of all the components.') 1060 FORMAT(/,' NOTE: Composite seasonal adjustment performed with ', & i3,' components, ', & /,' but the indirect seasonal adjustment for the', & ' sliding spans', & /,' was updated for only ',i3,' components.',/, & /,' Sliding spans analysis of the indirect ', & 'seasonal adjustments will not', & /,' be produced. Check for errors in the ', & 'sliding spans analysis of the', & /,' components, and ensure that a slidingspans spec', & ' is present in the', & /,' spec files of all the components.') 1070 FORMAT(/,' NOTE: A different span length was specified for ', & 'the sliding spans analysis', & /,' of the direct seasonal adjustment of the ', & 'composite than was used for', & /,' the component seasonal adjustments.',/, & /,' Sliding spans analysis of the indirect ', & 'seasonal adjustments will not', & /,' be produced. Use the length argument of the ', & 'slidingspans spec ', & /,' to ensure the same span length is used for', & ' sliding spans analysis ', & /,' of the direct seasonal adjustment and the ', & 'component adjustments.') 1080 FORMAT(/,' NOTE: A different number of sliding spans was ', & 'specified for the', & /,' sliding spans analysis of the direct seasonal ', & 'adjustment of the', & /,' composite than was used for the component', & ' seasonal adjustments.',/, & /,' Sliding spans analysis of the indirect ', & 'seasonal adjustments will not', & /,' be produced. Use the length argument of the ', & 'slidingspans spec ', & /,' to ensure the same span length is used for', & ' sliding spans analysis ', & /,' of the direct seasonal adjustment and the ', & 'component adjustments.') 1090 FORMAT('indsspans: ',a) * 9000 FORMAT(a,i1,a,e15.8) 9001 FORMAT(a,e15.8) END ssphdr.f0000664006604000003110000001741614521201574011655 0ustar sun00315stepsC Last change: BCM 26 Feb 1999 9:38 am SUBROUTINE ssphdr(Serno,Iagr,Ncol,Nlen,Ssfxrg,Nssfxr,Lyy,Lyy2, & Ssinit,Ssdiff,Lncset,Lnlset,Lprt,Lsav) IMPLICIT NONE c----------------------------------------------------------------------- C ***** PRINTS HEADING THAT IDENTIFIES WHICH OPTIONS ARE BEING USED C ***** IN A GIVEN SLIDING SPANS ANALYSIS. c----------------------------------------------------------------------- INTEGER ZERO,MINUS1,MINUS2 PARAMETER(ZERO=0,MINUS1=-1,MINUS2=-2) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'units.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'force.cmn' c----------------------------------------------------------------------- c correct dimension length for Ssfxrg (BCM May 2007) CHARACTER setstr*(13) INTEGER Ssfxrg,Nssfxr,Ncol,Nlen,i,Iagr,Ssinit LOGICAL Lyy,Lyy2,Lprt,Lsav,Lncset,Lnlset,Ssdiff CHARACTER Serno*8 DIMENSION Ssfxrg(4) c---------------------------------------------------------------------- c Save sliding spans information for diagnostic program c---------------------------------------------------------------------- IF(Lsav)THEN WRITE(Nform,1021)'sspans','yes' WRITE(Nform,1010)Ncol,Nlen,Im,Iyr 1010 FORMAT('ssa: ',4I5) WRITE(Nform,1020)(Cut(i,1),i=1,5) 1020 FORMAT('sscut: ',5F7.2) IF(Itd.eq.1)THEN WRITE(Nform,1021)'sstd','yes' ELSE WRITE(Nform,1021)'sstd','no' END IF IF(Ssdiff)THEN WRITE(Nform,1021)'ssdiff','yes' ELSE WRITE(Nform,1021)'ssdiff','no' END IF 1021 FORMAT(a,': ',a) END IF IF(.not.Lprt)RETURN c----------------------------------------------------------------------- IF(Iagr.lt.5)WRITE(Mt1,1030) 1030 FORMAT(//,' Sliding spans analysis',//, & ' S 0. Summary of options selected for this run',//) IF(Iagr.eq.5)WRITE(Mt1,1040) 1040 FORMAT(//,' Sliding spans analysis:Direct seasonal adjustment', & //,' S 0. Summary of options selected for this run',//) c---------------------------------------------------------------------- IF(Lncset)THEN setstr = '(set by user)' ELSE setstr = ' ' END IF WRITE(Mt1,1070)'Number',Ncol,setstr IF(Lnlset)THEN setstr = '(set by user)' ELSE setstr = ' ' END IF WRITE(Mt1,1070)'Length',Nlen,setstr 1070 FORMAT(' ',a,' of spans : ',i5,3x,a) c---------------------------------------------------------------------- IF(Nsea.eq.12)THEN WRITE(Mt1,1080)Im,Iyr 1080 FORMAT(' Month of first observation in first span : ',i5,/, & ' Year of first observation in first span : ',i5) IF(Ic.gt.(Im+Nsea))WRITE(Mt1,1090)Icm,Icyr 1090 FORMAT(' Month of first observation used in sliding spans ', & 'comparison : ',i5,/, & ' Year of first observation used in sliding spans ', & 'comparison : ',i5) ELSE IF(Nsea.eq.4)THEN WRITE(Mt1,1100)Im,Iyr 1100 FORMAT(' Quarter of first observation in first span : ',i5,/, & ' Year of first observation in first span : ',i5) IF(Ic.gt.(Im+Nsea))WRITE(Mt1,1110)Icm,Icyr 1110 FORMAT(' Quarter of first observation used in sliding spans ', & 'comparison : ',i5,/, & ' Year of first observation used in sliding spans ', & 'comparison : ',i5) END IF c---------------------------------------------------------------------- WRITE(Mt1,1120)Serno 1120 FORMAT(' Name of series being adjusted : ',a8) c---------------------------------------------------------------------- IF(Itd.eq.1)WRITE(Mt1,1050) 1050 FORMAT(' Trading day factors analyzed') IF((Itd.eq.1.or.Ihol.eq.1.or.Muladd.eq.1).and.Iyrt.gt.0) & WRITE(MT1,1060) 1060 FORMAT(' Seasonally adjusted series with revised yearly totals us &ed in this analysis.') c----------------------------------------------------------------------- IF(Lyy.and.Lyy2)THEN WRITE(Mt1,1061)' for direct and indirect seasonal adjustments.' ELSE IF(Lyy2) THEN WRITE(Mt1,1061)' for indirect seasonal adjustments only.' ELSE IF(Lyy.and.Iagr.eq.5) THEN WRITE(Mt1,1061)' for direct seasonal adjustments only.' ELSE IF(Lyy) THEN WRITE(Mt1,1061)'.' END IF 1061 FORMAT(' Year-to-year changes analyzed',a) c---------------------------------------------------------------------- IF(Ssinit.eq.1)THEN WRITE(Mt1,1139) 1139 FORMAT(' regARIMA model coefficients held fixed during ', & 'sliding spans analysis.') ELSE IF(Nssfxr.gt.0)THEN WRITE(Mt1,1140) 1140 FORMAT(' Regressors held fixed during sliding spans analysis:') DO i=1,Nssfxr IF(Ssfxrg(i).eq.1)THEN WRITE(Mt1,1141)'Trading Day' ELSE IF(Ssfxrg(i).eq.2)THEN WRITE(Mt1,1141)'Holiday' ELSE IF(Ssfxrg(i).eq.3)THEN WRITE(Mt1,1141)'User-defined regressors' ELSE IF(Ssfxrg(i).eq.4)THEN WRITE(Mt1,1141)'Outliers' END IF 1141 FORMAT(' - ',a) END DO END IF c---------------------------------------------------------------------- IF(Ncol.lt.4)THEN IF(Lncset)THEN WRITE(Mt1,1130)'By choice of the user' ELSE WRITE(Mt1,1130)'Due to the series length' END IF END IF 1130 FORMAT(/,' WARNING: ',a,', fewer than four spans have been used', & /,10x,'to compile the measures generated below.',//, & 10x,'In this situation, the threshold values used to ', & 'determine',/, & 10x,'adjustability (15%, 25%, 40%) which appear with ', & 'the summary',/, & 10x,'tables should be lowered.') IF(Itd.EQ.MINUS1.and.Ihol.le.ZERO)THEN WRITE(Mt1,2000) WRITE(Mt2,2000) ELSE IF(Ihol.EQ.MINUS1.and.Itd.le.ZERO)THEN WRITE(Mt1,2001) WRITE(Mt2,2001) END IF IF(Itd.eq.MINUS2.and.IHOL.eq.MINUS2)THEN WRITE(Mt1,2002)'trading day and holiday' ELSE IF(Itd.eq.MINUS2)THEN WRITE(Mt1,2002)'trading day' ELSE IF(Ihol.eq.MINUS2)THEN WRITE(Mt1,2002)'holiday' END IF c---------------------------------------------------------------------- 2000 FORMAT(/,' NOTE: Since the trading day coefficients are fixed ', & 'in the sliding spans',/, & ' analysis, the trading day statistics of the ', & 'sliding spans analysis',/,' are not printed.', & //,' In addition, the spans statistics for the ', & 'seasonally adjusted',/, & ' series have the same values as the ', & 'corresponding statistics',/, & ' for the seasonal factors. In this case, the ', & 'statistics for the',/, & ' seasonally adjusted series are not printed.',/) 2001 FORMAT(/,' NOTE: Since the holiday coefficients are fixed in ', & 'the sliding spans analysis,',/, & ' the spans statistics for the seasonally adjusted ', & 'series have',/, & ' the same values as the corresponding statistics ', & 'for the seasonal',/, & ' factors. In this case, the statistics for the ', & 'seasonally adjusted',/, & ' series are not printed.',/) 2002 FORMAT(/,' ERROR: Length of sliding span is too short for ', & a,' estimation.', & /,' At least five years of data are needed.') RETURN END sspinp.cmn0000664006604000003110000000526514521201574012215 0ustar sun00315stepsc Sstran - Do not print out tables from transparent modeling and c seasonal adjustments generated during sliding spans c analysis (if true) c----------------------------------------------------------------------- LOGICAL Sstran c----------------------------------------------------------------------- c Ncol - number of sliding spans c Nlen - length of sliding spans c Ssotl - indicator variable determining how outliers are treated c in sliding spans (0=keep,1=remove,2=auto identify) c Ssinit - indicator variable determining how REGARIMA parameter c estimates are initialized and whether they are fixed c during the sliding spans analysis c Strtss - Starting date for sliding spans analysis specifed by the c user c Ssfxrg - Integer array that determines which regressors are fixed c during the sliding spans analysis for the regARIMA model c (1-td, 2-holiday, 3-user defined regressors, 4-outlier) c Nssfxr - number of elements defined in Ssfxrg c Ssfxxr - Integer array that determines which regressors are fixed c during the sliding spans analysis for the irregular c regression model c (1-td, 2-holiday, 3-user defined regressors, 4-outlier) c Nssfxx - number of elements defined in Ssfxxr c----------------------------------------------------------------------- INTEGER Ssfxrg,Nssfxr,Ssfxxr,Nssfxx,Ncol,Nlen,Ssotl,Ssinit,Strtss c----------------------------------------------------------------------- c Ssdiff - logical indicator variable in sliding spans that c differences are to be analyzed for additive adjustments c Ssidif - logical indicator variable in sliding spans that c differences are to be analyzed for additive indirect c adjustments c Ssxotl - logical indicator variable determining how irregular c regression outliers are treated in sliding spans c Ssxint - indicator variable determining how irregular regression c parameter estimates are initialized and whether they are c fixed during the sliding spans analysis c----------------------------------------------------------------------- LOGICAL Ssdiff,Ssidif,Ssxotl,Ssxint c----------------------------------------------------------------------- DIMENSION Ssfxrg(4),Ssfxxr(4),Strtss(2) c----------------------------------------------------------------------- COMMON /sspinp/ Ncol,Nlen,Ssotl,Ssinit,Ssfxrg,Nssfxr,Ssfxxr, & Nssfxx,Strtss,Sstran COMMON /ssplog/ Ssdiff,Ssidif,Ssxotl,Ssxint ssprep.cmn0000664006604000003110000000315014521201574012204 0ustar sun00315stepsc----------------------------------------------------------------------- c Last change:Nov.2, 2023 add Nrusrx2 to save Nrusrx variable c These variables are all duplicates for other variables that are c changed during the sliding spans and revisions history analysis. c They are used to reset these variables after each span has been c run. c----------------------------------------------------------------------- CHARACTER Cttl*(PCOLCR*PB),Gttl*(PGRPCR*PGRP) DOUBLE PRECISION Bb,Ap2,Tc2,V2,Chx2,Chg2,Acm2,Dtcv2 INTEGER Clptr,Ngr2,Ngrt2,Gptr,G2,Nbb,Kfm2,Ksw2,Ncxy2,Pri2, & Atd,Ahol,AAO,ALS,ATC,Aso,Asea,Ausr,Nct2,Lt2,Rgv2,Nr2, & Ktc2,Ncusr2,Nrusrx2,Irfx2,Nintv2,Nextv2,Mxdfl2, & Mxarl2,Mxmal2,Acyc LOGICAL Flltd,Fxa,Fnhol,FnAO,FnLS,FnTC,Fnusr,Pktd2,Regfx2,Lma2, & Lar2 DIMENSION Ap2(PARIMA),Clptr(0:PB),Gptr(0:PGRP),G2(0:PGRP),Bb(PB), & Fxa(PARIMA),Lt2(12),Rgv2(PB),Regfx2(PB),Chx2(PXPX), & Chg2(PGPG),Acm2(PLEN+2*PORDER,PARIMA) c----------------------------------------------------------------------- COMMON /ssprp / Ap2,Bb,Chx2,Chg2,Tc2,V2,Acm2,Dtcv2,Atd,Ahol,AAO, & ALS,ATC,Aso,Asea,Acyc,Ausr,Ncxy2,Nct2,Nbb,Ksw2, & Ncusr2,Ktc2,Kfm2,Lt2,Clptr,Ngr2,Ngrt2,G2,Gptr, & Rgv2,Nr2,Pri2,Irfx2,Nintv2,Nextv2,Mxdfl2,Mxarl2, & Mxmal2,Flltd,Fxa,Fnhol,FnAO,FnLS,FnTC,Fnusr, & Regfx2,Pktd2,Lma2,Lar2,Cttl,Gttl,Nrusrx2 c----------------------------------------------------------------------- ssprep.f0000664006604000003110000000737714521201574011673 0ustar sun00315stepsC Last change: Nov.2, 2023, save nrusrx value C previous change: BCM 16 Feb 1999 3:56 pm SUBROUTINE ssprep(Lmodel,Lx11,Lx11rg) IMPLICIT NONE c----------------------------------------------------------------------- c Prepare for sliding spans or revision analysis by storing seasonal c adjustment options into temporary variables. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'ssprep.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- INTEGER PACM PARAMETER(PACM=(PLEN+2*PORDER)*PARIMA) c----------------------------------------------------------------------- INTEGER i LOGICAL Lmodel,Lx11,Lx11rg c----------------------------------------------------------------------- C **** Store selected options for seasonal adjustment in temporary C **** variables. c----------------------------------------------------------------------- c Store prior adjustment option c----------------------------------------------------------------------- Kfm2=Kfmt IF(Nprtyp.eq.0.and.Kfm2.gt.0.AND.(.not.Lpradj))Kfm2=0 c----------------------------------------------------------------------- IF(Lx11)THEN DO i=1,12 Lt2(i)=Lter(i) END DO c Lop2=Lopt Ktc2=Ktcopt Tc2=Tic END IF c----------------------------------------------------------------------- IF(Lx11rg)THEN c DO i=1,7 c Dwt2(i)=Dwt(i) c END DO Ksw2=Kswv END IF c----------------------------------------------------------------------- c **** Store model parameters to be saved in temporary variables c----------------------------------------------------------------------- IF(Lmodel)THEN c----------------------------------------------------------------------- c Reset value of Priadj if reset in tdlom subroutine. c----------------------------------------------------------------------- IF(Picktd.and.Fcntyp.eq.1.and.Priadj.le.0)THEN Priadj=Pri2 ELSE Pri2=Priadj END IF c----------------------------------------------------------------------- Ngr2=Ngrp Ngrt2=Ngrptl Ncxy2=Ncxy Nbb=Nb Nct2=Ncoltl i=PCOLCR*PB Cttl(1:i)=Colttl(1:i) i=PGRPCR*PGRP Gttl(1:i)=Grpttl(1:i) CALL cpyint(Colptr(0),PB+1,1,Clptr(0)) CALL cpyint(Grp(0),PGRP+1,1,G2(0)) CALL cpyint(Grpptr(0),PGRP+1,1,Gptr(0)) CALL cpyint(Rgvrtp,PB,1,Rgv2) CALL copy(Arimap,PARIMA,1,Ap2) CALL copy(B,PB,1,Bb) CALL copylg(Arimaf,PARIMA,1,Fxa) Nr2=Nrxy Ncusr2=Ncusrx Nrusrx2=Nrusrx Irfx2=Iregfx CALL copylg(Regfx,PB,1,Regfx2) Pktd2=Picktd Atd=Adjtd Ahol=Adjhol Aao=Adjao Als=Adjls Atc=Adjtc Aso=Adjso Asea=Adjsea Acyc=Adjcyc Ausr=Adjusr Fnhol=Finhol Fnao=Finao Fnls=Finls Fntc=Fintc Fnusr=Finusr Flltd=Fulltd Lma2=Lma Lar2=Lar Nintv2=Nintvl Nextv2=Nextvl Mxdfl2=Mxdflg Mxarl2=Mxarlg Mxmal2=Mxmalg V2=Var CALL copy(Chlxpx,PXPX,1,Chx2) CALL copy(Chlgpg,PGPG,1,Chg2) CALL copy(Armacm,PACM,1,Acm2) Dtcv2=Lndtcv END IF c----------------------------------------------------------------------- RETURN END ssptbl.i0000664006604000003110000000244314521201574011656 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c slidingspans SSP or SS c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c sliding spans header SHD c sliding spans ftests FTS c range analysis RNG c percent flagged PCT c summary tables SUM c seasonal fac spans SFS c changes spans CHS c sa spans SAS c yearly changes spans YCS c td spans TDS c----------------------------------------------------------------------- INTEGER LSSSHD,LSSFTS,LSSFMN,LSSPCT,LSSYPC,LSSSUM,LSSYSM,LSSSFS, & LSSCHS,LSSSAS,LSSYCS,LSSTDS PARAMETER( & LSSSHD=268,LSSFTS=269,LSSFMN=270,LSSPCT=272,LSSYPC=274, & LSSSUM=276,LSSYSM=278,LSSSFS=280,LSSCHS=282,LSSSAS=284, & LSSYCS=286,LSSTDS=288) sspvec.cmn0000664006604000003110000000112614521201574012174 0ustar sun00315steps DOUBLE PRECISION Aobs,Ayr,Aobsmx,Ayrmx INTEGER Chsgn,Iturn,SSnobs,SSnyr,Csign,Cturn,Per c----------------------------------------------------------------------- DIMENSION Aobs(PSP,NEST),Ayr(MXYR,NEST),Chsgn(NEST),Iturn(NEST), & Csign(MXLEN,NEST),Cturn(MXLEN,NEST),Per(MXLEN,NEST), & SSnobs(PSP,NEST),SSnyr(MXYR,NEST),Aobsmx(NEST), & Ayrmx(NEST) c----------------------------------------------------------------------- COMMON /ssvec / Aobs,Ayr,Aobsmx,Ayrmx,Chsgn,Iturn,SSnobs,SSnyr, & Csign,Per,Cturn ssrit.f0000664006604000003110000001074014521201574011507 0ustar sun00315stepsC Last change: BCM 26 Feb 1999 3:52 pm SUBROUTINE ssrit(X,L1,L2,Isec,Series) IMPLICIT NONE c----------------------------------------------------------------------- c ***** stores results from x-11.2 runs into sliding spans variables. c ***** convert results from double to single precision. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'agr.cmn' INCLUDE 'agrsrs.cmn' INCLUDE 'lzero.cmn' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'sspdat.cmn' INCLUDE 'ssft.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONEHND PARAMETER(ONEHND=100D0) c----------------------------------------------------------------------- INTEGER i,i0,Isec,L1,l10,L2,l20,ll0 DOUBLE PRECISION Series,X DIMENSION X(PLEN),Series(PLEN) c----------------------------------------------------------------------- IF(Isec.eq.0)L0=L0+Nsea c----------------------------------------------------------------------- c set options or check for indirect sliding spans, as necessary c----------------------------------------------------------------------- IF(Iagr.eq.2.and.Isec.eq.3.and.Icol.eq.1.and.Iag.ge.0)THEN Nscomp=Nscomp+1 IF(Indssp.eq.NOTSET)THEN Indssp=1 Indcol=Ncol Indlen=Nlen ELSE IF (Indssp.gt.0)THEN IF(Nlen.ne.Indlen)THEN Indssp=-1 ELSE IF(Ncol.ne.Indcol)THEN Indssp=-2 END IF END IF END IF c----------------------------------------------------------------------- l10=L1-L0+1 IF(l10.ne.1)THEN DO i=1,l10-1 IF(Isec.le.1)Td(i,Icol)=DNOTST IF(Isec.eq.2)S(i,Icol)=DNOTST IF(Isec.eq.3)THEN Sa(i,Icol)=DNOTST IF(Muladd.eq.1)Isfadd(i,Icol)=DNOTST IF(Iagr.eq.2.and.Iag.ge.0)THEN Saind(i,Icol)=DNOTST Sfind(i,Icol)=DNOTST Sfinda(i,Icol)=DNOTST END IF END IF END DO END IF DO i=L1,L2 i0=i-L0+1 c xss = sngl(x(i)) IF(Isec.le.1)THEN IF(Muladd.eq.1)THEN Td(i0,Icol)=X(i) ELSE Td(i0,Icol)=X(i)*ONEHND END IF END IF IF(Isec.eq.2)THEN IF(Muladd.eq.1)THEN S(i0,Icol)=X(i) ELSE S(i0,Icol)=X(i)*ONEHND END IF END IF IF(Isec.eq.3)THEN Sa(i0,Icol)=X(i) IF(Muladd.eq.1.and.Kfulsm.eq.0.and.(.not.Ssdiff))THEN IF(X(i).gt.0D0)THEN Isfadd(i0,Icol)=(Series(i)/X(i))*ONEHND ELSE Ssdiff=.true. END IF END IF c----------------------------------------------------------------------- c update variables of sliding spans analysis of c----------------------------------------------------------------------- IF(Indssp.gt.0)THEN IF(Iagr.eq.2)THEN IF(Iag.eq.0)Saind(i0,Icol)=Saind(i0,Icol)+(X(i)*W) IF(Iag.eq.1)Saind(i0,Icol)=Saind(i0,Icol)-(X(i)*W) IF(Iag.eq.2)Saind(i0,Icol)=Saind(i0,Icol)*(X(i)*W) IF(Iag.eq.3)Saind(i0,Icol)=Saind(i0,Icol)/(X(i)*W) ELSE IF(Iagr.gt.2)THEN IF(Muladd.eq.1)THEN Sfind(i0,Icol)=O2(i)-Saind(i0,Icol) IF(.not.Ssidif)THEN IF(Saind(i0,Icol).gt.0D0)THEN Sfinda(i0,Icol)=(O2(i)/Saind(i0,Icol))*ONEHND ELSE Ssidif=.true. END IF END IF ELSE Sfind(i0,Icol)=(O2(i)/Saind(i0,Icol))*ONEHND END IF END IF END IF END IF END DO c la=mod(Lfda,Nsea) c IF(la.eq.0)la=Nsea ll0=Sslen+Im+L0-2 l20=ll0 IF(mod(ll0,Nsea).ne.0)l20=((ll0/Nsea)+1)*Nsea IF(l20.eq.L2.and.Lstmo.lt.Nsea)l20=(Nsea-Lstmo)+l20 IF(l20.ne.L2)THEN DO i=L2+1,l20 i0=i-L0+1 IF(Isec.le.1)Td(i0,Icol)=DNOTST IF(Isec.eq.2)S(i0,Icol)=DNOTST IF(Isec.eq.3)THEN Sa(i0,Icol)=DNOTST IF(Muladd.eq.1)Isfadd(i0,Icol)=DNOTST IF(Iagr.eq.2)THEN Saind(i0,Icol)=DNOTST Sfind(i0,Icol)=DNOTST Sfinda(i0,Icol)=DNOTST END IF END IF END DO END IF IF(Isec.eq.0)L0=L0-Nsea RETURN END ssrng.f0000664006604000003110000001405714521201574011504 0ustar sun00315stepsC Last change: BCM 15 Oct 1998 1:35 pm SUBROUTINE ssrng(X,Cpobs,Iagr,Lrange,Ncol,Muladd) IMPLICIT NONE c----------------------------------------------------------------------- c ***** performs range analysis of the seasonal factors. calculates c ***** monthly means of the seasonal factors for each span and c ***** for all spans (xavg), as well as the maximum percentage c ***** difference for the monthly means (xmpd). computes values of c ***** the range (xran) for monthly means c ***** and seasonal factors for each span and for all spans. prints c ***** out results. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'ssptbl.i' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- LOGICAL Lrange CHARACTER alab*(6),xcm*(3),clab*(6),Cpobs*(9),fmt1*(48),fmt2*(32), & fmt3*(48),numf*(1),sflab*(36) INTEGER i,Iagr,j,jsea,k,k1,Kountr,l,lagr,Muladd,narg,Ncol,nsflab DOUBLE PRECISION X,xavg,xmn,xmnx,xmpd,xmx,xran DIMENSION X(MXLEN,MXCOL),xavg((MXCOL+1),PSP),xmnx((MXCOL+1),2), & xran(MXCOL+1),xmpd(PSP),Kountr(MXCOL,PSP),clab(2,6), & Cpobs(20),numf(3),xcm((MXCOL+1),PSP) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- COMMON /kcom / Kountr c----------------------------------------------------------------------- DATA(numf(i),i=1,3)/'2','3','4'/ DATA(clab(1,i),i=1,6)/' ',' ',' ',' ', & ' Max %',' All '/ DATA(clab(2,i),i=1,6)/'Span 1','Span 2','Span 3','Span 4', & ' Diff.',' Spans'/ c----------------------------------------------------------------------- IF(Iagr.eq.6)THEN narg=1 ELSE narg=0 END IF DO i=1,5 xran(i)=0D0 DO j=1,Nsea IF(i.le.4)Kountr(i,j)=0 IF(j.le.2)xmnx(i,j)=100D0 xavg(i,j)=0D0 END DO END DO DO i=1,Ncol DO j=1,Sslen IF((.not.dpeq(X(j,i),DNOTST)).and.j.ge.Ic)THEN jsea=mod(j,Nsea) IF(jsea.eq.0)jsea=Nsea xavg(i,jsea)=xavg(i,jsea)+X(j,i) xavg(Ns1,jsea)=xavg(Ns1,jsea)+X(j,i) IF(xmnx(i,1).gt.X(j,i))xmnx(i,1)=X(j,i) IF(xmnx(i,2).lt.X(j,i))xmnx(i,2)=X(j,i) Kountr(i,jsea)=Kountr(i,jsea)+1 END IF END DO CALL compb(xavg,xmnx,xran,i,xcm,Ncol) END DO CALL compb(xavg,xmnx,xran,Ns1,xcm,Ncol) DO i=1,Nsea xmx=xavg(1,i) xmn=xavg(1,i) DO j=2,Ncol IF(xmx.lt.xavg(j,i))xmx=xavg(j,i) IF(xmn.gt.xavg(j,i))xmn=xavg(j,i) END DO xmpd(i)=((xmx-xmn)/xmn)*100D0 END DO IF(Prttab(LSSFMN+narg))THEN fmt1='(1x,a9,1x, (f8.2,1x,a3),f7.2,1x,f7.2,1x,a3,/)' fmt2='(/,2(7x, (6x,a6),5x,a6,2x,a6,/))' fmt1(11:11)=numf(Ncol-1) fmt2(9:9)=numf(Ncol-1) WRITE(Mt1,fmt2)((clab(i,j),j=1,Ncol),clab(i,5),clab(i,6),i=1,2) k1=0 IF(Nsea.eq.4)k1=12 DO k=1,Nsea WRITE(Mt1,fmt1)Cpobs(k+k1),(xavg(j,k),xcm(j,k),j=1,Ncol), & xmpd(k),xavg(Ns1,k),xcm(Ns1,k) END DO sflab=' ' nsflab=1 IF(Iagr.eq.6)THEN sflab(1:9)='indirect ' nsflab=9 END IF IF(Muladd.eq.1)THEN sflab((nsflab+1):(nsflab+26))='implied adjustment factors' nsflab=25+nsflab ELSE sflab((nsflab+1):(nsflab+16))='seasonal factors' nsflab=15+nsflab END IF WRITE(Mt1,1010)sflab(1:nsflab) 1010 FORMAT(/,' Summary statistics for mean ',a) WRITE(Mt1,1020) 1020 FORMAT(/,21x,'Min',12X,'Max',11X,'Range',/) DO k=1,Ncol WRITE(Mt1,1030)k,(xmnx(k,l),l=1,2),xran(k) 1030 FORMAT(4x,'Span ',i1,3(5x,f10.2),/) END DO WRITE(Mt1,1040)(xmnx(Ns1,l),l=1,2),xran(Ns1) 1040 FORMAT(2x,'All spans',4x,f10.2,2(5x,f10.2),/) END IF Lrange=T IF(xran(Ns1).lt.10)THEN Lrange=F WRITE(Mt1,1080) 1080 FORMAT(/,5X,'WARNING: Range of seasonal factors is too low ', & 'for summary sliding spans measures to be reliable.', & /,14x,'Summary sliding spans statistics not printed out') IF(narg.eq.0.and.((.not.Prttab(LSSTDS)).AND.Itd.eq.1)) & Prttab(LSSTDS)=T IF(.not.Prttab(LSSSFS+narg))Prttab(LSSSFS+narg)=T IF(.not.Prttab(LSSSAS+narg))Prttab(LSSSAS+narg)=T IF(.not.Prttab(LSSCHS+narg))Prttab(LSSCHS+narg)=T IF(.not.Prttab(LSSYCS+narg))Prttab(LSSYCS+narg)=T c IF(Prttab(LSSPCT+narg))Prttab(LSSPCT+narg)=F c IF(Prttab(LSSYPC+targ))Prttab(LSSYPC+targ)=F c IF(Prttab(LSSSUM+narg))Prttab(LSSSUM+narg)=F c IF(Savtab(LSSPCT+narg))Savtab(LSSPCT+narg)=F END IF c----------------------------------------------------------------------- IF(Savtab(LSSFMN+narg))THEN IF(Iagr.eq.6)THEN lagr=6 alab='issran' ELSE lagr=5 alab='ssran' END IF fmt3='(a,a,i2.2,a,1x,a3,3x, (f10.2,2x),f10.2,2x,f10.2)' fmt3(22:22)=numf(Ncol-1) k1=0 IF(Nsea.eq.4)k1=16 DO k=1,Nsea WRITE(Nform,fmt3)alab(1:lagr),'.p',k,':',Cpobs(k+k1)(1:3), & (xavg(j,k),j=1,Ncol),xmpd(k),xavg(Ns1,k) END DO DO k=1,Ncol WRITE(Nform,1090)alab(1:lagr),k,(xmnx(k,l),l=1,2),xran(k) 1090 FORMAT(a,'.s',i1,':',3(2x,f10.2)) END DO WRITE(Nform,1100)alab(1:lagr),(xmnx(Ns1,l),l=1,2),xran(Ns1) 1100 FORMAT(a,'.all:',3(2x,f10.2)) END IF RETURN END ssx11a.f0000664006604000003110000002710614521201574011467 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:56 pm **==ssx11a.f processed by SPAG 4.03F at 10:07 on 4 Oct 1994 SUBROUTINE ssx11a(Ijk,Lmodel,Lx11,Lseats,Msr,Ncol,Nlen,Ixreg, & Otlfix,Ssinit,Ssxotl,Ssxint) IMPLICIT NONE c----------------------------------------------------------------------- C This subroutine sets up arrays and variables for the sliding c spans adjustment, if such an analysis is requested. Options c are preserved where necessary. The transparent (no print out) c seasonal adjustment runs needed to perform the sliding spans c analysis are performed, and the sliding spans subroutines are c called. If a sliding spans analysis is not selected by the c user, then the series is seasonally adjusted. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'ssft.cmn' INCLUDE 'lzero.cmn' INCLUDE 'units.cmn' INCLUDE 'arima.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'error.cmn' INCLUDE 'otlrev.cmn' INCLUDE 'otxrev.cmn' INCLUDE 'missng.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'inpt.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'xeastr.cmn' INCLUDE 'orisrs.cmn' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- CHARACTER str*(PCOLCR) INTEGER i,Ijk,Ncol,Msr,Nlen,igrp,begcol,i1,i2,nchr,otltyp,begotl, & endotl,lastsy,endcol,Ixreg,oldfx,oldxfx,ircol,obeg,oend, & Ssinit LOGICAL Lmodel,locok,Lx11,Lseats,lidotl,Otlfix,Ssxotl,Ssxint C----------------------------------------------------------------------- Icol=Ijk Nfcst=Posffc-Posfob IF(Ijk.eq.1)THEN oldfx=Iregfx oldxfx=Irgxfx ELSE Iregfx=oldfx Irgxfx=oldxfx END IF c----------------------------------------------------------------------- c Reset length of series, series + forecasts, turn off identify c option c----------------------------------------------------------------------- Nspobs=Nlen Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst c----------------------------------------------------------------------- C SET UP BEGINNING, ENDING DATES and X11 pointers FOR SEASONAL C ADJUSTMENT OF SPAN IJK. c----------------------------------------------------------------------- Lsp=L0+(Ijk-1)*Ny+Im-Nbcst2-1 CALL setxpt(Nfcst,Lx11.or.Lseats,Fctdrp) Ly0=Lyr+(Pos1ob/Ny) IF(mod(Pos1ob,Ny).eq.0)Ly0=Ly0-1 Lstyr=Lyr+(Posfob/Ny) IF(mod(Posfob,Ny).eq.0)Lstyr=Lstyr-1 c----------------------------------------------------------------------- c Set Span Beginning, Ending Dates for modeling routines c----------------------------------------------------------------------- Begspn(MO)=Im Begspn(YR)=Ly0 Endspn(MO)=mod(Posfob,Ny) IF(Endspn(MO).eq.0)Endspn(MO)=Ny Endspn(YR)=Lstyr CALL dfdate(Begspn,Begsrs,Sp,Frstsy) Frstsy=Frstsy+1 Nomnfy=Nobs-Frstsy+1 Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nomnfy) CALL dfdate(Endspn,Begsrs,Sp,lastsy) lastsy=lastsy+1 CALL cpyint(Begspn,2,1,Begmdl) CALL cpyint(Endspn,2,1,Endmdl) c----------------------------------------------------------------------- c Set variables for irregular regression. c----------------------------------------------------------------------- IF(Ixreg.gt.0)THEN Ixreg=1 IF(Lmodel)Ixreg=2 CALL cpyint(Begspn,2,1,Begxrg) CALL cpyint(Endspn,2,1,Endxrg) c----------------------------------------------------------------------- CALL loadxr(F) c----------------------------------------------------------------------- c If automatic AO outlier identification is redone for each span, c then delete automatic outliers from irregular regression model c----------------------------------------------------------------------- IF(Ssxotl)THEN CALL cpyint(Begspn,2,1,Begxot) CALL cpyint(Endspn,2,1,Endxot) DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF(Rgvrtp(begcol).eq.PRGTAA)THEN ircol=endcol DO WHILE (ircol.ge.begcol) CALL dlrgef(ircol,Nrxy,1) IF(Lfatal)RETURN ircol=ircol-1 END DO END IF END DO ELSE IF(Notxtl.gt.0)THEN CALL dfdate(Begspn,Begxrg,Sp,obeg) obeg=obeg+1 CALL dfdate(Endspn,Begxrg,Sp,oend) oend=oend+1 DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF(Rgvrtp(begcol).eq.PRGTAA.or.Rgvrtp(begcol).eq.PRGTAO)THEN ircol=endcol DO WHILE (ircol.ge.begcol) CALL getstr(Colttl,Colptr,Ncoltl,ircol,str,nchr) IF(Lfatal)RETURN CALL rdotlr(str(1:nchr),Begxrg,Sp,otltyp,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF IF(begotl.lt.obeg.or.begotl.gt.oend)THEN CALL dlrgef(ircol,Nrxy,1) IF(Lfatal)RETURN END IF ircol=ircol-1 END DO END IF END DO c----------------------------------------------------------------------- c See if automatic outliers identified from full series can be c added to irregular regression model. c----------------------------------------------------------------------- CALL adotss(Botx,Otxptr,Notxtl,Fixotx,Otxttl,lastsy, & Otlfix.or.Ssxint) END IF CALL loadxr(T) c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- IF(Msr.eq.5)THEN Lmsr=Lterm Lterm=6 END IF CALL restor(Lmodel,Lx11,Ixreg.gt.0) c----------------------------------------------------------------------- c Reset missing value code. c----------------------------------------------------------------------- IF(Missng)Missng=F c----------------------------------------------------------------------- C RESET VALUES FOR ORIGINAL SERIES. c----------------------------------------------------------------------- CALL copy(Orig(Pos1ob),Nspobs,-1,Stcsi(Pos1ob)) CALL copy(Orig(Pos1ob),Nspobs,-1,Series(Pos1ob)) c----------------------------------------------------------------------- c Set logical variable that generates X-11 holiday date indicator c variable c----------------------------------------------------------------------- IF(Lgenx)THEN Lgenx=F c----------------------------------------------------------------------- c Check to see if easter adjustment can be done in all spans, c if specified. c----------------------------------------------------------------------- IF(Keastr.eq.1)THEN i1=(Pos1bk/12)*12+3 IF(i1.lt.Pos1bk)i1=i1+12 DO i=1,Ncol IF(i.gt.1)i1=i1+12 i2=(Pos1bk+Nlen-1)+(i-1)*12 CALL chkeas(i1,i2) c----------------------------------------------------------------------- c Print error messages and turn off easter adjustment if X-11 c easter adjustment cannot be done. c----------------------------------------------------------------------- IF((Ieast(1)*Ieast(2)*Ieast(3)*Ieast(4)).eq.0.and.(Keastr.eq.1) & )THEN CALL errhdr WRITE(Mt2,1030)' due to:' WRITE(STDERR,1030)'.' Keastr=0 END IF IF(Ieast(1).eq.0)WRITE(Mt2,1040)i IF(Ieast(2).eq.0)WRITE(Mt2,1050)i IF(Ieast(3).eq.0)WRITE(Mt2,1060)i IF(Ieast(4).eq.0)WRITE(Mt2,1070)i END DO IF(Keastr.eq.0)THEN WRITE(Mt2,1080) WRITE(STDERR,1080) END IF END IF END IF c----------------------------------------------------------------------- c Check to see if X-11 holiday adjustment can still be done. c----------------------------------------------------------------------- IF(Khol.eq.2)Khol=Keastr c----------------------------------------------------------------------- c ilyr=Iyr+Ijk-1 c Lcyr=ilyr c Lfdc=Pos1bk c Layr=ilyr c Lfdr=Pos1bk c----------------------------------------------------------------------- c Check to see if outliers in model are no longer in the span. c----------------------------------------------------------------------- IF(Lmodel)THEN * lidotl=Ltstao.or.Ltstls.or.Ltsttc.or.Ltstso lidotl=Ltstao.or.Ltstls.or.Ltsttc IF(lidotl)THEN CALL cpyint(Begspn,2,1,Begtst) CALL cpyint(Endspn,2,1,Endtst) END IF IF(Ngrp.gt.0)THEN CALL dfdate(Begspn,Begxy,Sp,obeg) obeg=obeg+1 CALL dfdate(Endspn,Begxy,Sp,oend) oend=oend+1 DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 IF(Rgvrtp(begcol).eq.PRGTAA.or.Rgvrtp(begcol).eq.PRGTAO.or. & Rgvrtp(begcol).eq.PRGTAL.or.Rgvrtp(begcol).eq.PRGTLS.or. & Rgvrtp(begcol).eq.PRGTAT.or.Rgvrtp(begcol).eq.PRGTTC.or. & Rgvrtp(begcol).eq.PRGTQD.or.Rgvrtp(begcol).eq.PRGTQI.or. & Rgvrtp(begcol).eq.PRGTSO.or.Rgvrtp(begcol).eq.PRGTRP.or. & Rgvrtp(begcol).eq.PRGTTL)THEN ircol=endcol DO WHILE (ircol.ge.begcol) CALL getstr(Colttl,Colptr,Ncoltl,ircol,str,nchr) IF(Lfatal)RETURN CALL rdotlr(str(1:nchr),Begxy,Sp,otltyp,begotl,endotl,locok) IF(.not.locok)THEN CALL abend RETURN END IF IF(((otltyp.eq.RP.or.otltyp.eq.TLS).and.(begotl.ge.obeg.or. & endotl.le.oend)) & .or.((otltyp.ne.RP.and.otltyp.ne.TLS).and.(begotl.lt.obeg.or. & begotl.gt.oend)))THEN CALL dlrgef(ircol,Nrxy,1) IF(Lfatal)RETURN END IF ircol=ircol-1 END DO END IF END DO END IF c----------------------------------------------------------------------- c Check to see if outliers stored previously can be put back into c the regression matrix. c----------------------------------------------------------------------- CALL adotss(Botr,Otrptr,Notrtl,Fixotr,Otrttl,lastsy, & Otlfix.or.Ssinit.eq.1) END IF c----------------------------------------------------------------------- 1030 FORMAT(/,5x,'Easter adjustment cannot be performed during the ', & 'sliding spans analysis',a) 1040 FORMAT(/,5x,'No years with Easter before April 1st in span ',i1, & '.') 1050 FORMAT(/,5x,'No years with Easter after April 16th in span ',i1, & '.') 1060 FORMAT(/,5x,'No years with Easter between April 2nd and April ', & '8th in span ',i1,'.') 1070 FORMAT(/,5x,'No years with Easter between April 8th and April ', & '15th in span ',i1,'.') 1080 FORMAT(/,5x,'Either choose a longer span for the sliding spans ', & 'analysis or',/,5x,'preadjust the series using Easter ', & 'effects estimated from a',/,5x,'regARIMA model.') c----------------------------------------------------------------------- RETURN END ssxmdl.f0000664006604000003110000001443214521201574011657 0ustar sun00315steps SUBROUTINE ssxmdl(Begspn,Begss,Itd,Ihol,Tdfix,Holfix,Otlfix, & Usrfix) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'arima.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'otxrev.cmn' INCLUDE 'x11log.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- LOGICAL Tdfix,Holfix,tdfx,holfx,Usrfix,regchg,Otlfix INTEGER Itd,Ihol,Begspn,Begss,starta,enda,igrp,begcol,endcol,icol, & rtype,nbeg,nend,fhnote DIMENSION Begspn(2),Begss(2),starta(2),enda(2) c----------------------------------------------------------------------- CALL dfdate(Begxrg,Begspn,Sp,nbeg) CALL dfdate(Endspn,Endxrg,Sp,nend) fhnote=STDERR IF(Lquiet)fhnote=0 IF(nbeg.gt.0.or.nend.gt.0)THEN Ssxint=T IF(Itd.gt.0)Itd=-1 IF(Ihol.gt.0)Ihol=-1 CALL writln('NOTE: Since a span is used in the x11regression spec &, the irregular ',fhnote,Mt2,T) CALL writln(' regression coefficient estimates will be held &fixed during the ',STDERR,Mt2,F) CALL writln(' sliding spans analysis.',fhnote,Mt2,F) END IF c----------------------------------------------------------------------- CALL intlst(PB,Otxptr,Notxtl) regchg=F CALL loadxr(F) c----------------------------------------------------------------------- IF((.not.Ssxotl).and.Otlxrg)THEN CALL addate(Begss,Sp,(Ncol-1)*Sp,starta) CALL addate(Endspn,Sp,(1-Ncol)*Sp,enda) DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) endcol=Grp(igrp)-1 c----------------------------------------------------------------------- c Check regular outliers to see if they are defined within the c sliding spans. c----------------------------------------------------------------------- IF(Rgvrtp(begcol).eq.PRGTAO)THEN DO icol=endcol,begcol,-1 CALL rmotss(icol,Begxy,Nrxy,Begss,starta,enda,Botx,Otxptr, & Notxtl,Fixotx,Otxttl,Otlfix.or.Ssxint,regchg) IF(Lfatal)RETURN END DO c----------------------------------------------------------------------- c Check automatic outliers to see if they are defined within the c sliding spans. c----------------------------------------------------------------------- ELSE IF(Rgvrtp(begcol).eq.PRGTAA)THEN icol=endcol DO WHILE (icol.ge.begcol) IF(Rgvrtp(icol).eq.PRGTAA)Rgvrtp(icol)=PRGTAO CALL rmotss(icol,Begxy,Nrxy,Begss,starta,enda,Botx,Otxptr, & Notxtl,Fixotx,Otxttl,Otlfix.or.Ssxint,regchg) IF(Lfatal)RETURN icol=icol-1 END DO END IF END DO END IF c----------------------------------------------------------------------- tdfx=F holfx=F IF(Nbx.gt.0) & CALL rvfixd(Tdfix,Holfix,Otlfix,Usrfix,Irgxfx,Regfxx,Nbx, & Rgxvtp,Nusxrg,Usxtyp,Nusxrg,Usrxfx) IF(Tdfix.and.Itd.gt.0)Itd=-1 IF(Holfix.and.Ihol.gt.0)Ihol=-1 IF(((Itd.eq.1.and.Axrgtd.and.(.not.Tdfix)).OR. & (Ihol.eq.1.and.Axrghl.and.(.not.Holfix))).AND.Irgxfx.ge.2)THEN tdfx=T holfx=T IF(Irgxfx.eq.2)THEN DO igrp=1,Nxgrp endcol=Grpx(igrp)-1 begcol=Grpx(igrp-1) rtype=Rgxvtp(begcol) IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRA1TD.or.rtype.eq.PRRTST.or.rtype.eq.PRATTD.or. & rtype.eq.PRATST.or.rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or. & rtype.eq.PRA1ST.or.rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRATLQ.or.rtype.eq.PRRTLM.or. & rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or. & rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY)) & .or.(rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES.or. & rtype.eq.PRGTLD.or.rtype.eq.PRGTTH))THEN DO icol=begcol,endcol IF(rtype.eq.PRGTEA.or.rtype.eq.PRGTEC.or.rtype.eq.PRGTES & .or.rtype.eq.PRGTLD.or.rtype.eq.PRGTTH.or. & rtype.eq.PRGTUH)THEN holfx=holfx.and.Regfxx(icol) ELSE tdfx=tdfx.and.Regfxx(icol) END IF END DO END IF END DO END IF c----------------------------------------------------------------------- IF(tdfx.and.Itd.gt.0)THEN Itd=-1 IF(.not.Tdfix)THEN Nssfxx=Nssfxx+1 Ssfxxr(Nssfxx)=1 END IF END IF IF(holfx.and.Ihol.gt.0)THEN Ihol=-1 IF(.not.Holfix)THEN Nssfxx=Nssfxx+1 Ssfxxr(Nssfxx)=2 END IF END IF END IF c----------------------------------------------------------------------- CALL loadxr(T) c----------------------------------------------------------------------- c Fix all model parameters based on value of Ssxint c----------------------------------------------------------------------- IF(Ssxint)THEN CALL setlg(T,PB,Regfxx) IF(Irgxfx.lt.3)Irgxfx=3 IF(.not.Usrxfx)THEN Usrxfx=Nusxrg.gt.0 IF(Usrxfx) & CALL bakusr(Xuserx,Usxtyp,Usrxpt,Nusxrg,Usrxtt,Regfxx,Bx, & Rgxvtp,Nxgrp,Grpttx,Grpx,Gpxptr,Ngrptx,1,T) END IF END IF c----------------------------------------------------------------------- c Reset Lxrneg if td regressors results are fixed c----------------------------------------------------------------------- IF(Lxrneg.and.(Irgxfx.eq.3.or.tdfx))Lxrneg=F c----------------------------------------------------------------------- RETURN END stable.prm0000664006604000003110000001545714521201575012201 0ustar sun00315stepscLast change: change irregularoutieradj/se3 to irregularoutlieradj/se3 c----------------------------------------------------------------------- c table name dictionaries and pointers c----------------------------------------------------------------------- c BRKDSP, BRKDS2, BRKDS3 = c table number where break in the table dictionary occurs c this is done to keep the length of the table dictionaries c under 2000 characters, a requirement for the VAX/VMS Fortran c----------------------------------------------------------------------- c TB1DIC, TB2DIC, TB3DIC, TB4DIC = c data dictionaries for X-13ARIMA-SEATS table names and c abbreviations c----------------------------------------------------------------------- INTEGER BRKDSP PARAMETER (BRKDSP=118) c----------------------------------------------------------------------- INTEGER BRKDS2 PARAMETER (BRKDS2=267) c----------------------------------------------------------------------- INTEGER BRKDS3 PARAMETER (BRKDS3=348) c----------------------------------------------------------------------- CHARACTER TB1DIC*944 INTEGER tb1ptr,PTB1 PARAMETER(PTB1=236) DIMENSION tb1ptr(0:PTB1) c----------------------------------------------------------------------- PARAMETER(TB1DIC='spana1specfilespcseriesmvadjmvcalendaradjoriga18 &outlieradjoriga19adjoriginalb1seriesconstanta1cpriora2permpriora2p &temppriora2tprioradjusteda3permprioradjusteda3pprioradjustedptda4d &permprioradjustedptda4ptransformedtrnregressionmatrixrmxoutlierotl &aoutlieraolevelshiftlstemporarychangetcseasonaloutliersotradingday &tdholidayholuserdefusrregseasonala10transitorya13acfiacpacfipciter &ationsitrmodelmdlregcmatrixrcmestimatesestarmacmatrixacmlkstatslks &rootsrtsregressioneffectsrefresidualsrsdregressionresidualsrrsiter &ationsoitfinaltestsftsacfacfpacfpcfacfsquaredac2transformedftrvari &ancesfvrforecastsfcttransformedbcstbtrbackcastsbctspecorigsp0specr &esidualsprspecsasp1specirrsp2specseatssas1sspecseatsirrs2sspecextr &esidualsserspecindsais1specindirris2speccompositeis0spectukeyorigs &t0spectukeyresidualstrspectukeysast1spectukeyirrst2spectukeyseatss &at1sspectukeyseatsirrt2sspectukeyextresidualsterspectukeyindsait1s &pectukeyindirrit2spectukeycompositeit0') c----------------------------------------------------------------------- CHARACTER TB2DIC*1619 INTEGER tb2ptr,PTB2 PARAMETER(PTB2=298) DIMENSION tb2ptr(0:PTB2) c----------------------------------------------------------------------- PARAMETER(TB2DIC='adjoriginalcc1adjoriginaldd1modoriginale1mcdmova &vgf1trendb2b2trendc2c2trendd2d2modseasadje2sib3b3modirregulare3mod &sic4c4modsid4d4seasonalb5b5seasonalc5c5seasonald5d5origchangese5or &igchangespctpe5seasadjb6b6seasadjc6c6seasadjd6d6sachangese6sachang &espctpe6trendb7b7trendc7c7trendd7d7trendchangese7trendchangespctpe &7sib8b8unmodsid8unmodsioxd8bcalendaradjchangese8calendaradjchanges &pctpe8replacsic9c9replacsid9seasonalb10b10seasonalc10c10seasonald1 &0seasonalpctpsfseasonaldifffsdseasonaladjregseaarsseasonalnoshrink &snsseasadjb11b11seasadjc11c11seasadjd11seasadjconstsacrobustsae11t &rendd12trendadjlstalbiasfactorbcftrendconsttacirregularbb13irregul &arcc13irregulard13irregularpctpirirregularadjaoirairrwtbb17irrwtc1 &7extremebb20extremec20x11easterh1combholidaychladjustfacd16adjustf &acpctpafadjustdifffadcalendard18adjustmentratioe18totaladjustmentt &adtdadjorigbb19tdadjorigc19yrtotalse4seasadjfcstsaftrendfcsttrfirr &wtfcstiwfseasadjtotsaasaroundrndrevsachangese6arevsachangespctp6ar &ndsachangese6rrndsachangespctp6rcratiocrrratiorrforcefactorffcprio &rtda4extremevalbb14extremevalc14x11regbb15x11regc15tradingdaybb16t &radingdayc16combtradingdaybb18combtradingdayc18holidaybbxhholidayx &hlcalendarbbxccalendarxcacombcalendarbbcccombcalendarxccoutlierite &rxoixregressionmatrixxrmxregressioncmatrixxrcoutlierhistoryrotsfil &terhistorysfhsarevisionssarsaestimatessaechngrevisionschrchngestim &atescheindsarevisionsiarindsaestimatesiaetrendrevisionstrrtrendest &imatestretrendchngrevisionstcrtrendchngestimatestcesfrevisionssfrs &festimatessfelkhdhistorylkhfcsterrorsfcefcsthistoryfchseatsmdlhist &orysmhseasonalfcthistoryssharmahistoryamhtdhistorytdh') c----------------------------------------------------------------------- CHARACTER TB3DIC*848 INTEGER tb3ptr,PTB3 PARAMETER(PTB3=162) DIMENSION tb3ptr(0:PTB3) c----------------------------------------------------------------------- PARAMETER(TB3DIC='sfspanssfsindsfspanssischngspanschsindchngspansc &issaspansadsindsaspansaisychngspansycsindychngspansyistdspanstdsco &mpositesrscmsprioradjcompositeia3adjcompositesrsb1calendaradjcompo &sitecacoutlieradjcompositeoacindunmodsiid8indreplacsiid9indseasona &lisfindseasonalpctipsindseasonaldiffisdindseasadjisaindtrenditnind &irregulariirindirregularpctipiindmodoriginalie1indmodsadjie2indmod &irrie3origchangesie5origchangespctip5indsachangesie6indsachangespc &tip6indrevsachangesi6aindrevsachangespctipaindrndsachangesi6rindrn &dsachangespctiprindtrendchangesie7indtrendchangespctip7indcalendar &adjchangesie8indcalendaradjchangespctip8indrobustsaieeindadjustmen &tratioi18indtotaladjustmentitaindmcdmovavgif1indyrtotalsie4indadjs &atotiaaindsadjroundirnindlevelshiftilsindaoutlieriaoindcalendarica &indadjustfaciafindadjustfacpctipfindcratiocriindrratiorriindforcef &actoriff') c----------------------------------------------------------------------- CHARACTER tb4DIC*797 INTEGER tb4ptr,Ptb4 PARAMETER(Ptb4=96) DIMENSION tb4ptr(0:Ptb4) c----------------------------------------------------------------------- PARAMETER(tb4DIC='trends12trendconststcseasonals10seasonalpctpssir ®ulars13irregularpctpsiseasonaladjs11seasadjconstsectransitorys1 &4transitorypctpscadjustfacs16adjustfacpctpsatrendfcstdecomptfdseas &onalfcstdecompsfdseriesfcstdecompofdseasonaladjfcstdecompafdtransi &toryfcstdecompyfdadjustmentratios18totaladjustmentstawkendfilterwk &fcomponentmodelsmdcpseudoinnovtrendpicpseudoinnovseasonalpispseudo &innovtransitorypitpseudoinnovsadjpiasquaredgainsasymgafsquaredgain &saconcgacsquaredgaintrendsymgtfsquaredgaintrendconcgtctimeshiftsac &onctactimeshifttrendconcttcfiltersasymfaffiltersaconcfacfiltertren &dsymftffiltertrendconcftcdifforiginaldordiffseasonaladjdsadifftren &ddtrseasonalsumssmcyclecyclongtermtrendlttseasonalsesseseasonaladj &seasetrendsetsetransitorysecseseasonaladjoutlieradjse2irregularout &lieradjse3trendadjlsstl') stable.var0000664006604000003110000001237314521201576012166 0ustar sun00315stepscLast change: change irregularoutieradj/se3 to irregularoutlieradj/se3 c----------------------------------------------------------------------- c tb1ptr, tb2ptr, tb3ptr, tb4ptr - c pointers for the TB2DIC, TB2DIC, TB3DIC, TB4DIC data c dictionaries c----------------------------------------------------------------------- DATA tb1ptr / & 1, 1, 1, 5, 7, 7, 7, 15, 18, 18, & 18, 29, 31, 46, 49, 63, 66, 77, 79, 79, & 79, 93, 96, 96, 96, 101, 103, 112, 115, 124, & 127, 140, 142, 159, 162, 178, 181, 201, 204, 215, & 218, 218, 218, 234, 237, 237, 237, 244, 247, 255, & 257, 267, 269, 284, 286, 301, 303, 313, 315, 322, & 325, 332, 335, 346, 349, 359, 362, 362, 362, 362, & 362, 365, 368, 368, 368, 372, 375, 375, 375, 375, & 375, 375, 375, 375, 375, 375, 375, 375, 375, 375, & 375, 375, 375, 375, 375, 375, 375, 375, 375, 375, & 375, 375, 375, 375, 375, 375, 375, 375, 375, 375, & 375, 375, 375, 375, 375, 375, 375, 385, 388, 388, & 388, 393, 396, 406, 409, 418, 421, 432, 435, 442, & 445, 445, 445, 450, 453, 470, 473, 482, 485, 504, & 507, 507, 507, 507, 507, 517, 520, 520, 520, 520, & 520, 530, 533, 536, 539, 539, 539, 543, 546, 546, & 546, 556, 559, 559, 559, 559, 559, 559, 559, 559, & 559, 559, 559, 559, 559, 570, 573, 582, 585, 594, & 597, 612, 615, 624, 627, 635, 638, 650, 653, 659, & 662, 669, 672, 683, 686, 698, 701, 717, 720, 729, & 732, 742, 745, 758, 761, 774, 777, 794, 797, 808, & 811, 823, 826, 842, 845, 862, 865, 886, 889, 903, & 906, 921, 924, 942, 945, 945, 945, 945, 945, 945, & 945, 945, 945, 945, 945, 945, 945 / c----------------------------------------------------------------------- DATA tb2ptr / & 1, 13, 15, 27, 29, 40, 42, 51, 53, 60, & 62, 69, 71, 78, 80, 90, 92, 96, 98, 110, & 112, 112, 112, 119, 121, 128, 130, 140, 142, 152, & 154, 164, 166, 177, 179, 193, 196, 205, 207, 216, & 218, 227, 229, 238, 240, 252, 255, 262, 264, 271, & 273, 280, 282, 294, 296, 311, 314, 318, 320, 327, & 329, 338, 341, 359, 361, 382, 385, 385, 385, 395, & 397, 405, 407, 418, 421, 432, 435, 443, 446, 457, & 460, 472, 475, 492, 495, 511, 514, 524, 527, 537, & 540, 547, 550, 562, 565, 573, 576, 581, 584, 594, & 597, 607, 610, 620, 623, 633, 636, 646, 649, 658, & 661, 673, 676, 690, 693, 699, 702, 707, 710, 718, & 721, 728, 731, 740, 742, 753, 756, 765, 768, 780, & 783, 793, 796, 804, 807, 822, 825, 840, 843, 853, & 856, 865, 868, 868, 868, 868, 868, 868, 868, 876, & 878, 878, 878, 878, 878, 878, 878, 878, 878, 878, & 878, 878, 878, 878, 878, 878, 878, 878, 878, 878, & 878, 878, 878, 878, 878, 889, 892, 901, 904, 913, & 916, 926, 929, 936, 939, 951, 954, 969, 972, 984, & 987,1002,1005,1011,1013,1019,1021,1032,1035,1042, & 1044,1055,1058,1068,1071,1078,1081,1087,1090,1101, & 1104,1114,1117,1132,1135,1149,1152,1160,1163,1170, & 1173,1182,1185,1193,1196,1209,1212,1224,1227,1227, & 1227,1238,1241,1241,1241,1241,1241,1258,1261,1279, & 1282,1282,1282,1282,1282,1296,1299,1313,1316,1327, & 1330,1330,1330,1341,1344,1357,1360,1360,1360,1373, & 1376,1390,1393,1393,1393,1407,1410,1424,1427,1427, & 1427,1441,1444,1462,1465,1465,1465,1483,1486,1497, & 1500,1500,1500,1511,1514,1525,1528,1538,1541,1552, & 1555,1570,1573,1591,1594,1605,1608,1617,1620 / c----------------------------------------------------------------------- DATA tb3ptr / & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & 1, 1, 1, 1, 1, 8, 11, 21, 24, 33, & 36, 48, 51, 58, 61, 71, 74, 84, 87, 100, & 103, 110, 113, 125, 128, 145, 148, 163, 165, 165, & 165, 185, 188, 207, 210, 210, 210, 210, 210, 220, & 223, 234, 237, 248, 251, 265, 268, 283, 286, 296, & 299, 307, 310, 322, 325, 340, 343, 357, 360, 370, & 373, 382, 385, 396, 399, 413, 416, 428, 431, 446, & 449, 464, 467, 485, 488, 503, 506, 524, 527, 542, & 545, 563, 566, 587, 590, 614, 617, 628, 631, 649, & 652, 670, 673, 685, 688, 688, 688, 688, 688, 699, & 702, 702, 702, 702, 702, 702, 702, 713, 716, 728, & 731, 731, 731, 731, 731, 731, 731, 731, 731, 731, & 731, 731, 731, 731, 731, 731, 731, 744, 747, 758, & 761, 772, 775, 787, 790, 805, 808, 817, 820, 829, & 832, 846, 849 / c----------------------------------------------------------------------- DATA tb4ptr / & 1, 6, 9, 19, 22, 30, 33, 44, 47, 56, & 59, 71, 74, 85, 88, 100, 103, 113, 116, 129, & 132, 141, 144, 156, 159, 174, 177, 195, 198, 214, & 217, 238, 241, 261, 264, 279, 282, 297, 300, 311, & 314, 329, 332, 348, 351, 370, 373, 394, 397, 412, & 415, 431, 434, 451, 454, 473, 476, 496, 499, 514, & 517, 535, 538, 549, 552, 564, 567, 581, 584, 599, & 602, 614, 617, 632, 635, 644, 647, 658, 661, 666, & 669, 682, 685, 695, 698, 711, 714, 721, 724, 736, & 739, 760, 763, 782, 785, 795, 798 / stcfcm.cmn0000664006604000003110000000105414521201576012152 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Stcftr,Stcfsf,Stcfor,Stcfsa,Stcfcy LOGICAL Hvstft,Hvstfs,Hvstfo,Hvstfa,Hvstfc DIMENSION Stcftr(PFCST),Stcfsf(PFCST),Stcfor(PFCST),Stcfsa(PFCST), & Stcfcy(PFCST) c----------------------------------------------------------------------- COMMON / stcfcm / Stcftr,Stcfsf,Stcfor,Stcfsa,Stcfcy COMMON / stclcm / Hvstft,Hvstfs,Hvstfo,Hvstfa,Hvstfc c----------------------------------------------------------------------- stdio.i0000664006604000003110000000412114521201576011466 0ustar sun00315stepsc----------------------------------------------------------------------- c Include file that keeps track of the files and global varables c used with input and output. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c ALLFIL i PARAMETER for all files to be closed c Infile c PFILCR character name of the command file read off of the c command line c Intfil l Initialize the list of possible files to open c Fillst i List of unit numbers of files, the first nfiles are used c Nfile i Number of files currently open c Opnsin l Indicates that STDIN is open to a file and will need to c be closed c Opnsot l Indicates that STDOUT is open to a file and will need to c be closed c PFILCR i PARAMETER for the maximum number of characters in a c file name including path and format title c STDERR i Standard fortran error output c STDIN i Standard fortran input unit c STDOUT i Standard fortran output unit c----------------------------------------------------------------------- integer PFILCR,NPRGNM CHARACTER VERNUM*3,PRGNAM*15,SPCSEC*9,LIMSEC*11,RUNSEC*9,MDLSEC*9, & DOCNAM*16 parameter(PFILCR=512,VERNUM='1.1',PRGNAM='X-13ARIMA-SEATS', & SPCSEC='Section 7',LIMSEC='Section 2.7', & RUNSEC='Section 2',MDLSEC='Section 5', & DOCNAM='Reference Manual',NPRGNM=15) integer ALLFIL,PFILE,STDERR,STDIN,STDOUT,PSRS cfame cfame parameter(ALLFIL=-1,STDERR=6,STDIN=5,STDOUT=6,PFILE=200, cfame & PSRS=500) cdos parameter(ALLFIL=-1,STDIN=5,STDOUT=6,PFILE=10,PSRS=10000) C C COMMON variables C character*(PFILCR) Infile,Cursrs,Curgrf LOGICAL Opnsin,Opnsot,Opnudg,Lquiet INTEGER Fillst(PFILE),Nfile,Nfilcr,Ngrfcr,Grfout,Imeta COMMON /cstdio/Nfile,Nfilcr,Ngrfcr,Grfout,Imeta,Fillst,STDERR COMMON /cstdc/Infile,Cursrs,Curgrf COMMON /cstdlg/Opnsin,Opnsot,Opnudg,Lquiet stpitr.f0000664006604000003110000001271114521201576011672 0ustar sun00315stepsC Last change: BCM 14 May 1998 9:17 am LOGICAL FUNCTION stpitr(Lprier,Objfcn,Devtol,Iter,Nliter,Mxiter, & Convrg,Armaer,Lhiddn) IMPLICIT NONE c----------------------------------------------------------------------- c stpitr.f, Release 1, Subroutine Version 1.7, Modified 30 Nov 1994. c----------------------------------------------------------------------- c Function to check for convergence of the Reg + ARIMA model. c The subroutine checks for convergence of the reletive c deviance The probability whose normal deviate is sought. C P is DOUBLE PRECISION C C C Method C C C The rational function on page 95 of Kennedy and Gentle, C Statistical Computing, Marcel Dekker, NY , 1980. C C********************************************************************** C C .. Scalar Arguments .. DOUBLE PRECISION P C .. C .. Local Scalars .. DOUBLE PRECISION xsign,y,z C .. C .. Local Arrays .. DOUBLE PRECISION xden(5),xnum(5) C .. C .. External Functions .. DOUBLE PRECISION devlpl EXTERNAL devlpl C .. C .. Intrinsic Functions .. INTRINSIC log,sqrt C .. C .. Data statements .. DATA xnum/-0.322232431088D0,-1.000000000000D0,-0.342242088547D0, & -0.204231210245D-1,-0.453642210148D-4/ DATA xden/0.993484626060D-1,0.588581570495D0,0.531103462366D0, & 0.103537752850D0,0.38560700634D-2/ C .. C .. Executable Statements .. IF(P.gt.0.5D0)THEN xsign=1.0D0 z=1.0D0-P ELSE xsign=-1.0D0 z=P END IF y=sqrt(-2.0D0*log(z)) stvaln=y+devlpl(xnum,5,y)/devlpl(xden,5,y) stvaln=xsign*stvaln RETURN END subset.f0000664006604000003110000000424714521201577011660 0ustar sun00315stepsC Last change: SRD 16 Oct 2000 9:26 am **==subset.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 SUBROUTINE subset(A,Nrowa,Ncola,Begrow,Endrow,Begcol,Endcol, & Suba) IMPLICIT NONE c----------------------------------------------------------------------- c Returns in suba, a subset of a[begrow:endrow,begcol:endcol] c Note that the matrices are defined in FORTRAN with the row and c column indices reversed. c----------------------------------------------------------------------- c Input Arguments c Name Type Description c----------------------------------------------------------------------- c a d Nrowa by ncola matrix c begcol i Begining column of the subset c begrow i Begining row of the subset c endcol i Last column of the subset c endrow i Last row of the subset c ncola i Number of columns in a c nrowa i Number of rows in a c psuba i Number of elements in psuba (removed May 2001 BCM) c----------------------------------------------------------------------- INTEGER Begcol,Begrow,Endcol,Endrow,Ncola,Nrowa DOUBLE PRECISION A DIMENSION A(Ncola,Nrowa) c----------------------------------------------------------------------- c Output Arguments c Name Type Description c----------------------------------------------------------------------- c suba d Endrow-begrow+1 by endcol-begcol+1 output matrix c----------------------------------------------------------------------- DOUBLE PRECISION Suba DIMENSION Suba(*) c----------------------------------------------------------------------- c Local Arguments c Name Type Description c----------------------------------------------------------------------- c jcol i Column index c irow i Row index c----------------------------------------------------------------------- INTEGER jcol,irow c ------------------------------------------------------------------ DO irow=Begrow,Endrow DO jcol=Begcol,Endcol Suba(irow-Begrow+1)=A(jcol,irow) END DO END DO c ------------------------------------------------------------------ RETURN END sumf.f0000664006604000003110000000063414521201577011321 0ustar sun00315steps**==sumf.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 DOUBLE PRECISION FUNCTION sumf(X,N1,N2) IMPLICIT NONE C*** Start of declarations inserted by SPAG INTEGER i,N1,N2 DOUBLE PRECISION X C*** End of declarations inserted by SPAG C COMMON SUBROUTINE DIMENSION X(*) sumf=0D0 DO i=N1,N2 sumf=sumf+X(i) END DO RETURN END sumry.f0000664006604000003110000000544214521201577011530 0ustar sun00315stepsC Last change: BCM 16 Feb 1999 3:58 pm SUBROUTINE sumry(X,Xbar,Xbar2,Xsq,Xsd,Iopt,I,J) IMPLICIT NONE c----------------------------------------------------------------------- C --- SUBROUTINE TO CALCULATE SUMMARY MEASURES. C --- X IS THE INPUT SERIES. I IS THE 1ST VALUE OF X AND J IS THE LAST C --- VALUE OF X. C --- XBAR = AVERAGE CHANGE WITHOUT REGARD TO SIGN. C --- XBAR2 = AVERAGE CHANGE WITH REGARD TO SIGN. C --- XSQ = AVERAGE CHANGE SQUARED WITHOUT REGARD TO SIGN. C --- XSD = STD. DEV. OF CHANGES WITH REGARD TO SIGN. C --- NY = NUMBER OF SPANS IN ONE YEAR. C --- XBAR,XBAR2,XSQ, AND XSD ARE CALCULATED FOR SPANS 1 TO NY. C --- IF THE ADJUSTMENT IS ADDITIVE, THE CHANGES ARE DIFFERENCES. C --- IF THE ADJUSTMENT IS MULTIPLICATIVE, THEY ARE PERCENT CHANGES. c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE PARAMETER(ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'x11opt.cmn' INCLUDE 'goodob.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION c,xcount,X,Xbar,Xbar2,Xsd,Xsq INTEGER I,Iopt,J,k,kj,l DIMENSION X(*),Xbar(*),Xbar2(*),Xsq(*),Xsd(*) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- DO k=1,Ny Xbar(k)=ZERO xcount=ZERO IF(Iopt.le.1)THEN Xbar2(k)=ZERO Xsd(k)=ZERO END IF kj=J-k DO l=I,kj IF(Gudval(l))THEN c=X(l+k)-X(l) IF(Muladd.eq.0)c=c*100D0/X(l) Xbar(k)=Xbar(k)+abs(c) IF(Iopt.le.1)Xbar2(k)=Xbar2(k)+c xcount=xcount+ONE END IF END DO IF(xcount.gt.ZERO)THEN Xbar(k)=Xbar(k)/xcount ELSE Xbar(k)=DNOTST END IF IF(Iopt.ne.3)THEN IF(Iopt.ne.1)THEN IF(dpeq(Xbar(k),DNOTST))THEN Xsq(k)=DNOTST ELSE Xsq(k)=Xbar(k)*Xbar(k) END IF IF(Iopt.eq.2)GO TO 10 END IF IF(xcount.gt.ZERO)THEN Xbar2(k)=Xbar2(k)/xcount ELSE Xbar2(k)=DNOTST END IF Xsd(k)=ZERO IF(Muladd.eq.0)THEN DO l=I,kj IF(Gudval(l))Xsd(k)=Xsd(k)+ & ((X(l+k)-X(l))/X(l)*100D0-Xbar2(k))**2 END DO ELSE DO l=I,kj Xsd(k)=Xsd(k)+(X(l+k)-X(l)-Xbar2(k))**2 END DO END IF IF(Xsd(k).gt.ZERO)Xsd(k)=sqrt(Xsd(k)/xcount) END IF 10 CONTINUE END DO RETURN END sums.i0000664006604000003110000000063514521201577011342 0ustar sun00315stepsC... Variables in Common Block /varSumS/ ... integer tTMCS,tANA,tScomp,tCycComp,tStocTD,tSpecFac,tACF,tCCF, $ tUnstSa,tUnrSa,tRevSa,tSeasNoSig,tBias,tCrQs,tCrSNP, $ tCrPeaks,tX11,tSeats,tNSA common /varSumS/ tTMCS,tANA,tScomp,tCycComp,tStocTD,tSpecFac, $ tACF,tCCF,tUnstSa,tUnrSa,tRevSa,tSeasNoSig,tBias,tCrQs, $ tCrSNP,tCrPeaks,tX11,tSeats,tNSA sumsqr.f0000664006604000003110000000371414521201577011703 0ustar sun00315steps DOUBLE PRECISION FUNCTION sumsqr( vA, nStart, nEnd ) c----------------------------------------------------------------------- c sumsqr.f, Release 1, Subroutine Version 1.0, Created 18 Apr 2005. c----------------------------------------------------------------------- c This subroutine calculates the sum of square of the entries in c the vector vA from start index nStart to end index nEnd. c----------------------------------------------------------------------- c Name Type Description (Input/Output Variables) c----------------------------------------------------------------------- c nEnd i ending index of vA subvector for sum of squares c nStart i starting index of vA subvector for sum of squares c vA d input vector for calculation of sum of squares c----------------------------------------------------------------------- c Name Type Description (local Variables) c----------------------------------------------------------------------- c i i index variable for do loops c----------------------------------------------------------------------- IMPLICIT NONE c----------------------------------------------------------------------- c Declare Input/Output variables. c----------------------------------------------------------------------- INTEGER nStart, nEnd DOUBLE PRECISION vA(*) c ------------------------------------------------------------------ c Declare local variables. c ------------------------------------------------------------------ INTEGER i c----------------------------------------------------------------------- c Calculate the requisite sum of squares. c----------------------------------------------------------------------- sumsqr = 0.0D0 DO i = nStart, nEnd sumsqr = sumsqr + ( vA(i)*vA(i) ) END DO c ------------------------------------------------------------------ RETURN ENDsumtab.prm0000664006604000003110000000057514521201577012217 0ustar sun00315stepsc----------------------------------------------------------------------- c sumtab - logical variable which defines those tables to be saved c when the -s flag is used c DATA statement that defines sumtab is in sumtab.var c----------------------------------------------------------------------- LOGICAL sumtab DIMENSION sumtab(NTBL) sumtab.var0000664006604000003110000000240114521201600012162 0ustar sun00315stepsc----------------------------------------------------------------------- c DATA statement that defines sumtab, the logical variable which c defines those tables to be saved when the -s flag is used c----------------------------------------------------------------------- DATA sumtab/ & T,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, T,T,T,F,F,F,F,F,F,F, F,F,T,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,T,T,T,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,T,T,T,T,T,T,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, T,T,F,F,F,T,T,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,T, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,T,T,T, & T,T,T,T,T,T,T,T,T,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,T,T,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,T,T,F,F,F,T, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, F,F,F,F,F,F,F,F,F,F, & F,F,F,F,F,F/svaict.f0000664006604000003110000001637414521201600011633 0ustar sun00315stepsC Last change:Nov 2, 2023, change label saving the significance C value for user defined regressors in AICC testing SUBROUTINE svaict(Savtd,Savlom,Saveas,Savusr,Lsvlog,Hvmdl,Lsumm, & Mdltxt,Nmdtxt) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'picktd.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T,F DOUBLE PRECISION ZERO PARAMETER(T=.TRUE.,F=.FALSE.,ZERO=0D0) c----------------------------------------------------------------------- CHARACTER rgstr*(155),rgabb*(6),Mdltxt*(9),temp*(30) INTEGER nrgchr,nrgabb,Lsumm,iaic,Nmdtxt,ntmp,ieas,j LOGICAL Savtd,Savlom,Saveas,Savusr,Lsvlog,Hvmdl c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- IF(Savtd)THEN c----------------------------------------------------------------------- IF(Hvmdl)THEN iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(iaic.eq.0)iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Trading Day') IF(iaic.eq.0)iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'Stock Trading Day') IF(iaic.eq.0)iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Stock Trading Day') IF(iaic.gt.0)THEN CALL mktdlb(rgstr,nrgchr,Aicint,Aicstk,Tddate,Tdzero,Sp) IF(Lfatal)RETURN IF(Lsvlog)WRITE(Ng,1030)' AICtd : '//rgstr(1:nrgchr) IF(Lsumm.gt.0)WRITE(Nform,1010)'aictest.td: ',rgstr(1:nrgchr) ELSE IF(Lsvlog)WRITE(Ng,1030)' AICtd : none' IF(Lsumm.gt.0)WRITE(Nform,1010)'aictest.td: no' END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1040)'aictest.diff.td',Dfaict IF(Rgaicd(PTDAIC).gt.ZERO) & WRITE(Nform,1040)'aictest.cvaic.td',Rgaicd(PTDAIC) END IF ELSE IF(Lsvlog) & WRITE(Ng,1030)' AICtd : ARIMA model not '//Mdltxt(1:Nmdtxt) IF(Lsumm.gt.0)WRITE(Nform,1010)'aictest.td: nomodel' END IF END IF c----------------------------------------------------------------------- IF(Savlom)THEN CALL mklnlb(rgstr,nrgchr,rgabb,nrgabb,Lomtst,Lndate,Lnzero,Sp) IF(Lsumm.gt.0) & WRITE(Nform,1010)'aictest.'//rgabb(1:nrgabb)//'.reg: ', & rgstr(1:nrgchr) IF(Hvmdl)THEN iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Length-of-Month') IF(iaic.eq.0)iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'Length-of-Quarter') IF(iaic.eq.0)iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Leap Year') IF(iaic.gt.0)THEN IF(Lsvlog) & WRITE(Ng,1030)' AIC'//rgabb(1:nrgabb)//' : accepted' IF(Lsumm.gt.0) & WRITE(Nform,1010)'aictest.'//rgabb(1:nrgabb)//': yes' ELSE IF(Lsvlog) & WRITE(Ng,1030)' AIC'//rgabb(1:nrgabb)//' : rejected' IF(Lsumm.gt.0) & WRITE(Nform,1010)'aictest.'//rgabb(1:nrgabb)//': no' END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1040)'aictest.diff.'//rgabb(1:nrgabb),Dfaicl IF(Rgaicd(PTDAIC).gt.ZERO) & WRITE(Nform,1040)'aictest.cvaic.'//rgabb(1:nrgabb), & Rgaicd(PLAIC) END IF ELSE IF(Lsvlog)WRITE(Ng,1030)' AIC'//rgabb(1:nrgabb)// & ' : ARIMA model not '//Mdltxt(1:Nmdtxt) IF(Lsumm.gt.0) & WRITE(Nform,1010)'aictest.'//rgabb(1:nrgabb)//': nomodel' END IF END IF c----------------------------------------------------------------------- IF(Saveas)THEN CALL mkealb(rgstr,nrgchr,Eastst,Easidx,Aicind,T) IF(Lfatal)RETURN IF(Lsumm.gt.0) & WRITE(Nform,1010)'aictest.easter.reg: ',rgstr(1:nrgchr) IF(Hvmdl)THEN iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(iaic.eq.0) & iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StatCanEaster') IF(iaic.eq.0) & iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'StockEaster') IF(iaic.gt.0)THEN IF(Lsvlog)THEN IF(Aicind.eq.99)THEN ieas=1 DO j=2,Neasvc-1 CALL mkealb(temp,ntmp,Eastst,Easidx,Easvec(j)+Easidx,F) IF(.not.Lfatal)THEN rgstr(ieas:(ieas+ntmp))=temp(1:ntmp)//'+' ieas=ieas+ntmp+1 END IF IF(Lfatal)RETURN END DO rgstr(ieas-1:ieas-1)=' ' nrgchr=ieas-2 ELSE WRITE(Ng,1050)'AICeaster',rgstr(1:nrgchr),Aicind END IF END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1010)'aictest.e: yes' IF(Aicind.eq.99)THEN WRITE(Nform,1025)'aictest.e.window: ', & (Easvec(j),j=2,Neasvc-1) ELSE WRITE(Nform,1020)'aictest.e.window: ',Aicind END IF END IF ELSE IF(Lsvlog)WRITE(Ng,1030)' AICeaster : rejected' IF(Lsumm.gt.0)THEN WRITE(Nform,1010)'aictest.e: no' WRITE(Nform,1020)'aictest.e.window: ',-99999 END IF END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1040)'aictest.diff.e',Dfaice IF(Rgaicd(PEAIC).gt.ZERO) & WRITE(Nform,1040)'aictest.cvaic.e',Rgaicd(PEAIC) END IF ELSE IF(Lsvlog) & WRITE(Ng,1030)' AICeaster : ARIMA model not '// & Mdltxt(1:Nmdtxt) IF(Lsumm.gt.0)THEN WRITE(Nform,1010)'aictest.e: nomodel' WRITE(Nform,1020)'aictest.e.window: ',-99999 END IF END IF END IF c----------------------------------------------------------------------- IF(Savusr)THEN IF(Hvmdl)THEN iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'User-defined') IF(iaic.gt.0)THEN IF(Lsvlog)WRITE(Ng,1030)' AICuser : accepted' IF(Lsumm.gt.0)WRITE(Nform,1010)'aictest.u: yes' ELSE IF(Lsvlog)WRITE(Ng,1030)' AICuser : rejected' IF(Lsumm.gt.0)WRITE(Nform,1010)'aictest.u: no' END IF IF(Lsumm.gt.0)THEN WRITE(Nform,1040)'aictest.diff.u',Dfaicu c change udg label IF(Rgaicd(PUAIC).gt.ZERO) & WRITE(Nform,1040)'aictest.cvaic.u',Rgaicd(PUAIC) END IF ELSE IF(Lsvlog) & WRITE(Ng,1030)' AICuser : ARIMA model not '// & Mdltxt(1:Nmdtxt) IF(Lsumm.gt.0)WRITE(Nform,1010)'aictest.u: nomodel' END IF END IF c----------------------------------------------------------------------- 1010 FORMAT(a:,a) 1020 FORMAT(a,i6) 1025 FORMAT(a,5i6) 1030 FORMAT(a,/) 1040 FORMAT(a,': ',e20.10) 1050 FORMAT(3x,a,' : ',a,'[',i2,']',/) 1055 FORMAT(3x,a,' : ',5(a,'[',i2,']',1x),/) c----------------------------------------------------------------------- RETURN END svamcm.f0000664006604000003110000000647114521201600011625 0ustar sun00315stepsC Last change: BCM 15 Jan 98 12:01 pm SUBROUTINE svamcm IMPLICIT NONE c----------------------------------------------------------------------- c Save the ARMA covariance matrix from (X'X)^-1 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'mdltbl.i' INCLUDE 'error.cmn' INCLUDE 'savcmn.cmn' INCLUDE 'cchars.i' c ------------------------------------------------------------------ INTEGER OPRS PARAMETER(OPRS=2) c----------------------------------------------------------------------- LOGICAL locok CHARACTER cfix*7,tmpttl*(POPRCR),outstr*(POPRCR+22*PARIMA), & dash*(22) INTEGER beglag,begopr,endlag,endopr,fh,i,iestpm,iflt,ilag,iopr, & irow,ntmpcr,ipos c ------------------------------------------------------------------ DATA dash /'----------------------'/ c----------------------------------------------------------------------- IF(Nestpm.le.1)RETURN c ------------------------------------------------------------------ CALL opnfil(.true.,.false.,LESTAM,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c ------------------------------------------------------------------ c Construct and print header c ------------------------------------------------------------------ outstr(1:9)='parameter' ipos=10 DO i=1,Nestpm outstr(ipos:ipos)=TABCHR ipos=ipos+1 outstr(ipos:ipos+3)='parm' ipos=ipos+4 CALL itoc(i,outstr,ipos) IF(Lfatal)RETURN END DO WRITE(fh,1010)outstr(1:ipos-1) WRITE(fh,1010)'---------',(TABCHR,dash(1:Svsize),i=1,Nestpm) c ------------------------------------------------------------------ iestpm=0 DO iflt=AR,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ CALL isfixd(OPRS,Arimaf,beglag,endlag,cfix) IF(cfix.eq.' ')THEN CALL getstr(Oprttl,Oprptr,Noprtl,iopr,tmpttl,ntmpcr) IF(Lfatal)RETURN c ------------------------------------------------------------------ DO ilag=beglag,endlag IF(.not.Arimaf(ilag))THEN iestpm=iestpm+1 outstr(1:ntmpcr)=tmpttl(1:ntmpcr) ipos=ntmpcr+1 outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL itoc(Arimal(ilag),outstr,ipos) IF(Lfatal)RETURN DO irow=1,Nestpm outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Var*Armacm(iestpm,irow),outstr,ipos) IF(Lfatal)RETURN END DO WRITE(fh,1010)outstr(1:ipos-1) END IF END DO END IF END DO END DO c ------------------------------------------------------------------ IF(locok)CALL fclose(fh) c ------------------------------------------------------------------ 1010 FORMAT(1000a) RETURN END svchsd.f0000664006604000003110000000377714521201601011640 0ustar sun00315steps SUBROUTINE svchsd(Chvec,Ib,Ie,Iagr,Muladd,Chlab) c----------------------------------------------------------------------- c saves standard deviation of the month-to-month change vector CHVEC c (from IB to IE) to the seasonal adjustment diagnostics in the udg c file (FH representing the file handle). Chlab is the label used c to denote which change vector is being saved. c Written by BCM (July 2007) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'units.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONEHND PARAMETER(ONEHND=100D0) c----------------------------------------------------------------------- CHARACTER Chlab*(*) DOUBLE PRECISION Chvec(PLEN),chsd,tempch(PLEN) INTEGER i,Iagr,Muladd,Ib,Ie c----------------------------------------------------------------------- DOUBLE PRECISION sdev EXTERNAL sdev c----------------------------------------------------------------------- c copy change vector into tempch, multiply by 100 if necessary c----------------------------------------------------------------------- CALL copy(Chvec,Ie,1,tempch) IF(Muladd.ne.1)THEN DO i=Ib,Ie tempch(i)=tempch(i)*ONEHND END DO END IF c----------------------------------------------------------------------- c generate standard deviation of change vector tempch c----------------------------------------------------------------------- chsd = sdev(tempch,Ib,Ie,1,1) c-----------------------------------------------------------------------| IF(Iagr.eq.4)THEN WRITE(Nform,1010)'chsd.i',Chlab,chsd ELSE WRITE(Nform,1010)'chsd.',Chlab,chsd END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- 1010 FORMAT(a,a,': ',e21.14) END svdttm.f0000664006604000003110000000141714521201601011654 0ustar sun00315steps SUBROUTINE svdttm(Nform,datstr) IMPLICIT NONE c----------------------------------------------------------------------- c Function for Lahey fortran (PC) to print date and time information c to the .xdg file. c----------------------------------------------------------------------- CHARACTER datstr*24 INTEGER Nform c----------------------------------------------------------------------- * CHARACTER cvdttm*(24) * EXTERNAL cvdttm c----------------------------------------------------------------------- WRITE(Nform,1020)datstr(1:15) 1020 FORMAT('date:',a) WRITE(Nform,1030)datstr(15:24) 1030 FORMAT('time:',a) c----------------------------------------------------------------------- RETURN END svf2f3.f0000664006604000003110000001136614521201601011450 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 11:24 pm SUBROUTINE svf2f3(Nw,Ng,Lf2,Lf3,Arglab) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'x11svl.i' INCLUDE 'cmpsvl.i' INCLUDE 'inpt2.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'work2.cmn' INCLUDE 'tests.cmn' c----------------------------------------------------------------------- c Arglab is i if indirect adjustment, blank otherwise c----------------------------------------------------------------------- CHARACTER Arglab*(*),yn*3,clbl*25 INTEGER i,nlbl,n,Nw,Ng,im1 LOGICAL Lf2,Lf3 c----------------------------------------------------------------------- DIMENSION yn(2) c----------------------------------------------------------------------- DATA yn/'yes','no '/ c----------------------------------------------------------------------- c Print out X-11 diagnostics for F2 c----------------------------------------------------------------------- IF(Lf2)THEN DO i=1,Ny WRITE(Nw,1010)Arglab,i,Obar(i),Cibar(i),Ibar(i),Cbar(i),Sbar(i), & Pbar(i),Tdbar(i),Smbar(i),Ombar(i),Cimbar(i), & Imbar(i) 1010 FORMAT(a,'2.a',i2.2,':',1x,E15.8,10(1X,E15.8)) END DO DO i=1,Ny WRITE(Nw,1020)Arglab,i,Isq(i),Csq(i),Ssq(i),Psq(i),Tdsq(i), & Osq2(i) 1020 FORMAT(a,'2.b',i2.2,':',1x,5(2PF8.2),' 100.00',2PF8.2) END DO DO i=1,Ny WRITE(Nw,1030)Arglab,i,Obar2(i),Osd(i),Ibar2(i),Isd(i),Cbar2(i), & Csd(i),Sbar2(i),Ssd(i),Cibar2(i),Cisd(i),Smbar2(i) & ,Smsd(i) 1030 FORMAT(a,'2.c',i2.2,':',12(1x,E15.8)) END DO WRITE(Nw,1040)Arglab,Adrci,Adri,Adrc,Adrmcd 1040 FORMAT(a,'2.d:',4F8.2) WRITE(Nw,1050)Arglab,(Smic(i),i=1,Ny) 1050 FORMAT(a,'2.e:',12F8.2) WRITE(Nw,1060)Arglab,Mcd 1060 FORMAT(a,'2.mcd:',i8) WRITE(Nw,1070)Arglab,Vi,Vc,Vs,Vp,Vtd,Rv 1070 FORMAT(a,'2.f:',6F8.2) n=Ny+2 WRITE(Nw,1080)Arglab,(Autoc(i),i=1,n) 1080 FORMAT(a,'2.g:',14F8.2) WRITE(Nw,1090)Arglab,Ratic,Arglab,Ratis 1090 FORMAT(a,'2.ic:',F12.2,/,a,'2.is:',F12.2) WRITE(Nw,1100)Arglab,Fpres,P3 1100 FORMAT(a,'2.fsb1:',F11.3,F8.2) WRITE(Nw,1120)Arglab,Fstabl,P1,Arglab,Chikw,P5,Arglab,Fmove,P2 1120 FORMAT(a,'2.fsd8:',F11.3,F8.2,/,a,'2.kw:',F11.3,F8.2,/, & a,'2.msf:',F11.3,F8.2) WRITE(Nw,1121)Arglab,yn(Iqfail) 1121 FORMAT(a,'2.idseasonal: ',a) END IF c----------------------------------------------------------------------- IF(Arglab(1:1).eq.'i')THEN clbl=' (indirect adjustment) : ' nlbl=25 IF(Svltab(LSLISR).and.Kfulsm.lt.2) & WRITE(Ng,2010)clbl(1:nlbl),Ratis IF(Svltab(LSLIIR))WRITE(Ng,2020)clbl(1:nlbl),Ratic IF(Svltab(LSLID8))WRITE(Ng,2030)clbl(1:nlbl),Fstabl IF(Svltab(LSLISF))WRITE(Ng,2040)clbl(1:nlbl),Fmove IF(Svltab(LSLIID))WRITE(Ng,2060)clbl(1:nlbl),yn(Iqfail) im1=LSLIM1 ELSE clbl=' : ' nlbl=3 IF(Svltab(LSLMSR).and.Kfulsm.lt.2) & WRITE(Ng,2010)clbl(1:nlbl),Ratis IF(Svltab(LSLICR))WRITE(Ng,2020)clbl(1:nlbl),Ratic IF(Svltab(LSLFB1))WRITE(Ng,2050)clbl(1:nlbl),Fpres IF(Svltab(LSLFD8))WRITE(Ng,2030)clbl(1:nlbl),Fstabl IF(Svltab(LSLMSF))WRITE(Ng,2040)clbl(1:nlbl),Fmove IF(Svltab(LSLIDS))WRITE(Ng,2060)clbl(1:nlbl),yn(Iqfail) im1=LSLM1 END IF 2010 FORMAT(' Moving seasonality ratio ',a,f11.3) 2020 FORMAT(' I/C Ratio ',a,f11.3) 2030 FORMAT(' Stable Seasonal F, D8 table ',a,f11.3) 2040 FORMAT(' Moving Seasonal F, D8 table ',a,f11.3) 2050 FORMAT(' Stable Seasonal F, B1 table ',a,f11.3) 2060 FORMAT(' Identifiable seasonality ',a,a) c----------------------------------------------------------------------- c Print out Quality control diagnostics for F3 c----------------------------------------------------------------------- DO i=1,Nn IF(i.ne.6.or.Kfulsm.lt.2)THEN IF(Lf3)WRITE(Nw,1130)Arglab,i,Qu(i) 1130 FORMAT(a,'3.m',i2.2,':',1x,f6.3) IF(Svltab(im1+i-1))WRITE(Ng,2070)i,clbl(1:nlbl),Qu(i) 2070 FORMAT(' M',i2.2,a,f10.3) END IF END DO IF(Lf3)THEN WRITE(Nw,1140)Arglab,Qual,Arglab,Q2m2,Arglab,Kfail 1140 FORMAT(a,'3.q:',1x,F5.2,/,a,'3.qm2:',1x,F5.2,/,a,'3.fail:', & 1x,i2) END IF IF(Svltab(im1+11))WRITE(Ng,2080)' Q ',clbl(1:nlbl),Qual IF(Svltab(im1+12))WRITE(Ng,2080)' Q2 ',clbl(1:nlbl),Q2m2 2080 FORMAT(a,a,f10.3) RETURN END svfltd.f0000664006604000003110000000323014521201601011630 0ustar sun00315steps SUBROUTINE svfltd(Vfreq,Vdiag,Fltptr,Lgraf,Fltidx,Flthdr) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T PARAMETER(T=.TRUE.) c----------------------------------------------------------------------- DOUBLE PRECISION vfreq(0:1200),vdiag(0:1200,2) LOGICAL locok,Lgraf INTEGER i,fhc,ipos,Fltptr,Fltidx CHARACTER flthdr*(*),outstr*(50) c----------------------------------------------------------------------- CALL opnfil(T,Lgraf,Fltptr,fhc,locok) IF (.not.locok) THEN CALL abend RETURN END IF c----------------------------------------------------------------------- write(fhc,1000)'freq',TABCHR,Flthdr WRITE(fhc,1000)'----------------------',TABCHR, & '----------------------' c----------------------------------------------------------------------- do 400 i=0,1200 ipos=1 CALL setchr(' ',50,outstr) CALL dtoc(Vfreq(i),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Vdiag(i,Fltidx),outstr,ipos) IF(Lfatal)RETURN write(fhc,1001)outstr(1:(ipos-1)) 400 continue c----------------------------------------------------------------------- CALL fclose(fhc) c----------------------------------------------------------------------- 1000 format(3a) 1001 format(a) c----------------------------------------------------------------------- RETURN END svflt.f0000664006604000003110000000321114521201601011463 0ustar sun00315steps SUBROUTINE svflt(Pos1ob,Posfob,Vflt,Fltptr,Lgraf,Fltidx,Flthdr) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL T PARAMETER(T=.TRUE.) c----------------------------------------------------------------------- DOUBLE PRECISION Vflt(1200,2) LOGICAL locok,Lgraf INTEGER i,fhc,ipos,Fltptr,Fltidx,Pos1ob,Posfob,nz CHARACTER flthdr*(*),outstr*(50) c----------------------------------------------------------------------- CALL opnfil(T,Lgraf,Fltptr,fhc,locok) IF (.not.locok) THEN CALL abend RETURN END IF c----------------------------------------------------------------------- write(fhc,1000)'index',TABCHR,Flthdr WRITE(fhc,1000)'-----',TABCHR,'----------------------' c----------------------------------------------------------------------- nz=Posfob-Pos1ob+1 do 400 i=1,nz ipos=1 CALL setchr(' ',50,outstr) CALL itoc(1-i,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(Vflt(i,Fltidx),outstr,ipos) IF(Lfatal)RETURN write(fhc,1001)outstr(1:(ipos-1)) 400 continue c----------------------------------------------------------------------- CALL fclose(fhc) c----------------------------------------------------------------------- 1000 format(3a) 1001 format(a) c----------------------------------------------------------------------- RETURN END svfnrg.f0000664006604000003110000000524514521201601011643 0ustar sun00315stepsC Last change: BCM 13 May 1998 9:04 am SUBROUTINE svfnrg(Ttlstr,Ngrp,Grpttl,Grpptr,Ngrptl) IMPLICIT NONE c----------------------------------------------------------------------- c Constructs a description of the regression model c At some point need to show that the matrix might be length of month c adjusted c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' * INCLUDE 'title.cmn' INCLUDE 'units.cmn' c ------------------------------------------------------------------ CHARACTER addon*3,str*(PGRPCR),tmpttl*80,Grpttl*(PGRPCR*PGRP), & Ttlstr*(*),regttl*80 INTEGER igrp,naddcr,nchr,nttlcr,Grpptr,Ngrptl,Ngrp,ifnreg,n1, & nrgttl DIMENSION Grpptr(0:PGRP),regttl(10),nrgttl(10) c----------------------------------------------------------------------- c Print the regression part of the model c----------------------------------------------------------------------- nttlcr=0 ifnreg=1 CALL setchr(' ',80,tmpttl) addon=' ' naddcr=0 c ------------------------------------------------------------------ DO igrp=1,Ngrp CALL getstr(Grpttl,Grpptr,Ngrptl,igrp,str,nchr) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(nttlcr+nchr+naddcr.ge.78)THEN CALL setchr(' ',80,regttl(ifnreg)) n1=nttlcr+naddcr regttl(ifnreg)(1:n1)=tmpttl(1:nttlcr)//addon(1:naddcr) nrgttl(ifnreg)=n1 ifnreg=ifnreg+1 CALL setchr(' ',80,tmpttl) nttlcr=nchr tmpttl(1:nttlcr)=str(1:nchr) c ------------------------------------------------------------------ ELSE n1=nttlcr+1 IF(naddcr.gt.0)THEN tmpttl(n1:nttlcr+nchr+naddcr)=addon(1:naddcr)//str(1:nchr) nttlcr=nttlcr+nchr+naddcr ELSE tmpttl(n1:nttlcr+nchr)=str(1:nchr) nttlcr=nttlcr+nchr addon=' + ' naddcr=3 END IF END IF END DO c ------------------------------------------------------------------ CALL setchr(' ',80,regttl(ifnreg)) regttl(ifnreg)=tmpttl(1:nttlcr) nrgttl(ifnreg)=nttlcr c ------------------------------------------------------------------ WRITE(Nform,1010)Ttlstr,ifnreg 1010 FORMAT('n',a,': ',i3) DO igrp=1,ifnreg WRITE(Nform,1020)Ttlstr,igrp,regttl(igrp)(1:nrgttl(igrp)) 1020 FORMAT(a,i2.2,': ',a) END DO c ------------------------------------------------------------------ RETURN END svfreq.f0000664006604000003110000000655214521201601011646 0ustar sun00315stepsC Last change: BCM 4 Mar 2008 9:46 am SUBROUTINE svfreq(Ny,Svallf) IMPLICIT NONE c----------------------------------------------------------------------- C save frequency, spectral peak information into .udg file c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'spcidx.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL Svallf INTEGER Ny,i c----------------------------------------------------------------------- IF(Svallf)THEN write(Nform,1000)'nspecfreq',Nfreq ELSE write(Nform,1000)'nspecfreq',61 END IF c----------------------------------------------------------------------- write(Nform,1000)'ntdfreq',Ntfreq DO i = 1,Ntfreq write(Nform,1010)'t',i,'freq',Tfreq(i) IF (Svallf)THEN write(Nform,1020)'t',i,'index',Tpeak(i)-1 write(Nform,1020)'t',i,'index.lower',Tlow(i)-1 write(Nform,1020)'t',i,'index.upper',Tup(i)-1 ELSE IF(Ny.eq.12)THEN IF(Ntfreq.eq.2)THEN IF(i.eq.1)THEN write(Nform,1020)'t',i,'index',42 ELSE IF(i.eq.2)THEN write(Nform,1020)'t',i,'index',52 END IF ELSE IF(i.eq.1)THEN write(Nform,1020)'t',i,'index',36 ELSE IF(i.eq.2)THEN write(Nform,1020)'t',i,'index',42 ELSE IF(i.eq.3)THEN write(Nform,1020)'t',i,'index',52 END IF END IF ELSE IF(i.eq.1) THEN write(Nform,1020)'t',i,'index',5 ELSE IF(i.eq.2) THEN write(Nform,1020)'t',i,'index',11 ELSE IF(i.eq.3)THEN write(Nform,1020)'t',i,'index',35 ELSE IF(i.eq.4)THEN write(Nform,1020)'t',i,'index',41 ELSE IF(i.eq.5)THEN write(Nform,1020)'t',i,'index',46 END IF END IF END IF END DO c----------------------------------------------------------------------- write(Nform,1000)'nsfreq',Nsfreq DO i = 1,Nsfreq write(Nform,1010)'s',i,'freq',Sfreq(i) IF (Svallf)THEN write(Nform,1020)'s',i,'index',Speak(i)-1 write(Nform,1020)'s',i,'index.lower',Slow(i)-1 IF(i.lt.Nsfreq)write(Nform,1020)'s',i,'index.upper',Sup(i)-1 ELSE IF(Ny.eq.12)THEN IF(i.eq.1) THEN write(Nform,1020)'s',i,'index',10 ELSE IF(i.eq.2) THEN write(Nform,1020)'s',i,'index',20 ELSE IF(i.eq.3)THEN write(Nform,1020)'s',i,'index',30 ELSE IF(i.eq.4)THEN write(Nform,1020)'s',i,'index',40 ELSE IF(i.eq.5)THEN write(Nform,1020)'s',i,'index',50 ELSE IF(i.eq.6)THEN write(Nform,1020)'s',i,'index',60 END IF ELSE IF(i.eq.1) THEN write(Nform,1020)'s',i,'index',30 ELSE IF(i.eq.2) THEN write(Nform,1020)'s',i,'index',60 END IF END IF END IF END DO c----------------------------------------------------------------------- 1000 FORMAT(a,': ',i5) 1010 FORMAT(a,i1,'.',a,': ',f12.8) 1020 FORMAT(a,i1,'.',a,': ',i5) c----------------------------------------------------------------------- RETURN ENDsvllog.cmn0000664006604000003110000000063414521201601012171 0ustar sun00315stepsc----------------------------------------------------------------------- c Svltab - Logical vector indicating which diagnostic will be stored c in the log file. c----------------------------------------------------------------------- LOGICAL Svltab DIMENSION Svltab(NSVLOG) c----------------------------------------------------------------------- COMMON /csvllg/Svltab svllog.i0000664006604000003110000000326214521201601011644 0ustar sun00315stepsc----------------------------------------------------------------------- c These tables must be consistant with the level variable c in getprt, in dfttbl in gtinpt, and tbldic in opnfil. c Variables with LSL are the displacements for the tables c found in the specs below, NSL are the number of tables used in c each spec. The spec's that have savelog tables are c changed NSLCMP from 22->20 -- Jan.2021 c c regression REG c automdl AUM c estimate EST c x11 X11 c history REV c slidingspans SSP c composite CMP c----------------------------------------------------------------------- INTEGER LSLADJ,NSLADJ INTEGER LSLAUM,NSLAUM INTEGER LSLAXM,NSLAXM INTEGER LSLEST,NSLEST INTEGER LSLREG,NSLREG INTEGER LSLOTL,NSLOTL INTEGER LSLCHK,NSLCHK INTEGER LSLX11,NSLX11 INTEGER LSLXRG,NSLXRG INTEGER LSLREV,NSLREV INTEGER LSLSSP,NSLSSP INTEGER LSLSPC,NSLSPC INTEGER LSLCMP,NSLCMP INTEGER LSLSET,NSLSET c----------------------------------------------------------------------- PARAMETER (LSLADJ= 0,NSLADJ= 1, & LSLAUM= 1,NSLAUM= 6, & LSLAXM= 7,NSLAXM= 1, & LSLEST= 8,NSLEST= 8, & LSLREG= 16,NSLREG= 2, & LSLOTL= 18,NSLOTL= 1, & LSLCHK= 19,NSLCHK= 9, & LSLX11= 28,NSLX11= 20, & LSLXRG= 48,NSLXRG= 1, & LSLREV= 49,NSLREV= 9, & LSLSSP= 58,NSLSSP= 2, & LSLSPC= 60,NSLSPC= 14, & LSLCMP= 74,NSLCMP= 20, & LSLSET= 94,NSLSET= 15) svllog.prm0000664006604000003110000000077414521201601012217 0ustar sun00315stepsc----------------------------------------------------------------------- c Note NSVLOG (the number of tables) is half PSVLOG because each c table has a long and short name. In the table dictionaries the short c name is written after each long name so the 2i-1 and 2i entries relate c to table i. c----------------------------------------------------------------------- INTEGER NSVLOG PARAMETER(NSVLOG=109) c----------------------------------------------------------------------- svltbl.prm0000664006604000003110000000306514521201602012214 0ustar sun00315steps CHARACTER SVLDIC*1294 INTEGER svlptr,PSVL PARAMETER(PSVL=218) DIMENSION svlptr(0:PSVL) PARAMETER(SVLDIC='autotransformatrautomodelamdautodiffadfbestfivem &dlb5mmeanmufinalunitrootfuralldiagnosticsallautomodelamdaicaicaicc &accbicbichannanquinnhqeiceicaveragefcsterrafcrootsrtsalldiagnostic &sallaictestatschi2testctsidentifiedidnormalitytestnrmseasonalacfsa &cljungboxqlbqboxpierceqbpqseasftestsfttdftesttftdurbinwatsondwfrie &dmantestfrtalldiagnosticsallm1m1m2m2m3m3m4m4m5m5m6m6m7m7m8m8m9m9m1 &0m10m11m11qqq2q2movingseasratiomsricratioicrfstableb1fb1fstabled8f &d8movingseasfmsfidseasonalidsalldiagnosticsallaictestatsaveabsrevs &aasaaveabsrevchngachaveabsrevindsaiaaaveabsrevtrendatraveabsrevtre &ndchngatcaveabsrevsfasfaveabsrevsfprojaspavesumsqfcsterrafealldiag &nosticsallpercentpctpercentspcspeaksspkdirpeaksdpkindpeaksipktukey &peakstpkdirtukeypeaksdtpindtukeypeaksitpqsqsdirqsdqsindqsiqsqcheck &qchnpsanpadirnpsadnpindnpsainpalldiagnosticsallindm1im1indm2im2ind &m3im3indm4im4indm5im5indm6im6indm7im7indm8im8indm9im9indm10imtindm &11imeindqiqindq2iq2indmovingseasratioisrindicratioiirindfstabled8i &d8indmovingseasfisfindidseasonaliidindtestittalldiagnosticsallseat &smodelsmdx13modelxmdx12modelx2mnormalitytestnrmtotalsquarederrorts &ecomponentvariancecvrconcurrentesterrorceepercentreductionseprsave &rageabsdiffannualaadoverunderestimationoueoverunderstatisticsousse &asonalsignifssgdurbinwatsondwsfriedmanfrsalldiagnosticsall') svltbl.var0000664006604000003110000000200714521201603012202 0ustar sun00315steps DATA svlptr / 1,14,17,26,29,37,40,51,54,58,60,73,76,90,93,102,105, &108,111,115,118,121,124,135,137,140,143,157,160,165,168,182,185, &192,195,203,206,216,218,231,234,245,248,257,260,270,273,282,285, &292,295,307,309,321,324,338,341,343,345,347,349,351,353,355,357, &359,361,363,365,367,369,371,373,375,377,380,383,386,389,390,391, &393,395,410,413,420,423,432,435,444,447,458,461,471,474,488,491, &498,501,512,515,528,531,545,548,562,565,583,586,597,600,615,618, &633,636,650,653,660,663,671,674,679,682,690,693,701,704,714,717, &730,733,746,749,751,753,758,761,766,769,775,778,782,785,792,795, &802,805,819,822,827,830,835,838,843,846,851,854,859,862,867,870, &875,878,883,886,891,894,900,903,909,912,916,918,923,926,944,947, &957,960,972,975,989,992,1005,1008,1015,1018,1032,1035,1045,1048, &1056,1059,1067,1070,1083,1086,1103,1106,1123,1126,1144,1147,1165, &1168,1188,1191,1210,1213,1232,1235,1249,1252,1264,1267,1275,1278, &1292,1295 / svolit.f0000664006604000003110000001250614521201603011656 0ustar sun00315stepsC Last change: BCM 23 Jul 1998 3:39 pm SUBROUTINE svolit(Lfcn,I,Ia,Aord,Otlid,Notlcr,Tval,Rbmse,Rmse, & Sviter,Lxreg) IMPLICIT NONE c----------------------------------------------------------------------- c Called by idotlr() c----------------------------------------------------------------------- c Save the outlier detection iterations c add new argument for svolit (BCM May 2007) c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c I i Input number of forward addition or backward deletion pass c Ia i Input if addall, number of outlier added or deleted in c this pass, otherwise 0 c Aord c Input '+' for addition or '-' for deletion c Otlid c Input characters of outlier id c Tval d Input t value c Rb2mse d Input tao based robust root mse c Rbmse d Input robust root mse c Rmse d Input normal root mse c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'savcmn.cmn' INCLUDE 'mdltbl.i' INCLUDE 'xrgtbl.i' c ------------------------------------------------------------------ LOGICAL frstcl,Lfcn,locok,Sviter,Lxreg CHARACTER outstr*(150) CHARACTER Aord*1,Otlid*(PCOLCR),climit*1 CHARACTER dash*(22) INTEGER fh,I,Ia,ipos,j,Notlcr DOUBLE PRECISION Tval,Rbmse,Rmse c ------------------------------------------------------------------ * INTEGER nblank * EXTERNAL nblank c ------------------------------------------------------------------ SAVE frstcl,fh c ------------------------------------------------------------------ DATA frstcl/.true./ DATA dash /'----------------------'/ c----------------------------------------------------------------------- IF(frstcl.and.Sviter)THEN IF(Lxreg)THEN CALL opnfil(.true.,.false.,LXROIT,fh,locok) ELSE CALL opnfil(.true.,.false.,LOTLIT,fh,locok) END IF IF(.not.locok)THEN CALL abend RETURN END IF c ------------------------------------------------------------------ WRITE(fh,1010)'pass',TABCHR,'io',TABCHR,'outlier',TABCHR, & 'medrmse',TABCHR,'rmse',TABCHR,'t' 1010 FORMAT(1000a) WRITE(fh,1010)'----',TABCHR,'--',TABCHR,'---------', & (TABCHR,dash(1:Svsize),j=1,3) frstcl=.false. END IF c----------------------------------------------------------------------- c Close the file if requested. c----------------------------------------------------------------------- IF(Lfcn)THEN IF(Sviter)THEN CALL fclose(fh) frstcl=.true. END IF c----------------------------------------------------------------------- c Save the iterations c----------------------------------------------------------------------- ELSE IF(Sviter)THEN climit=TABCHR ELSE climit=' ' END IF ipos=1 CALL itoc(I,outstr,ipos) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Sviter)THEN IF (Ia.gt.0) THEN outstr(ipos:ipos)='.' ELSE outstr(ipos:ipos)=climit END IF ELSE outstr(ipos:ipos)='.' END IF ipos=ipos+1 IF(Ia.gt.0)THEN CALL itoc(Ia,outstr,ipos) outstr(ipos:ipos)='.' ipos = ipos + 1 IF(Lfatal)RETURN IF(Sviter)THEN outstr(ipos:ipos)=climit ipos = ipos + 1 END IF END IF outstr(ipos:ipos)=Aord ipos=ipos+1 c ------------------------------------------------------------------ IF(Sviter)THEN outstr(ipos:ipos)=climit ipos=ipos+1 ELSE outstr(ipos:ipos+1)=': ' ipos=ipos+2 END IF c rather than compute length of regressor with nblank, take as c argument to routine (BCM May 2007) * notlcr=nblank(Otlid) outstr(ipos:ipos+Notlcr-1)=Otlid(1:Notlcr) ipos=ipos+notlcr c ------------------------------------------------------------------ outstr(ipos:ipos)=climit ipos=ipos+1 CALL dtoc(Rbmse,outstr,ipos) IF(Lfatal)RETURN c ------------------------------------------------------------------ outstr(ipos:ipos)=climit ipos=ipos+1 CALL dtoc(Rmse,outstr,ipos) IF(Lfatal)RETURN c ------------------------------------------------------------------ outstr(ipos:ipos)=climit ipos=ipos+1 CALL dtoc(Tval,outstr,ipos) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Sviter)THEN WRITE(fh,1010)outstr(1:ipos-1) ELSE IF(Lxreg)THEN WRITE(Nform,1010)'xotlitr.',outstr(1:ipos-1) ELSE WRITE(Nform,1010)'otlitr.',outstr(1:ipos-1) END IF END IF END IF c ------------------------------------------------------------------ RETURN END svoudg.f0000664006604000003110000005310314521201604011644 0ustar sun00315steps SUBROUTINE svoudg(Lsav,Lsumm,Ny) IMPLICIT NONE c ------------------------------------------------------------------ c save variables created by REG for over/under estimation c diagnostics into log file and/or diagonstic output - c Originally created by BCM - September 2005 c ------------------------------------------------------------------ INCLUDE 'acfast.i' INCLUDE 'across.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL Lsav INTEGER Lsumm,nsigv,nsiga1,nsigas,nsigcc,Ny c ------------------------------------------------------------------ c Determine how many of the tests are significant c ------------------------------------------------------------------ nsigv=0 IF(.not.(FACFPDC(0).eq.'??'.or.FACFPDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(FACFADC(0).eq.'??'.or.FACFADC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(FACFSDC(0).eq.'??'.or.FACFSDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(FACFIDC(0).eq.'??'.or.FACFIDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(NACFPDC(0).eq.'??'.or.NACFPDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(NACFADC(0).eq.'??'.or.NACFADC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(NACFSDC(0).eq.'??'.or.NACFSDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(NACFIDC(0).eq.'??'.or.NACFIDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(WACFPDC(0).eq.'??'.or.WACFPDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(WACFADC(0).eq.'??'.or.WACFADC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(WACFSDC(0).eq.'??'.or.WACFSDC(0).eq.'OK'))nsigv=nsigv+1 IF(.not.(WACFIDC(0).eq.'??'.or.WACFIDC(0).eq.'OK'))nsigv=nsigv+1 nsiga1=0 IF(.not.(FACFPDC(1).eq.'??'.or.FACFPDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(FACFADC(1).eq.'??'.or.FACFADC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(FACFSDC(1).eq.'??'.or.FACFSDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(FACFIDC(1).eq.'??'.or.FACFIDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(NACFPDC(1).eq.'??'.or.NACFPDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(NACFADC(1).eq.'??'.or.NACFADC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(NACFSDC(1).eq.'??'.or.NACFSDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(NACFIDC(1).eq.'??'.or.NACFIDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(WACFPDC(1).eq.'??'.or.WACFPDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(WACFADC(1).eq.'??'.or.WACFADC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(WACFSDC(1).eq.'??'.or.WACFSDC(1).eq.'OK'))nsiga1=nsiga1+1 IF(.not.(WACFIDC(1).eq.'??'.or.WACFIDC(1).eq.'OK'))nsiga1=nsiga1+1 nsigas=0 IF(.not.(FACFPDC(Ny).eq.'??'.or.FACFPDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(FACFADC(Ny).eq.'??'.or.FACFADC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(FACFSDC(Ny).eq.'??'.or.FACFSDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(FACFIDC(Ny).eq.'??'.or.FACFIDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(NACFPDC(Ny).eq.'??'.or.NACFPDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(NACFADC(Ny).eq.'??'.or.NACFADC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(NACFSDC(Ny).eq.'??'.or.NACFSDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(NACFIDC(Ny).eq.'??'.or.NACFIDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(WACFPDC(Ny).eq.'??'.or.WACFPDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(WACFADC(Ny).eq.'??'.or.WACFADC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(WACFSDC(Ny).eq.'??'.or.WACFSDC(Ny).eq.'OK')) & nsigas=nsigas+1 IF(.not.(WACFIDC(Ny).eq.'??'.or.WACFIDC(Ny).eq.'OK')) & nsigas=nsigas+1 nsigcc=0 IF(.not.(seaIrrDgC.eq.'??'.or.seaIrrDgC.eq.'OK'))nsigcc=nsigcc+1 IF(.not.(seaTreDgC.eq.'??'.or.seaTreDgC.eq.'OK'))nsigcc=nsigcc+1 IF(.not.(treIrrDgC.eq.'??'.or.treIrrDgC.eq.'OK'))nsigcc=nsigcc+1 c ------------------------------------------------------------------ c Save significant over/under estimation tests to log file c ------------------------------------------------------------------ IF (Lsav) THEN WRITE(Ng,1) IF(nsigv.eq.0)THEN WRITE(Ng,1000)'Variance' ELSE WRITE(Ng,1010)'Variance' IF(.not.(FACFPDC(0).eq.'??'.or.FACFPDC(0).eq.'OK'))THEN IF(FACFPDC(0).eq.'++'.or.FACFPDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Full Series)',FACFPDP(0) ELSE WRITE(Ng,1021)'Trend-Cycle (Full Series)',FACFPDP(0) END IF END IF IF(.not.(FACFADC(0).eq.'??'.or.FACFADC(0).eq.'OK'))THEN IF(FACFADC(0).eq.'++'.or.FACFADC(0).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Full Series)',FACFADP(0) ELSE WRITE(Ng,1021)'Adjustment (Full Series)',FACFADP(0) END IF END IF IF(.not.(FACFSDC(0).eq.'??'.or.FACFSDC(0).eq.'OK'))THEN IF(FACFSDC(0).eq.'++'.or.FACFSDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Full Series)',FACFSDP(0) ELSE WRITE(Ng,1021)'Seasonal (Full Series)',FACFSDP(0) END IF END IF IF(.not.(FACFIDC(0).eq.'??'.or.FACFIDC(0).eq.'OK'))THEN IF(FACFIDC(0).eq.'++'.or.FACFIDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Full Series)',FACFIDP(0) ELSE WRITE(Ng,1021)'Irregular (Full Series)',FACFIDP(0) END IF END IF IF(.not.(NACFPDC(0).eq.'??'.or.NACFPDC(0).eq.'OK'))THEN IF(NACFPDC(0).eq.'++'.or.NACFPDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Trimmed Series)',NACFPDP(0) ELSE WRITE(Ng,1021)'Trend-Cycle (Trimmed Series)',NACFPDP(0) END IF END IF IF(.not.(NACFADC(0).eq.'??'.or.NACFADC(0).eq.'OK'))THEN IF(NACFADC(0).eq.'++'.or.NACFADC(0).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Trimmed Series)',NACFADP(0) ELSE WRITE(Ng,1021)'Adjustment (Trimmed Series)',NACFADP(0) END IF END IF IF(.not.(NACFSDC(0).eq.'??'.or.NACFSDC(0).eq.'OK'))THEN IF(NACFSDC(0).eq.'++'.or.NACFSDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Trimmed Series)',NACFSDP(0) ELSE WRITE(Ng,1021)'Seasonal (Trimmed Series)',NACFSDP(0) END IF END IF IF(.not.(NACFIDC(0).eq.'??'.or.NACFIDC(0).eq.'OK'))THEN IF(NACFIDC(0).eq.'++'.or.NACFIDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Trimmed Series)',NACFIDP(0) ELSE WRITE(Ng,1021)'Irregular (Trimmed Series)',NACFIDP(0) END IF END IF IF(.not.(WACFPDC(0).eq.'??'.or.WACFPDC(0).eq.'OK'))THEN IF(WACFPDC(0).eq.'++'.or.WACFPDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Weighted)',WACFPDP(0) ELSE WRITE(Ng,1021)'Trend-Cycle (Weighted)',WACFPDP(0) END IF END IF IF(.not.(WACFADC(0).eq.'??'.or.WACFADC(0).eq.'OK'))THEN IF(WACFADC(0).eq.'++'.or.WACFADC(0).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Weighted)',WACFADP(0) ELSE WRITE(Ng,1021)'Adjustment (Weighted)',WACFADP(0) END IF END IF IF(.not.(WACFSDC(0).eq.'??'.or.WACFSDC(0).eq.'OK'))THEN IF(WACFSDC(0).eq.'++'.or.WACFSDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Weighted)',WACFSDP(0) ELSE WRITE(Ng,1021)'Seasonal (Weighted)',WACFSDP(0) END IF END IF IF(.not.(WACFIDC(0).eq.'??'.or.WACFIDC(0).eq.'OK'))THEN IF(WACFIDC(0).eq.'++'.or.WACFIDC(0).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Weighted)',WACFIDP(0) ELSE WRITE(Ng,1021)'Irregular (Weighted)',WACFIDP(0) END IF END IF END IF c ------------------------------------------------------------------ WRITE(Ng,1) IF(nsiga1.eq.0)THEN WRITE(Ng,1000)'First Order Autocovariance' ELSE WRITE(Ng,1010)'First Order Autocovariance' IF(.not.(FACFPDC(1).eq.'??'.or.FACFPDC(1).eq.'OK'))THEN IF(FACFPDC(1).eq.'++'.or.FACFPDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Full Series)',FACFPDP(1) ELSE WRITE(Ng,1021)'Trend-Cycle (Full Series)',FACFPDP(1) END IF END IF IF(.not.(FACFADC(1).eq.'??'.or.FACFADC(1).eq.'OK'))THEN IF(FACFADC(1).eq.'++'.or.FACFADC(1).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Full Series)',FACFADP(1) ELSE WRITE(Ng,1021)'Adjustment (Full Series)',FACFADP(1) END IF END IF IF(.not.(FACFSDC(1).eq.'??'.or.FACFSDC(1).eq.'OK'))THEN IF(FACFSDC(1).eq.'++'.or.FACFSDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Full Series)',FACFSDP(1) ELSE WRITE(Ng,1021)'Seasonal (Full Series)',FACFSDP(1) END IF END IF IF(.not.(FACFIDC(1).eq.'??'.or.FACFIDC(1).eq.'OK'))THEN IF(FACFIDC(1).eq.'++'.or.FACFIDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Full Series)',FACFIDP(1) ELSE WRITE(Ng,1021)'Irregular (Full Series)',FACFIDP(1) END IF END IF IF(.not.(NACFPDC(1).eq.'??'.or.NACFPDC(1).eq.'OK'))THEN IF(NACFPDC(1).eq.'++'.or.NACFPDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Trimmed Series)',NACFPDP(1) ELSE WRITE(Ng,1021)'Trend-Cycle (Trimmed Series)',NACFPDP(1) END IF END IF IF(.not.(NACFADC(1).eq.'??'.or.NACFADC(1).eq.'OK'))THEN IF(NACFADC(1).eq.'++'.or.NACFADC(1).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Trimmed Series)',NACFADP(1) ELSE WRITE(Ng,1021)'Adjustment (Trimmed Series)',NACFADP(1) END IF END IF IF(.not.(NACFSDC(1).eq.'??'.or.NACFSDC(1).eq.'OK'))THEN IF(NACFSDC(1).eq.'++'.or.NACFSDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Trimmed Series)',NACFSDP(1) ELSE WRITE(Ng,1021)'Seasonal (Trimmed Series)',NACFSDP(1) END IF END IF IF(.not.(NACFIDC(1).eq.'??'.or.NACFIDC(1).eq.'OK'))THEN IF(NACFIDC(1).eq.'++'.or.NACFIDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Trimmed Series)',NACFIDP(1) ELSE WRITE(Ng,1020)'Irregular (Trimmed Series)',NACFIDP(1) END IF END IF IF(.not.(WACFPDC(1).eq.'??'.or.WACFPDC(1).eq.'OK'))THEN IF(WACFPDC(1).eq.'++'.or.WACFPDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Weighted)',WACFPDP(1) ELSE WRITE(Ng,1021)'Trend-Cycle (Weighted)',WACFPDP(1) END IF END IF IF(.not.(WACFADC(1).eq.'??'.or.WACFADC(1).eq.'OK'))THEN IF(WACFADC(1).eq.'++'.or.WACFADC(1).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Weighted)',WACFADP(1) ELSE WRITE(Ng,1021)'Adjustment (Weighted)',WACFADP(1) END IF END IF IF(.not.(WACFSDC(1).eq.'??'.or.WACFSDC(1).eq.'OK'))THEN IF(WACFSDC(1).eq.'++'.or.WACFSDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Weighted)',WACFSDP(1) ELSE WRITE(Ng,1021)'Seasonal (Weighted)',WACFSDP(1) END IF END IF IF(.not.(WACFIDC(1).eq.'??'.or.WACFIDC(1).eq.'OK'))THEN IF(WACFIDC(1).eq.'++'.or.WACFIDC(1).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Weighted)',WACFIDP(1) ELSE WRITE(Ng,1020)'Irregular (Weighted)',WACFIDP(1) END IF END IF END IF c ------------------------------------------------------------------ WRITE(Ng,1) IF(nsigas.eq.0)THEN WRITE(Ng,1000)'Seasonal Order Autocovariance' ELSE WRITE(Ng,1010)'Seasonal Order Autocovariance' IF(.not.(FACFPDC(Ny).eq.'??'.or.FACFPDC(Ny).eq.'OK'))THEN IF(FACFPDC(Ny).eq.'++'.or.FACFPDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Full Series)',FACFPDP(Ny) ELSE WRITE(Ng,1021)'Trend-Cycle (Full Series)',FACFPDP(Ny) END IF END IF IF(.not.(FACFADC(Ny).eq.'??'.or.FACFADC(Ny).eq.'OK'))THEN IF(FACFADC(Ny).eq.'++'.or.FACFADC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Full Series)',FACFADP(Ny) ELSE WRITE(Ng,1021)'Adjustment (Full Series)',FACFADP(Ny) END IF END IF IF(.not.(FACFSDC(Ny).eq.'??'.or.FACFSDC(Ny).eq.'OK'))THEN IF(FACFSDC(Ny).eq.'++'.or.FACFSDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Full Series)',FACFSDP(Ny) ELSE WRITE(Ng,1021)'Seasonal (Full Series)',FACFSDP(Ny) END IF END IF IF(.not.(FACFIDC(Ny).eq.'??'.or.FACFIDC(Ny).eq.'OK'))THEN IF(FACFIDC(Ny).eq.'++'.or.FACFIDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Full Series)',FACFIDP(Ny) ELSE WRITE(Ng,1021)'Irregular (Full Series)',FACFIDP(Ny) END IF END IF IF(.not.(NACFPDC(Ny).eq.'??'.or.NACFPDC(Ny).eq.'OK'))THEN IF(NACFPDC(Ny).eq.'++'.or.NACFPDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Trimmed Series)',NACFPDP(Ny) ELSE WRITE(Ng,1021)'Trend-Cycle (Trimmed Series)',NACFPDP(Ny) END IF END IF IF(.not.(NACFADC(Ny).eq.'??'.or.NACFADC(Ny).eq.'OK'))THEN IF(NACFADC(Ny).eq.'++'.or.NACFADC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Trimmed Series)',NACFADP(Ny) ELSE WRITE(Ng,1021)'Adjustment (Trimmed Series)',NACFADP(Ny) END IF END IF IF(.not.(NACFSDC(Ny).eq.'??'.or.NACFSDC(Ny).eq.'OK'))THEN IF(NACFSDC(Ny).eq.'++'.or.NACFSDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Trimmed Series)',NACFSDP(Ny) ELSE WRITE(Ng,1021)'Seasonal (Trimmed Series)',NACFSDP(Ny) END IF END IF IF(.not.(NACFIDC(Ny).eq.'??'.or.NACFIDC(Ny).eq.'OK'))THEN IF(NACFIDC(Ny).eq.'++'.or.NACFIDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Trimmed Series)',NACFIDP(Ny) ELSE WRITE(Ng,1020)'Irregular (Trimmed Series)',NACFIDP(Ny) END IF END IF IF(.not.(WACFPDC(Ny).eq.'??'.or.WACFPDC(Ny).eq.'OK'))THEN IF(WACFPDC(Ny).eq.'++'.or.WACFPDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Trend-Cycle (Weighted)',WACFPDP(Ny) ELSE WRITE(Ng,1021)'Trend-Cycle (Weighted)',WACFPDP(Ny) END IF END IF IF(.not.(WACFADC(Ny).eq.'??'.or.WACFADC(Ny).eq.'OK'))THEN IF(WACFADC(Ny).eq.'++'.or.WACFADC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Adjustment (Weighted)',WACFADP(Ny) ELSE WRITE(Ng,1021)'Adjustment (Weighted)',WACFADP(Ny) END IF END IF IF(.not.(WACFSDC(Ny).eq.'??'.or.WACFSDC(Ny).eq.'OK'))THEN IF(WACFSDC(Ny).eq.'++'.or.WACFSDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Seasonal (Weighted)',WACFSDP(Ny) ELSE WRITE(Ng,1021)'Seasonal (Weighted)',WACFSDP(Ny) END IF END IF IF(.not.(WACFIDC(Ny).eq.'??'.or.WACFIDC(Ny).eq.'OK'))THEN IF(WACFIDC(Ny).eq.'++'.or.WACFIDC(Ny).eq.'+ ')THEN WRITE(Ng,1020)'Irregular (Weighted)',WACFIDP(Ny) ELSE WRITE(Ng,1020)'Irregular (Weighted)',WACFIDP(Ny) END IF END IF END IF c ------------------------------------------------------------------ WRITE(Ng,1) IF(nsigcc.eq.0)THEN WRITE(Ng,1000)'Crosscovariance' ELSE WRITE(Ng,1010)'Crosscovariance' IF(.not.(seaIrrDgC.eq.'??'.or.seaIrrDgC.eq.'OK'))THEN IF(seaIrrDgC.eq.'++'.or.seaIrrDgC.eq.'+ ')THEN WRITE(Ng,1022)'Seasonal/Irregular',seaIrrDgP ELSE WRITE(Ng,1023)'Seasonal/Irregular',seaIrrDgP END IF END IF IF(.not.(seaTreDgC.eq.'??'.or.seaTreDgC.eq.'OK'))THEN IF(seaTreDgC.eq.'++'.or.seaTreDgC.eq.'+ ')THEN WRITE(Ng,1022)'Seasonal/Trend-Cycle',seaTreDgP ELSE WRITE(Ng,1023)'Seasonal/Trend-Cycle',seaTreDgP END IF END IF IF(.not.(treIrrDgC.eq.'??'.or.treIrrDgC.eq.'OK'))THEN IF(treIrrDgC.eq.'++'.or.treIrrDgC.eq.'+ ')THEN WRITE(Ng,1022)'Trend-Cycle/Irregular',treIrrDgP ELSE WRITE(Ng,1023)'Trend-Cycle/Irregular',treIrrDgP END IF END IF END IF WRITE(Ng,1) END IF 1000 FORMAT(' None of the over/under estimation tests for ',a, & ' is significant') 1010 FORMAT(' The over/under estimation tests of ',a, & ' are significant',/,' for these components:') 1020 FORMAT(' ',a,t40,'(oversmoothing, p value = ',f7.4,')') 1021 FORMAT(' ',a,t40,'(undersmoothing, p value = ',f7.4,')') 1022 FORMAT(' ',a,t40,'(positive crosscovariance, p value = ', & f7.4,')') 1023 FORMAT(' ',a,t40,'(negative crosscovariance, p value = ', & f7.4,')') 1 FORMAT(' ') c ------------------------------------------------------------------ c Save significant over/under estimation tests to log file c ------------------------------------------------------------------ IF (Lsumm.gt.0) THEN WRITE(Nform,1030)'nsigoustatvar: ',nsigv WRITE(Nform,1030)'nsigoustat1auto: ',nsiga1 WRITE(Nform,1030)'nsigoustatsauto: ',nsigas WRITE(Nform,1030)'nsigoustatcrosscov: ',nsigcc IF(.not.(FACFPDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvartcfull: ',FACFPDG(0),FACFPDP(0) IF(.not.(FACFADC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarsafull: ',FACFADG(0),FACFADP(0) IF(.not.(FACFSDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarsffull: ',FACFSDG(0),FACFSDP(0) IF(.not.(FACFIDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarirfull: ',FACFIDG(0),FACFIDP(0) IF(.not.(NACFPDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvartctrim: ',NACFPDG(0),NACFPDP(0) IF(.not.(NACFADC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarsatrim: ',NACFADG(0),NACFADP(0) IF(.not.(NACFSDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarsftrim: ',NACFSDG(0),NACFSDP(0) IF(.not.(NACFIDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarirtrim: ',NACFIDG(0),NACFIDP(0) IF(.not.(WACFPDC(1).eq.'??')) & WRITE(Nform,1040)'oustatvartcwt: ',WACFPDG(0),WACFPDP(0) IF(.not.(WACFADC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarsawt: ',WACFADG(0),WACFADP(0) IF(.not.(WACFSDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarsfwt: ',WACFSDG(0),WACFSDP(0) IF(.not.(WACFIDC(0).eq.'??')) & WRITE(Nform,1040)'oustatvarirwt: ',WACFIDG(0),WACFIDP(0) IF(.not.(FACFPDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autotcfull: ',FACFPDG(1),FACFPDP(1) IF(.not.(FACFADC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autosafull: ',FACFADG(1),FACFADP(1) IF(.not.(FACFSDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autosffull: ',FACFSDG(1),FACFSDP(1) IF(.not.(FACFIDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autoirfull: ',FACFIDG(1),FACFIDP(1) IF(.not.(NACFPDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autotctrim: ',NACFPDG(1),NACFPDP(1) IF(.not.(NACFADC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autosatrim: ',NACFADG(1),NACFADP(1) IF(.not.(NACFSDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autosftrim: ',NACFSDG(1),NACFSDP(1) IF(.not.(NACFIDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autoirtrim: ',NACFIDG(1),NACFIDP(1) IF(.not.(WACFPDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autotcwt: ',WACFPDG(1),WACFPDP(1) IF(.not.(WACFADC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autosawt: ',WACFADG(1),WACFADP(1) IF(.not.(WACFSDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autosfwt: ',WACFSDG(1),WACFSDP(1) IF(.not.(WACFIDC(1).eq.'??')) & WRITE(Nform,1040)'oustat1autoirwt: ',WACFIDG(1),WACFIDP(1) IF(.not.(FACFPDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautotcfull: ',FACFPDG(Ny),FACFPDP(Ny) IF(.not.(FACFADC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautosafull: ',FACFADG(Ny),FACFADP(Ny) IF(.not.(FACFSDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautosffull: ',FACFSDG(Ny),FACFSDP(Ny) IF(.not.(FACFIDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautoirfull: ',FACFIDG(Ny),FACFIDP(Ny) IF(.not.(NACFPDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautotctrim: ',NACFPDG(Ny),NACFPDP(Ny) IF(.not.(NACFADC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautosatrim: ',NACFADG(Ny),NACFADP(Ny) IF(.not.(NACFSDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautosftrim: ',NACFSDG(Ny),NACFSDP(Ny) IF(.not.(NACFIDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautoirtrim: ',NACFIDG(Ny),NACFIDP(Ny) IF(.not.(WACFPDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautotcwt: ',WACFPDG(Ny),WACFPDP(Ny) IF(.not.(WACFADC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautosawt: ',WACFADG(Ny),WACFADP(Ny) IF(.not.(WACFSDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautosfwt: ',WACFSDG(Ny),WACFSDP(Ny) IF(.not.(WACFIDC(Ny).eq.'??')) & WRITE(Nform,1040)'oustatsautoirwt: ',WACFIDG(Ny),WACFIDP(Ny) IF(.not.(seaIrrDgC.eq.'??')) & WRITE(Nform,1040)'oustatccorsfir: ',seaIrrDia,seaIrrDgP IF(.not.(seaTreDgC.eq.'??')) & WRITE(Nform,1040)'oustatccorsftc: ',seaTreDia,seaTreDgP IF(.not.(treIrrDgC.eq.'??')) & WRITE(Nform,1040)'oustatccortcir: ',treIrrDia,treIrrDgP END IF 1030 FORMAT(a,i3) 1040 FORMAT(a,2e21.14) c ------------------------------------------------------------------ RETURN ENDsvpeak.f0000664006604000003110000000454114521201604011630 0ustar sun00315stepsC Last change: BCM 4 Mar 2008 3:46 pm SUBROUTINE svpeak(Sxx,Sxx2,Itbl,Iagr,Tpeak,Tlow,Tup,Ntfreq,Speak, & Slow,Sup,Nsfreq,Lseats,Ldecbl,Ltdfrq) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ONE,TEN,FIVETO PARAMETER(F=.false.,T=.true.,ONE=1D0,TEN=10D0,FIVETO=52D0) c----------------------------------------------------------------------- DOUBLE PRECISION Sxx,Sxx2,tmpsxx,medsxx,pklim,star1,sprng INTEGER Itbl,Nspstr,Iagr,Lsumm,Tpeak,Tlow,Tup,Ntfreq,i, & domfqt,domfqs,Speak,Slow,Sup,Nsfreq,Ltdpk,Lsapk LOGICAL Lseats,Ldecbl,Ltdfrq CHARACTER spcstr*(10) DIMENSION Sxx(61),Sxx2(*),Tpeak(*),Tlow(*),Tup(*),Speak(*), & Slow(*),Sup(*),tmpsxx(61) c----------------------------------------------------------------------- INTEGER smpeak DOUBLE PRECISION mkmdsx EXTERNAL smpeak,mkmdsx c----------------------------------------------------------------------- c Save information to .udg file c----------------------------------------------------------------------- CALL copy(Sxx,61,1,tmpsxx) CALL shlsrt(61,tmpsxx) medsxx=mkmdsx(tmpsxx,61,Ldecbl) sprng=tmpsxx(61)-tmpsxx(1) c----------------------------------------------------------------------- CALL mkspky(Itbl,spcstr,nspstr,Iagr,Lseats) write(Nform,1010)spcstr(1:nspstr),'median',medsxx write(Nform,1010)spcstr(1:nspstr),'range',sprng c----------------------------------------------------------------------- star1=sprng/FIVETO domfqt=NOTSET IF(Ltdfrq)domfqt=smpeak(Sxx2,F,Tpeak,Tlow,Tup,Ntfreq,star1, & medsxx,Nform,spcstr(1:nspstr)) domfqs=smpeak(Sxx2,T,Speak,Slow,Sup,Nsfreq,star1,medsxx,Nform, & spcstr(1:nspstr)) CALL mxpeak(Sxx2,Tpeak,domfqt,Ntfreq,Speak,domfqs,Nsfreq, & tmpsxx(61),Nform,spcstr(1:nspstr)) c----------------------------------------------------------------------- 1010 FORMAT(a,'.',a,': ',e20.10) c----------------------------------------------------------------------- RETURN END svrgcm.f0000664006604000003110000000576414521201604011650 0ustar sun00315stepsC Last change: BCM 1 Jun 1998 4:55 pm SUBROUTINE svrgcm(Nefobs,Xpxinv,Regidx) IMPLICIT NONE c----------------------------------------------------------------------- c Called by prtmdl() c----------------------------------------------------------------------- c Save the covariance matrix from var*(X'X)^-1 c----------------------------------------------------------------------- INCLUDE 'cchars.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'mdltbl.i' INCLUDE 'error.cmn' INCLUDE 'savcmn.cmn' c ------------------------------------------------------------------ LOGICAL locok CHARACTER str*(PCOLCR),outstr*(PCOLCR+22*PB),dash*(22) INTEGER fh,i,j,ii,jj,nchr,Nefobs,ipos,Regidx,jcol DOUBLE PRECISION rgnvar,Xpxinv DIMENSION Xpxinv(Nb*Ncxy/2),Regidx(PB) c ------------------------------------------------------------------ DATA dash /'----------------------'/ c----------------------------------------------------------------------- IF(Nb.le.1)RETURN c ------------------------------------------------------------------ CALL opnfil(.true.,.false.,LESTCM,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF c ------------------------------------------------------------------ c Construct and print header c ------------------------------------------------------------------ outstr(1:8)='variable' ipos=9 jcol=0 DO i=1,Nb IF(Regidx(i).ne.NOTSET)THEN outstr(ipos:ipos)=TABCHR ipos=ipos+1 outstr(ipos:ipos+2)='var' ipos=ipos+3 CALL itoc(i,outstr,ipos) IF(Lfatal)RETURN jcol=jcol+1 END IF END DO WRITE(fh,1010)outstr(1:ipos-1) WRITE(fh,1010)'--------',(TABCHR,dash(1:Svsize),i=1,jcol) c ------------------------------------------------------------------ rgnvar=Var*Nefobs/(Nefobs-jcol) c ------------------------------------------------------------------ DO i=1,Nb IF(Regidx(i).ne.NOTSET)THEN CALL getstr(Colttl,Colptr,Ncoltl,i,str,nchr) IF(Lfatal)RETURN outstr(1:nchr)=str(1:nchr) ipos=nchr+1 DO j=1,Nb IF(Regidx(j).ne.NOTSET)THEN jj=max(Regidx(i),Regidx(j)) ii=min(Regidx(i),Regidx(j)) outstr(ipos:ipos)=TABCHR ipos=ipos+1 CALL dtoc(rgnvar*Xpxinv((jj-1)*jj/2+ii),outstr,ipos) IF(Lfatal)RETURN END IF END DO c ------------------------------------------------------------------ WRITE(fh,1010)outstr(1:ipos-1) END IF END DO c ------------------------------------------------------------------ IF(locok)CALL fclose(fh) c ------------------------------------------------------------------ RETURN 1010 FORMAT(100a) END svrvhd.f0000664006604000003110000000647114521201604011657 0ustar sun00315steps SUBROUTINE svrvhd(Endall,Ny,Irevsa) IMPLICIT NONE c----------------------------------------------------------------------- c If summary output produced, save relevant information to file. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'revtrg.cmn' INCLUDE 'units.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- INTEGER MO,YR PARAMETER(MO=2,YR=1) c----------------------------------------------------------------------- INTEGER Endall,i,j,Ny,Irevsa DIMENSION Endall(2) C----------------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- CHARACTER num*(2) DIMENSION num(4) DATA num/'st','nd','rd','th'/ c----------------------------------------------------------------------- IF(.not.(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvtrn.or.Lrvtch.or.Lrvaic.or. & Lrvfct))RETURN c----------------------------------------------------------------------- WRITE(Nform,2000)'yes' IF(Irevsa.gt.0)THEN WRITE(Nform,2002)'yes' ELSE IF(Irevsa.eq.0)THEN WRITE(Nform,2002)'no' ELSE WRITE(Nform,2002)'failed' END IF IF(Lrvfct.and.Nfctlg.gt.0)WRITE(Nform,2001)'nfctlag: ',Nfctlg IF(Ntarsa.gt.0)THEN WRITE(Nform,2001)'nsalag: ',Ntarsa WRITE(Nform,2001)'nsalags: ',(Targsa(i),i=1,Ntarsa) ELSE IF(Lrvsa.or.Lrvch)THEN WRITE(Nform,2001)'nsalag: ',0 END IF IF(Ntartr.gt.0)THEN WRITE(Nform,2001)'ntrnlag: ',Ntartr WRITE(Nform,2001)'ntrnlags: ',(Targtr(i),i=1,Ntartr) ELSE IF(Lrvtrn.or.Lrvtch)THEN WRITE(Nform,2001)'ntrnlag: ',0 END IF 2000 FORMAT('history: ',a) 2001 FORMAT(a,10i3) 2002 FORMAT('historysa: ',a) c----------------------------------------------------------------------- c Save the starting and ending date of revisions c----------------------------------------------------------------------- i=Rvstrt(MO) IF(i.gt.4)i=4 j=endall(MO) IF(j.gt.4)j=4 IF(Ny.eq.12.or.Ny.eq.4)THEN WRITE(Nform,1000)'revspan: ',Rvstrt(MO),num(i), & Moqu(1:nblank(Moqu)),Rvstrt(YR),endall(MO), & num(j),Moqu(1:nblank(Moqu)),endall(YR) ELSE IF(Ny.eq.1)THEN WRITE(Nform,1001)'revspan: ',Rvstrt(YR),endall(YR) ELSE WRITE(Nform,1000)'revspan: ',Rvstrt(MO),num(i),'period', & Rvstrt(YR),endall(MO),num(j),'period', & endall(YR) END IF c----------------------------------------------------------------------- IF(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvtrn.or.Lrvtch)THEN IF(Cnctar)THEN WRITE(Nform,1002)'concurrent' ELSE WRITE(Nform,1002)'final' END IF END IF c----------------------------------------------------------------------- 1000 FORMAT(a,i2,a2,1x,a,',',i4,' to ',i2,a2,1x,a,',',i4) 1001 FORMAT(a,i4,' to ',i4) 1002 FORMAT('historytarget: ',a) c----------------------------------------------------------------------- RETURN END svspan.f0000664006604000003110000000570314521201604011652 0ustar sun00315stepsC Last change: BCM 15 Jan 98 12:22 pm SUBROUTINE svspan(X,Nopt,Dmax,Ltbl,Ncol,Lopgrf) IMPLICIT NONE c----------------------------------------------------------------------- c Saves the complete sliding spans table into a separate file, c with date, estimate, and maximum percentage difference c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'error.cmn' INCLUDE 'ssap.cmn' INCLUDE 'cchars.i' c----------------------------------------------------------------------- INTEGER MO,YR PARAMETER(MO=2,YR=1) c----------------------------------------------------------------------- CHARACTER num*1 CHARACTER*130 outstr LOGICAL locok,Lopgrf DOUBLE PRECISION Dmax,X INTEGER idate,fh,Ltbl,i,ipos,l,l0,rdbdat,Nopt,ssdate,Ncol DIMENSION idate(2),ssdate(2),X(MXLEN,MXCOL),Dmax(MXLEN,NEST), & num(4) c----------------------------------------------------------------------- DATA num/'1','2','3','4'/ c----------------------------------------------------------------------- c Open the file; if the file cannot be opened, stop c----------------------------------------------------------------------- CALL opnfil(.true.,Lopgrf,Ltbl,fh,locok) IF(.not.locok)THEN CALL abend RETURN END IF ssdate(YR)=Iyr ssdate(MO)=Im c----------------------------------------------------------------------- c Write file header c----------------------------------------------------------------------- WRITE(fh,1010)'date',(TABCHR,'Span'//num(i),i=1,Ncol),TABCHR, & 'Max_%_DIFF' WRITE(fh,1010)'------',(TABCHR,'-----------------------',i=1,Ncol) & ,TABCHR,'-----------------------' c----------------------------------------------------------------------- c Write out the sliding spans information c----------------------------------------------------------------------- DO l0=Im,Sslen+Im-1 ipos=1 CALL addate(ssdate,Nsea,l0-Im,idate) rdbdat=100*idate(YR)+idate(MO) CALL itoc(rdbdat,outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 DO l=1,Ncol CALL dtoc(X(l0,l),outstr,ipos) IF(Lfatal)RETURN outstr(ipos:ipos)=TABCHR ipos=ipos+1 END DO c----------------------------------------------------------------------- CALL dtoc(Dmax(l0,Nopt),outstr,ipos) IF(Lfatal)RETURN WRITE(fh,1010)outstr(1:ipos-1) END DO c----------------------------------------------------------------------- c Close the file. c----------------------------------------------------------------------- IF(locok)CALL fclose(fh) RETURN c----------------------------------------------------------------------- 1010 FORMAT(a:,a,a,a,a,a,a:,a,a:,a,a) END svtukp.f0000664006604000003110000001120714521201604011670 0ustar sun00315steps SUBROUTINE svtukp(Iagr,Lsumm,csPeak,ctPeak,csPk90,ctPk90,Lsadj) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'tukey.cmn' INCLUDE 'spctbl.i' c----------------------------------------------------------------------- LOGICAL Lsadj CHARACTER thisLb*(9),csPeak*(35),ctPeak*(35),csPk90*(35), & ctPk90*(35) INTEGER Iagr,i,k,nLb,iLb,nsPeak,ntPeak,nsPk90,ntPk90,p1,p2,npk, & npk90,oriIdx,Lsumm DOUBLE PRECISION thisPk,thisTd DIMENSION thisPk(6) c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- oriIdx=NOTSET csPeak=' ' ctPeak=' ' csPk90=' ' ctPk90=' ' nsPeak=0 ntPeak=0 nsPk90=0 ntPk90=0 c----------------------------------------------------------------------- DO i=1,Ntukey c----------------------------------------------------------------------- c Set up labels, peak vectors c----------------------------------------------------------------------- thisLb(1:3)='spc ' IF(Itukey(i).eq.LSPCRS)THEN CALL copy(Ptsr,6,1,thisPk) thisTD=Pttdr nLb=6 thisLb(4:6)='rsd' iLb=4 ELSE IF(Itukey(i).eq.LSPTS0.or.Itukey(i).eq.LSPT0C)THEN CALL copy(Ptso,6,1,thisPk) thisTD=Pttdo nLb=6 thisLb(4:6)='ori' IF(.not.Lsadj)oriIdx=i iLb=4 ELSE IF(Itukey(i).eq.LSPTS1.or.Itukey(i).eq.LSPT1I.or. & Itukey(i).eq.LSPT1S)THEN CALL copy(Ptsa,6,1,thisPk) thisTD=Pttda IF(Itukey(i).eq.LSPTS1.or.Itukey(i).eq.LSPT1S)THEN nLb=5 thisLb(4:5)='sa' ELSE IF(Itukey(i).eq.LSPT1I)THEN nLb=8 thisLb(4:8)='indsa' END IF iLb=4 IF(Iagr.gt.3)iLb=7 ELSE IF(Itukey(i).eq.LSPTS2.or.Itukey(i).eq.LSPT2I.or. & Itukey(i).eq.LSPT2S)THEN CALL copy(Ptsi,6,1,thisPk) thisTD=Pttdi IF(Itukey(i).eq.LSPTS2.or.Itukey(i).eq.LSPT2S)THEN nLb=6 thisLb(4:6)='irr' ELSE IF(Itukey(i).eq.LSPT2I)THEN nLb=9 thisLb(4:9)='indirr' END IF iLb=4 IF(Iagr.gt.3)iLb=7 END IF c----------------------------------------------------------------------- c Write out peak probabilities c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN DO k=1,6 WRITE(Nform,1010)thisLb(1:nLb),'.tukey.s',k,': ',thisPk(k) END DO WRITE(Nform,1020)thisLb(1:nLb),'.tukey.td: ',thisTD END IF c----------------------------------------------------------------------- c Set up inidication is tukey spectra of given estimate has a peak c----------------------------------------------------------------------- npk=0 npk90=0 DO k=1,6 IF(k.ne.oriIdx)THEN IF(thisPk(k).gt.0.90D0)npk90=npk90+1 IF(thisPk(k).gt.0.99D0)npk=npk+1 END IF END DO IF(npk90.gt.0)THEN p1=nsPk90+1 p2=p1+(nLb-iLb) csPk90(p1:p2)=thisLb(iLb:nLb) nsPk90=p2+1 END IF IF(npk.gt.0)THEN p1=nsPeak+1 p2=p1+(nLb-iLb) csPeak(p1:p2)=thisLb(iLb:nLb) nsPeak=p2+1 END IF IF(thisTD.gt.0.90D0)THEN p1=ntPk90+1 p2=p1+(nLb-iLb) ctPk90(p1:p2)=thisLb(iLb:nLb) ntPk90=p2+1 END IF IF(thisTD.gt.0.99D0)THEN p1=ntPeak+1 p2=p1+(nLb-iLb) ctPeak(p1:p2)=thisLb(iLb:nLb) ntPeak=p2+1 END IF END DO c----------------------------------------------------------------------- c If no tukey peaks, set peak indicator to none c----------------------------------------------------------------------- IF(nsPeak.eq.0)THEN nsPeak=4 csPeak(1:nsPeak)='none' END IF IF(ntPeak.eq.0)THEN ntPeak=4 ctPeak(1:ntPeak)='none' END IF IF(nsPk90.eq.0)THEN nsPk90=4 csPk90(1:nsPk90)='none' END IF IF(ntPk90.eq.0)THEN ntPk90=4 ctPk90(1:ntPk90)='none' END IF c----------------------------------------------------------------------- 1010 FORMAT(a,a,i1,a,f9.4) 1020 FORMAT(a,a,f9.4) c----------------------------------------------------------------------- RETURN END table.f0000664006604000003110000005272514521201604011435 0ustar sun00315stepsC Last change: Mar.2021 - change from E3->E2 in e4lab C previous change: BCM 16 Feb 1999 3:59 pm SUBROUTINE table(Z,Ib,Ie,Ktabl,Itype,Nop,Y,Tblptr) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE WRITES TABLE OUTPUT. C --- Z IS THE ARRAY TO BE PRINTED FROM IB TO IE. C --- Y IS AN ADDITIONAL ARRAY TO BE PRINTED ON TABLE. C --- KTABL IS THE TABLE NUMBER. C --- NOP = 1,AVERAGE. C --- = 2,TOTAL. C --- = 3,STANDARD DEVIATION. C --- = 4,MOVING 5-YEAR STD. DEV. C --- = 5,NONE. C --- = 0,AVERAGE OF ABSOLUTE VALUE. C --- ITYPE SPECIFIES IF THIS IS ADDITIONAL KTABL. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'tfmts.prm' INCLUDE 'tbltitle.prm' INCLUDE 'desfct.prm' INCLUDE 'desfc2.prm' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'tfmts.cmn' INCLUDE 'units.cmn' INCLUDE 'missng.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'xtrm.cmn' INCLUDE 'goodob.cmn' INCLUDE 'force.cmn' INCLUDE 'agr.cmn' c----------------------------------------------------------------------- INTEGER YR,MO,PSP1 LOGICAL F,T DOUBLE PRECISION ZERO,BIG PARAMETER(YR=1,MO=2,F=.false.,T=.true.,PSP1=PSP+1,ZERO=0D0, & BIG=10D16) c----------------------------------------------------------------------- CHARACTER tblttl*(PTTLEN),tyrly*(5),fbase*(110),fobs*(5),fsum*(5), & tfmt*(110),tfmt2*(110),e4lab*(21),dash*(60) LOGICAL lp,ltbl DOUBLE PRECISION tmp,x,Z,Y,xmin,xmax,mtmp,numtmp INTEGER i,ip,ifct,jyr,nb,ie2,l,begtbl,nopp,Nop,Ib,Ie,iin,ipow, & ldec,nb2,Ktabl,iopt,ipos,wid,ndash,npos,npos2,Itype,kyr, & nobs,ib1,ie1,im,im1,im2,nop1,ke,Tblptr,nfct,idate,begfct, & ntbttl,nmod,sp1,nftbl DIMENSION ip(22),tmp(PSP1),x(PLEN),idate(2),begfct(2),tyrly(0:5), & Z(*),Y(*),begtbl(2),e4lab(4) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION totals,sdev INTEGER nblank EXTERNAL totals,sdev,nblank,dpeq c----------------------------------------------------------------------- DATA tyrly/'AVABS',' AVGE','TOTAL',' S.D.',' S.D.',' '/ DATA ip/0,0,3*1,0,0,3*1,0,0,1,1,0,1,1,1,0,1,1,1/ DATA e4lab/' Unmodified',' Modified', & ' (D11)',' (E2)'/ c----------------------------------------------------------------------- c include files containing DATA statements c----------------------------------------------------------------------- INCLUDE 'desfct.var' INCLUDE 'desfc2.var' INCLUDE 'tfmts.var' c----------------------------------------------------------------------- c Return if this is a transparent seasonal adjustment for sliding c spans, revisions, or X-11 Holiday adjustment. c----------------------------------------------------------------------- IF(Lhiddn)RETURN IF(.not.Prt1ps.AND.(.NOT.(Kpart.eq.1.and.Ktabl.eq.1)))THEN IF(Ixreg.eq.2.OR.Khol.eq.1)THEN IF(.NOT.((Kpart.eq.1.and.Ktabl.eq.4).OR. & (Kpart.eq.0.and.Ktabl.eq.1).or.(Ktabl.ge.14.and.Ktabl.le.16) & .or.Ktabl.eq.18.or.Ktabl.eq.21.or.Ktabl.eq.22))RETURN END IF END IF c----------------------------------------------------------------------- C --- INITIALIZATION c----------------------------------------------------------------------- nftbl=Posffc-Posfob IF(Kpart.eq.1)ip(3)=0 IF(Kpart.ne.1)ip(3)=1 nopp=Nop IF(Missng)THEN IF(nopp.lt.5.and.Ib.gt.0)THEN i=Ib DO WHILE (i.le.Ie.and.nopp.ne.5) IF(dpeq(Z(i),Mvval))nopp=5 i=i+1 END DO END IF mtmp=10D0**(Tblwid+1) IF(Mvval.gt.mtmp)mtmp=Mvval END IF ke=Ie iin=1 ipow=0 ldec=Kdec sp1=Ny+1 nmod=5 IF(Ny.lt.5)nmod=10 IF(Ib.ne.0)THEN c----------------------------------------------------------------------- c Determine if forecasts are to be printed out and, if so, how many c----------------------------------------------------------------------- IF(Tblptr.le.PDSF)THEN ifct=dsfptr(Tblptr)-dsfptr(Tblptr-1) ELSE ifct=df2ptr(Tblptr-PDSF)-df2ptr(Tblptr-PDSF-1) END IF nfct=ifct IF(ifct.gt.0)THEN IF(((Kpart.eq.2.and.Ktabl.eq.1).or.(Kpart.eq.4.and. & (((Ktabl.eq.10.or.Ktabl.eq.16).and.Itype.eq.2).or. & ((Ktabl.eq.16.or.Ktabl.eq.18).and.Itype.eq.3))).or. & (Kpart.eq.5.and.Ktabl.eq.16).and.(Kpart.eq.4.and.Ktabl.eq.11 & .and.Itype.eq.6)).and.nftbl.eq.0)THEN nfct=0 ifct=0 ELSE IF(Kpart.eq.4.and.Ktabl.eq.11.and.Itype.eq.6.and. & (.not.Lfctfr))THEN nfct=0 ifct=0 ELSE nfct=nftbl IF(nftbl.eq.0)THEN IF((Kpart.eq.0.and.Ktabl.eq.1).or.(Kpart.eq.1.AND. & (Ktabl.eq.4.OR.Ktabl.eq.6.or.Ktabl.eq.7.or.Ktabl.eq.8.or. & Ktabl.eq.16).and.Nfcst.eq.0).or.(Kpart.eq.3.and. & (Ktabl.eq.16.or.Ktabl.eq.18.or.Ktabl.gt.20)).or. & (Iagr.lt.4.and.(Kpart.eq.4.and.(Ktabl.eq.8.or.Ktabl.eq.10 & .or.Ktabl.eq.16.or.Ktabl.eq.18))))THEN nfct=Ny ELSE ifct=0 END IF END IF END IF END IF c----------------------------------------------------------------------- c Copy data into temporary vector x c----------------------------------------------------------------------- ie2=Ie+nfct xmin=DNOTST xmax=DNOTST ltbl=Ktabl.eq.17.or.((Kpart.eq.2.or.Kpart.eq.3).and. & (Ktabl.eq.16.or.Ktabl.eq.21.or.Ktabl.eq.22)) DO i=Ib,ie2 IF(Muladd.eq.2.and.(.not.ltbl))THEN IF(dpeq(Z(i),DNOTST).or.dpeq(Z(i),BIG))THEN x(i)=Z(i) ELSE x(i)=exp(Z(i)) END IF ELSE x(i)=Z(i) IF(Missng)THEN IF(dpeq(x(i),Mvval))x(i)=mtmp END IF END IF IF(nopp.lt.5.and.i.le.Ie)THEN IF(Gudval(i))THEN IF(dpeq(xmin,DNOTST))THEN xmin=x(i) xmax=x(i) ELSE IF(xmin.gt.x(i))xmin=x(i) IF(xmax.lt.x(i))xmax=x(i) END IF END IF END IF END DO IF(Muladd.eq.1)THEN IF((Kpart.eq.5.and.Ktabl.eq.18.and.Itype.eq.1).or. & (Ktabl.eq.17))THEN ipow=1 IF((Kpart.eq.5.and.Ktabl.eq.18.and.Itype.eq.1).and. & (ldec.eq.0))ldec=3 END IF ELSE ipow=ip(Ktabl) IF((Kpart.eq.1.and.(Ktabl.eq.2.or.Ktabl.eq.6.or.Ktabl.eq.7)).or. & (Kpart.eq.4.and.Ktabl.eq.12.and.Itype.eq.3).or. & (Kpart.eq.5.AND.(Ktabl.eq.6.or.Ktabl.eq.7)).or. & (Kpart.eq.0.and.Ktabl.eq.1).or. & (Kpart.eq.4.and.Ktabl.eq.11.and.Itype.eq.6)) & ipow=1 IF((Kpart.eq.4.and.Ktabl.eq.10.and.Itype.eq.2).or. & (Kpart.eq.4.and.Ktabl.eq.16.and.Itype.eq.2).or. & (Kpart.eq.-1.and.Ktabl.eq.10.and.Itype.eq.2).or. & (Kpart.eq.1.and.Ktabl.eq.18)) & ipow=0 IF(ldec.eq.0.and.((Kpart.eq.4.and.Itype.eq.1.and.(Ktabl.eq.10 & .or.Ktabl.eq.16)).or.(Kpart.eq.3.and.(Ktabl.eq.16.or. & Ktabl.eq.18)).or.(Kpart.eq.1.and.Ktabl.eq.16)))ldec=2 IF(ldec.eq.0.and.ipow.eq.1)ldec=1 END IF iopt=ip(Ktabl)+ipow IF(Kpart.eq.5.AND.(Ktabl.eq.5.or.Ktabl.eq.7.or.Ktabl.eq.8))iopt=1 IF(Muladd.ne.1)THEN IF((Kpart.eq.1.and.(Ktabl.eq.2.or.Ktabl.eq.6.or.Ktabl.eq.7)).or. & (Kpart.eq.0.and.Ktabl.eq.1).or. & (Kpart.eq.4.and.Ktabl.eq.12.and.Itype.eq.3).or. & (Kpart.eq.4.and.Ktabl.eq.11.and.Itype.eq.6))iopt=2 IF((Kpart.eq.1.and.Ktabl.eq.10))iopt=0 END IF END IF c----------------------------------------------------------------------- c Compute starting date for table c----------------------------------------------------------------------- begtbl(YR)=Lyr begtbl(MO)=mod(Ib,Ny) IF(begtbl(MO).eq.0)begtbl(MO)=Ny IF(Ib.gt.Pos1bk)THEN begtbl(YR)=begtbl(YR)+((Ib-1)/Ny) * begtbl(YR)=begtbl(YR)+((Ib-Pos1bk)/Ny) ELSE IF((Ixreg.eq.2.or.Ib.gt.Ny).and.Nbcst.eq.0) THEN begtbl(YR)=begtbl(YR)+((Ib-1)/Ny) END IF c----------------------------------------------------------------------- c compute number of observations in table c----------------------------------------------------------------------- nobs=Ie-Ib+1 c----------------------------------------------------------------------- c Get the table description from one of the data dictionaries C ------------------------------------------------------------------ CALL getdes(Tblptr,tblttl,ntbttl,T) IF(Lfatal)RETURN c----------------------------------------------------------------------- c --- Write header for table c----------------------------------------------------------------------- If(Ib.eq.0.and.Ie.eq.0)THEN lp=Lpage IF(Kpart.eq.4.and.Ktabl.eq.9)lp=F IF(lp)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF IF(ntbttl.gt.0)WRITE(Mt1,1020)tblttl(1:ntbttl) 1020 FORMAT(/,' ',a) RETURN END IF c----------------------------------------------------------------------- c If this is the E 4 table, print out results and print ratios. c----------------------------------------------------------------------- IF(Kpart.eq.5.and.Ktabl.eq.4)THEN * IF(Pos1bk.ne.1)begtbl(YR)=begtbl(YR)+1 c----------------------------------------------------------------------- c print out header for table c----------------------------------------------------------------------- CALL tblhdr(Ktabl,Itype,Ixreg,nobs,begtbl,1,Y,tblttl(1:ntbttl)) IF(Lfatal)RETURN wid=Tblwid IF(wid.lt.12)wid=12 write(fobs,1030)wid 1030 FORMAT('a',i2) fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr+1,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,tfmt,fobs(1:3),fobs(1:3),ipos,npos) CALL setchr('-',60,dash) dash(1:1)=' ' ndash=10+2*(Disp2+wid) WRITE(Mt1,1010)dash(1:ndash) WRITE(Mt1,tfmt(1:npos))' Year',(e4lab(i)((21-wid+1):21),i=1,2) WRITE(Mt1,tfmt(1:npos))' ',(e4lab(i)((21-wid+1):21),i=3,4) WRITE(Mt1,1010)dash(1:ndash) 1010 FORMAT(a) jyr=begtbl(YR) c----------------------------------------------------------------------- c Generate format for table, and print out ratios/differences c----------------------------------------------------------------------- ldec=Kdec IF(mod(Muladd,2).eq.0.and.ldec.eq.0)ldec=2 write(fobs,1040)wid,ldec 1040 FORMAT('f',i2,'.',i1) fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,tfmt,fobs,fobs,ipos,npos) DO i=1,Ie WRITE(Mt1,tfmt(1:npos))jyr,X(i),Y(i) IF((.not.Lcmpaq).or.((mod(jyr,nmod)+1).eq.nmod))WRITE(Mt1,1050) 1050 FORMAT(' ') jyr=jyr+1 END DO RETURN END IF c----------------------------------------------------------------------- c print out header for table c----------------------------------------------------------------------- CALL tblhdr(Ktabl,Itype,Ixreg,nobs,begtbl,Ny,Y,tblttl(1:ntbttl)) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- WRITE COLUMN HEADINGS. c----------------------------------------------------------------------- l=Ny+1 CALL prtcol(l,0,Tblcol,Tblwid,Ny,Mt1,nopp,tyrly(nopp),Disp2,Disp3, & Fmtcol,Colhdr) IF(nopp.eq.5)l=l-1 c----------------------------------------------------------------------- C --- WRITE TABLE. c----------------------------------------------------------------------- jyr=Lyr+(Ib-1)/Ny kyr=(Ie+Ny-1)/Ny+Lyr-1 iin=iin+(jyr-Lyr) DO i=1,PSP1 tmp(i)=DNOTST END DO ib1=Ib ie1=(jyr-Lyr+1)*Ny IF(ie1.gt.Ie)ie1=Ie im=Ib-(Ib-1)/Ny*Ny DO WHILE (T) im1=im DO i=ib1,ie1 tmp(im)=x(i) im=im+1 END DO im2=im-1 c----------------------------------------------------------------------- c Compute totals or std deviation for this year's observation. c----------------------------------------------------------------------- IF(nopp.eq.2)THEN tmp(l)=totals(tmp,im1,im2,1,0) ELSE IF(nopp.eq.3)THEN tmp(l)=sdev(tmp,im1,im2,1,iopt) ELSE IF(nopp.eq.4)THEN tmp(l)=Y(iin) iin=iin+1 ELSE IF(nopp.ne.5)THEN tmp(l)=totals(tmp,im1,im2,1,2-nopp) END IF c----------------------------------------------------------------------- c Compute number of blanks for the beginning or end of the series c for observations not in the series. c----------------------------------------------------------------------- nb=0 IF(jyr.eq.begtbl(YR).and.begtbl(MO).gt.1)nb=begtbl(MO) nb2=0 IF(ie1.eq.Ie)THEN CALL addate(begtbl,Ny,nobs-1,idate) nb2=idate(MO) IF(nb2.eq.Ny)nb2=0 END IF c----------------------------------------------------------------------- c If number of decimals in printout has changed, redo format c----------------------------------------------------------------------- IF(ldec.eq.Kdec)then tfmt=Ifmt1 tfmt2=Ifmt2 npos=Nfmt1 npos2=Nfmt2 ELSE write(fobs,1040)Tblwid,ldec write(fsum,1040)Tblwid+2,ldec fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,tfmt,fobs,fsum,ipos,npos) fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr+1,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,tfmt2,fobs,fsum,ipos,npos2) END IF c----------------------------------------------------------------------- c Write out this year's data. c----------------------------------------------------------------------- c02 111 WRITE(MT1,IF1) JYR,(TMP(I),I = 1,L) CALL wrttbl(tmp,jyr,'XXXXX',l,ldec,Mt1,tfmt(1:npos),Tblwid, & Tblcol,Disp1,Disp2,Disp3,nb,nb2,ipow,l.eq.sp1) IF(Lfatal)RETURN IF((.not.Lcmpaq) .or. (((mod(jyr,nmod)+1).eq.nmod) .or. & (kyr.lt.jyr+1)))WRITE(Mt1,1050) c----------------------------------------------------------------------- c Update year, starting and ending position of year c----------------------------------------------------------------------- jyr=jyr+1 im=1 ib1=ie1+1 ie1=ie1+Ny IF(kyr.lt.jyr)THEN IF((Kpart.eq.2.and.(Ktabl.eq.4.or.Ktabl.eq.9)).or. & ((Kpart.eq.2.or.Kpart.eq.3).and.Ktabl.eq.17))THEN IF(Ksdev.gt.0)THEN DO i=1,Ny tmp(i)=Stdper(i) END DO CALL wrttbl(tmp,0,tyrly(3),Ny,ldec,Mt1,tfmt2(1:npos2),Tblwid, & Tblcol,Disp1,Disp2,Disp3,0,0,ipow,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- CALCULATE AND WRITE COLUMN SUMMARIES. c----------------------------------------------------------------------- ELSE IF(nopp.lt.5)THEN ie1=Ib+Ny-1 im=Ib-(Ib-1)/Ny*Ny nb=0 nb2=0 DO i=Ib,ie1 IF(i.gt.Ie)THEN tmp(im)=DNOTST IF(i.eq.im)THEN IF(nb2.eq.0)nb2=im-1 ELSE IF(nb.eq.0)nb=1 nb=nb+1 END IF ELSE IF(nopp.gt.2)THEN tmp(im)=sdev(x,i,Ie,Ny,iopt) ELSE IF(nopp.gt.0)THEN tmp(im)=totals(x,i,Ie,Ny,1) ELSE tmp(im)=totals(x,i,Ie,Ny,2) END IF END IF IF(im.eq.Ny)im=0 im=im+1 END DO C --- GENERATE COLUMN SUMMARY FORMATS. nop1=(nopp-1)/2*2+1 IF(nopp.eq.0)nop1=0 c02 WRITE(MT1,IF2) TYRLY(NOP1),(TMP(I),I = 1,NY) CALL wrttbl(tmp,0,tyrly(nop1),Ny,ldec,Mt1,tfmt2(1:npos2), & Tblwid,Tblcol,Disp1,Disp2,Disp3,nb,nb2,ipow,F) IF(Lfatal)RETURN numtmp=totals(x,Ib,Ie,1,3) IF(numtmp.gt.ZERO)THEN IF(nopp.gt.0)THEN tmp(1)=totals(x,Ib,Ie,1,0) tmp(2)=tmp(1)/numtmp ELSE tmp(2)=totals(x,Ib,Ie,1,2) tmp(1)=tmp(2)*numtmp END IF tmp(3)=sdev(x,Ib,Ie,1,iopt) IF(ipow.ne.0)THEN DO i=1,3 tmp(i)=tmp(i)*100D0 END DO xmax=xmax*100D0 xmin=xmin*100D0 END IF C --- WRITE TABLE SUMMARY. WRITE(Mt1,Ifmt3)(tmp(i),i=1,3),xmin,xmax END IF END IF GO TO 10 ELSE IF(kyr.eq.jyr)THEN DO i=1,Ny tmp(i)=DNOTST END DO ie1=ke END IF END DO c----------------------------------------------------------------------- c Check to see if there are forecasts to be printed out. c----------------------------------------------------------------------- 10 IF(ifct.gt.0)THEN c----------------------------------------------------------------------- c If forecasts are to be printed out, get base title for forecasts c----------------------------------------------------------------------- IF(Tblptr.le.PDSF)THEN CALL makttl(DSFDIC,dsfptr,PDSF,Tblptr,0,tblttl,ntbttl,T,T) ELSE CALL makttl(DF2DIC,df2ptr,PDF2,Tblptr-PDSF,0,tblttl,ntbttl,T,T) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c compute starting date of forecasts in table, ending observation c----------------------------------------------------------------------- CALL addate(begtbl,Ny,nobs,begfct) ke=Ie+nfct lp=F c----------------------------------------------------------------------- c print header for forecasts c----------------------------------------------------------------------- CALL prtshd(tblttl(1:ntbttl),begfct,Ny,nfct,lp) IF(Lfatal)RETURN IF((.not.(Kpart.eq.1.and.Ktabl.eq.1)).AND.(Ixreg.eq.2.OR. & (Khol.eq.1.OR.(Kpart.eq.0.and.Ktabl.eq.1))))THEN IF(Ixreg.eq.2.AND.(Khol.eq.1.OR.(Kpart.eq.0.and.Ktabl.eq.1))) & THEN WRITE(Mt1,1000) 'irregular regression and X-11 Easter effects' ELSE IF(Ixreg.eq.2)THEN WRITE(Mt1,1000) 'irregular regression effects' ELSE WRITE(Mt1,1000) 'X-11 Easter effects' END IF 1000 FORMAT(' First pass - Estimating ',a) END IF c----------------------------------------------------------------------- c Print column headers c----------------------------------------------------------------------- CALL prtcol(l,0,Tblcol,Tblwid,Ny,Mt1,nopp,tyrly(nopp),Disp2, & Disp3,Fmtcol,Colhdr) c----------------------------------------------------------------------- c Print forecasts c----------------------------------------------------------------------- jyr=begfct(YR) CALL addate(begfct,Ny,nfct-1,idate) DO i=1,PSP1 tmp(i)=DNOTST END DO ib1=Ie+1 ie1=(((ib1-1)/Ny)+1)*Ny IF(ie1.gt.ie2)ie1=ie2 im=ib1-(ib1-1)/Ny*Ny DO WHILE (jyr.le.idate(YR)) im1=im DO i=ib1,ie1 tmp(im)=x(i) im=im+1 END DO im2=im-1 c----------------------------------------------------------------------- c Compute totals or std deviation for this year's observation. c----------------------------------------------------------------------- IF(nopp.eq.2)THEN tmp(l)=totals(tmp,im1,im2,1,0) ELSE IF(nopp.eq.0)THEN tmp(l)=totals(tmp,im1,im2,1,2) ELSE IF(nopp.ne.5)THEN tmp(l)=totals(tmp,im1,im2,1,1) END IF c----------------------------------------------------------------------- c Compute number of blanks for the beginning or end of the series c for observations not in the series. c----------------------------------------------------------------------- nb=0 IF(jyr.eq.begfct(YR).and.begfct(MO).gt.1)nb=begfct(MO) nb2=0 IF(jyr.eq.idate(YR).and.idate(MO).lt.Ny)nb2=idate(MO) c----------------------------------------------------------------------- c Write out this year's data. c----------------------------------------------------------------------- CALL wrttbl(tmp,jyr,'XXXXX',l,ldec,Mt1,tfmt(1:npos),Tblwid, & Tblcol,Disp1,Disp2,Disp3,nb,nb2,ipow,l.eq.sp1) IF(Lfatal)RETURN IF((.not.Lcmpaq) .or. (((mod(jyr,nmod)+1).eq.nmod) .or. & (idate(YR).lt.jyr+1)))WRITE(Mt1,1050) im=1 ib1=ie1+1 ie1=ie1+Ny IF(ie1.gt.ke)ie1=ke DO i=1,PSP1 tmp(i)=DNOTST END DO jyr=jyr+1 END DO c----------------------------------------------------------------------- END IF RETURN END table.prm0000664006604000003110000002056614521201604012004 0ustar sun00315stepscLast change: change irregularoutieradj/se3 to irregularoutlieradj/se3 c----------------------------------------------------------------------- c table name dictionaries and pointers c----------------------------------------------------------------------- c BRKDSP, BRKDS2, BRKDS3 = c table number where break in the table dictionary occurs c this is done to keep the length of the table dictionaries c under 2000 characters, a requirement for the VAX/VMS Fortran c----------------------------------------------------------------------- c TB1DIC, TB2DIC, TB3DIC, TB4DIC = c data dictionaries for X-13ARIMA-SEATS table names and c abbreviations c----------------------------------------------------------------------- INTEGER BRKDSP PARAMETER (BRKDSP=118) c----------------------------------------------------------------------- INTEGER BRKDS2 PARAMETER (BRKDS2=267) c----------------------------------------------------------------------- INTEGER BRKDS3 PARAMETER (BRKDS3=348) c----------------------------------------------------------------------- CHARACTER TB1DIC*1614 INTEGER tb1ptr,PTB1 PARAMETER(PTB1=236) DIMENSION tb1ptr(0:PTB1) c----------------------------------------------------------------------- PARAMETER(TB1DIC='headerhdrspana1seriesplota1pspecfilespcsavefiles &avseriesmvadjmvcalendaradjoriga18outlieradjoriga19adjoriginalb1adj &origplotb1pseriesconstanta1cseriesconstantplotacppriora2permpriora &2ptemppriora2tprioradjusteda3permprioradjusteda3pprioradjustedptda &4dpermprioradjustedptda4ptransformedtrnaictransformtacregressionma &trixrmxaictestatsoutlierotlaoutlieraolevelshiftlstemporarychangetc &seasonaloutliersotradingdaytdholidayholuserdefusrregseasonala10tra &nsitorya13chi2testctsdailyweightstdwacfiacacfplotacppacfipcpacfplo &tpcpregcoefficientsrgcheaderhdrunitroottesturtautochoiceachunitroo &ttestmdlurmautochoicemdlamdbestfivemdlb5mautooutlierhdraohautooutl &ieritraoiautooutliertestsaotautofinaloutliertestsaftautodefaulttes &tsadtautoljungboxtestalbautofinaltestsaftheaderhdrheaderbcsthdbuse &rmodelsumdpickmdlchoicepchoptionsoptiterationsitriterationerrorsit &emodelmdlregcmatrixrcmestimatesestarmacmatrixacmlkstatslkslformula &slkfrootsrtsregressioneffectsrefresidualsrsdregressionresidualsrrs &averagefcsterrafcheaderhdriterationsoittestsotstemporarylstlsfinal &testsftsacfacfacfplotacppacfpcfpacfplotpcpacfsquaredac2acfsquaredp &lotap2histogramhstnormalitytestnrmdurbinwatsondwfriedmantestfrtinv &pacfinptransformedftrvariancesfvrforecastsfcttransformedbcstbtrbac &kcastsbctspecorigsp0specresidualsprspecsasp1specirrsp2specseatssas &1sspecseatsirrs2sspecextresidualsserspecindsais1specindirris2specc &ompositeis0spectukeyorigst0spectukeyresidualstrspectukeysast1spect &ukeyirrst2spectukeyseatssat1sspectukeyseatsirrt2sspectukeyextresid &ualsterspectukeyindsait1spectukeyindirrit2spectukeycompositeit0qsq &sqsindqsitukeypeakstpkqcheckqchnpsanpanpsaindnpi') c----------------------------------------------------------------------- CHARACTER TB2DIC*1983 INTEGER tb2ptr,PTB2 PARAMETER(PTB2=298) DIMENSION tb2ptr(0:PTB2) c----------------------------------------------------------------------- PARAMETER(TB2DIC='adjoriginalcc1adjoriginaldd1modoriginale1mcdmova &vgf1trendb2b2trendc2c2trendd2d2modseasadje2sib3b3modirregulare3rep &lacsib4b4modsic4c4modsid4d4seasonalb5b5seasonalc5c5seasonald5d5ori &gchangese5origchangespctpe5seasadjb6b6seasadjc6c6seasadjd6d6sachan &gese6sachangespctpe6trendb7b7trendc7c7trendd7d7trendchangese7trend &changespctpe7sib8b8unmodsid8unmodsioxd8bcalendaradjchangese8calend &aradjchangespctpe8replacsib9b9replacsic9c9replacsid9seasonalb10b10 &seasonalc10c10seasonald10seasonalpctpsfseasonaldifffsdseasonaladjr &egseaarsseasonalnoshrinksnsseasadjb11b11seasadjc11c11seasadjd11sea &sadjconstsacrobustsae11trendd12trendadjlstalbiasfactorbcftrendcons &ttacirregularbb13irregularcc13irregulard13irregularpctpirirregular &adjaoirairrwtbb17irrwtc17extremebb20extremec20x11easterh1combholid &aychladjustfacd16adjustfacpctpafadjustdifffadcalendard18adjustment &ratioe18totaladjustmenttadtdadjorigbb19tdadjorigc19ftestb1b1fx11di &agf2qstatf3yrtotalse4ftestd8d8fmovseasratd9aresidualseasfrsfautosf &asftdaytypetdyorigwsaplote0ratioplotorigra1ratioplotsara2seasonalp &lotsfpseasadjplotsaptrendplottrpirregularplotirpseasadjfcstsaftren &dfcsttrfirrwtfcstiwfseasadjtotsaasaroundrndrevsachangese6arevsacha &ngespctp6arndsachangese6rrndsachangespctp6rcratiocrrratiorrforcefa &ctorffcpriortda4extremevalbb14extremevalc14x11regbb15x11regc15trad &ingdaybb16tradingdayc16combtradingdaybb18combtradingdayc18holidayb &bxhholidayxhlcalendarbbxccalendarxcacombcalendarbbcccombcalendarxc &coutlierhdrxohoutlieriterxoioutliertestsxotoutlierfinaltestsxftxre &gressionmatrixxrmxregressioncmatrixxrcxaictestxatheaderhdroutlierh &istoryrotsfilterhistorysfhsarevisionssarsasummarysassaestimatessae &chngrevisionschrchngsummarychschngestimatescheindsarevisionsiarind &sasummaryiasindsaestimatesiaetrendrevisionstrrtrendsummarytrstrend &estimatestretrendchngrevisionstcrtrendchngsummarytcstrendchngestim &atestcesfrevisionssfrsfsummarysfssfestimatessfelkhdhistorylkhfcste &rrorsfcefcsthistoryfchseatsmdlhistorysmhseasonalfcthistoryssharmah &istoryamhtdhistorytdh') c----------------------------------------------------------------------- CHARACTER TB3DIC*1243 INTEGER tb3ptr,PTB3 PARAMETER(PTB3=162) DIMENSION tb3ptr(0:PTB3) c----------------------------------------------------------------------- PARAMETER(TB3DIC='headerhdrssftestssffactormeansfmnindfactormeansf &mipercentpctindpercentpciyypercentpcyindyypercentpiysummarysuminds &ummarysmiyysummarysuyindyysummarysiysfspanssfsindsfspanssischngspa &nschsindchngspanscissaspansadsindsaspansaisychngspansycsindychngsp &ansyistdspanstdscompositesrscmsprioradjcompositeia3adjcompositesrs &b1adjcompositeplotb1pcalendaradjcompositecacoutlieradjcompositeoac &headerhdrindtestittindunmodsiid8indreplacsiid9indseasonalisfindsea &sonalpctipsindseasonaldiffisdindseasadjisaindtrenditnindirregulari &irindirregularpctipiindmodoriginalie1indmodsadjie2indmodirrie3orig &changesie5origchangespctip5indsachangesie6indsachangespctip6indrev &sachangesi6aindrevsachangespctipaindrndsachangesi6rindrndsachanges &pctiprindtrendchangesie7indtrendchangespctip7indcalendaradjchanges &ie8indcalendaradjchangespctip8indrobustsaieeindadjustmentratioi18i &ndtotaladjustmentitaindmcdmovavgif1indx11diagif2indqstatif3indyrto &talsie4indftestd8idfindmovseasratimsindresidualseasfirfindadjsatot &iaaindsadjroundirncompositeplotcmporigwindsaplotie0ratioplotorigir &1ratioplotindsair2indseasonalplotispindseasadjplotiapindtrendploti &tpindirregularplotiipindlevelshiftilsindaoutlieriaoindcalendaricai &ndadjustfaciafindadjustfacpctipfindcratiocriindrratiorriindforcefa &ctoriff') c----------------------------------------------------------------------- CHARACTER tb4DIC*797 INTEGER tb4ptr,Ptb4 PARAMETER(Ptb4=96) DIMENSION tb4ptr(0:Ptb4) c----------------------------------------------------------------------- PARAMETER(tb4DIC='trends12trendconststcseasonals10seasonalpctpssir ®ulars13irregularpctpsiseasonaladjs11seasadjconstsectransitorys1 &4transitorypctpscadjustfacs16adjustfacpctpsatrendfcstdecomptfdseas &onalfcstdecompsfdseriesfcstdecompofdseasonaladjfcstdecompafdtransi &toryfcstdecompyfdadjustmentratios18totaladjustmentstawkendfilterwk &fcomponentmodelsmdcpseudoinnovtrendpicpseudoinnovseasonalpispsuedo &innovtransitorypitpsuedoinnovsadjpiasquaredgainsasymgafsquaredgain &saconcgacsquaredgaintrendsymgtfsquaredgaintrendconcgtctimeshiftsac &onctactimeshifttrendconcttcfiltersasymfaffiltersaconcfacfiltertren &dsymftffiltertrendconcftcdifforiginaldordiffseasonaladjdsadifftren &ddtrseasonalsumssmcyclecyclongtermtrendlttseasonalsesseseasonaladj &seasetrendsetsetransitorysecseseasonaladjoutlieradjse2irregularout &lieradjse3trendadjlsstl') table.var0000664006604000003110000001237314521201605011774 0ustar sun00315stepscLast change: change irregularoutieradj/se3 to irregularoutlieradj/se3 c----------------------------------------------------------------------- c tb1ptr, tb2ptr, tb3ptr, tb4ptr - c pointers for the TB2DIC, TB2DIC, TB3DIC, TB4DIC data c dictionaries c----------------------------------------------------------------------- DATA tb1ptr / & 1, 7, 10, 14, 16, 26, 29, 37, 40, 48, & 51, 62, 64, 79, 82, 96, 99, 110, 112, 123, & 126, 140, 143, 161, 164, 169, 171, 180, 183, 192, & 195, 208, 210, 227, 230, 246, 249, 269, 272, 283, & 286, 298, 301, 317, 320, 327, 330, 337, 340, 348, & 350, 360, 362, 377, 379, 394, 396, 406, 408, 415, & 418, 425, 428, 439, 442, 452, 455, 463, 466, 478, & 481, 484, 487, 494, 497, 501, 504, 512, 515, 530, & 533, 539, 542, 554, 557, 567, 570, 585, 588, 601, & 604, 615, 618, 632, 635, 649, 652, 668, 671, 692, & 695, 711, 714, 730, 733, 747, 750, 756, 759, 769, & 772, 782, 785, 798, 801, 808, 811, 821, 824, 839, & 842, 847, 850, 860, 863, 872, 875, 886, 889, 896, & 899, 908, 911, 916, 919, 936, 939, 948, 951, 970, & 973, 987, 990, 996, 999,1009,1012,1017,1020,1031, & 1034,1044,1047,1050,1053,1060,1063,1067,1070,1078, & 1081,1091,1094,1108,1111,1120,1123,1136,1139,1151, & 1153,1165,1168,1175,1178,1189,1192,1201,1204,1213, & 1216,1231,1234,1243,1246,1254,1257,1269,1272,1278, & 1281,1288,1291,1302,1305,1317,1320,1336,1339,1348, & 1351,1361,1364,1377,1380,1393,1396,1413,1416,1427, & 1430,1442,1445,1461,1464,1481,1484,1505,1508,1522, & 1525,1540,1543,1561,1564,1566,1568,1573,1576,1586, & 1589,1595,1598,1602,1605,1612,1615 / c----------------------------------------------------------------------- DATA tb2ptr / & 1, 13, 15, 27, 29, 40, 42, 51, 53, 60, & 62, 69, 71, 78, 80, 90, 92, 96, 98, 110, & 112, 122, 124, 131, 133, 140, 142, 152, 154, 164, & 166, 176, 178, 189, 191, 205, 208, 217, 219, 228, & 230, 239, 241, 250, 252, 264, 267, 274, 276, 283, & 285, 292, 294, 306, 308, 323, 326, 330, 332, 339, & 341, 350, 353, 371, 373, 394, 397, 407, 409, 419, & 421, 429, 431, 442, 445, 456, 459, 467, 470, 481, & 484, 496, 499, 516, 519, 535, 538, 548, 551, 561, & 564, 571, 574, 586, 589, 597, 600, 605, 608, 618, & 621, 631, 634, 644, 647, 657, 660, 670, 673, 682, & 685, 697, 700, 714, 717, 723, 726, 731, 734, 742, & 745, 752, 755, 764, 766, 777, 780, 789, 792, 804, & 807, 817, 820, 828, 831, 846, 849, 864, 867, 877, & 880, 889, 892, 899, 902, 909, 911, 916, 918, 926, & 928, 935, 938, 948, 951, 964, 967, 973, 976, 984, & 987, 998,1000,1013,1016,1027,1030,1042,1045,1056, & 1059,1068,1071,1084,1087,1098,1101,1110,1113,1122, & 1125,1135,1138,1145,1148,1160,1163,1178,1181,1193, & 1196,1211,1214,1220,1222,1228,1230,1241,1244,1251, & 1253,1264,1267,1277,1280,1287,1290,1296,1299,1310, & 1313,1323,1326,1341,1344,1358,1361,1369,1372,1379, & 1382,1391,1394,1402,1405,1418,1421,1433,1436,1446, & 1449,1460,1463,1475,1478,1495,1498,1515,1518,1536, & 1539,1547,1550,1556,1559,1573,1576,1590,1593,1604, & 1607,1616,1619,1630,1633,1646,1649,1660,1663,1676, & 1679,1693,1696,1708,1711,1725,1728,1742,1745,1757, & 1760,1774,1777,1795,1798,1814,1817,1835,1838,1849, & 1852,1861,1864,1875,1878,1889,1892,1902,1905,1916, & 1919,1934,1937,1955,1958,1969,1972,1981,1984 / c----------------------------------------------------------------------- DATA tb3ptr / & 1, 7, 10, 17, 20, 31, 34, 48, 51, 58, & 61, 71, 74, 83, 86, 98, 101, 108, 111, 121, & 124, 133, 136, 148, 151, 158, 161, 171, 174, 183, & 186, 198, 201, 208, 211, 221, 224, 234, 237, 250, & 253, 260, 263, 275, 278, 295, 298, 313, 315, 331, & 334, 354, 357, 376, 379, 385, 388, 395, 398, 408, & 411, 422, 425, 436, 439, 453, 456, 471, 474, 484, & 487, 495, 498, 510, 513, 528, 531, 545, 548, 558, & 561, 570, 573, 584, 587, 601, 604, 616, 619, 634, & 637, 652, 655, 673, 676, 691, 694, 712, 715, 730, & 733, 751, 754, 775, 778, 802, 805, 816, 819, 837, & 840, 858, 861, 873, 876, 886, 889, 897, 900, 911, & 914, 924, 927, 940, 943, 959, 962, 973, 976, 988, & 991,1004,1007,1021,1024,1037,1040,1054,1057,1072, & 1075,1089,1092,1104,1107,1123,1126,1139,1142,1153, & 1156,1167,1170,1182,1185,1200,1203,1212,1215,1224, & 1227,1241,1244 / c----------------------------------------------------------------------- DATA tb4ptr / & 1, 6, 9, 19, 22, 30, 33, 44, 47, 56, & 59, 71, 74, 85, 88, 100, 103, 113, 116, 129, & 132, 141, 144, 156, 159, 174, 177, 195, 198, 214, & 217, 238, 241, 261, 264, 279, 282, 297, 300, 311, & 314, 329, 332, 348, 351, 370, 373, 394, 397, 412, & 415, 431, 434, 451, 454, 473, 476, 496, 499, 514, & 517, 535, 538, 549, 552, 564, 567, 581, 584, 599, & 602, 614, 617, 632, 635, 644, 647, 658, 661, 666, & 669, 682, 685, 695, 698, 711, 714, 721, 724, 736, & 739, 760, 763, 782, 785, 795, 798 / taper.f0000664006604000003110000000160314521201605011447 0ustar sun00315steps**==taper.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 SUBROUTINE taper(X,L1,L2,R) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION R,r1,r2,tap,X,xpi,xtap INTEGER i,l,L1,L2 C*** End of declarations inserted by SPAG DIMENSION X(*) DOUBLE PRECISION PI,ONE,TWO PARAMETER(PI=3.14159265358979D0,ONE=1D0,TWO=2D0) C *** C *** THIS SUBROUTINE APPLIES THE TUKEY-HANNING TAPER TO A SERIES C *** PRIOR TO CALCULATING THE SPECTRUM. C *** l=L2-L1+1 r1=R/2 r2=1-r1 DO i=L1,L2 xtap=(dble(i-L1)+0.5D0)/(dble(l)) IF(xtap.ge.r1.and.xtap.le.r2)THEN tap=ONE ELSE IF(xtap.lt.r1)xpi=(TWO*PI*xtap)/R IF(xtap.gt.r2)xpi=(TWO*PI*(1-xtap))/R tap=(ONE-cos(xpi))/TWO END IF X(i)=X(i)*tap END DO RETURN END tbl5x.i0000664006604000003110000000300514521201605011373 0ustar sun00315stepsC C Growth Rate table 5.x common block C c----------------------------------------------------------------------- c Name Type Description (Growth Rate common block Variables) c----------------------------------------------------------------------- c nSeaGRSE1 i size (rows,columns) of vSeaGRSE1 vector c nSeaGRSE2 i size (rows,columns) of vSeaGRSE2 vector c nTreGRSE1 i size (rows,columns) of vTreGRSE1 vector c nTreGRSE2 i size (rows,columns) of vTreGRSE2 vector c vSeaGRSE1 d vector of seasonal component growth rate SEs for table 5.2 c vSeaGRSE2 d vector of seasonal component growth rate SEs for table 5.5 c vTbl51 d vector of table 5.1 MSEs c vTbl53 d vector of table 5.3 SEs c vTbl54 d vector of table 5.4 MSEs c vTbl56 d vector of table 5.6 SEs c vTbl57 d vector of table 5.7 SEs c vTreGRSE1 d vector of trend component growth rate SEs for table 5.2 c vTreGRSE2 d vector of trend component growth rate SEs for table 5.5 c----------------------------------------------------------------------- INTEGER nSeaGRSE1(2), nSeaGRSE2(2), nTreGRSE1(2), nTreGRSE2(2) DOUBLE PRECISION vSeaGRSE1(POBS), vTreGRSE1(POBS) DOUBLE PRECISION vSeaGRSE2(POBS), vTreGRSE2(POBS) DOUBLE PRECISION vTbl51(6), vTbl53(2), vTbl54(6), vTbl56(6,2), & vTbl57(3,3) common / tbl5x / vTbl51, vSeaGRSE1, nSeaGRSE1, & vTreGRSE1, nTreGRSE1, vTbl53, vTbl54, & vSeaGRSE2, nSeaGRSE2, & vTreGRSE2, nTreGRSE2, vTbl56, vTbl57tblhdr.f0000664006604000003110000002204114521201606011613 0ustar sun00315stepsC Last change: BCM 6 May 2003 1:33 pm SUBROUTINE tblhdr(Ktabl,Itype,Ixreg,Nobs,Begtbl,Nny,Y,Tbltit) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine produces a header for the tabular output produced c by the suboutine TABLE. c----------------------------------------------------------------------- c Kpart is the iteration of the table c Ktabl is the table number c Nobs is the number of observations c Begtbl is the beginning date c Lyr is year of first observation c Nny is seasonal frequency (12 for monthly, 4 for quarterly) C Y is an additional array to be printed on table. c Tbltit is the title for the table c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'error.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'priusr.cmn' c INCLUDE 'prior.cmn' INCLUDE 'extend.cmn' INCLUDE 'title.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'force.cmn' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- LOGICAL lsdiff,subhdr,lpttl DOUBLE PRECISION Y INTEGER Ktabl,Begtbl,Nobs,Nny,i,Itype,Ixreg,nttl,n,m CHARACTER Tbltit*(*),avgs*(8),ttl2*(80) DIMENSION Begtbl(2),Y(*),avgs(7) c----------------------------------------------------------------------- INTEGER nblank LOGICAL dpeq EXTERNAL nblank,dpeq c----------------------------------------------------------------------- DATA avgs/'Default ','3 x 3 ','3 x 5 ','3 x 9 ','3 x 15 ', & 'Stable ','3 x 1 '/ c----------------------------------------------------------------------- c Call header routine to print title and date information c----------------------------------------------------------------------- lpttl=T IF(Kpart.eq.1.and.Ktabl.eq.2.and.Itype.gt.1)THEN IF(.not.Lcmpaq)THEN IF(Itype.eq.2)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Tmpser(1:Ntser) ELSE IF(Itype.eq.3)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Prmser(1:Npser) END IF END IF Kpage=Kpage+1 lpttl=F END IF c----------------------------------------------------------------------- c Generate subtitles for selected tables. c----------------------------------------------------------------------- CALL mkshdr(ttl2,nttl,Ktabl,Itype,subhdr) IF(subhdr)THEN CALL prshd2(Tbltit,ttl2(1:nttl),Begtbl,Nny,Nobs,lpttl) ELSE CALL prtshd(Tbltit,Begtbl,Nny,Nobs,lpttl) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print additional information for specific tables c----------------------------------------------------------------------- IF((.not.(Kpart.eq.1.and.Ktabl.eq.1)).AND.(Ixreg.eq.2.OR. & (Khol.eq.1.OR.(Kpart.eq.0.and.Ktabl.eq.1))))THEN IF(Ixreg.eq.2.AND.(Khol.eq.1.OR.(Kpart.eq.0.and.Ktabl.eq.1)))THEN WRITE(Mt1,1000) 'irregular regression and X-11 Easter effects' ELSE IF(Ixreg.eq.2)THEN WRITE(Mt1,1000) 'irregular regression effects' ELSE WRITE(Mt1,1000) 'X-11 Easter effects' END IF 1000 FORMAT(' First pass - Estimating ',a) END IF c----------------------------------------------------------------------- IF(Kpart.eq.1.and.Ktabl.eq.4)THEN IF(.not.dpeq(Y(1),DNOTST))WRITE(Mt1,1010)(Y(i),i=1,7) 1010 FORMAT(' Prior daily weights Mon Tue Wed ', & 'Thur Fri Sat Sun',/,19X,7F8.3) ELSE IF(Kpart.eq.3.and.Ktabl.eq.16)THEN IF(.not.dpeq(Y(1),DNOTST))WRITE(Mt1,1020)(Y(i),i=1,7) 1020 FORMAT(' Daily weights Mon Tue Wed Thur ', & 'Fri Sat Sun',/,13X,7F8.3) ELSE IF(Kpart.eq.3.and.Ktabl.eq.18)THEN IF(.not.dpeq(Y(1),DNOTST))WRITE(Mt1,1030)(Y(i),i=1,7) 1030 FORMAT(' Combined daily weights Mon Tue Wed ', & 'Thur Fri Sat Sun',/,22X,7F8.3) c----------------------------------------------------------------------- ELSE IF((Kpart.ge.2.and.Kpart.le.4).and.Ktabl.eq.2)THEN c nyy=(Iwt+1)*Nny c WRITE(Mt1,1040)nyy WRITE(Mt1,1040)Nny 1040 FORMAT(' Trend filter Centered ',i3,'-term moving average') ELSE IF((Kpart.ge.2.and.Kpart.le.4).and. & (Ktabl.eq.7.or.Ktabl.eq.12))THEN WRITE(Mt1,1050)Nterm,Ratic 1050 FORMAT(' Trend filter ',i3,'-term Henderson moving average',/, & ' I/C ratio ',F6.2) c ELSE IF(Kpart.eq.5.and.Ktabl.eq.12)THEN c WRITE(Mt1,1060)Adjtrn c 1060 FORMAT(' Trend filter ',i3,'-term Henderson moving average') c----------------------------------------------------------------------- ELSE IF((Ktabl.eq.5.and.(Kpart.eq.2.or.Kpart.eq.3.or.Kpart.eq.4)) & .or.(Ktabl.eq.10.and.(Kpart.eq.2.or.Kpart.eq.3.or. & (Kpart.eq.4.and.Itype.eq.1))))THEN lsdiff=.false. DO i=2,Nny IF(Lter(i).ne.0.and.Lter(i).ne.Lterm)lsdiff=.true. END DO IF(lsdiff)THEN WRITE(Mt1,1070)Moqu(1:nblank(Moqu)) 1070 FORMAT(' Seasonal filter Different moving averages used ', & 'for each ',a) ELSE WRITE(Mt1,1080)avgs(Mtype)(1:nblank(avgs(Mtype))) 1080 FORMAT(' Seasonal filter ',a,' moving average') END IF IF(Kpart.eq.4.and.Ishrnk.gt.0)THEN IF(Ishrnk.eq.1)THEN WRITE(Mt1,1081)'Global' ELSE IF(Ishrnk.eq.2)THEN WRITE(Mt1,1081)'Local' END IF 1081 FORMAT(' ',a,' shrinkage technique applied to seasonal.') END IF c----------------------------------------------------------------------- ELSE IF((Kpart.eq.2.and.Ktabl.eq.1).and.Nbcst.gt.0)THEN WRITE(Mt1,1090)Nbcst 1090 FORMAT(' Includes ',i2,' backcasts.') c----------------------------------------------------------------------- ELSE IF((Kpart.eq.2.or.Kpart.eq.3).and.Ktabl.eq.14)THEN WRITE(Mt1,1091)Sigxrg 1091 FORMAT(' Irregular component regression sigma limit ',f5.2) c----------------------------------------------------------------------- ELSE IF((Kpart.eq.2.or.Kpart.eq.3).and.Ktabl.eq.17)THEN WRITE(Mt1,1100)Sigml,Sigmu 1100 FORMAT(' Lower sigma limit ',f5.2,/,' Upper sigma limit ', & f5.2) ELSE IF(Kpart.eq.5.and.(Ktabl.ge.1.and.Ktabl.le.3))THEN IF(Adjao.eq.1.and.Adjtc.eq.1)THEN WRITE(Mt1,1120)'AO & TC' ELSE IF(Adjao.eq.1)THEN WRITE(Mt1,1120)'AO' ELSE IF(Adjtc.eq.1)THEN WRITE(Mt1,1120)'TC' END IF 1120 FORMAT(' ',a,' outliers removed') c----------------------------------------------------------------------- ELSE IF((Kpart.eq.4.or.Kpart.eq.-1).and.Ktabl.eq.11)THEN IF(Itype.eq.2)THEN IF(Iyrt.eq.1)THEN WRITE(Mt1,1130) 1130 FORMAT(' Denton method used.') ELSE IF(Iyrt.eq.2)THEN WRITE(Mt1,1131)Lamda,Rol 1131 FORMAT(' Regression method used, with lambda = ',f10.7, & ', rho = ',f10.7,'.') END IF END IF IF(Nustad.gt.0)THEN WRITE(Mt1,1132) 1132 FORMAT(' Temporary prior adjustments included.') END IF c----------------------------------------------------------------------- ELSE IF(Kpart.eq.7)THEN IF(Rvper)THEN WRITE(Mt1,1150) 1150 FORMAT(' Type of revision: Percent') ELSE WRITE(Mt1,1160) 1160 FORMAT(' Type of revision: Difference') END IF IF(Ktabl.eq.1.and.(Lrndsa.or.Iyrt.gt.0))THEN IF(Lrndsa.and.Iyrt.gt.0)THEN WRITE(Mt1,1140)'Rounded s','with revised yearly totals u' ELSE IF(Lrndsa)THEN WRITE(Mt1,1140)'Rounded s','u' ELSE IF(Iyrt.gt.0)THEN WRITE(Mt1,1140)'s','with revised yearly totals u' END IF c----------------------------------------------------------------------- ELSE IF(Ktabl.eq.9.and.(Lrndsa.or.Iyrt.gt.0))THEN IF(Lrndsa.and.Iyrt.gt.0)THEN WRITE(Mt1,1140)'Rounded indirect s', & 'with revised yearly totals u' ELSE IF(Lrndsa)THEN WRITE(Mt1,1140)'Rounded indirect s','u' ELSE IF(Iyrt.gt.0)THEN WRITE(Mt1,1140)'Indirect s','with revised yearly totals u' END IF END IF ELSE IF(Kpart.eq.6.and.Ktabl.eq.1)THEN n=Mcd IF(n.gt.6)n=6 m=2-n+n/2*2 WRITE(Mt1,1180)n,m 1180 FORMAT(' MCD filter ',i1,' x ',i1,' moving average') END IF 1140 FORMAT(' ',a,'easonally adjusted series ',a, & 'sed in this analysis.') c----------------------------------------------------------------------- RETURN END tbllbl.prm0000664006604000003110000000330714521201606012164 0ustar sun00315stepsc----------------------------------------------------------------------- c data dictionary for descriptions of series and output dealing with c 0. See tbllbl.var for pointers. c----------------------------------------------------------------------- CHARACTER LBLDIC*1120 INTEGER lblptr,PLBL PARAMETER(PLBL=396) DIMENSION lblptr(0:PLBL) c----------------------------------------------------------------------- PARAMETER(LBLDIC='A 1A 1.GMV 1A 18A 19B 1B 1.GA 1.CA 1C.GA 2A 2.PA & 2.TA 3A 3.PA 4.DA 4.PA 8A 8.AOA 8.LSA 8.TCA 8.SOA 6A 7A 9A 10A 13 &C 1D 1E 1F 1B 2C 2D 2E 2B 3E 3B 4C 4D 4B 5C 5D 5E 5E 5B 6C 6D 6E 6 &E 6B 7C 7D 7E 7E 7B 8D 8D 8.BE 8E 8B 9C 9D 9B 10C 10D 10D 10D 10.D &D 10.BD 10.SB 11C 11D 11D 11.CE 11D 12D 12D 12.BD 12.CB 13C 13D 13 &D 13D 13.BB 17C 17B 20C 20H 1A 16D 16D 16D 16.BD 18E 18E 18.BB 19C & 19F 2F 3E 4D 8.AD 9.AE 0.GG.3G.4D 10.GD 11.GD 12.GD 13.GD 11.FD 1 &2.FC 17.FD 11.AD 11.RE 6.AE 6.AE 6.RE 6.RD 11.CRD 11.RRD 11.FA 4B &14C 14B 15C 15B 16C 16B 18C 18B 16HC 16HB 16CC 16CB 18CC 18CR OTLR &R MSRR 1R 1.SR 1.AR 2R 2.SR 2.AR 3R 3.SR 3.AR 4R 4.SR 4.AR 5R 5.SR & 5.AR 6R 6.SR 6.AR 7R 8R 8.AR 9R 9.AR 9.BS 7.AS 7.AIS 7.DS 7.DIS 7 &.CS 7.CIS 7.ES 7.EIS 7.BA 1A 3B 1B 1.GA 18A 19D 8D 9D 10D 10D 10.B &D 11D 12D 13D 13E 1E 2E 3E 5E 5E 6E 6E 6.AE 6.AE 6.RE 6.RE 7E 7E 8 &E 8E 11E 18E 18.BF 1F 2F 3E 4D 8.AD 9.AD 11.AD 11.RA 1.GE 0.GG.3G. &4D 10.GD 11.GD 12.GD 13.GA 8.ILSA 8.IAOD 18D 16D 16D 11.CRD 11.RRD & 11.FS 12S 12.CS 10S 10S 13S 13S 11S 11.CS 14S 14S 16S 16S 15.BS 1 &5.DS 15.AS 15.CS 15.ES 18S 18.BS 1S 11.ES 12.ES 10.BS 14.CS 14.LTT &S 11.OS 13.OS 12') tbllbl.var0000664006604000003110000000511014521201606012150 0ustar sun00315stepsc----------------------------------------------------------------------- c pointers for descriptions of series and output dealing with c 0. See tbllbl.prm for data dictionaries. c----------------------------------------------------------------------- DATA lblptr / & 1, 1, 4, 9, 9, 9, 13, 17, 21, 24, & 29, 34, 40, 43, 48, 53, 56, 61, 66, 71, & 71, 71, 71, 71, 74, 80, 86, 92, 98, 101, & 104, 107, 111, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, & 115, 115, 115, 115, 115, 115, 115, 115, 115, 118, & 121, 124, 127, 130, 133, 136, 139, 142, 145, 148, & 151, 154, 157, 160, 163, 166, 169, 172, 175, 178, & 181, 184, 187, 190, 193, 196, 199, 202, 205, 210, & 213, 216, 219, 222, 225, 229, 233, 237, 241, 247, & 253, 259, 263, 267, 271, 277, 281, 285, 289, 295, & 301, 305, 309, 313, 317, 323, 327, 331, 335, 339, & 342, 346, 350, 354, 360, 364, 368, 374, 378, 382, & 382, 385, 388, 391, 396, 401, 401, 401, 401, 406, & 409, 412, 418, 424, 430, 436, 442, 448, 454, 460, & 466, 471, 476, 481, 486, 493, 500, 506, 509, 513, & 517, 521, 525, 529, 533, 537, 541, 546, 551, 556, & 561, 566, 571, 571, 571, 571, 571, 571, 571, 571, & 571, 577, 582, 585, 590, 595, 598, 603, 608, 611, & 616, 621, 624, 629, 634, 637, 642, 647, 650, 655, & 660, 663, 666, 671, 674, 674, 679, 684, 684, 684, & 684, 684, 684, 684, 684, 684, 684, 684, 684, 684, & 689, 695, 700, 706, 711, 717, 722, 728, 733, 736, & 739, 742, 747, 751, 755, 755, 755, 758, 761, 765, & 769, 775, 779, 783, 787, 791, 794, 797, 800, 803, & 806, 809, 812, 817, 822, 827, 832, 835, 838, 841, & 844, 848, 852, 858, 861, 864, 867, 870, 875, 880, & 880, 886, 892, 897, 902, 905, 908, 914, 920, 926, & 932, 939, 946, 950, 954, 958, 965, 972, 978, 982, & 988, 992, 996,1000,1004,1008,1014,1018,1022,1026, & 1030,1036,1042,1048,1054,1060,1064,1070,1070,1070, & 1070,1070,1070,1070,1070,1070,1070,1070,1070,1070, & 1070,1070,1070,1070,1073,1079,1085,1091,1097,1105, & 1105,1105,1105,1105,1111,1117,1121 / tbllog.cmn0000664006604000003110000000114314521201607012150 0ustar sun00315stepsc----------------------------------------------------------------------- c Prttab - Logical vector indicating which series are to be printed c Savtab - Logical vector indicating which series are to be saved c Savfct - Logical scalar indicating if forecasts should be stored c with selected series c----------------------------------------------------------------------- LOGICAL Prttab,Savtab,Savfct,Savbct DIMENSION Prttab(NTBL),Savtab(NTBL) c----------------------------------------------------------------------- COMMON /ctbllg/Prttab,Savtab,Savfct,Savbct tbllog.i0000664006604000003110000000377014521201607011633 0ustar sun00315stepsc----------------------------------------------------------------------- c Variables with LSP are the displacements for the tables c found in each spec, NSP are the number of tables used in each c spec. The spec's that have print and save tables are c c series SRS c transform TRN c regression REG c identify IDN c automdl AUM c pickmdl AXM c estimate EST c outlier OTL c check CHK c forecast FOR c spectrum SPC c x11 X11 c force FRC c x11regression XRG c history REV c slidingspans SSP c composite CMP c seats SET c----------------------------------------------------------------------- INTEGER LSPSRS,NSPSRS INTEGER LSPTRN,NSPTRN INTEGER LSPREG,NSPREG INTEGER LSPIDN,NSPIDN INTEGER LSPAUM,NSPAUM INTEGER LSPAXM,NSPAXM INTEGER LSPEST,NSPEST INTEGER LSPOTL,NSPOTL INTEGER LSPCHK,NSPCHK INTEGER LSPFOR,NSPFOR INTEGER LSPSPC,NSPSPC INTEGER LSPX11,NSPX11 INTEGER LSPFRC,NSPFRC INTEGER LSPXRG,NSPXRG INTEGER LSPREV,NSPREV INTEGER LSPSSP,NSPSSP INTEGER LSPCMP,NSPCMP INTEGER LSPSET,NSPSET c----------------------------------------------------------------------- PARAMETER (LSPSRS=0,NSPSRS=10, & LSPTRN=10,NSPTRN=11, & LSPREG=21,NSPREG=14, & LSPIDN=35,NSPIDN=5, & LSPAUM=40,NSPAUM=13, & LSPAXM=53,NSPAXM=4, & LSPEST=57,NSPEST=14, & LSPOTL=71,NSPOTL=5, & LSPCHK=76,NSPCHK=11, & LSPFOR=87,NSPFOR=5, & LSPSPC=92,NSPSPC=26, & LSPX11=118,NSPX11=90, & LSPFRC=208,NSPFRC=9, & LSPXRG=217,NSPXRG=22, & LSPREV=239,NSPREV=28, & LSPSSP=267,NSPSSP=21, & LSPCMP=288,NSPCMP=60, & LSPSET=348,NSPSET=48) tbllog.prm0000664006604000003110000000115114521201607012170 0ustar sun00315stepsc----------------------------------------------------------------------- c Note NTBL (the number of tables) is half PTBL because each table c has a long and short name. In the table dictionaries the short name c is written after each long name so the 2i-1 and 2i entries relate to c table i. c----------------------------------------------------------------------- c Note: Look in filext.var to find the extension names of the files c that are saved. The variable is tbxdic. c----------------------------------------------------------------------- INTEGER NTBL PARAMETER(NTBL=396) tbltitle.prm0000664006604000003110000000242414521201607012534 0ustar sun00315stepsc----------------------------------------------------------------------- c Parameters for table title data dictionaries c----------------------------------------------------------------------- INTEGER PDSR,PDSM,PDSP,PDSX,PDSS,PDSA,PDSI,PDSD,PDD2,PDSC,PDC2, & PDSE,PDS2,PTTLEN PARAMETER(PDSR=21,PDSM=71,PDSP=26,PDSX=28,PDSS=33,PDSA=38, & PDSI=22,PDSD=28,PDD2=21,PDSC=35,PDC2=25,PDSE=44, & PDS2=4,PTTLEN=150) INTEGER PDSUM1,PDSUM2,PDSUM3,PDSUM4,PDSUM5,PDSUM6,PDSUM7,PDSUM8, & PDSUM9,PDSUM10,PDSUM11 PARAMETER(PDSUM1=PDSR+PDSM,PDSUM2=PDSR+PDSM+PDSP, & PDSUM3=PDSR+PDSM+PDSP+PDSX, & PDSUM4=PDSR+PDSM+PDSP+PDSX+PDSS, & PDSUM5=PDSR+PDSM+PDSP+PDSX+PDSS+PDSA, & PDSUM6=PDSR+PDSM+PDSP+PDSX+PDSS+PDSA+PDSI, & PDSUM7=PDSR+PDSM+PDSP+PDSX+PDSS+PDSA+PDSI+PDSD, & PDSUM8=PDSR+PDSM+PDSP+PDSX+PDSS+PDSA+PDSI+PDSD+PDD2, & PDSUM9=PDSR+PDSM+PDSP+PDSX+PDSS+PDSA+PDSI+PDSD+PDD2+ & PDSC, & PDSUM10=PDSR+PDSM+PDSP+PDSX+PDSS+PDSA+PDSI+PDSD+PDD2+ & PDSC+PDC2, & PDSUM11=PDSR+PDSM+PDSP+PDSX+PDSS+PDSA+PDSI+PDSD+PDD2+ & PDSC+PDC2+PDSE) td6var.f0000664006604000003110000002022214521201607011542 0ustar sun00315stepsC Last change: BCM 27 May 1998 3:34 pm SUBROUTINE td6var(Begdat,Isp,Numrxy,Numcxy,Begcol,Endcol,Smpday, & Xy,Begrgm,Td1c) IMPLICIT NONE c----------------------------------------------------------------------- c td6var.f, Release 1, Subroutine Version 1.3, Modified 20 Oct 1994. c----------------------------------------------------------------------- c Inserts the first six trading day variables into the regression c matrix Xy c----------------------------------------------------------------------- c Arguments used with this program: c----------------------------------------------------------------------- c Begdat - Integer array of length 2 - beginning date of regression c matrix Xy c Begdat(1) = year (4 decimals assumed, ie, 1994) c Begdat(2) = period c Isp - Integer scalar - length of seasonal period c (12 for monthly, 4 for quarterly) c Numrxy - Integer scalar - # of rows in Xy matrix c Numcxy - Integer scalar - # of colums in Xy matrix c Begcol - Integer scalar - column of Xy matrix to place first c trading day variable c Smpday - Integer scalar - sample day for stock trading day c variables c Xy - Double precision matrix of dimension Numrxy, Numcxy - c regression matrix where trading day variables will be stored c Begrgm - logical vector that shows where a regressor is defined c when a change of regime has occurred. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL F,T DOUBLE PRECISION ZERO PARAMETER(F=.false.,T=.true.,ZERO=0D0) c ------------------------------------------------------------------ LOGICAL Begrgm,Td1c INTEGER Begcol,Begdat,idate,irow,Numcxy,Numrxy,precol,predat, & Endcol DOUBLE PRECISION Xy DIMENSION Begdat(2),idate(2),predat(2),Xy(Numcxy,Numrxy), & Begrgm(PLEN) c ------------------------------------------------------------------ CHARACTER str*(PCOLCR) LOGICAL ltdstk INTEGER Isp,period,Smpday,year INTEGER cendsp,sdoyr,fouryr(0:3) INTEGER lpyr INTEGER lnomo(12,2),ndomo INTEGER fdomo(12,2),sdomo INTEGER i,iday,icol,nchr INTEGER td(0:6) INTEGER ndywkm(0:6,28:31) INTEGER lnoqtr(4,2),ndoqtr INTEGER fdoqtr(4,2),sdoqtr INTEGER ndywkq(0:6,90:92) INTEGER dyosmp c ------------------------------------------------------------------ c stckwt - weights for I*(t) to create one-coefficient stock trading c day (BCM July 2007) c ------------------------------------------------------------------ DOUBLE PRECISION stckwt(4) c ------------------------------------------------------------------ INTEGER strinx EXTERNAL strinx c ------------------------------------------------------------------ CHARACTER DAYDIC*18 INTEGER dayptr,PDAY PARAMETER(PDAY=6) DIMENSION dayptr(0:PDAY) PARAMETER(DAYDIC='montuewedthufrisat') c ------------------------------------------------------------------ DATA fouryr/0,2,3,4/ DATA lnomo/31,28,31,30,31,30,31,31,30,31,30,31, & 31,29,31,30,31,30,31,31,30,31,30,31/ DATA fdomo/0,3,3,6,1,4,6,2,5,0,3,5, & 0,3,4,0,2,5,0,3,6,1,4,6/ DATA ndywkm/4,4,4,4,4,4,4, & 5,4,4,4,4,4,4, & 5,5,4,4,4,4,4, & 5,5,5,4,4,4,4/ DATA lnoqtr/90,91,92,92, & 91,91,92,92/ DATA fdoqtr/0,6,6,0, & 0,0,0,1/ DATA ndywkq/13,13,13,13,13,13,12, & 13,13,13,13,13,13,13, & 14,13,13,13,13,13,13/ DATA dayptr/1,4,7,10,13,16,19/ c ------------------------------------------------------------------ c stckwt - weights for I*(t) to create one-coefficient stock trading c day (BCM July 2007) c ------------------------------------------------------------------ DATA stckwt/-0.6D0,-0.2D0,0.2D0,0.6D0/ c ------------------------------------------------------------------ ltdstk=F IF(Smpday.gt.0)ltdstk=T c ------------------------------------------------------------------ CALL addate(Begdat,Isp,-1,predat) precol=Begcol-1 c ------------------------------------------------------------------ DO irow=1,Numrxy IF(Begrgm(irow))THEN CALL addate(predat,Isp,irow,idate) year=idate(YR) period=idate(MO) c----------------------------------------------------------------------- c The calendar as we know it begins in October 1752. If we define c Sun=0, Mon=1, ..., Sat=6, then we would like to start our pattern c on the first leap year that start on a Sunday after 1753. This is c 1764. c----------------------------------------------------------------------- sdoyr=5*(year/4-441)+fouryr(mod(year,4)) cendsp=(year-1601)/100 cendsp=cendsp-cendsp/4-1 sdoyr=sdoyr-cendsp sdoyr=mod(sdoyr,7) c ------------------------------------------------------------------ IF((mod(year,100).ne.0.and.mod(year,4).eq.0).or.mod(year,400) & .eq.0)THEN lpyr=2 ELSE lpyr=1 END IF c ------------------------------------------------------------------- IF(Isp.eq.12)THEN sdomo=mod(sdoyr+fdomo(period,lpyr),7) ndomo=lnomo(period,lpyr) c ------------------------------------------------------------------ IF(ltdstk)THEN IF(Smpday.gt.ndomo)THEN dyosmp=mod(sdomo+ndomo-1,7) c ------------------------------------------------------------------ ELSE dyosmp=mod(sdomo+Smpday-1,7) END IF c ------------------------------------------------------------------ DO iday=0,6 td(iday)=0 END DO td(dyosmp)=1 c ------------------------------------------------------------------ ELSE DO i=0,6 iday=mod(i+sdomo,7) td(iday)=ndywkm(i,ndomo) END DO END IF c ------------------------------------------------------------------ ELSE IF(Isp.eq.4)THEN sdoqtr=mod(sdoyr+fdoqtr(period,lpyr),7) ndoqtr=lnoqtr(period,lpyr) c ------------------------------------------------------------------ DO i=0,6 iday=mod(i+sdoqtr,7) td(iday)=ndywkq(i,ndoqtr) END DO END IF c ------------------------------------------------------------------ IF(Td1c)THEN c ------------------------------------------------------------------ c generate stock 1-coef trading day regressor (BCM July 2007) c ------------------------------------------------------------------ IF(ltdstk)THEN Xy(Begcol,irow)=DBLE(td(5)-td(0)) DO iday=1,4 Xy(Begcol,irow)=(stckwt(iday)*DBLE(td(iday)-td(0)))+ & Xy(Begcol,irow) END DO ELSE Xy(Begcol,irow)=ZERO-(DBLE(td(0)+td(6))*2.5D0) DO iday=1,5 Xy(Begcol,irow)=Xy(Begcol,irow)+DBLE(td(iday)) END DO END IF ELSE DO icol=Begcol,Endcol IF((Endcol-Begcol+1).lt.6)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN iday=strinx(F,DAYDIC,dayptr,1,PDAY,str(1:3)) ELSE iday=icol-Begcol+1 END IF td(iday)=td(iday)-td(0) Xy(icol,irow)=dble(td(iday)) END DO END IF ELSE DO iday=1,Endcol-Begcol+1 Xy(precol+iday,irow)=ZERO END DO END IF END DO c ------------------------------------------------------------------ RETURN END td7var.f0000664006604000003110000001467714521201607011564 0ustar sun00315stepsC Last change: BCM 30 Jun 1998 2:59 pm SUBROUTINE td7var(Begdat,Isp,Nrxy,Ncxy,Begcol,Lom,Ltdstk,Mltadd, & Xy,Begrgm) IMPLICIT NONE c----------------------------------------------------------------------- c td7var.f, Release 1, Subroutine Version 1.2, Modified 03 Oct 1994. c----------------------------------------------------------------------- c Adds a seventh trading day variable to the regression matrix Xy c----------------------------------------------------------------------- c Arguments used with this program: c----------------------------------------------------------------------- c Begdat - Integer array of length 2 - beginning date of regression c matrix Xy c Begdat(1) = year (4 decimals assumed, ie, 1994) c Begdat(2) = period c Isp - Integer scalar - length of seasonal period c (12 for monthly, 4 for quarterly) c Nrxy - Integer scalar - # of rows in Xy matrix c Ncxy - Integer scalar - # of colums in Xy matrix c Begcol - Integer scalar - column of Xy matrix to place first c trading day variable c Lom - Logical scalar - True if seventh variable is a length-of- c month regressor, False if seventh TD c variable is a leap year regressor. c Ltdstk - Logical scalar - True if stock trading day is performed, c False if not. c Mltadd - Logical scalar - True if multiplicative model assumed, c False if additive c Xy - Double precision matrix of dimension Nrxy, Ncxy - c regression matrix where trading day variables will be stored c Begrgm - Local array that is true where there are trading day c variables defined. c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO,MP25,P75,P28FEB,P29FEB,AVEMO,AVEQTR, & P90QTR,P91QTR PARAMETER(ONE=1D0,ZERO=0D0,MP25=-.25D0,P75=.75D0,AVEMO=30.4375D0, & AVEQTR=91.3125D0) PARAMETER(P28FEB=28D0/28.25D0) PARAMETER(P29FEB=29D0/28.25D0) PARAMETER(P90QTR=90D0/90.25D0) PARAMETER(P91QTR=91D0/90.25D0) c ------------------------------------------------------------------ LOGICAL Lom,Ltdstk,Mltadd,Begrgm INTEGER Begcol,Begdat,idate,irow,Ncxy,Nrxy,predat DOUBLE PRECISION Xy,td7,td7sum DIMENSION Begdat(2),idate(2),predat(2),Xy(Ncxy,Nrxy),Begrgm(PLEN) c ------------------------------------------------------------------ INTEGER Isp,period,year INTEGER lpyr INTEGER lnomo(12,2),ndomo c moved Bob Fay INTEGER lnoqtr(4,2),ndoqtr DOUBLE PRECISION sly(48) INTEGER idxsly c----------------------------------------------------------------------- DATA lnomo/31,28,31,30,31,30,31,31,30,31,30,31,31,29,31,30,31,30, & 31,31,30,31,30,31/ DATA lnoqtr/90,91,92,92,91,91,92,92/ c----------------------------------------------------------------------- c For initial stock td values see Bell SRD Research Report 84/01 c p. 9 for calculation of \delta^{\script l}. c----------------------------------------------------------------------- DATA sly/-.375D0,12*.375D0,12*.125D0,12*-.125D0,11*-.375D0/ c ------------------------------------------------------------------ CALL addate(Begdat,Isp,-1,predat) c ------------------------------------------------------------------ DO irow=1,Nrxy CALL addate(predat,Isp,irow,idate) year=idate(YR) period=idate(MO) c ------------------------------------------------------------------ IF(Ltdstk)idxsly=mod(year,4)*Isp+period IF((mod(year,100).ne.0.and.mod(year,4).eq.0).or.mod(year,400) & .eq.0)THEN lpyr=2 ELSE lpyr=1 END IF c----------------------------------------------------------------------- c Determine if there is a length of month adjustment. Then if c dtd(7) is the leap february variable or length of month c Do for quarterly series first. c----------------------------------------------------------------------- IF(Isp.ne.12)THEN IF(Lom)THEN ndoqtr=lnoqtr(period,lpyr) IF(Mltadd)THEN td7=DBLE(ndoqtr)/AVEQTR ELSE td7=DBLE(ndoqtr)-AVEQTR END IF c ------------------------------------------------------------------ ELSE IF(Mltadd)THEN IF(period.ne.1)THEN td7=ONE ELSE IF(lpyr.eq.2)THEN td7=P91QTR ELSE td7=P90QTR END IF c ------------------------------------------------------------------ ELSE IF(period.ne.1)THEN td7=ZERO ELSE IF(lpyr.eq.2)THEN td7=P75 ELSE td7=MP25 END IF c----------------------------------------------------------------------- c For monthly series c----------------------------------------------------------------------- ELSE IF(Lom)THEN ndomo=lnomo(period,lpyr) IF(Mltadd)THEN td7=DBLE(ndomo)/AVEMO ELSE td7=DBLE(ndomo)-AVEMO END IF c ------------------------------------------------------------------ ELSE IF(Mltadd)THEN IF(period.ne.2)THEN td7=ONE ELSE IF(lpyr.eq.2)THEN td7=P29FEB ELSE td7=P28FEB END IF c ------------------------------------------------------------------ ELSE IF(period.ne.2)THEN td7=ZERO ELSE IF(lpyr.eq.2)THEN td7=P75 ELSE td7=MP25 END IF c----------------------------------------------------------------------- c Stock Length of month variable c----------------------------------------------------------------------- IF(Ltdstk.and..not.Mltadd)THEN td7=sly(idxsly) END IF c ------------------------------------------------------------------ IF(Mltadd)THEN Xy(Begcol,irow)=ONE ELSE Xy(Begcol,irow)=ZERO END IF IF(Begrgm(irow))Xy(Begcol,irow)=td7 END DO c ------------------------------------------------------------------ RETURN END tdaic.f0000664006604000003110000006535214521201607011435 0ustar sun00315stepsC Last change: BCM 7 Sep 2005 3:30 pm SUBROUTINE tdaic(Trnsrs,A,Nefobs,Na,Frstry,Lester,Tdmdl1,Ltdlom, & Lprtit,Lprt,Lprtfm,Lsavlg,Lsumm,Lhiddn) IMPLICIT NONE c----------------------------------------------------------------------- c Estimate two or three regARIMA models: one with TD, one without, c and one coefficient TD (in default mode). c The routine will choose the model with the lowest value of AICC c and print out the resulting model. c----------------------------------------------------------------------- LOGICAL F,T INTEGER DIV,MULT,PLOM,PLOQ DOUBLE PRECISION ZERO PARAMETER(DIV=4,MULT=3,PLOM=2,PLOQ=3,F=.false.,T=.true.,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'inpt.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'adj.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'extend.cmn' INCLUDE 'notset.prm' INCLUDE 'units.cmn' INCLUDE 'error.cmn' * INCLUDE 'ssprep.cmn' c----------------------------------------------------------------------- INTEGER PA DOUBLE PRECISION ONE PARAMETER(PA=PLEN+2*PORDER,ONE=1D0) c----------------------------------------------------------------------- CHARACTER tdstr*(30),rgstr*(30),fmtsvl*(21) LOGICAL pktd,Lprt,lhide,Lprtit,Lester,lom,argok,Lprtfm,Lsavlg, & begrgm,Lhiddn,Ltdlom,lpv DOUBLE PRECISION A,a2,aic1,aic2,aicntd,lomeff,Trnsrs,tsrs, & aicbst,aicno,aictd,thiscv c DOUBLE PRECISION tap(PARIMA),tb(PB),tap0(PARIMA),tb0(PB) INTEGER Frstry,Tdmdl1,kf2,Na,Nefobs,begcol,ncol,ilom,lencol, & irgfx,igrp,endlag,ilag,ntdchr,nrgchr,Lsumm,thisTD,i,tdgrp, & aicdf,nbtd,nbno DIMENSION A(PA),lomeff(PLEN),Trnsrs(PLEN),tsrs(PLEN),a2(PLEN), & begrgm(PLEN) c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL dpeq,strinx c----------------------------------------------------------------------- c Store initial model values c----------------------------------------------------------------------- IF(.not.Lprt)THEN lhide=Lhiddn Lhiddn=T END IF CALL setdp(ONE,PLEN,lomeff) CALL copy(Adj,PLEN,1,a2) irgfx=Iregfx pktd=Picktd kf2=Kfmt ilom=Priadj aictd=DNOTST * write(*,*)Pvaic c----------------------------------------------------------------------- c Make copy of transformed data c----------------------------------------------------------------------- CALL copy(Trnsrs,PLEN,1,tsrs) c----------------------------------------------------------------------- c Set indicator variable to determine if td regression is in the c regression variables. c----------------------------------------------------------------------- Tdmdl1=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(Tdmdl1.eq.0) & Tdmdl1=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Stock Trading Day') IF(Tdmdl1.eq.0) & Tdmdl1=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Trading Day') IF(Tdmdl1.eq.0) & Tdmdl1=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Stock Trading Day') c----------------------------------------------------------------------- c Generate string for label of trading day effect c----------------------------------------------------------------------- CALL mktdlb(rgstr,nrgchr,Tdayvc(Ntdvec),Aicstk,Tddate,Tdzero,Sp) IF(.not.Lfatal) & CALL mktdlb(tdstr,ntdchr,Itdtst,Aicstk,Tddate,Tdzero,Sp) IF(Lfatal)RETURN IF(Lsavlg)THEN CALL setchr(' ',21,fmtsvl) WRITE(fmtsvl,1010)MAX(nrgchr,4)+10 END IF c----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN WRITE(Nform,1020)'aictest.td.num:',Ntdvec-1 WRITE(Nform,1030)'aictest.td.reg:',tdstr(1:ntdchr) IF(Ntdvec.eq.3) & WRITE(Nform,1030)'aictest.td.reg2:',rgstr(1:nrgchr) END IF c----------------------------------------------------------------------- c Check for length of month or leapyear regressors. c----------------------------------------------------------------------- lencol=strinx(T,Colttl,Colptr,1,Ncoltl,'Length-of-') IF(lencol.eq.0)lencol=strinx(T,Colttl,Colptr,1,Ncoltl, & 'Stock Length-of-') IF(lencol.eq.0)lencol=strinx(F,Colttl,Colptr,1,Ncoltl,'Leap Year') c----------------------------------------------------------------------- c Generate length of month effect for possible later use. c----------------------------------------------------------------------- IF(Priadj.eq.PLOM.or.Priadj.eq.PLOQ)THEN lom=T ELSE lom=F END IF IF(Lrgmtd.and.MOD(Tdzero,2).ne.0)THEN CALL gtrgpt(Begadj,Tddate,Tdzero,begrgm,Nadj) ELSE CALL setlg(T,PLEN,begrgm) END IF CALL td7var(Begadj,Sp,Nadj,1,1,lom,F,T,lomeff,begrgm) c----------------------------------------------------------------------- c Start loop through model choices c----------------------------------------------------------------------- DO i=1,Ntdvec thisTD=Tdayvc(i) c----------------------------------------------------------------------- c See if there is a trading day effect in the model c----------------------------------------------------------------------- tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(tdgrp.eq.0) & tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Stock Trading Day') IF(tdgrp.eq.0) & tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Trading Day') IF(tdgrp.eq.0) & tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl, & '1-Coefficient Stock Trading Day') c----------------------------------------------------------------------- c If trading day regressor in model, delete regressor from model c----------------------------------------------------------------------- IF(tdgrp.gt.0)THEN DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) ncol=Grp(igrp)-begcol IF(Rgvrtp(begcol).eq.PRGTST.or.Rgvrtp(begcol).eq.PRGTTD.or. & Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRATTD.or. & (Lomtst.eq.0.and.(Rgvrtp(begcol).eq.PRGTLM.or. & Rgvrtp(begcol).eq.PRGTLQ.or.Rgvrtp(begcol).eq.PRGTLY.or. & Rgvrtp(begcol).eq.PRGTSL.or.Rgvrtp(begcol).eq.PRRTLM.or. & Rgvrtp(begcol).eq.PRRTLQ.or.Rgvrtp(begcol).eq.PRRTLY.or. & Rgvrtp(begcol).eq.PRRTSL.or.Rgvrtp(begcol).eq.PRATLM.or. & Rgvrtp(begcol).eq.PRATLQ.or.Rgvrtp(begcol).eq.PRATLY)).or. & Rgvrtp(begcol).eq.PRATSL.or. & Rgvrtp(begcol).eq.PRG1TD.or.Rgvrtp(begcol).eq.PRR1TD.or. & Rgvrtp(begcol).eq.PRA1TD.or.Rgvrtp(begcol).eq.PRG1ST.or. & Rgvrtp(begcol).eq.PRR1ST.or.Rgvrtp(begcol).eq.PRA1ST)THEN CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN END IF END DO END IF c----------------------------------------------------------------------- IF(i.eq.1)THEN c----------------------------------------------------------------------- c if Picktd, put length of month back in series. c----------------------------------------------------------------------- IF(pktd)THEN Picktd=F Priadj=1 c *** Change Nspobs to Nadj and Adj1st to 1 until END OF CHANGE c *** Add if block so this is only done if log transform done c *** JAN 2000 BCM IF(dpeq(Lam,0D0))THEN IF(Nustad.gt.0)THEN CALL eltfcn(DIV,Y(Frstsy),Usrtad(Frstat),Nobspf,PLEN,Trnsrs) CALL copy(Usrtad(Frstat),Nadj,1,Adj(1)) ELSE CALL copy(Y(Frstsy),Nobspf,-1,Trnsrs) END IF IF(Nuspad.gt.0)THEN CALL eltfcn(DIV,Y(Frstsy),Usrpad(Frstap),Nobspf,PLEN,Trnsrs) IF(Nustad.gt.0)THEN CALL eltfcn(MULT,Adj(1),Usrpad(Frstap),Nadj,PLEN,Adj(1)) ELSE CALL copy(Usrpad(Frstap),Nadj,1,Adj(1)) END IF ELSE CALL setdp(1D0,PLEN,Adj) END IF c *** END OF CHANGE (BCM, JAN 1997) IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Else, preadjust series if necessary c----------------------------------------------------------------------- ELSE IF(i.eq.2)THEN IF(Tdmdl1.eq.0)THEN c----------------------------------------------------------------------- c If the td or td1coef options are selected, set Picktd to true and c add either a leap year regressor or leap year preadjustment c factors, depending on the data transformation. c----------------------------------------------------------------------- IF(thisTD.eq.1.or.thisTD.eq.4)THEN Picktd=T IF(Fcntyp.eq.4.OR.dpeq(Lam,1D0))THEN IF(Ltdlom)THEN IF(Sp.eq.12)THEN CALL adrgef(DNOTST,'Length-of-Month','Length-of-Month', & PRGTLM,F,F) ELSE IF(Sp.eq.4)THEN CALL adrgef(DNOTST,'Length-of-Quarter','Length-of-Quarter', & PRGTLQ,F,F) END IF ELSE CALL adrgef(DNOTST,'Leap Year','Leap Year',PRGTLY,F,F) END IF IF(Lfatal)RETURN ELSE IF(Ltdlom)THEN IF(Sp.eq.12)THEN Priadj=PLOM ELSE IF(Sp.eq.4)THEN Priadj=PLOQ END IF ELSE Priadj=4 END IF END IF END IF Iregfx=0 * CALL addtd(Aicstk,Tddate,Tdzero,Sp,Itdtst) c----------------------------------------------------------------------- c Length of Month adjust original series, if necessary. c----------------------------------------------------------------------- IF((ilom.le.1.and.Picktd).AND.(.not.(Fcntyp.eq.4.OR. & dpeq(Lam,1D0))))THEN c----------------------------------------------------------------------- c Generate length of month (or length of quarter) variables. c----------------------------------------------------------------------- IF(kf2.eq.0)THEN CALL eltfcn(DIV,Y(Frstsy),lomeff(Adj1st),Nobspf,PLEN,Trnsrs) IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF IF(Lfatal)RETURN CALL copy(lomeff,PLEN,1,Adj) Kfmt=1 ELSE CALL eltfcn(DIV,Y(Frstsy),lomeff(Adj1st),Nobspf,PLEN,Trnsrs) CALL eltfcn(DIV,Trnsrs,Adj(Adj1st),Nobspf,PLEN,Trnsrs) IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF IF(Lfatal)RETURN CALL eltfcn(MULT,lomeff(Adj1st),Adj(Adj1st),Nobspf,PLEN, & Adj(Adj1st)) END IF END IF c----------------------------------------------------------------------- c If not, restore variables from original model c----------------------------------------------------------------------- ELSE CALL copy(a2,PLEN,1,Adj) Picktd=pktd Kfmt=kf2 Priadj=ilom c----------------------------------------------------------------------- c Copy over transformed data c----------------------------------------------------------------------- CALL copy(tsrs,PLEN,1,Trnsrs) c----------------------------------------------------------------------- c Add LOM or LPY regressor, if necessary. c----------------------------------------------------------------------- IF((thisTD.eq.1.or.thisTD.eq.4).and.Picktd)THEN IF(Fcntyp.eq.4.OR.dpeq(Lam,1D0))THEN IF(Ltdlom)THEN IF(Sp.eq.12)THEN CALL adrgef(DNOTST,'Length-of-Month','Length-of-Month', & PRGTLM,F,F) ELSE IF(Sp.eq.4)THEN CALL adrgef(DNOTST,'Length-of-Quarter','Length-of-Quarter', & PRGTLQ,F,F) END IF ELSE CALL adrgef(DNOTST,'Leap Year','Leap Year',PRGTLY,F,F) END IF IF(Lfatal)RETURN END IF END IF END IF ELSE IF(i.eq.3)THEN IF(thisTD.eq.4)THEN IF(Fcntyp.eq.4.OR.dpeq(Lam,1D0))THEN IF(Ltdlom)THEN IF(Sp.eq.12)THEN CALL adrgef(DNOTST,'Length-of-Month','Length-of-Month', & PRGTLM,F,F) ELSE IF(Sp.eq.4)THEN CALL adrgef(DNOTST,'Length-of-Quarter','Length-of-Quarter', & PRGTLQ,F,F) END IF ELSE CALL adrgef(DNOTST,'Leap Year','Leap Year',PRGTLY,F,F) END IF IF(Lfatal)RETURN END IF END IF END IF c----------------------------------------------------------------------- c If i > 1, add new trading day regressor to model c----------------------------------------------------------------------- IF(i.gt.1.or.tdgrp.gt.0)THEN IF(i.gt.1)THEN CALL mktdlb(tdstr,ntdchr,thisTD,Aicstk,Tddate,Tdzero,Sp) IF(.not.Lfatal)CALL addtd(Aicstk,Tddate,Tdzero,Sp,thisTD) END IF IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Estimate the model c----------------------------------------------------------------------- argok=Lautom.or.Lautox CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) c CALL rgarma(T,Mxiter,Mxnlit,T,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok))Lester=T IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0.or. & ((Lautom.or.Lautox).and..not.argok))THEN Lester=T RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- IF(i.eq.1)THEN IF(Lprt)WRITE(Mt1,1040)'without',tdstr(1:ntdchr) ELSE IF(Lprt)WRITE(Mt1,1040)'with',tdstr(1:ntdchr) END IF IF(i.eq.Ntdvec)THEN CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt, & Lprtfm) ELSE CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,F) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Start testing AICC. First save the AICC for no TD. c----------------------------------------------------------------------- IF(i.eq.1)THEN aicno=Aicc nbno=Nb IF(Lsavlg)WRITE(Ng,fmtsvl)'AICC(no td)',':',Aicc IF(Lsumm.gt.0)WRITE(Nform,1050)'notd',Aicc c----------------------------------------------------------------------- c Next find best AICC for models with TD. c----------------------------------------------------------------------- ELSE IF(Lsavlg)WRITE(Ng,fmtsvl)'AICC('//tdstr(1:ntdchr)//')',':',Aicc IF(Lsumm.gt.0)WRITE(Nform,1050)tdstr(1:ntdchr),Aicc c----------------------------------------------------------------------- c If second pass, save td indicator, AICC, Nb c----------------------------------------------------------------------- IF(i.eq.2)THEN Aicint=thisTD aictd=Aicc IF(.not.dpeq(Pvaic,DNOTST))nbtd=Nb c----------------------------------------------------------------------- c If third pass, determine "critical value" by chi square, c if specified c----------------------------------------------------------------------- ELSE IF(.not.dpeq(Pvaic,DNOTST))THEN aicdf=nbtd-Nb CALL chsppf(Pvaic,aicdf,thiscv,Mt1) Rgaicd(PTDAIC)=thiscv-2D0*DBLE(aicdf) END IF c----------------------------------------------------------------------- c Determine which TD model is best c----------------------------------------------------------------------- Dfaict=Aicc-aictd IF(.not.(Dfaict.gt.Rgaicd(PTDAIC)))THEN Aicint=thisTD aictd=Aicc IF(.not.dpeq(Pvaic,DNOTST))nbtd=Nb END IF END IF END IF END DO c----------------------------------------------------------------------- c Determine best model between TD, no TD c----------------------------------------------------------------------- Dfaict=aicno-aictd IF(.not.dpeq(Pvaic,DNOTST))THEN aicdf=nbtd-nbno CALL chsppf(Pvaic,aicdf,thiscv,Mt1) Rgaicd(PTDAIC)=thiscv-2D0*dble(aicdf) END IF IF(Dfaict.gt.Rgaicd(PTDAIC))THEN aicbst=aictd ELSE aicbst=Aicno Aicint=0 END IF c----------------------------------------------------------------------- IF(.not.Lprt)Lhiddn=lhide c----------------------------------------------------------------------- c Show Trading Day effect that aic prefers c----------------------------------------------------------------------- IF(Lprt)THEN IF(Aicint.eq.0)THEN CALL mktdlb(tdstr,ntdchr,Tdayvc(2),Aicstk,Tddate,Tdzero,Sp) IF(Lfatal)RETURN IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1060)Rgaicd(PTDAIC),'without',tdstr(1:ntdchr) ELSE WRITE(Mt1,1070) & ONE-Pvaic,Rgaicd(PTDAIC),'without',tdstr(1:ntdchr) END IF ELSE IF(Aicint.ne.Tdayvc(Ntdvec))THEN CALL mktdlb(tdstr,ntdchr,Aicint,Aicstk,Tddate,Tdzero,Sp) IF(Lfatal)RETURN END IF IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1060)Rgaicd(PTDAIC),'with',tdstr(1:ntdchr) ELSE WRITE(Mt1,1070) & ONE-Pvaic,Rgaicd(PTDAIC),'with',tdstr(1:ntdchr) END IF END IF END IF c----------------------------------------------------------------------- c If no trading day selected, set up new model and data c----------------------------------------------------------------------- IF(Aicint.eq.0)THEN c----------------------------------------------------------------------- c if Picktd, put length of month back in series. c----------------------------------------------------------------------- IF(pktd)THEN Picktd=F Priadj=1 c *** Change Nspobs to Nadj and Adj1st to 1 until END OF CHANGE c *** Add if block so this is only done if log transform done c *** JAN 2000 BCM IF(dpeq(Lam,0D0))THEN IF(Nustad.gt.0)THEN CALL eltfcn(DIV,Y(Frstsy),Usrtad(Frstat),Nobspf,PLEN,Trnsrs) CALL copy(Usrtad(Frstat),Nadj,1,Adj(1)) ELSE CALL copy(Y(Frstsy),Nobspf,-1,Trnsrs) END IF IF(Nuspad.gt.0)THEN CALL eltfcn(DIV,Y(Frstsy),Usrpad(Frstap),Nobspf,PLEN,Trnsrs) IF(Nustad.gt.0)THEN CALL eltfcn(MULT,Adj(1),Usrpad(Frstap),Nadj,PLEN,Adj(1)) ELSE CALL copy(Usrpad(Frstap),Nadj,1,Adj(1)) END IF ELSE CALL setdp(1D0,PLEN,Adj) END IF c *** END OF CHANGE (BCM, JAN 1997) IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF IF(Lfatal)RETURN END IF ELSE CALL copy(a2,PLEN,1,Adj) Kfmt=kf2 Picktd=pktd Iregfx=irgfx IF(ilom.le.1)THEN Priadj=ilom CALL copy(tsrs,PLEN,1,Trnsrs) END IF END IF c----------------------------------------------------------------------- c removed trading day variables c----------------------------------------------------------------------- DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) ncol=Grp(igrp)-begcol IF(Rgvrtp(begcol).eq.PRGTST.or.Rgvrtp(begcol).eq.PRGTTD.or. & Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRATTD.or. & (Lomtst.eq.0.and.(Rgvrtp(begcol).eq.PRGTLM.or. & Rgvrtp(begcol).eq.PRGTLQ.or.Rgvrtp(begcol).eq.PRGTLY.or. & Rgvrtp(begcol).eq.PRGTSL.or.Rgvrtp(begcol).eq.PRRTLM.or. & Rgvrtp(begcol).eq.PRRTLQ.or.Rgvrtp(begcol).eq.PRRTLY.or. & Rgvrtp(begcol).eq.PRRTSL.or.Rgvrtp(begcol).eq.PRATLM.or. & Rgvrtp(begcol).eq.PRATLQ.or.Rgvrtp(begcol).eq.PRATLY)).or. & Rgvrtp(begcol).eq.PRATSL.or. & Rgvrtp(begcol).eq.PRG1TD.or.Rgvrtp(begcol).eq.PRR1TD.or. & Rgvrtp(begcol).eq.PRA1TD.or.Rgvrtp(begcol).eq.PRG1ST.or. & Rgvrtp(begcol).eq.PRR1ST.or.Rgvrtp(begcol).eq.PRA1ST)THEN CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN END IF END DO c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Estimate the model c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) CALL rgarma(T,Mxiter,Mxnlit,Lprtit,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & CALL abend() IF(Lfatal)RETURN c----------------------------------------------------------------------- c Remove trading day c----------------------------------------------------------------------- ELSE IF(Aicint.ne.Tdayvc(Ntdvec))THEN DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) ncol=Grp(igrp)-begcol IF(Rgvrtp(begcol).eq.PRGTST.or.Rgvrtp(begcol).eq.PRGTTD.or. & Rgvrtp(begcol).eq.PRRTST.or.Rgvrtp(begcol).eq.PRRTTD.or. & Rgvrtp(begcol).eq.PRATST.or.Rgvrtp(begcol).eq.PRATTD.or. & Rgvrtp(begcol).eq.PRATSL.or. & Rgvrtp(begcol).eq.PRG1TD.or.Rgvrtp(begcol).eq.PRR1TD.or. & Rgvrtp(begcol).eq.PRA1TD.or.Rgvrtp(begcol).eq.PRG1ST.or. & Rgvrtp(begcol).eq.PRR1ST.or.Rgvrtp(begcol).eq.PRA1ST)THEN CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN END IF END DO CALL addtd(Aicstk,Tddate,Tdzero,Sp,Aicint) c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) CALL rgarma(T,Mxiter,Mxnlit,Lprtit,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & CALL abend() IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(.not.Lpradj.and.Kfmt.eq.1)Lpradj=.true. IF(Aicint.eq.0)THEN IF(pktd.and.(.not.Picktd))THEN CALL copy(Adj,Nadj,-1,Sprior(Setpri)) IF((Nustad.eq.0.or.Nuspad.eq.0).and.Kfmt.gt.0)Kfmt=0 END IF IF(Tdmdl1.gt.0)Tdmdl1=1 ELSE IF((.not.pktd).and.Picktd)THEN CALL copy(Adj,Nadj,-1,Sprior(Setpri)) IF(Kfmt.eq.0)Kfmt=1 IF(Nuspad.eq.0.or.Npser.eq.0)THEN Prmser(1:3)='LPY' Npser=3 END IF END IF IF(Ntdvec.eq.2)THEN Tdmdl1=0 ELSE IF(Aicint.eq.Tdayvc(Ntdvec))THEN Tdmdl1=2 ELSE Tdmdl1=0 END IF END IF RETURN c----------------------------------------------------------------------- 1010 FORMAT('(1x,a,t',i2,',a,1x,f15.4)') 1020 FORMAT(a,1x,i6) 1030 FORMAT(a,1x,a) 1040 FORMAT(//,' Likelihood statistics for model ',a,' ',a) 1050 FORMAT('aictest.td.aicc.',a,': ',e29.15) 1060 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model ',a,' ',a,' *****') 1070 FORMAT(//,' ***** AICC (with p-value=',F7.5,' and aicdiff=', & F7.4,') prefers model ',a,' ',a,' *****') c----------------------------------------------------------------------- END tdftest.f0000664006604000003110000005676314521201607012034 0ustar sun00315steps SUBROUTINE tdftest(Xpxinv,Regidx,Lprtdt,Lsvtdt,Lsvlog,Lxreg) IMPLICIT NONE c----------------------------------------------------------------------- c generate model-based f-tests for seasonality from chi square c statistics of seasonal regressors; also generate model-based c f-tests for combinations of seasonal regression groups, c such as change of regime regressors and user defined seasonal c regressors c (BCM July 2007) c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'picktd.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'mdldg.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER grpstr*(PGRPCR),rg0str*(PGRPCR),rg1str*(PGRPCR), & rg2str*(PGRPCR) DOUBLE PRECISION Xpxinv,chi2vl,pv LOGICAL havlp,havlm,Lxreg,Lprtdt,Lsvtdt,Lsvlog,lprthd,lprund INTEGER baselt,begcol,endcol,igrp,gtdall,gtdrg,gtdrg1,gtdrg2,gutd, & Regidx,rgi2,rtype,df,df1,df2,iusr,utype,info,tbwdth,nchr, & icol,ud1st,udlast,i,nchr0,nchr1,nchr2,ipos,ntdgp,k DIMENSION gtdall(0:2),gtdrg(0:2),gtdrg1(0:2),gtdrg2(0:2), & gutd(0:2),Regidx(PB),rgi2(PB),Xpxinv(PXPX) c----------------------------------------------------------------------- DOUBLE PRECISION fvalue EXTERNAL fvalue c----------------------------------------------------------------------- lprthd=Lprtdt lprund=F tbwdth=71 c----------------------------------------------------------------------- c Compute number of regressors estimated c----------------------------------------------------------------------- k=Nb IF(Iregfx.eq.2)THEN DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 DO icol=begcol,endcol IF(regidx(icol).eq.NOTSET)k=k-1 END DO END DO END IF df2=Nspobs-Mxdflg-k c----------------------------------------------------------------------- c Print out f-tests for individual groups of trading day regressors c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) rtype=Rgvrtp(begcol) IF(rtype.eq.PRGTTD.or.rtype.eq.PRRTTD.or.rtype.eq.PRATTD.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRGTST.or.rtype.eq.PRRTST.or.rtype.eq.PRATST.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRR1ST)THEN IF(Lprtdt)lprund=T endcol=Grp(igrp)-1 CALL getstr(Grpttl,Grpptr,Ngrp,igrp,grpstr,nchr) IF(Lfatal)RETURN info=0 baselt=regidx(begcol) df=endcol-begcol+1 IF(Iregfx.eq.2)THEN IF(baselt.eq.NOTSET)df=df-1 DO icol=begcol+1,endcol IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE baselt=regidx(icol) END IF END DO END IF IF(baselt.ne.NOTSET) & CALL chitst(Xpxinv,begcol,endcol,chi2vl,pv,regidx,T,info) df1=df c df2=Nspobs-Mxdflg-df Tdfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Tdfpv=fvalue(Tdfval,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Tdfval,Tdfpv) END IF END DO c----------------------------------------------------------------------- c Create pointer dictionaries for different tests we wish to c perform c----------------------------------------------------------------------- DO icol=0,2 gtdall(icol)=0 gtdrg(icol)=0 gtdrg1(icol)=0 gtdrg2(icol)=0 gutd(icol)=0 END DO ud1st=NOTSET udlast=NOTSET iusr=1 c----------------------------------------------------------------------- DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 rtype=Rgvrtp(begcol) c----------------------------------------------------------------------- IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY))THEN gtdall(0)=gtdall(0)+1 IF(gtdall(0).eq.1)gtdall(1)=begcol gtdall(2)=endcol END IF IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRG1TD.or. & rtype.eq.PRG1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY))THEN gtdrg(0)=gtdrg(0)+1 IF(gtdrg(0).eq.1)gtdrg(1)=begcol gtdrg(2)=endcol CALL getstr(Grpttl,Grpptr,Ngrp,igrp,rg0str,nchr0) IF(Lfatal)RETURN END IF IF((rtype.eq.PRRTTD.or.rtype.eq.PRRTST.or.rtype.eq.PRR1TD.or. & (rtype.eq.PRR1ST).or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY))THEN gtdrg1(0)=gtdrg1(0)+1 IF(gtdrg1(0).eq.1)gtdrg1(1)=begcol gtdrg1(2)=endcol CALL getstr(Grpttl,Grpptr,Ngrp,igrp,rg1str,nchr1) IF(Lfatal)RETURN END IF IF((rtype.eq.PRATTD.or.rtype.eq.PRATST.or.rtype.eq.PRA1TD.or. & (rtype.eq.PRA1ST).or.rtype.eq.PRATLM.or.rtype.eq.PRATSL.or. & rtype.eq.PRATLQ.or.rtype.eq.PRATLY))THEN gtdrg2(0)=gtdrg2(0)+1 IF(gtdrg2(0).eq.1)gtdrg2(1)=begcol gtdrg2(2)=endcol CALL getstr(Grpttl,Grpptr,Ngrp,igrp,rg2str,nchr2) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- 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 IF(ud1st.eq.NOTSET)ud1st=begcol END IF IF(rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY)THEN IF(gtdall(0).eq.0)gtdall(1)=begcol gtdall(0)=gtdall(0)+1 gtdall(1)=icol gtdall(2)=endcol c----------------------------------------------------------------------- IF(rtype.eq.PRGUTD)THEN IF(gutd(0).eq.0)gutd(1)=begcol gutd(0)=gutd(0)+1 gutd(2)=endcol END IF END IF udlast=utype END DO c----------------------------------------------------------------------- c Generate combined Chi-Square test for trading day regressors c----------------------------------------------------------------------- IF(gtdrg(0).ge.2.and.gtdrg(2).lt.gtdall(2))THEN * IF(gtdrg(0).ge.2)THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdrg(2)-gtdrg(1)+1 baselt=regidx(gtdrg(1)) DO icol=gtdrg(1),gtdrg(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRG1TD.or. & rtype.eq.PRG1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRGTLY)havlp=T IF(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ)havlm=T END DO CALL chitst(Xpxinv,gtdrg(1),gtdrg(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=13 grpstr(1:nchr)='Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+12)='+ Leap Year ' nchr=nchr+12 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+20)='+ Length of Quarter ' nchr=nchr+20 ELSE grpstr(nchr+1:nchr+18)='+ Length of Month ' nchr=nchr+18 END IF END IF ipos=index(rg0str(1:nchr0),'(') grpstr(nchr+1:(nchr+nchr0-ipos+1))=rg0str(ipos:nchr0) nchr=nchr+nchr0-ipos+1 df1=df c df2=Nspobs-Mxdflg-df1 Tdfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Tdfpv=fvalue(Tdfval,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Tdfval,Tdfpv) ELSE ntdgp=0 IF(gtdrg(0).gt.0)ntdgp=ntdgp+1 IF(gtdrg1(0).gt.0)ntdgp=ntdgp+1 IF(gtdrg2(0).gt.0)ntdgp=ntdgp+1 IF(gutd(0).gt.0)ntdgp=ntdgp+1 IF(ntdgp.gt.1.and.gutd(0).gt.0)THEN CALL setint(NOTSET,Nb,rgi2) df=gtdall(2)-gtdall(1)+1 baselt=regidx(gtdall(1)) DO icol=gtdall(1),gtdall(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY).and.gutd(0).gt.0)THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF END DO CALL chitst(Xpxinv,gtdall(1),gtdall(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=31 grpstr(1:nchr)='Combined Trading Day Regressors' df1=df c df2=Nspobs-Mxdflg-df1 Tdfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Tdfpv=fvalue(Tdfval,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Tdfval,Tdfpv) END IF END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for trading day and lom c change of regime regressors c----------------------------------------------------------------------- IF(gtdrg1(0).ge.2.and.(.not.(gtdrg1(1).eq.gtdall(1).and. & gtdrg1(2).eq.gtdall(2))))THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdrg1(2)-gtdrg1(1)+1 baselt=regidx(gtdrg1(1)) DO icol=gtdrg1(1),gtdrg1(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRRTTD.or.rtype.eq.PRRTST.or.rtype.eq.PRR1TD.or. & rtype.eq.PRR1ST).or. & (rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRRTLY).or.(Fulltd.and. & (rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRG1TD.or. & rtype.eq.PRG1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY)))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRRTLY)THEN havlp=T ELSE IF(rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ & .or.(Fulltd.and.(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or. & rtype.eq.PRGTLQ.or.rtype.eq.PRGTLY)))THEN havlm=T END IF END DO CALL chitst(Xpxinv,gtdrg1(1),gtdrg1(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=13 grpstr(1:nchr)='Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+12)='+ Leap Year ' nchr=nchr+12 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+20)='+ Length of Quarter ' nchr=nchr+20 ELSE grpstr(nchr+1:nchr+18)='+ Length of Month ' nchr=nchr+18 END IF END IF ipos=index(rg1str(1:nchr1),'(') grpstr(nchr+1:(nchr+nchr1-ipos+1))=rg1str(ipos:nchr1) nchr=nchr+nchr1-ipos+1 df1=df c df2=Nspobs-Mxdflg-df1 Tdfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Tdfpv=fvalue(Tdfval,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Tdfval,Tdfpv) END IF c----------------------------------------------------------------------- IF(gtdrg2(0).ge.2.and.(.not.(gtdrg2(1).eq.gtdall(1).and. & gtdrg2(2).eq.gtdall(2))))THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdrg2(2)-gtdrg2(1)+1 baselt=regidx(gtdrg2(1)) DO icol=gtdrg2(1),gtdrg2(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRATTD.or.rtype.eq.PRATST.or.rtype.eq.PRA1TD).or. & (rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or. & rtype.eq.PRATLY))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRATLY)THEN havlp=T ELSE IF(rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ) & THEN havlm=T END IF END DO CALL chitst(Xpxinv,gtdrg2(1),gtdrg2(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=13 grpstr(1:nchr)='Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+12)='+ Leap Year ' nchr=nchr+12 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+20)='+ Length of Quarter ' nchr=nchr+20 ELSE grpstr(nchr+1:nchr+18)='+ Length of Month ' nchr=nchr+18 END IF END IF ipos=index(rg2str(1:nchr2),'(') grpstr(nchr+1:(nchr+nchr2-ipos+1))=rg2str(ipos:nchr2) nchr=nchr+nchr2-ipos+1 df1=df c df2=Nspobs-Mxdflg-df1 Tdfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Tdfpv=fvalue(Tdfval,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Tdfval,Tdfpv) END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for trading day and lom c regressors c----------------------------------------------------------------------- IF(gtdall(0).ge.2.and.(gutd(0).gt.0.and.gtdall(0).gt.gutd(0)))THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdall(2)-gtdall(1)+1 baselt=regidx(gtdall(1)) DO icol=gtdall(1),gtdall(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRGTLY.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLY.or. & rtype.eq.PRGULY)THEN havlp=T ELSE IF(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ & .or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ & .or.rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ & .or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ)THEN havlm=T END IF END DO CALL chitst(Xpxinv,gtdall(1),gtdall(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=21 grpstr(1:nchr)='Combined Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+14)='and Leap Year ' nchr=nchr+14 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+22)='and Length of Quarter ' nchr=nchr+22 ELSE grpstr(nchr+1:nchr+20)='and Length of Month ' nchr=nchr+20 END IF END IF grpstr(nchr+1:nchr+10)='Regressors' nchr=nchr+10 df1=df c df2=Nspobs-Mxdflg-df1 Tdfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Tdfpv=fvalue(Tdfval,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Tdfval,Tdfpv) END IF c----------------------------------------------------------------------- c Generate combined Chi-Square test for user defined trading day c regressors if there are more than one type of user defined c regressor defined. c----------------------------------------------------------------------- IF(ud1st.eq.NOTSET)THEN ntdgp=0 IF(gtdrg(0).gt.0)ntdgp=ntdgp+1 IF(gtdrg1(0).gt.0)ntdgp=ntdgp+1 IF(gtdrg2(0).gt.0)ntdgp=ntdgp+1 IF(gutd(0).gt.0)ntdgp=ntdgp+1 IF(ntdgp.gt.1)THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gtdall(2)-gtdall(1)+1 baselt=regidx(gtdall(1)) DO icol=gtdall(1),gtdall(2) rtype=Rgvrtp(icol) IF((rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or.rtype.eq.PRRTTD.or. & rtype.eq.PRRTST.or.rtype.eq.PRATTD.or.rtype.eq.PRATST.or. & rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or. & rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or.rtype.eq.PRA1ST).or. & (rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or. & rtype.eq.PRGTLY.or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or. & rtype.eq.PRRTLQ.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or. & rtype.eq.PRATSL.or.rtype.eq.PRATLQ.or.rtype.eq.PRATLY).or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY))THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(rtype.eq.PRGTLY.or.rtype.eq.PRRTLY.or.rtype.eq.PRATLY)THEN havlp=T ELSE IF(rtype.eq.PRGTLM.or.rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ & .or.rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ & .or.rtype.eq.PRATLM.or.rtype.eq.PRATSL.or.rtype.eq.PRATLQ & .or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ) & THEN havlm=T END IF END DO c IF(.not.(havlp.or.havlm))RETURN CALL chitst(Xpxinv,gtdall(1),gtdall(2),chi2vl,pv,rgi2,F,info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=21 grpstr(1:nchr)='Combined Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+14)='and Leap Year ' nchr=nchr+14 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+22)='and Length of Quarter ' nchr=nchr+22 ELSE grpstr(nchr+1:nchr+20)='and Length of Month ' nchr=nchr+20 END IF END IF grpstr(nchr+1:nchr+10)='Regressors' nchr=nchr+10 df1=df c df2=Nspobs-Mxdflg-df1 Tdfval=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Tdfpv=fvalue(Tdfval,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Tdfval,Tdfpv) END IF RETURN END IF IF(gutd(0).gt.0.and.(gutd(2)-gutd(1)).gt.0)THEN CALL setint(NOTSET,Nb,rgi2) havlp=F havlm=F df=gutd(2)-gutd(1)+1 baselt=regidx(gutd(1)) DO icol=gutd(1),gutd(2) iusr=icol-ud1st+1 IF(Lxreg)THEN utype=Usxtyp(iusr) ELSE utype=Usrtyp(iusr) END IF IF(utype.eq.PRGUTD.or.utype.eq.PRGULM.or. & utype.eq.PRGULQ.or.utype.eq.PRGULY)THEN rgi2(icol)=Regidx(icol) IF(regidx(icol).eq.NOTSET)THEN df=df-1 ELSE IF(baselt.eq.NOTSET)THEN baselt=rgi2(icol) END IF ELSE df=df-1 END IF IF(utype.eq.PRGULY)THEN havlp=T ELSE IF(utype.eq.PRGULM.or.utype.eq.PRGULQ) & THEN havlm=T END IF END DO CALL chitst(Xpxinv,gutd(1),gutd(2),chi2vl,pv,rgi2,gutd(0).lt.2, & info) c----------------------------------------------------------------------- c Print out and/or save chi square statistic c----------------------------------------------------------------------- nchr=25 grpstr(1:nchr)='User-defined Trading Day ' IF(havlp)THEN grpstr(nchr+1:nchr+14)='and Leap Year ' nchr=nchr+14 ELSE IF(havlm)THEN IF(Sp.eq.4)THEN grpstr(nchr+1:nchr+22)='and Length of Quarter ' nchr=nchr+22 ELSE grpstr(nchr+1:nchr+20)='and Length of Month ' nchr=nchr+20 END IF END IF grpstr(nchr+1:nchr+10)='Regressors' nchr=nchr+10 df1=df c df2=Nspobs-Mxdflg-df1 Utdfvl=(chi2vl/dble(df1))*(dble(df2)/dble(Nspobs-Mxdflg)) Utdfpv=fvalue(Utdfvl,df1,df2) CALL prtft(Lprtdt,lprthd,tbwdth,Lsvtdt,Lsvlog,baselt,grpstr, & nchr,'Trading Day',info,df1,df2,Utdfvl,Utdfpv) END IF c----------------------------------------------------------------------- c Print the tail line c----------------------------------------------------------------------- IF(lprund)WRITE(Mt1,1020)('-',i=1,tbwdth) IF(Lsvlog)WRITE(Ng,1020)' ' c----------------------------------------------------------------------- 1020 FORMAT(' ',120(a)) RETURN END tdlom.f0000664006604000003110000000623514521201607011463 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:35 pm **==tdlom.f processed by SPAG 4.03F at 10:51 on 21 Apr 1994 SUBROUTINE tdlom(Stcsi,Stocal,Sprior,Factd,First,Last,Muladd, & Adjtd,Adjtmp) IMPLICIT NONE c ------------------------------------------------------------------ c This routine removes length of month adjustment factors from the c prior adjustment factors (Sprior) and combines them with the c trading day effect generated by the regARIMA model (Factd) if this c effect is to be removed from the series. c Add Adjtmp as a argument, which is now computed in another c subroutine (BCM Oct 2009) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'adj.cmn' c INCLUDE 'lzero.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION Stcsi,Stocal,Adjtmp,Sprior,Factd INTEGER Muladd,First,Last,Adjtd DIMENSION Stcsi(PLEN),Stocal(PLEN),Adjtmp(PLEN),Sprior(PLEN), & Factd(PLEN) c ------------------------------------------------------------------ c Combine LOM factors with model based trading day effects by c multiplying series by combined prior and LOM factors and dividing c out prior effects. c ------------------------------------------------------------------ IF(Adjtd.eq.1)THEN CALL addmul(Factd,Factd,Sprior,First,Last) CALL divsub(Factd,Factd,Adjtmp,First,Last) c ------------------------------------------------------------------ c Remove Length of Month effect from Stocal (Oct 2009 BCM) c ------------------------------------------------------------------ CALL divsub(Stocal,Stocal,Sprior,First,Last) CALL addmul(Stocal,Stocal,Adjtmp,First,Last) c ------------------------------------------------------------------ c Reset prior effects to be original prior factors. c ------------------------------------------------------------------ CALL copy(Adjtmp(Setpri),Nadj,1,Sprior(Setpri)) Priadj=0-Priadj ELSE c ------------------------------------------------------------------ c Else, reset original series, remove LOM from prior effects and c adjust original series by prior effects. c ------------------------------------------------------------------ c Also, reset calendar adjusted original series, remove LOM from c prior effects and adjust original series by prior effects. c BCM May 2006 c ------------------------------------------------------------------ CALL addmul(Stcsi,Stcsi,Sprior,First,Last) CALL addmul(Stocal,Stocal,Sprior,First,Last) CALL copy(Adjtmp(Setpri),Nadj,1,Sprior(Setpri)) CALL divsub(Stcsi,Stcsi,Sprior,First,Last) CALL divsub(Stocal,Stocal,Sprior,First,Last) c ------------------------------------------------------------------ Priadj=0 END IF c ------------------------------------------------------------------ RETURN END tdset.f0000664006604000003110000001257714521201610011467 0ustar sun00315stepsC Last change: BCM 20 May 1999 8:53 am SUBROUTINE tdset(Sp,Tdgrp,Begdat,Lfda,Llda,Indxtd,Ixreg,Adjtd, & Adjusr,Kswv,Noxfac) IMPLICIT NONE c----------------------------------------------------------------------- c Initialize variables used for type-of-month trading day table. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'tdtyp.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- LOGICAL Noxfac INTEGER Adjtd,Adjusr,Indxtd,Lfda,Llda,Begdat,predat,Sp, & irow,idate,year,period,fouryr,sdoyr,cendsp,lpyr,sd,nd, & fdomo,lnomo,lnoqtr,fdoqtr,Ixreg,Tdgrp,Kswv DIMENSION Begdat(2),predat(2),idate(2),fouryr(0:3),fdomo(12,2), & lnomo(12,2),lnoqtr(4,2),fdoqtr(4,2) c----------------------------------------------------------------------- INTEGER YR,MO PARAMETER(YR=1,MO=2) c----------------------------------------------------------------------- DATA fouryr/0,2,3,4/ DATA lnomo/31,28,31,30,31,30,31,31,30,31,30,31, & 31,29,31,30,31,30,31,31,30,31,30,31/ DATA fdomo/0,3,3,6,1,4,6,2,5,0,3,5, & 0,3,4,0,2,5,0,3,6,1,4,6/ DATA lnoqtr/90,91,92,92, & 91,91,92,92/ DATA fdoqtr/0,6,6,0, & 0,0,0,1/ c----------------------------------------------------------------------- c Set indicator variable for the type of trading day table. c 0 - none, 1 - X-11 TD only, 2 - Model TD only, 3 - Both TD c----------------------------------------------------------------------- Tdtbl=0 IF((Adjtd.eq.1).or.(Indxtd.lt.0.and.Adjusr.eq.1))THEN Tdtbl=2 IF(Tdgrp.gt.0.and.(.not.Noxfac))Tdtbl=3 ELSE IF(Tdgrp.gt.0.and.(.not.Noxfac))THEN Tdtbl=1 IF(Indxtd.ne.0)Tdtbl=3 END IF c----------------------------------------------------------------------- c Initialize the variables for X-11 and model based trading day c----------------------------------------------------------------------- CALL setdp(DNOTST,PTD,Tdx11) CALL setdp(DNOTST,PTD,Tdx11b) CALL setdp(DNOTST,PTD,Tdmdl) CALL setdp(DNOTST,PTD,Tdmdl1) CALL setdp(DNOTST,2,Lpmdl) CALL setdp(DNOTST,2,Lpmdl1) CALL setdp(0D0,PLEN,Xnstar) CALL setdp(0D0,PLEN,Xlpyr) CALL setint(0,PTD,Tday) c----------------------------------------------------------------------- c Set the indicator variable for the type of a given month t. c Code goes from 1-28, where 1-7 means 30 (91) day month (quarter) c starting in Monday, Tuesday, ..., Sunday; 8-14 means 31 (92) day c month (quarter) starting in Monday, Tuesday, ..., Sunday; 15-21 c is a non-leap year February starting in Monday, Tuesday, ..., c Sunday; 22-28 means a leap year February starting in Monday, c Tuesday, ..., Sunday. Do only if a trading day table will be c produced. c----------------------------------------------------------------------- IF(Tdtbl.gt.0.or.Ixreg.gt.0.or.Kswv.gt.0)THEN CALL addate(Begdat,Sp,-Lfda,predat) DO irow=Lfda,Llda CALL addate(predat,Sp,irow,idate) year=idate(YR) period=idate(MO) c----------------------------------------------------------------------- c The calendar as we know it begins in October 1752. If we define c Sun=0, Mon=1, ..., Sat=6, then we would like to start our pattern c on the first leap year that start on a Sunday after 1753. This is c 1764. c----------------------------------------------------------------------- sdoyr=5*(year/4-441)+fouryr(mod(year,4)) cendsp=(year-1601)/100 cendsp=cendsp-cendsp/4-1 sdoyr=sdoyr-cendsp sdoyr=mod(sdoyr,7) c----------------------------------------------------------------------- IF((mod(year,100).ne.0.and.mod(year,4).eq.0).or.mod(year,400) & .eq.0)THEN lpyr=2 ELSE lpyr=1 END IF c----------------------------------------------------------------------- IF(Sp.eq.12)THEN sd=mod(sdoyr+fdomo(period,lpyr),7) nd=lnomo(period,lpyr) ELSE sd=mod(sdoyr+fdoqtr(period,lpyr),7) nd=lnoqtr(period,lpyr) END IF IF(sd.eq.0)sd=7 Tday(irow)=sd Xn(irow)=dble(float(nd)) Xnstar(irow)=dble(float(nd)) IF(Sp.eq.12)THEN IF(nd.eq.31)Tday(irow)=Tday(irow)+7 IF(nd.eq.28)Tday(irow)=Tday(irow)+14 IF(nd.eq.29)Tday(irow)=Tday(irow)+21 IF(period.eq.2)Xnstar(irow)=28.25D0 ELSE IF(nd.eq.92)Tday(irow)=Tday(irow)+7 IF(nd.eq.90)Tday(irow)=Tday(irow)+14 c changes suggested by NBB May 2004 IF(lpyr.eq.2.and.period.eq.1)Tday(irow)=Tday(irow)+21 IF(period.eq.1)Xnstar(irow)=90.25D0 c end of changes END IF Xlpyr(irow)=Xn(irow)-Xnstar(irow) END DO c----------------------------------------------------------------------- IF(Sp.eq.12)THEN Daybar=30.4375D0 ELSE Daybar=91.25D0 END IF c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- RETURN END tdtyp.cmn0000664006604000003110000000072614521201610012031 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Tdmdl,Tdmdl1,Lpmdl,Lpmdl1 INTEGER Tdtbl,Tday DIMENSION Tdmdl(PTD),Tdmdl1(PTD), & Tday(PLEN),Lpmdl(2),Lpmdl1(2) c----------------------------------------------------------------------- COMMON /tdtyp / Tdtbl,Tday COMMON /cmdltd / Tdmdl,Tdmdl1,Lpmdl,Lpmdl1 c----------------------------------------------------------------------- tdxtrm.f0000664006604000003110000001127414521201610011657 0ustar sun00315stepsC Last change: BCM 22 Jan 98 10:58 am SUBROUTINE tdxtrm(Sti,Faccal,Tday,Sigm,Kpart,Muladd,Fext,Irridx, & Irrend) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS ROUTINE inserts AO regression variables into the X-11 C --- REGRESSION Matrix for extreme irregulars c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'x11ptr.cmn' INCLUDE 'xclude.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO LOGICAL F,T PARAMETER(F=.false.,T=.true.,ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- DOUBLE PRECISION Sti,Sigm,tsd,Faccal,tdiff,tk,tmean,tcc,tirr,ex, & tkon,dvec INTEGER Tday,karray,i,m,kstd,Muladd,k,Kpart,Fext,Irridx,Irrend DIMENSION Sti(PLEN),Tday(PLEN),karray(PLEN),Faccal(PLEN),ex(PLEN), & tmean(28),tcc(28),dvec(1) c----------------------------------------------------------------------- c Set up logical vector of observations to exclude from regression c----------------------------------------------------------------------- dvec(1)=ZERO CALL setlg(.false.,PLEN,Rgxcld) Nxcld=0 c----------------------------------------------------------------------- CALL cpyint(Tday,Posfob,1,karray) CALL setdp(DNOTST,PLEN,ex) c----------------------------------------------------------------------- kstd=0 DO WHILE (kstd.lt.2) c----------------------------------------------------------------------- c If first time, calculate means for each type of month c----------------------------------------------------------------------- tsd=0 tk=0 IF(Kpart.eq.2)THEN c----------------------------------------------------------------------- c Initialize mean variables c----------------------------------------------------------------------- tkon=ONE IF(Muladd.eq.1)tkon=ZERO DO i=1,28 tcc(i)=ZERO IF(i.le.21)THEN tmean(i)=ZERO ELSE tmean(i)=tkon END IF END DO c----------------------------------------------------------------------- DO i=Irridx,Irrend m=karray(i) IF(m.lt.15)THEN tmean(m)=tmean(m)+Sti(i) tcc(m)=tcc(m)+ONE tk=tk+ONE ELSE IF(m.le.21)THEN DO k=15,21 tmean(k)=tmean(k)+Sti(i) tcc(k)=tcc(k)+ONE END DO tk=tk+ONE END IF END DO c----------------------------------------------------------------------- DO i=1,21 IF(tcc(i).gt.ZERO)tmean(i)=tmean(i)/tcc(i) END DO DO i=Irridx,Irrend m=karray(i) IF(m.le.21)THEN tdiff=Sti(i)-tmean(m) tsd=tsd+(tdiff*tdiff) END IF END DO c----------------------------------------------------------------------- ELSE c----------------------------------------------------------------------- C --- COMPUTE SQ.DEV. OF Irregular from Calendar effects c----------------------------------------------------------------------- DO i=Irridx,Irrend m=karray(i) IF(m.le.28)THEN tdiff=Sti(i)-Faccal(i) tsd=tsd+(tdiff*tdiff) tk=tk+ONE END IF END DO END IF tsd=sqrt(tsd/tk)*Sigm kstd=kstd+1 c----------------------------------------------------------------------- C --- IDENTIFY EXTREME IRREGULARS BY ADDING 28 TO TYPE CODE c----------------------------------------------------------------------- DO i=Irridx,Irrend m=karray(i) IF(m.le.28)THEN IF(Kpart.eq.2)THEN tirr=tmean(m) ELSE tirr=Faccal(i) END IF IF(abs(Sti(i)-tirr).gt.tsd)THEN karray(i)=karray(i)+28 ex(i)=Sti(i) Rgxcld(i-Irridx+1)=T Nxcld=Nxcld+1 END IF END IF END DO c----------------------------------------------------------------------- END DO c----------------------------------------------------------------------- c Print out table for extreme values c----------------------------------------------------------------------- IF(Prttab(Fext))CALL table(ex,Irridx,Irrend,14,1,5,dvec,Fext) IF(Savtab(Fext))CALL punch(ex,Irridx,Irrend,Fext,F,F) c----------------------------------------------------------------------- RETURN END templs.f0000664006604000003110000002264714521201610011647 0ustar sun00315stepsC Last change: BCM 2 Jun 1998 11:43 am SUBROUTINE templs(Lsrun,Rmse,Xpxinv,Prttls,Ldiag) IMPLICIT NONE c----------------------------------------------------------------------- c templs.f, Release 1, Subroutine Version 1.4, Modified 13 Mar 1995. c----------------------------------------------------------------------- c This subroutine computes t-statistics to test for temporary level c shifts, that is, to test whether a run of successive level shifts c have coefficient estimates that sum to something close to 0 (in the c sense that the sum is not statistically significantly different from c 0). These t-statistics are computed for all runs of 2 or more c successive level shifts up to a maximum of LSrun successive level c shifts. c Author: Bill Bell, SRD, 3/25/93 c c Input Arguments: c Name Type Definition c nls int number of level shifts c b dp nls x 1 vector of estimated level shift coefficients, c assumed to be arranged sequentially in time c V dp nls x nls variance-covariance matrix of b c nrowV int row dimension of the array V c title char nls x 1 character vector of labels of level shifts c LSrun int maximum number of successive level shifts used in c computing the t-statistics, i.e. if nls > LSrun, c then the largest number of level shifts would arise c in computing t-statistics for b(1) + ... + b(LSrun), c b(2) + ... + b(LSrun+1), ... , b(nls-LSrun+1) + ... c + b(nls) c Sometime in the future might want to put in an option to say that c only LS's within a certain time span (say 5 years) would be tested. c c 7/29/1999 (Matt Kramer) Bug corrected in this subroutine that c aborted the program from formatting problems. The problem c occurred if there was a request for temporary level shift tests, c lsrun > 2, and there were a large number of level shifts. c Excessive spacing was programmed. The fix involves introducing c a new variable, mxchr, which holds the length of the longest c character string used to identify individual outliers, and c calculating mxtlcr only at the end of the first DO loop. The c maximum number of successive level shifts that can be tested c is hardcoded in gtotlr.f (and in this subroutine at line 103 c for the fixed table width option). c----------------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION TWO PARAMETER(TWO=2D0) c----------------------------------------------------------------------- LOGICAL cmpstr,locok,Prttls,Ldiag CHARACTER fmt*(PSRSCR),str*(PCOLCR),tstttl*(PSRSCR) INTEGER baselt,begls,endls,i,icol,ils,ilstp,ipos,ipvt,ipvt2,j,jls, & jpvt,lspvt,Lsrun,lstls,lstp,mxtlcr,nchr,nls,ntest,otlidx, & mxchr,nlsrun DOUBLE PRECISION lsxpxi,Rmse,se,sumb,sumvar,tstat,Xpxinv DIMENSION lspvt(PB),lstp(PB),lsxpxi(PB*(PB+1)/2), & Xpxinv(Nb*(Nb+1)/2) EXTERNAL cmpstr c----------------------------------------------------------------------- c Find all the level shifts in the regression, both user-defined c and automatically identified. Then make an index of the columns c they are in. c----------------------------------------------------------------------- mxchr=0 nls=0 c ------------------------------------------------------------------ DO icol=1,Nb CALL getstr(Colttl,Colptr,Ncoltl,icol,str,nchr) IF(Lfatal)RETURN IF(cmpstr(NAME,'ls',str(1:2)))THEN CALL rdotlr(str(1:nchr),Begspn,Sp,otlidx,ilstp,endls,locok) c----------------------------------------------------------------------- c Sort the level shifts by time. This needs to be done because c they are found in two places. c----------------------------------------------------------------------- IF(locok.and.otlidx.eq.LS.AND.(.not.Regfx(icol)))THEN DO ils=1,nls IF(ilstp.lt.lstp(ils))THEN IF(ils.le.nls)THEN CALL cpyint(lspvt(ils),nls-ils+1,-1,lspvt(ils+1)) CALL cpyint(lstp(ils),nls-ils+1,-1,lstp(ils+1)) END IF c----------------------------------------------------------------------- GO TO 10 END IF END DO ils=nls+1 c----------------------------------------------------------------------- 10 lspvt(ils)=icol lstp(ils)=ilstp nls=nls+1 mxchr = max (nchr, mxchr) END IF END IF END DO c----------------------------------------------------------------------- c Check if there are runs of level-shifts to test. c----------------------------------------------------------------------- IF(Ldiag)THEN WRITE(Nform,1000)'lsrun: ',Lsrun IF(nls.le.1)THEN WRITE(Nform,1000)'nlsrun: ',0 ELSE ntest=min(nls,Lsrun) nlsrun=0 DO ntest=2,ntest DO begls=1,nls-ntest+1 nlsrun=nlsrun+1 END DO END DO WRITE(Nform,1000)'nlsrun: ',nlsrun END IF END IF IF(nls.le.1)RETURN 1000 FORMAT(a,i5) c----------------------------------------------------------------------- IF(Prttls)THEN mxtlcr = max (18, (min (Lsrun, nls) * mxchr) - 1) c mxtlcr = max (18, (7 * mxchr) - 1) ! for fixed width WRITE(fmt,1010)mxtlcr+2,mxtlcr+11 1010 FORMAT('(/,'' '',a,/,'' '',a,t',i2, & ',a,'' '',a, /,'' '',',i3, & '(''-''))') WRITE(Mt1,fmt)'Tests for Cancellation of Level Shifts', & 'Dates of LS Sets','Span','t-value' WRITE(fmt,1020)mxtlcr+1 1020 FORMAT('(2x,a,t',i2,',i5,f8.2)') END IF c----------------------------------------------------------------------- c Creat a sub matrix of inv(X'X) for i,j=1,nls c lsxpxi(i,j)=Xpxinv(ipvt,jpvt) c----------------------------------------------------------------------- DO i=1,nls ipvt=lspvt(i) c----------------------------------------------------------------------- DO j=1,i jpvt=lspvt(j) ipvt2=max(ipvt,jpvt) baselt=(ipvt2-1)*ipvt2/2 lsxpxi((i-1)*i/2+j)=Xpxinv(baselt+min(ipvt,jpvt)) END DO END DO c----------------------------------------------------------------------- c Loop over number of level shifts (k), from 2 to kk = min(nls, c LSrun). Initialize sumb (sum of the coefficient estimates) and c sumvar (variance of the sum of the coefficient estimates) to 0. c Then loop over starting level shift (m), from 1 to nls-k+1. c----------------------------------------------------------------------- ntest=min(nls,Lsrun) nlsrun=0 c----------------------------------------------------------------------- DO ntest=2,ntest IF(ntest.gt.2)WRITE(Mt1,*) DO begls=1,nls-ntest+1 endls=begls+ntest-1 ipvt=lspvt(begls) CALL getstr(Colttl,Colptr,Ncoltl,ipvt,str,nchr) IF(Lfatal)RETURN tstttl(1:nchr+3)=str(3:nchr)//'+' ipos=nchr-2+1+1 sumb=B(ipvt) baselt=begls*(begls+1)/2 sumvar=lsxpxi(baselt) c----------------------------------------------------------------------- c Sum the coefficient estimates b(m) + ... + b(m+k-1). Also c compute the variance of this sum and the corresponding t-statistic c (tstat). c----------------------------------------------------------------------- DO lstls=begls+1,endls ipvt=lspvt(lstls) sumb=sumb+B(ipvt) baselt=(lstls-1)*lstls/2 sumvar=sumvar+lsxpxi(baselt+lstls) c----------------------------------------------------------------------- DO jls=begls,lstls-1 sumvar=sumvar+TWO*lsxpxi(baselt+jls) END DO c----------------------------------------------------------------------- c Concatenate the titles of the level shifts being summed into tprt. c A maximum of 5 level shift titles can be printed on any one c line, so tprt is an array with each element used to store the c concatenated titles for up to 7 successive level shifts. c----------------------------------------------------------------------- CALL getstr(Colttl,Colptr,Ncoltl,ipvt,str,nchr) IF(Lfatal)RETURN tstttl(ipos:ipos+nchr)=str(3:nchr)//'+' ipos=ipos+nchr-1 END DO c----------------------------------------------------------------------- se=sqrt(sumvar)*Rmse tstat=sumb/se c----------------------------------------------------------------------- c Print out the results for this sum of level shifts (sumb,tstat). c----------------------------------------------------------------------- IF(Prttls) & WRITE(Mt1,fmt)tstttl(1:ipos-2),lstp(endls)-lstp(begls),tstat IF(Ldiag)THEN nlsrun=nlsrun+1 WRITE(Nform,1030)nlsrun,tstttl(1:ipos-2),' ', & lstp(endls)-lstp(begls),' ',tstat END IF END DO END DO c----------------------------------------------------------------------- 1030 FORMAT('lsspan',i2.2,': ',a,a,i3,a,e21.14) RETURN END testf1.i0000664006604000003110000000014614521201610011542 0ustar sun00315stepsC C... Variables in Common Block /testf1/ ... integer IFUNC1 common /testf1/ IFUNC1 test.i0000664006604000003110000000014014521201610011305 0ustar sun00315stepsC C... Variables in Common Block /test/ ... integer IFUNC common /test/ IFUNC testodf.f0000664006604000003110000003011714521201610012002 0ustar sun00315steps SUBROUTINE tstodf(Trnsrs,Frstry,Nefobs,A,Na,Lsumm,lpr,ldr,lqr, & lps,lds,lqs,Kstep,Lidotl,Lnoprt,FctOK,redoMD, & argok) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'mdldg.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'mdlsvl.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'extend.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION MALIM,ONE,TWO,ZERO,PT5 LOGICAL T,F PARAMETER(T=.true.,F=.false.,MALIM=0.001D0,ONE=1D0,TWO=2D0, & ZERO=0D0,PT5=0.05D0) c----------------------------------------------------------------------- CHARACTER effttl*(PCOLCR),cmonth*3,ordend*2 DOUBLE PRECISION Trnsrs,sumMA,A,xpxinv,tmp INTEGER disp,lpr,ldr,lps,lds,lqr,lqs,Frstry,Nefobs,Na,Lsumm,spm1, & cnote,i,ipos,icol,icol1,igrp,begcol,endcol,regidx, & nb2,nfix,nchr,nelt,j,Kstep LOGICAL Lidotl,Lnoprt,FctOK,redoMd,reReDoMd,argok DIMENSION Trnsrs(PLEN),A(*),cmonth(12),ordend(10),xpxinv(PXPX), & regidx(PB),tmp(2) c ------------------------------------------------------------------ DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA ordend/'th','st','nd','rd','th','th','th','th','th','th'/ c ------------------------------------------------------------------ DOUBLE PRECISION dpmpar INTEGER strinx EXTERNAL dpmpar,strinx c----------------------------------------------------------------------- c If model has nonseasonal diffencing and MA, check for c overdifferencing by seeing if sum of MA parameters is close to 1. c----------------------------------------------------------------------- redoMd=F reReDoMd=F IF (ldr.gt.0 .and. lqr.gt.0) THEN IF(Prttab(LAUFNT))write(Mt1,1011) & ' Checking for nonseasonal overdifferencing.' disp=lpr+ldr+lps+lds sumMa=ZERO do i = disp+1,disp+lqr sumMa = sumMa + Arimap(i) end do c----------------------------------------------------------------------- c Reduce by one the number of nonseasonal differences, nonseasonal c MA terms in the model, and add a constant term. c----------------------------------------------------------------------- IF (ABS(sumMA-ONE).lt.MALIM) THEN redoMd=T IF(Prttab(LAUFNT))write(Mt1,1010) & ' Reduce order of nonseasonal MA, nonseasonal differencing.' ldr=ldr-1 lqr=lqr-1 IF(Prttab(LAUFNT))WRITE(Mt1,1020) lpr,ldr,lqr,lps,lds,lqs icol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(icol.eq.0)THEN IF(Lchkmu)THEN IF(Prttab(LAUFNT))write(Mt1,1010)' Add constant term.' CALL adrgef(DNOTST,'Constant','Constant',PRGTCN,F,F) IF(Lfatal)RETURN ELSE cnote=Mt1 IF(Lnoprt.and.(.not.Prttab(LAUFNT)))cnote=0 CALL writln('NOTE: Due to a reduction in the order of '// & 'regular differencing, a constant term', & cnote,Mt2,T) CALL writln(' should be added to the regARIMA model.', & cnote,Mt2,F) CALL writln(' Either rerun the spec file with '// & 'checkmu = yes in the automdl spec, or', & cnote,Mt2,T) CALL writln(' add a constant regressor to the '// & 'regARIMA model via the regression spec.', & cnote,Mt2,F) END IF END IF END IF END IF c----------------------------------------------------------------------- c If model has seasonal diffencing and MA, check for c overdifferencing by seeing if sum of seasonal MA parameters is c close to 1. c----------------------------------------------------------------------- IF (lds.gt.0 .and. lqs.gt.0 .and. Lsovdf) THEN IF(Prttab(LAUFNT))write(Mt1,1011) & ' Checking for seasonal overdifferencing.' disp=lpr+ldr+lps+lds+lqr sumMa=ZERO do i = disp+1,disp+lqs sumMa = sumMa + Arimap(i) end do c----------------------------------------------------------------------- c Reduce by one the number of nonseasonal differences, nonseasonal c MA terms in the model, and add a constant term. c----------------------------------------------------------------------- IF (ABS(sumMA-ONE).lt.MALIM) THEN IF(.not.redoMd)redoMd=T IF(Prttab(LAUFNT))write(Mt1,1010) & ' Reduce order of seasonal MA, seasonal differencing.' lds=lds-1 lqs=lqs-1 IF(Prttab(LAUFNT))WRITE(Mt1,1020) lpr,ldr,lqr,lps,lds,lqs IF(Prttab(LAUFNT))write(Mt1,1010)' Add seasonal regressors.' spm1=Sp-1 c ------------------------------------------------------------------ IF(Sp.eq.12)THEN DO i=1,spm1 effttl=cmonth(i) nchr=3 CALL adrgef(DNOTST,effttl(1:nchr),'Seasonal',PRGTSE,F,T) IF(Lfatal)RETURN END DO c ------------------------------------------------------------------ ELSE DO i=1,spm1 ipos=1 CALL itoc(i,effttl,ipos) IF(Lfatal)RETURN IF(mod(i,100).ge.11.and.mod(i,100).le.13)THEN effttl(ipos:ipos+1)='th' ELSE effttl(ipos:ipos+1)=ordend(mod(i,10)) END IF nchr=ipos+1 CALL adrgef(DNOTST,effttl(1:nchr),'Seasonal',PRGTSE,F,T) IF(Lfatal)RETURN END DO END IF IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c re-estimate model. c----------------------------------------------------------------------- IF(redoMD)THEN CALL mdlint() CALL mdlset(lpr,ldr,lqr,lps,lds,lqs,argok) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If automatic outliers are identified for the model, eliminate the c outliers from the model (BCM April 2007) c----------------------------------------------------------------------- IF(Natotl.gt.0)THEN CALL clrotl(Nrxy) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) IF(Prttab(LAUFNT))WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Redo automatic outlier identification (BCM April 2007) c----------------------------------------------------------------------- IF(Lidotl.and.(.not.Lotmod))THEN CALL amidot(A,Trnsrs,Frstry,Nefobs,Priadj,Convrg,Fctok,Argok) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Check if mean term added is significant. c If not, remove and re-estimate model. c Added by B C Monsell Aug 2018 c----------------------------------------------------------------------- IF(Lchkmu)THEN CALL chkmu(Trnsrs,A,Nefobs,Na,Frstry,kstep,Prttab(LAUFNT)) IF(Lfatal)RETURN icol1=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Constant') IF(icol1.eq.0)reReDoMd=T END IF c----------------------------------------------------------------------- c Check if seasonal regressors added are significant. c If not, remove and re-estimate model. c Added by B C Monsell Aug 2018 c----------------------------------------------------------------------- IF(Lsovdf)THEN icol=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Seasonal') IF(icol.gt.0)THEN c ------------------------------------------------------------------ c Generate number of unfixed regressors c ------------------------------------------------------------------ nb2=Nb IF(Iregfx.ge.2)THEN DO j=1,Nb IF(Regfx(j))nb2=nb2-1 END DO END IF c----------------------------------------------------------------------- c Get the X'X inverse. c----------------------------------------------------------------------- IF(nb2.gt.0)THEN nelt=(nb2+1)*(nb2+2)/2 IF(Var.gt.TWO*dpmpar(1))THEN CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,nb2,tmp,1) END IF END IF c----------------------------------------------------------------------- c set up regidx variable c----------------------------------------------------------------------- nfix=0 DO igrp=1,Ngrp begcol=Grp(igrp-1) endcol=Grp(igrp)-1 DO icol=begcol,endcol IF(Regfx(icol))THEN nfix=nfix+1 regidx(icol)=NOTSET ELSE regidx(icol)=icol-nfix END IF END DO END DO c----------------------------------------------------------------------- c Generate F-test for seasonal F-test c----------------------------------------------------------------------- CALL sftest(Xpxinv,Regidx,Prttab(LAUFNT),F,F,F) c----------------------------------------------------------------------- c generate p-value limit, c remove seasonal regressors if not significant c----------------------------------------------------------------------- IF(Sfpv.gt.PT5)THEN igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Seasonal') begcol=Grp(igrp-1) endcol=Grp(igrp)-1 CALL dlrgef(begcol,Nrxy,endcol-begcol+1) IF(Prttab(LAUFNT)) & write(Mt1,1010)'Seasonal regressors removed from model' END IF icol1=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Seasonal') IF(icol1.eq.0)reReDoMd=T END IF END IF c----------------------------------------------------------------------- c Re-estimate model if c----------------------------------------------------------------------- IF(reReDoMd)THEN CALL rgarma(Lestim,Mxiter,Mxnlit,F,a,na,nefobs,argok) IF(.not.Lfatal)THEN CALL prterr(nefobs,T) IF(.not.Convrg)THEN WRITE(STDERR,1090) IF(Prttab(LAUFNT))WRITE(Mt1,1090) WRITE(Mt2,1090) CALL abend() ELSE IF(.not.argok)THEN CALL abend() END IF END IF IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- ELSE IF(Prttab(LAUFNT))WRITE(Mt1,1040)MALIM END IF c----------------------------------------------------------------------- 1010 FORMAT(' ',a) 1011 FORMAT(/,' ',a) 1020 FORMAT(' ',2(' (',i2,',',i2,',',i2,')')) 1090 FORMAT(/,' ERROR: Estimation failed to converge during the ', & 'automatic model', & /,' identification procedure.') 1040 FORMAT(' Nonseasonal MA not within ',f6.3,' of 1.0 - model ', & 'passes test.') c----------------------------------------------------------------------- RETURN ENDtests.cmn0000664006604000003110000000054014521201610012021 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Fstabl,Fmove,Fpres,Chikw,P1,P2,P3,P5,Test1,Test2 INTEGER Iqfail c----------------------------------------------------------------------- COMMON /tests / Fstabl,Fmove,Fpres,Chikw,P1,P2,P3,P5,Test1,Test2, & Iqfail tfmts2.prm0000664006604000003110000000172514521201612012127 0ustar sun00315steps CHARACTER TF2DIC*752 INTEGER tf2ptr,PTF2 PARAMETER(PTF2=24) DIMENSION tf2ptr(0:PTF2) PARAMETER(TF2DIC='(2x,i4,3x,3(3(@,a):,/,9x),3(@,a),4x,#)(1x,a5,3x, &3(3(@,a):,/,9x),3(@,a))(2x,i4,4x,3(@,a):,/,9x,@,a,35x,#)(1x,a5,4x, &3(@,a):,/,9x,@,a1)(2x,i4,3x,2(4(@,a):,/,9x),4(@,a),3x,#)(1x,a5,3x, &2(4(@,a):,/,9x),4(@,a))(2x,i4,3x,4(@,a),3x,#)(1x,a5,3x,4(@,a))(2x, &i4,4x,2(4(5x,@,a):,/,9x),4(5x,@,a),10x,#)(1x,a5,4x,2(4(5x,@,a):,/, &9x),4(5x,@,a))(2x,i4,4x,4(5x,@,a),10x,#)(1x,a5,4x,4(5x,@,a))(2x,i4 &,4x,6(@,a):,/,10x,6(@,a),4x,#)(1x,a5,4x,6(@,a):,/,10x,6(@,a))(2x,i &4,4x,6(@,a):,/,10x,6(@,a),4x,#)(1x,a5,4x,6(@,a):,/,10x,6(@,a))(2x, &i4,4x,8(@,a):,/,10x,4(@,a),56x,#)(1x,a5,4x,8(@,a):,/,10x,4(@,a))(2 &x,i4,4x,12(@,a),4x,#)(1x,a5,4x,12(@,a))(2x,i4,3x,5(2(@,a):,/,9x),2 &(@,a),4x,#)(1x,a5,3x,5(2(@,a):,/,9x),2(@,a)))(2x,i4,3x,2(@,a):,/,9 &x,2(@,a),4x,#)(1x,a5,3x,2(@,a):,/,9x,2(@,a))') tfmts2.var0000664006604000003110000000017714521201613012122 0ustar sun00315steps DATA tf2ptr / 1,39,72,105,133,171,204,226,243,288,327,353,373,409, &440,476,507,544,575,598,616,654,688,723,753 / tfmts3.f0000664006604000003110000000340514521201613011555 0ustar sun00315stepsC Last change: BCM 22 Dec 97 4:32 pm SUBROUTINE tfmts3(Outdec,Muladd,Tblwid,Lwidpr,Ifmt3) IMPLICIT NONE c----------------------------------------------------------------------- c Generate format for summary statistics at the end of the printout c----------------------------------------------------------------------- INCLUDE 'error.cmn' c----------------------------------------------------------------------- CHARACTER Ifmt3*132,wid*2,wid2*2 LOGICAL Lwidpr INTEGER Outdec,fac,Muladd,ipos,ipos2,Tblwid,wid3 c----------------------------------------------------------------------- fac=Outdec IF(Muladd.eq.0.or.Muladd.eq.2.and.fac.eq.0)fac=2 ipos=1 ipos2=1 CALL itoc(Tblwid+2,wid,ipos) IF(.not.Lfatal)CALL itoc(Tblwid+4,wid2,ipos2) IF(Lfatal)RETURN ipos=ipos-1 ipos2=ipos2-1 IF(Lwidpr)THEN wid3=Tblwid+40 WRITE(Ifmt3,1010)wid2(1:ipos2),fac,wid(1:ipos),fac,wid(1:ipos), & fac,wid3,wid(1:ipos),fac,wid(1:ipos),fac 1010 FORMAT('(/,15x,''Table Total- '',f',a,'.',i1,',8x,''Mean- '',f', & a,'.',i1,',8x,''Std. Deviation- '',f',a,'.',i1,',/,',i2, & 'x,''Min - '',f',a,'.',i1,',18x,''Max - '',f',a,'.',i1,')') ELSE wid3=Tblwid+22 WRITE(Ifmt3,1020)wid2(1:ipos2),fac,wid(1:ipos),fac,wid(1:ipos), & fac,wid3,wid(1:ipos),fac,wid(1:ipos),fac 1020 FORMAT('(/, 2x,''Table Total- '',f',a,'.',i1,',3x,''Mean- '',f', & a,'.',i1,',3x,''Std. Dev.- '',f',a,'.',i1,',/,',i2, & 'x,''Min - '',f',a,'.',i1,',8x,''Max - '',f',a,'.',i1,')') END IF c----------------------------------------------------------------------- RETURN END tfmts.cmn0000664006604000003110000000102514521201610012013 0ustar sun00315stepsc----------------------------------------------------------------------- CHARACTER Ifmt1*110,Ifmt2*110,Ifmt3*132,Fmtcol*110,Colhdr*22 INTEGER Iptr,Tblcol,Tblwid,Nfmt1,Nfmt2,Disp1,Disp2,Disp3 DIMENSION Colhdr(PSP+2) c----------------------------------------------------------------------- COMMON /tfmt / Iptr,Tblcol,Tblwid,Nfmt1,Nfmt2,Ifmt1,Ifmt2,Ifmt3 COMMON /tfmtd / Disp1,Disp2,Disp3 COMMON /colhdr/ Fmtcol,Colhdr c-----------------------------------------------------------------------tfmts.f0000664006604000003110000001657414521201610011502 0ustar sun00315stepsC Last change: BCM 30 Sep 1998 9:09 am **==tfmts.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 SUBROUTINE tfmts(Ny,Outdec,Maxy,Miny,Muladd,Lwidpr,Readok) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE GENERATES THE FORMATS FOR SUBROUTINE TABLES. c as well as column headers. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'tfmts.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- c Include data dictionary of table formats c----------------------------------------------------------------------- INCLUDE 'tfmts.prm' c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- DOUBLE PRECISION Miny,Maxy LOGICAL Lwidpr,Readok INTEGER Ny,Outdec,Muladd,obswid,fac,ipos,ipos2,ifmt,npos,itmp CHARACTER blnk*22,cmonth*3,cqtr*3,fbase*110,fobs*5,fsum*5,stmp*3 DIMENSION cmonth(12),cqtr(4) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA cqtr/'1st','2nd','3rd','4th'/ c----------------------------------------------------------------------- INCLUDE 'tfmts.var' c----------------------------------------------------------------------- c --- initialize format variables to blanks. c----------------------------------------------------------------------- CALL setchr(' ',110,Ifmt1) CALL setchr(' ',110,Ifmt2) c----------------------------------------------------------------------- c --- set formats for TABLE subroutine. First, determine how wide the c --- data should be c----------------------------------------------------------------------- IF(Muladd.eq.1.and.abs(Miny).gt.Maxy)THEN obswid=int(log10(abs(Miny)))+Outdec+3 ELSE IF(dpeq(Maxy,0D0))THEN obswid=Outdec+3 ELSE obswid=int(log10(Maxy))+Outdec+3 END IF END IF IF(Muladd.eq.0.or.Muladd.eq.2)THEN fac=Outdec+4 IF(Outdec.eq.0)fac=fac+2 IF(fac.gt.obswid)obswid=fac END IF c----------------------------------------------------------------------- c --- Set the number of observations per line and the width of the c --- obsertions to be printed out according to the observation width. c----------------------------------------------------------------------- IF(obswid.le.8)THEN Tblcol=6 Tblwid=8 ELSE IF(obswid.le.12)THEN Tblcol=4 Tblwid=12 ELSE IF(obswid.le.15)THEN Tblcol=3 Tblwid=15 ELSE IF(obswid.le.21)THEN Tblcol=2 Tblwid=21 ELSE CALL writln('ERROR: Data too large for '//PRGNAM// & ' print format.',STDERR,Mt2,T) CALL writln( & ' Try dividing the series by power of 10, or use the', & STDERR,Mt2,F) CALL writln(' divpower argument found in the series and com &posite specs.',STDERR,Mt2,F) Readok=F RETURN c Tblcol=3 c Tblwid=15 END IF IF(Lwidpr)Tblcol=Tblcol*2 IF(Ny.eq.4.and.Tblcol.gt.4)THEN Tblcol=4 IF(Lwidpr)THEN Tblwid=15 ELSE IF(Tblwid.le.12)THEN Tblwid=12 ELSE IF (Tblwid.eq.15)THEN Tblcol=3 ELSE Tblcol=2 END IF END IF c----------------------------------------------------------------------- c Construct the two formats c----------------------------------------------------------------------- IF(Tblcol.eq.3)THEN Iptr=1 ELSE IF(Tblcol.eq.4)THEN Iptr=5 ELSE IF(Tblcol.eq.6)THEN Iptr=13 ELSE IF(Tblcol.eq.8)THEN Iptr=17 ELSE IF(Tblcol.eq.12)THEN Iptr=19 ELSE IF(Tblcol.eq.2)THEN Iptr=21 END IF IF(Ny.eq.4)Iptr=Iptr+2 IF(Lwidpr.and.Tblcol.eq.4.and.Tblwid.le.15)Iptr=Iptr+4 IF(Lwidpr.and.Tblcol.eq.6)Iptr=Iptr+2 c----------------------------------------------------------------------- c set up observation formats c----------------------------------------------------------------------- IF(Tblwid.gt.9)then write(fobs,1010)Tblwid,Outdec 1010 format('f',i2,'.',i1) ifmt=5 ELSE write(fobs,1020)Tblwid,Outdec 1020 format('f',i1,'.',i1) ifmt=4 end if write(fsum,1010)Tblwid+2,Outdec fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,Ifmt1,fobs(1:ifmt),fsum,ipos,Nfmt1) fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr+1,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,Ifmt2,fobs(1:ifmt),fsum,ipos,Nfmt2) c----------------------------------------------------------------------- c Generate displacement indexes c----------------------------------------------------------------------- Disp1=4 IF(Iptr.eq.1.or.Iptr.eq.5.or.Iptr.eq.7.or.Iptr.ge.21)Disp1=3 Disp2=1 IF(Iptr.eq.9.or.Iptr.eq.11)Disp2=6 Disp3=4 IF(Iptr.eq.3)THEN Disp3=35 ELSE IF(Iptr.eq.17)THEN Disp3=56 ELSE IF(Iptr.eq.5.or.Iptr.eq.7)THEN Disp3=3 ELSE IF(Iptr.eq.9.or.Iptr.eq.11)THEN Disp3=10 END IF c----------------------------------------------------------------------- c Generate format for summary statistics at the end of the printout c----------------------------------------------------------------------- CALL tfmts3(Outdec,Muladd,Tblwid,Lwidpr,Ifmt3) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Generate vector for column headers. First, construct format for c column headings. c----------------------------------------------------------------------- if(Tblwid.gt.9)then write(fobs,1050)Tblwid 1050 format('a',i2) ifmt=3 else write(fobs,1060)Tblwid 1060 format('a',i1) ifmt=2 end if write(fsum,1050)Tblwid+2 fbase=' ' CALL getstr(TFMDIC,tfmptr,PTFM,Iptr,fbase,ipos) IF(Lfatal)RETURN CALL cnvfmt(fbase,Fmtcol,fobs(1:ifmt),fsum(1:3),ipos,npos) Fmtcol(1:npos)=Ifmt2(1:6)//Fmtcol(7:npos) c----------------------------------------------------------------------- c Set hdr array to be the name of the month or quarter c----------------------------------------------------------------------- CALL setchr(' ',22,blnk) Colhdr(1)=blnk DO ipos=1,Ny ipos2=ipos+1 Colhdr(ipos2)=blnk IF(Ny.eq.12)THEN Colhdr(ipos2)((Tblwid-3):(Tblwid-1))=cmonth(ipos) ELSE IF(Ny.eq.4)THEN Colhdr(ipos2)((Tblwid-3):(Tblwid-1))=cqtr(ipos) ELSE itmp=1 CALL itoc(ipos,stmp,itmp) Colhdr(ipos2)((Tblwid-itmp):(Tblwid-1))=stmp(1:(itmp-1)) END IF END DO c----------------------------------------------------------------------- RETURN END tfmts.prm0000664006604000003110000000175014521201611012042 0ustar sun00315steps CHARACTER TFMDIC*771 INTEGER tfmptr,PTFM PARAMETER(PTFM=24) DIMENSION tfmptr(0:PTFM) PARAMETER(TFMDIC='(2x,i4,3x,3(3(1x,@):,/,9x),3(1x,@),4x,#)(1x,a5,3 &x,3(3(1x,@):,/,9x),3(1x,@))(2x,i4,4x,3(1x,@):,/,11x,@,35x,#)(1x,a5 &,4x,3(1x,@):,/,11x,@)(2x,i4,3x,2(4(1x,@):,/,9x),4(1x,@),3x,#)(1x,a &5,3x,2(4(1x,@):,/,9x),4(1x,@))(2x,i4,3x,4(1x,@),3x,#)(1x,a5,3x,4(1 &x,@))(2x,i4,4x,2(4(6x,@):,/,9x),4(6x,@),10x,#)(1x,a5,4x,2(4(6x,@): &,/,9x),4(6x,@))(2x,i4,4x,4(6x,@),10x,#)(1x,a5,4x,4(6x,@))(2x,i4,4x &,6(1x,@):,/,10x,6(1x,@),4x,#)(1x,a5,4x,6(1x,@):,/,10x,6(1x,@))(2x, &i4,4x,6(1x,@):,/,10x,6(1x,@),4x,#)(1x,a5,4x,6(1x,@):,/,10x,6(1x,@) &)(2x,i4,4x,8(1x,@):,/,10x,4(1x,@),56x,#)(1x,a5,4x,8(1x,@):,/,10x,4 &(1x,@))(2x,i4,4x,12(1x,@),4x,#)(1x,a5,4x,12(1x,@))(2x,i4,3x,5(2(1x &,@):,/,9x),2(1x,@),4x,#)(1x,a5,3x,5(2(1x,@):,/,9x),2(1x,@)))(2x,i4 &,3x,2(1x,@):,/,9x,2(1x,@),4x,#)(1x,a5,3x,2(1x,@):,/,9x,2(1x,@))') tfmts.var0000664006604000003110000000017714521201611012036 0ustar sun00315steps DATA tfmptr / 1,41,76,109,136,176,211,234,252,293,328,352,370,408, &441,479,512,551,584,608,627,667,703,740,772 / title.cmn0000664006604000003110000000251314521201614012006 0ustar sun00315stepsC----------------------------------------------------------------------- c Newpag - character that sets new page c Title - Title printed on each page of output c Serno - Name of series c Ttlfmt - format for title C----------------------------------------------------------------------- CHARACTER Newpg*1,Title*(80),Serno*(64),Ttlfmt*(37) C----------------------------------------------------------------------- c Kpage - page number c Ntitle - length of title vector c Nser - length of series name C----------------------------------------------------------------------- INTEGER Kpage,Ntitle,Nser C----------------------------------------------------------------------- c Lpage - logical variable which indicates if a title will be c printed on each page c Lwdprt - logical variable which indicates if a wide printout c (132 characters) will be done C----------------------------------------------------------------------- LOGICAL Lpage,Lwdprt,Prt1ps,Lcmpaq C----------------------------------------------------------------------- COMMON /rote / Kpage,Ntitle,Nser,Lpage,Lwdprt,Prt1ps,Lcmpaq, & Newpg COMMON /crote / Title,Serno,Ttlfmt C----------------------------------------------------------------------- titl.i0000664006604000003110000000014714521201613011314 0ustar sun00315stepsC C... Variables in Common Block /titl/ ... character TITLEG*80 common /titl/ TITLEG totals.f0000664006604000003110000000372514521201614011651 0ustar sun00315stepsC Last change: BCM 26 Aug 1998 4:08 pm **==totals.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 DOUBLE PRECISION FUNCTION totals(X,I,J,K,Iopt) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS FUNCTION CALCULATES TOTALS AND AVERAGES. A TOTAL IS RETURNED C --- IF IOPT IS ZERO, AN AVERAGE IF IOPT IS ONE, and the absolute c average if IOPT is TWO. c----------------------------------------------------------------------- c revised by BCM March 2006 to handle cases where "bad" values for c multiplicative seasonal adjustment are found and missing values c in the series, and added an additonal value of IOPT to return the c number of "good" observations (IOPT = 3) c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE PARAMETER(ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'notset.prm' c----------------------------------------------------------------------- DOUBLE PRECISION fn,X INTEGER I,Iopt,J,K,l DIMENSION X(*) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- totals=ZERO fn=ZERO DO l=I,J,K * IF((.not.(Missng.and.X(l).eq.Mvval).and.Gudval(l))THEN IF(.not.dpeq(X(l),DNOTST))THEN IF(Iopt.eq.2)THEN totals=totals+abs(X(l)) ELSE IF(Iopt.lt.3)THEN totals=totals+X(l) END IF IF(Iopt.ne.0)fn=fn+ONE END IF END DO c----------------------------------------------------------------------- IF(Iopt.eq.3)THEN totals=fn ELSE IF(Iopt.ne.0)THEN IF(fn.gt.ZERO)THEN totals=totals/fn ELSE totals=DNOTST END IF END IF RETURN END transcad.i0000664006604000003110000000040614521201614012136 0ustar sun00315stepsc TransCad.i c TransLcad="TRANSITORY" or "TD-STOCHASTIC" c TransCad="TRANS" or "TD.Stoch" character*20 transLcad,transCad integer nTransLcad,nTransCad common /transCad/ transLCad,TransCad,nTransLcad,nTransCadtransc.f0000664006604000003110000001403314521201614011627 0ustar sun00315stepsC*==transc.f processed by SPAG 6.01Fc at 13:51 on 29 Jan 1999 C C subroutine TRANS2(P,Nn,X,M,N) C C PARAMETROS DE ENTRADA: C M = EL PRIMER INDICE DE PARAMETROS MENOS UNO C N = EL ULTIMO INDICE DE PARAMETROS C C IMPLICIT NONE C*--******************************************************************** CA OUTPUT - P CA INPUT - NN CA INPUT - X CA INPUT - M CA INPUT - N C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C calls ** NOTHING ** C called by ESFICH3 C modifies ** NOTHING ** C uses value ** NOTHING ** C local vars ALPH C D DELTA DISC E I C ICOUNT IROOT J S Y C uses PARAMs *** NONE **** C*++******************************************************************** C C*** Start of declarations rewritten by SPAG C C Dummy arguments C C C.. Implicits .. implicit none C C.. Formal Arguments .. integer Nn real*8 P(Nn) real*8 X(Nn) integer M integer N C C.. Local Scalars .. integer I,Icount,Iroot,J real*8 D,Delta,Disc,E,S,Y C C.. Local Arrays .. real*8 Alph(3),C(3) C C.. Intrinsic Functions .. intrinsic ABS, SQRT C C*** End of declarations rewritten by SPAG C C **** Start of Executable Program C C TO TRANSFORM SEARCH PARAMETERS INTO MODEL PARAMETERS C J = N - M Iroot = J if (J .lt. 2) then C(1) = X(N) Alph(1) = C(1) else if (J .eq. 2) then C(1) = X(M+1) * (1.0d0-X(N)) C(2) = X(N) Disc = C(1)**2 + 4.0d0*C(2) if (Disc .ge. 0.0d0) then Disc = SQRT(Disc) Alph(1) = 0.5d0 * (C(1)+Disc) Alph(2) = 0.5d0 * (C(1)-Disc) else Iroot = 0 end if else S = (2.0d0*X(M+1)-1.0d0) * (1.0d0-X(N)) D = (1.0d0+X(N)) * ((1.0d0+X(M+1))*(1.0d0+X(M+2))-1.0d0) C(1) = 0.5d0 * (S+D) C(2) = 0.5d0 * (S-D) C(3) = X(N) C C TO FIND REAL ROOTS OF X**3-C(1)*X**2-C(2)*X-C(3)=0. C PUT X=Y+C(1)/3. EQUATION BECOMES Y**3-D*Y-E=0 C FIND ROOT BY NEWTON-RAPHSON C D = C(1)*C(1)/3.0d0 + C(2) E = (2.0d0*C(1)**3+9.0d0*C(1)*C(2))/27.0d0 + C(3) Disc = 4.0d0*D**3 - 27.0d0*E**2 if (Disc .gt. 0.0d0) then Y = -E/D else if (E .gt. 0.0d0) then Y = 1 - C(1)/3 else Y = -1 - C(1)/3 end if Icount = 0 do while (.true.) Delta = (Y**3-D*Y-E) / (3.0d0*Y*Y-D) Y = Y - Delta if (ABS(Delta) .le. 0.00005d0) goto 1000 Icount = Icount + 1 if (Icount .gt. 10) then 7000 format (/,' CUBIC ITERATIONS EXCEEDED') write (7,7000) goto 1000 end if end do goto 1005 1000 Alph(1) = Y C C TEST IF ALL ROOTS ARE REAL C if (Disc .ge. 0.0d0) then C C ROOTS REAL.DIVIDE BY (Y-ALPH(1)) C Y**2+ALPH(1)*Y+E/ALPH(1)=0 C Disc = SQRT(Alph(1)**2-4.0d0*E/Alph(1)) Alph(2) = 0.5d0 * (-Alph(1)+Disc) Alph(3) = 0.5d0 * (-Alph(1)-Disc) else Iroot = 1 end if do I = 1,Iroot Alph(I) = Alph(I) + C(1)/3.0d0 end do end if 1005 do I = 1,N-M P(M+I) = -C(I) end do end C*==trans1.f processed by SPAG 6.01Fc at 13:51 on 29 Jan 1999 C C SUBROUTINE TRANSFORMS PARAMETER VALUES WITHIN GROUPS C C PHITH = ARRAY OF MODEL PARAMETERS E.G.THETA PARAMETERS C NPQ = NO OF ELEMENTS IN FITH C X = ARRAY OF TRANSFORMED PARAMETERS C XMIN = MINIMUM BOUNDS FOR X C XMAX = MAXIMUM BOUNDS FOR X C IB = POSITION OF FIRST TRANSFORMED MODEL PARAMETER WITHIN X C IE = POSITION OF LAST TRANSFORMED MODEL PARAMETER WITHIN X C C subroutine TRANS0(P,Nn,X,Ib,Ie,Iprs,Ur,Xl) C IMPLICIT NONE C*--******************************************************************** CA INPUT - P CA INPUT - NN CA OUTPUT - X CA INPUT - IB CA INPUT - IE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C calls ** NOTHING ** C called by ESFICH3 C modifies ** NOTHING ** C uses value /DIM/ /TRAN/ IPRS UR XL C local vars I J NPQ PHITH XMAX XMIN C XTEST C uses PARAMs *** NONE **** C*++******************************************************************** C C*** Start of declarations rewritten by SPAG C C COMMON variables C C C.. Implicits .. implicit none C C.. Formal Arguments .. integer Nn real*8 P(Nn) real*8 X(Nn) integer Ib,Ie,Iprs DOUBLE PRECISION Xl,Ur C C.. Local Scalars .. integer I,J,Npq real*8 Xmax,Xmin,Xtest C C.. Local Arrays .. real*8 Phith(3) C C.. Intrinsic Functions .. intrinsic ABS, SIGN C C*** End of declarations rewritten by SPAG C C--- C- C EXPLORE C C **** Start of Executable Program C Xmin = -XL Xmax = XL Npq = Ie - Ib + 1 do I = 1,Npq Phith(I) = -P(Ib+I-1) end do if (Npq .le. 1) then X(Ib) = Phith(1) else if (Npq .le. 2) then if (ABS(1.0d0-Phith(2)) .lt. 1.0d-9) then Phith(2) = UR end if X(Ib) = Phith(1) / (1.0d0-Phith(2)) X(Ie) = Phith(2) else if (ABS(Phith(3)-1.0d0) .lt. 1.0d-9) then Phith(3) = SIGN(UR,Phith(3)) end if X(Ib) = 0.5d0 * ((Phith(1)+Phith(2))/(1.0d0-Phith(3))+1.0d0) X(Ib+1) = (1.0d0+(Phith(1)-Phith(2))/(1.0d0+Phith(3))) if (ABS(X(Ib)+1.0d0) .lt. 1.0d-9) then X(Ib) = -UR end if X(Ib+1) = X(Ib+1)/(1.0d0+X(Ib)) - 1.0d0 X(Ie) = Phith(3) end if do J = Ib,Ie Xtest = (X(J)-Xmin) / (Xmax-Xmin) if (Xtest .lt. 0.01d0) then if (J .le. IPRS) then X(J) = -UR else X(J) = Xmin end if end if if (Xtest .gt. 0.99d0) then if (J .le. IPRS) then X(J) = UR else X(J) = Xmax end if end if end do C 12 CONTINUE end trbias.f0000664006604000003110000000351014521201614011617 0ustar sun00315stepsC Last change: BCM 25 Nov 97 3:29 pm **==trbias.f processed by SPAG 4.03F at 12:44 on 11 Aug 1994 SUBROUTINE trbias(Stc,Sts,Sti,L1,L2,Biasfc,Ny) IMPLICIT NONE c----------------------------------------------------------------------- c This routine corrects for bias in a trend component genrated from c a log-additive seasonal adjustment (see Thompson and Ozaki, 1992) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' c----------------------------------------------------------------------- DOUBLE PRECISION Stc,Sts,Sti,hs,sig,Biasfc,tic23 INTEGER i,L1,L2,Ny DIMENSION Stc(PLEN),Sts(PLEN),Sti(PLEN),Biasfc(PLEN),hs(PLEN) c----------------------------------------------------------------------- c Evaluate characteristic function of the irregular. c----------------------------------------------------------------------- c initialize sig - July 2006 BCM c ------------------------------------------------------------------ sig=0D0 DO i=L1,L2 sig=sig+Sti(i)*Sti(i) END DO sig=exp(sig/(2D0*(L2-L1+1))) c----------------------------------------------------------------------- c Smooth the seasonal factors using a 23 (or 7, if quarterly) term c Henderson filter. c----------------------------------------------------------------------- tic23=4.5D0 CALL hndtrn(hs,Sts,L1,L2,(2*Ny)-1,tic23,.true.,.false.) c----------------------------------------------------------------------- c Perform bias correction. c----------------------------------------------------------------------- DO i=L1,L2 Biasfc(i)=sig*hs(i) Stc(i)=Stc(i)*Biasfc(i) END DO c----------------------------------------------------------------------- RETURN END trnaic.f0000664006604000003110000004345314521201614011625 0ustar sun00315stepsC Last change: SRD 19 Nov 99 6:37 am SUBROUTINE trnaic(Lx11,Lmodel,Lprt,Lprtfm) IMPLICIT NONE c----------------------------------------------------------------------- c Estimate regARIMA model for the untransformed and log transformed c series. The routine will choose the model with the lowest value c of AICC and print out the resulting model. c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO LOGICAL F,T INTEGER DIV PARAMETER(ONE=1D0,ZERO=0D0,DIV=4,F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'arima.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'adj.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' INCLUDE 'extend.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'notset.prm' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' INCLUDE 'title.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'mdlsvl.i' INCLUDE 'mq3.cmn' c----------------------------------------------------------------------- INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c----------------------------------------------------------------------- LOGICAL Lprt,lhide,argok,Lprtfm,Lx11,rok,lam2,lad2,lax2,Lmodel, & begrgm,inptok DOUBLE PRECISION a,a2,aicno,aiclog,lomeff,Maxsrs,Minsrs,Temp, & trnsrs INTEGER Frstry,kf2,na,Nefobs,nbeg,nend,endlag,ilag,fhnote DIMENSION Temp(PLEN),a(PA),lomeff(PLEN),trnsrs(PLEN),a2(PLEN), & begrgm(PLEN) c----------------------------------------------------------------------- INTEGER nblank,strinx EXTERNAL nblank,strinx c----------------------------------------------------------------------- COMMON /maxmin/ Maxsrs,Minsrs COMMON /work / Temp c----------------------------------------------------------------------- c Set up Fcntyp and Lam to do no transformation c----------------------------------------------------------------------- Fcntyp=4 Lam=ONE Ixreg=-Ixreg CALL setdp(ONE,PLEN,lomeff) CALL copy(Adj,PLEN,1,a2) fhnote=STDERR IF(Lquiet)fhnote=0 c----------------------------------------------------------------------- c Generate leap year effect for possible later use. c----------------------------------------------------------------------- IF(Picktd.and.Lmodel)THEN IF(Lrgmtd.AND.(MOD(Tdzero,2).ne.0))THEN CALL gtrgpt(Begadj,Tddate,Tdzero,begrgm,Nadj) ELSE CALL setlg(T,PLEN,begrgm) END IF IF(Kfulsm.eq.2)THEN CALL td7var(Begadj,Sp,Nadj,1,1,T,F,T,lomeff,begrgm) ELSE CALL td7var(Begadj,Sp,Nadj,1,1,F,F,T,lomeff,begrgm) END IF END IF c----------------------------------------------------------------------- c Change Begspn and Endspn to match the model span, if necessary. c----------------------------------------------------------------------- CALL dfdate(Begmdl,Begspn,Sp,nbeg) CALL dfdate(Endspn,Endmdl,Sp,nend) IF(nbeg.gt.0)CALL cpyint(Begmdl,2,1,Begspn) IF(nend.gt.0)CALL cpyint(Endmdl,2,1,Endspn) c----------------------------------------------------------------------- c Process the series c----------------------------------------------------------------------- CALL dfdate(Endspn,Begspn,Sp,Nspobs) Nspobs=Nspobs+1 IF(nbeg.gt.0.or.nend.gt.0.or.Issap.eq.2)THEN CALL dfdate(Begspn,Begsrs,Sp,Frstsy) Frstsy=Frstsy+1 Nomnfy=Nobs-Frstsy+1 Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nomnfy) END IF CALL copy(Orig(Pos1ob+nbeg),Nobspf,-1,trnsrs) c----------------------------------------------------------------------- c If no model specified or automatic model specified, use default c model (0 1 1)(0 1 1) or (0 1 1). c----------------------------------------------------------------------- IF((.not.Lmodel).OR.Lautom.or.Lautox)THEN inptok=T CALL mdlint() IF(Lmodel.and.Lseff)THEN CALL mdlset(0,1,1,0,0,0,inptok) ELSE CALL mdlset(0,1,1,0,1,1,inptok) END IF IF((.not.inptok).or.Lfatal)THEN WRITE(STDERR,1070) WRITE(Mt2,1070) RETURN END IF END IF c----------------------------------------------------------------------- c Set up the regression matrix c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Estimate the regression and ARMA parameters c----------------------------------------------------------------------- lax2=Lautox Lautox=F lam2=Lautom Lautom=F lad2=Lautod Lautod=F argok=Lautom CALL rgarma(T,Mxiter,Mxnlit,F,a,na,Nefobs,argok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0)THEN WRITE(STDERR,1071)'untransformed' WRITE(Mt1,1071)'untransformed' WRITE(Mt2,1071)'untransformed' CALL prterr(nefobs,F) CALL abend() RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the first model c----------------------------------------------------------------------- IF(.not.Lprt)THEN lhide=Lhiddn Lhiddn=T END IF IF(Lprt)WRITE(Mt1,1010) CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,F) IF(Lfatal)RETURN aicno=Aicc IF(Svltab(LSLTRN))WRITE(Ng,1011)Aicc IF(Lsumm.gt.0)WRITE(Nform,1012)'nolog',Aicc c----------------------------------------------------------------------- c Restore initial values to model variables c----------------------------------------------------------------------- c CALL restor(T,F,F) IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Perform log transformation on series, and reset indicator c variables accordingly c----------------------------------------------------------------------- Fcntyp=1 Lam=ZERO Adjmod=1 CALL setdp(ONE,PLEN,Adj) c----------------------------------------------------------------------- c If model has TD, perform leap year prior adjustment c----------------------------------------------------------------------- IF(Lmodel.and.Picktd)THEN c----------------------------------------------------------------------- c Remove leap year regressor c----------------------------------------------------------------------- CALL rmlnvr(Priadj,Kfulsm,Nobs) c----------------------------------------------------------------------- c Leap Year adjust original series, if necessary. c----------------------------------------------------------------------- kf2=Kfmt c----------------------------------------------------------------------- c Perform leap year adjustment c----------------------------------------------------------------------- CALL addate(Begspn,Sp,-Nbcst,Begadj) Nadj=Nspobs+Nbcst+max(Sp,Nfcst-Fctdrp) CALL eltfcn(DIV,Y(Frstsy),lomeff,Nspobs,PLEN,trnsrs) CALL copy(lomeff,PLEN,1,Adj) CALL dfdate(Begspn,Begadj,Sp,Adj1st) Adj1st=Adj1st+1 END IF IF(Lmvaft.or.Ln0aft)THEN CALL trnfcn(trnsrs,Nspobs,Fcntyp,Lam,trnsrs) ELSE CALL trnfcn(trnsrs,Nobspf,Fcntyp,Lam,trnsrs) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c estimate model for log transformation c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,F) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0)THEN WRITE(STDERR,1071)'log transformed' WRITE(Mt1,1071)'log transformed' WRITE(Mt2,1071)'log transformed' CALL prterr(nefobs,F) CALL abend() RETURN END IF c----------------------------------------------------------------------- c Compute and print out the likelihood statistics and AICC for the c model with TD c----------------------------------------------------------------------- IF(Lprt)WRITE(Mt1,1020) CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,Lprtfm) IF(Lfatal)RETURN aiclog=Aicc IF(Svltab(LSLTRN))WRITE(Ng,1021)Aicc IF(Lsumm.gt.0)WRITE(Nform,1012)'log',Aicc IF(.not.Lprt)Lhiddn=lhide c----------------------------------------------------------------------- c Reset beginning and ending dates for span, if necessary. c----------------------------------------------------------------------- IF(nbeg.gt.0.or.nend.gt.0) & CALL setspn(Sp,nend,nbeg,Begspn,Endspn,Begmdl,Endmdl,Nspobs, & Frstsy,Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy, & Begadj,Adj1st) c----------------------------------------------------------------------- IF((aiclog+Traicd).lt.aicno)THEN IF(Lprt)THEN WRITE(Mt1,1030)Traicd IF(Lx11)WRITE(Mt1,1031) WRITE(Mt1,1032) END IF IF(Svltab(LSLTRN))THEN IF(Lmodel)THEN WRITE(Ng,1033)'Log Transformation' ELSE WRITE(Ng,1033)'Multiplicative Seasonal Adjustment' END IF END IF c----------------------------------------------------------------------- c Set up variables used in X-11 for prior adjustment (if this model c has td). c----------------------------------------------------------------------- IF(nbeg.gt.0.or.nend.gt.0)THEN Nadj=Nspobs+Nbcst+max(Sp,Nfcst-Fctdrp) IF(Picktd)CALL copy(lomeff,PLEN,1,Adj) END IF c----------------------------------------------------------------------- CALL copy(Adj,Nadj,-1,Sprior(Setpri)) IF(Lmodel.and.Picktd)THEN CALL ssprep(T,F,F) IF(Kfmt.eq.0)THEN Kfmt=1 Prmser='LPY' IF(Kfulsm.lt.2)THEN Prmser='LPY' ELSE IF(Sp.eq.12)THEN Prmser='LOM' ELSE IF(Sp.eq.4)THEN Prmser='LOQ' END IF END IF END IF END IF c----------------------------------------------------------------------- c redo table formats c----------------------------------------------------------------------- CALL tfmts(Sp,Kdec,Maxsrs,Minsrs,0,Lwdprt,rok) c----------------------------------------------------------------------- c If X-11 seasonal adjustment to be performed, set Muladd c----------------------------------------------------------------------- Muladd=0 Tmpma=0 Pcdif='percent change ' Rad='ratios ' c----------------------------------------------------------------------- c Re-initialize several variable used in program to 1.0 instead of c 0.0 c----------------------------------------------------------------------- CALL setdp(ONE,PLEN,Sts) CALL setdp(ONE,PLEN,Stsi) CALL setdp(ONE,PLEN,Sti) CALL setdp(ONE,PLEN,Stptd) CALL setdp(ONE,PLEN,Temp) CALL setdp(ONE,PLEN,Factd) CALL setdp(ONE,PLEN,Facao) CALL setdp(ONE,PLEN,Facls) CALL setdp(ONE,PLEN,Factc) CALL setdp(ONE,PLEN,Facso) CALL setdp(ONE,PLEN,Facsea) CALL setdp(ONE,PLEN,Facusr) CALL setdp(ONE,PLEN,Fachol) CALL setdp(ONE,PLEN,Facxhl) CALL setdp(ONE,PLEN,X11hol) CALL setdp(ONE,PLEN,Faccal) c----------------------------------------------------------------------- IF(Ln0aft.or.Lmvaft)THEN CALL writln('NOTE: At least one value that is either less than o &r equal to zero or',fhnote,Mt2,T) CALL writln(' equal to the missing value code was found aft &er the span of data',fhnote,Mt2,F) CALL writln(' to be analyzed, but within the time frame of &the forecasts',fhnote,Mt2,F) CALL writln(' generated by the regARIMA model.',fhnote,Mt2, & F) CALL writln(' In this situation, the forecast output will n &ot include a',fhnote,Mt2,T) CALL writln(' comparison of the transformed forecasts with &the corresponding',fhnote,Mt2,F) CALL writln(' values of the transformed original series.', & fhnote,Mt2,F) END IF c----------------------------------------------------------------------- ELSE IF(Lprt)THEN WRITE(Mt1,1040)Traicd IF(Lx11)WRITE(Mt1,1041) WRITE(Mt1,1032) END IF IF(Svltab(LSLTRN))THEN IF(Lmodel)THEN WRITE(Ng,1033)'No Transformation' ELSE WRITE(Ng,1033)'Additive Seasonal Adjustment' END IF END IF Fcntyp=4 Lam=ONE Adjmod=2 Priadj=1 IF(Ln0aft)Ln0aft=F IF(Lmvaft)THEN CALL writln('NOTE: At least one value that is either less than o &r equal to zero or',fhnote,Mt2,T) CALL writln(' equal to the missing value code was found aft &er the span of data',fhnote,Mt2,F) CALL writln(' to be analyzed, but within the time frame of &the forecasts',fhnote,Mt2,F) CALL writln(' generated by the regARIMA model.',fhnote,Mt2, & F) CALL writln(' In this situation, the forecast output will n &ot include a',fhnote,Mt2,T) CALL writln(' comparison of the forecasts with the correspo &nding values of the',fhnote,Mt2,F) CALL writln(' original series.',fhnote,Mt2,F) END IF CALL setdp(ZERO,PLEN,Adj) CALL copy(Orig(Pos1ob+nbeg),Nobspf,-1,trnsrs) c----------------------------------------------------------------------- c If the first model is better, restore original series and c reset LOM variables, if no td in first model c----------------------------------------------------------------------- IF(Lmodel)THEN IF(Picktd)THEN CALL adrgef(DNOTST,'Leap Year','Leap Year',PRGTLY,F,F) IF(Lfatal)RETURN CALL copy(a2,PLEN,1,Adj) Kfmt=kf2 END IF END IF END IF c----------------------------------------------------------------------- Lautox=lax2 Lautom=lam2 Lautod=lad2 IF(Lsumm.gt.0)THEN IF(Lmodel)CALL prtnfn(Fcntyp,Lam,2) IF(Lx11)THEN IF(Muladd.eq.0)THEN WRITE(Nform,1050)'multiplicative' ELSE WRITE(Nform,1050)'additive' END IF END IF END IF c----------------------------------------------------------------------- Ixreg=-Ixreg c----------------------------------------------------------------------- 1010 FORMAT(//, & ' Likelihood statistics for model fit to untransformed series.') 1011 FORMAT(' AICC(no log) : ',f15.4) 1012 FORMAT('aictest.trans.aicc.',a,': ',e29.15) 1020 FORMAT(//, &' Likelihood statistics for model fit to log transformed series.') 1021 FORMAT(' AICC(log) : ',f15.4) 1030 FORMAT(//,' ***** AICC (with aicdiff=',F5.2, & ') prefers log transformation *****') 1031 FORMAT(' ***** Multiplicative seasonal adjustment will be perf &ormed. ****') 1032 FORMAT(//) 1033 FORMAT(/,' Automatic transformation test : ',a) 1040 FORMAT(//,' ***** AICC (with aicdiff=',F5.2, & ') prefers no transformation *****') 1041 FORMAT(' ***** Additive seasonal adjustment will be performed. & ****') 1050 FORMAT('finmode: ',a) 1070 FORMAT(/,' ERROR: Unable to set up ARIMA model for automatic ', & 'transformation selection',/, & ' procedure for the reason(s) given above.') 1071 FORMAT(/,' Estimation error found during automatic ', & 'transformation selection', & /,' procedure while fitting regARIMA model to the ',a, & ' series.') c----------------------------------------------------------------------- RETURN END trnfcn.f0000664006604000003110000001214114521201614011625 0ustar sun00315stepsC Last change: BCM 14 May 1998 8:45 am SUBROUTINE trnfcn(Y,Nsrs,Fcntyp,Lam,Trny) c----------------------------------------------------------------------- c trnfcn.f, Release 1, Subroutine Version 1.5, Modified 07 Nov 1994. c----------------------------------------------------------------------- c Box-Cox Transformation, of y, 1 to nsrs, and putting in the c result in trny. Transformation is: c trny=y , lam=1 c trny=ln(y) , lam=0, y>0 c trny=lam^2+(y^lam-1)/lam, lam<>0 or 1, y>0 c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c lam d Box-Cox transformation parameter c lstop l Logical to call abend() c nsrs i Length of the vectors c trny d Transformed vector of length nsrs c y d Vector to be transformed length nsrs c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'stdio.i' INCLUDE 'units.cmn' c ------------------------------------------------------------------ LOGICAL T,F INTEGER PSTOP DOUBLE PRECISION ZO,ONE PARAMETER(ZO=0.0D0,ONE=1.0D0,T=.true.,F=.false.,PSTOP=10) c ------------------------------------------------------------------ LOGICAL lstop INTEGER Fcntyp,i,Nsrs,nstop DOUBLE PRECISION Lam,tmp,Trny(Nsrs),Y(Nsrs) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- c Initialize lstop to call abend() c are found. c----------------------------------------------------------------------- lstop=F nstop=0 c----------------------------------------------------------------------- c Lam=0, log transformation if y>0 c----------------------------------------------------------------------- IF(Fcntyp.eq.3)THEN DO i=1,Nsrs tmp=Y(i) IF(tmp.gt.ZO.and.tmp.lt.ONE)THEN Trny(i)=log(tmp/(ONE-tmp)) c ------------------------------------------------------------------ ELSE WRITE(STDERR,1010)'take the logit of',i,tmp WRITE(Mt2,1010)'take the logit of',i,tmp 1010 FORMAT(/,' ERROR: Cannot ',a,' a proportion not in the range ', & '(0,1), y(',i5,')=',1p,g16.8,'.',/) lstop=T nstop=nstop+1 IF(nstop.gt.PSTOP)THEN WRITE(STDERR,1030) WRITE(Mt2,1030) CALL abend() RETURN END IF END IF END DO c----------------------------------------------------------------------- c Lam=1, no transformation, just copy the vector c----------------------------------------------------------------------- ELSE IF(dpeq(Lam,ONE))THEN DO i=1,Nsrs Trny(i)=Y(i) END DO c----------------------------------------------------------------------- c Lam=0, log transformation if y>0 c----------------------------------------------------------------------- ELSE IF(dpeq(Lam,ZO))THEN DO i=1,Nsrs IF(Y(i).gt.ZO)THEN Trny(i)=log(Y(i)) c ------------------------------------------------------------------ ELSE IF(Y(i).lt.ZO)THEN WRITE(STDERR,1020)'log of a negative number',i,Y(i) WRITE(Mt2,1020)'log of a negative number',i,Y(i) ELSE WRITE(STDERR,1020)'log of zero',i,Y(i) WRITE(Mt2,1020)'log of a zero',i,Y(i) END IF 1020 FORMAT(' ERROR: Do not take ',a,', y(',i5,')=',1p,g16.8,'.') lstop=T nstop=nstop+1 IF(nstop.gt.PSTOP)THEN WRITE(STDERR,1030) WRITE(Mt2,1030) CALL abend() RETURN END IF END IF END DO c----------------------------------------------------------------------- c Lam not equal to 1 or 0 c----------------------------------------------------------------------- ELSE DO i=1,Nsrs IF(Y(i).gt.ZO)THEN Trny(i)=Lam**2+(Y(i)**Lam-ONE)/Lam c ------------------------------------------------------------------ ELSE WRITE(STDERR,1020)'BoxCox transform',i,Y(i) WRITE(Mt2,1020)'BoxCox transform',i,Y(i) lstop=T nstop=nstop+1 IF(nstop.gt.PSTOP)THEN WRITE(STDERR,1030) WRITE(Mt2,1030) CALL abend() RETURN END IF END IF END DO END IF c ------------------------------------------------------------------ IF(lstop)CALL abend() c ------------------------------------------------------------------ 1030 FORMAT(' ERROR: Maximum number of errors printed. More errors ', & 'may exist, but',/, & ' will not be specified. The above values ', & 'cannot be processed.') c ------------------------------------------------------------------ RETURN END tstdrv.f0000664006604000003110000000623214521201614011665 0ustar sun00315steps DOUBLE PRECISION FUNCTION tstdrv(Igrp) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO,TWO,TWOPT5 PARAMETER(ZERO=0D0,TWO=2D0,TWOPT5=2.5D0) c ------------------------------------------------------------------ DOUBLE PRECISION rmse,seb,xpxinv,tmp,sumb,sumvar INTEGER nb2,j,nelt,nfix,begcol,endcol,icol,regidx,Igrp,baselt,jcol DIMENSION regidx(PB),xpxinv(PB*(PB+1)/2),tmp(2) c ------------------------------------------------------------------ DOUBLE PRECISION dpmpar LOGICAL dpeq EXTERNAL dpeq,dpmpar c ------------------------------------------------------------------ c Generate number of unfixed regressors c ------------------------------------------------------------------ tstdrv=ZERO nfix=0 DO j=1,Nb IF(Regfx(j))THEN nfix=nfix+1 regidx(j)=NOTSET ELSE regidx(j)=j-nfix END IF END DO nb2=Nb-nfix c----------------------------------------------------------------------- c Get the root mean square error and X'X inverse. c----------------------------------------------------------------------- IF(nb2.gt.0)THEN nelt=(nb2+1)*(nb2+2)/2 IF(Var.gt.2D0*dpmpar(1))THEN rmse=sqrt(Var) CALL copy(Chlxpx,nelt,1,xpxinv) CALL dppdi(xpxinv,nb2,tmp,1) c---------------------------------------------------------------------- ELSE rmse=ZERO END IF ELSE rmse=ZERO END IF IF(dpeq(rmse,ZERO))RETURN c ------------------------------------------------------------------ c generate t-statistics for regressors c ------------------------------------------------------------------ begcol=Grp(Igrp-1) endcol=Grp(Igrp)-1 sumb=-B(begcol) baselt=0 IF(Regfx(begcol))THEN sumvar=0D0 ELSE baselt=regidx(begcol)*(regidx(begcol)+1)/2 sumvar=xpxinv(baselt) END IF c----------------------------------------------------------------------- IF(begcol.eq.endcol)THEN sumb=sumb*TWOPT5 IF(baselt.gt.0)seb=(sqrt(sumvar)*rmse)*TWOPT5 c----------------------------------------------------------------------- ELSE DO icol=begcol+1,endcol sumb=sumb-B(icol) IF(.not.Regfx(icol))THEN nelt=icol-nfix baselt=(regidx(icol)-1)*regidx(icol)/2 sumvar=sumvar+xpxinv(baselt+regidx(icol)) DO jcol=begcol,icol-1 IF(regidx(jcol).ne.NOTSET) & sumvar=sumvar+TWO*xpxinv(baselt+regidx(jcol)) END DO END IF END DO IF(baselt.gt.0)seb=sqrt(sumvar)*rmse END IF c----------------------------------------------------------------------- IF(baselt.gt.0)tstdrv=sumb/seb c----------------------------------------------------------------------- RETURN END tstmd1.f0000664006604000003110000002350014521201614011550 0ustar sun00315stepsC Last change: SRD 31 Jan 100 7:10 am SUBROUTINE tstmd1(Trnsrs,Frstry,A,Na,Nefobs,Pdfm,Rsddfm,Rtval, & Lpr,Lps,Lqr,Lqs,Ldr,Lds,Lmu,Lprt,Aici0,Pcktd0, & Adj0,Trns0,Tair) IMPLICIT NONE c ------------------------------------------------------------------ LOGICAL F,T PARAMETER (T=.true.,F=.false.) c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'arima.cmn' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' INCLUDE 'adj.cmn' INCLUDE 'inpt.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION A,tval,cval,Pdfm,Rsddfm,Rtval,rtv,fct0,pami,blq, & rsdami,fct2,Trnsrs,Tair,Adj0,Trns0 LOGICAL pcktd0,inptok,Lmu,Lprt INTEGER ipr,ips,idr,ids,iqr,iqs,id,ip,iq,iprs,iqrs,n,iopr, & Aici0,ilag,dipr,dips,diqr,diqs,Ldr,Lds,bldf, & Frstry,Na,Nefobs,iround,Lpr,Lps,Lqr,Lqs,ichk,i1dfm,i2dfm DIMENSION tval(PARIMA),A(PLEN+2*PORDER),Trnsrs(PLEN),Tair(2), & Adj0(*),Trns0(*) c ------------------------------------------------------------------ LOGICAL dpeq EXTERNAL dpeq c ------------------------------------------------------------------ c Convert X-13A-S model variables into variables compatable with c TRAMO/SEATS model data structure c ------------------------------------------------------------------ CALL cnvmdl(ipr,ips,idr,ids,iqr,iqs,id,ip,iq,iprs,iqrs,n) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Check to see if default model had at least one significant c coefficient. If not, exit c ------------------------------------------------------------------ i1dfm=1 IF (Sp.GT.1) THEN i2dfm=1 ELSE IF (Sp.EQ.1) THEN i2dfm=0 END IF IF (DABS(Tair(1)).LT.1.96D0) i1dfm=0 IF (Sp.GT.1.AND.DABS(Tair(2)).LT.1.96D0) i2dfm=0 IF ((idr.EQ.1.AND.ids.EQ.1.AND.Sp.GT.1.AND.iqr.EQ.1.AND. & iqs.EQ.1.AND.ipr.EQ.0.AND.ips.EQ.0).OR. & (idr.EQ.1.AND.Sp.EQ.1.AND.iqr.EQ.1.AND.ipr.EQ.0).OR. & (i1dfm+i2dfm.EQ.0)) RETURN c ------------------------------------------------------------------ c Estimate model c ------------------------------------------------------------------ inptok=T iround=1 10 CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,inptok) IF(Lfatal)RETURN IF(iround.gt.1)CALL ssprep(T,F,F) c----------------------------------------------------------------------- c generate t-statistics for ARMA parameters c----------------------------------------------------------------------- CALL armats(tval) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Check to see if there are insig lags c if so, decrease model order. c continue testing until model has no insig lags c----------------------------------------------------------------------- iopr=0 cval=1.8D0 dipr=0 dips=0 diqr=0 diqs=0 DO WHILE (T) ilag=0 IF(ipr.gt.dipr)THEN IF(dabs(tval(ipr-dipr)).lt.cval)THEN dipr=dipr+1 ilag=ilag+1 END IF END IF IF(ips.gt.dips)THEN IF(dabs(tval(iprs-dips)).lt.cval)THEN dips=dips+1 ilag=ilag+1 END IF END IF IF(iqr.gt.diqr)THEN IF(dabs(tval(iprs+iqr-diqr)).lt.cval)THEN diqr=diqr+1 ilag=ilag+1 END IF END IF IF(ips.gt.dips)THEN IF(dabs(tval(iprs+iqrs-diqs)).lt.cval)THEN diqs=diqs+1 ilag=ilag+1 END IF END IF IF(ilag.lt.1)GO TO 9999 END DO 9999 iopr=iopr+dipr+dips+diqr+diqs IF(iopr.eq.1.and.iprs+iqrs.gt.0.and.iround.eq.1)THEN iround=iround+1 IF (dipr.EQ.1) THEN ipr=ipr-1 ELSE IF (dips.EQ.1) THEN ips=ips-1 ELSE IF (diqr.EQ.1) THEN iqr=iqr-1 ELSE iqs=iqs-1 END IF c----------------------------------------------------------------------- c initialize X-13A-S model stats with new model order so the new c model can be estimated. c----------------------------------------------------------------------- inptok=T CALL mdlint() CALL mdlset(ipr,idr,iqr,ips,ids,iqs,inptok) IF(.not.Lfatal.and.inptok)GO TO 10 RETURN END IF c----------------------------------------------------------------------- IF(iround.gt.1)THEN IF(Lprt)THEN WRITE(Mt1,1010) & ' Due to insignificant ARMA coefficients, model changed to' WRITE(Mt1,1020) ipr,idr,iqr,ips,ids,iqs END IF CALL mkmdsn(ipr,idr,iqr,ips,ids,iqs,Bstdsn,Nbstds) IF(Lfatal)RETURN IF(Lpr.ne.ipr)Lpr=ipr IF(Lps.ne.ips)Lps=ips IF(Lqr.ne.iqr)Lqr=iqr IF(Lqs.ne.iqs)Lqs=iqs IF(Ldr.ne.idr)Ldr=idr IF(Lds.ne.ids)Lds=ids END IF c----------------------------------------------------------------------- c generate residual statisics c----------------------------------------------------------------------- CALL mdlchk(A,Na,Nefobs,pami,blq,bldf,rsdami,rtv) fct2=1.0D0 fct0=1.025D0 ichk=0 IF(pami.LT..95D0.AND.Pdfm.LT..75D0.AND.rsddfm.LT.rsdami)THEN * write(Mt1,991)pami,rsdami,pdfm,rsddfm ichk=1 ELSE IF(pami.LT..95D0.AND.Pdfm.LT..75D0.AND.Pdfm.LT.pami.AND. & rsddfm.LT.fct0*rsdami)THEN * write(Mt1,992)pami,rsdami,fct0,pdfm,rsddfm ichk=2 ELSE IF(pami.GE..95D0.AND.Pdfm.LT..95D0.AND. & rsddfm.LT.fct2*rsdami)THEN * write(Mt1,993)pami,rsdami,fct0,pdfm,rsddfm ichk=3 ELSE IF(Idr.EQ.0.AND.Ids.EQ.1.AND.Ipr.EQ.1.AND.Arimap(2).GE. & 0.82D0.AND.Ips.EQ.0.AND.Iqr.LE.1.AND.Iqs.EQ.1)THEN * write(Mt1,994)Arimap(2) ichk=4 ELSE IF(Idr.EQ.1.AND.Ids.EQ.0.AND.Ipr.EQ.0.AND.Arimap(2).GE. & 0.65D0.AND.Ips.EQ.1.AND.Iqr.EQ.1.AND.Iqs.LE.1)THEN * write(Mt1,994)Arimap(2) ichk=5 END IF c & iround.eq.1.and.iopr.gt.1)THEN IF(ichk.eq.0)THEN * write(Mt1,991)pami,rsdami,pdfm,rsddfm ELSE IF(ichk.gt.0)THEN * WRITE(Mt1,1000)ichk idr=1 ids=1 ipr=0 ips=0 iqr=1 iqs=1 IF(Sp.EQ.1)THEN ids=0 iqs=0 END IF IF(Lpr.ne.ipr)Lpr=ipr IF(Lps.ne.ips)Lps=ips IF(Lqr.ne.iqr)Lqr=iqr IF(Lqs.ne.iqs)Lqs=iqs IF(Ldr.ne.idr)Ldr=idr IF(Lds.ne.ids)Lds=ids inptok=T CALL mdlint() CALL mdlset(ipr,idr,iqr,ips,ids,iqs,inptok) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF((Pcktd0.and.(.not.Picktd)).or. & ((.not.Pcktd0).and.Picktd))THEN CALL copy(adj0,PLEN,1,Adj) CALL copy(trns0,PLEN,1,Trnsrs) CALL copy(Adj,Nadj,-1,Sprior(Setpri)) IF(.not.(Fcntyp.eq.4.OR.dpeq(Lam,1D0)))THEN IF(Pcktd0)THEN IF(Kfmt.eq.0)Kfmt=1 IF(.not.Lpradj)Lpradj=T ELSE IF(Nustad.eq.0.and.Nuspad.eq.0)THEN Kfmt=0 IF(Lpradj)Lpradj=F END IF END IF END IF END IF Aicind=Aici0 c----------------------------------------------------------------------- CALL bkdfmd(F) CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,F) IF(Lprt)THEN WRITE(Mt1,1010)' Model changed to default model' WRITE(Mt1,1020) Ipr,Idr,Iqr,Ips,Ids,Iqs END IF CALL mkmdsn(ipr,idr,iqr,ips,ids,iqs,Bstdsn,Nbstds) IF(Lfatal)RETURN IF((.not.Lmu).and.Rtval.gt.1.96D0)THEN IF(Lprt)WRITE(Mt1,1010)' Mean is signficant.' IF(Lchkmu)THEN Lmu=T CALL adrgef(DNOTST,'Constant','Constant',PRGTCN,F,F) IF(.not.Lfatal) & CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,Frstry,T,F) IF(.not.Lfatal) & CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,inptok) IF(.not.Lfatal)CALL prterr(Nefobs,T) IF(Lfatal)RETURN END IF CALL ssprep(T,F,F) ELSE IF(Lprt)WRITE(Mt1,1030) WRITE(Mt2,1030) END IF END IF c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- * 991 format(' pami = ',f10.3,' rsdami = ',e15.10,/, * & ' pdfm = ',f10.3,' rsddfm = ',e15.10) * 992 format(' pami = ',f10.3,' rsdami = ',e15.10,' fct0 = ',f5.3, * & /,' pdfm = ',f10.3,' rsddfm = ',e15.10) * 993 format(' pami = ',f10.3,' rsdami = ',e15.10,' fct2 = ',f5.3, * & /,' pdfm = ',f10.3,' rsddfm = ',e15.10) * 994 format(' arimap(2) = ',f10.5) * 1000 FORMAT(' ichk (auto versus default model) = ',i3) 1010 FORMAT(' ',a) 1020 FORMAT(' ',2(' (',i2,',',i2,',',i2,')')) 1030 FORMAT(' WARNING: A significant mean term will not be added ', & 'to the model since',/, & ' the automdl argument checkmu was set to ', & 'no in the input',/, & ' specification file.') END c----------------------------------------------------------------------- tstmd2.f0000664006604000003110000001144414521201615011556 0ustar sun00315stepsc Last change:Mar. 2021- if there are errors when calling armats, c return SUBROUTINE tstmd2(Nnsig,Nz,Ipr,Iqr,Ips,Iqs) IMPLICIT NONE c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'error.cmn' c ------------------------------------------------------------------ LOGICAL inptok DOUBLE PRECISION bmin,cval,tval,cmin,cv INTEGER i,ardsp,iurpr,iurps,iurqr,iurqs,Nnsig,Ipr,Ips,idr,ids,Iqr, & Iqs,id,ip,iq,iprs,iqrs,n,icpr,icps,icqr,icqs,Nz DIMENSION tval(PARIMA) c ------------------------------------------------------------------ c Initialize variables c ------------------------------------------------------------------ Nnsig=0 cval=Tsig IF (Nz.LE.150) THEN cmin=.15D0 ELSE cmin=.1D0 END IF ardsp=Nnsedf+Nseadf c ------------------------------------------------------------------ c Convert X-13A-S model variables into variables compatable with c TRAMO/SEATS model data structure c ------------------------------------------------------------------ CALL cnvmdl(Ipr,Ips,idr,ids,Iqr,Iqs,id,ip,iq,iprs,iqrs,n) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Check for unit roots. Do not reduce order of time series model c if unit roots are present. c ------------------------------------------------------------------ CALL chkurt(iurpr,iurps,iurqr,iurqs) c ------------------------------------------------------------------ c Generate t-values for ARMA parameters c ------------------------------------------------------------------ CALL armats(tval) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Check to see if t-values for the ARMA parameters are insignificant c ------------------------------------------------------------------ icpr=0 icps=0 icqr=0 icqs=0 bmin=-DNOTST c ------------------------------------------------------------------ c If there are insignificant paramters, reduce model order. c ------------------------------------------------------------------ IF(Iurpr.eq.0.and.Ipr.gt.icpr)THEN i=Ipr-icpr cv=DABS(tval(i)) IF (cv.LT.cval.AND.DABS(Arimap(i+ardsp)).LT.cmin) THEN icpr=icpr+1 IF (bmin.GT.cv) bmin=cv END IF END IF IF (Ips.GT.icps.AND.Iurps.EQ.0) THEN i=iprs-icps cv=DABS(tval(i)) IF (cv.LT.cval.AND.DABS(Arimap(i+ardsp)).LT.cmin) THEN icps=icps+1 IF (bmin.GT.cv) THEN bmin=cv icpr=0 END IF END IF END IF IF (Iqr.GT.icqr.AND.Iurqr.EQ.0) THEN i=iprs+Iqr-icqr cv=DABS(tval(i)) IF (cv.LT.cval.AND.DABS(Arimap(i+ardsp)).LT.cmin) THEN icqr=icqr+1 IF (bmin.GT.cv) THEN bmin=cv icpr=0 icps=0 END IF END IF END IF IF (Iqs.gt.icqs.AND.Iurqs.EQ.0) THEN i=iprs+iqrs-icqs cv=DABS(tval(i)) IF (cv.LT.cval.AND.DABS(Arimap(i+ardsp)).LT.cmin) THEN icqs=icqs+1 IF (bmin.GT.cv) THEN bmin=cv icpr=0 icps=0 icqr=0 END IF END IF END IF Nnsig=Nnsig+icpr+icps+icqr+icqs IF(((iprs+iqrs).EQ.1).OR.((iurpr+iurps+iurqr+iurqs).GT.0)) & Nnsig=0 IF (Nnsig.GE.1) THEN IF (icpr.GE.1) THEN DO WHILE (.TRUE.) DO i=Ipr,n-1 Arimap(i+ardsp)=Arimap(i+1+ardsp) END DO Ipr=Ipr-1 icpr=icpr-1 IF (icpr.LE.0) GO TO 10 END DO ELSE IF (icps.GE.1) THEN DO WHILE (.TRUE.) DO i=iprs,N-1 Arimap(i+ardsp)=Arimap(i+1+ardsp) END DO Ips=Ips-1 icps=icps-1 IF (icps.LE.0) GO TO 10 END DO ELSE IF (icqr.GE.1) THEN DO WHILE (.TRUE.) DO i=iprs+Iqr,N-1 Arimap(i+ardsp)=Arimap(i+1+ardsp) END DO Iqr=Iqr-1 icqr=icqr-1 IF (icqr.LE.0) GO TO 10 END DO ELSE DO WHILE (.TRUE.) DO i=iprs+iqrs,N-1 Arimap(i+ardsp)=Arimap(i+1+ardsp) END DO Iqs=Iqs-1 icqs=icqs-1 IF (icqs.LE.0) GO TO 10 END DO END IF 10 CALL mdlint() CALL mdlset(Ipr,idr,Iqr,Ips,ids,Iqs,inptok) END IF c ------------------------------------------------------------------ RETURN END ttest.f0000664006604000003110000002031214521201615011476 0ustar sun00315stepsC Last change: BCM 2 Apr 98 1:02 pm **==ttest.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 SUBROUTINE ttest(Xy,Nspobs,Ncxy,Chlxpx,Otlvar,Ltstpt,Mxcol,Propt, & Snglr) IMPLICIT NONE c----------------------------------------------------------------------- c Calculates a value proportional to the t-statistic for c p(AO|regression) and p(LS|regression). The values returned are c for the outlier type that has the largest statistic. c propt = b/sqrt((X'X)**-1/mse))*mse which is compared to t*sqrt(mse). c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c chlxpx d Input ncxy(ncxy+1)/2 vector for the packed form the the c Cholesky decompostion of [X:y]'[X:y] c i i Local do loop index c ielt i Local index for the current element in a matrix c j i Local do loop index c l1 d Local pb+1, ncxy used, long vector for part of the c augmented cholesky decomposition of [X:o]'[X:o] where l1 c is [L 0 ] c [l' lmd1] for the AO outlier regression c l2 d Local pb+1, ncxy used, long vector like l1 except for c the LS outlier regression c ltstpt l Input 2 long logical vector to decide what tests to perform c mxcol i Output type to outlier that had the largest t value c 1=AO, 2=LS. c nb i Local number of b elements and the number of columns in the c X matrix c ncxy i Input number of columns in the X:y matrix and rows in the b c vector c neltxy i Local number of elements in xy c notlr i Local number of types of outliers to be tested notlr c can be 1 only be 1 for A0 only or 2 for AO and LS. c Also, is the number of columns in otlvar. c nspobs i Input number of rows in the X:y matrix c nxpx i Local number of elements in the packed chol(X'X) matrix c oomll1 d Local scalar for lmd**2=o'o-l'l where 1/sqrt(o'o-l'l) is c se(b(AO)). Is also the denominator for b(AO) c oomll2 d Local scalar same as oomll1 but for the LS b estimate and t c statistic c otlvar d Input nspobs by notlr matrix of filtered outlier regression c effects c oymlw1 d Local scalar for o'y-l'w for the AO regression where oymlw1 c is the numerator for b(AO) and t(AO)*sqrt(mse) c oymlw2 d Local scalar same as oymlw1 but for the LS b estimate and t c statistic c propt d Output 2 long vector of the proptional t values (t*rmse), c where the first element is for the AO and the second c for the LS c snglr l Output 2 long array which is true if [X:o]'[X:o] is c singular c tmp1 d Local scalar used for the AO regression c tmp2 d Local scalar used for the LS regression c w d Input nb long vector of Lw=X'y c xy d Input nspobs by ncxy matrix in vector form of regression c variables and data c zero d Local PARAMETER for 0d0 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c ------------------------------------------------------------------ DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) LOGICAL T,F PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ LOGICAL Snglr,lgo c LOGICAL lflag INTEGER Ltstpt,i,i2,ielt,j,Mxcol,nb,Ncxy,neltxy,notlr,Nspobs,nxpx, & otype DOUBLE PRECISION Chlxpx,l,l1,oomll,Otlvar,oymlw,Propt,tmp, & Xy,ddot,xl DIMENSION Chlxpx(Ncxy*(Ncxy+1)/2),l(POTLR,PB+1),l1(PB+1), & Ltstpt(POTLR),Otlvar(*),Propt(POTLR),Snglr(POTLR), & Xy(Nspobs*Ncxy),Mxcol(POTLR),oomll(POTLR),oymlw(POTLR), & tmp(POTLR),otype(POTLR) c----------------------------------------------------------------------- DOUBLE PRECISION dpmpar EXTERNAL dpmpar c----------------------------------------------------------------------- c Find the dimensions of the regression and data matrix and outlier c effect matrix. ltstpt(AO) for AO's and ltstpt(LS) for LS's are both c true then there are two outlier effects. c----------------------------------------------------------------------- Snglr(AO)=F Snglr(LS)=F Snglr(TC)=F * Snglr(SO)=F nb=Ncxy-1 neltxy=Nspobs*Ncxy nxpx=nb*Ncxy/2 xl=sqrt(dpmpar(2)) c ------------------------------------------------------------------ notlr=0 DO i=1,POTLR IF(Ltstpt(i).eq.1)THEN notlr=notlr+1 otype(notlr)=i END IF END DO c----------------------------------------------------------------------- CALL setdp(ZERO,notlr,oomll) cdos ------------------------------------------------------------------ c CALL undfl(lflag) cunix ------------------------------------------------------------------ i2=1 DO ielt=1,notlr*Nspobs IF(abs(Otlvar(ielt)).gt.xl)THEN oomll(i2)=oomll(i2)+Otlvar(ielt)**2 END IF i2=i2+1 IF(i2.gt.notlr)i2=1 END DO c----------------------------------------------------------------------- c Form [X:y]o = [X'o] c [y'o] c Note y'o is in the last element of l1. c----------------------------------------------------------------------- DO j=1,Ncxy CALL setdp(ZERO,notlr,tmp) i=1 c ------------------------------------------------------------------ DO ielt=j,neltxy,Ncxy DO i2=1,notlr tmp(i2)=tmp(i2)+Xy(ielt)*Otlvar(i) i=i+1 END DO END DO c ------------------------------------------------------------------ DO i2=1,notlr l(i2,j)=tmp(i2) END DO END DO c----------------------------------------------------------------------- c Solve L*l=X'o for l and make running calculations of o'y-l'w and c o'o-l'l. Note w is the (ncxy-1)ncxy/2+1 to ncxy(ncxy+1)/2-1 c elements of chlxpx c----------------------------------------------------------------------- DO i2=1,notlr oymlw(i2)=l(i2,Ncxy) END DO ielt=0 c ------------------------------------------------------------------ DO i=1,nb DO i2=1,notlr DO j=1,Ncxy l1(j)=l(i2,j) END DO tmp(i2)=l(i2,i)-ddot(i-1,Chlxpx(ielt+1),1,l1,1) END DO ielt=ielt+i c ----------------------------------------------------------------- DO i2=1,notlr tmp(i2)=tmp(i2)/Chlxpx(ielt) l(i2,i)=tmp(i2) oymlw(i2)=oymlw(i2)-Chlxpx(nxpx+i)*tmp(i2) oomll(i2)=oomll(i2)-tmp(i2)**2 END DO c ------------------------------------------------------------------ END DO c----------------------------------------------------------------------- c b(outlier at t0)=(o'y-l'w)/(o'o-l'l) and c t*sqrt(mse)=b/se(b)=[(o'y-l'w)/(o'o-l'l)]/[1/sqrt(o'o-l'l) c and whether the AO or LS outlier has the larger absolute t statistic. c----------------------------------------------------------------------- DO i2=1,notlr IF(oomll(i2).le.ZERO)THEN Snglr(otype(i2))=T Propt(otype(i2))=ZERO ELSE Propt(otype(i2))=oymlw(i2)/sqrt(oomll(i2)) END IF END DO c ------------------------------------------------------------------ Mxcol(1)=otype(1) IF(notlr.gt.1)THEN tmp(1)=propt(otype(1)) DO i=2,notlr tmp(i)=propt(otype(i)) Mxcol(i)=otype(i) j=i-1 lgo=.true. DO WHILE (lgo.and.j.gt.0) IF(abs(tmp(j)).lt.abs(tmp(j+1)))THEN tmp(j+1)=tmp(j) Mxcol(j+1)=Mxcol(j) tmp(j)=propt(otype(i)) Mxcol(j)=otype(i) ELSE lgo=.false. END IF j=j-1 END DO END DO END IF cdos ------------------------------------------------------------------ c CALL undfl(lflag) cunix ------------------------------------------------------------------ RETURN END tukey.cmn0000664006604000003110000000052114521201615012024 0ustar sun00315steps INTEGER Ntukey,Itukey DOUBLE PRECISION Ptsr,Ptso,Ptsa,Ptsi,Pttdr,Pttdo,Pttda,Pttdi DIMENSION Itukey(4),Ptsr(6),Ptso(6),Ptsa(6),Ptsi(6) c----------------------------------------------------------------------- COMMON /ctukey / Ptsr,Ptso,Ptsa,Ptsi,Pttdr,Pttdo,Pttda,Pttdi, & Ntukey,Itukey uconv.f0000664006604000003110000000337614521201615011500 0ustar sun00315steps**==uconv.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 SUBROUTINE uconv(Fulma,Mxmalg,C) * SUBROUTINE uconv(Fulma,Mxmalg,C,Pc) c----------------------------------------------------------------------- c Calculates the autocovariance function of a moving average c model whose coefficients are in A, using the innovation variance V and c saving the result in C . c The definition in terms of generating functions is C(Z)=A(Z).V.A(ZINV). c FORTRAN corrections made by Bill Bell -- 9/10/92 c 1. Integer declaration statement put before double precision declaration c statement c 2. REAL A(mxmalg) changed to double precision A(max(mxmalg,1)) to handle case c where mxmalg = 0 c Changes made: 9/21/92, Bill Bell c 1. IMPLICIT NONE statement added c 2. REAL type statements changed to DOUBLE PRECISION c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ INTEGER i,Mxmalg,k,qmi * INTEGER Pc * DOUBLE PRECISION Fulma(0:Mxmalg),C(0:Pc),sum DOUBLE PRECISION Fulma(0:Mxmalg),C(0:Mxmalg),sum c----------------------------------------------------------------------- DO i=0,Mxmalg C(i)=Fulma(i) END DO c ------------------------------------------------------------------ DO i=0,Mxmalg sum=Fulma(i) qmi=Mxmalg-i c ------------------------------------------------------------------ DO k=1,qmi sum=sum+Fulma(k)*C(i+k) END DO c ------------------------------------------------------------------ C(i)=sum END DO c ------------------------------------------------------------------ RETURN END unitmak.i0000664006604000003110000000013714521201615012011 0ustar sun00315stepsC C... Variables in Common Block /unitmak/ ... real*8 XL common /unitmak/ XL units.cmn0000664006604000003110000000077214521201615012035 0ustar sun00315stepsc----------------------------------------------------------------------- C --- Mt is the input spec file C --- Mtm is the model file C --- Mt1 is the main printout C --- Mt2 is the error file C --- Ng is the file containing a summary of the run(s) C --- Nform contains the seasonal adjustment diagnostics for the run c----------------------------------------------------------------------- INTEGER Mt,Mtm,Mt1,Mt2,Nform,Ng,Mtprof COMMON /units / Mt,Mtm,Mt2,Mt1,Ng,Nform,Mtprof upbuf.g77.f0000664006604000003110000000566314521201615012073 0ustar sun00315steps SUBROUTINE upbuf(Linno,Lin,Linln,buf,bufln,begbuf,endbuf,crntbf) c----------------------------------------------------------------------- c upbuf.f, Release 1, Subroutine Version 1.1, Modified 18 Nov 2007. c----------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'lex.i' INCLUDE 'cchars.i' INCLUDE 'stdio.i' c ----------------------------------------------------------------- CHARACTER Lin*(*),nxtchr INTEGER i,Linln,Linno c ----------------------------------------------------------------- INTEGER nblank EXTERNAL nblank c----------------------------------------------------------------------- CHARACTER buf(0:PBUFSZ-1)*(LINLEN) INTEGER bufln(0:PBUFSZ-1),begbuf,endbuf,crntbf c ----------------------------------------------------------------- endbuf=mod(endbuf+1,PBUFSZ) IF(begbuf.eq.endbuf)begbuf=mod(begbuf+1,PBUFSZ) crntbf=mod(crntbf+1,PBUFSZ) c----------------------------------------------------------------------- c Tack on an EOL c----------------------------------------------------------------------- Linln=nblank(Lin) Linln=Linln+1 IF(Linln.gt.LINLEN)THEN WRITE(STDERR,*)' ERROR: Input record longer than limit :', & LINLEN CALL abend() RETURN END IF Lin(Linln:Linln)=NEWLIN c----------------------------------------------------------------------- c Filter out all unprintable characters c----------------------------------------------------------------------- i=1 c ----------------------------------------------------------------- DO WHILE (.true.) * i=i+1 c ----------------------------------------------------------------- IF(i.lt.Linln)THEN nxtchr=Lin(i:i) c ----------------------------------------------------------------- c Change by BCM to allow tab characters to be read in spec file c and not skipped over - May 2005 c ----------------------------------------------------------------- IF((nxtchr.lt.' '.or.nxtchr.gt.'~').and. & (.not.(nxtchr.eq.TABCHR)))THEN C CALL inpter(PERROR,Pos,'Skipped over unprintable character her C &e') Lin(i:Linln-1)=Lin(i+1:Linln) Linln=Linln-1 c ----------------------------------------------------------------- ELSE i=i+1 END IF GO TO 30 END IF c ----------------------------------------------------------------- GO TO 40 30 CONTINUE END DO c----------------------------------------------------------------------- c Store the next line in the buffer and return c----------------------------------------------------------------------- 40 buf(endbuf)=Lin bufln(endbuf)=Linln c ----------------------------------------------------------------- RETURN ENDupespm.f0000664006604000003110000000475014521201615011654 0ustar sun00315steps SUBROUTINE upespm(Estprm) IMPLICIT NONE c----------------------------------------------------------------------- c upespm.f, Release 1, Subroutine Version 1.1, Modified 01 Feb 1995. c----------------------------------------------------------------------- c This routine takes the vector of nonlinear estimated parameters c and stores them in the data structures needed to run the ARIMA c filter. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begptr i Local pointer to the first row in opr of the current c difference, AR, or MA filter 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 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----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ INTEGER beglag,begopr,endlag,endopr,estptr,iflt,ilag,iopr DOUBLE PRECISION Estprm DIMENSION Estprm(Nestpm) c----------------------------------------------------------------------- c For each operator insert the estimated parameters in the model c information vectors c----------------------------------------------------------------------- estptr=0 DO iflt=DIFF,MA begopr=Mdl(iflt-1) endopr=Mdl(iflt)-1 c ------------------------------------------------------------------ DO iopr=begopr,endopr beglag=Opr(iopr-1) endlag=Opr(iopr)-1 c ------------------------------------------------------------------ DO ilag=beglag,endlag IF(.not.Arimaf(ilag))THEN estptr=estptr+1 Arimap(ilag)=Estprm(estptr) END IF END DO END DO END DO c ------------------------------------------------------------------ RETURN END upmeta.g77.f0000664006604000003110000001537514521201615012246 0ustar sun00315steps SUBROUTINE upmeta(Insrs,Outsrs,Datsrs,Imeta,Mtafil,Ldata,Dtafil, & Mtalin,Nmeta,Nfil,blnk,quot) IMPLICIT NONE C----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' C----------------------------------------------------------------------- CHARACTER Insrs*(PFILCR),Outsrs*(PFILCR),Datsrs*(PFILCR),blnk*1, & Mtalin*(*),Dtafil*(PFILCR),Mtafil*(PFILCR),quot*1 LOGICAL Ldata INTEGER i,i2,Imeta,j,n,Nmeta,Nfil,ichr,nchr,n1,n2 DIMENSION Insrs(PSRS),Outsrs(PSRS),Datsrs(PSRS) C----------------------------------------------------------------------- INTEGER nblank,lstpth EXTERNAL nblank,lstpth c----------------------------------------------------------------------- Outsrs(Imeta)=blnk C----------------------------------------------------------------------- c If this is a blank line (line of length zero), decrement the c series counter and process the next line. C----------------------------------------------------------------------- IF(Nmeta.eq.0)THEN Imeta=Imeta-1 ELSE C---------------------------------------------------------------------- c If the first character of the line is a quotation mark, c Find the next quotation mark. c November 2005 - BCM C----------------------------------------------------------------------- IF(Mtalin(1:1).eq.quot)THEN i=2 DO WHILE (Mtalin(i:i).ne.quot.and.i.le.Nmeta) i=i+1 END DO IF (i.eq.Nmeta.and.Mtalin(Nmeta:Nmeta).ne.quot)THEN IF(Ldata)THEN WRITE(STDERR,1021)'data',Mtafil(1:Nfil) ELSE WRITE(STDERR,1021)'input',Mtafil(1:Nfil) END IF CALL abend RETURN END IF C----------------------------------------------------------------------- c Set the length of the first string. C----------------------------------------------------------------------- n=i n1=2 n2=n-1 ELSE C----------------------------------------------------------------------- c Find the first blank or not set character C----------------------------------------------------------------------- i=1 DO WHILE (Mtalin(i:i).ne.blnk.and.i.le.Nmeta) i=i+1 END DO C----------------------------------------------------------------------- c If the first character of a line is a blank character, print an c error message C----------------------------------------------------------------------- IF(i.eq.1)THEN IF(Ldata)THEN WRITE(STDERR,1020)' data',Mtafil(1:Nfil) ELSE WRITE(STDERR,1020)'n input',Mtafil(1:Nfil) END IF CALL abend RETURN END IF C----------------------------------------------------------------------- c Set the length of the first string. C----------------------------------------------------------------------- n=i-1 n1=1 n2=n END IF C----------------------------------------------------------------------- c If this is an input metafile, store the series name in the c variable series. Else, store as an element of Dtasrs C----------------------------------------------------------------------- IF(Ldata)THEN Datsrs(Imeta)=Mtalin(n1:n2) Insrs(Imeta)=Infile ELSE Insrs(Imeta)=Mtalin(n1:n2) END IF C----------------------------------------------------------------------- c Is the end of the first string the end of the line? If so, c set output names. C----------------------------------------------------------------------- IF(Nmeta.eq.n)THEN c ------------------------------------------------------------------ c If data metafile is used, get the path and filename from the c datafile to use as the output file name. c ------------------------------------------------------------------ IF(Ldata)THEN ichr=lstpth(Mtalin,n)+1 DO i2=n2,ichr,-1 IF(Mtalin(i2:i2).eq.'.')THEN nchr=i2-1 GO TO 30 END IF END DO nchr=n2 30 Outsrs(Imeta)=Mtalin(n1:nchr) ELSE c ------------------------------------------------------------------ c If an input metafile is used, set the output file to be the same c as the spec file. c ------------------------------------------------------------------ Outsrs(Imeta)=Mtalin(n1:n2) END IF C----------------------------------------------------------------------- c If not, find the position of the next non-blank character C----------------------------------------------------------------------- ELSE IF(Mtalin(i:i).eq.quot)i=i+1 DO WHILE (Mtalin(i:i).eq.blnk) i=i+1 END DO C----------------------------------------------------------------------- C Check to see if there are any more blanks in the line C----------------------------------------------------------------------- j=i IF(Mtalin(j:j).eq.quot)THEN j=j+1 DO WHILE (Mtalin(j:j).ne.quot.and.j.le.Nmeta) j=j+1 END DO IF (i.eq.Nmeta.and.Mtalin(Nmeta:Nmeta).ne.quot)THEN IF(Ldata)THEN WRITE(STDERR,1021)'data',Mtafil(1:Nfil) ELSE WRITE(STDERR,1021)'input',Mtafil(1:Nfil) END IF CALL abend RETURN END IF C----------------------------------------------------------------------- c Store the output file name in the array Outsrs C----------------------------------------------------------------------- Outsrs(Imeta)=Mtalin((i+1):(j-1)) ELSE C----------------------------------------------------------------------- DO WHILE (Mtalin(j:j).ne.blnk.and.j.le.Nmeta) j=j+1 END DO C----------------------------------------------------------------------- c Store the output file name in the array Outsrs C----------------------------------------------------------------------- Outsrs(Imeta)=Mtalin(i:(j-1)) END IF END IF END IF C----------------------------------------------------------------------- 1020 FORMAT(/,' ERROR: The first entry in each line of a',a, & ' metafile must be left ', & /,' justified. Correct the metafile and rerun ',a, & '.') 1021 FORMAT(/,' ERROR: Closing quotation mark not found in this ',a, & ' metafile.', & /,' Correct the metafile and rerun ',a,'.') C----------------------------------------------------------------------- RETURN ENDurgbak.cmn0000664006604000003110000000121714521201616012142 0ustar sun00315stepsc ------------------------------------------------------------------ c Backup copies of variables for user defined regressors c ------------------------------------------------------------------ LOGICAL Fxuser CHARACTER Usrtt2*(PCOLCR*PUREG) DOUBLE PRECISION Buser,Userx2 INTEGER Usrty2,Ncusx2,Usrpt2 DIMENSION Buser(PUREG*2),Fxuser(PUREG*2),Userx2(PUSERX*2), & Usrty2(PUREG*2),Usrpt2((PUREG+1)*2),Ncusx2(0:1), & Usrtt2(0:1) c ------------------------------------------------------------------ COMMON /usrbak/ Buser,Userx2,Ncusx2,Usrty2,Usrpt2,Usrtt2,Fxuser usraic.f0000664006604000003110000003412314521201616011627 0ustar sun00315stepsC Last change: BCM 23 Mar 2005 9:23 am SUBROUTINE usraic(Trnsrs,A,Nefobs,Na,Frstry,Lester,Lprtit,Lprt, & Lprtfm,Lsavlg,Lsumm,Lhiddn) IMPLICIT NONE c----------------------------------------------------------------------- c Estimate two regARIMA models, one with user-defined regressors and c one without. This routine chooses the model with the lowest value c of AICC and prints out the resulting model. c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ZERO,ONE PARAMETER(F=.false.,T=.true.,ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'lkhd.cmn' INCLUDE 'extend.cmn' INCLUDE 'units.cmn' INCLUDE 'adj.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'error.cmn' INCLUDE 'usrreg.cmn' c----------------------------------------------------------------------- INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c----------------------------------------------------------------------- CHARACTER effttl*(PCOLCR),ubkttl*(PCOLCR*PUREG) LOGICAL Lprt,Lprtit,Lester,argok,lhide,Lprtfm,Lsavlg,ubkfix,Lhiddn DOUBLE PRECISION A,aicnou,aicusr,Trnsrs,ubkx,ubkb,thiscv INTEGER Frstry,i,Na,Nefobs,nchr,iuser,nubk,ubktyp,ubkptr,begcol, & endcol,igrp,Lsumm,endlag,ilag,nbu,nbno,aicdf,rtype DIMENSION A(PA),Trnsrs(PLEN),ubktyp(PUREG),ubkptr(0:PUREG), & ubkx(PUSERX),ubkfix(PUREG),ubkb(PUREG) c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL strinx,dpeq c----------------------------------------------------------------------- c Initialize variables c----------------------------------------------------------------------- IF(.not.Lprt)THEN lhide=Lhiddn Lhiddn=T END IF c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Estimate model with user-defined regressors c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(Lfatal)RETURN argok=Lautom.or.Lautox CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & CALL abend() IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0.or. & ((Lautom.or.Lautox).and..not.argok))THEN Lester=T RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- IF(Lprt)WRITE(Mt1,1010) 1010 FORMAT(//,' Likelihood statistics for model with user-defined', & ' regressors') CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,F) IF(Lfatal)RETURN aicusr=Aicc IF((.not.dpeq(Pvaic,DNOTST)))nbu=Nb IF(Lsavlg)WRITE(Ng,1011)Aicc 1011 FORMAT(' AICC(userreg) : ',f15.4) IF(Lsumm.gt.0)WRITE(Nform,1012)'user',Aicc c----------------------------------------------------------------------- c Make local backup copy of user defined regressors. c----------------------------------------------------------------------- CALL copy(Userx,PUSERX,1,ubkx) CALL cpyint(Usrtyp,PUREG,1,ubktyp) CALL cpyint(Usrptr(0),PUREG+1,1,ubkptr(0)) nubk=Ncusrx ubkttl=Usrttl c----------------------------------------------------------------------- c save the regression coefficients, fixed regression indicators for c the user defined regressors c----------------------------------------------------------------------- iuser=0 DO igrp=1,Ngrp begcol=Grp(igrp-1) rtype=Rgvrtp(begcol) IF(rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY.or.rtype.eq.PRGTUD.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)THEN endcol=Grp(igrp)-1 DO i=begcol,endcol iuser=iuser+1 ubkb(iuser)=B(i) ubkfix(iuser)=Regfx(i) END DO END IF END DO c----------------------------------------------------------------------- c remove the user defined regressors from the regression matrix. c----------------------------------------------------------------------- DO igrp=Ngrp,1,-1 begcol=Grp(igrp-1) rtype=Rgvrtp(begcol) IF(rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY.or.rtype.eq.PRGTUD.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)THEN endcol=Grp(igrp)-1 iuser=endcol-begcol+1 CALL dlrgef(begcol,Nrxy,iuser) IF(Lfatal)RETURN END IF END DO Ncusrx=0 c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Re-estimate model without user-defined regressors c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,F,A,Na,Nefobs,argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok)) & CALL abend() IF(Lfatal)RETURN c----------------------------------------------------------------------- c If an estimation error is found, discontinue the routine. c----------------------------------------------------------------------- IF(Armaer.eq.PMXIER.or.Armaer.eq.PSNGER.or.Armaer.eq.PISNER.or. & Armaer.eq.PNIFER.or.Armaer.eq.PNIMER.or.Armaer.eq.PCNTER.or. & Armaer.eq.POBFN0.or.Armaer.lt.0.or. & ((Lautom.or.Lautox).and..not.argok))THEN Lester=T RETURN c----------------------------------------------------------------------- c If only a warning message would be printed out, reset the error c indicator variable to zero. c----------------------------------------------------------------------- ELSE IF(Armaer.ne.0)THEN Armaer=0 END IF c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- IF(Lprt)WRITE(Mt1,1020) 1020 FORMAT(//,' Likelihood statistics for model without user-defined', & ' regressors') CALL prlkhd(Y(Frstsy),Adj(Adj1st),Adjmod,Fcntyp,Lam,F,Lprt,Lprtfm) aicnou=Aicc IF((.not.dpeq(Pvaic,DNOTST)))nbno=Nb IF(Lsavlg)WRITE(Ng,1021)Aicc 1021 FORMAT(' AICC(no userreg) : ',f15.4) IF(Lsumm.gt.0)WRITE(Nform,1012)'nouser',Aicc IF(.not.Lprt)Lhiddn=lhide c----------------------------------------------------------------------- c Show the regression model AICC prefers c----------------------------------------------------------------------- Dfaicu=aicnou-aicusr IF((.not.dpeq(Pvaic,DNOTST)))THEN aicdf=nbu-nbno CALL chsppf(Pvaic,aicdf,thiscv,Mt1) Rgaicd(PUAIC)=thiscv-2D0*dble(aicdf) END IF IF(Dfaicu.gt.Rgaicd(PUAIC))THEN IF(Lprt)THEN WRITE(Mt1,1030)Rgaicd(PUAIC),'with' END IF c----------------------------------------------------------------------- c Add user-defined regressors back to model c----------------------------------------------------------------------- CALL copy(ubkx,PUSERX,1,Userx) CALL cpyint(ubktyp,PUREG,1,Usrtyp) CALL cpyint(ubkptr(0),PUREG+1,1,Usrptr(0)) Ncusrx=nubk Usrttl=ubkttl c----------------------------------------------------------------------- c Restore user-defined regressors to the regression matrix c----------------------------------------------------------------------- DO i=1,Ncusrx CALL getstr(Usrttl,Usrptr,Ncusrx,i,effttl,nchr) IF(.not.Lfatal)THEN IF(Usrtyp(i).eq.PRGTUH)THEN CALL adrgef(ubkb(i),effttl(1:nchr),'User-defined Holiday', & PRGTUH,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUH2)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Holiday Group 2',PRGUH2,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUH3)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Holiday Group 3',PRGUH3,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUH4)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Holiday Group 4',PRGUH4,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUH5)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Holiday Group 5',PRGUH5,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGTUS)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Seasonal',PRGTUS,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUCN)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Constant',PRGUCN,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUTD)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Trading Day',PRGUTD, & ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGULM)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined LOM',PRGULM,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGULQ)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined LOQ',PRGULQ,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGULY)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Leap Year',PRGULY,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUAO)THEN CALL adrgef(ubkb(i),effttl(1:nchr),'User-defined AO', & PRGUAO,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGULS)THEN CALL adrgef(ubkb(i),effttl(1:nchr),'User-defined LS', & PRGULS,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUSO)THEN CALL adrgef(ubkb(i),effttl(1:nchr),'User-defined SO', & PRGUSO,ubkfix(i),F) ELSE IF(Usrtyp(i).eq.PRGUCY)THEN CALL adrgef(ubkb(i),effttl(1:nchr), & 'User-defined Transitory',PRGUCY, & ubkfix(i),F) ELSE CALL adrgef(ubkb(i),effttl(1:nchr),'User-defined',PRGTUD, & ubkfix(i),F) END IF END IF END DO c----------------------------------------------------------------------- c If there are ARMA parameters that were set as initial values by c the user, reset Arimap to those values (BCM, 9-2010) c----------------------------------------------------------------------- IF(Nopr.gt.0)THEN endlag=Opr(Nopr)-1 DO ilag=1,endlag IF(.not.Arimaf(ilag))Arimap(ilag)=Ap1(ilag) END DO END IF c----------------------------------------------------------------------- c Estimate model c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,Frstry,T,Elong) IF(.not.Lfatal)CALL rgarma(T,Mxiter,Mxnlit,Lprtit,A,Na,Nefobs, & argok) IF((.not.Lfatal).and.(Lautom.or.Lautox).and.(.not.argok))Lester=T ELSE IF(Lprt)THEN IF(dpeq(Pvaic,DNOTST))THEN WRITE(Mt1,1030)Rgaicd(PUAIC),'without' ELSE WRITE(Mt1,1040)ONE-Pvaic,Rgaicd(PUAIC),'without' END IF END IF END IF c----------------------------------------------------------------------- 1012 FORMAT('aictest.u.aicc.',a,': ',e29.15) 1030 FORMAT(//,' ***** AICC (with aicdiff=',F7.4, & ') prefers model ',a,' user-defined regressor *****') 1040 FORMAT(//,' ***** AICC (with p-value=',F7.5,' and aicdiff=', & F7.4,') prefers model ',a,' user-defined regressor *****') RETURN END usrgrp.prm0000664006604000003110000000075314521201616012236 0ustar sun00315steps CHARACTER UTYDIC*320 INTEGER utyptr,PUTY PARAMETER(PUTY=15) DIMENSION utyptr(0:PUTY) PARAMETER(UTYDIC='User-defined SeasonalUser-defined HolidayUser-de &fined Holiday Group 2User-defined Holiday Group 3User-defined Holi &day Group 4User-defined Holiday Group 5User-defined ConstantUser-d &efined Trading DayUser-defined LOMUser-defined LOQUser-defined Lea &p YearUser-defined AOUser-defined LSUser-defined SOUser-defined Tr &ansitory') usrgrp.var0000664006604000003110000000012714521201617012224 0ustar sun00315steps DATA utyptr / 1,22,42,70,98,126,154,175,199,215,231,253,268,283, &298,321 / usrreg.cmn0000664006604000003110000000174014521201617012200 0ustar sun00315stepsc ------------------------------------------------------------------ c Usrttl - data dictionary for the names of the user-defined c regressor variables. c Usrptr - pointers for the data dictionary of the names of the c user-defined regressor variables. c Usrtyp - indicator of what type of regressor for each of the c user-defined regressor variables. c Ncusrx - Number of user-defined regression variables c Nguhl - Number of holiday groups defined withing user-defined c regression variables c ------------------------------------------------------------------ CHARACTER Usrttl*(PCOLCR*PUREG) INTEGER Usrtyp,Ncusrx,Usrptr,Nguhl DIMENSION Usrtyp(PUREG),Usrptr(0:PUREG) c ------------------------------------------------------------------ COMMON /usrreg/ Ncusrx,Usrtyp,Usrptr,Nguhl,Usrttl c ------------------------------------------------------------------ usrtyp.prm0000664006604000003110000000034714521201617012262 0ustar sun00315steps CHARACTER URGDIC*89 INTEGER urgptr,PURG PARAMETER(PURG=16) DIMENSION urgptr(0:PURG) PARAMETER(URGDIC='constantseasonaltdlomloqlpyearholidayholiday2hol &iday3holiday4holiday5aolssotransitoryuser') usrtyp.var0000664006604000003110000000010714521201620012240 0ustar sun00315steps DATA urgptr / 1,9,17,19,22,25,31,38,46,54,62,70,72,74,76,86,90 / usrxrg.cmn0000664006604000003110000000174614521201620012223 0ustar sun00315stepsc ------------------------------------------------------------------ c Usrxtt - data dictionary for the names of the user-defined c regressor variables. c Usrxpt - pointers for the data dictionary of the names of the c user-defined regressor variables. c Usxtyp - indicator of what type of regressor for each of the c user-defined regressor variables. c Ncxusx - Number of user-defined regression variables c Nrxusx - Number of observations read in for the user-defined c X-11 regression variables. c ------------------------------------------------------------------ CHARACTER Usrxtt*(PCOLCR*PUREG) INTEGER Usxtyp,Ncxusx,Nrxusx,Usrxpt DIMENSION Usxtyp(PUREG),Usrxpt(0:PUREG) c ------------------------------------------------------------------ COMMON /usrxrg/ Ncxusx,Nrxusx,Usxtyp,Usrxpt,Usrxtt c ------------------------------------------------------------------ value.f0000664006604000003110000000117014521201621011445 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:22 pm **==value.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 SUBROUTINE value IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'chrt.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION yvalue c----------------------------------------------------------------------- yvalue=Fact1*(Xyvec-Ymin)/Ydiff Ixy=Ifact2-int(yvalue) c----------------------------------------------------------------------- RETURN END varian.f0000664006604000003110000000144014521201621011611 0ustar sun00315steps**==varian.f processed by SPAG 4.03F at 09:54 on 1 Mar 1994 DOUBLE PRECISION FUNCTION varian(X,I,J,Iopt) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION ave,X INTEGER I,Iopt,J,k C*** End of declarations inserted by SPAG C --- THIS FUNCTION COMPUTES THE VARIANCE OF X. IF IOPT = 0 COMPUTE THE C --- MEAN , IF IOPT = 1 THE MEAN IS ASSUMED TO BE ZERO, AND IF IOPT = 2 C --- THE MEAN IS ASSUMED TO BE ONE. DIMENSION X(*) ave=1D0 IF(Iopt.ne.2)THEN ave=0D0 IF(Iopt.ne.1)THEN DO k=I,J ave=ave+X(k) END DO ave=ave/(J-I+1) END IF END IF varian=0D0 DO k=I,J varian=varian+(X(k)-ave)*(X(k)-ave) END DO RETURN END varlog.f0000664006604000003110000000271714521201621011633 0ustar sun00315steps DOUBLE PRECISION FUNCTION varlog(X,I,J,Iopt) IMPLICIT NONE c ------------------------------------------------------------------ C --- THIS FUNCTION COMPUTES THE LOG VARIANCE OF X. IF IOPT IS EQUAL C --- TO 1 THE LOG MEAN IS ASSUMED TO BE 1. c ------------------------------------------------------------------ DOUBLE PRECISION ZERO,ONE PARAMETER(ZERO=0D0,ONE=1D0) c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'goodob.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION tmp,tmp2,X,numtmp INTEGER I,Iopt,J,k DIMENSION X(*) c ------------------------------------------------------------------ tmp=ZERO numtmp=ZERO IF(Iopt.ne.1)THEN DO k=I,J IF(Gudval(k).and.X(k).gt.ZERO)THEN tmp=tmp+dlog(X(k)) numtmp=numtmp+ONE END IF END DO IF(numtmp.gt.ZERO)THEN tmp=tmp/numtmp ELSE varlog=DNOTST RETURN END IF END IF c ------------------------------------------------------------------ varlog=ZERO DO k=I,J IF(Gudval(k).and.X(k).gt.ZERO)THEN tmp2=dlog(X(k))-tmp varlog=varlog+tmp2*tmp2 END IF END DO c ------------------------------------------------------------------ RETURN END vars.f0000664006604000003110000000071714521201621011312 0ustar sun00315steps DOUBLE PRECISION FUNCTION vars(X,I,J,Iopt,Muladd) IMPLICIT NONE C----------------------------------------------------------------------- INTEGER I,Iopt,J,Muladd DOUBLE PRECISION varian,varlog,X DIMENSION X(*) C----------------------------------------------------------------------- IF(Muladd.ne.1)THEN vars=varlog(X,I,J,Iopt) RETURN END IF vars=varian(X,I,J,Iopt) RETURN END vsfa.f0000664006604000003110000000747614521201622011310 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 1:42 pm SUBROUTINE vsfa(Stsi,Lfda,Llda,Nyr) IMPLICIT NONE C----------------------------------------------------------------------- C --- SEASONAL FACTOR CURVE ROUTINE. C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11msc.cmn' INCLUDE 'x11opt.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) C----------------------------------------------------------------------- DOUBLE PRECISION cs,fis,fk,r1,r2,savg,simon,stimon,Stsi,tmp1,tmp2 INTEGER i,j,k,kfda,ki,Lfda,Llda,m,n,Nyr DIMENSION Stsi(PLEN),savg(PYRS+6),simon(PYRS+6),stimon(PYRS+6) C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- kfda=Lfda+Nyr-1 Ratis=999.99D0 r1=ZERO r2=ZERO C----------------------------------------------------------------------- C --- PLACE MONTHLY SI IN SIMON. C----------------------------------------------------------------------- DO j=Lfda,kfda m=j-(j-1)/Nyr*Nyr k=3 DO i=j,Llda,Nyr k=k+1 simon(k)=Stsi(i) END DO C----------------------------------------------------------------------- C --- COMPUTE A 7-TERM MOVING AVERAGE FOR AN ESTIMATE OF S. C----------------------------------------------------------------------- tmp1=(simon(4)+simon(5)+simon(6))/3.0D0 tmp2=(simon(k)+simon(k-1)+simon(k-2))/3.0D0 DO i=1,3 ki=k+i simon(i)=tmp1 simon(ki)=tmp2 END DO CALL averag(simon,savg,1,ki,1,7) Rati(m)=ZERO Rati(m+Nyr)=ZERO Rati(m+2*Nyr)=999.99D0 C----------------------------------------------------------------------- C --- DIVIDE SI/S FOR AN ESTIMATE OF I. C----------------------------------------------------------------------- IF(Psuadd)THEN DO i=4,k stimon(i)=simon(i)-savg(i)+1D0 END DO ELSE CALL divsub(stimon,simon,savg,4,k) END IF C----------------------------------------------------------------------- C --- ADJUST FOR THE LENGTH OF THE SERIES. C----------------------------------------------------------------------- n=k-4 C----------------------------------------------------------------------- C --- COMPUTE IBAR,SBAR, AN RATIOS. C----------------------------------------------------------------------- IF(Muladd.lt.1)THEN DO i=5,k Rati(m)=Rati(m)+abs(stimon(i)-stimon(i-1))/stimon(i-1) Rati(m+Nyr)=Rati(m+Nyr)+abs(savg(i)-savg(i-1))/savg(i-1) END DO Rati(m)=Rati(m)*100D0*fis(cs,n) Rati(m+Nyr)=Rati(m+Nyr)*100D0*cs ELSE DO i=5,k Rati(m)=Rati(m)+abs(stimon(i)-stimon(i-1))*fis(cs,n) Rati(m+Nyr)=Rati(m+Nyr)+abs(savg(i)-savg(i-1))*cs END DO END IF r1=r1+Rati(m) r2=r2+Rati(m+Nyr) c----------------------------------------------------------------------- c Change to handle series that are "STEP functions" BCM 10-97 c----------------------------------------------------------------------- IF(.NOT.dpeq(Rati(m+Nyr),ZERO))THEN IF(Rati(m).le.999D0*Rati(m+Nyr)) & Rati(m+Nyr*2)=Rati(m)/Rati(m+Nyr) END IF c----------------------------------------------------------------------- fk=n Rati(m)=Rati(m)/fk Rati(m+Nyr)=Rati(m+Nyr)/fk END DO IF(r1.le.999D0*r2.AND.(.not.dpeq(r2,ZERO)))Ratis=r1/r2 IF(Muladd.eq.2)THEN DO i=1,Nyr Rati(i)=100D0*Rati(i) Rati(i+Nyr)=100D0*Rati(i+Nyr) END DO END IF RETURN END vsfb.f0000664006604000003110000001746214521201622011305 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 1:43 pm SUBROUTINE vsfb(Sts,Stsi,Lfda,Llda,Nyr) IMPLICIT NONE C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11msc.cmn' INCLUDE 'x11opt.cmn' C----------------------------------------------------------------------- * LOGICAL T * PARAMETER(T=.true.) C----------------------------------------------------------------------- DOUBLE PRECISION savg,simon,Sts,Stsi,tmp1,w9,w15 INTEGER i,j,jjj,k,kfda,Lfda,Llda,Nyr * LOGICAL allstb DIMENSION savg(PYRS),simon(PYRS+6),w9(40),w15(100),Sts(PLEN), & Stsi(PLEN) C----------------------------------------------------------------------- DOUBLE PRECISION totals EXTERNAL totals C----------------------------------------------------------------------- DATA w9/ & 0.246D0,0.221D0,0.197D0,0.173D0,0.112D0,0.051D0, & 0.208D0,0.192D0,0.176D0,0.160D0,0.144D0,0.092D0,0.028D0, & 0.173D0,0.163D0,0.154D0,0.143D0,0.133D0,0.123D0,0.079D0, & 0.032D0, & 0.141D0,0.137D0,0.132D0,0.128D0,0.123D0,0.117D0,0.113D0, & 0.075D0,0.034D0, & 0.084D0,0.120D0,0.118D0,0.117D0,0.116D0,0.114D0,0.113D0, & 0.111D0,0.073D0,0.034D0/ DATA w15/ 1 .16000D0,.16000D0,.16000D0,.16000D0,.16000D0,.06667D0,.06667D0, & .04444D0,.02222D0, 2 .14667D0,.14667D0,.14667D0,.14667D0,.14667D0,.06667D0,.06667D0, & .06667D0,.04444D0,.02220D0, 3 .13333D0,.13333D0,.13333D0,.13333D0,.13333D0,.06667D0,.06667D0, & .06667D0,.06667D0,.04444D0,.02223D0, 4 .12000D0,.12000D0,.12000D0,.12000D0,.12000D0,.06667D0,.06667D0, & .06667D0,.06667D0,.06667D0,.04444D0,.02221D0, 5 .10667D0,.10667D0,.10667D0,.10667D0,.10667D0,.06667D0,.06667D0, & .06667D0,.06667D0,.06667D0,.06667D0,.04444D0,.02219D0, 6 .09333D0,.09333D0,.09333D0,.09333D0,.09333D0,.06667D0,.06667D0, & .06667D0,.06667D0,.06667D0,.06667D0,.06667D0,.04444D0,.02222D0, 7 .08000D0,.08000D0,.08000D0,.08000D0,.08000D0,.06667D0,.06667D0, & .06667D0,.06667D0,.06667D0,.06667D0,.06667D0,.06667D0,.04444D0, & .02220D0, 8 .04889D0,.07111D0,.07111D0,.07111D0,.07111D0,.06667D0,.06667D0, & .06667D0,.06667D0,.06667D0,.06667D0,.06667D0,.06667D0,.06667D0, & .04444D0,.02220D0 / C----------------------------------------------------------------------- kfda=Lfda+Nyr-1 Mtype=Lterm+1 * allstb=T C----------------------------------------------------------------------- C --- CHECK IF MOVING AVERAGE IS PRESELECTED. C----------------------------------------------------------------------- * IF(Mtype.eq.7.or.Mtype.eq.1)THEN * Mtype=3 * IF(Ksect.eq.1)Mtype=2 * END IF C----------------------------------------------------------------------- C --- IF LESS THAN 5 COMPLETE YEARS SWITCH TO STABLE SEASONALITY. C----------------------------------------------------------------------- IF(.not.Shrtsf.and.(Llda-Lfda-5*Nyr+1).lt.0)Mtype=6 DO j=Lfda,kfda IF(((Llda-Lfda+1-5*Nyr).ge.0).or.Shrtsf)THEN jjj=mod(j,Nyr) IF(jjj.eq.0)jjj=Nyr Mtype=Lter(jjj)+1 END IF IF(Mtype.eq.7.or.Mtype.eq.1)THEN Mtype=3 IF(Ksect.eq.1)Mtype=2 ELSE IF(Mtype.eq.8)THEN Mtype=7 END IF k=0 DO i=j,Llda,Nyr k=k+1 simon(k)=Stsi(i) END DO * allstb=allstb.and.(Mtype.eq.6.or.(Mtype.eq.5.and.k.lt.20)) IF(Shrtsf.and.k.eq.3.and.Mtype.eq.3)Mtype=6 IF(Mtype.eq.2)THEN C----------------------------------------------------------------------- C --- COMPUTE A 3X3 MOVING AVERAGE. C----------------------------------------------------------------------- CALL averag(simon,savg,1,k,3,3) savg(1)=(11D0*(simon(1)+simon(2))+5D0*simon(3))/27D0 savg(k)=(11D0*(simon(k)+simon(k-1))+5D0*simon(k-2))/27D0 IF(k.eq.3)THEN savg(2)=(simon(1)+simon(2)+simon(3))/3D0 ELSE savg(2)=(0.7D0*(simon(1)+simon(3))+simon(2)+0.3D0*simon(4))/ & 2.7D0 savg(k-1)=(0.7D0*(simon(k)+simon(k-2))+simon(k-1)+0.3D0* & simon(k-3))/2.7D0 END IF ELSE IF(Mtype.eq.3)THEN C----------------------------------------------------------------------- C --- COMPUTE A 3X5 MOVING AVERAGE. C----------------------------------------------------------------------- CALL averag(simon,savg,1,k,3,5) savg(1)=(17D0*(simon(1)+simon(2)+simon(3))+9D0*simon(4))/60D0 savg(k)=(17D0*(simon(k)+simon(k-1)+simon(k-2))+9D0*simon(k-3)) & /60D0 IF(k.eq.4)THEN savg(2)=(simon(1)+simon(2)+simon(3)+simon(4))/4D0 savg(3)=(simon(1)+simon(2)+simon(3)+simon(4))/4D0 ELSE savg(2)=(15D0*(simon(1)+simon(2)+simon(3))+11D0*simon(4) & +4D0*simon(5))/60D0 savg(k-1)=(15D0*(simon(k)+simon(k-1)+simon(k-2))+ & 11D0*simon(k-3)+4D0*simon(k-4))/60D0 END IF IF(k.eq.5)THEN savg(3)=(simon(1)+simon(2)+simon(3)+simon(4)+simon(5))/5D0 ELSE IF(k.gt.5)THEN savg(3)=(9D0*simon(1)+13D0*(simon(2)+simon(3)+simon(4)) & +8D0*simon(5)+4D0*simon(6))/60D0 savg(k-2)=(9D0*simon(k)+13D0*(simon(k-1)+simon(k-2)+simon(k-3)) & +8D0*simon(k-4)+4D0*simon(k-5))/60D0 END IF ELSE IF(Mtype.eq.4)THEN C----------------------------------------------------------------------- C --- COMPUTE A 3X9 MOVING AVERAGE C----------------------------------------------------------------------- CALL averag(simon,savg,1,k,3,9) C----------------------------------------------------------------------- C --- APPLY END WEIGHTS FOR THE 3X9 C----------------------------------------------------------------------- CALL endsf(simon,savg,k,w9,5) ELSE IF(Mtype.eq.5.and.k.ge.20)THEN C----------------------------------------------------------------------- C --- COMPUTE A 3X15 MOVING AVERAGE C----------------------------------------------------------------------- CALL averag(simon,savg,1,k,3,15) C----------------------------------------------------------------------- C --- APPLY END WEIGHTS FOR THE 3X15 C----------------------------------------------------------------------- CALL endsf(simon,savg,k,w15,8) ELSE IF(Mtype.eq.6.or.Mtype.eq.5)THEN C----------------------------------------------------------------------- C --- STABLE SEASONAL. AVERAGE OF ALL SI RATIOS FOR THIS MONTH. C----------------------------------------------------------------------- tmp1=totals(simon,1,k,1,1) DO i=1,k savg(i)=tmp1 END DO ELSE IF(Mtype.eq.7)THEN C----------------------------------------------------------------------- C --- COMPUTE A 3-TERM MOVING AVERAGE. C----------------------------------------------------------------------- CALL averag(simon,savg,1,k,1,3) savg(1) = 0.61D0*simon(1)+0.39D0*simon(2) savg(k) = 0.61D0*simon(k)+0.39D0*simon(k-1) END IF k=0 DO i=j,Llda,Nyr k=k+1 Sts(i)=savg(k) END DO END DO C----------------------------------------------------------------------- c CHANGE BCM FEB 1996 - comment out return for linear seasonal c adjustment C----------------------------------------------------------------------- c IF(Linsa)RETURN C----------------------------------------------------------------------- C --- APPLY A 2 X NYR MOVING AVERAGE TO THE SEASONALS. C----------------------------------------------------------------------- CALL vsfc(Sts,Lfda,Llda,Nyr,Lter) C----------------------------------------------------------------------- RETURN END vsfc.f0000664006604000003110000000415714521201622011303 0ustar sun00315steps SUBROUTINE vsfc(Sts,Lfda,Llda,Nyr,Lter) IMPLICIT NONE C----------------------------------------------------------------------- C Center seasonal factors by applying a 2 x Nyr moving average to c them - made a subroutine to enable it to be applied to combined c seasonal factor from X-11 seasonal and user seasonal effects c BCM June 2003 C----------------------------------------------------------------------- INCLUDE 'srslen.prm' C----------------------------------------------------------------------- DOUBLE PRECISION Sts,Temp INTEGER i,k,k1,kfda,klda,Lfda,Llda,Nyr,Lter DIMENSION Lter(PSP),Sts(PLEN),Temp(PLEN) C----------------------------------------------------------------------- COMMON /work / Temp C----------------------------------------------------------------------- C --- APPLY A 2 X NYR MOVING AVERAGE TO THE SEASONALS. C----------------------------------------------------------------------- CALL averag(Sts,Temp,Lfda,Llda,2,Nyr) k=Nyr/2 kfda=Lfda+k klda=Llda-k C----------------------------------------------------------------------- C --- FILL IN THE MISSING END TERMS BY REPEATING FIRST AND LAST C --- AVAILABLE MOVING AVERAGE VALUE. C----------------------------------------------------------------------- * IF(allstb)THEN k1=mod(kfda,Nyr) DO i=1,k k1=k1-1 IF(k1.le.0)k1=Nyr+k1 IF(Lter(k1).eq.5)THEN Temp(kfda-i)=Temp(kfda-i+Nyr) ELSE Temp(kfda-i)=Temp(kfda) END IF END DO k1=mod(klda,Nyr) DO i=1,k k1=k1+1 IF(k1.gt.Nyr)k1=1 IF(Lter(k1).eq.5)THEN Temp(klda+i)=Temp(klda+i-Nyr) ELSE Temp(klda+i)=Temp(klda) END IF END DO C----------------------------------------------------------------------- C --- DIVIDE SEASONALS BY THE 2 X NYR MOVING AVERAGE C----------------------------------------------------------------------- CALL divsub(Sts,Sts,Temp,Lfda,Llda) C----------------------------------------------------------------------- RETURN END vtc.f0000664006604000003110000000650414521201623011135 0ustar sun00315stepsC Last change: BCM 17 Apr 2003 11:27 pm SUBROUTINE vtc(Stc,Stci) IMPLICIT NONE c----------------------------------------------------------------------- C --- VARIABLE TREND CYCLE ROUTINE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'x11ptr.cmn' INCLUDE 'x11opt.cmn' c ------------------------------------------------------------------ DOUBLE PRECISION ONE,ZERO PARAMETER(ONE=1D0,ZERO=0D0) c ------------------------------------------------------------------ LOGICAL T,F PARAMETER(T=.true.,F=.false.) c----------------------------------------------------------------------- LOGICAL lsame DOUBLE PRECISION apcc,apci,r,Stc,Stci,Temp INTEGER i,ib,ie,ie1 DIMENSION Temp(PLEN),Stc(PLEN),Stci(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- COMMON /work / Temp c----------------------------------------------------------------------- C --- IF THE SERIES IS MONTHLY APPLY A 13-TERM HENDERSON. IF IT IS C --- QUARTERLY APPLY A 5-TERM HENDERSON. c----------------------------------------------------------------------- lsame=F Nterm=Ny+1 CALL hndtrn(Stc,Stci,Pos1bk,Posffc,Nterm,Tic,F,lsame) c----------------------------------------------------------------------- C --- DROP END TERMS AND CALCULATE IRREGULAR SERIES. c----------------------------------------------------------------------- ib=Pos1bk+Nterm/2 ie=Posffc-Nterm/2 CALL divsub(Temp,Stci,Stc,ib,ie) c----------------------------------------------------------------------- C --- CALCULATE IBAR/CBAR RATIO. c----------------------------------------------------------------------- ie1=Posfob-Nterm/2-1 apcc=ZERO apci=ZERO IF(Muladd.eq.0)THEN DO i=ib,ie1 apcc=apcc+abs(Stc(i+1)-Stc(i))/Stc(i) apci=apci+abs(Temp(i+1)-Temp(i))/Temp(i) END DO ELSE DO i=ib,ie1 apcc=apcc+abs(Stc(i+1)-Stc(i)) apci=apci+abs(Temp(i+1)-Temp(i)) END DO END IF IF(dpeq(apcc,ZERO))THEN Ratic=999D0 r=Ratic ELSE Ratic=apci/apcc r=Ratic*12/Ny END IF c----------------------------------------------------------------------- C --- CHECK IF TREND CYCLE MOVING AVERAGE PRESELECTED. c----------------------------------------------------------------------- IF(Ktcopt.le.0)THEN IF((Kpart.eq.2.and.r.ge.ONE).or.(r.ge.ONE.and.r.lt.3.5D0))THEN lsame=T ELSE IF(r.lt.ONE)THEN IF(Ny.eq.12)THEN Nterm=9 Tic=ONE END IF ELSE Tic=4.5D0 Nterm=23 IF(Ny.eq.4)Nterm=7 END IF ELSE IF(Ktcopt.eq.Nterm)THEN lsame=T ELSE Nterm=Ktcopt END IF c----------------------------------------------------------------------- c Generate and apply symmetric henderson filter and end weights c----------------------------------------------------------------------- * 10 CALL hndtrn(Stc,Stci,Pos1bk,Posffc,Nterm,Tic,T,lsame) CALL hndtrn(Stc,Stci,Pos1bk,Posffc,Nterm,Tic,T,lsame) RETURN END vtest.f0000664006604000003110000000455614521201623011513 0ustar sun00315stepsC Last change: BCM 29 Oct 97 7:39 am SUBROUTINE vtest(X,I1,Ib,Ie) IMPLICIT NONE C*********************************************************************** c This routine is modified code which originally appeared in X12W - c the seasonal adjustment program developed by the Budesbank C*********************************************************************** INCLUDE 'srslen.prm' INCLUDE 'x11opt.cmn' C----------------------------------------------------------------------- INTEGER i,I1,Ib,Ie,j,n1,nmin DOUBLE PRECISION s,smax,st,t,tw,X,t4,tt DIMENSION X(*),t(40),t4(40),s(PSP) C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- DATA t/ & .5410D0,.3934D0,.3264D0,.2880D0,.2624D0,.2439D0,.2299D0,.2187D0, & .2098D0,.2020D0,.1980D0,.194D0,.186D0,.182D0,.178D0,.174D0,.17D0, & .166D0,.162D0,.158D0,.15D0,.15D0,.15D0,.15D0,.15D0,.15D0,.15D0, & .15D0,.15D0,.15D0,.15D0,.15D0,.15D0,.15D0,.15D0,.1403D0,.14D0, & .14D0,.14D0,.14D0/ DATA t4/ & .9065D0,.7679D0,.6841D0,.6287D0,.5895D0,.5598D0,.5365D0,.5175D0, & .5017D0,.4884D0,.480D0,.471D0,.463D0,.454D0,.445D0,.4366D0, & .433D0,.430D0,.427D0,.424D0,.421D0,.417D0,.414D0,.411D0,.408D0, & .404D0,.401D0,.398D0,.395D0,.391D0,.388D0,.385D0,.382D0,.379D0, & .375D0,.3720D0,.369D0,.366D0,.362D0,.359D0/ C*********************************************************************** c This routine performs Cochran's test to determine if the months c are heteroskedastic. C*********************************************************************** tw=0D0 I1=0 smax=-10.D0 nmin=100 st=1D0 IF(Muladd.eq.1)st=0D0 DO i=1,Ny n1=1 j=Ib+i-1 s(i)=0D0 DO WHILE (.true.) s(i)=s(i)+(X(j)-st)**2D0 j=j+Ny n1=n1+1 IF(j.gt.Ie)THEN nmin=min0(nmin,n1-2) s(i)=s(i)/dble(n1-1) smax=dmax1(smax,s(i)) tw=tw+s(i) GO TO 10 END IF END DO 10 CONTINUE END DO IF(.not.dpeq(tw,0D0))tw=smax/tw IF(nmin.gt.40)nmin=40 tt=t(nmin) IF(Ny.eq.4)tt=t4(nmin) IF(tw.ge.tt)I1=1 RETURN END weight.f0000664006604000003110000001176314521201623011633 0ustar sun00315stepsC Last change: BCM 21 Nov 97 10:42 pm **==weight.f processed by SPAG 4.03F at 09:55 on 1 Mar 1994 SUBROUTINE weight(A,B,I1,I2,Mq) IMPLICIT NONE C*** Start of declarations inserted by SPAG DOUBLE PRECISION A,B,cent,endw,end10,end11,end12,end7,end8,end9, & qcent,qend,qend3,qend4 INTEGER i,I1,I2,j,j1,j2,k,l1,l2,m1,m2,Mq C*** End of declarations inserted by SPAG C THIS SUBROUTINE PRODUCES WEIGHTS FOR THE CENTERED 24-TERM (MONTHLY) C MOVING AVERAGE (CENTERED 8-TERM QUARTERLY MOVING AVERAGE) C FOR THE PRELIMINARY ESTIMATION OF THE TREND-CYCLE. INCLUDE 'srslen.prm' DIMENSION cent(25),A(PLEN),B(PLEN),endw(6,24) DIMENSION qcent(9),qend(2,8),qend4(8),qend3(8) DIMENSION end12(24),end11(24),end10(24),end9(24),end8(24),end7(24) DATA cent/ & -0.0112773D0,-0.0273401D0,-0.0195570D0,-0.0053389D0, 0.0113162D0, & 0.0274075D0, 0.0416667D0, 0.0559258D0, 0.0720171D0, 0.0886723D0, & 0.1028903D0, 0.1106735D0, 0.1058879D0, 0.1106735D0, 0.1028903D0, & 0.0886723D0, 0.0720171D0, 0.0559258D0, 0.0416667D0, 0.0274075D0, & 0.0113162D0,-0.0053389D0,-0.0195570D0,-0.0273401D0,-0.0112773D0/ DATA end12/ & -0.0225546D0,-0.0234459D0,-0.0160151D0,-0.0026792D0, 0.0121628D0, & 0.0279138D0, 0.0413240D0, 0.0564321D0, 0.0728637D0, 0.0913320D0, & 0.1064322D0, 0.1145676D0, 0.1058879D0, 0.1067793D0, 0.0993484D0, & 0.0860125D0, 0.0711706D0, 0.0554195D0, 0.0420093D0, 0.0269012D0, & 0.0104697D0,-0.0079986D0,-0.0230988D0,-0.0312343D0/ DATA end11/ & -0.0106354D0,-0.0195678D0,-0.0208123D0,-0.0144215D0,-0.0026399D0, & 0.0121064D0, 0.0272793D0, 0.0432593D0, 0.0595187D0, 0.0811315D0, & 0.1018984D0, 0.1178834D0, 0.0939688D0, 0.1029011D0, 0.1041457D0, & 0.0977549D0, 0.0859732D0, 0.0712269D0, 0.0560541D0, 0.0400741D0, & 0.0238147D0, 0.0022018D0,-0.0185651D0,-0.0345500D0/ DATA end10/ & 0.0019024D0,-0.0124004D0,-0.0214279D0,-0.0229499D0,-0.0159235D0, & -0.0036926D0, 0.0116272D0, 0.0297519D0, 0.0471940D0, 0.0692546D0, & 0.0931847D0, 0.1151461D0, 0.0814309D0, 0.0957337D0, 0.1047612D0, & 0.1062832D0, 0.0992569D0, 0.0870260D0, 0.0717061D0, 0.0535814D0, & 0.0361393D0, 0.0140787D0,-0.0098514D0,-0.0318128D0/ DATA end9/ & 0.0121814D0,-0.0035929D0,-0.0177541D0,-0.0263876D0,-0.0255157D0, & -0.0176449D0,-0.0039735D0, 0.0141749D0, 0.0338072D0, 0.0566876D0, & 0.0805875D0, 0.1057635D0, 0.0711520D0, 0.0869263D0, 0.1010874D0, & 0.1097209D0, 0.1088491D0, 0.1009782D0, 0.0873068D0, 0.0691584D0, & 0.0495261D0, 0.0266457D0, 0.0027458D0,-0.0224301D0/ DATA end8/ & 0.0181990D0, 0.0047570D0,-0.0107207D0,-0.0239906D0,-0.0292988D0, & -0.0274358D0,-0.0176746D0,-0.0019316D0, 0.0172443D0, 0.0407996D0, & 0.0654582D0, 0.0895942D0, 0.0651343D0, 0.0785764D0, 0.0940541D0, & 0.1073239D0, 0.1126322D0, 0.1107692D0, 0.1010079D0, 0.0852650D0, & 0.0660891D0, 0.0425338D0, 0.0178751D0,-0.0062608D0/ DATA end7/ & 0.0192206D0, 0.0109225D0,-0.0021151D0,-0.0163613D0,-0.0263849D0, & -0.0309178D0,-0.0270820D0,-0.0170193D0,-0.0009008D0, 0.0188178D0, & 0.0438290D0, 0.0696580D0, 0.0641127D0, 0.0724108D0, 0.0854485D0, & 0.0996946D0, 0.1097182D0, 0.1142511D0, 0.1104153D0, 0.1003527D0, & 0.0842342D0, 0.0645156D0, 0.0395043D0, 0.0136754D0/ DATA qcent/ & -0.0258462D0,-0.0208718D0, 0.1250000D0, 0.2708718D0, 0.3016923D0, & 0.2708718D0, 0.1250000D0,-0.0208718D0,-0.0258462D0/ DATA qend4/ & -0.0516923D0, 0.0012821D0, 0.1323846D0, 0.2930256D0, 0.3016923D0, & 0.2487179D0, 0.1176154D0,-0.0430256D0/ DATA qend3/ & -0.0036410D0,-0.0579487D0, 0.0079487D0, 0.1786410D0, 0.2536410D0, & 0.3079487D0, 0.2420513D0, 0.0713590D0/ DO i=I1,I2 B(i)=0D0 END DO IF(Mq.ne.2)THEN j1=I1+12 j2=I2-12 DO i=j1,j2 B(i)=cent(13)*A(i) DO j=1,12 B(i)=B(i)+cent(13-j)*A(i-j)+cent(13+j)*A(i+j) END DO END DO DO j=1,24 endw(1,j)=end12(j) endw(2,j)=end11(j) endw(3,j)=end10(j) endw(4,j)=end9(j) endw(5,j)=end8(j) endw(6,j)=end7(j) END DO DO i=1,6 l1=j1-i l2=j2+i DO k=1,24 m1=l1+i+12-k m2=l2-i-12+k B(l1)=B(l1)+endw(i,k)*A(m1) B(l2)=B(l2)+endw(i,k)*A(m2) END DO END DO RETURN END IF j1=I1+4 j2=I2-4 DO i=j1,j2 B(i)=qcent(5)*A(i) DO j=1,4 B(i)=B(i)+qcent(5-j)*A(i-j)+qcent(5+j)*A(i+j) END DO END DO DO j=1,8 qend(1,j)=qend4(j) qend(2,j)=qend3(j) END DO DO i=1,2 l1=j1-i l2=j2+i DO k=1,8 m1=l1+i+4-k m2=l2-i-4+k B(l1)=B(l1)+qend(i,k)*A(m1) B(l2)=B(l2)+qend(i,k)*A(m2) END DO END DO RETURN END whitsp.f0000664006604000003110000000261114521201623011652 0ustar sun00315stepsC Last change: BCM 12 Mar 98 12:21 pm **==whitsp.f processed by SPAG 4.03F at 09:55 on 1 Mar 1994 INTEGER FUNCTION whitsp() IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'lex.i' INCLUDE 'cchars.i' c ----------------------------------------------------------------- CHARACTER chr*1,dmychr*1 c ----------------------------------------------------------------- CHARACTER getchr*1 EXTERNAL getchr c ----------------------------------------------------------------- DO WHILE (.true.) chr=getchr(dmychr) c ----------------------------------------------------------------- IF(chr.ne.' '.and.chr.ne.TABCHR.and.chr.ne.NEWLIN)THEN c---------------------------------------------------------------------- c Pass back any end-of-file c---------------------------------------------------------------------- IF(chr.eq.CHREOF)THEN whitsp=EOF c---------------------------------------------------------------------- c Put back the nonwhitespace character and return c---------------------------------------------------------------------- ELSE whitsp=NULL CALL putbak(chr) END IF c ----------------------------------------------------------------- RETURN END IF END DO END work2.cmn0000664006604000003110000000064314521201623011733 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Pbar,Autoc,Qu,Q2m2,Psq,Qual INTEGER Nn,Kfail,Nyrs LOGICAL Lstabl,L3x5 DIMENSION Psq(PSP),Pbar(PSP),Autoc(PSP+2),Qu(11) c----------------------------------------------------------------------- COMMON /work2 / Pbar,Autoc,Qu,Q2m2,Psq,Qual,Nn,Kfail,Nyrs,Lstabl, & L3x5 wprint.f0000664006604000003110000000202114521201623011652 0ustar sun00315steps SUBROUTINE wprint(Fh,S) c----------------------------------------------------------------------- c eprint.f, Release 1, Subroutine Version 1.3, Modified 24 Jan 1995. c----------------------------------------------------------------------- c eprint - print error, Lahey pc version c----------------------------------------------------------------------- c Author - Larry Bobbitt c Statistical Research Division c U.S. Census Bureau c Room 3000-4 c Washington, D.C. 20233 c (301) 763-3957 c----------------------------------------------------------------------- IMPLICIT NONE c ------------------------------------------------------------------ CHARACTER*(*) S INTEGER Fh c ------------------------------------------------------------------ WRITE(Fh,*)'

    WARNING: ',S,'

    ' c ------------------------------------------------------------------ RETURN END wr.f0000664006604000003110000000261614521201623010771 0ustar sun00315steps subroutine WRTOUT3(title,nz,mq,tramo,lam,npatd,neast,p,q,bp,bq,d, $ imean,sqf,nou3,bjstat2) C C.. Implicits .. implicit none C C.. Formal Arguments .. integer nz,mq,tramo,lam,npatd,neast,p,q,bp,bq,d,imean,nou3 character title*80 real*8 sqf,bjstat2 C C.. Local Scalars .. character adj include 'titl.i' include 'transcad.i' C C ... Executable Statements ... C if (lam .eq. 1) then adj = 'A' end if if (lam .eq. 0) then adj = 'M' end if 7000 format ( $///,2x,'SERIES | # OF OBS. | # OF | TYPE OF |', $' OUTLIERS |',/,2x, $' | | OBS/YEAR | ADJUSTMENT |', $' LEVEL SHIFT | ',A,' |') write (nou3,7000) transLcad(1:nTransLcad) write (nou3,7000) 7001 format ( $2x,'--------|-----------|----------|------------|', $'-------------|------------|') write (nou3,7001) 7002 format (10x,'|',11x,'|',10x,'|',12x,'|',13x,'|',12x,'|') write (nou3,7002) 7003 format (2x,a8,'|',4x,i3,4x,'|',4x,i2,4x,'|',5x,a1,6x,'|') write (nou3,7003) titleg, nz, mq, adj write (nou3,7002) write (nou3,7002) end subroutine SETTIME C C.. Implicits .. implicit none include 'xxxs.i' C C ... Executable Statements ... C COMPILA='19-JUL-2001' end writln.f0000664006604000003110000000172514521201623011660 0ustar sun00315stepsC Last change: BCM 13 Oct 1998 11:09 am **==writln.f processed by SPAG 4.03F at 09:55 on 1 Mar 1994 SUBROUTINE writln(Oline,Flhdnl,Flhdn2,Lblnk) IMPLICIT NONE c ----------------------------------------------------------------- INCLUDE 'units.cmn' * INCLUDE 'error.cmn' c ----------------------------------------------------------------- INTEGER Flhdnl,Flhdn2 CHARACTER Oline*(*) LOGICAL Lblnk c ----------------------------------------------------------------- IF(Flhdnl.eq.Mt2.or.Flhdn2.eq.Mt2)CALL errhdr IF(Flhdnl.gt.0)THEN IF(Lblnk)WRITE(Flhdnl,1010)' ' WRITE(Flhdnl,1010)Oline(1:min(131,len(Oline))) END IF IF(Flhdn2.gt.0)THEN IF(Lblnk)WRITE(Flhdn2,1010)' ' WRITE(Flhdn2,1010)Oline(1:min(131,len(Oline))) END IF 1010 FORMAT(' ',a) c ----------------------------------------------------------------- RETURN END wrtdat.f0000664006604000003110000000316114521201624011643 0ustar sun00315stepsC Last change: BCM 24 Nov 97 12:07 pm SUBROUTINE wrtdat(Idate,Sp,Str,Nchr) IMPLICIT NONE c----------------------------------------------------------------------- c Puts the date in character format for outlier variables and c printouts. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'error.cmn' c ------------------------------------------------------------------ CHARACTER cmo*3 DIMENSION cmo(12) c ------------------------------------------------------------------ c moved by Bob Fay CHARACTER Str*(*) INTEGER Idate,Nchr,Sp DIMENSION Idate(2) c ------------------------------------------------------------------ DATA cmo/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ c ------------------------------------------------------------------ Nchr=1 CALL itoc(Idate(YR),Str,Nchr) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Sp.gt.1)THEN Str(Nchr:Nchr)='.' Nchr=Nchr+1 c ------------------------------------------------------------------ IF(Sp.eq.12)THEN Str(Nchr:Nchr+2)=cmo(Idate(MO)) Nchr=Nchr+3 c ------------------------------------------------------------------ ELSE CALL itoc(Idate(MO),Str,Nchr) IF(Lfatal)RETURN END IF END IF Nchr=Nchr-1 c ------------------------------------------------------------------ RETURN END wrtmss.f0000664006604000003110000001131514521201624011675 0ustar sun00315stepsC Last change: BCM 20 May 1998 11:08 am **==wrtmss.f processed by SPAG 4.03F at 12:24 on 21 Jun 1994 SUBROUTINE wrtmss(M,Iy,X,Dmax,Ncol,Nopt,Iobs,Fnote,L2Big) IMPLICIT NONE c----------------------------------------------------------------------- c Routine which prints out the sliding spans for each observation. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'notset.prm' INCLUDE 'units.cmn' c----------------------------------------------------------------------- INTEGER hicode,icode,jcode,M,Iy,i,i2,Nopt,Iobs,Ncol,n1,n2 LOGICAL L2Big CHARACTER cfmt*(80),starz*(9),star0*(10),Fnote*(10) DOUBLE PRECISION Dmax,X DIMENSION X(MXLEN,MXCOL),Dmax(MXLEN,NEST) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- DATA starz/'*********'/ DATA star0/'**********'/ c----------------------------------------------------------------------- hicode=0 jcode=1 icode=0 DO i=Ncol,1,-1 IF(dpeq(X(Iobs,i),DNOTST))icode=icode+jcode hicode=hicode+jcode IF(i.gt.1)jcode=jcode*10 END DO c----------------------------------------------------------------------- IF(icode.eq.0)THEN IF(L2Big)THEN WRITE(Mt1,F3)M,'-',Iy,(X(Iobs,i),i=1,Ncol),Dmax(Iobs,Nopt),Fnote ELSE WRITE(Mt1,F1)M,'-',Iy,(X(Iobs,i),i=1,Ncol),Dmax(Iobs,Nopt),Fnote END IF RETURN END IF c----------------------------------------------------------------------- IF(icode.eq.hicode)THEN IF(L2big)THEN WRITE(cfmt,910)Ncol 910 FORMAT('(1X,I2,A1,I4,2X,',i1,'(A10,1X),3X,A9,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(star0,i=1,Ncol),starz,Fnote ELSE WRITE(cfmt,1010)Ncol 1010 FORMAT('(1X,I2,A1,I4,2X,',i1,'(A9,2X),3X,A9,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(starz,i=1,Ncol),starz,Fnote END IF c----------------------------------------------------------------------- ELSE IF(icode.eq.(hicode-jcode))THEN IF(L2big)THEN WRITE(cfmt,920)Ncol-1 920 FORMAT('(1X,I2,A1,I4,2X,E10.4,1X,',i1,'(A10,1X),3X,A9,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,X(Iobs,1),(star0,i=1,Ncol-1),starz,Fnote ELSE WRITE(cfmt,1020)Ncol-1 1020 FORMAT('(1X,I2,A1,I4,2X,F9.2,2X,',i1,'(A9,2X),3X,A9,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,X(Iobs,1),(starz,i=1,Ncol-1),starz,Fnote END IF c----------------------------------------------------------------------- ELSE IF(icode.eq.(hicode-1))THEN IF(L2big)THEN WRITE(cfmt,930)Ncol-1 930 FORMAT('(1X,I2,A1,I4,2X,',i1,'(A10,1X),E10.4,1X,3X,A9,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(star0,i=1,Ncol-1),X(Iobs,Ncol),starz, & Fnote ELSE WRITE(cfmt,1030)Ncol-1 1030 FORMAT('(1X,I2,A1,I4,2X,',i1,'(A9,2X),F9.2,2X,3X,A9,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(starz,i=1,Ncol-1),X(Iobs,Ncol),starz, & Fnote END IF c----------------------------------------------------------------------- ELSE IF(icode.lt.jcode)THEN n2=1 IF(Ncol.eq.4.and.icode.gt.1)n2=2 n1=Ncol-n2 IF(L2big)THEN WRITE(cfmt,940)n1,n2 940 FORMAT('(1X,I2,A1,I4,2X,',i1,'(E10.4,1X),',i1, & '(A10,1X),3X,F9.2,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(X(Iobs,i),i=1,n1),(star0,i2=1,n2), & Dmax(Iobs,Nopt),Fnote ELSE WRITE(cfmt,1040)n1,n2 1040 FORMAT('(1X,I2,A1,I4,2X,',i1,'(F9.2,2X),',i1, & '(A9,2X),3X,F9.2,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(X(Iobs,i),i=1,n1),(starz,i2=1,n2), & Dmax(Iobs,Nopt),Fnote END IF c----------------------------------------------------------------------- ELSE n1=1 IF(Ncol.eq.4.and.icode.gt.1000)n1=2 n2=Ncol-n1 IF(L2big)THEN WRITE(cfmt,950)n1,n2 950 FORMAT('(1X,I2,A1,I4,2X,',i1,'(A10,1X),',i1, & '(E10.4,1X),3X,F9.2,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(star0,i2=1,n1),(X(Iobs,i),i=n1+1,Ncol), & Dmax(Iobs,Nopt),Fnote ELSE WRITE(cfmt,1050)n1,n2 1050 FORMAT('(1X,I2,A1,I4,2X,',i1,'(A9,2X),',i1, & '(F9.2,2X),3X,F9.2,2x,a10)') WRITE(Mt1,cfmt)M,'-',Iy,(starz,i2=1,n1),(X(Iobs,i),i=n1+1,Ncol), & Dmax(Iobs,Nopt),Fnote END IF END IF c----------------------------------------------------------------------- RETURN END wrtotl.f0000664006604000003110000000666614521201624011706 0ustar sun00315stepsC Last change: BCM 14 May 1998 8:45 am **==wrtotl.f processed by SPAG 4.03F at 09:55 on 1 Mar 1994 SUBROUTINE wrtotl(Itype,Begotl,Endotl,Begdat,Sp,Otlttl,Nchr) IMPLICIT NONE c----------------------------------------------------------------------- c Writes an outlier specifier 'AOyr.mo', 'LSyr.mo', or c 'ROyr.mo-yr.mo' given the type, dates (yr,mo) and the reference date. c Write or AOyr, LSyr, or ROyr-yr for annual or nonseasonal data. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c begdat i Input 2 long vector (yr,mo) for the begining data of the c data or regression variables, used as a reference to c calculate t0. c begotl i Input begining point for a ramp outlier and t0 for an AO c or level shift. c endotl i Input end point for a ramp outlier and undefined for an c AO or LS c itype i Input type of outlier 1=AO, 2=LS, 3=TC, 4=SO, 5=RO, 6=MV c otldat i Local 4 long vector for the begining (yr,mo) and possibly c the ending (yr,mo) of the outlier. c otlttl c Output outlier specifier to be read c otltyp c Local 3 long pcolcr character vector of character codes c for the outlier types, AO, LS, and RO, for additive, c level shift, or ramp outlier respectively. c sp i Input length of the seasonal period c----------------------------------------------------------------------- c Data typing and variable initialization c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'units.cmn' INCLUDE 'error.cmn' c----------------------------------------------------------------------- INTEGER NOTYPE PARAMETER(NOTYPE=6) c----------------------------------------------------------------------- CHARACTER Otlttl*(*),otltyp*2 INTEGER Begdat,Begotl,Endotl,itmp,Itype,Nchr,otldat,Sp DIMENSION Begdat(2),otldat(2),otltyp(NOTYPE) DATA otltyp/'AO','LS','TC','SO','Rp','MV'/ c----------------------------------------------------------------------- c Read the type and date(s) c----------------------------------------------------------------------- CALL addate(Begdat,Sp,Begotl-1,otldat) c ------------------------------------------------------------------ CALL wrtdat(otldat,Sp,Otlttl(3:),Nchr) IF(Lfatal)RETURN Nchr=Nchr+2 c ------------------------------------------------------------------ IF(Itype.eq.(NOTYPE-1))THEN Nchr=Nchr+1 Otlttl(Nchr:Nchr)='-' Nchr=Nchr+1 CALL addate(Begdat,Sp,Endotl-1,otldat) CALL wrtdat(otldat,Sp,Otlttl(Nchr:),itmp) IF(Lfatal)RETURN Nchr=Nchr+itmp-1 END IF c ------------------------------------------------------------------ CALL setchr(' ',len(Otlttl)-Nchr,Otlttl(Nchr+1:)) c ------------------------------------------------------------------ IF(Itype.lt.1.or.Itype.gt.NOTYPE)THEN CALL errhdr WRITE(STDERR,1010)Itype,Otlttl WRITE(Mt2,1010)Itype,Otlttl 1010 FORMAT(/,' ERROR: Invalid outlier type,',i5,', ',a,'.') CALL abend RETURN ELSE Otlttl(1:2)=otltyp(Itype) END IF c ------------------------------------------------------------------ RETURN END wrttb2.f0000664006604000003110000002112214521201624011557 0ustar sun00315steps SUBROUTINE wrttb2(Tmp,Ctmp,Jyr,Tyrly,L,Kdec,Mt1,Tblfmt,Tblwid, & Tblcol,Disp1,Disp2,Disp3,Nb,Nb1,Ipow,Disp4, & Lastcl) IMPLICIT NONE c----------------------------------------------------------------------- C THIS SUBROUTINE WAS ORIGINALLY WRITTEN BY DAVE PALETZ OF SRD, 9/91 C REVISED: BRIAN MONSELL, 8/95 and 1/2000 (to include labels) c----------------------------------------------------------------------- C SOMETIMES ONE OR MORE MONTHS IN A YEAR HAVE NO DATA PROVIDED BY THE C USER. WHEN SO, THE PROGRAM DISPLAYS AN ERROR MESSAGE WHEN IT PRINTS C THESE BLANK FIGURES IN THE TABLE AS REAL NUMBERS. THIS WAS INTENDED C SO THAT THE ASTERISKS WOULD REMIND THE USER THAT DATA WAS MISSING FOR C THAT MONTH. THE SUBROUTINE BELOW SUPRESSES THE ERROR MESSAGE WHILE C CONTINUING TO PLACE THE ASTERISKS WHERE THEY ARE NEEDED. C C I: Looping variable C IPOW: 0 if figure should not be expressed as percentage; 1 if it C should be C JYR: Year of the data to print C KDEC: Number of places behind decimal to display C L: Number of observations for the year plus total (12+1=13 for C monthly figures; 4+1=5 for quarterly) C LOOP: Looping variable C MT1: The unit number of the output file C TBLFMT: The format to use in the table C TMP: The user supplied observations for one year C TYRLY: Title for the average or total output line c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION BIG PARAMETER(BIG=10D16) c----------------------------------------------------------------------- DOUBLE PRECISION Tmp,postmp LOGICAL Lstar,Lastcl INTEGER i,Jyr,Kdec,L,Tblcol,loop,Mt1,Tblwid,Ipow,lstob,ipos,j,j2, & Disp1,Disp2,Disp3,Disp4,cnum,nlen,Nb,Nb1,ipos2,tw2 CHARACTER Tblfmt*(*),Tyrly*(5),chtmp*(25),star*(25),blank*(56), & dfmt*(13),xlin*(132),cy*(4),Ctmp*(*) DIMENSION chtmp(PSP+1),Tmp(*),Ctmp(*),postmp(PSP+1) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION ceilng EXTERNAL dpeq,ceilng c----------------------------------------------------------------------- DATA star/'*************************'/ DATA blank/ & ' '/ c----------------------------------------------------------------------- c Set position of last observation of the year c----------------------------------------------------------------------- lstob=L IF(Lastcl)lstob=lstob-1 c----------------------------------------------------------------------- C Go through L elements one at a time checking to see if special c output is needed c----------------------------------------------------------------------- Lstar=.false. DO i=1,L c----------------------------------------------------------------------- C If the element is 1 quadrillion or more, this means the C observation is assumed to be missing for this month/quarter. c Set Lstar to true, and set up the label for missing values. c If the missing value is before the start or end of the series, c set the label to blanks instead of stars. c----------------------------------------------------------------------- chtmp(i)=blank(1:Tblwid+2) IF(dpeq(Tmp(i),DNOTST).or.Tmp(i).ge.BIG)THEN IF(.not.Lstar)Lstar=.true. chtmp(i)=star(1:Tblwid+2) IF(Nb.gt.0.and.i.lt.Nb)chtmp(i)=blank(1:Tblwid+2) IF(Nb1.gt.0.and.i.gt.Nb1)chtmp(i)=blank(1:Tblwid+2) ELSE postmp(i)=Tmp(i) IF(Ipow.eq.1)postmp(i)=postmp(i)*100d0 c----------------------------------------------------------------------- c For cases where Kdec = 0 and the decimal fraction is exactly .5, c make an adjustment to ensure the number will round properly c when printed (BCM April 2007) c----------------------------------------------------------------------- IF(dpeq(postmp(i)-ceilng(postmp(i)-0.5D0),0.5D0).and.Kdec.eq.0) & postmp(i)=postmp(i)+0.01D0 END IF END DO IF(Lstar)THEN c----------------------------------------------------------------------- c Initial variables for printing stars for missing values. c----------------------------------------------------------------------- loop=lstob/Tblcol IF(mod(lstob,Tblcol).gt.0)loop=loop+1 cnum=1 c----------------------------------------------------------------------- c Write the observation format into dfmt. c----------------------------------------------------------------------- tw2=Tblwid-1 IF((Disp2-Disp4).gt.0)THEN IF(tw2.le.9)THEN WRITE(dfmt,1010)Disp2-Disp4,tw2,Kdec 1010 FORMAT('(',i1,'x,f',i1,'.',i1,',a)') ELSE WRITE(dfmt,1020)Disp2-Disp4,tw2,Kdec 1020 FORMAT('(',i1,'x,f',i2,'.',i1,',a)') END IF ELSE IF(tw2.le.9)THEN WRITE(dfmt,1011)tw2,Kdec 1011 FORMAT('(f',i1,'.',i1,',a)') ELSE WRITE(dfmt,1021)tw2,Kdec 1021 FORMAT('(f',i2,'.',i1,',a)') END IF END IF c----------------------------------------------------------------------- c For each line to be printed out, set up a character string c in the table format. c----------------------------------------------------------------------- DO i=1,loop c----------------------------------------------------------------------- c IF this is the first line, store year or label first on xlin. c----------------------------------------------------------------------- IF(i.eq.1)THEN IF(Tyrly.eq.'XXXXX')THEN nlen=1 CALL itoc(Jyr,cy,nlen) IF(Lfatal)RETURN xlin(1:(Disp1+6))=blank(1:(7-nlen))//cy(1:(nlen-1))// & blank(1:Disp1) ELSE xlin(1:(Disp1+6))=' '//Tyrly//blank(1:Disp1) END IF c----------------------------------------------------------------------- c For all other lines, store blanks for first Disp1+6 spaces of the c line. c----------------------------------------------------------------------- ELSE xlin(1:(Disp1+6))=blank(1:(Disp1+6)) END IF ipos=Disp1+6 c----------------------------------------------------------------------- c Loop through all the observations that will be printed on this c line. c----------------------------------------------------------------------- j2=cnum+Tblcol-1 IF(j2.gt.lstob)j2=lstob DO j=cnum,j2 c----------------------------------------------------------------------- c If observation is considered missing, store out stars; else, c write the observation in the correct format. c----------------------------------------------------------------------- ipos2=ipos+Tblwid+Disp2 IF(dpeq(Tmp(j),DNOTST).or.Tmp(j).ge.BIG)THEN IF(Disp2.eq.0)THEN xlin((ipos+1):ipos2)=chtmp(j)(1:Tblwid) ELSE xlin((ipos+1):ipos2)=blank(1:Disp2)//chtmp(j)(1:Tblwid) END IF ELSE WRITE(xlin((ipos+1):ipos2),dfmt)postmp(j),Ctmp(j) END IF ipos=ipos2 END DO IF(i.eq.loop.and.L.gt.lstob.and.Disp3.gt.0)THEN xlin((ipos+1):(ipos+Disp3))=blank(1:Disp3) ipos=ipos+Disp3 WRITE(dfmt,1030)Tblwid+2,Kdec 1030 FORMAT('( f',i2,'.',i1,')') WRITE(xlin((ipos+1):(ipos+Tblwid+2)),dfmt)postmp(j) ipos=ipos+Tblwid+2 END IF c----------------------------------------------------------------------- c Write fully formatted line to output file c----------------------------------------------------------------------- WRITE(Mt1,1040)xlin(1:ipos) 1040 FORMAT(a) cnum=cnum+Tblcol END DO ELSE c----------------------------------------------------------------------- C Print in table format. c----------------------------------------------------------------------- IF(Tyrly.eq.'XXXXX')THEN IF(Lastcl)THEN WRITE(Mt1,Tblfmt)Jyr,(postmp(j),ctmp(j),j=1,L-1),postmp(L) ELSE WRITE(Mt1,Tblfmt)Jyr,(postmp(j),ctmp(j),j=1,L) END IF ELSE WRITE(Mt1,Tblfmt)Tyrly,(postmp(j),ctmp(j),j=1,L) END IF END IF c----------------------------------------------------------------------- RETURN END wrttbl.f0000664006604000003110000002013214521201624011651 0ustar sun00315stepsC Last change: BCM 19 Apr 2007 4:06 pm **==wrttbl.f processed by SPAG 4.03F at 09:55 on 1 Mar 1994 SUBROUTINE wrttbl(Tmp,Jyr,Tyrly,L,Kdec,Mt1,Tblfmt,Tblwid,Tblcol, & Disp1,Disp2,Disp3,Nb,Nb1,Ipow,Lastcl) IMPLICIT NONE c----------------------------------------------------------------------- C THIS SUBROUTINE WAS ORIGINALLY WRITTEN BY DAVE PALETZ OF SRD, 9/91 C REVISED: BRIAN MONSELL, 8/95 c----------------------------------------------------------------------- C SOMETIMES ONE OR MORE MONTHS IN A YEAR HAVE NO DATA PROVIDED BY THE C USER. WHEN SO, THE PROGRAM DISPLAYS AN ERROR MESSAGE WHEN IT PRINTS C THESE BLANK FIGURES IN THE TABLE AS REAL NUMBERS. THIS WAS INTENDED C SO THAT THE ASTERISKS WOULD REMIND THE USER THAT DATA WAS MISSING FOR C THAT MONTH. THE SUBROUTINE BELOW SUPRESSES THE ERROR MESSAGE WHILE C CONTINUING TO PLACE THE ASTERISKS WHERE THEY ARE NEEDED. C C I: Looping variable C IPOW: 0 if figure should not be expressed as percentage; 1 if it C should be C JYR: Year of the data to print C KDEC: Number of places behind decimal to display C L: Number of observations for the year plus total (12+1=13 for C monthly figures; 4+1=5 for quarterly) C LOOP: Looping variable C MT1: The unit number of the output file C TBLFMT: The format to use in the table C TMP: The user supplied observations for one year C TYRLY: Title for the average or total output line c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'error.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION BIG PARAMETER(BIG=10D16) c----------------------------------------------------------------------- DOUBLE PRECISION Tmp,postmp LOGICAL Lstar,Lastcl INTEGER i,Jyr,Kdec,L,Tblcol,loop,Mt1,Tblwid,Ipow,lstob,ipos,j,j2, & Disp1,Disp2,Disp3,cnum,nlen,Nb,Nb1,ipos2 CHARACTER Tblfmt*(*),Tyrly*(5),chtmp*(25),star*(25),blank*(56), & dfmt*(10),xlin*(132),cy*(4) DIMENSION chtmp(PSP+1),Tmp(*),postmp(PSP+1) c----------------------------------------------------------------------- LOGICAL dpeq DOUBLE PRECISION ceilng EXTERNAL dpeq,ceilng c----------------------------------------------------------------------- DATA star/'*************************'/ DATA blank/ & ' '/ c----------------------------------------------------------------------- c Set position of last observation of the year c----------------------------------------------------------------------- lstob=L IF(Lastcl)lstob=lstob-1 c----------------------------------------------------------------------- C Go through L elements one at a time checking to see if special c output is needed c----------------------------------------------------------------------- Lstar=.false. DO i=1,L c----------------------------------------------------------------------- C If the element is 1 quadrillion or more, this means the C observation is assumed to be missing for this month/quarter. c Set Lstar to true, and set up the label for missing values. c If the missing value is before the start or end of the series, c set the label to blanks instead of stars. c----------------------------------------------------------------------- chtmp(i)=blank(1:Tblwid+2) IF(dpeq(Tmp(i),DNOTST).or.Tmp(i).ge.BIG)THEN IF(.not.Lstar)Lstar=.true. chtmp(i)=star(1:Tblwid+2) IF(Nb.gt.0.and.i.lt.Nb)chtmp(i)=blank(1:Tblwid+2) IF(Nb1.gt.0.and.i.gt.Nb1)chtmp(i)=blank(1:Tblwid+2) ELSE postmp(i)=Tmp(i) IF(Ipow.eq.1)postmp(i)=postmp(i)*100d0 c----------------------------------------------------------------------- c For cases where Kdec = 0 and the decimal fraction is exactly .5, c make an adjustment to ensure the number will round properly c when printed (BCM April 2007) c----------------------------------------------------------------------- IF(dpeq(postmp(i)-ceilng(postmp(i)-0.5D0),0.5D0).and.Kdec.eq.0) & postmp(i)=postmp(i)+0.01D0 END IF END DO IF(Lstar)THEN c----------------------------------------------------------------------- c Initial variables for printing stars for missing values. c----------------------------------------------------------------------- loop=lstob/Tblcol IF(mod(lstob,Tblcol).gt.0)loop=loop+1 cnum=1 c----------------------------------------------------------------------- c Write the observation format into dfmt. c----------------------------------------------------------------------- IF(Tblwid.le.9)THEN WRITE(dfmt,1010)Disp2,Tblwid,Kdec 1010 FORMAT('(',i1,'x,f',i1,'.',i1,')') ELSE WRITE(dfmt,1020)Disp2,Tblwid,Kdec 1020 FORMAT('(',i1,'x,f',i2,'.',i1,')') END IF c----------------------------------------------------------------------- c For each line to be printed out, set up a character string c in the table format. c----------------------------------------------------------------------- DO i=1,loop c----------------------------------------------------------------------- c IF this is the first line, store year or label first on xlin. c----------------------------------------------------------------------- IF(i.eq.1)THEN IF(Tyrly.eq.'XXXXX')THEN nlen=1 CALL itoc(Jyr,cy,nlen) IF(Lfatal)RETURN xlin(1:(Disp1+6))=blank(1:(7-nlen))//cy(1:(nlen-1))// & blank(1:Disp1) ELSE xlin(1:(Disp1+6))=' '//Tyrly//blank(1:Disp1) END IF c----------------------------------------------------------------------- c For all other lines, store blanks for first Disp1+6 spaces of the c line. c----------------------------------------------------------------------- ELSE xlin(1:(Disp1+6))=blank(1:(Disp1+6)) END IF ipos=Disp1+6 c----------------------------------------------------------------------- c Loop through all the observations that will be printed on this c line. c----------------------------------------------------------------------- j2=cnum+Tblcol-1 IF(j2.gt.lstob)j2=lstob DO j=cnum,j2 c----------------------------------------------------------------------- c If observation is considered missing, store out stars; else, c write the observation in the correct format. c----------------------------------------------------------------------- ipos2=ipos+Tblwid+Disp2 IF(dpeq(Tmp(j),DNOTST).or.Tmp(j).ge.BIG)THEN IF(Disp2.eq.0)THEN xlin((ipos+1):ipos2)=chtmp(j)(1:Tblwid) ELSE xlin((ipos+1):ipos2)=blank(1:Disp2)//chtmp(j)(1:Tblwid) END IF ELSE WRITE(xlin((ipos+1):ipos2),dfmt)postmp(j) END IF ipos=ipos2 END DO IF(i.eq.loop.and.L.gt.lstob.and.Disp3.gt.0)THEN xlin((ipos+1):(ipos+Disp3))=blank(1:Disp3) ipos=ipos+Disp3 WRITE(dfmt,1030)Tblwid+2,Kdec 1030 FORMAT('( f',i2,'.',i1,')') WRITE(xlin((ipos+1):(ipos+Tblwid+2)),dfmt)postmp(j) ipos=ipos+Tblwid+2 END IF c----------------------------------------------------------------------- c Write fully formatted line to output file c----------------------------------------------------------------------- WRITE(Mt1,1040)xlin(1:ipos) 1040 FORMAT(a) cnum=cnum+Tblcol END DO ELSE c----------------------------------------------------------------------- C Print in table format. c----------------------------------------------------------------------- IF(Tyrly.eq.'XXXXX')THEN WRITE(Mt1,Tblfmt)Jyr,(postmp(j),j=1,L) ELSE WRITE(Mt1,Tblfmt)Tyrly,(postmp(j),j=1,L) END IF END IF RETURN END wtxtrm.f0000664006604000003110000000365314521201624011711 0ustar sun00315stepsC Last change: BCM 25 Nov 97 10:46 am **==wtxtrm.f processed by SPAG 4.03F at 17:00 on 16 May 1994 DOUBLE PRECISION FUNCTION wtxtrm(X,Xbar,Stddev,Sigmu,Sigml,Istep, & Lstwt) IMPLICIT NONE c ------------------------------------------------------------------ DOUBLE PRECISION MONE,ZERO PARAMETER(MONE=-1D0,ZERO=0D0) c----------------------------------------------------------------------- DOUBLE PRECISION X,Xbar,Stddev,Sigmu,Sigml,temp,Lstwt INTEGER Istep c----------------------------------------------------------------------- c Initialize extreme weight c----------------------------------------------------------------------- wtxtrm=Lstwt c----------------------------------------------------------------------- C --- COMPUTE DEVIATION OF EACH IRREGULAR VALUE. c----------------------------------------------------------------------- temp=abs(X-Xbar)/Stddev IF(temp.le.Sigmu)THEN c----------------------------------------------------------------------- C --- ASSIGN GRADUATED WEIGHT BETWEEN THE LIMITS. c----------------------------------------------------------------------- IF(temp.gt.Sigml.and.Istep.ne.1)wtxtrm=(Sigmu-temp)/(Sigmu-Sigml) ELSE IF(Istep.eq.1)THEN c----------------------------------------------------------------------- C --- IN THE FIRST ITERATION ASSIGN A WEIGHT OF 0.0 TO ALL EXTREMES. c----------------------------------------------------------------------- wtxtrm=ZERO ELSE IF(Lstwt.gt.ZERO)THEN c----------------------------------------------------------------------- C --- IN THE SECOND ITERATION ASSIGN A TEMPORARY WEIGHT OF -1.0 TO C --- ALL EXTREMES. c----------------------------------------------------------------------- wtxtrm=MONE END IF c----------------------------------------------------------------------- RETURN END x11adj.cmn0000664006604000003110000000660114521201624011760 0ustar sun00315stepsc----------------------------------------------------------------------- c Common blocks for the adjustment factors derived from regression c effects estimated in the REG-ARIMA routines c----------------------------------------------------------------------- c FinAO - Logical variable indication whether to adjust the c final seasonally adjusted series with Regarima AO factors c FinLS - Logical variable indication whether to adjust the c final seasonally adjusted series with Regarima LS factors c FinTC - Logical variable indication whether to adjust the c final seasonally adjusted series with Regarima TC factors c Finusr - Logical variable indication whether to adjust the c final seasonally adjusted series with Regarima factors c derived from user-defined regression variables c Finhol - Logical variable indication whether to adjust the c final seasonally adjusted series with either Regarima c or X-11 holiday factors c----------------------------------------------------------------------- LOGICAL Finhol,FinAO,FinLS,FinTC,Finusr c----------------------------------------------------------------------- c Adjtd - Integer variable indication whether to adjust the c original series with Regarima TD factors c AdjAO - Integer variable indication whether to adjust the c original series with Regarima AO factors c AdjLS - Integer variable indication whether to adjust the c original series with Regarima LS factors c AdjTC - Integer variable indication whether to adjust the c original series with Regarima TC factors c AdjSO - Integer variable indication whether to adjust the c original series with Regarima SO factors c Adjsea - Integer variable indication whether to adjust the c original series with Regarima seasonal factors c Adjusr - Integer variable indication whether to adjust the c original series with Regarima factors derived from c user-defined regression variables c Adjhol - Integer variable indication whether to adjust the c original series with Regarima holiday factors c Adjcyc - Integer variable indication whether to adjust the c original series with a user-defined transitory component c estimated from the regARIMA model (only used with SEATS) c NAO - Number of AO outliers c NTC - Number of TC outliers c NLS - Number of LS outliers c NSO - Number of SO outliers c Nhol - Number of holiday regressors c Neas - Number of Easter regressors c Nusrrg - Number of user defined regression types specified c Nflwtd - Number of flow trading day regressors c----------------------------------------------------------------------- INTEGER Adjtd,Adjhol,AdjAO,AdjLS,AdjTC,AdjSO,Adjsea,Adjusr,Adjcyc, & NAO,NLS,NTC,NSO,NRamp,Nusrrg,Nhol,Neas,Nln,Nsln,Nlp, & Nflwtd,Nseq c----------------------------------------------------------------------- COMMON / x11adj / Adjtd,Adjhol,AdjAO,AdjLS,AdjTC,AdjSO,Adjsea, & Adjcyc,Adjusr,Finhol,FinAO,FinLS,FinTC,Finusr COMMON / numotl / Nusrrg,NAO,NLS,NTC,NSO,NRamp,Nhol,Neas,Nln,Nsln, & Nlp,Nflwtd,Nseq x11aic.f0000664006604000003110000006516414521201624011437 0ustar sun00315stepsC Last change: BCM 20 May 1999 9:20 am SUBROUTINE x11aic(Irridx,Irrend,Muladd,Psuadd,Trnsrs,A,Nbeg,Sti, & Kswv,Priadj,Trumlt,Lprt,Lsavlg,Ldiag) IMPLICIT NONE c----------------------------------------------------------------------- c This routine performs two tests for the irregular regression. c----------------------------------------------------------------------- c First, perform the test for trading day: c Estimate two regARIMA models - one with TD, one without. The c routine will choose the model with the lowest value of AICC and c print out the resulting model. c----------------------------------------------------------------------- c Then, perform the test for easter: c Estimate a number of regARIMA model, each with either no easter c effect or an easter effect with length 1, 8, or 15. This routine c chooses the model with the lowest value of AICC and prints out the c resulting model. c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'error.cmn' INCLUDE 'units.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'extend.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'usrxrg.cmn' INCLUDE 'xrgum.cmn' INCLUDE 'xclude.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- LOGICAL T,F INTEGER PA PARAMETER(T=.true.,F=.false.,PA=PLEN+2*PORDER) c----------------------------------------------------------------------- CHARACTER effttl*(PCOLCR),tdstr*(30),datstr*(10),fmtsvl*(21) LOGICAL Lprt,Psuadd,xm,Trumlt,tdhol,lhum2,estend,ladj,Lsavlg,fx2, & Ldiag DOUBLE PRECISION A,aicbst,aichol,aicntd,aicnus,aictd,aicusr,bu2, & jadj,jadj2,Sti,Trnsrs,zero INTEGER i,icol,Muladd,Nbeg,nchr,frstry,Irridx,Kswv,ncx2,Priadj, & ndifum,begcol,iuser,tdindx,rtype,ntdchr,nchdat,Irrend, & ncol,igrp,typ2 DIMENSION A(PA),Sti(PLEN),Trnsrs(PLEN),bu2(PUREG),zero(PLEN), & fx2(PUREG),typ2(PUREG) c----------------------------------------------------------------------- INTEGER strinx EXTERNAL strinx c----------------------------------------------------------------------- aicind=-1 estend=T IF(Xtdtst.gt.0)THEN IF(Tdgrp.gt.0)Tdgrp=0 IF(Stdgrp.gt.0)Stdgrp=0 END IF IF(Xeastr)THEN IF(Holgrp.gt.0)Holgrp=0 IF(Easgrp.gt.0)Easgrp=0 END IF IF(Xuser)THEN IF(Ncusrx.gt.0)THEN ncx2=Ncusrx Ncusrx=0 lhum2=Haveum Haveum=F ELSE Xuser=F END IF END IF CALL setdp(0D0,PLEN,zero) iuser=0 c----------------------------------------------------------------------- tdindx=Xtdtst IF(tdindx.eq.4)tdindx=6 IF(tdindx.eq.3)tdindx=4 IF(tdindx.eq.2)tdindx=3 c----------------------------------------------------------------------- c If multiplicative or log-additive seasonal adjustment done, c get jacobean adjustment for AICC based on N(t)* c----------------------------------------------------------------------- IF(Trumlt.or.Muladd.eq.2)THEN jadj=0D0 DO i=Irridx,Irrend ladj=T IF(Nxcld.gt.0)ladj=.not.Rgxcld(i-Irridx+1) IF(ladj)jadj=jadj+log(Xnstar(i)) END DO c----------------------------------------------------------------------- c If log-additive seasonal adjustment done, get jacobean adjustment c for AICC based on Irr(t) c----------------------------------------------------------------------- IF(Muladd.eq.2)THEN jadj2=0D0 DO i=Irridx,Irrend ladj=T IF(Nxcld.gt.0)ladj=Rgxcld(i-Irridx+1) IF(ladj)jadj2=jadj2+Sti(i) END DO END IF END IF c----------------------------------------------------------------------- c see if trading day and/or easter and/or user defined regressors c are in the regression matrix. If so, remove them before c performing an aictest. c----------------------------------------------------------------------- icol=Nb DO WHILE (icol.ge.1) rtype=Rgvrtp(icol) IF((Xtdtst.gt.0.AND.(rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or. & rtype.eq.PRRTTD.or.rtype.eq.PRRTST.or.rtype.eq.PRATTD.or. & rtype.eq.PRATST.or.rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or. & rtype.eq.PRA1TD.or.rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or. & rtype.eq.PRA1ST.or.rtype.eq.PRGTLM.or. & rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or.rtype.eq.PRGTLY.or. & rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or.rtype.eq.PRATSL.or. & rtype.eq.PRATLQ.or.rtype.eq.PRATLY)).or. & ((rtype.eq.PRGTEA.or.rtype.eq.PRGTEC).and.Xeastr).or. & ((rtype.eq.PRGTUD.or.rtype.eq.PRGTUH.or.rtype.eq.PRGUAO.or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY)).and.Xuser))THEN CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN IF(Xuser.and. & (rtype.eq.PRGTUD.or.rtype.eq.PRGTUH.or.rtype.eq.PRGUAO.or. & (rtype.eq.PRGUTD.or.rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or. & rtype.eq.PRGULY)))THEN iuser=iuser+1 bu2(iuser)=B(icol) fx2(iuser)=Regfx(icol) typ2(iuser)=rtype END IF ELSE IF(Xeastr.and.(rtype.eq.PRGTLD.or.rtype.eq.PRGTTH))THEN Holgrp=icol END IF icol=icol-1 END DO c----------------------------------------------------------------------- c Start trading day AICC test by fitting the model without trading c day regressors c----------------------------------------------------------------------- IF(Xtdtst.gt.0)THEN c----------------------------------------------------------------------- c Generate string for label of trading day effect c----------------------------------------------------------------------- CALL setchr(' ',30,tdstr) CALL mktdlb(tdstr,ntdchr,tdindx,Xaicst,Xaicrg,Xtdzro,Sp) c----------------------------------------------------------------------- c transform the Irregular c----------------------------------------------------------------------- IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum)THEN CALL copy(Sti(Irridx),Nobspf,-1,Trnsrs) ndifum=0 IF(Haveum)CALL dfdate(Begspn,Begum,Sp,ndifum) IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum) & CALL xrgtrn(Trnsrs,Irridx,Irrend,Psuadd,Muladd,Tdgrp,Haveum, & Umean,ndifum,Kswv) END IF c----------------------------------------------------------------------- c Generate the new regression matrix and estimate the new model c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Xelong) IF(.not.Lfatal)CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(Lfatal)RETURN c----------------------------------------------------------------------- c Get AICC(NO TD), print it out c----------------------------------------------------------------------- CALL xrlkhd(aicntd,Nxcld) IF(Lfatal)RETURN IF(Holgrp.gt.0.and.Muladd.eq.2)aicntd=aicntd+2*jadj2 c----------------------------------------------------------------------- c Add trading day regressors to the model and reestimate the model c----------------------------------------------------------------------- CALL addtd(Xaicst,Xaicrg,Xtdzro,Sp,tdindx) Tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(Tdgrp.eq.0.and.Xtdtst.eq.2) & Stdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Stock Trading Day') IF(Muladd.eq.1.and.Xtdtst.eq.1) & CALL adrgef(DNOTST,'Leap Year','Leap Year',PRGTLY,F,F) c----------------------------------------------------------------------- c transform the Irregular c----------------------------------------------------------------------- IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum)THEN CALL copy(Sti(Irridx),Nobspf,-1,Trnsrs) ndifum=0 IF(Haveum)CALL dfdate(Begspn,Begum,Sp,ndifum) IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum) & CALL xrgtrn(Trnsrs,Irridx,Irrend,Psuadd,Muladd,Tdgrp,Haveum, & Umean,ndifum,Kswv) END IF c----------------------------------------------------------------------- c Generate the new regression matrix and estimate the new model c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Xelong) c IF((.not.Axruhl).and.Holgrp.gt.0) c & CALL xrghol(Irridx,Psuadd,Xlpyr,Daybar) IF(.not.Lfatal)CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(A,Nbeg) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Get AICC(TD), print it out c----------------------------------------------------------------------- CALL xrlkhd(aictd,Nxcld) IF(Lfatal)RETURN IF(Trumlt.or.Muladd.eq.2)THEN aictd=aictd-2*jadj IF(Muladd.eq.2)aictd=aictd+2*jadj2 END IF c----------------------------------------------------------------------- c make choice, print it out c----------------------------------------------------------------------- IF(Lprt)WRITE(Mt1,1010)tdstr(1:ntdchr),aicntd,tdstr(1:ntdchr), & aictd 1010 FORMAT(//,'AICC for model without ',a,t50,f20.4,/, & 'AICC for model with ',a,t50,f20.4) IF(Lsavlg)THEN WRITE(fmtsvl,1011)MAX(ntdchr,4)+10 1011 FORMAT('(1x,a,t',i2,',a,1x,f15.4)') WRITE(Ng,fmtsvl)'AICC(no td)',':',aicntd WRITE(Ng,fmtsvl)'AICC('//tdstr(1:ntdchr)//')',':',aictd END IF IF(Ldiag)THEN WRITE(Nform,1013)'notd',aicntd WRITE(Nform,1013)'td',aictd WRITE(Nform,1012)tdstr(1:ntdchr) 1012 FORMAT('aictest.xtd.reg: ',a) 1013 FORMAT('aictest.xtd.aicc.',a,': ',e29.15) END IF IF((aictd+Xraicd).lt.aicntd)THEN IF(Lprt)WRITE(Mt1,1020)Xraicd,'with '//tdstr(1:ntdchr) IF(.not.Axrgtd.and.Ixrgtd.gt.0)Axrgtd=T estend=F IF(Xeastr)THEN aichol=aictd ELSE IF(Xeastr)THEN aicnus=aictd END IF ELSE IF(Lprt)WRITE(Mt1,1020)Xraicd,'without '//tdstr(1:ntdchr) IF(Axrgtd)Axrgtd=F IF(Havxtd)Havxtd=F Tdgrp=0 Stdgrp=0 c----------------------------------------------------------------------- c if AICC(NO TD) < AICC(TD), remove trading day regressors c----------------------------------------------------------------------- icol=Nb DO WHILE (icol.ge.1) rtype=Rgvrtp(icol) IF(rtype.eq.PRGTTD.or.rtype.eq.PRGTST.or. & rtype.eq.PRRTTD.or.rtype.eq.PRRTST.or.rtype.eq.PRATTD.or. & rtype.eq.PRATST.or.rtype.eq.PRG1TD.or.rtype.eq.PRR1TD.or. & rtype.eq.PRA1TD.or.rtype.eq.PRG1ST.or.rtype.eq.PRR1ST.or. & rtype.eq.PRA1ST.or.rtype.eq.PRGTLM.or. & rtype.eq.PRGTSL.or.rtype.eq.PRGTLQ.or.rtype.eq.PRGTLY.or. & rtype.eq.PRRTLM.or.rtype.eq.PRRTSL.or.rtype.eq.PRRTLQ.or. & rtype.eq.PRRTLY.or.rtype.eq.PRATLM.or.rtype.eq.PRATSL.or. & rtype.eq.PRATLQ.or.rtype.eq.PRATLY)THEN CALL getstr(Colttl,Colptr,Ncoltl,icol,effttl,nchr) IF(.not.Lfatal)CALL dlrgef(icol,Nrxy,1) IF(Lfatal)RETURN END IF icol=icol-1 END DO c----------------------------------------------------------------------- c transform the Irregular c----------------------------------------------------------------------- IF((Xeastr.or.Holgrp.gt.0).or.(Xuser.or.Ncusrx.gt.0))THEN IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum)THEN CALL copy(Sti(Irridx),Nobspf,-1,Trnsrs) ndifum=0 IF(Haveum)CALL dfdate(Begspn,Begum,Sp,ndifum) IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum) & CALL xrgtrn(Trnsrs,Irridx,Irrend,Psuadd,Muladd,Tdgrp, & Haveum,Umean,ndifum,Kswv) END IF c----------------------------------------------------------------------- c Generate the new regression matrix c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,T,Xelong) IF(Lfatal)RETURN END IF END IF END IF c----------------------------------------------------------------------- c Start loop through model choices for Easter c----------------------------------------------------------------------- IF(Xeastr)THEN DO i=1,Neasvx c----------------------------------------------------------------------- c If i > 2, locate and delete easter regressor from model c----------------------------------------------------------------------- IF(i.gt.2)THEN Easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(Easgrp.eq.0)Easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'StatCanEaster') begcol=Grp(easgrp-1) ncol=Grp(easgrp)-begcol CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Add new easter regressor to model, if i > 1 c----------------------------------------------------------------------- IF(i.gt.1)THEN CALL addeas(Xeasvc(i)+Easidx,Easidx,1) IF(Lfatal)RETURN Easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(Easgrp.eq.0)Easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'StatCanEaster') IF(Holgrp.eq.0)Holgrp=Easgrp END IF c----------------------------------------------------------------------- c Generate regression matrix c----------------------------------------------------------------------- IF(i.gt.1.or.estend)THEN tdhol=Holgrp.gt.0.and.Tdgrp.gt.0 xm=(.not.(Trumlt.and.tdhol.and.Xhlnln)).and.Easidx.eq.0 CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) IF(Lfatal)RETURN c IF(Tdgrp.gt.0)CALL xrghol(Irridx,Psuadd,Xlpyr,Daybar) c----------------------------------------------------------------------- c Estimate model c----------------------------------------------------------------------- IF(.not.Lfatal)CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(A,Nbeg) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- CALL xrlkhd(aichol,Nxcld) IF(Tdgrp.gt.0.and.(Trumlt.or.Muladd.eq.2))THEN aichol=aichol-2*jadj IF(Muladd.eq.2)aichol=aichol+2*jadj2 ELSE IF(Holgrp.gt.0.and.Muladd.eq.2)THEN aichol=aichol+2*jadj2 END IF END IF IF(i.eq.1)THEN IF(Lprt)WRITE(Mt1,1030)aichol 1030 FORMAT(//,' AICC for model without Easter',t50,f20.4) IF(Lsavlg)WRITE(Ng,1031)aichol 1031 FORMAT(' AICC(no easter) : ',f15.4) IF(Ldiag)WRITE(Nform,1032)'noeaster',aichol 1032 FORMAT('aictest.xe.aicc.',a,': ',e29.15) ELSE IF(Lprt)THEN IF(Easidx.eq.0)THEN WRITE(Mt1,1040)'Easter',Xeasvc(i),aichol ELSE WRITE(Mt1,1040)'StatCanEaster',Xeasvc(i),aichol END IF END IF 1040 FORMAT(' AICC for model with ',a,'[',i2,']',t50,f20.4) IF(Lsavlg)THEN IF(Easidx.eq.0)THEN WRITE(Ng,1041)'easter',Xeasvc(i),aichol ELSE WRITE(Ng,1041)'sceaster',Xeasvc(i),aichol END IF END IF 1041 FORMAT(' AICC(',a,'[',i2,']) : ',f15.4) IF(Ldiag)THEN IF(Easidx.eq.0)THEN WRITE(Nform,1042)'easter',Xeasvc(i),aichol ELSE WRITE(Nform,1042)'sceaster',Xeasvc(i),aichol END IF END IF 1042 FORMAT('aictest.xe.aicc.',a,i2.2,': ',e29.15) END IF c----------------------------------------------------------------------- c See if this AICC is the smallest. If so, update value and index c of best AICC. c----------------------------------------------------------------------- IF(i.eq.1)THEN aicbst=aichol aicind=Xeasvc(1) ELSE IF((aicind.eq.0.AND.(aichol+Xraicd).lt.aicbst).or. & (aicind.gt.0.and.aichol.lt.aicbst))THEN aicbst=aichol aicind=Xeasvc(i) END IF END DO c----------------------------------------------------------------------- c Show Easter effect that aic prefers c----------------------------------------------------------------------- IF(Lprt)THEN IF(aicind.eq.0)THEN WRITE(Mt1,1050)Xraicd 1050 FORMAT(//,' ***** AICC (with aicdiff=',F5.2, & ') prefers model without Easter *****') IF(Axrghl)Axrghl=F IF(Havxhl)Havxhl=F IF(Finhol)Finhol=T ELSE IF(Easidx.eq.0)THEN WRITE(Mt1,1060)Xraicd,'Easter',aicind ELSE WRITE(Mt1,1060)Xraicd,'Statistics Canada Easter',aicind END IF 1060 FORMAT(//,' ***** AICC (with aicdiff=',F5.2, & ') prefers model with ',a,'[',i2,'] *****') IF(.not.Axrghl.and.Ixrghl.gt.0)Axrghl=T END IF END IF c----------------------------------------------------------------------- c If model with best AICC wasn't the last one estimated, generate c regression matrix for the best model. c----------------------------------------------------------------------- estend=F IF(aicind.lt.Xeasvc(Neasvx))THEN estend=T easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(easgrp.eq.0)easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'StatCanEaster') begcol=Grp(easgrp-1) ncol=Grp(easgrp)-begcol CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN c----------------------------------------------------------------------- c IF no Easter effect, reset indicator variables and exit routine c if there are no other holiday or td regressors in model. c----------------------------------------------------------------------- IF(aicind.eq.0)THEN Easgrp=0 Holgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Thanksgiving') IF(Holgrp.eq.0)Holgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Labor') c----------------------------------------------------------------------- c Add new Easter variable, if necessary c----------------------------------------------------------------------- ELSE IF(aicind.gt.0)THEN CALL addeas(aicind+Easidx,Easidx,1) IF(Lfatal)RETURN END IF tdhol=Holgrp.gt.0.and.Tdgrp.gt.0 xm=Easidx.eq.0.and.(.not.(Trumlt.and.tdhol.and.Xhlnln)) CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) IF(Lfatal)RETURN c IF((.not.Axruhl).and.Holgrp.gt.0.and.Tdgrp.gt.0) c & CALL xrghol(Irridx,Psuadd,Xlpyr,Daybar) END IF IF(.not.estend.and.Xuser)aicnus=aichol END IF c----------------------------------------------------------------------- c Finally, test user defined AICC c----------------------------------------------------------------------- IF(Xuser)THEN IF(estend)THEN IF(.not.Lfatal)CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(A,Nbeg) c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- CALL xrlkhd(aicnus,Nxcld) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(Tdgrp.gt.0.and.(Trumlt.or.Muladd.eq.2))THEN aicnus=aicnus-2*jadj IF(Muladd.eq.2)aicnus=aicnus+2*jadj2 ELSE IF(Holgrp.gt.0.and.Muladd.eq.2)THEN aicnus=aicnus+2*jadj2 END IF END IF c----------------------------------------------------------------------- IF(Lprt)WRITE(Mt1,1070)aicnus 1070 FORMAT(//,' AICC for model without user-defined regressors',t50, & f20.4) IF(Lsavlg)WRITE(Ng,1071)'no userreg',aicnus 1071 FORMAT(' AICC(',a,') : ',f15.4) IF(Ldiag)WRITE(Nform,1072)'nouser',aicnus 1072 FORMAT('aictest.xu.aicc.',a,': ',e29.15) c----------------------------------------------------------------------- c Add user defined regressors back into model c----------------------------------------------------------------------- Ncusrx=ncx2 Haveum=lhum2 c----------------------------------------------------------------------- c Restore user-defined regressors to the regression matrix c----------------------------------------------------------------------- DO i=1,Ncusrx CALL getstr(Usrttl,Usrptr,Ncusrx,i,effttl,nchr) IF(Lfatal)RETURN IF(typ2(i).eq.PRGTUD)THEN CALL adrgef(bu2(i),effttl(1:nchr),'User-defined',PRGTUD, & fx2(i),F) ELSE IF(typ2(i).eq.PRGUTD)THEN CALL adrgef(bu2(i),effttl(1:nchr),'User-defined Trading Day', & PRGUTD,fx2(i),F) ELSE IF(typ2(i).eq.PRGULY)THEN CALL adrgef(bu2(i),effttl(1:nchr),'User-defined Leap Year', & PRGULY,fx2(i),F) ELSE IF(typ2(i).eq.PRGULM)THEN CALL adrgef(bu2(i),effttl(1:nchr),'User-defined LOM', & PRGULM,fx2(i),F) ELSE IF(typ2(i).eq.PRGULQ)THEN CALL adrgef(bu2(i),effttl(1:nchr),'User-defined LOQ', & PRGULQ,fx2(i),F) ELSE IF(typ2(i).eq.PRGUAO)THEN CALL adrgef(bu2(i),effttl(1:nchr),'User-defined AO', & PRGUAO,fx2(i),F) ELSE IF(typ2(i).eq.PRGTUH)THEN CALL adrgef(bu2(i),effttl(1:nchr),'User-defined Holiday', & PRGTUH,fx2(i),F) END IF END DO c----------------------------------------------------------------------- c Restore transformed data, if necessary c----------------------------------------------------------------------- IF(Haveum)THEN CALL copy(Sti(Irridx),Nobspf,-1,Trnsrs) ndifum=0 CALL dfdate(Begspn,Begum,Sp,ndifum) CALL xrgtrn(trnsrs,Irridx,Irrend,Psuadd,Muladd,Tdgrp,Haveum, & Umean,ndifum,Kswv) END IF c----------------------------------------------------------------------- c Re-generate regression matrix and estaimate model c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,T,Xelong) IF(.not.Lfatal)CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(A,Nbeg) c----------------------------------------------------------------------- c Compute the likelihood statistics and AICC for the model c----------------------------------------------------------------------- IF(.not.Lfatal)CALL xrlkhd(aicusr,Nxcld) IF(Lfatal)RETURN IF(Tdgrp.gt.0.and.(Trumlt.or.Muladd.eq.2))THEN aicusr=aicusr-2*jadj IF(Muladd.eq.2)aicusr=aicusr+2*jadj2 ELSE IF(Holgrp.gt.0.and.Muladd.eq.2)THEN aicusr=aicusr+2*jadj2 END IF IF(Lprt)WRITE(Mt1,1080)aicusr 1080 FORMAT(' AICC for model with user-defined regressor(s)',t50, & f20.4) IF(Lsavlg)WRITE(Ng,1071)'userreg',aicusr IF(Ldiag)WRITE(Nform,1072)'user',aicusr c----------------------------------------------------------------------- c Print out result of test c----------------------------------------------------------------------- IF((aicusr+Xraicd).lt.aicnus)THEN estend=F IF(Lprt)WRITE(Mt1,1020)Xraicd,'with user-defined regressor(s)' ELSE estend=T WRITE(Mt1,1020)Xraicd,'without user-defined regressor(s)' c----------------------------------------------------------------------- c Remove user defined regressors from regression matrix and c retransform series, if necessary. c----------------------------------------------------------------------- IF(Haveum)THEN Haveum=F CALL copy(Sti(Irridx),Nobspf,-1,Trnsrs) IF(Muladd.eq.0.or.Muladd.eq.2) & CALL xrgtrn(trnsrs,Irridx,Irrend,Psuadd,Muladd,Tdgrp,Haveum, & Umean,ndifum,Kswv) END IF igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'User-defined') begcol=Grp(igrp-1) ncol=Grp(igrp)-begcol CALL dlrgef(begcol,Nrxy,ncol) IF(Lfatal)RETURN Ncusrx=0 Ncxusx=0 Nrxusx=0 c----------------------------------------------------------------------- c Regenerate regression matrix c----------------------------------------------------------------------- CALL regvar(Trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,T,Xelong) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Estimate model c----------------------------------------------------------------------- IF(estend)THEN CALL regx11(A) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(A,Nbeg) END IF c----------------------------------------------------------------------- RETURN 1020 FORMAT(//,' ***** AICC (with aicdiff=',F5.2,') prefers ', & 'model ',a,' *****') END x11ari.f0000664006604000003110000003641714521201624011455 0ustar sun00315stepsc Last Change: 10,2021,pass additional paramter to seatpr, x11pt3, c x11pt4 because there is new argument trendtc in regression C previous change: BCM 23 Mar 2005 3:41 pm SUBROUTINE x11ari(Lmodel,Lx11,X11agr,Lseats,Lcomp,Issap,Irev, & Irevsa,Ixreg,Lsumm,Ltimer,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS SUBROUTINE PARTITIONS X-11 AND ARIMA ROUTINES TO C --- IMPROVE THE OVERLAY STRUCTURE. c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'model.prm' INCLUDE 'arima.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'agr.cmn' INCLUDE 'lzero.cmn' INCLUDE 'title.cmn' INCLUDE 'units.cmn' INCLUDE 'extend.cmn' INCLUDE 'error.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'mdltbl.i' INCLUDE 'spctbl.i' INCLUDE 'spcsvl.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'priusr.cmn' INCLUDE 'rho.cmn' INCLUDE 'tukey.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'nsums.i' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- CHARACTER errext*180,blank*180,outd*180,cstuk*35,cttuk*35, & cstk90*35,cttk90*35,cstuki*35,cttuki*35,csti90*35, & ctti90*35 LOGICAL Lmodel,Lx11,havmdl,Lrvsa,Lrvsf,Lrvch,Lrvaic,Lrvfct,Lcomp, & Lrvtrn,Lrfrsh,Revfix,Revfxx,extok,Lrvtch,Rvtran,Cnctar, & Lseats,lfm,Lgraf,Rvxotl,X11agr,lsadj,Lsvtpk,Ltimer,lpkhdr INTEGER ierr,nf2,ncur,icur,nspdir,ntpdir,Issap,Irev,Ixreg,Lsumm, & Irevsa,ixrbak,kswbak,ntky LOGICAL Lrvarma,Lrvtdrg,Rvtrfc c----------------------------------------------------------------------- INTEGER nblank,lstpth EXTERNAL nblank,lstpth c----------------------------------------------------------------------- REAL ticks c----------------------------------------------------------------------- COMMON /revlog/ Lrvsa,Lrvsf,Lrvch,Lrvtrn,Lrvtch,Lrvaic,Lrvfct, & Lrvarma,Lrvtdrg,Lrfrsh,Revfix,Revfxx,Rvtran, & Cnctar,Rvxotl,Rvtrfc c----------------------------------------------------------------------- Lsavpk=((Iagr.lt.3.and.Svltab(LSLSPK)).or.(Iagr.eq.3.and. & (Svltab(LSLSPK).or.Svltab(LSLDSP).or.Svltab(LSLISP))).OR. & (Lsumm.gt.0)).and.Ny.eq.12 Lsvtpk=((Iagr.lt.3.and.Svltab(LSLTPK)).or.(Iagr.eq.3.and. & (Svltab(LSLTPK).or.Svltab(LSLDTP).or.Svltab(LSLITP))).OR. & (Lsumm.gt.0)).and.Ny.eq.12 lpkhdr=((Iagr.lt.3.and.(Svltab(LSLSPK).or.Svltab(LSLTPK))).or. & (Iagr.eq.3.and. & (Svltab(LSLSPK).or.Svltab(LSLDSP).or.Svltab(LSLISP).or. & Svltab(LSLTPK).or.Svltab(LSLDTP).or.Svltab(LSLITP)))) & .and.Ny.eq.12 nspdir=0 ntpdir=0 havmdl=F IF((.not.(Lautom.or.Lautox)).and.Lmodel)havmdl=T lsadj=Lx11.or.Lseats c----------------------------------------------------------------------- c perform automatic transformation test c (BCM, July 1997, moved here Nov. 1999) c----------------------------------------------------------------------- IF(Fcntyp.eq.0)THEN Nspobs=Nofpob-Nfcst lfm=Prttab(LTRAIC).and.Prttab(LESTFM) CALL trnaic(Lx11,Lmodel,Prttab(LTRAIC),lfm) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- PRIOR-SIMULTANEOUS TRADING DAY AND HOLIDAY ADJUSTMENTS. c----------------------------------------------------------------------- IF(Lx11)THEN Axhol=F IF(Issap.lt.2.or.Irev.lt.4)Kh2=Khol IF(Ixreg.eq.2.or.Khol.eq.1)THEN CALL xrgdrv(Lmodel,Lx11,Kh2,Lgraf) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- C --- PRIOR ADJUSTMENTS. c----------------------------------------------------------------------- CALL x11pt1(Lmodel,Lgraf,Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- c --- REG-ARIMA MODELLING. c----------------------------------------------------------------------- IF(Lmodel)THEN IF(Same)THEN CALL writln('The program will not estimate a regARIMA model for &a constant series.',STDERR,Mt2,T) IF(Adjtd.eq.1)Adjtd=0 IF(Adjhol.eq.1)Adjhol=0 IF(Adjao.eq.1)Adjao=0 IF(Adjls.eq.1)Adjls=0 IF(Adjtc.eq.1)Adjtc=0 IF(Adjso.eq.1)Adjso=0 IF(Adjusr.eq.1)Adjusr=0 IF(Adjsea.eq.1)Adjsea=0 IF((.NOT.(Axrghl.or.Axruhl.or.Khol.ge.1)).and.Finhol)Finhol=F IF(Finao)Finao=F IF(Finls)Finls=F IF(Fintc)Fintc=F IF(Finusr)Finusr=F ELSE extok=T IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'barima:',ticks ELSE WRITE(Nform,9000) 'barima.diag:',ticks END IF END IF CALL arima(havmdl,extok,Lx11,Lseats,Lgraf) IF(Lfatal)RETURN IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'earima:',ticks ELSE WRITE(Nform,9000) 'earima.diag:',ticks END IF END IF END IF IF((Same.or.(.not.havmdl).or.(.not.extok)).and.Lmodel)THEN nf2=Nfcst Nfcst=0 Nbcst=0 IF(Nfdrp.gt.0)Nfdrp=0 CALL setxpt(nf2,lsadj,Fctdrp) IF(Nuspad.gt.0)THEN CALL dfdate(Begspn,Bgupad,Ny,Frstap) Frstap=Frstap+1 END IF IF(Nustad.gt.0)THEN CALL dfdate(Begspn,Bgutad,Ny,Frstat) Frstat=Frstat+1 END IF END IF IF(.not.havmdl.and.Lmodel)Lmodel=F * IF(.NOT.(Ny.eq.36.or.Ny.eq.24.or.Ny.eq.12.or.Ny.eq.4))RETURN IF(Lx11)THEN IF(.NOT.(Ny.eq.12.or.Ny.eq.4))THEN CALL writln('NOTE: The program will only generate an X-11 '// & 'seasonal adjustment for ',STDERR,Mt2,T) CALL writln(' monthly or quarterly series.',STDERR,Mt2,F) RETURN END IF ELSE IF(Lseats)THEN IF(.NOT.(Ny.eq.12.or.Ny.eq.6.or.Ny.eq.4.or.Ny.eq.2.or. & Ny.eq.1))THEN CALL writln('NOTE: The program will only generate a SEATS '// & 'adjustment for ',STDERR,Mt2,T) CALL writln(' monthly, bimonthly, quarterly, biannual '// & 'or annual.',STDERR,Mt2,F) RETURN END IF END IF END IF c----------------------------------------------------------------------- c If this is a revisions run and no seasonal adjustment diagnostics c are being analyzed, exit routine. c----------------------------------------------------------------------- IF((.not.(Lrvsa.or.Lrvsf.or.Lrvch.or.Lrvtrn).or.(.not.lsadj)).and. & Irev.eq.4)RETURN c----------------------------------------------------------------------- c --- X-11 Seasonal Adjustment c----------------------------------------------------------------------- C --- X-11 PARTS B1 TO D7. c----------------------------------------------------------------------- IF(Ltimer.and.Lx11)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'bx11:',ticks ELSE WRITE(Nform,9000) 'bx11.diag:',ticks END IF END IF IF((.not.Lcmpaq).or.Lx11) & CALL x11pt2(Lmodel,Lx11,Lseats,Lgraf,Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Seats seasonal adjustment c----------------------------------------------------------------------- IF(Lseats)THEN CALL chksmd(3) IF(.not.Lfatal)CALL initdg(Lsumm,Irev,Issap,Muladd) IF(Lfatal)RETURN CALL setchr(' ',180,blank) CALL setchr(' ',180,outd) ncur=nblank(Cursrs) icur=lstpth(Cursrs,ncur) IF(icur.gt.0)outd(1:icur)=Cursrs(1:icur) IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'bseats:',ticks ELSE WRITE(Nform,9000) 'bseats.diag:',ticks END IF END IF * call profiler(1,'entering SEATS') nSeatsSer=nSeatsSer+1 c write(*,*)' enter seats' CALL seats(blank,blank,outd,blank,0,0,ierr,errext,Lgraf,Lwdprt) c write(*,*)' exit seats' IF(Lfatal.and.ierr.le.0)RETURN IF(ierr.gt.0)THEN Lfatal=T CALL writln(errext,STDERR,Mt2,T) CALL abend() RETURN ELSE * write(*,*)' enter seatad' CALL seatad(Muladd,Ny,Nfcst) * write(*,*)' enter seatfc' CALL seatfc(Ny,Iagr) * write(*,*)' enter seatdg' CALL seatdg(Issap,Irev,Irevsa,Ny,Iag,Iagr,Muladd,Lsumm,Lseats, & Lgraf,Lam,Nfcst,Length) * write(*,*)' enter seatpr' CALL seatpr(Begspn,Endspn,Ny,Muladd,Kpart,Kdec,Lsumm,Lgraf,Lam, & Lttc) END IF IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'eseats:',ticks ELSE WRITE(Nform,9000) 'eseats.diag:',ticks END IF END IF IF(Lfatal.or.ABS(Issap).eq.2.or.ABS(Irev).eq.4)RETURN ELSE IF(Lx11)THEN c----------------------------------------------------------------------- C --- X-11 PARTS D8 TO D16. c----------------------------------------------------------------------- CALL x11pt3(Lgraf,Lttc) IF(Lfatal.or.Issap.eq.2.or.Irev.eq.4)RETURN c----------------------------------------------------------------------- C --- X-11 PARTS E1 TO F4. c----------------------------------------------------------------------- CALL x11pt4(Lgraf,Lttc) IF(Lfatal)RETURN IF(Ltimer)THEN CALL cpu_time(ticks) IF(Issap.lt.2.and.Irev.lt.4)THEN WRITE(Nform,9000) 'ex11:',ticks ELSE WRITE(Nform,9000) 'ex11.diag:',ticks END IF END IF END IF c----------------------------------------------------------------------- c Produce spectral plots c----------------------------------------------------------------------- IF(.not.Same)THEN IF(Prttab(LSPCQS).or.Savtab(LSPCQS).or.Svltab(LSLQS).or. & Svltab(LSLDQS))THEN CALL genqs(Lmodel,Lseats,Lx11,X11agr,Psuadd,Muladd,Kfulsm,Iagr, & Ny,LSPCQS,Svltab(LSLQS).or.Svltab(LSLDQS),T) END IF IF(Ny.eq.12)THEN IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'bspectrum:',ticks END IF CALL spcdrv(Muladd,Iagr,Kswv,Ny,Lx11,Kfulsm,X11agr,Lseats, & Psuadd,Lgraf,Lmodel) IF(Lfatal)RETURN IF(Nspeak.gt.0)nspdir=Nspeak-1 IF(Ntpeak.gt.0)ntpdir=Ntpeak-1 c----------------------------------------------------------------------- ntky=Ntukey IF(Ntukey.gt.0)THEN IF(Prttab(LSPCTP))CALL prtukp(Mt1,Iagr,Ny,F) IF(Svltab(LSLTPK).or.Svltab(LSLDTP))CALL prtukp(Ng,Iagr,Ny,T) IF(Lsumm.gt.0.or.(Svltab(LSLTPK).or.Svltab(LSLDTP))) & CALL svtukp(Iagr,Lsumm,cstuk,cttuk,cstk90,cttk90,lsadj) c----------------------------------------------------------------------- IF(Prttab(LSPCTP).or.(Svltab(LSLTPK).or.Svltab(LSLDTP)).or. & Lsumm.gt.0)THEN IF(Iagr.eq.3)THEN Ntukey=0 CALL setint(NOTSET,4,Itukey) END IF END IF END IF c----------------------------------------------------------------------- c Perform tests for quarterly seasonality in monthly series c----------------------------------------------------------------------- IF(Lqchk)THEN CALL chqsea(Lmodel,Lseats,Lx11,Prttab(LSPCQC),Svltab(LSLQCH), & Lsumm) END IF c----------------------------------------------------------------------- IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'espectrum:',ticks END IF END IF c----------------------------------------------------------------------- IF(Prttab(LSPNPA).or.Savtab(LSPNPA).or.Svltab(LSLNPA).or. & Svltab(LSLDNP))THEN CALL gennpsa(Lmodel,Lseats,Lx11,X11agr,Muladd,Kfulsm,Iagr,Ny, & LSPNPA,Svltab(LSLQS).or.Svltab(LSLDNP)) END IF END IF c----------------------------------------------------------------------- IF((.not.Lcomp).and.Iagr.gt.0)THEN c----------------------------------------------------------------------- C --- INDIRECT AGGREGATE SEASONAL ADJUSTMENT. c----------------------------------------------------------------------- IF(Iagr.eq.3)THEN ixrbak=Ixreg kswbak=Kswv Ixreg=0 Kswv=0 IF(X11agr)THEN CALL agr3(Lgraf,Begspn,Lx11) IF(.not.Lfatal)CALL x11pt4(Lgraf,Lttc) ELSE CALL agr3s(Lgraf,Begspn,Lx11) END IF IF(.not.Lfatal)THEN IF(Prttab(LSPCQS).or.Savtab(LSPCQS).or.Svltab(LSLQS).or. & Svltab(LSLIQS))THEN CALL genqs(Lmodel,Lseats,Lx11,X11agr,Psuadd,Muladd,Kfulsm, & Iagr,Ny,LSLIQS,Svltab(LSLQS).or.Svltab(LSLIQS), & .not.(Svltab(LSLQS).or.Svltab(LSLDQS))) END IF IF(Ny.eq.12)THEN CALL spcdrv(Muladd,Iagr,Kswv,Ny,Lx11,Kfulsm,X11agr,Lseats, & Psuadd,Lgraf,Lmodel) IF(Ntukey.gt.0)THEN ntky=ntky+Ntukey IF(Prttab(LSPCTP))CALL prtukp(Mt1,Iagr,Ny,F) IF(Svltab(LSLTPK).or.Svltab(LSLITP))CALL prtukp(Ng,Iagr,Ny,T) IF(Lsumm.gt.0.or.(Svltab(LSLTPK).or.Svltab(LSLITP))) & CALL svtukp(Iagr,Lsumm,cstuki,cttuki,csti90,ctti90,lsadj) END IF END IF END IF IF(Lfatal)RETURN Ixreg=ixrbak Kswv= kswbak IF(Prttab(LSPNPI).or.Savtab(LSPNPI).or.Svltab(LSLNPA).or. & Svltab(LSLINP))THEN CALL gennpsa(Lmodel,Lseats,Lx11,X11agr,Muladd,Kfulsm,Iagr,Ny, & LSPNPI,Svltab(LSLNPA).or.Svltab(LSLINP)) END IF END IF IF(Iag.ge.0.or.Iagr.eq.4) & CALL agr2(Issap,Irev,Lsavpk,Begspn,Lx11,X11agr) END IF c----------------------------------------------------------------------- IF(Lsavpk.or.Lsvtpk)THEN IF(lpkhdr)WRITE(Ng,1010)' Spectral Peak Summary:' IF(Lsavpk)CALL savpk(Iagr,Lsumm,nspdir,ntpdir) IF(Lsvtpk.and.ntky.gt.0)THEN CALL savtpk(Iagr,Lsumm,cstuk,cttuk,cstk90,cttk90,cstuki, & cttuki,csti90,ctti90) END IF IF(Issap.eq.0.and.Irev.eq.0.and.Iagr.gt.3)Iagr=0 END IF c----------------------------------------------------------------------- 1010 FORMAT(/,a) 9000 FORMAT(a,e15.8) RETURN END x11fac.cmn0000664006604000003110000000262314521201624011753 0ustar sun00315stepsc----------------------------------------------------------------------- c Factd - Regarima (or X-11 Regression) TD factors c FacAO - Regarima AO factors c FacLS - Regarima LS factors c FacTC - Regarima TC factors c FacSO - Regarima SO factors c Facsea - Regarima seasonal factors c Facusr - Regarima factors derived from user-defined regression c variables c Fachol - Regarima (or X-11 Regression) holiday factors c Faccal - X-11 Regression (or Regarima) factors derived from c calendar effects (trading day and holiday) c Facxhl - X-11 Regression factors derived from holiday effects c X11hol - X-11 Easter factors c Stptd - Prior Trading Day factors c----------------------------------------------------------------------- DOUBLE PRECISION Factd,FacAO,FacLS,FacTC,FacSO,Facsea,Faccyc, & Facusr,Fachol,Faccal,Facxhl,X11hol,Stptd c DOUBLE PRECISION LnMean DIMENSION Factd(PLEN),FacAO(PLEN),FacLS(PLEN),FacTC(PLEN), & FacSO(PLEN),Facsea(PLEN),Faccyc(PLEN),Facusr(PLEN), & Fachol(PLEN),Faccal(PLEN),Facxhl(PLEN),X11hol(PLEN), & Stptd(PLEN) c----------------------------------------------------------------------- COMMON / x11fac / Factd,Fachol,FacAO,FacLS,FacTC,FacSO,Facsea, & Faccyc,Facusr,Faccal,Facxhl,X11hol,Stptd x11int.f0000664006604000003110000000440114521201625011461 0ustar sun00315stepsC Last change: BCM 21 May 1998 7:27 am SUBROUTINE x11int IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'adj.cmn' INCLUDE 'inpt.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'xtrm.cmn' c----------------------------------------------------------------------- INTEGER PY1 PARAMETER(PY1=PYRS+1) c----------------------------------------------------------------------- DOUBLE PRECISION rinit,Stex,Temp DIMENSION Temp(PLEN),Stex(PLEN) c----------------------------------------------------------------------- COMMON /work / Temp COMMON /mq10 / Stex c----------------------------------------------------------------------- c INITIALIZE ARRAYS c----------------------------------------------------------------------- rinit=1D0 IF(Muladd.eq.1)rinit=0D0 c----------------------------------------------------------------------- CALL setdp(rinit,PLEN,Sts) CALL setdp(rinit,PLEN,Stsi) CALL setdp(rinit,PLEN,Sti) CALL setdp(rinit,PLEN,Stptd) CALL setdp(rinit,PLEN,Temp) c----------------------------------------------------------------------- CALL setdp(rinit,PLEN,Factd) CALL setdp(rinit,PLEN,Facao) CALL setdp(rinit,PLEN,Facls) CALL setdp(rinit,PLEN,Factc) CALL setdp(rinit,PLEN,Facso) CALL setdp(rinit,PLEN,Facsea) CALL setdp(rinit,PLEN,Facusr) CALL setdp(rinit,PLEN,Fachol) CALL setdp(rinit,PLEN,Facxhl) CALL setdp(rinit,PLEN,X11hol) CALL setdp(rinit,PLEN,Faccal) c----------------------------------------------------------------------- CALL setdp(0D0,PLEN,Stc) CALL setdp(0D0,PLEN,Stwt) CALL setdp(0D0,PLEN,Stci) CALL setdp(0D0,PLEN,Stex) CALL setdp(0D0,PY1,Stdev) c----------------------------------------------------------------------- c Copy adjustment factors in Sprior c----------------------------------------------------------------------- IF(Nadj.gt.0)CALL copy(Adj,PLEN-Setpri+1,-1,Sprior(Setpri)) c----------------------------------------------------------------------- RETURN END x11log.cmn0000664006604000003110000000270414521201625012004 0ustar sun00315stepsc----------------------------------------------------------------------- c Axrghl - Logical variable which determines if X-11 regression c holiday factors were used to adjust the series c Axruhl - Logical variable which determines if X-11 user-defined c regression holiday factors were present c Axrgtd - Logical variable which determines if X-11 regression c trading day factors were used to adjust the series c Otlxrg - Logical variable which determines if AO outlier detection c is used with X-11 regression c Xeastr - Logical variable which determines if an AIC test will be c performed for Easter in the irregular regression c Xuser - Logical variable which determines if an AIC test will be c performed for user-defined regressors in the irregular c regression c Xhlnln - Logical variable which determines if a nonlinear c procedure will be used when TD+Holiday is used in the c X-11 regression. c----------------------------------------------------------------------- LOGICAL Axrgtd,Axrghl,Axruhl,Otlxrg,Xeastr,Xuser,Xhlnln,Calfrc, & Havxhl,Havxtd,Xelong,Lxrneg,Cvxtyp c----------------------------------------------------------------------- COMMON /lxropt/ Axrgtd,Axrghl,Axruhl,Otlxrg,Xeastr,Xuser,Xhlnln, & Calfrc,Havxhl,Havxtd,Xelong,Lxrneg,Cvxtyp x11mdl.f0000664006604000003110000011070114521201625011444 0ustar sun00315stepsC Last change: BCM 20 May 1999 8:36 am SUBROUTINE x11mdl(Sti,Muladd,Tmpma,Psuadd,Kpart,Kswv,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine performs an OLS regression on the irregular c component of an X-11 seasonal adjustment. The regressors have c been previously chosen by the user. c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' c----------------------------------------------------------------------- DOUBLE PRECISION MINONE,ONE,ZERO,SEVEN LOGICAL T,F,LCLOSE PARAMETER(T=.true.,F=.false.,ONE=1D0,ZERO=0D0,SEVEN=7D0,LCLOSE=T, & MINONE=-1D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'notset.prm' INCLUDE 'tbltitle.prm' INCLUDE 'desxrg.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'adj.cmn' INCLUDE 'error.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'xrgtbl.i' INCLUDE 'xrgmdl.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11log.cmn' INCLUDE 'xrgfct.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' INCLUDE 'sspinp.cmn' INCLUDE 'title.cmn' INCLUDE 'units.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'x11svl.i' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' INCLUDE 'xrgum.cmn' INCLUDE 'tdtyp.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- INTEGER PA PARAMETER(PA=PLEN+2*PORDER) c----------------------------------------------------------------------- CHARACTER tblttl*(PTTLEN),otltmp*(PCOLCR) DOUBLE PRECISION trnsrs,Sti,a,bb2,cvec,fcal,ftd,fhol,oldlam,ftmp, & dvec,tdwsum,tdwfix LOGICAL Psuadd,xm,fctok,trumlt,tdhol,Lgraf,lxao,lxls,lxtc,ldiag, & tdneg,isfix,ldum INTEGER Muladd,nbeg,nend,frstry,Kpart,fext,fext2,nfac,Tmpma, & irridx,ndifum,igrp,oldfcn,nf2,nb2,rtype,iusr,icol,begcol, & endcol,Kswv,oldnpm,ntbttl,ntmp,ivec,tdindx,iaic, & irrend,lastpr,icol2,ncol0,nbck DIMENSION trnsrs(PLEN),a(PA),cvec(POTLR),fcal(PLEN),ftd(PLEN), & fhol(PLEN),rtype(PB),ftmp(PLEN),bb2(PB),dvec(1),ivec(5), & Sti(PLEN) c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL dpeq,strinx c----------------------------------------------------------------------- INTEGER fhb,fhc SAVE fhb,fhc c----------------------------------------------------------------------- INCLUDE 'desxrg.var' c----------------------------------------------------------------------- DATA ivec/LXRTDF,LXRHLF,LXRCLF,LXRTDC,LXRCLC/ c----------------------------------------------------------------------- dvec(1)=ZERO CALL setdp(ZERO,PA,a) trumlt=(.not.Psuadd).and.Muladd.eq.0 ldiag=Lsumm.gt.0.and.(Issap.LT.2.AND.Irev.lt.4) CALL setdp(ZERO,PXPX,Chlxpx) c----------------------------------------------------------------------- c initialize temporary outlier variable (BCM May 2007) c----------------------------------------------------------------------- CALL setchr(' ',PCOLCR,otltmp) c----------------------------------------------------------------------- c Set limits for saving tables when forecasts and backcasts can be c saved (BCM October 2006) c----------------------------------------------------------------------- ntmp=Posfob IF(Savfct)ntmp=Posffc nbck=Pos1ob IF(Savbct)nbck=Pos1bk c----------------------------------------------------------------------- c Reset data transformation variables (to get correct AIC for c irregular regression) c----------------------------------------------------------------------- oldlam=Lam oldfcn=Fcntyp IF(Fcntyp.ne.4)THEN Lam=ONE Fcntyp=4 END IF oldnpm=Nestpm IF(oldnpm.gt.0)Nestpm=0 c----------------------------------------------------------------------- c Change Begspn and Endspn to match the model span, if necessary. c----------------------------------------------------------------------- CALL dfdate(Begxrg,Begspn,Sp,nbeg) IF(nbeg.gt.0)CALL cpyint(Begxrg,2,1,Begspn) CALL dfdate(Endspn,Endxrg,Sp,nend) IF(nend.gt.0)CALL cpyint(Endxrg,2,1,Endspn) c----------------------------------------------------------------------- c Restore values of Nfcst, Nbcst if this is last iteration c----------------------------------------------------------------------- nf2=Nfcst nb2=Nbcst IF(Kpart.eq.3.AND.(Nfcstx.gt.0.or.Nbcstx.gt.0))THEN Nfcst=Nfcstx Nbcst=Nbcstx c----------------------------------------------------------------------- c Reset values of X-11 pointer variables c----------------------------------------------------------------------- Pos1bk=Pos1ob-Nbcst Posffc=Posfob+Nfcst Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst END IF c----------------------------------------------------------------------- c If automatic AIC tests performed are to be done in the C c iteration, add td and easter[8] regressors in the first iteration c if they do not exist already. c----------------------------------------------------------------------- IF(Kpart.eq.2)THEN IF(Easgrp.eq.0.and.Xeastr)THEN CALL addeas(Xeasvc(3)+Easidx,Easidx,1) Easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(Easgrp.eq.0)Easgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'StatCanEaster') IF(Holgrp.eq.0)Holgrp=Easgrp IF(.not.Axrghl.and.Ixrghl.gt.0)Axrghl=T END IF IF((Tdgrp.eq.0.and.Stdgrp.eq.0).and.Xtdtst.gt.0)THEN c----------------------------------------------------------------------- c Add trading day c----------------------------------------------------------------------- tdindx=Xtdtst IF(tdindx.eq.3)tdindx=4 IF(tdindx.eq.2)tdindx=3 CALL addtd(Xaicst,Xaicrg,Xtdzro,Sp,tdindx) IF(Xtdtst.eq.2)THEN Stdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Stock Trading Day') ELSE Tdgrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') END IF IF(.not.Axrgtd.and.Ixrgtd.gt.0)Axrgtd=T END IF c----------------------------------------------------------------------- c If sliding spans or revisions history run, set starting values of c regression estimates to notset. c----------------------------------------------------------------------- c IF((Issap.eq.2.and.(Ssinit.eq.1.or.Nssfxr.gt.0)).or. IF(Issap.eq.2.or.Irev.eq.4)THEN IF(Nssfxx.gt.0.or.Nrvfxr.gt.0.or.Ssxint.or.Revfxx)THEN CALL copy(Bx,PB,1,B) ELSE CALL setdp(DNOTST,PB,B) END IF END IF END IF c----------------------------------------------------------------------- c add leap year regressor if additive seasonal adjustment is done. c----------------------------------------------------------------------- IF((.NOT.(Issap.eq.2.or.Irev.eq.4)).and.Muladd.eq.1.and. & Kpart.eq.2)THEN IF(strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day').gt.0) & CALL adrgef(DNOTST,'Leap Year','Leap Year',PRGTLY,F,F) END IF c----------------------------------------------------------------------- c store irregular into trnsrs c----------------------------------------------------------------------- CALL dfdate(Endspn,Begspn,Sp,Nspobs) Nspobs=Nspobs+1 IF(nbeg.gt.0.or.nend.gt.0.or.Issap.eq.2)THEN CALL dfdate(Begspn,Begsrs,Sp,Frstsy) Frstsy=Frstsy+1 Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nobs-Frstsy+1) END IF irridx=Pos1ob+nbeg CALL copy(Sti(irridx),Nobspf,-1,trnsrs) irrend=irridx+Nspobs-1 c----------------------------------------------------------------------- c Prior adjust irregular, if necessary c----------------------------------------------------------------------- ndifum=0 IF(Haveum)CALL dfdate(Begspn,Begum,Sp,ndifum) IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum) & CALL xrgtrn(trnsrs,irridx,irrend,Psuadd,Muladd,Tdgrp, & Haveum,Umean,ndifum,Kswv) c----------------------------------------------------------------------- c Check irregular for extreme values. These extreme values will be c excluded from the regression matrix. c----------------------------------------------------------------------- IF(Sigxrg.gt.ZERO)THEN IF(Muladd.eq.2)THEN Muladd=0 CALL antilg(Sti,Pos1ob,Posfob) END IF fext=LXRIRX+Kpart-2 CALL tdxtrm(Sti,Faccal,Tday,Sigxrg,Kpart,Muladd,fext,irridx, & irrend) IF(Tmpma.eq.2)THEN Muladd=2 CALL logar(Sti,Pos1ob,Posfob) END IF END IF c----------------------------------------------------------------------- c Short description of the X-11 regression c----------------------------------------------------------------------- fext=LXRXRG+Kpart-2 IF(Prttab(fext))THEN CALL makttl(DSIDIC,dsiptr,PDSI,fext,PDSUM5,tblttl,ntbttl,T,F) IF(Lfatal)RETURN IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF WRITE(Mt1,1020)tblttl(1:ntbttl) 1020 FORMAT(/,' ',a) IF(Ngrp.gt.0) & CALL desreg('Irregular Regression Model',Ngrp,Grpttl,Grpptr, & Ngrptl) IF(.not.Lfatal)CALL prtmsp(Begxrg,Endxrg,Sp,T) IF(Lfatal)RETURN WRITE(Mt1,1020)'Extreme Value Adjustment Method' IF(Sigxrg.gt.ZERO)WRITE(Mt1,1021)Sigxrg 1021 FORMAT(' Exclude irregular values outside ',f5.2,' sigma limit') IF(Otlxrg)WRITE(Mt1,1022) 1022 FORMAT(' Automatic AO outlier identification') END IF c----------------------------------------------------------------------- c if C iteration, do automatic aic tests, if requested. c change to B iteration - march 6 2006 BCM c----------------------------------------------------------------------- IF((Xtdtst.gt.0.or.Xeastr.or.(Xuser.and.Ncusrx.gt.0)).and. & Kpart.eq.2)THEN CALL x11aic(irridx,irrend,Muladd,Psuadd,Trnsrs,a,nbeg,Sti,Kswv, & Priadj,trumlt,Prttab(LXAICT),Svltab(LSLXTS),ldiag) IF(Lfatal)RETURN IF(Xtdtst.gt.0)THEN IF(Svltab(LSLXTS).or.ldiag)THEN iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(iaic.eq.0)iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'Stock Trading Day') IF(iaic.gt.0)THEN IF(Svltab(LSLXTS))WRITE(Ng,1025)' AICtdX : accepted' IF(ldiag)WRITE(Nform,1025)'aictest.xtd: yes' ELSE IF(Svltab(LSLXTS))WRITE(Ng,1025)' AICtdX : rejected' IF(ldiag)WRITE(Nform,1025)'aictest.xtd: no' END IF END IF Xtdtst=0 END IF IF(Xeastr)THEN IF(Svltab(LSLXTS).or.ldiag)THEN iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Easter') IF(iaic.eq.0)iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl, & 'StatCanEaster') IF(iaic.gt.0)THEN IF(Svltab(LSLXTS))WRITE(Ng,1025)' AICeasterX : accepted' IF(ldiag)THEN WRITE(Nform,1025)'aictest.xe: yes' WRITE(Nform,2025)'aictest.xe.window: ',Aicind 2025 FORMAT(a,i3) END IF ELSE IF(Svltab(LSLXTS))WRITE(Ng,1025)' AICeasterX : rejected' IF(ldiag)THEN WRITE(Nform,1025)'aictest.xe: no' WRITE(Nform,1025)'aictest.xe.window: 0' END IF END IF END IF Xeastr=F END IF IF(Xuser)THEN IF(Svltab(LSLXTS).or.ldiag)THEN iaic=strinx(T,Grpttl,Grpptr,1,Ngrptl,'User-defined') IF(iaic.gt.0)THEN IF(Svltab(LSLXTS))WRITE(Ng,1025)' AICuserX : accepted' IF(ldiag)WRITE(Nform,1025)'aictest.xu: yes' ELSE IF(Svltab(LSLXTS))WRITE(Ng,1025)' AICuserX : rejected' IF(ldiag)WRITE(Nform,1025)'aictest.xu: no' END IF END IF Xuser=F END IF 1025 FORMAT(a) CALL loadxr(T) IF(Holgrp.gt.0.or.Tdgrp.gt.0.or.Stdgrp.gt.0)THEN tdhol=Holgrp.gt.0.and.Tdgrp.gt.0 xm=Easidx.eq.0.and.(.not.(trumlt.and.tdhol.and.Xhlnln)) c----------------------------------------------------------------------- c If td or holiday not estimated, print warning message and leave c subroutine. c----------------------------------------------------------------------- ELSE IF(Prttab(LXAICT))WRITE(Mt1,1030)PRGNAM CALL errhdr WRITE(Mt2,1030)PRGNAM IF(.not.Lquiet)WRITE(STDERR,1030)PRGNAM 1030 FORMAT(' NOTE: Because of the AIC test result, ',a,' ', & 'has removed any trading day,',/,7x, & 'stock trading day, or holiday regressors from the ', & 'irregular component',/,7x, & 'regression model. No further model estimation will ', & 'be attempted.',//) IF(Tdtbl.eq.1.or.Tdtbl.eq.3)Tdtbl=Tdtbl-1 c----------------------------------------------------------------------- c If factors are to be saved, save vector of 0s (additive adj) or c 1s (mult, log additive, psuedo additive). c----------------------------------------------------------------------- IF(Savtab(LXRTDF+1).or.Savtab(LXRHLF+1).or.Savtab(LXRCLF+1).or. & Savtab(LXRTDC+1).or.Savtab(LXRCLC+1))THEN ntmp=Posfob IF(Savfct)ntmp=Posffc IF(Muladd.eq.1)THEN CALL setdp(ZERO,ntmp,ftmp) ELSE CALL setdp(ONE,ntmp,ftmp) END IF DO icol=1,5 fext2=ivec(icol)+1 IF(Savtab(fext2))THEN IF(icol.ge.4.and.Kswv.gt.0)THEN CALL punch(Stptd,nbck,ntmp,fext2,F,F) ELSE CALL punch(ftmp,nbck,ntmp,fext2,F,F) END IF END IF END DO END IF c----------------------------------------------------------------------- c Reset values of model parameters, X-11 pointer variables c----------------------------------------------------------------------- IF(oldnpm.gt.0)Nestpm=oldnpm IF(oldfcn.ne.4)THEN Lam=oldlam Fcntyp=oldfcn END IF IF(Nfcst.ne.nf2.or.Nbcst.ne.nb2)THEN Nfcst=nf2 Nbcst=nb2 Pos1bk=Pos1ob-Nbcst Posffc=Posfob+Nfcst Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst END IF IF(nbeg.gt.0.or.nend.gt.0) & CALL setspn(Sp,nend,nbeg,Begspn,Endspn,Begxrg,Endxrg,Nspobs, & Frstsy,Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy, & Begadj,Adj1st) c----------------------------------------------------------------------- IF(Axrgtd)Axrgtd=F IF(Axrghl)Axrghl=F IF(Axruhl)Axruhl=F c----------------------------------------------------------------------- IF(ldiag)THEN WRITE(Nform,1025)'nfinalxreg: 1' WRITE(Nform,1060)'finalxreg01: none' END IF RETURN END IF ELSE c----------------------------------------------------------------------- c Set up the regression matrix c----------------------------------------------------------------------- tdhol=Holgrp.gt.0.and.Tdgrp.gt.0 xm=Easidx.eq.0.and.(.not.(trumlt.and.tdhol.and.Xhlnln)) CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) IF((.not.Lfatal).and.Iregfx.ge.2)THEN CALL rmfix(trnsrs,Nbcst,Nrxy,1) IF(.not.Lfatal) & CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,0,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c If both trading day and holiday factors are included, multiply the c holiday regressors by Daybar c BCM May 1999 - Operation no longer necessary c----------------------------------------------------------------------- c IF((.not.Axruhl).and.tdhol) c & CALL xrghol(irridx,Psuadd,Xlpyr,Daybar) c----------------------------------------------------------------------- c Perform X-11 regression c----------------------------------------------------------------------- c IF(Kpart.eq.3)THEN c IF(Prttab(LXRXMX))THEN c CALL prtshd('Irregular Component Regression Matrix',Begxy,Sp, c & Nrxy,T) c IF(.not.Lfatal)CALL prtmtx(Begxy,Sp,Xy,Nrxy,Ncxy,Colttl,Colptr, c & Ncoltl) c END IF c END IF c----------------------------------------------------------------------- IF(.not.Lfatal)CALL regx11(a) IF(.not.Lfatal.and.Armaer.eq.PSNGER)CALL prterx() IF(.not.Lfatal)CALL rgtdhl(a,nbeg) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Do automatic AO outlier detection c----------------------------------------------------------------------- IF(Otlxrg.and.(Irev.lt.4.or.(Irev.eq.4.and.Rvxotl)).and. & (Issap.lt.2.or.(Issap.eq.2.and.Ssxotl)))THEN cvec(AO)=Critxr cvec(LS)=Critxr cvec(TC)=Critxr * cvec(SO)=Critxr lxao=T lxls=F lxtc=F * lxso=F ldum=F IF(Prttab(LXROHD).and.Prttab(fext))THEN * CALL prothd(Begxot,Endxot,lxao,lxls,lxtc,lxso,Ladd1x,cvec) CALL prothd(Begxot,Endxot,lxao,lxls,lxtc,Ladd1x,cvec) IF(Lfatal)RETURN END IF * CALL idotlr(lxao,lxls,lxtc,lxso,Ladd1x,cvec,Cvxrdc,Begxot,Endxot, CALL idotlr(lxao,lxls,lxtc,Ladd1x,cvec,Cvxrdc,Begxot,Endxot, & Nspobs,Lestim,Mxiter,Mxnlit,ldum,a,trnsrs,Nobspf, & Nfcst,Outfct,fctok,T,nbeg,Prttab(fext), & Prttab(LXROTT),Prttab(LXROIT),Savtab(LXROIT), & Prttab(LXROFT),Savtab(LXROFT),F,F) IF(Lfatal)RETURN c add new argument for svolit (BCM May 2007) IF(Savtab(LXROIT).and.Kpart.eq.3) & CALL svolit(LCLOSE,0,'*',otltmp,1,ZERO,ZERO,ZERO, & Savtab(LXROIT),T) END IF IF(Nfcst.gt.0.or.Nbcst.gt.0)THEN CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) c IF(((.not.Axruhl).and.tdhol).and.(.not.Lfatal)) c & CALL xrghol(Pos1ob,Psuadd,Xlpyr,Daybar) IF(Lfatal)RETURN END IF IF(Iregfx.ge.2)THEN CALL addfix(trnsrs,Nbcst,1,1) IF(.not.Lfatal) & CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx, & Nrusrx,Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) c IF(((.not.Axruhl).and.tdhol).and.(.not.Lfatal)) c & CALL xrghol(Pos1ob,Psuadd,Xlpyr,Daybar) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print out results of OLS regression c----------------------------------------------------------------------- IF(Kpart.eq.3)THEN CALL prtxrg(Lestim,Prttab(fext),Savtab(fext),Prttab(LXRXCM), & Savtab(LXRXCM),fext,fhc,ldiag) ELSE CALL prtxrg(Lestim,Prttab(fext),Savtab(fext),F,F,fext,fhb,F) END IF IF(Lfatal)RETURN c----------------------------------------------------------------------- c Copy the series into trnsrs, and transform the irregular, if c necessary c----------------------------------------------------------------------- IF(Xhlnln.and.trumlt.and.Easidx.eq.0.and.(.not.Axruhl.and.tdhol)) & THEN CALL copy(Sti(Pos1ob),Nspobs,-1,trnsrs) IF((Muladd.eq.0.or.Muladd.eq.2).or.Haveum) & CALL xrgtrn(trnsrs,Pos1ob,Pos1ob+Nspobs-1,Psuadd,Muladd,Tdgrp, & Haveum,Umean,ndifum,Kswv) c----------------------------------------------------------------------- c Generate regression matrix c----------------------------------------------------------------------- CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) c IF(((.not.Axruhl).and.tdhol).and.(.not.Lfatal)) c & CALL xrghol(Pos1ob,Psuadd,Xlpyr,Daybar) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print out and/or save the X-11 regression matrix c----------------------------------------------------------------------- IF(Kpart.eq.3)THEN IF(Prttab(LXRXMX))THEN CALL prtshd('Irregular Component Regression Matrix',Begxy,Sp, & Nrxy,T) IF(.not.Lfatal)CALL prtmtx(Begxy,Sp,Xy,Nrxy,Ncxy,Colttl,Colptr, & Ncoltl) END IF IF(.not.Lfatal.and.Savtab(LXRXMX)) & CALL savmtx(LXRXMX,Begxy,Sp,Xy,Nrxy,Ncxy,Colttl,Colptr,Ncoltl) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Reset beginning and ending dates for span, if necessary. c----------------------------------------------------------------------- lastpr=Posfob IF(Xdsp.gt.0.and.Kpart.eq.3)THEN nend=Xdsp lastpr=Posfob+Xdsp END IF IF(nbeg.gt.0.or.nend.gt.0)THEN CALL setspn(Sp,nend,nbeg,Begspn,Endspn,Begxrg,Endxrg,Nspobs, & Frstsy,Nobspf,Begsrs,Nobs,Nfcst,Fctdrp,Nomnfy,Begadj, & Adj1st) CALL regvar(trnsrs,Nobspf,Fctdrp,Nfcst,Nbcst,Userx,Bgusrx,Nrusrx, & Priadj,Reglom,Nrxy,Begxy,frstry,xm,Xelong) IF(.not.Lfatal.and.Xhlnln) & CALL kfcn(Begspn,Nrxy,Pos1ob,Xelong) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Generate adjustment factors for regression variables c----------------------------------------------------------------------- iusr=1 DO icol=1,Nb IF(Rgvrtp(icol).eq.PRGTUD.and.Ncusrx.gt.0)THEN rtype(icol)=Usrtyp(iusr) iusr=iusr+1 ELSE rtype(icol)=Rgvrtp(icol) END IF END DO IF(Havxtd.and.(.not.Haveum))THEN c----------------------------------------------------------------------- c Set up "X-11 style" daily weights, if possible c----------------------------------------------------------------------- igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(igrp.gt.0)THEN CALL setdp(DNOTST,7,Dx11) begcol=Grp(igrp-1) endcol=Grp(igrp)-1 Dx11(7)=ZERO IF(begcol.eq.endcol)THEN DO icol=1,5 Dx11(icol)=B(begcol) IF(Muladd.ne.1)Dx11(icol)=ONE+Dx11(icol) END DO DO icol=6,7 Dx11(icol)=(-5D0*B(begcol))/2D0 IF(Muladd.ne.1)Dx11(icol)=ONE+Dx11(icol) END DO ELSE DO icol=begcol,endcol IF(Muladd.eq.1)THEN Dx11(icol-begcol+1)=B(icol) ELSE Dx11(icol-begcol+1)=ONE+B(icol) END IF Dx11(7)=Dx11(7)-B(icol) END DO IF(Muladd.ne.1)Dx11(7)=Dx11(7)+ONE END IF IF(Kpart.eq.3.and.ldiag) & WRITE(Nform,1010)'x11tdwt:',(Dx11(icol),icol=1,7) c----------------------------------------------------------------------- c If necessary, reweight trading day daily weights when there are c values less than zero c----------------------------------------------------------------------- tdneg=F IF(Lxrneg)THEN tdwsum=ZERO tdwfix=ZERO ncol0=endcol-begcol+1 DO icol=1,ncol0 isfix=Regfxx(begcol+icol-1) IF(Dx11(icol).ge.ZERO)THEN IF(isfix)THEN tdwfix=tdwfix+Dx11(icol) ELSE tdwsum=tdwsum+Dx11(icol) END IF ELSE IF(.not.isfix)THEN Dx11(icol)=ZERO IF(.not.tdneg)tdneg=T END IF END IF END DO IF(Dx11(7).ge.ZERO)THEN tdwsum=tdwsum+Dx11(icol) ELSE Dx11(icol)=ZERO IF(.not.tdneg)tdneg=T END IF IF(tdneg)THEN IF(tdwsum.gt.ZERO)THEN DO icol=1,7 icol2=begcol+icol-1 IF(.not.(Regfxx(icol2).and.endcol.gt.begcol))THEN IF(Dx11(icol).gt.ZERO) & Dx11(icol)=Dx11(icol)*((SEVEN-tdwfix)/tdwsum) IF(icol.le.ncol0)B(icol2)=Dx11(icol)-ONE END IF END DO ELSE WRITE(Mt1,1000) CALL errhdr WRITE(Mt2,1000) WRITE(STDERR,1000) 1000 FORMAT(' ERROR: Cannot generate factor necessary to ', & 'reweight trading day',/, & ' daily weights - none of the unfixed daily ', & 'weights are greater',/,' than zero.') CALL abend() RETURN END IF IF(Kpart.eq.3.and.ldiag) & WRITE(Nform,1010)'x11tdwt2:',(Dx11(icol),icol=1,7) 1010 FORMAT(a,7(1x,f15.7)) IF(Prttab(fext))THEN WRITE(Mt1,1020)' ' CALL errhdr WRITE(Mt2,1020)' ' IF(Kpart.eq.2)THEN WRITE(Mt1,1040)'B','B','preliminary','B' WRITE(Mt2,1040)'B','B','preliminary','B' ELSE WRITE(Mt1,1040)'C','C','final','C' WRITE(Mt2,1040)'C','C','final','C' END IF 1040 FORMAT(' NOTE: At least one of the parameter estimates ', & 'above yields a negative',/, & ' daily weight for the ',a,' 16 table. The ', & 'reweighting done to avoid',/, & ' negative daily weights in Table ',a,' 16 ', & 'produced the following',/, & ' parameter estimates, which were used to ', & 'obtain the ',a,/, & ' trading day factors of ',a,' 16:',/) IF(begcol.eq.endcol)THEN WRITE(Mt1,1050)B(begcol),Dx11(7)-ONE WRITE(Mt2,1050)B(begcol),Dx11(7)-ONE 1050 FORMAT(' Weekday Weekend(**)',/,3X,2(3x,F8.4),//) ELSE WRITE(Mt1,1060)(B(icol),icol=begcol,endcol),Dx11(7)-ONE WRITE(Mt2,1060)(B(icol),icol=begcol,endcol),Dx11(7)-ONE 1060 FORMAT(' Mon Tue Wed Thur Fri', & ' Sat Sun(*)',/,3X,7F9.4,//) END IF END IF END IF END IF ELSE Dx11(1)=DNOTST IF(Muladd.eq.0)THEN igrp=strinx(T,Grpttx,Gpxptr,1,Ngrptx,'Stock Trading Day') IF(igrp.gt.0)THEN begcol=Grp(igrp-1) endcol=Grp(igrp)-1 tdneg=F DO icol=begcol,endcol IF((B(icol).lt.MINONE.or.dpeq(B(icol),MINONE)))tdneg=T END DO IF(tdneg)THEN WRITE(Mt1,1070) CALL errhdr WRITE(Mt2,1070) WRITE(STDERR,1070) 1070 FORMAT(' ERROR: At least one of the stock trading day ', & 'regression coefficient',/, & ' estimates from the irregular regression ', & 'model produce',/, & ' nonpositive trading day factors for ', & 'multiplicative seasonal',/,' adjustments.',//, & ' Use the regression spec to estimate the ', & 'stock trading day effect.',//) CALL abend() RETURN END IF END IF END IF END IF END IF c----------------------------------------------------------------------- * call profiler(3,'Entering x11ref') CALL x11ref(fcal,ftd,fhol,Pos1bk,Muladd,Psuadd,Tdgrp,Stdgrp, & Holgrp,Axruhl,ndifum,rtype,Nrxy,Ncxy,B,Xy,Nb, & Easidx,Kswv,Calfrc,Xhlnln) * call profiler(3,'After x11ref') c----------------------------------------------------------------------- c Copy trading day, holiday, combined calendar factors c----------------------------------------------------------------------- nfac=Posffc-Pos1bk+1 IF(Xdsp.gt.0.and.Kpart.eq.3)nfac=nfac+Xdsp CALL copy(fcal(1),nfac,-1,Faccal(Pos1bk)) IF(Havxtd)CALL copy(ftd(1),nfac,-1,Factd(Pos1bk)) IF(Havxhl)THEN CALL copy(fhol(1),nfac,-1,Facxhl(Pos1bk)) * call profiler(3,'Copy fhol into facxhl') END IF c----------------------------------------------------------------------- c Print out trading day factors c----------------------------------------------------------------------- IF(Havxtd.and.(.not.Haveum))THEN fext=LXRTDF+Kpart-2 c----------------------------------------------------------------------- IF(Prttab(fext))CALL table(Factd,Pos1ob,lastpr,16,1,1,Dx11,fext) IF(Savtab(fext).OR.(Lgraf.and.Kpart.eq.3))THEN IF(Savfct.or.Savbct)THEN IF(Savtab(fext))CALL punch(Factd,nbck,ntmp,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Factd,nbck,ntmp,fext,Lgraf,F) ELSE IF(Savtab(fext))CALL punch(Factd,Pos1ob,lastpr,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Factd,Pos1ob,lastpr,fext,Lgraf,F) END IF END IF END IF c----------------------------------------------------------------------- c Print out holiday factors c----------------------------------------------------------------------- IF(Havxhl.and.(.not.Haveum))THEN fext=LXRHLF+Kpart-2 IF(Prttab(fext))THEN * call profiler(3,'print facxhl') CALL table(Facxhl,Pos1ob,lastpr,21,1,1,dvec,fext) END IF IF(Savtab(fext).OR.(Lgraf.and.Kpart.eq.3))THEN IF(Savfct.or.Savbct)THEN IF(Savtab(fext))CALL punch(Facxhl,nbck,ntmp,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Facxhl,nbck,ntmp,fext,Lgraf,F) ELSE IF(Savtab(fext))CALL punch(Facxhl,Pos1ob,lastpr,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Facxhl,Pos1ob,lastpr,fext,Lgraf,F) END IF END IF END IF c----------------------------------------------------------------------- c Print out the combined calendar effects c----------------------------------------------------------------------- IF((Havxtd.and.Havxhl).and.Haveum)THEN fext=LXRCLF+Kpart-2 IF(Prttab(fext))CALL table(Faccal,Pos1ob,lastpr,22,1,1,dvec,fext) IF(Savtab(fext).OR.(Lgraf.and.Kpart.eq.3))THEN IF(Savfct.or.Savbct)THEN IF(Savtab(fext))CALL punch(Faccal,nbck,ntmp,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Faccal,nbck,ntmp,fext,Lgraf,F) ELSE IF(Savtab(fext))CALL punch(Faccal,Pos1ob,lastpr,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Faccal,Pos1ob,lastpr,fext,Lgraf,F) END IF END IF END IF c----------------------------------------------------------------------- c Divide out the trading day effect from the irregular c----------------------------------------------------------------------- IF(Axrgtd.or.Axrghl)THEN IF(Muladd.eq.2)THEN Muladd=0 CALL antilg(Sti,Pos1ob,Posfob) END IF CALL divsub(Sti,Sti,Faccal,Pos1ob,Posfob) IF(Tmpma.eq.2)THEN Muladd=2 CALL logar(Sti,Pos1ob,Posfob) END IF END IF c----------------------------------------------------------------------- c IF prior trading day adjustment done, compute combined trading day c weights. c----------------------------------------------------------------------- IF(Kswv.eq.3)THEN DO icol=1,7 Dx11(icol)=Dx11(icol)+Dwt(icol)-ONE END DO IF(Kpart.eq.3.and.ldiag) & WRITE(Nform,1010)'x11combtdwt:',(Dx11(icol),icol=1,7) c----------------------------------------------------------------------- IF(Calfrc)THEN CALL addmul(Faccal,Faccal,Stptd,Pos1bk,Posffc) CALL addmul(Factd,Factd,Stptd,Pos1bk,Posffc) ELSE c----------------------------------------------------------------------- igrp=strinx(T,Grpttl,Grpptr,1,Ngrptl,'Trading Day') IF(igrp.gt.0)THEN begcol=Grp(igrp-1) endcol=Grp(igrp)-1 ELSE begcol=0 endcol=0 END IF DO icol=1,Nb IF(icol.ge.begcol.and.icol.le.endcol)THEN bb2(icol)=Dx11(icol-begcol+1)-ONE ELSE bb2(icol)=B(icol) END IF END DO Kswv=4 CALL x11ref(fcal,ftd,ftmp,Pos1bk,Muladd,Psuadd,Tdgrp,Stdgrp, & Holgrp,Axruhl,ndifum,rtype,Nrxy,Ncxy,bb2,Xy,Nb, & Easidx,Kswv,Calfrc,Xhlnln) c----------------------------------------------------------------------- c Copy trading day, combined calendar factors c----------------------------------------------------------------------- nfac=Posffc-Pos1bk+1 IF(Xdsp.gt.0.and.Kpart.eq.3)nfac=nfac+Xdsp CALL copy(fcal(1),nfac,-1,Faccal(Pos1bk)) CALL copy(ftd(1),nfac,-1,Factd(Pos1bk)) END IF Kswv=3 IF(Kpart.eq.3)Kswv=4 ELSE IF(Kswv.eq.0.and.Kpart.eq.3.and.Ixreg.eq.2)THEN IF(Axrgtd)Kswv=2 END IF c----------------------------------------------------------------------- IF(Tmpma.eq.2)Muladd=Tmpma IF(oldfcn.ne.4)THEN Lam=oldlam Fcntyp=oldfcn END IF IF(oldnpm.gt.0)Nestpm=oldnpm c----------------------------------------------------------------------- c Reset values of X-11 pointer variables c----------------------------------------------------------------------- IF(Kpart.eq.3)THEN IF(Nfcst.ne.nf2.or.Nbcst.ne.nb2)THEN Nfcst=nf2 Nbcst=nb2 Pos1bk=Pos1ob-Nbcst Posffc=Posfob+Nfcst Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst END IF c----------------------------------------------------------------------- c Get regression trading day factors for type of month table c----------------------------------------------------------------------- IF(Tdtbl.gt.0)THEN IF(.not.Axrgtd)THEN IF(Tdtbl.eq.1.or.Tdtbl.eq.3)Tdtbl=Tdtbl-1 ELSE IF(Irev.lt.4)THEN CALL getxtd(Factd,Begspn,Pos1bk,nfac,Muladd) END IF END IF c----------------------------------------------------------------------- c If sliding spans is done with initial values from the original c estimation, reset the value of the x-11 regression starting c values OR c----------------------------------------------------------------------- IF((Issap.eq.1.AND.Nssfxr.gt.0).and. & (Irev.lt.4.AND.Nrvfxr.gt.0))CALL copy(B,PB,1,Bx) c----------------------------------------------------------------------- c IF revisions history is done with the refresh option, set saved c X-11 regression model to current values. c----------------------------------------------------------------------- IF(Lrfrsh.and.Irev.eq.4)CALL loadxr(T) c----------------------------------------------------------------------- c Copy trading factors into sliding spans variables, if this is a c transparent seasonal adjusment run c----------------------------------------------------------------------- IF(Issap.eq.2.and.Itd.eq.1) & CALL ssrit(Factd,Pos1ob,lastpr,1,Series) c----------------------------------------------------------------------- IF(ldiag)THEN IF(Nbx.gt.0)THEN CALL svfnrg('finalxreg',Ngrp,Grpttl,Grpptr,Ngrptl) ELSE WRITE(Nform,1025)'nfinalxreg: 1' WRITE(Nform,1060)'finalxreg01: none' END IF END IF END IF c----------------------------------------------------------------------- RETURN END x11msc.cmn0000664006604000003110000000224214521201625012002 0ustar sun00315stepsc----------------------------------------------------------------------- c Miscellanous X-11 options added to the X-12 program as c enhancements c----------------------------------------------------------------------- c Shrtsf - Logical variable which indicates when seasonal filter c specified by user should be used for short series c Psuadd - Logical variable which indicates when pseudo-additive c seasonal adjustment is performed c Same - Logical variable which indicates when all original series c values are the same c Rvper - Logical variable which indicates that percent revisions c are used c Yr2000 - Logical variable which indicates that yrs read in from c X-11 formats that are <= 45 are assumed to be from the c 21 century; else, years are assumed to be in the 20th c century. c----------------------------------------------------------------------- LOGICAL Shrtsf,Psuadd,Same,Rvper,Yr2000,Noxfct,Tru7hn, & Lcentr COMMON /x11msc/ Shrtsf,Psuadd,Same,Rvper,Yr2000,Noxfct,Tru7hn, & Lcentr x11opt.cmn0000664006604000003110000000554214521201625012030 0ustar sun00315stepsc----------------------------------------------------------------------- c Sigmal - lower sigma limit c Sigmau - upper sigma limit c Rati - I/S ratios for individual months (or quarters) c Ratis - Global MSR c Ratic - I/C ratio c Tic - I\C ratio specified by user and used to generate end wts c for henderson filter c----------------------------------------------------------------------- DOUBLE PRECISION Ratic,Tic,Rati,Ratis,Sigml,Sigmu c----------------------------------------------------------------------- c Length - Length of the series c Muladd - adjustment mode - (0=multiplicate, 1=add, 2=logadd) c Tmpma - temporary variable used in conjunction with Muladd c Imad - indicator designating which MAD used for std. error c in extreme value adjustment c Lterm - default seasonal filter used in seasonal adjustment c Mtype - type of seasonal filter used in seasonal adjustment c Lter - vector of seasonal filters used for each month (quarter) c in seasonal adjustment c Ktcopt - Henderson filter specified to estimate trend; if =0, c trend filter chosen automatically c Nterm - Henderson filter currently used to estimate trend c Lyr - first year of series seasonally adjusted c Lstmo - last month (or quarter) of series seasonally adjusted c Lstyr - last year of series seasonally adjusted c Kfulsm - indicator variable for full seasonal adjustment (0) or c summary measures (1) run c Ny - length of seasonal period (12 if monthly, 4 if quarterly) c Kpart - counter for which seasonal adjustment iteration c we are currently in c Kswv - indicator for prior trading day c Ksect - counter for what part of the seasonal adjustment iteration c we are currently in c Mcd - months for cyclical dominance c Keastr - Indicator variable for X-11 easter adjustment c Khol - Indicator variable for X-11 holiday adjustment c Kdec - number of output decimals to display c Lmsr - if > 0, this means automatic seasonal filter selection is c on for this run c----------------------------------------------------------------------- INTEGER Divpwr,Kdec,Muladd,Tmpma,Imad,Lterm,Mtype,Lter,Lmsr, & Ktcopt,Nterm,Lyr,Lstmo,Lstyr,Kfulsm,Ny,Length,Ishrnk, & Kpart,Kswv,Ksect,Mcd,Keastr,Khol c----------------------------------------------------------------------- DIMENSION Lter(PSP),Rati(3*PSP) c----------------------------------------------------------------------- COMMON /optxin/ Divpwr,Kdec,Muladd,Tmpma,Imad,Lterm,Mtype,Lter, & Lmsr,Ktcopt,Nterm,Lyr,Lstmo,Lstyr,Kfulsm,Ny, & Ishrnk,Kpart,Kswv,Ksect,Mcd,Length,Keastr,Khol COMMON /optxdp/ Ratic,Tic,Rati,Ratis,Sigml,Sigmu x11plt.f0000664006604000003110000001252314521201625011472 0ustar sun00315stepsC Last change: SRD 31 Dec 2001 7:48 am **==x11plt.f processed by SPAG 4.03F at 09:55 on 1 Mar 1994 SUBROUTINE x11plt(Z1,Z2,Ib,Ie,Tblptr,Itb,Lfac,Ptype,Ptype2) IMPLICIT NONE c ------------------------------------------------------------------ c Driver routine to print X11 plots c ------------------------------------------------------------------ LOGICAL F,T PARAMETER(F=.false.,T=.true.) c ------------------------------------------------------------------ INCLUDE 'srslen.prm' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'error.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'tbltitle.prm' INCLUDE 'x11tbl.i' c ------------------------------------------------------------------ CHARACTER tblttl*(PTTLEN),ttl*(PTTLEN),subttl*(PTTLEN) LOGICAL ltd,lhol,subhdr DOUBLE PRECISION Z1(*),Z2(*) INTEGER Ib,Ie,Lfac,Ptype,Ptype2,Tblptr,nttl,ntbttl,Itb,nsttl,nnls DIMENSION ttl(2),nttl(2) c ------------------------------------------------------------------ INTEGER nblank EXTERNAL nblank c ------------------------------------------------------------------ c Print page heading c ------------------------------------------------------------------ nnls=Nls-Nramp IF(Lpage)THEN WRITE(Mt1,Ttlfmt)Newpg,Title(1:Ntitle),Kpage,Serno(1:Nser) Kpage=Kpage+1 END IF c ------------------------------------------------------------------ c Set up title vector c ------------------------------------------------------------------ CALL getdes(Tblptr,tblttl,ntbttl,F) IF(Lfatal)RETURN CALL setchr(' ',PTTLEN,subttl) ttl(1)=tblttl(1:ntbttl) nttl(1)=ntbttl ttl(2)=' ' nttl(2)=0 IF(Tblptr.eq.LXETRP.and.Itb.eq.1.and.Adjls.eq.1)THEN nsttl=7 subttl(1:nsttl)=' (' IF(nnls.gt.0)THEN subttl((nsttl+1):(nsttl+2))='LS' nsttl=nsttl+2 Subhdr=T END IF IF(Nramp.gt.0)THEN IF(Subhdr)THEN subttl((nsttl+1):(nsttl+1))=',' nsttl=nsttl+1 ELSE Subhdr=T END IF subttl((nsttl+1):(nsttl+4))='ramp' nsttl=nsttl+4 END IF subttl((nsttl+1):(nsttl+18))='outliers included)' nsttl=nsttl+18 ELSE IF(Tblptr.eq.LXEIRP.and.Itb.eq.1.AND. & (Adjao.eq.1.or.Adjtc.eq.1))THEN Subhdr=T IF(Adjao.eq.1.and.Adjtc.eq.1)THEN subttl=' (AO & TC outliers included)' ntbttl=28 ELSE IF(Adjao.eq.1)THEN subttl=' (AO outliers included)' ntbttl=33 ELSE IF(Adjtc.eq.1)THEN subttl=' (TC outliers included)' ntbttl=28 END IF ELSE IF(Tblptr.eq.LXESAP)THEN subhdr=F ltd=Adjtd.eq.1.or.(Ixreg.gt.0.and.Axrghl) lhol=Finhol.and.(Khol.eq.2.or.(Ixreg.gt.0.and.Axrghl).or. & Adjhol.eq.1) nsttl=0 IF (ltd.or.lhol.OR.Finao.or.Finls.or.Fintc.or.Finusr) THEN nsttl=26 subttl(1:nsttl)=' (also adjusted for' IF(ltd)THEN subttl((nsttl+1):(nsttl+12))=' trading day' subhdr=T nsttl=nsttl+12 END IF IF(lhol)THEN IF(subhdr)THEN subttl((nsttl+1):(nsttl+1))=',' nsttl=nsttl+1 ELSE subhdr=T END IF subttl((nsttl+1):(nsttl+8))=' holiday' nsttl=nsttl+8 END IF IF(Finao.or.Finls.or.Fintc)THEN IF(subhdr)THEN subttl(nsttl+1:nsttl+1)=',' nsttl=nsttl+1 ELSE subhdr=T END IF IF(Finao.and.Finls.and.Fintc)THEN subttl((nsttl+1):(nsttl+20))=' AO, TC & LS outlier' nsttl=nsttl+20 ELSE IF(Finls.and.Fintc)THEN subttl((nsttl+1):(nsttl+16))=' TC & LS outlier' nsttl=nsttl+16 ELSE IF(Finao.and.Fintc)THEN subttl((nsttl+1):(nsttl+16))=' TC & AO outlier' nsttl=nsttl+16 ELSE IF(Finao.and.Finls)THEN subttl((nsttl+1):(nsttl+16))=' AO & LS outlier' nsttl=nsttl+16 ELSE IF(Finls)THEN subttl((nsttl+1):(nsttl+11))=' LS outlier' nsttl=nsttl+11 ELSE IF(Fintc)THEN subttl((nsttl+1):(nsttl+11))=' TC outlier' nsttl=nsttl+11 ELSE subttl((nsttl+1):(nsttl+11))=' AO outlier' nsttl=nsttl+11 END IF END IF IF(Finusr)THEN IF(subhdr)THEN subttl(nsttl+1:nsttl+1)=',' nsttl=nsttl+1 ELSE subhdr=T END IF subttl((nsttl+1):(nsttl+21))=' user-defined effects' nsttl=nsttl+21 END IF subttl(nsttl+1:nsttl+1)=')' nsttl=nsttl+1 END IF ttl(2)=subttl nttl(2)=nsttl END IF c ------------------------------------------------------------------ c Set up and print plot c ------------------------------------------------------------------ CALL grzlst(Ib,Ie,Lyr,Z1,Z2,Ny*9,Ny,Lfac) CALL chrt(ttl,nttl,Ptype,Ptype2,Ny) c ------------------------------------------------------------------ RETURN END x11pt1.f0000664006604000003110000003456014521201625011404 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 11:46 am SUBROUTINE x11pt1(Lmodel,Lgraf,Lgrfxr) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine performs pre-adjustments for holiday, prior c adjustment factors and prior trading day. c----------------------------------------------------------------------- c add backcast saving bcm october 2006 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'arima.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'agr.cmn' INCLUDE 'adj.cmn' INCLUDE 'error.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'xrgtbl.i' INCLUDE 'cmptbl.i' INCLUDE 'mdltbl.i' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'extend.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11log.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' INCLUDE 'missng.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- LOGICAL F,T PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- DOUBLE PRECISION std,dvec INTEGER i,n2,fext,fplt,lastpr,phol,lasttd,frsttd LOGICAL Lmodel,aorb1,Lgraf,mvind,Lgrfxr DIMENSION dvec(1),std(PLEN),mvind(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- IF(Muladd.eq.2)Muladd=0 dvec(1)=0D0 c----------------------------------------------------------------------- C --- PART A. c----------------------------------------------------------------------- Kpart=1 c----------------------------------------------------------------------- c Set indicators for missing values. c----------------------------------------------------------------------- CALL setlg(F,PLEN,mvind) IF(Missng)THEN DO i=Pos1ob,Posfob IF(dpeq(Series(i),Mvval))mvind(i)=T END DO END IF c----------------------------------------------------------------------- C --- SET STO and Stcsi EQUAL TO INPUT SERIES. c----------------------------------------------------------------------- Nspobs=Nofpob-Nfdrp CALL copy(Series(Pos1ob),Nspobs,-1,Stcsi(Pos1ob)) CALL copy(Series,Posfob,-1,Stoap) CALL copy(Series,Posfob,-1,Stopp) CALL copy(Series,Posfob,-1,Stocal) c CALL dfdate(Begspn,Begsrs,Sp,Frstsy) c Frstsy=Frstsy+1 c Nomnfy=Nobs-Frstsy+1 c Nobspf=min(Nspobs+max(Nfcst-Fctdrp,0),Nobs-Frstsy+1) * write(Mtprof,*) ' Orig(Pos1ob) = ',Orig(Pos1ob) CALL copy(Orig(Pos1ob),Nomnfy,-1,Sto(Pos1ob)) * write(Mtprof,*) ' Sto(Pos1ob) = ',Sto(Pos1ob) lastpr=Nofpob IF(Pos1ob.gt.1)lastpr=lastpr+Pos1ob-1 c----------------------------------------------------------------------- C --- WRITE UNADJUSTED ORIGINAL SERIES A1. c----------------------------------------------------------------------- c Set logical variables to determine if original series should be c printed, saved, or graphed c----------------------------------------------------------------------- fext=LSRSSP fplt=LSRA1P IF(Iagr.eq.3)THEN fext=LCMPA1 fplt=LCPA1P END IF c----------------------------------------------------------------------- c Print out original series. c----------------------------------------------------------------------- IF(.not.dpeq(Cnstnt,DNOTST))THEN DO i=Pos1ob,Posffc IF(.not.mvind(i))Series(i)=Series(i)-Cnstnt END DO END IF aorb1=.not.(Khol.eq.2.or.Ixreg.eq.3) IF(Prttab(fext).and.aorb1)THEN IF(Ny.eq.4.or.Ny.eq.12)THEN CALL table(Series,Pos1ob,Posfob,1,1,2,dvec,fext) ELSE CALL prtshd('Data for regARIMA modeling',Begspn,Sp, & Posfob-Pos1ob+1,T) CALL prttbl(Begspn,Sp,Series(Pos1ob),Posfob-Pos1ob+1,'Data', & Kdec) END IF END IF c----------------------------------------------------------------------- IF(Lgraf)CALL punch(Series,Pos1ob,Posfob,fext,Lgraf,F) IF((.not.Lfatal).and.aorb1.and.Savtab(fext)) & CALL punch(Series,Pos1ob,Posfob,fext,F,F) IF((.not.Lfatal).and.Prttab(fplt).and.(Ny.eq.4.or.Ny.eq.12).and. & aorb1) & CALL x11plt(Series,Series,Pos1ob,Posfob,fplt,0,0,6,1) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print series with constant added (added by BCM - July 2005) c----------------------------------------------------------------------- IF(.not.dpeq(Cnstnt,DNOTST))THEN DO i=Pos1ob,Posffc IF(.not.mvind(i))Series(i)=Series(i)+Cnstnt END DO IF(Prttab(LTRSCN))THEN IF(Ny.eq.4.or.Ny.eq.12)THEN CALL table(Series,Pos1ob,Posfob,1,1,2,dvec,LTRSCN) ELSE CALL prtshd('Original Series with Constant Added', & Begspn,Sp,Posfob-Pos1ob+1,T) CALL prttbl(Begspn,Sp,Series(Pos1ob),Posfob-Pos1ob+1,'Data', & Kdec) END IF END IF c----------------------------------------------------------------------- IF((.not.Lfatal).and.aorb1.and.Savtab(LTRSCN)) & CALL punch(Series,Pos1ob,Posfob,LTRSCN,F,F) IF(Lgraf)CALL punch(Series,Pos1ob,Posfob,LTRSCN,Lgraf,F) IF((.not.Lfatal).and.Prttab(LTRACP).and.(Ny.eq.4.or.Ny.eq.12) & .and.aorb1) & CALL x11plt(Series,Series,Pos1ob,Posfob,LTRACP,0,0,6,1) END IF c----------------------------------------------------------------------- c If no seasonal adjustment or modelling is done in this run, c return. c----------------------------------------------------------------------- c IF(.not.(Lx11.or.Lmodel).or.Lfatal)RETURN IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- TEST FOR PRIOR ADJUSTMENT. c----------------------------------------------------------------------- IF(Kfmt.ge.1)THEN c----------------------------------------------------------------------- c Print out prior factors c----------------------------------------------------------------------- CALL prtadj(Sprior,Pos1ob,Posfob,Nspobs,Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- DIVIDE (SUBTRACT) BY THE PRIOR ADJUSTMENT SERIES. c----------------------------------------------------------------------- CALL divsub(Sto,Sto,Sprior,Pos1ob,lastpr) IF(Missng)THEN CALL setmv(Sto,mvind,Mvval,Pos1ob,Posfob) CALL setmv(Stoap,mvind,Mvval,Pos1ob,Posfob) CALL setmv(Stopp,mvind,Mvval,Pos1ob,Posfob) END IF END IF c----------------------------------------------------------------------- C --- TEST FOR PRIOR Calendar ADJUSTMENT via X-11 Regression or c X-11 Easter. c (Changed by Brian Monsell, Feb. 1996, Feb. 1998, May 1999) c----------------------------------------------------------------------- phol=Posffc IF(Posfob.eq.Posffc)phol=Posfob+Ny IF(((Axrghl.or.Axrgtd).and.Ixreg.eq.3).or.Khol.gt.1)THEN IF(Khol.gt.1)CALL addmul(Faccal,Faccal,X11hol,Pos1bk,phol) CALL divsub(Sto,Sto,Faccal,Pos1ob,Posfob) IF(Missng)CALL setmv(Sto,mvind,Mvval,Pos1ob,Posfob) END IF c----------------------------------------------------------------------- C --- TEST FOR PRIOR TRADING DAY ADJUSTMENT, both specified by the user c and via X-11 Regression.(Changed by Brian Monsell, Dec. 1996) c----------------------------------------------------------------------- IF(Kswv.ne.0.or.(Ixreg.ge.2.and.Axrgtd))THEN c----------------------------------------------------------------------- C --- WRITE PRIOR ADJUSTED SERIES BEFORE T.D. ADJUSTMENT A3. c----------------------------------------------------------------------- IF(Prttab(LTRNA3).and.(Kfmt.gt.0.or.Khol.eq.2))THEN IF(Ny.eq.4.or.Ny.eq.12)THEN CALL table(Sto,Pos1ob,Posfob,3,1,2,dvec,LTRNA3) ELSE CALL prtshd( & 'Prior Adjusted Series (Before Prior Calendar Adjustments)', & Begspn,Sp,Posfob-Pos1ob+1,T) CALL prttbl(Begspn,Sp,Sto(Pos1ob),Posfob-Pos1ob+1,'Data',Kdec) END IF END IF IF(.not.Lfatal.and.Savtab(LTRNA3).and.Kfmt.gt.0) & CALL punch(Sto,Pos1ob,Posfob,LTRNA3,F,F) IF(.not.Lfatal.and.Lgraf.and.Kfmt.gt.0) & CALL punch(Sto,Pos1ob,Posfob,LTRNA3,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- WRITE Permanent PRIOR ADJUSTED SERIES A3P. c----------------------------------------------------------------------- IF(Prttab(LTRA3P).and.(Kfmt.gt.0.and.Nuspad.gt.0))THEN IF(Ny.eq.4.or.Ny.eq.12)THEN CALL table(Stopp,Pos1ob,Posfob,3,2,2,dvec,LTRA3P) ELSE CALL prtshd('Prior Adjusted Series (Permanent Prior Factors)', & Begspn,Sp,Posfob-Pos1ob+1,T) CALL prttbl(Begspn,Sp,Stopp(Pos1ob),Posfob-Pos1ob+1,'Data', & Kdec) END IF END IF IF((.not.Lfatal).and.Savtab(LTRA3P).and.Kfmt.gt.0.and. & Nuspad.gt.0)CALL punch(Stopp,Pos1ob,Posfob,LTRA3P,F,F) IF((.not.Lfatal).and.Lgraf.and.Kfmt.gt.0.and.Nuspad.gt.0) & CALL punch(Stopp,Pos1ob,Posfob,LTRA3P,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Generate prior trading day factors c----------------------------------------------------------------------- IF(Kswv.eq.1.and.(((Axrghl.or.Axrgtd).and.Ixreg.eq.3).or. & Khol.lt.2))THEN n2=Nbfpob IF(Nfcst.eq.0)n2=n2+Sp CALL pritd(Dwt,Stptd,n2,Sp,Begbk2,Muladd,Psuadd,Kswv,Pos1bk) IF(Lfatal)RETURN IF(Axrgtd)Kswv=Kswv+2 c----------------------------------------------------------------------- C --- WRITE PRIOR TRADING FACTORS A4. c----------------------------------------------------------------------- IF(Prttab(LXRGA4)) & CALL table(Stptd,Pos1ob,Posfob,4,1,1,Dwt,LXRGA4) IF(.not.Lfatal.and.(Savtab(LXRGA4).or.Lgrfxr))THEN IF(.not.Savfct)THEN lasttd=Posfob ELSE IF(Nfcst.gt.0)THEN lasttd=Posffc ELSE lasttd=Posfob+Sp END IF IF(Savbct)THEN frsttd=Pos1bk ELSE frsttd=Pos1ob END IF IF(Savtab(LXRGA4))CALL punch(Stptd,frsttd,lasttd,LXRGA4,F,F) IF(Lgrfxr)CALL punch(Stptd,frsttd,lasttd,LXRGA4,Lgrfxr,F) END IF c----------------------------------------------------------------------- c Save X-11 Regression TD into sliding spans variable c----------------------------------------------------------------------- IF(Issap.eq.2.and.Ixreg.ne.2) & CALL ssrit(Stptd,Pos1ob,Posfob,1,Series) c----------------------------------------------------------------------- C --- DIVIDE (SUBTRACT) PRIOR ADJUSTED OR ORIGINAL BY PRIOR T.D. FACTORS c----------------------------------------------------------------------- CALL copy(Stptd(Pos1ob),Nbfpob,-1,std(Pos1ob)) CALL divsub(Sto,Sto,std,Pos1ob,lastpr) IF(Kswv.eq.1)CALL addmul(Faccal,Faccal,Stptd,Pos1bk,phol) c----------------------------------------------------------------------- c Check to see if prior adjustments have brought down missing c value code. c----------------------------------------------------------------------- IF(Missng)CALL setmv(Sto,mvind,Mvval,Pos1ob,lastpr) END IF END IF IF(Lmodel.AND.(Ixreg.eq.3.or.Ixreg.eq.0).and.Khol.ne.1)THEN c----------------------------------------------------------------------- C --- WRITE PRIOR ADJUSTED SERIES BEFORE ARIMA MODELLING c --- update table pointer fext if prior trading day factors are used c (BCM March 2004) c----------------------------------------------------------------------- fext=LTRNA3 IF(Kswv.gt.0)fext=LTRA4D IF(Prttab(fext).and.Kfmt.gt.0)THEN IF(Ny.eq.4.or.Ny.eq.12)THEN CALL table(Sto,Pos1ob,Posfob,3,1,2,dvec,fext) ELSE CALL prtshd('Prior Adjusted Series',Begspn,Sp,Posfob-Pos1ob+1, & T) CALL prttbl(Begspn,Sp,Sto(Pos1ob),Posfob-Pos1ob+1,'Data',Kdec) END IF END IF IF(Lfatal)RETURN IF((.not.Lfatal).and.Savtab(fext)) & CALL punch(Sto,Pos1ob,Posfob,fext,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Sto,Pos1ob,Posfob,fext,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- WRITE Permanent PRIOR ADJUSTED SERIES A3P. c --- update table pointer fext if prior trading day factors are used c (BCM March 2004) c----------------------------------------------------------------------- fext=LTRA3P IF(Kswv.gt.0)fext=LTRA4P IF(Prttab(fext).and.(Kfmt.gt.0.and.Nuspad.gt.0))THEN IF(Ny.eq.4.or.Ny.eq.12)THEN CALL table(Stopp,Pos1ob,Posfob,3,2,2,dvec,fext) ELSE CALL prtshd('Prior Adjusted Series (Permanent Prior Factors)', & Begspn,Sp,Posfob-Pos1ob+1,T) CALL prttbl(Begspn,Sp,Stopp(Pos1ob),Posfob-Pos1ob+1,'Data', & Kdec) END IF END IF IF((.not.Lfatal).and.Savtab(fext).and.Kfmt.gt.0.and.Nuspad.gt.0) & CALL punch(Stopp,Pos1ob,Posfob,fext,F,F) IF((.not.Lfatal).and.Lgraf.and.Kfmt.gt.0.and.Nuspad.gt.0) & CALL punch(Stopp,Pos1ob,Posfob,fext,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- SET STSCI EQUAL TO PRIOR ADJUSTED SERIES. c----------------------------------------------------------------------- CALL copy(Sto(Pos1ob),Posfob-Pos1ob+1,-1,Stcsi(Pos1ob)) c----------------------------------------------------------------------- RETURN END x11pt2.f0000664006604000003110000011764614521201625011414 0ustar sun00315stepsC Last change: LS Oct.24,2023-save d7trendma in .udg file C previous change: LS Nov. 1 2022- saved .b1 file C previous change: BCM 20 May 1999 8:58 am SUBROUTINE x11pt2(Lmodel,Lx11,Lseats,Lgraf,Lgrfxr) IMPLICIT NONE c----------------------------------------------------------------------- c Performs B, C, and D (up to table D7) iterations of X-11 seasonal c adjustment method c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO LOGICAL F,T PARAMETER(F=.false.,T=.true.,ONE=1D0,ZERO=0D0) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'srslen.prm' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'cmptbl.i' INCLUDE 'mdltbl.i' INCLUDE 'x11tbl.i' INCLUDE 'xrgtbl.i' INCLUDE 'error.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'xrgum.cmn' INCLUDE 'agr.cmn' INCLUDE 'units.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'xtrm.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'tdtyp.cmn' INCLUDE 'ssap.prm' INCLUDE 'ssap.cmn' c----------------------------------------------------------------------- CHARACTER pristr*(17),trnchr*1 LOGICAL gudrun,Lx11,Lseats,Lmodel,Lgraf,goodlm,oktrn,chkfct,Lgrfxr DOUBLE PRECISION Stex,Temp,dvec,Lam,dtemp,rbar,adjtmp INTEGER Fcntyp,i,posfex,pos1ex,kersa1,ksdev1,khclda,klda,lfd,lld, & fext,mfd1,mfda,mlda,iv,ksav,ny2,n2,lsthol,ntype,npri, & indhol,fexp,bsav DIMENSION dtemp(PLEN),dvec(1),Stex(PLEN),Temp(PLEN), & trnchr(PLEN),adjtmp(PLEN) c----------------------------------------------------------------------- c INTEGER mqu,Iwt,Kexopt c COMMON /oldopt/ Iwt,Kexopt c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- COMMON /work / Temp COMMON /mq10 / Stex COMMON /armalm/ Lam,Fcntyp c----------------------------------------------------------------------- rbar=1D0 IF(Muladd.eq.1)rbar=0D0 dvec(1)=ZERO Length=Posfob-Pos1ob+1 ny2=Ny/2 kersa1=Kersa ksdev1=Ksdev goodlm=dpeq(Lam,0D0).or.dpeq(Lam,1D0) gudrun=Issap.lt.2.and.Irev.lt.4.and.(Khol.ne.1) c----------------------------------------------------------------------- c If saving xdg file, save prior adjustment information here. c----------------------------------------------------------------------- IF(Lsumm.gt.0.and.gudrun)THEN IF(Kfmt.gt.0.and.Ixreg.ne.2)THEN pristr=' ' npri=0 IF(Priadj.eq.2)THEN pristr((npri+1):(npri+4))=' lom' npri=4 ELSE IF(Priadj.eq.3) THEN pristr((npri+1):(npri+4))=' loq' npri=4 ELSE IF(Priadj.eq.4)THEN pristr((npri+1):(npri+7))=' lpyear' npri=7 END IF IF(Nprtyp.gt.0)THEN DO i=1,Nprtyp IF(Prtype(i).eq.1)THEN pristr((npri+1):(npri+5))=' temp' ELSE pristr((npri+1):(npri+5))=' perm' END IF npri=npri+5 END DO END IF WRITE(Nform,1650)pristr ELSE WRITE(Nform,1650)' none' END IF END IF 1650 FORMAT('prioradj:',a) c----------------------------------------------------------------------- c Adjust series and prior effects when model based trading day and c lom adjustment are done together. c----------------------------------------------------------------------- IF(Nfcst.lt.Ny)THEN n2=Posfob+Ny ELSE n2=Posffc END IF IF(Ixreg.ne.2.AND.Priadj.gt.1.and.goodlm)THEN CALL makadj(adjtmp,Muladd) IF(Nflwtd.gt.0)THEN CALL tdlom(Stcsi,Stocal,Sprior,Factd,Pos1bk,n2,Muladd,Adjtd, & adjtmp) c----------------------------------------------------------------------- c If flow trading day not in model and prior adjustment for c lom or loq or leap year is done, remove that effect from Stocal c (BCM, Oct 2009) c----------------------------------------------------------------------- ELSE CALL divsub(Stocal,Stocal,Sprior,Pos1bk,n2) CALL addmul(Stocal,Stocal,adjtmp,Pos1bk,n2) END IF END IF c----------------------------------------------------------------------- c Store regression trading day factors for sliding spans analysis c----------------------------------------------------------------------- IF(Issap.eq.2)THEN IF(Itd.eq.1)THEN IF(Adjtd.eq.1)THEN CALL ssrit(Factd,Pos1ob,Posfob,1,Series) ELSE Itd=0 IF(Axrgtd)Itd=1 END IF END IF c----------------------------------------------------------------------- c Check to see if holiday adjustment done of series is done during c sliding spans c----------------------------------------------------------------------- IF((.not.(Adjhol.eq.1.or.Finhol)).and. & (Ihol.eq.1.and.Khol.eq.0))Ihol=0 END IF c----------------------------------------------------------------------- c Print model based adjustment factors c----------------------------------------------------------------------- khclda=Posffc-Nfdrp IF(Nfdrp.eq.0)khclda=Posfob ksav=khclda IF(Savfct)ksav=n2 bsav=Pos1ob IF(Savbct)bsav=Pos1bk IF(Adjtd.eq.1.and.goodlm)THEN IF(Prttab(LREGTD)) & CALL table(Factd,Pos1ob,khclda,6,1,1,dvec,LREGTD) IF(.not.Lfatal.and.Savtab(LREGTD)) & CALL punch(Factd,bsav,ksav,LREGTD,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Factd,bsav,ksav,LREGTD,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Combine with Calendar effect factors (BCM May 1999) c----------------------------------------------------------------------- CALL addmul(Faccal,Faccal,Factd,Pos1bk,n2) c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- IF((Adjhol.eq.1.or.(Finhol.and.Nhol.gt.0)).and.Khol.ne.1.and. & goodlm.and.Lmodel.AND.(.not.Axrghl))THEN IF(Prttab(LRGHOL)) & CALL table(Fachol,Pos1ob,khclda,7,1,1,dvec,LRGHOL) IF(.not.Lfatal.and.Savtab(LRGHOL)) & CALL punch(Fachol,bsav,ksav,LRGHOL,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Fachol,bsav,ksav,LRGHOL,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Combine with Calendar effect factors (BCM May 1999) c----------------------------------------------------------------------- CALL addmul(Faccal,Faccal,Fachol,Pos1bk,n2) END IF c----------------------------------------------------------------------- ntype=0 IF(((Adjao.eq.1.or.Finao).or.(Adjls.eq.1.or.Finls).or. & (Adjtc.eq.1.or.Fintc).or.Adjso.eq.1).and.goodlm)THEN CALL setdp(rbar,PLEN,dtemp) IF(Adjao.eq.1.or.Finao)THEN CALL addmul(dtemp,dtemp,Facao,Pos1ob,Posffc) ntype=ntype+1 END IF IF(Adjls.eq.1.or.Finls)THEN CALL addmul(dtemp,dtemp,Facls,Pos1ob,Posffc) ntype=ntype+1 END IF IF(Adjtc.eq.1.or.Fintc)THEN CALL addmul(dtemp,dtemp,Factc,Pos1ob,Posffc) ntype=ntype+1 END IF IF(Adjso.eq.1)THEN CALL addmul(dtemp,dtemp,Facso,Pos1ob,Posffc) ntype=ntype+1 END IF IF(Prttab(LRGOTL).or.(ntype.eq.1.AND. & (((Adjao.eq.1.or.Finao).and.Prttab(LREGAO)).or. & ((Adjls.eq.1.or.Finls).and.Prttab(LREGLC)).or. & ((Adjtc.eq.1.or.Fintc).and.Prttab(LREGTC)).or. & (Adjso.eq.1.and.Prttab(LREGSO))))) & CALL table(dtemp,Pos1ob,khclda,8,1,1,dvec,LRGOTL) IF(.not.Lfatal.and.Savtab(LRGOTL)) & CALL punch(dtemp,bsav,ksav,LRGOTL,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(dtemp,bsav,ksav,LRGOTL,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF((Adjao.eq.1.or.Finao).and.goodlm)THEN IF(Prttab(LREGAO).and.ntype.gt.1) & CALL table(Facao,Pos1ob,Posfob,8,2,1,dvec,LREGAO) IF(.not.Lfatal.and.Savtab(LREGAO)) & CALL punch(Facao,Pos1ob,Posfob,LREGAO,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Facao,Pos1ob,Posfob,LREGAO,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF((Adjls.eq.1.or.Finls).and.goodlm)THEN IF(Prttab(LREGLC).and.ntype.gt.1) & CALL table(Facls,Pos1ob,Posfob,8,3,1,dvec,LREGLC) IF(.not.Lfatal.and.Savtab(LREGLC)) & CALL punch(Facls,Pos1ob,Posfob,LREGLC,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Facls,Pos1ob,Posfob,LREGLC,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF((Adjtc.eq.1.or.Fintc).and.goodlm)THEN IF(Prttab(LREGTC).and.ntype.gt.1) & CALL table(Factc,Pos1ob,khclda,8,4,1,dvec,LREGTC) IF(.not.Lfatal.and.Savtab(LREGTC)) & CALL punch(Factc,bsav,ksav,LREGTC,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Factc,bsav,ksav,LREGTC,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Adjso.eq.1.and.goodlm)THEN IF(Prttab(LREGSO).and.ntype.gt.1) & CALL table(Facso,Pos1ob,Posfob,8,5,1,dvec,LREGSO) IF(.not.Lfatal.and.Savtab(LREGSO)) & CALL punch(Facso,Pos1ob,Posfob,LREGSO,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Facso,Pos1ob,Posfob,LREGSO,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF((Adjusr.eq.1.or.Finusr).and.goodlm)THEN IF(Prttab(LRGUSR)) & CALL table(Facusr,Pos1ob,khclda,9,1,1,dvec,LRGUSR) IF(.not.Lfatal.and.Savtab(LRGUSR)) & CALL punch(Facusr,bsav,ksav,LRGUSR,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Facusr,bsav,ksav,LRGUSR,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- IF(Adjsea.eq.1.and.goodlm)THEN IF(Prttab(LRGA10)) & CALL table(Facsea,Pos1ob,khclda,10,1,1,dvec,LRGA10) IF(.not.Lfatal.and.Savtab(LRGA10)) & CALL punch(Facsea,bsav,ksav,LRGA10,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Facsea,bsav,ksav,LRGA10,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print out regARIMA transitory component for SEATS adjustments c (Aug 2004 - BCM) c----------------------------------------------------------------------- IF(Adjcyc.eq.1.and.goodlm.and.Lseats)THEN IF(Prttab(LRGA13)) & CALL table(Faccyc,Pos1ob,khclda,13,1,1,dvec,LRGA13) IF(.not.Lfatal.and.Savtab(LRGA13)) & CALL punch(Faccyc,bsav,ksav,LRGA13,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Faccyc,bsav,ksav,LRGA13,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print combined holiday effect c----------------------------------------------------------------------- IF(.not.Noxfac)THEN indhol=0 IF(Khol.eq.2)indhol=indhol+1 IF(Ixreg.gt.2.and.Axrghl.and.(.not.Haveum))indhol=indhol+1 IF(Adjhol.eq.1)indhol=indhol+1 IF(indhol.gt.0.and.goodlm)THEN IF(Nfcst.eq.0)THEN lsthol=Posfob+Ny ELSE lsthol=Posffc END IF IF(Ixreg.gt.2.and.Axrghl) & CALL addmul(Fachol,Fachol,Facxhl,Pos1bk,lsthol) IF(Khol.eq.2)CALL addmul(Fachol,Fachol,X11hol,Pos1bk,lsthol) IF(Prttab(LXECHL).and.indhol.gt.1) & CALL table(Fachol,Pos1ob,khclda,16,1,1,dvec,LXECHL) IF(.not.Lfatal.and.Savtab(LXECHL)) & CALL punch(Fachol,bsav,ksav,LXECHL,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Fachol,bsav,ksav,LXECHL,Lgraf,F) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- c Generate and print the calendar adjusted original series c----------------------------------------------------------------------- IF(Adjhol.eq.1.or.Adjtd.eq.1.or.Khol.eq.2.or. & (Ixreg.gt.2.and.(Axrgtd.or.Axrghl)).or. & Ixreg.ne.2.and.Priadj.gt.1.and.goodlm)THEN fexp=LSRA18 IF(Iagr.eq.3)fexp=LCPA18 * CALL divsub(Stocal,Series,Faccal,Pos1ob,Posfob) IF(Prttab(fexp))CALL table(Stocal,Pos1ob,Posfob,18,1,2,dvec,fexp) IF(.not.Lfatal.and.Savtab(fexp)) & CALL punch(Stocal,bsav,ksav,fexp,F,F) * & CALL punch(Stocal,Pos1ob,Posfob,fexp,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Stocal,bsav,ksav,fexp,Lgraf,F) * & CALL punch(Stocal,Pos1ob,Posfob,fexp,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Generate and print the outlier adjusted original series c----------------------------------------------------------------------- fexp=LSRA19 IF(Iagr.eq.3)fexp=LCPA19 IF((Savtab(fexp).or.Prttab(fexp).or.Lgraf).and. & (Adjls.eq.1.or.Adjtc.eq.1.or.Adjao.eq.1.or.Adjso.eq.1))THEN IF(Prttab(fexp)) & CALL table(Temp,Pos1ob,Posfob,19,1,2,dvec,fexp) IF(.not.Lfatal.and.Savtab(fexp)) & CALL punch(Temp,Pos1ob,Posfob,fexp,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(Temp,Pos1ob,Posfob,fexp,Lgraf,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- PART B c----------------------------------------------------------------------- Kpart=2 Ksect=1 c----------------------------------------------------------------------- C --- WRITE ORIGINAL OR PRIOR ADJUSTED B1. C IF (IFORC.NE.0.AND.LENGTH.LE.IFTNY.AND.KEBACK.EQ.0) LYR=LYR-1 c----------------------------------------------------------------------- IF(.NOT.(Ixreg.eq.2.or.Khol.eq.1))THEN fexp=LSRSB1 IF(Iagr.eq.3)fexp=LCMPB1 IF(Prttab(fexp).AND.(Lmodel.or.Kfmt.gt.0.or.Kswv.gt.0.or. & Khol.eq.2.or.Ixreg.ge.3)) & CALL table(Stcsi,Pos1bk,khclda,1,1,2,dvec,fexp) c only print to the number of forecast if specified IF(.not.Lfatal.and.Savtab(fexp)) then IF(Savfct) then CALL punch(Stcsi,bsav,Posffc,fexp,F,F) else CALL punch(Stcsi,bsav,Posfob,fexp,F,F) end if end if IF(.not.Lfatal.and.Lgraf) then IF(Savfct) then CALL punch(Stcsi,bsav,Posffc,fexp,Lgraf,F) else CALL punch(Stcsi,bsav,Posfob,fexp,Lgraf,F) end if end if fexp=LSRB1P IF(Iagr.eq.3)fexp=LCPB1P IF(.not.Lfatal.and.Prttab(fexp)) & CALL x11plt(Stcsi,Stcsi,Pos1bk,Posffc,fexp,0,0,6,1) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c If X-11 Seasonal adjustment options not specified, return c----------------------------------------------------------------------- IF(.not.Lx11)RETURN c----------------------------------------------------------------------- C IF(Nfcst.ne.0)THEN C llaf=Posffc-Nfcst+1 C CALL copy(Stcsi(llaf),Posffc-llaf+1,1,Series(llaf)) C llaf=Pos1ob-1 C CALL copy(Stcsi(Pos1bk),llaf-Pos1bk+1,1,Series(Pos1bk)) C tmp=ONE C IF(Muladd.eq.1)tmp=ZERO C CALL setdp(tmp,Posffc-Posfob,Sprior(Posfob+1)) C END IF c----------------------------------------------------------------------- C --- TAKE LOGARITHM OF B1 IF THE LOGARITHMIC MODEL IS SELECTED. c----------------------------------------------------------------------- Muladd=Tmpma IF(Muladd.eq.2)CALL logar(Stcsi,Pos1bk,Posffc) CALL copy(Stcsi(Pos1bk),Posffc-Pos1bk+1,1,Sto(Pos1bk)) IF(.not.(Kswv.eq.0.or.Nfcst.eq.0.or.Adjtd.eq.1))THEN DO i=1,Ny Series(Posfob+i)=Series(Posfob+i)*Stptd(Posfob+i) END DO END IF c----------------------------------------------------------------------- C --- APPLY A CENTERED NY-TERM MOVING AVERAGE. c----------------------------------------------------------------------- * IF(Ny.eq.12)mqu=1 * IF(Ny.eq.4)mqu=2 DO WHILE (T) c write(*,*)' part ',Kpart,' starts' c IF(Iwt.eq.1)CALL weight(Stcsi,Stc,Pos1bk,Posffc,mqu) c IF(Iwt.eq.0)CALL averag(Stcsi,Stc,Pos1bk,Posffc,2,Ny) CALL averag(Stcsi,Stc,Pos1bk,Posffc,2,Ny) mfda=Pos1bk+ny2 mfd1=Pos1ob+ny2 mlda=Posffc-ny2 klda=Posfob-ny2 c----------------------------------------------------------------------- C --- DIVIDE (SUBTRACT) ORIGINAL BY TREND CYCLE FOR SI RATIOS. c----------------------------------------------------------------------- CALL divsub(Stsi,Stcsi,Stc,mfda,mlda) c----------------------------------------------------------------------- C --- SECTION 1. APPLY AN F-TEST TO THE SI TO TEST FOR THE PRESENCE C --- OF SEASONALITY. c----------------------------------------------------------------------- c IF(Prttab(LXEB1F).and. IF(Ksect.eq.1.and.Kpart.eq.2.and.Ixreg.ne.2.and.Khol.ne.1) & CALL ftest(Stsi,mfd1,klda,Ny,2,Prttab(LXEB1F),F) lfd=Pos1ob+(Ny/2) lld=Posfob-(Ny/2) fext=LXEITN+Kpart-2 IF(Prttab(fext))THEN c----------------------------------------------------------------------- C --- WRITE TREND CYCLE B2,C2,D2. c----------------------------------------------------------------------- IF(Nfcst.ne.0)THEN CALL table(Stc,lfd,Posfob,2,1,2,dvec,fext) ELSE CALL table(Stc,lfd,lld,2,1,2,dvec,fext) END IF IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- SAVE TREND CYCLE B2,C2,D2. c----------------------------------------------------------------------- IF(Savtab(fext))THEN IF(Nfcst.ne.0)THEN CALL punch(Stc,lfd,Posfob,fext,F,F) ELSE CALL punch(Stc,lfd,lld,fext,F,F) END IF IF(Lfatal)RETURN END IF IF(Kpart.eq.2)THEN c----------------------------------------------------------------------- C --- PART B. REPLACE EXTREME SI RATIOS (DIFFERENCES) c----------------------------------------------------------------------- posfex=mlda pos1ex=mfda IF(Noxfct)THEN posfex=klda pos1ex=mfd1 END IF CALL si(Ksect,mfda,mlda,Ny,Nfcst,Nbcst,kersa1,ksdev1,Pos1ob, & Posfob,Kfulsm,pos1ex,posfex) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- PART C AND D. COMPUTE A 5-TERM MOVING AVERAGE OF EACH MONTH C --- (QUARTER) FOR ESTIMATE OF SEASONAL FACTORS. c----------------------------------------------------------------------- ELSE IF(Kfulsm.lt.2)CALL vsfb(Sts,Stsi,mfda,mlda,Ny) c----------------------------------------------------------------------- C --- WRITE MODIFIED SI RATIOS (DIFFERENCES) C4 AND D4. c----------------------------------------------------------------------- fext=LXEIMS+Kpart-3 IF(Prttab(fext))THEN IF(Nfcst.ne.0)THEN IF(Nbcst.eq.0)THEN CALL table(Stsi,lfd,Posfob,4,1,1,dvec,fext) ELSE CALL table(Stsi,Pos1ob,Posfob,4,1,1,dvec,fext) END IF ELSE CALL table(Stsi,lfd,lld,4,1,1,dvec,fext) END IF IF(Lfatal)RETURN END IF IF(Savtab(fext))THEN IF(Nfcst.ne.0)THEN IF(Nbcst.eq.0)THEN CALL punch(Stsi,lfd,Posfob,fext,F,F) ELSE CALL punch(Stsi,Pos1ob,Posfob,fext,F,F) END IF ELSE CALL punch(Stsi,lfd,lld,fext,F,F) END IF IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- C --- REPLACE MISSING VALUES AT EACH END DUE TO CENTERED NY-TERM MOVING C --- AVERAGE. c----------------------------------------------------------------------- CALL forcst(Sts,mfda,mlda,Posffc,Ny,1,ZERO,ONE) c----------------------------------------------------------------------- C --- DIVIDE (SUBTRACT) THE ORIGINAL SERIES BY THE SEASONAL FACTORS TO C --- GET A PRELIMINARY ESTIMATE OF THE SEASONALLY ADJUSTED SERIES. c----------------------------------------------------------------------- IF(Psuadd)THEN DO i=Pos1bk,Posffc IF(i.lt.mfda.or.i.gt.mlda)THEN IF(dpeq(Sts(i),ZERO))THEN IF(.not.Lhiddn)THEN WRITE(STDERR,1020) CALL errhdr WRITE(Mt2,1020) 1020 FORMAT(/,' ERROR: Initial seasonal factor is equal to ', & 'zero - cannot continue with', & /,' pseudo-additive seasonal adjustment.',/) END IF CALL abend RETURN ELSE Stci(i)=Stcsi(i)/Sts(i) END IF ELSE Stci(i)=Stcsi(i)-Stc(i)*(Sts(i)-ONE) END IF END DO ELSE CALL divsub(Stci,Stcsi,Sts,Pos1bk,Posffc) END IF c----------------------------------------------------------------------- C --- WRITE SEASONAL FACTORS B5,C5, AND D5. c----------------------------------------------------------------------- IF(Kfulsm.lt.2)THEN fext=LXEISF+Kpart-2 IF(Prttab(fext))CALL table(Sts,Pos1ob,Posfob,5,1,1,dvec,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Sts,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- WRITE SEASONALLY ADJUSTED SERIES B6,C6, AND D6. c----------------------------------------------------------------------- fext=LXEISA+Kpart-2 IF(Prttab(fext))CALL table(Stci,Pos1ob,Posfob,6,1,2,dvec,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Stci,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- SECTION 2 c----------------------------------------------------------------------- Ksect=2 c----------------------------------------------------------------------- C --- APPLY VARIABLE TREND-CYCLE ROUTINE TO SEASONALLY ADJUSTED SERIES. c----------------------------------------------------------------------- CALL vtc(Stc,Stci) c IF(Kexopt.eq.1.and.Kpart.eq.2)THEN c----------------------------------------------------------------------- C --- MODIFY CI VALUES BEFORE TREND-CYCLE SELECTED IF THE STRIKE OPTION C --- IS SELECTED. c----------------------------------------------------------------------- C --- DIVIDE SEASONALLY ADJUSTED SERIES BY THE TREND-CYCLE FOR AN C --- ESTIMATE OF THE IRREGULAR. c----------------------------------------------------------------------- c CALL divsub(Sti,Stci,Stc,Pos1bk,Posffc) c----------------------------------------------------------------------- C --- IDENTIFY EXTREME IRREGULAR VALUES. c----------------------------------------------------------------------- c pos1ex=Pos1bk c posfex=Posffc c IF(Noxfct)THEN c pos1ex=Pos1ob c posfex=Posfob c END IF c CALL xtrm(Sti,Pos1bk,Posffc,pos1ob,posfex) c----------------------------------------------------------------------- C --- REPLACE EXTREME VALUES. c----------------------------------------------------------------------- c CALL replac(Stci,Temp,Stwt,Pos1bk,Posfob,1) c----------------------------------------------------------------------- C --- APPLY THE VARIABLE TREND-CYCLE ROUTINE TO THE MODIFIED CI VALUES. c----------------------------------------------------------------------- c CALL vtc(Stc,Stci) c END IF c----------------------------------------------------------------------- c For multiplicative seasonal adjustment, check to see if any c of the trend values are negative. c----------------------------------------------------------------------- oktrn=T IF(Muladd.eq.0)THEN chkfct=F CALL chktrn(Stc,Kpart,7,trnchr,chkfct,oktrn) END IF c----------------------------------------------------------------------- C --- WRITE THE TREND-CYCLE B7,C7, AND D7. c----------------------------------------------------------------------- c save d7trendma in .udg file If (Ktcopt.eq.0.and.Kpart.eq.4.and.Lsumm.gt.0.and.gudrun) then WRITE(Nform,1750)Nterm 1750 FORMAT('d7trendma: ',i3) end if fext=LXEPTN+Kpart-2 IF(Prttab(fext))THEN IF(oktrn)THEN CALL table(Stc,Pos1ob,Posfob,7,1,2,dvec,fext) ELSE CALL prttrn(Stc,trnchr,Pos1ob,Posfob,7,fext) END IF END IF IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Stc,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- DIVIDE B1 BY B7,CI BY C7, AND D1 BY D7 TO OBTAIN SI RATIOS. c----------------------------------------------------------------------- CALL divsub(Stsi,Stcsi,Stc,Pos1bk,Posffc) IF(Kpart.eq.2)THEN c----------------------------------------------------------------------- C --- PART B. REPLACE EXTREME SI RATIOS (DIFFERENCES). c----------------------------------------------------------------------- pos1ex=Pos1bk posfex=Posffc IF(Noxfct)THEN pos1ex=Pos1ob posfex=Posfob END IF CALL si(Ksect,Pos1bk,Posffc,Ny,Nfcst,Nbcst,kersa1,ksdev1,Pos1ob, & Posfob,Kfulsm,pos1ex,posfex) IF(Lfatal)RETURN ELSE IF(Kpart.eq.4)THEN c----------------------------------------------------------------------- c Variable seasonal routine moved to x11pt3 to correctly adjust for c extreme with calendarsigma options (BCM, 11/98) c----------------------------------------------------------------------- RETURN ELSE c----------------------------------------------------------------------- C --- PART C. APPLY THE VARIABLE SEASONAL FACTOR ROUTINE FOR AN C --- ESTIMATE OF THE SEASONAL FACTORS. c----------------------------------------------------------------------- IF(Kfulsm.lt.2)THEN CALL vsfa(Stsi,Pos1bk,Posfob,Ny) CALL vsfb(Sts,Stsi,Pos1bk,Posffc,Ny) END IF c----------------------------------------------------------------------- C --- WRITE THE MODIFIED SI C9. c----------------------------------------------------------------------- IF(Prttab(LX11C9))THEN CALL table(Stsi,Pos1ob,Posfob,9,1,1,dvec,LX11C9) IF(Lfatal)RETURN END IF END IF c----------------------------------------------------------------------- C --- OBTAIN A PRELIMINARY SEASONALLY ADJUSTED SERIES. c----------------------------------------------------------------------- IF(Kfulsm.eq.2)THEN CALL copy(Sto,Posffc,1,Stci) ELSE IF(Psuadd)THEN DO i=Pos1bk,Posffc Stci(i)=Sto(i)-Stc(i)*(Sts(i)-ONE) END DO ELSE CALL divsub(Stci,Sto,Sts,Pos1bk,Posffc) END IF END IF c----------------------------------------------------------------------- C --- DIVIDE SEASONALLY ADJUSTED SERIES BY THE TREND CYCLE TO OBTAIN A C --- PRELIMINARY IRREGULAR SERIES. c----------------------------------------------------------------------- CALL divsub(Sti,Stci,Stc,Pos1bk,Posffc) c----------------------------------------------------------------------- C --- WRITE SEASONAL FACTORS B10 AND C10. c----------------------------------------------------------------------- IF(Kfulsm.lt.2)THEN fext=LXEB10+Kpart-2 IF(Prttab(fext))CALL table(Sts,Pos1ob,Posfob,10,1,1,dvec,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Sts,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- WRITE SEASONALLY ADJUSTED SERIES B11 AND C11. c----------------------------------------------------------------------- fext=LXEPSA+Kpart-2 IF(Prttab(fext))CALL table(Stci,Pos1ob,Posfob,11,1,2,dvec,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Stci,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- WRITE IRREGULAR SERIES B13 AND C13. c----------------------------------------------------------------------- fext=LX11PI+Kpart-2 IF(Prttab(fext))CALL table(Sti,Pos1ob,Posfob,13,1,3,Stdev,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Sti,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN IF(Ixreg.eq.1.or.Ixreg.eq.2)THEN c----------------------------------------------------------------------- C --- X-11 REGRESSION OPTION. c----------------------------------------------------------------------- C --- COMPUTE X-11 REGRESSION FACTORS IF TRADING DAY OPTION C --- SELECTED. c----------------------------------------------------------------------- c CALL traday(Tday) C **** CHANGE BY B. C. MONSELL IF(Ixreg.eq.1)CALL loadxr(F) * call profiler(2,'in x11pt2') CALL x11mdl(Sti,Muladd,Tmpma,Psuadd,Kpart,Kswv,Lgrfxr) IF(Ixreg.eq.1)THEN CALL loadxr(T) IF(Lmodel)CALL restor(Lmodel,F,F) ELSE IF(Khol.eq.0.and.Kpart.eq.3)THEN RETURN END IF IF((Holgrp.eq.0.and.Tdgrp.eq.0.and.Stdgrp.eq.0).and. & Kpart.eq.2)THEN Ixreg=0-Ixreg IF(Ixreg.eq.-2)RETURN END IF END IF c----------------------------------------------------------------------- C --- For B Iteration, do BUNDESBANK outlier test c----------------------------------------------------------------------- IF(Kpart.eq.2.and.Ksdev.lt.4)THEN CALL vtest(Sti,iv,Pos1bk,Posfob) CALL entsch(kersa1,ksdev1,Kersa,Ksdev,iv) END IF c----------------------------------------------------------------------- C --- COMPUTE WEIGHTS FOR IRREGULAR COMPONENT. c----------------------------------------------------------------------- pos1ex=Pos1bk posfex=Posffc IF(Noxfct)THEN pos1ex=Pos1ob posfex=Posfob END IF CALL xtrm(Sti,Pos1bk,Posffc,pos1ex,posfex) c----------------------------------------------------------------------- C --- WRITE WEIGHTS FOR IRREGULAR COMPONENT B17 OR C17. c----------------------------------------------------------------------- fext=LX11IW+Kpart-2 IF(Prttab(fext).AND.(Ixreg.ne.2.or.Kpart.eq.2))THEN IF(Ksdev.eq.0)THEN CALL table(Stwt,Pos1ob,Posfob,17,1,4,Stdev,fext) ELSE CALL table(Stwt,Pos1ob,Posfob,17,1,5,dvec,fext) END IF END IF IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Stwt,Pos1ob,Posfob,fext,F,F) IF(.not.Lfatal.and.Lgraf.and.Kpart.eq.3) & CALL punch(Stwt,Pos1ob,Posfob,fext,Lgraf,F) IF(Lfatal)RETURN IF(Kpart.eq.3.and.Lsumm.gt.0.and.gudrun.and.Ksdev.gt.0.and. & Ixreg.ne.2.and.Khol.ne.1)THEN DO i=1,Ny WRITE(Nform,1010)i,Stdper(i) END DO 1010 FORMAT('calendarsigma.',i2.2,': ',f10.2) END IF c----------------------------------------------------------------------- IF(Nfcst.gt.0.and.Kpart.eq.3.and.(.not.Noxfct))THEN IF(Prttab(LXEIWF).AND.Ixreg.ne.2)THEN IF(Ksdev.eq.0)THEN CALL table(Stwt,Posfob+1,Posffc,17,2,4,Stdev,LXEIWF) ELSE CALL table(Stwt,Posfob+1,Posffc,17,2,5,dvec,LXEIWF) END IF END IF IF((.not.Lfatal).and.Savtab(LXEIWF)) & CALL punch(Stwt,Posfob+1,Posffc,LXEIWF,F,F) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Print out combined trading day, calendar effect c----------------------------------------------------------------------- IF(Axrgtd.and.Kswv.eq.4)THEN fext=LXRTDC+Kpart-2 IF(Prttab(fext))CALL table(Factd,Pos1ob,Posfob,18,1,1,Dx11,fext) IF(Savtab(fext).OR.(Lgraf.and.Kpart.eq.3))THEN IF(Savfct.or.Savbct)THEN IF(Savtab(fext))CALL punch(Factd,bsav,ksav,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Factd,bsav,ksav,fext,Lgraf,F) ELSE IF(Savtab(fext))CALL punch(Factd,Pos1ob,Posfob,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Factd,Pos1ob,Posfob,fext,Lgraf,F) END IF END IF IF(Axrghl)THEN fext=LXRCLC+Kpart-2 IF(Prttab(fext)) & CALL table(Faccal,Pos1ob,Posfob,22,2,1,dvec,fext) IF(Savtab(fext).OR.(Lgraf.and.Kpart.eq.3))THEN IF(Savfct.or.Savbct)THEN IF(Savtab(fext))CALL punch(Faccal,bsav,ksav,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Faccal,bsav,ksav,fext,Lgraf,F) ELSE IF(Savtab(fext))CALL punch(Faccal,Pos1ob,Posfob,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Faccal,Pos1ob,Posfob,fext,Lgraf,F) END IF END IF END IF END IF c----------------------------------------------------------------------- c Return if X-11 regression done as prior adjustment c----------------------------------------------------------------------- IF(Lfatal.or.(Ixreg.eq.2.and.Kpart.eq.3.and.Khol.ne.1))RETURN c----------------------------------------------------------------------- C --- COMPUTE EXTREME COMPONENT. c----------------------------------------------------------------------- IF(Muladd.gt.0)THEN c----------------------------------------------------------------------- C --- ADDITIVE AND LOGARITHMIC MODEL. c----------------------------------------------------------------------- DO i=Pos1bk,Posffc Stex(i)=Sti(i)*(ONE-Stwt(i)) END DO ELSE c----------------------------------------------------------------------- C --- MULTIPLICATIVE MODEL. c----------------------------------------------------------------------- DO i=Pos1bk,Posffc Stex(i)=Sti(i)/(ONE+Stwt(i)*(Sti(i)-ONE)) END DO END IF c----------------------------------------------------------------------- c IF((Axrgtd.or.Axrghl).and.Ixreg.eq.1)THEN IF((Axrgtd.or.Axrghl).AND.(Ixreg.eq.1.or.Ixreg.eq.2))THEN c----------------------------------------------------------------------- C --- SET STCSI EQUAL TO THE RAW SERIES. c----------------------------------------------------------------------- CALL copy(Series(Pos1bk),Posffc-Pos1bk+1,1,Stcsi(Pos1bk)) IF(Adjls.eq.1)CALL divsub(Stcsi,Stcsi,Facls,Pos1bk,Posffc) IF(Adjao.eq.1)CALL divsub(Stcsi,Stcsi,Facao,Pos1bk,Posffc) IF(Adjtc.eq.1)CALL divsub(Stcsi,Stcsi,Factc,Pos1bk,Posffc) IF(Adjso.eq.1)CALL divsub(Stcsi,Stcsi,Facso,Pos1bk,Posffc) IF(Adjsea.eq.1)CALL divsub(Stcsi,Stcsi,Facsea,Pos1bk,Posffc) * IF(Adjpls.eq.1)CALL divsub(Stcsi,Stcsi,Facpls,Pos1bk,Posffc) * IF(Adjplt.eq.1)CALL divsub(Stcsi,Stcsi,Facplt,Pos1bk,Posffc) * IF(Adjplo.eq.1)CALL divsub(Stcsi,Stcsi,Facplo,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL divsub(Stcsi,Stcsi,Facusr,Pos1bk,Posffc) IF(Muladd.eq.2)Muladd=0 c----------------------------------------------------------------------- C --- DIVIDE (SUBTRACT) BY THE PRIOR ADJUSTMENT SERIES. c----------------------------------------------------------------------- IF(Kfmt.gt.0)CALL divsub(Stcsi,Stcsi,Sprior,Pos1ob,Posfob) c IF(Adjhol.eq.1.or.Khol.gt.1.or.Axrghl)THEN c IF(Axrghl.AND.((Khol.eq.1.and.Ixreg.eq.2).OR.Ixreg.eq.1))THEN c CALL divsub(Stcsi,Stcsi,Facxhl,Pos1ob,Posfob) c ELSE c CALL divsub(Stcsi,Stcsi,Fachol,Pos1ob,Posfob) c END IF c END IF c----------------------------------------------------------------------- C --- DIVIDE (SUBTRACT) THE PRIOR MONTHLY ADJUSTED SERIES A3 OR A1 BY C --- THE COMBINED TRADING DAY FACTORS TO OBTAIN THE CALENDAR ADJUSTED C --- SERIES. c----------------------------------------------------------------------- IF(Adjtd.eq.1.or.Axrgtd.or.Adjhol.eq.1.or.Khol.gt.1.or.Axrghl & .or.Kswv.gt.0)THEN IF(Psuadd)THEN DO i=Pos1bk,Posffc IF(Kfulsm.lt.2)THEN Stcsi(i)=Stc(i)*(Sts(i)+Sti(i)/Faccal(i)-ONE) ELSE Stcsi(i)=Stc(i)*(Sti(i)/Faccal(i)) END IF END DO ELSE CALL divsub(Stcsi,Stcsi,Faccal,Pos1bk,Posffc) END IF END IF IF(Tmpma.eq.2)THEN Muladd=2 CALL logar(Stcsi,Pos1bk,Posffc) END IF c----------------------------------------------------------------------- C --- WRITE THE ORIGINAL SERIES ADJUSTED FOR CALENDAR VARIATION B19 OR C --- C19. c----------------------------------------------------------------------- fext=LXETDO+Kpart-2 IF(Prttab(fext))CALL table(Stcsi,Pos1ob,Posfob,19,1,2,dvec,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Stcsi,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN ELSE c----------------------------------------------------------------------- C --- SET STCSI EQUAL TO STO. c----------------------------------------------------------------------- DO i=Pos1bk,Posffc Stcsi(i)=Sto(i) END DO END IF IF(Kpart.eq.3.and.Ixreg.eq.1) & CALL divsub(Stocal,Series,Faccal,Pos1ob,Posfob) c----------------------------------------------------------------------- C --- MODIFY THE ORIGINAL SERIES ADJUSTED FOR CALENDAR VARIATION TO C --- ELIMINATE THE EXTREMES. c----------------------------------------------------------------------- IF(Psuadd)THEN DO i=Pos1bk,Posffc IF(Kfulsm.eq.2)THEN Stcsi(i)=Stc(i)*(Sti(i)/Stex(i)) ELSE Stcsi(i)=Stc(i)*(Sts(i)+((Sti(i)/Stex(i))-ONE)) END IF END DO ELSE CALL divsub(Stcsi,Stcsi,Stex,Pos1bk,Posffc) END IF c----------------------------------------------------------------------- C --- WRITE EXTREME SERIES B20 AND C20. c----------------------------------------------------------------------- fext=LX11EV+Kpart-2 IF(Prttab(fext))CALL table(Stex,Pos1ob,Posfob,20,1,3,dvec,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Stex,Pos1ob,Posfob,fext,F,F) IF(Lgraf.and.Kpart.eq.3) & CALL punch(Stex,Pos1ob,Posfob,fext,Lgraf,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- INCREASE ITERATION STEP BY 1. c----------------------------------------------------------------------- Kpart=Kpart+1 Ksect=1 c----------------------------------------------------------------------- C --- WRITE THE MODIFIED ORIGINAL SERIES C1 OR D1. c----------------------------------------------------------------------- fext=LX11MO+Kpart-3 IF(Prttab(fext))CALL table(Stcsi,Pos1ob,Posfob,1,1,2,dvec,fext) IF(.not.Lfatal.and.Savtab(fext)) & CALL punch(Stcsi,Pos1ob,Posfob,fext,F,F) IF(Lfatal)RETURN END DO c----------------------------------------------------------------------- END x11pt3.f0000664006604000003110000015764314521201626011417 0ustar sun00315stepsc Last change:10,2021, pass additional parameter because there is a c new argument trendtc in regression C previous change: BCM 15 Apr 2005 12:40 pm SUBROUTINE x11pt3(Lgraf,Lttc) IMPLICIT NONE c----------------------------------------------------------------------- LOGICAL F,T DOUBLE PRECISION ONE,ZERO,PT5 PARAMETER(F=.false.,T=.true.,ONE=1D0,ZERO=0D0,PT5=0.5D0) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'agr.cmn' INCLUDE 'error.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'adj.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11log.cmn' INCLUDE 'frctbl.i' INCLUDE 'x11tbl.i' INCLUDE 'revtbl.i' INCLUDE 'xrgum.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'units.cmn' INCLUDE 'xtrm.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'adxser.cmn' INCLUDE 'force.cmn' INCLUDE 'goodob.cmn' INCLUDE 'rev.prm' INCLUDE 'rev.cmn' c----------------------------------------------------------------------- CHARACTER trnchr*1 LOGICAL Lgraf,Lttc,rndok,oktrn,oktrf,gudrun,chkfct,negmsg,negfin DOUBLE PRECISION Ckhs,ebar,stsx11,stbase,Stex,Stime,Stsie,ststd, & Temp,biasfc,stsb,tempk,sti2,dvec,Stmcd,sp2, & stcipc,stc2pc,frcfac,rbak,lbak,temp2 INTEGER i,i2,ib,ie,ifac,k2,klda,nadj2,lastsf,iadj1,lstfrc,frstsf, & idate DIMENSION ststd(PLEN),biasfc(PLEN),Temp(PLEN),stbase(PLEN), & Stsie(PLEN),Stime(PLEN),sp2(PLEN),Stex(PLEN),Ckhs(PLEN), & dvec(1),sti2(PLEN),stsb(PLEN),stsx11(PLEN), & Stmcd(PLEN),trnchr(PLEN),stcipc(PLEN),stc2pc(PLEN), & frcfac(PLEN),temp2(PLEN),idate(2) c----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq c----------------------------------------------------------------------- COMMON /work / Temp COMMON /work3 / Stsie COMMON /mq5a / Stmcd,Stime COMMON /mq10 / Stex COMMON /kcser / Ckhs c ------------------------------------------------------------------ ifac=1 IF(Muladd.eq.1)ifac=0 nadj2=0 IF(Kfmt.gt.0)nadj2=Nadj CALL copy(Sprior,PLEN,1,sp2) Nfcst=Posffc-Posfob oktrn=T oktrf=T chkfct=Nfcst.gt.0.and.Prttab(LXETRF) gudrun=Issap.lt.2.and.Irev.lt.4.and.(Khol.ne.1) c ------------------------------------------------------------------ C --- APPLY THE VARIABLE SEASONAL FACTOR ROUTINE FOR AN C --- ESTIMATE OF THE SEASONAL FACTORS, USING MSR TO SELECT A SEASONAL C --- FILTER FOR D10. c----------------------------------------------------------------------- c This implements the MSR seasonal filter selection option from c X-11-ARIMA/88, developed at Statistics Canada. c ------------------------------------------------------------------ c Moved from x11pt2 by BCM, 11/98, to correctly adjust for extreme c with calendarsigma options c ------------------------------------------------------------------ IF(Kfulsm.lt.2.and.Ksdev.le.1) & CALL sfmsr(Sts,Stsi,Pos1bk,Posfob,Posffc,Prttab(LXEASF), & (Lsumm.gt.0.and.Irev.ne.4).or.Savtab(LXEASF)) c ------------------------------------------------------------------ C --- MULTIPLY (ADD) STSI BY STEX TO GET THE UNMODIFIED SI. c ------------------------------------------------------------------ CALL addmul(Stsie,Stsi,Stex,Pos1bk,Posffc) c ------------------------------------------------------------------ C --- WRITE UNMODIFIED SI RATIOS (DIFFERENCES) D8. c ------------------------------------------------------------------ lastsf=Posfob IF(Lgraf.or.Savtab(LX11D8))THEN IF(Savfct.and.Nfcst.gt.0)lastsf=Posffc END IF IF(Prttab(LX11D8)) & CALL table(Stsie,Pos1ob,Posfob,8,1,1,dvec,LX11D8) IF((.not.Lfatal).and.Savtab(LX11D8)) & CALL punch(Stsie,Pos1ob,lastsf,LX11D8,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Stsie,Pos1ob,lastsf,LX11D8,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ C --- PERFORM ANALYSIS OF VARIANCE ON THE UNMODIFIED SI RATIOS. c ------------------------------------------------------------------ IF((.not.Lhiddn).and.Khol.ne.1)THEN IF(Prttab(LXED8F))THEN CALL table(Stsie,0,0,8,2,0,dvec,LXED8F) IF(Lfatal)RETURN END IF CALL ftest(Stsie,Pos1ob,Posfob,Ny,0,Prttab(LXED8F),F) CALL kwtest(Stsie,Pos1bk,Posfob,Ny,Prttab(LXED8F)) CALL addmul(Stsie,Stsi,Stex,Pos1bk,Posffc) c ------------------------------------------------------------------ C --- PERFORM F-TEST FOR MOVING SEASONALITY. c ------------------------------------------------------------------ CALL mstest(Stsie,Pos1bk,Posfob,Ny,Prttab(LXED8F)) c ------------------------------------------------------------------ C --- PERFORM TEST FOR THE PRESENCE OF IDENTIFIABLE SEASONALITY. c ------------------------------------------------------------------ CALL COMBFT(Prttab(LXED8F)) ELSE IF (Issap.EQ.2) THEN CALL FTEST(Stsie,Pos1ob,Posfob,Ny,0,F,F) CALL KWTEST(Stsie,Pos1bk,Posfob,Ny,F) CALL ADDMUL(Stsie,Stsi,Stex,Pos1bk,Posffc) CALL MSTEST(Stsie,Pos1bk,Posfob,Ny,F) CALL COMBFT(F) END IF ebar=ZERO IF(Muladd.eq.0)ebar=ONE c ------------------------------------------------------------------ IF(Ksdev.gt.1)THEN CALL copy(Stsie,Posfob,1,Stsi) CALL replac(Stsi,Temp,Stwt,Pos1bk,Posfob,Ny) IF(Kfulsm.lt.2) & CALL sfmsr(Sts,Stsi,Pos1bk,Posfob,Posffc,Prttab(LXEASF), & (Lsumm.gt.0.and.Irev.ne.4).or.Savtab(LXEASF)) END IF c ------------------------------------------------------------------ C --- WRITE UNMODIFIED SI RATIOS (DIFFERENCES) with extreme value labels c D8B. (added by BCM, Jan 2000, revised to add save file May 2000) c ------------------------------------------------------------------ IF(Prttab(LXED8B).or.Savtab(LXED8B).or.(Lsumm.gt.0.and.gudrun)) & CALL prtd8b(Stsie,Stwt,Pos1ob,Posfob,LXED8B,Prttab(LXED8B), & Savtab(LXED8B),Lgraf) c ------------------------------------------------------------------ C --- IDENTIFY SI RATIOS (DIFFERENCES) WHICH ARE MODIFIED. c ------------------------------------------------------------------ DO i=Pos1bk,Posffc IF(.not.dpeq(Stex(i),ebar))THEN Temp(i)=Stsi(i) ELSE Temp(i)=DNOTST END IF stc2(i)=ebar END DO c ------------------------------------------------------------------ C --- WRITE FINAL REPLACEMENT VALUES FOR EXTREME SI RATIOS (DIFFERENCES) C --- D9. c ------------------------------------------------------------------ IF(Savtab(LX11D9))THEN IF(Savfct.and.Nfcst.gt.0)lastsf=Posffc END IF IF(Prttab(LX11D9))CALL table(Temp,Pos1ob,Posfob,9,1,5,dvec,LX11D9) IF((.not.Lfatal).and.Savtab(LX11D9)) & CALL punch(Temp,Pos1ob,lastsf,LX11D9,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Temp,Pos1ob,lastsf,LX11D9,Lgraf,F) IF(Lfatal)RETURN IF(Khol.ne.1.and.Kfulsm.lt.2)THEN IF(Prttab(LXED9A))THEN CALL table(Temp,0,0,9,2,5,dvec,LXED9A) IF(Lfatal)RETURN END IF IF(Lsumm.gt.0.or.Prttab(LXED9A))THEN CALL prtd9a(Prttab(LXED9A)) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ C --- COMPUTE YEAR AHEAD SEASONAL FACTORS. c ------------------------------------------------------------------ klda=Posffc+Ny IF(Kfulsm.lt.2)CALL forcst(Sts,0,Posffc,klda,Ny,1,PT5,ONE) c ------------------------------------------------------------------ C --- DIVIDE (SUBTRACT) D1 BY THE FINAL SEASONAL FACTORS TO OBTAIN A C --- MODIFIED SEASONALLY ADJUSTED SERIES. c ------------------------------------------------------------------ IF(Savtab(LXED10).or.Savtab(LXEPSF).or.Savtab(LXEARS).or. & Lgraf)THEN IF(.not.Savfct)THEN lastsf=Posfob ELSE IF(Nfcst.gt.0)THEN lastsf=Posffc ELSE lastsf=Posfob+Ny END IF frstsf=Pos1ob IF(Savbct)frstsf=Pos1bk END IF IF(Kfulsm.eq.2)THEN CALL copy(Stcsi,Posffc,1,Stci) CALL setdp(ebar,klda,Sts) c ------------------------------------------------------------------ c If adjustment for regARIMA seasonal performed, combine with X-11 c seasonal here (except in psuedo additive case). c ------------------------------------------------------------------ IF((Adjsea.eq.1.or.Adjso.eq.1).or.Savtab(LXEARS))THEN CALL copy(Sts,Posffc,1,stsx11) IF(Adjsea.eq.1)CALL addmul(Sts,Facsea,Sts,Pos1bk,Posffc) IF(Adjso.eq.1)CALL addmul(Sts,Facso,Sts,Pos1bk,Posffc) c ------------------------------------------------------------------ c center the combined seasonal effec, if requested by the user c BCM June 2003 c ------------------------------------------------------------------ IF(Lcentr)CALL vsfc(Sts,Pos1bk,Posffc,Ny,Lter) END IF c ------------------------------------------------------------------ IF(Savtab(LXED10)) & CALL punch(Sts,frstsf,lastsf,LXED10,F,F) IF(Savtab(LXEPSF)) & CALL punch(Sts,frstsf,lastsf,LXEPSF,F,Muladd.ne.1) IF((.not.Lfatal).and.Lgraf) & CALL punch(Sts,frstsf,lastsf,LXED10,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Else, print out the pure X-11 seasonal factors if the regARIMA c seasonal component is used. c ------------------------------------------------------------------ IF((Adjsea.eq.1.or.Adjso.eq.1).and.Savtab(LXEARS))THEN IF(Savtab(LXEARS)) & CALL punch(stsx11,frstsf,lastsf,LXEARS,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(stsx11,frstsf,lastsf,LXEARS,Lgraf,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ ELSE IF(Psuadd)THEN DO i=Pos1bk,Posffc Stci(i)=Stcsi(i)-Stc(i)*(Sts(i)-ONE) IF(Gudval(i).and.Stci(i).le.ZERO)Gudval(i)=F END DO ELSE CALL divsub(Stci,Stcsi,Sts,Pos1bk,Posffc) IF(Muladd.eq.2)THEN Muladd=0 c ------------------------------------------------------------------ C --- IF LOGARITHMIC MODEL SELECTED TAKE THE ANTILOG OF THE SEASONAL C --- FACTORS. c ------------------------------------------------------------------ CALL antilg(Sts,Pos1bk,klda) CALL antilg(Stsi,Pos1bk,Posffc) CALL antilg(Stsie,Pos1bk,Posffc) c ------------------------------------------------------------------ c set up Stex and Stcsi for the spectral routines - July 2006 BCM c ------------------------------------------------------------------ CALL divsub(Stex,Stsie,Stsi,Pos1bk,Posffc) CALL antilg(Stcsi,Pos1bk,Posffc) END IF END IF c ------------------------------------------------------------------ c If adjustment for regARIMA seasonal performed, combine with X-11 c seasonal here (except in psuedo additive case). c ------------------------------------------------------------------ IF((Adjsea.eq.1.or.Adjso.eq.1).and.(.not.Psuadd))THEN CALL copy(Sts,Posffc,1,stsx11) IF(Adjsea.eq.1)CALL addmul(Sts,Facsea,Sts,Pos1bk,Posffc) IF(Adjso.eq.1)CALL addmul(Sts,Facso,Sts,Pos1bk,Posffc) c ------------------------------------------------------------------ c center the combined seasonal effec, if requested by the user c BCM June 2003 c ------------------------------------------------------------------ IF(Lcentr)CALL vsfc(Sts,Pos1bk,Posffc,Ny,Lter) END IF c ------------------------------------------------------------------ IF(Ishrnk.gt.0)THEN IF(.not.(Adjsea.eq.1.and.(.not.Psuadd))) & CALL copy(Sts,Posffc,1,stsx11) CALL shrink(Stsi,Sts,Mtype,Ishrnk,Muladd,Ny) END IF c ------------------------------------------------------------------ C --- WRITE THE FINAL SEASONAL FACTORS D10. c ------------------------------------------------------------------ IF(Prttab(LXED10).or.Prttab(LXEPSF)) & CALL table(Sts,Pos1ob,Posfob,10,1,1,dvec,LXED10) IF((.not.Lfatal).and.Savtab(LXED10)) & CALL punch(Sts,frstsf,lastsf,LXED10,F,F) IF((.not.Lfatal).and.Savtab(LXEPSF)) & CALL punch(Sts,frstsf,lastsf,LXEPSF,F,Muladd.ne.1) IF((.not.Lfatal).and.Lgraf) & CALL punch(Sts,frstsf,lastsf,LXED10,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ c Graph the final seasonal factors c ------------------------------------------------------------------ IF(Prttab(LXESFP).and.Khol.ne.1)THEN CALL x11plt(Sts,Sts,Pos1ob,Posfob+Ny,LXESFP,0,ifac,7,1) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c If revisions history or sliding spans analysis are done, store c the seasonal factors. c ------------------------------------------------------------------ IF(Issap.eq.2)CALL ssrit(Sts,Pos1ob,Posfob,2,Series) IF(Irev.eq.4.and.Lrvsf)THEN CALL getrev(Sts,Posfob,Muladd,0,Ny,Iag,Iagr) c ------------------------------------------------------------------ c BCM - July 29, 2009 c Special code to save seasonal factor forecasts for concurrent c adjustments. c ------------------------------------------------------------------ IF(Revptr.gt.0.and.Savtab(LRVSSH))THEN CALL addate(Rvstrt,Ny,Revptr,idate) WRITE(Fhsfh,1120)idate DO i=Posfob+1,Posffc WRITE(Fhsfh,1130)Sts(i) END DO 1120 FORMAT(2i5) 1130 FORMAT(1x,e21.14) END IF IF(.not.(Lrvsa.or.Lrvch.or.Lrvtrn.or.Lrvtch))RETURN END IF IF((Prttab(LXEARS).or.Savtab(LXEARS).or.Lgraf).and. & (Adjsea.eq.1.or.Adjso.eq.1))THEN c ------------------------------------------------------------------ c Else, print out the pure X-11 seasonal factors if the regARIMA c seasonal component is used. c ------------------------------------------------------------------ IF(Prttab(LXEARS)) & CALL table(stsx11,Pos1ob,Posfob,10,1,1,dvec,LXEARS) IF((.not.Lfatal).and.Savtab(LXEARS)) & CALL punch(stsx11,frstsf,lastsf,LXEARS,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(stsx11,frstsf,lastsf,LXEARS,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ c If psuedo-additive seasonal adjustment is done, generate and print c out the final seasonal differences (Table D 10b). c ------------------------------------------------------------------ ELSE IF(Psuadd)THEN DO i=Pos1bk,Posffc stsb(i)=Stc(i)*(Sts(i)-ONE) END DO IF(Prttab(LXEFSD)) & CALL table(stsb,Pos1ob,Posfob,10,2,1,dvec,LXEFSD) IF((.not.Lfatal).and.Savtab(LXEFSD))THEN frstsf=Pos1ob IF(Savbct)frstsf=Pos1bk lastsf=Posfob IF(Savfct)lastsf=Posffc CALL punch(stsb,frstsf,lastsf,LXEFSD,F,F) END IF IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(Ishrnk.gt.0.and.(Prttab(LXESNS).or.Savtab(LXESNS)))THEN IF(Prttab(LXESNS))THEN Ishrnk=2-Ishrnk CALL table(stsx11,Pos1ob,Posfob,10,1,1,dvec,LXESNS) Ishrnk=2+Ishrnk IF(Lfatal)RETURN END IF IF(Savtab(LXESNS))CALL punch(stsx11,frstsf,lastsf,LXESNS,F,F) IF(.not.Lfatal.and.Lgraf) & CALL punch(stsx11,frstsf,lastsf,LXESNS,Lgraf,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ Muladd=Tmpma END IF c ------------------------------------------------------------------ CALL copy(Stci(Pos1bk),Nbfpob,1,Ckhs(Pos1bk)) c DO i=Pos1bk,Posffc c Ckhs(i)=Stci(i) c END DO klda=Posfob+Ny IF(Nfcst.gt.0)klda=Posfob+Nfcst k2=klda-Pos1bk+1 c ------------------------------------------------------------------ c If length of month/quarter regressor is removed from series, c put mean of effect back into trend c ------------------------------------------------------------------ c IF(Nln.gt.0)THEN c DO i=Pos1bk,Posffc c i2=Frstat+i-Pos1bk c IF(Muladd.eq.1)THEN c stc2(i)=stc2(i)+LnMean c ELSE c stc2(i)=stc2(i)*LnMean c END IF c END DO c END IF IF(Kfulsm.eq.0.or.Kfulsm.eq.2)THEN c ------------------------------------------------------------------ C --- FULL ADJUSTMENT OR TREND ESTIMATION VERSION ONLY. APPLY THE C --- VARIABLE TREND CYCLE TO THE MODIFIED SEASONALLY ADJUSTED SERIES C --- TO OBTAIN THE FINAL TREND CYCLE. c ------------------------------------------------------------------ CALL vtc(Stc,Stci) IF(Ktcopt.eq.0.and.Lsumm.gt.0.and.gudrun)THEN WRITE(Nform,1010)Nterm 1010 FORMAT('finaltrendma: ',i3) END IF IF(Muladd.eq.2)THEN c ------------------------------------------------------------------ C --- IF THE LOGARITHMIC MODEL WAS SELECTED TAKE THE ANTILOG OF THE C --- COMPONENTS. c ------------------------------------------------------------------ CALL antilg(Stc,Pos1bk,Posffc) c ------------------------------------------------------------------ c --- correct for bias in the trend component c ------------------------------------------------------------------ CALL trbias(Stc,Sts,Sti,Pos1bk,Posffc,biasfc,Ny) ebar=ONE Muladd=0 END IF c----------------------------------------------------------------------- c For multiplicative seasonal adjustment, check to see if any c of the trend values are negative. c----------------------------------------------------------------------- IF(Muladd.eq.0)THEN CALL chktrn(Stc,Kpart,12,trnchr,chkfct,oktrn) IF(chkfct)THEN i=Posfob DO WHILE(oktrf.and.i.le.Posffc) IF(oktrf.and.trnchr(i).eq.'*')oktrf=F i=i+1 END DO END IF END IF c ------------------------------------------------------------------ IF(Adjls.eq.1)CALL addmul(sp2,Facls,sp2,Pos1bk,Posffc) IF(Adjao.eq.1)CALL addmul(sp2,Facao,sp2,Pos1bk,Posffc) IF(Adjtc.eq.1)CALL addmul(sp2,Factc,sp2,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL addmul(sp2,Facusr,sp2,Pos1bk,Posffc) c ------------------------------------------------------------------ C --- DIVIDE (SUBTRACT) THE ORIGINAL SERIES BY THE SEASONAL AND TRADING C --- DAY FACTORS TO OBTAIN THE FINAL SEASONALLY ADJUSTED SERIES. c ------------------------------------------------------------------ IF(Kfulsm.eq.2)THEN CALL copy(Series,Posffc,1,Stci) ELSE IF(Psuadd)THEN DO i=Pos1bk,Posffc Stci(i)=Series(i)-Stc(i)*(Sts(i)-ONE) IF(Gudval(i).and.Stci(i).le.ZERO)Gudval(i)=F END DO ELSE CALL divsub(Stci,Series,Sts,Pos1bk,Posffc) END IF END IF c ------------------------------------------------------------------ C --- SET THE COMBINED FACTORS EQUAL TO THE SEASONAL FACTORS AND IF C --- TRADING DAY IS REQUESTED MULTIPLY BY THE TRADING-DAY FACTORS. c ------------------------------------------------------------------ IF(Kfulsm.eq.2)THEN CALL setdp(ebar,klda,ststd) ELSE CALL copy(Sts(Pos1bk),k2,1,ststd(Pos1bk)) END IF ELSE c ------------------------------------------------------------------ C --- SUMMARY MEASURES VERSION ONLY. REPLACE THE FINAL SEASONALLY C --- ADJUSTED SERIES WITH D1. c ------------------------------------------------------------------ CALL copy(Stcsi(Pos1bk),Nbfpob,1,Stci(Pos1bk)) c ------------------------------------------------------------------ C --- APPLY THE VARIABLE TREND CYCLE ROUTINE TO D1. c ------------------------------------------------------------------ CALL vtc(Stc,Stci) IF(Muladd.eq.2)THEN c ------------------------------------------------------------------ C --- IF THE LOGARITHMIC OPTION WAS SELECTED, TAKE THE ANTILOG C --- OF THE COMPONENTS. c ------------------------------------------------------------------ CALL antilg(Stc,Pos1bk,Posffc) c ------------------------------------------------------------------ c --- correct for bias in the trend component c ------------------------------------------------------------------ CALL trbias(Stc,Sts,Sti,Pos1bk,Posffc,biasfc,Ny) ebar=ONE Muladd=0 END IF c----------------------------------------------------------------------- c For multiplicative seasonal adjustment, check to see if any c of the trend values are negative. c----------------------------------------------------------------------- IF(Muladd.eq.0)THEN CALL chktrn(Stc,Kpart,12,trnchr,chkfct,oktrn) IF(chkfct)THEN i=Posfob DO WHILE(oktrf.and.i.le.Posffc) IF(oktrf.and.trnchr(i).eq.'*')oktrf=F i=i+1 END DO END IF END IF c ------------------------------------------------------------------ C --- CHANGE BY BRIAN C. MONSELL 11-1-88, MODIFIED 11-7-89 c ------------------------------------------------------------------ IF(Adjls.eq.1)CALL addmul(sp2,Facls,sp2,Pos1bk,Posffc) IF(Adjao.eq.1)CALL addmul(sp2,Facao,sp2,Pos1bk,Posffc) IF(Adjtc.eq.1)CALL addmul(sp2,Factc,sp2,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL addmul(sp2,Facusr,sp2,Pos1bk,Posffc) c ------------------------------------------------------------------ C --- END OF CHANGE C --- REPLACE THE FINAL SEASONALLY ADJUSTED SERIES WITH A1. c ------------------------------------------------------------------ CALL copy(Series(Pos1bk),Nbfpob,1,Ckhs(Pos1bk)) CALL copy(Series(Pos1bk),Nbfpob,1,Stci(Pos1bk)) c ------------------------------------------------------------------ C --- SET THE COMBINED FACTORS EQUAL TO THE SEASONAL FACTORS AND IF C --- TRADING DAY IS REQUESTED MULTIPLY BY THE TRADING-DAY FACTORS. c ------------------------------------------------------------------ CALL copy(Sts(Pos1bk),k2,1,ststd(Pos1bk)) END IF c ------------------------------------------------------------------ IF(.not.Finhol.and.(Khol.eq.2.or.(Ixreg.gt.0.and.Axrghl).or. & Adjhol.eq.1))THEN IF(Haveum)THEN IF(Muladd.eq.1)THEN CALL setdp(ZERO,PLEN,Faccal) ELSE CALL setdp(ONE,PLEN,Faccal) END IF IF(Adjtd.eq.1)THEN CALL addmul(Faccal,Faccal,Factd,Pos1bk,klda) ELSE IF(Kswv.gt.0)THEN CALL addmul(Faccal,Faccal,Stptd,Pos1bk,klda) END IF ELSE CALL divsub(Faccal,Faccal,Fachol,Pos1bk,klda) END IF END IF c ------------------------------------------------------------------ C **** CHANGES TO INCORPORATE NEW ARIMA ESTIMATION ROUTINES c ------------------------------------------------------------------ IF((Adjtd.eq.1.or.(Ixreg.gt.0.and.Axrgtd)).or.(Finhol.and. & (Ixreg.gt.0.and.Axrghl).or.Adjhol.eq.1).or.Kswv.gt.0)THEN IF(Kfulsm.eq.0.or.Kfulsm.eq.2) & CALL divsub(Stci,Stci,Faccal,Pos1bk,Posffc) CALL addmul(ststd,ststd,Faccal,Pos1bk,klda) END IF c ------------------------------------------------------------------ C If prior length of month or leap year adjustments are performed c with no trading day, include prior factors into combined c adjustment factor. c ------------------------------------------------------------------ IF((Adjtd.eq.0.or.Kswv.eq.0).and.Priadj.gt.1)THEN CALL dfdate(Begbak,Begadj,Ny,iadj1) iadj1=iadj1+1 DO i=Pos1bk,klda IF(Muladd.eq.1)THEN ststd(i)=ststd(i)+Adj(i+iadj1-1) ELSE ststd(i)=ststd(i)*Adj(i+iadj1-1) END IF END DO END IF c ------------------------------------------------------------------ IF(Nuspad.gt.0.or.Priadj.gt.1) & CALL rmpadj(Stci,Sprior,Pos1bk,Posffc,Muladd) c ------------------------------------------------------------------ C --- DIVIDE (SUBTRACT) THE FINAL SEASONALLY ADJUSTED SERIES BY THE C --- FINAL TREND-CYCLE TO OBTAIN THE FINAL IRREGULAR. c ------------------------------------------------------------------ CALL divsub(Sti,Stci,Stc,Pos1bk,Posffc) IF(Finao.and.Nao.gt.0)CALL divsub(Stci,Stci,Facao,Pos1bk,Posffc) IF(Finls.and.Nls.gt.0)CALL divsub(Stci,Stci,Facls,Pos1bk,Posffc) IF(Fintc.and.Ntc.gt.0)CALL divsub(Stci,Stci,Factc,Pos1bk,Posffc) IF(Finusr)CALL divsub(Stci,Stci,Facusr,Pos1bk,Posffc) c ------------------------------------------------------------------ IF(Adjls.eq.1.and.Nls.gt.0) & CALL divsub(Sti,Sti,Facls,Pos1bk,Posffc) IF(Adjao.eq.1.and.Nao.gt.0) & CALL divsub(Sti,Sti,Facao,Pos1bk,Posffc) IF(Adjtc.eq.1.and.Ntc.gt.0) & CALL divsub(Sti,Sti,Factc,Pos1bk,Posffc) IF(Adjusr.eq.1) & CALL divsub(Sti,Sti,Facusr,Pos1bk,Posffc) c ------------------------------------------------------------------ C --- IF PRIOR ADJUSTMENT REQUESTED REMOVE IT FROM THE IRREGULAR. c ------------------------------------------------------------------ IF(Nustad.gt.0)THEN c IF(Nustad.gt.0) c & CALL rmtadj(Sti,Sprior,Pos1bk,Posffc,Muladd) c CALL divsub(Sti,Sti,Sprior,Pos1ob,Posfob) DO i=Pos1bk,Posffc i2=Frstat+i-Pos1bk IF(Muladd.eq.1)THEN Sti(i)=Sti(i)-Usrtad(i2) ELSE Sti(i)=Sti(i)/Usrtad(i2) END IF END DO END IF c IF(Khol.eq.1)RETURN c ------------------------------------------------------------------ C --- WRITE THE FINAL SEASONALLY ADJUSTED SERIES D11. c ------------------------------------------------------------------ negmsg=F IF(dpeq(Cnstnt,DNOTST))THEN IF(Prttab(LXED11)) & CALL table(Stci,Pos1ob,Posfob,11,1,2,dvec,LXED11) IF((.not.Lfatal).and.Savtab(LXED11)) & CALL punch(Stci,Pos1ob,Posfob,LXED11,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Stci,Pos1ob,Posfob,LXED11,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ C --- DO TEST FOR RESIDUAL SEASONALITY. c ------------------------------------------------------------------ CALL ftest(Stci,Pos1ob,Posfob,Ny,1,Prttab(LXERSF),Savtab(LXERSF)) ELSE c ------------------------------------------------------------------ C --- remove constant from seasonally adjusted series and original c series. c (added by BCM July 2005) c ------------------------------------------------------------------ CALL copy(Stci,Posffc,-1,Stcipc) DO i=Pos1ob,Posffc Stci(i)=Stci(i)-Cnstnt Series(i)=Series(i)-Cnstnt IF((.not.(Stci(i).gt.ZERO)).and.Muladd.ne.1)THEN IF(.not.negmsg)negmsg=T IF(Iyrt.gt.0)Stci(i)=ZERO END IF END DO c ------------------------------------------------------------------ C --- WRITE THE FINAL SEASONALLY ADJUSTED SERIES D11 without the c constant. c ------------------------------------------------------------------ IF(Prttab(LXED11)) & CALL table(Stci,Pos1ob,Posfob,11,1,2,dvec,LXED11) IF((.not.Lfatal).and.Savtab(LXED11)) & CALL punch(Stci,Pos1ob,Posfob,LXED11,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Stci,Pos1ob,Posfob,LXED11,Lgraf,F) c ------------------------------------------------------------------ IF(negmsg.and.gudrun)THEN CALL writln('NOTE: Negative values were created in the seasonall &y adjusted series when ',Mt1,Mt2,T) CALL writln(' removing the temporary constant.',Mt1,Mt2,F) IF(Iyrt.gt.0)THEN CALL writln(' Negative values in the seasonally adjusted s &eries were replaced by ',Mt1,Mt2,T) CALL writln(' zero before forcing annual totals.',Mt1,Mt2, & F) END IF END IF c ------------------------------------------------------------------ C --- DO TEST FOR RESIDUAL SEASONALITY. c ------------------------------------------------------------------ CALL ftest(Stci,Pos1ob,Posfob,Ny,1,Prttab(LXERSF),Savtab(LXERSF)) c ------------------------------------------------------------------ C --- WRITE THE FINAL SEASONALLY ADJUSTED SERIES D11 including the c constant. c ------------------------------------------------------------------ IF(Prttab(LXESAC)) & CALL table(Stcipc,Pos1ob,Posfob,11,3,2,dvec,LXESAC) IF((.not.Lfatal).and.Savtab(LXESAC)) & CALL punch(Stcipc,Pos1ob,Posfob,LXESAC,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Stcipc,Pos1ob,Posfob,LXESAC,Lgraf,F) END IF c ------------------------------------------------------------------ c Store value of seasonally adjusted series for sliding spans c analysis. c ------------------------------------------------------------------ IF(Issap.eq.2.and.Iyrt.eq.0.and.(.not.Lrndsa))THEN CALL ssrit(Stci,Pos1ob,Posfob,3,Series) RETURN END IF c ------------------------------------------------------------------ c Store value of seasonally adjusted series for revisions analysis. c ------------------------------------------------------------------ IF(Irev.eq.4.and.(Lrvsa.or.Lrvch).and.Iyrt.eq.0)THEN CALL getrev(Stci,Posfob,Muladd,1,Ny,Iag,Iagr) IF(.not.(Lrvtrn.or.Lrvtch))RETURN END IF c ------------------------------------------------------------------ IF(Nfcst.gt.0)THEN IF(Prttab(LXESAF)) & CALL table(Stci,Posfob+1,Posffc,11,1,2,dvec,LXESAF) IF((.not.Lfatal).and.Savtab(LXESAF)) & CALL punch(Stci,Posfob+1,Posffc,LXESAF,F,F) IF(Lfatal)RETURN END IF IF(Prttab(LXESAP)) & CALL x11plt(Stci,Stci,Pos1ob,Posfob,LXESAP,0,0,6,1) c ------------------------------------------------------------------ C --- IF OPTION SELECTED ADJUST YEARLY TOTALS OF D11 TO EQUAL THE YEARLY C --- TOTALS OF THE ORIGINAL SERIES. c ------------------------------------------------------------------ IF(Iyrt.gt.0)THEN c ------------------------------------------------------------------ c use Lfctfr to set last observation to be forced (BCM, May 2006) c ------------------------------------------------------------------ IF(Lfctfr)THEN lstfrc=Posffc ELSE lstfrc=Posfob END IF c ------------------------------------------------------------------ c Based on value of Iftrgt, set up target (stbase) for forcing the c seasonally adjusted series (BCM, May 2003) c ------------------------------------------------------------------ IF(Iftrgt.eq.0)THEN CALL copy(Series,lstfrc,1,stbase) ELSE IF(Iftrgt.eq.1)THEN CALL copy(Stocal,lstfrc,1,stbase) ELSE CALL copy(Stopp,lstfrc,1,stbase) IF(Iftrgt.eq.3)CALL divsub(stbase,stbase,Faccal,Pos1ob,lstfrc) END IF c ------------------------------------------------------------------ IF(Iyrt.eq.1)THEN CALL qmap(stbase,Stci,Stci2,Pos1ob,lstfrc,Ny,ib,ie,Begyrt) c ------------------------------------------------------------------ c Change made October 1995 to duplicate X-11-ARIMA/88 partial year c adjustment of yearly totals. BCM c ------------------------------------------------------------------ IF(ie.lt.lstfrc)THEN tempk=Stci2(ie)-Stci(ie) DO i=ie+1,lstfrc Stci2(i)=Stci(i)+tempk END DO END IF c ------------------------------------------------------------------ c Change made May 2005 to do the same partial year adjustment c to early data BCM c ------------------------------------------------------------------ IF(ib.gt.Pos1ob)THEN tempk=Stci2(ib)-Stci(ib) DO i=Pos1ob,ib-1 Stci2(i)=Stci(i)+tempk END DO END IF ELSE IF(Iyrt.eq.2)THEN CALL qmap2(stbase,Stci,Stci2,Pos1ob,lstfrc,Ny,Iagr) END IF c ------------------------------------------------------------------ c check for values <= 0 in Stci2 c ------------------------------------------------------------------ negmsg=F negfin=F IF(Muladd.ne.1.and.(.not.dpeq(Cnstnt,DNOTST)))THEN DO i=Pos1ob,lstfrc IF(.not.(Stci2(i).gt.ZERO))THEN IF(.not.negmsg)negmsg=T Stci2(i)=ZERO END IF END DO c ------------------------------------------------------------------ c if so, correct the negative values by replacing the values < 0 c by prorating the modified SAA series with the target series c programmed by BCM from suggestion by Susie Fortier, June 2006 c ------------------------------------------------------------------ IF(negmsg)THEN rbak=Rol lbak=Lamda Rol=ZERO Lamda=0.5D0 CALL qmap2(stbase,Stci2,temp2,Pos1ob,lstfrc,Ny,Iagr) Rol = rbak Lamda = lbak CALL copy(temp2,PLEN,1,Stci2) c ------------------------------------------------------------------ c check to see if Stci2 has observations that are <= 0 c ------------------------------------------------------------------ DO i=Pos1ob,lstfrc IF(.not.(Stci2(i).gt.ZERO))THEN IF(.not.negfin)negfin=T END IF END DO END IF END IF c ------------------------------------------------------------------ C --- WRITE SEASONALLY ADJUSTED SERIES WITH REVISED YEARLY TOTALS D11A. c ------------------------------------------------------------------ IF(Prttab(LFCSAA)) & CALL table(Stci2,Pos1ob,Posfob,11,2,2,dvec,LFCSAA) IF((.not.Lfatal).and.Savtab(LFCSAA)) & CALL punch(Stci2,Pos1ob,Posfob,LFCSAA,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Stci2,Pos1ob,Posfob,LFCSAA,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(negmsg)THEN CALL writln('NOTE: Values <= 0 were found in the forced seasonal &ly adjusted series.',Mt1,Mt2,T) IF(Iyrt.gt.0)THEN CALL writln(' These values were corrected by replacing the & negative values with zero',Mt1,Mt2,F) CALL writln(' and prorating the modified forced seasonally &adjusted series with ',Mt1,Mt2,F) CALL writln(' the target series.',Mt1,Mt2,F) ELSE CALL writln(' These values were corrected by replacing the & negative values with zero.',Mt1,Mt2,F) END IF END IF c ------------------------------------------------------------------ C --- APPLY THE TEST FOR RESIDUAL SEASONALITY c ------------------------------------------------------------------ CALL ftest(Stci2,Pos1ob,Posfob,Ny,1,Prttab(LFCSAA).and. & Prttab(LXERSF),Savtab(LXERSF)) IF(.not.Lrndsa)THEN c ------------------------------------------------------------------ c Store value of seasonally adjusted series for sliding spans c analysis. c ------------------------------------------------------------------ IF(Issap.eq.2)THEN CALL ssrit(Stci2,Pos1ob,Posfob,3,Series) RETURN END IF c ------------------------------------------------------------------ c Store value of seasonally adjusted series for revision history c analysis. c ------------------------------------------------------------------ IF(Irev.eq.4.and.(Lrvsa.or.Lrvch))THEN CALL getrev(Stci2,Posfob,Muladd,1,Ny,Iag,Iagr) IF(.not.(Lrvtrn.or.Lrvtch))RETURN END IF END IF c ------------------------------------------------------------------ c compute forcing factor from seasonally adjusted series c (BCM May 2006) c ------------------------------------------------------------------ c If there are observations <= 0, set the forcing factor to DNOTST c and print a warning message. c (BCM July 2006) c ------------------------------------------------------------------ IF(negfin)THEN DO i=Pos1ob,lstfrc IF(.not.(Stci2(i).gt.ZERO))THEN frcfac(i)=DNOTST ELSE frcfac(i)=Stci(i)/Stci2(i) END IF END DO ELSE CALL divsub(frcfac,Stci,Stci2,Pos1ob,lstfrc) END IF c ------------------------------------------------------------------ C --- WRITE SEASONALLY ADJUSTED SERIES WITH REVISED YEARLY TOTALS D11A. c ------------------------------------------------------------------ IF(Prttab(LFRFAC)) & CALL table(frcfac,Pos1ob,Posfob,11,6,1,dvec,LFRFAC) IF((.not.Lfatal).and.Savtab(LFRFAC)) & CALL punch(frcfac,Pos1ob,lstfrc,LFRFAC,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(frcfac,Pos1ob,lstfrc,LFRFAC,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(negmsg)THEN CALL writln('NOTE: Values <= 0 were found in the final forced se &asonally adjusted series.',Mt1,Mt2,T) CALL writln(' Forcing factors for these observations were s &et to -999.',Mt1,Mt2,F) END IF ELSE c ------------------------------------------------------------------ c copy Seasonally adjusted series into seasonally adjusted forced c series to allow formation of indirect forced seasonally adjusted c series (BCM May 2006) c ------------------------------------------------------------------ CALL copy(Stci,Posffc,1,Stci2) END IF c ------------------------------------------------------------------ c If option selected ensure the rounded seasonally adjusted values c equals the rounded seasonally adjusted total. c ------------------------------------------------------------------ IF(Lrndsa)THEN CALL rndsa(Stci2,Stcirn,Pos1ob,Posfob,rndok) c ------------------------------------------------------------------ C --- WRITE rounded SEASONALLY ADJUSTED SERIES c ------------------------------------------------------------------ IF(rndok)THEN IF(Prttab(LFCRND)) & CALL table(Stcirn,Pos1ob,Posfob,11,3,2,dvec,LFCRND) IF((.not.Lfatal).and.Savtab(LFCRND)) & CALL punch(Stcirn,Pos1ob,Posfob,LFCRND,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Stcirn,Pos1ob,Posfob,LFCRND,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ C --- APPLY THE TEST FOR RESIDUAL SEASONALITY c ------------------------------------------------------------------ CALL ftest(Stcirn,Pos1ob,Posfob,Ny,1, & Prttab(LFCRND).and.Prttab(LXERSF),Savtab(LXERSF)) c ------------------------------------------------------------------ c Store value of rounded seasonally adjusted series for sliding c spans analysis. c ------------------------------------------------------------------ IF(Issap.eq.2)THEN CALL ssrit(Stcirn,Pos1ob,Posfob,3,Series) RETURN END IF ELSE Lrndsa=F IF(Issap.eq.2)RETURN END IF c ------------------------------------------------------------------ c Store value of seasonally adjusted series for revision history c analysis. c ------------------------------------------------------------------ IF(Irev.eq.4.and.(Lrvsa.or.Lrvch))THEN CALL getrev(Stcirn,Posfob,Muladd,1,Ny,Iag,Iagr) IF(.not.(Lrvtrn.or.Lrvtch))RETURN END IF END IF c ------------------------------------------------------------------ C --- WRITE THE FINAL TREND CYCLE D12. c ------------------------------------------------------------------ c If level shift outliers were removed, put them in the final c trend cycle. c ------------------------------------------------------------------ IF(((.not.Finls).and.Adjls.eq.1).or.(Nustad.gt.0.and.Lprntr).or. &((.not.Fintc).and.Lttc.and.Adjtc.eq.1)) THEN CALL copy(Stc,PLEN,1,stc2) IF((.not.Finls).and.Adjls.eq.1) & CALL addmul(stc2,Facls,Stc,Pos1bk,Posffc) IF((.not.Fintc).and.Lttc.and.Adjtc.eq.1) & CALL addmul(stc2,Factc,stc2,Pos1bk,Posffc) c ------------------------------------------------------------------ c If there are temporary adjustment factors, put them back into the c Trend c ------------------------------------------------------------------ IF(Nustad.gt.0.and.Lprntr)THEN DO i=Pos1bk,Posffc i2=Frstat+i-Pos1bk IF(Muladd.eq.1)THEN stc2(i)=stc2(i)+Usrtad(i2) ELSE stc2(i)=stc2(i)*Usrtad(i2) END IF END DO END IF c ------------------------------------------------------------------ C --- remove constant from final trend. (added by BCM July 2005) c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN CALL copy(stc2,Posffc,-1,stc2pc) DO i=Pos1ob,Posffc stc2(i)=stc2(i)-Cnstnt END DO END IF c ------------------------------------------------------------------ IF(Prttab(LXED12))THEN IF(oktrn)THEN CALL table(stc2,Pos1ob,Posfob,12,1,2,dvec,LXED12) ELSE CALL prttrn(stc2,trnchr,Pos1ob,Posfob,12,LXED12) END IF END IF IF((.not.Lfatal).and.Savtab(LXED12)) & CALL punch(stc2,Pos1ob,Posfob,LXED12,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(stc2,Pos1ob,Posfob,LXED12,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Nfcst.gt.0)THEN IF(Prttab(LXETRF))THEN IF(oktrf)THEN CALL table(stc2,Posfob+1,Posffc,12,1,2,dvec,LXETRF) ELSE CALL prttrn(stc2,trnchr,Posfob+1,Posffc,12,LXETRF) END IF END IF IF((.not.Lfatal).and.Savtab(LXETRF)) & CALL punch(stc2,Posfob+1,Posffc,LXETRF,F,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(Prttab(LXETRP)) & CALL x11plt(stc2,stc2,Pos1ob,Posfob,LXETRP,1,0,6,1) IF((.not.Lfatal).and.Prttab(LXETAL))THEN IF(oktrn)THEN CALL table(Stc,Pos1ob,Posfob,12,1,2,dvec,LXETAL) ELSE CALL prttrn(Stc,trnchr,Pos1ob,Posfob,12,LXETAL) END IF END IF IF((.not.Lfatal).and.Savtab(LXETAL)) & CALL punch(Stc,Pos1ob,Posfob,LXETAL,F,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ c print and/or save trend with constant added (BCM, July 2005 c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN IF(Prttab(LXETAC))THEN IF(oktrn)THEN CALL table(stc2pc,Pos1ob,Posfob,12,1,2,dvec,LXETAC) ELSE CALL prttrn(stc2pc,trnchr,Pos1ob,Posfob,12,LXETAC) END IF END IF IF((.not.Lfatal).and.Savtab(LXETAC)) & CALL punch(stc2pc,Pos1ob,Posfob,LXETAC,F,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ ELSE c ------------------------------------------------------------------ C --- remove constant from final trend. (added by BCM July 2005) c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN CALL copy(Stc,Posffc,-1,stc2pc) DO i=Pos1ob,Posffc Stc(i)=Stc(i)-Cnstnt END DO END IF c ------------------------------------------------------------------ IF(Prttab(LXED12))THEN IF(oktrn)THEN CALL table(Stc,Pos1ob,Posfob,12,1,2,dvec,LXED12) ELSE CALL prttrn(Stc,trnchr,Pos1ob,Posfob,12,LXED12) END IF END IF IF((.not.Lfatal).and.Savtab(LXED12)) & CALL punch(Stc,Pos1ob,Posfob,LXED12,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Stc,Pos1ob,Posfob,LXED12,Lgraf,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ IF(Nfcst.gt.0)THEN IF(Prttab(LXETRF))THEN IF(oktrf)THEN CALL table(Stc,Posfob+1,Posffc,12,1,2,dvec,LXETRF) ELSE CALL prttrn(Stc,trnchr,Posfob+1,Posffc,12,LXETRF) END IF END IF IF((.not.Lfatal).and.Savtab(LXETRF)) & CALL punch(Stc,Posfob+1,Posffc,LXETRF,F,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ IF(Prttab(LXETRP)) & CALL x11plt(Stc,Stc,Pos1ob,Posfob,LXETRP,0,0,6,1) IF(Lfatal)RETURN c ------------------------------------------------------------------ c print and/or save trend with constant added (BCM, July 2005 c ------------------------------------------------------------------ IF(.not.dpeq(Cnstnt,DNOTST))THEN IF(Prttab(LXETAC))THEN IF(oktrn)THEN CALL table(stc2pc,Pos1ob,Posfob,12,1,2,dvec,LXETAC) ELSE CALL prttrn(stc2pc,trnchr,Pos1ob,Posfob,12,LXETAC) END IF END IF IF((.not.Lfatal).and.Savtab(LXETAC)) & CALL punch(stc2pc,Pos1ob,Posfob,LXETAC,F,F) IF(Lfatal)RETURN END IF END IF IF(Irev.eq.4)THEN IF((.not.Finls).and.Adjls.eq.1)THEN CALL getrev(stc2,Posfob,Muladd,2,Ny,Iag,Iagr) ELSE CALL getrev(Stc,Posfob,Muladd,2,Ny,Iag,Iagr) END IF RETURN END IF c ------------------------------------------------------------------ C --- If this is a log-additive seasonal adjustment, print out the C --- bias correction factors for the trend. c ------------------------------------------------------------------ IF(Tmpma.eq.2)THEN IF(Prttab(LXEBCF)) & CALL table(biasfc,Pos1ob,Posfob,12,3,1,dvec,LXEBCF) IF((.not.Lfatal).and.Savtab(LXEBCF)) & CALL punch(biasfc,Pos1ob,Posfob,LXEBCF,F,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ C --- WRITE THE FINAL IRREGULAR D13. c ------------------------------------------------------------------ IF(Adjao.eq.1.or.(Adjtc.eq.1.and.(.not.Lttc)))THEN CALL copy(Sti,Posffc,1,sti2) IF(Adjao.eq.1)CALL addmul(sti2,Facao,sti2,Pos1bk,Posffc) IF((.not.Lttc).and.Adjtc.eq.1) & CALL addmul(sti2,Factc,sti2,Pos1bk,Posffc) IF(Prttab(LXED13).or.Prttab(LXEPIR)) & CALL table(sti2,Pos1ob,Posfob,13,1,3,dvec,LXED13) IF((.not.Lfatal).and.Savtab(LXED13)) & CALL punch(sti2,Pos1ob,Posfob,LXED13,F,F) IF((.not.Lfatal).and.Savtab(LXEPIR)) & CALL punch(sti2,Pos1ob,Posfob,LXEPIR,F,Muladd.ne.1) IF((.not.Lfatal).and.Lgraf) & CALL punch(sti2,Pos1ob,Posfob,LXED13,Lgraf,F) IF((.not.Lfatal).and.Prttab(LXEIRP)) & CALL x11plt(sti2,sti2,Pos1ob,Posfob,LXEIRP,1,ifac,29,1) IF((.not.Lfatal).and.Prttab(LXEIAO)) & CALL table(Sti,Pos1ob,Posfob,13,2,3,dvec,LXEIAO) IF((.not.Lfatal).and.Savtab(LXEIAO)) & CALL punch(Sti,Pos1ob,Posfob,LXEIAO,F,F) IF(Lfatal)RETURN c ------------------------------------------------------------------ ELSE IF(Prttab(LXED13).or.Prttab(LXEPIR)) & CALL table(Sti,Pos1ob,Posfob,13,1,3,dvec,LXED13) IF((.not.Lfatal).and.Savtab(LXED13)) & CALL punch(Sti,Pos1ob,Posfob,LXED13,F,F) IF((.not.Lfatal).and.Savtab(LXEPIR)) & CALL punch(sti2,Pos1ob,Posfob,LXEPIR,F,Muladd.ne.1) IF((.not.Lfatal).and.Lgraf) & CALL punch(Sti,Pos1ob,Posfob,LXED13,Lgraf,F) IF((.not.Lfatal).and.Prttab(LXEIRP)) & CALL x11plt(Sti,Sti,Pos1ob,Posfob,LXEIRP,0,ifac,29,1) IF (Lfatal) RETURN END IF IF(Khol.eq.1)RETURN c ------------------------------------------------------------------ C --- IF TRADING DAY IS APPLIED WRITE COMBINED SEASONAL AND TRADING C --- DAY FACTORS D16. c ------------------------------------------------------------------ IF(Prttab(LXED16).or.Prttab(LXEPAF)) & CALL table(ststd,Pos1ob,Posfob,16,1,1,dvec,LXED16) IF((Savtab(LXED16).or.Savtab(LXEPAF).or.Lgraf).and. & (.not.Lfatal))THEN IF(.not.Savfct)THEN lastsf=Posfob ELSE IF(Nfcst.gt.0)THEN lastsf=Posffc ELSE lastsf=Posfob+Ny END IF frstsf=Pos1ob IF(Savbct)frstsf=Pos1bk IF((.not.Lfatal).and.Savtab(LXED16)) & CALL punch(ststd,frstsf,lastsf,LXED16,F,F) IF((.not.Lfatal).and.Savtab(LXEPAF)) & CALL punch(ststd,frstsf,lastsf,LXEPAF,F,Muladd.ne.1) IF((.not.Lfatal).and.Lgraf) & CALL punch(ststd,frstsf,lastsf,LXED16,Lgraf,F) IF(Lfatal)RETURN END IF c ------------------------------------------------------------------ c If psuedo-additive seasonal adjustment is done, generate and print c out the final adjustment differences (Table D 16b). c ------------------------------------------------------------------ IF(Psuadd.and.Kfulsm.lt.2)THEN DO i=Pos1bk,Posffc stsb(i)=Series(i)-Stci(i) END DO IF(Prttab(LXEFAD)) & CALL table(stsb,Pos1ob,Posfob,10,2,1,dvec,LXEFAD) IF((.not.Lfatal).and.Savtab(LXEFAD))THEN IF(Savfct.and.Nfcst.gt.0)THEN CALL punch(stsb,Pos1ob,Posffc,LXEFAD,F,F) ELSE CALL punch(stsb,Pos1ob,Posfob,LXEFAD,F,F) END IF IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ IF((Adjtd.eq.1.or.(Ixreg.gt.0.and.Axrgtd)).or.(Finhol.and. & (Ixreg.gt.0.and.Axrghl).or.Adjhol.eq.1))THEN IF(Prttab(LXED18)) & CALL table(Faccal,Pos1ob,Posfob,18,1,1,dvec,LXED18) IF((.not.Lfatal).and.(Savtab(LXED18).or.Lgraf))THEN IF(.not.Savfct)THEN lastsf=Posfob ELSE IF(Nfcst.gt.0)THEN lastsf=Posffc ELSE lastsf=Posfob+Ny END IF frstsf=Pos1ob IF(Savbct)frstsf=Pos1bk IF((.not.Lfatal).and.Savtab(LXED18)) & CALL punch(Faccal,frstsf,lastsf,LXED18,F,F) IF((.not.Lfatal).and.Lgraf) & CALL punch(Faccal,frstsf,lastsf,LXED18,Lgraf,F) IF(Lfatal)RETURN END IF END IF c ------------------------------------------------------------------ C --- BEGIN PART E. c ------------------------------------------------------------------ Kpart=5 c ------------------------------------------------------------------ C --- COMPUTE THE MODIFIED ORIGINAL, SEASONALLY ADJUSTED, AND IRREGULAR C --- SERIES BY REPLACING THOSE VALUES WHICH WERE ASSIGNED A WEIGHT OF C --- ZERO IN TABLE C17. c ------------------------------------------------------------------ DO i=Pos1bk,Posffc IF(Stwt(i).gt.ZERO)THEN Stome(i)=Series(i) Stime(i)=Sti(i) Stcime(i)=Stci(i) IF(.not.dpeq(Cnstnt,DNOTST))THEN Stome(i)=Stome(i)+Cnstnt Stcime(i)=Stcime(i)+Cnstnt END IF ELSE c ------------------------------------------------------------------ C --- REPLACE THE SEASONALLY ADJUSTED SERIES WITH THE FINAL TREND CYCLE c ------------------------------------------------------------------ IF(((.not.Finls).and.Adjls.eq.1).or.(Nustad.gt.0.and. & Lprntr))THEN Stcime(i)=Stc2(i) ELSE Stcime(i)=Stc(i) END IF IF(.not.dpeq(Cnstnt,DNOTST))Stcime(i)=Stcime(i)+Cnstnt c ------------------------------------------------------------------ C --- REPLACE THE IRREGULAR BY ITS EXPECTED VALUE. c ------------------------------------------------------------------ Stime(i)=ebar c ------------------------------------------------------------------ C --- REPLACE THE ORIGINAL SERIES BY COMBINING THE TREND CYCLE, C --- SEASONAL, TRADING DAY AND PRIOR COMPONENTS. c ------------------------------------------------------------------ Stome(i)=Series(i) IF(.not.dpeq(Cnstnt,DNOTST))Stome(i)=Stome(i)+Cnstnt IF(Muladd.eq.1)THEN Stome(i)=Stome(i)-Sti(i) ELSE Stome(i)=Stome(i)/Sti(i) END IF IF(nadj2.gt.0)THEN IF(Muladd.eq.1)THEN Stcime(i)=Stcime(i)+Sprior(i) ELSE Stcime(i)=Stcime(i)*Sprior(i) END IF END IF c ------------------------------------------------------------------ c change by brian monsell 9/96 c ------------------------------------------------------------------ c Check to see if level shift outlier is adjusted for; replace value c of outier in seasonally adjusted series only if Finls is false c ------------------------------------------------------------------ IF(Finls)THEN IF(Muladd.eq.1)THEN Stcime(i)=Stcime(i)-Facls(i) ELSE Stcime(i)=Stcime(i)/Facls(i) END IF END IF c ------------------------------------------------------------------ c end of change by brian monsell 9/96 c ------------------------------------------------------------------ END IF END DO c ------------------------------------------------------------------ c change by brian monsell 9/96 c ------------------------------------------------------------------ c if ao outliers are removed from series prior to seasonal c adjustment, then remove them from these values as well. c ------------------------------------------------------------------ IF(Adjao.eq.1)THEN CALL divsub(Stome,Stome,Facao,Pos1bk,Posffc) IF(.not.Finao)CALL divsub(Stcime,Stcime,Facao,Pos1bk,Posffc) c CALL divsub(Stime,Stime,Facao,Pos1bk,Posffc) END IF IF(Adjtc.eq.1)THEN CALL divsub(Stome,Stome,Factc,Pos1bk,Posffc) IF(.not.Fintc)CALL divsub(Stcime,Stcime,Factc,Pos1bk,Posffc) c CALL divsub(Stime,Stime,Factc,Pos1bk,Posffc) END IF IF(.not.dpeq(Cnstnt,DNOTST))THEN DO i=Pos1bk,Posffc Stome(i)=Stome(i)-Cnstnt Stcime(i)=Stcime(i)-Cnstnt END DO END IF c ------------------------------------------------------------------ c end of change by brian monsell 9/96 c ------------------------------------------------------------------ IF(Adjls.eq.1.or.Adjusr.eq.1.or.Adjao.eq.1.or.Adjtc.eq.1)THEN CALL copy(sp2,PLEN,1,Sprior) IF(nadj2.eq.0)nadj2=Posffc-Pos1bk+1 IF(Kfmt.eq.0)Kfmt=1 END IF RETURN c ------------------------------------------------------------------ END x11pt4.f0000664006604000003110000007616414521201626011416 0ustar sun00315stepsc Last Change: Oct,2021- add a new argument trendtc in regression C previous change: BCM 17 Apr 2003 11:12 pm SUBROUTINE x11pt4(Lgraf,Lttc) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'stdio.i' INCLUDE 'x11adj.cmn' INCLUDE 'x11fac.cmn' INCLUDE 'adj.cmn' INCLUDE 'agr.cmn' INCLUDE 'agrsrs.cmn' INCLUDE 'orisrs.cmn' INCLUDE 'inpt.cmn' INCLUDE 'units.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priusr.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'error.cmn' INCLUDE 'tbllog.prm' INCLUDE 'tbllog.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11srs.cmn' INCLUDE 'x11tbl.i' INCLUDE 'frctbl.i' INCLUDE 'cmptbl.i' INCLUDE 'inpt2.cmn' INCLUDE 'work2.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'adxser.cmn' INCLUDE 'force.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'goodob.cmn' INCLUDE 'tdtyp.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ZERO,ONE,ONEHND,TWO,SIX LOGICAL F,T PARAMETER(F=.false.,T=.true.,ZERO=0D0,ONE=1D0,ONEHND=100D0, & TWO=2D0,SIX=6D0) c----------------------------------------------------------------------- LOGICAL lsame,Lgraf,pre18b,gudbak,allgud,Lttc DOUBLE PRECISION ebar,fn,rd1,rd2,Stime,Stmcd,Temp,tmp1,tmp2,totci, & totcim,toto,totom,trend,xrat,stcirb,ombar2, & ombrsq,ombrsd,imbar2,imbrsd,dvec,vo,vpp,thisob c DOUBLE PRECISION adjtic,adjstc c DOUBLE PRECISION adjstc(PLEN) INTEGER fext,i,ip,ifail,ij,j,jj,jyr,k,fhnote,l,ly2,m,mgrz,mlda,n, & mfda,mldaf DIMENSION trend(PLEN),xrat(PLEN),rd1(PYRS),rd2(PYRS),Stmcd(PLEN), & Stime(PLEN),imbrsd(PSP),ombrsq(PSP),ombar2(PSP),dvec(1), & stcirb(PLEN),imbar2(PSP),Temp(PLEN),ombrsd(PSP), & gudbak(PLEN) c----------------------------------------------------------------------- LOGICAL dpeq,issame,isfals DOUBLE PRECISION vars,varian EXTERNAL dpeq,issame,vars,varian,isfals c----------------------------------------------------------------------- COMMON /work / Temp COMMON /mq5a / Stmcd,Stime c----------------------------------------------------------------------- dvec(1)=ZERO c----------------------------------------------------------------------- fhnote=STDERR IF(Lquiet)fhnote=0 c----------------------------------------------------------------------- lsame=F IF((Iagr.lt.4.and.Prttab(LX11E0)).or. & (Iagr.eq.4.and.Prttab(LCMPE0)))THEN mgrz=(Lstyr-Lyr)*Ny+Lstmo ip=15 IF(Iagr.eq.4)THEN CALL x11plt(Orig,Stci,Pos1ob,mgrz,LCMPE0,0,0,ip,2) ELSE CALL x11plt(Orig,Stci,Pos1ob,mgrz,LX11E0,0,0,ip,2) END IF IF(Lfatal)RETURN END IF * IF(Kfulsm.eq.0.or.Kfulsm.eq.2)THEN c----------------------------------------------------------------------- C --- WRITE ORIGINAL SERIES MODIFIED FOR EXTREMES AND PRIORS E1. c----------------------------------------------------------------------- CALL prtagr(Stome,Pos1ob,Posfob,Pos1ob,Posfob,1,1,2,Iagr,LX11E1, & LCMPE1,dvec,Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- WRITE MODIFIED SEASONALLY ADJUSTED SERIES E2. c----------------------------------------------------------------------- * IF(Kfulsm.eq.0)THEN CALL prtagr(Stcime,Pos1ob,Posfob,Pos1ob,Posfob,2,1,2,Iagr,LX11E2, & LCMPE2,dvec,Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- DO TEST FOR RESIDUAL SEASONALITY. c----------------------------------------------------------------------- IF(Iagr.lt.4)THEN CALL ftest(Stcime,Pos1ob,Posfob,Ny,1,Prttab(LX11E2),F) ELSE CALL ftest(Stcime,Pos1ob,Posfob,Ny,1,Prttab(LCMPE2),F) END IF * END IF c----------------------------------------------------------------------- C --- WRITE THE MODIFIED IRREGULAR SERIES E3. c----------------------------------------------------------------------- CALL prtagr(Stime,Pos1ob,Posfob,Pos1ob,Posfob,3,1,3,Iagr,LX11E3, & LCMPE3,dvec,Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- C --- COMPUTE THE RATIOS (DIFFERENCES) OF THE ANNUAL TOTALS OF B1(A1) C --- TO D11 AND E1 TO E2. c----------------------------------------------------------------------- IF(Kfulsm.eq.0)THEN fext=LX11E4 IF(Iagr.eq.4)fext=LCMPE4 IF(Prttab(fext))THEN j=1 jyr=Lstyr-Lyr+1 c IF(Pos1bk.ne.1)THEN c j=Ny+j c jyr=jyr-1 c END IF ly2=Lyr DO WHILE (j.lt.Pos1ob) j=Ny+j jyr=jyr-1 Lyr=Lyr+1 END DO IF(Lstmo.ne.Ny)jyr=jyr-1 c IF (IFORC.NE.0) JYR=JYR+1 DO jj=1,jyr toto=ZERO totci=ZERO totom=ZERO totcim=ZERO k=j+Ny-1 DO l=j,k toto=toto+Series(l) totom=totom+Stome(l) totci=totci+Stci(l) totcim=totcim+Stcime(l) END DO IF(Muladd.ne.1)THEN rd1(jj)=toto/totci*ONEHND rd2(jj)=totom/totcim*ONEHND ELSE rd1(jj)=toto-totci rd2(jj)=totom-totcim END IF j=j+Ny END DO c----------------------------------------------------------------------- C --- WRITE RATIOS (DIFFERENCES)OF ANNUAL TOTALS E4. c----------------------------------------------------------------------- CALL table(rd1,1,jyr,4,1,1,rd2,fext) Lyr=ly2 IF(Lfatal)RETURN END IF END IF * END IF c----------------------------------------------------------------------- c --- if this is a multiplicative seasonal adjustment, check each of c the series that will have percent changes (differences) generated c from them to see if there is are zeroes in any of the series c (BCM March 2006). c----------------------------------------------------------------------- IF(Iagr.eq.4)CALL divsub(O5,O,Faccal,Pos1ob,Posffc) IF(Muladd.ne.1.and.(Psuadd.or.(.not.dpeq(Cnstnt,DNOTST))))THEN IF(Iagr.eq.4)THEN CALL chkzro(Series,Stci,Stci2,Stcirn,O5,Pos1bk,Posffc,Kfulsm) ELSE CALL chkzro(Series,Stci,Stci2,Stcirn,Stocal,Pos1bk,Posffc, & Kfulsm) END IF END IF c----------------------------------------------------------------------- C --- COMPUTE THE AVERAGE PERCENT CHANGES (DIFFERENCES) IN THE ORIGINAL C --- SERIES. c----------------------------------------------------------------------- mfda=Pos1ob+1 CALL change(Series,Temp,mfda,Posfob) c----------------------------------------------------------------------- C --- WRITE THE CHANGES IN THE ORIGINAL SERIES E5. c----------------------------------------------------------------------- CALL pragr2(Temp,mfda,Posfob,mfda,Posfob,5,1,1,Iagr,LX11E5,LCMPE5, & LXEE5P,LCPE5P,Muladd,dvec,F) IF(Lfatal)RETURN IF(Lsumm.gt.0)CALL svchsd(Temp,mfda,Posfob,Iagr,Muladd,'e5') IF(Kfulsm.eq.0)THEN c----------------------------------------------------------------------- C --- CALCULATE THE CHANGES IN THE SEASONALLY ADJUSTED SERIES. c----------------------------------------------------------------------- CALL change(Stci,Temp,mfda,Posfob) c----------------------------------------------------------------------- C --- WRITE THE CHANGES IN THE SEASONALLY ADJUSTED SERIES E6. c----------------------------------------------------------------------- CALL pragr2(Temp,mfda,Posfob,mfda,Posfob,6,1,1,Iagr,LX11E6, & LCMPE6,LXEE6P,LCPE6P,Muladd,dvec,F) IF(Lfatal)RETURN IF(Lsumm.gt.0)CALL svchsd(Temp,mfda,Posfob,Iagr,Muladd,'e6') c----------------------------------------------------------------------- C --- IF THE YEARLY TOTALS OF THE SEASONALLY ADJUSTED SERIES ARE C --- MODIFIED or the seasonally adjusted values were rounded, c --- CALCULATE THE CHANGES IN THE MODIFIED SERIES. c comment out setting of ify, allow changes to be computed for c earlier data - BCM, March 2006 c----------------------------------------------------------------------- IF(Iyrt.gt.0)THEN * ify=mod(Pos1ob,Ny) * IF(ify.gt.Begyrt)THEN * ify=(((Pos1ob+Ny-2)/Ny)*Ny)+Begyrt+1 * ELSE * ify=(((Pos1ob-1)/Ny)*Ny)+Begyrt+1 * END IF c----------------------------------------------------------------------- C --- WRITE THE CHANGES E6.A. c----------------------------------------------------------------------- CALL change(Stci2,Temp,mfda,Posfob) CALL pragr2(Temp,mfda,Posfob,mfda,Posfob,6,2,1,Iagr,LFCE6A, & LCPE6A,LFC6AP,LCP6AP,Muladd,dvec,F) IF(Lfatal)RETURN IF(Lsumm.gt.0)CALL svchsd(Temp,mfda,Posfob,Iagr,Muladd,'e6a') END IF c----------------------------------------------------------------------- C --- WRITE THE CHANGES E6.R. c----------------------------------------------------------------------- IF(Lrndsa)THEN * IF(Iyrt.eq.0)ify=mfda CALL change(Stcirn,Temp,mfda,Posfob) CALL pragr2(Temp,mfda,Posfob,mfda,Posfob,6,3,1,Iagr,LFCE6R, & LCPE6R,LFC6RP,LCP6RP,Muladd,dvec,F) IF(Lfatal)RETURN IF(Lsumm.gt.0)CALL svchsd(Temp,mfda,Posfob,Iagr,Muladd,'e6r') END IF END IF c ------------------------------------------------------------------ C --- WRITE THE CHANGES FOR THE FINAL TREND CYCLE D12. If level shift c outliers were removed, put them in the final trend cycle. c ------------------------------------------------------------------ IF((((.not.Finls).and.Adjls.eq.1).or.(Nustad.gt.0.and.Lprntr).and. & Iagr.lt.4).or.(Iagr.eq.4.and.Lindls).or.(Lttc.and.Adjtc.eq.1 & .and.(.not.Fintc)))THEN CALL change(Stc2,Temp,mfda,Posfob) ELSE CALL change(Stc,Temp,mfda,Posfob) END IF CALL pragr2(Temp,mfda,Posfob,mfda,Posfob,7,3,1,Iagr,LX11E7, & LCMPE7,LXEE7P,LCPE7P,Muladd,dvec,F) IF(Lfatal)RETURN IF(Lsumm.gt.0)CALL svchsd(Temp,mfda,Posfob,Iagr,Muladd,'e7') c ------------------------------------------------------------------ C --- WRITE THE CHANGES FOR THE original series adjusted for calendar c effects. (added by BCM June 2005) c ------------------------------------------------------------------ IF(Iagr.eq.4)THEN CALL change(O5,Temp,mfda,Posfob) ELSE CALL change(Stocal,Temp,mfda,Posfob) END IF CALL pragr2(Temp,mfda,Posfob,mfda,Posfob,8,1,1,Iagr,LX11E8,LCMPE8, & LXEE8P,LCPE8P,Muladd,dvec,F) IF(Lfatal)RETURN IF(Lsumm.gt.0)CALL svchsd(Temp,mfda,Posfob,Iagr,Muladd,'e8') IF(Muladd.ne.1.and.(.not.dpeq(Cnstnt,DNOTST)))THEN CALL copylg(Gudval,POBS,1,gudbak) CALL setlg(T,POBS,Gudval) END IF c----------------------------------------------------------------------- c Print a more robust estimate of the seasonally adjusted series. c----------------------------------------------------------------------- DO i=Pos1ob,Posfob stcirb(i)=Series(i)-Stome(i)+Stcime(i) END DO CALL prtagr(stcirb,Pos1ob,Posfob,Pos1ob,Posfob,11,1,2,Iagr,LXEE11, & LCPE11,dvec,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print Final adjustment ratios - A1 / D11. c----------------------------------------------------------------------- i=Pos1ob pre18b=F DO WHILE (i.le.Posffc) IF(Iagr.lt.4)THEN thisob=Series(i) ELSE thisob=O(i) END IF IF(dpeq(Stci(i),ZERO))THEN IF(dpeq(thisob,ZERO))THEN stcirb(i)=ONE ELSE stcirb(i)=DNOTST IF(.not.pre18b)pre18b=T END IF ELSE IF(dpeq(thisob,ZERO).or.thisob.lt.ZERO)pre18b=T stcirb(i)=thisob/Stci(i) END IF i=i+1 END DO CALL prtagr(stcirb,Pos1ob,Posfob,Pos1bk,Posffc,18,1,1,Iagr,LXEE18, & LCPE18,dvec,Lgraf) IF(Lfatal)RETURN c----------------------------------------------------------------------- c Print/Save total adjustment factors (BCM - March 2004, revised c June 2008) c----------------------------------------------------------------------- IF(pre18b.or.((Iagr.lt.4.and.Savtab(LXEEEB)).or. & (Iagr.ge.4.and.Savtab(LCPEEB))))THEN IF(Iagr.lt.4)THEN CALL divsub(stcirb,Series,Stci,Pos1ob,Posffc) ELSE CALL divsub(stcirb,O,Stci,Pos1ob,Posffc) END IF CALL prtagr(stcirb,Pos1ob,Posfob,Pos1bk,Posffc,18,2,1,Iagr, & LXEEEB,LCPEEB,dvec,Lgraf.and.pre18b) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- C --- PART F. c----------------------------------------------------------------------- Kpart=6 c----------------------------------------------------------------------- C --- COMPUTE MEASURES FOR THE SUMMARY MEASURES TABLE. c----------------------------------------------------------------------- c IF(Adjhol.eq.1.or.Khol.eq.2.or.(Ixreg.gt.0.and.Axrghl))THEN c CALL addmul(Sprior,Sprior,Fachol,Pos1bk,Posffc) c Kfmt=1 c END IF c----------------------------------------------------------------------- allgud=T IF(Muladd.ne.1.and.(.not.dpeq(Cnstnt,DNOTST)))THEN CALL copylg(gudbak,POBS,1,Gudval) allgud=isfals(Gudval,Pos1ob,Posfob) END IF c----------------------------------------------------------------------- IF(Kfmt.ne.0)THEN CALL sumry(Sprior,Pbar,dvec,Psq,dvec,2,Pos1ob,Posfob) vpp=vars(Sprior,Pos1ob,Posfob,0,Muladd) Vp=vpp ELSE DO i=1,Ny Pbar(i)=ZERO Psq(i)=ZERO END DO Vp=ZERO END IF IF((.not.Axrgtd.and.Kswv.eq.0.and.Adjtd.le.0).and.(.not. & (Adjhol.eq.1.or.Khol.eq.2.or.(Ixreg.gt.0.and.Axrghl))).or. & (Iagr.ge.4.and.(.not.Lindcl)))THEN Vtd=ZERO DO i=1,Ny Tdbar(i)=ZERO Tdsq(i)=ZERO END DO ELSE CALL sumry(Faccal,Tdbar,dvec,Tdsq,dvec,2,Pos1ob,Posfob) Vtd=vars(Faccal,Pos1ob,Posfob,1,Muladd) END IF CALL sumry(Sti,Ibar,Ibar2,Isq,Isd,0,Pos1ob,Posfob) CALL avedur(Sti,Pos1ob,Posfob,Adri) c Vi=vars(Sti,Pos1ob,Posfob,1,Muladd) c ------------------------------------------------------------------ * IF(.not.dpeq(Cnstnt,DNOTST))THEN * DO i=Pos1ob,Posfob * Stome(i)=Stome(i)+Cnstnt * Stc(i)=Stc(i)+Cnstnt * Series(i)=Series(i)+Cnstnt * Stcime(i)=Stcime(i)+Cnstnt * END DO * END IF IF(allgud)THEN IF(Adjls.eq.1)CALL divsub(Stome,Stome,Facls,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL divsub(Stome,Stome,Facusr,Pos1bk,Posffc) ELSE CALL copy(Stome,Posffc,1,Temp) IF(Adjls.eq.1)CALL divgud(Stome,Stome,Facls,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL divgud(Stome,Stome,Facusr,Pos1bk,Posffc) END IF c ------------------------------------------------------------------ CALL sumry(Stome,Ombar,ombar2,ombrsq,ombrsd,0,Pos1ob,Posfob) IF(issame(Stome,Pos1ob,Posfob))THEN CALL writln('NOTE: Seasonal adjustment diagnostics cannot be gene &rated because ',fhnote,Mt2,T) CALL writln(' the series listed below have either a variance & of zero or a ',fhnote,Mt2,F) CALL writln(' variance could not be computed:',fhnote,Mt2,F) CALL writln(' - the original series adjusted for extreme val &ues.',fhnote,Mt2,F) lsame=T END IF CALL sumry(Stime,Imbar,imbar2,Isq,imbrsd,0,Pos1ob,Posfob) Vi=vars(Stime,Pos1ob,Posfob,1,Muladd) IF(dpeq(Vi,ZERO).or.issame(Sti,Pos1ob,Posfob).or. & dpeq(Vi,DNOTST))THEN IF(.not.lsame)THEN CALL writln('NOTE: Seasonal adjustment diagnostics cannot be gen &erated because ',fhnote,Mt2,T) CALL writln(' the series listed below have either a varianc &e of zero or a ',fhnote,Mt2,F) CALL writln(' variance could not be computed:',fhnote,Mt2, & F) lsame=T END IF CALL writln(' - the irregular component.',STDERR,Mt2,F) END IF c ------------------------------------------------------------------ IF(allgud)THEN IF(Adjls.eq.1)CALL addmul(Stome,Stome,Facls,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL addmul(Stome,Stome,Facusr,Pos1bk,Posffc) ELSE CALL copy(Temp,Posffc,1,Stome) END IF c ------------------------------------------------------------------ IF(Kfulsm.eq.2)THEN DO i=1,Ny Sbar(i)=ZERO Sbar2(i)=ZERO Ssd(i)=ZERO Ssq(i)=ZERO END DO Vs=ZERO ELSE CALL sumry(Sts,Sbar,Sbar2,Ssq,Ssd,0,Pos1ob,Posfob) Vs=vars(Sts,Pos1ob,Posfob,1,Muladd) END IF CALL sumry(Stc,Cbar,Cbar2,Csq,Csd,0,Pos1ob,Posfob) IF(issame(Stc,Pos1ob,Posfob))THEN IF(.not.lsame)THEN CALL writln('NOTE: Seasonal adjustment diagnostics cannot be gen &erated because ',fhnote,Mt2,T) CALL writln(' the series listed below have either a varianc &e of zero or a ',fhnote,Mt2,F) CALL writln(' variance could not be computed:',fhnote,Mt2, & F) lsame=T END IF CALL writln(' - the trend component.',STDERR,Mt2,F) END IF c----------------------------------------------------------------------- C --- REMOVE LINEAR TREND (OR LINEAR PERCENTAGE GROWTH IF THE SERIES IS C --- MULTIPLICATIVE) FROM TREND CYCLE. c----------------------------------------------------------------------- IF(Muladd.ne.1)THEN IF(.not.dpeq(Cnstnt,DNOTST))THEN DO i=Pos1ob,Posfob Stc(i)=Stc(i)+Cnstnt END DO END IF CALL logar(Stc,Pos1ob,Posfob) END IF tmp1=DBLE(-Pos1ob-Posfob) tmp2=ZERO DO i=Pos1ob,Posfob tmp2=tmp2+Stc(i)*(TWO*DBLE(i)+tmp1) END DO fn=DBLE(Posfob-Pos1ob+1) tmp1=SIX*tmp2/(fn*(fn*fn-ONE)) DO i=Pos1ob,Posffc trend(i)=tmp1*(DBLE(i-Pos1bk)+ONE) END DO IF(Muladd.ne.1)THEN CALL antilg(Stc,Pos1ob,Posfob) CALL antilg(trend,Pos1ob,Posfob) END IF CALL divsub(Temp,Stc,trend,Pos1ob,Posfob) IF(Muladd.ne.1)THEN IF(.not.dpeq(Cnstnt,DNOTST))THEN DO i=Pos1ob,Posfob Stc(i)=Stc(i)-Cnstnt trend(i)=trend(i)-Cnstnt END DO END IF END IF CALL avedur(Stc,Pos1ob,Posfob,Adrc) Vc=vars(Temp,Pos1ob,Posfob,0,Muladd) c ------------------------------------------------------------------ IF(allgud)THEN IF(Adjls.eq.1)CALL divsub(Series,Series,Facls,Pos1bk,Posffc) IF(Adjao.eq.1)CALL divsub(Series,Series,Facao,Pos1bk,Posffc) IF(Adjtc.eq.1)CALL divsub(Series,Series,Factc,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL divsub(Series,Series,Facusr,Pos1bk,Posffc) ELSE CALL copy(Series,Posffc,1,Temp) IF(Adjls.eq.1)CALL divgud(Series,Series,Facls,Pos1bk,Posffc) IF(Adjao.eq.1)CALL divgud(Series,Series,Facao,Pos1bk,Posffc) IF(Adjtc.eq.1)CALL divgud(Series,Series,Factc,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL divgud(Series,Series,Facusr,Pos1bk,Posffc) END IF c ------------------------------------------------------------------ IF(issame(Series,Pos1ob,Posfob))THEN IF(.not.lsame)THEN CALL writln('NOTE: Seasonal adjustment diagnostics cannot be gen &erated because ',fhnote,Mt2,T) CALL writln(' the series listed below have either a varianc &e of zero or a ',fhnote,Mt2,F) CALL writln(' variance could not be computed:',fhnote,Mt2, & F) lsame=T END IF IF((Adjls.eq.1.or.Adjao.eq.1.or.Adjtc.eq.1).and.Adjusr.eq.1)THEN CALL writln(' - the original series adjusted for regARIMA o &utlier and user-defined',fhnote,Mt2,F) CALL writln(' regression effects.',STDERR,Mt2,F) ELSE IF(Adjls.eq.1.or.Adjao.eq.1.or.Adjtc.eq.1)THEN CALL writln(' - the original series adjusted for regARIMA o &utlier effects.',STDERR,Mt2,F) ELSE IF(Adjusr.eq.1)THEN CALL writln(' - the original series adjusted for user-defin &ed regression',STDERR,Mt2,F) CALL writln(' effects.',STDERR,Mt2,F) ELSE CALL writln(' - the original series.',STDERR,Mt2,F) END IF END IF CALL sumry(Series,Obar,Obar2,Osq,Osd,0,Pos1ob,Posfob) c ------------------------------------------------------------------ IF(allgud)THEN IF(Adjls.eq.1)CALL addmul(Series,Series,Facls,Pos1bk,Posffc) IF(Adjao.eq.1)CALL addmul(Series,Series,Facao,Pos1bk,Posffc) IF(Adjtc.eq.1)CALL addmul(Series,Series,Factc,Pos1bk,Posffc) IF(Adjusr.eq.1)CALL addmul(Series,Series,Facusr,Pos1bk,Posffc) ELSE CALL copy(Temp,Posffc,1,Series) END IF c ------------------------------------------------------------------ CALL divsub(Temp,Stome,trend,Pos1ob,Posfob) vo=vars(Temp,Pos1ob,Posfob,0,Muladd)/ONEHND c ------------------------------------------------------------------ c Check to see if seasonal adjustment diagnostics can be computed. c ------------------------------------------------------------------ IF(dpeq(vo,ZERO).or.dpeq(vo,DNOTST))THEN IF(.not.lsame)THEN CALL writln('NOTE: Seasonal adjustment diagnostics cannot be gen &erated because ',fhnote,Mt2,T) CALL writln(' the series listed below have either a varianc &e of zero or a ',fhnote,Mt2,F) CALL writln(' variance could not be computed:',fhnote,Mt2, & F) lsame=T END IF CALL writln(' - the original series with the linear trend re &moved.',fhnote,Mt2,F) END IF IF(lsame)RETURN Vp=Vp/vo Vtd=Vtd/vo Vc=Vc/vo Vs=Vs/vo Vi=Vi/vo Rv=Vp+Vtd+Vc+Vs+Vi DO i=1,Ny IF(dpeq(Isq(i),DNOTST).or.dpeq(Csq(i),DNOTST).or. & dpeq(Ssq(i),DNOTST).or.dpeq(Psq(i),DNOTST).or. & dpeq(Tdsq(i),DNOTST))THEN IF(.not.dpeq(Isq(i),DNOTST))Isq(i)=DNOTST IF(.not.dpeq(Csq(i),DNOTST))Csq(i)=DNOTST IF(.not.dpeq(Ssq(i),DNOTST))Ssq(i)=DNOTST IF(.not.dpeq(Psq(i),DNOTST))Psq(i)=DNOTST IF(.not.dpeq(Tdsq(i),DNOTST))Tdsq(i)=DNOTST Osq2(i)=DNOTST ELSE Osq2(i)=Isq(i)+Csq(i)+Ssq(i)+Psq(i)+Tdsq(i) Isq(i)=Isq(i)/Osq2(i) Csq(i)=Csq(i)/Osq2(i) Ssq(i)=Ssq(i)/Osq2(i) Psq(i)=Psq(i)/Osq2(i) Tdsq(i)=Tdsq(i)/Osq2(i) c Osq2(i)=Osq2(i)/Osq(i) Osq2(i)=Osq2(i)/ombrsq(i) END IF c----------------------------------------------------------------------- C --- COMPUTE I/C RATIOS. c----------------------------------------------------------------------- IF(dpeq(Cbar(i),DNOTST).or.dpeq(Ibar(i),DNOTST))THEN smic(i)=DNOTST ELSE Smic(i)=Ibar(i)/Cbar(i) END IF END DO c ------------------------------------------------------------------ IF(allgud)THEN IF(.not.Finls.and.Adjls.eq.1) & CALL divsub(Stci,Stci,Facls,Pos1bk,Posffc) IF(.not.Finao.and.Adjao.eq.1) & CALL divsub(Stci,Stci,Facao,Pos1bk,Posffc) IF(.not.Fintc.and.Adjtc.eq.1) & CALL divsub(Stci,Stci,Factc,Pos1bk,Posffc) IF(.not.Finusr.and.Adjusr.eq.1) & CALL divsub(Stci,Stci,Facusr,Pos1bk,Posffc) ELSE CALL copy(Stci,Posffc,1,Temp) IF(.not.Finls.and.Adjls.eq.1) & CALL divgud(Stci,Stci,Facls,Pos1bk,Posffc) IF(.not.Finao.and.Adjao.eq.1) & CALL divgud(Stci,Stci,Facao,Pos1bk,Posffc) IF(.not.Fintc.and.Adjtc.eq.1) & CALL divgud(Stci,Stci,Factc,Pos1bk,Posffc) IF(.not.Finusr.and.Adjusr.eq.1) & CALL divgud(Stci,Stci,Facusr,Pos1bk,Posffc) END IF c ------------------------------------------------------------------ CALL sumry(Stci,Cibar,Cibar2,dvec,Cisd,1,Pos1ob,Posfob) CALL avedur(Stci,Pos1ob,Posfob,Adrci) c ------------------------------------------------------------------ IF(allgud)THEN IF(.not.Finls.and.Adjls.eq.1) & CALL addmul(Stci,Stci,Facls,Pos1bk,Posffc) IF(.not.Finao.and.Adjao.eq.1) & CALL addmul(Stci,Stci,Facao,Pos1bk,Posffc) IF(.not.Fintc.and.Adjtc.eq.1) & CALL addmul(Stci,Stci,Factc,Pos1bk,Posffc) IF(.not.Finusr.and.Adjusr.eq.1) & CALL addmul(Stci,Stci,Facusr,Pos1bk,Posffc) ELSE CALL copy(Temp,Posffc,1,Stci) END IF c ------------------------------------------------------------------ IF(allgud)THEN IF(.not.Finls.and.Adjls.eq.1) & CALL divsub(Stcime,Stcime,Facls,Pos1bk,Posffc) * IF(.not.Finao.and.Adjao.eq.1) * & CALL divsub(Stcime,Stcime,Facao,Pos1bk,Posffc) * IF(.not.Fintc.and.Adjtc.eq.1) * & CALL divsub(Stcime,Stcime,Factc,Pos1bk,Posffc) IF(.not.Finusr.and.Adjusr.eq.1) & CALL divsub(Stcime,Stcime,Facusr,Pos1bk,Posffc) ELSE CALL copy(Stcime,Posffc,1,Temp) IF(.not.Finls.and.Adjls.eq.1) & CALL divgud(Stcime,Stcime,Facls,Pos1bk,Posffc) * IF(.not.Finao.and.Adjao.eq.1) * & CALL divgud(Stcime,Stcime,Facao,Pos1bk,Posffc) * IF(.not.Fintc.and.Adjtc.eq.1) * & CALL divgud(Stcime,Stcime,Factc,Pos1bk,Posffc) IF(.not.Finusr.and.Adjusr.eq.1) & CALL divgud(Stcime,Stcime,Facusr,Pos1bk,Posffc) END IF c ------------------------------------------------------------------ CALL sumry(Stcime,Cimbar,dvec,dvec,dvec,3,Pos1ob,Posfob) c ------------------------------------------------------------------ IF(allgud)THEN IF(.not.Finls.and.Adjls.eq.1) & CALL addmul(Stcime,Stcime,Facls,Pos1bk,Posffc) * IF(.not.Finao.and.Adjao.eq.1) * & CALL addmul(Stcime,Stcime,Facao,Pos1bk,Posffc) * IF(.not.Fintc.and.Adjtc.eq.1) * & CALL addmul(Stcime,Stcime,Factc,Pos1bk,Posffc) IF(.not.Finusr.and.Adjusr.eq.1) & CALL addmul(Stcime,Stcime,Facusr,Pos1bk,Posffc) ELSE CALL copy(Stcime,Posffc,1,Temp) END IF c ------------------------------------------------------------------ * IF(.not.dpeq(Cnstnt,DNOTST))THEN * DO i=Pos1ob,Posfob * Stome(i)=Stome(i)-Cnstnt * Stc(i)=Stc(i)-Cnstnt * Series(i)=Series(i)-Cnstnt * Stcime(i)=Stcime(i)-Cnstnt * END DO * END IF c----------------------------------------------------------------------- C --- COMPUTE MCD. c----------------------------------------------------------------------- Mcd=Ny DO WHILE (Smic(Mcd).lt.ONE) IF(Mcd.eq.1)GO TO 10 Mcd=Mcd-1 END DO Mcd=Mcd+1 IF(Mcd.gt.Ny)Mcd=Ny 10 n=Mcd IF(n.gt.6)n=6 m=2-n+n/2*2 c----------------------------------------------------------------------- C --- APPLY THE MCD MOVING AVERAGE. c----------------------------------------------------------------------- CALL averag(Stci,Stmcd,Pos1bk,Posffc,m,n) mfda=Pos1ob+n/2 mlda=Posfob-n/2 mldaf=Posffc-n/2 IF(mldaf.gt.Posfob)mldaf=Posfob CALL sumry(Stmcd,Smbar,Smbar2,dvec,Smsd,1,mfda,mlda) CALL avedur(Stmcd,mfda,mlda,Adrmcd) Kpart=6 c----------------------------------------------------------------------- C --- WRITE THE MCD MOVING AVERAGE F1. c----------------------------------------------------------------------- CALL prtagr(Stmcd,mfda,mlda,mfda,mlda,1,1,2,Iagr,LX11F1,LCMPF1, & dvec,F) IF(Lfatal)RETURN DO i=mfda,mldaf Stmcd(i)=Temp(i) END DO c----------------------------------------------------------------------- C --- CALCULATE THE AUTOCORRELATION FUNCTION OF THE IRREGULARS FOR SPANS C --- 1 TO NY+2. c----------------------------------------------------------------------- Nn=2-Muladd ebar=dble(1-Muladd) tmp1=varian(Sti,Pos1ob,Posfob,Nn)/fn n=Ny+2 CALL setdp(ZERO,n,Autoc) DO i=1,n ij=Pos1ob+i DO j=ij,Posfob Autoc(i)=Autoc(i)+(Sti(j)-ebar)*(Sti(j-i)-ebar) END DO Autoc(i)=Autoc(i)/((fn-i)*tmp1) END DO CALL f3cal(Sts,ifail) c----------------------------------------------------------------------- C --- WRITE TABLES F2 AND F3. c----------------------------------------------------------------------- IF(Iagr.eq.4)THEN IF(Prttab(LCMPF2).or.Prttab(LCMPF3)) & CALL fgen(Mt1,Kfmt,Prttab(LCMPF2),Prttab(LCMPF3),.False.) CALL svf2f3(Nform,Ng,Savtab(LCMPF2),Savtab(LCMPF3),'if') IF(Lfatal)RETURN ELSE IF(Prttab(LX11F2).or.Prttab(LX11F3)) & CALL fgen(Mt1,Kfmt,Prttab(LX11F2),Prttab(LX11F3),.True.) CALL svf2f3(Nform,Ng,Savtab(LX11F2),Savtab(LX11F3),'f') IF(Lfatal)RETURN END IF c CALL qcontr(Tmpma,Ny) c----------------------------------------------------------------------- c Print out type of trading day table. c----------------------------------------------------------------------- IF(Tdtbl.gt.0.and.Prttab(LXETDY).and.Iagr.lt.4)THEN CALL prtdtb(Tdtbl) IF(Lfatal)RETURN END IF c----------------------------------------------------------------------- c Produce ratio plots c----------------------------------------------------------------------- IF(Iagr.lt.4.and.Prttab(LXERA1).or.Iagr.eq.4.and.Prttab(LCMPR1)) & THEN IF(Muladd.eq.1)THEN DO i=Posfob,Pos1bk+1,-1 xrat(i)=Stome(i)-Stome(i-1) END DO ELSE DO i=Posfob,Pos1bk+1,-1 xrat(i)=Stome(i)/Stome(i-1) END DO END IF ip=17 IF(Iagr.eq.4)THEN CALL x11plt(xrat,xrat,Pos1bk+1,Posfob,LCMPR1,0,0,ip,1) ELSE CALL x11plt(xrat,xrat,Pos1bk+1,Posfob,LXERA1,0,0,ip,1) END IF IF(Lfatal)RETURN END IF IF(Iagr.lt.4.and.Prttab(LXERA2).or.Iagr.eq.4.and.Prttab(LCMPR2)) & THEN IF(Muladd.eq.1)THEN DO i=Posfob,Pos1bk+1,-1 xrat(i)=Stcime(i)-Stcime(i-1) END DO ELSE DO i=Posfob,Pos1bk+1,-1 xrat(i)=Stcime(i)/Stcime(i-1) END DO END IF ip=17 IF(Iagr.eq.4)THEN CALL x11plt(xrat,xrat,Pos1bk+1,Posfob,LCMPR2,0,0,ip,1) ELSE CALL x11plt(xrat,xrat,Pos1bk+1,Posfob,LXERA2,0,0,ip,1) END IF END IF c----------------------------------------------------------------------- RETURN END x11ptr.cmn0000664006604000003110000000127514521201626012033 0ustar sun00315stepsc----------------------------------------------------------------------- c Pos1bk - relative position of first backcast in orix vector c Pos1ob - relative position of first observation of original series in c orix vector c Posfob - relative position of final observation of original series in c orix vector c Posffc - relative position of final observation of original series c augmented by forecasts in orix vector c----------------------------------------------------------------------- INTEGER Pos1bk,Pos1ob,Posfob,Posffc c----------------------------------------------------------------------- COMMON /foscmn / Pos1bk,Pos1ob,Posfob,Posffc x11ref.f0000664006604000003110000001513014521201626011445 0ustar sun00315stepsC Last change: BCM 27 May 1998 12:45 pm SUBROUTINE x11ref(Fcal,Ftd,Fhol,Xdev,Muladd,Psuadd,Tdgrp,Stdgrp, & Holgrp,Axruhl,Ndifum,Rtype,Nrxy,Ncxy,B,Xy,Nb, & Easidx,Kswv,Calfrc,Xhlnln) IMPLICIT NONE c----------------------------------------------------------------------- c Computes X-11 Regression factors c----------------------------------------------------------------------- INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'xrgum.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION ONE,ZERO LOGICAL F,T PARAMETER(ONE=1D0,ZERO=0D0,F=.false.,T=.true.) c----------------------------------------------------------------------- LOGICAL Psuadd,Axruhl,Trumlt,Calfrc,Xhlnln DOUBLE PRECISION Fcal,Ftd,Fhol,B,Xy INTEGER icol,irow,Tdgrp,Xdev,Muladd,ir2,Rtype,Holgrp,Ndifum,Nrxy, & Ncxy,Nb,Easidx,Kswv,Stdgrp DIMENSION Fcal(*),Ftd(*),Fhol(*),Rtype(*),B(*),Xy(*) c----------------------------------------------------------------------- c initialize regression factors to zero c----------------------------------------------------------------------- CALL setdp(ZERO,PLEN,Fcal) CALL setdp(ZERO,PLEN,Ftd) CALL setdp(ZERO,PLEN,Fhol) c----------------------------------------------------------------------- trumlt=(.not.Psuadd).and.Muladd.eq.0 c----------------------------------------------------------------------- c get raw factors for trading day, holiday effects c----------------------------------------------------------------------- DO icol=1,Nb IF(Rtype(icol).eq.PRGTTD.or.Rtype(icol).eq.PRGTST.or. & Rtype(icol).eq.PRRTTD.or.Rtype(icol).eq.PRRTST.or. & Rtype(icol).eq.PRATTD.or.Rtype(icol).eq.PRATST.or. & Rtype(icol).eq.PRGTLY.or.Rtype(icol).eq.PRRTLY.or. & Rtype(icol).eq.PRATLY.or.Rtype(icol).eq.PRG1TD.or. & Rtype(icol).eq.PRR1TD.or.Rtype(icol).eq.PRA1TD.or. & Rtype(icol).eq.PRG1ST.or.Rtype(icol).eq.PRR1ST.or. & Rtype(icol).eq.PRA1ST.or. & (Rtype(icol).eq.PRGUTD.or.Rtype(icol).eq.PRGULM.or. & Rtype(icol).eq.PRGULQ.or.Rtype(icol).eq.PRGULY))THEN CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Ftd,1) ELSE IF(Rtype(icol).eq.PRGTEA.or.Rtype(icol).eq.PRGTLD.or. & Rtype(icol).eq.PRGTTH.or.Rtype(icol).eq.PRGTEC.or. & Rtype(icol).eq.PRGTUH)THEN CALL daxpy(Nrxy,B(icol),Xy(icol),Ncxy,Fhol,1) END IF END DO c----------------------------------------------------------------------- c Complete creating factors with user defined means, or derived from c an additive seasonal adjustment. c----------------------------------------------------------------------- IF(Haveum.or.Muladd.eq.1)THEN DO irow=1,Nrxy Fcal(irow)=Ftd(irow)+Fhol(irow) IF(Haveum)THEN ir2=irow+Ndifum Fcal(irow)=Fcal(irow)+Umean(ir2) IF(Muladd.eq.2)Fcal(irow)=dexp(Fcal(irow)) IF(.not.Noxfac)THEN IF(Tdgrp.gt.0)THEN Ftd(irow)=Fcal(irow) ELSE Fhol(irow)=Fcal(irow) END IF END IF END IF END DO RETURN END IF c----------------------------------------------------------------------- c Adjust raw factors as necessary c----------------------------------------------------------------------- IF(Tdgrp.gt.0)THEN IF(Psuadd)THEN CALL mulref(Nrxy,Fcal,Ftd,Xdev,Xnstar,Daybar,F) CALL mulref(Nrxy,Ftd,Ftd,Xdev,Xnstar,Daybar,T) ELSE CALL mulref(Nrxy,Fcal,Ftd,Xdev,Xnstar,DNOTST,F) CALL mulref(Nrxy,Ftd,Ftd,Xdev,Xnstar,DNOTST,T) END IF END IF IF(Holgrp.gt.0)THEN IF((Muladd.eq.2.or.Trumlt).and.Tdgrp.gt.0)THEN CALL mulref(Nrxy,Fcal,Fhol,Xdev,Xnstar,DNOTST,F) c CALL mulref(Nrxy,Fhol,Fhol,Xdev,Xn,DNOTST,T) CALL mulref(Nrxy,Fhol,Fhol,Xdev,Xnstar,DNOTST,T) ELSE CALL mulref(Nrxy,Fcal,Fhol,Xdev,Xnstar,ONE,F) END IF END IF c----------------------------------------------------------------------- c Finish creating the factors c----------------------------------------------------------------------- DO irow=1,Nrxy ir2=irow+Xdev-1 Fhol(irow)=Fhol(irow)+ONE c----------------------------------------------------------------------- c Pseudo additive calendar factors c----------------------------------------------------------------------- IF(Psuadd)THEN Fcal(irow)=Fcal(irow)+ONE IF(Tdgrp.gt.0)THEN Ftd(irow)=Ftd(irow)+ONE ELSE IF(Stdgrp.gt.0)Ftd(irow)=Ftd(irow)+ONE END IF c----------------------------------------------------------------------- c Multiplicative calendar factors c----------------------------------------------------------------------- ELSE IF(Muladd.eq.0)THEN IF(Tdgrp.gt.0)THEN IF(Kswv.eq.3)THEN Ftd(irow)=Ftd(irow)+ONE Fcal(irow)=Fcal(irow)+ONE ELSE Ftd(irow)=Ftd(irow)+Xn(ir2)/Xnstar(ir2) Fcal(irow)=Fcal(irow)+Xn(ir2)/Xnstar(ir2) END IF IF(Holgrp.gt.0)THEN IF((.not.Axruhl).and.Easidx.eq.0.and.Xhlnln)THEN Fhol(irow)=Fhol(irow)/Kvec(irow) IF(.not.Calfrc)Fcal(irow)=Fcal(irow)/Kvec(irow) ELSE IF(Calfrc)THEN Fcal(irow)=Ftd(irow)*Fhol(irow) END IF END IF ELSE Fcal(irow)=Fcal(irow)+ONE IF(Stdgrp.gt.0)Ftd(irow)=Ftd(irow)+ONE END IF c----------------------------------------------------------------------- c log-additive calendar factors c----------------------------------------------------------------------- ELSE IF(Muladd.eq.2)THEN IF(Tdgrp.gt.0)THEN IF(Calfrc)THEN Ftd(irow)=(Ftd(irow)+1)*(Xn(ir2)/Xnstar(ir2)) IF(Holgrp.gt.0)THEN Fcal(irow)=Ftd(irow)*Fhol(irow) ELSE Fcal(irow)=Ftd(irow) END IF ELSE Fcal(irow)=dexp(Fcal(irow)+(Xlpyr(ir2)/Xnstar(ir2))) Ftd(irow)=Fcal(irow) END IF ELSE Fcal(irow)=dexp(Fcal(irow)) Fhol(irow)=Fcal(irow) IF(Stdgrp.gt.0)Ftd(irow)=Fcal(irow) c IF(Holgrp.gt.0)Fhol(irow)=exp(Fhol(irow)) END IF END IF END DO c----------------------------------------------------------------------- RETURN END x11reg.cmn0000664006604000003110000000556214521201626012006 0ustar sun00315stepsc----------------------------------------------------------------------- c Easgrp - Indicator variable that signals the presence of an c Easter regressor c Holgrp - Indicator variable that signals the presence of any c holiday regressor c Tdgrp - Indicator variable that signals the presence of a trading c day regressor c Stdgrp - Indicator variable that signals the presence of a Stock c trading day regressor c Xtdtst - Indicator variable specifying whether an AIC-test will c be performed for the trading day regression variables c for the irregular regression (1=td,3=tdstock) c Xaicst - Stock day given in tdstock selected for TD AIC-test c Xaicrg - Displacement for change of regime given for TD AIC-test c Begxrg - Starting date for the span of data used in the irregular c regression c Endxrg - Ending date for the span of data used in the irregular c regression c Fxprxr - Period every year for which the irregular regression will c be estimated in the revisions history. Every other c period, the model parameters will be fixed to what they c were at the last value of Fxprxr c Begxot - Starting date for the outlier testing procedure used in c the irregular regression c Endxot - Ending date for the outlier testing procedure used in c the irregular regression c Xeasvc - Vector for Easter windows used for Easter AIC-test for c the irregular regression c Neasvx - Number of Easter windows used for Easter AIC-test for c the irregular regression c----------------------------------------------------------------------- INTEGER Ixrgtd,Ixrghl,Easgrp,Holgrp,Tdgrp,Stdgrp,Xtdtst,Xaicrg, & Xaicst,Begxrg,Endxrg,Fxprxr,Xdsp,Begxot,Endxot,Xeasvc, & Neasvx c----------------------------------------------------------------------- c Critxr - critical value for automatic AO detection for X-11 c Regression c Sigxrg - sigma limit for X-11 Regression (only done if td) c Dwt - Prior trading day weights (expressed as in X-11) c Dx11 - Trading day weights (expressed as in X-11) c----------------------------------------------------------------------- DOUBLE PRECISION Critxr,Sigxrg,Dwt,Dx11 c----------------------------------------------------------------------- DIMENSION Xaicrg(2),Dwt(7),Dx11(7),Begxrg(2),Endxrg(2),Begxot(2), & Endxot(2),Xeasvc(4) c----------------------------------------------------------------------- COMMON /cxropt/ Critxr,Sigxrg,Dwt,Dx11,Easgrp,Holgrp,Tdgrp,Stdgrp, & Xtdtst,Xaicrg,Xaicst,Begxrg,Endxrg,Fxprxr,Xdsp, & Begxot,Endxot,Xeasvc,Neasvx,Ixrgtd,Ixrghl x11reg.prm0000664006604000003110000000036614521201626012024 0ustar sun00315steps CHARACTER XRGDIC*91 INTEGER xrgidx,xrgptr,PXRG PARAMETER(PXRG=16) DIMENSION xrgptr(0:PXRG) PARAMETER(XRGDIC='variablesuserdatastartfileformatbprintsaveuserre &gsigmacriticalusermeanumstartumfileumformat') x11reg.var0000664006604000003110000000011114521201627012003 0ustar sun00315steps DATA xrgptr / 1,10,14,18,23,27,33,34,39,43,50,55,63,71,78,84,92 / x11srs.cmn0000664006604000003110000000077614521201627012043 0ustar sun00315stepsc----------------------------------------------------------------------- c Arrays containing the elemental components of an X-11 seasonal c adjustment c----------------------------------------------------------------------- DOUBLE PRECISION Sts,Stsi,Stc,Stci,Sti,Stc2 DIMENSION Sts(PLEN),Stsi(PLEN),Stc(PLEN),Stci(PLEN),Sti(PLEN), & Stc2(PLEN) c----------------------------------------------------------------------- COMMON /x11srs / Sts,Stsi,Stc,Stc2,Stci,Sti x11svl.i0000664006604000003110000000170014521201627011477 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for svltbl are of the form LSL c where the types are c----------------------------------------------------------------------- c M1 M1 c Q Q c Q without M2 Q2 c Moving seasonality ratio MSR c I/C Ratio ICR c F-test for stable seasonality, B1 FB1 c F-test for stable seasonality, D8 FD8 c F-test for moving seasonality, D8 MSF c----------------------------------------------------------------------- INTEGER LSLM1,LSLMSR,LSLICR,LSLFB1,LSLFD8,LSLMSF,LSLIDS,LSLALX, & LSLXTS PARAMETER( & LSLM1= 29,LSLMSR= 42,LSLICR= 43,LSLFB1= 44,LSLFD8= 45, & LSLMSF= 46,LSLIDS= 47,LSLALX= 48,LSLXTS= 49) x11tbl.i0000664006604000003110000001365114521201627011464 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c regression REG or RG c x11 X11 or XE c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c ao outlier factors AO c level change factors LC c td factors (regression) TD c holiday factors (regression) HOL c user defined regression factors USR c regarima outlier adj original series A11 c adjusted original B1 c modified original MO c final modified original E1 c mcd moving avgerage F1 c initial trend ITN c modified seasonally adjusted E2 c initial unmodified si b B3 c final modified irregular E3 c initial replacement si b B4 c initial modified si IMS c initial seasonal ISF c change in original E5 c initial seasonal adjusted ISA c change in seasonal adjusted E6 c preliminary trend PTN c henderson trend adjusted for extremes E7 c unmodified si b B8 c final unmodified si D8 c replacement si b B9 c modified si c C9 c final replacement si D9 c preliminary seasonal PSF c final seasonal D10 c final seasonal difference FSD c preliminary seasonal adjusted PSA c final seasonal adjusted D11 c robust seasonal adjusted E11 c final trend D12 c bias correction factors BCF c preliminary irregular PI c final irregular D13 c irregular wts IW c extreme values EV c holiday factors H1 c prior td A4 c irregular excluded from ts IRX c td factors (X11) TDF c combined adjustment factors D16 c combined adjustment differences FAD c combined td factos CTD c td adjusted original TDO c ftest, b1 B1F c ftest, hol H1F c x11 diagnostic summary F2 c q statistics F3 c yearly totals E4 c ftest, d8 D8F c moving seasonality ratio D9A c residual seasonality f-test RSF c automatic s.f. selection ASF c td by type of day TDY c modified original series plot B1P c series vrs. sa series plot E0 c ratios of series plot RA1 c ratios of sa series plot RA2 c final seasonal factors plot SFP c final seasonally adj. plot SAP c final trend component plot TRP c final irregular component plot IRP c----------------------------------------------------------------------- INTEGER LX11MO,LX11E1,LX11F1,LXEITN,LX11E2,LX11B3,LX11E3,LX11B4, & LXEIMS,LXEISF,LX11E5,LXEE5P,LXEISA,LX11E6,LXEE6P,LXEPTN, & LX11E7,LXEE7P,LX11B8,LX11D8,LXED8B,LX11E8,LXEE8P,LX11B9, & LX11C9,LX11D9,LXEB10,LXED10,LXEPSF,LXEFSD,LXEARS,LXESNS, & LXEPSA,LXED11,LXESAC,LXEE11,LXED12,LXETAL,LXEBCF,LXETAC, & LX11PI,LXED13,LXEPIR,LXEIAO,LX11IW,LX11EV,LX11H1,LXECHL, & LXED16,LXEPAF,LXEFAD,LXED18,LXEE18,LXEEEB,LXETDO,LXEB1F, & LX11F2,LX11F3,LX11E4,LXED8F,LXED9A,LXERSF,LXEASF,LXETDY, & LX11E0,LXERA1,LXERA2,LXESFP,LXESAP,LXETRP,LXEIRP,LXESAF, & LXETRF,LXEIWF PARAMETER( & LX11MO=119,LX11E1=121,LX11F1=122,LXEITN=123,LX11E2=126, & LX11B3=127,LX11E3=128,LX11B4=129,LXEIMS=130,LXEISF=132, & LX11E5=135,LXEE5P=136,LXEISA=137,LX11E6=140,LXEE6P=141, & LXEPTN=142,LX11E7=145,LXEE7P=146,LX11B8=147,LX11D8=148, & LXED8B=149,LX11E8=150,LXEE8P=151,LX11B9=152,LX11C9=153, & LX11D9=154,LXEB10=155,LXED10=157,LXEPSF=158,LXEFSD=159, & LXEARS=160,LXESNS=161,LXEPSA=162,LXED11=164,LXESAC=165, & LXEE11=166,LXED12=167,LXETAL=168,LXEBCF=169,LXETAC=170, & LX11PI=171,LXED13=173,LXEPIR=174,LXEIAO=175,LX11IW=176, & LX11EV=178,LX11H1=180,LXECHL=181,LXED16=182,LXEPAF=183, & LXEFAD=184,LXED18=185,LXEE18=186,LXEEEB=187,LXETDO=188, & LXEB1F=190,LX11F2=191,LX11F3=192,LX11E4=193,LXED8F=194, & LXED9A=195,LXERSF=196,LXEASF=197,LXETDY=198,LX11E0=199, & LXERA1=200,LXERA2=201,LXESFP=202,LXESAP=203,LXETRP=204, & LXEIRP=205,LXESAF=206,LXETRF=207,LXEIWF=208) x12hdr.f0000664006604000003110000011017014521201627011450 0ustar sun00315stepsC Last change: BCM 25 Nov 1998 12:19 pm **==x12hdr.f processed by SPAG 4.03F at 10:39 on 20 Oct 1994 SUBROUTINE x12hdr(Nfcst,Srsttl,Nsrscr,Ttlvec,Notc,Lx11,Lmodel, & Lseats,Lwidpr,Pos1,Nuspad,Nustad,Iqtype,Fcntyp, & Lam,Ciprob,Dattim,Cnstnt,Isrflw,Lognrm) IMPLICIT NONE c----------------------------------------------------------------------- c Print header page and title info for X-13ARIMA-SEATS c----------------------------------------------------------------------- LOGICAL F DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0,F=.false.) c----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'srslen.prm' c----------------------------------------------------------------------- INCLUDE 'build.prm' INCLUDE 'metadata.prm' INCLUDE 'model.prm' INCLUDE 'notset.prm' INCLUDE 'prior.prm' INCLUDE 'tbllog.prm' c----------------------------------------------------------------------- INCLUDE 'agr.cmn' INCLUDE 'error.cmn' INCLUDE 'force.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'metadata.cmn' INCLUDE 'missng.cmn' INCLUDE 'mq3.cmn' INCLUDE 'prior.cmn' INCLUDE 'rho.cmn' INCLUDE 'tbllog.cmn' INCLUDE 'title.cmn' INCLUDE 'units.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'x11log.cmn' INCLUDE 'x11msc.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'x11reg.cmn' c----------------------------------------------------------------------- INCLUDE 'mdltbl.i' INCLUDE 'cmptbl.i' INCLUDE 'x11tbl.i' INCLUDE 'spctbl.i' c----------------------------------------------------------------------- LOGICAL Lx11,Lmodel,Lseats,Lwidpr,Lognrm DOUBLE PRECISION Lam,Ciprob,Cnstnt INTEGER Nfcst,i,ie2,ie3,ie4,ie5,ie6,ie7,Notc,j,nttl,ipos, & Nsrscr,nstr,ie7a,Pos1,lnlen,msp,linsp,nxrg,nastr, & nxrg2,Nuspad,Nustad,Fcntyp,ikey,Iqtype,Isrflw,ival CHARACTER qqmm*(9),runs*(26),num*(2),mmqq*(7),malo*(14),avg*(8), & avg2*(4),xhdr*(LINLEN),Ttlvec*(80),cmonth*(3),cqtr*(3), & Dattim*(24),mqcds*(3),r*(11),pcd*(15),sf*(4),cm2*(6), & xb*(LINLEN),str*(10),Srsttl*(*),xrgstr*(50),adjstr*(20), & outstr*(25),thisky*(LINLEN),thisvl*(LINLEN) DIMENSION qqmm(3),runs(4),num(4),mmqq(3),malo(5), & avg(7),avg2(8),Ttlvec(10),cmonth(12),cqtr(4),mqcds(3), & r(2),pcd(2),sf(PSP),cm2(12),Pos1(2) c----------------------------------------------------------------------- INTEGER nblank LOGICAL dpeq EXTERNAL nblank,dpeq c----------------------------------------------------------------------- DATA pcd/'percent change ','differences '/ DATA qqmm/'monthly ','quarterly',' '/ DATA runs/ & 'seasonal adjustment ','summary measures ', & 'trend estimation ','regARIMA model estimation '/ DATA num/'st','nd','rd','th'/ DATA mmqq/'month ','quarter','period '/ DATA malo/'multiplicative','additive ','logarithmic ', & 'pseudo-add ','auto-mode '/ DATA avg/'3x3 ','3x5 ','3x9 ','3x15 ','Stable ', & 'MSR ','3x1 '/ DATA avg2/'def ','3x3 ','3x5 ','3x9 ','3x15','Stbl','MSR ','3x1 '/ DATA cmonth/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', & 'Oct','Nov','Dec'/ DATA cm2/'uary ','ruary ','ch ','il ',' ','e ', & 'y ','ust ','tember','ober ','ember ','ember '/ DATA cqtr/'1st','2nd','3rd','4th'/ DATA mqcds/'mcd','qcd',' '/ DATA r/'ratios ','differences'/ c----------------------------------------------------------------------- IF(Ny.eq.1)THEN ie2=0 ELSE IF(Ny.eq.12)THEN ie2=1 ELSE IF(Ny.eq.4)THEN ie2=2 ELSE ie2=3 END IF IF(Lx11)THEN ie3=Kfulsm+1 ELSE IF(Lseats)THEN ie3=1 ELSE ie3=4 END IF ie4=0 ie5=Pos1(MO) IF(ie5.gt.4)ie5=4 ie6=Lstmo IF(ie6.gt.4)ie6=4 ie7=Muladd+1 IF(Psuadd)ie7=4 IF(Fcntyp.eq.0)ie7=5 c----------------------------------------------------------------------- IF(ie2.gt.0)THEN Qm=qqmm(ie2) Moqu=mmqq(ie2) Mqcd=mqcds(ie2) ELSE Qm=qqmm(3) Moqu=' ' Mqcd=mqcds(3) END IF IF(ie7.eq.5)THEN Pcdif=pcd(2) Rad=r(2) ELSE ie7a=2-mod(ie7,2) IF(Psuadd)ie7a=2 Pcdif=pcd(ie7a) Rad=r(ie7a) END IF IF(Kfulsm.lt.2.and.Lx11)THEN sf(1)=avg2(Lterm+1) DO i=2,Ny IF(Lterm.gt.0.and.Lter(i).eq.0)THEN ie4=ie4+1 ELSE IF(Lter(i).ne.Lterm)THEN ie4=Lter(i)+ie4 END IF sf(i)=avg2(Lter(i)+1) END DO END IF c----------------------------------------------------------------------- CALL setchr(' ',LINLEN,xb) nttl=nblank(Ttlvec(1)) Ntitle=0 IF(Nsrscr.gt.0)THEN IF(xb(1:Nsrscr).eq.Srsttl(1:Nsrscr))THEN Nsrscr=0 ELSE Title=Srsttl(1:Nsrscr)//xb(1:(80-Nsrscr)) Ntitle=Nsrscr END IF END IF IF(Ntitle.eq.0)THEN IF(nttl.gt.0)THEN Title=Ttlvec(1)(1:nttl)//xb(1:(80-nttl)) Ntitle=nttl ELSE IF(Nser.gt.0)THEN Ntitle=8+Nser+NPRGNM IF(Ntitle.gt.79)THEN Title=PRGNAM//' run of '//Serno(1:Nser-(Ntitle-80)) Ntitle=80 ELSE Title=PRGNAM//' run of '//Serno(1:Nser)//xb(1:(80-Ntitle)) END IF ELSE Ntitle=NPRGNM Title=PRGNAM//xb(1:(80-Ntitle)) END IF END IF c----------------------------------------------------------------------- IF(Savtab(LSRSHD))THEN CALL svdttm(Nform,Dattim) WRITE(Nform,1790)VERNUM,BUILD 1790 FORMAT('version: ',a,/,'build: ',a,/,'output: out') END IF IF(Prttab(LSRSHD))THEN c----------------------------------------------------------------------- lnlen=80 msp=7 linsp=8 IF(Lwidpr)THEN lnlen=LINLEN msp=msp+24 linsp=13 END IF c----------------------------------------------------------------------- i=(lnlen-49)/2 WRITE(xhdr,1010)xb(1:i) 1010 FORMAT(a,'U. S. Department of Commerce, U. S. Census Bureau') IF(.not.Lcmpaq)WRITE(Mt1,1020)'1' WRITE(Mt1,1020)xhdr(1:nblank(xhdr)) 1020 FORMAT(/,a) c----------------------------------------------------------------------- CALL setchr(' ',LINLEN,xhdr) IF(Ny.eq.12.or.Ny.eq.4)THEN i=(lnlen-(NPRGNM+nblank(Qm)+nblank(runs(ie3))+10))/2 WRITE(xhdr,1030)xb(1:i),PRGNAM,Qm(1:nblank(Qm)), & runs(ie3)(1:nblank(runs(ie3))) ELSE i=(lnlen-(NPRGNM+nblank(runs(ie3))+10))/2 WRITE(xhdr,1029)xb(1:i),PRGNAM,runs(ie3)(1:nblank(runs(ie3))) END IF 1029 FORMAT(a,a,1x,a,' Method,') 1030 FORMAT(a,a,1x,a,1x,a,' Method,') WRITE(Mt1,1020)xhdr(1:nblank(xhdr)) i=(lnlen-(23+nblank(VERNUM)+nblank(BUILD)))/2 WRITE(Mt1,1031)xb(1:i),VERNUM,BUILD 1031 FORMAT(a,'Release Version ',a,' Build ',a) IF(.not.Lcmpaq)WRITE(Mt1,'(/)') WRITE(Mt1,1040)xb(1:(msp+4)),xb(1:(msp+6)),xb(1:(msp+10)), & xb(1:(msp+15)),xb(1:(msp+5)),xb(1:msp), & xb(1:msp),xb(1:(msp+9)),xb(1:(msp+8)), & xb(1:(msp+3)),xb(1:(msp+2)),PRGNAM,xb(1:(msp+3)), & xb(1:(msp+5)),xb(1:(msp+7)),xb(1:(msp+10)), & xb(1:(msp+15)) 1040 FORMAT(a,'This software application provides an enhanced ', & 'version of',/, & a,'Statistics Canada''s X-11-ARIMA extension (Dagum, ', & '1980)',/, & a,'of the X-11 variant of the Census Method II of',/, & a,'Shiskin, Young and Musgrave (1967).',// & a,'It also provides an ARIMA model-based method ', & 'following',/, & a,'Hillmer and Tiao (1982) and Burman (1980) that is ', & 'very similar',/, & a,'to the update of the method of SEATS (Gomez and ', & 'Maravall, 1996)',/, & a,'produced at the Bank of Spain by G. Caporello and',/, & a,'A. Maravall for TSW (Caporello and Maravall, 2004).',/, & a,'The present application includes additional ', & 'enhancements.',//, & a,a,' includes an automatic ARIMA model selection ', & 'procedure',/, & a,'based largely on the procedure of Gomez and Maravall ', & '(1998)',/, & a,'as implemented in TRAMO (1996) and subsequent ', & 'revisions.',//, & a,'Primary Programmers: Brian Monsell, Mark Otto and,',/, & a,'for the ARIMA model-based signal extraction,',/, & a,'Gianluca Caporello and Victor Gomez',//) c----------------------------------------------------------------------- WRITE(Mt1,1050)Title(1:nblank(Title)) IF(Nser.gt.0)WRITE(Mt1,1060)Serno(1:Nser) IF(Dattim(1:2).ne.' ')WRITE(Mt1,1070)Dattim(2:24) 1050 FORMAT(5x,'Series Title- ',a) 1060 FORMAT(5x,'Series Name- ',a) 1070 FORMAT(5x,a) c----------------------------------------------------------------------- IF(Notc.gt.0)THEN DO i=1,Notc WRITE(Mt1,1080)Ttlvec(i) 1080 FORMAT(24x,a) END DO END IF c----------------------------------------------------------------------- IF(Ny.eq.4.or.Ny.eq.12)THEN WRITE(Mt1,1090)xb(1:linsp),Pos1(MO),num(ie5), & Moqu(1:nblank(Moqu)),Pos1(YR),Lstmo,num(ie6), & Moqu(1:nblank(Moqu)),Lstyr 1090 FORMAT(/,a,'-Period covered- ',i2,a2,1x,a,',',i4,' to ',i2,a2, & 1x,a,',',i4) ELSE IF (Ny.eq.1) THEN WRITE(Mt1,1091)xb(1:linsp),Pos1(YR),Lstyr 1091 FORMAT(/,a,'-Period covered- ',i4,' to ',i4) ELSE WRITE(Mt1,1092)xb(1:linsp),Pos1(YR),Pos1(MO),Lstyr,Lstmo 1092 FORMAT(/,a,'-Period covered- ',i4,'.',i2.2,' to ',i4,'.',i2.2) END IF c----------------------------------------------------------------------- IF(Lx11)THEN WRITE(Mt1,1100)xb(1:linsp),malo(ie7)(1:nblank(malo(ie7))), & runs(ie3)(1:nblank(runs(ie3))) 1100 FORMAT(a,'-Type of run - ',a,1x,a) IF(.not.Lcmpaq)WRITE(Mt1,'()') c----------------------------------------------------------------------- WRITE(Mt1,1110)xb(1:linsp),Sigml,Sigmu 1110 FORMAT(a,'-Sigma limits for graduating extreme values are ', & f4.1,' and ',f4.1,' .') c----------------------------------------------------------------------- c IF(Kexopt.eq.1)WRITE(Mt1,1120)xb(1:linsp) c 1120 FORMAT(a,'-Modify extreme values before computing the B7 ', c & 'trend cycle curve.') c----------------------------------------------------------------------- IF(Kfulsm.lt.2)THEN c----------------------------------------------------------------------- IF(ie4.ne.0)THEN WRITE(Mt1,1150)xb(1:linsp) 1150 FORMAT(a,'-The following moving averages were selected for ', & 'the seasonal factor curves:') linsp=linsp+5 IF(Ny.eq.4)WRITE(Mt1,1160)xb(1:linsp),(cqtr(i),i=1,4), & xb(1:linsp),(sf(j),j=1,4) IF(Ny.eq.12)WRITE(Mt1,1170)xb(1:linsp),(cmonth(i),i=1,12), & xb(1:linsp),(sf(j),j=1,12) linsp=linsp-5 1160 FORMAT(a,4(1x,a3,1x),/,a,4(1x,a4)) 1170 FORMAT(a,12(1x,a3,1x),/,a,12(1x,a4)) ELSE IF(Lterm.eq.0)THEN WRITE(Mt1,1180)xb(1:linsp),xb(1:(linsp+1)) 1180 FORMAT(a,'-3x3 moving average used in section 1 of each ', & 'iteration,',/,a,'3x5 moving average in section 2 of ', & 'each iteration.') ELSE IF(Lterm.eq.6)THEN WRITE(Mt1,1190)xb(1:linsp),xb(1:(linsp+1)),xb(1:(linsp+1)) 1190 FORMAT(a,'-3x3 moving average used in section 1 of each ', & 'iteration, ',/,a,'3x5 moving average in section 2', & ' of iterations B and C,'/,a, & 'moving average for final seasonal factors chosen by ', & 'Global MSR.') ELSE WRITE(Mt1,1200)xb(1:linsp),avg(Lterm)(1:nblank(avg(Lterm))) 1200 FORMAT(a,'-a ',a,' moving average selected for the ', & 'seasonal factor curves.') END IF END IF c----------------------------------------------------------------------- IF(Ktcopt.gt.0)THEN WRITE(Mt1,1210)xb(1:linsp),Ktcopt 1210 FORMAT(a,'-Moving average for the variable trend cycle ', & 'routine is a ',i3,'-term Henderson') END IF END IF c----------------------------------------------------------------------- IF(Kfmt.gt.0)THEN CALL setchr(' ',20,adjstr) IF(Ny.eq.12.or.Ny.eq.4)THEN WRITE(adjstr,1219)Qm(1:nblank(Qm)) 1219 FORMAT(a,' adjustment') nastr=18 IF(Ny.eq.4)nastr=nastr+2 ELSE adjstr(1:10)='adjustment' nastr=10 END IF IF(Nustad.gt.0.and.Nuspad.gt.0)THEN WRITE(Mt1,1220)xb(1:linsp),adjstr(1:nastr), & '(temporary and permanent)' ELSE IF(Nustad.gt.0)THEN WRITE(Mt1,1220)xb(1:linsp),adjstr(1:nastr),'(temporary)' ELSE IF(Nuspad.gt.0)THEN WRITE(Mt1,1220)xb(1:linsp),adjstr(1:nastr),'(permanent)' END IF 1220 FORMAT(a,'-Prior ',a,' ',a,' factors.') END IF IF(.not.dpeq(Cnstnt,DNOTST))THEN ipos=1 CALL dtoc(Cnstnt,outstr,ipos) WRITE(Mt1,1221)xb(1:linsp),outstr(1:(ipos-1)) 1221 FORMAT(a,'-Constant value added to series (',a,')') END IF c----------------------------------------------------------------------- IF(Lx11)THEN IF(Kswv.eq.1)THEN WRITE(Mt1,1230)xb(1:linsp) 1230 FORMAT(a,'-Prior trading day adjustment.') c WRITE(Mt1,1230)xb(1:linsp),Out(1:(nblank(Out)+1)), c & mmqq(1)(1:nblank(mmqq(1))) c 1230 FORMAT(a,'-Prior trading day adjustment with',a,'length of ', c & a,' adjustment.') END IF c----------------------------------------------------------------------- IF(Ixreg.gt.0)THEN c----------------------------------------------------------------------- CALL wrtdat(Begxrg,Ny,str,nstr) nxrg=0 IF(Tdgrp.gt.0.and.Holgrp.gt.0)THEN xrgstr='Trading day and holiday' nxrg=23 ELSE IF(Tdgrp.gt.0)THEN xrgstr='Trading day' nxrg=11 ELSE IF(Stdgrp.gt.0)THEN xrgstr='Stock trading day' nxrg=17 ELSE IF(Holgrp.gt.0)THEN xrgstr='Holiday' nxrg=7 END IF IF(nxrg.gt.0)THEN IF(Otlxrg)THEN IF(Critxr.gt.0)THEN IF(Lwidpr)THEN WRITE(Mt1,1240)xb(1:linsp),xrgstr(1:nxrg),str(1:nstr), & xb(1:linsp),Critxr 1240 FORMAT(a,'-',a,' irregular regression computed ', & 'starting ',a,' with AO outliers identified using', & ' a',/,a,'critical value of ',f5.2,'.') ELSE WRITE(Mt1,1241)xb(1:linsp),xrgstr(1:nxrg),str(1:nstr), & xb(1:linsp),Critxr 1241 FORMAT(a,'-',a,' irregular regression computed ', & 'starting ',a,/,a,' with AO outliers identified ', & 'using a critical value of ',f5.2,'.') END IF ELSE IF(Lwidpr)THEN WRITE(Mt1,1242)xb(1:linsp),xrgstr(1:nxrg),str(1:nstr), & xb(1:linsp) 1242 FORMAT(a,'-',a,' irregular regression computed ', & 'starting ',a,' with AO outliers identified using', & ' a',/,a,'default critical value.') ELSE WRITE(Mt1,1243)xb(1:linsp),xrgstr(1:nxrg),str(1:nstr), & xb(1:linsp) 1243 FORMAT(a,'-',a,' irregular regression computed ', & 'starting ',a,/,a,' with AO outliers identified ', & 'using a default critical value.') END IF END IF ELSE IF(Sigxrg.gt.ZERO)THEN IF(Lwidpr)THEN WRITE(Mt1,1244)xb(1:linsp),xrgstr(1:nxrg),str(1:nstr),Sigxrg 1244 FORMAT(a,'-',a,' irregular regression computed ', & 'starting ',a,' excluding irregular values outside ', & f5.2,'-sigma limits.') ELSE WRITE(Mt1,1245)xb(1:linsp),xrgstr(1:nxrg),str(1:nstr), & xb(1:linsp),Sigxrg 1245 FORMAT(a,'-',a,' irregular regression computed ', & 'starting ',a,/,a,' excluding irregular values ', & 'outside ',f5.2,'-sigma limits.') END IF ELSE WRITE(Mt1,1246)xb(1:linsp),xrgstr(1:nxrg),str(1:nstr) 1246 FORMAT(a,'-',a,' irregular regression computed ', & 'starting ',a) END IF END IF c----------------------------------------------------------------------- IF(Tdgrp.gt.0)THEN IF(Axrgtd)THEN IF(Ixreg.eq.2)THEN WRITE(Mt1,1250)xb(1:linsp),'Trading day',' ', & ' as prior factors.' ELSE WRITE(Mt1,1250)xb(1:linsp),'Trading day',' ','.' END IF ELSE WRITE(Mt1,1250)xb(1:linsp),'Trading day',' not','.' END IF END IF IF(Stdgrp.gt.0)THEN IF(Axrgtd)THEN IF(Ixreg.eq.2)THEN WRITE(Mt1,1250)xb(1:linsp),'Stock trading day',' ', & ' as prior factors.' ELSE WRITE(Mt1,1250)xb(1:linsp),'Stock Trading day',' ','.' END IF ELSE WRITE(Mt1,1250)xb(1:linsp),'Stock Trading day',' not','.' END IF END IF IF(Holgrp.gt.0)THEN IF(Axrghl)THEN IF(Ixreg.eq.2)THEN WRITE(Mt1,1250)xb(1:linsp),'Holiday',' ', & ' as prior factors.' ELSE WRITE(Mt1,1250)xb(1:linsp),'Holiday',' ','.' END IF ELSE WRITE(Mt1,1250)xb(1:linsp),'Holiday',' not','.' END IF END IF 1250 FORMAT(a,'-',a,' irregular regression estimates',a,'applied',a) c----------------------------------------------------------------------- nxrg=0 IF(Xeastr.or.Xuser.or.Xtdtst.gt.0)THEN IF(Xtdtst.eq.2)THEN xrgstr((nxrg+1):(nxrg+17))='stock trading day' nxrg=nxrg+17 ELSE IF(Xtdtst.gt.0)THEN xrgstr((nxrg+1):(nxrg+11))='trading day' nxrg=nxrg+11 END IF IF(Xeastr)THEN IF(nxrg.gt.0)THEN xrgstr((nxrg+1):(nxrg+1))=',' nxrg=nxrg+1 END IF xrgstr((nxrg+1):(nxrg+6))='Easter' nxrg=nxrg+6 END IF IF(Xuser)THEN IF(nxrg.gt.0)THEN xrgstr((nxrg+1):(nxrg+1))=',' nxrg=nxrg+1 END IF xrgstr((nxrg+1):(nxrg+12))='user-defined' nxrg=nxrg+12 END IF WRITE(Mt1,1280)xb(1:linsp),xrgstr(1:nxrg) 1280 FORMAT(a,'-Irregular regression AIC test performed for ',a, & ' regressors.') END IF END IF c----------------------------------------------------------------------- IF(Khol.eq.1)THEN WRITE(Mt1,1290)xb(1:linsp) 1290 FORMAT(a,'-Prior holiday adjustment factors estimated ', & 'for:') IF(Keastr.eq.1)WRITE(Mt1,1300)xb(1:(linsp+3)) 1300 FORMAT(a,'- Easter') END IF c----------------------------------------------------------------------- IF(Nuspad.gt.0)WRITE(Mt1,1350)xb(1:linsp) 1350 FORMAT(a,'-Permanent prior adjustment factors will be applied', & ' directly to the final seasonally adjusted series') IF(Finhol.AND.(Adjhol.eq.1.or.Axrghl.or.Khol.eq.1)) & WRITE(Mt1,1360)xb(1:linsp) 1360 FORMAT(a,'-Holiday adjustment factors applied directly to the ', & 'final seasonally adjusted series') c----------------------------------------------------------------------- IF(Issap.gt.0)THEN WRITE(Mt1,1370)xb(1:linsp) 1370 FORMAT(a,'-Sliding spans analysis performed') END IF c----------------------------------------------------------------------- IF(.not.(Prttab(LSPCS0).or.Prttab(LSPCS1).or.Prttab(LSPCS2).or. & Prttab(LSPS1I).or.Prttab(LSPS2I).or.Prttab(LSPS0C)))THEN IF(.not.Lcmpaq)WRITE(Mt1,1380)xb(1:linsp),xb(1:(linsp+1)) 1380 FORMAT(a,'-Spectral estimates of original series, table ', & 'D11 and table E3 will be searched for ',/,a, & 'signficant seasonal and trading day peaks') ELSE IF(Thtapr.gt.0)THEN WRITE(Mt1,1390)xb(1:linsp),Thtapr 1390 FORMAT(a,'-Spectral plots generated with rho for Tukey-', & 'Hanning taper = ',f6.3) ELSE IF(.not.Lcmpaq)WRITE(Mt1,1400)xb(1:linsp) 1400 FORMAT(a,'-Spectral plots generated for selected series') END IF IF(Pos1(YR).ne.Bgspec(YR).or.Pos1(MO).ne.Bgspec(MO))THEN CALL wrtdat(Bgspec,Ny,str,nstr) IF(Lfatal)RETURN IF(.not.Lcmpaq)WRITE(Mt1,1410)xb(1:linsp),str(1:nstr) 1410 FORMAT(a,'-Spectral plots generated for series starting in ',a) END IF c----------------------------------------------------------------------- IF(Imad.eq.1)WRITE(Mt1,1420)xb(1:linsp) 1420 FORMAT(a,'-X-11 outlier detection procedure uses moving median', & ' absolute deviations') IF(Imad.eq.2)WRITE(Mt1,1430)xb(1:linsp) 1430 FORMAT(a,'-X-11 outlier detection procedure uses moving median', & ' absolute deviations of the log data') IF(Imad.eq.3)WRITE(Mt1,1440)xb(1:linsp) 1440 FORMAT(a,'-X-11 outlier detection procedure uses tau ', & 'adjustment to moving median absolute deviations') IF(Imad.eq.4)WRITE(Mt1,1450)xb(1:linsp) 1450 FORMAT(a,'-X-11 outlier detection procedure uses tau ', & 'adjustment to moving median absolute deviations of ', & 'the log data') c----------------------------------------------------------------------- IF(Ishrnk.eq.1)WRITE(Mt1,1710)xb(1:linsp),'global' IF(Ishrnk.eq.2)WRITE(Mt1,1710)xb(1:linsp),'local' 1710 FORMAT(a,'-X-11 seasonal factors adjusted using ',a, & 'shrinkage factors from Miller and Williams (2003)') c----------------------------------------------------------------------- ELSE IF(Lmodel)THEN IF(.not.Prttab(LSPCS0))THEN IF(.not.Lcmpaq)WRITE(Mt1,1460)xb(1:linsp) 1460 FORMAT(a,'-Spectral estimates of original series will be ', & 'searched for signficant trading day peaks') ELSE IF(Thtapr.gt.0)THEN WRITE(Mt1,1470)xb(1:linsp),Thtapr 1470 FORMAT(a,'-Spectral plot of the original series will be ', & 'generated with rho for Tukey-Hanning taper = ',f6.3) ELSE IF(.not.Lcmpaq)WRITE(Mt1,1480)xb(1:linsp) 1480 FORMAT(a,'-Spectral plot of the original series generated') END IF END IF c----------------------------------------------------------------------- IF(Lseats)THEN WRITE(Mt1,1800)xb(1:linsp) 1800 FORMAT(a,'-SEATS model based seasonal adjustment performed.') END IF c----------------------------------------------------------------------- IF(Iyrt.gt.0)THEN WRITE(Mt1,1130)xb(1:linsp) 1130 FORMAT(a,'-Modify the D11. series to make the yearly totals ', & 'of the seasonally') IF(Iftrgt.eq.0)THEN WRITE(Mt1,1131) 1131 FORMAT(14x,'adjusted series agree with the original series.') ELSE IF(Iftrgt.eq.1)THEN WRITE(Mt1,1132) 1132 FORMAT(14x,'adjusted series agree with the calendar adjusted', & ' series.') ELSE IF(Iftrgt.eq.2)THEN WRITE(Mt1,1133) 1133 FORMAT(14x,'adjusted series agree with the permanent prior ', & 'adjusted',/,14x,'series.') ELSE IF(Iftrgt.eq.3)THEN WRITE(Mt1,1134) 1134 FORMAT(14x,'adjusted series agree with the calendar and ', & 'permanent prior',/,14x,'adjusted series.') END IF IF(Iyrt.eq.1)THEN WRITE(Mt1,1135)xb(1:linsp) 1135 FORMAT(a,'-Denton method used.') ELSE IF(Iyrt.eq.2)THEN WRITE(Mt1,1136)xb(1:linsp),Lamda,Rol 1136 FORMAT(a,'-Regression method used, with lambda = ',f10.7, & ', rho = ',f10.7,'.') END IF c----------------------------------------------------------------------- IF(Begyrt.gt.1)THEN IF(Ny.eq.12)WRITE(Mt1,1140)xb(1:linsp),Moqu(1:nblank(Moqu)), & cmonth(Begyrt),cm2(Begyrt) IF(Ny.eq.4)WRITE(Mt1,1140)xb(1:linsp),Moqu,cqtr(Begyrt), & ' Quarter' 1140 FORMAT(a,'-First ',a,' of fiscal year set to be ',a,a) END IF END IF c----------------------------------------------------------------------- IF(Lnoprt)WRITE(Mt1,1520)xb(1:linsp) 1520 FORMAT(a,'-Printout suppressed. Only user-specified tables and', & ' plots will be printed out.') END IF c----------------------------------------------------------------------- IF(Ixreg.eq.2.or.Khol.eq.1)THEN WRITE(Mt1,1780) 1780 FORMAT(//,' Tables labeled "First pass" are from an initial', & ' seasonal adjustment used to estimate ',/, & ' irregular regression and/or X-11 Easter effects.') END IF c----------------------------------------------------------------------- IF (Divpwr.ne.NOTSET) THEN WRITE(Mt1,1770)Divpwr 1770 FORMAT(//,' All values of original series divided by 10 ** ', & i2,' in this run.') END IF c----------------------------------------------------------------------- IF(Savtab(LSRSHD))THEN IF(Nsrscr.gt.0)THEN WRITE(Nform,1600)'srstit',Srsttl(1:Nsrscr) ELSE WRITE(Nform,1600)'srstit',Title(1:Ntitle) END IF WRITE(Nform,1600)'srsnam',Serno c----------------------------------------------------------------------- WRITE(Nform,1610)'freq',Ny c----------------------------------------------------------------------- IF(Ny.eq.12.or.Ny.eq.4)THEN WRITE(Nform,1550)Pos1(MO),num(ie5),Moqu(1:nblank(Moqu)), & Pos1(YR),Lstmo,num(ie6),Moqu(1:nblank(Moqu)), & Lstyr ELSE IF(Ny.eq.1)THEN WRITE(Nform,1551)Pos1(YR),Lstyr * WRITE(Nform,1553)Bgspec(YR) ELSE WRITE(Nform,1550)Pos1(MO),num(ie5),'period',Pos1(YR), & Lstmo,num(ie6),'period',Lstyr * ie5=Bgspec(MO) * IF(ie5.gt.4)ie5=4 * WRITE(Nform,1552)Bgspec(MO),num(ie5),'period',Bgspec(YR) END IF WRITE(Nform,1610)'nobs',Nspobs c----------------------------------------------------------------------- IF(Isrflw.eq.1)THEN WRITE(Nform,1600)'datatype','flow' ELSE IF(Isrflw.eq.2)THEN WRITE(Nform,1600)'datatype','stock' END IF c----------------------------------------------------------------------- ipos=1 IF(dpeq(Cnstnt,DNOTST))THEN WRITE(Nform,1630)'constant',ZERO ELSE WRITE(Nform,1630)'constant',Cnstnt END IF c----------------------------------------------------------------------- IF(Lmodel)THEN CALL prtnfn(Fcntyp,Lam,1) WRITE(Nform,1610)'nfcst',Nfcst IF(Nfcst.gt.0)WRITE(Nform,1620)'ciprob',Ciprob IF(Lognrm)THEN WRITE(Nform,1600)'lognormal','yes' ELSE WRITE(Nform,1600)'lognormal','no' END IF WRITE(Nform,1630)'mvval',Mvval IF(Iqtype.eq.0)THEN WRITE(Nform,1600)'iqtype','ljungbox' ELSE WRITE(Nform,1600)'iqtype','boxpierce' END IF END IF IF(Lx11)THEN WRITE(Nform,1660)'samode',malo(ie7)(1:nblank(malo(ie7))), & runs(ie3)(1:nblank(runs(ie3))) c----------------------------------------------------------------------- WRITE(Nform,1640)'siglim',Sigml,Sigmu c----------------------------------------------------------------------- c IF(Kexopt.eq.1)WRITE(Nform,1580) c 1580 FORMAT('strike:') c----------------------------------------------------------------------- IF(Iyrt.gt.0)THEN WRITE(Nform,1600)'adjtot','yes' WRITE(Nform,1610)'adjtotstart',Begyrt IF(Iftrgt.eq.0)THEN WRITE(Nform,1600)'adjtottarget','original' ELSE IF(Iftrgt.eq.1)THEN WRITE(Nform,1600)'adjtottarget','original' ELSE IF(Iftrgt.eq.2)THEN WRITE(Nform,1600)'adjtottarget','pprioradj' ELSE WRITE(Nform,1600)'adjtottarget','both' END IF 1592 FORMAT('adjtottarget: ',a) IF(Iyrt.gt.1)THEN WRITE(Nform,1600)'adjtottype','regression' WRITE(Nform,1620)'adjtotlambda',Lamda WRITE(Nform,1620)'adjtotrho',Rol IF(Mid.eq.0)THEN WRITE(Nform,1600)'adjtotmode','ratio' ELSE WRITE(Nform,1600)'adjtotmode','diff' END IF IF(Lfctfr)THEN WRITE(Nform,1600)'adjtotfct','yes' ELSE WRITE(Nform,1600)'adjtotfct','no' END IF ELSE WRITE(Nform,1600)'adjtottype','denton' END IF ELSE WRITE(Nform,1600)'adjtot','no' END IF c----------------------------------------------------------------------- IF(Lterm.eq.NOTSET)THEN WRITE(Nform,1600)'seasonalma','None' ELSE IF(Ny.eq.4)WRITE(Nform,1650)'seasonalma',(sf(j),j=1,4) IF(Ny.eq.12)WRITE(Nform,1650)'seasonalma',(sf(j),j=1,12) END IF c----------------------------------------------------------------------- IF(Ktcopt.gt.0)THEN WRITE(Nform,1610)'trendma',Ktcopt ELSE WRITE(Nform,1600)'trendma','default' END IF c----------------------------------------------------------------------- IF(Kswv.eq.1)WRITE(Nform,1600)'priortd','yes' c IF(Kswv.eq.1)WRITE(Nform,1660)Out(1:nblank(Out)) c 1660 FORMAT('priortd: with',a) c----------------------------------------------------------------------- IF(Ixreg.gt.0)THEN WRITE(Nform,1600)'x11regress','yes' IF(Otlxrg)THEN WRITE(Nform,1600)'x11regressextreme','autoao' WRITE(Nform,1620)'x11irrcrtval',Critxr ELSE IF(Sigxrg.gt.0)THEN WRITE(Nform,1600)'x11regressextreme','sigma' WRITE(Nform,1620)'x11irrsiglim',Sigxrg ELSE WRITE(Nform,1600)'x11regressextreme','none' END IF ELSE WRITE(Nform,1600)'x11regress','no' END IF c----------------------------------------------------------------------- IF(Khol.eq.1)WRITE(Nform,1600)'x11easter','yes' c----------------------------------------------------------------------- IF(Imad.eq.0)WRITE(Nform,1600)'x11otl','stderr' IF(Imad.eq.1)WRITE(Nform,1600)'x11otl','mad' IF(Imad.eq.2)WRITE(Nform,1600)'x11otl','madlog' IF(Imad.eq.3)WRITE(Nform,1600)'x11otl','taumad' IF(Imad.eq.4)WRITE(Nform,1600)'x11otl','taumadlog' c----------------------------------------------------------------------- IF(Ishrnk.eq.0)WRITE(Nform,1600)'shrink','none' IF(Ishrnk.eq.1)WRITE(Nform,1600)'shrink','global' IF(Ishrnk.eq.2)WRITE(Nform,1600)'shrink','local' ELSE IF(Lseats)THEN WRITE(Nform,1600)'samode','SEATS seasonal adjustment' ELSE WRITE(Nform,1600)'samode','none' END IF END IF IF (Divpwr.ne.NOTSET) THEN WRITE(Nform,1610)'divpower',Divpwr END IF c----------------------------------------------------------------------- IF(Ny.eq.12)THEN ie5=Bgspec(MO) IF(ie5.gt.4)ie5=4 WRITE(Nform,1600)'spectrum','yes' WRITE(Nform,1552)Bgspec(MO),num(ie5),Moqu(1:nblank(Moqu)), & Bgspec(YR) IF(Spctyp.eq.0)THEN WRITE(Nform,1600)'spectype','AR-spectrum' ELSE WRITE(Nform,1600)'spectype','periodogram' END IF IF(Ldecbl)THEN WRITE(Nform,1600)'decibel','yes' ELSE WRITE(Nform,1600)'decibel','no' END IF IF(Lrbstsa)THEN WRITE(Nform,1600)'specrobustsa','yes' ELSE WRITE(Nform,1600)'specrobustsa','no' END IF * IF(Spcl10)THEN * WRITE(Nform,1600)'speclog10','yes' * ELSE * WRITE(Nform,1600)'speclog10','no' * END IF IF(Spcsrs.eq.0)THEN WRITE(Nform,1600)'specseries','original' ELSE IF(Spcsrs.eq.1)THEN WRITE(Nform,1600)'specseries','outlieradjoriginal' ELSE IF(Spcsrs.eq.2)THEN WRITE(Nform,1600)'specseries','adjoriginal' ELSE IF(Spcsrs.eq.3)THEN WRITE(Nform,1600)'specseries','modoriginal' END IF IF(Lprsfq)THEN WRITE(Nform,1600)'showseasonalfreq','yes' ELSE WRITE(Nform,1600)'showseasonalfreq','no' END IF IF(Mxarsp.eq.NOTSET)THEN WRITE(Nform,1610)'specmaxar',30 ELSE WRITE(Nform,1610)'specmaxar',Mxarsp END IF IF(Lfqalt)THEN WRITE(Nform,1600)'altfreq','yes' ELSE WRITE(Nform,1600)'altfreq','no' END IF IF(Svallf)THEN WRITE(Nform,1600)'saveallspecfreq','yes' ELSE WRITE(Nform,1600)'saveallspecfreq','no' END IF CALL svfreq(Ny,Svallf) WRITE(Nform,1630)'peaklocal',Plocal WRITE(Nform,1610)'peakwd',Peakwd WRITE(Nform,1620)'siglevel',Spclim ELSE WRITE(Nform,1600)'spectrum','no' END IF c----------------------------------------------------------------------- IF(Iag.ge.0)THEN IF(Iag.eq.0)THEN WRITE(Nform,1600)'comptype','add' ELSE IF(Iag.eq.1) THEN WRITE(Nform,1600)'comptype','sub' ELSE IF(Iag.eq.2) THEN WRITE(Nform,1600)'comptype','mult' ELSE IF(Iag.eq.3) THEN WRITE(Nform,1600)'comptype','div' END IF WRITE(Nform,1620)'compwt',W END IF c----------------------------------------------------------------------- END IF c----------------------------------------------------------------------- c Write out user defined metadata. c----------------------------------------------------------------------- IF(Hvmtdt)THEN DO i=1,Nval CALL getstr(Keystr,Keyptr,Nkey,i,thisky,ikey) IF(Lfatal)RETURN CALL getstr(Valstr,Valptr,Nval,i,thisvl,ival) IF(Lfatal)RETURN WRITE(Nform,1600)'metadata.'//thisky(1:ikey),thisvl(1:ival) END DO END IF c----------------------------------------------------------------------- 1550 FORMAT('span: ',i2,a2,1x,a,',',i4,' to ',i2,a2,1x,a,',',i4) 1551 FORMAT('span: ',i4,' to ',i4) 1552 FORMAT('startspec: ',i2,a2,1x,a,',',i4) 1553 FORMAT('startspec: ',i4) 1600 FORMAT(a,': ',a) 1610 FORMAT(a,': ',i5) 1620 FORMAT(a,': ',f12.6) 1630 FORMAT(a,': ',e20.10) 1640 FORMAT(a,':',2(1x,f12.6)) 1650 FORMAT(a,': ',11(a4,2x),a4) 1660 FORMAT(a,': ',a,1x,a) c----------------------------------------------------------------------- RETURN c----------------------------------------------------------------------- END x12run.f0000664006604000003110000002774314521201627011514 0ustar sun00315stepsC Last change:Mar. 2021 if there is history or sliding spans , C rest Tabtbl,skip _tbs file C Last change: BCM 23 Mar 2005 3:38 pm SUBROUTINE x12run(Isrs,Unopnd,Nopen,Lchkin,Lcomp,Rok,Fok,N1,Nfail, & Ldata,Dtafil,Mtafil,Nmf,Dattim,X11agr,Lgraf, & Lexgrf,l1stcomp) IMPLICIT NONE c----------------------------------------------------------------------- c preform and x12 run on one series C----------------------------------------------------------------------- INCLUDE 'stdio.i' INCLUDE 'lex.i' INCLUDE 'srslen.prm' INCLUDE 'notset.prm' INCLUDE 'hiddn.cmn' INCLUDE 'agr.cmn' INCLUDE 'units.cmn' INCLUDE 'title.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'svllog.prm' INCLUDE 'svllog.cmn' INCLUDE 'dgnsvl.i' INCLUDE 'seatop.cmn' C----------------------------------------------------------------------- INTEGER FILLIM PARAMETER(FILLIM=16) CHARACTER blnk*(15) LOGICAL T,F PARAMETER(T=.true.,F=.false.) C----------------------------------------------------------------------- CHARACTER ttlvec*(80),filenm*(FILLIM),srsttl*(PSRSCR),Dattim*(24), & mdlfil*(PFILCR),Dtafil*(PFILCR),Mtafil*(PFILCR) REAL bticks,ticks LOGICAL Lfatal,Fok,Lchkin,lx11,lmodel,hvmfil,Lcomp,Ldata,Rok, & X11agr,Lgraf,Lexgrf,lseats,l1stcomp DOUBLE PRECISION Lam,sscut INTEGER Fcntyp,Isrs,Nmf,Unopnd,Nopen,ltmax,N1,notc,ncur, & icur,nsrscr,Nfail DIMENSION Unopnd(*),ttlvec(10),sscut(5) C----------------------------------------------------------------------- INTEGER lstpth,nblank,sfmax LOGICAL dpeq,istrue EXTERNAL lstpth,nblank,sfmax,dpeq,istrue c----------------------------------------------------------------------- COMMON /fcnerr/ Lfatal COMMON /armalm/ Lam,Fcntyp C----------------------------------------------------------------------- DATA blnk/' '/ C----------------------------------------------------------------------- c Process a series. C----------------------------------------------------------------------- IF(Ltimer)THEN CALL cpu_time(bticks) END IF Lfatal=F Opnudg=F C----------------------------------------------------------------------- c generate file names for output files C----------------------------------------------------------------------- CALL genfor(Fok,Lchkin,Isrs) C----------------------------------------------------------------------- c Generate error message for genfor C----------------------------------------------------------------------- IF(.not.Fok)THEN WRITE(STDOUT,*) & ' error in genfor - unable to open input/output files for '// & PRGNAM Nopen=Nopen+1 Unopnd(Nopen)=Isrs Lfatal=T RETURN END IF c----------------------------------------------------------------------- c Extract filename from Cursrs (for MSDOS filenames, only c first 8 characters are used). c----------------------------------------------------------------------- ncur=nblank(Cursrs) icur=lstpth(Cursrs,ncur) ncur=min(ncur-icur,FILLIM) filenm(1:ncur)=Cursrs(icur+1:ncur+icur) IF(ncur.lt.FILLIM)filenm(ncur+1:FILLIM)=blnk(1:(FILLIM-ncur)) C----------------------------------------------------------------------- CALL mdlint() C----------------------------------------------------------------------- c If all files have been opened, read in X-13A-S options C----------------------------------------------------------------------- nsrscr=0 CALL gtinpt(sscut,srsttl,nsrscr,ttlvec,notc,lx11,X11agr,lseats, & lmodel,Ldata,Dtafil,l1stcomp,hvmfil,mdlfil,Rok) IF(Lfatal)RETURN C----------------------------------------------------------------------- c If series name hasn't been set, set to be the filename. Then c set the number of characters in the series name, truncated to 16. C----------------------------------------------------------------------- IF(Nser.eq.0)THEN Serno=filenm Nser=min(nblank(Serno),16) ELSE Nser=min(16,Nser) END IF C----------------------------------------------------------------------- c If there are no input errors, check the input options. C----------------------------------------------------------------------- c IF(Rok)THEN IF(Rok.and.Lexok)THEN c----------------------------------------------------------------------- c If an error is found in a previous spec, print an error message c and do not perform the direct and indirect adjustment of the c aggregate total. c----------------------------------------------------------------------- IF((Iagr.eq.3.and.Nfail.gt.0).or.Iagr.eq.NOTSET)THEN IF(Iagr.eq.3)THEN CALL writln('ERROR: Error(s) were found while executing the spe &c file(s) of component ',STDERR,Mt2,T) CALL writln(' series used for this composite adjustment. & The direct and indirect',STDERR,Mt2,F) CALL writln(' seasonal adjustment of the total series wil &l not be performed.',STDERR,Mt2,F) END IF CALL writln(' Correct the error(s) for the component serie &s and rerun the ',STDERR,Mt2,T) CALL writln(' metafile '//Mtafil(1:Nmf)//'.',STDERR,Mt2,F) Lfatal=T RETURN c----------------------------------------------------------------------- c Else, check the input options and print the header. c----------------------------------------------------------------------- ELSE CALL editor(sscut,srsttl,nsrscr,ttlvec,notc,Lchkin,Lcomp,lx11, & lseats,lmodel,Ldata,hvmfil,mdlfil,Dattim, & Lgraf,Lexgrf,Rok) IF(Lfatal)RETURN END IF END IF Lhiddn=.false. C----------------------------------------------------------------------- c If there are errors in the input, print out a message to correct c the input. C----------------------------------------------------------------------- c IF(.not.Rok)THEN IF(.NOT.(Lexok.and.Rok))THEN WRITE(STDOUT,*)' **Correct input and rerun '//Infile(1:N1)// & '.spc**' Lfatal=T C----------------------------------------------------------------------- c If there are no errors in the input and the check input option c is selected, print out a message. C----------------------------------------------------------------------- ELSE IF(Lchkin)THEN WRITE(STDOUT,*)' Input checking complete for ',Infile(1:N1), & '.spc' C----------------------------------------------------------------------- c If there are no errors in the input and the check input option c is not selected, call the X-13A-S main driver routine. C----------------------------------------------------------------------- ELSE C----------------------------------------------------------------------- IF(Lsumm.gt.0)THEN IF(lmodel)THEN WRITE(Nform,1010)'yes' ELSE WRITE(Nform,1010)'no' END IF END IF C----------------------------------------------------------------------- CALL ssprep(lmodel,T,T) IF(Fcntyp.eq.0.and.dpeq(Lam,DNOTST))THEN CALL qcontr(-2,Ny) ELSE IF(lx11)THEN CALL qcontr(Tmpma,Ny) ELSE CALL qcontr(-1,Ny) END IF CALL x11int IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'bx12run:',bticks WRITE(Nform,9000) 'bx11ari:',ticks END IF c write(*,*)' enter x11ari' CALL x11ari(lmodel,lx11,X11agr,lseats,Lcomp,Issap,Irev,Irevsa, & Ixreg,Lsumm,Ltimer,Lgraf) IF(Lfatal)RETURN c write(*,*)' exit x11ari' IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'ex11ari:',ticks END IF C----------------------------------------------------------------------- c CALL timer(iticks) c WRITE(Ng,*) ' timer(2) = ', iticks, ' (end of run)' C----------------------------------------------------------------------- c IF not doing either sliding spans or revisons history, return C----------------------------------------------------------------------- IF(Issap.eq.0.and.Irev.eq.0)THEN IF(Lsumm.gt.0)THEN WRITE(Nform,1000)'no' WRITE(Nform,1005)'no' WRITE(Nform,1015)'no' END IF IF(Ltimer.and.Rok)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'ex12run:',ticks WRITE(Nform,9000) 'run.time:',ticks-bticks END IF RETURN END IF C----------------------------------------------------------------------- c determine the maximum seasonal filter length. C---------------------------------------------------------------------- ltmax=sfmax(Lterm,Lter,Ny) c----------------------------------------------------------------------- IF(Issap.gt.0.and.Irev.gt.0) & CALL ss2rv(Lmodel,Lx11,Ixreg.gt.0,lseats) C----------------------------------------------------------------------- c Perform sliding spans analysis C----------------------------------------------------------------------- IF(Issap.eq.1)THEN IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'bsspan:',ticks END IF c change Mar.2021 if there is sliding span ,rest Tabtbl,skip _tbs file CALL setchr(' ',100,Tabtbl) CALL sspdrv(ltmax,lmodel,lx11,X11agr,lseats,Lcomp,Lgraf,Iagr, & Ncomp) IF(Lfatal.or.Issap.le.0)THEN IF(Issap.le.0.and.Nfile.gt.0)THEN IF(Lsumm.gt.0)WRITE(Nform,1005)'failed' IF(Svltab(LSLPCT))WRITE(Ng,1020) END IF IF(Lfatal)RETURN END IF IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'esspan:',ticks END IF IF(Irev.gt.0)THEN CALL rv2ss(Lmodel,Lx11,Ixreg.gt.0,lseats) CALL restor(Lmodel,Lx11,Ixreg.gt.0) END IF Issap=0 ELSE IF(Lsumm.gt.0)THEN WRITE(Nform,1005)'no' END IF C----------------------------------------------------------------------- c Perform revisions analysis C----------------------------------------------------------------------- IF(Irev.gt.0)THEN IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'bhist:',ticks END IF c write(*,*)' enter revdrv' c change Mar.2021 if there is history ,rest Tabtbl,skip _tbs file CALL setchr(' ',100,Tabtbl) CALL revdrv(ltmax,lmodel,lx11,X11agr,lseats,Lcomp,Lgraf,Iagr, & Ncomp) c write(*,*)' exit revdrv' * IF(Lfatal)RETURN IF(Lfatal.or.Irev.eq.0)THEN IF(Irev.eq.0.and.Nfile.gt.0)THEN IF(Lsumm.gt.0)THEN WRITE(Nform,1000)'failed' IF(Irevsa.lt.0)WRITE(Nform,1015)'failed' END IF IF(istrue(Svltab,LSLASA,LSLASP))WRITE(Ng,1030) END IF IF(Ltimer)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'ehist:',ticks END IF END IF ELSE IF(Lsumm.gt.0)THEN WRITE(Nform,1000)'no' END IF END IF C----------------------------------------------------------------------- IF(Ltimer.and.Rok)THEN CALL cpu_time(ticks) WRITE(Nform,9000) 'ex12run:',ticks WRITE(Nform,9000) 'run.time:',ticks-bticks END IF C----------------------------------------------------------------------- 1000 FORMAT('history: ',a) 1005 FORMAT('sspans: ',a) 1010 FORMAT('mdg: ',a) 1015 FORMAT('historysa: ',a) 1020 FORMAT(/,' Sliding spans analysis failed : check error file.') 1030 FORMAT(/,' History analysis failed : check error file.') 9000 FORMAT(a,e15.8) RETURN END xarr.i0000664006604000003110000000015614521201630011313 0ustar sun00315stepsC C... Variables in Common Block /xarr/ ... integer nx real*8 x(N10) common /xarr/ x,nx xchng.f0000664006604000003110000000272114521201630011443 0ustar sun00315stepsC Last change: BCM 26 Feb 1999 4:12 pm **==xchng.f processed by SPAG 4.03F at 12:24 on 21 Jun 1994 SUBROUTINE xchng(X,Cx,Ncol,Im,Sslen,Nchng,Ldiff) IMPLICIT NONE C----------------------------------------------------------------------- c ***** c ***** calculate month-to-month or year-to-year changes of the c ***** seasonally adjusted data (Nchng = 1 for month-to month, c ***** 12 or 4 for year-to year) c ***** C----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'ssap.prm' INCLUDE 'notset.prm' C----------------------------------------------------------------------- LOGICAL Ldiff DOUBLE PRECISION Cx,X INTEGER i,iyy,iyy2,Sslen,Ncol,Nchng,Im DIMENSION X(MXLEN,MXCOL),Cx(MXLEN,MXCOL) C----------------------------------------------------------------------- LOGICAL dpeq EXTERNAL dpeq C----------------------------------------------------------------------- DO i=1,Ncol DO iyy=1,Sslen+Im-1 Cx(iyy,i)=DNOTST iyy2=iyy-Nchng IF(.not.dpeq(X(iyy,i),DNOTST).and.iyy2.gt.0)THEN IF(.not.dpeq(X(iyy2,i),DNOTST))THEN Cx(iyy,i)=X(iyy,i)-X(iyy2,i) IF(.not.Ldiff)Cx(iyy,i)=(Cx(iyy,i)/abs(X(iyy2,i)))*100D0 END IF END IF END DO END DO C----------------------------------------------------------------------- RETURN END xclude.cmn0000664006604000003110000000106614521201630012151 0ustar sun00315stepsc----------------------------------------------------------------------- c This is a common block used in the irregular regression c subroutines to keep track of irregular values that are excluded c from the regression. c----------------------------------------------------------------------- INTEGER Nxcld LOGICAL Rgxcld c---------------------------------------------------------------------- DIMENSION Rgxcld(PLEN) c----------------------------------------------------------------------- COMMON /xclude/ Nxcld,Rgxcld xeastr.cmn0000664006604000003110000000072414521201630012173 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Yhol,Xhol INTEGER Ieast LOGICAL Lgenx c----------------------------------------------------------------------- DIMENSION Ieast(4),Yhol(PLEN),Xhol(PLEN) c----------------------------------------------------------------------- COMMON /xyser / Yhol,Xhol,Ieast,Lgenx c----------------------------------------------------------------------- xpand.f0000664006604000003110000000441214521201630011445 0ustar sun00315steps SUBROUTINE xpand(B,Mxarlg,Na,Nc,C,Pc) IMPLICIT NONE c----------------------------------------------------------------------- c FORTRAN corrections made by Bill Bell -- 9/10/92 c 1. Integer declaration statement put before double precision declaration c statement c 2. Variable name "O" changed to "m" for clarity c 3. REAL B(P) changed to double precision B(max(P,1)) to handle case c where P = 0 c 4. REAL A(m:Na) changed to double precision A(m:max(Na,1)) c to handle case where Na = 0 c Changes made: 9/21/92, Bill Bell c 1. IMPLICIT NONE statement added c 2. REAL type statements changed to DOUBLE PRECISION c Changes made: 8/30/2005, REG c 1. Changed dimension on arrays a(0:porder) and c(0:porder) to (0:pobs) c and commented out include file 'model.prm' that is no longer needed c Changes made: 9/15/2005, REG c 1. Added input argument Pc. Changed dimension on arrays a(0:pobs) and c c(0:pobs) to (0:Pc) and commented out include file 'srslen.prm' c that is no longer needed c----------------------------------------------------------------------- c INCLUDE 'srslen.prm' c INCLUDE 'model.prm' DOUBLE PRECISION ZERO PARAMETER(ZERO=0D0) c ------------------------------------------------------------------ INTEGER i,Mxarlg,Na,Nc,nlag,Pc,w DOUBLE PRECISION a(0:Pc),B(0:Mxarlg),C(0:Pc),sum c----------------------------------------------------------------------- c Calculates the expansion of A(Z)/B(Z) = C(Z) up to order nc. c----------------------------------------------------------------------- * CALL copy(C,Na+1,1,a) DO i=0,Na a(i)=C(i) END DO c ------------------------------------------------------------------ DO i=0,Nc nlag=min(Mxarlg,i) c ------------------------------------------------------------------ IF(i.le.Na)THEN sum=a(i) ELSE sum=ZERO END IF c ------------------------------------------------------------------ DO w=1,nlag sum=sum-B(w)*C(i-w) END DO c ------------------------------------------------------------------ C(i)=sum END DO c ------------------------------------------------------------------ RETURN END xprmx.f0000664006604000003110000000574414521201630011522 0ustar sun00315steps**==xprmx.f processed by SPAG 4.03F at 09:56 on 1 Mar 1994 SUBROUTINE xprmx(Xy,Nspobs,Ncxy,Pcxy,Xypxy) IMPLICIT NONE c----------------------------------------------------------------------- c Subroutine to make X'X matrix or an [X:y]'[X:y] with the data c vector in the pcxyth column. Does this by matrix multiplication c of the upper triangle of elements of X'X or [X:y]'[X:y]. c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c ielt i Local packed element index c j i Local do loop index c k i Local do loop index c ncxy i Input number of columns in x c nspobs i Input number of rows in both x and y c pcxy i Input parmeter for the leading array (column) index of the c X matrix. c sum d Local temporary sum to get the inner product of x'(i) and c x(j) c xy d Input nspobs by ncxy matrix with possibly a vector of data c in the pcxyth column. X'y then is stored in the ncxy+1 c column if pcxy is greater than ncxy. c xypxy d Output packed ncxy square symmetric output matrix, c [X:y]'[X:y] with ncxy(ncxy+1)/2 elements if ncxy=pcxy and c (ncxy+1)(ncxy+2)/2 if pcxy>ncxy. c----------------------------------------------------------------------- c LOGICAL T,F c PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INTEGER Pcxy,i,ielt,j,Ncxy,Nspobs DOUBLE PRECISION ddot,Xy(Pcxy*Nspobs),Xypxy(*) EXTERNAL ddot c----------------------------------------------------------------------- c Also, the elements of the array are stored are stored row by row c which is why the FORTRAN array indices are switched from standard c matrix notation. c----------------------------------------------------------------------- c CALL under0(T) ielt=0 c ------------------------------------------------------------------ DO i=1,Ncxy DO j=1,i ielt=ielt+1 Xypxy(ielt)=ddot(Nspobs,Xy(i),Pcxy,Xy(j),Pcxy) END DO END DO c----------------------------------------------------------------------- c If pcxy > ncxy then assume the data array is in the pcxyth column c so calculate X'y and put y'y in the last element. c----------------------------------------------------------------------- IF(Pcxy.gt.Ncxy)THEN DO j=1,Ncxy ielt=ielt+1 Xypxy(ielt)=ddot(Nspobs,Xy(j),Pcxy,Xy(Pcxy),Pcxy) END DO c ------------------------------------------------------------------ Xypxy(ielt+1)=ddot(Nspobs,Xy(Pcxy),Pcxy,Xy(Pcxy),Pcxy) END IF c ------------------------------------------------------------------ c CALL under0(F) c----------------------------------------------------------------------- RETURN END xrgdiv.f0000664006604000003110000000310314521201630011632 0ustar sun00315stepsC Last change: BCM 27 May 1998 12:27 pm SUBROUTINE xrgdiv(Kvec) IMPLICIT NONE c----------------------------------------------------------------------- c Divide trading day and holiday regressors in X-11 Regression by c value of the holiday mean function c----------------------------------------------------------------------- c Author : Brian Monsell, March 1996 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'usrreg.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION Kvec INTEGER icol,irow,rtype,iusr,ir1 DIMENSION Kvec(PLEN) c----------------------------------------------------------------------- iusr=1 DO icol=1,Nb rtype=Rgvrtp(icol) IF(rtype.eq.PRGTTD.or.rtype.eq.PRGTEA.or.rtype.eq.PRGTLD.or. & rtype.eq.PRGTTH.or.rtype.eq.PRGTUH.or.rtype.eq.PRGTLY.or. & rtype.eq.PRRTTD.or.rtype.eq.PRRTLY.or.rtype.eq.PRG1TD.or. & rtype.eq.PRATTD.or.rtype.eq.PRATLY.or.rtype.eq.PRGTEC.or. & rtype.eq.PRR1TD.or.rtype.eq.PRA1TD.or.rtype.eq.PRGUTD.or. & rtype.eq.PRGULM.or.rtype.eq.PRGULQ.or.rtype.eq.PRGULY)THEN DO irow=1,Nrxy ir1=icol+(irow-1)*Ncxy Xy(ir1)=Xy(ir1)/Kvec(irow) END DO END IF END DO c----------------------------------------------------------------------- RETURN END xrgdrv.f0000664006604000003110000002122414521201630011647 0ustar sun00315stepsC Last Change: Oct,2021 C previous change: BCM 16 Feb 1999 3:47 pm SUBROUTINE xrgdrv(Lmodel,Lx11,Khl2,Lgraf) IMPLICIT NONE c----------------------------------------------------------------------- c This subroutine performs an OLS regression on the irregular c component of an X-11 seasonal adjustment. The regressors have c been previously chosen by the user. The irregular is calculated c from transparent seasonal adjustments. c----------------------------------------------------------------------- c Author : Brian Monsell, February 1996 c----------------------------------------------------------------------- LOGICAL T,F PARAMETER(F=.false.,T=.true.) c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'picktd.cmn' INCLUDE 'xrgmdl.cmn' INCLUDE 'arima.cmn' INCLUDE 'error.cmn' INCLUDE 'x11ptr.cmn' INCLUDE 'extend.cmn' INCLUDE 'prior.prm' INCLUDE 'prior.cmn' INCLUDE 'priadj.cmn' INCLUDE 'priusr.cmn' INCLUDE 'x11reg.cmn' INCLUDE 'x11adj.cmn' INCLUDE 'hiddn.cmn' INCLUDE 'inpt.cmn' INCLUDE 'usrreg.cmn' INCLUDE 'x11srs.cmn' c INCLUDE 'sspinp.cmn' c INCLUDE 'rev.prm' c INCLUDE 'rev.cmn' INCLUDE 'lzero.cmn' INCLUDE 'units.cmn' c----------------------------------------------------------------------- CHARACTER ubkttl*(PCOLCR*PUREG) DOUBLE PRECISION base,sumf,spr,ubkx LOGICAL Lmodel,Lx11,pktd,lest,Lgraf INTEGER i,Khl2,next2,nint2,nf2,nb2,pa2,nubk,ubktyp,ubkptr DIMENSION spr(PLEN),ubktyp(PUREG),ubkptr(0:PUREG),ubkx(PUSERX) EXTERNAL sumf c----------------------------------------------------------------------- c DOUBLE PRECISON adj2(PLEN) c INTEGER nadj2 c----------------------------------------------------------------------- INCLUDE 'x11opt.cmn' c---------------------------------------------------------------------- c Store model, seasonal adjustment parameters before transparent c seasonal adjustments. c----------------------------------------------------------------------- CALL ssprep(Lmodel,Lx11,F) lest=Lestim Lestim=T nint2=Nintvl Nintvl=0 next2=Nextvl Nextvl=0 c----------------------------------------------------------------------- c Make local backup copy of user defined regressors for regARIMA c models. c----------------------------------------------------------------------- nubk=0 IF(Ncusrx.gt.0)THEN CALL copy(Userx,PUSERX,1,ubkx) CALL cpyint(Usrtyp,PUREG,1,ubktyp) CALL cpyint(Usrptr(0),PUREG+1,1,ubkptr(0)) nubk=Ncusrx ubkttl=Usrttl END IF * call profiler(2,'in xrgdrv') c----------------------------------------------------------------------- c Set model adjustment indicators to false c----------------------------------------------------------------------- IF(Adjtd.eq.1)Adjtd=0 IF(Adjhol.eq.1)Adjhol=0 IF(Adjao.eq.1)Adjao=0 IF(Adjls.eq.1)Adjls=0 IF(Adjtc.eq.1)Adjtc=0 IF(Adjso.eq.1)Adjso=0 IF(Adjusr.eq.1)Adjusr=0 IF(Adjsea.eq.1)Adjsea=0 c----------------------------------------------------------------------- c Reset TD logical variables, Prior adjustment factors to ensure c that Length of Month adjustment is not performed when TD is c chosen in regression spec c----------------------------------------------------------------------- pktd=Picktd pa2=Priadj IF(Picktd.and.Priadj.gt.1)THEN Picktd=F Priadj=0 CALL copy(Sprior,Posfob,-1,spr) base=1D0 IF(Muladd.eq.1)base=0D0 IF(Nprtyp.eq.0)THEN CALL setdp(base,PLEN,Sprior) Kfmt=0 ELSE DO i=Pos1ob,Posfob Sprior(i)=base IF(Nustad.gt.0)THEN IF(Muladd.eq.1)THEN Sprior(i)=Sprior(i)+Usrtad(Frstat+i-Pos1ob+Lsp-1) ELSE Sprior(i)=Sprior(i)*Usrtad(Frstat+i-Pos1ob+Lsp-1) END IF END IF IF(Nuspad.gt.0)THEN IF(Muladd.eq.1)THEN Sprior(i)=Sprior(i)+Usrpad(Frstap+i-Pos1ob+Lsp-1) ELSE Sprior(i)=Sprior(i)*Usrpad(Frstap+i-Pos1ob+Lsp-1) END IF END IF END DO END IF ELSE pktd=F END IF c----------------------------------------------------------------------- c Load X-11 Regression parameters into regARIMA model parameters c----------------------------------------------------------------------- IF(Ixreg.gt.0)CALL loadxr(F) c----------------------------------------------------------------------- c Set number of X-11 forecasts and backcasts to be zero and reset c X-11 pointers c----------------------------------------------------------------------- IF(Nfcst.gt.0.or.Nbcst.gt.0)THEN nf2=Nfcst Nfcst=0 Nfdrp=0 nb2=Nbcst Nbcst=0 c----------------------------------------------------------------------- c Reset X-11 pointers c----------------------------------------------------------------------- Pos1bk=Pos1ob Posffc=Posfob Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst ELSE nf2=0 nb2=0 END IF c----------------------------------------------------------------------- IF(Ixreg.gt.0)THEN CALL dfdate(Endspn,Endxrg,Sp,Xdsp) IF(Xdsp.gt.0)THEN Posfob=Posfob-Xdsp Posffc=Posfob CALL cpyint(Endxrg,2,1,Endspn) END IF END IF c----------------------------------------------------------------------- c Perform iterations of X-11 to get X-11 Regression c----------------------------------------------------------------------- CALL x11pt1(F,F,Lgraf) IF(.not.Lfatal)CALL x11pt2(F,T,F,F,Lgraf) IF(.not.Lfatal.and.Khol.eq.1)CALL x11pt3(F,F) IF(Lfatal)RETURN c----------------------------------------------------------------------- IF(Nfcst.ne.nf2.or.Nbcst.ne.nb2)THEN Nfcst=nf2 Nbcst=nb2 Nfdrp=nf2 c----------------------------------------------------------------------- c Reset X-11 pointers c----------------------------------------------------------------------- Pos1bk=Pos1ob-Nbcst Posffc=Posfob+Nfcst Nofpob=Nspobs+Nfcst Nbfpob=Nspobs+Nfcst+Nbcst END IF c----------------------------------------------------------------------- c Call X-11 holiday estimation routines c----------------------------------------------------------------------- IF(Khol.eq.1)THEN CALL holday(Sti,Mt1,Lgraf,Nfcst,Xdsp) IF(Lfatal)RETURN c----------------------------------------------------------------------- c If no holiday adjustment is to be done, set holiday pointer c variable to proper value. c----------------------------------------------------------------------- IF(Khol.eq.0)THEN Khl2=0 Axhol=F ELSE Axhol=T END IF END IF c----------------------------------------------------------------------- IF((Ixreg.gt.0).and.(Xdsp.gt.0))THEN CALL addate(Endxrg,Sp,Xdsp,Endspn) Posfob=Posfob+Xdsp Posffc=Posfob END IF c----------------------------------------------------------------------- c Reset X-11, Model parameters c----------------------------------------------------------------------- CALL loadxr(T) CALL restor(Lmodel,Lx11,F) c----------------------------------------------------------------------- c Reset Model based TD logical variables c----------------------------------------------------------------------- IF(pktd)THEN Picktd=T Priadj=pa2 CALL copy(spr,Posfob,-1,Sprior) ELSE IF(Picktd)THEN Picktd=F END IF Lestim=lest Nintvl=nint2 Nextvl=next2 Nfev=0 c----------------------------------------------------------------------- c Add user-defined regressors back to regARIMA model c----------------------------------------------------------------------- IF(nubk.gt.0)THEN CALL copy(ubkx,PUSERX,1,Userx) CALL cpyint(ubktyp,PUREG,1,Usrtyp) CALL cpyint(ubkptr(0),PUREG+1,1,Usrptr(0)) Ncusrx=nubk Usrttl=ubkttl END IF c----------------------------------------------------------------------- IF(Ixreg.gt.0)Ixreg=3 c----------------------------------------------------------------------- RETURN END xrgfct.cmn0000664006604000003110000000076114521201630012163 0ustar sun00315stepsc----------------------------------------------------------------------- c Nfcstx - number of forecasts c Nbcstx - number of backcasts c Ladd1x - logical variable indicating whether outliers will be c added one at a time c----------------------------------------------------------------------- LOGICAL Ladd1x INTEGER Nfcstx,Nbcstx c----------------------------------------------------------------------- common /cx11fc/ Nfcstx,Nbcstx,Ladd1x xrghol.f0000664006604000003110000000311014521201630011630 0ustar sun00315steps SUBROUTINE xrghol(Xdisp,Psuadd,Xlpyr,Daybar) IMPLICIT NONE c----------------------------------------------------------------------- c Divide trading day and holiday regressors in X-11 Regression by c length of month/quarter. c----------------------------------------------------------------------- c Author : Brian Monsell, February 1996 c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' INCLUDE 'arima.cmn' INCLUDE 'usrreg.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION Xlpyr,Daybar LOGICAL Psuadd INTEGER icol,irow,ir1,ir2,iusr,rtype,Xdisp DIMENSION Xlpyr(PLEN) c----------------------------------------------------------------------- iusr=1 DO icol=1,Nb rtype=Rgvrtp(icol) IF(rtype.eq.PRGTUD.and.Ncusrx.gt.0)THEN rtype=Usrtyp(iusr) iusr=iusr+1 END IF IF(rtype.eq.PRGTEA.or.rtype.eq.PRGTLD.or.rtype.eq.PRGTTH.or. & rtype.eq.PRGTEC.or.rtype.eq.PRGTUH)THEN DO irow=1,Nrxy c ir1=irow+(icol-1)*Nrxy ir1=icol+(irow-1)*Ncxy IF(Psuadd.and.Easidx.eq.0)THEN ir2=irow+Xdisp-1 Xy(ir1)=Xy(ir1)*Daybar-Xlpyr(ir2)/Sp ELSE Xy(ir1)=Xy(ir1)*Daybar END IF END DO END IF END DO c----------------------------------------------------------------------- RETURN END xrgmdl.cmn0000664006604000003110000000641514521201631012166 0ustar sun00315stepsc----------------------------------------------------------------------- c Common for model description that is independant of the data. c----------------------------------------------------------------------- c Colttx - data dictionary for the names of the regression variables c Grpttx - data dictionary for the names of groups of regression c variables c----------------------------------------------------------------------- CHARACTER Colttx*(PCOLCR*PB),Grpttx*(PGRPCR*PGRP) c----------------------------------------------------------------------- c Pckxtd - logical scalar which indicates that "td" was selected c as one of the X-11 trading day regressors c----------------------------------------------------------------------- LOGICAL Pckxtd,Xrgmtd,Fulxtd,Regfxx,Usrxfx c----------------------------------------------------------------------- c Clxptr - pointers for the X-11 regression variable data dictionary c Grpx - pointers for X-11 regression groups c Gpxptr - pointers for X-11 regression groups names data dictionary c Nbx - number of X-11 regression variables c Ncoltx - length of Colttx c Nxcxy - number of columns in Xy X-11 regression matrix c Nxgrp - number of regression variable groups c Ngrptx - length of Grpttx c Rgxvtp - indicator variable denoting X-11 regression variable c type - see model.prm for more details c Bgxusx - Starting date for the user-defined X-11 regression c variables. c Nxrxy - Number of rows in Xy X-11 regression matrix c Xbegxy - Beginning date of Xy X-11 regression matrix c Nusxrg - number of user-defined X-11 regression types c Priadx - indicator for prior adjustment for X-11 regressors. c Xeasid - Integer idicator variable for type of Easter regressor c (0=default,1=sunday,2=monday,3=statcan) c Irgxfx - Integer indicator variable for fixed X-11 regressors c (0=default,1=initial values specified for regressors, c 2=regressors fixed at initial values) c----------------------------------------------------------------------- INTEGER Bgxusx,Clxptr,Grpx,Gpxptr,Irgxfx,Nbx,Ncoltx,Ngrptx,Nusxrg, & Nxcxy,Nxgrp,Nxrxy,Priadx,Rgxvtp,xBegxy,Xeasid,Xtdzro, & Xtddat c----------------------------------------------------------------------- c Xuserx : User-defined X-11 regression variables c Bx - vector of X-11 regression parameter estimates c----------------------------------------------------------------------- DOUBLE PRECISION Bx,Xuserx,Xraicd,Cvxalf,Cvxrdc c----------------------------------------------------------------------- DIMENSION Bgxusx(2),Bx(PB),Clxptr(0:PB),Grpx(0:PGRP), & Gpxptr(0:PGRP),Regfxx(PB),Rgxvtp(PB),Xbegxy(2), & Xtddat(2),Xuserx(PUSERX) c----------------------------------------------------------------------- COMMON /cx11rg/ Clxptr,Grpx,Gpxptr,Nbx,Ncoltx,Nxcxy,Nxgrp,Ngrptx, & Rgxvtp,Bgxusx,Nxrxy,Xbegxy,Nusxrg,Priadx,Irgxfx, & Xeasid,Regfxx,Usrxfx COMMON /cmnttx/ Colttx,Grpttx COMMON /cxpktd/ Xtdzro,Xtddat,Pckxtd,Xrgmtd,Fulxtd COMMON /cx11rd/ Bx,Xraicd,Xuserx,Cvxalf,Cvxrdc xrgtbl.i0000664006604000003110000000261614521201631011645 0ustar sun00315stepsc----------------------------------------------------------------------- c Table pointer variables used for prttbl and savtbl are of the form c L where the spec codes are c----------------------------------------------------------------------- c x11regress XRG or XR c----------------------------------------------------------------------- c and the types are c----------------------------------------------------------------------- c extreme values for X-11 regression IRX c X-11 regression model XRG c trading day factors TDF c holiday factors HLF c combined calendar factors CLF c automatic outlier header for X-11 regression OHD c automatic outlier iterations for X-11 regression OIT c automatic outlier tests for X-11 regression OTT c final X-11 regression matrix XMX c----------------------------------------------------------------------- INTEGER LXRGA4,LXRIRX,LXRXRG,LXRTDF,LXRTDC,LXRHLF,LXRCLF,LXRCLC, & LXROHD,LXROIT,LXROTT,LXROFT,LXRXMX,LXRXCM,LXAICT PARAMETER( & LXRGA4=218,LXRIRX=219,LXRXRG=221,LXRTDF=223,LXRTDC=225, & LXRHLF=227,LXRCLF=229,LXRCLC=231,LXROHD=233,LXROIT=234, & LXROTT=235,LXROFT=236,LXRXMX=237,LXRXCM=238,LXAICT=239) xrgtrn.f0000664006604000003110000000424214521201631011661 0ustar sun00315stepsC Last change: BCM 4 Sep 1998 10:48 am SUBROUTINE xrgtrn(X,L1,L2,Psuadd,Muladd,Tdgrp,Haveum,Umean, & Ndifum,Kswv) IMPLICIT NONE c----------------------------------------------------------------------- c Adjust the irregular for the X-11 Regression c----------------------------------------------------------------------- c X : Irregular component c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'tdtyp.cmn' INCLUDE 'xtdtyp.cmn' c----------------------------------------------------------------------- DOUBLE PRECISION X,Umean LOGICAL Psuadd,Haveum INTEGER L1,L2,i,i2,Muladd,Ndifum,i3,Tdgrp,Kswv DIMENSION X(*),Umean(PLEN) c----------------------------------------------------------------------- DO i=L1,L2 i2=i-L1+1 c----------------------------------------------------------------------- IF(Haveum)THEN i3=i2+Ndifum X(i2)=X(i2)-Umean(i3) c----------------------------------------------------------------------- ELSE IF(Psuadd)THEN IF(Tdgrp.gt.0)THEN X(i2)=Daybar*(X(i2)-1D0)-Xlpyr(i) ELSE X(i2)=X(i2)-1D0 END IF c----------------------------------------------------------------------- ELSE IF(Muladd.eq.0)THEN c----------------------------------------------------------------------- c Multiplicative adjustments c----------------------------------------------------------------------- IF(Tdgrp.gt.0)THEN IF(Kswv.eq.3)THEN X(i2)=Xnstar(i)*X(i2)-Xnstar(i) ELSE X(i2)=Xnstar(i)*X(i2)-Xn(i) END IF ELSE X(i2)=X(i2)-1D0 END IF ELSE IF(Muladd.eq.2)THEN c----------------------------------------------------------------------- c Log-additive adjustments ( N*(log(i)+1) - Nt ) c----------------------------------------------------------------------- IF(Tdgrp.gt.0)X(i2)=Xnstar(i)*(X(i2)+1)-Xn(i) END IF END DO c----------------------------------------------------------------------- RETURN END xrgum.cmn0000664006604000003110000000105614521201631012027 0ustar sun00315stepsc----------------------------------------------------------------------- c variables associated with the user defined mean used in the c x11regression spec c----------------------------------------------------------------------- LOGICAL Haveum,Noxfac DOUBLE PRECISION Umean INTEGER Begum c----------------------------------------------------------------------- DIMENSION Umean(PLEN),Begum(2) c----------------------------------------------------------------------- COMMON /cxrum / Umean,Begum,Haveum,Noxfac xrlkhd.f0000664006604000003110000000457414521201631011641 0ustar sun00315stepsC Last change: BCM 29 Jan 1999 9:56 am SUBROUTINE xrlkhd(Aicc,Nxcld) IMPLICIT NONE c----------------------------------------------------------------------- c Generates Likelihood statistics for use with x11regression c----------------------------------------------------------------------- c Data typing and initialization c----------------------------------------------------------------------- DOUBLE PRECISION ONE,TWO,ZERO PARAMETER(ONE=1D0,TWO=2.0D0,ZERO=0D0) c ------------------------------------------------------------------ INCLUDE 'notset.prm' INCLUDE 'srslen.prm' INCLUDE 'model.prm' INCLUDE 'model.cmn' INCLUDE 'mdldat.cmn' c ------------------------------------------------------------------ INTEGER ilag,nefobs,Nxcld DOUBLE PRECISION Aicc,dnefob,dnp,dnp1 c----------------------------------------------------------------------- INTEGER strinx LOGICAL dpeq EXTERNAL dpeq,strinx c----------------------------------------------------------------------- nefobs=Nspobs-Nxcld dnefob=dble(nefobs) c----------------------------------------------------------------------- c Calculate the AIC. First find the number of estimated parameters, c including the regression and ARIMA parameters, and the variance. c----------------------------------------------------------------------- dnp=dble(Ncxy) IF(Nb.gt.0)THEN DO ilag=1,Nb IF(Regfx(ilag))dnp=dnp-ONE END DO END IF dnp1=dnp+ONE c----------------------------------------------------------------------- c Calculate the jacobian of the transformation and print out the c AIC's if valid to do so. c----------------------------------------------------------------------- Aicc=DNOTST IF(Var.gt.ZERO.and.Convrg.and.(dnefob.gt.dnp1)) & Aicc=-TWO*(Lnlkhd-dnefob*dnp/(dnefob-dnp1)) c ------------------------------------------------------------------ c IF(Aicc.lt.ZERO)THEN c WRITE(Mt1,1010) c WRITE(Mt2,1010) c CALL abend() c END IF c ------------------------------------------------------------------ c 1010 FORMAT('ERROR : Cannot generate AICC for irregular regression ', c & 'model.') c ------------------------------------------------------------------ RETURN END xtdtyp.cmn0000664006604000003110000000076514521201631012227 0ustar sun00315stepsc----------------------------------------------------------------------- DOUBLE PRECISION Tdx11,Tdx11b,Xn,Xnstar,Xlpyr,Daybar,Kvec DIMENSION Tdx11(PTD),Tdx11b(PTD),Kvec(PLEN),Xn(PLEN),Xlpyr(PLEN), & Xnstar(PLEN) c----------------------------------------------------------------------- COMMON /cx11td / Tdx11,Tdx11b COMMON /tdvec / Xn,Xnstar,Xlpyr,Daybar COMMON /kvcmn / Kvec c----------------------------------------------------------------------- xtrm.cmn0000664006604000003110000000220014521201631011647 0ustar sun00315stepsc----------------------------------------------------------------------- c arrays and variables for X-11 extreme value procedure c----------------------------------------------------------------------- c Csigvc - Logical variable which indicates when calendarsigma is c used c Stdper - standard errors for different months (or quarters) used c in Bundesbank extreme value replacement procedure c----------------------------------------------------------------------- DOUBLE PRECISION Stwt,Stdper,Stdev c----------------------------------------------------------------------- c Ksdev - Indicator for Budesbank outlier procedure c Kersa - Indicator variable used in Budesbank outlier procedure c----------------------------------------------------------------------- INTEGER Ksdev,Kersa LOGICAL Csigvc c----------------------------------------------------------------------- DIMENSION Stwt(PLEN),Stdev(PYRS+1),Stdper(PSP),Csigvc(PSP) c----------------------------------------------------------------------- COMMON /cxtrm / Stwt,Stdev,Stdper,Ksdev,Kersa,Csigvc xtrm.f0000664006604000003110000001641014521201631011327 0ustar sun00315stepsC Last change: BCM 15 Apr 2005 12:40 pm SUBROUTINE xtrm(Xi,Kfda,Klda,Kfdax,Kldax) IMPLICIT NONE c----------------------------------------------------------------------- C --- THIS ROUTINE COMPUTES WEIGHTS FOR THE IRREGULAR COMPONENT C --- AND IDENTIFIES EXTREME IRREGULAR VALUES c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'notset.prm' c INCLUDE 'x11ptr.cmn' INCLUDE 'lzero.cmn' INCLUDE 'x11opt.cmn' INCLUDE 'xtrm.cmn' c----------------------------------------------------------------------- INTEGER PY1 DOUBLE PRECISION ZERO,ONE LOGICAL F,T PARAMETER(PY1=PYRS+1,ZERO=0D0,ONE=1D0,F=.false.,T=.true.) c----------------------------------------------------------------------- DOUBLE PRECISION sdev1,sdev2,xbar,Xi INTEGER i,inx,istep,j,jfda,jlda,k,Kfda,Klda,l,m,lx, & mx,n,n1,n2,Kfdax,Kldax INTEGER n3,nfda,nlda DIMENSION Xi(PLEN) c----------------------------------------------------------------------- DOUBLE PRECISION sdxtrm,wtxtrm LOGICAL dpeq EXTERNAL sdxtrm,wtxtrm,dpeq c----------------------------------------------------------------------- n1=2*Ny n2=n1+Ny-1 n3=n2+n1 istep=1 jfda=(Kfdax+Ny-2)/Ny*Ny+1 jlda=Kldax/Ny*Ny-n3 c changes suggested by NBB May 2004 nfda=(Kfdax-1)/Ny*Ny+1 nlda=(((Kldax-1)/Ny)+1)*Ny-n3 c end of changes IF(jlda.lt.jfda)nlda=nfda c----------------------------------------------------------------------- C --- SET ALL WEIGHTS EQUAL TO 1.0 TO START c----------------------------------------------------------------------- CALL setdp(ONE,Klda,Stwt) CALL setdp(ZERO,Ny,Stdper) xbar=ONE IF(Muladd.ne.0)xbar=ZERO DO WHILE (istep.le.2) c----------------------------------------------------------------------- c Check to see if a grouping of periods has been done. If so, c calculate extremes using standard errors generated for the c grouped irregulars. c----------------------------------------------------------------------- IF(Ksdev.eq.4)THEN sdev1=sdxtrm(Xi,xbar,Kfdax,Kldax,1,Imad,istep,Ny,T) sdev2=sdxtrm(Xi,xbar,Kfdax,Kldax,1,Imad,istep,Ny,F) c----------------------------------------------------------------------- c Store sdev/MAD for each group c----------------------------------------------------------------------- DO i=1,Ny Stdper(i)=sdev2 IF(Csigvc(i))Stdper(i)=sdev1 END DO c----------------------------------------------------------------------- DO k=Kfda,Klda c----------------------------------------------------------------------- C --- COMPUTE DEVIATION OF EACH IRREGULAR VALUE. c----------------------------------------------------------------------- i=mod(k,Ny) IF(i.eq.0)i=Ny IF(Stdper(i).gt.ZERO)Stwt(k)=wtxtrm(Xi(k),xbar,Stdper(i),Sigmu, & Sigml,istep,Stwt(k)) END DO c----------------------------------------------------------------------- c Check to see if test for heterskedastic irregular has been c accepted. If so, calculate extremes using standard errors c calculated for each month/quarter. c----------------------------------------------------------------------- ELSE IF(Ksdev.gt.0)THEN DO l=Kfda,Kfda+Ny-1 i=mod(l,Ny) IF(i.eq.0)i=Ny c----------------------------------------------------------------------- c Calculate s.dev./MAD for a given calendar month/quarter. c----------------------------------------------------------------------- lx=l IF(l.lt.Kfdax)THEN j=mod(lx,Ny) IF(j.eq.0)j=Ny IF(i.ge.j)THEN lx=Kfdax+(j-i) ELSE lx=Kfdax+Ny+(i-j) END IF END IF m=((Klda-l)/Ny)*Ny+l mx=((Kldax-l)/Ny)*Ny+l sdev1=sdxtrm(Xi,xbar,lx,mx,Ny,Imad,istep,Ny,T) c----------------------------------------------------------------------- c Store sdev/MAD for month/quarter i c----------------------------------------------------------------------- Stdper(i)=sdev1 c----------------------------------------------------------------------- IF(.not.dpeq(sdev1,ZERO))THEN DO k=l,m,Ny Stwt(k)=wtxtrm(Xi(k),xbar,sdev1,Sigmu,Sigml,istep,Stwt(k)) END DO END IF END DO c----------------------------------------------------------------------- IF(istep.eq.2)CALL setdp(DNOTST,PY1,Stdev) ELSE c----------------------------------------------------------------------- c Else, identify extreme values and weights using standard X-11 c Method c----------------------------------------------------------------------- inx=3+((Lsp-1)/Ny) DO i=nfda,nlda,Ny IF(nlda.le.nfda)THEN c----------------------------------------------------------------------- C --- LESS THAN 5 YEARS AVAILABLE. c----------------------------------------------------------------------- j=Kfda k=Klda l=Kfdax m=Kldax ELSE IF(i.le.nfda)THEN c----------------------------------------------------------------------- C --- BEGINNING OF SERIES c----------------------------------------------------------------------- j=Kfda k=nfda+n2 l=Kfdax m=jfda+n3 ELSE IF(i.lt.nlda)THEN c----------------------------------------------------------------------- C --- CENTRAL YEARS c----------------------------------------------------------------------- j=i+n1 k=i+n2 l=i m=n3+i ELSE c----------------------------------------------------------------------- C --- END OF SERIES c----------------------------------------------------------------------- j=nlda+n1 k=Klda l=jlda m=Kldax END IF c----------------------------------------------------------------------- C --- COMPUTE FIVE YEAR STANDARD DEVIATION (OR MEDIAN ABSOLUTE C DEVIATION) OF THE IRREGULARS. c----------------------------------------------------------------------- sdev1=sdxtrm(Xi,xbar,l,m,1,Imad,istep,Ny,T) c----------------------------------------------------------------------- C --- STORE STANDARD DEVIATIONS FOR PRINTING IN TABLE OF WEIGHTS. c----------------------------------------------------------------------- Stdev(inx)=sdev1 inx=inx+1 IF(.not.dpeq(sdev1,ZERO))THEN DO n=j,k Stwt(n)=wtxtrm(Xi(n),xbar,sdev1,Sigmu,Sigml,istep,Stwt(n)) END DO END IF END DO c----------------------------------------------------------------------- IF(istep.eq.2)THEN DO i=1,3 Stdev(i-1+inx)=sdev1 Stdev(i)=Stdev(3+((Lsp-1)/Ny)) END DO END IF c----------------------------------------------------------------------- END IF istep=istep+1 END DO c----------------------------------------------------------------------- c DO i=Kfda,Klda DO i=Kfdax,Kldax IF((Stwt(i)+ONE).le.ZERO)Stwt(i)=ZERO END DO RETURN END xxxs.i0000664006604000003110000000014614521201631011351 0ustar sun00315stepsC C... Variables in Common Block /xxx/ ... character COMPILA*180 common /xxx/ COMPILA yprmy.f0000664006604000003110000000273714521201631011524 0ustar sun00315steps**==yprmy.f processed by SPAG 4.03F at 09:56 on 1 Mar 1994 SUBROUTINE yprmy(Y,Nr,Ypy) IMPLICIT NONE c----------------------------------------------------------------------- c Calculate the inner product of y c----------------------------------------------------------------------- c Name Type Description c----------------------------------------------------------------------- c i i Local do loop index c nr i Input number of rows in both x and y c y r Input nr long vector c ypy r Output scalar of y'y c----------------------------------------------------------------------- DOUBLE PRECISION ZERO PARAMETER(ZERO=0.0D0) c LOGICAL T,F c PARAMETER(T=.true.,F=.false.) c ------------------------------------------------------------------ INTEGER i,Nr DOUBLE PRECISION Y(*),Ypy c----------------------------------------------------------------------- c Take the sum of squares of y. c----------------------------------------------------------------------- Ypy=ZERO c ------------------------------------------------------------------ c CALL under0(T) c ------------------------------------------------------------------ DO i=1,Nr Ypy=Ypy+Y(i)**2 END DO c ------------------------------------------------------------------ c CALL under0(F) c ------------------------------------------------------------------ RETURN END yrly.f0000664006604000003110000000417514521201632011342 0ustar sun00315stepsC Last change: BCM 25 Nov 97 2:57 pm **==yrly.f processed by SPAG 4.03F at 09:56 on 1 Mar 1994 SUBROUTINE yrly(Icode,Icod2,Jx,Noser) IMPLICIT NONE c----------------------------------------------------------------------- INCLUDE 'srslen.prm' INCLUDE 'chrt.cmn' c----------------------------------------------------------------------- INTEGER i,Icod2,Icode,j,Jx,jy1,jy2,l,Noser CHARACTER*1 itype c----------------------------------------------------------------------- C PLOT CHART TYPES 1-6 c----------------------------------------------------------------------- DO i=1,N1 Xyvec=Y1(i) CALL value l=mod(Ifrst+i-2,Nseas)+1 itype=I1 c----------------------------------------------------------------------- IF(Nseas.eq.12)THEN itype=Ialpha(l) ELSE IF(Nseas.eq.4)THEN itype=Ialphq(l) END IF c----------------------------------------------------------------------- IF(Icode.eq.0)THEN IF(Ixy.gt.Ibottm)THEN Ia(Jx,Ixy)=itype ELSE IF(Ia(Jx,Ixy).ne.'S'.and.Ia(Jx,Ixy).ne.'T')Ia(Jx,Ixy)=itype END IF ELSE Ia(Jx,Ixy)=itype END IF c----------------------------------------------------------------------- IF((Icode-6).eq.0)THEN DO j=Ibottm-1,Ixy,-1 Ia(Jx,j)=itype END DO ELSE IF(Icode.eq.0)THEN DO j=2,Ixy-1 IF(Ia(Jx,j).eq.'S'.or.Ia(Jx,j).eq.'T')Ia(Jx,j)=' ' END DO DO j=Ibottm-1,Ixy+1,-1 IF(Ia(Jx,j).ne.'S'.and.Ia(Jx,j).ne.'T')Ia(Jx,j)=I1 END DO END IF c----------------------------------------------------------------------- IF(Noser.eq.2)THEN jy1=Ixy Xyvec=Y2(i) CALL value jy2=Ixy Ia(Jx,jy2)=I12 IF(Icod2.eq.15)CALL dot(jy1,jy2,Jx) END IF Jx=Jx+1 END DO c----------------------------------------------------------------------- IF(Icod2.ge.15)Icode=Icod2 c----------------------------------------------------------------------- RETURN END