Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/stp/stp12.for
There is 1 other file named stp12.for in the archive. Click here to see a list.
C *** STAT PACK ***
C READ DATA FROM MAGTAPE.
C CALLING SEQUENCE: CALL TAPEI(NV,NC,MV,MC,DATA,COR,VMN,STD,FMT)
C WHERE NV - IS THE NUMBER OF COLUMNS ACTAULLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (CASES)
C MV - MAXIMUM NUMBER OF VARIABLES, AS SPECIFIED IN MAIN.
C MC - MAXIMUM NUMBER OF CASES AS SPECIFIED IN MAIN.
C DATA - MATRIX FOR DATA DIMENSIONED FOR MAXIMUM
C COR - CORRELATION MATRIX.
C VMN - VECTOR CONTAINING VARIABLE MEANS.
C STD - VECTOR CONTAINING STANDARD DEVIATIONS.
C FMT - OBJECT TIME FORMAT
C
C PROGRAM ALLOWS USER TO ACCESS A MAGTAPE FOR USE IN STAT PACK.
C THROUGH A SERIES OF QUESTIONS THE PROGRAM WILL ISSUE MOUNT
C REQUESTS TO THE OPERATOR. USING THE PLEASE TERMINAL,
C IT WILL SKIP X NUMBER OF FILES AND FINALLY SELECT ONLY
C OBSERVATIONS MEETING CERTAIN REQUIREMENTS AS SET FORTH BY THE
C USER. UP TO 50 VARIABLES, WITH UP TO 50 QUALIFIERS.
C
SUBROUTINE TAPEI(NV,NC,MV,MC,DATA,COR,VMN,STD,FMT)
DIMENSION DATA(MC,MV),COR(MV,MV),VMN(1),STD(1),FMT(80)
DIMENSION V(50,3),IIN(30),IO(70),X(50)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
BELL="034000000000
CALL JOBNUM(IJOB)
CALL GETPPN(IPROJ,IPROG)
ITAP=16
DO 101 I=1,MV
VMN(I)=0
STD(I)=0
DO 101 J=1,MV
101 COR(J,I)=0
3 WRITE(IDLG,1)
1 FORMAT('0PLEASE GIVE SOME IDENTIFICATION FOR THE TAPE? ',$)
READ(ICC,2,END=7)(IO(I),I=1,26)
2 FORMAT(70A1)
IF((IO(1).NE.'H').OR.(IO(2).NE.'E').OR.(IO(3).NE.'L').OR
1.(IO(4).NE.'P')) GO TO 5
WRITE(IDLG,4)
4 FORMAT('0SIMPLY TYPE IN SOME ID FOR THE TAPE YOU WISH TO READ'
1,' FROM'/' IN MOST CASES IF YOU KNOW THE CENTER NUMBER',
2' THIS WILL BE SUFFICIENT')
GO TO 3
5 IF(IO(1).EQ.'!') RETURN
DO 6 I=26,1,-1
IF(IO(I).NE.' ') GO TO 9
6 CONTINUE
7 WRITE(IDLG,8)
8 FORMAT('0NO ID USED - RETURN TO MAIN')
RETURN
C
C TTY40 IS SET UP TO BE THE INSTALATION "PLEASE TERMINAL"
C IT IS HERE USED FOR COMUNICATIONG WITH THE OPERATOR AS
C TO WHICH TAPE TO MOUNT WHERE.
C
9 OPEN(UNIT=7,DEVICE='TTY40',ACCESS='SEQINOUT')
CALL BUSY(7)
WRITE(7,2)(BELL,J=1,10)
WRITE(7,10) IPROJ,IPROG,IJOB,(IO(J),J=1,I)
10 FORMAT('0STP MTA MOUNT REQUEST',4X,O6,',',O6,5X,'JOB',I3/
1' OPERATOR PLEASE MOUNT, WRITE PROTECTED, THE TAPE ',26A1)
WRITE(7,110)
110 FORMAT(' RESPOND WITH ONE OF THE FOLLOWING:'/
3' -DEVICE NUMBER'/' ?-NEED MORE INFORMATION ABOUT TAPE ID'/
4' X-NO DRIVE AVAILABLE'/' F-TAPE NOT FOUND'/
5' !-TAPE MAY NOT BE MOUNTED FOR PROJ,PROG NUMBER'/)
11 READ(7,2) ANS
IF(ANS.EQ.'1') GO TO 27
IF(ANS.EQ.'0') GO TO 27
IF(ANS.NE.'X') GO TO 13
WRITE(IDLG,12)
12 FORMAT(' NO DRIVES AVAILABLE, PLEASE TRY AGAIN LATER')
GO TO 30
13 IF(ANS.NE.'F') GO TO 15
WRITE(IDLG,14)
14 FORMAT(' WE ARE UNABLE TO LOCATE THE TAPE YOU REQUESTED'/
1' PLEASE CONTACT US')
GO TO 30
15 IF(ANS.NE.'!') GO TO 17
WRITE(IDLG,16)
16 FORMAT(' THE TAPE REQUESTED IS SPECIFIED FOR CERTAIN PROJECT'/
1' PROGRAMMER NUMBER ONLY, YOURS IS NOT ONE OF THEM')
GO TO 30
17 IF(ANS.NE.'?') GO TO 25
20 WRITE(IDLG,18)
18 FORMAT(' OPERATOR NEEDS MORE ID INFORMATION, PLEASE TYPE IN'/
1' MORE ID, OR A "!" TO EXIT? ',$)
READ(ICC,2) (IO(I),I=1,50)
IF(IO(1).EQ.'!') GO TO 30
DO 19 I=50,1,-1
IF(IO(I).NE.' ') GO TO 21
19 CONTINUE
GO TO 20
21 WRITE(7,22)(IO(J),J=1,I)
22 FORMAT(' FURTHUR ID INFO: ',50A1)
WRITE(7,23)
23 FORMAT(' RESPOND WITH APPROPRIATE CHARACTER: ',$)
GO TO 11
25 WRITE(7,26)
26 FORMAT(' ANSWER NOT POSSIBLE')
WRITE(7,23)
GO TO 11
27 ENCODE(5,28,DEV) ANS
28 FORMAT('MTA',A1,' ')
OPEN(UNIT=ITAP,DEVICE=DEV,ACCESS='SEQIN')
CALL RELEAS(ITAP)
IF(IERR.EQ.0) GO TO 32
WRITE(7,29)
29 FORMAT(' DRIVE ALREADY ASSIGNED TO ANOTHER JOB')
WRITE(7,23)
GO TO 11
30 WRITE(7,31)
31 FORMAT(' THANK YOU'/' .'/)
CALL RELEAS (7)
RETURN
32 WRITE(7,31)
CALL RELEAS(7)
WRITE(IDLG,33) DEV
33 FORMAT(' TAPE HAS BEEN MOUNTED ON ',A4,' WRITE PROTECTED. BE'/
1' SURE TO ASK TO HAVE THE TAPE DISMOUNTED WHEN DONE')
36 WRITE(IDLG,34)
34 FORMAT(' WHAT POSITION DOES THE FILE OCCUPY ON THE TAPE? ',$)
READ(ICC,35) IPOS
35 FORMAT(I)
IF(IPOS.GT.0) GO TO 38
WRITE(IDLG,37)
37 FORMAT(' NOT A VALID ANSWER')
GO TO 36
38 REWIND(ITAP)
L=IPOS-1
IF(L.LT.1) GO TO 40
C IF RUNNING UNDER F10 THIS WILL WORK SIMPLY REMOVE THE C'S.
C IF THE COMMAND IS NEEDED AND IS BEING RUN UNDER F40 SOME SKIPFILE
C SUBSTITUTE WILL HAVE TO BE WRITTEN. THIS COMMAND WILL PROBABLY BE
C SCRAPED OR REWRITTEN BEFOR THE NEXT RELEASE.
C
C DO 39 I=1,L
C39 SKIP FILE ITAP
C FINALLY READ DATA FROM TAPE.
40 WRITE(IDLG,41)
41 FORMAT(' HOW MANY VARIABLES? ',$)
READ(ICC,35) INV
IF((INV.GE.1).AND.(INV.LE.50)) GO TO 43
WRITE(IDLG,97)
97 FORMAT(' MINIMUM ANSWER OF 1, MAXIMUM OF 50')
GO TO 40
43 WRITE(IDLG,42)
42 FORMAT(' LIST QUALIFIERS 1 PER LINE'/)
DO 44 I=1,50
50 WRITE(IDLG,48)
48 FORMAT(' ? ',$)
READ(ICC,45,END=73)(V(I,J),J=1,3)
45 FORMAT(F,A2,1X,F)
IF(V(I,2).NE.'EL') GO TO 61
WRITE(IDLG,46)
46 FORMAT('0QUALIFYING FIELDS ARE USED FOR SUBSETTING DATA'/
1' THE FORM IS: VARIABLE TO BE LOOKED AT,QUALIFIER,VALUE'/
2' QUALIFIERS ARE: "EQ"- EQUAL; "NE"- NOT EQUAL; "GT"-',
3' GREATER THAN'/' "GE"- GREATER THAN OR EQUAL TO; "LT"- LESS',
4' THAN;'/' "LE" - LESS THAN OR EQUAL TO'/' A QUALIFIER MIGHT',
5' LOOK LIKE THIS')
WRITE(IDLG,47)
47 FORMAT(' 1,LT,75 - MEANING TAKE ONLY THOSE CASES WHERE VARIABLE'/
1' ONE IS LESS THAN 75. UP TO 50 QUALIFIERS MAY BE USED AT ONE'/
2' TIME. TO STOP INSERTION OF QUALIFIERS OR IF NO QUALIFIERS ARE'/
3' TO BE USED, RETURN, TYPE "STOP", OR USE A CONTROL Z(^Z)'/)
GO TO 43
61 IF((V(I,1).EQ.0).AND.(V(I,2).EQ.' ')) GO TO 73
IF(V(I,2).EQ.'TO') GO TO 73
IF((V(I,1).GT.0).AND.(V(I,1).LE.INV)) GO TO 51
WRITE(IDLG,49)
49 FORMAT(' VARIABLE SPECIFIED NOT POSSIBLE - REENTER LINE')
GO TO 50
51 IF(V(I,2).NE.'EQ') GO TO 52
V(I,2)=1
GO TO 44
52 IF(V(I,2).NE.'NE') GO TO 53
V(I,2)=2
GO TO 44
53 IF(V(I,2).NE.'LT') GO TO 54
V(I,2)=3
GO TO 44
54 IF(V(I,2).NE.'LE') GO TO 55
V(I,2)=4
GO TO 44
55 IF(V(I,2).NE.'GT') GO TO 56
V(I,2)=5
GO TO 44
56 IF(V(I,2).NE.'GE') GO TO 57
V(I,2)=6
GO TO 44
57 WRITE(IDLG,58) V(I,2)
58 FORMAT(' QUALIFIER "',A2,'" NOT POSSIBLE -REENTER LINE')
GO TO 50
44 CONTINUE
WRITE(IDLG,59)
59 FORMAT(' NO MORE QUALIFIERS ACCEPTED MAXIMUM OF 50')
I=51
73 NQ=I-1
60 WRITE(IDLG,62)
62 FORMAT(' LIST THE VARIABLES TO BE KEPT, SEPERATED BY COMMAS'/)
READ(ICC,63) IIN
63 FORMAT(30I)
DO 64 I=1,30
IF(IIN(I).EQ.0) GO TO 65
64 CONTINUE
I=31
65 N=I-1
IF(N.LE.MV) GO TO 67
WRITE(IDLG,66)
66 FORMAT(' MORE VARIABLES SPECIFIED THAN ROOM ALLOCATED')
GO TO 60
67 DO 68 I=1,N
IF((IIN(I).GT.0).AND.(IIN(I).LE.INV)) GO TO 69
WRITE(IDLG,70) IIN(I)
70 FORMAT(' VARIABLE ',I3,' NOT POSSIBLE')
GO TO 60
69 DO 71 J=1,I
IF(J.EQ.I) GO TO 71
IF(IIN(I).NE.IIN(J)) GO TO 71
WRITE(IDLG,72) IIN(I)
72 FORMAT(' VARIABLE ',I3,' APPEARS TWICE INT THE LIST')
GO TO 60
71 CONTINUE
68 CONTINUE
I=1
LC=0
80 READ(ITAP,FMT,END=84)(X(J),J=1,INV)
LC=LC+1
IF(NQ.LT.1) GO TO 98
DO 81 J=1,NQ
L=V(J,2)
M=V(J,1)
GO TO (91,92,93,94,95,96)L
91 IF(X(M).EQ.V(J,3)) GO TO81
GO TO 80
92 IF(X(M).NE.V(J,3)) GO TO 81
GO TO 80
93 IF(X(M).LT.V(J,3)) GO TO 81
GO TO 80
94 IF(X(M).LE.V(J,3)) GO TO81
GO TO 80
95 IF(X(M).GT.V(J,3)) GO TO 81
GO TO 80
96 IF(X(M).GE.V(J,3)) GO TO 81
GO TO 80
81 CONTINUE
98 DO 82 J=1,N
L=IIN(J)
DATA (I,J)=X(L)
VMN(J)=VMN(J)+X(L)
DO 82 K=1,J
M=IIN(K)
82 COR(K,J)=COR(K,J)+X(L)*X(M)
I=I+1
IF(I.LE.MC) GO TO 80
WRITE(IDLG,83)LC
83 FORMAT(' ***WARNING*** YOU HAVE COMPLETED THE SPECIFIED DATA',
1' SET'/' NO MORE DATA ACCEPTED; SELECTED FROM SAMPLE OF',I7)
NC=MC
NV=N
GO TO 103
84 NC=I-1
NV=N
IF(NC.GT.1) GO TO 100
WRITE(IDLG,102)
102 FORMAT(' NO DATA IN SET SPECIFIED')
RETURN
100 WRITE(IDLG,99) NC,LC
99 FORMAT(' DATA SET CONSISTS OF ',I4,' OBSERVATIONS'/' AS',
1' SELECTED FROM A SAMPLE OF',I6)
103 DO 85 I=1,NV
DO 85 J=I,NV
85 COR(J,I)=NC*COR(I,J)-VMN(I)*VMN(J)
DO 86 I=1,NV
STD(I)=SQRT(COR(I,J)/(NC*(NC-1)))
86 VMN(I)=VMN(I)/NC
DO 87 I=1,NV
DO 87 J=I,NV
IF(I.EQ.J) GO TO 87
IF(COR(I,I)*COR(J,J).EQ.0) GO TO 88
COR(I,J)=COR(J,I)/SQRT(COR(I,I)*COR(J,J))
COR(J,I)=COR(I,J)
GO TO 87
88 COR(I,J)=0
COR(J,I)=0
87 CONTINUE
DO 89 I=1,NV
89 COR(I,I)=1.0
RETURN
END
C *** STAT PACK ***
C SUBROUTINE FOR ONE WAY ANOVA WITH REPEATED MEASURES.
C CALLING SEQUENCE: CALL ANVR(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
C WHERE NV - NUMBER OF VARIABLES ACTUALL IN USE
C NC - NUMBER OF OBSERVATIONS ACTUALLY IN USE
C MV - MAXIMUM NUMBER OF VARIABLES POSSIBLE
C MC - MAXIMUM NUMBER OF OBSERVATIONS POSSIBLE
C DATA - MATRIX CONTAINING DATA DIMENSIONED FOR MAXIMUMS
C VMN - VECTOR CONTAINING VARIABLE MEANS
C STD - VECTOR CONTAINING VARIABLE STANDARD DEVIATIONS
C NAMES - VECTOR CONTAINING VARIABLE NAMES
C
SUBROUTINE ANVR(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
DIMENSION DATA(MC,MV),VMN(1),NAMES(1),IV(50),IVA(50),STD(1)
COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON /EXTRA/ HEDR(70),NSZ
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT(' WHICH VARIABLES? ',$)
IRET=0
CALL ALPHA(IVA,50,NN,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IHELP.EQ.1) GO TO 1
IF(IERR.EQ.1) GO TO 1
K=1
DO 3 I=1,NN
IV(I)=IVA(I)
IF(IVA(I).GT.0) GO TO 3
IV(I)=K
K=K+1
3 CONTINUE
GO TO 9
4 J=NN
5 IF(IVA(J).GT.0) GO TO 6
IV(J)=IV(J)+1
IF(IV(J).LE.NV) GO TO 7
6 J=J-1
IF(J.GE.1) GO TO 5
RETURN
7 K=IV(J)
IF(J.EQ.NN) GO TO 9
DO 8 I=J+1,NN
IF(IVA(I).GT.0) GO TO 8
K=K+1
IF(K.GT.NV) GO TO 6
IV(I)=K
8 CONTINUE
9 DO 10 I=1,NN-1
DO 10 K=I+1,NN
IF(IV(I).EQ.IV(K)) GO TO 4
10 CONTINUE
C
C BEGIN ANALYSIS
C
G=0
SUMX2=0
SUMT2=0
SUMP2=0
DO 15 I=1,NC
P=0
DO 16 J=1,NN
X=DATA(I,IV(J))
SUMX2=SUMX2+X**2
16 P=P+X
G=G+P
15 SUMP2=SUMP2+P**2
DO 17 J=1,NN
17 SUMT2=SUMT2+(NC*VMN(IV(J)))**2
SSBET=(SUMP2/NN)-G**2/(NN*NC)
IDFBET=NC-1
SSWITH=SUMX2-(SUMP2/NN)
IDFWTH=NC*(NN-1)
SSTRT=(SUMT2/NC)-(G**2/(NN*NC))
IDFTRT=(SUMT2/NC)-(G**2/(NN*NC))
IDFTRT=NN-1
SSRES=SUMX2-(SUMT2/NC)-SSBET
IDFRES=(NN-1)*(NC-1)
SSTOT=SUMX2-(G**2/(NN*NC))
IDFTOT=(NN*NC)-1
AMSTRT=SSTRT/IDFTRT
AMSRES=SSRES/IDFRES
F=AMSTRT/AMSRES
PROB=FISHER(IDFTRT,IDFRES,F)
IF(IOUT.NE.21) WRITE(IOUT,7766)(HEDR(I),I=1,NSZ)
7766 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,20)
20 FORMAT('0',10X,'***** 1-WAY ANOVA WITH REPEATED MEASURES *****')
WRITE(IOUT,21)
21 FORMAT('0TRET.',3X,'SIZE',6X,'MEAN',8X,'STD. DEV.')
LINES=6
DO 22 I=1,NN
IF(IOUT.NE.21) GO TO 22
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 22
CALL PRNTHD
WRITE(IOUT,21)
LINES=4
22 WRITE(IOUT,23) NAMES(IV(I)),NC,VMN(IV(I)),STD(IV(I))
23 FORMAT(1X,A5,2X,I5,4X,G10.4,1X,G)
IF(IOUT.NE.21) GO TO 30
LINES=LINES+7
IF(LINES.LE.LINPP) GO TO 30
LINES=9
30 WRITE(IOUT,24)
24 FORMAT('0SOURCE',3X,'SUM OF SQ.',4X,'D.F.',3X,'MEAN SQ.',6X,
1'F',9X,'PROB')
WRITE(IOUT,25) SSBET,IDFBET
25 FORMAT(' BETWEEN',1X,G,I4)
WRITE(IOUT,26)SSWITH,IDFWTH
26 FORMAT(' WITHIN ',1X,G,I4)
WRITE(IOUT,27) SSTRT,IDFTRT,AMSTRT,F,PROB
27 FORMAT(' TREAT.',2X,G,I4,3X,G10.4,1X,G11.4,1X,F7.4)
WRITE(IOUT,28)SSRES,IDFRES,AMSRES
28 FORMAT(' RESID.',2X,G,I4,3X,G10.4)
WRITE(IOUT,29) SSTOT,IDFTOT
29 FORMAT(' TOTAL',3X,G,I4)
GO TO 4
END
C *** STAT PACK ***
C SUBROUTINE FOR EXPONENTIAL SMOOTHING MODEL.
C CALLING SEQUENCE: CALL EXPSM(NV,NC,MV,MC,DATA,Y,NAMES)
C WHERE NV - NUMBER OF VARIABLES ACTUALLY USED
C NC - NUMBER OF OBSERVATIONS ACTUALLY USED
C MV - MAXIMUM NUMBER OF VARIABLES POSSIBLE
C MC - MAXIMUM NUMBER OF OBSERVATIONS ACTUALLY USED
C DATA - MATRIX CONTAINING DATA.
C Y - EXTRA VECTOR AT LEAST NC LONG
C NAMES - VECTOR CONTAINING VARIABLE NAMES
C
C ROUTINE REQUESTED BY WMU MANAGEMENT DEPARTMENT, WHO SUBMITTED
C A BASIC PROGRAM. NO OTHER REFERENCE IS AVAILABLE AT THIS TIME.
C
SUBROUTINE EXPSM(NV,NC,MV,MC,DATA,Y,NAMES)
DIMENSION DATA(MC,MV),NAMES(1),IV(20)
DIMENSION ACT(50),E(50),S(50),Y(1),OPTS(10)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ
U3=0
IRET=0
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT(' WHICH VARIABLES? ',$)
CALL ALPHA(IV,20,NN,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 1
IF(IHELP.NE.1) GO TO 320
WRITE(IDLG,11)
11 FORMAT('0THIS PROGRAM IS AN EXPONENTIAL SMOOTHING MODEL'/
1' CONTAINING STEADY STATE, TREND, AND SEASONAL TERMS.'/
2' EACH TERM IS THE FORM -'/
3'0EST(T)=A*ACT(T-1)+(1-A)*EST(T-1)'/
4'0WHERE:'/
5'0 EST(T)=ESTIMATED VALUE FOR PEROID T'/
6'0 ACT(T-1)=ACTUAL VALUE FOR PEROID T-1'/
7'0 EST(T-1)=ESTIMATED VALUE FOR PEROID T-1'/
8'0 A=WEIGHTING FACTOR (0<A<1)')
WRITE(IDLG,12)
12 FORMAT('0THE WEIGHTING FACTOR DETERMINES THE EMPHASIS'/
1' PLACED ON PAST DATA VERSUS THE EMPHASIS PLACED'/
2' ON NEW INFORMATION ABOUT THE TERM WHICH ENTERED'/
3' THE ANALYSIS IN THE LAST PEROID. A LARGE VALUE OF'/
4' A ALLOWS RAPID ADJUSTMENT TO CHANGES IN THE TERM,'/
5' BUT WILL CAUSE THE MODEL TO REACT QUICKLY TO'/
6' RANDOM CHANGES. A SMALL VALUE OF A DAMPENS'/
7' THE EFFECT OF RANDOM VARIATIONS BUT WILL MAKE'/
8' THE MODEL LESS RESPONSIVE TO CHANGES IN THE TERM.'/
9' THE GENERALLY ACCEPTED VALUES FOR THE'/
1' WEIGHTING FACTORS ARE:'/
2'0 STEADY STATE 0<A<0.1'/
3' TREND 0<A<0.05'/
4' SEASONAL 0<A<0.05')
WRITE(IDLG,13)
13 FORMAT('0THE PROGRAM HAS THE FOLLOWING FEATURES;')
WRITE(IDLG,14)
14 FORMAT('01. SEASONAL TERM'/
1' A. ADDITIVE Y=SS+T+C'/
2' B. MULTIPLICATIVE Y=(SS+T)*C'/
3' WHERE:'/
4' SS=STEADY STATE TERM'/
5' T=TREND TERM'/
6' C=SEASONAL TERM')
WRITE(IDLG,15)
15 FORMAT('02. INITIAL TREND'/
1' A. CALCULATED BY COMPUTER'/
2' B. INPUT BY USER'/
3'03. OUTPUT'/
4' A. FULL'/
5' B. PARTIAL VARIANCE OF ACTUAL VALUES FROM'/
6' ESTIMATED VALUES AND PROJECTED VALUES'/
7'04. NATURAL LOG TRANSFORMATION OF DATA')
WRITE(IDLG,16)
16 FORMAT('0THE PROGRAM ANALYZES THE FIRST TWO CYCLES OF'/
1' DATA TO DETERMINE THE SEASONAL PATERN. THOSE PEROIDS'/
2' THAT CONSISTENTLY DEVIATE FROM THE EXPECTED VALUE'/
3' (I.E. SUM OF ESTIMATED SS AND T) BY A GIVEN PERCENTAGE'/
4' (DETERMINED BY THE USER) IN THE FIRST TWO'/
5' CYCLES ARE ASSUMED TO HAVE SEASONAL EFFECTS')
WRITE(IDLG,17)
17 FORMAT(' OPTIONS INCLUDE:'/
1' NLOGY - NATURAL LOG TRANSFORMATION OF DEPENDENT VAR.'/
2' NLOGT - NATURAL LOG TRANSFORMATION OF TIME VARIABLE'/
3' TREND - ENTER USER TREND LINE'/
4' SHORT - SHORT OUTPUT (TREND LINE, VARIANCE, PROJ. VALUES)'/
5' MULTI - MULTIPLICATIVE RATHER THAN ADDITIVE SEASONAL TERMS'/
6'0IF NO OPRIONS ARE DESIRED TYPE A RETURN'/'0')
GO TO 1
320 IF(ICC.NE.2) WRITE(IDLG,300)
300 FORMAT('+LIST OPTIONS SEPARATED BY COMMAS'/)
READ(ICC,301) OPTS
301 FORMAT(10(A5,1X))
U=1
U3=0
U4=0
Z8=1
U2=0
IF(OPTS(1).EQ.'!') RETURN
IF(OPTS(1).NE.'HELP') GO TO 302
WRITE(IDLG,17)
GO TO 320
302 DO 303 I=1,10
IF(OPTS(I).EQ.' ') GO TO 3
IF(OPTS(I).NE.'NLOGY') GO TO 304
U2=1
GO TO 303
304 IF(OPTS(I).NE.'TREND') GO TO 305
U=0
GO TO 303
305 IF(OPTS(I).NE.'NLOGT') GO TO 306
U3=1
GO TO 303
306 IF(OPTS(I).NE.'MULTI') GO TO 307
U4=1
GO TO 303
307 IF(OPTS(I).NE.'SHORT') GO TO 308
Z8=0
GO TO 303
308 WRITE(IDLG,309) OPTS(I)
309 FORMAT(' OPTION "',A5,'" DOES NOT EXIST'/)
GO TO 320
303 CONTINUE
3 IF(ICC.NE.2) WRITE(IDLG,4)
4 FORMAT(' HOW MANY OBSERVATIONS PER CYCLE? ',$)
READ(ICC,5) ANS
5 FORMAT(A5)
IF(ANS.EQ.'!') RETURN
IF(ANS.EQ.' ') GO TO 3
IF(ANS.NE.'HELP') GO TO 6
WRITE(IDLG,16)
GO TO 3
6 REREAD 7,IP
7 FORMAT(I)
IF(NC.GT.2*IP) GO TO 25
WRITE(IDLG,8)
8 FORMAT('0MUST HAVE AT LEAST TWO CYCLES OF DATA')
GO TO 3
25 IF(ICC.NE.2) WRITE(IDLG,26)
26 FORMAT(' WEIGHTING FACTORS FOR:'/)
27 IF(ICC.NE.2) WRITE(IDLG,28)
28 FORMAT('+STEADY STATE? ',$)
READ(ICC,5,END=27) ANS
IF(ANS.EQ.'!') RETURN
IF(ANS.NE.'HELP') GO TO 32
WRITE(IDLG,12)
GO TO 25
32 REREAD 29,A9
29 FORMAT(F)
30 IF(ICC.NE.2) WRITE(IDLG,31)
31 FORMAT('+TREND? ',$)
READ(ICC,5,END=30) ANS
IF(ANS.EQ.'!') RETURN
IF(ANS.NE.'HELP') GO TO 33
WRITE(IDLG,12)
GO TO 30
33 REREAD 29,B9
34 IF(ICC.NE.2) WRITE(IDLG,35)
35 FORMAT('+SEASONAL? ',$)
READ(ICC,5,END=34) ANS
IF(ANS.EQ.'!') RETURN
IF(ANS.NE.'HELP') GO TO 36
WRITE(IDLG,12)
GO TO 34
36 REREAD 29,C9
37 IF(ICC.NE.2) WRITE(IDLG,38)
38 FORMAT('0HOW MANY PEROIDS TO BE PROJECTED? ',$)
READ(ICC,5,END=37) ANS
IF(ANS.EQ.'!') RETURN
IF(ANS.EQ.'HELP') GOTO 37
REREAD 7,IZ
39 IF(ICC.NE.2) WRITE(IDLG,40)
40 FORMAT(' WHAT IS THE PERCENTAGE CRITERION FOR SEASONAL TERMS? ',$)
READ(ICC,5,END=39) ANS
IF(ANS.EQ.'!') RETURN
IF(ANS.NE.'HELP') GO TO 41
WRITE(IDLG,16)
GO TO 39
41 REREAD 29,T1
IF(T1.GT.1.00) T1=T1/100
IF(U.EQ.1) GO TO 154
47 IF(ICC.NE.2) WRITE(IDLG,46)
46 FORMAT(' Y-INTERSECTION? ',$)
READ(ICC,5,END=47) ANS
IF(ANS.EQ.'!') RETURN
IF(ANS.EQ.'HELP') GO TO 47
REREAD 29,A
48 IF(ICC.NE.2) WRITE(IDLG,49)
49 FORMAT('0SLOPE? ',$)
READ(ICC,5,END=48) ANS
IF(ANS.EQ.'!') RETURN
IF(ANS.EQ.'HELP') GO TO 48
REREAD 29,B
C
C QUESTIONS ANSWERED NOW DO ANALYSIS
C
154 ALL=0
DO 53 I=1,NN
IF(IV(I).GT.0) GO TO 53
ALL=1
53 CONTINUE
IF(ALL.EQ.1) NN=NV
DO 60 I=1,NN
IF(ALL.EQ.0) IVV=IV(I)
IF(ALL.EQ.1) IVV=I
IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(J),J=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,200)
200 FORMAT('0',15X,'***** CURVE SMOOTHING MODEL *****')
TYST='ADD.'
IF(U4.EQ.1) TYST='MULT.'
WRITE(IOUT,201) NAMES(IVV),TYST
201 FORMAT(10X,'FOR VARIABLE: ',A5,', WITH ',A5,' SEASONAL TERMS')
IF(U2.EQ.1) WRITE(IOUT,202) NAMES(IVV)
202 FORMAT(10X,'WITH NATURAL LOG TRANSFORMATION OF VARIABLE: ',A5)
IF(U3.EQ.1) WRITE(IOUT,203)
203 FORMAT(10X,'WITH NATURAL LOG TRANSFORMATION OF TIME')
TYST=T1*100.
WRITE(IOUT,204) TYST
204 FORMAT(10X,'PERCENTAGE CRITERIAN FOR SEASONAL TERMS IS ',F6.1,
1'%')
WRITE(IOUT,205) A9,B9,C9
205 FORMAT(10X,'WEIGHTING FACTORS WERE: ',F6.3,' FOR STEADY STATE'/
112X,F6.3,' FOR TREND, AND ',F6.3,' FOR SEASONAL')
LINES=9
DO 61 J=1,50
S(J)=0
ACT(J)=0
E(J)=0
IF(U4.EQ.0) GO TO 61
ACT(J)=1.
E(J)=1.
61 CONTINUE
D=0
IC1=0
V=0
C2=0
P9=0
X2=0
X9=0
Y9=0
T2=0
DO 62 J=1,NC
Z1=J
IF(U3.EQ.1) Z1=ALOG(Z1)
Y(J)=DATA(J,IVV)
IF(U2.EQ.1) Y(J)=ALOG(Y(J))
X2=X2+Z1**2
X9=X9+Z1
P9=P9+Y(J)*Z1
Y9=Y9+Y(J)
62 CONTINUE
IF(U.EQ.1) B=(NC*P9-(X9*Y9))/(NC*X2-X9**2)
IF(U.EQ.1) A=(Y9/NC)-B*(X9/NC)
WRITE(IOUT,63)A,B
63 FORMAT('0THE TREND LINE IS Y=',G,'+',G,'X')
LINES=LINES+3
A2=A
B2=B
DO 64 J=1,IP
Z1=J
IF(U3.EQ.0) GO TO 65
Z1=ALOG(Z1)
AL3=B*Z1+A
AL4=B*ALOG(FLOAT(J+IP))+A
GO TO 66
65 AL3=B*Z1+A
AL4=B*(Z1+P)+A
66 D1=Y(J)-AL3
D2=Y(J+IP)-AL4
P1=D1/AL3
P2=D2/AL4
IF((P1.GT.T1).AND.(P2.GT.T1)) GO TO 164
IF((P1.LT.-T1).AND.(P2.LT.-T1)) GO TO 164
GO TO 64
164 S(J)=1
ACT(J)=D1
E(J)=D1
IF(U4.NE.1) GO TO 64
ACT(J)=Y(J)/AL3
E(J)=ACT(J)
64 CONTINUE
IC1=1
J=1
C2=1.
IF(S(IC1).EQ.0) GO TO 67
C2=C9*ACT(1)+(1-C9)*E(1)
GO TO 166
67 IF(U4.EQ.0) C2=0
166 IF(Z8.EQ.0) GO TO 170
WRITE(IOUT,68)
68 FORMAT('0',5X,'ACTUAL',4X,'PREDICTED',3X,'DEVIATION',2X,
1'% DEVIATION',2X,'MEAN AVG DEV.')
LINES=LINES+2
GO TO 170
167 IF(S(IC1).NE.0) GO TO 168
C2=1
IF(U4.EQ.0) C2=0
GO TO 169
168 C2=C9*(ACT(IC1))+(1-C9)*E(IC1)
169 A2=A9*D9+(1-A9)*(A1+B1)
B2=B9*(A2-A1)+(1-B9)*B1
170 Y1=A2+B2+C2
IF(U4.NE.0) Y1=C2*(A2+B2)
IF(S(IC1).NE.0) GO TO 69
D9=Y(J)
GO TO 71
69 E(IC1)=Y1-(A2+B2)
ACT(IC1)=Y(J)-(A2+B2)
IF(U4.NE.1) GO TO 70
E(IC1)=Y1/(A2+B2)
ACT(IC1)=Y(J)/(A2+B2)
70 D9=A2+B2
71 A1=A2
B1=B2
IF(U2.EQ.0) GO TO 172
Y(J)=EXP(Y(J))
Y1=EXP(Y1)
172 D=Y(J)-Y1
V=V+D**2
P3=0
IF(Y1.NE.0) P3=ABS((D/Y1)*100)
T2=T2+ABS(D)
T3=T2/J
IF(Z8.EQ.0) GO TO 210
IF(IOUT.NE.21) GO TO 211
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 211
CALL PRNTHD
WRITE(IOUT,68)
LINES=5
211 WRITE(IOUT,72) J,Y(J),Y1,D,P3,T3
72 FORMAT(1X,I3,5G12.4)
210 J=J+1
IC1=IC1+1
IF(IC1.GT.IP) IC1=1
IF(J.LE.NC) GO TO 167
VAR=V/NC
IF(IZ.LT.1) GO TO 173
IF(Z8.NE.0) GO TO 212
WRITE(IOUT,174)
174 FORMAT('0',15X,'PREDICTED')
LINES=LINES+2
212 K=1
DO 74 J=1,IP
74 ACT(J)=C9*ACT(J)+(1-C9)*E(J)
A2=A9*D9+(1-A9)*(A1+B1)
B2=B9*(A2-A1)+(1.-B9)*B1
Y1=A2+B2+ACT(IC1)
IF(U4.EQ.1) Y1=ACT(IC1)*(A2+B2)
GO TO 76
75 Y1=A2+K*B2+ACT(IC1)
IF(U4.EQ.1) Y1=(A2+K*B2)*ACT(IC1)
76 IC1=IC1+1
IF(IC1.GT.IP) IC1=1
IF(U2.EQ.1) Y1=EXP(Y1)
L=K+NC
IF(IOUT.NE.21) GO TO 213
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 213
CALL PRNTHD
IF(Z8.EQ.0) WRITE(IOUT,174)
IF(Z8.NE.0) WRITE(IOUT,72)
LINES=5
213 WRITE(IOUT,176) L,Y1
176 FORMAT(1X,I3,12X,G12.4)
K=K+1
IF(K.LE.IZ) GO TO 75
173 IF(IOUT.NE.21) GO TO 214
LINES=LINES+2
IF(LINES.LE.LINPP) GO TO 214
CALL PRNTHD
LINES=4
214 WRITE(IOUT,73) VAR
73 FORMAT('0VARIANCE IS ',G12.4)
60 CONTINUE
RETURN
END