**==aa0001.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C     REGION REQUIRED IS 358K
C     IBM PC VERSION OF X-11.2 SEASONAL ADJUSTMENT PROGRAM
C
C     U.S. BUREAU OF THE CENSUS
C     ECONOMIC RESEARCH AND ANALYSIS DIVISION
C     JULIUS SHISKIN, CHIEF
C     PROGRAMMED BY MORTON SOMER
C     CHART ROUTINE BY NORMAN BAKKA AND MORTON SOMER
C     NOVEMBER 1, 1968
C
C     SPECIAL GRAPHICS ROUTINES DEVELOPED BY MAUREEN LYNCH AND ALAN
C     HECKERT, ADAPTED FOR THE X-11.2 PROGRAM BY BRIAN C. MONSELL
C     MARCH 1, 1986
C
C     HOLIDAY ADJUSTMENT, SLIDING SPANS ANALYSIS, TABLE STORAGE
C     AND REDESIGNED NAMELIST INPUT PROGRAMMED BY BRIAN C. MONSELL
C     APRIL 4, 1988
C
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION D,Dwt,dwt2,Hfac,opx,ox,Rati,Rv,Sigm,Sigml,Sigmu,
     &                 Smp,Sti,Stopa,Stopma,Stor,Stpmf,Stptdf,Sts,Stsi
      DOUBLE PRECISION Sttdrf,Vc,Vi,Vp,Vs,Vtd
      INTEGER i,ib2,Ibreak,Ic,ic2,icer,Icm,Icyr,ifmt,Ifor,Igrz,igz2,ijk,
     &        ilyr,Im,In,indec,inm,inx,inx2
      INTEGER Io12,Iovr,iptd,Irang,irerr,irs,Irun,Issap,Itbl,itblon,
     &        itc1,Itchar,Itd,Itfmt,Ixerr,Iyr,iz,j,kd2,Kdwopt
      INTEGER Keastr,Kfulsm,kh2,Khol,kji,Klbrdy,Kmtyp,Kpage,Kpart,
     &        Kpropt,Kspopt,ksw2,Kswerr,Kswk,Kswt,kswv,Ktcopt,Kthgvg,
     &        kyr,L0
      INTEGER l1,l2,ld,ldec,Len,Len2,Length,Lfdc,Lfdr,lfmo,Llda,llmo,
     &        llyr,Lm,Lopt,Lstob,Lstyr,Lswv,Lterm,ltss
      INTEGER Lyr,Mach,max,Mcd,Mdec,Muladd,myr,ncmax,Ncol,nd,Nerr,nk,
     &        NL1,NL2,Nlen,Nopt,Np,Nr,Ns1,Nsea
      INTEGER Numtbl,Nw,Y2KLIM
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372,Y2KLIM=45)
      CHARACTER*1 reset,stop,sspan,seaadj,rewind,addmul,prtout,tsma,
     &            sma(12),ascibm,chart,holday,lom,td,Newpag,Spc,Part,as,
     &            bs,Aorb,prompt,y2kset
      CHARACTER*2 trend
      CHARACTER*3 outk,Cout,Tbl
      CHARACTER*4 csma(12),vsk(5),blank,toc(32),tit2(13),tdtit(4),vtk(3)
     &            ,Pcdif,Radif1,Radif2,difrat(9),Finap,Finab,Fstar
      CHARACTER*5 nlt
      CHARACTER*6 Ser,mser,prser,kblnk,tser
      CHARACTER*8 rdat
      CHARACTER*24 crerr(8),cre
      CHARACTER*80 Title,ofile,otemp,dfile,dtemp,ifile,pfile,tfile,
     &             ptemp,Tblfil,efile,f1
      CHARACTER*40 nf4,fmt,prfmt,Tf4
      LOGICAL Lgenx,lerout,lerdat,lerpri
      INTEGER Ieast,Begob,Begyr,Outdec,ssyear,prdec,Yrcomp,Yrapp,yc2,
     &        ya2,nl(4),i1,i2
      REAL siglim(2),tdsig,ptdwt(7)
      COMMON /ca    / Nw
      COMMON /cc    / Rati(36),Lterm(12),Sts(NL2),Stsi(NL1)
      COMMON /cf    / Begyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Outdec,
     &                Yrapp,Lstob,Lstyr,Kpropt
      COMMON /cf1   / Radif1(2),Radif2
      COMMON /cf2   / Finab(2),Finap(2),Cout,Newpag,Spc
      COMMON /cf3   / Title
      COMMON /cf4   / Part,Aorb
      COMMON /cj    / Muladd
      COMMON /cl    / Sti(NL1),Kmtyp(NL1),Sttdrf(NL2),D(7),Dwt(7),Fstar
      COMMON /cm    / Begob,Llda,Kfulsm,Lopt,Kdwopt,Lfdc,Lfdr,Ktcopt,
     &                Kspopt,Mdec,Pcdif(4),Smp(24),Stptdf(NL2),Stor(NL1)
     &                ,Stopa(NL1),Stpmf(NL1),Stopma(NL1),Yrcomp
      COMMON /cz    / Kpage,Np,Ser
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /fhol  / Hfac(NL2)
      COMMON /opthol/ Keastr,Klbrdy,Kthgvg
      COMMON /chrtm / Mach
      COMMON /grz   / Igrz
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lm
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /lzero / L0
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /xerr  / Nr,Nerr,Kswerr,Irun,Ixerr
      COMMON /xk    / Kswt,Lswv
      COMMON /itcom / Itchar,Itfmt,Itbl(10),Ifor,Numtbl,Iovr,Io12
      COMMON /tcom  / Tf4,Tblfil,Tbl(10)
C  *****  CHANGE TO IMPLEMENT X-11-ARIMA M & Q DIAGNOSTICS
      COMMON /mq2   / Vi,Vc,Vs,Vp,Vtd,Rv,Length
C  *****  END OF CHANGE
C  *****  CHANGE TO INCORPORATE TEST FOR EASTER
      COMMON /feast / Ieast(4),Lgenx
C  *****  END OF CHANGE
      DIMENSION ox(180),opx(180),dwt2(7)
      DATA max/360/
      DATA blank,kblnk/'    ','      '/
      DATA outk/'OUT'/
      DATA difrat/'RATI','OS  ','DIFF','EREN','CES ',' PER',' CEN',
     &     'T CH','ANGE'/
      DATA as,bs/'A','B'/
      DATA toc/'MULT','IPLI','CATI','VE  ','SEAS','ONAL',' ADJ','USTM',
     &     'ENT.','STAN','DARD','STAN','DARD','ADDI','TIVE','SUMM',
     &     'ARY ','MEAS','URES','LONG','  FU','LL  ',' NO ','   A',
     &     ' IF ','SIGN','IFIC','ANT.','  SH','ORT ','  SO','ME  '/
      DATA crerr/'NLX11                   ','NLXOPT                  ',
     &     'TITLE                   ','DATA FILE NAME          ',
     &     'OUTPUT FILE NAME        ','PRIOR FACTOR FILE NAME  ',
     &     'X-11.2 COMMAND FILE NAME','X-11.2 ERROR FILE NAME  '/
      DATA vsk/' 3  ','3X3 ','3X5 ','3X9 ','STA '/
      DATA vtk/' 9  ','13  ','23  '/
      DATA nl/72,84,96,132/
      NAMELIST /nlx11 / Ser,fmt,indec,Begob,Begyr,Lstob,Lstyr,rewind,
     & addmul,seaadj,prtout,Outdec,chart,ascibm,siglim,sspan,ssyear,
     & trend,sma,reset,Numtbl,y2kset,prompt,stop
      NAMELIST /nlxop / td,Yrcomp,Yrapp,tdsig,lom,ptdwt,holday,prfmt,
     & prser,prdec,stop
      Nr=5
      Np=6
      Nw=0
      nd=0
      nk=0
      ld=0
      Io12=0
      itblon=0
      Irun=1
      Ixerr=0
      irs=0
      reset='Y'
      lerout=.false.
      lerdat=.false.
      lerpri=.false.
      icer=7
   10 PRINT *,'ENTER CON (FOR INTERACTIVE PROCESSING) OR X-11.2 ',
     &      'COMMAND FILE NAME : '
      PRINT *,' > '
      READ ,ifile
      IF(ifile(1:3).ne.'CON'.and.ifile(1:3).ne.'con')THEN
       Nr=10
       tfile=ifile
       OPEN(Nr,FILE=ifile,STATUS='OLD',ERR=240)
      END IF
      icer=8
      Nerr=25
   20 IF(Nr.eq.10)THEN
       PRINT *,'ENTER X-11.2 ERROR FILE NAME OR @ (ERRORS STORED IN',
     &       ' C:\X11.ERR) :'
       PRINT *,' > '
       READ ,efile
       IF(efile.eq.'@')efile='C:\X11.ERR'
       tfile=efile
       OPEN(25,FILE=efile,ERR=250)
      END IF
   30 IF(reset.eq.'Y')THEN
       stop='N'
       Begob=1
       Begyr=0
       Lstob=12
       Lstyr=0
       Title=' '
       ofile=' '
       dfile=' '
       indec=0
       addmul='M'
       seaadj='Y'
       prtout='D'
       prser='      '
       Ser='      '
       pfile=' '
       siglim(1)=1.5
       siglim(2)=2.5
       trend='PS'
       chart='N'
       ascibm='Y'
       rewind='N'
       y2kset='Y'
       fmt='1'
       prfmt='N'
       prompt='N'
       Outdec=0
       prdec=3
       DO i=1,12
        sma(i)=' '
        IF(i.le.7)ptdwt(i)=0.
       END DO
       sma(1)='D'
       lom='N'
       td='N'
       Yrcomp=0
       Yrapp=0
       tdsig=2.5
       holday='N'
       sspan='N'
       ssyear=0
       Numtbl=0
      ELSE
       IF(yc2.ne.Yrcomp)Yrcomp=yc2
       IF(ya2.ne.Yrapp)Yrapp=ya2
       IF(Lopt.eq.4)Lopt=1
       IF(kswv.eq.0)THEN
        DO iptd=1,7
         ptdwt(iptd)=0.
        END DO
       END IF
      END IF
C  --  READ MANDITORY NAMELIST
      IF(Nr.eq.10)THEN
       nlt=crerr(1)(1:5)
       READ(Nr,nlx11,ERR=170,END=180)
       IF(stop.ne.'N'.and.stop.ne.'n')GO TO 260
       nlt=crerr(2)(1:5)
       READ(Nr,nlxop,ERR=170,END=180)
       IF(stop.ne.'N'.and.stop.ne.'n')GO TO 260
      ELSE
       icer=1
       PRINT *,' '
       PRINT *,'  CURRENT SETTINGS FOR NLX11 NAMELIST ARE : '
       PRINT nlx11
   40  PRINT *,' '
       PRINT *,'  ENTER VARIABLES AND THEIR SETTINGS FOR NLX11',
     &       ' NAMELIST : '
       READ(*,nlx11,ERR=190)
       IF(stop.ne.'N'.and.stop.ne.'n')GO TO 260
       PRINT nlx11
       IF(prompt.eq.'Y'.or.prompt.eq.'y')CALL prop(icer,*40)
       icer=2
       PRINT *,' '
       PRINT *,'  CURRENT SETTINGS FOR NLXOP NAMELIST ARE : '
       PRINT nlxop
   50  PRINT *,' '
       PRINT *,'  ENTER VARIABLES AND THEIR SETTINGS FOR NLXOP',
     &       ' NAMELIST : '
       READ(*,nlxop,ERR=200)
       IF(stop.ne.'N'.and.stop.ne.'n')GO TO 260
       PRINT nlxop
       IF(prompt.eq.'Y'.or.prompt.eq.'y')CALL prop(icer,*50)
      END IF
   60 Kswerr=0
      Kswk=1
      Kswt=4
      IF(irs.ne.2)THEN
       irs=9
       IF(reset.eq.'Y'.or.reset.eq.'y')irs=0
       IF(reset.eq.'N'.or.reset.eq.'n')irs=1
       IF(irs.eq.9)THEN
        CALL inerr(reset,irs,*260)
        IF(Nr.eq.10)WRITE(Nerr,1080)'RESET '
        IF(Nr.eq.5)PRINT 1080,'RESET '
       END IF
      END IF
      IF(Begob.lt.1.or.Begob.gt.12)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'BEGOB ',Begob,1,12
 1010  FORMAT(10X,'THE ENTRY FOR ',A6,' IS ',I6,', WHICH IS NOT ',
     &        'DEFINED',/,10X,'THE ENTRY SHOULD BE BETWEEN ',I6,' AND ',
     &        I6)
       IF(Nr.eq.5)PRINT 1010,'BEGOB ',Begob,1,12
      END IF
      IF(Lstob.lt.1.or.Lstob.gt.12)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'LSTOB ',Lstob,1,12
       IF(Nr.eq.5)PRINT 1010,'LSTOB ',Lstob,1,12
      END IF
      IF(.not.(y2kset.eq.'Y'.or.y2kset.eq.'y'.or.y2kset.eq.'N'.or.
     &         y2kset.eq.'n'))THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1021)'Y2KSET',y2kset
 1021  FORMAT(10X,'THE ENTRY FOR ',A6,' IS ',I6,', WHICH IS NOT ',
     &        'DEFINED',/,10X,'THE ENTRY SHOULD BE EITHER Y OR N')
       IF(Nr.eq.5)PRINT 1021,'Y2KSET',y2kset
      END IF
      IF(Begyr.le.0)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1020)'BEGYR ',Begyr
 1020  FORMAT(10X,'THE ENTRY FOR ',A6,' IS ',I6,', WHICH IS NOT ',
     &        'DEFINED',/,10X,'THE ENTRY SHOULD BE GREATER THAN ZERO')
       IF(Nr.eq.5)PRINT 1020,'BEGYR ',Begyr
      ELSE IF(Begyr.lt.1900)THEN
       IF(y2kset.eq.'Y'.or.y2kset.eq.'y')THEN
        IF(Begyr.le.Y2KLIM)THEN
         Begyr=2000+Begyr
        ELSE
         Begyr=1900+Begyr
        END IF
       ELSE
        Begyr=1900+Begyr
       END IF 
      END IF
      IF(Lstyr.le.0)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1020)'LSTYR ',Lstyr
       IF(Nr.eq.5)PRINT 1020,'LSTYR ',Lstyr
      ELSE IF(Lstyr.lt.1900)THEN
       IF(y2kset.eq.'Y'.or.y2kset.eq.'y')THEN
        IF(Lstyr.le.Y2KLIM)THEN
         Lstyr=2000+Lstyr
        ELSE
         Lstyr=1900+Lstyr
        END IF
       ELSE
        Lstyr=1900+Lstyr
       END IF 
      END IF
C --- CHECK LENGTH OF SERIES
      Llda=(Lstyr-Begyr)*12+Lstob
      Length=Llda-Begob+1
      IF(Length.lt.36)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1030)
 1030  FORMAT(10X,'THE SERIES IS LESS THAN 36 MONTHS LONG')
       IF(Nr.eq.5)PRINT 1030
      ELSE IF(Llda.gt.max)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1040)
 1040  FORMAT(10X,'SERIES EXCEEDS 20 CALENDAR YEARS IN LENGTH')
       IF(Nr.eq.5)PRINT 1040
      END IF
      kyr=Begyr
      Kpart=4
      Part=as
      Aorb=bs
C --- CHECK NO. OF DECIMAL PLACES IN INPUT
      IF(indec.lt.0.or.indec.gt.5)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'INDEC ',indec,0,5
       IF(Nr.eq.5)PRINT 1010,'INDEC ',indec,0,5
      END IF
      IF(prdec.lt.0.or.prdec.gt.5)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'PRDEC ',prdec,0,5
       IF(Nr.eq.5)PRINT 1010,'PRDEC ',prdec,0,5
      END IF
      IF(fmt.eq.'2')THEN
       ifmt=0
       WRITE(nf4,1050)indec,indec
 1050  FORMAT('(6F12.',I1,',/,6F12.',I1,',I2,A6)')
      ELSE IF(fmt.eq.'1')THEN
       ifmt=0
       WRITE(nf4,1060)indec
 1060  FORMAT('(12F6.',I1,',I2,A6)         ')
      ELSE IF(fmt.eq.' ')THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1070)
 1070  FORMAT(10X,'FORMAT FOR DATA INPUT NOT ENTERED')
       IF(Nr.eq.5)PRINT 1070
      ELSE
       ifmt=1
       nf4=fmt
      END IF
      IF(Outdec.lt.0.or.Outdec.gt.3)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'OUTDEC',Outdec,0,3
       IF(Nr.eq.5)PRINT 1010,'OUTDEC',Outdec,0,3
      END IF
      Muladd=9
      IF(addmul.eq.'M'.or.addmul.eq.'m')Muladd=0
      IF(addmul.eq.'A'.or.addmul.eq.'a')Muladd=1
      IF(Muladd.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'ADDMUL'
 1080  FORMAT(10X,'THE ENTRY FOR ',A6,' IS NOT DEFINED')
       IF(Nr.eq.5)PRINT 1080,'ADDMUL'
      END IF
      Kfulsm=9
      IF(seaadj.eq.'Y'.or.seaadj.eq.'y')Kfulsm=0
      IF(seaadj.eq.'N'.or.seaadj.eq.'n')Kfulsm=1
      IF(Kfulsm.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'SEAADJ'
       IF(Nr.eq.5)PRINT 1080,'SEAADJ'
      END IF
      Kpropt=9
      IF(prtout.eq.'S'.or.prtout.eq.'s')Kpropt=0
      IF(prtout.eq.'D'.or.prtout.eq.'d')Kpropt=1
      IF(prtout.eq.'L'.or.prtout.eq.'l')Kpropt=2
      IF(prtout.eq.'F'.or.prtout.eq.'f')Kpropt=3
      IF(Kpropt.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'PRTOUT'
       IF(Nr.eq.5)PRINT 1080,'PRTOUT'
      END IF
C --- TEST SIGMA LIMITS FOR GRADUATING EXTREMES
      IF(siglim(2).le.0.)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1090)'UPPER'
 1090  FORMAT(A5,' SIGMA LIMIT IS NEGATIVE OR ZERO')
       IF(Nr.eq.5)PRINT 1090,'UPPER'
      ELSE
       Sigmu=dble(siglim(2))
      END IF
      IF(siglim(1).le.0)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1090)'LOWER'
       IF(Nr.eq.5)PRINT 1090,'LOWER'
      ELSE
       Sigml=dble(siglim(1))
      END IF
      IF(siglim(2).lt.siglim(1))THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1100)
 1100  FORMAT('UPPER SIGMA LIMIT IS LESS THAN LOWER SIGMA LIMIT')
       IF(Nr.eq.5)PRINT 1100
      END IF
      Lswv=0
C --- TEST SEASONAL FACTOR CURVE MOVING AVERAGES
      DO i=1,12
       tsma=sma(i)
       IF(tsma.eq.' ')tsma=sma(1)
       Lterm(i)=9
       IF(tsma.eq.'D'.or.tsma.eq.'d')Lterm(i)=0
       IF(tsma.eq.'1')Lterm(i)=1
       IF(tsma.eq.'3')Lterm(i)=2
       IF(tsma.eq.'5')Lterm(i)=3
       IF(tsma.eq.'9')Lterm(i)=4
       IF(tsma.eq.'S'.or.tsma.eq.'s')Lterm(i)=5
       IF(Lterm(i).eq.9)THEN
        CALL inerr(reset,irs,*260)
        IF(Nr.eq.10)WRITE(Nerr,1110)i
 1110   FORMAT(10X,'SEASONAL MOVING AVERAGE SELECTED FOR MONTH ',I2,
     &         ' IS UNDEFINED')
        IF(Nr.eq.5)PRINT 1110,i
       ELSE IF(Lterm(i).eq.0)THEN
        csma(i)=blank
       ELSE
        Lswv=1
        j=Lterm(i)
        csma(i)=vsk(j)
       END IF
      END DO
      Ktcopt=9
      IF(trend.eq.'PS'.or.trend.eq.'ps'.or.trend.eq.'pS'.or.
     &   trend.eq.'Ps')Ktcopt=0
      IF(trend.eq.'09')Ktcopt=1
      IF(trend.eq.'13')Ktcopt=2
      IF(trend.eq.'23')Ktcopt=3
      IF(Ktcopt.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'TREND '
       IF(Nr.eq.5)PRINT 1080,'TREND '
      END IF
      Issap=9
      Ibreak=0
      IF(sspan.eq.'N'.or.sspan.eq.'n')Issap=0
      IF(sspan.eq.'A'.or.sspan.eq.'a')Issap=1
      IF(sspan.eq.'S'.or.sspan.eq.'s')THEN
       Issap=1
       Ibreak=1
      END IF
      IF(Issap.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'SSPAN '
       IF(Nr.eq.5)PRINT 1080,'SSPAN '
      END IF
C --- TEST GRAPHICS OPTIONS
      Igrz=9
      IF(chart.eq.'N'.or.chart.eq.'n')Igrz=0
      IF(chart.eq.'S'.or.chart.eq.'s')Igrz=1
      IF(chart.eq.'A'.or.chart.eq.'a')Igrz=2
      IF(Igrz.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'CHART '
       IF(Nr.eq.5)PRINT 1080,'CHART '
      END IF
      Mach=9
      IF(ascibm.eq.'Y'.or.ascibm.eq.'y')Mach=0
      IF(ascibm.eq.'N'.or.ascibm.eq.'n')Mach=1
      IF(Mach.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'ASCIBM'
       IF(Nr.eq.5)PRINT 1080,'ASCIBM'
      END IF
C --- TEST HOLIDAY ADJUSTMENT OPTIONS
      Khol=9
      Keastr=0
      Klbrdy=0
      Kthgvg=0
      IF(holday.eq.'N'.or.holday.eq.'n')THEN
       Khol=0
      ELSE IF(holday.eq.'A'.or.holday.eq.'a')THEN
       Keastr=1
       Klbrdy=1
       Kthgvg=1
       Khol=1
      ELSE IF(holday.eq.'E'.or.holday.eq.'e')THEN
       Keastr=1
       Khol=1
      ELSE IF(holday.eq.'F'.or.holday.eq.'f')THEN
       Keastr=1
       Klbrdy=2
       Kthgvg=2
       Khol=1
      END IF
      IF(Khol.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'HOLDAY'
       IF(Nr.eq.5)PRINT 1080,'HOLDAY'
      ELSE IF(Khol.gt.0)THEN
       Lgenx=.true.
      END IF
C --- TEST TBLE STORAGE OPTION
      IF(Numtbl.lt.0.or.Numtbl.gt.10)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'NUMTBL',Numtbl,0,10
       IF(Nr.eq.5)PRINT 1010,'NUMTBL',Numtbl,0,10
      END IF
C --- TEST LENGTH OF MONTH ADJUSTMENT OPTION
      Lopt=9
      IF(lom.eq.'N'.or.lom.eq.'n')Lopt=0
      IF(lom.eq.'Y'.or.lom.eq.'y')Lopt=1
      IF(Lopt.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'LOM   '
       IF(Nr.eq.5)PRINT 1080,'LOM   '
      END IF
C --- TEST FOR PRIOR TRADING DAY FACTORS
      kswv=0
      DO i=1,7
       IF(ptdwt(i).lt.0)THEN
        CALL inerr(reset,irs,*260)
        IF(Nr.eq.10)WRITE(Nerr,1120)i,ptdwt(i)
 1120   FORMAT(10X,'PTDWT(',I1,') = ',F8.4,', NEGATIVE WEIGHTS NOT',
     &         ' ALLOWED')
        IF(Nr.eq.5)PRINT 1120,i,ptdwt(i)
       ELSE IF(ptdwt(i).gt.0)THEN
        kswv=1
       END IF
      END DO
      IF(kswv.eq.0)THEN
C --- NO PRIOR T.D.FACTORS. SET EQUAL TO 1.
       Kswt=Kswt-1
       IF(Muladd.eq.0)THEN
        DO i=1,7
         ptdwt(i)=1.
        END DO
       ELSE
        Lopt=0
       END IF
      ELSE IF(Muladd.eq.1)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1130)
 1130  FORMAT(10X,'PRIOR TRADING DAY ADJUSTMENT NOT ALLOWED FOR AN ',
     &        'ADDITIVE ADJUSTMENT')
       IF(Nr.eq.5)PRINT 1130
      END IF
C --- TEST TRADING DAY REGRESSION OPTION
      Kdwopt=9
      IF(td.eq.'N'.or.td.eq.'n')Kdwopt=0
      IF(td.eq.'D'.or.td.eq.'d')Kdwopt=1
      IF(td.eq.'A'.or.td.eq.'a')Kdwopt=2
      IF(td.eq.'F'.or.td.eq.'f')Kdwopt=3
      IF(Kdwopt.eq.9)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1080)'TD    '
       IF(Nr.eq.5)PRINT 1080,'TD    '
      END IF
C --- TEST SIGMA LIMIT FOR EXCLUDING EXTREMES FROM T.D. REGRESSION
C --- TEST T.D.REGRESSION COMPUTE AND APPLY DATES
      IF(tdsig.le.0)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1090)'T. D.'
       IF(Nr.eq.5)PRINT 1090,'T. D.'
      ELSE
       Sigm=dble(tdsig)
      END IF
      llyr=Begyr+(Llda-1)/12
      yc2=Yrcomp
      IF(Yrcomp.lt.0)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1140)'COMPUTATION'
 1140  FORMAT(10X,'BEGINNING YEAR FOR TRADING DAY ',A11,' IS ',
     &        'NEGATIVE')
       IF(Nr.eq.5)PRINT 1140,'COMPUTATION'
      ELSE IF(Yrcomp.eq.0)THEN
       Yrcomp=Begyr
      ELSE IF(Yrcomp.lt.1900)THEN
       IF(y2kset.eq.'Y'.or.y2kset.eq.'y')THEN
        IF(Yrcomp.le.Y2KLIM)THEN
         Yrcomp=2000+Yrcomp
        ELSE
         Yrcomp=1900+Yrcomp
        END IF
       ELSE
        Yrcomp=1900+Yrcomp
       END IF 
      END IF
      IF(Begyr.gt.Yrcomp.or.llyr.lt.Yrcomp)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'YRCOMP',Yrcomp,Begyr,llyr
       IF(Nr.eq.5)PRINT 1010,'YRCOMP',Yrcomp,Begyr,llyr
      END IF
      IF(Begyr.eq.Yrcomp)THEN
       Lfdc=Begob
      ELSE
       Lfdc=(Yrcomp-Begyr)*12+1
      END IF
      ya2=Yrapp
      IF(Yrapp.lt.0)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1140)'APPLICATION'
       IF(Nr.eq.5)PRINT 1140,'APPLICATION'
      ELSE IF(Yrapp.eq.0)THEN
       Yrapp=Begyr
      ELSE IF(Yrapp.lt.1900)THEN
       IF(y2kset.eq.'Y'.or.y2kset.eq.'y')THEN
        IF(Yrapp.le.Y2KLIM)THEN
         Yrapp=2000+Yrapp
        ELSE
         Yrapp=1900+Yrapp
        END IF
       ELSE
        Yrapp=1900+Yrapp
       END IF 
      END IF
      IF(Begyr.gt.Yrapp.or.llyr.lt.Yrapp)THEN
       CALL inerr(reset,irs,*260)
       IF(Nr.eq.10)WRITE(Nerr,1010)'YRAPP',Yrapp,Begyr,llyr
       IF(Nr.eq.5)PRINT 1010,'YRAPP',Yrapp,Begyr,llyr
      END IF
      IF(Begyr.eq.Yrapp)THEN
       Lfdr=Begob
      ELSE
       Lfdr=(Yrapp-Begyr)*12+1
      END IF
      IF(Issap.ne.0)THEN
       Nsea=12
       Itd=0
       IF(Kdwopt.gt.1)Itd=1
       ltss=0
       DO i=1,12
        IF(Lterm(i).eq.0.and.ltss.lt.3)THEN
         ltss=3
        ELSE IF(Lterm(i).gt.ltss)THEN
         ltss=Lterm(i)
        END IF
       END DO
       IF(ltss.eq.5)THEN
        Nlen=Length-36
        Ncol=4
        IF(Nlen.gt.144)THEN
         Nlen=144
         IF(Lstob.lt.12)Nlen=132
        ENDIF
        IF(Nlen.lt.36)THEN
         Ncol=((Length-36)/12)+1
         IF(Ncol.le.1)THEN
          Ncol=0
          Issap=0
          IF(Nr.eq.10)THEN
           WRITE(Nerr,1150)
           IF(Ixerr.eq.0)Ixerr=1
          END IF
          IF(Nr.eq.5)PRINT 1150
          GO TO 70
         END IF
         Nlen=Length-12*(Ncol-1)
        END IF
       ELSE
        Nlen=nl(ltss)
        ncmax=((Length-Nlen)/12)+1
        IF(ncmax.gt.4)THEN
         Ncol=4
        ELSE IF(ncmax.lt.2)THEN
         Ncol=0
         Issap=0
         IF(Nr.eq.10)THEN
          WRITE(Nerr,1150)
          IF(Ixerr.eq.0)Ixerr=1
         END IF
         IF(Nr.eq.5)PRINT 1150
 1150    FORMAT('    NOT ENOUGH DATA TO PERFORM SLIDING SPANS ',
     &          'ANALYSIS')
         GO TO 70
        ELSE
         Ncol=ncmax
        END IF
       END IF
       Len=Nlen+(Ncol-1)*12
       IF(Length.eq.Len)THEN
        Im=Begob
        Iyr=Begyr
       ELSE
        l2=Length-(Nlen+(Ncol-1)*12)
        Iyr=Begyr+l2/12
        Im=Begob+mod(l2,12)
        IF(Im.gt.12)THEN
         Im=Im-12
         Iyr=Iyr+1
        END IF
        IF(ltss.lt.5)THEN
         IF((Begob.eq.1.and.Im.ne.1).or.(Begob.lt.Im.and.Iyr.eq.Begyr))
     &      THEN
          Nlen=(Im-Begob)+Nlen
          Im=Begob
         ELSE IF(Im.gt.1.and.Iyr.gt.Begyr)THEN
          Nlen=(Im-1)+Nlen
          Im=1
         END IF
        ELSE IF(Im.gt.1)THEN
         Nlen=Nlen-(12-Im+1)
         Im=1
        END IF
        Len=Nlen+(Ncol-1)*12
       END IF
       Lm=mod(Len,12)
       IF(Lm.eq.0)Lm=12
       IF(ssyear.le.Iyr)THEN
        Icm=Im
        Icyr=Iyr
        Ic=Im
       ELSE
        Icm=1
        Icyr=ssyear
        Ic=(Icyr-Iyr)*12+Icm
       END IF
      END IF
   70 IF(Kswt.le.0)THEN
       IF(Nr.eq.10)WRITE(Nerr,1160)ifile
 1160  FORMAT('    EXECUTION FOR THIS X-11.2 RUN CEASES.',/,4X,
     &        'WILL ATTEMPT TO EXECUTE REMAINDER OF COMMANDS IN ',A80)
       IF(Nr.eq.5)PRINT *,'ERRORS FOUND IN NAMELIST INPUT . . .',
     &                  ' TRY AGAIN'
       GO TO 30
      END IF
      DO i=1,13
       tit2(i)=toc(i)
      END DO
      irerr=0
      IF(Numtbl.gt.0)CALL tabset(nf4,ifmt,itblon,reset,prompt,*260)
      IF(Nr.eq.5)PRINT *,' '
      CALL inc(3,tfile,Title,ifile,crerr,*30,*260)
      CALL inc(4,dfile,dtemp,ifile,crerr,*30,*260)
      CALL inc(5,ofile,otemp,ifile,crerr,*30,*260)
      IF(prfmt.ne.'N'.and.prfmt.ne.'n')
     &   CALL inc(6,pfile,ptemp,ifile,crerr,*30,*260)
      IF(tfile.ne.'@')Title=tfile
   80 IF(Nw.gt.0.and.ofile.eq.'@')THEN
       ofile=otemp
       IF(lerout)THEN
        tfile=ofile
        GOTO 250
       ENDIF
      ELSE IF(otemp.ne.ofile.or.Nw.eq.0)THEN
       IF(Np.eq.16)CLOSE(16)
       tfile=ofile
       otemp=ofile
       icer=5
       OPEN(16,FILE=ofile,ERR=250)
       IF(lerout)lerout=.false. 
       IF(Nw.eq.0)THEN
        Np=16
        Nw=Np
       END IF
      END IF
   90 IF(Nr.eq.10.and.dfile.eq.ifile)THEN
       nd=Nr
       dtemp=dfile
      ELSE IF(nd.gt.0.and.dfile.eq.'@')THEN
       dfile=dtemp
       IF(lerdat)THEN
        tfile=dfile
        GO TO 240
       ENDIF
      ELSE IF(dtemp.ne.dfile.or.nd.eq.0)THEN
       IF(nd.eq.15)CLOSE(15)
       tfile=dfile
       dtemp=dfile
       icer=4
       OPEN(15,FILE=dfile,STATUS='OLD',ERR=240)
       IF(lerdat)lerdat=.false.
       IF(nd.eq.0)nd=15
      END IF
      IF(rewind.eq.'Y'.or.rewind.eq.'y')REWIND nd
      tfile=dfile
      tser=Ser
      lfmo=1
  100 llmo=lfmo+11
      DO WHILE (.true.)
C --- READ DATA CARDS. CHECK DATE AND IDENT
C --- REGARDLESS OF MONTH IN WHICH SERIES STARTS, STOR(1) IS EQUATED TO
C --- JANUARY, STOR(2) TO FEB , ETC.
       IF(ifmt.gt.0)THEN
        IF(llmo.gt.Llda)llmo=Llda
        IF(Begob.gt.lfmo)lfmo=Begob
       ENDIF
       CALL input(Stor,ifmt,lfmo,llmo,nd,nf4,myr,mser,y2kset,*210,*220,
     &            *230)
       IF(ifmt.eq.0)THEN
        IF(Ser.ne.mser)THEN
         irerr=1
         GO TO 110
        ELSE IF(Ser.eq.mser.and.irerr.eq.1)THEN
         irerr=0
        END IF
        IF(kyr.ne.myr)THEN
         irerr=2
         GO TO 110
        ELSE IF(kyr.eq.myr.and.irerr.eq.2)THEN
         irerr=0
        END IF
       END IF
       IF(kyr.lt.Lstyr)THEN
        kyr=kyr+1
        lfmo=llmo+1
        GO TO 100
       ELSE
        IF(Muladd.ne.1)THEN
C --- TEST FOR ZERO, NEGATIVE DATA- MULTIPLICATIVE VERSION
         iz=0
         DO i=Begob,Llda
          IF(Stor(i).le.0.0)CALL zdat(i,0,Begyr,reset,irs,prfmt,iz,*260)
         END DO
         IF(iz.eq.1)CALL zdat(i,3,Begyr,reset,irs,prfmt,iz,*260)
        END IF
        GO TO 120
       END IF
  110 END DO
C --- TEST FOR PRIOR MONTHLY ADJUSTMENT FACTORS
  120 IF(prfmt.eq.'N'.or.prfmt.eq.'n')THEN
C***** SPAG has made duplicate copies of the following statement 
       Kswt=Kswt-2
      ELSE
C --- READ PRIOR MONTHLY FACTORS AND CHECK DATES AND IDENT.
       tfile=pfile
       tser=prser
       IF(dfile.eq.pfile)THEN
        nk=nd
       ELSE
        nk=20
        IF(pfile.eq.'@')THEN
         pfile=ptemp
         IF(lerpri)GO TO 240
        ELSE
         ptemp=pfile
        ENDIF
        icer=6
        OPEN(20,FILE=pfile,STATUS='OLD',ERR=240)
        IF(lerpri)lerpri=.false.
       END IF
       lfmo=1
       kyr=Begyr
       IF(prfmt.eq.'2')THEN
        ifmt=0
        WRITE(nf4,1050)prdec,prdec
       ELSE IF(prfmt.eq.'1')THEN
        ifmt=0
        WRITE(nf4,1060)prdec
       ELSE IF(prfmt.eq.' ')THEN
        CALL inerr(reset,irs,*260)
        IF(Nr.eq.10)WRITE(Nerr,1170)
 1170   FORMAT(10X,'FORMAT FOR PRIOR FACTOR INPUT NOT ENTERED')
        IF(Nr.eq.5)PRINT 1070
       ELSE
        ifmt=1
        nf4=prfmt
       END IF
       irerr=0
       IF(rewind.eq.'Y')REWIND nk
       ld=1
C***** SPAG has made duplicate copies of the following statement 
       llmo=lfmo+11
       DO WHILE (.true.)
        IF(ifmt.ge.1)THEN
         IF(llmo.gt.Llda)llmo=Llda
         IF(Begob.gt.lfmo)lfmo=Begob
        ENDIF
        CALL input(Stpmf,ifmt,lfmo,llmo,nk,nf4,myr,mser,y2kset,*210,
     &             *220,*230)
        IF(ifmt.lt.1)THEN
         IF(prser.ne.mser)THEN
          irerr=1
          GO TO 130
         ELSE IF(prser.eq.mser.and.irerr.eq.1)THEN
          irerr=0
         END IF
         IF(kyr.ne.myr)THEN
          irerr=2
          GO TO 130
         ELSE IF(kyr.eq.myr.and.irerr.eq.2)THEN
          irerr=0
         END IF
        END IF
        IF(kyr.lt.Lstyr)THEN
         kyr=kyr+1
         lfmo=llmo+1
C***** The following statement is a duplicate copy made by SPAG
         llmo=lfmo+11
        ELSE
         IF(nk.eq.20)CLOSE(20)
         IF(Muladd.eq.0)THEN
C --- CHECK FOR ZERO, NEGATIVE WTS. -MULT. ADJUSTMENT ONLY.
          iz=0
          DO i=Begob,Llda
           IF(Stpmf(i).le.0.0)CALL zdat(i,1,Begyr,reset,irs,prfmt,iz,
     &                                  *260)
          END DO
          IF(iz.ne.0)THEN
           IF(iz.eq.1)CALL zdat(i,3,Begyr,reset,irs,prfmt,iz,*260)
C***** The following statement is a duplicate copy made by SPAG
           Kswt=Kswt-2
          END IF
         END IF
         GO TO 140
        END IF
  130  END DO
      END IF
  140 IF(Kswt.le.0)THEN
C --- SERIES REJECTED
       IF(Nr.eq.5)PRINT 1180
 1180  FORMAT(/48X,'SERIES REJECTED')
       IF(Nr.eq.10)THEN
        WRITE(Nerr,1180)
        WRITE(Nerr,1160)ifile
       END IF
      ELSE
       IF(irs.eq.2)reset='Y'
       IF(Muladd.eq.0)THEN
        Radif1(1)=difrat(1)
        Radif1(2)=difrat(2)
        Radif2=blank
        Pcdif(1)=difrat(6)
        Pcdif(2)=difrat(7)
        Pcdif(3)=difrat(8)
        Pcdif(4)=difrat(9)
        ldec=100
        Mdec=1
       ELSE
C --- SET TITLES FOR ADDITIVE VERSION
        tit2(1)=blank
        tit2(2)=toc(14)
        tit2(3)=toc(15)
        tit2(4)=blank
        Radif1(1)=difrat(3)
        Radif1(2)=difrat(4)
        Radif2=difrat(5)
        Pcdif(1)=blank
        Pcdif(2)=difrat(3)
        Pcdif(3)=difrat(4)
        Pcdif(4)=difrat(5)
        ldec=0
        Mdec=0
       END IF
C --- SET ALL CALENDAR FACTORS TO 100. FOR MULT. OR 0. FOR ADD. VERSION
       DO i=Begob,Llda
        Sttdrf(i)=ldec
        IF(prfmt.eq.'N'.or.prfmt.eq.'n')Stpmf(i)=ldec
        IF(holday.eq.'N'.or.holday.eq.'n')Hfac(i)=ldec
        Stptdf(i)=ldec
C --- SET PRIOR ADJUSTED SERIES EQUAL TO  ORIGINAL
        Stopma(i)=Stor(i)
        Stopa(i)=Stor(i)
       END DO
       IF(Kfulsm.eq.1)THEN
C --- SET TITLES FOR SUMMARY MEASURES RUN
        tit2(5)=toc(16)
        tit2(6)=toc(17)
        tit2(7)=toc(18)
        tit2(8)=toc(19)
        tit2(9)=blank
C --- TEST PRINTOUT OPTION
       ELSE IF(Kpropt.eq.0)THEN
        tit2(10)=toc(29)
        tit2(11)=toc(30)
       ELSE IF(Kpropt.eq.2)THEN
C --- LONG PRINTOUT
        tit2(10)=blank
        tit2(11)=toc(20)
       ELSE IF(Kpropt.eq.3)THEN
C --- FULL PRINTOUT
        tit2(10)=toc(21)
        tit2(11)=toc(22)
C --- STANDARD PRINTOUT. TEST CHART OPTION
       END IF
       IF(Igrz.eq.0)THEN
C --- NO CHARTS
        tit2(12)=blank
        tit2(13)=toc(23)
       ELSE IF(Igrz.eq.1)THEN
C --- SOME CHARTS
        tit2(12)=toc(31)
        tit2(13)=toc(32)
       ELSE IF(Igrz.eq.2)THEN
C --- ALL CHARTS
        tit2(12)=toc(24)
        tit2(13)=toc(22)
       END IF
       Kpage=1
C --- WRITE BLANK PAGE AT START OF EACH SERIES
       WRITE(Nw,1190)Newpag
 1190  FORMAT(A1)
C --- WRITE TITLE PAGE
       WRITE(Nw,1200)
 1200  FORMAT(44X,'X-11.2 SEASONAL ADJUSTMENT PROGRAM',/,47X,'U. S. ',
     &        'BUREAU OF THE CENSUS',/,45X,
     &        'STATISTICAL RESEARCH DIVISION',/,53X,'SEPTEMBER 1, 1988',
     &        //,12X,'THE X-11 PROGRAM IS DIVIDED ',
     &        'INTO SEVEN MAJOR PARTS-',/,17X,'PART',7X,'DESCRIPTION',/,
     &        18X,'A. PRIOR ADJUSTMENTS, IF ANY',/,18X,
     &        'B. PRELIMINARY ESTIMATES ',
     &        'OF IRREGULAR COMPONENT WEIGHTS',/,25X,
     &        'AND REGRESSION TRADING ','DAY FACTORS',/,18X,
     &        'C. FINAL ESTIMATES OF ABOVE',/,18X,'D. ',
     &        'FINAL ESTIMATES OF SEASONAL, TREND-CYCLE AND IRREGULAR ',
     &        'COMPONENTS',/,18X,'E. ANALYTICAL TABLES',/,18X,
     &        'F. SUMMARY ','MEASURES',/,18X,
     &        'S. SLIDING SPANS DIAGNOSTICS, IF REQUESTED')
       WRITE(Nw,1210)
 1210  FORMAT(12X,'TABLES ARE IDENTIFIED BY THEIR PART LETTER AND ',
     &        'SEQUENCE WITHIN THE PART. A GIVEN TABLE HAS THE SAME',/,
     &        12X,
     &  'IDENTIFICATION IN THE STANDARD, LONG AND FULL PRINTOUTS.  THE '
     &  ,'SAME NUMBER IS GIVEN TO CORRESPONDING',/,12X,
     &  'TABLES IN PARTS ',
     &  'B, C AND D. THUS, TABLES B10., C10. AND D10. ARE ALL TABLES OF'
     &  ,' SEASONAL FACTORS.',/,12X,
     &  'WHERE NO CORRESPONDING TABLE EXISTS',
     &  ' THE SEQUENCE NO. IS NOT USED IN THE PART.  THUS, B8. AND D8. '
     &  ,'ARE',/,12X,
     &  'TABLES OF UNMODIFIED SI RATIOS BUT THERE IS NO C8.',///)
       CALL date(rdat)
       WRITE(Nw,1220)rdat,Title,Ser,Begob,Begyr,Lstob,Lstyr,
     &               (tit2(i),i=1,13)
 1220  FORMAT(47X,'THIS SERIES RUN ',A8,/,12X,'SERIES TITLE- ',A80,
     &        '  SERIES NO. ',A6,/,43X,'PERIOD COVERED- ',I2,'/',I4,
     &        ' TO ',I2,'/',I4,//,36X,'TYPE OF RUN - ',3A4,A3,5A4,/,42X,
     &        2A4,' PRINTOUT.',1X,2A4,' CHARTS.')
C --- WRITE LOG ENTRY
       DO i=1,4
        tdtit(i)=blank
       END DO
       Cout=outk
       IF(Lopt.eq.1)THEN
C --- WITH
        Lopt=4
        Cout=blank
       END IF
       IF(kswv.eq.1)WRITE(Nw,1230)Cout
 1230  FORMAT(28X,'PRIOR TRADING DAY ADJUSTMENT WITH',A3,
     &        ' LENGTH OF MONTH ADJUSTMENT.')
       IF(Kdwopt.gt.1)WRITE(Nw,1240)Yrcomp,tdsig
 1240  FORMAT(12X,'TRADING DAY REGRESSION COMPUTED STARTING ',I4,
     &        ' EXCLUDING IRREGULAR VALUES OUTSIDE ',F3.1,
     &        '-SIGMA LIMITS.')
       IF(Kdwopt.lt.2)THEN
        WRITE(Nw,1250)
 1250   FORMAT(38X,'TRADING DAY REGRESSION ESTIMATES NOT APPLIED.')
        GO TO 150
       ELSE IF(Kdwopt.ne.2)THEN
        tdtit(1)=toc(25)
        tdtit(2)=toc(26)
        tdtit(3)=toc(27)
        tdtit(4)=toc(28)
       END IF
       WRITE(Nw,1260)Yrapp,(tdtit(i),i=1,4)
 1260  FORMAT(29X,'TRADING DAY REGRESSION ESTIMATES APPLIED STARTING ',
     &        I4,4A4)
C --- PRINT MESSAGE FOR HOLIDAY ADJUSTMENT
  150  IF(Khol.eq.1)THEN
        WRITE(Nw,1270)
 1270   FORMAT(41X,'PRIOR HOLIDAY ADJUSTMENT FACTORS ESTIMATED FOR:')
        IF(Keastr.eq.1)WRITE(Nw,1280)
        IF(Klbrdy.eq.1)WRITE(Nw,1290)
        IF(Klbrdy.eq.2)WRITE(Nw,1300)
 1280   FORMAT(45X,'- EASTER')
 1290   FORMAT(45X,'- LABOR DAY',/,45X,'- THANKSGIVING')
 1300   FORMAT(45X,'- LABOR DAY (APPLIED IF F-TEST SIGNIFICANT)',/,45X,
     &         '- THANKSGIVING (APPLIED IF F-TEST SIGNIFICANT)')
       END IF
       IF(prfmt.ne.'N')WRITE(Nw,1310)
 1310  FORMAT(48X,'PRIOR MONTHLY ADJUSTMENT.')
       WRITE(Nw,1320)(siglim(i),i=1,2)
 1320  FORMAT(31X,'SIGMA LIMITS FOR GRADUATING EXTREME VALUES ARE ',
     &        F3.1,' AND ',F3.1)
       IF(Lswv.ne.0)THEN
        WRITE(Nw,1330)(csma(i),i=1,12)
 1330   FORMAT(15X,
     &'MOVING AVERAGES FOR SEASONAL FACTOR CURVES- J   F   M   A   M   J
     &   J   A   S   O   N   D'/58X,12A4)
       END IF
C --- TEST TREND CYCLE MOVING AVERAGE
       IF(Ktcopt.lt.1)THEN
        Ktcopt=4
       ELSE
        WRITE(Nw,1340)vtk(Ktcopt)
 1340   FORMAT(25X,
     &         'MOVING AVERAGE FOR THE VARIABLE TREND CYCLE ROUTINE- ',
     &         A2,'-TERM HENDERSON')
       END IF
       WRITE(Np,1350)Ser,Begob,Begyr,Lstob,Lstyr,(tit2(i),i=1,11)
 1350  FORMAT(2X,A6,2X,I2,'/',I4,' - ',I2,'/',I4,2X,3A4,A3,5A4,2X,2A4,
     &        ' PRINTOUT')
       DO i=1,7
        Dwt(i)=ptdwt(i)
       END DO
       IF(Khol.eq.1.and.Muladd.eq.1)THEN
        WRITE(Nw,1360)
 1360   FORMAT('   HOLIDAY ADJUSTMENT OPTION CAN ONLY BE USED WITH A ',
     &         'MULTIPLICATIVE ADJUSTMENT.',/,'   HOLIDAY OPTION ',
     &         'IS TURNED OFF FOR THIS RUN.')
        Khol=0
       END IF
       PRINT *,' '
       PRINT *,'     X-11.2 IS NOW EXECUTING . . . ',Ser
       IF(Issap.eq.1)THEN
        Issap=2
        kd2=Kdwopt
        kh2=Khol
        ksw2=Kswt
        DO i=1,7
         dwt2(i)=Dwt(i)
        END DO
        IF(Muladd.eq.1.and.Itd.eq.1)Itd=-1
        L0=Llda-(Nlen+Im-2+(Ncol-1)*12)
        l1=L0+Im-1
        DO ijk=l1,Llda
         IF(prser.ne.kblnk)opx(ijk-L0+1)=Stpmf(ijk)
         ox(ijk-L0+1)=Stor(ijk)
        END DO
       END IF
       IF(Khol.eq.1)CALL runhol
       CALL x11pt1
       CALL subx11
       IF(Issap.eq.2)THEN
        Issap=1
        ib2=Begob
        igz2=Igrz
        Igrz=0
        IF(Lfdc.gt.Begob)THEN
         WRITE(Nerr,1370)
 1370    FORMAT('  STARTING YEAR FOR TRADING DAY COMPUTATIONS WILL ',
     &          'BE RESET TO FIRST YEAR OF SPAN')
        END IF
        IF(Lfdr.gt.Begob)THEN
         WRITE(Nerr,1380)
 1380    FORMAT('  STARTING YEAR FOR APPLYING TRADING DAY FACTORS ',
     &          'WILL BE RESET TO FIRST YEAR OF SPAN')
        END IF
        IF(Nlen.lt.60.and.kd2.gt.0)THEN
         WRITE(Nerr,1390)
 1390    FORMAT('  LENGTH OF SPAN IS TOO SHORT FOR TRADING DAY ',
     &          'REGRESSION; TRADING DAY OPTION TURNED OFF.')
         Itd=0
         kd2=0
        END IF
        DO ijk=1,Ncol
         Begob=L0+(ijk-1)*12+Im-1
         Llda=Begob+Nlen-1
         DO kji=Begob,Llda
          Stor(kji)=ox(kji-L0+1)
          Stopa(kji)=ox(kji-L0+1)
          Stopma(kji)=ox(kji-L0+1)
          Sttdrf(kji)=ldec
          IF(prser.ne.kblnk)Stpmf(kji)=opx(kji-L0+1)
         END DO
         DO i=1,7
          Dwt(i)=dwt2(i)
         END DO
         ilyr=Iyr+ijk-1
         Yrcomp=ilyr
         Lfdc=Begob
         Yrapp=ilyr
         Lfdr=Begob
         Part=as
         Kpart=4
         Kdwopt=kd2
         IF(kd2.eq.3)Kdwopt=2
         Khol=kh2
         Kswt=ksw2
c-----------------------------------------------------------------------
c     Set logical variable that generates X-11 holiday date indicator
c     variable
c-----------------------------------------------------------------------
         IF(Lgenx)THEN
          Lgenx=.false.
c-----------------------------------------------------------------------
c     Check to see if easter adjustment can be done in all spans,
c     if specified.
c-----------------------------------------------------------------------
          IF(Keastr.eq.1)THEN
           i1=(Begob/12)*12+3
           IF(i1.lt.Begob)i1=i1+12
           DO i=1,Ncol
            IF(i.gt.1)i1=i1+12
            i2=Begob+Nlen+(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
             WRITE(Nerr,2040)
 2040        FORMAT(/,5x,'Easter adjustment cannot be performed ',
     &              'during the sliding spans analysis due to:')
             Keastr=0
            ENDIF
            IF(Ieast(1).eq.0)WRITE(Nerr,2050)i
 2050       FORMAT(5x,'No years with Easter before April 1st in span ',
     &             i1,'.')
            IF(Ieast(2).eq.0)WRITE(Nerr,2060)i
 2060       FORMAT(5x,'No years with Easter after April 16th in span ',
     &             i1,'.')
            IF(Ieast(3).eq.0)WRITE(Nerr,2070)i
 2070       FORMAT(5x,'No years with Easter between April 2nd and ',
     &             'April 8th in span ',i1,'.')
            IF(Ieast(4).eq.0)WRITE(Nerr,2080)i
 2080       FORMAT(5x,'No years with Easter between April 8th and ',
     &             'April 15th in span ',i1,'.')
           END DO
          ENDIF
         ENDIF
c-----------------------------------------------------------------------
c     Check to see if X-11 holiday adjustment can still be done.
c-----------------------------------------------------------------------
         IF(Khol.eq.1)THEN
          Khol=Keastr+Klbrdy+Kthgvg
          IF(Khol.gt.1)Khol=1
         ENDIF
c-----------------------------------------------------------------------
         IF(Khol.eq.1)CALL runhol
         Nopt=1
         CALL x11pt1
         CALL subx11
        END DO
        CALL ssap(Title)
        Nopt=0
        Begob=ib2
        Igrz=igz2
       END IF
       IF(Numtbl.gt.0)THEN
        itc1=Itchar+1
        ic2=Itchar+2
        f1=' '
        Tblfil(Itchar:ic2)='TBL'
        DO inm=1,Numtbl
         IF(Iovr.lt.3)THEN
          Tblfil(Itchar:ic2)=Tbl(inm)
          IF(Tblfil(itc1:itc1).eq.' ')Tblfil(itc1:itc1)='_'
         END IF
         IF(Itbl(inm).ge.999)THEN
          IF(Iovr.lt.0)THEN
           WRITE(f1,1400)ic2
 1400      FORMAT('(5X,6HTABLE ,A3,20H WAS STORED IN FILE ,A',I2,
     &            ',25H BY THE OVERWRITE OPTION.)')
           IF(ic2.lt.10)f1(41:42)=' A'
          ELSE IF(Iovr.ge.2.and.Itbl(inm).eq.1999)THEN
           WRITE(f1,1410)ic2
 1410      FORMAT('(5X,6HTABLE ,A3,22H WAS APPENDED TO FILE ,A',I2,')')
           IF(ic2.lt.10)f1(43:44)=' A'
          ELSE
           WRITE(f1,1420)ic2
 1420      FORMAT('(5X,6HTABLE ,A3,20H WAS STORED IN FILE ,A',I2,')')
           IF(ic2.lt.10)f1(41:42)=' A'
          END IF
          PRINT f1,Tbl(inm),Tblfil(1:ic2)
         END IF
         IF(Itbl(inm).lt.999.and.Itbl(inm).gt.0)
     &      CALL terr(Tbl(inm),reset,irs,0,Itbl(inm),*160,*260)
  160   END DO
       END IF
       PRINT *,'     X-11.2 RUN FOR ',Ser,' COMPLETED.'
       PRINT *,' '
       PRINT *,' '
       IF(Nr.eq.10)Irun=Irun+1
      END IF
      GO TO 30
C --  ERRORS IN DATA INPUT AND OUTPUT
  170 CALL inerr(reset,irs,*260)
      WRITE(Nerr,1430)nlt,ifile
 1430 FORMAT(10X,'ERROR IN READING NAMELIST ',A5,' FROM ',A80)
      WRITE(Nerr,1160)ifile
      Irun=Irun+1
      GO TO 30
  180 CALL inerr(reset,irs,*260)
      WRITE(Nerr,1440)nlt,ifile
 1440 FORMAT(10X,'END OF FILE ENCONTERED IN READING NAMELIST ',A5,
     &       ' FROM ',A80)
      IF(Ixerr.eq.0)Ixerr=1
      GO TO 260
  190 PRINT *,' '
      PRINT *,'  ERROR IN NAMELIST NLX11 ... TRY AGAIN '
      PRINT *,'  CURRENT SETTINGS FOR NLX11 NAMELIST ARE : '
      PRINT nlx11
      READ(*,nlx11,ERR=190)
      IF(stop.ne.'N'.and.stop.ne.'n')GO TO 260
      PRINT nlx11
  200 IF(icer.eq.2)THEN
       PRINT *,' '
       PRINT *,'  ERROR IN NAMELIST NLXOP ... TRY AGAIN '
       PRINT *,'  CURRENT SETTINGS FOR NLXOP NAMELIST ARE : '
       PRINT nlxop
      ELSE
       icer=2
       PRINT *,' '
       PRINT *,'  CURRENT SETTINGS FOR NLXOP NAMELIST ARE : '
       PRINT nlxop
       PRINT *,' '
       PRINT *,'  ENTER VARIABLES AND THEIR SETTINGS FOR NLXOP',
     &       ' NAMELIST : '
      END IF
      READ(*,nlxop,ERR=200)
      GO TO 60
  210 inx=index(tfile,' ')-1
      f1=' '
      IF(irerr.eq.1)THEN
       CALL inerr(reset,irs,*260)
       WRITE(f1,1450)inx
 1450  FORMAT('(10X,A',I2,'," SEARCHED FOR ",A6,", SERIES NOT ',
     &        'FOUND")')
       IF(inx.lt.10)f1(6:7)=' A'
       IF(Nr.eq.10)WRITE(Nerr,f1)tfile(1:inx),tser
       IF(Nr.eq.5)THEN
        IF(ld.eq.1)PRINT 1310
        PRINT f1,tfile(1:inx),Ser
       END IF
      ELSE IF(irerr.eq.2)THEN
       CALL inerr(reset,irs,*260)
       WRITE(f1,1460)inx
 1460  FORMAT('(10X,A',I2,'," SEARCHED FOR ",A6,", DATA FOR "',
     &        ',I4," NOT FOUND")')
       IF(inx.lt.10)f1(6:7)=' A'
       IF(Nr.eq.10)WRITE(Nerr,f1)tfile(1:inx),tser,kyr
       IF(Nr.eq.5)THEN
        IF(ld.eq.1)PRINT 1310
        PRINT f1,tfile(1:inx),tser,kyr
       END IF
      ELSE IF((kyr-1).lt.Lstyr)THEN
       CALL inerr(reset,irs,*260)
       WRITE(f1,1470)inx
 1470  FORMAT('(10X,A',I2,'," SEARCHED FOR ",A6,", REQUESTED ',
     &        'DATA TO ",I4," NOT FOUND")')
       IF(inx.lt.10)f1(6:7)=' A'
       IF(Nr.eq.10)WRITE(Nerr,f1)tfile(1:inx),tser,kyr
       IF(Nr.eq.5)THEN
        IF(ld.eq.1)PRINT 1310
        PRINT f1,tfile(1:inx),tser,kyr
       END IF
      END IF
      IF(ld.eq.0)GO TO 120
      IF(ld.eq.1.and.Kswt.le.0.and.Nr.eq.10)WRITE(Nerr,1160)ifile
      IF(ld.eq.1.and.Kswt.le.0)THEN
       IF(Nr.eq.10)Irun=Irun+1
       GO TO 30
      END IF
      IF(ld.eq.1)THEN
C***** The following statement is a duplicate copy made by SPAG
       Kswt=Kswt-2
       GO TO 140
      END IF
  220 CALL inerr(reset,irs,*260)
      IF(Nr.eq.10)WRITE(Nerr,1480)tfile
 1480 FORMAT(10X,'ERROR WHILE READING ',A80)
      IF(Nr.eq.5)THEN
       IF(ld.eq.1)PRINT 1310
       inx=index(tfile,' ')-1
       PRINT *,'    ERROR WHILE READING ',tfile(1:inx)
      END IF
      IF(ld.eq.0)GO TO 120
      IF(ld.eq.1.and.Nr.eq.10)THEN
       WRITE(Nerr,1160)ifile
       Irun=Irun+1
      END IF
      GO TO 30
  230 CALL inerr(reset,irs,*260)
      IF(Nr.eq.10)WRITE(Nerr,1490)tfile
 1490 FORMAT(10X,'END OF FILE ENCOUNTERED WHILE READING ',A80)
      IF(Nr.eq.5)THEN
       IF(ld.eq.1)PRINT 1310
       inx=index(tfile,' ')-1
       PRINT *,'END OF FILE ENCOUNTERED WHILE READING ',tfile(1:inx)
      END IF
      IF(ld.eq.0)GO TO 120
      IF(ld.eq.1.and.Nr.eq.10)THEN
       WRITE(Nerr,1160)ifile
       Irun=Irun+1
      END IF
      GO TO 30
  240 cre=crerr(icer)
      IF(icer.eq.4)lerdat=.true.
      IF(icer.eq.6)lerpri=.true.
      inx=index(cre,' N')
      inx2=index(tfile,' ')-1
      f1=' '
      WRITE(f1,1500)inx,inx2
 1500 FORMAT('(10X,A',I2,',1X,A',I2,',15H DOES NOT EXIST)')
      IF(inx.lt.10)f1(6:7)=' A'
      IF(inx2.lt.10)f1(13:14)=' A'
      IF(Nr.eq.5.or.icer.eq.7)THEN
       PRINT f1,cre(1:inx),tfile(1:inx2)
       IF(icer.eq.4)CALL inc(14,dfile,dtemp,ifile,crerr,*90,*260)
       IF(icer.eq.6)CALL inc(16,pfile,ptemp,ifile,crerr,*120,*260)
       IF(icer.eq.7)THEN
        Nr=5
        GO TO 10
       END IF
      ELSE
       CALL inerr(reset,irs,*260)
       WRITE(Nerr,f1)cre(1:inx),tfile(1:inx2)
       WRITE(Nerr,1160)ifile
       Irun=Irun+1
       GO TO 30
      END IF
  250 inx=index(tfile,' ')-1
      if(icer.eq.5)lerout=.true.
      WRITE(f1,1510)inx
 1510 FORMAT('(10X,5HFILE ,A',I2,',28H CANNOT BE OPENED FOR OUTPUT)')
      IF(inx.lt.10)f1(14:15)=' A'
      IF(Nr.eq.5.or.icer.eq.8)THEN
       PRINT f1,tfile(1:inx)
       IF(icer.eq.8)GO TO 20
       CALL inc(15,ofile,otemp,ifile,crerr,*80,*260)
      ELSE
       CALL inerr(reset,irs,*260)
       WRITE(Nerr,f1)tfile(1:inx)
       WRITE(Nerr,1160)ifile
       Irun=Irun+1
       GO TO 30
      END IF
C --- FINISH
  260 WRITE(6,1520)
 1520 FORMAT(1X,'   END OF X-11.2 RUN')
      IF(Np.ne.6)THEN
       REWIND Np
       CLOSE(Np)
      END IF
      IF(Nr.eq.10)THEN
       CLOSE(Nr)
       CLOSE(25)
       IF(Ixerr.eq.1)THEN
        inx=index(ifile,' ')-1
        PRINT *,'  ERRORS FOUND IN X-11.2 RUN(S) STORED IN ',
     &        ifile(1:inx)
        inx=index(efile,' ')-1
        PRINT *,'  CHECK ',efile(1:inx),' FOR ERROR MESSAGES'
       END IF
      END IF
      IF(Nr.ne.nd.and.nd.ne.0)CLOSE(nd)
      STOP
      END
**==rite.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR RITE,RITE,RITES
C --- TABLE OUTPUT ROUTINE. WRITES THE HEADING LINE ON ALL PAGES AND
C --- ALL MONTHLY TABLES.
      SUBROUTINE rite(Ktabl,Array,Lfda,Llda,Javg,Jdcm,Arr)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Adri,Arr,Array,avge,avgmon,p,R,r1,r2,Rati,Ratic,
     &                 rmsr,sdev,Sigm,Sigml,Sigmu,sk,Smp,Stc,Stci
      DOUBLE PRECISION Stopa,Stopma,Stor,Stpmf,Stptdf,Sts,Stsi,tmp,
     &                 total,totdev,totmon,totn,yrdev,yrtot
      INTEGER i,ibeg2,icol,Ifor,Igrz,il,im,In,Io12,Iovr,ir,Issap,Itbl,
     &        Itchar,Itfmt,Javg,Jdcm,jdec,jfda,jlda
      INTEGER jmon,jyr,kavg,kd,kdcm,kde,Kdec,Kdwopt,kexit,kf1,Kfulsm,
     &        Khol,kmon,Kpage,Kpart,Kpropt,krite,Kspopt,Kswk,Kswt
      INTEGER Ktabl,Ktcopt,kyrly,Layr,Lcyr,Lfda,Lfda1,Lfdc,Lfdr,Llda,
     &        Llda1,Lopt,Lstmo,Lstyr,Lswv,Lterm,Lyr,Mcd,Mdec,Muladd
      INTEGER NL1,NL2,nmon,Nopt,Np,Nterm,Numtbl,Nw
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      CHARACTER*1 Newpag,Spc,Part,Aorb
      CHARACTER*3 Cout
      CHARACTER*4 Radif1,Radif2,Pcdif,blank,ff2(4),fc4(6),fg1(2),fa2(9),
     &            fa3(15),fa4(9),fb1(8),fb2(11),fb3(6),fb4(11),fb5(6),
     &            fb7(10),fb13(6),fb14(16),fb15(8),fb16(17),fb17(10),
     &            fb18(15),fb19(14),fe1(10),fe2(9),fe3(7),fe4(15),
     &            fe5(11),fe6(17),fd20(9),tyrly(4),title(20),difrat(9),
     &            ff1(5),fb6(8),Finab,Finap,yrly
      CHARACTER*6 Lser,cmsr(5)
      CHARACTER*8 nf3,nf4,nf5
      CHARACTER*38 nf1
      CHARACTER*58 kse
      CHARACTER*80 title2,nf2,Name
      COMMON /ca    / Nw
      COMMON /cb    / Ratic,Stc(NL1),Stci(NL1),Nterm
      COMMON /cc    / Rati(36),Lterm(12),Sts(NL2),Stsi(NL1)
      COMMON /cf    / Lyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Kdec,Layr,
     &                Lstmo,Lstyr,Kpropt
      COMMON /cf4   / Part,Aorb
      COMMON /cf1   / Radif1(2),Radif2
      COMMON /cf2   / Finab(2),Finap(2),Cout,Newpag,Spc
      COMMON /cf3   / Name
      COMMON /cj    / Muladd
      COMMON /cm    / Lfda1,Llda1,Kfulsm,Lopt,Kdwopt,Lfdc,Lfdr,Ktcopt,
     &                Kspopt,Mdec,Pcdif(4),Smp(24),Stptdf(NL2),Stor(NL1)
     &                ,Stopa(NL1),Stpmf(NL1),Stopma(NL1),Lcyr
      COMMON /cz    / Kpage,Np,Lser
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /grz   / Igrz
      COMMON /itcom / Itchar,Itfmt,Itbl(10),Ifor,Numtbl,Iovr,Io12
      COMMON /xk    / Kswt,Lswv
C  *****  CHANGES TO INCORPORATE M & Q STATISTICS
      COMMON /mq1   / Adri,R
C  *****  END OF CHANGE
      DIMENSION Array(NL2),Arr(NL2),tmp(12),avgmon(12),totmon(12),
     &          sdev(12),rmsr(8)
      DATA rmsr/2.3,4.1,5.2,6.5,2.1,3.8,5.0,6.9/
      DATA cmsr/'3-TERM',' 3 X 3',' 3 X 5',' 3 X 9','STABLE'/
      DATA blank/'    '/
      DATA difrat/'RATI','OS  ','DIFF','EREN','CES ',' PER',' CEN',
     &     'T CH','ANGE'/
      DATA tyrly/'AVGE',' TOT','S.D.','S.D.'/
      DATA nf3/'I4,     '/,nf4/'"AVGE", '/,nf5/'"S.D.", '/
      DATA fa2/'PRIO','R MO','NTHL','Y AD','JUST','MENT',' FAC','TORS',
     &     '    '/
      DATA fa3/'ORIG','INAL',' SER','IES ','ADJU','STED',' BY ','PRIO',
     &     'R MO','NTHL','Y AD','JUST','MENT',' FAC','TORS'/
      DATA fa4/'PRIO','R TR','ADIN','G DA','Y AD','JUST','MENT',' FAC',
     &     'TORS'/
      DATA fb1/'PRIO','R AD','JUST','ED O','RIGI','NAL ','SERI','ES  '/
      DATA fb2/'TREN','D CY','CLE-',' CEN','TERE','D 12','-TER','M MO',
     &     'VING',' AVE','RAGE'/
      DATA fb3/' FIN','AL  ','  UN','MODI','FIED',' SI '/
      DATA fb4/' FIN','AL  ',' REP','LACE','MENT',' VAL','UES ','FOR ',
     &     'EXTR','EME ',' SI '/
      DATA fc4/' FIN','AL  ','    ','MODI','FIED',' SI '/
      DATA fb5/'    ',' SEA','SONA','L FA','CTOR','S   '/
      DATA fb6/'    ',' SEA','SONA','LLY ','ADJU','STED',' SER','IES '/
      DATA fb7/' FIN','AL  ','TREN','D CY','CLE ','- HE','NDER','SON ',
     &     'CURV','E   '/
      DATA fb13/'    ',' IRR','EGUL','AR S','ERIE','S   '/
      DATA fb14/'EXTR','EME ','IRRE','GULA','R VA','LUES',' EXC','LUDE',
     &     'D FR','OM T','RADI','NG D','AY R','EGRE','SSIO','N   '/
      DATA fb15/' PRE','LIM ',' TRA','DING',' DAY',' REG','RESS','ION '/
      DATA fb16/'TRAD','ING ','DAY ','ADJU','STME','NT F','ACTO','RS D',
     &     'ERIV','ED F','ROM ','REGR','ESSI','ON C','OEFF','ICIE',
     &     'NTS '/
      DATA fb17/' PRE','LIM ',' WEI','GHTS',' FOR',' IRR','EGUL','AR C',
     &     'OMPO','NENT'/
      DATA fb18/'TRAD','ING-','DAY ','ADJU','STME','NT F','ACTO','RS F',
     &     'ROM ','COMB','INED',' DAI','LY W','EIGH','TS  '/
      DATA fb19/'   A','DJUS','TED*',' ORI','GINA','L SE','RIES',' MOD',
     &     'IFIE','D BY',' PRE','LIM ','WEIG','HTS '/
      DATA fd20/'   F','INAL',' COM','BINE','D AD','JUST','MENT',' FAC',
     &     'TORS'/
      DATA fe1/'ORIG','INAL',' SER','IES ','MODI','FIED',' FOR',' EXT',
     &     'REME','S   '/
      DATA fe2/'MODI','FIED',' SEA','SONA','LLY ','ADJU','STED',' SER',
     &     'IES '/
      DATA fe3/'MODI','FIED',' IRR','EGUL','AR S','ERIE','S   '/
      DATA fe4/'    ',' RAT','IOS ','OF A','NNUA','L TO','TALS',', OR',
     &     'IGIN','AL A','ND A','DJUS','TED ','SERI','ES  '/
      DATA fe5/'MONT','H-TO','-MON','TH C','HANG','ES I','N OR','IGIN',
     &     'AL S','ERIE','S   '/
      DATA fe6/'MONT','H-TO','-MON','TH C','HANG','ES I','N FI','NAL ',
     &     'SEAS','ONAL','LY A','DJUS','TED ','SERI','ES (','D11.',
     &     ')   '/
      DATA ff1/'MCD ','MOVI','NG A','VERA','GE  '/
      DATA ff2/'SUMM','ARY ','MEAS','URES'/
      DATA fg1/' CHA','RT  '/
      IF(Nopt.eq.1)RETURN
      ASSIGN 760 TO krite
      ASSIGN 870 TO kexit
      jfda=Lfda
      jlda=Llda
      kavg=Javg
      DO i=1,20
       title(i)=blank
      END DO
      GO TO(110,110,110,10,530,610,660),Kpart
   10 GO TO(20,30,40,50,60,70),Ktabl
   20 DO i=1,4
       title(i)=fb19(i+3)
      END DO
      GO TO 750
   30 DO i=1,9
       title(i)=fa2(i)
      END DO
      GO TO 750
   40 DO i=1,15
       title(i)=fa3(i)
      END DO
      GO TO 750
   50 DO i=1,9
       title(i)=fa4(i)
      END DO
      ASSIGN 90 TO krite
      GO TO 750
   60 WRITE(Nw,1010)
 1010 FORMAT(' A2B. COMBINED PRIOR AND HOLIDAY MONTHLY ADJUSTMENT ',
     &       'FACTORS')
      GO TO 760
   70 DO i=1,9
       title(i)=fa2(i)
      END DO
      Ktabl=2
      ASSIGN 80 TO krite
      GO TO 750
   80 WRITE(Nw,1020)
 1020 FORMAT(9X,'(SAME AS TABLE H.1) ')
      Ktabl=6
      RETURN
   90 WRITE(Nw,1030)(Arr(i),i=1,7),Cout
 1030 FORMAT(
     &' A4A. PRIOR DAILY WEIGHTS - MON     TUE     WED    THUR     FRI  
     &   SAT     SUN'/23X,
     &7F8.3/' A4B. PRIOR TRADING DAY ADJUSTMENT FACTORS WITH',A3,
     &' LENGTH OF MONTH ADJUSTMENT')
      ASSIGN 100 TO kexit
      GO TO 760
  100 WRITE(Nw,1040)
 1040 FORMAT(
     &      ' A4C. PRIOR TRADING DAY ADJUSTMENT FACTORS, ONE YEAR AHEAD'
     &      )
C***** SPAG has made duplicate copies of the following statement 
      ASSIGN 870 TO kexit
      GO TO 310
  110 GO TO(120,130,140,150,190,210,220,140,150,190,210,220,240,250,270,
     &      280,320,340,390,500),Ktabl
  120 IF(Kpart.lt.2)THEN
       IF(Kswk.eq.1)GO TO 20
       DO i=1,8
        title(i)=fb1(i)
       END DO
       GO TO 750
      ELSE
       DO i=1,14
        title(i)=fb19(i)
       END DO
       title(11)=Finap(1)
       title(12)=Finap(2)
       IF(Kswk.le.1)THEN
        title(1)=blank
        title(2)=blank
        title(3)=blank
       ELSE
        ASSIGN 400 TO krite
       END IF
       GO TO 750
      END IF
  130 DO i=1,11
       title(i)=fb2(i)
      END DO
      GO TO 750
  140 DO i=3,6
       title(i)=fb3(i)
      END DO
      GO TO 160
  150 IF(Kpart.lt.2)GO TO 170
      IF(Kpart.ne.2)THEN
       IF(Ktabl.ge.9)THEN
        ASSIGN 180 TO kexit
        GO TO 170
       END IF
      END IF
      DO i=1,6
       title(i)=fc4(i)
      END DO
  160 title(7)=Radif1(1)
      title(8)=Radif1(2)
      title(9)=Radif2
      GO TO 740
  170 DO i=3,11
       title(i)=fb4(i)
      END DO
      title(12)=Radif1(1)
      title(13)=Radif1(2)
      title(14)=Radif2
      GO TO 740
  180 WRITE(Nw,1050)Spc
 1050 FORMAT(A1,'D 9A. YEAR TO YEAR CHANGE IN IRREGULAR AND SEASONAL ',
     &       'COMPONENTS AND MOVING SEASONALITY RATIO',/,15X,
     &       'JAN      FEB      MAR      APR      MAY      JUN      ',
     &       'JUL      AUG      SEP      OCT      NOV      DEC')
      kde=3
      IF(Muladd.ne.0)kde=2
      WRITE(kse,1060)kde,kde
 1060 FORMAT('(6X,4HI   ,12F9.',I1,',/,6X,4HS   ,12F9.',I1,
     &       ',/,4X,6HRATIO ,12F9.2)')
      WRITE(Nw,kse)Rati
      r1=0
      r2=0
      DO ir=1,12
       r1=r1+Rati(ir)
       r2=r2+Rati(ir+12)
      END DO
      R=r1/r2
      WRITE(Nw,1070)R
 1070 FORMAT(/,4X,'OVERALL MOVING SEASONALITY RATIO : ',12F9.3)
      IF(Lswv.eq.0)THEN
       il=0
       IF(Llda1.ge.180)il=4
       IF(R.lt.rmsr(il+1))WRITE(Nw,1080)cmsr(1)
       IF(R.lt.rmsr(il+2).and.R.ge.rmsr(il+1))WRITE(Nw,1080)cmsr(2)
       IF(R.lt.rmsr(il+3).and.R.ge.rmsr(il+2))WRITE(Nw,1080)cmsr(3)
       IF(R.lt.rmsr(il+4).and.R.ge.rmsr(il+3))WRITE(Nw,1080)cmsr(4)
       IF(R.ge.rmsr(il+4))WRITE(Nw,1080)cmsr(5)
 1080  FORMAT(4X,'TRY A ',A6,' MOVING AVERAGE FOR ALL MONTHS')
      END IF
      GO TO 870
  190 DO i=2,6
       title(i+1)=fb5(i)
      END DO
      IF(kavg.eq.1)ASSIGN 200 TO kexit
      GO TO 740
  200 WRITE(Nw,1090)Spc
 1090 FORMAT(A1,'D10A. SEASONAL FACTORS, ONE YEAR AHEAD')
      ASSIGN 870 TO kexit
      GO TO 310
  210 DO i=2,8
       title(i+1)=fb6(i)
      END DO
      GO TO 740
  220 DO i=1,10
       title(i)=fb7(i)
      END DO
      ASSIGN 230 TO krite
      GO TO 740
  230 WRITE(Nw,1100)Nterm,Ratic
 1100 FORMAT(19X,I2,'-TERM MOVING AVERAGE SELECTED.   I/C RATIO IS',
     &       F6.2)
      GO TO 760
  240 DO i=2,6
       title(i+1)=fb13(i)
      END DO
      GO TO 740
  250 DO i=1,16
       title(i)=fb14(i)
      END DO
      ASSIGN 260 TO krite
      GO TO 750
  260 WRITE(Nw,1110)Sigm
 1110 FORMAT(9X,'(OUTSIDE ',F3.1,'-SIGMA LIMIT)')
      GO TO 760
  270 DO i=3,8
       title(i)=fb15(i)
      END DO
      title(1)=Finap(1)
      title(2)=Finap(2)
      GO TO 650
  280 DO i=1,17
       title(i)=fb16(i)
      END DO
      IF(Kpart.eq.2)ASSIGN 290 TO krite
      GO TO 750
  290 WRITE(Nw,1120)(Arr(i),i=1,7)
 1120 FORMAT(
     &' C16A. REGRESSION COEFFICIENTS - MON       TUE       WED      THU
     &R       FRI       SAT       SUN'/27X,
     &7F10.3/' C16B. REGRESSION TRADING DAY ADJUSTMENT FACTORS')
      ASSIGN 300 TO kexit
      GO TO 760
  300 WRITE(Nw,1130)
 1130 FORMAT(
     &' C16C. REGRESSION TRADING DAY ADJUSTMENT FACTORS, ONE YEAR AHEAD'
     &)
C***** The following statement is a duplicate copy made by SPAG
      ASSIGN 870 TO kexit
  310 jfda=jlda+1
      jlda=jfda+11
      kavg=6
      GO TO 760
  320 DO i=3,10
       title(i)=fb17(i)
      END DO
      title(1)=Finap(1)
      title(2)=Finap(2)
      ASSIGN 330 TO krite
      GO TO 750
  330 WRITE(Nw,1140)Spc,Sigml,Sigmu
 1140 FORMAT(A1,8X,'GRADUATION RANGE FROM ',F3.1,' TO ',F3.1,' SIGMA')
      GO TO 760
  340 DO i=1,15
       title(i)=fb18(i)
      END DO
      IF(kavg.lt.18)THEN
       IF(Kpart.eq.2)ASSIGN 370 TO krite
      ELSE IF(kavg.eq.18)THEN
       ASSIGN 360 TO krite
      ELSE
       ASSIGN 350 TO krite
      END IF
      GO TO 750
  350 WRITE(Nw,1150)Part
 1150 FORMAT(9X,'(SAME AS TABLE ',A1,'16.)')
      GO TO 870
  360 WRITE(Nw,1160)
 1160 FORMAT(9X,'(SAME AS TABLE A 4.)')
      GO TO 870
  370 WRITE(Nw,1170)(Arr(i),i=1,7),Cout
 1170 FORMAT(
     &' C18A. COMBINED DAILY WEIGHTS - MON     TUE     WED    THUR     F
     &RI     SAT     SUN'/27X,
     &7F8.3/' C18B. COMBINED TRADING-DAY ADJUSTMENT FACTORS WITH',A3,
     &' LENGTH OF MONTH ADJUSTMENT')
      ASSIGN 380 TO kexit
      GO TO 760
  380 WRITE(Nw,1180)
 1180 FORMAT(
     &  ' C18C. COMBINED TRADING-DAY ADJUSTMENT FACTORS, ONE YEAR AHEAD'
     &  )
C***** The following statement is a duplicate copy made by SPAG
      ASSIGN 870 TO kexit
      GO TO 310
  390 DO i=1,7
       title(i)=fb19(i)
      END DO
      ASSIGN 400 TO krite
      GO TO 750
  400 DO i=1,15
       title(i)=blank
      END DO
      GO TO(760,410,440,420,470,480,440,440),Kswk
  410 IF(Ktabl.eq.1)GO TO 450
      GO TO 430
  420 IF(Ktabl.eq.1)GO TO 440
  430 WRITE(Nw,1190)
 1190 FORMAT(9X,'(SAME AS TABLE B 1.)')
      GO TO 870
  440 DO i=1,9
       title(i)=fa2(i)
      END DO
      WRITE(Nw,1200)title
 1200 FORMAT(9X,'*ADJUSTED BY...',20A4)
  450 GO TO(760,460,760,460,470,480,470,480),Kswk
  460 DO i=1,9
       title(i)=fa4(i)
      END DO
      GO TO 490
  470 DO i=1,17
       title(i)=fb16(i)
      END DO
      GO TO 490
  480 DO i=1,15
       title(i)=fb18(i)
      END DO
  490 WRITE(Nw,1200)title
      GO TO 760
  500 DO i=1,9
       title(i)=fd20(i)
      END DO
      ASSIGN 510 TO krite
      GO TO 750
  510 IF(Khol.eq.2.and.(Kdwopt.ge.2.or.Kswt.eq.2.or.Kswt.eq.4))THEN
       WRITE(Nw,1210)
 1210  FORMAT(' *SEASONAL, TRADING DAY AND HOLIDAY FACTORS')
      ELSE IF(Kdwopt.ge.2.or.Kswt.eq.2.or.Kswt.eq.4)THEN
       WRITE(Nw,1220)
 1220  FORMAT(' *SEASONAL AND TRADING DAY FACTORS')
      ELSE IF(Khol.eq.2)THEN
       WRITE(Nw,1230)
 1230  FORMAT(' *SEASONAL AND HOLIDAY FACTORS')
      END IF
      ASSIGN 520 TO kexit
      GO TO 760
  520 WRITE(Nw,1240)Spc
 1240 FORMAT(A1,'D20A. COMBINED FACTORS, ONE YEAR AHEAD')
      ASSIGN 870 TO kexit
      GO TO 310
  530 GO TO(540,550,560,570,590,600),Ktabl
  540 DO i=1,10
       title(i)=fe1(i)
      END DO
      GO TO 750
  550 DO i=1,9
       title(i)=fe2(i)
      END DO
      GO TO 750
  560 DO i=1,7
       title(i)=fe3(i)
      END DO
      GO TO 750
  570 DO i=1,15
       title(i)=fe4(i)
      END DO
      IF(Muladd.ne.0)THEN
       title(1)=difrat(3)
       title(2)=difrat(4)
       title(3)=difrat(5)
      END IF
      ASSIGN 580 TO krite
      GO TO 750
  580 WRITE(Nw,1250)
 1250 FORMAT(4X,'YEAR',6X,'UNMODIFIED   MODIFIED')
      GO TO 870
  590 DO i=1,11
       title(i)=fe5(i)
      END DO
      GO TO 750
  600 DO i=1,17
       title(i)=fe6(i)
      END DO
      GO TO 750
  610 GO TO(620,640),Ktabl
  620 DO i=1,5
       title(i)=ff1(i)
      END DO
      ASSIGN 630 TO krite
      GO TO 750
  630 WRITE(Nw,1260)Mcd
 1260 FORMAT(12X,'MCD IS ',I2)
      IF(Mcd.ne.1)GO TO 760
      WRITE(Nw,1270)
 1270 FORMAT(9X,'SEE TABLE D11')
      GO TO 870
  640 DO i=1,4
       title(i)=ff2(i)
      END DO
  650 ASSIGN 870 TO krite
      GO TO 750
  660 GO TO(670,680,680,690),Ktabl
  670 ASSIGN 710 TO krite
      GO TO 700
  680 ASSIGN 720 TO krite
      GO TO 700
  690 ASSIGN 730 TO krite
  700 title(1)=fg1(1)
      title(2)=fg1(2)
      GO TO 750
  710 WRITE(Nw,1280)
 1280 FORMAT(9X,'(X) - D11. FINAL SEASONALLY ADJUSTED SERIES'/9X,
     &       '(O) - D12. FINAL TREND CYCLE'/9X,
     &       '(*) - COINCIDENCE OF POINTS')
      GO TO 870
  720 WRITE(Nw,1290)Radif1,Radif2,Radif1,Radif2
 1290 FORMAT(9X,'(X) - D 8. FINAL UNMODIFIED SI ',3A4/9X,
     &       '(O) - D 9. FINAL SI ',3A4,'MODIFIED FOR EXTREMES'/9X,
     &       '(+) - D10. FINAL SEASONAL FACTORS'/9X,
     &       '(*) - COINCIDENCE OF POINTS')
      GO TO 870
  730 WRITE(Nw,1300)
 1300 FORMAT(9X,'(X) - D13. FINAL IRREGULAR SERIES'/9X,
     &       '(O) - E 3. FINAL MODIFIED IRREGULAR SERIES'/9X,
     &       '(*) - COINCIDENCE OF POINTS')
      GO TO 870
  740 title(1)=Finab(1)
      title(2)=Finab(2)
  750 WRITE(Nw,1310)Newpag,Name,Kpage,Lser
 1310 FORMAT(A1,17X,A80,1X,'P.',I2,', SERIES ',A6)
      WRITE(Nw,1320)Spc,Part,Ktabl,(title(i),i=1,20)
 1320 FORMAT(2A1,I2,'. ',20A4)
      Kpage=Kpage+1
      GO TO krite
  760 kdcm=Jdcm
      kyrly=1
      IF(kdcm.eq.1.or.kdcm.eq.6)kyrly=2
      IF(kdcm.eq.5)kyrly=3
      IF(kdcm.eq.6)kyrly=4
      yrly=tyrly(kyrly)
      kd=Kdec
      IF(Muladd.eq.0.and.Kdec.eq.0.and.kdcm.ne.7)kd=2
      WRITE(nf1,1330)nf3,kd,kd
 1330 FORMAT('(A1,3X,',A8,'2X,12(1X,F8.',I1,'),6X,F8.',I1,')')
      WRITE(Nw,1340)Spc,yrly
 1340 FORMAT(A1,3X,'YEAR       JAN      FEB      MAR      APR      ',
     &       'MAY      JUN      JUL      AUG      SEP      OCT      ',
     &       'NOV      DEC         ',A4)
      sk=100.
      IF(Muladd.ne.0)sk=0.
      jyr=Lyr+(jfda-1)/12
      jdec=(jlda+11)/12*12
      total=0.0
      yrdev=0.0
      totdev=0.0
      DO i=1,12
       tmp(i)=10.**10
       avgmon(i)=0.0
       sdev(i)=0.0
       totmon(i)=0.0
      END DO
      jmon=jfda
      im=jmon-(jmon-1)/12*12
      kmon=jmon-im+12
  770 yrtot=0.0
      yrdev=0.0
      DO i=jmon,kmon
       tmp(im)=Array(i)
       totmon(im)=totmon(im)+1.
       totdev=totdev+tmp(im)**2
       sdev(im)=sdev(im)+(tmp(im)-sk)**2
       yrdev=yrdev+(tmp(im)-sk)**2
       avgmon(im)=avgmon(im)+tmp(im)
       yrtot=yrtot+tmp(im)
       total=total+tmp(im)
       im=im+1
      END DO
      p=kmon+1-jmon
      GO TO(790,810,780,800),kyrly
  780 yrtot=sqrt(yrdev/p)
      GO TO 810
  790 yrtot=yrtot/p
      GO TO 810
  800 yrtot=Arr(In)
      In=In+1
  810 WRITE(Nw,nf1)Spc,jyr,(tmp(i),i=1,12),yrtot
      jyr=jyr+1
      jmon=kmon+1
      kmon=kmon+12
      im=1
      IF(kmon.lt.jdec)THEN
      ELSE IF(kmon.eq.jdec)THEN
       kmon=jlda
       DO i=1,12
        tmp(i)=10.**10
       END DO
      ELSE
       WRITE(Nw,1350)Spc
 1350  FORMAT(A1)
       GO TO(850,820,830,850,820,860),kavg
       GO TO 820
      END IF
      GO TO 770
  820 WRITE(nf1,1360)nf4,kd
 1360 FORMAT('(A1,3X,',A8,'2X,12(1X,F8.',I1,')',8X,')')
      DO i=1,12
       avgmon(i)=avgmon(i)/totmon(i)
      END DO
      GO TO 840
  830 kf1=1
      WRITE(nf1,1360)nf5,kf1
      DO i=1,12
       avgmon(i)=sqrt(sdev(i)/totmon(i))
      END DO
  840 WRITE(Nw,nf1)Spc,(avgmon(i),i=1,12)
  850 IF(kavg.le.3)THEN
       totn=jlda+1-jfda
       avge=total/totn
       totdev=sqrt(totdev/totn-avge**2)
       WRITE(nf2,1370)kd,kd,kd
 1370  FORMAT('(A1,12X,14H TABLE TOTAL- ,F12.',I1,',A1,8X,6HMEAN- ,F9.',
     &        I1,',8X,16HSTD. DEVIATION- ,F9.',I1,')')
       WRITE(Nw,nf2)Spc,total,blank,avge,totdev
      ELSE
       WRITE(nf2,1380)kd
 1380  FORMAT('(A1,12X,14H TABLE TOTAL- ,F12.',I1,48X,')')
       WRITE(Nw,nf2)Spc,total
      END IF
  860 GO TO kexit
  870 IF(Numtbl.gt.0)CALL trite(Array,Lfda,Llda,Lyr,Lser,Kpart,Ktabl)
      IF(Igrz.eq.0)RETURN
      nmon=108
      IF(Kpart.eq.4.and.Ktabl.eq.1)THEN
       title2='A1. ORIGINAL SERIES'
       CALL grzlst(Lfda,ibeg2,Llda,Lyr,Array,Array,nmon)
       CALL chrt(title2,6,1,ibeg2,Llda)
       Igrz=Igrz+100
      ELSE IF(Kpart.eq.1.and.Ktabl.eq.1.and.Igrz.lt.100)THEN
       title2='B1. ORIGINAL SERIES'
       CALL grzlst(Lfda,ibeg2,Llda,Lyr,Array,Array,nmon)
       CALL chrt(title2,6,1,ibeg2,Llda)
      ELSE IF(Kpart.eq.1.and.Ktabl.eq.1.and.Igrz.ge.100)THEN
       Igrz=Igrz-100
      ELSE IF(Kpart.eq.3.and.Ktabl.eq.11)THEN
       CALL ftest(Array,Lfda,Llda,1,icol)
       title2='D11. FINAL SEASONALLY ADJUSTED SERIES'
       CALL grzlst(Lfda,ibeg2,Llda,Lyr,Array,Array,nmon)
       CALL chrt(title2,6,1,ibeg2,Llda)
      END IF
      IF(Igrz.eq.1)RETURN
      IF(Kpart.eq.3.and.Ktabl.eq.10)THEN
       title2='D10. FINAL SEASONAL FACTORS WITH ONE YEAR FORECAST'
       CALL grzlst(Lfda,ibeg2,Llda+12,Lyr,Array,Array,nmon)
       CALL chrt(title2,7,1,ibeg2,Llda+12)
      ELSE IF(Kpart.eq.3.and.Ktabl.eq.13)THEN
       title2='D13. FINAL IRREGUAR SERIES'
       CALL grzlst(Lfda,ibeg2,Llda,Lyr,Array,Array,nmon)
       CALL chrt(title2,29,1,ibeg2,Llda)
      END IF
      RETURN
      END
**==subx11.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR SUBX11,SUBX1S
      SUBROUTINE subx11
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION adrc,adrci,Adri,adrmcd,cfac,D,Dwt,F,Hfac,P,Rati,
     &                 Ratic,Ratis,Rv,Sigm,Sigml,Sigmu,sin,Smc,Smci
      DOUBLE PRECISION smcime,Smi,smic,smime,smmcd,Smo,smo2,smome,Smp,
     &                 sms,Smtd,Stc,Stci,Stci2,stcime,stcsi,stdev,Sti,
     &                 Stime,Stmcd
      DOUBLE PRECISION Stmp,Stmp2,stocca,stome,Stopa,Stopma,Stor,Stor2,
     &                 Stpmf,Stptdf,Sts,Stsi,stsie,Stsp,Sttdrf,stwt,
     &                 Test1,Test2,tmp,tota
      DOUBLE PRECISION totam,toto,totom,vars,Vc,Vi,Vp,Vs,Vtd,x,xmcd
      INTEGER i,i2,ibeg2,Ibreak,icol,Igrz,ii,In,Iqfail,Irang,Issap,Itd,
     &        j,jyra,k,k2,kadd,Kdec,Kdwopt,kext
      INTEGER kfda,Kfulsm,Khol,Kmtyp,Kpage,Kpart,Kpropt,ksect,Kspopt,
     &        kswa,Kswk,Kswt,ktabl,Ktcopt,kyra,l,l2,Layr,Lcyr,Length
      INTEGER Lfda,Lfdc,Lfdr,Llda,Lopt,Lstmo,Lstyr,Lswv,Lterm,Lyr,m,
     &        Mach,Mcd,Mdec,mfda,mgrz,mlda,mopt,Muladd,n
      INTEGER NL1,NL2,Nopt,Np,nt,Nterm,Nw
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      CHARACTER*1 Newpag,Spc,Part,Aorb,bs,cs,ds,es,fs
      CHARACTER*3 Cout
      CHARACTER*4 Pcdif,Finap,Finab,prelim(2),final(2),blank,Fstar,swo,
     &            star
      CHARACTER*6 Lser
      CHARACTER*80 title2,Name
      COMMON /ca    / Nw
      COMMON /caa   / Stmp(NL2)
      COMMON /cb    / Ratic,Stc(NL1),Stci(NL1),Nterm
      COMMON /cc    / Rati(36),Lterm(12),Sts(NL2),Stsi(NL1)
      COMMON /cf    / Lyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Kdec,Layr,
     &                Lstmo,Lstyr,Kpropt
      COMMON /cf2   / Finab(2),Finap(2),Cout,Newpag,Spc
      COMMON /cf4   / Part,Aorb
      COMMON /cj    / Muladd
      COMMON /cl    / Sti(NL1),Kmtyp(NL1),Sttdrf(NL2),D(7),Dwt(7),Fstar
      COMMON /cm    / Lfda,Llda,Kfulsm,Lopt,Kdwopt,Lfdc,Lfdr,Ktcopt,
     &                Kspopt,Mdec,Pcdif(4),Smp(24),Stptdf(NL2),Stor(NL1)
     &                ,Stopa(NL1),Stpmf(NL1),Stopma(NL1),Lcyr
      COMMON /cz    / Kpage,Np,Lser
      COMMON /cf3   / Name
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /fhol  / Hfac(NL2)
      COMMON /grz   / Igrz
      COMMON /chrtm / Mach
      COMMON /xk    / Kswt,Lswv
C  *****  CHANGES TO INCORPORATE M & Q STATISTICS
      COMMON /tests / F(3),P(3),Test1,Test2,Iqfail
      COMMON /mq1   / Adri,Ratis
      COMMON /mq2   / Vi,Vc,Vs,Vp,Vtd,Rv,Length
      CHARACTER*7 mq
      DATA mq/' MONTH '/
C  *****  END OF CHANGE
      DIMENSION stcime(NL1),stcsi(NL1),Stsp(NL1),stsie(NL1),stdev(NL1),
     &          Stime(NL1),Stmcd(NL1),stocca(NL1),stome(NL1),stwt(NL1),
     &          Smo(48),Smci(48),Smi(48),Smc(48),sms(48),Smtd(24),
     &          smmcd(48),smome(12),smcime(12),smime(12),smic(12),
     &          smo2(12),cfac(NL2)
C --- THIS EQUIVALENCE IS USED ONLY TO REDUCE SIZE OF PROGRAM STORAGE
      EQUIVALENCE(Sttdrf,Stmcd,Stsp),(Stopma,Stime),(stocca,stome),
     &            (stcsi,stcime),(Stopa,Smo),(Stopa(49),Smci),
     &            (Stopa(97),Smi),(Stopa(145),Smc),(Stopa(193),Smtd),
     &            (cfac,sms),(cfac(49),smmcd),(cfac(97),smome),
     &            (cfac(109),smcime),(cfac(121),smime),(cfac(133),smic),
     &            (cfac(145),smo2)
      EQUIVALENCE(Stmp(2),Stmp2),(Stor(2),Stor2),(Stci(2),Stci2)
      DATA blank/'    '/,final/' FIN','AL  '/,prelim/'PREL','IM  '/
      DATA bs,cs,ds,es,fs/'B','C','D','E','F'/
      DATA star/'****'/
C  *****  CHANGE TO IMPLEMENT X-11-ARIMA M & Q DIAGNOSTICS
C  *****  END OF CHANGE
      Finab(1)=blank
      Finab(2)=blank
      Finap(1)=prelim(1)
      Finap(2)=prelim(2)
      ksect=1
      Kpart=1
      Part=bs
C --- WRITE ORIGINAL OR PRIOR ADJUSTED -B1.
      CALL rite(1,Stopa,Lfda,Llda,2,7,0.0)
C --- SET COMPLETELY CALENDAR ADJUSTED SERIES EQUAL TO PRIOR ADJUSTED
C --- OR ORIGINAL
      DO i=Lfda,Llda
       stocca(i)=Stopa(i)
       stcsi(i)=Stopa(i)
      END DO
C --- THE FOLLOWING CODING IS USED IN PARTS B,C, AND D
C --- CENTERED 12-TERM MVG AVGE OF ORIGINAL OR PRIOR ADJUSTED
C --- IN PART C, MODIFIED BY PRELIM WTS AND IN PART D MOD. BY FINAL WTS.
   10 mfda=Lfda+6
      mlda=Llda-6
      DO i=mfda,mlda
       Stc(i)=(stcsi(i-6)+stcsi(i+6)+2.*(stcsi(i-5)+stcsi(i-4)+stcsi(i-3
     &        )+stcsi(i-2)+stcsi(i-1)+stcsi(i)+stcsi(i+1)+stcsi(i+2)
     &        +stcsi(i+3)+stcsi(i+4)+stcsi(i+5)))/24.
      END DO
C --- WRITE TREND CYCLE -B2,C2, OR D2.
      IF(Kpropt.eq.3.or.(Kpart.eq.1.and.Kpropt.eq.2))
     &   CALL rite(2,Stc,mfda,mlda,5,7,0.0)
C --- DIVIDE ORIGINAL BY TREND CYCLE FOR SI RATIOS
      CALL addmul(Stsi,stcsi,Stc,mfda,mlda)
      kadd=0
      GO TO(20,80,80),Kpart
C --- PART B ONLY
   20 ktabl=3+kadd
C --- WRITE SI RATIOS -B3, OR B8.
      IF(Kpropt.eq.3)CALL rite(ktabl,Stsi,mfda,mlda,5,4,0.0)
C --- COMPUTE 5-TERM MVG AVG OF EACH MONTH SEPARATELY FOR ESTIMATE OF
C --- SEASONAL FACTORS. TO CENTER COMPUTE A CENTERED 12-TERM M.A. OF
C --- ENTIRE SERIES
      CALL vsfc(mfda,mlda,ksect)
C --- DIVIDE SI RATIOS BY ESTIMATED SEASONAL FACTORS FOR ESTIMATE OF IRR
      CALL addmul(Sti,Stsi,Sts,mfda,mlda)
C --- IDENTIFY EXTREME IRREGULAR VALUES -SEE XTRM FOR METHOD
      CALL xtrm(Sti,stdev,stwt,mfda,mlda,Sigmu,Sigml,kext)
C --- REPLACE CORRESPONDING SI RATIOS FOR IRR. VALUES RECVING LESS THAN
C --- FULL WEIGHT
C --- STI USED TO STORE REPLACEMENT VALUES ONLY FOR WRITING B4. OR B9.
      DO i=Lfda,Llda
       Sti(i)=10.0**10
      END DO
C --- FOR EACH MONTH SEPARATELY
      DO i=1,12
       kfda=mfda+i-1
       sin=0.
       tmp=0.
       DO ii=kfda,mlda,12
        tmp=tmp+Stsi(ii)
        sin=sin+1.
       END DO
       tmp=tmp/sin
       DO j=kfda,mlda,12
C --- TEST FOR FULL WEIGHT -100.
        IF(stwt(j).eq.100.)GO TO 70
C --- COMPUTE AVGE OF NON-FULL WT. VALUE  TIMES ITS WT. AND 4 NEAREST
C --- FULL WT. VALUES
        Stsi(j)=Stsi(j)*stwt(j)/100.
        n=0
        nt=400
        IF(j-12.le.kfda)THEN
C***** SPAG has made duplicate copies of the following statement 
         nt=300
        ELSE IF(j+24.gt.mlda)THEN
C***** The following statement is a duplicate copy made by SPAG
         nt=300
        END IF
        k=12
        k2=12
        kswa=0
   30   DO WHILE (.true.)
         l=j-k
         IF(l.lt.kfda)THEN
          kswa=1
          GO TO 40
         ELSE IF(stwt(l).ne.100.)THEN
C***** SPAG has made duplicate copies of the following statement 
          k=k+12
         ELSE
          Stsi(j)=Stsi(j)+Stsi(l)
          n=n+100
          IF(n.ge.nt)GO TO 50
          GO TO 40
         END IF
        END DO
   40   DO WHILE (.true.)
         m=j+k2
         IF(m.le.mlda)THEN
          IF(stwt(m).ne.100.)THEN
           k2=k2+12
          ELSE
           Stsi(j)=Stsi(j)+Stsi(m)
           n=n+100
           IF(n.ge.nt)GO TO 50
C***** SPAG has made duplicate copies of the following statement 
           k2=k2+12
C***** The following statement is a duplicate copy made by SPAG
           k=k+12
           GO TO 30
          END IF
         ELSE IF(kswa.ne.0)THEN
C --- IF FEWER THAN 4 FULL WEIGHT VALUES IN MONTH, REPLACE EXTREME WITH
C --- AVGE OF ALL SI RATIOS.
          Stsi(j)=tmp
          GO TO 60
         ELSE
C***** The following statement is a duplicate copy made by SPAG
          k2=k2+12
C***** The following statement is a duplicate copy made by SPAG
          k=k+12
          GO TO 30
         END IF
        END DO
   50   x=n
        Stsi(j)=Stsi(j)/(stwt(j)+x)*100.
   60   Sti(j)=Stsi(j)
   70  END DO
      END DO
      ktabl=4+kadd
      In=1
C --- WRITE REPLACEMENT VALUES FOR EXTREME SI RATIOS -B4. OR B9.
      IF(Kpropt.eq.3)CALL rite(ktabl,Sti,mfda,mlda,6,6,stdev)
      GO TO(90,130),ksect
C --- PART C + D ONLY.
C --- WRITE MODIFIED SI RATIOS -C4. OR D4.
   80 IF(Kpropt.eq.3)CALL rite(4,Stsi,mfda,mlda,5,4,0.0)
C --- THE FOLLOWING CODING IS USED IN PARTS B,C AND D
C --- COMPUTE ESTIMATE OF SEASONAL FACTORS
   90 CALL vsfc(mfda,mlda,ksect)
C --- REPLACE 6 MISSING VALUES AT EACH END DUE TO USE OF CENTERED
C --- 12-TERM TREND CYCLE MOVING AVERAGE
      DO i=1,6
       j=Lfda+i-1
       k=Llda-i+1
       Sts(j)=Sts(j+12)
       Sts(k)=Sts(k-12)
      END DO
C --- OBTAIN PRLIM SEASONALLY ADJUSTED SERIES
      CALL addmul(Stci,stcsi,Sts,Lfda,Llda)
      IF(Kpropt.eq.3)THEN
C --- WRITE SEASONAL FACTORS -B5.,C5., OR D5.
       CALL rite(5,Sts,Lfda,Llda,4,4,0.0)
C --- WRITE SEASONALLY ADJUSTED SERIES -B6.,C6., OR D6.
       CALL rite(6,Stci,Lfda,Llda,5,7,0.0)
      END IF
      ksect=2
      GO TO(100,110,110),Kpart
C --- PART B ONLY
  100 Nterm=999
C --- THE FOLLOWING CODING IS USED IN PARTS B,C AND D
C --- APPLY THE VARIABLE TREND CYCLE ROUTINE TO THE (MODIFIED) CI VALUES
  110 CALL vtc(Lfda,Llda,Ktcopt)
C --- WRITE TREND CYCLE -B7.,C7., OR D7.
      IF(Kpropt.eq.3.or.(Kpart.gt.1.and.Kpropt.eq.2))
     &   CALL rite(7,Stc,Lfda,Llda,5,7,0.0)
C --- DIVIDE B1 BY B7 *C1 BY C7,D1 BY D7* TO OBTAIN SI RATIOS
      CALL addmul(Stsi,stcsi,Stc,Lfda,Llda)
      mfda=Lfda
      mlda=Llda
      kadd=5
      GO TO(20,120,240),Kpart
C --- PART C ONLY
C --- WRITE MODIFIED SI RATIOS C9.
  120 IF(Kpropt.eq.3)CALL rite(9,Stsi,Lfda,Llda,5,4,0.0)
C --- PART B AND C
C --- COMPUTE WEIGHTED 7-TERM MVG AVG OF EACH MONTH SEPARATELY FOR
C --- ESTIMATE OF SEASONAL FACTORS. TO CENTER COMPUTE CENTERED 12-TERM
C --- MOVING AVGE OF ENTIRE SERIES
  130 CALL vsfc(mfda,mlda,ksect)
C --- WRITE SEASONAL FACTORS -B10. OR C10.
      IF(Kpropt.ge.2)CALL rite(10,Sts,Lfda,Llda,4,4,0.0)
C --- DIVIDE PRIOR ADJUSTED SERIES*B1. OR A1* BY SEASONAL FACTORS TO
C --- OBTAIN A PRELIM SEASONALLY ADJUSTED SERIES
      CALL addmul(Stci,Stopa,Sts,Lfda,Llda)
C --- WRITE SEASONALLY ADJUSTED SERIES -B11. OR C11.
      IF(Kpropt.eq.3)CALL rite(11,Stci,Lfda,Llda,5,7,0.0)
C --- DIVIDE SEASONALLY ADJUSTED SERIES BY TREND CYCLE TO OBTAIN PRELIM
C --- IRREGULAR
      CALL addmul(Sti,Stci,Stc,Lfda,Llda)
C --- WRITE IRREGULAR SERIES -B13. OR C13. *B12. +C12. NOT USED*
      IF(Kpropt.ge.2)CALL rite(13,Sti,Lfda,Llda,3,5,0.0)
      Kswk=Kdwopt*4+Kswt
      IF(Kdwopt.le.0)GO TO 160
      Kswk=Kswk-4
C --- COMPUTE TRADING DAY REGRESSION FACTORS FOR ALL OPTIONS EXCEPT
C --- *SKIP REGRESSION*
      CALL traday(Lfdc,Llda,Lcyr,Sigm,Kpart,Lopt,Kswt,Kpropt)
      IF(Muladd.ne.0)GO TO 150
C --- IF MULT., ADD 1. TO EACH DAILY FACTOR
      DO i=1,7
       D(i)=D(i)+1.
      END DO
C --- COMPUTE MONTHLY FACTORS FROM 7 T.D.REGR. FACTORS
      mopt=0
      GO TO(150,140,150,140),Kswt
  140 mopt=8
  150 CALL dow(D,Sttdrf,Lyr,Lfda,Llda,mopt)
C --- WRITE T.D.REGRESSION FACTORS -B16. OR C16.
      IF(Kpropt.ge.2.or.Kpart.eq.2)CALL rite(16,Sttdrf,Lfdr,Llda,4,4,D)
C --- SKIP BALANCE OF TRADING DAY REGR. IF *COMPUTE BUT DO NOT APPLY*
C --- OPTION WAS SELECTED
      IF(Kdwopt.lt.2)GO TO 160
      IF(Kdwopt.ne.2)THEN
C --- DISREGARD RESULTS OF F-TEST IN PART B IF *APPLY ON BASIS OF F* O
C --- OPTION SELECTED AND APPLY T.D.REGRESSION
       IF(Kpart.ne.1)THEN
C --- IN PART C APPLY T.D. REGR. OR NOT ON BASIS OF F.
        IF(Fstar.eq.blank)THEN
         Kswk=Kswk-8
C***** SPAG has made duplicate copies of the following statement 
         IF(Kpart.eq.2.and.Issap.eq.1.and.Itd.eq.1.and.Muladd.eq.0)
     &      CALL ssrit(Sttdrf,Lfda,Llda,1,NL1,Stor,Lfda,Lstmo)
         GO TO 160
        END IF
       END IF
       Kswk=Kswk-4
      END IF
C --- DIVIDE IRREGULAR BY T.D. REGR FACTORS TO OBTAIN AN IRREGULAR FREE
C --- OF T.D.VARIATION
      CALL addmul(Sti,Sti,Sttdrf,Lfdr,Llda)
C***** The following statement is a duplicate copy made by SPAG
      IF(Kpart.eq.2.and.Issap.eq.1.and.Itd.eq.1.and.Muladd.eq.0)
     &   CALL ssrit(Sttdrf,Lfda,Llda,1,NL1,Stor,Lfda,Lstmo)
C --- COMPUTE WEIGHTS FOR IRREGULAR COMPONENT
  160 CALL xtrm(Sti,stdev,stwt,Lfda,Llda,Sigmu,Sigml,kext)
C --- WRITE WEIGHTS FOR IRREGULAR COMPONENT -B17. OR C17.
      In=1
      DO i=Lfda,Llda+12
       Stmp(i)=Stptdf(i)
      END DO
      IF(Kpropt.ge.2.or.(Kpart.eq.2.and.Kpropt.le.1))
     &   CALL rite(17,stwt,Lfda,Llda,6,1,stdev)
C --- IF THERE ARE PRIOR T.D. WEIGHTS AND REGR.T.D. WTS B18.,C18,B19,C19
C --- ARE PRINTED OUT. IF THERE ARE NO T.D. WIGHTS THEY ARE SUPPRESSED.
C --- IF THERE ARE PRIOR T.D. WTS. BUT NO REGR. WTS. B18 AND C18 ARE THE
C --- SAME AS A4 AND B19 AND C19 ARE THE SAME AS B1. IF THERE ARE REGR
C --- WTS AND NO PRIOR T.D. WTS B18 AND C18 ARE THE SAME AS B16 +C16
C --- AND B19 + C19 ARE PRINTED OUT
      GO TO(200,170,200,170,180,190,180,190),Kswk
  170 IF(Kpropt.ge.2.or.Kpart.eq.2)CALL rite(18,0.0,0,0,18,0,0.0)
      GO TO 200
  180 IF(Kpart.gt.1)THEN
       IF(Lopt.gt.0)GO TO 190
      END IF
      DO i=Lfdr,Llda+12
       Stmp(i)=Sttdrf(i)
      END DO
      IF(Kpropt.ge.2.or.Kpart.eq.2)CALL rite(18,0.0,0,0,19,0,0.0)
      GO TO 200
C --- COMBINE PRIOR AND REGR WTS
  190 DO i=1,7
       D(i)=D(i)+Dwt(i)-1.
      END DO
C --- COMPUTE MONTHLY FACTORS FROM COMBINED DAILY WTS.
      CALL dow(D,Stmp,Lyr,Lfdr,Llda,Lopt)
C --- WRITE TRADING DAY FACTORS FROM COMBINED WTS. -B18. OR C18.
      IF(Kpropt.ge.2.or.Kpart.eq.2)CALL rite(18,Stmp,Lfda,Llda,4,4,D)
  200 IF(Kpart.gt.1)THEN
C --- PART C ONLY
C --- COMPUTE AVGE MONTH-TO-MONTH CHANGES OF COMBINED T.D. FACTORS
       DO i=Lfda,Llda+12
        Sttdrf(i)=Stmp(i)
       END DO
C  *****  CHANGE TO IMPLEMENT X-11-ARIMA M & Q DIAGNOSTICS
       IF(Issap.ne.1)THEN
        CALL sumry(Sttdrf,Smtd,Lfda,Llda,1)
        Vtd=vars(Sttdrf,Lfda,Llda,0)
       END IF
      END IF
C  *****  END OF CHANGES
C --- PART B AND C
C --- DIVIDE PRIOR MONTHLY ADJUSTED -*A3 OR A1* BY COMBINED T.D. FACTORS
C --- TO OBTAIN CALENDAR ADJUSTED SERIES
      CALL addmul(stocca,Stopma,Stmp,Lfda,Llda)
      IF(Kswk.lt.3)THEN
       IF(Kswk.ne.1)THEN
C --- WRITE ORIGINAL SERIES ADJUSTED FOR CALENDAR VARIATION -B19 OR C19.
C***** SPAG has made duplicate copies of the following statement 
        IF(Kpropt.gt.2)CALL rite(19,stocca,Lfda,Llda,2,7,0.0)
       END IF
      ELSE IF(Kswk.ne.3)THEN
C***** The following statement is a duplicate copy made by SPAG
       IF(Kpropt.gt.2)CALL rite(19,stocca,Lfda,Llda,2,7,0.0)
      END IF
C --- MODIFY THE ORIGINAL SERIES ADJUSTED FOR CALENDAR VARIATION FOR
C --- EXTREMES WHERE IRREGULAR VALUES RECVD LESS THAN FULL WT.
      IF(Muladd.ne.0)THEN
       DO i=Lfda,Llda
        stcsi(i)=stocca(i)
        IF(stwt(i).ne.100.)stcsi(i)=stocca(i)
     &                              -(Sti(i)*(1.0-stwt(i)/100.))
       END DO
      ELSE
       DO i=Lfda,Llda
        stcsi(i)=stocca(i)
        IF(stwt(i).ne.100.)stcsi(i)=stocca(i)
     &                              *((100.-stwt(i))/Sti(i)+stwt(i)
     &                              /100.)
       END DO
      END IF
      GO TO(210,220),Kpart
C --- BEGIN PART C
  210 Kpart=2
      Part=cs
      GO TO 230
C --- BEGIN PART D
  220 Kpart=3
      Part=ds
  230 ksect=1
C --- WRITE MODIFIED ORIGINAL SERIES - C1. OR D1.
      IF(Kpropt.ge.2)CALL rite(1,stcsi,Lfda,Llda,5,7,0.0)
      Finap(1)=final(1)
      Finap(2)=final(2)
      GO TO 10
C --- PART D ONLY
C --- DIVIDE CALENDAR ADJUSTED SERIES *C19 IF REGRESSION OPTION SELECTED
C ---  B1 IF PRIOR ADJUSTMENT ONLY OR A1 IF NO CALENDAR ADJUSTMENT* BY T
C --- TREND CYCLE -D7. TO OBTAIN FINAL UNMODIFIED SI RATIOS
  240 CALL addmul(stsie,stocca,Stc,Lfda,Llda)
C --- COMPUTE SEASONAL FACTORS
      CALL vsfc(mfda,mlda,ksect)
      Finab(1)=final(1)
      Finab(2)=final(2)
C --- WRITE UNMODIFIED SI RATIOS -D8.
      CALL rite(8,stsie,Lfda,Llda,5,4,0.0)
C --- PERFORM ANALYSIS OF VARIANCE ON UNMODIFIED SI RATIOS
      IF(Khol.ne.1)THEN
       IF(Issap.ne.1)THEN
        WRITE(Nw,1010)Name,Kpage,Lser
 1010   FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
        Kpage=Kpage+1
        WRITE(Nw,1020)
 1020   FORMAT(/20X,'STABLE SEASONALITY TEST')
       END IF
       CALL ftest(stsie,Lfda,Llda,0,icol)
       CALL mstest(stsie,Lfda,Llda,12,icol)
       CALL combft(icol)
       IF(Igrz.eq.2.and.Issap.ne.1)THEN
        title2='D8. FINAL UNMODIFIED SI RATIOS'
        CALL grzlst(Lfda,ibeg2,Llda,Lyr,stsie,stsie,108)
        CALL chrt(title2,7,1,ibeg2,Llda)
       END IF
      END IF
C --- IDENTIFY SI RATIOS WHICH ARE NOT IDENTICAL IN D7. AND D8.
      DO i=Lfda,Llda
       Stmp(i)=10.**10
       IF(stsie(i).ne.Stsi(i))Stmp(i)=Stsi(i)
      END DO
C --- WRITE FINAL REPLACEMANT VALUES FOR EXTREME SI RATIOS -D9.
      CALL rite(9,Stmp,Lfda,Llda,6,4,0.0)
C --- COMPUTE YEAR AHEAD SEASONAL FACTORS
      j=Llda+1
      k=Llda+12
      DO i=j,k
       Sts(i)=(3.*Sts(i-12)-Sts(i-24))/2.
      END DO
C --- WRITE FINAL SEASONAL FACTORS - D10.
      CALL rite(10,Sts,Lfda,Llda,1,4,0.0)
      IF(Issap.eq.1.and.Muladd.eq.0)CALL ssrit(Sts,Lfda,Llda,2,NL2,Stor,
     &   Lfda,Lstmo)
      IF(Kfulsm.ne.0)THEN
C --- SUMMARY MEASURES VERSION ONLY
C --- REPLACE FINAL SEASONALLY ADJUSTED SERIES WITH D1.
       DO i=Lfda,Llda
        Stci(i)=stcsi(i)
       END DO
C --- APPLY VARIABLE TREND CYCLE ROUTINE TO D1
       CALL vtc(Lfda,Llda,Ktcopt)
C --- REPLACE FINAL SEASONALLY ADJUSTED SERIES WITH B1.
       DO i=Lfda,Llda
        Stci(i)=Stor(i)
       END DO
      ELSE
C --- FULL ADJUSTMENT VERSION ONLY
C --- DIVIDE D1 BY FINAL SEASONAL FACTORS TO OBTAIN A MODIFIED SEASONAL-
C --- LY ADJUSTED SERIES
       CALL addmul(Stci,stcsi,Sts,Lfda,Llda)
C --- APPLY THE VARIABLE TREND CYCLE ROUTINE TO THE MOD. SEASONALLY ADJ.
C --- SERIES TO OBTAIN FINAL TREND CYCLE
       CALL vtc(Lfda,Llda,Ktcopt)
C --- DIVIDE THE CALENDAR ADJ. SERIES *C19,B1, OR A1* BY FINAL SEASONAL
C --- FACTORS TO OBTAIN A FINAL SEASONALLY ADJ. SERIES
       CALL addmul(Stci,stocca,Sts,Lfda,Llda)
      END IF
C --- FOR ALL VERSIONS
C --- WRITE FINAL SEASONALLY ADJUSTED SERIES -D11.
      CALL rite(11,Stci,Lfda,Llda,2,7,0.0)
      IF(Issap.eq.1)CALL ssrit(Stci,Lfda,Llda,3,NL1,Stor,Lfda,Lstmo)
      IF(Khol.ne.1.and.Igrz.eq.0)CALL ftest(Stci,Lfda,Llda,1,icol)
C --- WRITE FINAL TREND CYCLE -D12.
      IF(Kpropt.gt.0)CALL rite(12,Stc,Lfda,Llda,2,7,0.0)
C --- DIVIDE FINAL SEASONALLY ADJUSTED SERIES BY FINAL TREND CYCLE TO
C --- OBTAIN THE FINAL IRREGULAR
      CALL addmul(Sti,Stci,Stc,Lfda,Llda)
      IF(Khol.eq.1)RETURN
C --- WRITE FINAL IRREGULAR -D13.
      IF(Kpropt.gt.0)CALL rite(13,Sti,Lfda,Llda,3,5,0.0)
      IF(Kdwopt.ge.2.or.Khol.eq.2.or.
     &   (Kdwopt.le.1.and.(Kswt.eq.2.or.Kswt.eq.4)))THEN
       l2=Llda+12
       DO i=Lfda,l2
        cfac(i)=Sts(i)
        IF(Kdwopt.ge.2)THEN
         IF(Muladd.eq.0)THEN
          cfac(i)=(cfac(i)*Sttdrf(i))/100.0
         ELSE
          cfac(i)=cfac(i)+Sttdrf(i)
         END IF
        END IF
        IF(Khol.eq.2)cfac(i)=(cfac(i)*Hfac(i))/100.0
        IF(Kdwopt.le.1.and.(Kswt.eq.2.or.Kswt.eq.4))THEN
         IF(Muladd.eq.0)THEN
          cfac(i)=(cfac(i)*Stptdf(i))/100.0
         ELSE
          cfac(i)=cfac(i)+Stptdf(i)
         END IF
        END IF
       END DO
       CALL rite(20,cfac,Lfda,Llda,1,4,0.0)
      END IF
C --- BEGIN PART E
      IF(Kpropt.eq.0)RETURN
      Kpart=5
      Part=es
C --- COMPUTE MODIFIED ORIGINAL, SEASONALLLY ADJUSTED AND IRREGUAAR
C --- SERIES BY REPLACING THOSE VALUES WHICH WERE ASSIGNED ZERO WT. IN
C --- TABLE C17.
      DO i=Lfda,Llda
       IF(stwt(i).ne.0)THEN
        stome(i)=Stor(i)
        stcime(i)=Stci(i)
        Stime(i)=Sti(i)
       ELSE
C --- REPLACE SEASONALLY ADJUSTED VALUES WITH FINAL TREND CYCLE VALUES
        stcime(i)=Stc(i)
        IF(Muladd.ne.0)THEN
C --- IF ADDITIVE, REPLACE IRREGULAR VALUES WITH 0. AND ORIGINAL VALUES
C --- WITH THE SUM OF THE  ABOVE
         Stime(i)=0.
         stome(i)=Stc(i)+Sts(i)+Sttdrf(i)+Stpmf(i)
        ELSE
C --- IF MULTIPLICATIVE, REPLACE IRREGULAR VALUES WITH 100. AND ORIGINAL
C --- VALUES WITH THE PRODUCT OF THE FINAL TREND CYCLE, FINAL SEASONAL F
C --- FACTORS, COMBINED TRADING DAY FACTORS AND PRIOR MONTHLY FACTORS
         Stime(i)=100.
         stome(i)=Stc(i)*Sts(i)/100.*Sttdrf(i)/100.*Stpmf(i)/100.
        END IF
       END IF
      END DO
C --- WRITE ORIGINAL SERIES MODIFIED FOR EXTREMES -E1.
      IF(Igrz.ne.0.and.Nopt.eq.0)THEN
       title2=
     &'E0. ORIGINAL SERIES,@-SEASONALLY ADJUSTED SERIES COINCIDENCE OF P
     &OINTS'
       IF(Mach.eq.0)title2(21:21)=char(223)
       mgrz=(Lstyr-Lyr)*12+Lstmo
       CALL grzlst(Lfda,ibeg2,mgrz,Lyr,Stor,Stci,108)
       CALL chrt(title2,15,2,ibeg2,mgrz)
      END IF
      IF(Kpropt.ge.2)CALL rite(1,stome,Lfda,Llda,2,7,0.0)
      IF(Kfulsm.eq.0)THEN
C --- FOR FULL ADJUSTMENT ONLY, WRITE MODIFIED SEASONALLY ADJUSTED
C --- SERIES -E2.
       IF(Kpropt.ge.2)THEN
        CALL rite(2,stcime,Lfda,Llda,2,7,0.0)
        CALL ftest(stcime,Lfda,Llda,2,icol)
       END IF
      END IF
C --- WRITE MODIFIED IRREGULAR SERIES -E3
      IF(Kpropt.ge.2)CALL rite(3,Stime,Lfda,Llda,3,5,0.0)
      IF(Kfulsm.eq.0)THEN
C --- FOR FULL ADJUSTMENT ONLY COMPUTE AND WRITE RATIOS OF ANNUAL TOTALS
C --- B1/D11 AND E1/E2   -E4.
       IF(Kpropt.eq.3)CALL rite(4,0.0,0,0,0,0,0.0)
       IF(Issap.ne.1.and.Kpropt.eq.3)THEN
        j=1
        jyra=Lyr
        IF(Lfda.ne.1)THEN
         j=13
         jyra=Lyr+1
        END IF
        kyra=Lyr+Llda/12-1
        DO i=jyra,kyra
         toto=0.
         totom=0.
         tota=0.
         totam=0.
         k=j+11
         DO l=j,k
          toto=toto+Stor(l)
          totom=totom+stome(l)
          tota=tota+Stci(l)
          totam=totam+stcime(l)
         END DO
         j=j+12
         IF(Muladd.ne.0)THEN
          toto=toto-tota
          totom=totom-totam
         ELSE
          toto=toto/tota*100.
          totom=totom/totam*100.
         END IF
         WRITE(Nw,1030)Spc,i,toto,totom
 1030    FORMAT(A1,'   ',I4,5X,F8.1,5X,F8.1)
        END DO
       END IF
      END IF
      mfda=Lfda+1
      mlda=Llda-1
C --- COMPUTE AVGE CHANGES IN ORIGINAL AND SEASONALLY ADJUSTED SERIES
      IF(Muladd.ne.0)THEN
       CALL addmul(Stmp2,Stor2,Stor,Lfda,mlda)
      ELSE
       DO i=mfda,Llda
        Stmp(i)=(Stor(i)-Stor(i-1))/Stor(i-1)*100.
       END DO
      END IF
C --- WRITE AVGE CHANGES IN ORIGINAL SERIES -E5.
      CALL rite(5,Stmp,mfda,Llda,5,4,0.0)
      IF(Kfulsm.eq.0)THEN
       IF(Muladd.ne.0)THEN
        CALL addmul(Stmp2,Stci2,Stci,Lfda,mlda)
       ELSE
        DO i=mfda,Llda
         Stmp(i)=(Stci(i)-Stci(i-1))/Stci(i-1)*100.
        END DO
       END IF
C --- WRITE AVGE CHANGES IN SEASONALLY ADJUSTED SERIES -E6.
       CALL rite(6,Stmp,mfda,Llda,5,4,0.0)
      END IF
C --- COMPUTE AVGE CHANGES IN I + C OVER 1-12 MONTH SPANS
      CALL sumry(Sti,Smi,Lfda,Llda,2)
      CALL sumry(Stc,Smc,Lfda,Llda,2)
      DO i=1,12
C --- COMPUTE I/C TO DETERMINE MCD
       smic(i)=Smi(i)/Smc(i)
      END DO
C  *****  CHANGE TO IMPLEMENT X-11-ARIMA M & Q DIAGNOSTICS
      Mcd=12
      DO WHILE (smic(Mcd).lt.1.0)
       IF(Mcd.eq.1)GO TO 250
       Mcd=Mcd-1
      END DO
      Mcd=Mcd+1
      IF(Mcd.gt.12)Mcd=12
C  *****  END OF CHANGES
  250 mfda=Lfda+Mcd/2
      mlda=Llda-(Mcd-1)/2
      j=(Mcd+2)/2
      xmcd=Mcd
      DO i=mfda,mlda
       tmp=0.
       DO i2=1,Mcd
        l=i+i2-j
        tmp=tmp+Stci(l)
       END DO
       Stmcd(i)=tmp/xmcd
      END DO
C --- COMPUTE AVGE MO-TO-MO CHANGES IN MCD FOR SUMMARY MEASURES TABLE
      CALL sumry(Stmcd,smmcd,mfda,mlda,3)
C --- COMPUTE AVGE DURATION OF RUN OF MCD SERIES
      CALL avdur(Stmcd,mfda,mlda,adrmcd)
      Kpart=6
      Part=fs
C --- WRITE MCD MOVING AVERAGE -F1.
      IF(Kpropt.eq.3)CALL rite(1,Stmcd,mfda,mlda,5,7,0.0)
      IF(Issap.ne.1)THEN
C --- COMPUTE MEASURES FOR SUMMARY MEASURES TABLE
       CALL sumry(Sts,sms,Lfda,Llda,2)
       CALL sumry(Stor,Smo,Lfda,Llda,2)
       CALL sumry(Stci,Smci,Lfda,Llda,3)
       CALL sumry(stome,smome,Lfda,Llda,4)
       IF(Kfulsm.ne.0)THEN
C --- IN SUMMARY MEASURES RUN REPLACE SEASONALLY ADJUSTED WITH ORIGINAL
        DO i=1,12
         smcime(i)=smome(i)
        END DO
       ELSE
        CALL sumry(stcime,smcime,Lfda,Llda,4)
       END IF
       CALL sumry(Stime,smime,Lfda,Llda,4)
       CALL avdur(Stci,Lfda,Llda,adrci)
       CALL avdur(Sti,Lfda,Llda,Adri)
       CALL avdur(Stc,Lfda,Llda,adrc)
C --- IF MCD IS 1, MCD IS SAME AS SEASONALLY ADJUSTED SERIES
       IF(Mcd.eq.1)THEN
        adrmcd=adrci
        DO i=1,12
         smmcd(i)=Smci(i)
        END DO
       END IF
C --- WRITE TABLE HEADING FOR SUMMARY MEASURES
       CALL rite(2,0.0,0,0,0,0,0.0)
       swo=blank
       IF(Kdwopt.eq.2)THEN
C***** The following statement is a duplicate copy made by SPAG
        swo=star
       ELSE IF(.not.(Fstar.eq.blank.and.(Kswt.eq.1.or.Kswt.eq.3)))THEN
C***** SPAG has made duplicate copies of the following statement 
        swo=star
       END IF
C --- WRITE AVGE CHANGE W/O REGARD TO SIGN. 1-12 MOS. SPAN
       WRITE(Nw,1040)Pcdif,Aorb,swo
 1040  FORMAT(' F 2.A:',2X,'AVERAGE',4A4,
     &        ' WITHOUT REGARD TO SIGN OVER INDICATED SPAN ',/,14X,
     &        'SPAN',/,15X,'IN',6X,A1,
     &        '1     D11     D13     D12     D10      ',
     &        'A2     C18      F1             E1      E2      E3',/,13X,
     &       'MONTHS    O      CI       I       C       S       P      '
     &       ,'TD',A1,'     MCD           MOD.O   MOD.CI  MOD.I')
       DO i=1,12
        j=i+12
        IF(i.lt.8)THEN
        ELSE IF(i.eq.8)THEN
         GO TO 260
        ELSE IF(i.eq.10)THEN
         GO TO 260
        END IF
        WRITE(Nw,1050)i,Smo(i),Smci(i),Smi(i),Smc(i),sms(i),Smp(i),
     &                Smtd(i),smmcd(i),smome(i),smcime(i),smime(i)
 1050   FORMAT(15X,I2,8F8.2,9X,3F8.2)
C --- COMPUTE CONTRIBUTIONS TO ORIGINAL SERIES IN FULL ADJUST. RUN ONLY
        smo2(i)=Smi(j)+Smc(j)+sms(j)+Smp(j)+Smtd(j)
        Smi(j)=Smi(j)/smo2(i)
        Smc(j)=Smc(j)/smo2(i)
        sms(j)=sms(j)/smo2(i)
        Smp(j)=Smp(j)/smo2(i)
        Smtd(j)=Smtd(j)/smo2(i)
        smo2(i)=smo2(i)/Smo(j)
  260  END DO
       IF(Kfulsm.eq.0)THEN
        WRITE(Nw,1060)swo
 1060   FORMAT(/,' F 2.B:',2X,'RELATIVE CONTRIBUTIONS OF COMPONENTS ',
     &         'TO VARIANCE IN ORIGINAL SERIES',/,14X,'SPAN',/,15X,
     &         'IN    D13     D12     D10      A2     C18            ',
     &         'RATIO',/,13X,
     &         'MONTHS   I       C       S       P      TD',A1,
     &         '    TOTAL   (X100)')
        DO i=1,12
         j=i+12
         IF(i.lt.8)THEN
         ELSE IF(i.eq.8)THEN
          GO TO 270
         ELSE IF(i.eq.10)THEN
          GO TO 270
         END IF
         WRITE(Nw,1070)i,Smi(j),Smc(j),sms(j),Smp(j),Smtd(j),smo2(i)
 1070    FORMAT(15X,I2,2P5F8.2,'   100.00',F8.2)
  270   END DO
       END IF
C --- WRITE AVERAGE DURATIONS OF RUN
       WRITE(Nw,1080)adrci,Adri,adrc,adrmcd,(smic(i),i=1,12),Mcd
 1080  FORMAT(/,' F 2.C:',2X,'AVERAGE DURATION OF RUN      CI      I',
     &        '       C      MCD',/,33X,4F8.2,//,' F 2.D:',2X,
     &        'I/C RATIO FOR MONTHS SPAN',/,23X,
     &        '1       2       3       4       5       6       7',
     &        '       8       9      10      11      12',/,17X,12F8.2,
     &        //,9X,'MONTHS FOR CYCLICAL DOMINANCE  ',I2,/)
       WRITE(Nw,1090)(Pcdif(i),i=1,4),Aorb
 1090  FORMAT(' F 2.E:',2X,'AVERAGE',4A4,' 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,
     &        'MCD',/,13X,'MONTHS   AVGE    S.D.     AVGE    ',
     &        'S.D.     AVGE    S.D.     AVGE    S.D.     AVGE',
     &        '    S.D.     AVGE    S.D.')
       DO i=1,12
        j=i+24
        k=i+36
        IF(i.lt.8)THEN
        ELSE IF(i.eq.8)THEN
         GO TO 280
        ELSE IF(i.eq.10)THEN
         GO TO 280
        END IF
C --- WRITE AVERAGE CHANGE WITH REGARD TO SIGN
        WRITE(Nw,1100)i,Smo(j),Smo(k),Smi(j),Smi(k),Smc(j),Smc(k),sms(j)
     &                ,sms(k),Smci(j),Smci(k),smmcd(j),smmcd(k)
 1100   FORMAT(15X,I2,6(F9.2,F8.2))
  280  END DO
C  *****  CHANGES TO INCORPORATE M & Q STATISTICS
       CALL vcomp(12,Stime,stome)
       WRITE(Nw,1010)Name,Kpage,Lser
       Kpage=Kpage+1
       WRITE(Nw,1110)Vi,Vc,Vs,Vp,Vtd,Rv
 1110  FORMAT(//,' F 2.F:',2X,'RELATIVE CONTRIBUTION OF THE ',
     &        'COMPONENTS TO THE STATIONARY PORTION OF THE VARIANCE IN '
     &        ,'THE ORIGINAL SERIES',/,24X,'I',7X,'C',7X,'S',7X,'P',6X,
     &        'TD',4X,'TOTAL',/,19X,6F8.2,/)
       WRITE(Nw,1120)Ratic,Ratis
 1120  FORMAT(/,' F 2.G:',2X,'THE FINAL I/C RATIO FROM TABLE D12:',
     &        F12.2,/,9X,'THE FINAL I/S RATIO FROM TABLE D10:',F12.2)
       WRITE(Nw,1130)
 1130  FORMAT(/,' F 2.H:',77X,'STATISTIC PROBABILITY',/,100X,'LEVEL')
       IF(Kdwopt.ge.1.and.Kdwopt.lt.6)WRITE(Nw,1140)F(3),P(3)
 1140  FORMAT(10X,'F-TEST FOR THE TRADING DAY REGESSION IN TABLE ',
     &        'C15.',21X,':',F11.3,F8.2,'%')
       WRITE(Nw,1150)F(1),P(1),F(2),P(2)
 1150  FORMAT(10X,'F-TEST FOR STABLE SEASONALITY FROM TABLE D 8.',26X,
     &        ':',F11.3,F8.2,'%',/,10X,
     &        'F-TEST FOR MOVING SEASONALITY FROM TABLE D 8.',26X,':',
     &        F11.3,F8.2,'%')
C  *****  END OF CHANGES
       IF(swo.eq.star)THEN
        WRITE(Nw,1160)Cout
 1160   FORMAT(//10X,'* (TRADING DAY ADJUSTMENT FACTORS WITH',A3,
     &         ' LENGTH OF MONTH ADJUSTMENT)')
       END IF
C  *****  CHANGES TO INCORPORATE M & Q STATISTICS
       CALL f3cal(Smi,Smp,smic,12)
       CALL f3gen(12,mq)
C  *****  END OF CHANGES
       IF(Igrz.ge.1)THEN
        CALL spgrh(Stci,Lfda+1,Llda,1)
        CALL spgrh(Stime,Lfda,Llda,2)
       END IF
      END IF
      RETURN
      END
**==inerr.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE inerr(Reset,Irs,*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER Irs,Irun,Ixerr,Kpage,Kswerr,Kswt,Kswv,Nerr,Np,Nr
C*** End of declarations inserted by SPAG
      CHARACTER*1 Reset
      CHARACTER*6 Lser
      COMMON /cz    / Kpage,Np,Lser
      COMMON /xk    / Kswt,Kswv
      COMMON /xerr  / Nr,Nerr,Kswerr,Irun,Ixerr
      IF(Kswt.gt.0)THEN
       Kswt=0
       IF(Nr.eq.10)THEN
        WRITE(Nerr,1010)Irun
 1010   FORMAT(5X,'ERROR MESSAGES FOR X-11.2 RUN ',I3,' : ')
        WRITE(Nerr,1020)Lser
        IF(Ixerr.eq.0)Ixerr=1
       END IF
       IF(Nr.eq.5)PRINT 1020,Lser
 1020  FORMAT(5X,' REJECT ',A6)
       IF(Reset.eq.'Y'.or.Irs.eq.9)THEN
        Reset='N'
        Irs=2
       END IF
      END IF
      Kswerr=Kswerr+1
      IF(Nr.eq.10.and.Kswerr.eq.31)THEN
       WRITE(Nerr,1030)
 1030  FORMAT(10X,'ERROR MESSAGES FOR THIS SERIES DISCONTINUED')
       RETURN 1
      END IF
      RETURN
      END
**==inc.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE inc(Icer,File,File2,Ifile,Crerr,*,*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER Icer,Irun,Ixerr,Kswerr,Nerr,Nr
C*** End of declarations inserted by SPAG
      CHARACTER*8 ce
      CHARACTER*24 Crerr(8)
      CHARACTER*80 File,File2,Ifile
      COMMON /xerr  / Nr,Nerr,Kswerr,Irun,Ixerr
      IF(Nr.eq.10)THEN
       READ(Nr,1010,ERR=30,END=40)File
 1010  FORMAT(A80)
      ELSE
       ce='   ENTER'
       IF(Icer.gt.10)THEN
        Icer=Icer-10
        ce='RE-ENTER'
       END IF
       DO WHILE (.true.)
        IF(Icer.eq.3)PRINT *,ce,' TITLE FOR X-11.2 RUN :'
        IF(Icer.eq.4)PRINT *,ce,' DATA FILE NAME :'
        IF(Icer.eq.5)PRINT *,ce,' OUTPUT FILE NAME :'
        IF(Icer.eq.6)PRINT *,ce,' PRIOR MONTHLY FACTOR FILE NAME :'
        PRINT *,' > '
        READ 1010,File
        IF(File.eq.'*')THEN
         PRINT *,File2
         GO TO 10
        END IF
        IF(ce.eq.'RE-ENTER')RETURN 1
        GO TO 20
   10  END DO
      END IF
   20 RETURN
   30 WRITE(25,1020)Crerr(Icer),Ifile
 1020 FORMAT(10X,'ERROR IN READING ',A24,' FOUND IN ',A80)
      WRITE(25,1030)
 1030 FORMAT('    EXECUTION FOR THIS X-11.2 RUN CEASES.',/,
     &       '    WILL ATTEMPT TO EXECUTE REMAINDER OF INSTRUCTIONS ',
     &       'IN THIS COMMAND FILE.')
      IF(Ixerr.eq.0)Ixerr=1
      RETURN 1
   40 WRITE(25,1040)Crerr(Icer),Ifile
 1040 FORMAT(10X,'END OF FILE ENCONTERED IN READING ',A24,'FOUND IN ',
     &       A80)
      IF(Ixerr.eq.0)Ixerr=1
      RETURN 2
      END
**==zdat.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE zdat(Idat,Ld,Ibyr,Reset,Irs,Prfmt,Iz,*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER Ibyr,Idat,Irs,Irun,Ixerr,Iz,Kswerr,Ld,Muladd,Nerr,nmo,Nr,
     &        nyr
C*** End of declarations inserted by SPAG
      CHARACTER*1 Reset
      CHARACTER*6 kedit
      CHARACTER*40 Prfmt
      COMMON /xerr  / Nr,Nerr,Kswerr,Irun,Ixerr
      COMMON /cj    / Muladd
      IF(Ld.lt.2)THEN
       Iz=1
       nyr=(Idat-1)/12
       nmo=Idat-nyr*12
       nyr=nyr+Ibyr
       IF(Ld.eq.0)kedit=' DATA '
       IF(Ld.eq.1)kedit='WEIGHT'
       IF(Nr.eq.10)WRITE(Nerr,1010)kedit,nmo,nyr
       IF(Nr.eq.5)PRINT 1010,kedit,nmo,nyr
 1010  FORMAT(10X,'THE ',A6,' FOR ',I2,'/',I2,' IS ZERO OR NEGATIVE')
      ELSE IF(Prfmt.eq.'n'.or.Prfmt.eq.'N')THEN
       Muladd=1
       IF(Ixerr.eq.0)Ixerr=1
       IF(Nr.eq.5)PRINT 1020
       IF(Nr.eq.10)WRITE(Nerr,1020)
 1020  FORMAT(10X,'SWITCHED TO ADDITIVE ADJUSTMENT DUE TO NEGATIVE',
     &        ' DATA VALUES')
      ELSE
       CALL inerr(Reset,Irs,*10)
      END IF
      RETURN
   10 RETURN 1
      END
**==traday.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE traday(Kfda,Klda,Lyr,Sigm,Kpart,Lopt,Kswt,Kpropt)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION adj,Array,c,dc,Dp,Dr,dss,dssm,f,Fst,fvalue,p,Pr,
     &                 r,rss,rssm,s,se,setdaf,Sigm
      DOUBLE PRECISION sigt1,sigt2,Stdr,Stmp,sumy,sumysq,t1,tc,Test1,
     &                 Test2,tk,tkon,tmean,tmp,tp,tsd,v,wt,x,xn
      DOUBLE PRECISION y
      INTEGER i,Iqfail,Issap,j,k,Karray,kdays,Kfda,Khol,Klda,kon,Kpart,
     &        Kpropt,kstd,Kswt,l,lfda,llda,Lopt,Lyr,lyr2
      INTEGER m,m1,m2,mdays,mtype,Muladd,n,ndgfre,NL1,NL2,Nopt,Nw
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      DOUBLE PRECISION matrx
      CHARACTER*4 Fstar,blank,star,star1(7),star2(7)
      COMMON /ca    / Nw
      COMMON /caa   / Stmp(NL2)
      COMMON /cj    / Muladd
      COMMON /cl    / Array(NL1),Karray(NL1),Stdr(NL2),Dr(7),Dp(7),Fstar
      COMMON /czz   / Nopt,Khol,Issap
C  *****  CHANGES TO INCORPORATE M & Q STATISTICS
      COMMON /tests / Fst(3),Pr(3),Test1,Test2,Iqfail
C  *****  END OF CHANGES
      DIMENSION kdays(12),mdays(12),tmean(22),tc(22),x(7),c(6),s(7),
     &          v(6),tp(7),dc(7),t1(7),setdaf(3),adj(8),matrx(6,7),wt(3)
      DATA adj/31.,30.,29.,0.,30.4375,30.4375,30.4375,0./
      DATA star/'****'/
      DATA blank/'    '/
      DATA kdays/3,0,3,2,3,2,3,3,2,3,2,3/
      DATA mdays/0,3,3,6,1,4,6,2,5,0,3,5/
 1010 FORMAT(22X,
     &'COMBINED      PRIOR    REGRESSION   ST.ERROR         T          T
     &'/23X,'WEIGHT      WEIGHT      COEFF.    (COMB.WT.)       (',I1,
     &')     (PRIOR WT.)'/11X,'   MONDAY',F9.3,7X,F5.3,3F12.3,A1,4X,
     &F7.3,A2/11X,'  TUESDAY',F9.3,7X,F5.3,3F12.3,A1,4X,F7.3,A2/11X,
     &'WEDNESDAY',F9.3,7X,F5.3,3F12.3,A1,4X,F7.3,A2/11X,' THURSDAY',
     &F9.3,7X,F5.3,3F12.3,A1,4X,F7.3,A2/11X,'   FRIDAY',F9.3,7X,F5.3,
     &3F12.3,A1,4X,F7.3,A2/11X,' SATURDAY',F9.3,7X,F5.3,3F12.3,A1,4X,
     &F7.3,A2/11X,'   SUNDAY',F9.3,7X,F5.3,3F12.3,A1,4X,F7.3,A2)
 1020 FORMAT(26X,'*   COMBINED WT. SIGNIFICANTLY DIFFERENT FROM ',I1,
     &       ' AT 1 PER CENT LEVEL')
 1030 FORMAT(26X,
     &'**  COMBINED WT. SIGNIFICANTLY DIFFERENT FROM PRIOR WEIGHT AT 1 P
     &ER CENT LEVEL')
 1040 FORMAT(//21X,'SOURCE OF',9X,'SUM OF',5X,'DGRS.OF',9X,'MEAN'/22X,
     &       'VARIANCE',9X,'SQUARES',4X,'FREEDOM',9X,'SQUARE',9X,
     &       'F'//20X,'REGRESSION',F17.3,7X,'6.',F17.3,F12.3,A3/25X,
     &       'ERROR',F17.3,F9.0,F17.3/25X,'TOTAL',F17.3,F9.0)
 1050 FORMAT(26X,
     &'*** RESIDUAL TRADING DAY VARIATION PRESENT AT THE 1 PER CENT LEVE
     &L'/)
 1060 FORMAT(11X,
     &'STANDARD ERRORS OF TRADING DAY ADJUSTMENT FACTORS DERIVED FROM RE
     &GRESSION COEFFICIENTS'/15X,'31-DAY MONTHS- ',F8.2/15X,
     &'30-DAY MONTHS- ',F8.2/15X,'29-DAY MONTHS- ',F8.2/15X,
     &'28-DAY MONTHS-      .00')
      lfda=Kfda
      llda=Klda
      tkon=100.
      kon=1
      IF(Muladd.ne.0)THEN
       tkon=0.
       kon=0
      END IF
      IF(Kpart.le.1)THEN
C --- DETERMINE DAY-OF-WEEK OF FIRST DAY OF FIRST MONTH OF SERIES
C ---     DETERMINE D-O-W OF JAN.1 OF LYR. 1=MON., 7=SUN.
       lyr2=Lyr-1900
       n=lyr2+12-((lyr2+11)/28)*28
       n=n+(n-1)/4
       n=n-((n-1)/7)*7
C ---    D-O-W FOR ACTUAL FIRST MONTH OF SERIES
       j=lfda-(lfda-1)/12*12
       n=n+mdays(j)
C ---    ADD A DAY IF FIRST MONTH IS IN LEAP YEAR AND AFTER FEB.
       l=lyr2-1
       IF(j.gt.2)THEN
        l=lyr2
        IF(lyr2.eq.lyr2/4*4)n=n+1
       END IF
       IF(n.gt.7)n=n-7
       m=n
C --- STORE TYPE CODE FOR EACH MONTH IN KARRAY.ALSO ACCUMULATE IRREGULAR
C ---   AND COUNT BY TYPE TO GET TYPE MEAN
       DO i=lfda,llda
        Stmp(i)=10.**10
        k=kdays(j)
C --- TEST FOR FEB.
        IF(k.ne.0)THEN
C --- TYPE CODES FOR NON-FEB ARE 1-7  AND  8-14 FOR 30 AND 31 DAY MOS.
         mtype=(k-2)*7+m
        ELSE
C --- TEST FOR LEAP YEAR FEB.
         l=l+1
         IF(l.ne.(l/4)*4)THEN
C --- NON-LEAP YEAR FEB. TYPE CODE IS 15
          mtype=15
         ELSE
C --- LEAP YEAR FEB. TYPE CODE IS 16-22 FOR 1ST DAY MON. THRU SUN.
          mtype=m+15
          k=1
         END IF
        END IF
C --- STORE TYPE CODE IN KARRAY
        Karray(i)=mtype
C --- FIND FIRST DAY FOR NEXT MONTH IN SERIES
        m=m+k
        IF(m.gt.7)m=m-7
        j=j+1
        IF(j.gt.12)j=1
       END DO
C --- COMPUTE SIGMA LIMITS AND IDENTIFY EXTREME IRREGULARS
       kstd=1
      ELSE
       DO i=lfda,llda
        DO WHILE (Karray(i).gt.22)
         Karray(i)=Karray(i)-22
        END DO
       END DO
       kstd=1
       GO TO 40
      END IF
   10 DO i=1,22
       tc(i)=0.
       tmean(i)=0.
      END DO
      tk=0.
      tsd=0.
      DO i=lfda,llda
       m=Karray(i)
       IF(m.le.15)THEN
        tmean(m)=tmean(m)+Array(i)
        tc(m)=tc(m)+1.
        tk=tk+1.
       END IF
      END DO
      DO i=1,15
       tmean(i)=tmean(i)/tc(i)
      END DO
C --- COMPUTE SQ.DEV. OF IRR.FM.TYPE-MEANS FOR NON-LEAP YEAR FEBS.
      DO i=lfda,llda
       m=Karray(i)
       IF(m.le.15)tsd=tsd+(Array(i)-tmean(m))**2
      END DO
      tsd=sqrt(tsd/tk)*Sigm
C --- IDENTIFY EXTREME IRREGULARS BY ADDING 22 TO TYPE CODE
      DO i=lfda,llda
       m=Karray(i)
       IF(m.le.22)THEN
        IF(m.le.15)THEN
         IF(abs(Array(i)-tmean(m)).le.tsd)GO TO 20
        ELSE IF(abs(Array(i)-tkon).le.tsd)THEN
         GO TO 20
        END IF
        Karray(i)=Karray(i)+22
        Stmp(i)=Array(i)
       END IF
   20 END DO
      GO TO(30,60),kstd
   30 kstd=2
      GO TO 10
   40 tsd=0.
      tk=0.
      DO i=lfda,llda
       IF(Karray(i).le.22)THEN
        tsd=tsd+(Array(i)-Stdr(i))**2
        tk=tk+1.
       END IF
      END DO
      tsd=sqrt(tsd/tk)*Sigm
      DO i=lfda,llda
       Stmp(i)=10.**10
       IF(abs(Array(i)-Stdr(i)).gt.tsd)THEN
        Karray(i)=Karray(i)+22
        Stmp(i)=Array(i)
       END IF
      END DO
      GO TO(50,60),kstd
   50 kstd=2
      GO TO 40
C --- REGRESSION COMPUTATION
   60 IF(Issap.ne.1)THEN
       IF(Kpropt.ge.2.or.(Kpart.eq.2.and.Kpropt.eq.1))THEN
        CALL rite(14,Stmp,lfda,llda,6,4,0.0)
        CALL rite(15,0.0,0,0,0,0,0.0)
       END IF
      END IF
      sumy=0.
      sumysq=0.
      DO i=1,6
       DO j=1,7
        matrx(i,j)=0.
       END DO
      END DO
      DO i=lfda,llda
       DO j=1,7
        x(j)=0.
       END DO
       m=Karray(i)
       y=Array(i)
       IF(m.le.7)THEN
C --- 30 DAY MONTH
        n=2
        IF(Muladd.eq.0)THEN
         m1=m+1
         IF(m1.ge.8)m1=1
         y=(y/100.0-1.0)*(28.0+Dp(m)+Dp(m1))
        END IF
        GO TO 120
       ELSE
        m=m-7
        IF(m.lt.8)THEN
C --- 31 DAY MONTH
         n=3
         IF(Muladd.eq.0)THEN
          m1=m+1
          m2=m+2
          IF(m1.lt.7)GO TO 70
          IF(m1.ne.7)m1=m1-7
          m2=m2-7
   70     y=(y/100.0-1.0)*(28.0+Dp(m)+Dp(m1)+Dp(m2))
         END IF
         GO TO 120
        ELSE IF(m.eq.8)THEN
C --- 28 DAY MONTH
         IF(Muladd.ne.0)GO TO 130
         GO TO(80,90,80,90),Kswt
        ELSE
         m=m-8
         IF(m.gt.7)GO TO 140
C --- 29 DAY MONTH
         n=1
         IF(Muladd.ne.0)GO TO 120
         GO TO(100,110,100,110),Kswt
         GO TO 100
        END IF
       END IF
   80  y=y*0.2825-28.0
       GO TO 130
   90  y=y*0.28-28.0
       GO TO 130
  100  y=y*0.2825-29.0
       GO TO 120
  110  y=(y/100.0-1.0)*(28.0+Dp(m))
  120  DO j=1,n
        IF(m.gt.7)m=m-7
        x(m)=1.
        m=m+1
       END DO
       IF(x(7).gt.0)THEN
        DO j=1,6
         x(j)=x(j)-1.
        END DO
       END IF
  130  sumy=sumy+y
       sumysq=sumysq+y*y
       DO m=1,6
        matrx(m,7)=matrx(m,7)+y*x(m)
        DO j=1,6
         matrx(m,j)=matrx(m,j)+x(m)*x(j)
        END DO
       END DO
  140 END DO
      DO i=1,6
       v(i)=matrx(i,7)
      END DO
      DO i=1,6
       r=1./matrx(i,1)
       DO j=1,6
        matrx(i,j)=r*matrx(i,j+1)
       END DO
       matrx(i,7)=r
       DO m=1,6
        IF(m.ne.i)THEN
         r=-matrx(m,1)
         DO j=1,6
          matrx(m,j)=matrx(m,j+1)+r*matrx(i,j)
         END DO
         matrx(m,7)=r*matrx(i,7)
        END IF
       END DO
      END DO
      s(7)=0.
      DO i=1,6
       DO j=2,7
        s(7)=s(7)+matrx(i,j)
       END DO
      END DO
      DO i=1,6
       c(i)=matrx(i,i+1)
      END DO
      dss=0.
      xn=0.
      DO i=lfda,llda
       IF(Karray(i).le.22)xn=xn+1.
      END DO
      Dr(7)=0.
      DO i=1,6
       Dr(i)=matrx(i,1)
       Dr(7)=Dr(7)-matrx(i,1)
       dss=dss+Dr(i)*v(i)
      END DO
      rss=sumysq-dss
      tmp=rss/(xn-6.)
      se=sqrt(tmp)
      f=(dss/6.)/tmp
      Fstar=blank
      ndgfre=idint(xn-6)
      p=fvalue(f,6,ndgfre)*100.0
      IF(p.lt.1.00)Fstar=star
      Fst(3)=f
      Pr(3)=p
      IF(Kpropt.eq.0.or.(Kpart.eq.1.and.Kpropt.eq.1))RETURN
      DO i=1,6
       s(i)=se*sqrt(c(i))
      END DO
      s(7)=se*sqrt(s(7))
      tmp=xn-6.
      dssm=dss/6.
      rssm=rss/tmp
      sigt1=0.
      sigt2=0.
      DO i=1,7
       star1(i)=blank
       star2(i)=blank
       IF(Muladd.ne.0)THEN
        x(i)=10.**10
        tp(i)=10.**10
        dc(i)=Dr(i)
        t1(i)=dc(i)/s(i)
       ELSE
        x(i)=Dp(i)
        dc(i)=Dp(i)+Dr(i)
        tp(i)=Dr(i)/s(i)
        t1(i)=(dc(i)-1.)/s(i)
        IF(abs(tp(i)).gt.2.62)THEN
         star2(i)=star
         sigt2=1.
        END IF
       END IF
       IF(abs(t1(i)).gt.2.62)THEN
        star1(i)=star
        sigt1=1.
       END IF
      END DO
      IF(Issap.eq.1.or.Nopt.eq.1)RETURN
      WRITE(Nw,1010)kon,(dc(i),x(i),Dr(i),s(i),t1(i),star1(i),tp(i),
     &              star2(1),i=1,7)
      IF(sigt1.eq.1.)WRITE(Nw,1020)kon
      IF(sigt2.eq.1.)WRITE(Nw,1030)
      WRITE(Nw,1040)dss,dssm,f,Fstar,rss,tmp,rssm,sumysq,xn
      IF(Fstar.ne.blank)WRITE(Nw,1050)
      DO k=1,3
       m=k+Lopt
       wt(k)=adj(m)
       m=4-k
       setdaf(m)=0.
       l=k+1
       DO i=1,k
        DO j=2,l
         setdaf(m)=setdaf(m)+matrx(i,j)
        END DO
       END DO
      END DO
      DO i=1,3
       setdaf(i)=sqrt(setdaf(i))*100.*se/wt(i)
      END DO
      WRITE(Nw,1060)setdaf
      IF(Kpart.gt.1)WRITE(Nw,1070)
 1070 FORMAT(//,22X,'IF THE TRADING DAY F-STATISTIC IS LESS THAN 7.0, ',
     &       'EXAMINE SPECTRAL PLOT FROM',/,23X,
     &       'AN X-11.2 RUN WITHOUT ',
     &       'TRADING DAY FOR SPIKES AT THE TRADING DAY FREQUENCIES')
      RETURN
      END
**==x11pt1.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE x11pt1
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION D,Dwt,Hfac,Sigm,Sigml,Sigmu,Smp,Sti,Stopa,Stopma,
     &                 Stor,Stpmf,Stptdf,Sttdrf
      INTEGER i,In,Issap,Kdec,Kdwopt,Kfulsm,Khol,Kmtyp,Kpart,Kpropt,
     &        Kspopt,Kswk,Kswt,Ktcopt,Layr,Lcyr,Lfda,Lfdc,Lfdr,Llda
      INTEGER Lopt,Lstmo,Lstyr,Lswv,Lyr,Mcd,Mdec,NL1,NL2,Nopt
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      CHARACTER*1 Part,Aorb,as
      CHARACTER*4 Pcdif,Fstar
      COMMON /cf    / Lyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Kdec,Layr,
     &                Lstmo,Lstyr,Kpropt
      COMMON /cf4   / Part,Aorb
      COMMON /cl    / Sti(NL1),Kmtyp(NL1),Sttdrf(NL2),D(7),Dwt(7),Fstar
      COMMON /cm    / Lfda,Llda,Kfulsm,Lopt,Kdwopt,Lfdc,Lfdr,Ktcopt,
     &                Kspopt,Mdec,Pcdif(4),Smp(24),Stptdf(NL2),Stor(NL1)
     &                ,Stopa(NL1),Stpmf(NL1),Stopma(NL1),Lcyr
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /fhol  / Hfac(NL2)
      COMMON /xk    / Kswt,Lswv
      DATA as/'A'/
      DO i=1,24
       Smp(i)=0
      END DO
      IF(Kswt.eq.1.and.Khol.ne.2)RETURN
C --- WRITE UNADJUSTED ORIGINAL SERIES -A1.
      CALL rite(1,Stor,Lfda,Llda,2,7,0.0)
      Kswk=0
      Aorb=as
C --- WRITE PRIOR MONTHLY FACTORS -A2.
      IF(Kswt.gt.2)CALL rite(2,Stpmf,Lfda,Llda,2,3,0.0)
      IF(Khol.eq.2)THEN
       DO i=Lfda,Llda
        Stpmf(i)=(Hfac(i)*Stpmf(i))/100.0
       END DO
      END IF
      IF(Khol.eq.2.and.Kswt.le.2)THEN
       CALL rite(6,0.0,0,0,0,0,0.0)
       Kswt=Kswt+2
      ELSE IF(Kswt.gt.2.and.Khol.eq.2)THEN
       CALL rite(5,Stpmf,Lfda,Llda,2,3,0.0)
      END IF
      IF(Kswt.gt.2)THEN
C ------ DIVIDE ORIGINAL BY P.M.F..RESULT IS PRIOR MONTHLY ADJUSTED
       CALL addmul(Stopma,Stor,Stpmf,Lfda,Llda)
       CALL sumry(Stpmf,Smp,Lfda,Llda,1)
C ------ SET PRIOR ADJUSTED EQUAL TO PRIOR MONTHLY ADJUSTED
       DO i=Lfda,Llda
        Stopa(i)=Stopma(i)
       END DO
C ------ TEST FOR PRIOR TRADING DAY ADJUSTMENT, THEN IF P.T.D.
C ------ WRITE PRIOR MONTHLY ADJUSTED SERIES BEFORE T.D. ADJUSTMENT -A3.
       IF(Kswt.eq.4)CALL rite(3,Stopma,Lfda,Llda,5,7,0.0)
      END IF
      IF(Kswt.eq.3)RETURN
C --- COMPUTE MONTHLY T.D.FACTORS FROM 7 PRIOR DAILY WEIGHTS
      CALL dow(Dwt,Stptdf,Lyr,Lfda,Llda,Lopt)
C --- SET TRADING DAY REGRESSION FACTORS EQUAL TO PRIOR T.D.FACTORS
      DO i=Lfda,Llda+12
       Sttdrf(i)=Stptdf(i)
      END DO
C --- WRITE PRIOR TRADING DAY FACTORS -A4.
      CALL rite(4,Stptdf,Lfda,Llda,5,4,Dwt)
C --- DIVIDE PRIOR MONTHLY ADJUSTED OR ORIGINAL BY PRIOR T.D. FACTORS.
      CALL addmul(Stopa,Stopma,Stptdf,Lfda,Llda)
      RETURN
      END
**==addmul.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE addmul(Result,Array1,Array2,Jfda,Jlda)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Array1,Array2,Result
      INTEGER i,Jfda,Jlda,Muladd,NL2
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      DIMENSION Result(NL2),Array1(NL2),Array2(NL2)
      COMMON /cj    / Muladd
      IF(Muladd.eq.0)THEN
       DO i=Jfda,Jlda
        Result(i)=Array1(i)/Array2(i)*100.
       END DO
       RETURN
      END IF
      DO i=Jfda,Jlda
       Result(i)=Array1(i)-Array2(i)
      END DO
      RETURN
      END
**==avdur.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR AVDUR,AVDUR,AVDUS
C --- THIS ROUTINE COMPUTES THE AVERAGE DURATION OF RUN OF THE SERIES I
C --- IN *ARRAY*.
      SUBROUTINE avdur(Array,Jfda,Jlda,Adr)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Adr,Array,runs
      INTEGER i,Jfda,Jlda,k,ksw,NL2
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      DIMENSION Array(NL2)
      runs=1.
      Adr=Jlda-Jfda
      k=Jlda-1
      ksw=0
      IF(Array(Jfda+1).lt.Array(Jfda))ksw=1
      DO i=Jfda,k
       IF(Array(i+1).lt.Array(i))THEN
        IF(ksw.eq.1)GO TO 10
        ksw=1
       ELSE IF(Array(i+1).eq.Array(i))THEN
        GO TO 10
       ELSE
        IF(ksw.eq.0)GO TO 10
        ksw=0
       END IF
       runs=runs+1.
   10 END DO
      Adr=Adr/runs
      RETURN
      END
**==dow.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR DOW,DOW,DOWS
C --- THIS ROUTINE COMBINES SEVEN DAILY WEIGHTS INTO MONTHLY FACTORS
      SUBROUTINE dow(Dwt,Array,Kyr,Kfda,Jlda,Jopt)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION adj,Array,Dwt,tkon,tmp,wt
      INTEGER i,j,jfda,jl,Jlda,Jopt,jyr,k,Kfda,Kyr,l,m,mdays,Muladd,n,
     &        NL2
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      DIMENSION Array(NL2),Dwt(7),mdays(12),wt(4),adj(12)
      COMMON /cj    / Muladd
      DATA mdays/3,0,3,2,3,2,3,3,2,3,2,3/
      DATA adj/28.25,30.,31.,28.25,30.4375,30.4375,30.4375,30.4375,29.,
     &     30.,31.,28./
      tkon=0.
      IF(Muladd.eq.0)THEN
       tkon=28.
       DO i=1,4
        m=i+Jopt
        wt(i)=adj(m)
       END DO
C --- STANDARDIZE WEIGHTS TO TOTAL 7.0
       tmp=0
       DO i=1,7
        tmp=tmp+Dwt(i)
       END DO
       DO i=1,7
        Dwt(i)=(Dwt(i)*7.)/tmp
       END DO
      END IF
      jfda=(Kfda-1)/12*12+1
      jyr=(Kyr-1900)+jfda/12
C --- SET PERPETUAL CALENDAR
      i=jyr+12-((jyr+11)/28)*28
      i=i+(i-1)/4
      i=i-((i-1)/7)*7
      m=1
      jl=Jlda+12
      l=jyr-1
      DO j=jfda,jl
       Array(j)=tkon
       n=mdays(m)
       IF(n.ne.0)THEN
C***** SPAG has made duplicate copies of the following statement 
        k=0
       ELSE
        l=l+1
        n=4
        IF(l.ne.(l/4)*4)GO TO 20
        n=1
C***** The following statement is a duplicate copy made by SPAG
        k=0
       END IF
   10  Array(j)=Array(j)+Dwt(i)
       i=i+1
       IF(i.gt.7)i=1
       k=k+1
       IF(k.lt.n)GO TO 10
   20  IF(Muladd.eq.0)Array(j)=Array(j)/wt(n)*100.
       m=m+1
       IF(m.gt.12)m=1
      END DO
      RETURN
      END
**==mvavg.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR MVAVG,MVAVG,MVAVGS
C --- THIS ROUTINE COMPUTES WEIGHTED MOVING AVERAGES FOR VSFC AND VTC.
C --- WEIGHTS ARE ORDERED SO THAT FIRST N WEIGHTS ARE APPLIED TO VALUES
C --- FOR FIRST AND LAST MOVING AVERAGE TERMS. LAST N VALUES ARE FOR
C --- MIDDLE TERMS. WITHIN EACH SET OF N VALUES FOR END TERMS, FIRST
C --- WEIGHT IS APPLIED TO FIRST AND LAST INPUT VALUE.
      SUBROUTINE mvavg(Stb,Sta,Lf,Ll,N,Wt)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,ii,j,jj,kk,Lf,Ll,m,mm,N,NL2,nn
      DOUBLE PRECISION Sta,Stb,Wt
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      DIMENSION Sta(NL2),Stb(NL2),Wt(276)
      m=N/2
      DO i=1,m
       ii=Lf+i-1
       jj=Ll-i+1
       Stb(ii)=0.
       Stb(jj)=0.
       kk=Lf
       mm=Ll
       nn=N*(i-1)
       DO j=1,N
        nn=nn+1
        Stb(ii)=Stb(ii)+Sta(kk)*Wt(nn)
        Stb(jj)=Stb(jj)+Sta(mm)*Wt(nn)
        kk=kk+1
        mm=mm-1
       END DO
      END DO
      IF(N-m.ne.m)THEN
       ii=ii+1
       jj=jj-1
       DO i=ii,jj
        kk=i-m-1
        Stb(i)=0.
        DO j=1,N
         kk=kk+1
         mm=nn+j
         Stb(i)=Stb(i)+Sta(kk)*Wt(mm)
        END DO
       END DO
      END IF
      RETURN
      END
**==sumry.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR SUMRY,SUMRY,SUMRYS
      SUBROUTINE sumry(Array,Sm,Lfda,Llda,N)
C     AVERAGE PERCENT CHANGE WITHOUT REGARD TO SIGN FOR 1-12 MONTHS
C     SPANS IN SM(1)-SM(12). AVGE PCT CHANGE WITH REGARD TO SIGN -
C     SM(25)-SM(36). AVGE PCT CHANGE W/O REGARD TO SIGN SQUARED -
C     SM(13)-SM(24). STND.DEVIATION OF PERCENT CHANGES - SM(37)-SM(48).
      COMMON /cj    / Muladd
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Array,p,Sm
      INTEGER i,j,k,Lfda,Llda,m,Muladd,N,NL2
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      DIMENSION Array(NL2),Sm(48)
      k=Llda
      DO i=1,12
       k=k-1
       p=k-Lfda+1
       Sm(i)=0.
       DO j=Lfda,k
        m=i+j
        IF(Muladd.ne.0)THEN
         Sm(i)=Sm(i)+abs(Array(m)-Array(j))
        ELSE
         Sm(i)=Sm(i)+abs((Array(m)-Array(j))*100./Array(j))
        END IF
       END DO
       Sm(i)=Sm(i)/p
       IF(N.lt.3)THEN
        Sm(i+12)=Sm(i)**2
        IF(N.ne.2)GO TO 10
       ELSE IF(N.ne.3)THEN
        GO TO 10
       END IF
       Sm(i+24)=0
       Sm(i+36)=0
       DO j=Lfda,k
        m=i+j
        IF(Muladd.ne.0)THEN
         Sm(i+24)=Sm(i+24)+Array(m)-Array(j)
        ELSE
         Sm(i+24)=Sm(i+24)+(Array(m)-Array(j))*100./Array(j)
        END IF
       END DO
       Sm(i+24)=Sm(i+24)/p
       DO j=Lfda,k
        m=i+j
        IF(Muladd.ne.0)THEN
         Sm(i+36)=Sm(i+36)+(Array(m)-Array(j)-Sm(i+24))**2
        ELSE
         Array(j)=Array(j)
         Sm(i+36)=Sm(i+36)+(Sm(i+24)-(Array(m)-Array(j))*100./Array(j))
     &            **2
        END IF
       END DO
       Sm(i+36)=sqrt(Sm(i+36)/p)
   10 END DO
      RETURN
      END
**==vsfc.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE vsfc(Lfda,Llda,Ksect)
C --- SEASONAL FACTOR CURVE ROUTINE.
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,In,j,k,Kdec,kfda,ki,Kpart,Kpropt,Ksect,Kswk,l,Layr,Lfda,
     &        Llda,Lstmo,Lstyr,Lterm,Lyr,m
      INTEGER Mcd,mfda,mlda,Muladd,NL1,NL2,nterm
      DOUBLE PRECISION p,Rati,Sigm,Sigml,Sigmu,stavg,Stmp,Sts,Stsi,stsp,
     &                 sum,tmp,w3a3,w3a5,w3a9,w3b3,w3b5,w3b9,w3c5,w3c9
      DOUBLE PRECISION w3d9,w3e9,w3x1,w3x3,w3x5,w3x9
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      COMMON /caa   / Stmp(NL2)
      COMMON /cc    / Rati(36),Lterm(12),Sts(NL2),Stsi(NL1)
      COMMON /cf    / Lyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Kdec,Layr,
     &                Lstmo,Lstyr,Kpropt
      COMMON /cj    / Muladd
      DIMENSION w3x9(66),w3a9(50),w3b9(45),w3c9(32),w3d9(28),w3e9(18),
     &          w3x5(28),w3a5(18),w3b5(15),w3c5(8),w3x3(15),w3a3(8),
     &          w3b3(6),w3x1(6),stsp(57),stavg(57)
C --- WEIGHTS FOR 3X9 MOVING AVGE. WEIGHTS IN W3A9-W3E9 ARE FOR SERIES
C --- SHORTER THAN 11 YEARS.
      DATA w3x9/.246,.221,.197,.173,.112,.051,.0,.0,.0,.0,.0,.208,.192,
     &     .176,.160,.144,.092,.028,.0,.0,.0,.0,.173,.163,.154,.143,
     &     .133,.123,.079,.032,.0,.0,.0,.141,.137,.132,.128,.123,.117,
     &     .113,.075,.034,.0,.0,.084,.120,.118,.117,.116,.114,.113,.111,
     &     .073,.034,.0,.037,.074,.111,.111,.111,.111,.111,.111,.111,
     &     .074,.037/
      DATA w3a9/.246,.221,.197,.173,.112,.051,.0,.0,.0,.0,.208,.192,
     &     .176,.160,.144,.092,.028,.0,.0,.0,.173,.163,.154,.143,.133,
     &     .123,.079,.032,.0,.0,.141,.137,.132,.128,.123,.117,.113,.075,
     &     .034,.0,.084,.120,.118,.117,.116,.114,.113,.111,.073,.034/
      DATA w3b9/.246,.221,.197,.173,.112,.051,.0,.0,.0,.208,.192,.176,
     &     .160,.144,.092,.028,.0,.0,.173,.163,.154,.143,.133,.123,.079,
     &     .032,.0,.141,.137,.132,.128,.123,.117,.113,.075,.034,.111,
     &     .111,.111,.111,.111,.111,.111,.111,.111/
      DATA w3c9/.246,.221,.197,.173,.112,.051,.0,.0,.208,.192,.176,.160,
     &     .144,.092,.028,.0,.173,.163,.154,.143,.133,.123,.079,.032,
     &     .125,.125,.125,.125,.125,.125,.125,.125/
      DATA w3d9/.246,.221,.197,.173,.112,.051,.0,.208,.192,.176,.160,
     &     .144,.092,.028,.143,.143,.143,.143,.143,.143,.143,.143,.143,
     &     .143,.143,.143,.143,.143/
      DATA w3e9/.246,.221,.197,.173,.112,.051,.167,.167,.167,.167,.167,
     &     .167,.167,.167,.167,.167,.167,.167/
C --- WEIGHTS FOR 3X5 MOVING AVERAGE.
      DATA w3x5/.283,.283,.283,.150,.0,.0,.0,.250,.250,.250,.183,.067,
     &     .0,.0,.150,.217,.217,.217,.133,.067,.0,.067,.133,.200,.200,
     &     .200,.133,.067/
      DATA w3a5/.283,.283,.283,.150,.0,.0,.250,.250,.250,.183,.067,.0,
     &     .150,.217,.217,.217,.133,.067/
      DATA w3b5/.283,.283,.283,.150,.0,.250,.250,.250,.183,.067,.200,
     &     .200,.200,.200,.200/
      DATA w3c5/.283,.283,.283,.150,.250,.250,.250,.250/
C --- WEIGHTS FOR 3X3 MOVING AVERAGE.
      DATA w3x3/.407,.407,.185,.0,.0,.259,.370,.259,.111,.0,.111,.222,
     &     .333,.222,.111/
      DATA w3a3/.407,.407,.185,.0,.259,.370,.259,.111/
      DATA w3b3/.407,.407,.185,.333,.333,.333/
C --- WEIGHTS FOR 3-TERM MOVING AVERAGE.
      DATA w3x1/.610,.390,.0,.333,.333,.333/
      mfda=Lfda
      mlda=Llda
      kfda=mfda+11
C --- FOR EACH MONTH SEPARATELY.
      DO j=mfda,kfda
       m=j-(j-1)/12*12
       k=3
C --- MOVE MONTH TO *STSP*.
       DO i=j,mlda,12
        k=k+1
        stsp(k)=Stsi(i)
       END DO
       IF(Kpart.eq.3)THEN
        IF(Ksect.eq.2)THEN
C --- COMPUTE IBAR,SBAR,AND RATIO IN FINAL ROUND ONLY.
C --- COMPUTE 7-TERM MOVING AVERAGE FOR ESTIMATE OF S.
         DO i=1,3
          stsp(i)=(stsp(4)+stsp(5)+stsp(6))/3.
          ki=k+i
          stsp(ki)=(stsp(k)+stsp(k-1)+stsp(k-2))/3.
         END DO
         DO i=4,k
          stavg(i)=(stsp(i-3)+stsp(i-2)+stsp(i-1)+stsp(i)+stsp(i+1)
     &             +stsp(i+2)+stsp(i+3))/7.
         END DO
C --- COMPUTE SBAR.
         Rati(m+12)=0.
         DO i=5,k
          IF(Muladd.ne.0)THEN
           Rati(m+12)=Rati(m+12)+abs(stavg(i-1)-stavg(i))
          ELSE
           Rati(m+12)=Rati(m+12)+abs(stavg(i-1)-stavg(i))/stavg(i)*100.
          END IF
         END DO
         p=k-4
         Rati(m+12)=Rati(m+12)/p
C --- DIVIDE SI/S FOR ESTIMATE OF I
         CALL addmul(stavg,stsp,stavg,4,k)
C --- COMPTUE IBAR
         Rati(m)=0.
         DO i=5,k
          IF(Muladd.ne.0)THEN
           Rati(m)=Rati(m)+abs(stavg(i-1)-stavg(i))
          ELSE
           Rati(m)=Rati(m)+abs(stavg(i-1)-stavg(i))/stavg(i)*100.
          END IF
         END DO
         Rati(m)=Rati(m)/p
C --- COMPUTE IBAR/SBAR RATIO. LARGEST RATIO PRINTED IS 999.99.
         Rati(m+24)=999.99
         IF(Rati(m).lt.Rati(m+12)*999.99)Rati(m+24)=Rati(m)/Rati(m+12)
        END IF
       END IF
       nterm=Lterm(m)
C --- CHECK IF MOVING AVERAGE FOR THIS MONTH PRESELECTED.
       IF(nterm.le.0)THEN
        IF(Ksect.eq.1)GO TO 40
        GO TO 30
       ELSE
        GO TO(50,40,30,20,10),nterm
       END IF
C --- STABLE SEASONAL. AVERAGE OF ALL SI RATIOS FOR THIS MONTH.
   10  tmp=0.
       DO i=4,k
        tmp=tmp+stsp(i)
       END DO
       sum=k-3
       tmp=tmp/sum
       DO i=4,k
        stavg(i)=tmp
       END DO
       GO TO 60
C --- COMPUTE 3X9 MOVING AVERAGE.
   20  IF(k.lt.13)THEN
        IF(k.lt.11)THEN
         IF(k.lt.9)GO TO 10
         IF(k.eq.9)THEN
          CALL mvavg(stavg,stsp,4,k,6,w3e9)
         ELSE
          CALL mvavg(stavg,stsp,4,k,7,w3d9)
         END IF
        ELSE IF(k.eq.11)THEN
         CALL mvavg(stavg,stsp,4,k,8,w3c9)
        ELSE
         CALL mvavg(stavg,stsp,4,k,9,w3b9)
        END IF
       ELSE IF(k.eq.13)THEN
        CALL mvavg(stavg,stsp,4,k,10,w3a9)
       ELSE
        CALL mvavg(stavg,stsp,4,k,11,w3x9)
       END IF
       GO TO 60
C --- COMPUTE 3X5 MOVING AVERAGE.
   30  IF(k.lt.9)THEN
        IF(k.lt.7)GO TO 10
        IF(k.eq.7)THEN
         CALL mvavg(stavg,stsp,4,k,4,w3c5)
        ELSE
         CALL mvavg(stavg,stsp,4,k,5,w3b5)
        END IF
       ELSE IF(k.eq.9)THEN
        CALL mvavg(stavg,stsp,4,k,6,w3a5)
       ELSE
        CALL mvavg(stavg,stsp,4,k,7,w3x5)
       END IF
       GO TO 60
C --- COMPUTE 3X3 MOVING AVERAGE.
   40  IF(k.lt.7)THEN
        IF(k.le.5)GO TO 10
        CALL mvavg(stavg,stsp,4,k,3,w3b3)
        GO TO 60
       ELSE IF(k.eq.7)THEN
        CALL mvavg(stavg,stsp,4,k,4,w3a3)
        GO TO 60
       ELSE
        CALL mvavg(stavg,stsp,4,k,5,w3x3)
        GO TO 60
       END IF
C --- COMPUTE 3-TERM MOVING AVERAGE
   50  CALL mvavg(stavg,stsp,4,k,3,w3x1)
   60  l=j
       DO i=4,k
        Stmp(l)=stavg(i)
        l=l+12
       END DO
      END DO
C --- COMPUTE CENTERED 12-TERM MOVING AVERAGE.
      j=mfda+6
      k=mlda-6
      DO i=j,k
       Sts(i)=(Stmp(i-6)+Stmp(i+6)+2.*(Stmp(i-5)+Stmp(i-4)+Stmp(i-3)+
     &        Stmp(i-2)+Stmp(i-1)+Stmp(i)+Stmp(i+1)+Stmp(i+2)+Stmp(i+3)
     &        +Stmp(i+4)+Stmp(i+5)))/24.
      END DO
C --- FILL IN MISSING END TERMS BY REPEATING FIRST AND LAST AVAILABLE
C --- MOVING AVERAGE VALUES 6 TIMES.
      k=mfda
      l=mlda
      DO i=1,6
       Sts(k)=Sts(mfda+6)
       Sts(l)=Sts(mlda-6)
       k=k+1
       l=l-1
      END DO
C --- DIVIDE SEASONALS BY 12-TERM MOVING AVERAGE.
      CALL addmul(Sts,Stmp,Sts,mfda,mlda)
      RETURN
      END
**==vtc.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR VTC,VTC,VTCS
C --- VARIABLE TREND-CYCLE ROUTINE.
      SUBROUTINE vtc(Lfda,Llda,Ktcopt)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION apcc,apci,Ratic,Stc,Stci,Sti,w13h,w23h,w23h1,
     &                 w23h2,w9h
      INTEGER i,k,Ktcopt,Lfda,Llda,mfda,mlda,Muladd,NL1,NL2,Nterm
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      COMMON /caa   / Sti(NL2)
      COMMON /cb    / Ratic,Stc(NL1),Stci(NL1),Nterm
      COMMON /cj    / Muladd
      DIMENSION w9h(45),w13h(91),w23h(276),w23h1(207),w23h2(69)
      EQUIVALENCE(w23h(1),w23h1(1)),(w23h(208),w23h2(1))
C --- 9-TERM HENDERSON WEIGHTS.
      DATA w9h/.581,.424,.185,-.034,-.156,.0,.0,.0,.0,.298,.354,.282,
     &     .126,-.011,-.049,.0,.0,.0,.086,.242,.315,.259,.120,.0,-.022,
     &     .0,.0,-.029,.102,.255,.324,.263,.120,-.004,-.031,.0,-.041,
     &     -.010,.119,.267,.330,.267,.119,-.010,-.041/
C --- 13-TERM HENDERSON WEIGHTS.
      DATA w13h/.421,.353,.244,.120,.012,-.058,-.092,.0,.0,.0,.0,.0,.0,
     &     .279,.292,.254,.174,.080,.002,-.038,-.043,.0,.0,.0,.0,.0,
     &     .148,.216,.241,.216,.149,.068,.003,-.025,-.016,.0,.0,.0,.0,
     &     .046,.131,.201,.230,.208,.145,.066,.004,-.022,-.009,.0,.0,.0,
     &     -.018,.050,.136,.205,.235,.210,.145,.067,.003,-.022,-.011,.0,
     &     .0,-.034,-.006,.061,.144,.212,.238,.213,.147,.066,.001,-.025,
     &     -.017,.0,-.019,-.028,.0,.066,.147,.214,.240,.214,.147,.066,
     &     .0,-.028,-.019/
C --- 23-TERM HENDERSON WEIGHTS.
      DATA(w23h1(i),i=1,103)/.288,.263,.227,.182,.133,.084,.039,.002,
     &     -.028,-.049,-.064,-.077,.0,.0,.0,.0,.0,.0,.0,.0,.0,.0,.0,
     &     .224,.219,.203,.176,.141,.101,.061,.025,-.004,-.024,-.035,
     &     -.041,-.046,.0,.0,.0,.0,.0,.0,.0,.0,.0,.0,.166,.176,.177,
     &     .166,.146,.116,.082,.049,.018,-.005,-.019,-.025,-.025,-.022,
     &     .0,.0,.0,.0,.0,.0,.0,.0,.0,.112,.134,.150,.154,.147,.129,
     &     .103,.073,.042,.015,-.004,-.015,-.018,-.014,-.008,.0,.0,.0,
     &     .0,.0,.0,.0,.0,.066,.095,.119,.136,.142,.137,.121,.098,.068,
     &     .040,.015/
      DATA(w23h1(i),i=104,207)/-.003,-.012,-.013,-.008,-.001,.0,.0,.0,
     &     .0,.0,.0,.0,.027,.059,.088,.114,.131,.139,.134,.119,.095,
     &     .067,.039,.015,-.002,-.011,-.011,-.006,.003,.0,.0,.0,.0,.0,
     &     .0,.001,.027,.059,.089,.114,.132,.138,.134,.118,.096,.068,
     &     .039,.015,-.003,-.011,-.012,-.006,.002,.0,.0,.0,.0,.0,-.015,
     &     .005,.031,.060,.090,.116,.133,.140,.135,.120,.096,.068,.039,
     &     .015,-.003,-.011,-.013,-.007,.001,.0,.0,.0,.0,-.021,-.010,
     &     .008,.034,.064,.094,.118,.136,.140,.137,.120,.097,.068,.039,
     &     .014,-.003,-.013,-.013,-.007,-.002,.0,.0,.0/
      DATA w23h2/-.019,-.017,-.007,.011,.037,.067,.095,.120,.137,.143,
     &     .138,.122,.097,.069,.040,.014,-.005,-.014,-.015,-.010,-.003,
     &     .0,.0,-.011,-.016,-.015,-.005,.013,.039,.068,.097,.122,.138,
     &     .144,.138,.122,.097,.068,.039,.013,-.005,-.015,-.016,-.011,
     &     -.004,.0,-.004,-.011,-.016,-.015,-.005,.013,.039,.068,.097,
     &     .122,.138,.148,.138,.122,.097,.068,.039,.013,-.005,-.015,
     &     -.016,-.011,-.004/
C --- CALCULATE 13-TERM HENDERSON. DROP END TERMS. CALC  IRREGULAR SER.
      mfda=Lfda+6
      mlda=Llda-6
      DO i=mfda,mlda
       Stc(i)=.240057*Stci(i)+.214337*(Stci(i+1)+Stci(i-1))
     &        +.147357*(Stci(i+2)+Stci(i-2))
     &        +.065492*(Stci(i+3)+Stci(i-3))
     &        -.027864*(Stci(i+5)+Stci(i-5))
     &        -.019350*(Stci(i+6)+Stci(i-6))
      END DO
      CALL addmul(Sti,Stci,Stc,mfda,mlda)
C --- CALCULATE IBAR/CBAR RATIO
      apcc=0.
      apci=0.
      k=mlda-1
      DO i=mfda,k
       IF(Muladd.ne.0)THEN
        apcc=apcc+abs(Stc(i+1)-Stc(i))
        apci=apci+abs(Sti(i+1)-Sti(i))
       ELSE
        apcc=apcc+abs(Stc(i+1)-Stc(i))/Stc(i)
        apci=apci+abs(Sti(i+1)-Sti(i))/Sti(i)
       END IF
      END DO
      Ratic=apci/apcc
C --- CHECK IF TREND-CYCLE MOVING AVERAGE PRESELECTED.
      IF(Ktcopt.lt.3)THEN
       IF(Ktcopt.lt.1)THEN
       ELSE IF(Ktcopt.eq.1)THEN
        GO TO 10
       ELSE
        GO TO 20
       END IF
      ELSE IF(Ktcopt.eq.3)THEN
       GO TO 30
      END IF
      IF(Ratic.ge..995)THEN
       IF(Nterm.eq.999)GO TO 20
       IF(Ratic.ge.3.495)GO TO 30
       GO TO 20
      END IF
   10 Nterm=9
      CALL mvavg(Stc,Stci,Lfda,Llda,9,w9h)
      RETURN
   20 Nterm=13
      CALL mvavg(Stc,Stci,Lfda,Llda,13,w13h)
      RETURN
   30 Nterm=23
      CALL mvavg(Stc,Stci,Lfda,Llda,23,w23h)
      RETURN
      END
**==xtrm.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
C --- LIP FOR XTRM,XTRM,XTRMS
C --- THIS ROUTINE COMPUTES WEIGHTS FOR IRREGULAR COMPONENT AND IDENTIF
C --- IES EXTREME IRREGULAR VALUES.
      SUBROUTINE xtrm(Array,Stdev,Stwt,Kfda,Klda,Tmpu,Tmpl,Kext)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Array,sdev,sigml,sigmu,sk,Stdev,Stwt,temp,Tmpl,
     &                 Tmpu,xn,zwt
      INTEGER i,itmp,j,k,Kext,Kfda,Klda,ksws,kwt,m,Muladd,nfda,NL1,nlda
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360)
      COMMON /cj    / Muladd
      DIMENSION Array(NL1),Stdev(NL1),Stwt(NL1)
      zwt=-99.
      kwt=0
      sk=100
      IF(Muladd.ne.0)sk=0
C --- SET ALL WEIGHTS EQUAL TO 100. TO START.
      DO i=Kfda,Klda
       Stwt(i)=100.0
      END DO
C --- IN FIRST ROUND, IDENTIFY EXTREMES OUTSIDE UPPER LIMIT FOR
C --- EXCLUSION FROM SECOND ROUND.
      sigmu=Tmpu
      sigml=Tmpu
C --- DETERMINE IF AT LEAST 5 YEARS AVAILABLE FOR MOVING STANDARD DEVTN
      nfda=(Kfda+10)/12*12+1
      nlda=Klda/12*12-59
      itmp=59
      IF(nlda.lt.nfda)THEN
C --- LESS THAN 5 YEARS AVAILABLE.
       itmp=itmp+nlda-nfda
       nlda=nfda
      END IF
      ksws=1
C --- COMPUTE MOVING 5-YEAR STD. DEV. EXCLUDING ZERO WT. IRREGULARS.
   10 DO i=nfda,nlda,12
       sdev=0
       k=i+itmp
       xn=0.
       DO m=i,k
        IF(ksws.ne.2.or.Stwt(m).ge.0)THEN
         sdev=sdev+(Array(m)-sk)**2
         xn=xn+1.
        END IF
       END DO
       sdev=sqrt(sdev/xn)
       IF(nlda.le.nfda)THEN
        j=Kfda
        k=Klda
C --- APPLY TO CENTRAL YEAR. AT ENDS OF SERIES APPLY TO ALL VALUES UP T
C --- TO CENTRAL YEAR.
       ELSE IF(i.ne.nfda)THEN
        IF(i.ne.nlda)THEN
         j=i+24
         k=i+35
        ELSE
         j=nlda+24
         k=Klda
        END IF
       ELSE
        j=Kfda
        k=nfda+35
       END IF
C --- COMPUTE DEVIATION OF EACH IRREGULAR VALUE.
       DO m=j,k
        Stdev(m)=sdev
        temp=(abs(Array(m)-sk))/sdev
        IF(temp.ge.sigmu)THEN
C --- ASSIGN ZERO WT. IF OUTSIDE UPPER LIMIT.
         IF(Stwt(m).ge.0)Stwt(m)=zwt
         IF(ksws.eq.1)kwt=m
         Kext=Kext+1
        ELSE IF(temp.gt.sigml)THEN
C --- GRADUATE IF BETWEEN LIMITS.
         Stwt(m)=(sigmu-temp)*100./(sigmu-sigml)
        END IF
       END DO
      END DO
      GO TO(20,30),ksws
C --- START SECOND ROUND.
   20 ksws=2
      Kext=0
      sigml=Tmpl
      zwt=0.
      GO TO 10
C --- STORE STD.DEVS. FOR PRINTING ON TABLE OF WEIGHTS.
   30 j=1
      DO i=Kfda,Klda,12
       Stdev(j)=Stdev(i)
       Stdev(j+1)=Stdev(i)
       j=j+1
      END DO
      IF(kwt.gt.0)THEN
       DO i=1,kwt
        IF(Stwt(i).lt.0)Stwt(i)=0.
       END DO
      END IF
      RETURN
      END
**==runhol.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE runhol
C--- THIS SUBROUTINE WILL READ THE HOLIDAYS REQUESTED FROM THE FIRST
C--- INPUT CARD, THEN READ THE DATA FROM CARDS, AND CALL THE APPROPRIATE
C--- SUBROUTINES
C
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION D,Dwt,Sigm,Sigml,Sigmu,Smp,Sti,Stopa,Stopma,Stor,
     &                 Stpmf,Stptdf,Sttdrf,X,Y,Yhat
      INTEGER i,iend,In,iss2,Issap,Kdec,Kdwopt,Kfulsm,Khol,Kmtyp,Kpart,
     &        Kpropt,Kspopt,Kswk,Ktcopt,Layr,Lcyr,Lfda,Lfdc,Lfdr
      INTEGER Llda,Lopt,Lstmo,Lstyr,Lyr,Mcd,Mdec,NL1,NL2,Nopt,Nw,nyear
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      CHARACTER*1 Part,Aorb,as
      CHARACTER*4 Pcdif,Fstar
      CHARACTER*80 Name
      COMMON /fhol  / Yhat(NL2)
      COMMON /xyser / Y(NL2),X(NL2)
      COMMON /ca    / Nw
      COMMON /cf    / Lyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Kdec,Layr,
     &                Lstmo,Lstyr,Kpropt
      COMMON /cf3   / Name
      COMMON /cf4   / Part,Aorb
      COMMON /cl    / Sti(NL1),Kmtyp(NL1),Sttdrf(NL2),D(7),Dwt(7),Fstar
      COMMON /cm    / Lfda,Llda,Kfulsm,Lopt,Kdwopt,Lfdc,Lfdr,Ktcopt,
     &                Kspopt,Mdec,Pcdif(4),Smp(24),Stptdf(NL2),Stor(NL1)
     &                ,Stopa(NL1),Stpmf(NL1),Stopma(NL1),Lcyr
      COMMON /czz   / Nopt,Khol,Issap
      DATA as/'A'/
      Nopt=1
      iss2=Issap
      Issap=0
      CALL x11pt1
      CALL subx11
      Nopt=0
      Issap=iss2
C--- INITIALIZE PRIOR FACTORS TO 100, INCLUDING ONE YEAR AHEAD FACTORS
      iend=Llda+12
      DO i=Lfda,iend
       IF(i.le.Llda)Y(i)=Sti(i)
       Yhat(i)=100.
      END DO
C--- CALCULATE NUMBER OF YEARS USED IN HOLIDAY ADJUSTMENT
      nyear=iend/12
      IF(mod(iend,12).ne.0)nyear=nyear+1
C--- READ IN THE DATA FOR HOLIDAY ADJUSTMENT. NOTE- THIS AMOUNTS TO THE
C--- D13 FINAL IRREGULAR FROM A PRIOR EXECUTION OF X11.
      CALL holidy(nyear,Lfda,Lyr,Llda)
      IF(Issap.ne.1)CALL hrite(Nw,Lfda,Name,Lyr,Lstmo,Lstyr,Llda)
      Khol=2
      Kpart=4
      Part=as
      RETURN
      END
**==holidy.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE holidy(Nyear,Lfda,Lyr,Llda)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Fstatl,Fstatt,X,Y,Yres
      INTEGER i,j,k,Keastr,Klbrdy,Kthgvg,l,l2,lf,lf1,lf12,Lfda,Llda,Lyr,
     &        m,mar,Ndfl,Ndft,NL2,nov
      INTEGER Nyear,Ieast
      LOGICAL Lgenx
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      COMMON /opthol/ Keastr,Klbrdy,Kthgvg
      COMMON /freg  / Fstatl,Fstatt,Ndfl,Ndft
      COMMON /outhol/ Yres(NL2)
      COMMON /xyser / Y(NL2),X(NL2)
      COMMON /feast / Ieast(4),Lgenx
      INTEGER aug,apr,sep,dec
      INTEGER 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,7,6,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/
c-----------------------------------------------------------------------
c     Generate X indicator vector
c-----------------------------------------------------------------------
      IF(Lgenx)THEN
       m=1
       l=Lyr-1900
       l2=l+Nyear-1
       DO i=l,l2
        DO j=1,3
         DO k=1,4
          X(m+4*j-4+k)=dble(kdate(i,j))
         END DO
        END DO
        m=m+12
       END DO
      ENDIF
      DO i=Lfda,Llda
       Yres(i)=10.0**10
      END DO
C --- LOCATE FIRST MARCH,AUGUST AND NOVEMBER IN X AND Y. SUBTRACT 100
C     FROM FIRST MONTH. SUBTRACT SECOND MONTH FROM 100.
      lf1=mod(Lfda,12)
      IF(lf1.eq.0)lf1=12
      lf12=Lfda/12
      IF(lf1.eq.12)lf12=lf12-1
      lf=lf12*12
      mar=lf+3
      aug=lf+8
      nov=lf+11
      apr=0
      sep=0
      dec=0
      IF(lf1.gt.3)THEN
       mar=mar+12
       IF(Lfda.eq.4)apr=lf+3
       IF(lf1.gt.8)THEN
        aug=aug+12
        IF(Lfda.eq.9)sep=lf+8
        IF(Lfda.eq.12)THEN
         nov=nov+12
         dec=lf+11
        END IF
       END IF
      END IF
      IF(Kthgvg.gt.0)CALL regrss(nov,dec,Llda,Fstatt,Ndft,Kthgvg)
      IF(Klbrdy.gt.0)CALL regrss(aug,sep,Llda,Fstatl,Ndfl,Klbrdy)
      IF(Keastr.gt.0)THEN
       CALL easter(mar,apr,Llda,Keastr)
      ELSE
       Ieast(1)=-99
       Ieast(2)=-99
       Ieast(3)=-99
       Ieast(4)=-99
      ENDIF
      RETURN
      END
**==regrss.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE regrss(Khol,Kh2,Llda,Fratio,Ndf,Ktl)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION a,b,Fratio,fsig,fvalue,s2,se,smean,sumn,sumsqe,
     &                 sumsqt,sumx,sumxsq,sumxy,sumy,X,Y,Yhat,Yres
      INTEGER i,ii,ixtm,Kh2,Khol,ksw,Ktl,ll,Llda,mm,Ndf,NL1,NL2
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      DIMENSION ixtm(NL1)
      COMMON /xyser / Y(NL2),X(NL2)
      COMMON /fhol  / Yhat(NL2)
      COMMON /outhol/ Yres(NL2)
      ll=Llda
      mm=ll+12
      ksw=0
C --- INVERT 2ND MONTH
      DO i=Khol,ll,12
       ixtm(i)=0
       ixtm(i+1)=0
       IF(i.lt.ll)Y(i+1)=200.-Y(i+1)
      END DO
      DO WHILE (.true.)
C --- COMPUTE A,B. EXCLUDE XTRMS FROM COMPUTATION
       sumx=0.
       sumy=0.
       sumxy=0.
       sumxsq=0.
       sumn=0.
       DO i=Khol,ll,12
C --- TEST FOR XTRM MONTH 1.
        IF(ixtm(i).ne.99)THEN
         sumx=sumx+X(i)
         sumy=sumy+Y(i)
         sumxsq=sumxsq+X(i)**2
         sumxy=sumxy+X(i)*Y(i)
         sumn=sumn+1
        END IF
C --- TEST FOR XTRM 2ND MONTH
        IF(i.lt.ll)THEN
         IF(ixtm(i+1).ne.99)THEN
          sumx=sumx+X(i+1)
          sumxsq=sumxsq+X(i+1)**2
          sumy=sumy+Y(i+1)
          sumxy=sumxy+X(i+1)*Y(i+1)
          sumn=sumn+1.
         END IF
        END IF
       END DO
       a=(sumx*sumxy-sumxsq*sumy)/(sumx**2-sumn*sumxsq)
       b=(sumx*sumy-sumn*sumxy)/(sumx**2-sumn*sumxsq)
C --- COMPUTE ESTIMATED YS. STORE IN YHAT
       DO i=Khol,mm,12
        Yhat(i)=a+b*X(i)
        Yhat(i+1)=200.-Yhat(i)
       END DO
       IF(ksw.ne.0)GO TO 10
       ksw=1
C --- COMPUTE STANDARD ERROR ABOUT YHAT.
       se=0.
       DO i=Khol,ll,12
        se=se+(Y(i)-Yhat(i))**2
        IF(i.lt.ll)se=se+(200.-Y(i+1)-Yhat(i+1))**2
       END DO
       s2=sumn-2
       se=2.5*sqrt(se/s2)
C --- IDENTIFY EXTREMES
       DO i=Khol,ll,12
        IF(abs(Y(i)-Yhat(i)).ge.se)ixtm(i)=99
        IF(i.lt.ll)THEN
         IF(abs(200.-Y(i+1)-Yhat(i+1)).ge.se)ixtm(i+1)=99
        END IF
C --- RECOMPUTE A, B EXCLUDING EXTREMES
       END DO
      END DO
C --- STORE RESIDUALS FOR PRINTING
   10 DO i=Khol,mm,12
       Yres(i)=Y(i)-Yhat(i)
       IF(i.lt.ll)Yres(i+1)=200.-Y(i+1)-Yhat(i+1)
      END DO
C --- COMPUTE F-RATIO
      sumsqt=0.
      sumsqe=0.
      smean=sumy/sumn
      DO i=Khol,ll,12
       IF(ixtm(i).ne.99)THEN
        sumsqt=sumsqt+dble((Y(i)-smean))**2
        sumsqe=sumsqe+dble(Yres(i))**2
       END IF
       IF(ixtm(i+1).ne.99.and.i.lt.ll)THEN
        sumsqt=sumsqt+dble((Y(i+1)-smean))**2
        sumsqe=sumsqe+dble(Yres(i+1))**2
       END IF
      END DO
      s2=sumn-2
      Ndf=int(s2)
      Fratio=(sumsqt-sumsqe)/(sumsqe/s2)
      IF(Ktl.eq.2)THEN
       fsig=fvalue(Fratio,1,Ndf)*100.0
       IF(fsig.gt.5.)THEN
        DO ii=Khol,mm,12
         Yhat(ii)=100.0
         Yhat(ii+1)=100.0
        END DO
        Ktl=-1
       END IF
      END IF
      IF(Kh2.ne.0.and.Ktl.lt.0)Yhat(Kh2+1)=200.-(a+b*X(Kh2))
      RETURN
      END
**==easter.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE easter(Khol,Kh2,Llda,Ihol)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION dif,dif1,dif2,sd28,sd915,sda,sdm,sum,sum1,sum2,
     &                 suma,suma1,suma1e,suma2,suma2e,sumae,sumd1,sumd2,
     &                 sumd3,summ,smfac,mfac,mfreq
      DOUBLE PRECISION summe,var28,var915,vara,varm,X,Y,Yhat,yl1,yl2
      INTEGER i,Ieast,Ihol,Kh2,Khol,ll,Llda,mm,NL2,nsuaa,nsuaa1,nsuaa2,
     &        nsum,nsum1,nsum2,nsuma,nsuma1,nsuma2
      LOGICAL Lgenx
C*** End of declarations inserted by SPAG
      DIMENSION mfac(34),mfreq(34)
      PARAMETER(NL2=372)
      COMMON /xyser / Y(NL2),X(NL2)
      COMMON /fhol  / Yhat(NL2)
      COMMON /feast / Ieast(4),Lgenx
c-----------------------------------------------------------------------
      DATA mfreq /0.0075,0.0150,0.0153,0.0221,0.0229,0.0295,0.0382,
     &  0.0300,0.0300,0.0382,0.0295,0.0382,0.0368,0.0305,0.0375,0.0300,
     &  0.0305,0.0368,0.0305,0.0295,0.0382,0.0300,0.0375,0.0382,0.0295,
     &  0.0382,0.0368,0.0382,0.0375,0.0300,0.0229,0.0221,0.0153,0.0074 /
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
       ENDIF
      ENDIF
      mm=ll+12
C---- INVERT APRIL
      DO i=Khol,ll-1,12
       Y(i+1)=200.-Y(i+1)
      END DO
C---- CALCULATE AVERAGES OF IRREGULARS BEFORE APRIL 2
      summ=0
      sum=0
      DO i=Khol,ll,12
       IF(X(i).le.10)THEN
        summ=summ+Y(i)
        sum=sum+1
        IF(i.lt.ll)THEN
         summ=summ+Y(i+1)
         sum=sum+1
        END IF
       END IF
      END DO
      IF(sum.gt.1)THEN
       summ=summ/sum
C---- CALCULATE STANDARD DEVIATION OF OBS BEFORE APRIL 2
       summe=0
       nsum=0
       varm=0
       DO i=Khol,ll,12
        IF(X(i).le.10.)THEN
         varm=(Y(i)-summ)**2+varm
         IF(i.lt.ll)varm=(Y(i+1)-summ)**2+varm
        END IF
       END DO
       sdm=sqrt(varm)/sqrt(sum)*2
C---- GET RID OF EXTREMES
       DO i=Khol,ll,12
        IF(X(i).le.10.)THEN
         yl1=Y(i)
         dif=abs(Y(i)-summ)
         nsum1=1
         IF(dif.ge.sdm)THEN
          nsum1=0
          yl1=0
         END IF
         yl2=0
         nsum2=0
         IF(i.lt.ll)THEN
          dif=abs(Y(i+1)-summ)
          IF(dif.lt.sdm)THEN
           yl2=Y(i+1)
           nsum2=1
          END IF
         END IF
         summe=yl1+yl2+summe
         nsum=nsum1+nsum2+nsum
        END IF
       END DO
       summ=summe/nsum
      END IF
C---- CALCULATE AVERAGE AFTER APRIL 16TH
      suma=0
      sum=0
      DO i=Khol,ll,12
       IF(X(i).gt.24.)THEN
        suma=suma+Y(i)
        sum=sum+1.
        IF(i.lt.ll)THEN
         suma=suma+Y(i+1)
         sum=sum+1
        END IF
       END IF
      END DO
      IF(sum.gt.1)THEN
       suma=suma/sum
C---- CALCULATE STANDARD DEVIATION OF OBS AFTER APRIL 16
       sumae=0
       nsum=0
       vara=0
       DO i=Khol,ll,12
        IF(X(i).gt.24.)THEN
         vara=(Y(i)-suma)**2+vara
         IF(i.lt.ll)vara=(Y(i+1)-suma)**2+vara
        END IF
       END DO
       sda=sqrt(vara)/sqrt(sum)*2
C---- GET RID OF EXTREMES
       DO i=Khol,ll,12
        IF(X(i).gt.24.)THEN
         yl1=Y(i)
         dif=abs(Y(i)-suma)
         nsum1=1
         IF(dif.ge.sda)THEN
          nsum1=0
          yl1=0
         END IF
         yl2=0
         nsum2=0
         IF(i.lt.ll)THEN
          dif=abs(Y(i+1)-suma)
          IF(dif.lt.sda)THEN
           yl2=Y(i+1)
           nsum2=1
          END IF
         END IF
         sumae=yl1+yl2+sumae
         nsum=nsum1+nsum2+nsum
        END IF
       END DO
       suma=sumae/nsum
      END IF
      sum1=0
      sum2=0
      suma1=0
      suma2=0
      DO i=Khol,ll,12
       IF((X(i).gt.10.).and.(X(i).lt.25))THEN
C---- DO PERIOD APRIL 2 TO 8, 9 TO 15
        IF(X(i).le.17.)THEN
         suma1=suma1+Y(i)
         sum1=sum1+1.
         IF(i.lt.ll)THEN
          suma1=suma1+Y(i+1)
          sum1=sum1+1.
         END IF
        ELSE
         suma2=suma2+Y(i)
         sum2=sum2+1.
         IF(i.lt.ll)THEN
          suma2=suma2+Y(i+1)
          sum2=sum2+1.
         END IF
        END IF
       END IF
      END DO
      IF(sum1.gt.0)THEN
       suma1=suma1/sum1
      END IF
      IF(sum2.gt.0)suma2=suma2/sum2
      DO i=Khol,mm,12
       IF(X(i).lt.11.)THEN
        Yhat(i)=summ
        Yhat(i+1)=200.-Yhat(i)
       ELSE IF(X(i).gt.24.)THEN
        Yhat(i)=suma
        Yhat(i+1)=200.-Yhat(i)
       ELSE IF(X(i).le.14.)THEN
        sumd1=14.-X(i)
        Yhat(i)=suma1+sumd1*(summ-suma1)/4.
       ELSE IF(X(i).le.21.)THEN
        sumd2=21.-X(i)
        Yhat(i)=suma2+sumd2*(suma1-suma2)/7.
       ELSE
        sumd3=25.-X(i)
        Yhat(i)=suma+sumd3*(suma2-suma)/4.
       END IF
      END DO
C---- CALCULATE STANDARD ERRS FOR PERIODS APRIL 2-8,9-15
      var28=0
      var915=0
      DO i=Khol,ll,12
       IF((X(i).gt.10.).and.(X(i).lt.25))THEN
        IF(X(i).gt.17.)THEN
         var915=(Y(i)-Yhat(i))**2+var915
         IF(i.lt.ll)var915=(Y(i+1)-Yhat(i))**2+var915
        ELSE
         var28=(Y(i)-Yhat(i))**2+var28
         IF(i.lt.ll)var28=(Y(i+1)-Yhat(i))**2+var28
        END IF
       END IF
      END DO
      sd28=sqrt(var28)/sqrt(sum1)*2
      sd915=sqrt(var915)/sqrt(sum2)*2
      nsuma=0
      suma1e=0
      nsuaa=0
      suma2e=0
C---- THROW OUT EXTREMES BEYOND 2 STANDARD ERRORS FOR PERIODS APR 2-8
C---- AND APRIL 9-15
      DO i=Khol,ll,12
       yl1=Y(i)
       IF(i.lt.ll)yl2=Y(i+1)
       IF((X(i).gt.10.).and.(X(i).lt.25))THEN
        IF(X(i).gt.17)THEN
C---- GET RID OF EXTREMES APRIL 9-15
         dif2=abs(Y(i)-Yhat(i))
         IF(dif2.lt.sd915)THEN
          nsuaa1=1
         ELSE
          yl1=0
          nsuaa1=0
         END IF
         IF(i.ge.ll)GO TO 20
         dif2=abs(Y(i+1)-Yhat(i))
         IF(dif2.ge.sd915)GO TO 20
         nsuaa2=1
         GO TO 30
        ELSE
C---- APRIL 2-8
         dif1=abs(Y(i)-Yhat(i))
         IF(dif1.lt.sd28)THEN
          nsuma1=1
         ELSE
          yl1=0
          nsuma1=0
         END IF
         IF(i.lt.ll)THEN
          dif1=abs(Y(i+1)-Yhat(i))
          IF(dif1.lt.sd28)THEN
           nsuma2=1
           GO TO 10
          END IF
         END IF
         yl2=0
         nsuma2=0
        END IF
   10   suma1e=yl1+yl2+suma1e
        nsuma=nsuma1+nsuma2+nsuma
       END IF
       GO TO 40
   20  yl2=0
       nsuaa2=0
   30  suma2e=yl1+yl2+suma2e
       nsuaa=nsuaa1+nsuaa2+nsuaa
   40 END DO
      IF(nsuma.ne.0)suma1=suma1e/nsuma
      IF(nsuaa.ne.0)suma2=suma2e/nsuaa
C---- RECALCULATE FIT FOR PERIODS APR 2-8,9-15 WITH EXTREMES REMOVED
      DO i=Khol,mm,12
       IF((X(i).gt.10.).and.(X(i).lt.25))THEN
        IF(X(i).le.14.)THEN
         sumd1=14.-X(i)
         Yhat(i)=suma1+sumd1*(summ-suma1)/4.
         Yhat(i+1)=200-Yhat(i)
        ELSE IF(X(i).le.21.)THEN
         sumd2=21.-X(i)
         Yhat(i)=suma2+sumd2*(suma1-suma2)/7.
         Yhat(i+1)=200.-Yhat(i)
        ELSE
         sumd3=25.-X(i)
         Yhat(i)=suma+sumd3*(suma2-suma)/4.
         Yhat(i+1)=200.-Yhat(i)
        END IF
       END IF
      END DO
c-----------------------------------------------------------------------
c     Compute seasonal component within easter effect for March.
c-----------------------------------------------------------------------
      smfac=0d0
      DO i=1,34
       IF(i.le.10)THEN
        mfac(i)=summ
       ELSE IF(i.gt.10.and.i.le.14)THEN
        sumd1=14.-i
        mfac(i)=(suma1+sumd1*(summ-suma1)/4.)
       ELSE IF(i.gt.14.and.i.le.21.)THEN
        sumd2=21.-i
        mfac(i)=(suma2+sumd2*(suma1-suma2)/7.)
       ELSE IF(i.gt.21.and.i.le.24.)THEN
        sumd3=25.-i
        mfac(i)=(suma+sumd3*(suma2-suma)/4.)
       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=Khol,mm,12
       Yhat(i)=(Yhat(i)*100d0)/smfac
       Yhat(i+1)=(Yhat(i+1)*100d0)/(200d0-smfac)
      END DO
c-----------------------------------------------------------------------
      IF(Kh2.eq.0)RETURN
      IF(X(Kh2).le.10)THEN
       Yhat(Kh2+1)=200.-summ
      ELSE IF(X(Kh2).gt.10.and.X(Kh2).le.14)THEN
       sumd1=14.-X(Kh2)
       Yhat(Kh2+1)=200.-(suma1+sumd1*(summ-suma1)/4.)
      ELSE IF(X(Kh2).gt.14.and.X(Kh2).le.21.)THEN
       sumd2=21.-X(Kh2)
       Yhat(Kh2+1)=200.-(suma2+sumd2*(suma1-suma2)/7.)
      ELSE IF(X(Kh2).gt.21.and.X(Kh2).le.24.)THEN
       sumd3=25.-X(Kh2)
       Yhat(Kh2+1)=200.-(suma+sumd3*(suma2-suma)/4.)
      ELSE
       Yhat(Kh2+1)=200.-suma
      END IF
      Yhat(Kh2+1)=(Yhat(Kh2+1)*100d0)/(200d0-smfac)
      RETURN
      END
**==hrite.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      SUBROUTINE hrite(Nw,Lfda,Name,Lyr,Lstmo,Lstyr,Llda)
C--- THIS SUBROUTINE WILL WRITE OUT THE HOLIDAY PRIOR ADJUSTMENT FACTORS
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION avgmon,Fstatl,Fstatt,summon,ydum,Yhat
      INTEGER i,icntmo,Ieast,Ifor,ii,Io12,Iovr,Issap,Itbl,Itchar,Itfmt,
     &        j,janyr,k,k0,k1,k11,k12,k2,Keastr
      INTEGER Khol,Klbrdy,Kpage,Kthgvg,length,Lfda,lk,Llda,llx,llxx,
     &        lnxyr,Lstmo,Lstyr,Lyr,Ndfl,Ndft,NL2,Nopt,Np,Numtbl
      INTEGER Nw,nxyr,nyr
      LOGICAL Lgenx
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      CHARACTER*6 Lser
      CHARACTER*80 Name
      DIMENSION ydum(25)
      DIMENSION avgmon(12),summon(12)
      DIMENSION icntmo(12)
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /opthol/ Keastr,Klbrdy,Kthgvg
      COMMON /freg  / Fstatl,Fstatt,Ndfl,Ndft
      COMMON /cz    / Kpage,Np,Lser
      COMMON /fhol  / Yhat(NL2)
      COMMON /feast / Ieast(4),Lgenx
      COMMON /itcom / Itchar,Itfmt,Itbl(10),Ifor,Numtbl,Iovr,Io12
      CHARACTER*36 fh2,fh2a
      DO i=1,25
       ydum(i)=10.0**10
      END DO
      fh2='HOLIDAY PRIOR ADJUSTMENT FACTORS    '
      fh2a='HOLIDAY FACTORS ONE YEAR AHEAD      '
      WRITE(Nw,1010)Name,Kpage,Lser
 1010 FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
      Kpage=Kpage+1
      WRITE(Nw,1020)fh2
 1020 FORMAT(1X,'H 1. ',A36)
      IF(Khol.eq.1)THEN
       WRITE(Nw,1030)
 1030  FORMAT(' ',3X,'YEAR       JAN      FEB      MAR      APR    ',
     &        '  MAY      JUN      JUL      AUG      SEP      OCT    ',
     &        '  NOV      DEC')
 1040  FORMAT(' ',3X,I4,2X,12(1X,F8.3))
       janyr=1
       length=Lstyr-Lyr+1
       k0=0
       DO k=1,length
        nyr=Lyr+k-1
        k12=k*12
        IF(k12.ge.Lfda)THEN
         k11=k12-11
         IF(k11.gt.Llda)GO TO 10
         llx=janyr+Lstmo-1
         IF(k1.ne.Lfda.and.k0.eq.0)THEN
          lk=mod(Lfda-1,12)
          WRITE(Nw,1040)nyr,(ydum(k1),k1=1,lk),(Yhat(k2),k2=Lfda,k12)
         ELSE IF(k11.le.Llda.and.k12.gt.Llda)THEN
          WRITE(Nw,1040)nyr,(Yhat(k1),k1=janyr,llx),
     &                  (ydum(k2),k2=Lstmo+1,12)
         ELSE
          WRITE(Nw,1040)nyr,(Yhat(k1),k1=janyr,janyr+11)
         END IF
         k0=1
        END IF
        janyr=janyr+12
   10  END DO
C
C--- COMPUTE & PRINT AVERAGE MONTHLY FACTORS, NO ASSUMPTIONS
C--- INITIALIZE
       DO k=1,12
        avgmon(k)=100.
        icntmo(k)=0
        summon(k)=0.
       END DO
       ii=Lfda-1
       DO i=Lfda,Llda
        ii=ii+1
        IF(ii.gt.12)ii=ii-12
        icntmo(ii)=icntmo(ii)+1
        summon(ii)=summon(ii)+Yhat(i)
       END DO
       DO k=1,12
        avgmon(k)=summon(k)/icntmo(k)
       END DO
       WRITE(Nw,1050)(avgmon(i),i=1,12)
 1050  FORMAT(' ',3X,'AVGE',2X,12(1X,F8.3))
C
C--- WRITE HOLIDAY FACTORS, ONE YEAR AHEAD
       llxx=llx/12
       IF(mod(llx,12).eq.0)llxx=llxx-1
       nxyr=Lyr+llxx+1
       lnxyr=nxyr-1
       WRITE(Nw,1060)fh2a
 1060  FORMAT(1X,'H 1A. ',A36)
       WRITE(Nw,1030)
       IF(Lstmo.eq.12)THEN
        WRITE(Nw,1040)nxyr,(Yhat(i),i=llx+1,llx+12)
       ELSE IF(Lstmo.ne.12)THEN
        WRITE(Nw,1040)lnxyr,(ydum(i),i=1,Lstmo),
     &                (Yhat(j),j=llx+1,llx+12-Lstmo)
        WRITE(Nw,1040)nxyr,(Yhat(i),i=llx+12-Lstmo+1,llx+12),
     &                (ydum(j),j=Lstmo+1,12)
       END IF
      END IF
      IF((Ieast(1)*Ieast(2)*Ieast(3)*Ieast(4)).eq.0)WRITE(Nw,2050)
      IF(Ieast(1).eq.0)WRITE(Nw,3050)
      IF(Ieast(2).eq.0)WRITE(Nw,3060)
      IF(Ieast(3).eq.0)WRITE(Nw,3070)
      IF(Ieast(4).eq.0)WRITE(Nw,3080)
      IF((Ieast(1)*Ieast(2)*Ieast(3)*Ieast(4)).eq.0)WRITE(Nw,2080)
 2050 FORMAT(' ')
 3050 FORMAT(10X,'NO YEARS WITH EASTER BEFORE APRIL 1ST.')
 3060 FORMAT(10X,'NO YEARS WITH EASTER AFTER APRIL 16TH.')
 3070 FORMAT(10X,'NO YEARS WITH EASTER BETWEEN APRIL 2ND AND APRIL ',
     &       '8TH.')
 3080 FORMAT(10X,'NO YEARS WITH EASTER BETWEEN APRIL 8TH AND APRIL ',
     &       '15TH.')
 2080 FORMAT(10X,'EASTER ADJUSTMENT CANNOT BE PERFORMED.')
      IF(Klbrdy.ne.0)THEN
       WRITE(Nw,1110)Fstatl,Ndfl
 1110  FORMAT(/,10X,'F-TEST FOR LABOR DAY REGRESSION =    ',F10.3,
     &        ' (1,',I3,' D.F)')
       IF(Klbrdy.lt.0)WRITE(Nw,1130)
      END IF
      IF(Kthgvg.ne.0)THEN
       WRITE(Nw,1120)Fstatt,Ndft
 1120  FORMAT(/,10X,'F-TEST FOR THANKSGIVING REGRESSION = ',F10.3,
     &        ' (1,',I3,' D.F)')
       IF(Kthgvg.lt.0)WRITE(Nw,1140)
      END IF
 1130 FORMAT(10X,'F-TEST FOR LABOR DAY REGRESSION NOT SIGNIFICANT AT ',
     &       'THE 5 PERCENT LEVEL, FACTORS NOT APPLIED')
 1140 FORMAT(10X,'F-TEST FOR THANKSGIVING REGRESSION NOT SIGNIFICANT ',
     &       'AT THE 5 PERCENT LEVEL, FACTORS NOT APPLIED')
      IF(Numtbl.gt.0)CALL trite(Yhat,Lfda,Llda,Lyr,Lser,8,1)
      RETURN
      END
**==fvalue.f    processed by SPAG 4.03F  at 09:56 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION fvalue(X,M,N)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      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,X
      IF(X.gt.0.0)THEN
       IF(X.le.90.0)THEN
        IF(X.le.40.0.or.N.le.150)THEN
         l=(M/2)*2-M+2
         k=(N/2)*2-N+2
         w=X*dble(float(M))/dble(float(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(float(N))/dble(float(k))
           p=p*zk+w*z*(zk-1.0D0)/(z-1.0D0)
          ELSE
           DO j=j1,N,2
            d=(1.0D0+dble(float(l))/dble(float(j-2)))*d*z
            p=p+d*y/dble(float(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(float(i+k))
           d=y*d*zk/dble(float(i-2))
           p=p-z*d/zk
          END DO
         END IF
         IF(p.lt.1.0D0)THEN
          IF(p.le.0.0D0)GO TO 10
          GO TO 20
         END IF
        END IF
       END IF
       fvalue=0.0
       RETURN
      END IF
   10 fvalue=1.0
      X=0.0
      RETURN
   20 fvalue=sngl(1.0D0-p)
      RETURN
      END
**==tabset.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE tabset(Nf4,Ifmt,Irun,Reset,Prompt,*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,i0,i1,ic,ic2,idx,Ifmt,Ifor,io,Io12,Iovr,irs,Irun,Irunt,
     &        it,itb,Itbl,itc1,Itchar,Itfmt
      INTEGER Ixerr,j,k2,Kpage,Kswerr,Kswt,ktbl,Lswv,Nerr,Np,Nr,Numtbl
C*** End of declarations inserted by SPAG
      INTEGER tbldec
      LOGICAL fxst
      CHARACTER*1 forcst,cpart,stop,treset,overit,Reset,Prompt
      CHARACTER*3 Tbl
      CHARACTER*40 tblfmt,drive,Tf4,Nf4
      CHARACTER*80 Tblfil,tbf,f1
      CHARACTER*6 Ser
      COMMON /xk    / Kswt,Lswv
      COMMON /cz    / Kpage,Np,Ser
      COMMON /tcom  / Tf4,Tblfil,Tbl(10)
      COMMON /itcom / Itchar,Itfmt,Itbl(10),Ifor,Numtbl,Iovr,Io12
      COMMON /xerr  / Nr,Nerr,Kswerr,Irunt,Ixerr
      NAMELIST /nltbl / Numtbl,Tbl,tblfmt,drive,tbldec,forcst,treset,
     & overit,stop
      irs=0
      k2=Kswt
      IF(Irun.eq.0)treset=' '
      IF(Irun.eq.0.or.treset.eq.'Y'.or.treset.eq.'y')THEN
       treset=' '
       stop='N'
       tblfmt=' '
       tbldec=0
       forcst='N'
       drive=' '
       overit='Y'
       DO i=1,10
        Tbl(i)='   '
       END DO
      END IF
   10 Irun=1
      IF(Nr.eq.10)THEN
       READ(Nr,nltbl,ERR=80,END=90)
       IF(stop.ne.'N'.and.stop.ne.'n')RETURN 1
      ELSE
       IF(Kswt.eq.0)Kswt=k2
       PRINT *,' '
       PRINT *,'  CURRENT SETTINGS FOR NLTBL NAMELIST ARE : '
       PRINT nltbl
   20  PRINT *,' '
       PRINT *,'  ENTER VARIABLES AND THEIR SETTINGS FOR NLTBL',
     &       ' NAMELIST : '
       READ(*,nltbl,ERR=100)
       IF(stop.ne.'N'.and.stop.ne.'n')RETURN 1
       PRINT nltbl
       IF(Prompt.eq.'Y'.or.Prompt.eq.'y')CALL prop(3,*20)
      END IF
      IF(irs.ne.2)THEN
       irs=9
       IF(treset.eq.' ')treset=Reset
       IF(treset.eq.'Y'.or.treset.eq.'y')irs=0
       IF(treset.eq.'N'.or.treset.eq.'n')irs=1
       IF(irs.eq.9)THEN
        CALL inerr(treset,irs,*40)
        IF(Nr.eq.10)WRITE(Nerr,1010)'TRESET'
 1010   FORMAT(10X,'THE ENTRY FOR ',A6,' IS NOT DEFINED')
        IF(Nr.eq.5)PRINT 1010,'TRESET '
       END IF
      END IF
      IF(tbldec.lt.0.or.tbldec.gt.5)THEN
       CALL inerr(treset,irs,*40)
       IF(Nr.eq.10)WRITE(Nerr,1020)'TBLDEC',tbldec,0,5
 1020  FORMAT(10X,'THE ENTRY FOR ',A6,' IS ',I6,', WHICH IS NOT ',
     &        'DEFINED',/,10X,'THE ENTRY SHOULD BE BETWEEN ',I6,' AND ',
     &        I6)
       IF(Nr.eq.5)PRINT 1020,'TBLDEC',tbldec,0,5
      END IF
      Ifor=9
      IF(forcst.eq.'N'.or.forcst.eq.'n')Ifor=0
      IF(forcst.eq.'Y'.or.forcst.eq.'y')Ifor=1
      IF(Ifor.eq.9)THEN
       CALL inerr(treset,irs,*40)
       IF(Nr.eq.10)WRITE(Nerr,1010)'FORCST'
       IF(Nr.eq.5)PRINT 1010,'FORCST'
      END IF
      Iovr=9
      IF(overit.eq.'N'.or.overit.eq.'n')Iovr=0
      IF(overit.eq.'Y'.or.overit.eq.'y')Iovr=1
      IF(overit.eq.'A'.or.overit.eq.'a')Iovr=2
      IF(overit.eq.'O'.or.overit.eq.'o')Iovr=3
      IF(Iovr.eq.9)THEN
       CALL inerr(treset,irs,*40)
       IF(Nr.eq.10)WRITE(Nerr,1010)'OVERIT'
       IF(Nr.eq.5)PRINT 1010,'OVERIT'
      END IF
      DO j=1,Numtbl
       IF(Tbl(j).eq.' ')CALL terr(Tbl(j),treset,irs,3,Itbl(j),*30,*40)
       READ(Tbl(j),1030)cpart,ktbl
 1030  FORMAT(A1,I2)
       IF(ktbl.gt.20.or.ktbl.le.0)CALL terr(Tbl(j),treset,irs,1,Itbl(j),
     &    *30,*40)
       ic=ichar(cpart)-ichar('a')+1
       IF(ic.lt.0)ic=ichar(cpart)-ichar('A')+1
       IF(ic.le.0.and.ic.gt.8.or.ic.eq.7)
     &    CALL terr(Tbl(j),treset,irs,1,Itbl(j),*30,*40)
       IF(ic.le.4)ic=ic-1
       IF(ic.eq.0)ic=4
       Itbl(j)=ic*100+ktbl
       IF((Itbl(j).ge.315.and.Itbl(j).le.319).or.
     &    (Itbl(j).ge.405.and.Itbl(j).le.420).or.
     &    (Itbl(j).ge.507.and.Itbl(j).le.520).or.
     &    (Itbl(j).ge.603.and.Itbl(j).le.620).or.(Itbl(j).gt.801).or.
     &    (Itbl(j).eq.112.or.Itbl(j).eq.203.or.Itbl(j).eq.208.or.Itbl(j)
     &    .eq.212.or.Itbl(j).eq.303))
     &    CALL terr(Tbl(j),treset,irs,1,Itbl(j),*30,*40)
       IF(Itbl(j).eq.114.or.Itbl(j).eq.115.or.Itbl(j).eq.214.or.Itbl(j)
     &    .eq.215.or.Itbl(j).eq.309.or.Itbl(j).eq.504.or.Itbl(j).eq.602)
     &    CALL terr(Tbl(j),treset,irs,2,Itbl(j),*30,*40)
   30 END DO
   40 IF(Kswt.eq.0)THEN
       IF(Nr.eq.10)THEN
        PRINT *,'  ERROR(S) FOUND IN NLTBL NAMELIST ENTRIES'
        PRINT *,'  NO TABLES WILL BE STORED.  X-11.2 RUN CONTINUES'
        Numtbl=0
        RETURN
       END IF
       GO TO 10
      END IF
      IF(tblfmt.eq.'2')THEN
       Itfmt=0
       WRITE(Tf4,1040)tbldec,tbldec
 1040  FORMAT('(6F12.',I1,',/,6F12.',I1,',I2.2,A6)')
      ELSE IF(tblfmt.eq.'1')THEN
       Itfmt=0
       WRITE(Tf4,1050)tbldec
 1050  FORMAT('(12F6.',I1,',I2.2,A6)       ')
      ELSE IF(tblfmt.eq.' ')THEN
       Itfmt=Ifmt
       Tf4=Nf4
      ELSE
       Itfmt=1
       Tf4=tblfmt
      END IF
      itb=1
      Itchar=0
      IF(drive.ne.' ')THEN
       IF(drive(1:1).eq.' ')THEN
        DO WHILE (.true.)
         itb=itb+1
         IF(drive(itb:itb).ne.' ')GO TO 50
        END DO
       END IF
   50  DO WHILE (.true.)
        Itchar=Itchar+1
        it=Itchar+itb-1
        IF(drive(it:it).eq.' ')THEN
         Tblfil(1:(Itchar-1))=drive(itb:(it-1))
         GO TO 60
        END IF
       END DO
      END IF
   60 IF(Itchar.eq.0)Itchar=1
      IF(Iovr.eq.3)THEN
       Tblfil(Itchar:Itchar+5)='X11SS.'
       Itchar=Itchar+6
       RETURN
      END IF
      Tblfil(Itchar:(Itchar+5))=Ser
      idx=index(Ser,' ')
      IF(idx.eq.0)idx=7
      Itchar=Itchar+idx-1
      Tblfil(Itchar:Itchar)='.'
      Itchar=Itchar+1
      IF(Iovr.eq.0)THEN
       tbf=Tblfil
       i1=1
       DO i=1,Numtbl
        tbf(Itchar:Itchar+2)=Tbl(i)
        itc1=Itchar+1
        IF(tbf(itc1:itc1).eq.' ')tbf(itc1:itc1)='_'
        io=0
        i0=0
   70   INQUIRE(FILE=tbf,EXIST=fxst,ERR=110)
        i0=i0+1
        IF(fxst)CALL novrit(i,io,tbf,*70,*40)
        IF(.not.fxst.and.io.gt.0.and.i0.gt.i1)THEN
         i1=i0
         Tblfil=tbf
        END IF
        tbf(Itchar-1:Itchar+4)='.     '
       END DO
       IF(i1.gt.1)THEN
        Itchar=Itchar+2
        Iovr=-1
       END IF
      END IF
      RETURN
   80 CALL inerr(treset,irs,*40)
      WRITE(Nerr,1060)
 1060 FORMAT(10X,'ERROR IN READING NLTBL')
      Numtbl=0
      RETURN
   90 CALL inerr(treset,irs,*40)
      WRITE(Nerr,1070)
 1070 FORMAT(10X,'END OF FILE ENCOUNTERED IN READING NLTBL')
      RETURN 1
  100 PRINT *,' ERROR IN READING NLTBL.'
      PRINT *,' RE-ENTER VALUES FOR NLTBL :'
      GO TO 10
  110 ic2=Itchar+2
      WRITE(f1,1080)(Itchar+2)
 1080 FORMAT('(10X,17HUNABLE TO ACCESS ,A',I2,',18H FOR TABLE STORAGE)')
      IF(ic2.lt.10)f1(27:28)=' A'
      WRITE(Nerr,f1)tbf(1:Itchar+2)
      IF(Nr.eq.10)THEN
       CALL inerr(treset,irs,*40)
       WRITE(Nerr,1090)
 1090  FORMAT(10X,'X-11.2 RUN WILL CONTINUE WITHOUT TABLE STORAGE')
       IF(Ixerr.eq.0)Ixerr=1
       Numtbl=0
       RETURN
      ELSE IF(Nr.eq.5)THEN
       PRINT f1,tbf(1:Itchar+2)
       GO TO 10
      END IF
      END
**==terr.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE terr(T,Treset,Irs,Ix,Ij,*,*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER Ij,Irs,Irun,Ix,Ixerr,Kswerr,Nerr,Nr
C*** End of declarations inserted by SPAG
      CHARACTER*1 Treset
      CHARACTER*3 T
      COMMON /xerr  / Nr,Nerr,Kswerr,Irun,Ixerr
      IF(Ix.eq.1)THEN
       CALL inerr(Treset,Irs,*10)
       IF(Nr.eq.10)WRITE(Nerr,1010)T
 1010  FORMAT(10X,'TABLE ',A3,' DOES NOT EXIST')
       IF(Nr.eq.5)PRINT 1010,T
       Ij=0
      ELSE IF(Ix.eq.0)THEN
       IF(Nr.eq.10)WRITE(Nerr,1020)T
 1020  FORMAT(10X,'TABLE ',A3,' NOT AVAILABLE ON THIS LEVEL OF ',
     &        'PRINTOUT')
       IF(Nr.eq.5)PRINT 1020,T
      ELSE IF(Ix.eq.2)THEN
       CALL inerr(Treset,Irs,*10)
       IF(Nr.eq.10)WRITE(Nerr,1030)T
 1030  FORMAT(10X,'TABLE ',A3,' NOT AVAILABLE FOR PRINTING')
       IF(Nr.eq.5)PRINT 1030,T
       Ij=0
      ELSE
       CALL inerr(Treset,Irs,*10)
       IF(Nr.eq.10)WRITE(Nerr,1040)
 1040  FORMAT(10X,'TABLE NUMBER NOT ENTERED.  CHECK TBL, NUMTBL ',
     &        'VARIABLES IN NLTBL NAMELIST.')
       IF(Nr.eq.5)PRINT 1040
       Ij=0
      END IF
      RETURN 1
   10 RETURN 2
      END
**==trite.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE trite(X,L1,L2,Lyr,Ser,Kpart,Ktbl)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,ic2,Ifor,Io12,Iovr,iret,Irun,Itbl,itc1,Itchar,Itfmt,
     &        Ixerr,iyr,j,j1,j2,k,Kpart,Kswerr,Ktbl
      INTEGER l,L1,l12,L2,l3,Lyr,Nerr,NL2,Nr,Numtbl
      DOUBLE PRECISION X
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      LOGICAL fxst
      CHARACTER*3 Tbl
      CHARACTER*6 Ser
      CHARACTER*40 Tf4
      CHARACTER*80 Tblfil,f1
      DIMENSION X(NL2)
      COMMON /xerr  / Nr,Nerr,Kswerr,Irun,Ixerr
      COMMON /itcom / Itchar,Itfmt,Itbl(10),Ifor,Numtbl,Iovr,Io12
      COMMON /tcom  / Tf4,Tblfil,Tbl(10)
      k=Kpart*100+Ktbl
      iret=0
      DO j=1,Numtbl
       IF(k.eq.Itbl(j))THEN
        Itbl(j)=999
        iret=j
       END IF
      END DO
      IF(iret.eq.0)RETURN
      itc1=Itchar+1
      Tblfil(Itchar:Itchar+2)='TBL'
      IF(Iovr.lt.3)THEN
       Tblfil(Itchar:Itchar+2)=Tbl(iret)
       IF(Tblfil(itc1:itc1).eq.' ')Tblfil(itc1:itc1)='_'
      END IF
      fxst=.false.
      IF(Iovr.eq.2.or.Iovr.eq.3)THEN
       INQUIRE(FILE=Tblfil,EXIST=fxst,ERR=10)
       IF(fxst)THEN
        IF(Iovr.eq.2.or.(Iovr.eq.3.and.Io12.eq.1))
     &     OPEN(12,FILE=Tblfil,ACCESS='APPEND',STATUS='OLD',ERR=10)
        IF(Iovr.eq.3.and.Io12.eq.0)fxst=.false.
       END IF
      END IF
      IF(.not.fxst)OPEN(12,FILE=Tblfil,ERR=10)
      IF(Iovr.eq.3.and.Io12.eq.0)Io12=1
      IF(fxst)Itbl(iret)=1999
      IF(L1.ne.1)THEN
       DO j=1,L1-1
        X(j)=0.
       END DO
      END IF
      l3=L2
      IF(Ifor.eq.1.and.(k.eq.216.or.k.eq.218.or.k.eq.310.or.k.eq.320.or.
     &   k.eq.404.or.k.eq.801))l3=l3+12
      l=l3/12
      IF(mod(l3,12).ne.0)l=l+1
      l12=l*12
      IF(l3.ne.l12)THEN
       DO j=l3+1,l12
        X(j)=0.
       END DO
      END IF
      IF(Itfmt.eq.0)THEN
       DO i=1,l
        j1=(i-1)*12+1
        j2=i*12
        iyr=Lyr+i-1
        IF(iyr.ge.2000)THEN
         iyr=iyr-2000
        ELSE
         iyr=iyr-1900
        END IF
        WRITE(12,Tf4)(X(j),j=j1,j2),iyr,Ser
       END DO
      ELSE
       WRITE(12,Tf4)(X(j),j=1,l12)
      END IF
      CLOSE(12)
      RETURN
   10 Itbl(iret)=0
      ic2=Itchar+2
      WRITE(f1,1010)ic2
 1010 FORMAT('(10X,15HUNABLE TO OPEN ,A',I2,',21H, CANNOT STORE TABLE ',
     &       ',A3)')
      IF(ic2.lt.10)f1(25:26)=' A'
      IF(Nr.eq.10)THEN
       WRITE(Nerr,f1)Tblfil(1:ic2),Tbl(iret)
       IF(Ixerr.eq.0)Ixerr=1
      END IF
      IF(Nr.eq.5)PRINT f1,Tblfil(1:ic2),Tbl(iret)
      RETURN
      END
**==novrit.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE novrit(J,Iasc,Tbf,*,*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,Iasc,ic,Ifor,Io12,Iovr,Irun,Itbl,Itchar,Itfmt,Ixerr,J,
     &        Kswerr,Nerr,Nr,Numtbl
C*** End of declarations inserted by SPAG
      CHARACTER*3 Tbl
      CHARACTER*40 Tf4
      CHARACTER*80 Tblfil,Tbf
      COMMON /xerr  / Nr,Nerr,Kswerr,Irun,Ixerr
      COMMON /itcom / Itchar,Itfmt,Itbl(10),Ifor,Numtbl,Iovr,Io12
      COMMON /tcom  / Tf4,Tblfil,Tbl(10)
      IF(Iasc.eq.0)THEN
       Iasc=47
       DO i=2,-1,-1
        ic=Itchar+i
        Tbf(ic+2:ic+2)=Tbf(ic:ic)
       END DO
       Tbf(ic:ic)='$'
      END IF
      Iasc=Iasc+1
      IF(Iasc.eq.58)Iasc=65
      IF(Iasc.eq.91)Iasc=35
      IF(Iasc.eq.39.and.Nr.eq.10)THEN
       IF(Ixerr.eq.0)Ixerr=1
       WRITE(Nerr,1010)Tbl(J)
 1010  FORMAT(10X,'OVERWRITE OPTION ACTIVATED; CANNOT ASSIGN NEW ',
     &        'FILENAME.',/,10X,'TABLE ',A3,' WILL NOT BE STORED')
      ELSE IF(Iasc.eq.39.and.Nr.eq.5)THEN
       PRINT 1010,Tbl(J)
      END IF
      IF(Iasc.eq.39)RETURN 2
      Tbf(Itchar:Itchar)=char(Iasc)
      RETURN 1
      END
**==prop.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE prop(I,*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER I
C*** End of declarations inserted by SPAG
      CHARACTER*1 yn
      CHARACTER*5 nl(3)
      DATA nl/'NLX11','NLXOP','NLTBL'/
      DO WHILE (.true.)
       PRINT *,' '
       PRINT *,' DO YOU WISH TO CHANGE ANY OF THE CURRENT SETTINGS IN ',
     &       nl(I),'? (Y=YES,N=NO)'
       PRINT *,' > '
       READ *,yn
       IF(yn.eq.'Y'.or.yn.eq.'y')RETURN 1
       IF(yn.eq.'N'.or.yn.eq.'n')RETURN
       PRINT *,'IMPROPER INPUT . . . TRY AGAIN'
      END DO
      END
**==aa0002.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      BLOCK DATA 
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Cut,Fact1,Ten
      INTEGER Ibottm,Ifact2,ii,Imid,j,Kount
C*** End of declarations inserted by SPAG
      CHARACTER*1 Ia(110,55),Ialpha(12),I1,I2,I3,I4,I5,I6,I7,I8,I9,
     &            Ip(10),Ch,Newpag,Spc
      CHARACTER*3 Cout
      CHARACTER*4 Finap,Finab
      CHARACTER*9 Cpmon
      CHARACTER*14 Chper
      CHARACTER*24 Cname
      CHARACTER*50 F1
      CHARACTER*35 F2
      COMMON /cf2   / Finab(2),Finap(2),Cout,Newpag,Spc
      COMMON /ko    / Ten
      COMMON /com5  / Kount(4),Cut(5,4)
      COMMON /mform / F1,F2
      COMMON /chame / Cname(5),Ch(5),Chper(2),Cpmon(12)
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /chrtq / I1,I2,I3,I4,I5,I6,I7,I8,I9
      COMMON /chrts / Ibottm,Imid(14),Fact1,Ifact2
      DATA Spc/' '/
      DATA Newpag/'1'/
      DATA Ialpha/'J','F','M','A','M','J','J','A','S','O','N','D'/
      DATA I1,I2,I4,I5,I6,I7/'*','-','I','\','/','.'/
      DATA Ibottm,Fact1,Ifact2/55,52.,54/
      DATA Imid/2,6,10,14,18,22,26,30,34,38,42,46,50,54/
      DATA F1/'(1X,I2,A1,I4,2X, (F10.3,5X),3X,2A1,3X,F10.3,5X,A4)'/
      DATA F2/'(10X, (1X,I2,A1,I4,1X,A1,5X),8X,A7)'/
      DATA(Cut(1,ii),ii=1,4)/3.,4.,5.,6./
      DATA(Cut(2,ii),ii=1,4)/2.,3.,4.,5./
      DATA(Cut(3,ii),ii=1,4)/3.,4.,5.,6./
      DATA(Cut(4,ii),ii=1,4)/3.,5.,7.,10./
      DATA(Cut(5,ii),ii=1,4)/3.,4.,5.,6./
      DATA(Chper(j),j=1,2)/'MONTH-TO-MONTH',' YEAR-TO-YEAR '/
      DATA(Cname(j),j=1,5)/'SEASONAL FACTORS        ',
     &     'TRADING DAY FACTORS     ','SEASONALLY ADJUSTED DATA',
     &     'CHANGES IN S. A. DATA   ','CHANGES IN S. A. DATA   '/
      DATA(Cpmon(j),j=1,12)/'JANUARY  ','FEBRUARY ','MARCH    ',
     &     'APRIL    ','MAY      ','JUNE     ','JULY     ','AUGUST   ',
     &     'SEPTEMBER','OCTOBER  ','NOVEMBER ','DECEMBER '/
      DATA(Ch(j),j=1,5)/'%','+','#','$','@'/
      DATA Ten/1.0D10/
      END
**==chrt.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE chrt(Title,Icode,Noser,Ibeg2,Ienda)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER ialphc,Ibeg2,icod2,Icode,Ienda,Ifrst,jx,jxo,jyo,l,Last,
     &        Llyr,Logsw,Lstyr,Mach,Muladd,N1,NL2,Noser,Npts
      INTEGER Nyr
      REAL Xdata3,Y1,Y2,Ydiff,Ymax,Ymin
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      CHARACTER*1 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,Ia(110,55),Ip(10),
     &            Ialpha(12),I12
      CHARACTER*80 Title
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /chrtq / I1,I2,I3,I4,I5,I6,I7,I8,I9
      COMMON /chrtq3/ I10,I11,I12
      COMMON /grzar1/ Y1(NL2),Y2(NL2),Xdata3(31),Ymin,Ymax,Ydiff
      COMMON /grzar2/ Nyr,Npts,N1,Ifrst,Last,Llyr,Lstyr
      COMMON /lg1   / Logsw
      COMMON /cj    / Muladd
      COMMON /chrtm / Mach
      IF(Mach.eq.0)THEN
       I3=char(205)
       I4=char(186)
       I8=char(187)
       I9=char(188)
       I10=char(202)
       I11=char(203)
       I12=char(223)
      ELSE
       I3='+'
       I4='I'
       I8='I'
       I9='I'
       I10=I4
       I11=I10
       I12='@'
      END IF
      DO l=1,10
       Ip(l)=I3
      END DO
      IF(Icode.eq.0)RETURN
      Logsw=0
      IF(Ymax.le.Ymin)RETURN
      icod2=0
      IF(Icode.eq.15)THEN
       icod2=Icode
       Icode=5
      ELSE IF(Icode.eq.29)THEN
       IF(Muladd.eq.0)THEN
        icod2=Icode
       ELSE
        icod2=19
       END IF
       Icode=9
      END IF
      IF(Icode.eq.20)Icode=0
      CALL setup(Icode,icod2,jxo,jyo,ialphc)
      jx=2
      IF(Icode.eq.9)CALL ave(Y1,N1,'I',Icode,icod2,jx)
      IF(Icode.eq.7)CALL month(Icode,Ibeg2,Ienda,jx)
      IF(Icode.le.6)CALL yrly(Icode,icod2,jx,Noser)
      CALL out(Title,Icode)
      RETURN
      END
**==setup.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C**************
      SUBROUTINE setup(Icode,Icod2,Jxo,Jyo,Ialphc)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Fact1,Xdata3,Xy,Y1,Y2,Ydiff,Ydifl,Ymax,Ymaxl,Ymid,Ymin,Yminl
      INTEGER i,Ialphc,Ibottm,Icmax,Icod2,Icode,Ifact2,Ifrst,Imid,Ixy,
     &        Iyr,j,j2,Jxo,Jyo,k,k2,Last,Llyr,Logsw
      INTEGER Lstyr,N1,NL2,Npts,Nseas,Nyr
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      CHARACTER*1 Ia(110,55),Ialpha(12),I1,I2,I3,I4,I5,I6,I7,I8,I9
      CHARACTER*1 Ip(10),I10,I11,I12
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /chrtp2/ Iyr(31)
      COMMON /chrtr / Yminl,Ymaxl,Ydifl,Ymid(14)
      COMMON /chrtq / I1,I2,I3,I4,I5,I6,I7,I8,I9
      COMMON /chrtq3/ I10,I11,I12
      COMMON /chrtq2/ Icmax
      COMMON /chrts / Ibottm,Imid(14),Fact1,Ifact2
      COMMON /grzar1/ Y1(NL2),Y2(NL2),Xdata3(31),Ymin,Ymax,Ydiff
      COMMON /grzar2/ Nyr,Npts,N1,Ifrst,Last,Llyr,Lstyr
      COMMON /arim1 / Nseas,Xy,Ixy
      COMMON /lg1   / Logsw
C  SET UP CHART BOUNDARIES
C***************
      DO i=1,110
       DO j=1,55
        Ia(i,j)=' '
       END DO
      END DO
      DO i=1,21
       Iyr(i)=int(Xdata3(i))
      END DO
      Icmax=N1+1
      IF(Icode.eq.19)Icmax=Icmax+1
      IF(Icode.eq.11)Icmax=1+(Nseas+1)*4
      Jxo=1
      Jyo=1
      Ialphc=Ifrst-1
      Ydiff=Ymax-Ymin
      IF(Logsw.eq.1)THEN
       Ymaxl=alog10(Ymax)
       Yminl=alog10(Ymin)
       Ydifl=Ymaxl-Yminl
      END IF
      DO j=1,53,4
       j2=((53-j)/4)+1
       IF(Logsw.eq.0)THEN
        Ymid(j2)=(Ydiff*(j-1))/52+Ymin
       ELSE
        Ymid(j2)=10**((Ydifl*(j-1))/52+Yminl)
       END IF
      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)*(Icode-9)*(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(j2.eq.42.or.j2.eq.52)Ia(j,i)='T'
         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((Icod2-15)*(Icode-7)*(Icode-9)*(Icode).ne.0)THEN
        DO k2=3,12,3
         Ia(i,Imid(k2))=I7
        END DO
       END IF
      END DO
      RETURN
      END
**==yrly.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C*****************
      SUBROUTINE yrly(Icode,Icod2,Jx,Noser)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Fact1,Xdata3,Xy,Y1,Y2,Ydiff,Ymax,Ymin
      INTEGER i,Ibottm,Icod2,Icode,Ifact2,Ifrst,Imid,Ixy,j,Jx,jy1,jy2,l,
     &        Last,Llyr,Lstyr,N1,NL2,Noser,Npts
      INTEGER Nseas,Nyr
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      CHARACTER*1 Ia(110,55),Ialpha(12),I1,I2,I3,I4,I5,I6,I7,I8,I9
      CHARACTER*1 Ip(10),I10,I11,I12
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /chrtq / I1,I2,I3,I4,I5,I6,I7,I8,I9
      COMMON /chrtq3/ I10,I11,I12
      COMMON /chrts / Ibottm,Imid(14),Fact1,Ifact2
      COMMON /grzar1/ Y1(NL2),Y2(NL2),Xdata3(31),Ymin,Ymax,Ydiff
      COMMON /grzar2/ Nyr,Npts,N1,Ifrst,Last,Llyr,Lstyr
      COMMON /arim1 / Nseas,Xy,Ixy
C  PLOT CHART TYPES 1-6
C******************
      CHARACTER*1 itype
      DO i=1,N1
       Xy=Y1(i)
       CALL value(*10)
       itype=I1
       l=mod(Ifrst+i-2,Nseas)+1
       IF((Icode-5)*(Icode-6).eq.0)itype=Ialpha(l)
       Ia(Jx,Ixy)=itype
       IF(Icode.eq.6)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
       IF(Noser.eq.2)THEN
        jy1=Ixy
        Xy=Y2(i)
        CALL value(*10)
        jy2=Ixy
        Ia(Jx,jy2)=I12
        IF(Icod2.eq.15)CALL dot(jy1,jy2,Jx)
       END IF
   10  Jx=Jx+1
      END DO
      IF(Icod2.ge.15)Icode=Icod2
      RETURN
      END
**==month.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C***************
      SUBROUTINE month(Icode,Ibeg2,Ienda,Jx)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Aa,Bb,Xy
      INTEGER Ibeg2,Icode,Ienda,Ifrst,Ixy,Jx,l,Last,Llyr,Lstyr,N1,Npts,
     &        Nseas,Nyr,nyr2
C*** End of declarations inserted by SPAG
      CHARACTER*1 Ia(110,55),Ialpha(12)
      CHARACTER*1 Ip(10)
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /grzar2/ Nyr,Npts,N1,Ifrst,Last,Llyr,Lstyr
      COMMON /grzg2 / Aa(31),Bb(31)
      COMMON /arim1 / Nseas,Xy,Ixy
C  PLOT CHART TYPES 7 AND 8 (MONTHLY CHARTS)
C***************
      CHARACTER*1 itype
      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)
       CALL ave(Aa,nyr2,itype,Icode,0,Jx)
      END DO
      RETURN
      END
**==out.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C***************
      SUBROUTINE out(Title,Icode)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Fact1,Xdata3,Y1,Y2,Ydiff,Ydifl,Ymax,Ymaxl,Ymid,Ymin,Yminl
      INTEGER i,Ibottm,Icmax,Icode,Ifact2,Ifrst,iline,Imid,Iyr,j,j2,
     &        Kpage,Last,Llyr,Logsw,Lstyr,n,N1,NL2,Np
      INTEGER Npts,Nw,Nyr
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      CHARACTER*1 Ia(110,55),Ialpha(12)
      CHARACTER*1 Ip(10)
      CHARACTER*6 Lser
      CHARACTER*80 Title,Name
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /chrtp2/ Iyr(31)
      COMMON /chrtr / Yminl,Ymaxl,Ydifl,Ymid(14)
      COMMON /chrtq2/ Icmax
      COMMON /chrts / Ibottm,Imid(14),Fact1,Ifact2
      COMMON /grzar1/ Y1(NL2),Y2(NL2),Xdata3(31),Ymin,Ymax,Ydiff
      COMMON /grzar2/ Nyr,Npts,N1,Ifrst,Last,Llyr,Lstyr
      COMMON /ca    / Nw
      COMMON /lg1   / Logsw
      COMMON /cf3   / Name
      COMMON /cz    / Kpage,Np,Lser
C  WRITE OUT THE CHART
C***************
      WRITE(Nw,1010)Name,Kpage,Lser
      Kpage=Kpage+1
      WRITE(Nw,1020)Title
      iline=Icmax+1
      j2=1
      DO j=1,55
       IF(j.eq.1.or.j.eq.55)THEN
        WRITE(Nw,1030)(Ip(i),i=1,10),(Ia(i,j),i=1,iline)
       ELSE IF(j.eq.Imid(j2))THEN
        IF(Logsw.eq.0.and.Ymax.ge.1.0E08)THEN
         WRITE(Nw,1050)Ymid(j2),(Ia(i,j),i=1,iline)
        ELSE
         WRITE(Nw,1040)Ymid(j2),(Ia(i,j),i=1,iline)
        END IF
        j2=j2+1
        IF(j2.gt.14)j2=1
       ELSE
        WRITE(Nw,1080)(Ia(i,j),i=1,iline)
       END IF
      END DO
      IF(Icode.eq.7)THEN
       WRITE(Nw,1100)Iyr(1),Iyr(Nyr)
      ELSE IF(Icode.eq.0)THEN
       WRITE(Nw,1090)
      ELSE
       n=min0(9,Nyr)
       IF(Icmax.le.61)n=min0(5,Nyr)
       IF(Ifrst.le.6)THEN
        WRITE(Nw,1070)(Iyr(i),i=1,n)
       ELSE
        WRITE(Nw,1060)(Iyr(i),i=2,n)
       END IF
      END IF
 1010 FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
 1020 FORMAT(' ',A80)
 1030 FORMAT(1X,120A1)
 1040 FORMAT(1X,F10.2,110A1)
 1050 FORMAT(1X,E10.2,110A1)
 1060 FORMAT(18X,I4,7(8X,I4))
 1070 FORMAT(12X,I4,8(8X,I4))
 1080 FORMAT(1X,10X,110A1)
 1090 FORMAT(12X,'S=SEASONAL FREQUENCIES, T=TRADING DAY FREQUENCIES')
 1100 FORMAT(T20,I4,'  TO  ',I4)
      RETURN
      END
**==ave.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C************************
      SUBROUTINE ave(Val,N,I,Icode,Icod2,Jx)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER Icod2,Icode,Ifrst,imnth,istep,Ixy,j,Jx,jyave,jyval,k,l,
     &        Last,Llyr,Lstyr,N,N1,NL2,Npts,Nseas
      INTEGER Nyr
      REAL sum,Val,Xy
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      CHARACTER*1 Ia(110,55),Ialpha(12),I1,I2,I3,I4,I5,I6,I7,I8,I9
      CHARACTER*1 Ip(10)
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /chrtq / I1,I2,I3,I4,I5,I6,I7,I8,I9
      COMMON /grzar2/ Nyr,Npts,N1,Ifrst,Last,Llyr,Lstyr
      COMMON /arim1 / Nseas,Xy,Ixy
C PLOT BY MONTH AROUND MEAN OF EACH MONTH
C************************
      DIMENSION Val(*)
      CHARACTER*1 itype
      CHARACTER*1 I
      imnth=Ifrst
      itype=Ialpha(imnth)
      IF(Icode.eq.9)I=itype
      IF(Icod2.eq.19)THEN
       Xy=0.
      ELSE IF(Icod2.eq.29)THEN
       Xy=100.
      ELSE
       sum=0.
       DO l=1,N
        sum=sum+Val(l)
       END DO
       Xy=sum/float(N)
      END IF
      CALL value(*20)
      jyave=Ixy
      DO k=1,N
       Xy=Val(k)
       CALL value(*10)
       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
   10 END DO
   20 RETURN
      END
**==value.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C**************
      SUBROUTINE value(*)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Fact1,Xdata3,Xy,Y1,Y2,Ydiff,Ydifl,yl,Ymax,Ymaxl,Ymid,Ymin,
     &     Yminl,yvalue
      INTEGER Ibottm,Ifact2,Imid,Jy,Logsw,NL2,Nseas
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      COMMON /chrtr / Yminl,Ymaxl,Ydifl,Ymid(14)
      COMMON /chrts / Ibottm,Imid(14),Fact1,Ifact2
      COMMON /grzar1/ Y1(NL2),Y2(NL2),Xdata3(31),Ymin,Ymax,Ydiff
      COMMON /arim1 / Nseas,Xy,Jy
      COMMON /lg1   / Logsw
C*************
      IF(Logsw.eq.0)THEN
       IF(Xy.gt.Ymax)RETURN 1
       yvalue=Fact1*(Xy-Ymin)/Ydiff
       Jy=Ifact2-int(yvalue)
      ELSE
       yl=alog10(Xy)
       IF(yl.gt.Ymaxl)RETURN 1
       yvalue=Fact1*(yl-Yminl)/Ydifl
       Jy=Ifact2-int(yvalue)
      END IF
      RETURN
      END
**==dot.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C*************
      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
      CHARACTER*1 Ia(110,55),Ialpha(12),I1,I2,I3,I4,I5,I6,I7,I8,I9
      CHARACTER*1 Ip(10)
      COMMON /chrtp / Ia,Ialpha,Ip
      COMMON /chrtq / I1,I2,I3,I4,I5,I6,I7,I8,I9
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
**==grzlst.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE grzlst(Ibeg,Ibeg2,Iend,Lyr,A,B,Nmon)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL A1,B1,Grzmax,Grzmin,Xdata3,Xy,Ydiff
      INTEGER i,Ibeg,Ibeg2,Iend,Ifrst,Ixy,k,l,Last,Llyr,Lstyr,Lyr,N1,
     &        nfreq,NL2,Nmon,Npts,Nseas,Nyr
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      DOUBLE PRECISION A(*),B(*)
      COMMON /grzar1/ A1(NL2),B1(NL2),Xdata3(31),Grzmin,Grzmax,Ydiff
      COMMON /grzar2/ Nyr,Npts,N1,Ifrst,Last,Llyr,Lstyr
      COMMON /arim1 / Nseas,Xy,Ixy
      Grzmin=999999999.
      Grzmax=-999999999.
      Ibeg2=Iend-Nmon+1
      IF(Ibeg2.lt.Ibeg.or.Nmon.eq.0)Ibeg2=Ibeg
      l=0
      nfreq=12
      IF(Lyr.eq.0)nfreq=10
      Nseas=nfreq
      Ifrst=mod(Ibeg2-1,nfreq)+1
      Last=mod(Iend-1,nfreq)+1
      DO k=Ibeg2,Iend
       Npts=Npts+1
       l=l+1
       A1(l)=sngl(A(k))
       B1(l)=sngl(B(k))
       Grzmin=amin1(Grzmin,A1(l),B1(l))
       Grzmax=amax1(Grzmax,A1(l),B1(l))
      END DO
      Llyr=Lyr+Ibeg2/nfreq
      Lstyr=Lyr+(Iend+nfreq-1)/nfreq-1
      Nyr=Lstyr-Llyr+1
      N1=Iend-Ibeg2+1
      DO i=1,Nyr
       Xdata3(i)=Llyr+i-1
       IF(Lyr.eq.0)Xdata3(i)=0.
      END DO
      RETURN
      END
**==grzmth.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE grzmth(Ibeg,Iend)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL A1,B1,Ser1,Ser2,Xdata3,Xy,Ydiff,Ymax,Ymin
      INTEGER i,Ibeg,Iend,Ixy,iyear,j,month,nfreq,NL2,Nseas
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      COMMON /grzmon/ Ser1(31,12),Ser2(31,12)
      COMMON /grzar1/ A1(NL2),B1(NL2),Xdata3(31),Ymin,Ymax,Ydiff
      COMMON /arim1 / Nseas,Xy,Ixy
C---- INITIALIZE THE ARRAYS
      DO i=1,31
       DO j=1,12
        Ser1(i,j)=9999999999.
        Ser2(i,j)=9999999999.
       END DO
      END DO
C---PUT THE PROPER DATA VALUES TO BE PLOTTED INTO THE ARRAYS
      i=0
      j=0
      nfreq=12
      IF(Nseas.eq.4)nfreq=4
      DO iyear=1,31
       DO month=1,nfreq
        i=i+1
        IF(i.ge.Ibeg)THEN
         IF(i.gt.Iend)GO TO 10
         j=j+1
         Ser1(iyear,month)=A1(j)
         Ser2(iyear,month)=B1(j)
        END IF
       END DO
      END DO
   10 RETURN
      END
**==grzmyr.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE grzmyr(L)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Aa,Bb,Ser1,Ser2
      INTEGER i,iyear,L
C*** End of declarations inserted by SPAG
      COMMON /grzg2 / Aa(31),Bb(31)
      COMMON /grzmon/ Ser1(31,12),Ser2(31,12)
      i=0
      DO iyear=1,31
       IF(Ser1(iyear,L).le.999999998.)THEN
        i=i+1
        Aa(i)=Ser1(iyear,L)
        Bb(i)=Ser2(iyear,L)
       END IF
      END DO
      RETURN
      END
**==spgrh.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE spgrh(Yy,N1,N2,Itbl)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 a,an,b,cxx,oaic,sgme2,sxx,x,y,Yy
      INTEGER i,ifpl,ifpl1,Itbl,k,l,lagh,lagh1,n,N1,N2,NL1
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360)
      INTEGER h,h1
      DIMENSION y(NL1),Yy(NL1)
      DIMENSION x(NL1),cxx(1001)
      DIMENSION a(101),b(101)
      DIMENSION sxx(501)
      n=N2-N1+1
      DO i=N1,N2
       y(i)=Yy(i)
       IF(Itbl.eq.1)y(i)=Yy(i)-Yy(i-1)
      END DO
C
      h=60
C
      h1=h+1
C
      DO i=N1,N2
       x(i)=y(i)
      END DO
C
C     AUTO COVARIANCE COMPUTATION.
      lagh=n-1
      lagh=min0(lagh,60)
      lagh1=lagh+1
      CALL sautco(x,cxx,N1,N2,n,lagh1)
      an=dble(n)
      ifpl=3.0D-00*dsqrt(an)
C
      ifpl=min0(ifpl,50,lagh)
C
C
C
C     ----- 5/15/80 -----
      ifpl=min0(30,n-1)
C     ----- 5/15/80 -----
      ifpl1=ifpl+1
      CALL sicp2(cxx,ifpl1,N1,N2,a,l,sgme2,oaic)
      k=0
      CALL snrasp(a,b,sxx,sgme2,l,k,h1,Itbl)
C
      RETURN
      END
**==sicp2.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE sicp2(Cyy,L1,N1,N2,Coef,Mo,Osd,Oaic)
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     MO: ORDER OF AR
C     OSD: INNOVATION VARIANCE
C     OAIC: VALUE OF AIC
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 a,aic,am,an,anfc,b,Coef,cst0,cst01,cst05,cst1,cst2,cst20,
     &       Cyy,d,d2,Oaic,Osd,ran,scalh
      REAL*8 sd,sdr,se
      INTEGER i,ian,ian1,ian2,im,jj,jj0,l,L1,lan1,lan2,lm,m,Mo,mp1,n,N1,
     &        N2,nfc
C*** End of declarations inserted by SPAG
      DIMENSION Cyy(L1),Coef(L1)
      DIMENSION a(101),b(101)
      REAL*4 ax,bl,sta
      REAL*4 ffff
      REAL*4 f(41)
      DATA(f(i),i=1,41)/41*' '/
      DATA ax,bl,sta/' ',' ','*'/
      n=N2-N1+1
      cst0=0.0D-00
      cst1=1.0D-00
      cst2=2.0D-00
      cst20=20.0D-00
      cst05=0.05D-00
      cst01=0.00001D-00
      l=L1-1
      sd=Cyy(1)
      an=dble(n)
      Oaic=an*dlog(sd)
      Osd=sd
      Mo=0
C     INITIAL CONDITION PRINTOUT
      ran=cst1/dsqrt(an)
      scalh=cst20
      jj0=scalh+cst1
      ian=scalh*(ran+cst05)
      ian1=ian+jj0
      ian2=2*ian+jj0
      lan1=-ian+jj0
      lan2=-2*ian+jj0
      f(jj0)=ax
      f(ian1)=ax
      f(ian2)=ax
      f(lan1)=ax
      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*dlog(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
       IF(a(m).lt.cst0)nfc=scalh*(a(m)-cst05)
       IF(a(m).ge.cst0)nfc=scalh*(a(m)+cst05)
       anfc=nfc
       jj=anfc+scalh+cst1
       ffff=f(jj)
       f(jj)=sta
       f(jj)=ffff
C
C     ----- 5/15/80 -----
C
       IF(Oaic.ge.aic)THEN
        Oaic=aic
        Osd=sd
        Mo=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
      Mo=l
      DO i=1,l
       Coef(i)=-a(i)
      END DO
      f(jj0)=bl
      f(ian1)=bl
      f(ian2)=bl
      f(lan1)=bl
      f(lan2)=bl
      RETURN
      END
**==snrasp.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE snrasp(A,B,Sxx,Sgme2,L,K,H1,Itbl)
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.
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 A,B,cst1,g,gi1,gi2,gr1,gr2,pxx,Sgme2,Sxx,t
      INTEGER i,i1,ibeg2,Itbl,K,k1,L,l1
C*** End of declarations inserted by SPAG
      INTEGER H1
      DIMENSION A(101),B(101)
      DIMENSION g(501),gr1(501),gi1(501),gr2(501),gi2(501)
      DIMENSION pxx(501),Sxx(501)
      CHARACTER*80 title
      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)
      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)
      DO i=1,H1
       pxx(i)=(gr2(i)**2+gi2(i)**2)/(gr1(i)**2+gi1(i)**2)*Sgme2
      END DO
      DO i=1,H1
       t=pxx(i)
       IF(t.lt.0)t=-t
       Sxx(i)=dlog10(t)*10.0
      END DO
      IF(Itbl.eq.1)title=
     &' G 1. 10 * LOG(SPECTRUM) OF THE DIFFERENCED SEASONALLY ADJUSTED D
     &ATA (TABLE D11)'
      IF(Itbl.eq.2)title=
     &   ' G 2. 10 * LOG(SPECTRUM) OF THE MODIFIED IRREGULAR (TABLE E3)'
      CALL grzlst(1,ibeg2,61,0,Sxx,Sxx,61)
      CALL chrt(title,20,1,ibeg2,61)
      RETURN
      END
**==sautco.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE sautco(X,Cxx,N1,N2,N,Lagh1)
C     THE OUTPUTS ARE AUTOCOVARIANCES (CXX(I), I = 0, LAGH) AND
C     AUTO CORRELATIONS (NORMALIZED COVARIANCES).
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 cn,cx0,Cxx,X,xmean
      INTEGER Lagh1,N,N1,N2
C*** End of declarations inserted by SPAG
      DIMENSION X(*),Cxx(*)
      DIMENSION cn(1001)
C     MEAN DELETION
      CALL smeadl(X,N1,N2,N,xmean)
C     AUTO COVARIANCE COMPUTATION
C     COMMON SUBROUTINE CALL
      CALL crosco(X,X,N1,N2,N,Cxx,Lagh1)
C     NORMALIZATION
      cx0=Cxx(1)
C     COMMON SUBROUTINE CALL
      CALL cornom(Cxx,cn,Lagh1,cx0,cx0)
      RETURN
      END
**==fouger.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE fouger(G,Lgp1,Fc,Fs,Lf1)
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).
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 ak,alf,ck,ck2,cst0,Fc,Fs,G,pi,sk,t,tk,um0,um1,um2
      INTEGER i,i2,k,lf,Lf1,lg,lg3,lg4,Lgp1
C*** End of declarations inserted by SPAG
      DIMENSION G(Lgp1),Fc(Lf1),Fs(Lf1)
      lg=Lgp1-1
      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
      pi=3.1415926536D-00
      alf=lf
      t=pi/alf
      DO k=1,Lf1
       ak=k-1
       tk=t*ak
       ck=dcos(tk)
       sk=dsin(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
**==cornom.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE cornom(C,Cn,Lagh1,Cx0,Cy0)
C     COMMON SUBROUTINE
C     NORMALIZATION OF COVARIANCE
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 C,Cn,cst1,Cx0,Cy0,ds
      INTEGER i,Lagh1
C*** End of declarations inserted by SPAG
      DIMENSION C(*),Cn(*)
      cst1=1.0D-00
      ds=cst1/dsqrt(Cx0*Cy0)
      DO i=1,Lagh1
       Cn(i)=C(i)*ds
      END DO
      RETURN
      END
**==smeadl.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE smeadl(X,N1,N2,N,Xmean)
C     MEAN DELETION
C     SUMF: FUNCTION
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 an,sumf,X,Xmean
      INTEGER i,N,N1,N2
C*** End of declarations inserted by SPAG
      DIMENSION X(*)
      an=dble(N)
      Xmean=sumf(X,N1,N2)/an
      DO i=N1,N2
       X(i)=X(i)-Xmean
      END DO
      RETURN
      END
**==sumf.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION sumf(X,N1,N2)
C     COMMON SUBROUTINE
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,N1,N2
      REAL*8 X
C*** End of declarations inserted by SPAG
      DIMENSION X(*)
      sumf=0.0
      DO i=N1,N2
       sumf=sumf+X(i)
      END DO
      RETURN
      END
**==crosco.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE crosco(X,Y,N1,N2,N,C,Lagh1)
C     COMMON SUBROUTINE
C     THIS SUBROUTINE COMPUTES C(L)=COVARIANCE(X(S+L),Y(S))
C     (L=0,1,...,LAGH1-1).
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL*8 an,bn,bn1,C,ct0,t,X,Y
      INTEGER i,ii,il,j,j1,Lagh1,N,N1,N2
C*** End of declarations inserted by SPAG
      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
**==mstest.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE mstest(Array,Jfda,Jlda,Nyr,Icol)
C --- AN F TEST FOR MOVING SEASONALITY
C
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Array,array1,F,fvalue,P,Ssf,Ssmf,Test1,Test2
      INTEGER i,i1,Icol,ifmo,Iqfail,Issap,Issqf,j,j1,Jfda,Jlda,k,k1,
     &        Khol,l,l1,lmo,m,Muladd,n
      INTEGER n1,ndgfre,nmin1,Nopt,noyrs,Nw,Nyr
C*** End of declarations inserted by SPAG
      DOUBLE PRECISION suma1,xbar,colss,colmn,rowss,rowmn,fnyr,totss,
     &                 errss,degfre,fnoyrs,rowssn,errssn,c
      COMMON /ca    / Nw
      COMMON /cj    / Muladd
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /ssft  / Ssf(4),Ssmf(4),Issqf(4)
C  *****  CHANGE TO IMPLEMENT X-11-ARIMA M & Q DIAGNOSTICS
      COMMON /tests / F(3),P(3),Test1,Test2,Iqfail
C  *****  END OF CHANGE
      DIMENSION Array(Jlda),array1(372)
      c=1.0D0
      ifmo=(Jfda+Nyr-2)/Nyr*Nyr+1
      lmo=Jlda/Nyr*Nyr
      noyrs=(lmo-ifmo)/Nyr+1
      fnoyrs=noyrs
      IF(Muladd.eq.0)THEN
C -- MULTIPLICATIVE MODEL
       c=10000.0D0
       DO j=ifmo,lmo
        array1(j)=abs(Array(j)-100.0)
       END DO
      ELSE
C --- ADDITIVE MODEL
       DO i=ifmo,lmo
        array1(i)=abs(Array(i))
       END DO
      END IF
C --- ANALYSIS OF VARIANCE TEST
      suma1=0.0D0
      DO k=ifmo,lmo
       suma1=suma1+array1(k)
      END DO
      fnyr=Nyr
      xbar=suma1/(fnyr*fnoyrs)
      colss=0.0D0
      DO l=1,Nyr
       colmn=0.0D0
       k1=ifmo+l-1
       DO m=k1,lmo,Nyr
        colmn=colmn+array1(m)
       END DO
       colmn=colmn/fnoyrs
       colss=colss+(colmn-xbar)*(colmn-xbar)
      END DO
      colss=colss*fnoyrs*c
      rowss=0.0D0
      DO n=ifmo,lmo,Nyr
       rowmn=0.0D0
       l1=n+Nyr-1
       DO i1=n,l1
        rowmn=rowmn+array1(i1)
       END DO
       rowmn=rowmn/fnyr
       rowss=rowss+(rowmn-xbar)*(rowmn-xbar)
      END DO
      rowss=rowss*fnyr*c
      totss=0.0D0
      DO j1=ifmo,lmo
       totss=totss+(array1(j1)-xbar)*(array1(j1)-xbar)
      END DO
      errss=totss*c-colss-rowss
      degfre=fnoyrs-1.0D0
      rowssn=rowss/degfre
      errssn=errss/((fnyr-1.0D0)*degfre)
      ndgfre=(Nyr-1)*(noyrs-1)
      F(2)=rowssn/errssn
      n1=noyrs-1
      P(2)=fvalue(F(2),n1,ndgfre)*100.0
      IF(Issap.eq.1)Ssmf(Icol)=F(2)
      IF(Nopt.eq.1.or.Issap.eq.1)RETURN
      nmin1=noyrs-1
      WRITE(Nw,1010)rowss,nmin1,rowssn,F(2),errss,ndgfre,errssn
 1010 FORMAT(//,20X,'MOVING SEASONALITY TEST',/,43X,'SUM OF',5X,
     &       'DGRS.OF',9X,'MEAN',/,42X,'SQUARES',5X,'FREEDOM',8X,
     &       'SQUARE',7X,'F-VALUE',/,21X,'BETWEEN YEARS',F17.4,I9,F17.6,
     &       F12.3,/,29X,'ERROR',F17.4,I9,F17.6,/)
      RETURN
      END
**==ftest.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
C --- LIP FOR FTEST,FTEST,FTESTS
C --- THIS ROUTINE COMPUTES THE ANALYSIS-OF-VARIANCE F-TEST.
      SUBROUTINE ftest(Array,Jfda,Jlda,Ind,Icol)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Array,dfr,F,Fmsm,Fmsr,Fst,Fsu,fvalue,P,prob,sm,
     &                 Ssf,Ssm,Ssmf,Ssqt,Ssr,st,Stmp,Summ,Sumt
      DOUBLE PRECISION temp,Test1,Test2,Xk,Xnm
      INTEGER i,Icol,idiff,Im,Ind,Iqfail,Issap,Issqf,itype,Iyr,j,Jfda,
     &        Jlda,kb,kdfr,kdft,Khol,L0,Lm,Lyr
      INTEGER m,Muladd,NL2,nm,Nopt,Nsea,nt,Nw
C*** End of declarations inserted by SPAG
      PARAMETER(NL2=372)
      DIMENSION Array(NL2),nm(12),temp(NL2)
      CHARACTER*2 blank,star,star2,fstar
      COMMON /ca    / Nw
      COMMON /caa   / Xnm(12),Summ(12),Ssqt,Sumt,F,Fsu,Ssr,Ssm,Xk(2),
     &                Fmsm,Fmsr,Stmp(338)
      COMMON /cj    / Muladd
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lm
      COMMON /lzero / L0
      COMMON /ssft  / Ssf(4),Ssmf(4),Issqf(4)
C  *****  CHANGE TO IMPLEMENT X-11-ARIMA M & Q DIAGNOSTICS
      COMMON /tests / Fst(3),P(3),Test1,Test2,Iqfail
C  *****  END OF CHANGE
      DATA blank,star,star2/'  ','* ','**'/
      DATA idiff/1/
      IF(Ind.gt.0.and.Issap.eq.1)RETURN
      itype=0
      Icol=0
      IF(Issap.eq.1)Icol=(Jfda-L0-Im+13)/12
      IF(Ind.ge.1)THEN
       kb=Jfda+idiff
       DO i=kb,Jlda
        temp(i)=Array(i)-Array(i-idiff)
       END DO
      ELSE
       kb=Jfda
       DO i=Jfda,Jlda
        temp(i)=Array(i)
       END DO
      END IF
      DO WHILE (.true.)
       DO i=1,12
        nm(i)=0
        Summ(i)=0.
       END DO
       nt=0
       Sumt=0.
       Ssqt=0.
       DO i=1,12
        j=i+kb-1
        DO m=j,Jlda,12
         nm(i)=nm(i)+1
         nt=nt+1
         Summ(i)=Summ(i)+temp(m)
         Sumt=Sumt+temp(m)
         Ssqt=Ssqt+temp(m)**2
        END DO
       END DO
       st=dble(nt)
       Ssqt=Ssqt-Sumt**2/st
       Ssm=0.
       DO i=1,12
        sm=dble(nm(i))
        Ssm=Ssm+Summ(i)**2/sm
       END DO
       Ssm=Ssm-Sumt**2/st
       Ssr=Ssqt-Ssm
       kdfr=nt-12
       kdft=nt-1
       Fmsm=Ssm/11.
       dfr=dble(kdfr)
       Fmsr=Ssr/dfr
       F=Fmsm/Fmsr
       prob=fvalue(F,11,kdfr)*100.0
       IF(Ind.eq.0)THEN
        Fst(1)=F
        P(1)=prob
        IF(Issap.eq.1)THEN
         Ssf(Icol)=F
        ELSE
         WRITE(Nw,1010)Ssm,Fmsm,F,Ssr,kdfr,Fmsr,Ssqt,kdft
         IF(Muladd.ne.0)RETURN
         IF(Fmsr.gt.0.01D0)RETURN
         WRITE(Nw,1120)
        END IF
        RETURN
       END IF
       fstar=blank
       IF(prob.lt.1.0)fstar=star
       IF(prob.lt.0.1)fstar=star2
       IF(itype.eq.0)THEN
        WRITE(Nw,1020)
        IF(fstar.eq.blank)WRITE(Nw,1060)fstar,F
        IF(fstar.ne.blank)WRITE(Nw,1050)fstar,F
        kb=Jlda-35
        IF(kb.le.Jfda)RETURN
        itype=1
        GO TO 10
       ELSE IF(fstar.ne.blank)THEN
        WRITE(Nw,1100)fstar,F
        WRITE(Nw,1110)
       ELSE
        WRITE(Nw,1070)fstar,F
        IF(prob.gt.5.0)WRITE(Nw,1090)fstar
        IF(prob.le.5.0)WRITE(Nw,1080)fstar
        WRITE(Nw,1110)
       END IF
 1010  FORMAT(43X,'SUM OF',5X,'DGRS.OF',9X,'MEAN',/,42X,'SQUARES',4X,
     &        'FREEDOM',9X,'SQUARE',9X,'F',/,20X,'BETWEEN MONTHS',F17.3,
     &        7X,'11',F17.3,F12.3,/,26X,'RESIDUAL',F17.3,I9,F17.3,/,29X,
     &        'TOTAL',F17.3,I9)
 1020  FORMAT(/,42X,'TEST FOR THE PRESENCE OF RESIDUAL SEASONALITY')
 1030  FORMAT(/,49X,'IN THE SEASONALLY ADJUSTED DATA')
 1040  FORMAT(/,44X,'IN THE MODIFIED SEASONALLY ADJUSTED DATA')
 1050  FORMAT(/,18X,A2,'RESIDUAL SEASONALITY PRESENT IN THE ENTIRE ',
     &        'SERIES AT THE 1 PER CENT LEVEL.        F =',F10.2)
 1060  FORMAT(/,18X,A2,'NO EVIDENCE OF RESIDUAL SEASONALITY IN THE ',
     &        'ENTIRE SERIES AT THE 1 PER CENT LEVEL. F =',F10.2)
 1070  FORMAT(/,18X,A2,'NO EVIDENCE OF RESIDUAL SEASONALITY IN THE ',
     &        'LAST 3 YEARS AT THE 1 PER CENT LEVEL.  F =',F10.2)
 1080  FORMAT(/,18X,A2,'RESIDUAL SEASONALITY PRESENT IN THE LAST 3 ',
     &        'YEARS AT THE 5 PER CENT LEVEL.')
 1090  FORMAT(/,18X,A2,'NO EVIDENCE OF RESIDUAL SEASONALITY IN THE ',
     &        'LAST 3 YEARS AT THE 5 PER CENT LEVEL.')
 1100  FORMAT(/,18X,A2,'RESIDUAL SEASONALITY PRESENT IN THE LAST 3 ',
     &        'YEARS AT THE 1 PER CENT LEVEL.         F =',F10.2)
 1110  FORMAT(/,1X,'NOTE: SUDDEN LARGE CHANGES IN THE LEVEL OF THE ',
     &      'SEASONALLY ADJUSTED SERIES WILL INVALIDATE THE RESULTS OF '
     &      ,'THIS TEST FOR THE',/,50X,'LAST THREE YEAR PERIOD.')
 1120  FORMAT(/,28X,'DUE TO THE SMALL RESIDUAL MEAN SQUARE ERROR ALL ',
     &        'THE ANALYSIS OF VARIANCE TESTS FOR THIS SERIES MAY BE ',
     &        'INVALID')
       RETURN
   10 END DO
      END
**==ssftst.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE ssftst(Ncol)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,Issqf,Kout,Kpage,Ncol
      DOUBLE PRECISION Ssf,Ssmf
C*** End of declarations inserted by SPAG
      CHARACTER*3 qf(4)
      CHARACTER*5 table
      CHARACTER*6 span(4),Lser
      CHARACTER*18 label(2)
      CHARACTER*46 ftfmt
      COMMON /ssft  / Ssf(4),Ssmf(4),Issqf(4)
      COMMON /cz    / Kpage,Kout,Lser
      DATA table/'(D 8)'/
      DATA span/'SPAN 1','SPAN 2','SPAN 3','SPAN 4'/
      DATA label/'STABLE SEASONALITY','MOVING SEASONALITY'/
      WRITE(Kout,1010)
      WRITE(Kout,1010)
 1010 FORMAT(' ')
      WRITE(Kout,1020)
 1020 FORMAT(5X,'SUMMARY OF F-TESTS FOR STABLE AND MOVING SEASONALITY ',
     &       'FOR EACH SPAN',/)
      ftfmt=' '
      WRITE(ftfmt,1030)Ncol
 1030 FORMAT('(27X,',I1,'(9X,A6))')
      WRITE(Kout,ftfmt)(span(i),i=1,Ncol)
      ftfmt=' '
      WRITE(ftfmt,1040)Ncol
 1040 FORMAT('(5X,A18,3X,A5,',I1,'(3X,F8.2,4X))')
      WRITE(Kout,ftfmt)label(1),table,(Ssf(i),i=1,Ncol)
      WRITE(Kout,ftfmt)label(2),table,(Ssmf(i),i=1,Ncol)
      ftfmt=' '
      WRITE(ftfmt,1050)Ncol
 1050 FORMAT('(5X,25HIDENTIFIABLE SEASONALITY?,9X,',I1,'(A3,12X))')
      DO i=1,Ncol
       qf(i)='   '
       IF(Issqf(i).eq.0)qf(i)='YES'
       IF(Issqf(i).eq.1)qf(i)='???'
       IF(Issqf(i).eq.2)qf(i)=' NO'
      END DO
      WRITE(Kout,ftfmt)(qf(i),i=1,Ncol)
      WRITE(Kout,1010)
      WRITE(Kout,1060)
 1060 FORMAT(/,10X,'YES = IDENTIFIABLE SEASONALITY PRESENT',/,10X,
     &       '??? = IDENTIFIABLE SEASONALITY PROBABLY NOT PRESENT',/,
     &       10X,' NO = IDENTIFIABLE SEASONALITY NOT PRESENT',//)
      RETURN
      END
**==combft.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE combft(Icol)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION F,P,Ssf,Ssmf,test,Test1,Test2
      INTEGER Icol,Iqfail,Issap,Issqf,Khol,Nopt,Nw
C*** End of declarations inserted by SPAG
C --- THIS SUBROUTINUE PRODUCES THE COMBINED TEST FOR THE PRESENCE OF
C --- IDENTIFIABLE SEASONALITY.
      COMMON /ca    / Nw
C  *****  CHANGE TO IMPLEMENT X-11-ARIMA M & Q DIAGNOSTICS
      COMMON /tests / F(3),P(3),Test1,Test2,Iqfail
C  *****  END OF CHANGE
      COMMON /czz   / Nopt,Khol,Issap
      COMMON /ssft  / Ssf(4),Ssmf(4),Issqf(4)
      Iqfail=0
      Test1=9.0
      IF(F(1)*9.0.gt.7.0)Test1=7.0/F(1)
      Test2=(3.0*F(2))/F(1)
      IF(Test2.gt.9.0)Test2=9.0
      test=(Test1+Test2)/2.0
      IF(Test1.ge.1.0.or.Test2.ge.1.0)Iqfail=1
      IF(P(1).ge.0.1)Iqfail=2
      IF(P(2).le.5.0.and.test.ge.1.0)Iqfail=2
      IF(Issap.eq.1)Issqf(Icol)=Iqfail
      IF(Nopt.eq.1.or.Issap.eq.1)RETURN
      WRITE(Nw,1010)
      IF(Iqfail.eq.0)WRITE(Nw,1030)
      IF(Iqfail.eq.1)WRITE(Nw,1020)
      IF(Iqfail.eq.2)WRITE(Nw,1040)
 1010 FORMAT(//,20X,
     &    'COMBINED TEST FOR THE PRESENCE OF IDENTIFIABLE SEASONALITY :'
     &    )
 1020 FORMAT(/,30X,'IDENTIFIABLE SEASONALITY PROBABLY NOT PRESENT')
 1030 FORMAT(/,30X,'IDENTIFIABLE SEASONALITY PRESENT')
 1040 FORMAT(/,30X,'IDENTIFIABLE SEASONALITY NOT PRESENT')
      RETURN
      END
**==vcomp.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE vcomp(Ny,Stime,Stome)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION b,bx,flen,fny,fsum1,fsum2,ftemp,Rati,Ratic,Rv,
     &                 Sigm,Sigml,Sigmu,Smp,Stc,Stci,Stime,Stome,Stopa,
     &                 Stopma
      DOUBLE PRECISION Stor,Stpmf,Stptdf,Sts,Stsi,sum1,sum2,temp,trend,
     &                 vars,Vc,Vi,vo,Vp,Vs,Vtd,w,xmat
      INTEGER i,iflag,In,j,j1,j2,k,Kdec,Kdwopt,Kfulsm,Kpart,Kpropt,
     &        Kspopt,Kswk,Ktcopt,Layr,Lcyr,Length,lf,Lfda
      INTEGER Lfdc,Lfdr,Llda,Lopt,Lstmo,Lstyr,Lterm,Lyr,Mcd,Mdec,Muladd,
     &        NL1,NL2,Nterm,nvar,Ny
C*** End of declarations inserted by SPAG
      PARAMETER(NL1=360,NL2=372)
      CHARACTER*4 Pcdif
      DIMENSION xmat(31,31),b(31),bx(31),trend(NL2),temp(NL2)
      DIMENSION Stime(NL1),Stome(NL1)
      COMMON /cb    / Ratic,Stc(NL1),Stci(NL1),Nterm
      COMMON /cc    / Rati(36),Lterm(12),Sts(NL2),Stsi(NL1)
      COMMON /cf    / Lyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Kdec,Layr,
     &                Lstmo,Lstyr,Kpropt
      COMMON /cj    / Muladd
      COMMON /cm    / Lfda,Llda,Kfulsm,Lopt,Kdwopt,Lfdc,Lfdr,Ktcopt,
     &                Kspopt,Mdec,Pcdif(4),Smp(24),Stptdf(NL2),Stor(NL1)
     &                ,Stopa(NL1),Stpmf(NL1),Stopma(NL1),Lcyr
      COMMON /mq2   / Vi,Vc,Vs,Vp,Vtd,Rv,Length
C *** INITIALIZE VARIABLES, TAKE LOG OF TREND IF NOT ADDITIVE ADJUSTMENT
      IF(Muladd.ne.1)CALL logar(Stc,Lfda,Llda)
      sum1=fsum1(Ny)
      sum2=fsum2(Ny)
      nvar=Lstyr-Lyr+2
      fny=float(Ny)
      flen=float(Length)
C *** SET UP X-PRIME-X MATRIX FOR SPLINE REGRESSION
      xmat(nvar,nvar)=fsum2(Lstmo)
      DO i=1,nvar-1
       IF(i.eq.1)THEN
        xmat(i,i)=flen
       ELSE
        ftemp=flen-float(Ny*(i-2)+(Ny-Lfda+1))
        xmat(i,i)=sum2+fny*fny*ftemp
        IF(i.eq.2.and.Lfda.gt.1)xmat(i,i)=xmat(i,i)-fsum2(Lfda-1)
       END IF
       DO j=i+1,nvar
        ftemp=flen-float(Ny*(j-2)+(Ny-Lfda+1))
        IF(j.eq.nvar)ftemp=0.0
        IF(i.eq.1)THEN
         xmat(i,j)=sum1+fny*ftemp
         IF(j.eq.nvar)xmat(i,j)=fsum1(Lstmo)
         IF(j.eq.2.and.Lfda.gt.1)xmat(i,j)=xmat(i,j)-fsum1(Lfda-1)
        ELSE
         xmat(i,j)=fny*xmat(1,j)
         IF(i.eq.2.and.Lfda.gt.1)xmat(i,j)=xmat(i,j)-fsum1(Lfda-1)
        END IF
        xmat(j,i)=xmat(i,j)
       END DO
      END DO
C *** SET UP X-PRIME-Y MATRIX FOR SPLINE REGRESSION
      j2=Llda
      lf=mod(Lfda,Ny)
      IF(lf.eq.0)lf=Ny
      DO j=1,nvar
       b(j)=0.0
       j1=Lfda
       IF(j.gt.2)j1=((Lfda/Ny)+j-2)*Ny+1
       j2=Llda
       DO k=j1,j2
        w=1.0
        IF(j.eq.1)trend(k)=0.0
        IF(j.gt.1)w=float(k-j1+1)
        IF(j.eq.2)w=w+(lf-1)
        IF(w.gt.Ny)w=Ny
        b(j)=b(j)+w*Stc(k)
       END DO
      END DO
C *** USE GAUSSIAN ELIMINATION AND PIVOTING SUBROUTINE TO ESTIMATE
C     COEFFICIENTS TO BE USED IN GENERATING THE SPLINE TREND
      CALL lassol(nvar,xmat,b,31,bx,iflag)
      IF(iflag.eq.2)THEN
       PRINT *,'MATRIX APPEARS SINGULAR, WILL NOT PROCEED FURTHER'
       STOP 10
      END IF
C *** USING SPLINE REGRESSION COEFFICIENTS, COMPUTE SPLINE TREND
C     AND STORE IN VARIABLE TREND
      DO j=1,nvar
       j1=Lfda
       IF(j.gt.2)j1=((Lfda/Ny)+j-2)*Ny+1
       j2=Llda
       DO k=j1,j2
        w=1.0
        IF(j.gt.1)w=float(k-j1+1)
        IF(w.gt.Ny)w=Ny
        trend(k)=trend(k)+w*bx(j)
       END DO
      END DO
C *** CALCULATE RELATIVE CONTRIBUTION OF EACH COMPONENT
C     TO STATIONARY PORTION OF THE VARIANCE, USING SPLINE
C     TREND AS DETRENDER
      IF(Muladd.ne.1)THEN
       CALL antilg(Stc,Lfda,Llda)
       CALL antilg(trend,Lfda,Llda)
      END IF
      Vs=vars(Sts,Lfda,Llda,1)
      Vi=vars(Stime,Lfda,Llda,1)
      Vp=vars(Stpmf,Lfda,Llda,1)
      CALL divsub(temp,Stc,trend,Lfda,Llda)
      Vc=vars(temp,Lfda,Llda,0)
      CALL divsub(temp,Stome,trend,Lfda,Llda)
      vo=vars(temp,Lfda,Llda,0)/100.0
      Vs=Vs/vo
      Vi=Vi/vo
      Vp=Vp/vo
      Vtd=Vtd/vo
      Vc=Vc/vo
      Rv=Vp+Vtd+Vc+Vs+Vi
      RETURN
      END
**==fsum1.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION fsum1(N)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER N
C*** End of declarations inserted by SPAG
      fsum1=dble(N*(N+1))/2.0
      RETURN
      END
**==fsum2.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION fsum2(N)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER N
C*** End of declarations inserted by SPAG
      fsum2=dble(N*(N+1)*(2*N+1))/6.0
      RETURN
      END
**==lassol.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE lassol(N,A,B,M,X,Iflag)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,ib,idxpiv,Iflag,ip1,j,k,kp1,M,N,nm1,np1
C*** End of declarations inserted by SPAG
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
      DOUBLE PRECISION A(M,M),B(N),X(N),ab(31,32),rowmax,big,quot,sum,
     &                 tempb,tempi,scale,one
      EQUIVALENCE(big,quot,sum,scale),(rowmax,tempb,tempi)
      DATA one/1.0/
      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=0.
       DO j=1,N
        rowmax=dmax1(rowmax,dabs(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=0.0
       DO i=k,N
        tempb=dabs(ab(i,k))
        IF(big.lt.tempb)THEN
         big=tempb
         idxpiv=i
        END IF
       END DO
       IF(big.eq.0)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(ab(N,N).ne.0.0)THEN
       X(N)=ab(N,np1)/ab(N,N)
       DO ib=2,N
        i=np1-ib
        ip1=i+1
        sum=0.0
        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
**==vars.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION vars(X,I,J,Iopt)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER I,Iopt,J,Muladd
      DOUBLE PRECISION varian,varlog,X
C*** End of declarations inserted by SPAG
      COMMON /cj    / Muladd
      DIMENSION X(*)
      IF(Muladd.eq.1)vars=varian(X,I,J,Iopt)
      IF(Muladd.eq.0)vars=varlog(X,I,J,Iopt)
      RETURN
      END
**==varlog.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION varlog(X,I,J,Iopt)
C --- THIS FUNCTION COMPUTES THE LOG VARIANCE OF X. IF IOPT IS EQUAL
C --- TO 1 THE LOG MEAN IS ASSUMED TO BE 1.
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER I,Iopt,J,k
      DOUBLE PRECISION tmp,tmp2,X
C*** End of declarations inserted by SPAG
      DIMENSION X(*)
      tmp=0.0
      IF(Iopt.eq.0)THEN
       DO k=I,J
        tmp=tmp+dlog(X(k))
       END DO
       tmp=tmp/float(J-I+1)
      END IF
      varlog=0.0
      DO k=I,J
       IF(Iopt.eq.0)tmp2=dlog(X(k))-tmp
       IF(Iopt.eq.1)tmp2=dlog(X(k)/100.0)
       varlog=varlog+tmp2*tmp2
      END DO
      RETURN
      END
**==varian.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION varian(X,I,J,Iopt)
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 HUNDRED.
      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
      DIMENSION X(*)
      IF(Iopt.eq.2)ave=100.0
      IF(Iopt.eq.1)ave=0.0
      IF(Iopt.eq.0)THEN
       DO k=I,J
        ave=ave+X(k)
       END DO
       ave=ave/(J-I+1)
      END IF
      varian=0.0
      DO k=I,J
       varian=varian+(X(k)-ave)*(X(k)-ave)
      END DO
      RETURN
      END
**==logar.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE logar(X,I,J)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER I,J,k
      DOUBLE PRECISION tmp,X
C*** End of declarations inserted by SPAG
      DIMENSION X(*)
      DO k=I,J
       tmp=X(k)
       X(k)=dlog(tmp)
      END DO
      RETURN
      ENTRY antilg(X,I,J)
      DO k=I,J
       tmp=X(k)
       X(k)=dexp(tmp)
      END DO
      RETURN
      END
**==f3cal.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE f3cal(Isq,Psq,Smic,Ny)
C --- THIS SUBROUTINE CALCULATES THE QUALITY CONTROL STATISTICS IN TABLE
C --- F3.
C
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Adri,ave,ave1,ave2,ave3,ave4,count,ct,ct1,ct2,
     &                 diff,F,fn,P,Psq,Qual,Rati,Ratic,Ratis,rmcd
      DOUBLE PRECISION Rv,sd,sdev,Sigm,Sigml,Sigmu,Smic,Smp,Stc,Stci,
     &                 Stopa,Stopma,Stor,Stpmf,Stptdf,Sts,Stsi,t1,t2,
     &                 temp
      DOUBLE PRECISION Test1,Test2,twt,Vc,Vi,Vp,Vs,Vtd,wt
      INTEGER i,i1,ifail,In,Iqfail,j,k,Kdec,Kdwopt,Kfail,Kfulsm,klda,
     &        kny,Kpart,Kpropt,Kspopt,Kswk,Ktcopt,l,Layr
      INTEGER Lcyr,Length,Lfda,Lfdc,Lfdr,Llda,Lopt,Lstmo,Lstyr,Lterm,
     &        Lyr,Mcd,Mdec,mtype,Muladd,n,NL1,NL2,Nn,Nterm
      INTEGER Ny,Nyrs
C*** End of declarations inserted by SPAG
      DIMENSION wt(11),Psq(*),Smic(*),temp(372)
      DOUBLE PRECISION Isq(*),Nm
      PARAMETER(NL1=360,NL2=372)
      CHARACTER*4 Pcdif
      COMMON /mq1   / Adri,Ratis
      COMMON /mq2   / Vi,Vc,Vs,Vp,Vtd,Rv,Length
      COMMON /mq3   / Qual,Nm(11),Nn,Kfail,Nyrs
      COMMON /cb    / Ratic,Stc(NL1),Stci(NL1),Nterm
      COMMON /cc    / Rati(36),Lterm(12),Sts(NL2),Stsi(NL1)
      COMMON /cf    / Lyr,Kswk,Kpart,Mcd,Sigm,Sigml,Sigmu,In,Kdec,Layr,
     &                Lstmo,Lstyr,Kpropt
      COMMON /cj    / Muladd
      COMMON /cm    / Lfda,Llda,Kfulsm,Lopt,Kdwopt,Lfdc,Lfdr,Ktcopt,
     &                Kspopt,Mdec,Pcdif(4),Smp(24),Stptdf(NL2),Stor(NL1)
     &                ,Stopa(NL1),Stpmf(NL1),Stopma(NL1),Lcyr
      COMMON /tests / F(3),P(3),Test1,Test2,Iqfail
      DATA wt/10.,11.,10.,8.,11.,10.,18.,7.,7.,4.,4./
      mtype=Lterm(1)
      DO i=2,12
       IF(mtype.ne.Lterm(i))mtype=6
      END DO
      ifail=0
      kny=Ny/4+Ny
      Nm(1)=(Isq(kny)/(1.0-Psq(kny)))/0.10
      kny=12/Ny
      Nm(2)=(Vi/(100.0-Vp))/0.10
      Nm(3)=(Ratic*kny-1.0)/2.0
      fn=Llda-Lfda+1
      t1=dabs((3.0*(fn-1.0)/Adri)-2.0*(fn-1.0))
      t2=dsqrt(1.6*fn-2.9)*2.577
      Nm(4)=t1/t2
      IF(Mcd.eq.1)THEN
       rmcd=1+(Smic(1)-1.0)/(Smic(1)-Smic(2))
       IF(rmcd.lt.0.5)rmcd=0.5
       IF(rmcd.gt.1.0)rmcd=1.0
      ELSE
       rmcd=Mcd+(Smic(Mcd)-1.0)/(Smic(Mcd-1)-Smic(Mcd))
       IF(Mcd.eq.Ny.and.Smic(Ny-1).le.Smic(Ny))rmcd=kny*15.5
      END IF
      Nm(5)=(rmcd*kny-0.5)/5.0
      Nm(6)=dabs(Ratis-4.0)/2.5
      Nm(7)=dsqrt((Test1+Test2)/2.0)
      Nyrs=(Llda-Lfda+1)/Ny
      Nn=7
      IF(mtype.ne.5.and.Nyrs.ge.6)THEN
       Nn=11
       n=2-Muladd
       sd=sdev(Sts,Lfda,Llda,1,n)
       ave=(1-Muladd)*100.0
       DO i=Lfda,Llda
        temp(i)=(Sts(i)-ave)/sd
       END DO
       ct1=0.0
       ct2=0.0
       count=0.0
       ave1=0.0
       ave2=0.0
       ave3=0.0
       ave4=0.0
       klda=Lfda+Ny-1
       DO i=Lfda,klda
        ct=0.0
        i1=i+Ny
        DO j=i1,Llda,Ny
         ct=ct+1.0
         count=count+1.0
         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.Lfda)THEN
         ave3=ave3+dabs(temp(k)-temp(j))/3.0
         ct1=ct1+1.0
         j=j+Ny
         DO l=j,k,Ny
          i1=l-Ny
          IF(i1.ge.Lfda)THEN
           ct2=ct2+1.0
           diff=dabs(temp(l)-temp(i1))
           ave4=ave4+diff
          END IF
         END DO
        END IF
       END DO
       ave1=ave1/count
       ave2=ave2/Ny
       IF(ct1.gt.0.0)THEN
        ave3=ave3/ct1
        ave4=ave4/ct2
       END IF
       Nm(8)=10.0*ave1
       Nm(9)=10.0*ave2
       Nm(10)=10.0*ave4
       Nm(11)=10.0*ave3
      END IF
      Qual=0.0
      twt=0.0
      DO i=1,11
       IF(i.le.Nn)THEN
        IF(Nm(i).lt.0.0)Nm(i)=0.0
        IF(Nm(i).gt.3.0)Nm(i)=3.0
        IF(Nm(i).ge.1.0)ifail=ifail+1
        IF(i.ne.6.or.(mtype.eq.3.and.i.eq.6))Qual=Qual+Nm(i)*wt(i)
       ELSE IF(i.eq.10)THEN
        Qual=Qual+Nm(1)*wt(i)
       ELSE IF(i.eq.11)THEN
        Qual=Qual+Nm(2)*wt(i)
       ELSE
        Qual=Qual+Nm(7)*wt(i)
       END IF
       IF(i.ne.6.or.(mtype.eq.3.and.i.eq.6))twt=twt+wt(i)
      END DO
      Qual=Qual/twt
      Kfail=ifail
      RETURN
      END
**==sdev.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION sdev(X,I,J,K,Iopt)
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.
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION ave,fn,X
      INTEGER I,Iopt,J,K,l
C*** End of declarations inserted by SPAG
      DOUBLE PRECISION totals
      DIMENSION X(*)
      fn=dble((J-I)/K+1)
      ave=0.0
      IF(Iopt.eq.2)ave=100.0
      IF(Iopt.eq.0)ave=totals(X,I,J,K,1)
      sdev=0.0
      DO l=I,J,K
       sdev=sdev+(X(l)-ave)*(X(l)-ave)
      END DO
      sdev=sqrt(sdev/fn)
      RETURN
      END
**==f3gen.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE f3gen(Ny,Mq)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER k,Kfail,Kpage,l,Nn,Np,Ny,Nyrs
      DOUBLE PRECISION Qu,Qual
C*** End of declarations inserted by SPAG
      CHARACTER*6 span(4),Lser
      CHARACTER*7 Mq
      CHARACTER*80 Name
C --- THIS SUBROUTINE PRINTS THE F3 TABLE.
      COMMON /mq3   / Qual,Qu(11),Nn,Kfail,Nyrs
      COMMON /cf3   / Name
      COMMON /cz    / Kpage,Np,Lser
      DATA span/'THREE ','MONTHS','ONE QU','ARTER '/
      k=1
      IF(Ny.eq.4)k=3
      l=k+1
      WRITE(Np,1010)Name,Kpage,Lser
 1010 FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
      Kpage=Kpage+1
      WRITE(Np,1020)
 1020 FORMAT(//,' F 3. MONITORING AND QUALITY ASSESSMENT STATISTICS')
      WRITE(Np,1030)
 1030 FORMAT('0',6X,
     &'ALL THE MEASURES BELOW ARE IN THE RANGE FROM 0 TO 3 WITH AN ACCEP
     &TANCE REGION FROM 0 TO 1.')
      WRITE(Np,1040)span(k),span(l),Qu(1)
 1040 FORMAT('0',3X,
     &       '1. THE RELATIVE CONTRIBUTION OF THE IRREGULAR OVER ',2A6,
     &       ' SPAN (FROM TABLE F 2.B).',T99,'M1  = ',F5.3,//)
      WRITE(Np,1050)Qu(2)
 1050 FORMAT('0',3X,
     &'2. THE RELATIVE CONTRIBUTION OF THE IRREGULAR COMPONENT TO THE ST
     &ATIONARY PORTION OF',T99,'M2  = ',F5.3,/,7X,
     &'THE VARIANCE (FROM TABLE F 2.F).',/)
      WRITE(Np,1060)Mq,Mq,Qu(3),Mq,Mq
 1060 FORMAT('0',3X,'3. THE AMOUNT OF ',A7,' TO ',A7,
     &       ' CHANGE IN THE IRREGULAR COMPONENT AS COMPARED TO THE',
     &       T99,'M3  = ',F5.3,/,7X,'AMOUNT OF ',A7,' TO ',A7,
     &       ' CHANGE IN THE TREND-CYCLE (FROM TABLE F2.G).',/)
      WRITE(Np,1070)Qu(4)
 1070 FORMAT('0',3X,
     &'4. THE AMOUNT OF AUTOCORRELATION IN THE IRREGULAR AS DESCRIBED BY
     & THE AVERAGE DURATION',T99,'M4  = ',F5.3,/,7X,
     &'OF RUN (TABLE F 2.C).',/)
      WRITE(Np,1080)Mq,Qu(5)
 1080 FORMAT('0',3X,'5. THE NUMBER OF ',A7,
     &   'S IT TAKES THE CHANGE IN THETREND-CYCLE TO SURPASS THE AMOUNT'
     &   ,T99,'M5  = ',F5.3,/,6X,
     &   ' OF CHANGE IN THE IRREGULAR (FROM TABLE F 2.D).',/)
      WRITE(Np,1090)Qu(6)
 1090 FORMAT('0',3X,
     &'6. THE AMOUNT OF YEAR TO YEAR CHANGE IN THE IRREGULAR AS COMPARED
     & TO THE AMOUNT OF YEAR',T99,'M6  = ',F5.3,/,7X,
     &'TO YEAR CHANGE IN THE SEASONAL (FROM TABLE F 2.G).',/)
      WRITE(Np,1100)Qu(7)
 1100 FORMAT('0',3X,
     &'7. THE AMOUNT OF MOVING SEASONALITY PRESENT RELATIVE TO THE AMOUN
     &T OF STABLE',T99,'M7  = ',F5.3,/,7X,
     &'SEASONALITY (FROM TABLE F 2.H).',/)
      IF(Nn.gt.7)THEN
       WRITE(Np,1110)Qu(8)
 1110  FORMAT('0',3X,
     &'8. THE SIZE OF THE FLUCTUATIONS IN THE SEASONAL COMPONENT THROUGH
     &OUT THE WHOLE SERIES.',T99,'M8  = ',F5.3,//)
       WRITE(Np,1120)Qu(9)
 1120  FORMAT('0',3X,
     &'9. THE AVERAGE LINEAR MOVEMENT IN THE SEASONAL COMPONENT THROUGHO
     &UT THE WHOLE SERIES.',T99,'M9  = ',F5.3,//)
       WRITE(Np,1130)Qu(10)
 1130  FORMAT('0',2X,'10. SAME AS 8, CALCULATED FOR RECENT YEARS ',
     &        'ONLY.',T99,'M10 = ',F5.3,//)
       WRITE(Np,1140)Qu(11)
 1140  FORMAT('0',2X,'11. SAME AS 9, CALCULATED FOR RECENT YEARS ONLY .'
     &        ,T99,'M11 = ',F5.3)
      END IF
      IF(Qual.lt.0.8)WRITE(Np,1150)Qual
      IF(Qual.lt.1.0.and.Qual.ge.0.8)WRITE(Np,1160)Qual
      IF(Qual.lt.1.2.and.Qual.ge.1.0)WRITE(Np,1170)Qual
      IF(Qual.gt.1.2)WRITE(Np,1180)Qual
 1150 FORMAT('0',/,42X,'*** ACCEPTED *** AT THE LEVEL  ',F5.2)
 1160 FORMAT('0',/,28X,'*** CONDITIONALLY ACCEPTED *** AT THE LEVEL  ',
     &       F5.2)
 1170 FORMAT('0',/,28X,'*** CONDITIONALLY REJECTED *** AT THE LEVEL ',
     &       F5.2)
 1180 FORMAT('0',/,42X,'*** REJECTED *** AT THE LEVEL ',F5.2)
      IF(Kfail.gt.0)THEN
       WRITE(Np,1190)Kfail
 1190  FORMAT(/,42X,'*** CHECK THE ',I2,' ABOVE MEASURES WHICH ',
     &        'FAILED.')
      END IF
      RETURN
      END
**==totals.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      DOUBLE PRECISION FUNCTION totals(X,I,J,K,Iopt)
C --- THIS FUNCTION CALCULATES TOTALS AND AVERAGES. A TOTAL IS RETURNED
C --- IF IOPT IS ZERO AND AN AVERAGE IF IOPT IS ONE.
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION fn,X
      INTEGER I,Iopt,J,K,l
C*** End of declarations inserted by SPAG
      DIMENSION X(*)
      totals=0.0
      DO l=I,J,K
       totals=totals+X(l)
      END DO
      IF(Iopt.ne.0)THEN
       fn=(J-I)/K+1
       totals=totals/fn
      END IF
      RETURN
      END
**==divsub.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE divsub(Result,Array1,Array2,Jfda,Jlda)
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.
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      DOUBLE PRECISION Array1,Array2,Result
      INTEGER i,Jfda,Jlda,Muladd
C*** End of declarations inserted by SPAG
      DIMENSION Result(*),Array1(*),Array2(*)
      COMMON /cj    / Muladd
      IF(Muladd.eq.0)THEN
       DO i=Jfda,Jlda
        Result(i)=Array1(i)/Array2(i)
       END DO
      ELSE
       DO i=Jfda,Jlda
        Result(i)=Array1(i)-Array2(i)
       END DO
      END IF
      RETURN
      END
**==ssap.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
 
      SUBROUTINE ssap(Title)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL c,dmax,S,Sa,Td,yy
      INTEGER i1,i2,Ibreak,Im,iobs,Irang,Itd,Iyr,Kpage,l,l0,Len,Len2,
     &        length,Lobs,Lyr,Muladd,n2,n48,Ncol
      INTEGER Nlen,Np,Ns1,Nsea,nyears,nyearz
C*** End of declarations inserted by SPAG
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  *****
      DIMENSION yy(180,4),c(180,4),dmax(180,5)
      INTEGER Y,Period
      CHARACTER*1 fc(3),Ch
      CHARACTER*6 Lser
      CHARACTER*9 Cpmon
      CHARACTER*14 Chper
      CHARACTER*24 Cname
      CHARACTER*35 F2
      CHARACTER*50 F1
      CHARACTER*80 Title
      COMMON /chame / Cname(5),Ch(5),Chper(2),Cpmon(12)
      COMMON /cj    / Muladd
      COMMON /com4  / Y(8),Period(8)
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /cz    / Kpage,Np,Lser
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /mform / F1,F2
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      COMMON /sser  / S(180,4),Td(180,4),Sa(180,4)
      DATA fc/'2','3','4'/
      Nsea=12
      CALL header(Title)
      CALL ssftst(Ncol)
      l=Im+(Iyr*Nsea)+Nlen-1
      Lobs=mod(l,Nsea)
      IF(Lobs.eq.0)THEN
       Lobs=Nsea
       Lyr=(l/Nsea)-1
      ELSE
       Lyr=l/Nsea
      END IF
      nyears=Lyr-Iyr+1
      Len2=Len-Nsea+1
      Ns1=Ncol+1
      nyearz=nyears+Ncol-3
      iobs=Im+Nsea-1
      WRITE(Np,1010)Title,Kpage,Lser
 1010 FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
      Kpage=Kpage+1
      IF(Muladd.eq.0)THEN
       WRITE(Np,1020)Lser
 1020  FORMAT(//,' S 1.  RANGE ANALYSIS OF SEASONAL FACTORS FOR ',A6,//,
     &        9X,'MEANS OF SEASONAL FACTORS FOR EACH MONTH',/,9X,
     &        '(MOVEMENTS WITHIN A MONTH SHOULD BE SMALL)')
      ELSE
       WRITE(Np,1030)Lser
 1030  FORMAT(//,' S 1.  RANGE ANALYSIS OF IMPLIED ADJUSTMENT ',
     &        'FACTORS FOR ',A6,//,9X,'MEANS OF IMPLIED ADJUSTMENT ',
     &        'FACTORS FOR EACH MONTH',/,9X,'(MOVEMENTS WITHIN A ',
     &        'MONTH SHOULD BE SMALL)')
      END IF
      CALL range(S,Cpmon)
      IF(Muladd.eq.0)THEN
       CALL btab(S,1,0,iobs,nyearz,dmax,Title)
       IF(Itd.eq.1)THEN
        CALL btab(Td,2,0,iobs,nyearz,dmax,Title)
        CALL btab(Sa,3,0,iobs,nyearz,dmax,Title)
       END IF
      ELSE
       CALL btab(Sa,3,0,iobs,nyearz,dmax,Title)
      END IF
      CALL xchng(Sa,c,yy,nyears)
      iobs=iobs+1
      CALL btab(c,4,1,iobs,nyearz,dmax,Title)
      iobs=iobs+Nsea-1
      CALL btab(yy,5,2,iobs,nyearz,dmax,Title)
      IF(Ibreak.eq.0)THEN
       DO l=1,Ncol
        i1=l
        i2=l+Ncol
        Y(i1)=Iyr+l-1
        Y(i2)=Lyr+l-1
        Period(i1)=Im
        Period(i2)=Lobs
       END DO
       n2=Ncol*2
       length=Len-Im+1
       n48=(length/48)+1
       IF(mod(length,48).eq.0)n48=n48-1
       l0=Ncol-1
       F1(17:17)=fc(l0)
       F2(6:6)=fc(l0)
       IF(Muladd.eq.0)THEN
        CALL mlist(S,1,0,dmax,n2,n48,Title)
        IF(Itd.eq.1)THEN
         CALL mlist(Td,2,0,dmax,n2,n48,Title)
         CALL mlist(Sa,3,0,dmax,n2,n48,Title)
        END IF
       ELSE
        CALL mlist(Sa,3,0,dmax,n2,n48,Title)
       END IF
       CALL mlist(c,4,1,dmax,n2,n48,Title)
       CALL mlist(yy,5,2,dmax,n2,n48,Title)
      END IF
      RETURN
      END
**==btab.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE btab(X,Icol,Ic2,Imn,Nyearz,Dmax,Title)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Dmax,X
      INTEGER Ibreak,Ic2,Icol,Imn,Irang,Itd,Kpage,Len,Len2,Ncol,Nlen,Np,
     &        Ns1,Nyearz
C*** End of declarations inserted by SPAG
C  *****
C  *****  THIS SUBROUTINE IS CALLED FOR EACH SEASONALLY ADJUSTED
C  *****  ESTIMATE (SEASONAL FACTORS, MONTH-TO-MONTH CHANGES, ETC.).
C  *****  CALLS OTHER SUBROUTINES WHICH DETERMINE WHICH OBSERVATIONS ARE
C  *****  FLAGGED AS EXTREME, PRINTS OUT BREAKDOWN TABLE, CALCULATE AND
C  *****  PRINT OUT SLIDING SPANS HISTOGRAM, AND CALCULATE AND PRINT OUT
C  *****  HINGE VALUES. PRINTS HEADING ON TOP OF PAGE.
C  *****
      DIMENSION Dmax(180,5),X(180,4)
      CHARACTER*6 Lser
      CHARACTER*80 Title
      COMMON /cz    / Kpage,Np,Lser
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      IF(Irang.eq.0)WRITE(Np,1010)Title,Kpage,Lser
 1010 FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
      Kpage=Kpage+1
      CALL mflag(X,Icol,Ic2,Imn,Dmax)
      CALL calca(Icol,Ic2)
      IF(Irang.eq.1)RETURN
      CALL btrit(Nyearz,Icol,Ic2)
      CALL hinge(Dmax,Len2,Icol,Ic2)
      RETURN
      END
**==mflag.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE mflag(X,Iopt,Iop2,Km,Dmax)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Aobs,Ayr,Cut,Dmax,Ten,X
      INTEGER i,Im,Iop2,Iopt,Iscf,Isign,Itf,Itot,Iturn,Iyr,j,k,Km,Kount,
     &        Len,Len2,Lobs,Lyr,Ncol,Nlen
      INTEGER Nobs,Ns1,Nsea,Ntot,Nyr
C*** End of declarations inserted by SPAG
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  *****
      DIMENSION X(180,4),Dmax(180,5)
      CHARACTER*1 Csign,Cturn
      CHARACTER*4 Per
      COMMON /ave   / Aobs(12),Ayr(15)
      COMMON /com1  / Isign,Iscf,Iturn,Itf,Itot
      COMMON /com1c / Csign(180,5),Per(180,5),Cturn(180,5)
      COMMON /com3  / Nobs(12),Nyr(15),Ntot
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /com5  / Kount(4),Cut(5,4)
      COMMON /ko    / Ten
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      Ntot=0
      Isign=0
      Iscf=0
      Iturn=0
      Itf=0
      DO j=1,15
       Nyr(j)=0
       Ayr(j)=0.
      END DO
      DO j=1,Nsea
       Nobs(j)=0
       Aobs(j)=0.
      END DO
      DO k=1,4
       Kount(k)=0
      END DO
      DO i=1,Len
       Per(i,Iopt)='    '
       Csign(i,Iopt)=' '
       Cturn(i,Iopt)=' '
       IF(i.le.Km.or.i.ge.Len2)THEN
        Dmax(i,Iopt)=Ten
       ELSE
        CALL rplus(X,i,Iopt,Iop2,Dmax(i,Iopt))
       END IF
      END DO
      DO k=1,3
       Kount(k)=Kount(k)-Kount(k+1)
      END DO
      RETURN
      END
**==rplus.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE rplus(X,I,Nopt,Nop2,R)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Aobs,Ayr,Cut,R,Ten,X,xbase,xj,xmn,xmx
      INTEGER I,ibase,Ic,Icm,Icyr,ij,Im,Iscf,Isign,Itf,Itot,ittot,Iturn,
     &        iy,Iyr,j,jay,jay2,jay3,jbase,jbase1
      INTEGER k,Kount,Len,Len2,Lobs,Lyr,mon,Ncol,Nlen,Nobs,Nop2,Nopt,
     &        Ns1,Nsea,Ntot,Nyr
C*** End of declarations inserted by SPAG
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  *****
      DIMENSION X(180,4)
      LOGICAL chnge
      CHARACTER*1 Ch,Csign,Cturn
      CHARACTER*4 Per,temp
      CHARACTER*9 Cpmon
      CHARACTER*14 Chper
      CHARACTER*24 Cname
      COMMON /ave   / Aobs(12),Ayr(15)
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /chame / Cname(5),Ch(5),Chper(2),Cpmon(12)
      COMMON /com1  / Isign,Iscf,Iturn,Itf,Itot
      COMMON /com1c / Csign(180,5),Per(180,5),Cturn(180,5)
      COMMON /com3  / Nobs(12),Nyr(15),Ntot
      COMMON /com5  / Kount(4),Cut(5,4)
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /ko    / Ten
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      mon=mod(I,Nsea)
      IF(mon.eq.0)mon=Nsea
      iy=(I-1)/Nsea
      j=1
      DO WHILE (X(I,j).eq.Ten)
       j=j+1
      END DO
      jay=j
      xmx=X(I,j)
      xmn=X(I,j)
      DO WHILE (.true.)
       j=j+1
       IF(j.gt.Ncol.or.X(I,j).eq.Ten)THEN
        temp='    '
        jay2=j-1
        R=xmx-xmn
        IF(Nop2.eq.0)R=(R/abs(xmn))*100.0
        IF(I.lt.Ic)THEN
         Per(I,Nopt)=' -- '
         RETURN
        END IF
        IF(R.ge.Cut(Nopt,1))THEN
         DO k=1,4
          IF(R.ge.Cut(Nopt,k))THEN
           temp(k:k)=Ch(Nopt)
           Kount(k)=Kount(k)+1
          END IF
         END DO
         Per(I,Nopt)=temp
         Nobs(mon)=Nobs(mon)+1
         Nyr(iy)=Nyr(iy)+1
         Ntot=Ntot+1
        END IF
        Aobs(mon)=Aobs(mon)+R
        Ayr(iy)=Ayr(iy)+R
        Csign(I,Nopt)=' '
        IF(Nopt.eq.3)GO TO 10
        j=jay
        jbase=0
        xbase=100.
        IF(Nop2.gt.0)xbase=0.
        DO WHILE (.true.)
         IF(X(I,j).eq.xbase)THEN
          ibase=0
         ELSE IF(X(I,j).lt.xbase)THEN
          ibase=-1
         ELSE
          ibase=1
         END IF
         IF(jbase.eq.0)THEN
          jbase=ibase
         ELSE
          ij=ibase+jbase
          IF(ij.eq.0)THEN
           Isign=Isign+1
           Csign(I,Nopt)='*'
           RETURN
          END IF
         END IF
         j=j+1
         IF(j.gt.Ncol.or.X(I,j).eq.Ten)GO TO 10
        END DO
       ELSE
        IF(xmx.lt.X(I,j))xmx=X(I,j)
        IF(xmn.gt.X(I,j))xmn=X(I,j)
       END IF
      END DO
   10 IF(Ncol.eq.2)RETURN
      jay3=jay2-jay+1
      Cturn(I,Nopt)=' '
      IF(jay3.lt.3)RETURN
      ibase=0
      jbase=0
      chnge=.false.
      ittot=ittot+1
      DO j=jay+1,jay2
c-----------------------------------------------------------------------
c     Check to see if observation I has already been flagged as a 
c     turning point.
c-----------------------------------------------------------------------
       IF(Cturn(I,Nopt).eq.' ')THEN
c-----------------------------------------------------------------------
c     Compute change between adjoining spans.  Check to see if the
c     change is greater than one percent
c-----------------------------------------------------------------------
        xj=X(I,j)-X(I,j-1)
        IF(Nop2.eq.0)xj=(xj/X(I,j-1))*100.0
        IF(xj.gt.1.0)chnge=.true.
c-----------------------------------------------------------------------
c     set ibase to be 1 if the change of direction is up, -1 if it
c     is down
c-----------------------------------------------------------------------
        IF(xj.lt.0)ibase=-1
        IF(xj.gt.0)ibase=1
c-----------------------------------------------------------------------
c     If 4 sliding spans, save direction of first change
c-----------------------------------------------------------------------
        IF(jay3.eq.4.and.j.eq.2)jbase1=ibase
        IF(jbase.eq.0)THEN
c-----------------------------------------------------------------------
c     If jbase hasn't been set yet, set jbase to be the direction of the
c     current change
c-----------------------------------------------------------------------
         jbase=ibase
        ELSE IF(ibase.ne.jbase)THEN
c-----------------------------------------------------------------------
c     If direction has changed, test to see if the current change is 
c     greater than one percent.
c-----------------------------------------------------------------------
         IF(abs(xj).gt.1)THEN
c-----------------------------------------------------------------------
c     If so, declare a turning point
c-----------------------------------------------------------------------
          Iturn=Iturn+1
          Cturn(I,Nopt)='^'
         ELSE
c-----------------------------------------------------------------------
c     If not, update the direction indicator variable jbase
c-----------------------------------------------------------------------
          jbase=ibase
         END IF
        ELSE IF(jay3.eq.4.and.j.eq.4)THEN
c-----------------------------------------------------------------------
c     If there is no change in direction for the last span, determine
c     the direction of the change from the second to the fourth span.
c-----------------------------------------------------------------------
         xj=X(I,j)-X(I,j-2)
         IF(xj.lt.0)ibase=-1
         IF(xj.gt.0)ibase=1
c-----------------------------------------------------------------------
c     If the direction of this change is different than that of the 
c     first two spans, test to see if this change is greater than one
c     percent.
c-----------------------------------------------------------------------
         IF(ibase.ne.jbase1)THEN
          IF(Nop2.eq.0)xj=(xj/X(I,j-2))*100.0
          IF(abs(xj).gt.1.and.chnge)THEN
c-----------------------------------------------------------------------
c     If so, declare a turning point, if at least one of the individal
c     changes is greater than one percent.
c-----------------------------------------------------------------------
           Iturn=Iturn+1
           Cturn(I,Nopt)='^'
          END IF
         END IF
        END IF
       END IF
      END DO
      RETURN
      END
**==calca.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE calca(I,I2)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Aobs,Ayr
      INTEGER I,I2,Ic,Icm,Icyr,Im,Iscf,Isign,Itf,Itot,Iturn,Iyr,j,j1,
     &        jlpyr,jt,jyt,Len,Len2,Lobs
      INTEGER Lyr,mj4,Ncol,Nlen,Ns1,Nsea,nt
C*** End of declarations inserted by SPAG
C  *****
C  *****  COMPUTES MONTHLY (AOBS) AND YEARLY (AYR) AVERAGES OF THE
C  *****  MAXIMUM PERCENTAGE DIFFERENCE, AND DETERMINES NUMBER OF
C  *****  OBSERVATIONS TESTED (ITOT).  DETERMINES NUMBER OF OBSERVATIONS
C  *****  WITH CHANGES IN DIRECTION WHICH WERE FLAGGED AS EXTREME (ISCF)
C  *****
      INTEGER t1,t2
      CHARACTER*4 Per
      CHARACTER*1 Csign,Cturn
      COMMON /ave   / Aobs(12),Ayr(15)
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /com1  / Isign,Iscf,Iturn,Itf,Itot
      COMMON /com1c / Csign(180,5),Per(180,5),Cturn(180,5)
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      jlpyr=0
      Iscf=0
      t1=Icyr
      t2=Lyr+Ncol-2
      IF(Icyr.eq.Iyr)t1=t1+1
      IF(I2.eq.2.and.(Im+Nsea).gt.Ic)t1=t1+1
      DO j=t1,t2
       mj4=mod(j,4)
       jt=j-Iyr
       nt=Nsea
       IF(j.eq.t1)THEN
        nt=Nsea-Icm+1
        IF(I2.eq.1)nt=nt-1
        IF(Icm.le.2.and.I.eq.2.and.mj4.ne.0)THEN
         nt=nt-1
         jlpyr=jlpyr+1
        END IF
       ELSE IF(j.eq.t2)THEN
        nt=Lobs
        IF(Lobs.ge.2.and.I.eq.2.and.mj4.ne.0)THEN
         nt=nt-1
         jlpyr=jlpyr+1
        END IF
       ELSE IF(I.eq.2.and.mj4.ne.0)THEN
        nt=nt-1
        jlpyr=jlpyr+1
       END IF
       IF(nt.gt.0)Ayr(jt)=Ayr(jt)/nt
       IF(nt.eq.0)Ayr(jt)=0.
      END DO
      jyt=t2-t1+1
      Itot=0
      DO j=1,Nsea
       nt=jyt
       IF(j.lt.Icm)nt=nt-1
       IF(j.gt.Lobs)nt=nt-1
       IF(I2.eq.1.and.j.eq.1.and.Im.eq.Ic)nt=nt-1
       IF(I.eq.2.and.j.eq.2)nt=nt-jlpyr
       Aobs(j)=Aobs(j)/nt
       Itot=Itot+nt
      END DO
      j1=Nsea+1
      IF(I2.eq.2)j1=j1+Nsea
      DO j=j1,Len2
       IF(Per(j,I).ne.'    '.and.Csign(j,I).eq.'*'.and.I.ne.3)
     &    Iscf=Iscf+1
       IF(Per(j,I).ne.'    '.and.Cturn(j,I).eq.'^')Itf=Itf+1
      END DO
      RETURN
      END
**==btrit.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE btrit(Nyearz,Nopt,No2)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Aobs,Ayr,Cut,fper
      INTEGER i,Ic,Icm,Icyr,ij,Im,Iscf,Isign,Itf,Itot,Iturn,iy,Iyr,j,j1,
     &        Kount,Kpage,Lobs,Lyr,n1
      INTEGER No2,Nobs,Nopt,Np,Nsea,Ntot,Nyearz,Nyr
C*** End of declarations inserted by SPAG
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  *****
      CHARACTER*1 Ch
      CHARACTER*4 c
      CHARACTER*6 Lser
      CHARACTER*9 Cpmon
      CHARACTER*14 Chper
      CHARACTER*24 Cname
      COMMON /ave   / Aobs(12),Ayr(15)
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /chame / Cname(5),Ch(5),Chper(2),Cpmon(12)
      COMMON /com1  / Isign,Iscf,Iturn,Itf,Itot
      COMMON /com3  / Nobs(12),Nyr(15),Ntot
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /com5  / Kount(4),Cut(5,4)
      COMMON /cz    / Kpage,Np,Lser
      fper=(real(Ntot)/real(Itot))*100.
      n1=Nopt+1
      IF(No2.eq.0)WRITE(Np,1020)n1,Cut(Nopt,1),Cname(Nopt),Lser
      IF(No2.gt.0)WRITE(Np,1030)n1,Cut(Nopt,1),Chper(No2),Cname(Nopt),
     &                          Lser
      WRITE(Np,1040)Ntot,Itot,fper
      IF(Nopt.eq.1)WRITE(Np,1050)
      IF(Nopt.eq.4)WRITE(Np,1060)
      IF(Nopt.eq.5)WRITE(Np,1070)
      WRITE(Np,1080)
      j1=0
      IF(Nsea.eq.4)j1=12
      DO j=1,Nsea
       WRITE(Np,1090)Cpmon(j+j1),Nobs(j),Aobs(j)
      END DO
      WRITE(Np,1080)
      ij=Icyr-Iyr+1
      IF(Icyr.eq.Iyr)THEN
       IF(No2.eq.2)ij=ij+1
       IF(No2.eq.1.and.Im.eq.Nsea)ij=ij+1
      END IF
      DO j=ij,Nyearz
       iy=Iyr+j
       WRITE(Np,1100)iy,Nyr(j),Ayr(j)
      END DO
      WRITE(Np,1110)
      CALL prst(Nopt,0)
C  *****
C  *****  PRINTS OUT SLIDING SPANS HISTOGRAM.
C  *****
      c='    '
      IF(No2.eq.0)WRITE(Np,1120)n1,Cname(Nopt)
      IF(No2.gt.0)WRITE(Np,1130)n1,Chper(No2),Cname(Nopt)
      DO i=1,3
       c(i:i)=Ch(Nopt)
       WRITE(Np,1140)c,Cut(Nopt,i),Cut(Nopt,i+1),Kount(i)
      END DO
      c(4:4)=Ch(Nopt)
      WRITE(Np,1010)c,Cut(Nopt,4),Kount(4)
 1010 FORMAT('  ',A4,' : GREATER THAN OR EQUAL TO ',F4.1,'%',T61,':',1X,
     &       I3)
 1020 FORMAT(' S ',I1,'.A  BREAKDOWN OF ',F3.1,' PERCENT OR MORE ',
     &       'DIFFERENCES IN ',A24,' FOR ',A6,/)
 1030 FORMAT(' S ',I1,'.A  BREAKDOWN OF ',F3.1,' PERCENT OR MORE ',
     &       'DIFFERENCES IN ',A14,1X,A24,' FOR ',A6,/)
 1040 FORMAT(2X,'TOTAL : ',I3,' OUT OF ',I3,' (',F5.1,' %)')
 1050 FORMAT(2X,'(USUALLY, 15% IS TOO HIGH, AND 25% IS MUCH TOO HIGH)')
 1060 FORMAT(2X,'(USUALLY, 35% IS TOO HIGH, AND 40% IS MUCH TOO HIGH)')
 1070 FORMAT(2X,'(USUALLY, 10% IS TOO HIGH)')
 1080 FORMAT(/)
 1090 FORMAT(10X,A9,' : ',I3,5X,'(AMPD = ',F5.1,')')
 1100 FORMAT(10X,I4,5X,' : ',I3,5X,'(AMPD = ',F5.1,')')
 1110 FORMAT(/,'  AMPD = AVERAGE MAXIMUM PERCENTAGE DIFFERENCE')
 1120 FORMAT(/,' S ',I1,'.B  HISTOGRAM OF MAXIMUM PERCENTAGE ',
     &       'DIFFERENCE IN ',A24,' FOR FLAGGED MONTHS',/)
 1130 FORMAT(/,' S ',I1,'.B  HISTOGRAM OF MAXIMUM PERCENTAGE ',
     &       'DIFFERENCE IN ',A14,1X,A24,' FOR FLAGGED MONTHS',/)
 1140 FORMAT('  ',A4,' : GREATER THAN OR EQUAL TO ',F4.1,'% BUT LESS ',
     &       'THAN ',F4.1,'% :',1X,I3)
      RETURN
      END
**==hinge.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE hinge(Dmax,Len2,Nopt,No2)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Dmax,temp,Ten,ts,ts65,ts85,xo
      INTEGER i,Ibreak,Ic,Icm,Icyr,Im,Irang,it,Itd,Iyr,Kpage,l2,l65,l85,
     &        Len2,Lobs,Lyr,n,n1,n2
      INTEGER n3,No2,Nopt,Np,Nsea
C*** End of declarations inserted by SPAG
C  *****
C  *****  CALCULATES AND PRINTS OUT HINGE VALUES FOR THE MAXIMUM
C  *****  PERCENTAGE DIFFERENCE (TS).  INCLUDES THE 65TH (TS65) AND
C  *****  85TH (TS85) PERCENTILES.
C  *****
      DIMENSION Dmax(180,5),ts(5),xo(180),temp(180)
      CHARACTER*1 Ch
      CHARACTER*6 Lser
      CHARACTER*9 Cpmon
      CHARACTER*14 Chper
      CHARACTER*24 Lab
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /chame / Lab(5),Ch(5),Chper(2),Cpmon(12)
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /cz    / Kpage,Np,Lser
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /ko    / Ten
      l2=Len2-1
      it=0
      DO i=Ic,l2
       IF(Dmax(i,Nopt).eq.Ten)THEN
        it=it+1
       ELSE IF(mod(i,Nsea).eq.2.and.Nopt.eq.2.and.Dmax(i,Nopt).eq.0)THEN
        it=it+1
       ELSE
        n=i-it-Ic+1
        xo(n)=Dmax(i,Nopt)
       END IF
      END DO
      CALL ssort(xo,temp,n,1)
      ts(1)=xo(1)
      ts(5)=xo(n)
      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
      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
      l85=n-int(real(n)*0.15+0.5)
      ts85=xo(l85)
      l65=n-int(real(n)*0.35+0.5)
      ts65=xo(l65)
      n1=Nopt+1
      IF(Irang.eq.1)THEN
       IF(No2.eq.0)WRITE(Np,1010)Lab(Nopt)
       IF(No2.gt.0)WRITE(Np,1020)Chper(No2),Lab(Nopt)
      ELSE
       IF(No2.eq.0)WRITE(Np,1030)n1,Lab(Nopt)
       IF(No2.gt.0)WRITE(Np,1040)n1,Chper(No2),Lab(Nopt)
      END IF
 1010 FORMAT(/,5X,'STATISTICS FOR MAXIMUM PERCENTAGE DIFFERENCE OF ',
     &       'THE ',A24,/)
 1020 FORMAT(/,5X,'STATISTICS FOR MAXIMUM PERCENTAGE DIFFERENCE OF ',
     &       'THE ',A14,1X,A24,/)
 1030 FORMAT(/,' S ',I1,'.C  STATISTICS FOR MAXIMUM PERCENTAGE ',
     &       'DIFFERENCE OF THE ',A24,/)
 1040 FORMAT(/,' S ',I1,'.C  STATISTICS FOR MAXIMUM PERCENTAGE ',
     &       'DIFFERENCE OF THE ',A14,1X,A24,/)
      WRITE(Np,1050)(ts(i),i=1,3),ts65,ts(4),ts85,ts(5)
 1050 FORMAT(5X,'MINIMUM',T22,': ',F10.3,/,5X,'25TH PERCENTILE',T22,
     &       ': ',F10.3,/,5X,'MEDIAN',T22,': ',F10.3,/,3X,
     &       '->65TH PERCENTILE',T22,': ',F10.3,'<-',/,5X,
     &       '75TH PERCENTILE',T22,': ',F10.3,/,3X,'->85TH PERCENTILE',
     &       T22,': ',F10.3,'<-',/,5X,'MAXIMUM',T22,': ',F10.3)
      RETURN
      END
**==ssort.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE ssort(X,Y,N,Kflag)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,ij,il,iu,j,k,Kflag,kk,l,m,N,nn
      REAL r,t,tt,tty,ty,X,Y
C*** End of declarations inserted by SPAG
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
      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
      GO TO(10,80),kk
C
C SORT X ONLY
C
   10 m=1
      i=1
      j=nn
      r=.375
   20 IF(i.eq.j)GO TO 50
      IF(r.gt..5898437)THEN
       r=r-.21875
      ELSE
       r=r+3.90625E-2
      END IF
   30 k=i
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION T
      ij=i+ifix(float(j-i)*r)
      t=X(ij)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF(X(i).gt.t)THEN
       X(ij)=X(i)
       X(i)=t
       t=X(ij)
      END IF
      l=j
C                                  IF LAST ELEMENT OF ARRAY IS LESS THAN
C                                  T, INTERCHANGE WITH T
      IF(X(j).lt.t)THEN
       X(ij)=X(j)
       X(j)=t
       t=X(ij)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
       IF(X(i).gt.t)THEN
        X(ij)=X(i)
        X(i)=t
        t=X(ij)
       END IF
      END IF
      DO WHILE (.true.)
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN T
       l=l-1
       IF(X(l).le.t)THEN
        DO WHILE (.true.)
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN T
         k=k+1
         IF(X(k).ge.t)THEN
C                                  INTERCHANGE THESE ELEMENTS
          IF(k.le.l)THEN
           tt=X(l)
           X(l)=X(k)
           X(k)=tt
           GO TO 40
          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 60
          END IF
         END IF
        END DO
       END IF
   40 END DO
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
   50 m=m-1
      IF(m.eq.0)GO TO 150
      i=il(m)
      j=iu(m)
   60 IF(j-i.ge.1)GO TO 30
      IF(i.eq.1)GO TO 20
      i=i-1
      DO WHILE (.true.)
       i=i+1
       IF(i.eq.j)GO TO 50
       t=X(i+1)
       IF(X(i).gt.t)THEN
        k=i
        DO WHILE (.true.)
         X(k+1)=X(k)
         k=k-1
         IF(t.ge.X(k))THEN
          X(k+1)=t
          GO TO 70
         END IF
        END DO
       END IF
   70 END DO
C
C SORT X AND CARRY Y ALONG
C
   80 m=1
      i=1
      j=nn
      r=.375
   90 IF(i.eq.j)GO TO 120
      IF(r.gt..5898437)THEN
       r=r-.21875
      ELSE
       r=r+3.90625E-2
      END IF
  100 k=i
C                                  SELECT A CENTRAL ELEMENT OF THE
C                                  ARRAY AND SAVE IT IN LOCATION T
      ij=i+ifix(float(j-i)*r)
      t=X(ij)
      ty=Y(ij)
C                                  IF FIRST ELEMENT OF ARRAY IS GREATER
C                                  THAN T, INTERCHANGE WITH T
      IF(X(i).gt.t)THEN
       X(ij)=X(i)
       X(i)=t
       t=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.t)THEN
       X(ij)=X(j)
       X(j)=t
       t=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.t)THEN
        X(ij)=X(i)
        X(i)=t
        t=X(ij)
        Y(ij)=Y(i)
        Y(i)=ty
        ty=Y(ij)
       END IF
      END IF
      DO WHILE (.true.)
C                                  FIND AN ELEMENT IN THE SECOND HALF OF
C                                  THE ARRAY WHICH IS SMALLER THAN T
       l=l-1
       IF(X(l).le.t)THEN
        DO WHILE (.true.)
C                                  FIND AN ELEMENT IN THE FIRST HALF OF
C                                  THE ARRAY WHICH IS GREATER THAN T
         k=k+1
         IF(X(k).ge.t)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 110
          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 130
          END IF
         END IF
        END DO
       END IF
  110 END DO
C                                  BEGIN AGAIN ON ANOTHER PORTION OF
C                                  THE UNSORTED ARRAY
  120 m=m-1
      IF(m.eq.0)GO TO 150
      i=il(m)
      j=iu(m)
  130 IF(j-i.ge.1)GO TO 100
      IF(i.eq.1)GO TO 90
      i=i-1
      DO WHILE (.true.)
       i=i+1
       IF(i.eq.j)GO TO 120
       t=X(i+1)
       ty=Y(i+1)
       IF(X(i).gt.t)THEN
        k=i
        DO WHILE (.true.)
         X(k+1)=X(k)
         Y(k+1)=Y(k)
         k=k-1
         IF(t.ge.X(k))THEN
          X(k+1)=t
          Y(k+1)=ty
          GO TO 140
         END IF
        END DO
       END IF
  140 END DO
C
C CLEAN UP
C
  150 IF(Kflag.ge.1)RETURN
      DO i=1,nn
       X(i)=-X(i)
      END DO
      RETURN
      END
**==mlist.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE mlist(X,Nopt,Nop2,Dmax,N2,N48,Title)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL Dmax,X
      INTEGER i,Ibreak,Ic,Icm,Icyr,Im,Irang,Itd,iy,Iyr,Kpage,l,l0,l1,l2,
     &        Len,Len2,Lobs,Lyr,m
      INTEGER N2,N48,Ncol,Nlen,Nop2,Nopt,Np,Ns1,Nsea
C*** End of declarations inserted by SPAG
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  *****
      DIMENSION X(180,4),Dmax(180,5)
      INTEGER Y,Period
      CHARACTER*1 dash(3),Csign,Ch,cpart(5),Cturn
      CHARACTER*4 Per
      CHARACTER*7 f(2)
      CHARACTER*9 Cpmon
      CHARACTER*14 Chper
      CHARACTER*24 Cname
      CHARACTER*50 F1
      CHARACTER*35 F2
      CHARACTER*6 Lser
      CHARACTER*80 Title
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /com1c / Csign(180,5),Per(180,5),Cturn(180,5)
      COMMON /com4  / Y(8),Period(8)
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /chame / Cname(5),Ch(5),Chper(2),Cpmon(12)
      COMMON /cz    / Kpage,Np,Lser
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /mform / F1,F2
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      DATA dash/'-','/',' '/
      DATA f/'MAXIMUM','% DIFF.'/
      DATA cpart/'A','B','C','D','E'/
      iy=Iyr
      m=Im-1
      DO l0=1,N48
       l1=(l0-1)*48+Im
       l2=l0*48+Im-1
       IF(l0.eq.N48)l2=Len
       WRITE(Np,1010)Title,Kpage,Lser
 1010  FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
       Kpage=Kpage+1
       IF(Nop2.eq.0)THEN
        WRITE(Np,1020)cpart(Nopt),Cname(Nopt),Lser
 1020   FORMAT(' S 7.',A1,'  SLIDING SPANS ANALYSIS OF ',A24,' FOR ',A6)
       ELSE
        WRITE(Np,1030)cpart(Nopt),Chper(Nop2),Cname(Nopt),Lser
 1030   FORMAT(' S 7.',A1,'  SLIDING SPANS ANALYSIS OF ',A14,1X,A24,
     &         ' FOR ',A6)
       END IF
       WRITE(Np,1040)
 1040  FORMAT(' ')
       WRITE(Np,F2)(Period(i),dash(2),Y(i),dash(1),i=1,Ncol),f(1)
       WRITE(Np,F2)(Period(i),dash(2),Y(i),dash(3),i=Ncol+1,N2),f(2)
       WRITE(Np,1040)
       DO l=l1,l2
        m=m+1
        IF(m.gt.Nsea)THEN
         m=1
         iy=iy+1
        END IF
        WRITE(Np,F1)m,dash(1),iy,(X(l,i),i=1,Ncol),Csign(l,Nopt),
     &              Cturn(l,Nopt),Dmax(l,Nopt),Per(l,Nopt)
       END DO
      END DO
      IF(Irang.eq.1)THEN
       CALL hinge(Dmax,Len2,Nopt,Nop2)
       CALL prst(Nopt,Irang)
      END IF
      WRITE(Np,1040)
      IF(Nopt.ne.3)WRITE(Np,1050)
      IF(Ncol.gt.2)WRITE(Np,1060)
      IF(Im.ne.Ic)WRITE(Np,1070)
 1050 FORMAT('  * - SIGN CHANGE FOR OBSERVATION OVER ALL SPANS')
 1060 FORMAT('  ^ - TURNING POINT FOR OBSERVATION OVER ALL SPANS')
 1070 FORMAT(' -- - OBSERVATION NOT INCLUDED IN SLIDING SPANS ',
     &       'COMPARISONS')
      RETURN
      END
**==range.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE range(X,Cpmon)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,Ibreak,Ic,Icm,Icyr,Im,Irang,Itd,Iyr,j,jsea,k,Kountr,
     &        Kpage,l,Len,Len2,Lobs,Lyr,m1
      INTEGER Muladd,Ncol,Nlen,Np,Ns1,Nsea
      REAL Ten,X,xavg,xmn,xmnx,xmpd,xmx,xran,xranr
C*** End of declarations inserted by SPAG
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) THE RANGE RATIO (XRANR) FOR MONTHLY MEANS
C  *****  AND SEASONAL FACTORS FOR EACH SPAN AND FOR ALL SPANS.  PRINTS
C  *****  OUT RESULTS.
C  *****
      DIMENSION X(180,4),xavg(5,12),xmnx(5,2),xran(5,2),xranr(5,2)
      DIMENSION xmpd(12)
      CHARACTER*3 Xcm,xc(2)
      CHARACTER*6 clab(6),Lser
      CHARACTER*9 Cpmon(12)
      CHARACTER*46 f1
      CHARACTER*27 f2
      CHARACTER*1 f(3)
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /charx / Xcm(5,12)
      COMMON /cj    / Muladd
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /cz    / Kpage,Np,Lser
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /kcom  / Kountr(4,12)
      COMMON /ko    / Ten
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      DATA xc/' SF','IAF'/
      DATA(f(i),i=1,3)/'2','3','4'/
      DATA(clab(i),i=1,6)/'SPAN 1','SPAN 2','SPAN 3','SPAN 4','  MPD ',
     &     ' TOTAL'/
      DO j=1,Nsea
       DO i=1,5
        IF(i.le.4)Kountr(i,j)=0
        IF(j.le.2)THEN
         xran(i,j)=0.
         xranr(i,j)=0.
         xmnx(i,j)=100.
        END IF
        xavg(i,j)=0.
       END DO
      END DO
      DO i=1,Ncol
       DO j=1,Len
        IF(X(j,i).ne.Ten.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,xranr,i)
      END DO
      CALL compb(xavg,xmnx,xran,xranr,Ns1)
      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)*100.
      END DO
      f1='(2X,A9,3X, (F10.2,2X,A3),F10.2,5X,F10.2,2X,A3)'
      f2='(//,8X, (9X,A6),2(9X,A6),/)'
      f1(11:11)=f(Ncol-1)
      f2(8:8)=f(Ncol-1)
      WRITE(Np,f2)(clab(j),j=1,Ncol),clab(5),clab(6)
      DO k=1,Nsea
       WRITE(Np,f1)Cpmon(k),(xavg(j,k),Xcm(j,k),j=1,Ncol),xmpd(k),
     &             xavg(Ns1,k),Xcm(Ns1,k)
      END DO
      WRITE(Np,1010)Ncol
 1010 FORMAT(/,10X,'MPD = MAXIMUM PERCENT DIFFERENCE = (MAX - MIN) ',
     &       '/ MIN',/,10X,'TOTAL = AVERAGE TAKEN OVER ALL ',I1,
     &       ' SPANS',//,10X,'SUMMARY OF RANGE MEASURES')
      m1=Muladd+1
      WRITE(Np,1020)xc(m1),xc(m1),xc(m1),xc(m1)
 1020 FORMAT(/,20X,'RANGE',9X,'R-R',14X,'MIN',12X,'MAX',11X,'RANGE',9X,
     &       'R-R',/,20X,'MEANS',8X,'MEANS',13X,A3,12X,A3,12X,A3,10X,A3,
     &       /)
      DO k=1,Ncol
       WRITE(Np,1030)k,xran(k,1),xranr(k,1),(xmnx(k,l),l=1,2),xran(k,2),
     &               xranr(k,2)
 1030  FORMAT(4X,'SPAN ',I1,5X,F10.2,5X,F10.4,3(5X,F10.2),5X,F10.4)
      END DO
      WRITE(Np,1040)xran(Ns1,1),xranr(Ns1,1),(xmnx(Ns1,l),l=1,2),
     &              xran(Ns1,2),xranr(Ns1,2)
      WRITE(Np,1050)
      IF(m1.eq.1)WRITE(Np,1060)
      IF(m1.eq.2)WRITE(Np,1070)
 1040 FORMAT(2X,'ALL SPANS',4X,F10.2,5X,F10.4,3(5X,F10.2),5X,F10.4,/)
 1050 FORMAT(10X,'R-R = RANGE RATIO = MAX / MIN')
 1060 FORMAT(10X,'SF = SEASONAL FACTORS')
 1070 FORMAT(10X,'IAF = IMPLIED ADJUSTMENT FACTORS')
      Irang=0
      IF(xran(Ns1,2).lt.10)THEN
       Irang=1
       Ibreak=0
       WRITE(Np,1080)
 1080  FORMAT(/,5X,'WARNING : RANGE OF SEASONAL FACTORS IS TOO LOW ',
     &        'FOR SUMMARY SLIDING SPANS MEASURES TO BE RELIABLE.',/,
     &        15X,'SUMMARY SLIDING SPANS STATISTICS NOT PRINTED OUT')
      END IF
      RETURN
      END
**==compb.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE compb(Xavg,Xmnx,Xran,Xranr,I)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER I,i2,ij,Im,Iyr,j,k,Kountr,Len,Len2,Lobs,Lyr,Ncol,Nlen,Ns1,
     &        Nsea
      REAL Ten,Xavg,xmax,xmin,Xmnx,Xran,Xranr
C*** End of declarations inserted by SPAG
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  *****
      CHARACTER*3 Xcm
      DIMENSION Xavg(5,12),Xmnx(5,2),Xran(5,2),Xranr(5,2)
      COMMON /charx / Xcm(5,12)
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /kcom  / Kountr(4,12)
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      COMMON /ko    / Ten
      Xran(I,2)=Xmnx(I,2)-Xmnx(I,1)
      IF(I.ne.Ns1)THEN
       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)
       DO j=1,Nsea
        Xavg(I,j)=Xavg(I,j)/Kountr(I,j)
       END DO
      ELSE
       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
      END IF
      Xranr(I,2)=Ten
      IF(Xmnx(I,1).ne.0)Xranr(I,2)=abs(Xmnx(I,2)/Xmnx(I,1))
      xmax=100.
      xmin=100.
      ij=1
      DO j=ij,Nsea
       IF(xmin.gt.Xavg(I,j))xmin=Xavg(I,j)
       IF(xmax.lt.Xavg(I,j))xmax=Xavg(I,j)
      END DO
      Xran(I,1)=xmax-xmin
      Xranr(I,1)=Ten
      IF(xmin.ne.0)Xranr(I,1)=abs(xmax/xmin)
      DO j=1,Nsea
       Xcm(I,j)='   '
       IF(xmax.eq.Xavg(I,j))Xcm(I,j)='MAX'
       IF(xmin.eq.Xavg(I,j))Xcm(I,j)='MIN'
      END DO
      RETURN
      END
**==ssrit.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE ssrit(X,L1,L2,Isec,Nl,Stor,Lfda,Lstmo)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER i,i0,icol,Im,Isec,Iyr,L0,L1,l10,L2,l20,la,Len,Len2,Lfda,
     &        ll0,Lobs,Lstmo,Lyr,Muladd
      INTEGER Ncol,Nl,Nlen,Ns1,Nsea
      REAL S,Sa,Td,Ten,xss
C*** End of declarations inserted by SPAG
C  *****
C  *****  STORES RESULTS FROM X-11.2 RUNS INTO SLIDING SPANS VARIABLES.
C  *****  CONVERT RESULTS FROM DOUBLE TO SINGLE PRECISION.
C  *****
      DOUBLE PRECISION X(Nl),Stor(360)
      COMMON /cj    / Muladd
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /ko    / Ten
      COMMON /lzero / L0
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      COMMON /sser  / S(180,4),Td(180,4),Sa(180,4)
      IF(Isec.eq.0)L0=L0+12
      l10=L1-L0
      icol=(l10/Nsea)+1
      IF(l10.ne.0)THEN
       DO i=1,l10
        IF(Isec.le.1)Td(i,icol)=Ten
        IF(Isec.eq.2)S(i,icol)=Ten
        IF(Isec.eq.3)THEN
         Sa(i,icol)=Ten
         IF(Muladd.eq.1)S(i,icol)=Ten
        END IF
       END DO
      END IF
      DO i=L1,L2
       i0=i-L0+1
       xss=sngl(X(i))
       IF(Isec.le.1)Td(i0,icol)=xss
       IF(Isec.eq.2)S(i0,icol)=xss
       IF(Isec.eq.3)THEN
        Sa(i0,icol)=xss
        IF(Muladd.eq.1)S(i0,icol)=(sngl(Stor(i))/xss)*100.0
       END IF
      END DO
      la=mod(Lfda,Nsea)
      IF(la.eq.0)la=Nsea
      ll0=Len+L0-2+la
      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)=Ten
        IF(Isec.eq.2)S(i0,icol)=Ten
        IF(Isec.eq.3)THEN
         Sa(i0,icol)=Ten
         IF(Muladd.eq.1)S(i0,icol)=Ten
        END IF
       END DO
      END IF
      IF(Isec.eq.0)L0=L0-12
      RETURN
      END
**==xchng.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE xchng(X,C,Yy,Nyears)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL C,Ten,X,Yy
      INTEGER i,i1,i2,Im,iten,Iyr,iyy,iyy2,Len,Len2,Lobs,Lyr,Ncol,Nlen,
     &        Ns1,Nsea,Nyears
C*** End of declarations inserted by SPAG
C  *****
C  *****  CALCULATE MONTH-TO-MONTH AND YEAR-TO-YEAR CHANGES OF THE
C  *****  SEASONALLY ADJUSTED DATA
C  *****
      DIMENSION X(180,4),Yy(180,4),C(180,4)
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /ko    / Ten
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      DO i=1,Ncol
       i1=((i-1)*Nsea)+1
       i2=(Nyears+i-1)*Nsea
       IF(i1.ne.1)THEN
        DO iten=1,i1-1
         C(iten,i)=Ten
         Yy(iten,i)=Ten
        END DO
       END IF
       IF(i2.ne.Len)THEN
        DO iten=i2+1,Len
         C(iten,i)=Ten
         Yy(iten,i)=Ten
        END DO
       END IF
       DO iyy=i1,i2
        C(iyy,i)=Ten
        Yy(iyy,i)=Ten
        IF(X(iyy,i).lt.Ten.and.iyy.ge.(i1+1))THEN
         iyy2=iyy-1
         IF(X(iyy2,i).ne.Ten)C(iyy,i)=((X(iyy,i)-X(iyy2,i))/abs(X(iyy2,i
     &                                )))*100.
        END IF
        IF(X(iyy,i).lt.Ten.and.iyy.ge.(i1+Nsea))THEN
         iyy2=iyy-Nsea
         IF(X(iyy2,i).ne.Ten)Yy(iyy,i)=((X(iyy,i)-X(iyy2,i))/abs(X(iyy2,
     &                                 i)))*100.
        END IF
       END DO
      END DO
      RETURN
      END
**==header.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE header(Title)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER Ibreak,Ic,Icm,Icyr,Im,Irang,Itd,Iyr,Kpage,Len,Len2,Lobs,
     &        Lyr,Ncol,Nlen,Np,Ns1,Nsea
C*** End of declarations inserted by SPAG
C  *****
C  *****  PRINTS HEADING THAT IDENTIFIES WHICH OPTIONS ARE BEING USED
C  *****  IN A GIVEN SLIDING SPANS ANALYSIS.
C  *****
      CHARACTER*6 Lser
      CHARACTER*80 Title
      COMMON /cee   / Ic,Icyr,Icm
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /cz    / Kpage,Np,Lser
      COMMON /iopt  / Ibreak,Itd,Irang
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      WRITE(Np,1010)Title,Kpage,Lser
 1010 FORMAT('1',17X,A80,1X,'P.',I2,', SERIES ',A6)
      Kpage=Kpage+1
      WRITE(Np,1020)
 1020 FORMAT(//,'  SLIDING SPANS ANALYSIS',//,
     &       '  S 0.   SUMMARY OF OPTIONS SELECTED FOR THIS RUN',//)
      IF(Ibreak.eq.1)WRITE(Np,1030)
      IF(Ibreak.eq.0)WRITE(Np,1040)
 1030 FORMAT('  PRINT ONLY BREAKDOWN TABLES')
 1040 FORMAT('  PRINT ALL TABLES')
      IF(Itd.eq.1)THEN
       WRITE(Np,1050)
 1050  FORMAT('  TRADING DAY FACTORS ANALYZED')
      ELSE
       WRITE(Np,1060)
 1060  FORMAT('  TRADING DAY FACTORS NOT ANALYZED')
       IF(Itd.eq.-1)WRITE(Np,1070)
 1070  FORMAT('  TRADING DAY OPTION TURNED OFF DUE TO ADDITIVE ',
     &        'SEASONAL ADJUSTMENT')
      END IF
      WRITE(Np,1080)Ncol,Nlen,Im,Iyr
 1080 FORMAT('  YEAR-TO-YEAR CHANGES ANALYZED',/,'  NUMBER OF SPANS : ',
     &       I5,/,'  LENGTH OF SPANS : ',I5,/,'  MONTH OF FIRST ',
     &       'OBSERVATION IN FIRST SPAN : ',I5,/,'  YEAR  OF FIRST ',
     &       'OBSERVATION IN FIRST SPAN : ',I5)
      IF(Ic.ne.Im)WRITE(Np,1090)Icyr
 1090 FORMAT('  YEAR   OF FIRST OBSERVATION USED IN SLIDING SPANS ',
     &       'COMPARISON : ',I5)
      WRITE(Np,1100)Lser
 1100 FORMAT('  NAME OF SERIES BEING ADJUSTED : ',A6)
      IF(Ncol.lt.4)WRITE(Np,1110)
 1110 FORMAT(/,'   WARNING: DUE TO THE LENGTH OF THE SERIES, FEWER ',
     &       'THAN FOUR SPANS HAVE BEEN USED TO COMPILE THE MEASURES ',
     &       'GENERATED BELOW.',/,12X,
     &       'IN THIS SITUATION, THE THRESHOLD ',
     &       'VALUES USED TO DETERMINE ADJUSTABILITY (15%, 25%, 40%) ',
     &       'WHICH APPEAR WITH THE',/,12X,'SUMMARY TABLES SHOULD BE ',
     &       'LOWERED.',/)
      RETURN
      END
**==prst.f    processed by SPAG 4.03F  at 09:57 on  2 Mar 1994
      SUBROUTINE prst(Nopt,Irang)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      INTEGER Im,Irang,Iscf,Isign,Itf,Itot,itp,Iturn,Iyr,Kpage,Len,Len2,
     &        Lobs,Lyr,Ncol,Nlen,Nopt,Np,Ns1,Nsea
      REAL sfper,sper,tfper,tper
C*** End of declarations inserted by SPAG
      CHARACTER*6 Lser
      COMMON /com1  / Isign,Iscf,Iturn,Itf,Itot
      COMMON /com4b / Iyr,Im,Nsea,Lyr,Lobs
      COMMON /cz    / Kpage,Np,Lser
      COMMON /nsl   / Nlen,Ncol,Ns1,Len,Len2
      IF(Nopt.ne.3)THEN
       sper=(real(Isign)/real(Itot))*100.
       WRITE(Np,1010)Isign,Itot,sper
       IF(Irang.eq.0)THEN
        sfper=0.0
        IF(Isign.gt.0)sfper=(real(Iscf)/real(Isign))*100.
        WRITE(Np,1020)Iscf,Isign,sfper
       END IF
      END IF
      IF(Ncol.eq.2)RETURN
      itp=Itot-2*Nsea
      IF(itp.gt.0)THEN
       tper=(real(Iturn)/real(itp))*100.
       WRITE(Np,1030)Iturn,itp,tper,Ncol
       IF(Irang.eq.1)RETURN
       tfper=0.0
       IF(Iturn.gt.0)tfper=(real(Itf)/real(Iturn))*100.
       WRITE(Np,1040)Itf,Iturn,tfper
      END IF
 1010 FORMAT(/,2X,I3,' OUT OF ',I3,' (',F5.1,' %)',' OF THE ',
     &       'MONTHS TESTED HAD A CHANGE OF DIRECTION.')
 1020 FORMAT(2X,I3,' OUT OF ',I3,' (',F5.1,' %)',' OF THE ',
     &       'MONTH(S) WITH CHANGES OF DIRECTION WERE FLAGGED.',/)
 1030 FORMAT(/,2X,I3,' OUT OF ',I3,' (',F5.1,' %)',' OF THE ',
     &       'MONTHS TESTED HAD A TURNING POINT OVER ALL ',I2,' SPANS.')
 1040 FORMAT(2X,I3,' OUT OF ',I3,' (',F5.1,' %)',' OF THE ',
     &       'MONTH(S) WITH TURNING POINTS WERE FLAGGED.',//)
      RETURN
      END
      SUBROUTINE input(Srs,Ifmt,L1,L2,Nd,Fmt,Myr,Mser,Y2kset,*,*,*)
      IMPLICIT NONE
      CHARACTER Fmt*40,Mser*6,Y2kset*1
      INTEGER i,Ifmt,L1,L2,Myr,Nd,Y2KLIM
      DOUBLE PRECISION Srs
      DIMENSION Srs(*)
      PARAMETER(Y2KLIM=45)
      IF(Ifmt.eq.0)THEN
       READ(Nd,Fmt,END=10,ERR=20)(Srs(i),i=L1,L2),Myr,Mser
       IF(Y2kset.eq.'Y'.or.Y2kset.eq.'y')THEN
        IF(Myr.le.Y2KLIM)THEN
         Myr=2000+Myr
        ELSE
         Myr=1900+Myr
        END IF
       ELSE
        Myr=1900+Myr
       END IF
      ELSE
       READ(Nd,Fmt,END=30,ERR=20)(Srs(i),i=L1,L2)
      ENDIF
      RETURN
   10 RETURN 1
   20 RETURN 2
   30 RETURN 3
      END
c-----------------------------------------------------------------------
      SUBROUTINE chkeas(Lmar,Llda)
      IMPLICIT NONE
c-----------------------------------------------------------------------
c     Check to see if X-11 Easter adjustment can be computed.  
c----------------------------------------------------------------------
      DOUBLE PRECISION Y,X
      LOGICAL Lgenx
      INTEGER i,Ieast,Lmar,Llda
c-----------------------------------------------------------------------
      COMMON /xyser / Y(372),X(372)
      COMMON /feast / Ieast(4),Lgenx
c-----------------------------------------------------------------------
      Ieast(1)=0
      Ieast(2)=0
      Ieast(3)=0
      Ieast(4)=0
c-----------------------------------------------------------------------
      DO i=Lmar,Llda,12
c-----------------------------------------------------------------------
C---- CALCULATE Number of Easters BEFORE APRIL 2
c-----------------------------------------------------------------------
       IF(X(i).le.10)THEN
        Ieast(1)=Ieast(1)+1
c-----------------------------------------------------------------------
C---- CALCULATE Number of Easters AFTER APRIL 16
c-----------------------------------------------------------------------
       ELSE IF(X(i).gt.24.)THEN
        Ieast(2)=Ieast(2)+1
c-----------------------------------------------------------------------
C---- CALCULATE Number of Easters From APRIL 2 to April 8
c-----------------------------------------------------------------------
       ELSE IF(X(i).gt.10.and.X(i).le.17)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
