Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/stp/stp3.for
There is 1 other file named stp3.for in the archive. Click here to see a list.
C *** STAT PACK ***
C SUBROUTINE FOR REGRESSIONS FROM SIMPLE TO MULTIPLE.
C CALLING SEQUENCE: CALL STREGR(NV,NC,MV,MC,VMN,STD,COR,CO,DATA,NAMES)
C WHERE NV - IS THE NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS,
C CASES)
C MV - IS THE MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN.
C MC - IS THE MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN.
C VMN - IS A VECTOR CONTAINING THE VARIABLE MEANS.
C STD - IS THE VARIABLE STANDARD DEVIATIONS.
C COR - IS THE CORRELATION MATRIX.
C CO - IS A VECTOR DIMENSIONED AT LEAST FOR NV.
C DATA - IS STORAGE FOR DATA, DIMENSIONED FOR MAXIMUM MATRIX.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C THIS IS ONE OF THE FEW ORIGINAL SUBROUTINES WHICH ESCAPED
C EXTENSIVE MODIFICATION. ALL THAT HAS BEEN CHANGED IS THE
C INPUT AND INVERSE ROUTINES. IT USES THE CORRELATION MATRIX TO
C CALCULATE THE REGRESSION. IT ALSO ALLOWS THE RESIDUALS TO BE
C STORED AS A VARIABLE FOR FURTHER ANALYSIS.
C
SUBROUTINE STREGR(NV,NC,MV,MC,VMN,STD,COR,CO,DATA,NAMES)
COMMON/DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON /EXTRA/HEDR(70),NSZ
DIMENSION IV(20),NAMES(1),IVA(20),OPT(3)
DIMENSION COR(MV,MV),DATA(MC,MV),VMN(1),STD(1)
DIMENSION VAR(20),F1(19),F2(19),RC(19),SERC(19)
DIMENSION CO(1),DCOR(20,20),SDA(20),XVER(20,20)
DATA YES/3HYES/
53 RESID=0
IF(ICC.NE.2) WRITE(IDLG,51)
51 FORMAT(' ENTER OPTIONS SEPARATED BY COMMAS'/)
READ(ICC,52) OPT
52 FORMAT(5(A5,1X))
IF(OPT(1).EQ.'!') RETURN
DO 58 I=1,3
IF(OPT(I).EQ.' ') GOTO 59
IF(OPT(I).NE.'HELP') GO TO 55
WRITE(IDLG,54)
54 FORMAT(' ONLY OPTION AVAILABLE IS:'/
1' "RESID" - SAVE RESIDUALS')
GO TO 53
55 IF(OPT(I).NE.'RESID') GO TO 56
RESID=1
GO TO 58
56 WRITE(IDLG,57) OPT(I)
57 FORMAT(' OPTION "',A5,'" DOES NOT EXIST')
GO TO 53
58 CONTINUE
59 IF(RESID.NE.1) GO TO 996
IF(ICC.NE.2) WRITE(IDLG,62)
62 FORMAT(' WHICH VARIABLE ARE THE RESIDUALS TO BE STORED UNDER? ',$)
CALL ALPHA(IX,1,NI,IRET,IHELP,IERR,NAMES,MV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GOTO 59
IF(IHELP.NE.1) GO TO 65
WRITE(IDLG,64)
64 FORMAT(' ENTER THE VARIABLE NAME OR NUMBER OF THE VARIABLE'/
1' TO BE USED FOR STOREING THE RESIDUALS. THE NAME GIVEN'/
2' THE VARIABLE WILL BE "RESID"')
GO TO 59
65 IF(IX.GT.0) GO TO 63
WRITE(IDLG,66)
66 FORMAT(' *, ?, OR ALL MAY NOT BE USED HERE')
GO TO 59
63 IF(IX.LE.NV) GO TO 996
IX=NV+1
NV=IX
IF(NV.GT.MV) PAUSE
996 IF(ICC.NE.2) WRITE(IDLG,101)
101 FORMAT('0LIST THE INDEPENDENT VARIABLES?'/)
CALL ALPHA(IVA,19,NI,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 996
IF(IHELP.NE.1) GO TO 9
GO TO 996
9 K=1
DO 1 I=1,NI
IV(I)=IVA(I)
IF(IVA(I).GT.0) GO TO 1
IV(I)=K
K=K+1
1 CONTINUE
DO 2 I=1,NI-1
IF(IVA(I).LT.0) GO TO 2
DO 5 J=I+1,NI
IF(IVA(J).LT.0) GO TO 5
IF(IVA(I).NE.IVA(J)) GO TO 5
WRITE(IDLG,3)
3 FORMAT(' THE SAME INDEP. VAR. HAS BEEN LISTED TWICE')
GO TO 996
5 CONTINUE
2 CONTINUE
IF((NI+1).LE.NV) GO TO 19
WRITE(IDLG,4)
4 FORMAT(' YOU HAVE LISTED MORE VARIABLES THAN IS POSSIBLE'/
1' WITH THE DATA SET AVAILABLE')
GO TO 996
19 IF(ICC.NE.2) WRITE(IDLG,102)
102 FORMAT(' WHICH IS THE DEPENDENT VARIABLE? ',$)
NN=NI+1
CALL ALPHA(IY,1,J,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 19
IF(IHELP.EQ.1) GO TO 19
IVA(NN)=IY
IV(NN)=IVA(NN)
IF(IVA(NN).LT.0) IV(NN)=1
J=NI
IF(IVA(NN).LT.0) GOTO 18
DO 6 J=1,NI
IF(IVA(J).LT.0) GO TO 6
IF(IVA(J).NE.IVA(NN)) GO TO 6
WRITE(IDLG,7)
7 FORMAT(' THE DEPENDENT VARIABLE ALSO EXISTS AS AN INDEP. VAR.')
GO TO 996
6 CONTINUE
GO TO 18
C
C ********************************************************
C
C HERE THE DATA IS SET UP REPLACEING *,?, AND ALL WITH VALID VAR.
C
10 J=NI
14 IF(IVA(J).GT.0) GO TO 15
IV(J)=IV(J)+1
IF(IV(J).LE.NV) GO TO 16
15 J=J-1
IF(J.GE.1) GO TO 14
IF(IVA(NN).GT.0) RETURN
IV(NN)=IV(NN)+1
IF(IV(NN).GT.NV) RETURN
K=1
DO 12 I=1,NI
IF(IVA(I).GT.0) GO TO 12
IV(I)=K
K=K+1
12 CONTINUE
J=NI
GO TO 18
16 K=IV(J)
IF(J.EQ.NI) GO TO 18
DO 17 I=J+1,NI
IF(IVA(I).GT.0) GO TO 17
K=K+1
IF(K.GT.NV) GO TO 15
IV(I)=K
17 CONTINUE
18 DO 13 I=1,NI
DO 13 K=I+1,NN
IF(IV(I).EQ.IV(K)) GO TO 14
13 CONTINUE
C
C
C ***********************************************************
C
IY=IV(NN)
DO 20 I=1,NN
K=IV(I)
SDA(I)=STD(K)
VAR(I)=STD(K)*STD(K)
DO 20 J=I,NN
L=IV(J)
DCOR(I,J)=COR(K,L)
20 DCOR(J,I)=DCOR(I,J)
DO 30 J=1,NI
CC=DCOR(J,NN)*DCOR(J,NN)
IF(CC.EQ.1.0) GO TO 170
30 F2(J)=CC*(NC-2.)/(1.-CC)
C
C *********************************************************
C INVERSE BY LINEAR ROW (NOT PARTICULARLY SOPHISTICATED)
C
DO 202 I=1,NN
DO 201 J=1,NN
201 XVER(I,J)=0.0
202 XVER(I,I)=1.0
DO 210 I=1,NN
IF(((DCOR(I,I)+100.)-100.).NE.0.0) GO TO 220
IF(I.EQ.NN) GO TO 190
DO 211 J=I+1,NN
IF(((DCOR(J,I)+100.)-100.).NE.0.0) GO TO 212
211 CONTINUE
GO TO 190
212 DO 213 K=1,NN
DCOR(I,K)=DCOR(I,K)+DCOR(J,K)
213 XVER(I,K)=XVER(I,K)+XVER(J,K)
220 G=DCOR(I,I)
DO 221 J=1,NN
DCOR(I,J)=DCOR(I,J)/G
221 XVER(I,J)=XVER(I,J)/G
DO 230 L=1,NN
IF(L.EQ.I) GO TO 230
G=DCOR(L,I)
DO 231 J=1,NN
DCOR(L,J)=DCOR(L,J)-G*DCOR(I,J)
231 XVER(L,J)=XVER(L,J)-G*XVER(I,J)
230 CONTINUE
210 CONTINUE
DO 250 I=1,NN
DO 250 J=1,NN
250 DCOR(I,J)=XVER(I,J)
C
C ***********************************************************
C
CD=(DCOR(NN,NN)-1.)/DCOR(NN,NN)
CC=DSQRT(DBLE(CD))
SST=VAR(NN)*(NC-1.)
SSRG=CD*SST
SSRS=(1.-CD)*SST
RMS=SSRG/NI
EMS=SSRS/(NC-NN)
SEEST=DSQRT(DBLE(EMS))
FVAL=RMS/EMS
DO 50 J=1,NI
RC(J)=-1.0*DCOR(NN,J)/DCOR(NN,NN)
SERC(J)=SEEST*DSQRT(DBLE(DCOR(J,J)+RC(J)*DCOR(NN,J))/
1((NC-1.)*VAR(J)))
RC(J)=RC(J)*SDA(NN)/SDA(J)
50 F1(J)=RC(J)*RC(J)/(SERC(J)*SERC(J))
SEE=DSQRT(DBLE(VAR(NN)/(NC-NN)))
YINT=VMN(IV(NN))
DO 60 J=1,NI
60 YINT=YINT-RC(J)*VMN(IV(J))
IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(J),J=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,99)
99 FORMAT('0',10X,'***** MULTIPLE LINEAR REGRESSION *****')
WRITE(IOUT,90)NC,NAMES(IY),(NAMES(IV(J)),J=1,NI)
90 FORMAT('0SAMPLE SIZE ',I3/' DEPENDENT VARIABLE: ',A5/
1' INDEPENDENT VARIABLES:',6(2X,A5)/(23X,6(2X,A5)))
WRITE(IOUT,91)CD,CC
91 FORMAT('0COEFFICIENT OF DETERMINATION ',F8.5/' MULTIPLE',
1' CORR COEFF. ',F8.5)
WRITE(IOUT,98)YINT,SEEST
98 FORMAT('0ESTIMATED CONSTANT TERM',G16.8/' STANDARD ERROR OF ESTIMA
1TE ',G16.8)
WRITE(IOUT,92)
92 FORMAT(/' ANALYSIS OF VARIANCE'/' FOR THE REGRESSION'/' SOURCE OF
1 VARIATION',3X,'DF',5X,'S. SQ.',6X,'M.S.',11X,'F',8X,'PROB')
NDGN=NN-1
NDGD=NC-NN
PROB=FISHER(NDGN,NDGD,FVAL)
IDF=NN-1
WRITE(IOUT,93)IDF,SSRG,RMS,FVAL,PROB
93 FORMAT(6X,'REGRESSION',I9,G15.6,G12.6,G10.4,1X,F7.4)
IDF=NC-NN
WRITE(IOUT,94)IDF,SSRS,EMS
94 FORMAT(6X,'RESIDUALS',I10,G15.6,G12.6)
IDF=NC-1
WRITE(IOUT,95)IDF,SST
95 FORMAT(6X,'TOTAL',I14,G15.6/)
WRITE(IOUT,96)
96 FORMAT(7X,'REGRESSION',7X,'S. E. OF',3X,'F-VALUE',18X,
1'CORR.COEF.')
IDF=NC-NN
WRITE(IOUT,97)IDF,NAMES(IV(NN))
97 FORMAT(' VAR.',2X,'COEFFICIENT',5X,'REG. COEF.',2X,'DF (1,',
1I4,')',2X,'PROB',8X,'WITH ',A5)
LINES=23
DO 110 I=1,NI
NDGN=1
NDGD=IDF
PROB=FISHER(NDGN,NDGD,F1(I))
IF(IOUT.NE.21) GO TO 110
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 110
CALL PRNTHD
WRITE(IOUT,96)
WRITE(IOUT,97) IDF,NAMES(IV(NN))
LINES=5
110 WRITE(IOUT,111)NAMES(IV(I)),RC(I),SERC(I),F1(I),PROB,COR(IV(I),
1IV(NN))
111 FORMAT(1X,A5,1X,G15.7,2X,G10.4,1X,G10.4,1X,F7.4,7X,F7.4)
IF(RESID.EQ.0) GO TO 10
IF(IX.LE.NV) GO TO 300
IX=NV+1
NV=IX
300 NAMES(IX)='RESID'
120 DO 121 L=1,NV
121 CO(L)=0.0
DO 116 J=1,NC
RES=DATA(J,IY)-YINT
DO 115 K=1,NI
115 RES=RES-RC(K)*DATA(J,IV(K))
DATA(J,IX)=RES
DO 116 L=1,NV
116 CO(L)=DATA(J,L)*RES+CO(L)
VMN(IX)=0.0
STD(IX)=SQRT(SSRS/(NC-1.0))
DO 119 L=1,NV
IF(L.EQ.IX) GO TO 118
IF(STD(L)*STD(IX).EQ.0.0) GO TO 117
COR(L,IX)=(CO(L)/((NC-1.)*STD(L)*STD(IX)))
GO TO 119
117 COR(L,IX)=0.0
GO TO 119
118 COR(L,IX)=1.0
119 COR(IX,L)=COR(L,IX)
GO TO 10
170 WRITE(IDLG,171)NAMES(IV(J))
171 FORMAT('0DEPENDENT VAR LINEAR FUNCTION OF VAR ',A5/' REGRESSION IG
1NORED')
GO TO 10
190 WRITE(IDLG,191)
191 FORMAT('0DEP VAR LINEAR FUNCTION OF INDEP VARS, ALL RESIDUALS EQUA
1L ZERO')
GO TO 10
END
C *** STAT PACK ***
C SUBROUTINE TO CALCULATE PERCENTILES.
C CALLING SEQUENCE: CALL STPCNT(NV,NC,MV,MC,DATA,AV,NAMES)
C WHERE NV - IS THE NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS,
C CASES)
C MV - IS THE MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN.
C MC - IS THE MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN.
C DATA - IS STORAGE FOR DATA, DIMENSIONED FOR MAXIMUM MATRIX.
C AV - IS AN ADDITIONAL VECTOR DIMENSIONED AT LEAST NC.
C NAMES - VECTOR CONTAINING VARIABLE NAMES
C
C BINARY INSERTION SORT, THEN CALCULATE PERCENTILES. COMMANDS
C "DEC" FOR DECILES, AND "QTR" FOR QUARTILES MAY ALSO BE GIVEN.
C
SUBROUTINE STPCNT(NV,NC,MV,MC,DATA,AV,NAMES)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ
DIMENSION DATA(MC,MV),AV(1),STRG(20),CENT(20,10),IVARB(20)
DIMENSION IVOUT(20),NAMES(1)
C
C THE FOLLOWING DIMENSIONS ARE FOR THE SORT IL(16), IU(16)
C
DIMENSION IL(16),IU(16)
INTEGER BASE
NIND=5
IF(IOUT.EQ.21) NIND=10
ALL=0
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT('OWHICH VARIABLES? ',$)
CALL ALPHA(IVARB,20,NN,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 1
IF(IHELP.EQ.1) GO TO 1
DO 3 I=1,NN
IF(IVARB(I).GT.0) GO TO 3
ALL=1
NN=NV
GO TO 19
3 CONTINUE
19 IF(NN.LE.0) GO TO 1
IF(ICC.NE.2) WRITE(IDLG,6)
6 FORMAT('0TYPE IN PERCENTILES YOU WISH TO HAVE, SEPARATED',
1' BY COMMAS'/)
9 READ(ICC,7)ANS
7 FORMAT(A4)
IF(ANS.EQ.'!') RETURN
IF(ANS.EQ.'HELP') WRITE (IDLG,8)
8 FORMAT('0PERCENTILES CAN BE ENTERED INDIVIDUALLY OR THEY'/
1' CAN BE FOUND IN DECILES BY TYPING "DEC", OR QUARTILES'/
2' BY TYPING "QTR"')
IF(ANS.EQ.'HELP') GO TO 19
IF(ANS.NE.'DEC') GO TO 10
ND=9
STRG(1)=10
STRG(2)=20
STRG(3)=30
STRG(4)=40
STRG(5)=50
STRG(6)=60
STRG(7)=70
STRG(8)=80
STRG(9)=90
GO TO 16
10 IF(ANS.NE.'QTR') GO TO 11
ND=3
STRG(1)=25
STRG(2)=50
STRG(3)=75
GO TO 16
11 REREAD 12,(STRG(I),I=1,20)
12 FORMAT(20F)
DO 13 I=1,20
IF(STRG(I).EQ.0) GO TO 15
IF((STRG(I).LT.100).AND.(STRG(I).GT.0)) GO TO 13
WRITE(IDLG,14) STRG(I)
14 FORMAT('0PERCENTILE',G9.3,' NOT POSSIBLE')
GO TO 19
13 CONTINUE
15 ND=I-1
16 IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(I),I=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
LINES=2
C **********************************************************
C ACM SORT
C
DO 20 I=1,NN,NIND
MAX=I+NIND-1
IF(MAX.GT.NN) MAX=NN
NMAX=MAX-I+1
DO 21 N=I,MAX
IVAR=N
IF(ALL.EQ.0) IVAR=IVARB(N)
INDEX=(N-I)+1
IVOUT(INDEX)=IVAR
DO 70 J=1,NC
70 AV(J)=DATA(J,IVAR)
M=1
II=1
J=NC
71 IF(II.GE.J) GO TO 78
72 K=II
IJ=(J+II)/2
T=AV(IJ)
IF(AV(II).LE.T) GO TO 73
AV(IJ)=AV(II)
AV(II)=T
T=AV(IJ)
73 LL=J
IF(AV(J).GE.T) GO TO 75
AV(IJ)=AV(J)
AV(J)=T
T=AV(IJ)
IF(AV(II).LE.T) GOTO 75
AV(IJ)=AV(II)
AV(II)=T
T=AV(IJ)
GO TO 75
74 AV(LL)=AV(K)
AV(K)=TT
75 LL=LL-1
IF(AV(LL).GT.T) GO TO 75
TT=AV(LL)
76 K=K+1
IF(AV(K).LT.T) GOTO 76
IF(K.LE.LL) GOTO 74
IF((LL-II).LE.(J-K)) GO TO 77
IL(M)=II
IU(M)=LL
II=K
M=M+1
GO TO 79
77 IL(M)=K
IU(M)=J
J=LL
M=M+1
GO TO 79
78 M=M-1
IF(M.EQ.0) GO TO 90
II=IL(M)
J=IU(M)
79 IF((J-II).GE.11) GO TO 72
IF(II.EQ.1) GO TO 71
II=II-1
80 II=II+1
IF(II.EQ.J) GO TO 78
T=AV(II+1)
IF(AV(II).LE.T) GO TO 80
K=II
81 AV(K+1)=AV(K)
K=K-1
IF(T.LT.AV(K)) GO TO 81
AV(K+1)=T
GO TO 80
90 C=NC
DO 40 J=1,ND
Y=STRG(J)
X=(Y*C*.01)+.5
K=X
IF((K.LE.0).OR.(K.GE.NC)) GO TO 40
Y=K
YY=X-Y
CENT(J,INDEX)=((AV(K+1)-AV(K))*YY)+AV(K)
40 CONTINUE
21 CONTINUE
AVAR='VAR'
IF(IOUT.NE.21) GO TO 47
LINES=LINES+4
IF(LINES.LE.(LINPP-5)) GO TO 47
CALL PRNTHD
LINES=6
47 WRITE(IOUT,41)(NAMES(IVOUT(J)),J=1,NMAX)
41 FORMAT('0',20X,'***** PERCENTILES *****'/'0',26X,'VARIABLES'/
1' PERCENTILE',4X,10(1X,A5,5X))
MINUS='-----'
WRITE(IOUT,42)((MINUS,J=1,3),K=1,NMAX)
42 FORMAT(1X,10('-'),4X,10(A5,A5,A1))
DO 43 J=1,ND
Y=STRG(I)
X=(Y*C*.01)+.5
K=X
IF(IOUT.NE.21) GO TO 48
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 48
CALL PRNTHD
WRITE(IOUT,41)(NAMES(IVOUT(KJ)),KJ=1,NMAX)
WRITE(IOUT,42)((MINUS,JK=1,3),KJ=1,NMAX)
LINES=6
48 IF((K.LE.0).OR.(K.GE.NC)) GO TO 44
WRITE(IOUT,45) STRG(J),(CENT(J,K),K=1,NMAX)
45 FORMAT(1X,F6.2,8X,10(G10.4,1X))
GO TO 43
44 WRITE(IOUT,46) STRG(J)
46 FORMAT(1X,F6.2,8X,'CANNOT BE FOUND')
43 CONTINUE
LINES=LINES+1
IF((LINES.GT.LINPP).AND.(IOUT.EQ.21)) GO TO 20
WRITE(IOUT,49)
49 FORMAT(1X)
20 CONTINUE
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO OUTPUT SPECIFIED VARIABLES ON TERMINAL.
C CALLING SEQUENCE: CALL STTYPE(NV,NC,MV,MC,DATA,IV,NAMES)
C WHERE NV - IS THE NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS,
C CASES)
C MV - IS THE MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN.
C MC - IS THE MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN.
C DATA - IS STORAGE FOR DATA, DIMENSIONED FOR MAXIMUM MATRIX.
C IV - IS A VECTOR DIMENSIONED AT LEAST NV.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C USER SPECIFIES HOW MANY VARIABLES ARE TO BE OUTPUT, AND WHICH
C ONES, AND THE PROGRAM OUTPUTS THESE TO THE TERMINAL.
C
SUBROUTINE STTYPE(NV,NC,MV,MC,DATA,IV,NAMES)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON/EXTRA/HEDR(70),NSZ
DIMENSION DATA(MC,MV),IV(1),NAMES(1)
2 IF(ICC.NE.2) WRITE(IDLG,1)
1 FORMAT(' WHICH VARIABLES? ',$)
CALL ALPHA(IV,NV,N,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 2
IF(IHELP.EQ.1) GO TO 2
3 DO 5 I=1,N
IF(IV(I).LT.0) GO TO 20
5 CONTINUE
DO 6 I=1,N
IF((IV(I).GT.0).AND.(IV(I).LE.NV)) GO TO 6
WRITE(IDLG,4) IV(I)
4 FORMAT('0VARIABLE',I4,' NOT POSSIBLE'/' TRY AGAIN')
GO TO 5
6 CONTINUE
GO TO 22
20 N=NV
DO 21 I=1,NV
21 IV(I)=I
22 WRITE(IDLG,5566)(HEDR(I),I=1,NSZ)
5566 FORMAT('1',70A1)
WRITE (IDLG,7) (NAMES(IV(I)),I=1,N)
7 FORMAT(1H0,9X,'VAR'/' OBS',6(3X,A5,3X)/(4X,6(3X,A5,3X)))
DO 8 I=1,NC
8 WRITE(IDLG,9) I,(DATA(I,IV(J)),J=1,N)
9 FORMAT(1H0,I3,1X,6(1X,G10.4)/(5X,6(1X,G10.4)))
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO CALCULATE Z-SCORES.
C CALLING SEQUENCE: CALL STZSC(NV,NC,MV,MC,DATA,VMN,STD,AV,NAMES)
C WHERE NV - IS THE NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS,
C CASES)
C MV - IS THE MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN.
C MC - IS THE MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN.
C DATA - IS STORAGE FOR DATA, DIMENSIONED FOR MAXIMUM MATRIX.
C VMN - IS A VECTOR CONTAINING THE VARIABLE MEANS
C STD - IS A VECTOR CONTAINING THE VARIABLE STANDARD DEVIATIONS.
C AV - IS A VECTOR DIMENSIONED AT LEAST NV.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C SUBROUTINE OUTPUTS VALUES IN ORDER FOLLOWED BY FREQUENCIES,
C AND FINALLY THE Z SCORE. BINARY INSERTION SORT USED FOR
C SORTING VALUES IN ORDER IN VECTOR AV, ALLOWING DATA TO REMAIN
C UNCHANGED.
C
SUBROUTINE STZSC(NV,NC,MV,MC,DATA,VMN,STD,AV,NAMES)
DIMENSION DATA(MC,MV),VMN(1),STD(1),AV(1),IVAR(40),NAMES(1)
C
C THIS DIMENSION FOR SORTING ONLY
C
DIMENSION IU(16),IL(16)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ
INTEGER BASE
ALL=0
21 IF(ICC.NE.2) WRITE(IDLG,1)
1 FORMAT('0WHICH VARIABLES? ',$)
CALL ALPHA(IVAR,40,NN,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 21
IF(IHELP.EQ.1) GO TO 21
DO 3 I=1,NN
IF(IVAR(I).GT.0) GO TO 3
ALL=1
NN=NV
GO TO 25
3 CONTINUE
50 I=0
51 I=I+1
52 IF(I.GT.NN) GO TO 25
22 IF(STD(IVAR(I)).NE.0) GO TO 51
WRITE(IDLG,24) NAMES(IVAR(I))
24 FORMAT('0Z-SCORES UNDEFINED VARIABLE ',A5,' -- ST. DEV. OF ZERO')
IF(I.EQ.NN) GOTO 43
DO 42 J=I,NN-1
42 IVAR(J)=IVAR(J+1)
43 IVAR(NN)=0
NN=NN-1
GO TO 52
40 CONTINUE
C
C **************************************************************
C ACM SORT (PARTITIONING)
25 DO 45 I=1,NN
IF(ALL.EQ.1) GO TO 46
N=IVAR(I)
GO TO 47
46 IF(STD(I).EQ.0) GO TO 45
N=I
47 DO 70 J=1,NC
70 AV(J)=DATA(J,N)
M=1
II=1
J=NC
71 IF(II.GE.J) GO TO 78
72 K=II
IJ=(J+II)/2
T=AV(IJ)
IF(AV(II).LE.T) GO TO 73
AV(IJ)=AV(II)
AV(II)=T
T=AV(IJ)
73 LL=J
IF(AV(J).GE.T) GO TO 75
AV(IJ)=AV(J)
AV(J)=T
T=AV(IJ)
IF(AV(II).LE.T) GO TO 75
AV(IJ)=AV(II)
AV(II)=T
T=AV(IJ)
GO TO 75
74 AV(LL)=AV(K)
AV(K)=TT
75 LL=LL-1
IF(AV(LL).GT.T) GO TO 75
TT=AV(LL)
76 K=K+1
IF(AV(K).LT.T) GO TO 76
IF(K.LE.LL) GO TO 74
IF((LL-II).LE.(J-K)) GO TO 77
IL(M)=II
IU(M)=LL
II=K
M=M+1
GO TO 79
77 IL(M)=K
IU(M)=J
J=LL
M=M+1
GO TO 79
78 M=M-1
IF(M.EQ.0) GO TO 90
II=IL(M)
J=IU(M)
79 IF((J-II).GE.11) GO TO 72
IF(II.EQ.1) GO TO 71
II=II-1
80 II=II+1
IF(II.EQ.J) GO TO 78
T=AV(II+1)
IF(AV(II).LE.T) GO TO 80
K=II
81 AV(K+1)=AV(K)
K=K-1
IF(T.LT.AV(K)) GO TO 81
AV(K+1)=T
GO TO 80
C
C ************************************:::::::::***************
C FREQUENCY AND Z-SCORE
90 IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(J),J=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,34) NAMES(N)
34 FORMAT('0',10X,'***** Z SCORES FOR VARIABLE: ',A5,' *****')
WRITE(IOUT,30)
30 FORMAT('0',5X,'VALUE',7X,'FREQUENCY',6X,'Z-SCORE')
LINES=6
XNUM=AV(1)
NUM=1
DO 31 J=2,NC
IF(XNUM.EQ.AV(J)) GO TO 33
Z=(XNUM-VMN(N))/STD(N)
IF(IOUT.NE.21) GO TO 35
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 35
CALL PRNTHD
WRITE(IOUT,30)
LINES=5
35 WRITE(IOUT,32)XNUM,NUM,Z
32 FORMAT(1X,G15.7,4X,I4,5X,G15.7)
XNUM=AV(J)
NUM=1
GO TO 31
33 NUM=NUM+1
31 CONTINUE
Z=(XNUM-VMN(N))/STD(N)
IF(IOUT.NE.21) GO TO 36
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 36
CALL PRNTHD
WRITE(IOUT,30)
LINES=5
36 WRITE(IOUT,32)XNUM,NUM,Z
45 CONTINUE
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO OUTPUT INFORMATION ABOUT STAT PACK ON REQUEST.
C CALLING SEQUENCE: CALL STINFO
C
SUBROUTINE STINFO
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
WRITE (IDLG,1)
WRITE (IDLG,2)
WRITE (IDLG,3)
1 FORMAT('0STAT PACK IS AN INTEGRATED STATISTICAL PACKAGE,',
1' WRITTEN FOR'/' TERMINAL USE. IT ALLOWS THE USER TO ',
2'ISSUE SIMPLE COMMANDS'/' FOR DATA ANALYSIS. THE',
3' PROGRAM IS IN CONVERSATIONAL MODE AND'/' WILL',
4' PROMPT THE USER FOR DESIRED INFORMATION. IN MOST',
5' INSTANCES'/' WHEN QUESTIONS OF PROCEDURE ARISE THE ',
6' USER MAY REQUEST FURTHER'/' INFORMATION, BY SIMPLY',
7' TYPING "HELP". STANDARD FORM OF OUTPUT'/' IS TERMINAL,',
8' BUT OUTPUT MAY EASILY BE CHANNELED TO THE PRINTER'/
9' INPUT IS READILY ACCEPTED FROM TERMINAL OR DISK.')
2 FORMAT('0INPUT CONSISTS OF OBSERVATIONS, EACH CONTAINING',
1' A VALUE FOR'/' ALL OF THE VARIABLES. EACH OBSERVATION',
2' MUST BEGIN A NEW LINE.'/' THE DATA MAY BE INPUT EITHER',
3' OF TWO WAYS: 1) ONE OBSERVATION'/' PER LINE WITH VALUES',
4' SEPARATED BY COMMAS; OR 2) ACCORDING'/' TO YOUR OWN',
5' INPUT FORMAT WHICH IS ENTERED USING THE COMMAND'/' "FORM"',
6'. AFTER THE LAST OBSERVATION ENTER A ^Z (CNTRL Z).')
3 FORMAT('0TO SEE THE COMMAND LIST TYPE "HELP" AFTER "WHICH',
1' COMMAND?"'/' AND "AL" FOR THE 2 CHARACTER CODE. A ',
2'RESTRICTION ON'/' DATA INPUT IS: 20 NUMBERS',
3' MAXIMUM PER LINE UNDER'/' STANDARD FORMAT. IF A LINE',
4' REQUIRES MORE THAN 72'/' COLUMNS USE YOUR OWN INPUT',
5' FORMAT.')
END
C *** STAT PACK ***
C OUTPUT FOR HELP WHEN UNDER "WHICH COMMAND?".
C CALLING SEQUENCE: CALL STHELP(KK)
C WHERE KK - IS AN INDICATOR TELLING THE PROGRAM TO TYPE OUT
C ONLY 1 PORTION OF THE OUTPUT.
C
C WHENEVER THE STUDENT REQUIRES HELP, HE MAY TYPE IN "HELP".
C IN THE CASE THAT HE IS UNDER "WHICH COMMAND?" THIS PORTION IS
C BROUGHT IN. IN ADDITION ONLY CERTAIN PARTS NEED BE TYPED
C OUT, IF "DC", "ES", "GR", ETC. ARE TYPED FOR "WHICH COMMAND?".
C KK REGULATES WHICH OF THESE IS TYPED.
C
SUBROUTINE STHELP(KK)
DIMENSION ICODE(6)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
IF(KK.NE.1) GO TO 1
IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT(' COMMANDS ARE BROKEN INTO 5 GROUPS:'//
1' "DC" - DATA CONTROL'/
1' "ST" - STATISTICS'/
1' "GR" - GRAPHS'/
1' "IA" - ITEM ANALYSIS'/
1' "PC" - PROGRAM CONTROL'//
1' "AL" - COMPLETE COMMAND CODE LIST'//
1' WHICH SET (TYPE IN THE 2 CHARACTER CODE)? ',$)
READ (ICC,3) ICODE
IF(ICODE(1).EQ.'!') RETURN
3 FORMAT(6(A2,1X))
1 WRITE(IDLG,4)
4 FORMAT(//'0COMMANDS AVAILABLE')
C
C **********************************************************
C DATA CONTROL
IF(KK.EQ.2) GO TO 105
IF(KK.NE.1) GO TO 6
DO 31 I=1,6
IF(ICODE(I).EQ.'AL') GO TO 105
IF(ICODE(I).EQ.'DC') GO TO 105
31 CONTINUE
GO TO 6
105 WRITE (IDLG,5)
5 FORMAT(/' "DATA" - DATA INPUT BY TTY'/
1' "FETCH" - READ DATA FROM DISK'/
1' "FORM" - ENTER SPECIAL INPUT FORMAT'/
1' "MANIP" - MANIPULATE DATA IN CORE (INCLUDES APPENDING)'/
1' "TRANS" - DATA TRANSFORMATIONS'/
1' "STORE" - STORE DATA ON DISK'/
1' "PRINT" - PRINT SELECTED VARIABLES ON LINE PRINTER'/
1' "TYPE" - TYPE OUT SELECTED VARIABLES ON TTY'/
1' "ACBNK" - ACCESS A STORED DATA BANK'/
1' "MABNK" - CREATE A BANK FROM DATA IN STP'/
1' "SORT" - SORT DATA INTO ASCENDING ORDER'/
1' "MTA/I" - READ DATA FROM MAG TAPE')
C
C ***********************************************************
C ELEMENTRY STATISTICS
6 IF(KK.EQ.3) GO TO 107
IF(KK.NE.1) GO TO 8
DO 32 I=1,6
IF(ICODE(I).EQ.'AL') GO TO 107
IF(ICODE(I).EQ.'ST') GO TO 107
32 CONTINUE
GO TO 8
107 WRITE(IDLG,7)
7 FORMAT(/' "DESC" - DESCRIPTION OF DATA - MEANS, ST. DEV., VAR.'/
1' "BASIC" - MEDIANS, MODES, AND RANGES'/
1' "ERANA" - STD. ERROR OF MEAN, COEFF. OF SKEWNESS,',
2' COEFF. OF VARIATION'/
1' "ESTAT" - "DESC", "BASIC", AND "ERANA"'/
1' "ZSCOR" - Z SCORES'/
1' "KOLM" - 1 OR 2 SAMPLE KOLMOGOROV-SMIRNOV TESTS'/
1' "CORR" - CORRELATION MATRIX')
WRITE(IDLG,13)
13 FORMAT(
1' "PCORR" - PARTIAL CORRELATIONS'/
1' "KENDL" - KENDALL TAU CORRELATIONS'/
1' "SRANK" - SPEARMAN RANK CORRELATION'/
1' "PTBIS" - POINT BISERIAL CORRELATION'/
1' "TTEST" - T TEST (SIGNIFICANCE BETWEEN MEANS)'/
1' "CORRT" - CORRELATED T TESTS'/
1' "MANN" - MANN WHITNEY U TEST'/
1' "WILCX" - WILCOXEN RANK'/
1' "ANOV1" - SINGLE FACTOR ANALYSIS OF VARIANCE'/
1' "ANOV2" - 2-WAY ANALYSIS OF VARIANCE'/
1' "1WAYR" - 1-WAY ANALYSIS OF VARIANCE W/ REPEATED MEASURES'/
1' "ANOC1" - 1-WAY ANALYSIS OF COVARIANCE'/
1' "REGR" - REGRESSION'/
1' "STEPR" - STEPWISE REGRESSION'/
1' "FACTO" - FACTOR ANALYSIS'/
1' "PROB" - PROBABILITY ASSOC. WITH T, F, OR CHI SQUARE'/
1' "CHISQ" - CHI SQUARE'/
1' "CVSMT" - EXPONENTIAL CURVE SMOOTHING MODEL')
C
C ***************************************************************
C GRAPHS
8 IF(KK.EQ.4) GO TO 109
IF(KK.NE.1) GO TO 10
DO 33 I=1,6
IF(ICODE(I).EQ.'AL') GO TO 109
IF(ICODE(I).EQ.'GR') GO TO 109
33 CONTINUE
GO TO 10
109 WRITE(IDLG,9)
9 FORMAT(/' "PLOT" - SCATTER PLOT'/
1' "HIST" - HISTOGRAM'/
1' "BARGR" - BAR GRAPH')
C
C ************************************************************
C ITEM ANALYSIS
10 IF(KK.EQ.5) GO TO 111
IF(KK.NE.1) GO TO 12
DO 34 I=1,6
IF(ICODE(I).EQ.'AL') GO TO 111
IF(ICODE(I).EQ.'IA') GO TO 111
34 CONTINUE
GO TO 12
111 WRITE(IDLG,11)
11 FORMAT(/' "FREQ" - FREQUENCY'/
1' "XTAB" - CROSS TAB'/
1' "XTAB*" - CROSS TAB (TABLE FORM - ONLY IF "ASSIG" IS USED)'/
1' "PCENT" - PERCENTILES')
C
C ***************************************************************
C PROGRAM CONTROL
12 IF(KK.EQ.6) GO TO 115
IF(KK.NE.1) GO TO 16
DO 35 I=1,6
IF(ICODE(I).EQ.'AL') GO TO 115
IF(ICODE(I).EQ.'PC') GO TO 115
35 CONTINUE
GO TO 16
115 WRITE (IDLG,15)
15 FORMAT(/' "STOP" - RESTART'/
1' "HELP" - FOR COMMANDS'/
1' "FINI" - END RUN'/
1' "INFO" - GENERAL INFORMATION'/
1' "ASSIG" - ASSIGN OUTPUT TO LINE PRINTER'/
1' "DEASS" - REINITIALIZE OUTPUT TO TERMINAL'/
1' "COPYS" - INDICATE MORE THAN 1 PRINTER COPY("ASSIG" AND '
2,'"PRINT")'/
1' "TITLE" - LABEL OUTPUT WITH IDENTIFICATION'/
1' "NAME" - GIVE NAMES TO VARIABLES'/
1' "MAKE" - MAKE A TEXT TO BE INSERTED INTO LINE PRINTER OUTPUT')
16 RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO OUTPUT SELECTED VARIABLES TO THE LPT.
C CALLING SEQUENCE: CALL STPRNT(NV,NC,MV,MC,DATA,IV,NAMES)
C WHERE NV - IS THE NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS,
C CASES)
C MV - IS THE MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN.
C MC - IS THE MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN.
C DATA - IS STORAGE FOR DATA, DIMENSIONED FOR MAXIMUM MATRIX.
C IV - IS A VECTOR DIMENSIONED FOR AT LEAST NV.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C USER INDICATES HOW MANY VARIABLES TO BE OUTPUT AND WHICH
C ONES. A TEMPARARY FILE IS CREATED AND OUTPUT ON THE LINE
C PRINTER BY USE OF THE CALL PRINTS.
C
C
C
C AAR ===============================================================
C AAR
C AAR
C AAR *** AAR UPDATES MADE TO RUN ON DEC-20 ***
C AAR CHANGES: INSTEAD OF WRITING OUTPUT GENERATED BY THE
C AAR 'PRINT' COMMAND TO THE FILE "PRINT.DAT" AND
C AAR THEN USING ROUTINE "PRINTS" TO QUEUE IT,
C AAR WRITE DATA GENERATED BY THE PRINT COMMAND TO
C AAR THE OUTPUT FILE "S%%%%.DAT" WHICH WAS OPENED
C AAR IN THE MAIN PROGRAM (ORIGINALLY,TO HANDLE OUTPUT
C AAR IF AN "ASSIGN" COMMAND WAS ISSUED). CHANGES
C AAR IN THE MAIN PGM. HAVE BEEN MADE TO PRINT THIS
C AAR FILE ON NORMAL TERMINATION BY USING THE
C AAR 'LIST' OPTION OF THE CLOSE COMMAND.
C AAR REDIRECTION OF THE 'PRINT' CMMND. OUTPUT
C AAR IS ACCOMPLISHED BY CHANGING THE DEVICE #
C AAR FOR OUTPUT TO 21, WHICH REPRESENTS THE
C AAR "S%%%%.DAT" FILE. IT WAS NECESSARY TO
C AAR INCLUDE THE COMMON AREA "/HDR/" FROM THE
C AAR MAIN PROGRAM TO KEEP TRACK OF THE # OF PAGES
C AAR IN THE "S%%%%.DAT" FILE.
C AAR
C AAR
C AAR NOTE: AAR CHANGES ARE SURROUNDED BY COMMENTS WITH "AAR"
C AAR IN THE LEFT MARGIN. ORIGINAL LINES WHICH HAVE BEEN
C AAR COMMENTED OUT HAVE "WMU" IN THE LEFT MARGIN.
C AAR
C AAR
C AAR ===============================================================
C
C
C
SUBROUTINE STPRNT(NV,NC,MV,MC,DATA,IV,NAMES)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ
C AAR
C AAR ----
C AAR !
COMMON/HDR/DATRN(2),NPAGE,PROG
C AAR !
C AAR ----
C AAR
DIMENSION DATA(MC,MV),IV(1),NAMES(1)
C WMU
C WMU
C WMU OPEN(UNIT=IDSK,FILE='PRINT.DAT',DEVICE='DSK',ACCESS='SEQOUT')
C WMU NPAGE=1
C WMU
C WMU
C
C AAR
C AAR *** AAR CHANGES ***
C AAR USE PAGE COUNTER FROM MAIN PGM, AND ALSO CHANGE
C AAR OUTPUT UNIT TO THE S%%%%.DAT FILE (UNIT 21).
C AAR
C AAR ----
C AAR !
NPAGE=NPAGE+1
IDSK=21
C AAR !
C AAR ----
C AAR
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT(' WHICH VARIABLES? ',$)
CALL ALPHA(IV,NV,N,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GOTO 1
IF(IHELP.EQ.1) GO TO 1
DO 3 I=1,N
IF(IV(I).LT.0) GO TO 20
3 CONTINUE
GO TO 22
20 N=NV
DO 21 I=1,NV
21 IV(I)=I
22 LINPO=(N+7)/8+1
WRITE(IDSK,30) HEDR,NPAGE
30 FORMAT('1STP-V5 WMU',20X,70A1,20X,'PAGE ',I5/)
LINES=4+LINPO
WRITE(IDSK,7)(NAMES(IV(I)),I=1,N)
7 FORMAT('0',21X,'VAR'/' OBS',4X,8(4X,A5,6X)/(11X,8(4X,A5,6X)))
DO 8 I=1,NC
LINES=LINES+LINPO
IF(LINES.LE.LINPP) GO TO 12
NPAGE=NPAGE+1
WRITE(IDSK,30) HEDR,NPAGE
WRITE(IDSK,7)(NAMES(IV(J)),J=1,N)
LINES=4+LINPO*2
12 DO 8 J=1,N,8
NEND=J+7
IF(NEND.GT.N) NEND=N
IF(J.EQ.1) WRITE(IDSK,18) I,(DATA(I,IV(K)),K=J,NEND)
18 FORMAT('0',I6,2X,8G15.7)
IF(J.NE.1) WRITE(IDSK,19) (DATA(I,IV(K)),K=J,NEND)
19 FORMAT(9X,8G15.7)
8 CONTINUE
9 FORMAT('0',I6,2X,8G15.7/(9X,8G15.7))
11 CONTINUE
C WMU
C WMU CALL RELEAS (IDSK)
C WMU NPAGE=(NPAGE+1)*ICOPS+2
C WMU CALL PRINTS('PRINT.DAT',2,1,ICOPS,NPAGE)
C WMU
C WMU 23 RETURN
C WMU
C WMU
C
C AAR
C AAR *** AAR CHANGE ***
C AAR RETURN IDSK TO ITS ORIGINAL VALUE, 1 AND RETURN.
C AAR
C AAR ----
C AAR !
23 IDSK=1
RETURN
C AAR !
C AAR ----
C AAR
END